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.adb1663
1 files changed, 0 insertions, 1663 deletions
diff --git a/ortho/mcode/ortho_code-exprs.adb b/ortho/mcode/ortho_code-exprs.adb
deleted file mode 100644
index b2dfa1a..0000000
--- a/ortho/mcode/ortho_code-exprs.adb
+++ /dev/null
@@ -1,1663 +0,0 @@
--- 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; use 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_Stack_Adjust (Enode : O_Enode) return Int32 is
- begin
- return Int32 (Enodes.Table (Enode).Arg1);
- end Get_Stack_Adjust;
-
- 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;
- pragma Unreferenced (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;
-
- function Get_Loop_Level (Stmt : O_Enode) return Int32 is
- begin
- return Int32 (Enodes.Table (Stmt).Arg1);
- end Get_Loop_Level;
-
- procedure Set_Loop_Level (Stmt : O_Enode; Level : Int32) is
- begin
- Enodes.Table (Stmt).Arg1 := O_Enode (Level);
- end Set_Loop_Level;
-
- 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 : constant 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_Union
- | OC_Sizeof
- | OC_Alignof =>
- 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
- -- The static chain is the first interface of the subprogram.
- Res := New_Enode (OE_Addrl, Abi.Mode_Ptr, O_Tnode_Ptr,
- O_Enode (Get_Subprg_Interfaces (Subprg.D_Decl)),
- 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;
- if Get_Base_Type (Get_Enode_Type (O_Enode (Lvalue)))
- /= Get_Base_Type (Get_Type_Access_Type (Atype))
- 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;
- St_Type : O_Tnode;
- 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);
- if Stack_Ptr_Type /= O_Tnode_Null then
- St_Type := Stack_Ptr_Type;
- else
- St_Type := Rtype;
- end if;
- -- Add a decl.
- New_Var_Decl (Save_Var, O_Ident_Nul, O_Storage_Local, St_Type);
- -- Add insn to save stack ptr.
- Stmt := New_Enode (OE_Asgn, St_Type,
- New_Stack (St_Type),
- 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 not Flag_Lower_Stmt 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_Else_Stmt (Block : in out O_If_Block) is
- begin
- if not Flag_Lower_Stmt then
- New_Enode_Stmt (OE_Else, 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 not Flag_Lower_Stmt 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 not Flag_Lower_Stmt 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 not Flag_Lower_Stmt 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 not Flag_Lower_Stmt 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 not Flag_Lower_Stmt 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 Debug_Expr (N : O_Enode)
- is
- use Ada.Text_IO;
- use Ortho_Code.Debug.Int32_IO;
- Indent : constant Count := Col;
- begin
- Put (Int32 (N), 0);
- Set_Col (Indent + 7);
- Disp_Mode (Get_Expr_Mode (N));
- Put (" ");
- Put (OE_Kind'Image (Get_Expr_Kind (N)));
- Set_Col (Indent + 28);
--- 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 Debug_Expr;
-
- procedure Disp_Subprg_Body (Indent : Natural; Subprg : O_Enode)
- is
- use Ada.Text_IO;
- 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.
- Set_Col (Count (Indent));
- Debug_Expr (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 =>
- Set_Col (Count (Indent));
- Debug_Expr (N);
- exit;
- when others =>
- Set_Col (Count (N_Indent));
- Debug_Expr (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
- Debug_Expr (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-22 10:31:08 +0000