diff options
author | Tristan Gingold <gingold@adacore.com> | 2016-09-09 06:47:17 +0100 |
---|---|---|
committer | Tristan Gingold <tgingold@free.fr> | 2016-09-12 20:34:56 +0200 |
commit | b14c63e70136fbb134739ed53cc0f49b14ab5c90 (patch) | |
tree | 029e7781f8c7344338bd1dbe044bb427e4794010 /src/ortho/llvm-nodebug/ortho_llvm.adb | |
parent | 1325c83731501d5bd05cd38e8c3301749eb99243 (diff) | |
download | ghdl-b14c63e70136fbb134739ed53cc0f49b14ab5c90.tar.gz ghdl-b14c63e70136fbb134739ed53cc0f49b14ab5c90.tar.bz2 ghdl-b14c63e70136fbb134739ed53cc0f49b14ab5c90.zip |
Add llvm-nodebug, an llvm backend more portable across llvm versions.
Tested with llvm-3.8
Diffstat (limited to 'src/ortho/llvm-nodebug/ortho_llvm.adb')
-rw-r--r-- | src/ortho/llvm-nodebug/ortho_llvm.adb | 2320 |
1 files changed, 2320 insertions, 0 deletions
diff --git a/src/ortho/llvm-nodebug/ortho_llvm.adb b/src/ortho/llvm-nodebug/ortho_llvm.adb new file mode 100644 index 000000000..b0fdddcae --- /dev/null +++ b/src/ortho/llvm-nodebug/ortho_llvm.adb @@ -0,0 +1,2320 @@ +-- 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; + + 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); + AddFunctionAttr (Decl, NoUnwindAttribute + UWTable); + 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; + + 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); + end Init; + +end Ortho_LLVM; |