summaryrefslogtreecommitdiff
path: root/ortho/mcode/ortho_code-exprs.adb
diff options
context:
space:
mode:
Diffstat (limited to 'ortho/mcode/ortho_code-exprs.adb')
-rw-r--r--ortho/mcode/ortho_code-exprs.adb1656
1 files changed, 1656 insertions, 0 deletions
diff --git a/ortho/mcode/ortho_code-exprs.adb b/ortho/mcode/ortho_code-exprs.adb
new file mode 100644
index 0000000..b8da44c
--- /dev/null
+++ b/ortho/mcode/ortho_code-exprs.adb
@@ -0,0 +1,1656 @@
+-- Mcode back-end for ortho - Expressions and control handling.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO;
+with Ada.Unchecked_Deallocation;
+with GNAT.Table;
+with Ortho_Code.Types; use Ortho_Code.Types;
+with Ortho_Code.Consts; use Ortho_Code.Consts;
+with Ortho_Code.Decls; use Ortho_Code.Decls;
+with Ortho_Code.Debug; use Ortho_Code.Debug;
+with Ortho_Code.Abi;
+with Ortho_Code.Disps;
+with Ortho_Code.Opts;
+with Ortho_Code.Flags;
+
+package body Ortho_Code.Exprs is
+
+ type Enode_Pad is mod 256;
+
+ type Enode_Common is record
+ Kind : OE_Kind; -- about 1 byte (6 bits)
+ Reg : O_Reg; -- 1 byte
+ Mode : Mode_Type; -- 4 bits
+ Ref : Boolean;
+ Flag1 : Boolean;
+ Flag2 : Boolean;
+ Flag3 : Boolean;
+ Pad : Enode_Pad;
+ Arg1 : O_Enode;
+ Arg2 : O_Enode;
+ Info : Int32;
+ end record;
+ pragma Pack (Enode_Common);
+ for Enode_Common'Size use 4*32;
+ for Enode_Common'Alignment use 4;
+
+ package Enodes is new GNAT.Table
+ (Table_Component_Type => Enode_Common,
+ Table_Index_Type => O_Enode,
+ Table_Low_Bound => 2,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ function Get_Expr_Kind (Enode : O_Enode) return OE_Kind is
+ begin
+ return Enodes.Table (Enode).Kind;
+ end Get_Expr_Kind;
+
+ function Get_Expr_Mode (Enode : O_Enode) return Mode_Type is
+ begin
+ return Enodes.Table (Enode).Mode;
+ end Get_Expr_Mode;
+
+ function Get_Enode_Type (Enode : O_Enode) return O_Tnode is
+ begin
+ return O_Tnode (Enodes.Table (Enode).Info);
+ end Get_Enode_Type;
+
+ function Get_Expr_Reg (Enode : O_Enode) return O_Reg is
+ begin
+ return Enodes.Table (Enode).Reg;
+ end Get_Expr_Reg;
+
+ procedure Set_Expr_Reg (Enode : O_Enode; Reg : O_Reg) is
+ begin
+ Enodes.Table (Enode).Reg := Reg;
+ end Set_Expr_Reg;
+
+ function Get_Expr_Operand (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg1;
+ end Get_Expr_Operand;
+
+ procedure Set_Expr_Operand (Enode : O_Enode; Val : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg1 := Val;
+ end Set_Expr_Operand;
+
+ function Get_Expr_Left (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg1;
+ end Get_Expr_Left;
+
+ function Get_Expr_Right (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg2;
+ end Get_Expr_Right;
+
+ procedure Set_Expr_Left (Enode : O_Enode; Val : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg1 := Val;
+ end Set_Expr_Left;
+
+ procedure Set_Expr_Right (Enode : O_Enode; Val : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg2 := Val;
+ end Set_Expr_Right;
+
+ function Get_Expr_Low (Cst : O_Enode) return Uns32 is
+ begin
+ return To_Uns32 (Int32 (Enodes.Table (Cst).Arg1));
+ end Get_Expr_Low;
+
+ function Get_Expr_High (Cst : O_Enode) return Uns32 is
+ begin
+ return To_Uns32 (Int32 (Enodes.Table (Cst).Arg2));
+ end Get_Expr_High;
+
+ function Get_Assign_Target (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg2;
+ end Get_Assign_Target;
+
+ procedure Set_Assign_Target (Enode : O_Enode; Targ : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg2 := Targ;
+ end Set_Assign_Target;
+
+ function Get_Expr_Lit (Lit : O_Enode) return O_Cnode is
+ begin
+ return O_Cnode (Enodes.Table (Lit).Arg1);
+ end Get_Expr_Lit;
+
+ function Get_Conv_Type (Enode : O_Enode) return O_Tnode is
+ begin
+ return O_Tnode (Enodes.Table (Enode).Arg2);
+ end Get_Conv_Type;
+
+ -- Leave node corresponding to the entry.
+ function Get_Entry_Leave (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg1;
+ end Get_Entry_Leave;
+
+ procedure Set_Entry_Leave (Enode : O_Enode; Leave : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg1 := Leave;
+ end Set_Entry_Leave;
+
+ function Get_Jump_Label (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg2;
+ end Get_Jump_Label;
+
+ procedure Set_Jump_Label (Enode : O_Enode; Label : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg2 := Label;
+ end Set_Jump_Label;
+
+ function Get_Addr_Object (Enode : O_Enode) return O_Dnode is
+ begin
+ return O_Dnode (Enodes.Table (Enode).Arg1);
+ end Get_Addr_Object;
+
+ function Get_Addrl_Frame (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg2;
+ end Get_Addrl_Frame;
+
+ procedure Set_Addrl_Frame (Enode : O_Enode; Frame : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg2 := Frame;
+ end Set_Addrl_Frame;
+
+ function Get_Call_Subprg (Enode : O_Enode) return O_Dnode is
+ begin
+ return O_Dnode (Enodes.Table (Enode).Arg1);
+ end Get_Call_Subprg;
+
+ function Get_Arg_Link (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg2;
+ end Get_Arg_Link;
+
+ function Get_Block_Decls (Blk : O_Enode) return O_Dnode is
+ begin
+ return O_Dnode (Enodes.Table (Blk).Arg2);
+ end Get_Block_Decls;
+
+ function Get_Block_Parent (Blk : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Blk).Arg1;
+ end Get_Block_Parent;
+
+ function Get_Block_Has_Alloca (Blk : O_Enode) return Boolean is
+ begin
+ return Enodes.Table (Blk).Flag1;
+ end Get_Block_Has_Alloca;
+
+ procedure Set_Block_Has_Alloca (Blk : O_Enode; Flag : Boolean) is
+ begin
+ Enodes.Table (Blk).Flag1 := Flag;
+ end Set_Block_Has_Alloca;
+
+ function Get_End_Beg (Blk : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Blk).Arg1;
+ end Get_End_Beg;
+
+ function Get_Label_Info (Label : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Label).Arg2);
+ end Get_Label_Info;
+
+ procedure Set_Label_Info (Label : O_Enode; Info : Int32) is
+ begin
+ Enodes.Table (Label).Arg2 := O_Enode (Info);
+ end Set_Label_Info;
+
+ function Get_Label_Block (Label : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Label).Arg1;
+ end Get_Label_Block;
+
+ function Get_Spill_Info (Spill : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Spill).Arg2);
+ end Get_Spill_Info;
+
+ procedure Set_Spill_Info (Spill : O_Enode; Info : Int32) is
+ begin
+ Enodes.Table (Spill).Arg2 := O_Enode (Info);
+ end Set_Spill_Info;
+
+ -- Get the statement link.
+ function Get_Stmt_Link (Stmt : O_Enode) return O_Enode is
+ begin
+ return O_Enode (Enodes.Table (Stmt).Info);
+ end Get_Stmt_Link;
+
+ procedure Set_Stmt_Link (Stmt : O_Enode; Next : O_Enode) is
+ begin
+ Enodes.Table (Stmt).Info := Int32 (Next);
+ end Set_Stmt_Link;
+
+ function Get_BB_Next (Stmt : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Stmt).Arg1;
+ end Get_BB_Next;
+
+ procedure Set_BB_Next (Stmt : O_Enode; Next : O_Enode) is
+ begin
+ Enodes.Table (Stmt).Arg1 := Next;
+ end Set_BB_Next;
+
+ function Get_BB_Number (Stmt : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Stmt).Arg2);
+ end Get_BB_Number;
+
+ procedure Set_Case_Branch (C : O_Enode; Branch : O_Enode) is
+ begin
+ Enodes.Table (C).Arg2 := Branch;
+ end Set_Case_Branch;
+
+ procedure Set_Case_Branch_Choice (Branch : O_Enode; Choice : O_Enode) is
+ begin
+ Enodes.Table (Branch).Arg1 := Choice;
+ end Set_Case_Branch_Choice;
+
+ function Get_Case_Branch_Choice (Branch : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Branch).Arg1;
+ end Get_Case_Branch_Choice;
+
+ procedure Set_Case_Choice_Link (Choice : O_Enode; N_Choice : O_Enode) is
+ begin
+ Enodes.Table (Choice).Info := Int32 (N_Choice);
+ end Set_Case_Choice_Link;
+
+ function Get_Case_Choice_Link (Choice : O_Enode) return O_Enode is
+ begin
+ return O_Enode (Enodes.Table (Choice).Info);
+ end Get_Case_Choice_Link;
+
+ function Get_Ref_Field (Ref : O_Enode) return O_Fnode is
+ begin
+ return O_Fnode (Enodes.Table (Ref).Arg2);
+ end Get_Ref_Field;
+
+ function Get_Ref_Index (Ref : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Ref).Arg2;
+ end Get_Ref_Index;
+
+ function Get_Expr_Line_Number (Stmt : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Stmt).Arg1);
+ end Get_Expr_Line_Number;
+
+ function Get_Intrinsic_Operation (Stmt : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Stmt).Arg1);
+ end Get_Intrinsic_Operation;
+
+ Last_Stmt : O_Enode := O_Enode_Null;
+
+ procedure Link_Stmt (Stmt : O_Enode) is
+ begin
+ if Last_Stmt = O_Enode_Null then
+ raise Program_Error;
+ end if;
+ Set_Stmt_Link (Last_Stmt, Stmt);
+ Last_Stmt := Stmt;
+ end Link_Stmt;
+
+ function New_Enode (Kind : OE_Kind;
+ Rtype : O_Tnode;
+ Arg1 : O_Enode;
+ Arg2 : O_Enode) return O_Enode
+ is
+ Mode : Mode_Type;
+ begin
+ Mode := Get_Type_Mode (Rtype);
+ Enodes.Append (Enode_Common'(Kind => Kind,
+ Reg => 0,
+ Mode => Mode,
+ Ref => False,
+ Flag1 => False,
+ Flag2 => False,
+ Flag3 => False,
+ Pad => 0,
+ Arg1 => Arg1,
+ Arg2 => Arg2,
+ Info => Int32 (Rtype)));
+ return Enodes.Last;
+ end New_Enode;
+
+ function New_Enode (Kind : OE_Kind;
+ Mode : Mode_Type;
+ Rtype : O_Tnode;
+ Arg1 : O_Enode;
+ Arg2 : O_Enode) return O_Enode
+ is
+ begin
+ Enodes.Append (Enode_Common'(Kind => Kind,
+ Reg => 0,
+ Mode => Mode,
+ Ref => False,
+ Flag1 => False,
+ Flag2 => False,
+ Flag3 => False,
+ Pad => 0,
+ Arg1 => Arg1,
+ Arg2 => Arg2,
+ Info => Int32 (Rtype)));
+ return Enodes.Last;
+ end New_Enode;
+
+ procedure New_Enode_Stmt (Kind : OE_Kind; Arg1 : O_Enode; Arg2 : O_Enode)
+ is
+ begin
+ Enodes.Append (Enode_Common'(Kind => Kind,
+ Reg => 0,
+ Mode => Mode_Nil,
+ Ref => False,
+ Flag1 => False,
+ Flag2 => False,
+ Flag3 => False,
+ Pad => 0,
+ Arg1 => Arg1,
+ Arg2 => Arg2,
+ Info => 0));
+ Link_Stmt (Enodes.Last);
+ end New_Enode_Stmt;
+
+ procedure New_Enode_Stmt
+ (Kind : OE_Kind; Mode : Mode_Type; Arg1 : O_Enode; Arg2 : O_Enode)
+ is
+ begin
+ Enodes.Append (Enode_Common'(Kind => Kind,
+ Reg => 0,
+ Mode => Mode,
+ Ref => False,
+ Flag1 => False,
+ Flag2 => False,
+ Flag3 => False,
+ Pad => 0,
+ Arg1 => Arg1,
+ Arg2 => Arg2,
+ Info => 0));
+ Link_Stmt (Enodes.Last);
+ end New_Enode_Stmt;
+
+ Bb_Num : Int32 := 0;
+ Last_Bb : O_Enode := O_Enode_Null;
+
+ procedure Create_BB is
+ begin
+ New_Enode_Stmt (OE_BB, Mode_Nil, O_Enode_Null, O_Enode (Bb_Num));
+ if Last_Bb /= O_Enode_Null then
+ Set_BB_Next (Last_Bb, Enodes.Last);
+ end if;
+ Last_Bb := Enodes.Last;
+ Bb_Num := Bb_Num + 1;
+ end Create_BB;
+
+ procedure Start_BB is
+ begin
+ if Flags.Flag_Opt_BB then
+ Create_BB;
+ end if;
+ end Start_BB;
+ pragma Inline (Start_BB);
+
+ procedure Check_Ref (E : O_Enode) is
+ begin
+ if Enodes.Table (E).Ref then
+ raise Syntax_Error;
+ end if;
+ Enodes.Table (E).Ref := True;
+ end Check_Ref;
+
+ procedure Check_Ref (E : O_Lnode) is
+ begin
+ Check_Ref (O_Enode (E));
+ end Check_Ref;
+
+ procedure Check_Value_Type (Val : O_Enode; Vtype : O_Tnode) is
+ begin
+ if Get_Enode_Type (Val) /= Vtype then
+ raise Syntax_Error;
+ end if;
+ end Check_Value_Type;
+
+ function New_Const_U32 (Val : Uns32; Vtype : O_Tnode) return O_Enode
+ is
+ begin
+ return New_Enode (OE_Const, Vtype,
+ O_Enode (To_Int32 (Val)), O_Enode_Null);
+ end New_Const_U32;
+
+ Last_Decl : O_Dnode := 2;
+ Cur_Block : O_Enode := O_Enode_Null;
+
+ procedure Start_Declare_Stmt
+ is
+ Res : O_Enode;
+ begin
+ New_Enode_Stmt (OE_Beg, Cur_Block, O_Enode_Null);
+ Res := Enodes.Last;
+ Enodes.Table (Res).Arg2 := O_Enode
+ (Ortho_Code.Decls.Start_Declare_Stmt);
+ Cur_Block := Res;
+ end Start_Declare_Stmt;
+
+ function New_Stack (Rtype : O_Tnode) return O_Enode is
+ begin
+ return New_Enode (OE_Get_Stack, Rtype, O_Enode_Null, O_Enode_Null);
+ end New_Stack;
+
+ procedure New_Stack_Restore (Blk : O_Enode)
+ is
+ Save_Asgn : O_Enode;
+ Save_Var : O_Dnode;
+ begin
+ Save_Asgn := Get_Stmt_Link (Blk);
+ Save_Var := Get_Addr_Object (Get_Assign_Target (Save_Asgn));
+ New_Enode_Stmt (OE_Set_Stack, New_Value (New_Obj (Save_Var)),
+ O_Enode_Null);
+ end New_Stack_Restore;
+
+ procedure Finish_Declare_Stmt
+ is
+ Parent : O_Dnode;
+ begin
+ if Get_Block_Has_Alloca (Cur_Block) then
+ New_Stack_Restore (Cur_Block);
+ end if;
+ New_Enode_Stmt (OE_End, Cur_Block, O_Enode_Null);
+ Cur_Block := Get_Block_Parent (Cur_Block);
+ if Cur_Block = O_Enode_Null then
+ Parent := O_Dnode_Null;
+ else
+ Parent := Get_Block_Decls (Cur_Block);
+ end if;
+ Ortho_Code.Decls.Finish_Declare_Stmt (Parent);
+ end Finish_Declare_Stmt;
+
+ function New_Label return O_Enode is
+ begin
+ return New_Enode (OE_Label, Mode_Nil, O_Tnode_Null,
+ Cur_Block, O_Enode_Null);
+ end New_Label;
+
+ procedure Start_Subprogram_Body (Func : O_Dnode)
+ is
+ Start : O_Enode;
+ D_Body : O_Dnode;
+ Data : Subprogram_Data_Acc;
+ begin
+ if Cur_Subprg = null then
+ Abi.Start_Body (Func);
+ end if;
+
+ Start := New_Enode (OE_Entry, Mode_Nil, O_Tnode_Null,
+ Last_Stmt, O_Enode_Null);
+ D_Body := Decls.Start_Subprogram_Body (Func, Start);
+
+ -- Create the corresponding decl.
+ Enodes.Table (Start).Arg2 := O_Enode (D_Body);
+
+ -- Create the data record.
+ Data := new Subprogram_Data'(Parent => Cur_Subprg,
+ First_Child => null,
+ Last_Child => null,
+ Brother => null,
+ Depth => Get_Decl_Depth (Func),
+ D_Decl => Func,
+ E_Entry => Start,
+ D_Body => D_Body,
+ Exit_Label => O_Enode_Null,
+ Last_Stmt => O_Enode_Null,
+ Stack_Max => 0);
+
+ if not Flag_Debug_Hli then
+ Data.Exit_Label := New_Label;
+ end if;
+
+ -- Link the record.
+ if Cur_Subprg = null then
+ -- A top-level subprogram.
+ if First_Subprg = null then
+ First_Subprg := Data;
+ else
+ Last_Subprg.Brother := Data;
+ end if;
+ Last_Subprg := Data;
+ else
+ -- A nested subprogram.
+ if Cur_Subprg.First_Child = null then
+ Cur_Subprg.First_Child := Data;
+ else
+ Cur_Subprg.Last_Child.Brother := Data;
+ end if;
+ Cur_Subprg.Last_Child := Data;
+
+ -- Also save last_stmt.
+ Cur_Subprg.Last_Stmt := Last_Stmt;
+ end if;
+
+ Cur_Subprg := Data;
+ Last_Stmt := Start;
+
+ Start_Declare_Stmt;
+
+ -- Create a basic block for the beginning of the subprogram.
+ Start_BB;
+
+ -- Disp declarations.
+ if Cur_Subprg.Parent = null then
+ if Ortho_Code.Debug.Flag_Debug_Body
+ or Ortho_Code.Debug.Flag_Debug_Code
+ then
+ while Last_Decl <= D_Body loop
+ case Get_Decl_Kind (Last_Decl) is
+ when OD_Block =>
+ -- Skip blocks.
+ Disp_Decl (1, Last_Decl);
+ Last_Decl := Get_Block_Last (Last_Decl) + 1;
+ when others =>
+ Disp_Decl (1, Last_Decl);
+ Last_Decl := Last_Decl + 1;
+ end case;
+ end loop;
+ end if;
+ end if;
+ end Start_Subprogram_Body;
+
+ procedure Finish_Subprogram_Body
+ is
+ Parent : Subprogram_Data_Acc;
+ begin
+ Finish_Declare_Stmt;
+
+ -- Create a new basic block for the epilog.
+ Start_BB;
+
+ if not Flag_Debug_Hli then
+ Link_Stmt (Cur_Subprg.Exit_Label);
+ end if;
+
+ New_Enode_Stmt (OE_Leave, O_Enode_Null, O_Enode_Null);
+
+ -- Save last statement.
+ Cur_Subprg.Last_Stmt := Enodes.Last;
+ -- Set Leave of Entry.
+ Set_Entry_Leave (Cur_Subprg.E_Entry, Enodes.Last);
+
+ Decls.Finish_Subprogram_Body;
+
+ Parent := Cur_Subprg.Parent;
+
+ if Flags.Flag_Optimize then
+ Opts.Optimize_Subprg (Cur_Subprg);
+ end if;
+
+ if Parent = null then
+ -- This is a top-level subprogram.
+ if Ortho_Code.Debug.Flag_Disp_Code then
+ Disps.Disp_Subprg (Cur_Subprg);
+ end if;
+ if Ortho_Code.Debug.Flag_Dump_Code then
+ Disp_Subprg_Body (1, Cur_Subprg.E_Entry);
+ end if;
+ if not Ortho_Code.Debug.Flag_Debug_Dump then
+ Abi.Finish_Body (Cur_Subprg);
+ end if;
+ end if;
+
+ -- Restore Cur_Subprg.
+ Cur_Subprg := Parent;
+
+ -- Restore Last_Stmt.
+ if Cur_Subprg = null then
+ Last_Stmt := O_Enode_Null;
+ else
+ Last_Stmt := Cur_Subprg.Last_Stmt;
+ end if;
+ end Finish_Subprogram_Body;
+
+ function Get_Inner_Alloca (Label : O_Enode) return O_Enode
+ is
+ Res : O_Enode := O_Enode_Null;
+ Blk : O_Enode;
+ Last_Blk : O_Enode := Get_Label_Block (Label);
+ begin
+ Blk := Cur_Block;
+ while Blk /= Last_Blk loop
+ if Get_Block_Has_Alloca (Blk) then
+ Res := Blk;
+ end if;
+ Blk := Get_Block_Parent (Blk);
+ end loop;
+ return Res;
+ end Get_Inner_Alloca;
+
+ procedure Emit_Jmp (Code : OE_Kind; Expr : O_Enode; Label : O_Enode)
+ is
+ begin
+ -- Discard jump after jump.
+ if Code /= OE_Jump or else Get_Expr_Kind (Last_Stmt) /= OE_Jump then
+ New_Enode_Stmt (Code, Expr, Label);
+ end if;
+ end Emit_Jmp;
+
+
+ -- If there is stack allocated memory to be freed, free it.
+ -- Then jump to LABEL.
+ procedure New_Allocb_Jump (Label : O_Enode)
+ is
+ Inner_Alloca : O_Enode;
+ begin
+ Inner_Alloca := Get_Inner_Alloca (Label);
+ if Inner_Alloca /= O_Enode_Null then
+ New_Stack_Restore (Inner_Alloca);
+ end if;
+ Emit_Jmp (OE_Jump, O_Enode_Null, Label);
+ end New_Allocb_Jump;
+
+ function New_Lit (Lit : O_Cnode) return O_Enode
+ is
+ L_Type : O_Tnode;
+ H, L : Uns32;
+ begin
+ L_Type := Get_Const_Type (Lit);
+ if Flag_Debug_Hli then
+ return New_Enode (OE_Lit, L_Type, O_Enode (Lit), O_Enode_Null);
+ else
+ case Get_Const_Kind (Lit) is
+ when OC_Signed
+ | OC_Unsigned
+ | OC_Float
+ | OC_Null
+ | OC_Lit =>
+ Get_Const_Bytes (Lit, H, L);
+ return New_Enode
+ (OE_Const, L_Type,
+ O_Enode (To_Int32 (L)), O_Enode (To_Int32 (H)));
+ when OC_Address
+ | OC_Subprg_Address =>
+ return New_Enode (OE_Addrg, L_Type,
+ O_Enode (Get_Const_Decl (Lit)), O_Enode_Null);
+ when OC_Array
+ | OC_Record
+ | OC_Sizeof =>
+ raise Syntax_Error;
+ end case;
+ end if;
+ end New_Lit;
+
+ function Get_Static_Chain (Depth : O_Depth) return O_Enode
+ is
+ Cur_Depth : O_Depth := Cur_Subprg.Depth;
+ Subprg : Subprogram_Data_Acc;
+ Res : O_Enode;
+ begin
+ if Depth = Cur_Depth then
+ return New_Enode (OE_Get_Frame, Abi.Mode_Ptr, O_Tnode_Ptr,
+ O_Enode_Null, O_Enode_Null);
+ else
+ Subprg := Cur_Subprg;
+ Res := O_Enode_Null;
+ loop
+ Res := New_Enode (OE_Addrl, Abi.Mode_Ptr, O_Tnode_Ptr,
+ O_Enode (Subprg.D_Decl + 1), Res);
+ Res := New_Enode (OE_Indir, O_Tnode_Ptr, Res, O_Enode_Null);
+ Cur_Depth := Cur_Depth - 1;
+ if Cur_Depth = Depth then
+ return Res;
+ end if;
+ Subprg := Subprg.Parent;
+ end loop;
+ end if;
+ end Get_Static_Chain;
+
+ function New_Obj (Obj : O_Dnode) return O_Lnode
+ is
+ O_Type : O_Tnode;
+ Kind : OE_Kind;
+ Chain : O_Enode;
+ Depth : O_Depth;
+ begin
+ O_Type := Get_Decl_Type (Obj);
+ case Get_Decl_Kind (Obj) is
+ when OD_Local
+ | OD_Interface =>
+ Kind := OE_Addrl;
+ -- Local declarations are 1 deeper than their subprogram.
+ Depth := Get_Decl_Depth (Obj) - 1;
+ if Depth /= Cur_Subprg.Depth then
+ Chain := Get_Static_Chain (Depth);
+ else
+ Chain := O_Enode_Null;
+ end if;
+ when OD_Var
+ | OD_Const =>
+ Kind := OE_Addrg;
+ Chain := O_Enode_Null;
+ when others =>
+ raise Program_Error;
+ end case;
+ return O_Lnode (New_Enode (Kind, Abi.Mode_Ptr, O_Type,
+ O_Enode (Obj), Chain));
+ end New_Obj;
+
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode
+ is
+ L_Type : O_Tnode;
+ begin
+ L_Type := Get_Enode_Type (Left);
+ if Flag_Debug_Assert then
+ if L_Type /= Get_Enode_Type (Right) then
+ raise Syntax_Error;
+ end if;
+ if Get_Type_Mode (L_Type) = Mode_Blk then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Left);
+ Check_Ref (Right);
+ end if;
+
+ return New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)),
+ L_Type, Left, Right);
+ end New_Dyadic_Op;
+
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode
+ is
+ O_Type : O_Tnode;
+ begin
+ O_Type := Get_Enode_Type (Operand);
+
+ if Flag_Debug_Assert then
+ if Get_Type_Mode (O_Type) = Mode_Blk then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Operand);
+ end if;
+
+ return New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), O_Type,
+ Operand, O_Enode_Null);
+ end New_Monadic_Op;
+
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
+ return O_Enode
+ is
+ Res : O_Enode;
+ begin
+ if Flag_Debug_Assert then
+ if Get_Enode_Type (Left) /= Get_Enode_Type (Right) then
+ raise Syntax_Error;
+ end if;
+ if Get_Expr_Mode (Left) = Mode_Blk then
+ raise Syntax_Error;
+ end if;
+ if Get_Type_Kind (Ntype) /= OT_Boolean then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Left);
+ Check_Ref (Right);
+ end if;
+
+ Res := New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), Ntype,
+ Left, Right);
+ if Flag_Debug_Hli then
+ return New_Enode (OE_Typed, Ntype, Res, O_Enode (Ntype));
+ else
+ return Res;
+ end if;
+ end New_Compare_Op;
+
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Enode is
+ begin
+ return New_Const_U32 (Get_Type_Size (Atype), Rtype);
+ end New_Sizeof;
+
+ function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Enode is
+ begin
+ return New_Const_U32 (Get_Field_Offset (Field), Rtype);
+ end New_Offsetof;
+
+ function Is_Pow2 (V : Uns32) return Boolean is
+ begin
+ return (V and -V) = V;
+ end Is_Pow2;
+
+ function Extract_Pow2 (V : Uns32) return Uns32 is
+ begin
+ for I in Natural range 0 .. 31 loop
+ if V = Shift_Left (1, I) then
+ return Uns32 (I);
+ end if;
+ end loop;
+ raise Program_Error;
+ end Extract_Pow2;
+
+ function New_Index_Slice_Element
+ (Arr : O_Lnode; Index : O_Enode; Res_Type : O_Tnode)
+ return O_Lnode
+ is
+ El_Type : O_Tnode;
+ In_Type : O_Tnode;
+ Sz : O_Enode;
+ El_Size : Uns32;
+ begin
+ El_Type := Get_Type_Array_Element (Get_Enode_Type (O_Enode (Arr)));
+ In_Type := Get_Enode_Type (Index);
+
+ if Flag_Debug_Assert then
+ Check_Ref (Index);
+ Check_Ref (Arr);
+ end if;
+
+ -- result := arr + index * sizeof (element).
+ El_Size := Get_Type_Size (El_Type);
+ if El_Size = 1 then
+ Sz := Index;
+ elsif Get_Expr_Kind (Index) = OE_Const then
+ -- FIXME: may recycle previous index?
+ Sz := New_Const_U32 (Get_Expr_Low (Index) * El_Size, In_Type);
+ else
+ if Is_Pow2 (El_Size) then
+ Sz := New_Const_U32 (Extract_Pow2 (El_Size), In_Type);
+ Sz := New_Enode (OE_Shl, In_Type, Index, Sz);
+ else
+ Sz := New_Const_U32 (El_Size, In_Type);
+ Sz := New_Enode (OE_Mul, In_Type, Index, Sz);
+ end if;
+ end if;
+ return O_Lnode (New_Enode (OE_Add, Abi.Mode_Ptr, Res_Type,
+ O_Enode (Arr), Sz));
+ end New_Index_Slice_Element;
+
+ function New_Hli_Index_Slice
+ (Kind : OE_Kind; Res_Type : O_Tnode; Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode
+ is
+ begin
+ if Flag_Debug_Assert then
+ Check_Ref (Index);
+ Check_Ref (Arr);
+ end if;
+ return O_Lnode (New_Enode (Kind, Res_Type, O_Enode (Arr), Index));
+ end New_Hli_Index_Slice;
+
+ -- Get an element of an array.
+ -- INDEX must be of the type of the array index.
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode
+ is
+ El_Type : O_Tnode;
+ begin
+ El_Type := Get_Type_Array_Element (Get_Enode_Type (O_Enode (Arr)));
+
+ if Flag_Debug_Hli then
+ return New_Hli_Index_Slice (OE_Index_Ref, El_Type, Arr, Index);
+ else
+ return New_Index_Slice_Element (Arr, Index, El_Type);
+ end if;
+ end New_Indexed_Element;
+
+ -- Get a slice of an array; this is equivalent to a conversion between
+ -- an array or an array subtype and an array subtype.
+ -- RES_TYPE must be an array_sub_type whose base type is the same as the
+ -- base type of ARR.
+ -- INDEX must be of the type of the array index.
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode
+ is
+ begin
+ if Flag_Debug_Hli then
+ return New_Hli_Index_Slice (OE_Slice_Ref, Res_Type, Arr, Index);
+ else
+ return New_Index_Slice_Element (Arr, Index, Res_Type);
+ end if;
+ end New_Slice;
+
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode
+ is
+ Offset : Uns32;
+ Off : O_Enode;
+ Res_Type : O_Tnode;
+ begin
+ if Flag_Debug_Assert then
+ Check_Ref (Rec);
+ end if;
+
+ Res_Type := Get_Field_Type (El);
+ if Flag_Debug_Hli then
+ return O_Lnode (New_Enode (OE_Record_Ref, Res_Type,
+ O_Enode (Rec), O_Enode (El)));
+ else
+ Offset := Get_Field_Offset (El);
+ if Offset = 0 then
+ return O_Lnode (New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Res_Type,
+ O_Enode (Rec), O_Enode (Res_Type)));
+ else
+ Off := New_Enode (OE_Const, Mode_U32, O_Tnode_Null,
+ O_Enode (Offset), O_Enode_Null);
+
+ return O_Lnode (New_Enode (OE_Add, Abi.Mode_Ptr, Res_Type,
+ O_Enode (Rec), Off));
+ end if;
+ end if;
+ end New_Selected_Element;
+
+ function New_Access_Element (Acc : O_Enode) return O_Lnode
+ is
+ Acc_Type : O_Tnode;
+ Res_Type : O_Tnode;
+ begin
+ Acc_Type := Get_Enode_Type (Acc);
+
+ if Flag_Debug_Assert then
+ if Get_Type_Kind (Acc_Type) /= OT_Access then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Acc);
+ end if;
+
+ Res_Type := Get_Type_Access_Type (Acc_Type);
+ if Flag_Debug_Hli then
+ return O_Lnode (New_Enode (OE_Access_Ref, Abi.Mode_Ptr, Res_Type,
+ Acc, O_Enode_Null));
+ else
+ return O_Lnode (New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Res_Type,
+ Acc, O_Enode (Res_Type)));
+ end if;
+ end New_Access_Element;
+
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is
+ begin
+ if Flag_Debug_Assert then
+ Check_Ref (Val);
+ end if;
+
+ return New_Enode (OE_Conv, Rtype, Val, O_Enode (Rtype));
+ end New_Convert_Ov;
+
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode is
+ begin
+ if Flag_Debug_Assert then
+ if Get_Type_Kind (Atype) /= OT_Access then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Lvalue);
+ end if;
+
+ return New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Atype,
+ O_Enode (Lvalue), O_Enode (Atype));
+ end New_Unchecked_Address;
+
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is
+ begin
+ if Flag_Debug_Assert then
+ if Get_Type_Kind (Atype) /= OT_Access then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Lvalue);
+ end if;
+
+ return New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Atype,
+ O_Enode (Lvalue), O_Enode (Atype));
+ end New_Address;
+
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Enode is
+ begin
+ raise Program_Error;
+ return O_Enode_Null;
+ end New_Subprogram_Address;
+
+ function New_Value (Lvalue : O_Lnode) return O_Enode
+ is
+ V_Type : O_Tnode;
+ begin
+ V_Type := Get_Enode_Type (O_Enode (Lvalue));
+
+ if Flag_Debug_Assert then
+ Check_Ref (Lvalue);
+ end if;
+
+ return New_Enode (OE_Indir, V_Type, O_Enode (Lvalue), O_Enode_Null);
+ end New_Value;
+
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode
+ is
+ Save_Var : O_Dnode;
+ Stmt : O_Enode;
+ begin
+ if Flag_Debug_Assert then
+ Check_Ref (Size);
+ if Get_Type_Kind (Rtype) /= OT_Access then
+ raise Syntax_Error;
+ end if;
+ if Get_Type_Kind (Get_Enode_Type (Size)) /= OT_Unsigned then
+ raise Syntax_Error;
+ end if;
+ end if;
+
+ if not Get_Block_Has_Alloca (Cur_Block) then
+ Set_Block_Has_Alloca (Cur_Block, True);
+ -- Add a decl.
+ New_Var_Decl (Save_Var, O_Ident_Nul, O_Storage_Local, Rtype);
+ -- Add insn to save stack ptr.
+ Stmt := New_Enode (OE_Asgn, Rtype,
+ New_Stack (Rtype),
+ O_Enode (New_Obj (Save_Var)));
+ if Cur_Block = Last_Stmt then
+ Set_Stmt_Link (Last_Stmt, Stmt);
+ Last_Stmt := Stmt;
+ else
+ Set_Stmt_Link (Stmt, Get_Stmt_Link (Cur_Block));
+ Set_Stmt_Link (Cur_Block, Stmt);
+ end if;
+ end if;
+
+ return New_Enode (OE_Alloca, Rtype, Size, O_Enode (Rtype));
+ end New_Alloca;
+
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode)
+ is
+ Depth : O_Depth;
+ Arg : O_Enode;
+ First_Inter : O_Dnode;
+ begin
+ First_Inter := Get_Subprg_Interfaces (Subprg);
+ if Get_Decl_Storage (Subprg) = O_Storage_Local then
+ Depth := Get_Decl_Depth (Subprg);
+ Arg := New_Enode (OE_Arg, Abi.Mode_Ptr, O_Tnode_Ptr,
+ Get_Static_Chain (Depth - 1), O_Enode_Null);
+ First_Inter := Get_Interface_Chain (First_Inter);
+ else
+ Arg := O_Enode_Null;
+ end if;
+ Assocs := (Subprg => Subprg,
+ First_Arg => Arg,
+ Last_Arg => Arg,
+ Next_Inter => First_Inter);
+ end Start_Association;
+
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode)
+ is
+ V_Type : O_Tnode;
+ Mode : Mode_Type;
+ N_Mode : Mode_Type;
+ Res : O_Enode;
+ begin
+ V_Type := Get_Enode_Type (Val);
+
+ if Flag_Debug_Assert then
+ if Assocs.Next_Inter = O_Dnode_Null then
+ -- More assocs than interfaces.
+ raise Syntax_Error;
+ end if;
+ Check_Value_Type (Val, Get_Decl_Type (Assocs.Next_Inter));
+ Check_Ref (Val);
+ end if;
+
+ -- Follow the C convention call: no parameters shorter than int.
+ Mode := Get_Type_Mode (V_Type);
+ case Mode is
+ when Mode_B2
+ | Mode_U8
+ | Mode_U16 =>
+ N_Mode := Mode_U32;
+ when Mode_I8
+ | Mode_I16 =>
+ N_Mode := Mode_I32;
+ when Mode_P32
+ | Mode_U32
+ | Mode_I32
+ | Mode_U64
+ | Mode_I64
+ | Mode_P64
+ | Mode_F32
+ | Mode_F64 =>
+ N_Mode := Mode;
+ when Mode_Blk
+ | Mode_Nil
+ | Mode_X1 =>
+ raise Program_Error;
+ end case;
+ if N_Mode /= Mode and not Flag_Debug_Hli then
+ Res := New_Enode (OE_Conv, N_Mode, V_Type, Val, O_Enode (V_Type));
+ else
+ Res := Val;
+ end if;
+ Res := New_Enode (OE_Arg, N_Mode, V_Type, Res, O_Enode_Null);
+ if Assocs.Last_Arg /= O_Enode_Null then
+ Enodes.Table (Assocs.Last_Arg).Arg2 := Res;
+ else
+ Assocs.First_Arg := Res;
+ end if;
+ Assocs.Last_Arg := Res;
+ Assocs.Next_Inter := Get_Interface_Chain (Assocs.Next_Inter);
+ end New_Association;
+
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode
+ is
+ F_Type : O_Tnode;
+ begin
+ if Flag_Debug_Assert then
+ if Assocs.Next_Inter /= O_Dnode_Null then
+ -- Not enough assocs.
+ raise Syntax_Error;
+ end if;
+ end if;
+
+ F_Type := Get_Decl_Type (Assocs.Subprg);
+ return New_Enode (OE_Call, F_Type,
+ O_Enode (Assocs.Subprg), Assocs.First_Arg);
+ end New_Function_Call;
+
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is
+ begin
+ if Flag_Debug_Assert then
+ if Assocs.Next_Inter /= O_Dnode_Null then
+ -- Not enough assocs.
+ raise Syntax_Error;
+ end if;
+ end if;
+ New_Enode_Stmt (OE_Call, O_Enode (Assocs.Subprg), Assocs.First_Arg);
+ end New_Procedure_Call;
+
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode)
+ is
+ V_Type : O_Tnode;
+ begin
+ V_Type := Get_Enode_Type (Value);
+
+ if Flag_Debug_Assert then
+ Check_Value_Type (Value, Get_Enode_Type (O_Enode (Target)));
+ Check_Ref (Value);
+ Check_Ref (Target);
+ end if;
+
+ New_Enode_Stmt (OE_Asgn, Get_Type_Mode (V_Type),
+ Value, O_Enode (Target));
+ end New_Assign_Stmt;
+
+ procedure New_Return_Stmt (Value : O_Enode)
+ is
+ V_Type : O_Tnode;
+ begin
+ V_Type := Get_Enode_Type (Value);
+
+ if Flag_Debug_Assert then
+ Check_Ref (Value);
+ Check_Value_Type (Value, Get_Decl_Type (Cur_Subprg.D_Decl));
+ end if;
+
+ New_Enode_Stmt (OE_Ret, Get_Type_Mode (V_Type), Value, O_Enode_Null);
+ if not Flag_Debug_Hli then
+ New_Allocb_Jump (Cur_Subprg.Exit_Label);
+ end if;
+ end New_Return_Stmt;
+
+ procedure New_Return_Stmt is
+ begin
+ if Flag_Debug_Assert then
+ if Get_Decl_Kind (Cur_Subprg.D_Decl) /= OD_Procedure then
+ raise Syntax_Error;
+ end if;
+ end if;
+
+ if not Flag_Debug_Hli then
+ New_Allocb_Jump (Cur_Subprg.Exit_Label);
+ else
+ New_Enode_Stmt (OE_Ret, Mode_Nil, O_Enode_Null, O_Enode_Null);
+ end if;
+ end New_Return_Stmt;
+
+
+ procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode) is
+ begin
+ if Flag_Debug_Assert then
+ if Get_Expr_Mode (Cond) /= Mode_B2 then
+ -- COND must be a boolean.
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Cond);
+ end if;
+
+ if Flag_Debug_Hli then
+ New_Enode_Stmt (OE_If, Cond, O_Enode_Null);
+ Block := (Label_End => O_Enode_Null,
+ Label_Next => Last_Stmt);
+ else
+ Block := (Label_End => O_Enode_Null,
+ Label_Next => New_Label);
+ Emit_Jmp (OE_Jump_F, Cond, Block.Label_Next);
+ Start_BB;
+ end if;
+ end Start_If_Stmt;
+
+ procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode) is
+ begin
+ if Flag_Debug_Assert then
+ if Get_Expr_Mode (Cond) /= Mode_B2 then
+ -- COND must be a boolean.
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Cond);
+ end if;
+
+ if Flag_Debug_Hli then
+ New_Enode_Stmt (OE_Elsif, Cond, O_Enode_Null);
+ Block.Label_Next := Last_Stmt;
+ else
+ if Block.Label_End = O_Enode_Null then
+ Block.Label_End := New_Label;
+ end if;
+ Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End);
+ Start_BB;
+ Link_Stmt (Block.Label_Next);
+ Block.Label_Next := New_Label;
+ Emit_Jmp (OE_Jump_F, Cond, Block.Label_Next);
+ Start_BB;
+ end if;
+ end New_Elsif_Stmt;
+
+ procedure New_Else_Stmt (Block : in out O_If_Block) is
+ begin
+ if Flag_Debug_Hli then
+ New_Enode_Stmt (OE_Elsif, O_Enode_Null, O_Enode_Null);
+ else
+ if Block.Label_End = O_Enode_Null then
+ Block.Label_End := New_Label;
+ end if;
+ Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End);
+ Start_BB;
+ Link_Stmt (Block.Label_Next);
+ Block.Label_Next := O_Enode_Null;
+ end if;
+ end New_Else_Stmt;
+
+ procedure Finish_If_Stmt (Block : in out O_If_Block) is
+ begin
+ if Flag_Debug_Hli then
+ New_Enode_Stmt (OE_Endif, O_Enode_Null, O_Enode_Null);
+ else
+ -- Create a badic-block after the IF.
+ Start_BB;
+ if Block.Label_Next /= O_Enode_Null then
+ Link_Stmt (Block.Label_Next);
+ end if;
+ if Block.Label_End /= O_Enode_Null then
+ Link_Stmt (Block.Label_End);
+ end if;
+ end if;
+ end Finish_If_Stmt;
+
+ procedure Start_Loop_Stmt (Label : out O_Snode) is
+ begin
+ if Flag_Debug_Hli then
+ New_Enode_Stmt (OE_Loop, O_Enode_Null, O_Enode_Null);
+ Label := (Label_Start => Last_Stmt,
+ Label_End => O_Enode_Null);
+ else
+ -- Create a basic-block at the beginning of the loop.
+ Start_BB;
+ Label.Label_Start := New_Label;
+ Link_Stmt (Label.Label_Start);
+ Label.Label_End := New_Label;
+ end if;
+ end Start_Loop_Stmt;
+
+ procedure Finish_Loop_Stmt (Label : in out O_Snode)
+ is
+ begin
+ if Flag_Debug_Hli then
+ New_Enode_Stmt (OE_Eloop, Label.Label_Start, O_Enode_Null);
+ else
+ Emit_Jmp (OE_Jump, O_Enode_Null, Label.Label_Start);
+ Start_BB;
+ Link_Stmt (Label.Label_End);
+ end if;
+ end Finish_Loop_Stmt;
+
+
+ procedure New_Exit_Stmt (L : O_Snode)
+ is
+ begin
+ if Flag_Debug_Hli then
+ New_Enode_Stmt (OE_Exit, O_Enode_Null, L.Label_Start);
+ else
+ New_Allocb_Jump (L.Label_End);
+ end if;
+ end New_Exit_Stmt;
+
+ procedure New_Next_Stmt (L : O_Snode)
+ is
+ begin
+ if Flag_Debug_Hli then
+ New_Enode_Stmt (OE_Next, O_Enode_Null, L.Label_Start);
+ else
+ New_Allocb_Jump (L.Label_Start);
+ end if;
+ end New_Next_Stmt;
+
+ procedure Start_Case_Stmt (Block : out O_Case_Block; Value : O_Enode)
+ is
+ V_Type : O_Tnode;
+ Mode : Mode_Type;
+ Start : O_Enode;
+ begin
+ V_Type := Get_Enode_Type (Value);
+ Mode := Get_Type_Mode (V_Type);
+
+ if Flag_Debug_Assert then
+ Check_Ref (Value);
+ case Mode is
+ when Mode_U8 .. Mode_U64
+ | Mode_I8 .. Mode_I64
+ | Mode_B2 =>
+ null;
+ when others =>
+ raise Syntax_Error;
+ end case;
+ end if;
+
+ New_Enode_Stmt (OE_Case, Mode, Value, O_Enode_Null);
+ Start := Enodes.Last;
+ if Flag_Debug_Hli then
+ Block := (Expr => Start,
+ Expr_Type => V_Type,
+ Last_Node => O_Enode_Null,
+ Label_End => O_Enode_Null,
+ Label_Branch => Start);
+ else
+ Block := (Expr => Start,
+ Expr_Type => V_Type,
+ Last_Node => Start,
+ Label_End => New_Label,
+ Label_Branch => O_Enode_Null);
+ end if;
+ end Start_Case_Stmt;
+
+ procedure Start_Choice (Block : in out O_Case_Block)
+ is
+ B : O_Enode;
+ begin
+ if Flag_Debug_Hli then
+ B := New_Enode (OE_Case_Branch, Mode_Nil, O_Tnode_Null,
+ O_Enode_Null, O_Enode_Null);
+ Link_Stmt (B);
+ -- Link it.
+ Set_Case_Branch (Block.Label_Branch, B);
+ Block.Label_Branch := B;
+ else
+ -- Jump to the end of the case statement.
+ -- If there is already a branch open, this is ok
+ -- (do not fall-through).
+ -- If there is no branch open, then this is the default choice
+ -- (nothing to do).
+ Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End);
+
+ -- Create a label for the code of this branch.
+ Block.Label_Branch := New_Label;
+ end if;
+ end Start_Choice;
+
+ procedure Insert_Choice_Stmt (Block : in out O_Case_Block; Stmt : O_Enode)
+ is
+ Prev : O_Enode;
+ begin
+ Prev := Get_Stmt_Link (Block.Last_Node);
+ Set_Stmt_Link (Block.Last_Node, Stmt);
+ Block.Last_Node := Stmt;
+ if Prev = O_Enode_Null then
+ Last_Stmt := Stmt;
+ else
+ Set_Stmt_Link (Stmt, Prev);
+ end if;
+ end Insert_Choice_Stmt;
+
+ procedure Emit_Choice_Jmp (Block : in out O_Case_Block;
+ Code : OE_Kind; Expr : O_Enode; Label : O_Enode)
+ is
+ Jmp : O_Enode;
+ begin
+ Jmp := New_Enode (Code, Mode_Nil, O_Tnode_Null, Expr, Label);
+ Insert_Choice_Stmt (Block, Jmp);
+ end Emit_Choice_Jmp;
+
+ -- Create a node containing the value of the case expression.
+ function New_Case_Expr (Block : O_Case_Block) return O_Enode is
+ begin
+ return New_Enode (OE_Case_Expr, Block.Expr_Type,
+ Block.Expr, O_Enode_Null);
+ end New_Case_Expr;
+
+ procedure New_Hli_Choice (Block : in out O_Case_Block;
+ Hi, Lo : O_Enode)
+ is
+ Res : O_Enode;
+ begin
+ Res := New_Enode (OE_Case_Choice, Mode_Nil, O_Tnode_Null, Hi, Lo);
+ if Block.Label_End = O_Enode_Null then
+ Set_Case_Branch_Choice (Block.Label_Branch, Res);
+ else
+ Set_Case_Choice_Link (Block.Label_End, Res);
+ end if;
+ Block.Label_End := Res;
+ end New_Hli_Choice;
+
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode)
+ is
+ Res : O_Enode;
+ begin
+ if Flag_Debug_Hli then
+ New_Hli_Choice (Block, New_Lit (Expr), O_Enode_Null);
+ else
+ Res := New_Enode (OE_Eq, Mode_B2, O_Tnode_Null,
+ New_Case_Expr (Block), New_Lit (Expr));
+ Emit_Choice_Jmp (Block, OE_Jump_T, Res, Block.Label_Branch);
+ end if;
+ end New_Expr_Choice;
+
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode)
+ is
+ E1 : O_Enode;
+ E2 : O_Enode;
+ Label : O_Enode;
+ begin
+ if Flag_Debug_Hli then
+ New_Hli_Choice (Block, New_Lit (Low), New_Lit (High));
+ else
+ -- Internal label.
+ Label := New_Label;
+ E1 := New_Enode (OE_Lt, Mode_B2, O_Tnode_Null,
+ New_Case_Expr (Block), New_Lit (Low));
+ Emit_Choice_Jmp (Block, OE_Jump_T, E1, Label);
+ E2 := New_Enode (OE_Le, Mode_B2, O_Tnode_Null,
+ New_Case_Expr (Block), New_Lit (High));
+ Emit_Choice_Jmp (Block, OE_Jump_T, E2, Block.Label_Branch);
+ Insert_Choice_Stmt (Block, Label);
+ end if;
+ end New_Range_Choice;
+
+ procedure New_Default_Choice (Block : in out O_Case_Block) is
+ begin
+ if Flag_Debug_Hli then
+ New_Hli_Choice (Block, O_Enode_Null, O_Enode_Null);
+ else
+ -- Jump to the code.
+ Emit_Choice_Jmp (Block, OE_Jump, O_Enode_Null, Block.Label_Branch);
+ end if;
+ end New_Default_Choice;
+
+ procedure Finish_Choice (Block : in out O_Case_Block) is
+ begin
+ if Flag_Debug_Hli then
+ Block.Label_End := O_Enode_Null;
+ else
+ -- Put the label of the branch.
+ Start_BB;
+ Link_Stmt (Block.Label_Branch);
+ end if;
+ end Finish_Choice;
+
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block) is
+ begin
+ if Flag_Debug_Hli then
+ New_Enode_Stmt (OE_Case_End, O_Enode_Null, O_Enode_Null);
+ else
+ -- Jump to the end of the case statement.
+ -- Note: this is not required, since the next instruction is the
+ -- label.
+ -- Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End);
+
+ -- Put the label of the end of the case.
+ Start_BB;
+ Link_Stmt (Block.Label_End);
+ Block.Label_End := O_Enode_Null;
+ end if;
+ end Finish_Case_Stmt;
+
+ procedure New_Debug_Line_Stmt (Line : Natural) is
+ begin
+ New_Enode_Stmt (OE_Line, O_Enode (Line), O_Enode_Null);
+ end New_Debug_Line_Stmt;
+
+ procedure Disp_Enode (Indent : Natural; N : O_Enode)
+ is
+ use Ada.Text_IO;
+ use Ortho_Code.Debug;
+ use Ortho_Code.Debug.Int32_IO;
+ begin
+ Set_Col (Count (Indent));
+ Put (Int32 (N), 0);
+ Set_Col (Count (Indent + 7));
+ Disp_Mode (Get_Expr_Mode (N));
+ Put (" ");
+ Put (OE_Kind'Image (Get_Expr_Kind (N)));
+ Set_Col (Count (Indent + 25));
+-- Put (Abi.Image_Insn (Get_Expr_Insn (N)));
+-- Put (" ");
+ Put (Abi.Image_Reg (Get_Expr_Reg (N)));
+ Put (" ");
+ Put (Int32 (Enodes.Table (N).Arg1), 7);
+ Put (Int32 (Enodes.Table (N).Arg2), 7);
+ Put (Enodes.Table (N).Info, 7);
+ New_Line;
+ end Disp_Enode;
+
+ procedure Disp_Subprg_Body (Indent : Natural; Subprg : O_Enode)
+ is
+ N : O_Enode;
+ N_Indent : Natural;
+ begin
+ N := Subprg;
+ if Get_Expr_Kind (N) /= OE_Entry then
+ raise Program_Error;
+ end if;
+ -- Display the entry.
+ Disp_Enode (Indent, N);
+ -- Display the subprogram, binding.
+ N_Indent := Indent;-- + 1;
+ N := N + 1;
+ loop
+ case Get_Expr_Kind (N) is
+ when OE_Entry =>
+ N := Get_Entry_Leave (N) + 1;
+ when OE_Leave =>
+ Disp_Enode (Indent, N);
+ exit;
+ when others =>
+ Disp_Enode (N_Indent, N);
+ case Get_Expr_Kind (N) is
+ when OE_Beg =>
+ Disp_Block (N_Indent + 2,
+ O_Dnode (Enodes.Table (N).Arg2));
+ N_Indent := N_Indent + 1;
+ when OE_End =>
+ N_Indent := N_Indent - 1;
+ when others =>
+ null;
+ end case;
+ N := N + 1;
+ end case;
+ end loop;
+ end Disp_Subprg_Body;
+
+ procedure Disp_All_Enode is
+ begin
+ for I in Enodes.First .. Enodes.Last loop
+ Disp_Enode (1, I);
+ end loop;
+ end Disp_All_Enode;
+
+ Max_Enode : O_Enode := O_Enode_Null;
+
+ procedure Mark (M : out Mark_Type) is
+ begin
+ M.Enode := Enodes.Last;
+ end Mark;
+
+ procedure Release (M : Mark_Type) is
+ begin
+ Max_Enode := O_Enode'Max (Max_Enode, Enodes.Last);
+ Enodes.Set_Last (M.Enode);
+ end Release;
+
+ procedure Disp_Stats
+ is
+ use Ada.Text_IO;
+ begin
+ Max_Enode := O_Enode'Max (Max_Enode, Enodes.Last);
+ Put ("Number of Enodes:" & O_Enode'Image (Enodes.Last));
+ Put (", max:" & O_Enode'Image (Max_Enode));
+ New_Line;
+ end Disp_Stats;
+
+ procedure Free_Subprogram_Data (Data : in out Subprogram_Data_Acc)
+ is
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Subprogram_Data, Subprogram_Data_Acc);
+ Ch, N_Ch : Subprogram_Data_Acc;
+ begin
+ Ch := Data.First_Child;
+ while Ch /= null loop
+ N_Ch := Ch.Brother;
+ Free_Subprogram_Data (Ch);
+ Ch := N_Ch;
+ end loop;
+ Free (Data);
+ end Free_Subprogram_Data;
+
+ procedure Finish is
+ begin
+ Enodes.Free;
+ Free_Subprogram_Data (First_Subprg);
+ end Finish;
+end Ortho_Code.Exprs;
generated by cgit (git 2.34.1) at 2024-12-21 09:01:37 +0000