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