diff options
Diffstat (limited to 'ortho/llvm/ortho_llvm.adb')
| -rw-r--r-- | ortho/llvm/ortho_llvm.adb | 2768 |
1 files changed, 2768 insertions, 0 deletions
diff --git a/ortho/llvm/ortho_llvm.adb b/ortho/llvm/ortho_llvm.adb new file mode 100644 index 0000000..b18eae3 --- /dev/null +++ b/ortho/llvm/ortho_llvm.adb @@ -0,0 +1,2768 @@ +-- 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 Ortho_LLVM.Main; use Ortho_LLVM.Main; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with LLVM.Target; use LLVM.Target; + +package body Ortho_LLVM is + + -- Target_Data : TargetDataRef; + Cur_Func : ValueRef; + Cur_Func_Decl : O_Dnode; + Unreach : Boolean; + + type Declare_Block_Type; + type Declare_Block_Acc is access Declare_Block_Type; + + type Declare_Block_Type is record + Stmt_Bb : BasicBlockRef; + + Dbg_Scope : ValueRef; + Prev : Declare_Block_Acc; + end record; + + Cur_Declare_Block : Declare_Block_Acc; + Old_Declare_Block : Declare_Block_Acc; + + -- 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 + if Old_Declare_Block /= null then + Res := Old_Declare_Block; + Old_Declare_Block := Res.Prev; + else + Res := new Declare_Block_Type; + end if; + + Res.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 + Cur_Declare_Block := Blk.Prev; + 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; + + when others => + null; + 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 => + -- FIXME: float ? + 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 + 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); + 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; + pragma Unreferenced (Br); + begin + if not Unreach then + -- Create a basic block for the statements after the declare. + Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); + + -- 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; +end Ortho_LLVM; |