-- LLVM back-end for ortho. -- Copyright (C) 2014 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.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with LLVM.Target; use LLVM.Target; package body Ortho_LLVM is -- The current function for LLVM (needed to add new basic blocks). Cur_Func : ValueRef; -- The current function node (needed for return type). Cur_Func_Decl : O_Dnode; -- Wether the code is currently unreachable. LLVM doesn't accept basic -- blocks that cannot be reached (using trivial rules). So we need to -- discard instructions after a return, a next or an exit statement. Unreach : Boolean; -- Builder for statements. Builder : BuilderRef; -- Builder for declarations (local variables). Decl_Builder : BuilderRef; -- Temporary builder. Extra_Builder : BuilderRef; -- Additional data for declare blocks. type Declare_Block_Type; type Declare_Block_Acc is access Declare_Block_Type; type Declare_Block_Type is record -- First basic block of the declare. Stmt_Bb : BasicBlockRef; -- Stack pointer at entry of the block. This value has to be restore -- when leaving the block (either normally or via exit/next). Set only -- if New_Alloca was used. -- FIXME: TODO: restore stack pointer on exit/next stmts. Stack_Value : ValueRef; -- Debug data for the scope of the declare block. Dbg_Scope : ValueRef; -- Previous element in the stack. Prev : Declare_Block_Acc; end record; -- Current declare block. Cur_Declare_Block : Declare_Block_Acc; -- Chain of unused blocks to be recycled. Old_Declare_Block : Declare_Block_Acc; Stacksave_Fun : ValueRef; Stacksave_Name : constant String := "llvm.stacksave" & ASCII.NUL; Stackrestore_Fun : ValueRef; Stackrestore_Name : constant String := "llvm.stackrestore" & ASCII.NUL; Copysign_Fun : ValueRef; Copysign_Name : constant String := "llvm.copysign.f64" & ASCII.NUL; Fp_0_5 : ValueRef; Nounwind_Attr : AttributeRef; Uwtable_Attr : AttributeRef; procedure Free is new Ada.Unchecked_Deallocation (ValueRefArray, ValueRefArray_Acc); procedure Create_Declare_Block is Res : Declare_Block_Acc; begin -- Try to recycle an unused record. if Old_Declare_Block /= null then Res := Old_Declare_Block; Old_Declare_Block := Res.Prev; else -- Create a new one if no unused records. Res := new Declare_Block_Type; end if; -- Chain. Res.all := (Stmt_Bb => Null_BasicBlockRef, Stack_Value => Null_ValueRef, Dbg_Scope => Null_ValueRef, Prev => Cur_Declare_Block); Cur_Declare_Block := Res; if not Unreach then Res.Stmt_Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); end if; end Create_Declare_Block; procedure Destroy_Declare_Block is Blk : constant Declare_Block_Acc := Cur_Declare_Block; begin -- Unchain. Cur_Declare_Block := Blk.Prev; -- Put on the recyle list. Blk.Prev := Old_Declare_Block; Old_Declare_Block := Blk; end Destroy_Declare_Block; ----------------------- -- Start_Record_Type -- ----------------------- procedure Start_Record_Type (Elements : out O_Element_List) is begin Elements := (Kind => OF_Record, Nbr_Elements => 0, Rec_Type => O_Tnode_Null, Size => 0, Align => 0, Align_Type => Null_TypeRef, First_Elem => null, Last_Elem => null); end Start_Record_Type; ---------------------- -- New_Record_Field -- ---------------------- procedure Add_Field (Elements : in out O_Element_List; Ident : O_Ident; Etype : O_Tnode) is O_El : O_Element_Acc; begin Elements.Nbr_Elements := Elements.Nbr_Elements + 1; O_El := new O_Element'(Next => null, Etype => Etype, Ident => Ident); if Elements.First_Elem = null then Elements.First_Elem := O_El; else Elements.Last_Elem.Next := O_El; end if; Elements.Last_Elem := O_El; end Add_Field; procedure New_Record_Field (Elements : in out O_Element_List; El : out O_Fnode; Ident : O_Ident; Etype : O_Tnode) is begin El := (Kind => OF_Record, Index => Elements.Nbr_Elements, Ftype => Etype); Add_Field (Elements, Ident, Etype); end New_Record_Field; ------------------------ -- Finish_Record_Type -- ------------------------ procedure Free_Elements (Elements : in out O_Element_List) is procedure Free is new Ada.Unchecked_Deallocation (O_Element, O_Element_Acc); El : O_Element_Acc; Next_El : O_Element_Acc; begin -- Free elements El := Elements.First_Elem; while El /= null loop Next_El := El.Next; Free (El); El := Next_El; end loop; Elements.First_Elem := null; Elements.Last_Elem := null; end Free_Elements; procedure Finish_Record_Type (Elements : in out O_Element_List; Res : out O_Tnode) is Count : constant unsigned := unsigned (Elements.Nbr_Elements); El : O_Element_Acc; Types : TypeRefArray (1 .. Count); begin El := Elements.First_Elem; for I in Types'Range loop Types (I) := Get_LLVM_Type (El.Etype); El := El.Next; end loop; if Elements.Rec_Type /= null then -- Completion StructSetBody (Elements.Rec_Type.LLVM, Types, Count, 0); Res := Elements.Rec_Type; else Res := new O_Tnode_Type'(Kind => ON_Record_Type, LLVM => StructType (Types, Count, 0), Dbg => Null_ValueRef); end if; Free_Elements (Elements); end Finish_Record_Type; -------------------------------- -- New_Uncomplete_Record_Type -- -------------------------------- procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is begin -- LLVM type will be created when the type is declared, as the name -- is required (for unification). Res := new O_Tnode_Type'(Kind => ON_Incomplete_Record_Type, LLVM => Null_TypeRef, Dbg => Null_ValueRef); end New_Uncomplete_Record_Type; ---------------------------------- -- Start_Uncomplete_Record_Type -- ---------------------------------- procedure Start_Uncomplete_Record_Type (Res : O_Tnode; Elements : out O_Element_List) is begin if Res.Kind /= ON_Incomplete_Record_Type then raise Program_Error; end if; Elements := (Kind => OF_Record, Nbr_Elements => 0, Rec_Type => Res, Size => 0, Align => 0, Align_Type => Null_TypeRef, First_Elem => null, Last_Elem => null); end Start_Uncomplete_Record_Type; ---------------------- -- Start_Union_Type -- ---------------------- procedure Start_Union_Type (Elements : out O_Element_List) is begin Elements := (Kind => OF_Union, Nbr_Elements => 0, Rec_Type => O_Tnode_Null, Size => 0, Align => 0, Align_Type => Null_TypeRef, First_Elem => null, Last_Elem => null); end Start_Union_Type; --------------------- -- New_Union_Field -- --------------------- procedure New_Union_Field (Elements : in out O_Element_List; El : out O_Fnode; Ident : O_Ident; Etype : O_Tnode) is El_Type : constant TypeRef := Get_LLVM_Type (Etype); Size : constant unsigned := unsigned (ABISizeOfType (Target_Data, El_Type)); Align : constant Unsigned_32 := ABIAlignmentOfType (Target_Data, El_Type); begin El := (Kind => OF_Union, Ftype => Etype, Utype => El_Type, Ptr_Type => PointerType (El_Type)); if Size > Elements.Size then Elements.Size := Size; end if; if Elements.Align_Type = Null_TypeRef or else Align > Elements.Align then Elements.Align := Align; Elements.Align_Type := El_Type; end if; Add_Field (Elements, Ident, Etype); end New_Union_Field; ----------------------- -- Finish_Union_Type -- ----------------------- procedure Finish_Union_Type (Elements : in out O_Element_List; Res : out O_Tnode) is Count : unsigned; Types : TypeRefArray (1 .. 2); Pad : unsigned; begin if Elements.Align_Type = Null_TypeRef then -- An empty union. Is it allowed ? Count := 0; else -- The first element is the field with the biggest alignment Types (1) := Elements.Align_Type; -- Possibly complete with an array of bytes. Pad := Elements.Size - unsigned (ABISizeOfType (Target_Data, Elements.Align_Type)); if Pad /= 0 then Types (2) := ArrayType (Int8Type, Pad); Count := 2; else Count := 1; end if; end if; Res := new O_Tnode_Type'(Kind => ON_Union_Type, LLVM => StructType (Types, Count, 0), Dbg => Null_ValueRef, Un_Size => Elements.Size, Un_Main_Field => Elements.Align_Type); Free_Elements (Elements); end Finish_Union_Type; --------------------- -- New_Access_Type -- --------------------- function New_Access_Type (Dtype : O_Tnode) return O_Tnode is begin if Dtype = O_Tnode_Null then -- LLVM type will be built by New_Type_Decl, so that the name -- can be used for the structure. return new O_Tnode_Type'(Kind => ON_Incomplete_Access_Type, LLVM => Null_TypeRef, Dbg => Null_ValueRef, Acc_Type => O_Tnode_Null); else return new O_Tnode_Type'(Kind => ON_Access_Type, LLVM => PointerType (Get_LLVM_Type (Dtype)), Dbg => Null_ValueRef, Acc_Type => Dtype); end if; end New_Access_Type; ------------------------ -- Finish_Access_Type -- ------------------------ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is Types : TypeRefArray (1 .. 1); begin if Atype.Kind /= ON_Incomplete_Access_Type then -- Not an incomplete access type. raise Program_Error; end if; if Atype.Acc_Type /= O_Tnode_Null then -- Already completed. raise Program_Error; end if; -- Completion Types (1) := Get_LLVM_Type (Dtype); StructSetBody (GetElementType (Atype.LLVM), Types, Types'Length, 0); Atype.Acc_Type := Dtype; end Finish_Access_Type; -------------------- -- New_Array_Type -- -------------------- function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) return O_Tnode is pragma Unreferenced (Index_Type); Res : O_Tnode; begin Res := new O_Tnode_Type' (Kind => ON_Array_Type, LLVM => ArrayType (Get_LLVM_Type (El_Type), 0), Dbg => Null_ValueRef, Arr_El_Type => El_Type); return Res; end New_Array_Type; -------------------------------- -- New_Constrained_Array_Type -- -------------------------------- function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) return O_Tnode is Res : O_Tnode; Len : constant unsigned := unsigned (ConstIntGetZExtValue (Length.LLVM)); begin Res := new O_Tnode_Type' (Kind => ON_Array_Sub_Type, LLVM => ArrayType (GetElementType (Get_LLVM_Type (Atype)), Len), Dbg => Null_ValueRef, Arr_El_Type => Atype.Arr_El_Type); return Res; end New_Constrained_Array_Type; ----------------------- -- New_Unsigned_Type -- ----------------------- function Size_To_Llvm (Size : Natural) return TypeRef is Llvm : TypeRef; begin case Size is when 8 => Llvm := Int8Type; when 32 => Llvm := Int32Type; when 64 => Llvm := Int64Type; when others => raise Program_Error; end case; return Llvm; end Size_To_Llvm; function New_Unsigned_Type (Size : Natural) return O_Tnode is begin return new O_Tnode_Type'(Kind => ON_Unsigned_Type, LLVM => Size_To_Llvm (Size), Dbg => Null_ValueRef, Scal_Size => Size); end New_Unsigned_Type; --------------------- -- New_Signed_Type -- --------------------- function New_Signed_Type (Size : Natural) return O_Tnode is begin return new O_Tnode_Type'(Kind => ON_Signed_Type, LLVM => Size_To_Llvm (Size), Dbg => Null_ValueRef, Scal_Size => Size); end New_Signed_Type; -------------------- -- New_Float_Type -- -------------------- function New_Float_Type return O_Tnode is begin return new O_Tnode_Type'(Kind => ON_Float_Type, LLVM => DoubleType, Dbg => Null_ValueRef, Scal_Size => 64); end New_Float_Type; ---------------------- -- New_Boolean_Type -- ---------------------- procedure New_Boolean_Type (Res : out O_Tnode; False_Id : O_Ident; False_E : out O_Cnode; True_Id : O_Ident; True_E : out O_Cnode) is pragma Unreferenced (False_Id, True_Id); begin Res := new O_Tnode_Type'(Kind => ON_Boolean_Type, LLVM => Int1Type, Dbg => Null_ValueRef, Scal_Size => 1); False_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 0, 0), Ctype => Res); True_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 1, 0), Ctype => Res); end New_Boolean_Type; --------------------- -- Start_Enum_Type -- --------------------- procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) is LLVM : constant TypeRef := Size_To_Llvm (Size); begin List := (LLVM => LLVM, Num => 0, Etype => new O_Tnode_Type'(Kind => ON_Enum_Type, LLVM => LLVM, Scal_Size => Size, Dbg => Null_ValueRef)); end Start_Enum_Type; ---------------------- -- New_Enum_Literal -- ---------------------- procedure New_Enum_Literal (List : in out O_Enum_List; Ident : O_Ident; Res : out O_Cnode) is pragma Unreferenced (Ident); begin Res := O_Cnode'(LLVM => ConstInt (List.LLVM, Unsigned_64 (List.Num), 0), Ctype => List.Etype); List.Num := List.Num + 1; end New_Enum_Literal; ---------------------- -- Finish_Enum_Type -- ---------------------- procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is begin Res := List.Etype; end Finish_Enum_Type; ------------------------ -- New_Signed_Literal -- ------------------------ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) return O_Cnode is function To_Unsigned_64 is new Ada.Unchecked_Conversion (Integer_64, Unsigned_64); begin return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype), To_Unsigned_64 (Value), 1), Ctype => Ltype); end New_Signed_Literal; -------------------------- -- New_Unsigned_Literal -- -------------------------- function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) return O_Cnode is begin return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype), Value, 0), Ctype => Ltype); end New_Unsigned_Literal; ----------------------- -- New_Float_Literal -- ----------------------- function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) return O_Cnode is begin return O_Cnode'(LLVM => ConstReal (Get_LLVM_Type (Ltype), Interfaces.C.double (Value)), Ctype => Ltype); end New_Float_Literal; --------------------- -- New_Null_Access -- --------------------- function New_Null_Access (Ltype : O_Tnode) return O_Cnode is begin return O_Cnode'(LLVM => ConstNull (Get_LLVM_Type (Ltype)), Ctype => Ltype); end New_Null_Access; ----------------------- -- Start_Record_Aggr -- ----------------------- procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode) is Llvm : constant TypeRef := Get_LLVM_Type (Atype); begin List := (Len => 0, Vals => new ValueRefArray (1 .. CountStructElementTypes (Llvm)), Atype => Atype); end Start_Record_Aggr; ------------------------ -- New_Record_Aggr_El -- ------------------------ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; Value : O_Cnode) is begin List.Len := List.Len + 1; List.Vals (List.Len) := Value.LLVM; end New_Record_Aggr_El; ------------------------ -- Finish_Record_Aggr -- ------------------------ procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; Res : out O_Cnode) is V : ValueRef; begin if List.Atype.Kind = ON_Incomplete_Record_Type then V := ConstNamedStruct (Get_LLVM_Type (List.Atype), List.Vals.all, List.Len); else V := ConstStruct (List.Vals.all, List.Len, 0); end if; Res := (LLVM => V, Ctype => List.Atype); Free (List.Vals); end Finish_Record_Aggr; ---------------------- -- Start_Array_Aggr -- ---------------------- procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) is Llvm : constant TypeRef := Get_LLVM_Type (Atype); begin List := (Len => 0, Vals => new ValueRefArray (1 .. GetArrayLength (Llvm)), El_Type => GetElementType (Llvm), Atype => Atype); end Start_Array_Aggr; ----------------------- -- New_Array_Aggr_El -- ----------------------- procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; Value : O_Cnode) is begin List.Len := List.Len + 1; List.Vals (List.Len) := Value.LLVM; end New_Array_Aggr_El; ----------------------- -- Finish_Array_Aggr -- ----------------------- procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; Res : out O_Cnode) is begin Res := (LLVM => ConstArray (List.El_Type, List.Vals.all, List.Len), Ctype => List.Atype); Free (List.Vals); end Finish_Array_Aggr; -------------------- -- New_Union_Aggr -- -------------------- function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) return O_Cnode is Values : ValueRefArray (1 .. 2); Count : unsigned; Size : constant unsigned := unsigned (ABISizeOfType (Target_Data, Field.Utype)); begin Values (1) := Value.LLVM; if Size < Atype.Un_Size then Values (2) := GetUndef (ArrayType (Int8Type, Atype.Un_Size - Size)); Count := 2; else Count := 1; end if; -- If `FIELD` is the main field of the union, create a struct using -- the same type as the union (and possibly pad). if Field.Utype = Atype.Un_Main_Field then return O_Cnode' (LLVM => ConstNamedStruct (Atype.LLVM, Values, Count), Ctype => Atype); else -- Create an on-the-fly record. return O_Cnode'(LLVM => ConstStruct (Values, Count, 0), Ctype => Atype); end if; end New_Union_Aggr; ----------------------- -- New_Default_Value -- ----------------------- function New_Default_Value (Ltype : O_Tnode) return O_Cnode is begin return O_Cnode'(LLVM => ConstNull (Ltype.LLVM), Ctype => Ltype); end New_Default_Value; ---------------- -- New_Sizeof -- ---------------- -- Return VAL with type RTYPE (either unsigned or access) function Const_To_Cnode (Rtype : O_Tnode; Val : Unsigned_64) return O_Cnode is Tmp : ValueRef; begin case Rtype.Kind is when ON_Scalar_Types => -- Well, unsigned in fact. return O_Cnode'(LLVM => ConstInt (Rtype.LLVM, Val, 0), Ctype => Rtype); when ON_Access_Type => Tmp := ConstInt (Int64Type, Val, 0); return O_Cnode'(LLVM => ConstIntToPtr (Tmp, Rtype.LLVM), Ctype => Rtype); when others => raise Program_Error; end case; end Const_To_Cnode; function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is begin return Const_To_Cnode (Rtype, ABISizeOfType (Target_Data, Get_LLVM_Type (Atype))); end New_Sizeof; ----------------- -- New_Alignof -- ----------------- function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is begin return Const_To_Cnode (Rtype, Unsigned_64 (ABIAlignmentOfType (Target_Data, Get_LLVM_Type (Atype)))); end New_Alignof; ------------------ -- New_Offsetof -- ------------------ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) return O_Cnode is begin return Const_To_Cnode (Rtype, OffsetOfElement (Target_Data, Get_LLVM_Type (Atype), Unsigned_32 (Field.Index))); end New_Offsetof; ---------------------------- -- New_Subprogram_Address -- ---------------------------- function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) return O_Cnode is begin return O_Cnode' (LLVM => ConstBitCast (Subprg.LLVM, Get_LLVM_Type (Atype)), Ctype => Atype); end New_Subprogram_Address; ------------------------ -- New_Global_Address -- ------------------------ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode is begin return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), Ctype => Atype); end New_Global_Address; ---------------------------------- -- New_Global_Unchecked_Address -- ---------------------------------- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode is begin return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), Ctype => Atype); end New_Global_Unchecked_Address; ------------- -- New_Lit -- ------------- function New_Lit (Lit : O_Cnode) return O_Enode is begin return O_Enode'(LLVM => Lit.LLVM, Etype => Lit.Ctype); end New_Lit; ------------------- -- New_Dyadic_Op -- ------------------- function New_Smod (L, R : ValueRef; Res_Type : TypeRef) return ValueRef is Cond : ValueRef; Br : ValueRef; pragma Unreferenced (Br); -- The result of 'L rem R'. Rm : ValueRef; -- Rm + R Rm_Plus_R : ValueRef; -- The result of 'L xor R'. R_Xor : ValueRef; Adj : ValueRef; Phi : ValueRef; -- Basic basic for the non-overflow branch Normal_Bb : constant BasicBlockRef := AppendBasicBlock (Cur_Func, Empty_Cstring); Adjust_Bb : constant BasicBlockRef := AppendBasicBlock (Cur_Func, Empty_Cstring); -- Basic block after the result Next_Bb : constant BasicBlockRef := AppendBasicBlock (Cur_Func, Empty_Cstring); Vals : ValueRefArray (1 .. 3); BBs : BasicBlockRefArray (1 .. 3); begin -- Avoid overflow with -1: -- if R = -1 then -- result := 0; -- else -- ... Cond := BuildICmp (Builder, IntEQ, R, ConstAllOnes (Res_Type), Empty_Cstring); Br := BuildCondBr (Builder, Cond, Next_Bb, Normal_Bb); Vals (1) := ConstNull (Res_Type); BBs (1) := GetInsertBlock (Builder); -- Rm := Left rem Right PositionBuilderAtEnd (Builder, Normal_Bb); Rm := BuildSRem (Builder, L, R, Empty_Cstring); -- if Rm = 0 then -- result := 0 -- else Cond := BuildICmp (Builder, IntEQ, Rm, ConstNull (Res_Type), Empty_Cstring); Br := BuildCondBr (Builder, Cond, Next_Bb, Adjust_Bb); Vals (2) := ConstNull (Res_Type); BBs (2) := Normal_Bb; -- if (L xor R) < 0 then -- result := Rm + R -- else -- result := Rm; -- end if; PositionBuilderAtEnd (Builder, Adjust_Bb); R_Xor := BuildXor (Builder, L, R, Empty_Cstring); Cond := BuildICmp (Builder, IntSLT, R_Xor, ConstNull (Res_Type), Empty_Cstring); Rm_Plus_R := BuildAdd (Builder, Rm, R, Empty_Cstring); Adj := BuildSelect (Builder, Cond, Rm_Plus_R, Rm, Empty_Cstring); Br := BuildBr (Builder, Next_Bb); Vals (3) := Adj; BBs (3) := Adjust_Bb; -- The Phi node PositionBuilderAtEnd (Builder, Next_Bb); Phi := BuildPhi (Builder, Res_Type, Empty_Cstring); AddIncoming (Phi, Vals, BBs, Vals'Length); return Phi; end New_Smod; type Dyadic_Builder_Acc is access function (Builder : BuilderRef; LHS : ValueRef; RHS : ValueRef; Name : Cstring) return ValueRef; pragma Convention (C, Dyadic_Builder_Acc); function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) return O_Enode is Build : Dyadic_Builder_Acc := null; Res : ValueRef := Null_ValueRef; begin if Unreach then return O_Enode'(LLVM => Null_ValueRef, Etype => Left.Etype); end if; case Left.Etype.Kind is when ON_Integer_Types => case Kind is when ON_And => Build := BuildAnd'Access; when ON_Or => Build := BuildOr'Access; when ON_Xor => Build := BuildXor'Access; when ON_Add_Ov => Build := BuildAdd'Access; when ON_Sub_Ov => Build := BuildSub'Access; when ON_Mul_Ov => Build := BuildMul'Access; when ON_Div_Ov => case Left.Etype.Kind is when ON_Unsigned_Type => Build := BuildUDiv'Access; when ON_Signed_Type => Build := BuildSDiv'Access; when others => null; end case; when ON_Mod_Ov | ON_Rem_Ov => -- FIXME... case Left.Etype.Kind is when ON_Unsigned_Type => Build := BuildURem'Access; when ON_Signed_Type => if Kind = ON_Rem_Ov then Build := BuildSRem'Access; else Res := New_Smod (Left.LLVM, Right.LLVM, Left.Etype.LLVM); end if; when others => null; end case; end case; when ON_Float_Type => case Kind is when ON_Add_Ov => Build := BuildFAdd'Access; when ON_Sub_Ov => Build := BuildFSub'Access; when ON_Mul_Ov => Build := BuildFMul'Access; when ON_Div_Ov => Build := BuildFDiv'Access; when others => null; end case; when others => null; end case; if Build /= null then pragma Assert (Res = Null_ValueRef); Res := Build.all (Builder, Left.LLVM, Right.LLVM, Empty_Cstring); end if; if Res = Null_ValueRef then raise Program_Error with "Unimplemented New_Dyadic_Op " & ON_Dyadic_Op_Kind'Image (Kind) & " for type " & ON_Type_Kind'Image (Left.Etype.Kind); end if; return O_Enode'(LLVM => Res, Etype => Left.Etype); end New_Dyadic_Op; -------------------- -- New_Monadic_Op -- -------------------- function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) return O_Enode is Res : ValueRef; begin if Unreach then return O_Enode'(LLVM => Null_ValueRef, Etype => Operand.Etype); end if; case Operand.Etype.Kind is when ON_Integer_Types => case Kind is when ON_Not => Res := BuildNot (Builder, Operand.LLVM, Empty_Cstring); when ON_Neg_Ov => Res := BuildNeg (Builder, Operand.LLVM, Empty_Cstring); when ON_Abs_Ov => Res := BuildSelect (Builder, BuildICmp (Builder, IntSLT, Operand.LLVM, ConstInt (Get_LLVM_Type (Operand.Etype), 0, 0), Empty_Cstring), BuildNeg (Builder, Operand.LLVM, Empty_Cstring), Operand.LLVM, Empty_Cstring); end case; when ON_Float_Type => case Kind is when ON_Not => raise Program_Error; when ON_Neg_Ov => Res := BuildFNeg (Builder, Operand.LLVM, Empty_Cstring); when ON_Abs_Ov => Res := BuildSelect (Builder, BuildFCmp (Builder, RealOLT, Operand.LLVM, ConstReal (Get_LLVM_Type (Operand.Etype), 0.0), Empty_Cstring), BuildFNeg (Builder, Operand.LLVM, Empty_Cstring), Operand.LLVM, Empty_Cstring); end case; when others => raise Program_Error; end case; return O_Enode'(LLVM => Res, Etype => Operand.Etype); end New_Monadic_Op; -------------------- -- New_Compare_Op -- -------------------- type Compare_Op_Entry is record Signed_Pred : IntPredicate; Unsigned_Pred : IntPredicate; Real_Pred : RealPredicate; end record; type Compare_Op_Table_Type is array (ON_Compare_Op_Kind) of Compare_Op_Entry; Compare_Op_Table : constant Compare_Op_Table_Type := (ON_Eq => (IntEQ, IntEQ, RealOEQ), ON_Neq => (IntNE, IntNE, RealONE), ON_Le => (IntSLE, IntULE, RealOLE), ON_Lt => (IntSLT, IntULT, RealOLT), ON_Ge => (IntSGE, IntUGE, RealOGE), ON_Gt => (IntSGT, IntUGT, RealOGT)); function New_Compare_Op (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) return O_Enode is Res : ValueRef; begin if Unreach then return O_Enode'(LLVM => Null_ValueRef, Etype => Ntype); end if; case Left.Etype.Kind is when ON_Unsigned_Type | ON_Boolean_Type | ON_Enum_Type | ON_Access_Type | ON_Incomplete_Access_Type => Res := BuildICmp (Builder, Compare_Op_Table (Kind).Unsigned_Pred, Left.LLVM, Right.LLVM, Empty_Cstring); when ON_Signed_Type => Res := BuildICmp (Builder, Compare_Op_Table (Kind).Signed_Pred, Left.LLVM, Right.LLVM, Empty_Cstring); when ON_Float_Type => Res := BuildFCmp (Builder, Compare_Op_Table (Kind).Real_Pred, Left.LLVM, Right.LLVM, Empty_Cstring); when ON_Array_Type | ON_Array_Sub_Type | ON_Record_Type | ON_Incomplete_Record_Type | ON_Union_Type | ON_No_Type => raise Program_Error; end case; return O_Enode'(LLVM => Res, Etype => Ntype); end New_Compare_Op; ------------------------- -- New_Indexed_Element -- ------------------------- function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) return O_Lnode is Idx : constant ValueRefArray (1 .. 2) := (ConstInt (Int32Type, 0, 0), Index.LLVM); begin return O_Lnode' (Direct => False, LLVM => BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring), Ltype => Arr.Ltype.Arr_El_Type); end New_Indexed_Element; --------------- -- New_Slice -- --------------- function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) return O_Lnode is Idx : constant ValueRefArray (1 .. 2) := (ConstInt (Int32Type, 0, 0), Index.LLVM); Tmp : ValueRef; begin if Unreach then Tmp := Null_ValueRef; else Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring); Tmp := BuildBitCast (Builder, Tmp, PointerType (Get_LLVM_Type (Res_Type)), Empty_Cstring); end if; return O_Lnode'(Direct => False, LLVM => Tmp, Ltype => Res_Type); end New_Slice; -------------------------- -- New_Selected_Element -- -------------------------- function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) return O_Lnode is Res : ValueRef; begin if Unreach then Res := Null_ValueRef; else 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 := BuildGEP (Builder, Rec.LLVM, Idx, 2, Empty_Cstring); end; when OF_Union => Res := BuildBitCast (Builder, Rec.LLVM, El.Ptr_Type, Empty_Cstring); when OF_None => raise Program_Error; end case; end if; return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); end New_Selected_Element; ------------------------ -- New_Access_Element -- ------------------------ function New_Access_Element (Acc : O_Enode) return O_Lnode is Res : ValueRef; begin case Acc.Etype.Kind is when ON_Access_Type => Res := Acc.LLVM; when ON_Incomplete_Access_Type => -- Unwrap the structure declare Idx : constant ValueRefArray (1 .. 2) := (ConstInt (Int32Type, 0, 0), ConstInt (Int32Type, 0, 0)); begin Res := BuildGEP (Builder, Acc.LLVM, Idx, 2, Empty_Cstring); end; when others => raise Program_Error; end case; return O_Lnode'(Direct => False, LLVM => Res, Ltype => Acc.Etype.Acc_Type); end New_Access_Element; -------------------- -- New_Convert_Ov -- -------------------- function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is Res : ValueRef := Null_ValueRef; begin if Rtype = Val.Etype then -- Convertion to itself: nothing to do. return Val; end if; if Rtype.LLVM = Val.Etype.LLVM then -- Same underlying LLVM type: no conversion but keep new type in -- case of change of sign. return O_Enode'(LLVM => Val.LLVM, Etype => Rtype); end if; if Unreach then return O_Enode'(LLVM => Val.LLVM, Etype => Rtype); end if; case Rtype.Kind is when ON_Integer_Types => case Val.Etype.Kind is when ON_Integer_Types => -- Int to Int if Val.Etype.Scal_Size > Rtype.Scal_Size then -- Truncate Res := BuildTrunc (Builder, Val.LLVM, Get_LLVM_Type (Rtype), Empty_Cstring); elsif Val.Etype.Scal_Size < Rtype.Scal_Size then if Val.Etype.Kind = ON_Signed_Type then Res := BuildSExt (Builder, Val.LLVM, Get_LLVM_Type (Rtype), Empty_Cstring); else -- Unsigned, enum Res := BuildZExt (Builder, Val.LLVM, Get_LLVM_Type (Rtype), Empty_Cstring); end if; else Res := BuildBitCast (Builder, Val.LLVM, Get_LLVM_Type (Rtype), Empty_Cstring); end if; when ON_Float_Type => -- Float to Int if Rtype.Kind = ON_Signed_Type then -- FPtoSI rounds toward zero, so we need to add -- copysign (0.5, x). declare V : ValueRef; begin V := BuildCall (Builder, Copysign_Fun, (Fp_0_5, Val.LLVM), 2, Empty_Cstring); V := BuildFAdd (Builder, Val.LLVM, V, Empty_Cstring); Res := BuildFPToSI (Builder, V, Get_LLVM_Type (Rtype), Empty_Cstring); end; end if; when others => null; end case; when ON_Float_Type => if Val.Etype.Kind = ON_Signed_Type then Res := BuildSIToFP (Builder, Val.LLVM, Get_LLVM_Type (Rtype), Empty_Cstring); elsif Val.Etype.Kind = ON_Unsigned_Type then Res := BuildUIToFP (Builder, Val.LLVM, Get_LLVM_Type (Rtype), Empty_Cstring); end if; when ON_Access_Type | ON_Incomplete_Access_Type => if GetTypeKind (TypeOf (Val.LLVM)) /= PointerTypeKind then raise Program_Error; end if; Res := BuildBitCast (Builder, Val.LLVM, Get_LLVM_Type (Rtype), Empty_Cstring); when others => null; end case; if Res /= Null_ValueRef then -- FIXME: only if insn was generated -- Set_Insn_Dbg (Res); return O_Enode'(LLVM => Res, Etype => Rtype); else raise Program_Error with "New_Convert_Ov: not implemented for " & ON_Type_Kind'Image (Val.Etype.Kind) & " -> " & ON_Type_Kind'Image (Rtype.Kind); end if; end New_Convert_Ov; ----------------- -- New_Address -- ----------------- function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is begin return New_Unchecked_Address (Lvalue, Atype); end New_Address; --------------------------- -- New_Unchecked_Address -- --------------------------- function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is Res : ValueRef; begin if Unreach then Res := Null_ValueRef; else Res := BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype), Empty_Cstring); end if; return O_Enode'(LLVM => Res, Etype => Atype); end New_Unchecked_Address; --------------- -- New_Value -- --------------- function New_Value (Lvalue : O_Lnode) return O_Enode is Res : ValueRef; begin if Unreach then Res := Null_ValueRef; else Res := Lvalue.LLVM; if not Lvalue.Direct then Res := BuildLoad (Builder, Res, Empty_Cstring); end if; end if; return O_Enode'(LLVM => Res, Etype => Lvalue.Ltype); end New_Value; ------------------- -- New_Obj_Value -- ------------------- function New_Obj_Value (Obj : O_Dnode) return O_Enode is begin return New_Value (New_Obj (Obj)); end New_Obj_Value; ------------- -- New_Obj -- ------------- 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; case Obj.Kind is when ON_Const_Decl | ON_Var_Decl | ON_Local_Decl => return O_Lnode'(Direct => False, LLVM => Obj.LLVM, Ltype => Obj.Dtype); when ON_Interface_Decl => return O_Lnode'(Direct => True, LLVM => Obj.Inter.Ival, Ltype => Obj.Dtype); when ON_Type_Decl | ON_Completed_Type_Decl | ON_Subprg_Decl | ON_No_Decl => raise Program_Error; end case; end New_Obj; ---------------- -- New_Alloca -- ---------------- function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode is Res : ValueRef; begin if Unreach then Res := Null_ValueRef; else if Cur_Declare_Block.Stack_Value = Null_ValueRef and then Cur_Declare_Block.Prev /= null then -- Save stack pointer at entry of block declare First_Insn : ValueRef; Bld : BuilderRef; begin First_Insn := GetFirstInstruction (Cur_Declare_Block.Stmt_Bb); if First_Insn = Null_ValueRef then -- Alloca is the first instruction, save the stack now. Bld := Builder; else -- There are instructions before alloca, insert the save -- at the beginning. PositionBuilderBefore (Extra_Builder, First_Insn); Bld := Extra_Builder; end if; Cur_Declare_Block.Stack_Value := BuildCall (Bld, Stacksave_Fun, (1 .. 0 => Null_ValueRef), 0, Empty_Cstring); end; end if; Res := BuildArrayAlloca (Builder, Int8Type, Size.LLVM, Empty_Cstring); Res := BuildBitCast (Builder, Res, Get_LLVM_Type (Rtype), Empty_Cstring); end if; return O_Enode'(LLVM => Res, Etype => Rtype); end New_Alloca; ------------------- -- New_Type_Decl -- ------------------- procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is begin -- Create the incomplete structure. This is the only way in LLVM to -- build recursive types. case Atype.Kind is when ON_Incomplete_Record_Type => Atype.LLVM := StructCreateNamed (GetGlobalContext, Get_Cstring (Ident)); when ON_Incomplete_Access_Type => Atype.LLVM := PointerType (StructCreateNamed (GetGlobalContext, Get_Cstring (Ident))); when others => null; end case; end New_Type_Decl; ----------------------------- -- New_Debug_Filename_Decl -- ----------------------------- procedure New_Debug_Filename_Decl (Filename : String) is begin null; end New_Debug_Filename_Decl; ------------------------- -- New_Debug_Line_Decl -- ------------------------- procedure New_Debug_Line_Decl (Line : Natural) is begin null; end New_Debug_Line_Decl; ---------------------------- -- New_Debug_Comment_Decl -- ---------------------------- procedure New_Debug_Comment_Decl (Comment : String) is begin null; end New_Debug_Comment_Decl; -------------------- -- New_Const_Decl -- -------------------- procedure New_Const_Decl (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) is Decl : ValueRef; begin if Storage = O_Storage_External then Decl := GetNamedGlobal (Module, Get_Cstring (Ident)); else Decl := Null_ValueRef; end if; if Decl = Null_ValueRef then Decl := AddGlobal (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident)); end if; Res := (Kind => ON_Const_Decl, LLVM => Decl, Dtype => Atype); SetGlobalConstant (Res.LLVM, 1); if Storage = O_Storage_Private then SetLinkage (Res.LLVM, InternalLinkage); end if; end New_Const_Decl; ----------------------- -- Start_Init_Value -- ----------------------- procedure Start_Init_Value (Decl : in out O_Dnode) is begin null; end Start_Init_Value; ------------------------ -- Finish_Init_Value -- ------------------------ procedure Finish_Init_Value (Decl : in out O_Dnode; Val : O_Cnode) is begin SetInitializer (Decl.LLVM, Val.LLVM); end Finish_Init_Value; ------------------ -- New_Var_Decl -- ------------------ procedure New_Var_Decl (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) is Decl : ValueRef; begin if Storage = O_Storage_Local then Res := (Kind => ON_Local_Decl, LLVM => BuildAlloca (Decl_Builder, Get_LLVM_Type (Atype), Get_Cstring (Ident)), Dtype => Atype); else if Storage = O_Storage_External then Decl := GetNamedGlobal (Module, Get_Cstring (Ident)); else Decl := Null_ValueRef; end if; if Decl = Null_ValueRef then Decl := AddGlobal (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident)); end if; Res := (Kind => ON_Var_Decl, LLVM => Decl, Dtype => Atype); -- Set linkage. case Storage is when O_Storage_Private => SetLinkage (Res.LLVM, InternalLinkage); when O_Storage_Public | O_Storage_External => null; when O_Storage_Local => raise Program_Error; end case; -- Set initializer. case Storage is when O_Storage_Private | O_Storage_Public => SetInitializer (Res.LLVM, ConstNull (Get_LLVM_Type (Atype))); when O_Storage_External => null; when O_Storage_Local => raise Program_Error; end case; end if; end New_Var_Decl; ------------------------- -- Start_Function_Decl -- ------------------------- procedure Start_Function_Decl (Interfaces : out O_Inter_List; Ident : O_Ident; Storage : O_Storage; Rtype : O_Tnode) is begin Interfaces := (Ident => Ident, Storage => Storage, Res_Type => Rtype, Nbr_Inter => 0, First_Inter => null, Last_Inter => null); end Start_Function_Decl; -------------------------- -- Start_Procedure_Decl -- -------------------------- procedure Start_Procedure_Decl (Interfaces : out O_Inter_List; Ident : O_Ident; Storage : O_Storage) is begin Interfaces := (Ident => Ident, Storage => Storage, Res_Type => O_Tnode_Null, Nbr_Inter => 0, First_Inter => null, Last_Inter => null); end Start_Procedure_Decl; ------------------------ -- New_Interface_Decl -- ------------------------ procedure New_Interface_Decl (Interfaces : in out O_Inter_List; Res : out O_Dnode; Ident : O_Ident; Atype : O_Tnode) is Inter : constant O_Inter_Acc := new O_Inter'(Itype => Atype, Ival => Null_ValueRef, Ident => Ident, Next => null); begin Res := (Kind => ON_Interface_Decl, Dtype => Atype, LLVM => Null_ValueRef, Inter => Inter); Interfaces.Nbr_Inter := Interfaces.Nbr_Inter + 1; if Interfaces.First_Inter = null then Interfaces.First_Inter := Inter; else Interfaces.Last_Inter.Next := Inter; end if; Interfaces.Last_Inter := Inter; end New_Interface_Decl; ---------------------------- -- Finish_Subprogram_Decl -- ---------------------------- procedure Finish_Subprogram_Decl (Interfaces : in out O_Inter_List; Res : out O_Dnode) is Count : constant unsigned := unsigned (Interfaces.Nbr_Inter); Inter : O_Inter_Acc; Types : TypeRefArray (1 .. Count); Ftype : TypeRef; Rtype : TypeRef; Decl : ValueRef; Id : constant Cstring := Get_Cstring (Interfaces.Ident); begin -- Fill Types (from interfaces list) Inter := Interfaces.First_Inter; for I in 1 .. Count loop Types (I) := Inter.Itype.LLVM; Inter := Inter.Next; end loop; -- Build function type. if Interfaces.Res_Type = O_Tnode_Null then Rtype := VoidType; else Rtype := Interfaces.Res_Type.LLVM; end if; Ftype := FunctionType (Rtype, Types, Count, 0); if Interfaces.Storage = O_Storage_External then Decl := GetNamedFunction (Module, Id); else Decl := Null_ValueRef; end if; if Decl = Null_ValueRef then Decl := AddFunction (Module, Id, Ftype); AddAttributeAtIndex (Decl, AttributeFunctionIndex, Nounwind_Attr); AddAttributeAtIndex (Decl, AttributeFunctionIndex, Uwtable_Attr); end if; Res := (Kind => ON_Subprg_Decl, Dtype => Interfaces.Res_Type, Subprg_Id => Interfaces.Ident, Nbr_Args => Count, Subprg_Inters => Interfaces.First_Inter, LLVM => Decl); SetFunctionCallConv (Res.LLVM, CCallConv); -- Translate interfaces. Inter := Interfaces.First_Inter; for I in 1 .. Count loop Inter.Ival := GetParam (Res.LLVM, I - 1); SetValueName (Inter.Ival, Get_Cstring (Inter.Ident)); Inter := Inter.Next; end loop; end Finish_Subprogram_Decl; --------------------------- -- Start_Subprogram_Body -- --------------------------- procedure Start_Subprogram_Body (Func : O_Dnode) is -- Basic block at function entry that contains all the declarations. Decl_BB : BasicBlockRef; begin if Cur_Func /= Null_ValueRef then -- No support for nested subprograms. raise Program_Error; end if; Cur_Func := Func.LLVM; Cur_Func_Decl := Func; Unreach := False; Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring); PositionBuilderAtEnd (Decl_Builder, Decl_BB); Create_Declare_Block; PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb); end Start_Subprogram_Body; ---------------------------- -- Finish_Subprogram_Body -- ---------------------------- procedure Finish_Subprogram_Body is Ret : ValueRef; pragma Unreferenced (Ret); begin -- Add a jump from the declare basic block to the first statement BB. Ret := BuildBr (Decl_Builder, Cur_Declare_Block.Stmt_Bb); -- Terminate the statement BB. if not Unreach then if Cur_Func_Decl.Dtype = O_Tnode_Null then Ret := BuildRetVoid (Builder); else Ret := BuildUnreachable (Builder); end if; end if; Destroy_Declare_Block; Cur_Func := Null_ValueRef; end Finish_Subprogram_Body; ------------------------- -- New_Debug_Line_Stmt -- ------------------------- procedure New_Debug_Line_Stmt (Line : Natural) is begin null; end New_Debug_Line_Stmt; ---------------------------- -- New_Debug_Comment_Stmt -- ---------------------------- procedure New_Debug_Comment_Stmt (Comment : String) is begin null; end New_Debug_Comment_Stmt; ------------------------ -- Start_Declare_Stmt -- ------------------------ procedure Start_Declare_Stmt is Br : ValueRef; pragma Unreferenced (Br); begin Create_Declare_Block; if Unreach then return; end if; -- Add a jump to the new BB. Br := BuildBr (Builder, Cur_Declare_Block.Stmt_Bb); PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb); end Start_Declare_Stmt; ------------------------- -- Finish_Declare_Stmt -- ------------------------- procedure Finish_Declare_Stmt is Bb : BasicBlockRef; Br : ValueRef; Tmp : ValueRef; pragma Unreferenced (Br, Tmp); begin if not Unreach then -- Create a basic block for the statements after the declare. Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); if Cur_Declare_Block.Stack_Value /= Null_ValueRef then -- Restore stack pointer. Tmp := BuildCall (Builder, Stackrestore_Fun, (1 .. 1 => Cur_Declare_Block.Stack_Value), 1, Empty_Cstring); end if; -- Execution will continue on the next statement Br := BuildBr (Builder, Bb); PositionBuilderAtEnd (Builder, Bb); end if; -- Do not reset Unread. Destroy_Declare_Block; end Finish_Declare_Stmt; ----------------------- -- Start_Association -- ----------------------- procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) is begin Assocs := (Subprg => Subprg, Idx => 0, Vals => new ValueRefArray (1 .. Subprg.Nbr_Args)); end Start_Association; --------------------- -- New_Association -- --------------------- procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is begin Assocs.Idx := Assocs.Idx + 1; Assocs.Vals (Assocs.Idx) := Val.LLVM; end New_Association; ----------------------- -- New_Function_Call -- ----------------------- function New_Function_Call (Assocs : O_Assoc_List) return O_Enode is Res : ValueRef; Old_Vals : ValueRefArray_Acc; begin if not Unreach then Res := BuildCall (Builder, Assocs.Subprg.LLVM, Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); Old_Vals := Assocs.Vals; Free (Old_Vals); else Res := Null_ValueRef; end if; return O_Enode'(LLVM => Res, Etype => Assocs.Subprg.Dtype); end New_Function_Call; ------------------------ -- New_Procedure_Call -- ------------------------ procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is Res : ValueRef; pragma Unreferenced (Res); begin if not Unreach then Res := BuildCall (Builder, Assocs.Subprg.LLVM, Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); end if; Free (Assocs.Vals); end New_Procedure_Call; --------------------- -- New_Assign_Stmt -- --------------------- procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) is Res : ValueRef; pragma Unreferenced (Res); begin if Target.Direct then raise Program_Error; end if; if not Unreach then Res := BuildStore (Builder, Value.LLVM, Target.LLVM); end if; end New_Assign_Stmt; --------------------- -- New_Return_Stmt -- --------------------- procedure New_Return_Stmt (Value : O_Enode) is Res : ValueRef; pragma Unreferenced (Res); begin if Unreach then return; end if; Res := BuildRet (Builder, Value.LLVM); Unreach := True; end New_Return_Stmt; --------------------- -- New_Return_Stmt -- --------------------- procedure New_Return_Stmt is Res : ValueRef; pragma Unreferenced (Res); begin if Unreach then return; end if; Res := BuildRetVoid (Builder); Unreach := True; end New_Return_Stmt; ------------------- -- Start_If_Stmt -- ------------------- procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is Res : ValueRef; pragma Unreferenced (Res); Bb_Then : BasicBlockRef; begin if Unreach then Block := (Bb => Null_BasicBlockRef); return; end if; Bb_Then := AppendBasicBlock (Cur_Func, Empty_Cstring); Block := (Bb => AppendBasicBlock (Cur_Func, Empty_Cstring)); Res := BuildCondBr (Builder, Cond.LLVM, Bb_Then, Block.Bb); PositionBuilderAtEnd (Builder, Bb_Then); end Start_If_Stmt; ------------------- -- New_Else_Stmt -- ------------------- procedure New_Else_Stmt (Block : in out O_If_Block) is Res : ValueRef; pragma Unreferenced (Res); Bb_Next : BasicBlockRef; begin if not Unreach then Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); Res := BuildBr (Builder, Bb_Next); else if Block.Bb = Null_BasicBlockRef then -- The IF statement was unreachable. Else part is also -- unreachable. return; end if; Bb_Next := Null_BasicBlockRef; end if; PositionBuilderAtEnd (Builder, Block.Bb); Block := (Bb => Bb_Next); Unreach := False; end New_Else_Stmt; -------------------- -- Finish_If_Stmt -- -------------------- procedure Finish_If_Stmt (Block : in out O_If_Block) is Res : ValueRef; pragma Unreferenced (Res); Bb_Next : BasicBlockRef; begin if not Unreach then -- The branch can continue. if Block.Bb = Null_BasicBlockRef then Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); else Bb_Next := Block.Bb; end if; Res := BuildBr (Builder, Bb_Next); PositionBuilderAtEnd (Builder, Bb_Next); else -- The branch doesn't continue. if Block.Bb /= Null_BasicBlockRef then -- There is a fall-through (either from the then branch, or -- there is no else). Unreach := False; PositionBuilderAtEnd (Builder, Block.Bb); else Unreach := True; end if; end if; end Finish_If_Stmt; --------------------- -- Start_Loop_Stmt -- --------------------- procedure Start_Loop_Stmt (Label : out O_Snode) is Res : ValueRef; pragma Unreferenced (Res); begin -- FIXME: check Unreach Label := (Bb_Entry => AppendBasicBlock (Cur_Func, Empty_Cstring), Bb_Exit => AppendBasicBlock (Cur_Func, Empty_Cstring)); Res := BuildBr (Builder, Label.Bb_Entry); PositionBuilderAtEnd (Builder, Label.Bb_Entry); end Start_Loop_Stmt; ---------------------- -- Finish_Loop_Stmt -- ---------------------- procedure Finish_Loop_Stmt (Label : in out O_Snode) is Res : ValueRef; pragma Unreferenced (Res); begin if not Unreach then Res := BuildBr (Builder, Label.Bb_Entry); end if; if Label.Bb_Exit /= Null_BasicBlockRef then -- FIXME: always true... PositionBuilderAtEnd (Builder, Label.Bb_Exit); Unreach := False; else Unreach := True; end if; end Finish_Loop_Stmt; ------------------- -- New_Exit_Stmt -- ------------------- procedure New_Exit_Stmt (L : O_Snode) is Res : ValueRef; pragma Unreferenced (Res); begin if not Unreach then Res := BuildBr (Builder, L.Bb_Exit); Unreach := True; end if; end New_Exit_Stmt; ------------------- -- New_Next_Stmt -- ------------------- procedure New_Next_Stmt (L : O_Snode) is Res : ValueRef; pragma Unreferenced (Res); begin if not Unreach then Res := BuildBr (Builder, L.Bb_Entry); Unreach := True; end if; end New_Next_Stmt; --------------------- -- Start_Case_Stmt -- --------------------- procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is begin Block := (BB_Prev => GetInsertBlock (Builder), Value => Value.LLVM, Vtype => Value.Etype, BB_Next => Null_BasicBlockRef, BB_Others => Null_BasicBlockRef, BB_Choice => Null_BasicBlockRef, Nbr_Choices => 0, Choices => new O_Choice_Array (1 .. 8)); end Start_Case_Stmt; ------------------ -- Start_Choice -- ------------------ procedure Finish_Branch (Block : in out O_Case_Block) is Res : ValueRef; pragma Unreferenced (Res); begin -- Close previous branch. if not Unreach then if Block.BB_Next = Null_BasicBlockRef then Block.BB_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); end if; Res := BuildBr (Builder, Block.BB_Next); end if; end Finish_Branch; procedure Start_Choice (Block : in out O_Case_Block) is Res : ValueRef; pragma Unreferenced (Res); begin if Block.BB_Choice /= Null_BasicBlockRef then -- Close previous branch. Finish_Branch (Block); end if; Unreach := False; Block.BB_Choice := AppendBasicBlock (Cur_Func, Empty_Cstring); PositionBuilderAtEnd (Builder, Block.BB_Choice); end Start_Choice; --------------------- -- New_Expr_Choice -- --------------------- procedure Free is new Ada.Unchecked_Deallocation (O_Choice_Array, O_Choice_Array_Acc); procedure New_Choice (Block : in out O_Case_Block; Low, High : ValueRef) is Choices : O_Choice_Array_Acc; begin if Block.Nbr_Choices = Block.Choices'Last then Choices := new O_Choice_Array (1 .. Block.Choices'Last * 2); Choices (1 .. Block.Choices'Last) := Block.Choices.all; Free (Block.Choices); Block.Choices := Choices; end if; Block.Nbr_Choices := Block.Nbr_Choices + 1; Block.Choices (Block.Nbr_Choices) := (Low => Low, High => High, Bb => Block.BB_Choice); end New_Choice; procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is begin New_Choice (Block, Expr.LLVM, Null_ValueRef); end New_Expr_Choice; ---------------------- -- New_Range_Choice -- ---------------------- procedure New_Range_Choice (Block : in out O_Case_Block; Low, High : O_Cnode) is begin New_Choice (Block, Low.LLVM, High.LLVM); end New_Range_Choice; ------------------------ -- New_Default_Choice -- ------------------------ procedure New_Default_Choice (Block : in out O_Case_Block) is begin Block.BB_Others := Block.BB_Choice; end New_Default_Choice; ------------------- -- Finish_Choice -- ------------------- procedure Finish_Choice (Block : in out O_Case_Block) is begin null; end Finish_Choice; ---------------------- -- Finish_Case_Stmt -- ---------------------- procedure Finish_Case_Stmt (Block : in out O_Case_Block) is Bb_Default : constant BasicBlockRef := AppendBasicBlock (Cur_Func, Empty_Cstring); Bb_Default_Last : BasicBlockRef; Nbr_Cases : unsigned := 0; GE, LE : IntPredicate; Res : ValueRef; begin if Block.BB_Choice /= Null_BasicBlockRef then -- Close previous branch. Finish_Branch (Block); end if; -- Strategy: use a switch instruction for simple choices, put range -- choices in the default using if statements. case Block.Vtype.Kind is when ON_Unsigned_Type | ON_Enum_Type | ON_Boolean_Type => GE := IntUGE; LE := IntULE; when ON_Signed_Type => GE := IntSGE; LE := IntSLE; when others => raise Program_Error; end case; -- BB for the default case of the LLVM switch. PositionBuilderAtEnd (Builder, Bb_Default); Bb_Default_Last := Bb_Default; for I in 1 .. Block.Nbr_Choices loop declare C : O_Choice_Type renames Block.Choices (I); begin if C.High /= Null_ValueRef then Bb_Default_Last := AppendBasicBlock (Cur_Func, Empty_Cstring); Res := BuildCondBr (Builder, BuildAnd (Builder, BuildICmp (Builder, GE, Block.Value, C.Low, Empty_Cstring), BuildICmp (Builder, LE, Block.Value, C.High, Empty_Cstring), Empty_Cstring), C.Bb, Bb_Default_Last); PositionBuilderAtEnd (Builder, Bb_Default_Last); else Nbr_Cases := Nbr_Cases + 1; end if; end; end loop; -- Insert the switch PositionBuilderAtEnd (Builder, Block.BB_Prev); Res := BuildSwitch (Builder, Block.Value, Bb_Default, Nbr_Cases); for I in 1 .. Block.Nbr_Choices loop declare C : O_Choice_Type renames Block.Choices (I); begin if C.High = Null_ValueRef then AddCase (Res, C.Low, C.Bb); end if; end; end loop; -- Insert the others. PositionBuilderAtEnd (Builder, Bb_Default_Last); if Block.BB_Others /= Null_BasicBlockRef then Res := BuildBr (Builder, Block.BB_Others); else Res := BuildUnreachable (Builder); end if; if Block.BB_Next /= Null_BasicBlockRef then Unreach := False; PositionBuilderAtEnd (Builder, Block.BB_Next); else Unreach := True; end if; Free (Block.Choices); end Finish_Case_Stmt; function Get_LLVM_Type (Atype : O_Tnode) return TypeRef is begin case Atype.Kind is when ON_Incomplete_Record_Type | ON_Incomplete_Access_Type => if Atype.LLVM = Null_TypeRef then raise Program_Error with "early use of incomplete type"; end if; return Atype.LLVM; when ON_Union_Type | ON_Scalar_Types | ON_Access_Type | ON_Array_Type | ON_Array_Sub_Type | ON_Record_Type => return Atype.LLVM; when others => raise Program_Error; end case; end Get_LLVM_Type; function CreateAttribute (Name : String; Val : Unsigned_64 := 0) return AttributeRef is Id : unsigned; begin Id := GetEnumAttributeKindForName (Name'Address, Name'Length); if Id = 0 then -- Unknown attribute raise Program_Error; end if; return CreateEnumAttribute (GetGlobalContext, Id, Val); end CreateAttribute; procedure Init is -- Some predefined types and functions. I8_Ptr_Type : TypeRef; begin Builder := CreateBuilder; Decl_Builder := CreateBuilder; Extra_Builder := CreateBuilder; -- Create type i8 *. I8_Ptr_Type := PointerType (Int8Type); -- Create intrinsic 'i8 *stacksave (void)'. Stacksave_Fun := AddFunction (Module, Stacksave_Name'Address, FunctionType (I8_Ptr_Type, (1 .. 0 => Null_TypeRef), 0, 0)); -- Create intrinsic 'void stackrestore (i8 *)'. Stackrestore_Fun := AddFunction (Module, Stackrestore_Name'Address, FunctionType (VoidType, (1 => I8_Ptr_Type), 1, 0)); -- Create intrinsic 'double llvm.copysign.f64 (double, double)'. Copysign_Fun := AddFunction (Module, Copysign_Name'Address, FunctionType (DoubleType, (0 .. 1 => DoubleType), 2, 0)); Fp_0_5 := ConstReal (DoubleType, 0.5); Nounwind_Attr := CreateAttribute ("nounwind"); Uwtable_Attr := CreateAttribute ("uwtable"); end Init; end Ortho_LLVM;