diff options
Diffstat (limited to 'src/ortho')
30 files changed, 707 insertions, 214 deletions
diff --git a/src/ortho/debug/ortho_debug-disp.adb b/src/ortho/debug/ortho_debug-disp.adb index 53e4a6767..51707786e 100644 --- a/src/ortho/debug/ortho_debug-disp.adb +++ b/src/ortho/debug/ortho_debug-disp.adb @@ -264,6 +264,7 @@ package body Ortho_Debug.Disp is procedure Disp_Enode (E : O_Enode; Etype : O_Tnode); procedure Disp_Lnode (Node : O_Lnode); + procedure Disp_Gnode (Node : O_Gnode); procedure Disp_Snode (First, Last : O_Snode); procedure Disp_Dnode (Decl : O_Dnode); procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean); @@ -556,17 +557,17 @@ package body Ortho_Debug.Disp is when OC_Address => Disp_Tnode_Name (C.Ctype); Put ("'address ("); - Disp_Dnode_Name (C.Decl); + Disp_Gnode (C.Addr_Global); Put (")"); when OC_Unchecked_Address => Disp_Tnode_Name (C.Ctype); Put ("'unchecked_address ("); - Disp_Dnode_Name (C.Decl); + Disp_Gnode (C.Addr_Global); Put (")"); when OC_Subprogram_Address => Disp_Tnode_Name (C.Ctype); Put ("'subprg_addr ("); - Disp_Dnode_Name (C.Decl); + Disp_Dnode_Name (C.Addr_Decl); Put (")"); end case; end Disp_Cnode; @@ -677,13 +678,21 @@ package body Ortho_Debug.Disp is Disp_Lnode (Node.Rec_Base); Put ('.'); Disp_Ident (Node.Rec_El.Ident); --- when OL_Var_Ref --- | OL_Const_Ref --- | OL_Param_Ref => --- Disp_Dnode_Name (Node.Decl); end case; end Disp_Lnode; + procedure Disp_Gnode (Node : O_Gnode) is + begin + case Node.Kind is + when OG_Decl => + Disp_Dnode_Name (Node.Decl); + when OG_Selected_Element => + Disp_Gnode (Node.Rec_Base); + Put ('.'); + Disp_Ident (Node.Rec_El.Ident); + end case; + end Disp_Gnode; + procedure Disp_Fnodes (First : O_Fnode) is El : O_Fnode; diff --git a/src/ortho/debug/ortho_debug.adb b/src/ortho/debug/ortho_debug.adb index 3645b89e8..bb32197a4 100644 --- a/src/ortho/debug/ortho_debug.adb +++ b/src/ortho/debug/ortho_debug.adb @@ -288,6 +288,14 @@ package body Ortho_Debug is N.Ref := True; end Check_Ref; + procedure Check_Ref (N : O_Gnode) is + begin + if N.Ref then + raise Syntax_Error; + end if; + N.Ref := True; + end Check_Ref; + procedure Check_Complete_Type (T : O_Tnode) is begin if not T.Complete then @@ -928,7 +936,7 @@ package body Ortho_Debug is | ON_Interface_Decl => null; when others => - raise Program_Error; + raise Syntax_Error; end case; Check_Scope (Obj); return new O_Lnode_Obj'(Kind => OL_Obj, @@ -937,8 +945,28 @@ package body Ortho_Debug is Obj => Obj); end New_Obj; + function New_Global (Decl : O_Dnode) return O_Gnode + is + subtype O_Gnode_Decl is O_Gnode_Type (OG_Decl); + begin + case Decl.Kind is + when ON_Const_Decl + | ON_Var_Decl => + null; + when others => + raise Syntax_Error; + end case; + if Decl.Storage = O_Storage_Local then + raise Syntax_Error; + end if; + return new O_Gnode_Decl'(Kind => OG_Decl, + Rtype => Decl.Dtype, + Ref => False, + Decl => Decl); + end New_Global; + function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode + return O_Lnode is subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element); Res : O_Lnode; @@ -953,7 +981,7 @@ package body Ortho_Debug is end New_Indexed_Element; function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode + return O_Lnode is subtype O_Lnode_Slice is O_Lnode_Type (OL_Slice); Res : O_Lnode; @@ -995,6 +1023,27 @@ package body Ortho_Debug is Rec_El => El); end New_Selected_Element; + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode + is + subtype O_Gnode_Selected_Element is O_Gnode_Type (OG_Selected_Element); + begin + if Rec.Rtype.Kind /= ON_Record_Type + and then Rec.Rtype.Kind /= ON_Union_Type + then + raise Type_Error; + end if; + if Rec.Rtype /= El.Parent then + raise Type_Error; + end if; + Check_Ref (Rec); + return new O_Gnode_Selected_Element'(Kind => OG_Selected_Element, + Rtype => El.Ftype, + Ref => False, + Rec_Base => Rec, + Rec_El => El); + end New_Global_Selected_Element; + function New_Access_Element (Acc : O_Enode) return O_Lnode is subtype O_Lnode_Access_Element is O_Lnode_Type (OL_Access_Element); @@ -1086,12 +1135,13 @@ package body Ortho_Debug is Lvalue => Lvalue); end New_Address; - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is subtype O_Cnode_Address is O_Cnode_Type (OC_Unchecked_Address); begin - Check_Scope (Decl); + -- FIXME: check Lvalue is a static object. + Check_Ref (Lvalue); if Atype.Kind /= ON_Access_Type then -- An address is of type access. raise Type_Error; @@ -1099,25 +1149,27 @@ package body Ortho_Debug is return new O_Cnode_Address'(Kind => OC_Unchecked_Address, Ctype => Atype, Ref => False, - Decl => Decl); + Addr_Global => Lvalue); end New_Global_Unchecked_Address; - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is subtype O_Cnode_Address is O_Cnode_Type (OC_Address); begin - Check_Scope (Decl); + -- FIXME: check Lvalue is a static object. + Check_Ref (Lvalue); if Atype.Kind /= ON_Access_Type then -- An address is of type access. raise Type_Error; end if; - if Get_Base_Type (Decl.Dtype) /= Get_Base_Type (Atype.D_Type) then + if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then raise Type_Error; end if; return new O_Cnode_Address'(Kind => OC_Address, Ctype => Atype, Ref => False, - Decl => Decl); + Addr_Global => Lvalue); end New_Global_Address; function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) @@ -1132,7 +1184,7 @@ package body Ortho_Debug is return new O_Cnode_Subprg_Address'(Kind => OC_Subprogram_Address, Ctype => Atype, Ref => False, - Decl => Subprg); + Addr_Decl => Subprg); end New_Subprogram_Address; -- Raise TYPE_ERROR is ATYPE is a composite type. diff --git a/src/ortho/debug/ortho_debug.private.ads b/src/ortho/debug/ortho_debug.private.ads index a1e711b62..b505ff434 100644 --- a/src/ortho/debug/ortho_debug.private.ads +++ b/src/ortho/debug/ortho_debug.private.ads @@ -179,9 +179,10 @@ private Aggr_Value : O_Cnode; Aggr_Next : O_Cnode; when OC_Address - | OC_Unchecked_Address - | OC_Subprogram_Address => - Decl : O_Dnode; + | OC_Unchecked_Address => + Addr_Global : O_Gnode; + when OC_Subprogram_Address => + Addr_Decl : O_Dnode; end case; end record; @@ -280,12 +281,6 @@ private OL_Slice, OL_Selected_Element, OL_Access_Element - - -- Variable, constant, parameter reference. - -- This allows to read/write a declaration. - --OL_Var_Ref, - --OL_Const_Ref, - --OL_Param_Ref ); type O_Lnode_Type (Kind : OL_Kind); @@ -311,10 +306,30 @@ private Rec_El : O_Fnode; when OL_Access_Element => Acc_Base : O_Enode; --- when OL_Var_Ref --- | OL_Const_Ref --- | OL_Param_Ref => --- Decl : O_Dnode; + end case; + end record; + + type OG_Kind is + ( + OG_Decl, + OG_Selected_Element + ); + + type O_Gnode_Type (Kind : OG_Kind); + type O_Gnode is access O_Gnode_Type; + O_Gnode_Null : constant O_Gnode := null; + + type O_Gnode_Type (Kind : OG_Kind) is record + -- Type of the result. + Rtype : O_Tnode; + -- True if referenced. + Ref : Boolean; + case Kind is + when OG_Decl => + Decl : O_Dnode; + when OG_Selected_Element => + Rec_Base : O_Gnode; + Rec_El : O_Fnode; end case; end record; diff --git a/src/ortho/gcc/ortho_gcc.adb b/src/ortho/gcc/ortho_gcc.adb index ae7b4f53b..37f782dcd 100644 --- a/src/ortho/gcc/ortho_gcc.adb +++ b/src/ortho/gcc/ortho_gcc.adb @@ -30,6 +30,17 @@ package body Ortho_Gcc is return O_Lnode (Obj); end New_Obj; + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + return O_Gnode (Decl); + end New_Global; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode is + begin + return O_Gnode (New_Selected_Element (O_Lnode (Rec), El)); + end New_Global_Selected_Element; + function New_Obj_Value (Obj : O_Dnode) return O_Enode is begin return O_Enode (Obj); diff --git a/src/ortho/gcc/ortho_gcc.ads b/src/ortho/gcc/ortho_gcc.ads index 7332ceb21..6273435dc 100644 --- a/src/ortho/gcc/ortho_gcc.ads +++ b/src/ortho/gcc/ortho_gcc.ads @@ -34,10 +34,12 @@ package Ortho_Gcc is type O_Tnode is private; type O_Snode is private; type O_Dnode is private; + type O_Gnode is private; type O_Fnode is private; O_Cnode_Null : constant O_Cnode; O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; O_Enode_Null : constant O_Enode; O_Fnode_Null : constant O_Fnode; O_Lnode_Null : constant O_Lnode; @@ -183,17 +185,17 @@ package Ortho_Gcc is -- Get the address of a subprogram. function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; + return O_Cnode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; ------------------- -- Expressions -- @@ -292,12 +294,15 @@ package Ortho_Gcc is -- 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; + return O_Lnode; -- Get an element of a record or a union. -- Type of REC must be a record or a union type. function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; -- Reference an access. -- Type of ACC must be an access type. @@ -324,6 +329,9 @@ package Ortho_Gcc is -- Get an lvalue from a declaration. function New_Obj (Obj : O_Dnode) return O_Lnode; + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; @@ -474,6 +482,7 @@ private type O_Cnode is new Tree; type O_Enode is new Tree; type O_Lnode is new Tree; + type O_Gnode is new Tree; type O_Tnode is new Tree; type O_Fnode is new Tree; type O_Dnode is new Tree; @@ -486,6 +495,7 @@ private O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); + O_Gnode_Null : constant O_Gnode := O_Gnode (NULL_TREE); O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE); O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE); O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE); diff --git a/src/ortho/gcc/ortho_gcc.private.ads b/src/ortho/gcc/ortho_gcc.private.ads index fcbc59129..3bae8526e 100644 --- a/src/ortho/gcc/ortho_gcc.private.ads +++ b/src/ortho/gcc/ortho_gcc.private.ads @@ -38,6 +38,7 @@ private type O_Cnode is new Tree; type O_Enode is new Tree; type O_Lnode is new Tree; + type O_Gnode is new Tree; type O_Tnode is new Tree; type O_Fnode is new Tree; type O_Dnode is new Tree; @@ -50,6 +51,7 @@ private O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); + O_Gnode_Null : constant O_Gnode := O_Gnode (NULL_TREE); O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE); O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE); O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE); diff --git a/src/ortho/llvm-nodebug/ortho_llvm.adb b/src/ortho/llvm-nodebug/ortho_llvm.adb index 7eb7277c6..443b469aa 100644 --- a/src/ortho/llvm-nodebug/ortho_llvm.adb +++ b/src/ortho/llvm-nodebug/ortho_llvm.adb @@ -779,22 +779,21 @@ package body Ortho_LLVM is -- New_Global_Address -- ------------------------ - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), - Ctype => Atype); + return New_Global_Unchecked_Address (Lvalue, Atype); end New_Global_Address; ---------------------------------- -- New_Global_Unchecked_Address -- ---------------------------------- - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), + return O_Cnode'(LLVM => ConstBitCast (Lvalue.LLVM, + Get_LLVM_Type (Atype)), Ctype => Atype); end New_Global_Unchecked_Address; @@ -808,6 +807,24 @@ package body Ortho_LLVM is Etype => Lit.Ctype); end New_Lit; + ---------------- + -- New_Global -- + ---------------- + + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. + case Decl.Kind is + when ON_Const_Decl + | ON_Var_Decl => + return O_Gnode'(LLVM => Decl.LLVM, + Ltype => Decl.Dtype); + when others => + raise Program_Error; + end case; + end New_Global; + ------------------- -- New_Dyadic_Op -- ------------------- @@ -1174,6 +1191,28 @@ package body Ortho_LLVM is return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); end New_Selected_Element; + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode + is + Res : ValueRef; + begin + case El.Kind is + when OF_Record => + declare + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); + begin + Res := ConstGEP (Rec.LLVM, Idx, 2); + end; + when OF_Union => + Res := ConstBitCast (Rec.LLVM, El.Ptr_Type); + when OF_None => + raise Program_Error; + end case; + return O_Gnode'(LLVM => Res, Ltype => El.Ftype); + end New_Global_Selected_Element; + ------------------------ -- New_Access_Element -- ------------------------ @@ -1364,12 +1403,8 @@ package body Ortho_LLVM is function New_Obj (Obj : O_Dnode) return O_Lnode is begin - if Unreach then - return O_Lnode'(Direct => False, - LLVM => Null_ValueRef, - Ltype => Obj.Dtype); - end if; - + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. case Obj.Kind is when ON_Const_Decl | ON_Var_Decl @@ -1718,7 +1753,8 @@ package body Ortho_LLVM is Cur_Func := Func.LLVM; Cur_Func_Decl := Func; - Unreach := False; + + pragma Assert (not Unreach); Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring); PositionBuilderAtEnd (Decl_Builder, Decl_BB); @@ -1751,6 +1787,8 @@ package body Ortho_LLVM is Destroy_Declare_Block; Cur_Func := Null_ValueRef; + + Unreach := False; end Finish_Subprogram_Body; ------------------------- diff --git a/src/ortho/llvm-nodebug/ortho_llvm.private.ads b/src/ortho/llvm-nodebug/ortho_llvm.private.ads index e5527a734..723aa5c7a 100644 --- a/src/ortho/llvm-nodebug/ortho_llvm.private.ads +++ b/src/ortho/llvm-nodebug/ortho_llvm.private.ads @@ -178,6 +178,13 @@ private O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + type O_Snode is record -- First BB in the loop body. Bb_Entry : BasicBlockRef; diff --git a/src/ortho/llvm/ortho_llvm.adb b/src/ortho/llvm/ortho_llvm.adb index d5e172532..250870224 100644 --- a/src/ortho/llvm/ortho_llvm.adb +++ b/src/ortho/llvm/ortho_llvm.adb @@ -1115,22 +1115,21 @@ package body Ortho_LLVM is -- New_Global_Address -- ------------------------ - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), - Ctype => Atype); + return New_Global_Unchecked_Address (Lvalue, Atype); end New_Global_Address; ---------------------------------- -- New_Global_Unchecked_Address -- ---------------------------------- - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), + return O_Cnode'(LLVM => ConstBitCast (Lvalue.LLVM, + Get_LLVM_Type (Atype)), Ctype => Atype); end New_Global_Unchecked_Address; @@ -1144,6 +1143,24 @@ package body Ortho_LLVM is Etype => Lit.Ctype); end New_Lit; + ---------------- + -- New_Global -- + ---------------- + + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. + case Decl.Kind is + when ON_Const_Decl + | ON_Var_Decl => + return O_Gnode'(LLVM => Decl.LLVM, + Ltype => Decl.Dtype); + when others => + raise Program_Error; + end case; + end New_Global; + ------------------- -- New_Dyadic_Op -- ------------------- @@ -1517,6 +1534,28 @@ package body Ortho_LLVM is return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); end New_Selected_Element; + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode + is + Res : ValueRef; + begin + case El.Kind is + when OF_Record => + declare + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); + begin + Res := ConstGEP (Rec.LLVM, Idx, 2); + end; + when OF_Union => + Res := ConstBitCast (Rec.LLVM, El.Ptr_Type); + when OF_None => + raise Program_Error; + end case; + return O_Gnode'(LLVM => Res, Ltype => El.Ftype); + end New_Global_Selected_Element; + ------------------------ -- New_Access_Element -- ------------------------ @@ -1708,12 +1747,8 @@ package body Ortho_LLVM is function New_Obj (Obj : O_Dnode) return O_Lnode is begin - if Unreach then - return O_Lnode'(Direct => False, - LLVM => Null_ValueRef, - Ltype => Obj.Dtype); - end if; - + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. case Obj.Kind is when ON_Const_Decl | ON_Var_Decl @@ -2257,7 +2292,8 @@ package body Ortho_LLVM is Cur_Func := Func.LLVM; Cur_Func_Decl := Func; - Unreach := False; + + pragma Assert (not Unreach); Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring); PositionBuilderAtEnd (Decl_Builder, Decl_BB); @@ -2399,6 +2435,9 @@ package body Ortho_LLVM is Destroy_Declare_Block; Cur_Func := Null_ValueRef; + + Unreach := False; + Dbg_Current_Scope := Null_ValueRef; Dbg_Insn_MD := Null_ValueRef; end Finish_Subprogram_Body; diff --git a/src/ortho/llvm/ortho_llvm.ads b/src/ortho/llvm/ortho_llvm.ads index 1dca66f4e..2779d0233 100644 --- a/src/ortho/llvm/ortho_llvm.ads +++ b/src/ortho/llvm/ortho_llvm.ads @@ -57,10 +57,12 @@ package Ortho_LLVM is type O_Tnode is private; type O_Snode is private; type O_Dnode is private; + type O_Gnode is private; type O_Fnode is private; O_Cnode_Null : constant O_Cnode; O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; O_Enode_Null : constant O_Enode; O_Fnode_Null : constant O_Fnode; O_Lnode_Null : constant O_Lnode; @@ -206,17 +208,17 @@ package Ortho_LLVM is -- Get the address of a subprogram. function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; + return O_Cnode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; ------------------- -- Expressions -- @@ -315,12 +317,15 @@ package Ortho_LLVM is -- 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; + return O_Lnode; -- Get an element of a record or a union. -- Type of REC must be a record or a union type. function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; -- Reference an access. -- Type of ACC must be an access type. @@ -347,6 +352,9 @@ package Ortho_LLVM is -- Get an lvalue from a declaration. function New_Obj (Obj : O_Dnode) return O_Lnode; + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; @@ -621,6 +629,13 @@ private O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + type O_Snode is record -- First BB in the loop body. Bb_Entry : BasicBlockRef; diff --git a/src/ortho/llvm/ortho_llvm.private.ads b/src/ortho/llvm/ortho_llvm.private.ads index a4041cb44..ce0685a90 100644 --- a/src/ortho/llvm/ortho_llvm.private.ads +++ b/src/ortho/llvm/ortho_llvm.private.ads @@ -185,6 +185,13 @@ private O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + type O_Snode is record -- First BB in the loop body. Bb_Entry : BasicBlockRef; diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.adb b/src/ortho/llvm4-nodebug/ortho_llvm.adb index 4e02a908a..2f0edca3c 100644 --- a/src/ortho/llvm4-nodebug/ortho_llvm.adb +++ b/src/ortho/llvm4-nodebug/ortho_llvm.adb @@ -782,22 +782,21 @@ package body Ortho_LLVM is -- New_Global_Address -- ------------------------ - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), - Ctype => Atype); + return New_Global_Unchecked_Address (Lvalue, Atype); end New_Global_Address; ---------------------------------- -- New_Global_Unchecked_Address -- ---------------------------------- - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), + return O_Cnode'(LLVM => ConstBitCast (Lvalue.LLVM, + Get_LLVM_Type (Atype)), Ctype => Atype); end New_Global_Unchecked_Address; @@ -811,6 +810,24 @@ package body Ortho_LLVM is Etype => Lit.Ctype); end New_Lit; + ---------------- + -- New_Global -- + ---------------- + + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. + case Decl.Kind is + when ON_Const_Decl + | ON_Var_Decl => + return O_Gnode'(LLVM => Decl.LLVM, + Ltype => Decl.Dtype); + when others => + raise Program_Error; + end case; + end New_Global; + ------------------- -- New_Dyadic_Op -- ------------------- @@ -1177,6 +1194,28 @@ package body Ortho_LLVM is return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); end New_Selected_Element; + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode + is + Res : ValueRef; + begin + case El.Kind is + when OF_Record => + declare + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); + begin + Res := ConstGEP (Rec.LLVM, Idx, 2); + end; + when OF_Union => + Res := ConstBitCast (Rec.LLVM, El.Ptr_Type); + when OF_None => + raise Program_Error; + end case; + return O_Gnode'(LLVM => Res, Ltype => El.Ftype); + end New_Global_Selected_Element; + ------------------------ -- New_Access_Element -- ------------------------ @@ -1367,12 +1406,8 @@ package body Ortho_LLVM is function New_Obj (Obj : O_Dnode) return O_Lnode is begin - if Unreach then - return O_Lnode'(Direct => False, - LLVM => Null_ValueRef, - Ltype => Obj.Dtype); - end if; - + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. case Obj.Kind is when ON_Const_Decl | ON_Var_Decl @@ -1725,7 +1760,8 @@ package body Ortho_LLVM is Cur_Func := Func.LLVM; Cur_Func_Decl := Func; - Unreach := False; + + pragma Assert (not Unreach); Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring); PositionBuilderAtEnd (Decl_Builder, Decl_BB); @@ -1758,6 +1794,8 @@ package body Ortho_LLVM is Destroy_Declare_Block; Cur_Func := Null_ValueRef; + + Unreach := False; end Finish_Subprogram_Body; ------------------------- diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.ads b/src/ortho/llvm4-nodebug/ortho_llvm.ads index 772a91894..837f4846e 100644 --- a/src/ortho/llvm4-nodebug/ortho_llvm.ads +++ b/src/ortho/llvm4-nodebug/ortho_llvm.ads @@ -50,10 +50,12 @@ package Ortho_LLVM is type O_Tnode is private; type O_Snode is private; type O_Dnode is private; + type O_Gnode is private; type O_Fnode is private; O_Cnode_Null : constant O_Cnode; O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; O_Enode_Null : constant O_Enode; O_Fnode_Null : constant O_Fnode; O_Lnode_Null : constant O_Lnode; @@ -199,17 +201,17 @@ package Ortho_LLVM is -- Get the address of a subprogram. function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; + return O_Cnode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; ------------------- -- Expressions -- @@ -308,12 +310,15 @@ package Ortho_LLVM is -- 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; + return O_Lnode; -- Get an element of a record or a union. -- Type of REC must be a record or a union type. function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; -- Reference an access. -- Type of ACC must be an access type. @@ -340,6 +345,9 @@ package Ortho_LLVM is -- Get an lvalue from a declaration. function New_Obj (Obj : O_Dnode) return O_Lnode; + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; @@ -614,6 +622,13 @@ private O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + type O_Snode is record -- First BB in the loop body. Bb_Entry : BasicBlockRef; diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.private.ads b/src/ortho/llvm4-nodebug/ortho_llvm.private.ads index e5527a734..723aa5c7a 100644 --- a/src/ortho/llvm4-nodebug/ortho_llvm.private.ads +++ b/src/ortho/llvm4-nodebug/ortho_llvm.private.ads @@ -178,6 +178,13 @@ private O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + type O_Snode is record -- First BB in the loop body. Bb_Entry : BasicBlockRef; diff --git a/src/ortho/mcode/ortho_code-consts.adb b/src/ortho/mcode/ortho_code-consts.adb index 7cc554211..1b2146dc4 100644 --- a/src/ortho/mcode/ortho_code-consts.adb +++ b/src/ortho/mcode/ortho_code-consts.adb @@ -19,6 +19,7 @@ with Ada.Unchecked_Conversion; with Tables; with Ada.Text_IO; with Ortho_Code.Types; use Ortho_Code.Types; +with Ortho_Code.Decls; with Ortho_Code.Debug; package body Ortho_Code.Consts is @@ -59,6 +60,12 @@ package body Ortho_Code.Consts is end record; for Cnode_Addr'Size use 64; + type Cnode_Global is record + Obj : O_Gnode; + Pad : Int32; + end record; + for Cnode_Global'Size use 64; + type Cnode_Aggr is record Els : Int32; Nbr : Int32; @@ -83,11 +90,43 @@ package body Ortho_Code.Consts is Table_Low_Bound => 2, Table_Initial => 128); + type Gnode_Common is record + Kind : OG_Kind; + Ref : Int32; + end record; + for Gnode_Common use record + Kind at 0 range 0 .. 31; + Ref at 4 range 0 .. 31; + end record; + for Gnode_Common'Size use 64; + + type Gnode_Record_Ref is record + Field : O_Fnode; + Off : Uns32; + end record; + for Gnode_Record_Ref'Size use 64; + + function To_Gnode_Common is new Ada.Unchecked_Conversion + (Gnode_Record_Ref, Gnode_Common); + function To_Gnode_Record_Ref is new Ada.Unchecked_Conversion + (Gnode_Common, Gnode_Record_Ref); + + package Gnodes is new Tables + (Table_Component_Type => Gnode_Common, + Table_Index_Type => O_Gnode, + Table_Low_Bound => 2, + Table_Initial => 64); + function Get_Const_Kind (Cst : O_Cnode) return OC_Kind is begin return Cnodes.Table (Cst).Kind; end Get_Const_Kind; + function Get_Global_Kind (Cst : O_Gnode) return OG_Kind is + begin + return Gnodes.Table (Cst).Kind; + end Get_Global_Kind; + function Get_Const_Type (Cst : O_Cnode) return O_Tnode is begin return Cnodes.Table (Cst).Lit_Type; @@ -227,12 +266,12 @@ package body Ortho_Code.Consts is end New_Default_Value; function To_Cnode_Common is new Ada.Unchecked_Conversion - (Source => Cnode_Addr, Target => Cnode_Common); + (Source => Cnode_Global, Target => Cnode_Common); - function To_Cnode_Addr is new Ada.Unchecked_Conversion - (Source => Cnode_Common, Target => Cnode_Addr); + function To_Cnode_Global is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Cnode_Global); - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is Res : O_Cnode; @@ -240,12 +279,12 @@ package body Ortho_Code.Consts is Cnodes.Append (Cnode_Common'(Kind => OC_Address, Lit_Type => Atype)); Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl, - Pad => 0))); + Cnodes.Append (To_Cnode_Common (Cnode_Global'(Obj => Lvalue, + Pad => 0))); return Res; end New_Global_Unchecked_Address; - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is Res : O_Cnode; @@ -253,11 +292,23 @@ package body Ortho_Code.Consts is Cnodes.Append (Cnode_Common'(Kind => OC_Address, Lit_Type => Atype)); Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl, - Pad => 0))); + Cnodes.Append (To_Cnode_Common (Cnode_Global'(Obj => Lvalue, + Pad => 0))); return Res; end New_Global_Address; + function Get_Const_Global (Cst : O_Cnode) return O_Gnode is + begin + pragma Assert (Get_Const_Kind (Cst) = OC_Address); + return To_Cnode_Global (Cnodes.Table (Cst + 1)).Obj; + end Get_Const_Global; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Addr, Target => Cnode_Common); + + function To_Cnode_Addr is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Cnode_Addr); + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) return O_Cnode is @@ -273,6 +324,7 @@ package body Ortho_Code.Consts is function Get_Const_Decl (Cst : O_Cnode) return O_Dnode is begin + pragma Assert (Get_Const_Kind (Cst) = OC_Subprg_Address); return To_Cnode_Addr (Cnodes.Table (Cst + 1)).Decl; end Get_Const_Decl; @@ -512,6 +564,74 @@ package body Ortho_Code.Consts is (Rtype, Unsigned_64 (Get_Field_Offset (Field))); end New_Offsetof; + function Get_Global_Decl (Global : O_Gnode) return O_Dnode is + begin + pragma Assert (Get_Global_Kind (Global) = OG_Decl); + return O_Dnode (Gnodes.Table (Global).Ref); + end Get_Global_Decl; + + function Get_Global_Field (Global : O_Gnode) return O_Fnode is + begin + pragma Assert (Get_Global_Kind (Global) = OG_Record_Ref); + return To_Gnode_Record_Ref (Gnodes.Table (Global + 1)).Field; + end Get_Global_Field; + + function Get_Global_Ref (Global : O_Gnode) return O_Gnode is + begin + pragma Assert (Get_Global_Kind (Global) = OG_Record_Ref); + return O_Gnode (Gnodes.Table (Global).Ref); + end Get_Global_Ref; + + function Get_Global_Type (Global : O_Gnode) return O_Tnode is + begin + case Get_Global_Kind (Global) is + when OG_Decl => + return Decls.Get_Decl_Type (Get_Global_Decl (Global)); + when OG_Record_Ref => + return Get_Field_Type (Get_Global_Field (Global)); + end case; + end Get_Global_Type; + + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + Gnodes.Append (Gnode_Common'(Kind => OG_Decl, + Ref => Int32 (Decl))); + return Gnodes.Last; + end New_Global; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode + is + Res : O_Gnode; + begin + -- TODO: Check Ref. + + -- Check type. + pragma Assert + (Get_Type_Kind (Get_Global_Type (Rec)) in OT_Kinds_Record_Union); + + Gnodes.Append (Gnode_Common'(Kind => OG_Record_Ref, + Ref => Int32 (Rec))); + Res := Gnodes.Last; + Gnodes.Append (To_Gnode_Common + (Gnode_Record_Ref'(Field => El, + Off => Get_Field_Offset (El)))); + return Res; + end New_Global_Selected_Element; + + procedure Get_Global_Decl_Offset (Global : O_Gnode; + Decl : out O_Dnode; Off : out Uns32) is + begin + case Get_Global_Kind (Global) is + when OG_Decl => + Decl := Get_Global_Decl (Global); + Off := 0; + when OG_Record_Ref => + Get_Global_Decl_Offset (Get_Global_Ref (Global), Decl, Off); + Off := Off + Get_Field_Offset (Get_Global_Field (Global)); + end case; + end Get_Global_Decl_Offset; + procedure Get_Const_Bytes (Cst : O_Cnode; H, L : out Uns32) is begin case Get_Const_Kind (Cst) is diff --git a/src/ortho/mcode/ortho_code-consts.ads b/src/ortho/mcode/ortho_code-consts.ads index 0a4f347fc..dcb719f26 100644 --- a/src/ortho/mcode/ortho_code-consts.ads +++ b/src/ortho/mcode/ortho_code-consts.ads @@ -24,6 +24,8 @@ package Ortho_Code.Consts is OC_Subprg_Address, OC_Address, OC_Sizeof, OC_Alignof); + type OG_Kind is (OG_Decl, OG_Record_Ref); + function Get_Const_Kind (Cst : O_Cnode) return OC_Kind; function Get_Const_Type (Cst : O_Cnode) return O_Tnode; @@ -54,9 +56,12 @@ package Ortho_Code.Consts is function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode; function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode; - -- Declaration for an address. + -- Declaration for a subprogram address. function Get_Const_Decl (Cst : O_Cnode) return O_Dnode; + -- Object for a global object address. + function Get_Const_Global (Cst : O_Cnode) return O_Gnode; + -- Get the type from an OC_Sizeof node. function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode; @@ -77,14 +82,22 @@ package Ortho_Code.Consts is -- Create a null access literal. function New_Null_Access (Ltype : O_Tnode) return O_Cnode; - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; function New_Default_Value (Ltype : O_Tnode) return O_Cnode; - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) return O_Cnode; + function New_Global (Decl : O_Dnode) return O_Gnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; + + procedure Get_Global_Decl_Offset (Global : O_Gnode; + Decl : out O_Dnode; Off : out Uns32); + function New_Named_Literal (Atype : O_Tnode; Id : O_Ident; Val : Uns32; Prev : O_Cnode) return O_Cnode; diff --git a/src/ortho/mcode/ortho_code-decls.ads b/src/ortho/mcode/ortho_code-decls.ads index 70a0ba4df..bd84bf2eb 100644 --- a/src/ortho/mcode/ortho_code-decls.ads +++ b/src/ortho/mcode/ortho_code-decls.ads @@ -19,24 +19,27 @@ with Ortho_Code.Abi; package Ortho_Code.Decls is -- Kind of a declaration. - type OD_Kind is (OD_Type, - OD_Const, + type OD_Kind is + ( + OD_Type, + OD_Const, - -- Value of constant, initial value of variable. - OD_Init_Val, + -- Value of constant, initial value of variable. + OD_Init_Val, - -- Global and local variables. - OD_Var, OD_Local, + -- Global and local variables. + OD_Var, OD_Local, - -- Subprograms. - OD_Function, OD_Procedure, + -- Subprograms. + OD_Function, OD_Procedure, - -- Additional node for a subprogram. Internal use only. - OD_Subprg_Ext, + -- Additional node for a subprogram. Internal use only. + OD_Subprg_Ext, - OD_Interface, - OD_Body, - OD_Block); + OD_Interface, + OD_Body, + OD_Block + ); -- Return the kind of declaration DECL. function Get_Decl_Kind (Decl : O_Dnode) return OD_Kind; @@ -126,11 +129,10 @@ package Ortho_Code.Decls is -- This simply gives a name to a constant value or aggregate. -- A constant cannot be modified and its storage cannot be local. -- ATYPE must be constrained. - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); + procedure New_Const_Decl (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode); -- Set the value to DECL. procedure New_Init_Value (Decl : O_Dnode; Val : O_Cnode); @@ -138,11 +140,10 @@ package Ortho_Code.Decls is -- Create a variable declaration. -- A variable can be local only inside a function. -- ATYPE must be constrained. - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); + procedure New_Var_Decl (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode); type O_Inter_List is limited private; @@ -151,23 +152,20 @@ package Ortho_Code.Decls is -- be declared inside a subprograms. It is not allowed to declare -- o_storage_external subprograms inside a subprograms. -- Return type and interfaces cannot be a composite type. - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode); + procedure Start_Function_Decl (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode); -- For a subprogram without return value. - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage); + procedure Start_Procedure_Decl (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage); -- Add an interface declaration to INTERFACES. - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode); + procedure New_Interface_Decl (Interfaces : in out O_Inter_List; + Res : out O_Dnode; + Ident : O_Ident; + Atype : O_Tnode); -- Finish the function declaration, get the node and a statement list. procedure Finish_Subprogram_Decl (Interfaces : in out O_Inter_List; Res : out O_Dnode); diff --git a/src/ortho/mcode/ortho_code-disps.adb b/src/ortho/mcode/ortho_code-disps.adb index d33fe403d..b0b9a353a 100644 --- a/src/ortho/mcode/ortho_code-disps.adb +++ b/src/ortho/mcode/ortho_code-disps.adb @@ -273,18 +273,18 @@ package body Ortho_Code.Disps is begin Op := Get_Expr_Operand (Expr); case Get_Expr_Kind (Op) is - when OE_Addrg + when OE_Addrd | OE_Addrl => - Decls.Disp_Decl_Name (Get_Addr_Object (Op)); + Decls.Disp_Decl_Name (Get_Addr_Decl (Op)); when others => --Put ("*"); Disp_Expr (Op); end case; end; when OE_Addrl - | OE_Addrg => + | OE_Addrd => -- Put ('@'); - Decls.Disp_Decl_Name (Get_Addr_Object (Expr)); + Decls.Disp_Decl_Name (Get_Addr_Decl (Expr)); when OE_Call => Disp_Call (Expr); when OE_Alloca => diff --git a/src/ortho/mcode/ortho_code-exprs.adb b/src/ortho/mcode/ortho_code-exprs.adb index 4e0d6bdc4..fd467e315 100644 --- a/src/ortho/mcode/ortho_code-exprs.adb +++ b/src/ortho/mcode/ortho_code-exprs.adb @@ -160,11 +160,16 @@ package body Ortho_Code.Exprs is Enodes.Table (Enode).Arg2 := Label; end Set_Jump_Label; - function Get_Addr_Object (Enode : O_Enode) return O_Dnode is + function Get_Addr_Object (Enode : O_Enode) return O_Lnode is begin - return O_Dnode (Enodes.Table (Enode).Arg1); + return O_Lnode (Enodes.Table (Enode).Arg1); end Get_Addr_Object; + function Get_Addr_Decl (Enode : O_Enode) return O_Dnode is + begin + return O_Dnode (Enodes.Table (Enode).Arg1); + end Get_Addr_Decl; + function Get_Addrl_Frame (Enode : O_Enode) return O_Enode is begin return Enodes.Table (Enode).Arg2; @@ -492,7 +497,7 @@ package body Ortho_Code.Exprs is Save_Var : O_Dnode; begin Save_Asgn := Get_Stmt_Link (Blk); - Save_Var := Get_Addr_Object (Get_Assign_Target (Save_Asgn)); + Save_Var := Get_Addr_Decl (Get_Assign_Target (Save_Asgn)); New_Enode_Stmt (OE_Set_Stack, New_Value (New_Obj (Save_Var)), O_Enode_Null); end New_Stack_Restore; @@ -696,10 +701,8 @@ package body Ortho_Code.Exprs is function New_Lit (Lit : O_Cnode) return O_Enode is - L_Type : O_Tnode; - H, L : Uns32; + L_Type : constant O_Tnode := Get_Const_Type (Lit); 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 @@ -709,13 +712,18 @@ package body Ortho_Code.Exprs is | 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, + declare + H, L : Uns32; + begin + Get_Const_Bytes (Lit, H, L); + return New_Enode + (OE_Const, L_Type, + O_Enode (To_Int32 (L)), O_Enode (To_Int32 (H))); + end; + when OC_Address => + raise Syntax_Error; + when OC_Subprg_Address => + return New_Enode (OE_Addrd, L_Type, O_Enode (Get_Const_Decl (Lit)), O_Enode_Null); when OC_Array | OC_Record @@ -783,7 +791,7 @@ package body Ortho_Code.Exprs is end if; when OD_Var | OD_Const => - Kind := OE_Addrg; + Kind := OE_Addrd; Chain := O_Enode_Null; when others => raise Program_Error; diff --git a/src/ortho/mcode/ortho_code-exprs.ads b/src/ortho/mcode/ortho_code-exprs.ads index 31931702c..0bb5ec2bb 100644 --- a/src/ortho/mcode/ortho_code-exprs.ads +++ b/src/ortho/mcode/ortho_code-exprs.ads @@ -63,9 +63,9 @@ package Ortho_Code.Exprs is -- ARG1 is object. -- ARG2 is the frame pointer or O_Enode_Null for current frame pointer. OE_Addrl, - -- Address of a global variable. - -- ARG1 is object. - OE_Addrg, + -- Address of a declaration. + -- ARG1 is the declaration. + OE_Addrd, -- Pointer dereference. -- ARG1 is operand. @@ -214,7 +214,6 @@ package Ortho_Code.Exprs is subtype OE_Kind_Dyadic is OE_Kind range OE_Add_Ov .. OE_Xor; subtype OE_Kind_Cmp is OE_Kind range OE_Eq .. OE_Gt; - -- BE representation of an instruction. type O_Insn is mod 256; @@ -329,8 +328,11 @@ package Ortho_Code.Exprs is function Get_Jump_Label (Enode : O_Enode) return O_Enode; procedure Set_Jump_Label (Enode : O_Enode; Label : O_Enode); - -- Get the object of addrl,addrp,addrg - function Get_Addr_Object (Enode : O_Enode) return O_Dnode; + -- Get the declaration of addrl,addrp,addrs + function Get_Addr_Decl (Enode : O_Enode) return O_Dnode; + + -- Get the object of addrg + function Get_Addr_Object (Enode : O_Enode) return O_Lnode; -- Get the computed frame for the object. -- If O_Enode_Null, then use current frame. diff --git a/src/ortho/mcode/ortho_code-types.ads b/src/ortho/mcode/ortho_code-types.ads index da6549841..a9d15b60a 100644 --- a/src/ortho/mcode/ortho_code-types.ads +++ b/src/ortho/mcode/ortho_code-types.ads @@ -24,6 +24,8 @@ package Ortho_Code.Types is -- Optionnal. OT_Complete); + subtype OT_Kinds_Record_Union is OT_Kind range OT_Record .. OT_Union; + -- Kind of ATYPE. function Get_Type_Kind (Atype : O_Tnode) return OT_Kind; @@ -237,4 +239,3 @@ private end record; end Ortho_Code.Types; - diff --git a/src/ortho/mcode/ortho_code-x86-abi.adb b/src/ortho/mcode/ortho_code-x86-abi.adb index d76563a3e..ba9b437d9 100644 --- a/src/ortho/mcode/ortho_code-x86-abi.adb +++ b/src/ortho/mcode/ortho_code-x86-abi.adb @@ -243,7 +243,7 @@ package body Ortho_Code.X86.Abi is is use Ada.Text_IO; use Ortho_Code.Debug.Int32_IO; - Obj : constant O_Dnode := Get_Addr_Object (Stmt); + Obj : constant O_Dnode := Get_Addr_Decl (Stmt); Frame : constant O_Enode := Get_Addrl_Frame (Stmt); begin if Frame = O_Enode_Null then @@ -315,9 +315,9 @@ package body Ortho_Code.X86.Abi is case Kind is when OE_Const => Disp_Const (Stmt); - when OE_Addrg => + when OE_Addrd => Put ("&"); - Disp_Decl_Name (Get_Addr_Object (Stmt)); + Disp_Decl_Name (Get_Addr_Decl (Stmt)); when OE_Add => Disp_Irm_Code (Get_Expr_Left (Stmt)); Put ("+"); @@ -348,9 +348,9 @@ package body Ortho_Code.X86.Abi is Disp_Irm_Code (Get_Expr_Left (Stmt)); Put (" + "); Disp_Irm_Code (Get_Expr_Right (Stmt)); - when OE_Addrg => + when OE_Addrd => Put ("&"); - Disp_Decl_Name (Get_Addr_Object (Stmt)); + Disp_Decl_Name (Get_Addr_Decl (Stmt)); when others => raise Program_Error; end case; @@ -587,10 +587,10 @@ package body Ortho_Code.X86.Abi is Disp_Local (Stmt); Put (")"); New_Line; - when OE_Addrg => - Disp_Reg_Op_Name ("lea{addrg}"); + when OE_Addrd => + Disp_Reg_Op_Name ("lea{addrd}"); Put ("&"); - Disp_Decl_Name (Get_Addr_Object (Stmt)); + Disp_Decl_Name (Get_Addr_Decl (Stmt)); New_Line; when OE_Add => Disp_Reg_Op_Name ("lea{add}"); diff --git a/src/ortho/mcode/ortho_code-x86-emits.adb b/src/ortho/mcode/ortho_code-x86-emits.adb index d26a830f7..cc27a3a23 100644 --- a/src/ortho/mcode/ortho_code-x86-emits.adb +++ b/src/ortho/mcode/ortho_code-x86-emits.adb @@ -277,8 +277,8 @@ package body Ortho_Code.X86.Emits is Off := Off + To_Int32 (Get_Expr_Low (C)); P := S; end loop; - pragma Assert (Get_Expr_Kind (P) = OE_Addrg); - Sym := Get_Decl_Symbol (Get_Addr_Object (P)); + pragma Assert (Get_Expr_Kind (P) = OE_Addrd); + Sym := Get_Decl_Symbol (Get_Addr_Decl (P)); Gen_Abs (Sym, Integer_32 (Off)); end Gen_Imm_Addr; @@ -303,7 +303,7 @@ package body Ortho_Code.X86.Emits is Gen_32 (Unsigned_32 (Get_Expr_Low (N))); end case; when OE_Add - | OE_Addrg => + | OE_Addrd => -- Only for 32-bit immediat. pragma Assert (Sz = Sz_32); Gen_Imm_Addr (N); @@ -470,11 +470,11 @@ package body Ortho_Code.X86.Emits is Rm_Base := Get_Expr_Reg (Frame); end if; end; - Rm_Offset := Rm_Offset + Get_Local_Offset (Get_Addr_Object (N)); - when OE_Addrg => + Rm_Offset := Rm_Offset + Get_Local_Offset (Get_Addr_Decl (N)); + when OE_Addrd => -- Cannot add two symbols. pragma Assert (Rm_Sym = Null_Symbol); - Rm_Sym := Get_Decl_Symbol (Get_Addr_Object (N)); + Rm_Sym := Get_Decl_Symbol (Get_Addr_Decl (N)); when OE_Add => Fill_Sib (Get_Expr_Left (N)); Fill_Sib (Get_Expr_Right (N)); @@ -2525,10 +2525,10 @@ package body Ortho_Code.X86.Emits is -- Result is in eflags. pragma Assert (Get_Expr_Reg (Stmt) in Regs_Cc); end; - when OE_Addrg => + when OE_Addrd => pragma Assert (Mode = Abi.Mode_Ptr); if Flags.M64 - and then not Insns.Is_External_Object (Get_Addr_Object (Stmt)) + and then not Insns.Is_External_Object (Get_Addr_Decl (Stmt)) then -- Use RIP relative to load an address. Emit_Lea (Stmt); @@ -3163,8 +3163,15 @@ package body Ortho_Code.X86.Emits is when others => raise Program_Error; end case; - when OC_Address - | OC_Subprg_Address => + when OC_Address => + declare + Decl : O_Dnode; + Off : Uns32; + begin + Get_Global_Decl_Offset (Get_Const_Global (Val), Decl, Off); + Gen_Abs (Get_Decl_Symbol (Decl), Integer_32 (To_Int32 (Off))); + end; + when OC_Subprg_Address => Gen_Abs (Get_Decl_Symbol (Get_Const_Decl (Val)), 0); when OC_Array => for I in 0 .. Get_Const_Aggr_Length (Val) - 1 loop diff --git a/src/ortho/mcode/ortho_code-x86-insns.adb b/src/ortho/mcode/ortho_code-x86-insns.adb index acdcc7746..5429df016 100644 --- a/src/ortho/mcode/ortho_code-x86-insns.adb +++ b/src/ortho/mcode/ortho_code-x86-insns.adb @@ -848,7 +848,7 @@ package body Ortho_Code.X86.Insns is Set_Addrl_Frame (Expr, Reload (Spill, R_Any32, Num)); end if; return Expr; - when OE_Addrg => + when OE_Addrd => return Expr; when others => Error_Reg ("reload: unhandle expr in b_off", Expr, Dest); @@ -938,7 +938,7 @@ package body Ortho_Code.X86.Insns is if Get_Addrl_Frame (Insn) /= O_Enode_Null then Free_Insn_Regs (Get_Addrl_Frame (Insn)); end if; - when OE_Addrg => + when OE_Addrd => -- RIP-relative, no reg to free. null; when others => @@ -1358,11 +1358,11 @@ package body Ortho_Code.X86.Insns is when others => Error_Gen_Insn (Stmt, Reg); end case; - when OE_Addrg => + when OE_Addrd => if Flags.M64 then -- Use RIP-Relative addressing. if Reg = R_Sib - and then not Is_External_Object (Get_Addr_Object (Stmt)) + and then not Is_External_Object (Get_Addr_Decl (Stmt)) then Set_Expr_Reg (Stmt, R_Sib); else diff --git a/src/ortho/mcode/ortho_code.ads b/src/ortho/mcode/ortho_code.ads index 0657b07e6..489eeeccf 100644 --- a/src/ortho/mcode/ortho_code.ads +++ b/src/ortho/mcode/ortho_code.ads @@ -65,6 +65,10 @@ package Ortho_Code is for O_Lnode'Size use 32; O_Lnode_Null : constant O_Lnode := 0; + type O_Gnode is new Int32; + for O_Gnode'Size use 32; + O_Gnode_Null : constant O_Gnode := 0; + type O_Ident is new Int32; O_Ident_Nul : constant O_Ident := 0; diff --git a/src/ortho/mcode/ortho_mcode.adb b/src/ortho/mcode/ortho_mcode.adb index fac45e438..16638300d 100644 --- a/src/ortho/mcode/ortho_mcode.adb +++ b/src/ortho/mcode/ortho_mcode.adb @@ -347,22 +347,36 @@ package body Ortho_Mcode is (Ortho_Code.O_Dnode (Subprg), Ortho_Code.O_Tnode (Atype))); end New_Subprogram_Address; - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode is + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is begin return O_Cnode (Ortho_Code.Consts.New_Global_Address - (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype))); + (Ortho_Code.O_Gnode (Lvalue), Ortho_Code.O_Tnode (Atype))); end New_Global_Address; - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is begin return O_Cnode (Ortho_Code.Consts.New_Global_Unchecked_Address - (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype))); + (Ortho_Code.O_Gnode (Lvalue), Ortho_Code.O_Tnode (Atype))); end New_Global_Unchecked_Address; + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + return O_Gnode + (Ortho_Code.Consts.New_Global (Ortho_Code.O_Dnode (Decl))); + end New_Global; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode is + begin + return O_Gnode + (Ortho_Code.Consts.New_Global_Selected_Element + (Ortho_Code.O_Gnode (Rec), Ortho_Code.O_Fnode (El))); + end New_Global_Selected_Element; + function New_Lit (Lit : O_Cnode) return O_Enode is begin return O_Enode (Ortho_Code.Exprs.New_Lit (Ortho_Code.O_Cnode (Lit))); diff --git a/src/ortho/mcode/ortho_mcode.ads b/src/ortho/mcode/ortho_mcode.ads index dda220f1c..515242561 100644 --- a/src/ortho/mcode/ortho_mcode.ads +++ b/src/ortho/mcode/ortho_mcode.ads @@ -41,10 +41,12 @@ package Ortho_Mcode is type O_Tnode is private; type O_Snode is private; type O_Dnode is private; + type O_Gnode is private; type O_Fnode is private; O_Cnode_Null : constant O_Cnode; O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; O_Enode_Null : constant O_Enode; O_Fnode_Null : constant O_Fnode; O_Lnode_Null : constant O_Lnode; @@ -190,17 +192,17 @@ package Ortho_Mcode is -- Get the address of a subprogram. function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; + return O_Cnode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; ------------------- -- Expressions -- @@ -299,12 +301,15 @@ package Ortho_Mcode is -- 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; + return O_Lnode; -- Get an element of a record or a union. -- Type of REC must be a record or a union type. function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; -- Reference an access. -- Type of ACC must be an access type. @@ -331,6 +336,9 @@ package Ortho_Mcode is -- Get an lvalue from a declaration. function New_Obj (Obj : O_Dnode) return O_Lnode; + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; @@ -476,9 +484,11 @@ private type O_Enode is new Ortho_Code.O_Enode; type O_Fnode is new Ortho_Code.O_Fnode; type O_Lnode is new Ortho_Code.O_Lnode; + type O_Gnode is new Ortho_Code.O_Gnode; type O_Snode is new Ortho_Code.Exprs.O_Snode; O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null); + O_Gnode_Null : constant O_Gnode := O_Gnode (Ortho_Code.O_Gnode_Null); O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null); O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null); O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null); diff --git a/src/ortho/mcode/ortho_mcode.private.ads b/src/ortho/mcode/ortho_mcode.private.ads index 5374ae978..a78a1a170 100644 --- a/src/ortho/mcode/ortho_mcode.private.ads +++ b/src/ortho/mcode/ortho_mcode.private.ads @@ -40,9 +40,11 @@ private type O_Enode is new Ortho_Code.O_Enode; type O_Fnode is new Ortho_Code.O_Fnode; type O_Lnode is new Ortho_Code.O_Lnode; + type O_Gnode is new Ortho_Code.O_Gnode; type O_Snode is new Ortho_Code.Exprs.O_Snode; O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null); + O_Gnode_Null : constant O_Gnode := O_Gnode (Ortho_Code.O_Gnode_Null); O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null); O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null); O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null); diff --git a/src/ortho/oread/ortho_front.adb b/src/ortho/oread/ortho_front.adb index 13fdc77ae..b3d9d3a08 100644 --- a/src/ortho/oread/ortho_front.adb +++ b/src/ortho/oread/ortho_front.adb @@ -1842,9 +1842,15 @@ package body Ortho_Front is end case; end Parse_Expression; + procedure Check_Selected_Prefix (N_Type : Node_Acc) is + begin + if N_Type.Kind /= Type_Record and N_Type.Kind /= Type_Union then + Parse_Error ("type of prefix is neither a record nor an union"); + end if; + end Check_Selected_Prefix; + -- Expect and leave: next token - procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc) - is + procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc) is begin loop case Tok is @@ -1858,11 +1864,7 @@ package body Ortho_Front is N_Type := N_Type.Access_Dtype; Next_Token; elsif Tok = Tok_Ident then - if N_Type.Kind /= Type_Record and N_Type.Kind /= Type_Union - then - Parse_Error - ("type of prefix is neither a record nor an union"); - end if; + Check_Selected_Prefix (N_Type); declare Field : Node_Acc; begin @@ -2501,12 +2503,50 @@ package body Ortho_Front is return Res; end Parse_Address; + procedure Parse_Global_Name (Prefix : Node_Acc; + Name : out O_Gnode; N_Type : out Node_Acc) + is + begin + case Prefix.Kind is + when Node_Object => + Name := New_Global (Prefix.Obj_Node); + N_Type := Prefix.Decl_Dtype; + when others => + Parse_Error ("invalid name"); + end case; + + loop + case Tok is + when Tok_Dot => + Next_Token; + if Tok = Tok_Ident then + Check_Selected_Prefix (N_Type); + declare + Field : Node_Acc; + begin + Field := Find_Field_By_Name (N_Type); + Name := New_Global_Selected_Element (Name, + Field.Field_Fnode); + N_Type := Field.Field_Type; + Next_Token; + end; + else + Parse_Error ("'.' must be followed by a field name"); + end if; + when others => + return; + end case; + end loop; + end Parse_Global_Name; + function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode is Pfx : Node_Acc; Res : O_Cnode; Attr : Syment_Acc; T : O_Tnode; + N : O_Gnode; + N_Type : Node_Acc; begin Attr := Token_Sym; Next_Expect (Tok_Left_Paren); @@ -2523,10 +2563,11 @@ package body Ortho_Front is Next_Token; else Next_Token; + Parse_Global_Name (Pfx, N, N_Type); if Attr = Id_Address then - Res := New_Global_Address (Pfx.Obj_Node, T); + Res := New_Global_Address (N, T); elsif Attr = Id_Unchecked_Address then - Res := New_Global_Unchecked_Address (Pfx.Obj_Node, T); + Res := New_Global_Unchecked_Address (N, T); else Parse_Error ("address attribute expected"); end if; diff --git a/src/ortho/ortho_nodes.common.ads b/src/ortho/ortho_nodes.common.ads index d0f22b720..30e44d6fd 100644 --- a/src/ortho/ortho_nodes.common.ads +++ b/src/ortho/ortho_nodes.common.ads @@ -28,10 +28,12 @@ package ORTHO_NODES is type O_Tnode is private; type O_Snode is private; type O_Dnode is private; + type O_Gnode is private; type O_Fnode is private; O_Cnode_Null : constant O_Cnode; O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; O_Enode_Null : constant O_Enode; O_Fnode_Null : constant O_Fnode; O_Lnode_Null : constant O_Lnode; @@ -177,17 +179,17 @@ package ORTHO_NODES is -- Get the address of a subprogram. function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; + return O_Cnode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; ------------------- -- Expressions -- @@ -286,12 +288,15 @@ package ORTHO_NODES is -- 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; + return O_Lnode; -- Get an element of a record or a union. -- Type of REC must be a record or a union type. function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; -- Reference an access. -- Type of ACC must be an access type. @@ -318,6 +323,9 @@ package ORTHO_NODES is -- Get an lvalue from a declaration. function New_Obj (Obj : O_Dnode) return O_Lnode; + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; |