diff options
Diffstat (limited to 'ortho/llvm/ortho_llvm.adb')
| -rw-r--r-- | ortho/llvm/ortho_llvm.adb | 2881 |
1 files changed, 0 insertions, 2881 deletions
diff --git a/ortho/llvm/ortho_llvm.adb b/ortho/llvm/ortho_llvm.adb deleted file mode 100644 index dd8e64971..000000000 --- a/ortho/llvm/ortho_llvm.adb +++ /dev/null @@ -1,2881 +0,0 @@ --- 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; -with GNAT.Directory_Operations; - -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; - - -- Declaration of llvm.dbg.declare - Llvm_Dbg_Declare : ValueRef; - - Debug_ID : unsigned; - - Current_Directory : constant String := - GNAT.Directory_Operations.Get_Current_Dir; - - -- 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; - - -- For debugging - - DW_Version : constant := 16#c_0000#; - DW_TAG_Array_Type : constant := DW_Version + 16#01#; - DW_TAG_Enumeration_Type : constant := DW_Version + 16#04#; - DW_TAG_Lexical_Block : constant := DW_Version + 16#0b#; - DW_TAG_Member : constant := DW_Version + 16#0d#; - DW_TAG_Pointer_Type : constant := DW_Version + 16#0f#; - DW_TAG_Compile_Unit : constant := DW_Version + 16#11#; - DW_TAG_Structure_Type : constant := DW_Version + 16#13#; - DW_TAG_Subroutine_Type : constant := DW_Version + 16#15#; - DW_TAG_Subrange_Type : constant := DW_Version + 16#21#; - DW_TAG_Base_Type : constant := DW_Version + 16#24#; - DW_TAG_Enumerator : constant := DW_Version + 16#28#; - DW_TAG_File_Type : constant := DW_Version + 16#29#; - DW_TAG_Subprogram : constant := DW_Version + 16#2e#; - DW_TAG_Variable : constant := DW_Version + 16#34#; - - DW_TAG_Auto_Variable : constant := DW_Version + 16#100#; - DW_TAG_Arg_Variable : constant := DW_Version + 16#101#; - - DW_ATE_address : constant := 16#01#; - DW_ATE_boolean : constant := 16#02#; - DW_ATE_float : constant := 16#04#; - DW_ATE_signed : constant := 16#05#; - DW_ATE_unsigned : constant := 16#07#; - pragma Unreferenced (DW_ATE_address, DW_ATE_boolean); - - -- File + Dir metadata - Dbg_Current_Filedir : ValueRef; - Dbg_Current_File : ValueRef; -- The DW_TAG_File_Type - - Dbg_Current_Line : unsigned := 0; - - Dbg_Current_Scope : ValueRef; - Scope_Uniq_Id : Unsigned_64 := 0; - - -- Metadata for the instruction - Dbg_Insn_MD : ValueRef; - Dbg_Insn_MD_Line : unsigned := 0; - - procedure Free is new Ada.Unchecked_Deallocation - (ValueRefArray, ValueRefArray_Acc); - - package Dbg_Utils is - type Dyn_MDNode is private; - - procedure Append (D : in out Dyn_MDNode; Val : ValueRef); - function Get_Value (D : Dyn_MDNode) return ValueRef; - - -- Reset D. FIXME: should be done automatically within Get_Value. - procedure Clear (D : out Dyn_MDNode); - private - Chunk_Length : constant unsigned := 32; - type MD_Chunk; - type MD_Chunk_Acc is access MD_Chunk; - - type MD_Chunk is record - Vals : ValueRefArray (1 .. Chunk_Length); - Next : MD_Chunk_Acc; - end record; - - type Dyn_MDNode is record - First : MD_Chunk_Acc; - Last : MD_Chunk_Acc; - Nbr : unsigned := 0; - end record; - end Dbg_Utils; - - package body Dbg_Utils is - procedure Append (D : in out Dyn_MDNode; Val : ValueRef) is - Chunk : MD_Chunk_Acc; - Pos : constant unsigned := D.Nbr rem Chunk_Length; - begin - if Pos = 0 then - Chunk := new MD_Chunk; - if D.First = null then - D.First := Chunk; - else - D.Last.Next := Chunk; - end if; - D.Last := Chunk; - else - Chunk := D.Last; - end if; - Chunk.Vals (Pos + 1) := Val; - D.Nbr := D.Nbr + 1; - end Append; - - procedure Free is new Ada.Unchecked_Deallocation - (MD_Chunk, MD_Chunk_Acc); - - function Get_Value (D : Dyn_MDNode) return ValueRef - is - Vals : ValueRefArray (1 .. D.Nbr); - Pos : unsigned; - Chunk : MD_Chunk_Acc := D.First; - Next_Chunk : MD_Chunk_Acc; - Nbr : constant unsigned := D.Nbr; - begin - Pos := 0; - -- Copy by chunks - while Pos + Chunk_Length < Nbr loop - Vals (Pos + 1 .. Pos + Chunk_Length) := Chunk.Vals; - Pos := Pos + Chunk_Length; - Next_Chunk := Chunk.Next; - Free (Chunk); - Chunk := Next_Chunk; - end loop; - -- Last chunk - if Pos < Nbr then - Vals (Pos + 1 .. Pos + Nbr - Pos) := Chunk.Vals (1 .. Nbr - Pos); - Free (Chunk); - end if; - return MDNode (Vals, Vals'Length); - end Get_Value; - - procedure Clear (D : out Dyn_MDNode) is - begin - D := (null, null, 0); - end Clear; - end Dbg_Utils; - - use Dbg_Utils; - - -- List of debug info for subprograms. - Subprg_Nodes: Dyn_MDNode; - - -- List of literals for enumerated type - Enum_Nodes : Dyn_MDNode; - - -- List of global variables - Global_Nodes : Dyn_MDNode; - - -- Create a MDString from an Ada string. - function MDString (Str : String) return ValueRef is - begin - return MDString (Str'Address, Str'Length); - end MDString; - - function MDString (Id : O_Ident) return ValueRef is - begin - return MDString (Get_Cstring (Id), unsigned (Get_String_Length (Id))); - end MDString; - - function Dbg_Size (Atype : TypeRef) return ValueRef is - begin - return ConstInt (Int64Type, 8 * ABISizeOfType (Target_Data, Atype), 0); - end Dbg_Size; - - function Dbg_Align (Atype : TypeRef) return ValueRef is - begin - return ConstInt - (Int64Type, - Unsigned_64 (8 * ABIAlignmentOfType (Target_Data, Atype)), 0); - end Dbg_Align; - - function Dbg_Line return ValueRef is - begin - return ConstInt (Int32Type, Unsigned_64 (Dbg_Current_Line), 0); - end Dbg_Line; - - -- Set debug metadata on instruction INSN. - -- FIXME: check if INSN is really an instruction - procedure Set_Insn_Dbg (Insn : ValueRef) is - begin - if Flag_Debug then - if Dbg_Current_Line /= Dbg_Insn_MD_Line then - declare - Vals : ValueRefArray (0 .. 3); - begin - Vals := (Dbg_Line, - ConstInt (Int32Type, 0, 0), -- col - Dbg_Current_Scope, -- context - Null_ValueRef); -- inline - Dbg_Insn_MD := MDNode (Vals, Vals'Length); - Dbg_Insn_MD_Line := Dbg_Current_Line; - end; - end if; - SetMetadata (Insn, Debug_ID, Dbg_Insn_MD); - end if; - end Set_Insn_Dbg; - - procedure Dbg_Create_Variable (Tag : Unsigned_32; - Ident : O_Ident; - Vtype : O_Tnode; - Argno : Natural; - Addr : ValueRef) - is - Vals : ValueRefArray (0 .. 7); - Str : constant ValueRef := MDString (Ident); - Call_Vals : ValueRefArray (0 .. 1); - Call : ValueRef; - begin - Vals := (ConstInt (Int32Type, Unsigned_64 (Tag), 0), - Dbg_Current_Scope, - Str, - Dbg_Current_File, - ConstInt (Int32Type, - Unsigned_64 (Dbg_Current_Line) - + Unsigned_64 (Argno) * 2 ** 24, 0), - Vtype.Dbg, - ConstInt (Int32Type, 0, 0), -- flags - ConstInt (Int32Type, 0, 0)); - - Call_Vals := (MDNode ((0 => Addr), 1), - MDNode (Vals, Vals'Length)); - Call := BuildCall (Decl_Builder, Llvm_Dbg_Declare, - Call_Vals, Call_Vals'Length, Empty_Cstring); - Set_Insn_Dbg (Call); - end Dbg_Create_Variable; - - 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 := (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 New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode) - is - O_El : O_Element_Acc; - begin - El := (Kind => OF_Record, - Index => Elements.Nbr_Elements, - Ftype => Etype); - 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 New_Record_Field; - - ------------------------ - -- Finish_Record_Type -- - ------------------------ - - procedure Finish_Record_Type - (Elements : in out O_Element_List; - Res : out O_Tnode) - is - procedure Free is new Ada.Unchecked_Deallocation - (O_Element, O_Element_Acc); - - Count : constant unsigned := unsigned (Elements.Nbr_Elements); - El : O_Element_Acc; - Next_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; - - if Flag_Debug then - declare - Fields : ValueRefArray (1 .. Count); - Vals : ValueRefArray (0 .. 9); - Ftype : TypeRef; - Fields_Arr : ValueRef; - begin - El := Elements.First_Elem; - for I in Fields'Range loop - Ftype := Get_LLVM_Type (El.Etype); - Vals := - (ConstInt (Int32Type, DW_TAG_Member, 0), - Dbg_Current_File, - Null_ValueRef, - MDString (El.Ident), - ConstInt (Int32Type, 0, 0), -- linenum - Dbg_Size (Ftype), - Dbg_Align (Ftype), - ConstInt - (Int32Type, - 8 * OffsetOfElement (Target_Data, - Res.LLVM, Unsigned_32 (I - 1)), 0), - ConstInt (Int32Type, 0, 0), -- Flags - El.Etype.Dbg); - Fields (I) := MDNode (Vals, Vals'Length); - El := El.Next; - end loop; - Fields_Arr := MDNode (Fields, Fields'Length); - if Elements.Rec_Type /= null then - -- Completion - MDNodeReplaceOperandWith (Res.Dbg, 10, Fields_Arr); - MDNodeReplaceOperandWith (Res.Dbg, 5, Dbg_Size (Res.LLVM)); - MDNodeReplaceOperandWith (Res.Dbg, 6, Dbg_Align (Res.LLVM)); - else - -- Temporary borrowed. - Res.Dbg := Fields_Arr; - end if; - end; - end if; - - -- Free elements - El := Elements.First_Elem; - for I in Types'Range loop - Next_El := El.Next; - Free (El); - El := Next_El; - end loop; - 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. - 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 := (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 := (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 - pragma Unreferenced (Ident); - - 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, Utype => El_Type, Ftype => Etype); - 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; - 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); - 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; - - -- Debug. - -- FIXME. - end Finish_Access_Type; - - -------------------- - -- New_Array_Type -- - -------------------- - - function Dbg_Array (El_Type : O_Tnode; Len : ValueRef; Atype : O_Tnode) - return ValueRef - is - Rng : ValueRefArray (0 .. 2); - Rng_Arr : ValueRefArray (0 .. 0); - Vals : ValueRefArray (0 .. 14); - begin - Rng := (ConstInt (Int32Type, DW_TAG_Subrange_Type, 0), - ConstInt (Int64Type, 0, 0), -- Lo - Len); -- Count - Rng_Arr := (0 => MDNode (Rng, Rng'Length)); - Vals := (ConstInt (Int32Type, DW_TAG_Array_Type, 0), - Null_ValueRef, - Null_ValueRef, -- context - Null_ValueRef, - ConstInt (Int32Type, 0, 0), -- line - Dbg_Size (Atype.LLVM), - Dbg_Align (Atype.LLVM), - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 0, 0), -- Flags - El_Type.Dbg, -- element type - MDNode (Rng_Arr, Rng_Arr'Length), -- subscript - ConstInt (Int32Type, 0, 0), - Null_ValueRef, - Null_ValueRef, - Null_ValueRef); -- Runtime lang - return MDNode (Vals, Vals'Length); - end Dbg_Array; - - 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); - - if Flag_Debug then - Res.Dbg := Dbg_Array - (El_Type, ConstInt (Int64Type, Unsigned_64'Last, 1), Res); - end if; - - 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); - - if Flag_Debug then - Res.Dbg := Dbg_Array - (Atype.Arr_El_Type, - ConstInt (Int64Type, Unsigned_64 (Len), 0), Res); - end if; - - 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; - - procedure Dbg_Add_Enumeration (Id : O_Ident; Val : Unsigned_64) is - Vals : ValueRefArray (0 .. 2); - begin - Vals := (ConstInt (Int32Type, DW_TAG_Enumerator, 0), - MDString (Id), - ConstInt (Int64Type, Val, 0)); - -- FIXME: make it local to List ? - Append (Enum_Nodes, MDNode (Vals, Vals'Length)); - end Dbg_Add_Enumeration; - - ---------------------- - -- 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 - 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); - if Flag_Debug then - Dbg_Add_Enumeration (False_Id, 0); - Dbg_Add_Enumeration (True_Id, 1); - end if; - 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 - begin - Res := O_Cnode'(LLVM => ConstInt (List.LLVM, Unsigned_64 (List.Num), 0), - Ctype => List.Etype); - if Flag_Debug then - Dbg_Add_Enumeration (Ident, Unsigned_64 (List.Num)); - end if; - - 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 - begin - Res := (LLVM => ConstStruct (List.Vals.all, List.Len, 0), - 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_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 R = 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; - - Set_Insn_Dbg (Res); - - 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 - 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; - - if IsAInstruction (Res) /= Null_ValueRef then - Set_Insn_Dbg (Res); - end if; - - 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 - 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; - Set_Insn_Dbg (Res); - 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 - Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring); - Tmp := BuildBitCast - (Builder, Tmp, PointerType (Get_LLVM_Type (Res_Type)), Empty_Cstring); - 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 - 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; - 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: nothing to do. - return Val; - 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 - Res := BuildFPToSI - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - 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 O_Enode' - (LLVM => BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype), - Empty_Cstring), - Etype => Atype); - end New_Address; - - --------------------------- - -- New_Unchecked_Address -- - --------------------------- - - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode - is - begin - return O_Enode' - (LLVM => BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype), - Empty_Cstring), - 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); - Set_Insn_Dbg (Res); - 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 - 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 => - if Flag_Debug then - -- The argument was allocated. - return O_Lnode'(Direct => False, - LLVM => Obj.Inter.Ival, - Ltype => Obj.Dtype); - else - return O_Lnode'(Direct => True, - LLVM => Obj.Inter.Ival, - Ltype => Obj.Dtype); - end if; - - 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 - PositionBuilderBefore - (Extra_Builder, GetFirstInstruction (Cur_Declare_Block.Stmt_Bb)); - Cur_Declare_Block.Stack_Value := - BuildCall (Extra_Builder, Stacksave_Fun, - (1 .. 0 => Null_ValueRef), 0, Empty_Cstring); - end if; - - Res := BuildArrayAlloca - (Builder, Int8Type, Size.LLVM, Empty_Cstring); - Set_Insn_Dbg (Res); - - Res := BuildBitCast - (Builder, Res, Get_LLVM_Type (Rtype), Empty_Cstring); - Set_Insn_Dbg (Res); - end if; - - return O_Enode'(LLVM => Res, Etype => Rtype); - end New_Alloca; - - ------------------- - -- New_Type_Decl -- - ------------------- - - function Add_Dbg_Basic_Type (Id : O_Ident; Btype : O_Tnode; Enc : Natural) - return ValueRef - is - Vals : ValueRefArray (0 .. 9); - begin - Vals := (ConstInt (Int32Type, DW_TAG_Base_Type, 0), - Null_ValueRef, - Null_ValueRef, - MDString (Id), - ConstInt (Int32Type, 0, 0), -- linenum - Dbg_Size (Btype.LLVM), - Dbg_Align (Btype.LLVM), - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 0, 0), -- Flags - ConstInt (Int32Type, Unsigned_64 (Enc), 0)); -- Encoding - return MDNode (Vals, Vals'Length); - end Add_Dbg_Basic_Type; - - function Add_Dbg_Enum_Type (Id : O_Ident; Etype : O_Tnode) return ValueRef - is - Vals : ValueRefArray (0 .. 14); - begin - Vals := (ConstInt (Int32Type, DW_TAG_Enumeration_Type, 0), - Dbg_Current_Filedir, - Null_ValueRef, -- context - MDString (Id), - Dbg_Line, - Dbg_Size (Etype.LLVM), - Dbg_Align (Etype.LLVM), - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 0, 0), -- Flags - Null_ValueRef, - Get_Value (Enum_Nodes), - ConstInt (Int32Type, 0, 0), - Null_ValueRef, - Null_ValueRef, - Null_ValueRef); -- Runtime lang - Clear (Enum_Nodes); - return MDNode (Vals, Vals'Length); - end Add_Dbg_Enum_Type; - - function Add_Dbg_Pointer_Type (Id : O_Ident; Ptype : O_Tnode) - return ValueRef - is - Vals : ValueRefArray (0 .. 9); - begin - pragma Assert (Ptype.Acc_Type.Dbg /= Null_ValueRef); - - Vals := (ConstInt (Int32Type, DW_TAG_Pointer_Type, 0), - Dbg_Current_Filedir, - Null_ValueRef, -- context - MDString (Id), - Dbg_Line, - Dbg_Size (Ptype.LLVM), - Dbg_Align (Ptype.LLVM), - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 1024, 0), -- Flags - Ptype.Acc_Type.Dbg); - return MDNode (Vals, Vals'Length); - end Add_Dbg_Pointer_Type; - - function Add_Dbg_Record_Type (Id : O_Ident; Rtype : O_Tnode) - return ValueRef - is - Vals : ValueRefArray (0 .. 14); - begin - Vals := (ConstInt (Int32Type, DW_TAG_Structure_Type, 0), - Dbg_Current_Filedir, - Null_ValueRef, -- context - MDString (Id), - Dbg_Line, - Null_ValueRef, -- 5: Size - Null_ValueRef, -- 6: Align - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 1024, 0), -- Flags - Null_ValueRef, - Null_ValueRef, -- 10 - ConstInt (Int32Type, 0, 0), -- Runtime lang - Null_ValueRef, -- Vtable Holder - Null_ValueRef, -- ? - Null_ValueRef); -- Uniq Id - if Rtype /= O_Tnode_Null then - Vals (5) := Dbg_Size (Rtype.LLVM); - Vals (6) := Dbg_Align (Rtype.LLVM); - Vals (10) := Rtype.Dbg; - end if; - - return MDNode (Vals, Vals'Length); - end Add_Dbg_Record_Type; - - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is - begin - 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; - - -- Emit debug info - if Flag_Debug then - case Atype.Kind is - when ON_Unsigned_Type => - Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_unsigned); - when ON_Signed_Type => - Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_signed); - when ON_Float_Type => - Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_float); - when ON_Enum_Type => - Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype); - when ON_Boolean_Type => - Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype); - when ON_Access_Type => - Atype.Dbg := Add_Dbg_Pointer_Type (Ident, Atype); - when ON_Record_Type => - Atype.Dbg := Add_Dbg_Record_Type (Ident, Atype); - when ON_Incomplete_Record_Type => - Atype.Dbg := Add_Dbg_Record_Type (Ident, O_Tnode_Null); - when ON_Array_Type - | ON_Array_Sub_Type => - -- FIXME: typedef - null; - when ON_Incomplete_Access_Type => - -- FIXME: todo - null; - when ON_Union_Type => - -- FIXME: todo - null; - when ON_No_Type => - raise Program_Error; - end case; - end if; - end New_Type_Decl; - - ----------------------------- - -- New_Debug_Filename_Decl -- - ----------------------------- - - procedure New_Debug_Filename_Decl (Filename : String) is - Vals : ValueRefArray (1 .. 2); - begin - if Flag_Debug then - Vals := (MDString (Filename), - MDString (Current_Directory)); - Dbg_Current_Filedir := MDNode (Vals, 2); - - Vals := (ConstInt (Int32Type, DW_TAG_File_Type, 0), - Dbg_Current_Filedir); - Dbg_Current_File := MDNode (Vals, 2); - end if; - end New_Debug_Filename_Decl; - - ------------------------- - -- New_Debug_Line_Decl -- - ------------------------- - - procedure New_Debug_Line_Decl (Line : Natural) is - begin - Dbg_Current_Line := unsigned (Line); - 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 Dbg_Add_Global_Var (Id : O_Ident; - Atype : O_Tnode; - Storage : O_Storage; - Decl : O_Dnode) - is - pragma Assert (Atype.Dbg /= Null_ValueRef); - Vals : ValueRefArray (0 .. 12); - Name : constant ValueRef := MDString (Id); - Is_Local : constant Boolean := Storage = O_Storage_Private; - Is_Def : constant Boolean := Storage /= O_Storage_External; - begin - Vals := - (ConstInt (Int32Type, DW_TAG_Variable, 0), - Null_ValueRef, - Null_ValueRef, -- context - Name, - Name, - Null_ValueRef, -- linkageName - Dbg_Current_File, - Dbg_Line, - Atype.Dbg, - ConstInt (Int1Type, Boolean'Pos (Is_Local), 0), -- isLocal - ConstInt (Int1Type, Boolean'Pos (Is_Def), 0), -- isDef - Decl.LLVM, - Null_ValueRef); - Append (Global_Nodes, MDNode (Vals, Vals'Length)); - end Dbg_Add_Global_Var; - - 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; - if Flag_Debug then - Dbg_Add_Global_Var (Ident, Atype, Storage, Res); - end if; - end New_Const_Decl; - - ----------------------- - -- Start_Const_Value -- - ----------------------- - - procedure Start_Const_Value (Const : in out O_Dnode) is - begin - null; - end Start_Const_Value; - - ------------------------ - -- Finish_Const_Value -- - ------------------------ - - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) is - begin - SetInitializer (Const.LLVM, Val.LLVM); - end Finish_Const_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); - if Flag_Debug then - Dbg_Create_Variable (DW_TAG_Auto_Variable, - Ident, Atype, 0, Res.LLVM); - end if; - 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; - - if Flag_Debug then - Dbg_Add_Global_Var (Ident, Atype, Storage, Res); - end if; - 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); - 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); - - if Flag_Debug then - declare - Type_Vals : ValueRefArray (0 .. Func.Nbr_Args); - Vals : ValueRefArray (0 .. 14); - Arg : O_Inter_Acc; - Subprg_Type : ValueRef; - - Subprg_Vals : ValueRefArray (0 .. 19); - Name : ValueRef; - begin - Arg := Func.Subprg_Inters; - if Func.Dtype /= O_Tnode_Null then - Type_Vals (0) := Func.Dtype.Dbg; - else - -- Void - Type_Vals (0) := Null_ValueRef; - end if; - for I in 1 .. Type_Vals'Last loop - Type_Vals (I) := Arg.Itype.Dbg; - Arg := Arg.Next; - end loop; - Vals := - (ConstInt (Int32Type, DW_TAG_Subroutine_Type, 0), - ConstInt (Int32Type, 0, 0), -- 1 ?? - Null_ValueRef, -- 2 Context - MDString (Empty_Cstring, 0), -- 3 name - ConstInt (Int32Type, 0, 0), -- 4 linenum - ConstInt (Int64Type, 0, 0), -- 5 size - ConstInt (Int64Type, 0, 0), -- 6 align - ConstInt (Int64Type, 0, 0), -- 7 offset - ConstInt (Int32Type, 0, 0), -- 8 flags - Null_ValueRef, -- 9 derived from - MDNode (Type_Vals, Type_Vals'Length), -- 10 type - ConstInt (Int32Type, 0, 0), -- 11 runtime lang - Null_ValueRef, -- 12 containing type - Null_ValueRef, -- 13 template params - Null_ValueRef); -- 14 ?? - Subprg_Type := MDNode (Vals, Vals'Length); - - -- Create TAG_subprogram. - Name := MDString (Func.Subprg_Id); - - Subprg_Vals := - (ConstInt (Int32Type, DW_TAG_Subprogram, 0), - Dbg_Current_Filedir, -- 1 loc - Dbg_Current_File, -- 2 context - Name, -- 3 name - Name, -- 4 display name - Null_ValueRef, -- 5 linkage name - Dbg_Line, -- 6 line num - Subprg_Type, -- 7 type - ConstInt (Int1Type, 0, 0), -- 8 islocal (FIXME) - ConstInt (Int1Type, 1, 0), -- 9 isdef (FIXME) - ConstInt (Int32Type, 0, 0), -- 10 virtuality - ConstInt (Int32Type, 0, 0), -- 11 virtual index - Null_ValueRef, -- 12 containing type - ConstInt (Int32Type, 256, 0), -- 13 flags: prototyped - ConstInt (Int1Type, 0, 0), -- 14 isOpt (FIXME) - Cur_Func, -- 15 function - Null_ValueRef, -- 16 template param - Null_ValueRef, -- 17 function decl - Null_ValueRef, -- 18 variables ??? - Dbg_Line); -- 19 scope ln - Cur_Declare_Block.Dbg_Scope := - MDNode (Subprg_Vals, Subprg_Vals'Length); - Append (Subprg_Nodes, Cur_Declare_Block.Dbg_Scope); - Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; - end; - - -- Create local variables for arguments. - declare - Arg : O_Inter_Acc; - Tmp : ValueRef; - St : ValueRef; - pragma Unreferenced (St); - Argno : Natural; - begin - Arg := Func.Subprg_Inters; - Argno := 1; - while Arg /= null loop - Tmp := BuildAlloca (Decl_Builder, Get_LLVM_Type (Arg.Itype), - Empty_Cstring); - Dbg_Create_Variable (DW_TAG_Arg_Variable, - Arg.Ident, Arg.Itype, Argno, Tmp); - St := BuildStore (Decl_Builder, Arg.Ival, Tmp); - Arg.Ival := Tmp; - - Arg := Arg.Next; - Argno := Argno + 1; - end loop; - end; - end if; - 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; - Dbg_Current_Scope := Null_ValueRef; - end Finish_Subprogram_Body; - - ------------------------- - -- New_Debug_Line_Stmt -- - ------------------------- - - procedure New_Debug_Line_Stmt (Line : Natural) is - begin - Dbg_Current_Line := unsigned (Line); - 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); - - if Flag_Debug then - declare - Vals : ValueRefArray (0 .. 5); - begin - Vals := - (ConstInt (Int32Type, DW_TAG_Lexical_Block, 0), - Dbg_Current_Filedir, -- 1 loc - Dbg_Current_Scope, -- 2 context - Dbg_Line, -- 3 line num - ConstInt (Int32Type, 0, 0), -- 4 col - ConstInt (Int32Type, Scope_Uniq_Id, 0)); - Cur_Declare_Block.Dbg_Scope := MDNode (Vals, Vals'Length); - Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; - Scope_Uniq_Id := Scope_Uniq_Id + 1; - end; - end if; - 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; - - Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; - 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 - Res := BuildCall (Builder, Assocs.Subprg.LLVM, - Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); - Old_Vals := Assocs.Vals; - Free (Old_Vals); - Set_Insn_Dbg (Res); - 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; - begin - if not Unreach then - Res := BuildCall (Builder, Assocs.Subprg.LLVM, - Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); - Set_Insn_Dbg (Res); - 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; - begin - if Target.Direct then - raise Program_Error; - end if; - if not Unreach then - Res := BuildStore (Builder, Value.LLVM, Target.LLVM); - Set_Insn_Dbg (Res); - end if; - end New_Assign_Stmt; - - --------------------- - -- New_Return_Stmt -- - --------------------- - - procedure New_Return_Stmt (Value : O_Enode) is - Res : ValueRef; - begin - if Unreach then - return; - end if; - Res := BuildRet (Builder, Value.LLVM); - Set_Insn_Dbg (Res); - Unreach := True; - end New_Return_Stmt; - - --------------------- - -- New_Return_Stmt -- - --------------------- - - procedure New_Return_Stmt is - Res : ValueRef; - begin - if Unreach then - return; - end if; - Res := BuildRetVoid (Builder); - Set_Insn_Dbg (Res); - 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; - Bb_Then : BasicBlockRef; - begin - -- FIXME: check Unreach - Bb_Then := AppendBasicBlock (Cur_Func, Empty_Cstring); - Block := (Bb => AppendBasicBlock (Cur_Func, Empty_Cstring)); - Res := BuildCondBr (Builder, Cond.LLVM, Bb_Then, Block.Bb); - Set_Insn_Dbg (Res); - - 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 - 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; - begin - if not Unreach then - Res := BuildBr (Builder, L.Bb_Exit); - Set_Insn_Dbg (Res); - Unreach := True; - end if; - end New_Exit_Stmt; - - ------------------- - -- New_Next_Stmt -- - ------------------- - - procedure New_Next_Stmt (L : O_Snode) is - Res : ValueRef; - begin - if not Unreach then - Res := BuildBr (Builder, L.Bb_Entry); - Set_Insn_Dbg (Res); - 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 Finish_Debug is - begin - declare - Dbg_Cu : constant String := "llvm.dbg.cu" & ASCII.NUL; - Producer : constant String := "ortho llvm"; - Vals : ValueRefArray (0 .. 12); - begin - Vals := - (ConstInt (Int32Type, DW_TAG_Compile_Unit, 0), - Dbg_Current_Filedir, -- 1 file+dir - ConstInt (Int32Type, 1, 0), -- 2 language (C) - MDString (Producer), -- 3 producer - ConstInt (Int1Type, 0, 0), -- 4 isOpt - MDString (""), -- 5 flags - ConstInt (Int32Type, 0, 0), -- 6 runtime version - Null_ValueRef, -- 7 enum types - Null_ValueRef, -- 8 retained types - Get_Value (Subprg_Nodes), -- 9 subprograms - Get_Value (Global_Nodes), -- 10 global var - Null_ValueRef, -- 11 imported entities - Null_ValueRef); -- 12 split debug - - AddNamedMetadataOperand - (Module, Dbg_Cu'Address, MDNode (Vals, Vals'Length)); - end; - - declare - Module_Flags : constant String := "llvm.module.flags" & ASCII.NUL; - Flags1 : ValueRefArray (0 .. 2); - Flags2 : ValueRefArray (0 .. 2); - begin - Flags1 := (ConstInt (Int32Type, 1, 0), - MDString ("Debug Info Version"), - ConstInt (Int32Type, 1, 0)); - AddNamedMetadataOperand - (Module, Module_Flags'Address, MDNode (Flags1, Flags1'Length)); - Flags2 := (ConstInt (Int32Type, 2, 0), - MDString ("Dwarf Version"), - ConstInt (Int32Type, 2, 0)); - AddNamedMetadataOperand - (Module, Module_Flags'Address, MDNode (Flags2, Flags2'Length)); - end; - end Finish_Debug; - - Dbg_Str : constant String := "dbg"; - - 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)); - - if Flag_Debug then - Debug_ID := GetMDKindID (Dbg_Str, Dbg_Str'Length); - - declare - Atypes : TypeRefArray (1 .. 2); - Ftype : TypeRef; - Name : String := "llvm.dbg.declare" & ASCII.NUL; - begin - Atypes := (MetadataType, MetadataType); - Ftype := FunctionType (VoidType, Atypes, Atypes'Length, 0); - Llvm_Dbg_Declare := AddFunction (Module, Name'Address, Ftype); - AddFunctionAttr (Llvm_Dbg_Declare, - NoUnwindAttribute + ReadNoneAttribute); - end; - end if; - end Init; - -end Ortho_LLVM; |