aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile.in9
-rwxr-xr-xconfigure7
-rw-r--r--src/ortho/llvm-nodebug/llvm-analysis.ads53
-rw-r--r--src/ortho/llvm-nodebug/llvm-bitwriter.ads34
-rw-r--r--src/ortho/llvm-nodebug/llvm-cbindings.cpp38
-rw-r--r--src/ortho/llvm-nodebug/llvm-core.ads1193
-rw-r--r--src/ortho/llvm-nodebug/llvm-target.ads84
-rw-r--r--src/ortho/llvm-nodebug/llvm-targetmachine.ads122
-rw-r--r--src/ortho/llvm-nodebug/llvm-transforms-scalar.ads169
-rw-r--r--src/ortho/llvm-nodebug/llvm-transforms.ads21
-rw-r--r--src/ortho/llvm-nodebug/llvm.ads21
-rw-r--r--src/ortho/llvm-nodebug/ortho_code_main.adb316
-rw-r--r--src/ortho/llvm-nodebug/ortho_ident.adb134
-rw-r--r--src/ortho/llvm-nodebug/ortho_ident.ads42
-rw-r--r--src/ortho/llvm-nodebug/ortho_llvm.adb2320
-rw-r--r--src/ortho/llvm-nodebug/ortho_llvm.private.ads307
-rw-r--r--src/ortho/llvm-nodebug/ortho_nodes.ads20
17 files changed, 4883 insertions, 7 deletions
diff --git a/Makefile.in b/Makefile.in
index 06ee4df43..ceb07217a 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -30,6 +30,7 @@ gcc_src_dir=@gcc_src_dir@
LLVM_CONFIG=@llvm_config@
LDFLAGS=@LDFLAGS@
LIBBACKTRACE=@backtrace_lib@
+llvm_be=@llvm_be@
build_mode=@build_mode@
INSTALL_PROGRAM=install -m 755
@@ -197,7 +198,7 @@ oread-gcc$(EXEEXT): force
#################### For llvm backend ##############################
-GHDL_LLVM_INCFLAGS=$(GHDL_COMMON_INCFLAGS) -aI$(srcdir)/src/ghdldrv -aI$(srcdir)/src/grt -aI$(srcdir)/src/ortho -aI$(srcdir)/src/ortho/llvm
+GHDL_LLVM_INCFLAGS=$(GHDL_COMMON_INCFLAGS) -aI$(srcdir)/src/ghdldrv -aI$(srcdir)/src/grt -aI$(srcdir)/src/ortho -aI$(srcdir)/src/ortho/$(llvm_be)
all.llvm: ghdl1-llvm$(EXEEXT) ghdl_llvm$(EXEEXT) grt-all libs.vhdl.llvm all.vpi
@@ -211,7 +212,7 @@ ghdl_llvm_jit$(EXEEXT): $(GRT_ADD_OBJS) $(GRT_SRC_DEPS) $(ORTHO_DEPS) \
$(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) --LINK=$(CXX) \
`$(LLVM_CONFIG) --ldflags --libs --system-libs` $(LDFLAGS)
-llvm-cbindings.o: $(srcdir)/src/ortho/llvm/llvm-cbindings.cpp
+llvm-cbindings.o: $(srcdir)/src/ortho/$(llvm_be)/llvm-cbindings.cpp
$(CXX) -c `$(LLVM_CONFIG) --includedir --cxxflags` \
$(OPT_FLAGS) -o $@ $<
@@ -226,13 +227,13 @@ ghdl_llvm$(EXEEXT): force
ghdl_llvm $(GNAT_BARGS) -largs $(GNAT_LARGS)
ghdl1-llvm$(EXEEXT): force
- $(MAKE) -f $(srcdir)/src/ortho/llvm/Makefile \
+ $(MAKE) -f $(srcdir)/src/ortho/$(llvm_be)/Makefile \
ortho_srcdir=$(srcdir)/src/ortho ortho_exec=$@ \
GNAT_FLAGS="$(GHDL_LLVM_INCFLAGS) $(GNATFLAGS)" LDFLAGS="$(LDFLAGS)" \
LLVM_CONFIG="$(LLVM_CONFIG)" all
oread-llvm$(EXEEXT): force
- $(MAKE) -f $(srcdir)/src/ortho/llvm/Makefile \
+ $(MAKE) -f $(srcdir)/src/ortho/$(llvm_be)/Makefile \
ortho_srcdir=$(srcdir)/src/ortho ortho_exec=$@ \
GNATMAKE="$(GNATMAKE)" \
GNAT_FLAGS="-aI$(srcdir)/src/ortho/oread $(GNATFLAGS)" \
diff --git a/configure b/configure
index a69ba04c1..49ce69380 100755
--- a/configure
+++ b/configure
@@ -15,6 +15,7 @@ gcc_src_dir=
gcc_version=unknown
llvm_config=
backtrace_lib=
+llvm_be=llvm
build=
build_mode=
EXEEXT=
@@ -24,7 +25,7 @@ PIC_FLAGS=-fPIC
show_help=no
progname=$0
-subst_vars="CC GNATMAKE CFLAGS LDFLAGS build srcdir prefix backend libdirsuffix libdirreverse gcc_src_dir llvm_config backtrace_lib build_mode EXEEXT SOEXT PIC_FLAGS"
+subst_vars="CC GNATMAKE CFLAGS LDFLAGS build srcdir prefix backend libdirsuffix libdirreverse gcc_src_dir llvm_config llvm_be backtrace_lib build_mode EXEEXT SOEXT PIC_FLAGS"
# Find srcdir
srcdir=`dirname $progname`
@@ -165,8 +166,8 @@ if test $backend = llvm; then
fi
if ! check_version $llvm_version $llvm_ver; then
echo "Mismatch llvm version $llvm_ver from $llvm_config"
- echo "Need llvm version $llvm_version"
- exit 1
+ echo "Debugging is not enabled"
+ llvm_be=llvm-nodebug
fi
# For llvm, the c++ compiler is used for linking so that the standard c++
# library is included. However, the linker needs the no_compact_unwind
diff --git a/src/ortho/llvm-nodebug/llvm-analysis.ads b/src/ortho/llvm-nodebug/llvm-analysis.ads
new file mode 100644
index 000000000..bfecec579
--- /dev/null
+++ b/src/ortho/llvm-nodebug/llvm-analysis.ads
@@ -0,0 +1,53 @@
+-- LLVM binding
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with LLVM.Core; use LLVM.Core;
+
+package LLVM.Analysis is
+ type VerifierFailureAction is
+ (
+ AbortProcessAction, -- verifier will print to stderr and abort()
+ PrintMessageAction, -- verifier will print to stderr and return 1
+ ReturnStatusAction -- verifier will just return 1
+ );
+ pragma Convention (C, VerifierFailureAction);
+
+ -- Verifies that a module is valid, taking the specified action if not.
+ -- Optionally returns a human-readable description of any invalid
+ -- constructs.
+ -- OutMessage must be disposed with DisposeMessage. */
+ function VerifyModule(M : ModuleRef;
+ Action : VerifierFailureAction;
+ OutMessage : access Cstring)
+ return Integer;
+
+ -- Verifies that a single function is valid, taking the specified
+ -- action. Useful for debugging.
+ function VerifyFunction(Fn : ValueRef; Action : VerifierFailureAction)
+ return Integer;
+
+ -- Open up a ghostview window that displays the CFG of the current function.
+ -- Useful for debugging.
+ procedure ViewFunctionCFG(Fn : ValueRef);
+ procedure ViewFunctionCFGOnly(Fn : ValueRef);
+private
+ pragma Import (C, VerifyModule, "LLVMVerifyModule");
+ pragma Import (C, VerifyFunction, "LLVMVerifyFunction");
+ pragma Import (C, ViewFunctionCFG, "LLVMViewFunctionCFG");
+ pragma Import (C, ViewFunctionCFGOnly, "LLVMViewFunctionCFGOnly");
+end LLVM.Analysis;
+
diff --git a/src/ortho/llvm-nodebug/llvm-bitwriter.ads b/src/ortho/llvm-nodebug/llvm-bitwriter.ads
new file mode 100644
index 000000000..3f9c518e4
--- /dev/null
+++ b/src/ortho/llvm-nodebug/llvm-bitwriter.ads
@@ -0,0 +1,34 @@
+-- LLVM binding
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with LLVM.Core; use LLVM.Core;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Interfaces.C; use Interfaces.C;
+
+package LLVM.BitWriter is
+ -- Writes a module to an open file descriptor. Returns 0 on success.
+ -- Closes the Handle. Use dup first if this is not what you want.
+ function WriteBitcodeToFileHandle(M : ModuleRef; Handle : File_Descriptor)
+ return int;
+
+ -- Writes a module to the specified path. Returns 0 on success.
+ function WriteBitcodeToFile(M : ModuleRef; Path : Cstring)
+ return int;
+private
+ pragma Import (C, WriteBitcodeToFileHandle, "LLVMWriteBitcodeToFileHandle");
+ pragma Import (C, WriteBitcodeToFile, "LLVMWriteBitcodeToFile");
+end LLVM.BitWriter;
diff --git a/src/ortho/llvm-nodebug/llvm-cbindings.cpp b/src/ortho/llvm-nodebug/llvm-cbindings.cpp
new file mode 100644
index 000000000..4a61ad552
--- /dev/null
+++ b/src/ortho/llvm-nodebug/llvm-cbindings.cpp
@@ -0,0 +1,38 @@
+/* LLVM binding
+ 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 GHDL; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA. */
+#include "llvm-c/Target.h"
+#include "llvm/IR/Type.h"
+#include "llvm/IR/LLVMContext.h"
+
+using namespace llvm;
+
+extern "C" {
+
+void
+LLVMInitializeNativeTarget_noinline (void)
+{
+ LLVMInitializeNativeTarget ();
+}
+
+void
+LLVMInitializeNativeAsmPrinter_noinline (void)
+{
+ LLVMInitializeNativeAsmPrinter();
+}
+
+}
diff --git a/src/ortho/llvm-nodebug/llvm-core.ads b/src/ortho/llvm-nodebug/llvm-core.ads
new file mode 100644
index 000000000..5a28b7ee7
--- /dev/null
+++ b/src/ortho/llvm-nodebug/llvm-core.ads
@@ -0,0 +1,1193 @@
+-- LLVM binding
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+with Interfaces.C; use Interfaces.C;
+use Interfaces;
+
+package LLVM.Core is
+
+ subtype Cstring is System.Address;
+ function "=" (L, R : Cstring) return Boolean renames System."=";
+ -- Null_Cstring : constant Cstring := Null_Address;
+ Nul : constant String := (1 => Character'Val (0));
+ Empty_Cstring : constant Cstring := Nul'Address;
+
+ -- The top-level container for all LLVM global data. See the LLVMContext
+ -- class.
+ type ContextRef is new System.Address;
+
+ -- The top-level container for all other LLVM Intermediate
+ -- Representation (IR) objects. See the llvm::Module class.
+ type ModuleRef is new System.Address;
+
+ subtype Bool is int;
+
+ -- Each value in the LLVM IR has a type, an LLVMTypeRef. See the llvm::Type
+ -- class.
+ type TypeRef is new System.Address;
+ Null_TypeRef : constant TypeRef := TypeRef (System.Null_Address);
+ type TypeRefArray is array (unsigned range <>) of TypeRef;
+ pragma Convention (C, TypeRefArray);
+
+ type ValueRef is new System.Address;
+ Null_ValueRef : constant ValueRef := ValueRef (System.Null_Address);
+ type ValueRefArray is array (unsigned range <>) of ValueRef; -- Ada
+ pragma Convention (C, ValueRefArray);
+
+ type BasicBlockRef is new System.Address;
+ Null_BasicBlockRef : constant BasicBlockRef :=
+ BasicBlockRef (System.Null_Address);
+ type BasicBlockRefArray is
+ array (unsigned range <>) of BasicBlockRef; -- Ada
+ pragma Convention (C, BasicBlockRefArray);
+
+ type BuilderRef is new System.Address;
+
+ -- Used to provide a module to JIT or interpreter.
+ -- See the llvm::MemoryBuffer class.
+ type MemoryBufferRef is new System.Address;
+
+ -- See the llvm::PassManagerBase class.
+ type PassManagerRef is new System.Address;
+
+ type Attribute is new unsigned;
+ ZExtAttribute : constant Attribute := 2**0;
+ SExtAttribute : constant Attribute := 2**1;
+ NoReturnAttribute : constant Attribute := 2**2;
+ InRegAttribute : constant Attribute := 2**3;
+ StructRetAttribute : constant Attribute := 2**4;
+ NoUnwindAttribute : constant Attribute := 2**5;
+ NoAliasAttribute : constant Attribute := 2**6;
+ ByValAttribute : constant Attribute := 2**7;
+ NestAttribute : constant Attribute := 2**8;
+ ReadNoneAttribute : constant Attribute := 2**9;
+ ReadOnlyAttribute : constant Attribute := 2**10;
+ NoInlineAttribute : constant Attribute := 2**11;
+ AlwaysInlineAttribute : constant Attribute := 2**12;
+ OptimizeForSizeAttribute : constant Attribute := 2**13;
+ StackProtectAttribute : constant Attribute := 2**14;
+ StackProtectReqAttribute : constant Attribute := 2**15;
+ Alignment : constant Attribute := 31 * 2**16;
+ NoCaptureAttribute : constant Attribute := 2**21;
+ NoRedZoneAttribute : constant Attribute := 2**22;
+ NoImplicitFloatAttribute : constant Attribute := 2**23;
+ NakedAttribute : constant Attribute := 2**24;
+ InlineHintAttribute : constant Attribute := 2**25;
+ StackAlignment : constant Attribute := 7 * 2**26;
+ ReturnsTwice : constant Attribute := 2**29;
+ UWTable : constant Attribute := 2**30;
+ NonLazyBind : constant Attribute := 2**31;
+
+ type TypeKind is
+ (
+ VoidTypeKind, -- type with no size
+ HalfTypeKind, -- 16 bit floating point type
+ FloatTypeKind, -- 32 bit floating point type
+ DoubleTypeKind, -- 64 bit floating point type
+ X86_FP80TypeKind, -- 80 bit floating point type (X87)
+ FP128TypeKind, -- 128 bit floating point type (112-bit mantissa)
+ PPC_FP128TypeKind, -- 128 bit floating point type (two 64-bits)
+ LabelTypeKind, -- Labels
+ IntegerTypeKind, -- Arbitrary bit width integers
+ FunctionTypeKind, -- Functions
+ StructTypeKind, -- Structures
+ ArrayTypeKind, -- Arrays
+ PointerTypeKind, -- Pointers
+ VectorTypeKind, -- SIMD 'packed' format, or other vector type
+ MetadataTypeKind, -- Metadata
+ X86_MMXTypeKind -- X86 MMX
+ );
+ pragma Convention (C, TypeKind);
+
+ type Linkage is
+ (
+ ExternalLinkage, -- Externally visible function
+ AvailableExternallyLinkage,
+ LinkOnceAnyLinkage, -- Keep one copy of function when linking (inline)
+ LinkOnceODRLinkage, -- Same, but only replaced by someth equivalent.
+ LinkOnceODRAutoHideLinkage, -- Obsolete
+ WeakAnyLinkage, -- Keep one copy of function when linking (weak)
+ WeakODRLinkage, -- Same, but only replaced by someth equivalent.
+ AppendingLinkage, -- Special purpose, only applies to global arrays
+ InternalLinkage, -- Rename collisions when linking (static func)
+ PrivateLinkage, -- Like Internal, but omit from symbol table
+ DLLImportLinkage, -- Obsolete
+ DLLExportLinkage, -- Obsolete
+ ExternalWeakLinkage,-- ExternalWeak linkage description
+ GhostLinkage, -- Obsolete
+ CommonLinkage, -- Tentative definitions
+ LinkerPrivateLinkage, -- Like Private, but linker removes.
+ LinkerPrivateWeakLinkage -- Like LinkerPrivate, but is weak.
+ );
+ pragma Convention (C, Linkage);
+
+ type Visibility is
+ (
+ DefaultVisibility, -- The GV is visible
+ HiddenVisibility, -- The GV is hidden
+ ProtectedVisibility -- The GV is protected
+ );
+ pragma Convention (C, Visibility);
+
+ type CallConv is new unsigned;
+ CCallConv : constant CallConv := 0;
+ FastCallConv : constant CallConv := 8;
+ ColdCallConv : constant CallConv := 9;
+ X86StdcallCallConv : constant CallConv := 64;
+ X86FastcallCallConv : constant CallConv := 6;
+
+ type IntPredicate is new unsigned;
+ IntEQ : constant IntPredicate := 32; -- equal
+ IntNE : constant IntPredicate := 33; -- not equal
+ IntUGT : constant IntPredicate := 34; -- unsigned greater than
+ IntUGE : constant IntPredicate := 35; -- unsigned greater or equal
+ IntULT : constant IntPredicate := 36; -- unsigned less than
+ IntULE : constant IntPredicate := 37; -- unsigned less or equal
+ IntSGT : constant IntPredicate := 38; -- signed greater than
+ IntSGE : constant IntPredicate := 39; -- signed greater or equal
+ IntSLT : constant IntPredicate := 40; -- signed less than
+ IntSLE : constant IntPredicate := 41; -- signed less or equal
+
+ type RealPredicate is
+ (
+ RealPredicateFalse, -- Always false (always folded)
+ RealOEQ, -- True if ordered and equal
+ RealOGT, -- True if ordered and greater than
+ RealOGE, -- True if ordered and greater than or equal
+ RealOLT, -- True if ordered and less than
+ RealOLE, -- True if ordered and less than or equal
+ RealONE, -- True if ordered and operands are unequal
+ RealORD, -- True if ordered (no nans)
+ RealUNO, -- True if unordered: isnan(X) | isnan(Y)
+ RealUEQ, -- True if unordered or equal
+ RealUGT, -- True if unordered or greater than
+ RealUGE, -- True if unordered, greater than, or equal
+ RealULT, -- True if unordered or less than
+ RealULE, -- True if unordered, less than, or equal
+ RealUNE, -- True if unordered or not equal
+ RealPredicateTrue -- Always true (always folded)
+ );
+
+ -- Error handling ----------------------------------------------------
+
+ procedure DisposeMessage (Message : Cstring);
+
+
+ -- Context
+
+ -- Create a new context.
+ -- Every call to this function should be paired with a call to
+ -- LLVMContextDispose() or the context will leak memory.
+ function ContextCreate return ContextRef;
+
+ -- Obtain the global context instance.
+ function GetGlobalContext return ContextRef;
+
+ -- Destroy a context instance.
+ -- This should be called for every call to LLVMContextCreate() or memory
+ -- will be leaked.
+ procedure ContextDispose (C : ContextRef);
+
+ -- Modules -----------------------------------------------------------
+
+ -- Create and destroy modules.
+ -- See llvm::Module::Module.
+ function ModuleCreateWithName (ModuleID : Cstring) return ModuleRef;
+
+ -- See llvm::Module::~Module.
+ procedure DisposeModule (M : ModuleRef);
+
+ -- Data layout. See Module::getDataLayout.
+ function GetDataLayout(M : ModuleRef) return Cstring;
+ procedure SetDataLayout(M : ModuleRef; Triple : Cstring);
+
+ -- Target triple. See Module::getTargetTriple.
+ function GetTarget (M : ModuleRef) return Cstring;
+ procedure SetTarget (M : ModuleRef; Triple : Cstring);
+
+ -- See Module::dump.
+ procedure DumpModule(M : ModuleRef);
+
+ -- Print a representation of a module to a file. The ErrorMessage needs to
+ -- be disposed with LLVMDisposeMessage. Returns 0 on success, 1 otherwise.
+ --
+ -- @see Module::print()
+ function PrintModuleToFile(M : ModuleRef;
+ Filename : Cstring;
+ ErrorMessage : access Cstring) return Bool;
+
+
+ -- Types -------------------------------------------------------------
+
+ -- LLVM types conform to the following hierarchy:
+ --
+ -- types:
+ -- integer type
+ -- real type
+ -- function type
+ -- sequence types:
+ -- array type
+ -- pointer type
+ -- vector type
+ -- void type
+ -- label type
+ -- opaque type
+
+ -- See llvm::LLVMTypeKind::getTypeID.
+ function GetTypeKind (Ty : TypeRef) return TypeKind;
+
+ -- Operations on integer types
+ function Int1Type return TypeRef;
+ function Int8Type return TypeRef;
+ function Int16Type return TypeRef;
+ function Int32Type return TypeRef;
+ function Int64Type return TypeRef;
+ function IntType(NumBits : unsigned) return TypeRef;
+ function GetIntTypeWidth(IntegerTy : TypeRef) return unsigned;
+
+ function MetadataType return TypeRef;
+
+ -- Operations on real types
+ function FloatType return TypeRef;
+ function DoubleType return TypeRef;
+ function X86FP80Type return TypeRef;
+ function FP128Type return TypeRef;
+ function PPCFP128Type return TypeRef;
+
+ -- Operations on function types
+ function FunctionType(ReturnType : TypeRef;
+ ParamTypes : TypeRefArray;
+ ParamCount : unsigned;
+ IsVarArg : int) return TypeRef;
+
+ function IsFunctionVarArg(FunctionTy : TypeRef) return int;
+ function GetReturnType(FunctionTy : TypeRef) return TypeRef;
+ function CountParamTypes(FunctionTy : TypeRef) return unsigned;
+ procedure GetParamTypes(FunctionTy : TypeRef; Dest : out TypeRefArray);
+
+ -- Operations on struct types
+ function StructType(ElementTypes : TypeRefArray;
+ ElementCount : unsigned;
+ Packed : Bool) return TypeRef;
+ function StructCreateNamed(C : ContextRef; Name : Cstring) return TypeRef;
+ procedure StructSetBody(StructTy : TypeRef;
+ ElementTypes : TypeRefArray;
+ ElementCount : unsigned;
+ Packed : Bool);
+ function CountStructElementTypes(StructTy : TypeRef) return unsigned;
+ procedure GetStructElementTypes(StructTy : TypeRef;
+ Dest : out TypeRefArray);
+ function IsPackedStruct(StructTy : TypeRef) return Bool;
+
+
+ -- Operations on array, pointer, and vector types (sequence types)
+ function ArrayType(ElementType : TypeRef; ElementCount : unsigned)
+ return TypeRef;
+ function PointerType(ElementType : TypeRef; AddressSpace : unsigned := 0)
+ return TypeRef;
+ function VectorType(ElementType : TypeRef; ElementCount : unsigned)
+ return TypeRef;
+
+ function GetElementType(Ty : TypeRef) return TypeRef;
+ function GetArrayLength(ArrayTy : TypeRef) return unsigned;
+ function GetPointerAddressSpace(PointerTy : TypeRef) return unsigned;
+ function GetVectorSize(VectorTy : TypeRef) return unsigned;
+
+ -- Operations on other types.
+ function VoidType return TypeRef;
+ function LabelType return TypeRef;
+
+ -- See Module::dump.
+ procedure DumpType(T : TypeRef);
+
+ -- Values ------------------------------------------------------------
+ -- The bulk of LLVM's object model consists of values, which comprise a very
+ -- rich type hierarchy.
+ --
+ -- values:
+ -- constants:
+ -- scalar constants
+ -- composite contants
+ -- globals:
+ -- global variable
+ -- function
+ -- alias
+ -- basic blocks
+
+ -- Operations on all values
+ function TypeOf(Val : ValueRef) return TypeRef;
+ function GetValueName(Val : ValueRef) return Cstring;
+ procedure SetValueName(Val : ValueRef; Name : Cstring);
+ procedure DumpValue(Val : ValueRef);
+
+ -- Operations on constants of any type
+ function ConstNull(Ty : TypeRef) return ValueRef; -- All zero
+ function ConstAllOnes(Ty : TypeRef) return ValueRef; -- Int or Vec
+ function GetUndef(Ty : TypeRef) return ValueRef;
+ function IsConstant(Val : ValueRef) return int;
+ function IsNull(Val : ValueRef) return int;
+ function IsUndef(Val : ValueRef) return int;
+
+ -- Convert value instances between types.
+ --
+ -- Internally, an LLVMValueRef is "pinned" to a specific type. This
+ -- series of functions allows you to cast an instance to a specific
+ -- type.
+ --
+ -- If the cast is not valid for the specified type, NULL is returned.
+ --
+ -- @see llvm::dyn_cast_or_null<>
+ function IsAInstruction (Val : ValueRef) return ValueRef;
+
+ -- Operations on scalar constants
+ function ConstInt(IntTy : TypeRef; N : Unsigned_64; SignExtend : int)
+ return ValueRef;
+ function ConstReal(RealTy : TypeRef; N : double) return ValueRef;
+ function ConstRealOfString(RealTy : TypeRef; Text : Cstring)
+ return ValueRef;
+
+
+ -- Obtain the zero extended value for an integer constant value.
+ -- @see llvm::ConstantInt::getZExtValue()
+ function ConstIntGetZExtValue (ConstantVal : ValueRef) return Unsigned_64;
+
+ -- Operations on composite constants
+ function ConstString(Str : Cstring;
+ Length : unsigned; DontNullTerminate : int)
+ return ValueRef;
+ function ConstArray(ElementTy : TypeRef;
+ ConstantVals : ValueRefArray; Length : unsigned)
+ return ValueRef;
+ function ConstStruct(ConstantVals : ValueRefArray;
+ Count : unsigned; packed : int) return ValueRef;
+
+ -- Create a non-anonymous ConstantStruct from values.
+ -- @see llvm::ConstantStruct::get()
+ function ConstNamedStruct(StructTy : TypeRef;
+ ConstantVals : ValueRefArray;
+ Count : unsigned) return ValueRef;
+
+ function ConstVector(ScalarConstantVals : ValueRefArray; Size : unsigned)
+ return ValueRef;
+
+ -- Constant expressions
+ function SizeOf(Ty : TypeRef) return ValueRef;
+ function AlignOf(Ty : TypeRef) return ValueRef;
+
+ function ConstNeg(ConstantVal : ValueRef) return ValueRef;
+ function ConstNot(ConstantVal : ValueRef) return ValueRef;
+ function ConstAdd(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstSub(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstMul(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstUDiv(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstSDiv(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstFDiv(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstURem(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstSRem(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstFRem(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstAnd(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstOr(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstXor(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstICmp(Predicate : IntPredicate;
+ LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstFCmp(Predicate : RealPredicate;
+ LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstShl(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstLShr(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstAShr(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstGEP(ConstantVal : ValueRef;
+ ConstantIndices : ValueRefArray; NumIndices : unsigned)
+ return ValueRef;
+ function ConstTrunc(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstSExt(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstZExt(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstFPTrunc(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstFPExt(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstUIToFP(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstSIToFP(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstFPToUI(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstFPToSI(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstPtrToInt(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstIntToPtr(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstBitCast(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+
+ function ConstTruncOrBitCast(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+
+ function ConstSelect(ConstantCondition : ValueRef;
+ ConstantIfTrue : ValueRef;
+ ConstantIfFalse : ValueRef) return ValueRef;
+ function ConstExtractElement(VectorConstant : ValueRef;
+ IndexConstant : ValueRef) return ValueRef;
+ function ConstInsertElement(VectorConstant : ValueRef;
+ ElementValueConstant : ValueRef;
+ IndexConstant : ValueRef) return ValueRef;
+ function ConstShuffleVector(VectorAConstant : ValueRef;
+ VectorBConstant : ValueRef;
+ MaskConstant : ValueRef) return ValueRef;
+
+ -- Operations on global variables, functions, and aliases (globals)
+ function GetGlobalParent(Global : ValueRef) return ModuleRef;
+ function IsDeclaration(Global : ValueRef) return int;
+ function GetLinkage(Global : ValueRef) return Linkage;
+ procedure SetLinkage(Global : ValueRef; Link : Linkage);
+ function GetSection(Global : ValueRef) return Cstring;
+ procedure SetSection(Global : ValueRef; Section : Cstring);
+ function GetVisibility(Global : ValueRef) return Visibility;
+ procedure SetVisibility(Global : ValueRef; Viz : Visibility);
+ function GetAlignment(Global : ValueRef) return unsigned;
+ procedure SetAlignment(Global : ValueRef; Bytes : unsigned);
+
+ -- Operations on global variables
+ function AddGlobal(M : ModuleRef; Ty : TypeRef; Name : Cstring)
+ return ValueRef;
+ function GetNamedGlobal(M : ModuleRef; Name : Cstring) return ValueRef;
+ function GetFirstGlobal(M : ModuleRef) return ValueRef;
+ function GetLastGlobal(M : ModuleRef) return ValueRef;
+ function GetNextGlobal(GlobalVar : ValueRef) return ValueRef;
+ function GetPreviousGlobal(GlobalVar : ValueRef) return ValueRef;
+ procedure DeleteGlobal(GlobalVar : ValueRef);
+ function GetInitializer(GlobalVar : ValueRef) return ValueRef;
+ procedure SetInitializer(GlobalVar : ValueRef; ConstantVal : ValueRef);
+ function IsThreadLocal(GlobalVar : ValueRef) return int;
+ procedure SetThreadLocal(GlobalVar : ValueRef; IsThreadLocal : int);
+ function IsGlobalConstant(GlobalVar : ValueRef) return int;
+ procedure SetGlobalConstant(GlobalVar : ValueRef; IsConstant : int);
+
+ -- Operations on functions
+ function AddFunction(M : ModuleRef; Name : Cstring; FunctionTy : TypeRef)
+ return ValueRef;
+ function GetNamedFunction(M : ModuleRef; Name : Cstring) return ValueRef;
+ function GetFirstFunction(M : ModuleRef) return ValueRef;
+ function GetLastFunction(M : ModuleRef) return ValueRef;
+ function GetNextFunction(Fn : ValueRef) return ValueRef;
+ function GetPreviousFunction(Fn : ValueRef) return ValueRef;
+ procedure DeleteFunction(Fn : ValueRef);
+ function GetIntrinsicID(Fn : ValueRef) return unsigned;
+ function GetFunctionCallConv(Fn : ValueRef) return CallConv;
+ procedure SetFunctionCallConv(Fn : ValueRef; CC : CallConv);
+ function GetGC(Fn : ValueRef) return Cstring;
+ procedure SetGC(Fn : ValueRef; Name : Cstring);
+
+ -- Add an attribute to a function.
+ -- @see llvm::Function::addAttribute()
+ procedure AddFunctionAttr (Fn : ValueRef; PA : Attribute);
+
+ -- Add a target-dependent attribute to a fuction
+ -- @see llvm::AttrBuilder::addAttribute()
+ procedure AddTargetDependentFunctionAttr
+ (Fn : ValueRef; A : Cstring; V : Cstring);
+
+ -- Obtain an attribute from a function.
+ -- @see llvm::Function::getAttributes()
+ function GetFunctionAttr (Fn : ValueRef) return Attribute;
+
+ -- Remove an attribute from a function.
+ procedure RemoveFunctionAttr (Fn : ValueRef; PA : Attribute);
+
+ -- Operations on parameters
+ function CountParams(Fn : ValueRef) return unsigned;
+ procedure GetParams(Fn : ValueRef; Params : ValueRefArray);
+ function GetParam(Fn : ValueRef; Index : unsigned) return ValueRef;
+ function GetParamParent(Inst : ValueRef) return ValueRef;
+ function GetFirstParam(Fn : ValueRef) return ValueRef;
+ function GetLastParam(Fn : ValueRef) return ValueRef;
+ function GetNextParam(Arg : ValueRef) return ValueRef;
+ function GetPreviousParam(Arg : ValueRef) return ValueRef;
+ procedure AddAttribute(Arg : ValueRef; PA : Attribute);
+ procedure RemoveAttribute(Arg : ValueRef; PA : Attribute);
+ procedure SetParamAlignment(Arg : ValueRef; align : unsigned);
+
+ -- Operations on basic blocks
+ function BasicBlockAsValue(BB : BasicBlockRef) return ValueRef;
+ function ValueIsBasicBlock(Val : ValueRef) return int;
+ function ValueAsBasicBlock(Val : ValueRef) return BasicBlockRef;
+ function GetBasicBlockParent(BB : BasicBlockRef) return ValueRef;
+ function CountBasicBlocks(Fn : ValueRef) return unsigned;
+ procedure GetBasicBlocks(Fn : ValueRef; BasicBlocks : BasicBlockRefArray);
+ function GetFirstBasicBlock(Fn : ValueRef) return BasicBlockRef;
+ function GetLastBasicBlock(Fn : ValueRef) return BasicBlockRef;
+ function GetNextBasicBlock(BB : BasicBlockRef) return BasicBlockRef;
+ function GetPreviousBasicBlock(BB : BasicBlockRef) return BasicBlockRef;
+ function GetEntryBasicBlock(Fn : ValueRef) return BasicBlockRef;
+ function AppendBasicBlock(Fn : ValueRef; Name : Cstring)
+ return BasicBlockRef;
+ function InsertBasicBlock(InsertBeforeBB : BasicBlockRef;
+ Name : Cstring) return BasicBlockRef;
+ procedure DeleteBasicBlock(BB : BasicBlockRef);
+
+ -- Operations on instructions
+
+ -- Determine whether an instruction has any metadata attached.
+ function HasMetadata(Val: ValueRef) return Bool;
+
+ -- Return metadata associated with an instruction value.
+ function GetMetadata(Val : ValueRef; KindID : unsigned) return ValueRef;
+
+ -- Set metadata associated with an instruction value.
+ procedure SetMetadata(Val : ValueRef; KindID : unsigned; Node : ValueRef);
+
+ function GetInstructionParent(Inst : ValueRef) return BasicBlockRef;
+ function GetFirstInstruction(BB : BasicBlockRef) return ValueRef;
+ function GetLastInstruction(BB : BasicBlockRef) return ValueRef;
+ function GetNextInstruction(Inst : ValueRef) return ValueRef;
+ function GetPreviousInstruction(Inst : ValueRef) return ValueRef;
+
+ -- Operations on call sites
+ procedure SetInstructionCallConv(Instr : ValueRef; CC : unsigned);
+ function GetInstructionCallConv(Instr : ValueRef) return unsigned;
+ procedure AddInstrAttribute(Instr : ValueRef;
+ index : unsigned; Attr : Attribute);
+ procedure RemoveInstrAttribute(Instr : ValueRef;
+ index : unsigned; Attr : Attribute);
+ procedure SetInstrParamAlignment(Instr : ValueRef;
+ index : unsigned; align : unsigned);
+
+ -- Operations on call instructions (only)
+ function IsTailCall(CallInst : ValueRef) return int;
+ procedure SetTailCall(CallInst : ValueRef; IsTailCall : int);
+
+ -- Operations on phi nodes
+ procedure AddIncoming(PhiNode : ValueRef; IncomingValues : ValueRefArray;
+ IncomingBlocks : BasicBlockRefArray; Count : unsigned);
+ function CountIncoming(PhiNode : ValueRef) return unsigned;
+ function GetIncomingValue(PhiNode : ValueRef; Index : unsigned)
+ return ValueRef;
+ function GetIncomingBlock(PhiNode : ValueRef; Index : unsigned)
+ return BasicBlockRef;
+
+ -- Instruction builders ----------------------------------------------
+ -- An instruction builder represents a point within a basic block,
+ -- and is the exclusive means of building instructions using the C
+ -- interface.
+
+ function CreateBuilder return BuilderRef;
+ procedure PositionBuilder(Builder : BuilderRef;
+ Block : BasicBlockRef; Instr : ValueRef);
+ procedure PositionBuilderBefore(Builder : BuilderRef; Instr : ValueRef);
+ procedure PositionBuilderAtEnd(Builder : BuilderRef; Block : BasicBlockRef);
+ function GetInsertBlock(Builder : BuilderRef) return BasicBlockRef;
+ procedure DisposeBuilder(Builder : BuilderRef);
+
+ -- Terminators
+ function BuildRetVoid(Builder : BuilderRef) return ValueRef;
+ function BuildRet(Builder : BuilderRef; V : ValueRef) return ValueRef;
+ function BuildBr(Builder : BuilderRef; Dest : BasicBlockRef)
+ return ValueRef;
+ function BuildCondBr(Builder : BuilderRef;
+ If_Br : ValueRef;
+ Then_Br : BasicBlockRef; Else_Br : BasicBlockRef)
+ return ValueRef;
+ function BuildSwitch(Builder : BuilderRef;
+ V : ValueRef;
+ Else_Br : BasicBlockRef; NumCases : unsigned)
+ return ValueRef;
+ function BuildInvoke(Builder : BuilderRef;
+ Fn : ValueRef;
+ Args : ValueRefArray;
+ NumArgs : unsigned;
+ Then_Br : BasicBlockRef;
+ Catch : BasicBlockRef;
+ Name : Cstring) return ValueRef;
+ function BuildUnwind(Builder : BuilderRef) return ValueRef;
+ function BuildUnreachable(Builder : BuilderRef) return ValueRef;
+
+ -- Add a case to the switch instruction
+ procedure AddCase(Switch : ValueRef;
+ OnVal : ValueRef; Dest : BasicBlockRef);
+
+ -- Arithmetic
+ function BuildAdd(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNSWAdd(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNUWAdd(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFAdd(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+
+ function BuildSub(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNSWSub(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNUWSub(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFSub(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+
+ function BuildMul(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFMul(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+
+ function BuildUDiv(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildSDiv(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFDiv(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildURem(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildSRem(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFRem(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildShl(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildLShr(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildAShr(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildAnd(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildOr(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildXor(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNeg(Builder : BuilderRef; V : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFNeg(Builder : BuilderRef; V : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNot(Builder : BuilderRef; V : ValueRef; Name : Cstring)
+ return ValueRef;
+
+ -- Memory
+ function BuildMalloc(Builder : BuilderRef; Ty : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildArrayMalloc(Builder : BuilderRef;
+ Ty : TypeRef; Val : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildAlloca(Builder : BuilderRef; Ty : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildArrayAlloca(Builder : BuilderRef;
+ Ty : TypeRef; Val : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFree(Builder : BuilderRef; PointerVal : ValueRef)
+ return ValueRef;
+ function BuildLoad(Builder : BuilderRef; PointerVal : ValueRef;
+ Name : Cstring) return ValueRef;
+ function BuildStore(Builder : BuilderRef; Val : ValueRef; Ptr : ValueRef)
+ return ValueRef;
+ function BuildGEP(Builder : BuilderRef;
+ Pointer : ValueRef;
+ Indices : ValueRefArray;
+ NumIndices : unsigned; Name : Cstring) return ValueRef;
+
+ -- Casts
+ function BuildTrunc(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildZExt(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildSExt(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildFPToUI(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildFPToSI(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildUIToFP(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildSIToFP(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildFPTrunc(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildFPExt(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildPtrToInt(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildIntToPtr(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildBitCast(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+
+ -- Comparisons
+ function BuildICmp(Builder : BuilderRef;
+ Op : IntPredicate;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFCmp(Builder : BuilderRef;
+ Op : RealPredicate;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+
+ -- Miscellaneous instructions
+ function BuildPhi(Builder : BuilderRef; Ty : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildCall(Builder : BuilderRef;
+ Fn : ValueRef;
+ Args : ValueRefArray; NumArgs : unsigned; Name : Cstring)
+ return ValueRef;
+ function BuildSelect(Builder : BuilderRef;
+ If_Sel : ValueRef;
+ Then_Sel : ValueRef;
+ Else_Sel : ValueRef;
+ Name : Cstring) return ValueRef;
+ function BuildVAArg(Builder : BuilderRef;
+ List : ValueRef; Ty : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildExtractElement(Builder : BuilderRef;
+ VecVal : ValueRef;
+ Index : ValueRef;
+ Name : Cstring) return ValueRef;
+ function BuildInsertElement(Builder : BuilderRef;
+ VecVal : ValueRef;
+ EltVal : ValueRef;
+ Index : ValueRef;
+ Name : Cstring) return ValueRef;
+ function BuildShuffleVector(Builder : BuilderRef;
+ V1 : ValueRef;
+ V2 : ValueRef;
+ Mask : ValueRef;
+ Name : Cstring) return ValueRef;
+
+ -- Memory buffers ----------------------------------------------------
+
+ function CreateMemoryBufferWithContentsOfFile
+ (Path : Cstring;
+ OutMemBuf : access MemoryBufferRef;
+ OutMessage : access Cstring) return int;
+ function CreateMemoryBufferWithSTDIN
+ (OutMemBuf : access MemoryBufferRef;
+ OutMessage : access Cstring) return int;
+ procedure DisposeMemoryBuffer(MemBuf : MemoryBufferRef);
+
+
+ -- Pass Managers -----------------------------------------------------
+
+ -- Constructs a new whole-module pass pipeline. This type of pipeline is
+ -- suitable for link-time optimization and whole-module transformations.
+ -- See llvm::PassManager::PassManager.
+ function CreatePassManager return PassManagerRef;
+
+ -- Constructs a new function-by-function pass pipeline over the module
+ -- provider. It does not take ownership of the module provider. This type of
+ -- pipeline is suitable for code generation and JIT compilation tasks.
+ -- See llvm::FunctionPassManager::FunctionPassManager.
+ function CreateFunctionPassManagerForModule(M : ModuleRef)
+ return PassManagerRef;
+
+ -- Initializes, executes on the provided module, and finalizes all of the
+ -- passes scheduled in the pass manager. Returns 1 if any of the passes
+ -- modified the module, 0 otherwise. See llvm::PassManager::run(Module&).
+ function RunPassManager(PM : PassManagerRef; M : ModuleRef)
+ return int;
+
+ -- Initializes all of the function passes scheduled in the function pass
+ -- manager. Returns 1 if any of the passes modified the module, 0 otherwise.
+ -- See llvm::FunctionPassManager::doInitialization.
+ function InitializeFunctionPassManager(FPM : PassManagerRef)
+ return int;
+
+ -- Executes all of the function passes scheduled in the function
+ -- pass manager on the provided function. Returns 1 if any of the
+ -- passes modified the function, false otherwise.
+ -- See llvm::FunctionPassManager::run(Function&).
+ function RunFunctionPassManager (FPM : PassManagerRef; F : ValueRef)
+ return int;
+
+ -- Finalizes all of the function passes scheduled in in the function pass
+ -- manager. Returns 1 if any of the passes modified the module, 0 otherwise.
+ -- See llvm::FunctionPassManager::doFinalization.
+ function FinalizeFunctionPassManager(FPM : PassManagerRef)
+ return int;
+
+ -- Frees the memory of a pass pipeline. For function pipelines,
+ -- does not free the module provider.
+ -- See llvm::PassManagerBase::~PassManagerBase.
+ procedure DisposePassManager(PM : PassManagerRef);
+
+private
+ pragma Import (C, ContextCreate, "LLVMContextCreate");
+ pragma Import (C, GetGlobalContext, "LLVMGetGlobalContext");
+ pragma Import (C, ContextDispose, "LLVMContextDispose");
+
+ pragma Import (C, DisposeMessage, "LLVMDisposeMessage");
+ pragma Import (C, ModuleCreateWithName, "LLVMModuleCreateWithName");
+ pragma Import (C, DisposeModule, "LLVMDisposeModule");
+ pragma Import (C, GetDataLayout, "LLVMGetDataLayout");
+ pragma Import (C, SetDataLayout, "LLVMSetDataLayout");
+ pragma Import (C, GetTarget, "LLVMGetTarget");
+ pragma Import (C, SetTarget, "LLVMSetTarget");
+ pragma Import (C, DumpModule, "LLVMDumpModule");
+ pragma Import (C, PrintModuleToFile, "LLVMPrintModuleToFile");
+ pragma Import (C, GetTypeKind, "LLVMGetTypeKind");
+ pragma Import (C, Int1Type, "LLVMInt1Type");
+ pragma Import (C, Int8Type, "LLVMInt8Type");
+ pragma Import (C, Int16Type, "LLVMInt16Type");
+ pragma Import (C, Int32Type, "LLVMInt32Type");
+ pragma Import (C, Int64Type, "LLVMInt64Type");
+ pragma Import (C, IntType, "LLVMIntType");
+ pragma Import (C, GetIntTypeWidth, "LLVMGetIntTypeWidth");
+ pragma Import (C, MetadataType, "LLVMMetadataType_extra");
+
+ pragma Import (C, FloatType, "LLVMFloatType");
+ pragma Import (C, DoubleType, "LLVMDoubleType");
+ pragma Import (C, X86FP80Type, "LLVMX86FP80Type");
+ pragma Import (C, FP128Type, "LLVMFP128Type");
+ pragma Import (C, PPCFP128Type, "LLVMPPCFP128Type");
+
+ pragma Import (C, FunctionType, "LLVMFunctionType");
+ pragma Import (C, IsFunctionVarArg, "LLVMIsFunctionVarArg");
+ pragma Import (C, GetReturnType, "LLVMGetReturnType");
+ pragma Import (C, CountParamTypes, "LLVMCountParamTypes");
+ pragma Import (C, GetParamTypes, "LLVMGetParamTypes");
+
+ pragma Import (C, StructType, "LLVMStructType");
+ pragma Import (C, StructCreateNamed, "LLVMStructCreateNamed");
+ pragma Import (C, StructSetBody, "LLVMStructSetBody");
+ pragma Import (C, CountStructElementTypes, "LLVMCountStructElementTypes");
+ pragma Import (C, GetStructElementTypes, "LLVMGetStructElementTypes");
+ pragma Import (C, IsPackedStruct, "LLVMIsPackedStruct");
+
+ pragma Import (C, ArrayType, "LLVMArrayType");
+ pragma Import (C, PointerType, "LLVMPointerType");
+ pragma Import (C, VectorType, "LLVMVectorType");
+ pragma Import (C, GetElementType, "LLVMGetElementType");
+ pragma Import (C, GetArrayLength, "LLVMGetArrayLength");
+ pragma Import (C, GetPointerAddressSpace, "LLVMGetPointerAddressSpace");
+ pragma Import (C, GetVectorSize, "LLVMGetVectorSize");
+
+ pragma Import (C, VoidType, "LLVMVoidType");
+ pragma Import (C, LabelType, "LLVMLabelType");
+ pragma Import (C, DumpType, "LLVMDumpType");
+
+ pragma Import (C, TypeOf, "LLVMTypeOf");
+ pragma Import (C, GetValueName, "LLVMGetValueName");
+ pragma Import (C, SetValueName, "LLVMSetValueName");
+ pragma Import (C, DumpValue, "LLVMDumpValue");
+
+ pragma Import (C, ConstNull, "LLVMConstNull");
+ pragma Import (C, ConstAllOnes, "LLVMConstAllOnes");
+ pragma Import (C, GetUndef, "LLVMGetUndef");
+ pragma Import (C, IsConstant, "LLVMIsConstant");
+ pragma Import (C, IsNull, "LLVMIsNull");
+ pragma Import (C, IsUndef, "LLVMIsUndef");
+ pragma Import (C, IsAInstruction, "LLVMIsAInstruction");
+
+ pragma Import (C, ConstInt, "LLVMConstInt");
+ pragma Import (C, ConstReal, "LLVMConstReal");
+ pragma Import (C, ConstIntGetZExtValue, "LLVMConstIntGetZExtValue");
+ pragma Import (C, ConstRealOfString, "LLVMConstRealOfString");
+ pragma Import (C, ConstString, "LLVMConstString");
+ pragma Import (C, ConstArray, "LLVMConstArray");
+ pragma Import (C, ConstStruct, "LLVMConstStruct");
+ pragma Import (C, ConstNamedStruct, "LLVMConstNamedStruct");
+ pragma Import (C, ConstVector, "LLVMConstVector");
+
+ pragma Import (C, SizeOf, "LLVMSizeOf");
+ pragma Import (C, AlignOf, "LLVMAlignOf");
+ pragma Import (C, ConstNeg, "LLVMConstNeg");
+ pragma Import (C, ConstNot, "LLVMConstNot");
+ pragma Import (C, ConstAdd, "LLVMConstAdd");
+ pragma Import (C, ConstSub, "LLVMConstSub");
+ pragma Import (C, ConstMul, "LLVMConstMul");
+ pragma Import (C, ConstUDiv, "LLVMConstUDiv");
+ pragma Import (C, ConstSDiv, "LLVMConstSDiv");
+ pragma Import (C, ConstFDiv, "LLVMConstFDiv");
+ pragma Import (C, ConstURem, "LLVMConstURem");
+ pragma Import (C, ConstSRem, "LLVMConstSRem");
+ pragma Import (C, ConstFRem, "LLVMConstFRem");
+ pragma Import (C, ConstAnd, "LLVMConstAnd");
+ pragma Import (C, ConstOr, "LLVMConstOr");
+ pragma Import (C, ConstXor, "LLVMConstXor");
+ pragma Import (C, ConstICmp, "LLVMConstICmp");
+ pragma Import (C, ConstFCmp, "LLVMConstFCmp");
+ pragma Import (C, ConstShl, "LLVMConstShl");
+ pragma Import (C, ConstLShr, "LLVMConstLShr");
+ pragma Import (C, ConstAShr, "LLVMConstAShr");
+ pragma Import (C, ConstGEP, "LLVMConstGEP");
+ pragma Import (C, ConstTrunc, "LLVMConstTrunc");
+ pragma Import (C, ConstSExt, "LLVMConstSExt");
+ pragma Import (C, ConstZExt, "LLVMConstZExt");
+ pragma Import (C, ConstFPTrunc, "LLVMConstFPTrunc");
+ pragma Import (C, ConstFPExt, "LLVMConstFPExt");
+ pragma Import (C, ConstUIToFP, "LLVMConstUIToFP");
+ pragma Import (C, ConstSIToFP, "LLVMConstSIToFP");
+ pragma Import (C, ConstFPToUI, "LLVMConstFPToUI");
+ pragma Import (C, ConstFPToSI, "LLVMConstFPToSI");
+ pragma Import (C, ConstPtrToInt, "LLVMConstPtrToInt");
+ pragma Import (C, ConstIntToPtr, "LLVMConstIntToPtr");
+ pragma Import (C, ConstBitCast, "LLVMConstBitCast");
+ pragma Import (C, ConstTruncOrBitCast, "LLVMConstTruncOrBitCast");
+ pragma Import (C, ConstSelect, "LLVMConstSelect");
+ pragma Import (C, ConstExtractElement, "LLVMConstExtractElement");
+ pragma Import (C, ConstInsertElement, "LLVMConstInsertElement");
+ pragma Import (C, ConstShuffleVector, "LLVMConstShuffleVector");
+
+ pragma Import (C, GetGlobalParent, "LLVMGetGlobalParent");
+ pragma Import (C, IsDeclaration, "LLVMIsDeclaration");
+ pragma Import (C, GetLinkage, "LLVMGetLinkage");
+ pragma Import (C, SetLinkage, "LLVMSetLinkage");
+ pragma Import (C, GetSection, "LLVMGetSection");
+ pragma Import (C, SetSection, "LLVMSetSection");
+ pragma Import (C, GetVisibility, "LLVMGetVisibility");
+ pragma Import (C, SetVisibility, "LLVMSetVisibility");
+ pragma Import (C, GetAlignment, "LLVMGetAlignment");
+ pragma Import (C, SetAlignment, "LLVMSetAlignment");
+
+ pragma Import (C, AddGlobal, "LLVMAddGlobal");
+ pragma Import (C, GetNamedGlobal, "LLVMGetNamedGlobal");
+ pragma Import (C, GetFirstGlobal, "LLVMGetFirstGlobal");
+ pragma Import (C, GetLastGlobal, "LLVMGetLastGlobal");
+ pragma Import (C, GetNextGlobal, "LLVMGetNextGlobal");
+ pragma Import (C, GetPreviousGlobal, "LLVMGetPreviousGlobal");
+ pragma Import (C, DeleteGlobal, "LLVMDeleteGlobal");
+ pragma Import (C, GetInitializer, "LLVMGetInitializer");
+ pragma Import (C, SetInitializer, "LLVMSetInitializer");
+ pragma Import (C, IsThreadLocal, "LLVMIsThreadLocal");
+ pragma Import (C, SetThreadLocal, "LLVMSetThreadLocal");
+ pragma Import (C, IsGlobalConstant, "LLVMIsGlobalConstant");
+ pragma Import (C, SetGlobalConstant, "LLVMSetGlobalConstant");
+
+ pragma Import (C, AddFunction, "LLVMAddFunction");
+ pragma Import (C, GetNamedFunction, "LLVMGetNamedFunction");
+ pragma Import (C, GetFirstFunction, "LLVMGetFirstFunction");
+ pragma Import (C, GetLastFunction, "LLVMGetLastFunction");
+ pragma Import (C, GetNextFunction, "LLVMGetNextFunction");
+ pragma Import (C, GetPreviousFunction, "LLVMGetPreviousFunction");
+ pragma Import (C, DeleteFunction, "LLVMDeleteFunction");
+ pragma Import (C, GetIntrinsicID, "LLVMGetIntrinsicID");
+ pragma Import (C, GetFunctionCallConv, "LLVMGetFunctionCallConv");
+ pragma Import (C, SetFunctionCallConv, "LLVMSetFunctionCallConv");
+ pragma Import (C, GetGC, "LLVMGetGC");
+ pragma Import (C, SetGC, "LLVMSetGC");
+
+ pragma Import (C, AddFunctionAttr, "LLVMAddFunctionAttr");
+ pragma import (C, AddTargetDependentFunctionAttr,
+ "LLVMAddTargetDependentFunctionAttr");
+ pragma Import (C, GetFunctionAttr, "LLVMGetFunctionAttr");
+ pragma Import (C, RemoveFunctionAttr, "LLVMRemoveFunctionAttr");
+
+ pragma Import (C, CountParams, "LLVMCountParams");
+ pragma Import (C, GetParams, "LLVMGetParams");
+ pragma Import (C, GetParam, "LLVMGetParam");
+ pragma Import (C, GetParamParent, "LLVMGetParamParent");
+ pragma Import (C, GetFirstParam, "LLVMGetFirstParam");
+ pragma Import (C, GetLastParam, "LLVMGetLastParam");
+ pragma Import (C, GetNextParam, "LLVMGetNextParam");
+ pragma Import (C, GetPreviousParam, "LLVMGetPreviousParam");
+ pragma Import (C, AddAttribute, "LLVMAddAttribute");
+ pragma Import (C, RemoveAttribute, "LLVMRemoveAttribute");
+ pragma Import (C, SetParamAlignment, "LLVMSetParamAlignment");
+
+ pragma Import (C, BasicBlockAsValue, "LLVMBasicBlockAsValue");
+ pragma Import (C, ValueIsBasicBlock, "LLVMValueIsBasicBlock");
+ pragma Import (C, ValueAsBasicBlock, "LLVMValueAsBasicBlock");
+ pragma Import (C, GetBasicBlockParent, "LLVMGetBasicBlockParent");
+ pragma Import (C, CountBasicBlocks, "LLVMCountBasicBlocks");
+ pragma Import (C, GetBasicBlocks, "LLVMGetBasicBlocks");
+ pragma Import (C, GetFirstBasicBlock, "LLVMGetFirstBasicBlock");
+ pragma Import (C, GetLastBasicBlock, "LLVMGetLastBasicBlock");
+ pragma Import (C, GetNextBasicBlock, "LLVMGetNextBasicBlock");
+ pragma Import (C, GetPreviousBasicBlock, "LLVMGetPreviousBasicBlock");
+ pragma Import (C, GetEntryBasicBlock, "LLVMGetEntryBasicBlock");
+ pragma Import (C, AppendBasicBlock, "LLVMAppendBasicBlock");
+ pragma Import (C, InsertBasicBlock, "LLVMInsertBasicBlock");
+ pragma Import (C, DeleteBasicBlock, "LLVMDeleteBasicBlock");
+
+ pragma Import (C, HasMetadata, "LLVMHasMetadata");
+ pragma Import (C, GetMetadata, "LLVMGetMetadata");
+ pragma Import (C, SetMetadata, "LLVMSetMetadata");
+
+ pragma Import (C, GetInstructionParent, "LLVMGetInstructionParent");
+ pragma Import (C, GetFirstInstruction, "LLVMGetFirstInstruction");
+ pragma Import (C, GetLastInstruction, "LLVMGetLastInstruction");
+ pragma Import (C, GetNextInstruction, "LLVMGetNextInstruction");
+ pragma Import (C, GetPreviousInstruction, "LLVMGetPreviousInstruction");
+
+ pragma Import (C, SetInstructionCallConv, "LLVMSetInstructionCallConv");
+ pragma Import (C, GetInstructionCallConv, "LLVMGetInstructionCallConv");
+ pragma Import (C, AddInstrAttribute, "LLVMAddInstrAttribute");
+ pragma Import (C, RemoveInstrAttribute, "LLVMRemoveInstrAttribute");
+ pragma Import (C, SetInstrParamAlignment, "LLVMSetInstrParamAlignment");
+
+ pragma Import (C, IsTailCall, "LLVMIsTailCall");
+ pragma Import (C, SetTailCall, "LLVMSetTailCall");
+
+ pragma Import (C, AddIncoming, "LLVMAddIncoming");
+ pragma Import (C, CountIncoming, "LLVMCountIncoming");
+ pragma Import (C, GetIncomingValue, "LLVMGetIncomingValue");
+ pragma Import (C, GetIncomingBlock, "LLVMGetIncomingBlock");
+
+ pragma Import (C, CreateBuilder, "LLVMCreateBuilder");
+ pragma Import (C, PositionBuilder, "LLVMPositionBuilder");
+ pragma Import (C, PositionBuilderBefore, "LLVMPositionBuilderBefore");
+ pragma Import (C, PositionBuilderAtEnd, "LLVMPositionBuilderAtEnd");
+ pragma Import (C, GetInsertBlock, "LLVMGetInsertBlock");
+ pragma Import (C, DisposeBuilder, "LLVMDisposeBuilder");
+
+ -- Terminators
+ pragma Import (C, BuildRetVoid, "LLVMBuildRetVoid");
+ pragma Import (C, BuildRet, "LLVMBuildRet");
+ pragma Import (C, BuildBr, "LLVMBuildBr");
+ pragma Import (C, BuildCondBr, "LLVMBuildCondBr");
+ pragma Import (C, BuildSwitch, "LLVMBuildSwitch");
+ pragma Import (C, BuildInvoke, "LLVMBuildInvoke");
+ pragma Import (C, BuildUnwind, "LLVMBuildUnwind");
+ pragma Import (C, BuildUnreachable, "LLVMBuildUnreachable");
+
+ -- Add a case to the switch instruction
+ pragma Import (C, AddCase, "LLVMAddCase");
+
+ -- Arithmetic
+ pragma Import (C, BuildAdd, "LLVMBuildAdd");
+ pragma Import (C, BuildNSWAdd, "LLVMBuildNSWAdd");
+ pragma Import (C, BuildNUWAdd, "LLVMBuildNUWAdd");
+ pragma Import (C, BuildFAdd, "LLVMBuildFAdd");
+ pragma Import (C, BuildSub, "LLVMBuildSub");
+ pragma Import (C, BuildNSWSub, "LLVMBuildNSWSub");
+ pragma Import (C, BuildNUWSub, "LLVMBuildNUWSub");
+ pragma Import (C, BuildFSub, "LLVMBuildFSub");
+ pragma Import (C, BuildMul, "LLVMBuildMul");
+ pragma Import (C, BuildFMul, "LLVMBuildFMul");
+ pragma Import (C, BuildUDiv, "LLVMBuildUDiv");
+ pragma Import (C, BuildSDiv, "LLVMBuildSDiv");
+ pragma Import (C, BuildFDiv, "LLVMBuildFDiv");
+ pragma Import (C, BuildURem, "LLVMBuildURem");
+ pragma Import (C, BuildSRem, "LLVMBuildSRem");
+ pragma Import (C, BuildFRem, "LLVMBuildFRem");
+ pragma Import (C, BuildShl, "LLVMBuildShl");
+ pragma Import (C, BuildLShr, "LLVMBuildLShr");
+ pragma Import (C, BuildAShr, "LLVMBuildAShr");
+ pragma Import (C, BuildAnd, "LLVMBuildAnd");
+ pragma Import (C, BuildOr, "LLVMBuildOr");
+ pragma Import (C, BuildXor, "LLVMBuildXor");
+ pragma Import (C, BuildNeg, "LLVMBuildNeg");
+ pragma Import (C, BuildFNeg, "LLVMBuildFNeg");
+ pragma Import (C, BuildNot, "LLVMBuildNot");
+
+ -- Memory
+ pragma Import (C, BuildMalloc, "LLVMBuildMalloc");
+ pragma Import (C, BuildArrayMalloc, "LLVMBuildArrayMalloc");
+ pragma Import (C, BuildAlloca, "LLVMBuildAlloca");
+ pragma Import (C, BuildArrayAlloca, "LLVMBuildArrayAlloca");
+ pragma Import (C, BuildFree, "LLVMBuildFree");
+ pragma Import (C, BuildLoad, "LLVMBuildLoad");
+ pragma Import (C, BuildStore, "LLVMBuildStore");
+ pragma Import (C, BuildGEP, "LLVMBuildGEP");
+
+ -- Casts
+ pragma Import (C, BuildTrunc, "LLVMBuildTrunc");
+ pragma Import (C, BuildZExt, "LLVMBuildZExt");
+ pragma Import (C, BuildSExt, "LLVMBuildSExt");
+ pragma Import (C, BuildFPToUI, "LLVMBuildFPToUI");
+ pragma Import (C, BuildFPToSI, "LLVMBuildFPToSI");
+ pragma Import (C, BuildUIToFP, "LLVMBuildUIToFP");
+ pragma Import (C, BuildSIToFP, "LLVMBuildSIToFP");
+ pragma Import (C, BuildFPTrunc, "LLVMBuildFPTrunc");
+ pragma Import (C, BuildFPExt, "LLVMBuildFPExt");
+ pragma Import (C, BuildPtrToInt, "LLVMBuildPtrToInt");
+ pragma Import (C, BuildIntToPtr, "LLVMBuildIntToPtr");
+ pragma Import (C, BuildBitCast, "LLVMBuildBitCast");
+
+ -- Comparisons
+ pragma Import (C, BuildICmp, "LLVMBuildICmp");
+ pragma Import (C, BuildFCmp, "LLVMBuildFCmp");
+
+ -- Miscellaneous instructions
+ pragma Import (C, BuildPhi, "LLVMBuildPhi");
+ pragma Import (C, BuildCall, "LLVMBuildCall");
+ pragma Import (C, BuildSelect, "LLVMBuildSelect");
+ pragma Import (C, BuildVAArg, "LLVMBuildVAArg");
+ pragma Import (C, BuildExtractElement, "LLVMBuildExtractElement");
+ pragma Import (C, BuildInsertElement, "LLVMBuildInsertElement");
+ pragma Import (C, BuildShuffleVector, "LLVMBuildShuffleVector");
+
+ -- Memory buffers ----------------------------------------------------
+ pragma Import (C, CreateMemoryBufferWithContentsOfFile,
+ "LLVMCreateMemoryBufferWithContentsOfFile");
+ pragma Import (C, CreateMemoryBufferWithSTDIN,
+ "LLVMCreateMemoryBufferWithSTDIN");
+ pragma Import (C, DisposeMemoryBuffer, "LLVMDisposeMemoryBuffer");
+
+ -- Pass Managers -----------------------------------------------------
+ pragma Import (C, CreatePassManager, "LLVMCreatePassManager");
+ pragma Import (C, CreateFunctionPassManagerForModule,
+ "LLVMCreateFunctionPassManagerForModule");
+ pragma Import (C, RunPassManager, "LLVMRunPassManager");
+ pragma Import (C, InitializeFunctionPassManager,
+ "LLVMInitializeFunctionPassManager");
+ pragma Import (C, RunFunctionPassManager,
+ "LLVMRunFunctionPassManager");
+ pragma Import (C, FinalizeFunctionPassManager,
+ "LLVMFinalizeFunctionPassManager");
+ pragma Import (C, DisposePassManager, "LLVMDisposePassManager");
+
+end LLVM.Core;
diff --git a/src/ortho/llvm-nodebug/llvm-target.ads b/src/ortho/llvm-nodebug/llvm-target.ads
new file mode 100644
index 000000000..b7c35848a
--- /dev/null
+++ b/src/ortho/llvm-nodebug/llvm-target.ads
@@ -0,0 +1,84 @@
+-- LLVM binding
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+with Interfaces; use Interfaces;
+with Interfaces.C; use Interfaces.C;
+with LLVM.Core; use LLVM.Core;
+
+package LLVM.Target is
+
+ type TargetDataRef is new System.Address;
+
+ -- LLVMInitializeNativeTarget - The main program should call this function
+ -- to initialize the native target corresponding to the host. This is
+ -- useful for JIT applications to ensure that the target gets linked in
+ -- correctly.
+ procedure InitializeNativeTarget;
+ pragma Import (C, InitializeNativeTarget,
+ "LLVMInitializeNativeTarget_noinline");
+
+ -- LLVMInitializeNativeTargetAsmPrinter - The main program should call this
+ -- function to initialize the printer for the native target corresponding
+ -- to the host.
+ procedure InitializeNativeAsmPrinter;
+ pragma Import (C, InitializeNativeAsmPrinter,
+ "LLVMInitializeNativeAsmPrinter_noinline");
+
+ -- Creates target data from a target layout string.
+ -- See the constructor llvm::DataLayout::DataLayout.
+ function CreateTargetData (StringRep : Cstring) return TargetDataRef;
+ pragma Import (C, CreateTargetData, "LLVMCreateTargetData");
+
+ -- Adds target data information to a pass manager. This does not take
+ -- ownership of the target data.
+ -- See the method llvm::PassManagerBase::add.
+ procedure AddTargetData(TD : TargetDataRef; PM : PassManagerRef);
+ pragma Import (C, AddTargetData, "LLVMAddTargetData");
+
+ -- Converts target data to a target layout string. The string must be
+ -- disposed with LLVMDisposeMessage.
+ -- See the constructor llvm::DataLayout::DataLayout. */
+ function CopyStringRepOfTargetData(TD :TargetDataRef) return Cstring;
+ pragma Import (C, CopyStringRepOfTargetData,
+ "LLVMCopyStringRepOfTargetData");
+
+ -- Returns the pointer size in bytes for a target.
+ -- See the method llvm::DataLayout::getPointerSize.
+ function PointerSize(TD : TargetDataRef) return unsigned;
+ pragma Import (C, PointerSize, "LLVMPointerSize");
+
+ -- Computes the ABI size of a type in bytes for a target.
+ -- See the method llvm::DataLayout::getTypeAllocSize.
+ function ABISizeOfType (TD : TargetDataRef; Ty: TypeRef) return Unsigned_64;
+ pragma Import (C, ABISizeOfType, "LLVMABISizeOfType");
+
+ -- Computes the ABI alignment of a type in bytes for a target.
+ -- See the method llvm::DataLayout::getTypeABISize.
+ function ABIAlignmentOfType (TD : TargetDataRef; Ty: TypeRef)
+ return Unsigned_32;
+ pragma Import (C, ABIAlignmentOfType, "LLVMABIAlignmentOfType");
+
+ -- Computes the byte offset of the indexed struct element for a target.
+ -- See the method llvm::StructLayout::getElementContainingOffset.
+ function OffsetOfElement(TD : TargetDataRef;
+ StructTy : TypeRef;
+ Element : Unsigned_32)
+ return Unsigned_64;
+ pragma Import (C, OffsetOfElement, "LLVMOffsetOfElement");
+
+end LLVM.Target;
diff --git a/src/ortho/llvm-nodebug/llvm-targetmachine.ads b/src/ortho/llvm-nodebug/llvm-targetmachine.ads
new file mode 100644
index 000000000..cbf074940
--- /dev/null
+++ b/src/ortho/llvm-nodebug/llvm-targetmachine.ads
@@ -0,0 +1,122 @@
+-- LLVM binding
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+with LLVM.Core; use LLVM.Core;
+with LLVM.Target; use LLVM.Target;
+
+package LLVM.TargetMachine is
+
+ type TargetMachineRef is new System.Address;
+ Null_TargetMachineRef : constant TargetMachineRef :=
+ TargetMachineRef (System.Null_Address);
+
+ type TargetRef is new System.Address;
+ Null_TargetRef : constant TargetRef := TargetRef (System.Null_Address);
+
+ type CodeGenOptLevel is (CodeGenLevelNone,
+ CodeGenLevelLess,
+ CodeGenLevelDefault,
+ CodeGenLevelAggressive);
+ pragma Convention (C, CodeGenOptLevel);
+
+ type RelocMode is (RelocDefault,
+ RelocStatic,
+ RelocPIC,
+ RelocDynamicNoPic);
+ pragma Convention (C, RelocMode);
+
+ type CodeModel is (CodeModelDefault,
+ CodeModelJITDefault,
+ CodeModelSmall,
+ CodeModelKernel,
+ CodeModelMedium,
+ CodeModelLarge);
+ pragma Convention (C, CodeModel);
+
+ type CodeGenFileType is (AssemblyFile,
+ ObjectFile);
+ pragma Convention (C, CodeGenFileType);
+
+ -- Returns the first llvm::Target in the registered targets list.
+ function GetFirstTarget return TargetRef;
+ pragma Import (C, GetFirstTarget, "LLVMGetFirstTarget");
+
+ -- Returns the next llvm::Target given a previous one (or null if there's
+ -- none) */
+ function GetNextTarget(T : TargetRef) return TargetRef;
+ pragma Import (C, GetNextTarget, "LLVMGetNextTarget");
+
+ -- Target
+
+ -- Finds the target corresponding to the given name and stores it in T.
+ -- Returns 0 on success.
+ function GetTargetFromName (Name : Cstring) return TargetRef;
+ pragma Import (C, GetTargetFromName, "LLVMGetTargetFromName");
+
+ -- Finds the target corresponding to the given triple and stores it in T.
+ -- Returns 0 on success. Optionally returns any error in ErrorMessage.
+ -- Use LLVMDisposeMessage to dispose the message.
+ -- Ada: ErrorMessage is the address of a Cstring.
+ function GetTargetFromTriple
+ (Triple : Cstring; T : access TargetRef; ErrorMessage : access Cstring)
+ return Bool;
+ pragma Import (C, GetTargetFromTriple, "LLVMGetTargetFromTriple");
+
+ -- Returns the name of a target. See llvm::Target::getName
+ function GetTargetName (T: TargetRef) return Cstring;
+ pragma Import (C, GetTargetName, "LLVMGetTargetName");
+
+ -- Returns the description of a target. See llvm::Target::getDescription
+ function GetTargetDescription (T : TargetRef) return Cstring;
+ pragma Import (C, GetTargetDescription, "LLVMGetTargetDescription");
+
+ -- Target Machine ----------------------------------------------------
+
+ -- Creates a new llvm::TargetMachine. See llvm::Target::createTargetMachine
+
+ function CreateTargetMachine(T : TargetRef;
+ Triple : Cstring;
+ CPU : Cstring;
+ Features : Cstring;
+ Level : CodeGenOptLevel;
+ Reloc : RelocMode;
+ CM : CodeModel)
+ return TargetMachineRef;
+ pragma Import (C, CreateTargetMachine, "LLVMCreateTargetMachine");
+
+ -- Returns the llvm::DataLayout used for this llvm:TargetMachine.
+ function GetTargetMachineData(T : TargetMachineRef) return TargetDataRef;
+ pragma Import (C, GetTargetMachineData, "LLVMGetTargetMachineData");
+
+ -- Emits an asm or object file for the given module to the filename. This
+ -- wraps several c++ only classes (among them a file stream). Returns any
+ -- error in ErrorMessage. Use LLVMDisposeMessage to dispose the message.
+ function TargetMachineEmitToFile(T : TargetMachineRef;
+ M : ModuleRef;
+ Filename : Cstring;
+ Codegen : CodeGenFileType;
+ ErrorMessage : access Cstring)
+ return Bool;
+ pragma Import (C, TargetMachineEmitToFile,
+ "LLVMTargetMachineEmitToFile");
+
+ -- Get a triple for the host machine as a string. The result needs to be
+ -- disposed with LLVMDisposeMessage.
+ function GetDefaultTargetTriple return Cstring;
+ pragma Import (C, GetDefaultTargetTriple, "LLVMGetDefaultTargetTriple");
+end LLVM.TargetMachine;
diff --git a/src/ortho/llvm-nodebug/llvm-transforms-scalar.ads b/src/ortho/llvm-nodebug/llvm-transforms-scalar.ads
new file mode 100644
index 000000000..0f23ce87e
--- /dev/null
+++ b/src/ortho/llvm-nodebug/llvm-transforms-scalar.ads
@@ -0,0 +1,169 @@
+-- LLVM binding
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with LLVM.Core; use LLVM.Core;
+
+package LLVM.Transforms.Scalar is
+ -- See llvm::createAggressiveDCEPass function.
+ procedure AddAggressiveDCEPass(PM : PassManagerRef);
+ pragma Import (C, AddAggressiveDCEPass, "LLVMAddAggressiveDCEPass");
+
+ -- See llvm::createCFGSimplificationPass function.
+ procedure AddCFGSimplificationPass(PM : PassManagerRef);
+ pragma Import (C, AddCFGSimplificationPass, "LLVMAddCFGSimplificationPass");
+
+ -- See llvm::createDeadStoreEliminationPass function.
+ procedure AddDeadStoreEliminationPass(PM : PassManagerRef);
+ pragma Import (C, AddDeadStoreEliminationPass,
+ "LLVMAddDeadStoreEliminationPass");
+
+ -- See llvm::createScalarizerPass function.
+ procedure AddScalarizerPass(PM : PassManagerRef);
+ pragma Import (C, AddScalarizerPass, "LLVMAddScalarizerPass");
+
+ -- See llvm::createGVNPass function.
+ procedure AddGVNPass(PM : PassManagerRef);
+ pragma Import (C, AddGVNPass, "LLVMAddGVNPass");
+
+ -- See llvm::createIndVarSimplifyPass function.
+ procedure AddIndVarSimplifyPass(PM : PassManagerRef);
+ pragma Import (C, AddIndVarSimplifyPass, "LLVMAddIndVarSimplifyPass");
+
+ -- See llvm::createInstructionCombiningPass function.
+ procedure AddInstructionCombiningPass(PM : PassManagerRef);
+ pragma Import (C, AddInstructionCombiningPass,
+ "LLVMAddInstructionCombiningPass");
+
+ -- See llvm::createJumpThreadingPass function.
+ procedure AddJumpThreadingPass(PM : PassManagerRef);
+ pragma Import (C, AddJumpThreadingPass, "LLVMAddJumpThreadingPass");
+
+ -- See llvm::createLICMPass function.
+ procedure AddLICMPass(PM : PassManagerRef);
+ pragma Import (C, AddLICMPass, "LLVMAddLICMPass");
+
+ -- See llvm::createLoopDeletionPass function.
+ procedure AddLoopDeletionPass(PM : PassManagerRef);
+ pragma Import (C, AddLoopDeletionPass, "LLVMAddLoopDeletionPass");
+
+ -- See llvm::createLoopIdiomPass function
+ procedure AddLoopIdiomPass(PM : PassManagerRef);
+ pragma Import (C, AddLoopIdiomPass, "LLVMAddLoopIdiomPass");
+
+ -- See llvm::createLoopRotatePass function.
+ procedure AddLoopRotatePass(PM : PassManagerRef);
+ pragma Import (C, AddLoopRotatePass, "LLVMAddLoopRotatePass");
+
+ -- See llvm::createLoopRerollPass function.
+ procedure AddLoopRerollPass(PM : PassManagerRef);
+ pragma Import (C, AddLoopRerollPass, "LLVMAddLoopRerollPass");
+
+ -- See llvm::createLoopUnrollPass function.
+ procedure AddLoopUnrollPass(PM : PassManagerRef);
+ pragma Import (C, AddLoopUnrollPass, "LLVMAddLoopUnrollPass");
+
+ -- See llvm::createLoopUnswitchPass function.
+ procedure AddLoopUnswitchPass(PM : PassManagerRef);
+ pragma Import (C, AddLoopUnswitchPass, "LLVMAddLoopUnswitchPass");
+
+ -- See llvm::createMemCpyOptPass function.
+ procedure AddMemCpyOptPass(PM : PassManagerRef);
+ pragma Import (C, AddMemCpyOptPass, "LLVMAddMemCpyOptPass");
+
+ -- See llvm::createPartiallyInlineLibCallsPass function.
+ procedure AddPartiallyInlineLibCallsPass(PM : PassManagerRef);
+ pragma Import (C, AddPartiallyInlineLibCallsPass,
+ "LLVMAddPartiallyInlineLibCallsPass");
+
+ -- See llvm::createPromoteMemoryToRegisterPass function.
+ procedure AddPromoteMemoryToRegisterPass(PM : PassManagerRef);
+ pragma Import (C, AddPromoteMemoryToRegisterPass,
+ "LLVMAddPromoteMemoryToRegisterPass");
+
+ -- See llvm::createReassociatePass function.
+ procedure AddReassociatePass(PM : PassManagerRef);
+ pragma Import (C, AddReassociatePass, "LLVMAddReassociatePass");
+
+ -- See llvm::createSCCPPass function.
+ procedure AddSCCPPass(PM : PassManagerRef);
+ pragma Import (C, AddSCCPPass, "LLVMAddSCCPPass");
+
+ -- See llvm::createScalarReplAggregatesPass function.
+ procedure AddScalarReplAggregatesPass(PM : PassManagerRef);
+ pragma Import (C, AddScalarReplAggregatesPass,
+ "LLVMAddScalarReplAggregatesPass");
+
+ -- See llvm::createScalarReplAggregatesPass function.
+ procedure AddScalarReplAggregatesPassSSA(PM : PassManagerRef);
+ pragma Import (C, AddScalarReplAggregatesPassSSA,
+ "LLVMAddScalarReplAggregatesPassSSA");
+
+ -- See llvm::createScalarReplAggregatesPass function.
+ procedure AddScalarReplAggregatesPassWithThreshold
+ (PM : PassManagerRef; Threshold : Integer);
+ pragma Import (C, AddScalarReplAggregatesPassWithThreshold,
+ "LLVMAddScalarReplAggregatesPassWithThreshold");
+
+ -- See llvm::createSimplifyLibCallsPass function.
+ procedure AddSimplifyLibCallsPass(PM : PassManagerRef);
+ pragma Import (C, AddSimplifyLibCallsPass, "LLVMAddSimplifyLibCallsPass");
+
+ -- See llvm::createTailCallEliminationPass function.
+ procedure AddTailCallEliminationPass(PM : PassManagerRef);
+ pragma Import (C, AddTailCallEliminationPass,
+ "LLVMAddTailCallEliminationPass");
+
+ -- See llvm::createConstantPropagationPass function.
+ procedure AddConstantPropagationPass(PM : PassManagerRef);
+ pragma Import (C, AddConstantPropagationPass,
+ "LLVMAddConstantPropagationPass");
+
+ -- See llvm::demotePromoteMemoryToRegisterPass function.
+ procedure AddDemoteMemoryToRegisterPass(PM : PassManagerRef);
+ pragma Import (C, AddDemoteMemoryToRegisterPass,
+ "LLVMAddDemoteMemoryToRegisterPass");
+
+ -- See llvm::createVerifierPass function.
+ procedure AddVerifierPass(PM : PassManagerRef);
+ pragma Import (C, AddVerifierPass, "LLVMAddVerifierPass");
+
+ -- See llvm::createCorrelatedValuePropagationPass function
+ procedure AddCorrelatedValuePropagationPass(PM : PassManagerRef);
+ pragma Import (C, AddCorrelatedValuePropagationPass,
+ "LLVMAddCorrelatedValuePropagationPass");
+
+ -- See llvm::createEarlyCSEPass function
+ procedure AddEarlyCSEPass(PM : PassManagerRef);
+ pragma Import (C, AddEarlyCSEPass, "LLVMAddEarlyCSEPass");
+
+ -- See llvm::createLowerExpectIntrinsicPass function
+ procedure AddLowerExpectIntrinsicPass(PM : PassManagerRef);
+ pragma Import (C, AddLowerExpectIntrinsicPass,
+ "LLVMAddLowerExpectIntrinsicPass");
+
+ -- See llvm::createTypeBasedAliasAnalysisPass function
+ procedure AddTypeBasedAliasAnalysisPass(PM : PassManagerRef);
+ pragma Import (C, AddTypeBasedAliasAnalysisPass,
+ "LLVMAddTypeBasedAliasAnalysisPass");
+
+ -- See llvm::createBasicAliasAnalysisPass function
+ procedure AddBasicAliasAnalysisPass(PM : PassManagerRef);
+ pragma Import (C, AddBasicAliasAnalysisPass,
+ "LLVMAddBasicAliasAnalysisPass");
+end LLVM.Transforms.Scalar;
+
+
diff --git a/src/ortho/llvm-nodebug/llvm-transforms.ads b/src/ortho/llvm-nodebug/llvm-transforms.ads
new file mode 100644
index 000000000..d5a8011ce
--- /dev/null
+++ b/src/ortho/llvm-nodebug/llvm-transforms.ads
@@ -0,0 +1,21 @@
+-- LLVM binding
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package LLVM.Transforms is
+ pragma Pure (LLVM.Transforms);
+end LLVM.Transforms;
diff --git a/src/ortho/llvm-nodebug/llvm.ads b/src/ortho/llvm-nodebug/llvm.ads
new file mode 100644
index 000000000..80d036b84
--- /dev/null
+++ b/src/ortho/llvm-nodebug/llvm.ads
@@ -0,0 +1,21 @@
+-- LLVM binding
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package LLVM is
+ pragma Pure (LLVM);
+end LLVM;
diff --git a/src/ortho/llvm-nodebug/ortho_code_main.adb b/src/ortho/llvm-nodebug/ortho_code_main.adb
new file mode 100644
index 000000000..b15cf782a
--- /dev/null
+++ b/src/ortho/llvm-nodebug/ortho_code_main.adb
@@ -0,0 +1,316 @@
+-- LLVM back-end for ortho - Main subprogram.
+-- 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.Command_Line; use Ada.Command_Line;
+with Ada.Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
+with Ada.Text_IO; use Ada.Text_IO;
+
+with Ortho_Front; use Ortho_Front;
+with LLVM.BitWriter;
+with LLVM.Core; use LLVM.Core;
+with LLVM.Target; use LLVM.Target;
+with LLVM.TargetMachine; use LLVM.TargetMachine;
+with LLVM.Analysis;
+with LLVM.Transforms.Scalar;
+with Ortho_LLVM; use Ortho_LLVM;
+with Interfaces;
+with Interfaces.C; use Interfaces.C;
+
+procedure Ortho_Code_Main is
+ -- Name of the output filename (given by option '-o').
+ Output : String_Acc := null;
+
+ type Output_Kind_Type is (Output_Llvm, Output_Bytecode,
+ Output_Assembly, Output_Object);
+ Output_Kind : Output_Kind_Type := Output_Llvm;
+
+ -- True if the LLVM output must be displayed (set by '--dump-llvm')
+ Flag_Dump_Llvm : Boolean := False;
+
+ -- Index of the first file argument.
+ First_File : Natural;
+
+ -- Current option index.
+ Optind : Natural;
+
+ -- Number of arguments.
+ Argc : constant Natural := Argument_Count;
+
+ -- Name of the module.
+ Module_Name : String := "ortho" & Ascii.Nul;
+
+ -- Target triple.
+ Triple : Cstring := Empty_Cstring;
+
+ Target : aliased TargetRef;
+
+ CPU : constant Cstring := Empty_Cstring;
+ Features : constant Cstring := Empty_Cstring;
+ Reloc : constant RelocMode := RelocDefault;
+
+ function To_String (C : Cstring) return String is
+ function Strlen (C : Cstring) return Natural;
+ pragma Import (C, Strlen);
+
+ subtype Fat_String is String (Positive);
+ type Fat_String_Acc is access Fat_String;
+
+ function To_Fat_String_Acc is new
+ Ada.Unchecked_Conversion (Cstring, Fat_String_Acc);
+ begin
+ return To_Fat_String_Acc (C)(1 .. Strlen (C));
+ end To_String;
+
+ Codegen : CodeGenFileType := ObjectFile;
+
+ Msg : aliased Cstring;
+begin
+ Ortho_Front.Init;
+
+ -- Decode options.
+ First_File := Natural'Last;
+ Optind := 1;
+ while Optind <= Argc loop
+ declare
+ Arg : constant String := Argument (Optind);
+ begin
+ if Arg (1) = '-' then
+ if Arg = "--dump-llvm" then
+ Flag_Dump_Llvm := True;
+ elsif Arg = "-o" then
+ if Optind = Argc then
+ Put_Line (Standard_Error, "error: missing filename to '-o'");
+ return;
+ end if;
+ Output := new String'(Argument (Optind + 1) & ASCII.Nul);
+ Optind := Optind + 1;
+ elsif Arg = "-quiet" then
+ -- Skip silently.
+ null;
+ elsif Arg = "-S" then
+ Output_Kind := Output_Assembly;
+ Codegen := AssemblyFile;
+ elsif Arg = "-c" then
+ Output_Kind := Output_Object;
+ Codegen := ObjectFile;
+ elsif Arg = "-O0" then
+ Optimization := CodeGenLevelNone;
+ elsif Arg = "-O1" or else Arg = "-O" then
+ Optimization := CodeGenLevelLess;
+ elsif Arg = "-O2" then
+ Optimization := CodeGenLevelDefault;
+ elsif Arg = "-O3" then
+ Optimization := CodeGenLevelAggressive;
+ elsif Arg = "--emit-llvm" then
+ Output_Kind := Output_Llvm;
+ elsif Arg = "--emit-bc" then
+ Output_Kind := Output_Bytecode;
+ elsif Arg = "-glines"
+ or else Arg = "-gline-tables-only"
+ then
+ null;
+ elsif Arg = "-g" then
+ null;
+ else
+ -- This is really an argument.
+ declare
+ procedure Unchecked_Deallocation is
+ new Ada.Unchecked_Deallocation
+ (Name => String_Acc, Object => String);
+
+ Opt : String_Acc := new String'(Arg);
+ Opt_Arg : String_Acc;
+ Res : Natural;
+ begin
+ Opt_Arg := null;
+ if Optind < Argument_Count then
+ declare
+ Arg1 : constant String := Argument (Optind + 1);
+ begin
+ if Arg1 (Arg1'First) /= '-' then
+ Opt_Arg := new String'(Arg1);
+ end if;
+ end;
+ end if;
+
+ Res := Ortho_Front.Decode_Option (Opt, Opt_Arg);
+ case Res is
+ when 0 =>
+ Put_Line (Standard_Error,
+ "unknown option '" & Arg & "'");
+ return;
+ when 1 =>
+ null;
+ when 2 =>
+ Optind := Optind + 1;
+ when others =>
+ raise Program_Error;
+ end case;
+ Unchecked_Deallocation (Opt);
+ Unchecked_Deallocation (Opt_Arg);
+ end;
+ end if;
+ else
+ First_File := Optind;
+ exit;
+ end if;
+ end;
+ Optind := Optind + 1;
+ end loop;
+
+ -- Link with LLVM libraries.
+ InitializeNativeTarget;
+ InitializeNativeAsmPrinter;
+
+ -- LinkInJIT;
+
+ Module := ModuleCreateWithName (Module_Name'Address);
+
+ -- Extract target triple
+ Triple := GetDefaultTargetTriple;
+ SetTarget (Module, Triple);
+
+ -- Get Target
+ if GetTargetFromTriple (Triple, Target'Access, Msg'Access) /= 0 then
+ raise Program_Error;
+ end if;
+
+ -- Create a target machine
+ Target_Machine := CreateTargetMachine
+ (Target, Triple, CPU, Features, Optimization, Reloc, CodeModelDefault);
+
+ Target_Data := GetTargetMachineData (Target_Machine);
+
+ SetDataLayout (Module, CopyStringRepOfTargetData (Target_Data));
+
+ Ortho_LLVM.Init;
+
+ Set_Exit_Status (Failure);
+
+ if First_File > Argument_Count then
+ begin
+ if not Parse (null) then
+ return;
+ end if;
+ exception
+ when others =>
+ return;
+ end;
+ else
+ for I in First_File .. Argument_Count loop
+ declare
+ Filename : constant String_Acc :=
+ new String'(Argument (First_File));
+ begin
+ if not Parse (Filename) then
+ return;
+ end if;
+ exception
+ when others =>
+ return;
+ end;
+ end loop;
+ end if;
+
+ if Flag_Dump_Llvm then
+ DumpModule (Module);
+ end if;
+
+ -- Verify module.
+ if False then
+ if LLVM.Analysis.VerifyModule
+ (Module, LLVM.Analysis.PrintMessageAction, Msg'Access) /= 0
+ then
+ DisposeMessage (Msg);
+ raise Program_Error;
+ end if;
+ end if;
+
+ if Optimization > CodeGenLevelNone then
+ declare
+ use LLVM.Transforms.Scalar;
+ Global_Manager : constant Boolean := False;
+ Pass_Manager : PassManagerRef;
+ Res : Bool;
+ pragma Unreferenced (Res);
+ A_Func : ValueRef;
+ begin
+ if Global_Manager then
+ Pass_Manager := CreatePassManager;
+ else
+ Pass_Manager := CreateFunctionPassManagerForModule (Module);
+ end if;
+
+ LLVM.Target.AddTargetData (Target_Data, Pass_Manager);
+ AddPromoteMemoryToRegisterPass (Pass_Manager);
+ AddCFGSimplificationPass (Pass_Manager);
+
+ if Global_Manager then
+ Res := RunPassManager (Pass_Manager, Module);
+ else
+ A_Func := GetFirstFunction (Module);
+ while A_Func /= Null_ValueRef loop
+ Res := RunFunctionPassManager (Pass_Manager, A_Func);
+ A_Func := GetNextFunction (A_Func);
+ end loop;
+ end if;
+ end;
+ end if;
+
+ if Output /= null then
+ declare
+ Error : Boolean;
+ begin
+ Msg := Empty_Cstring;
+
+ case Output_Kind is
+ when Output_Assembly
+ | Output_Object =>
+ Error := LLVM.TargetMachine.TargetMachineEmitToFile
+ (Target_Machine, Module,
+ Output.all'Address, Codegen, Msg'Access) /= 0;
+ when Output_Bytecode =>
+ Error := LLVM.BitWriter.WriteBitcodeToFile
+ (Module, Output.all'Address) /= 0;
+ when Output_Llvm =>
+ Error := PrintModuleToFile
+ (Module, Output.all'Address, Msg'Access) /= 0;
+ end case;
+ if Error then
+ Put_Line (Standard_Error,
+ "error while writing to " & Output.all);
+ if Msg /= Empty_Cstring then
+ Put_Line (Standard_Error,
+ "message: " & To_String (Msg));
+ DisposeMessage (Msg);
+ end if;
+ Set_Exit_Status (2);
+ return;
+ end if;
+ end;
+ else
+ DumpModule (Module);
+ end if;
+
+ Set_Exit_Status (Success);
+exception
+ when others =>
+ Set_Exit_Status (2);
+ raise;
+end Ortho_Code_Main;
diff --git a/src/ortho/llvm-nodebug/ortho_ident.adb b/src/ortho/llvm-nodebug/ortho_ident.adb
new file mode 100644
index 000000000..e7b650539
--- /dev/null
+++ b/src/ortho/llvm-nodebug/ortho_ident.adb
@@ -0,0 +1,134 @@
+-- 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.
+
+package body Ortho_Ident is
+ type Chunk (Max : Positive);
+ type Chunk_Acc is access Chunk;
+
+ type Chunk (Max : Positive) is record
+ Prev : Chunk_Acc;
+ Len : Natural := 0;
+ S : String (1 .. Max);
+ end record;
+
+ Cur_Chunk : Chunk_Acc := null;
+
+ subtype Fat_String is String (Positive);
+
+ function Get_Identifier (Str : String) return O_Ident
+ is
+ Len : constant Natural := Str'Length;
+ Max : Positive;
+ Org : Positive;
+ begin
+ if Cur_Chunk = null or else Cur_Chunk.Len + Len >= Cur_Chunk.Max then
+ if Cur_Chunk = null then
+ Max := 32 * 1024;
+ else
+ Max := 2 * Cur_Chunk.Max;
+ end if;
+ if Len + 2 > Max then
+ Max := 2 * (Len + 2);
+ end if;
+ declare
+ New_Chunk : Chunk_Acc;
+ begin
+ -- Do not use allocator by expression, as we don't want to
+ -- initialize S.
+ New_Chunk := new Chunk (Max);
+ New_Chunk.Len := 0;
+ New_Chunk.Prev := Cur_Chunk;
+ Cur_Chunk := New_Chunk;
+ end;
+ end if;
+
+ Org := Cur_Chunk.Len + 1;
+ Cur_Chunk.S (Org .. Org + Len - 1) := Str;
+ Cur_Chunk.S (Org + Len) := ASCII.NUL;
+ Cur_Chunk.Len := Org + Len;
+
+ return (Addr => Cur_Chunk.S (Org)'Address);
+ end Get_Identifier;
+
+ function Is_Equal (L, R : O_Ident) return Boolean
+ is
+ begin
+ return L = R;
+ end Is_Equal;
+
+ function Get_String_Length (Id : O_Ident) return Natural
+ is
+ Str : Fat_String;
+ pragma Import (Ada, Str);
+ for Str'Address use Id.Addr;
+ begin
+ for I in Str'Range loop
+ if Str (I) = ASCII.NUL then
+ return I - 1;
+ end if;
+ end loop;
+ raise Program_Error;
+ end Get_String_Length;
+
+ function Get_String (Id : O_Ident) return String
+ is
+ Str : Fat_String;
+ pragma Import (Ada, Str);
+ for Str'Address use Id.Addr;
+ begin
+ for I in Str'Range loop
+ if Str (I) = ASCII.NUL then
+ return Str (1 .. I - 1);
+ end if;
+ end loop;
+ raise Program_Error;
+ end Get_String;
+
+ function Get_Cstring (Id : O_Ident) return System.Address is
+ begin
+ return Id.Addr;
+ end Get_Cstring;
+
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean
+ is
+ Istr : Fat_String;
+ pragma Import (Ada, Istr);
+ for Istr'Address use Id.Addr;
+
+ Str_Len : constant Natural := Str'Length;
+ begin
+ for I in Istr'Range loop
+ if Istr (I) = ASCII.NUL then
+ return I - 1 = Str_Len;
+ end if;
+ if I > Str_Len then
+ return False;
+ end if;
+ if Istr (I) /= Str (Str'First + I - 1) then
+ return False;
+ end if;
+ end loop;
+ raise Program_Error;
+ end Is_Equal;
+
+ function Is_Nul (Id : O_Ident) return Boolean is
+ begin
+ return Id = O_Ident_Nul;
+ end Is_Nul;
+
+end Ortho_Ident;
diff --git a/src/ortho/llvm-nodebug/ortho_ident.ads b/src/ortho/llvm-nodebug/ortho_ident.ads
new file mode 100644
index 000000000..7d3955c02
--- /dev/null
+++ b/src/ortho/llvm-nodebug/ortho_ident.ads
@@ -0,0 +1,42 @@
+-- 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 System;
+
+package Ortho_Ident is
+ type O_Ident is private;
+
+ function Get_Identifier (Str : String) return O_Ident;
+ function Is_Equal (L, R : O_Ident) return Boolean;
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean;
+ function Is_Nul (Id : O_Ident) return Boolean;
+ function Get_String (Id : O_Ident) return String;
+ function Get_String_Length (Id : O_Ident) return Natural;
+
+ -- Note: the address is always valid.
+ function Get_Cstring (Id : O_Ident) return System.Address;
+
+ O_Ident_Nul : constant O_Ident;
+
+private
+ type O_Ident is record
+ Addr : System.Address;
+ end record;
+ O_Ident_Nul : constant O_Ident := (Addr => System.Null_Address);
+
+ pragma Inline (Get_Cstring);
+end Ortho_Ident;
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;
diff --git a/src/ortho/llvm-nodebug/ortho_llvm.private.ads b/src/ortho/llvm-nodebug/ortho_llvm.private.ads
new file mode 100644
index 000000000..e5527a734
--- /dev/null
+++ b/src/ortho/llvm-nodebug/ortho_llvm.private.ads
@@ -0,0 +1,307 @@
+-- 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 Interfaces; use Interfaces;
+with Interfaces.C; use Interfaces.C;
+with Ortho_Ident; use Ortho_Ident;
+with LLVM.Core; use LLVM.Core;
+with LLVM.TargetMachine;
+with LLVM.Target;
+
+-- Interface to create nodes.
+package Ortho_LLVM is
+ procedure Init;
+
+ -- LLVM specific: the module.
+ Module : ModuleRef;
+
+ -- Descriptor for the layout.
+ Target_Data : LLVM.Target.TargetDataRef;
+
+ Target_Machine : LLVM.TargetMachine.TargetMachineRef;
+
+ -- Optimization level
+ Optimization : LLVM.TargetMachine.CodeGenOptLevel :=
+ LLVM.TargetMachine.CodeGenLevelDefault;
+
+private
+ -- No support for nested subprograms in LLVM.
+ Has_Nested_Subprograms : constant Boolean := False;
+
+ type O_Tnode_Type (<>);
+ type O_Tnode is access O_Tnode_Type;
+ O_Tnode_Null : constant O_Tnode := null;
+
+ type ON_Type_Kind is
+ (ON_No_Type,
+ ON_Unsigned_Type, ON_Signed_Type, ON_Enum_Type, ON_Boolean_Type,
+ ON_Float_Type,
+ ON_Array_Type, ON_Array_Sub_Type,
+ ON_Incomplete_Record_Type,
+ ON_Record_Type, ON_Union_Type,
+ ON_Incomplete_Access_Type, ON_Access_Type);
+
+ subtype ON_Scalar_Types is ON_Type_Kind range
+ ON_Unsigned_Type .. ON_Float_Type;
+
+ subtype ON_Integer_Types is ON_Type_Kind range
+ ON_Unsigned_Type .. ON_Boolean_Type;
+
+ type O_Tnode_Type (Kind : ON_Type_Kind := ON_No_Type) is record
+ LLVM : TypeRef;
+ Dbg : ValueRef;
+ case Kind is
+ when ON_No_Type =>
+ null;
+ when ON_Union_Type =>
+ Un_Size : unsigned;
+ Un_Main_Field : TypeRef;
+ when ON_Access_Type
+ | ON_Incomplete_Access_Type =>
+ Acc_Type : O_Tnode;
+ when ON_Scalar_Types =>
+ Scal_Size : Natural;
+ when ON_Array_Type
+ | ON_Array_Sub_Type =>
+ -- Type of the element
+ Arr_El_Type : O_Tnode;
+ when ON_Record_Type
+ | ON_Incomplete_Record_Type =>
+ null;
+ end case;
+ end record;
+
+ type O_Inter;
+ type O_Inter_Acc is access O_Inter;
+ type O_Inter is record
+ Itype : O_Tnode;
+ Ival : ValueRef;
+ Ident : O_Ident;
+ Next : O_Inter_Acc;
+ end record;
+
+ type On_Decl_Kind is
+ (ON_Type_Decl, ON_Completed_Type_Decl,
+ ON_Const_Decl,
+ ON_Var_Decl, ON_Local_Decl, ON_Interface_Decl,
+ ON_Subprg_Decl,
+ ON_No_Decl);
+
+ type O_Dnode (Kind : On_Decl_Kind := ON_No_Decl) is record
+ Dtype : O_Tnode;
+ LLVM : ValueRef;
+ case Kind is
+ when ON_Var_Decl
+ | ON_Const_Decl
+ | ON_Local_Decl =>
+ null;
+ when ON_Subprg_Decl =>
+ Subprg_Id : O_Ident;
+ Nbr_Args : unsigned;
+ Subprg_Inters : O_Inter_Acc;
+ when ON_Interface_Decl =>
+ Inter : O_Inter_Acc;
+ when others =>
+ null;
+ end case;
+ end record;
+
+ O_Dnode_Null : constant O_Dnode := (Kind => ON_No_Decl,
+ Dtype => O_Tnode_Null,
+ LLVM => Null_ValueRef);
+
+ type OF_Kind is (OF_None, OF_Record, OF_Union);
+ type O_Fnode (Kind : OF_Kind := OF_None) is record
+ -- Type of the field.
+ Ftype : O_Tnode;
+ case Kind is
+ when OF_None =>
+ null;
+ when OF_Record =>
+ -- Field index (starting from 0).
+ Index : Natural;
+ when OF_Union =>
+ Utype : TypeRef;
+ Ptr_Type : TypeRef;
+ end case;
+ end record;
+
+ O_Fnode_Null : constant O_Fnode := (Kind => OF_None,
+ Ftype => O_Tnode_Null);
+
+ type O_Anode_Type;
+ type O_Anode is access O_Anode_Type;
+ type O_Anode_Type is record
+ Next : O_Anode;
+ Formal : O_Dnode;
+ Actual : O_Enode;
+ end record;
+
+ type O_Cnode is record
+ LLVM : ValueRef;
+ Ctype : O_Tnode;
+ end record;
+ O_Cnode_Null : constant O_Cnode := (LLVM => Null_ValueRef,
+ Ctype => O_Tnode_Null);
+
+ type O_Enode is record
+ LLVM : ValueRef;
+ Etype : O_Tnode;
+ end record;
+ O_Enode_Null : constant O_Enode := (LLVM => Null_ValueRef,
+ Etype => O_Tnode_Null);
+
+
+ type O_Lnode is record
+ -- If True, the LLVM component is the value (used for arguments).
+ -- If False, the LLVM component is the address of the value (used
+ -- for everything else).
+ Direct : Boolean;
+ LLVM : ValueRef;
+ Ltype : O_Tnode;
+ end record;
+
+ O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null);
+
+ type O_Snode is record
+ -- First BB in the loop body.
+ Bb_Entry : BasicBlockRef;
+
+ -- BB after the loop.
+ Bb_Exit : BasicBlockRef;
+ end record;
+
+ O_Snode_Null : constant O_Snode := (Null_BasicBlockRef,
+ Null_BasicBlockRef);
+
+ type O_Inter_List is record
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Res_Type : O_Tnode;
+ Nbr_Inter : Natural;
+ First_Inter, Last_Inter : O_Inter_Acc;
+ end record;
+
+ type O_Element;
+ type O_Element_Acc is access O_Element;
+ type O_Element is record
+ -- Identifier for the element
+ Ident : O_Ident;
+
+ -- Type of the element
+ Etype : O_Tnode;
+
+ -- Next element (in the linked list)
+ Next : O_Element_Acc;
+ end record;
+
+ -- Record and union builder.
+ type O_Element_List is record
+ Kind : OF_Kind;
+
+ -- Number of fields.
+ Nbr_Elements : Natural;
+
+ -- For record: the access to the incomplete (but named) type.
+ Rec_Type : O_Tnode;
+
+ -- For unions: biggest for size and alignment
+ Size : unsigned;
+ Align : Unsigned_32;
+ Align_Type : TypeRef;
+
+ First_Elem, Last_Elem : O_Element_Acc;
+ end record;
+
+ type ValueRefArray_Acc is access ValueRefArray;
+
+ type O_Record_Aggr_List is record
+ -- Current number of elements in Vals.
+ Len : unsigned;
+
+ -- Value of elements.
+ Vals : ValueRefArray_Acc;
+
+ -- Type of the aggregate.
+ Atype : O_Tnode;
+ end record;
+
+ type O_Array_Aggr_List is record
+ -- Current number of elements in Vals.
+ Len : unsigned;
+
+ -- Value of elements.
+ Vals : ValueRefArray_Acc;
+ El_Type : TypeRef;
+
+ -- Type of the aggregate.
+ Atype : O_Tnode;
+ end record;
+
+ type O_Assoc_List is record
+ Subprg : O_Dnode;
+ Idx : unsigned;
+ Vals : ValueRefArray_Acc;
+ end record;
+
+ type O_Enum_List is record
+ LLVM : TypeRef;
+ Num : Natural;
+ Etype : O_Tnode;
+ end record;
+
+ type O_Choice_Type is record
+ Low, High : ValueRef;
+ Bb : BasicBlockRef;
+ end record;
+
+ type O_Choice_Array is array (Natural range <>) of O_Choice_Type;
+ type O_Choice_Array_Acc is access O_Choice_Array;
+
+ type O_Case_Block is record
+ -- BB before the case.
+ BB_Prev : BasicBlockRef;
+
+ -- Select expression
+ Value : ValueRef;
+ Vtype : O_Tnode;
+
+ -- BB after the case statement.
+ BB_Next : BasicBlockRef;
+
+ -- BB for others
+ BB_Others : BasicBlockRef;
+
+ -- BB for the current choice
+ BB_Choice : BasicBlockRef;
+
+ -- List of choices.
+ Nbr_Choices : Natural;
+ Choices : O_Choice_Array_Acc;
+ end record;
+
+ type O_If_Block is record
+ -- The next basic block.
+ -- After the 'If', this is the BB for the else part. If there is no
+ -- else part, this is the BB for statements after the if.
+ -- After the 'else', this is the BB for statements after the if.
+ Bb : BasicBlockRef;
+ end record;
+
+ function Get_LLVM_Type (Atype : O_Tnode) return TypeRef;
+end Ortho_LLVM;
diff --git a/src/ortho/llvm-nodebug/ortho_nodes.ads b/src/ortho/llvm-nodebug/ortho_nodes.ads
new file mode 100644
index 000000000..34d1dbbc9
--- /dev/null
+++ b/src/ortho/llvm-nodebug/ortho_nodes.ads
@@ -0,0 +1,20 @@
+-- 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;
+package Ortho_Nodes renames Ortho_LLVM;
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-07 18:30:16 +0000