aboutsummaryrefslogtreecommitdiffstats
path: root/ortho
diff options
context:
space:
mode:
authorTristan Gingold <tgingold@free.fr>2014-03-06 21:27:19 +0100
committerTristan Gingold <tgingold@free.fr>2014-03-06 21:27:19 +0100
commit7b1e07c025bd01aad47bb78222a5e6b17682d4e4 (patch)
tree9bab215376b6cd0c0df0817d46f0bd12b880bc42 /ortho
parent627f7b8313148cde9c372aca8b6cdc3d4d3dc78f (diff)
downloadghdl-7b1e07c025bd01aad47bb78222a5e6b17682d4e4.tar.gz
ghdl-7b1e07c025bd01aad47bb78222a5e6b17682d4e4.tar.bz2
ghdl-7b1e07c025bd01aad47bb78222a5e6b17682d4e4.zip
Add LLVM back-end for ortho.
Diffstat (limited to 'ortho')
-rw-r--r--ortho/llvm/Makefile29
-rw-r--r--ortho/llvm/llvm-analysis.ads53
-rw-r--r--ortho/llvm/llvm-bitwriter.ads34
-rw-r--r--ortho/llvm/llvm-cbindings.cpp61
-rw-r--r--ortho/llvm/llvm-core.ads1279
-rw-r--r--ortho/llvm/llvm-executionengine.ads163
-rw-r--r--ortho/llvm/llvm-target.ads84
-rw-r--r--ortho/llvm/llvm-targetmachine.ads122
-rw-r--r--ortho/llvm/llvm-transforms-scalar.ads169
-rw-r--r--ortho/llvm/llvm-transforms.ads21
-rw-r--r--ortho/llvm/llvm.ads21
-rw-r--r--ortho/llvm/ortho_code_main.adb377
-rw-r--r--ortho/llvm/ortho_ident.adb134
-rw-r--r--ortho/llvm/ortho_ident.ads42
-rw-r--r--ortho/llvm/ortho_jit.adb147
-rw-r--r--ortho/llvm/ortho_llvm-jit.adb55
-rw-r--r--ortho/llvm/ortho_llvm-jit.ads31
-rw-r--r--ortho/llvm/ortho_llvm-main.adb77
-rw-r--r--ortho/llvm/ortho_llvm-main.ads57
-rw-r--r--ortho/llvm/ortho_llvm.adb2768
-rw-r--r--ortho/llvm/ortho_llvm.ads724
-rw-r--r--ortho/llvm/ortho_nodes.ads20
22 files changed, 6468 insertions, 0 deletions
diff --git a/ortho/llvm/Makefile b/ortho/llvm/Makefile
new file mode 100644
index 000000000..b5c279863
--- /dev/null
+++ b/ortho/llvm/Makefile
@@ -0,0 +1,29 @@
+ortho_srcdir=..
+GNAT_FLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwael
+CC=clang
+LLVM_CONFIG=llvm-config
+
+all: $(ortho_exec)
+
+$(ortho_exec): force llvm-cbindings.o
+ gnatmake -m -o $@ -g -aI$(ortho_srcdir)/llvm -aI$(ortho_srcdir) \
+ $(GNAT_FLAGS) ortho_code_main -bargs -E \
+ -largs llvm-cbindings.o `$(LLVM_CONFIG) --ldflags --libs --system-libs` -lc++ #-static
+
+llvm-bindings.o: $(ortho_srcdir)/llvm/llvm-bindings.cpp
+ $(CXX) -c -m64 -I`$(LLVM_CONFIG) --includedir --cxxflags` -g -o $@ $<
+
+llvm-cbindings.o: $(ortho_srcdir)/llvm/llvm-cbindings.cpp
+ $(CC) -c -I`$(LLVM_CONFIG) --includedir --cflags` -g -o $@ $<
+
+clean:
+ $(RM) -f *.o *.ali ortho_code_main
+ $(RM) b~*.ad? *~
+
+distclean: clean
+
+
+force:
+
+.PHONY: force all clean
+
diff --git a/ortho/llvm/llvm-analysis.ads b/ortho/llvm/llvm-analysis.ads
new file mode 100644
index 000000000..bfecec579
--- /dev/null
+++ b/ortho/llvm/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/ortho/llvm/llvm-bitwriter.ads b/ortho/llvm/llvm-bitwriter.ads
new file mode 100644
index 000000000..3f9c518e4
--- /dev/null
+++ b/ortho/llvm/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/ortho/llvm/llvm-cbindings.cpp b/ortho/llvm/llvm-cbindings.cpp
new file mode 100644
index 000000000..e4d666ade
--- /dev/null
+++ b/ortho/llvm/llvm-cbindings.cpp
@@ -0,0 +1,61 @@
+/* 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-c/Core.h"
+#include "llvm-c/ExecutionEngine.h"
+#include "llvm/IR/Type.h"
+#include "llvm/IR/LLVMContext.h"
+#include "llvm/IR/Metadata.h"
+#include "llvm/ExecutionEngine/ExecutionEngine.h"
+
+using namespace llvm;
+
+extern "C" {
+
+void
+LLVMInitializeNativeTarget_noinline (void)
+{
+ LLVMInitializeNativeTarget ();
+}
+
+void
+LLVMInitializeNativeAsmPrinter_noinline (void)
+{
+ LLVMInitializeNativeAsmPrinter();
+}
+
+LLVMTypeRef LLVMMetadataTypeInContext(LLVMContextRef C) {
+ return (LLVMTypeRef) Type::getMetadataTy(*unwrap(C));
+}
+
+LLVMTypeRef LLVMMetadataType_extra(void) {
+ return LLVMMetadataTypeInContext(LLVMGetGlobalContext());
+}
+
+void
+LLVMMDNodeReplaceOperandWith_extra (LLVMValueRef N, unsigned i, LLVMValueRef V) {
+ MDNode *MD = cast<MDNode>(unwrap(N));
+ MD->replaceOperandWith (i, unwrap(V));
+}
+
+void *LLVMGetPointerToFunction(LLVMExecutionEngineRef EE, LLVMValueRef Func)
+{
+ return unwrap(EE)->getPointerToFunction(unwrap<Function>(Func));
+}
+
+}
diff --git a/ortho/llvm/llvm-core.ads b/ortho/llvm/llvm-core.ads
new file mode 100644
index 000000000..74a47484f
--- /dev/null
+++ b/ortho/llvm/llvm-core.ads
@@ -0,0 +1,1279 @@
+-- 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 := 1**11;
+ AlwaysInlineAttribute : constant Attribute := 1**12;
+ OptimizeForSizeAttribute : constant Attribute := 1**13;
+ StackProtectAttribute : constant Attribute := 1**14;
+ StackProtectReqAttribute : constant Attribute := 1**15;
+ Alignment : constant Attribute := 31**16;
+ NoCaptureAttribute : constant Attribute := 1**21;
+ NoRedZoneAttribute : constant Attribute := 1**22;
+ NoImplicitFloatAttribute : constant Attribute := 1**23;
+ NakedAttribute : constant Attribute := 1**24;
+ InlineHintAttribute : constant Attribute := 1**25;
+ StackAlignment : constant Attribute := 7**26;
+ ReturnsTwice : constant Attribute := 1**29;
+ UWTable : constant Attribute := 1**30;
+ NonLazyBind : constant Attribute := 1**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);
+
+ function GetMDKindIDInContext
+ (C : ContextRef; Name : Cstring; Slen : unsigned)
+ return unsigned;
+
+ function GetMDKindID(Name : String; Slen : unsigned) return unsigned;
+
+ -- 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;
+
+ -- 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);
+
+ -- Obtain the number of operands for named metadata in a module.
+ -- @see llvm::Module::getNamedMetadata()
+ function GetNamedMetadataNumOperands(M : ModuleRef; Name : Cstring)
+ return unsigned;
+
+ -- Obtain the named metadata operands for a module.
+ -- The passed LLVMValueRef pointer should refer to an array of
+ -- LLVMValueRef at least LLVMGetNamedMetadataNumOperands long. This
+ -- array will be populated with the LLVMValueRef instances. Each
+ -- instance corresponds to a llvm::MDNode.
+ -- @see llvm::Module::getNamedMetadata()
+ -- @see llvm::MDNode::getOperand()
+ procedure GetNamedMetadataOperands
+ (M : ModuleRef; Name : Cstring; Dest : ValueRefArray);
+
+ -- Add an operand to named metadata.
+ -- @see llvm::Module::getNamedMetadata()
+ -- @see llvm::MDNode::addOperand()
+ procedure AddNamedMetadataOperand
+ (M : ModuleRef; Name : Cstring; Val : ValueRef);
+
+ -- 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);
+
+ -- Metadata
+
+ -- Obtain a MDString value from a context.
+ -- The returned instance corresponds to the llvm::MDString class.
+ -- The instance is specified by string data of a specified length. The
+ -- string content is copied, so the backing memory can be freed after
+ -- this function returns.
+ function MDStringInContext(C : ContextRef; Str : Cstring; Len : unsigned)
+ return ValueRef;
+
+ -- Obtain a MDString value from the global context.
+ function MDString(Str : Cstring; Len : unsigned) return ValueRef;
+
+ -- Obtain a MDNode value from a context.
+ -- The returned value corresponds to the llvm::MDNode class.
+ function MDNodeInContext
+ (C : ContextRef; Vals : ValueRefArray; Count : unsigned)
+ return ValueRef;
+
+ -- Obtain a MDNode value from the global context.
+ function MDNode(Vals : ValueRefArray; Count : unsigned) return ValueRef;
+
+ -- Obtain the underlying string from a MDString value.
+ -- @param V Instance to obtain string from.
+ -- @param Len Memory address which will hold length of returned string.
+ -- @return String data in MDString.
+ function GetMDString(V : ValueRef; Len : access unsigned) return Cstring;
+
+ -- Obtain the number of operands from an MDNode value.
+ -- @param V MDNode to get number of operands from.
+ -- @return Number of operands of the MDNode.
+ function GetMDNodeNumOperands(V : ValueRef) return unsigned;
+
+ -- Obtain the given MDNode's operands.
+ -- The passed LLVMValueRef pointer should point to enough memory to hold
+ -- all of the operands of the given MDNode (see LLVMGetMDNodeNumOperands)
+ -- as LLVMValueRefs. This memory will be populated with the LLVMValueRefs
+ -- of the MDNode's operands.
+ -- @param V MDNode to get the operands from.
+ -- @param Dest Destination array for operands.
+ procedure GetMDNodeOperands(V : ValueRef; Dest : ValueRefArray);
+
+ procedure MDNodeReplaceOperandWith
+ (N : ValueRef; I : unsigned; V : ValueRef);
+
+ -- 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, GetMDKindIDInContext, "LLVMGetMDKindIDInContext");
+ pragma Import (C, GetMDKindID, "LLVMGetMDKindID");
+
+ 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, 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, GetNamedMetadataNumOperands,
+ "LLVMGetNamedMetadataNumOperands");
+ pragma Import (C, GetNamedMetadataOperands, "LLVMGetNamedMetadataOperands");
+ pragma Import (C, AddNamedMetadataOperand, "LLVMAddNamedMetadataOperand");
+
+ 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, MDStringInContext, "LLVMMDStringInContext");
+ pragma Import (C, MDString, "LLVMMDString");
+ pragma Import (C, MDNodeInContext, "LLVMMDNodeInContext");
+ pragma Import (C, MDNode, "LLVMMDNode");
+ pragma Import (C, GetMDString, "LLVMGetMDString");
+ pragma Import (C, GetMDNodeNumOperands, "LLVMGetMDNodeNumOperands");
+ pragma Import (C, GetMDNodeOperands, "LLVMGetMDNodeOperands");
+ pragma Import (C, MDNodeReplaceOperandWith,
+ "LLVMMDNodeReplaceOperandWith_extra");
+
+ 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/ortho/llvm/llvm-executionengine.ads b/ortho/llvm/llvm-executionengine.ads
new file mode 100644
index 000000000..72d4cda2f
--- /dev/null
+++ b/ortho/llvm/llvm-executionengine.ads
@@ -0,0 +1,163 @@
+-- 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; use System;
+with Interfaces; use Interfaces;
+with Interfaces.C; use Interfaces.C;
+with LLVM.Core; use LLVM.Core;
+with LLVM.Target; use LLVM.Target;
+
+package LLVM.ExecutionEngine is
+ type GenericValueRef is new Address;
+ type GenericValueRefArray is array (unsigned range <>) of GenericValueRef;
+ pragma Convention (C, GenericValueRefArray);
+ type ExecutionEngineRef is new Address;
+
+ procedure LinkInJIT;
+ procedure LinkInMCJIT;
+ procedure LinkInInterpreter;
+
+ -- Operations on generic values --------------------------------------
+
+ function CreateGenericValueOfInt(Ty : TypeRef;
+ N : Unsigned_64;
+ IsSigned : Integer)
+ return GenericValueRef;
+
+ function CreateGenericValueOfPointer(P : System.Address)
+ return GenericValueRef;
+
+ function CreateGenericValueOfFloat(Ty : TypeRef; N : double)
+ return GenericValueRef;
+
+ function GenericValueIntWidth(GenValRef : GenericValueRef)
+ return unsigned;
+
+ function GenericValueToInt(GenVal : GenericValueRef;
+ IsSigned : Integer) return Unsigned_64;
+
+ function GenericValueToPointer(GenVal : GenericValueRef)
+ return System.Address;
+
+ function GenericValueToFloat(TyRef : TypeRef; GenVal : GenericValueRef)
+ return double;
+
+ procedure DisposeGenericValue(GenVal : GenericValueRef);
+
+ -- Operations on execution engines -----------------------------------
+
+ function CreateExecutionEngineForModule
+ (EE : access ExecutionEngineRef; M : ModuleRef; Error : access Cstring)
+ return Bool;
+
+ function CreateInterpreterForModule (Interp : access ExecutionEngineRef;
+ M : ModuleRef;
+ Error : access Cstring)
+ return Bool;
+
+ function CreateJITCompilerForModule (JIT : access ExecutionEngineRef;
+ M : ModuleRef;
+ OptLevel : unsigned;
+ Error : access Cstring)
+ return Bool;
+
+
+ procedure DisposeExecutionEngine(EE : ExecutionEngineRef);
+
+ procedure RunStaticConstructors(EE : ExecutionEngineRef);
+
+ procedure RunStaticDestructors(EE : ExecutionEngineRef);
+
+ function RunFunctionAsMain(EE : ExecutionEngineRef;
+ F : ValueRef;
+ ArgC : unsigned; Argv : Address; EnvP : Address)
+ return Integer;
+
+ function RunFunction(EE : ExecutionEngineRef;
+ F : ValueRef;
+ NumArgs : unsigned;
+ Args : GenericValueRefArray)
+ return GenericValueRef;
+
+ procedure FreeMachineCodeForFunction(EE : ExecutionEngineRef; F : ValueRef);
+
+ procedure AddModule(EE : ExecutionEngineRef; M : ModuleRef);
+
+ function RemoveModule(EE : ExecutionEngineRef;
+ M : ModuleRef;
+ OutMod : access ModuleRef;
+ OutError : access Cstring) return Bool;
+
+ function FindFunction(EE : ExecutionEngineRef; Name : Cstring;
+ OutFn : access ValueRef)
+ return Integer;
+
+ function GetExecutionEngineTargetData(EE : ExecutionEngineRef)
+ return TargetDataRef;
+
+ procedure AddGlobalMapping(EE : ExecutionEngineRef; Global : ValueRef;
+ Addr : Address);
+
+ function GetPointerToGlobal (EE : ExecutionEngineRef; GV : ValueRef)
+ return Address;
+ function GetPointerToFunctionOrStub (EE : ExecutionEngineRef;
+ Func : ValueRef)
+ return Address;
+
+private
+ pragma Import (C, LinkInJIT, "LLVMLinkInJIT");
+ pragma Import (C, LinkInMCJIT, "LLVMLinkInMCJIT");
+ pragma Import (C, LinkInInterpreter, "LLVMLinkInInterpreter");
+
+ pragma Import (C, CreateGenericValueOfInt, "LLVMCreateGenericValueOfInt");
+ pragma Import (C, CreateGenericValueOfPointer,
+ "LLVMCreateGenericValueOfPointer");
+ pragma Import (C, CreateGenericValueOfFloat,
+ "LLVMCreateGenericValueOfFloat");
+ pragma Import (C, GenericValueIntWidth, "LLVMGenericValueIntWidth");
+ pragma Import (C, GenericValueToInt, "LLVMGenericValueToInt");
+ pragma Import (C, GenericValueToPointer, "LLVMGenericValueToPointer");
+ pragma Import (C, GenericValueToFloat, "LLVMGenericValueToFloat");
+ pragma Import (C, DisposeGenericValue, "LLVMDisposeGenericValue");
+
+ -- Operations on execution engines -----------------------------------
+
+ pragma Import (C, CreateExecutionEngineForModule,
+ "LLVMCreateExecutionEngineForModule");
+ pragma Import (C, CreateInterpreterForModule,
+ "LLVMCreateInterpreterForModule");
+ pragma Import (C, CreateJITCompilerForModule,
+ "LLVMCreateJITCompilerForModule");
+ pragma Import (C, DisposeExecutionEngine, "LLVMDisposeExecutionEngine");
+ pragma Import (C, RunStaticConstructors, "LLVMRunStaticConstructors");
+ pragma Import (C, RunStaticDestructors, "LLVMRunStaticDestructors");
+ pragma Import (C, RunFunctionAsMain, "LLVMRunFunctionAsMain");
+ pragma Import (C, RunFunction, "LLVMRunFunction");
+ pragma Import (C, FreeMachineCodeForFunction,
+ "LLVMFreeMachineCodeForFunction");
+ pragma Import (C, AddModule, "LLVMAddModule");
+ pragma Import (C, RemoveModule, "LLVMRemoveModule");
+ pragma Import (C, FindFunction, "LLVMFindFunction");
+ pragma Import (C, GetExecutionEngineTargetData,
+ "LLVMGetExecutionEngineTargetData");
+ pragma Import (C, AddGlobalMapping, "LLVMAddGlobalMapping");
+
+ pragma Import (C, GetPointerToFunctionOrStub,
+ "LLVMGetPointerToFunctionOrStub");
+ pragma Import (C, GetPointerToGlobal,
+ "LLVMGetPointerToGlobal");
+end LLVM.ExecutionEngine;
diff --git a/ortho/llvm/llvm-target.ads b/ortho/llvm/llvm-target.ads
new file mode 100644
index 000000000..b7c35848a
--- /dev/null
+++ b/ortho/llvm/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/ortho/llvm/llvm-targetmachine.ads b/ortho/llvm/llvm-targetmachine.ads
new file mode 100644
index 000000000..cbf074940
--- /dev/null
+++ b/ortho/llvm/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/ortho/llvm/llvm-transforms-scalar.ads b/ortho/llvm/llvm-transforms-scalar.ads
new file mode 100644
index 000000000..0f23ce87e
--- /dev/null
+++ b/ortho/llvm/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/ortho/llvm/llvm-transforms.ads b/ortho/llvm/llvm-transforms.ads
new file mode 100644
index 000000000..d5a8011ce
--- /dev/null
+++ b/ortho/llvm/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/ortho/llvm/llvm.ads b/ortho/llvm/llvm.ads
new file mode 100644
index 000000000..80d036b84
--- /dev/null
+++ b/ortho/llvm/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/ortho/llvm/ortho_code_main.adb b/ortho/llvm/ortho_code_main.adb
new file mode 100644
index 000000000..eec8490b0
--- /dev/null
+++ b/ortho/llvm/ortho_code_main.adb
@@ -0,0 +1,377 @@
+-- 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.Text_IO; use Ada.Text_IO;
+with Ortho_LLVM.Main; use Ortho_LLVM.Main;
+with Ortho_Front; use Ortho_Front;
+with LLVM.BitWriter;
+with LLVM.Core; use LLVM.Core;
+with LLVM.ExecutionEngine; use LLVM.ExecutionEngine;
+with LLVM.Target; use LLVM.Target;
+with LLVM.TargetMachine; use LLVM.TargetMachine;
+with LLVM.Analysis;
+with LLVM.Transforms.Scalar;
+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;
+
+ -- Set by '--exec': function to call and its argument (an integer)
+ Exec_Func : String_Acc := null;
+ Exec_Val : Integer := 0;
+
+ -- 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;
+
+ -- Execution engine
+ Engine : aliased ExecutionEngineRef;
+
+ Target : aliased TargetRef;
+
+ CPU : constant Cstring := Empty_Cstring;
+ Features : constant Cstring := Empty_Cstring;
+ Reloc : constant RelocMode := RelocDefault;
+
+ procedure Dump_Llvm
+ is
+ use LLVM.Analysis;
+ Msg : aliased Cstring;
+ begin
+ DumpModule (Module);
+ if LLVM.Analysis.VerifyModule
+ (Module, PrintMessageAction, Msg'Access) /= 0
+ then
+ null;
+ end if;
+ end Dump_Llvm;
+
+ 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" 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 = "--exec" then
+ if Optind + 1 >= Argc then
+ Put_Line (Standard_Error,
+ "error: missing function name to '--exec'");
+ return;
+ end if;
+ Exec_Func := new String'(Argument (Optind + 1));
+ Exec_Val := Integer'Value (Argument (Optind + 2));
+ Optind := Optind + 2;
+ elsif Arg = "-g" then
+ Flag_Debug := True;
+ 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
+ if Optind < Argument_Count then
+ Opt_Arg := new String'(Argument (Optind + 1));
+ else
+ Opt_Arg := null;
+ 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);
+
+ if Output = null and then Exec_Func /= null then
+ -- Now we going to create JIT
+ if CreateExecutionEngineForModule
+ (Engine'Access, Module, Msg'Access) /= 0
+ then
+ Put_Line (Standard_Error,
+ "cannot create execute: " & To_String (Msg));
+ raise Program_Error;
+ end if;
+
+ Target_Data := GetExecutionEngineTargetData (Engine);
+ else
+ -- 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);
+ end if;
+
+ SetDataLayout (Module, CopyStringRepOfTargetData (Target_Data));
+
+ if False then
+ declare
+ Targ : TargetRef;
+ begin
+ Put_Line ("Triple: " & To_String (Triple));
+ New_Line;
+ Put_Line ("Targets:");
+ Targ := GetFirstTarget;
+ while Targ /= Null_TargetRef loop
+ Put_Line (" " & To_String (GetTargetName (Targ))
+ & ": " & To_String (GetTargetDescription (Targ)));
+ Targ := GetNextTarget (Targ);
+ end loop;
+ end;
+ -- Target_Data := CreateTargetData (Triple);
+ end if;
+
+ Ortho_LLVM.Main.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_Debug then
+ Ortho_LLVM.Finish_Debug;
+ end if;
+
+ -- Ortho_Mcode.Finish;
+
+ if Flag_Dump_Llvm then
+ Dump_Llvm;
+ end if;
+
+ -- Verify module.
+ if LLVM.Analysis.VerifyModule
+ (Module, LLVM.Analysis.PrintMessageAction, Msg'Access) /= 0
+ then
+ DisposeMessage (Msg);
+ raise Program_Error;
+ 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;
+ elsif Exec_Func /= null then
+ declare
+ use Interfaces;
+ Res : GenericValueRef;
+ Vals : GenericValueRefArray (0 .. 0);
+ Func : aliased ValueRef;
+ begin
+ if FindFunction (Engine, Exec_Func.all'Address, Func'Access) /= 0 then
+ raise Program_Error;
+ end if;
+
+ -- Call the function with argument n:
+ Vals (0) := CreateGenericValueOfInt
+ (Int32Type, Unsigned_64 (Exec_Val), 0);
+ Res := RunFunction (Engine, Func, 1, Vals);
+
+ -- import result of execution
+ Put_Line ("Result is "
+ & Unsigned_64'Image (GenericValueToInt (Res, 0)));
+
+ end;
+ else
+ Dump_Llvm;
+ end if;
+
+ Set_Exit_Status (Success);
+exception
+ when others =>
+ Set_Exit_Status (2);
+ raise;
+end Ortho_Code_Main;
diff --git a/ortho/llvm/ortho_ident.adb b/ortho/llvm/ortho_ident.adb
new file mode 100644
index 000000000..e7b650539
--- /dev/null
+++ b/ortho/llvm/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/ortho/llvm/ortho_ident.ads b/ortho/llvm/ortho_ident.ads
new file mode 100644
index 000000000..7d3955c02
--- /dev/null
+++ b/ortho/llvm/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/ortho/llvm/ortho_jit.adb b/ortho/llvm/ortho_jit.adb
new file mode 100644
index 000000000..cdb4f0f2d
--- /dev/null
+++ b/ortho/llvm/ortho_jit.adb
@@ -0,0 +1,147 @@
+-- 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 GNAT.OS_Lib; use GNAT.OS_Lib;
+with Ada.Text_IO; use Ada.Text_IO;
+
+with Ortho_LLVM.Main; use Ortho_LLVM.Main;
+with Ortho_LLVM.Jit;
+
+with LLVM.Core; use LLVM.Core;
+with LLVM.Target; use LLVM.Target;
+-- with LLVM.TargetMachine; use LLVM.TargetMachine;
+with LLVM.ExecutionEngine; use LLVM.ExecutionEngine;
+with LLVM.Analysis;
+-- with Interfaces;
+with Interfaces.C; use Interfaces.C;
+
+package body Ortho_Jit is
+ -- Snap_Filename : GNAT.OS_Lib.String_Access := null;
+
+ Flag_Dump_Llvm : Boolean := False;
+
+ -- Name of the module.
+ Module_Name : String := "ortho" & Ascii.Nul;
+
+ -- procedure DisableLazyCompilation (EE : ExecutionEngineRef;
+ -- Disable : int);
+ -- pragma Import (C, DisableLazyCompilation,
+ -- "LLVMDisableLazyCompilation");
+
+ -- Initialize the whole engine.
+ procedure Init
+ is
+ Msg : aliased Cstring;
+ begin
+ InitializeNativeTarget;
+ InitializeNativeAsmPrinter;
+
+ LinkInJIT;
+
+ Module := ModuleCreateWithName (Module_Name'Address);
+
+ -- Now we going to create JIT
+ if CreateExecutionEngineForModule
+ (Ortho_LLVM.Jit.Engine'Access, Module, Msg'Access) /= 0
+ then
+ Put_Line (Standard_Error,
+ "cannot create execute: " & To_String (Msg));
+ raise Program_Error;
+ end if;
+
+ Target_Data := GetExecutionEngineTargetData (Ortho_LLVM.Jit.Engine);
+ SetDataLayout (Module, CopyStringRepOfTargetData (Target_Data));
+
+ Ortho_LLVM.Main.Init;
+ end Init;
+
+ procedure Set_Address (Decl : O_Dnode; Addr : Address)
+ renames Ortho_LLVM.Jit.Set_Address;
+
+ function Get_Address (Decl : O_Dnode) return Address
+ renames Ortho_LLVM.Jit.Get_Address;
+
+ -- procedure InstallLazyFunctionCreator (EE : ExecutionEngineRef;
+ -- Func : Address);
+ -- pragma Import (C, InstallLazyFunctionCreator,
+ -- "LLVMInstallLazyFunctionCreator");
+
+ -- Do link.
+ procedure Link (Status : out Boolean)
+ is
+ use LLVM.Analysis;
+ Msg : aliased Cstring;
+ begin
+ if Flag_Debug then
+ Ortho_LLVM.Finish_Debug;
+ end if;
+
+ if Flag_Dump_Llvm then
+ DumpModule (Module);
+ end if;
+
+ -- Verify module.
+ if LLVM.Analysis.VerifyModule
+ (Module, LLVM.Analysis.PrintMessageAction, Msg'Access) /= 0
+ then
+ DisposeMessage (Msg);
+ Status := False;
+ return;
+ end if;
+
+ -- FIXME: optim
+ end Link;
+
+ procedure Finish
+ is
+ -- F : ValueRef;
+ -- Addr : Address;
+ -- pragma Unreferenced (Addr);
+ begin
+ null;
+
+ -- if No_Lazy then
+ -- -- Be sure all functions code has been generated.
+ -- F := GetFirstFunction (Module);
+ -- while F /= Null_ValueRef loop
+ -- if GetFirstBasicBlock (F) /= Null_BasicBlockRef then
+ -- -- Only care about defined functions.
+ -- Addr := GetPointerToFunction (EE, F);
+ -- end if;
+ -- F := GetNextFunction (F);
+ -- end loop;
+ -- end if;
+ end Finish;
+
+ function Decode_Option (Option : String) return Boolean
+ is
+ Opt : constant String (1 .. Option'Length) := Option;
+ begin
+ if Opt = "--llvm-dump" then
+ Flag_Dump_Llvm := True;
+ return True;
+ end if;
+ return False;
+ end Decode_Option;
+
+ procedure Disp_Help is
+ begin
+ null;
+ end Disp_Help;
+
+end Ortho_Jit;
diff --git a/ortho/llvm/ortho_llvm-jit.adb b/ortho/llvm/ortho_llvm-jit.adb
new file mode 100644
index 000000000..9155a02c7
--- /dev/null
+++ b/ortho/llvm/ortho_llvm-jit.adb
@@ -0,0 +1,55 @@
+-- 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_LLVM.Jit is
+ -- procedure AddExternalFunction (Name : Cstring; Val : Address);
+ -- pragma Import (C, AddExternalFunction, "ortho_AddExternalFunction");
+
+ function GetPointerToFunction (EE : ExecutionEngineRef; Func : ValueRef)
+ return Address;
+ pragma Import (C, GetPointerToFunction, "LLVMGetPointerToFunction");
+
+ -- Set address of non-defined global variables or functions.
+ procedure Set_Address (Decl : O_Dnode; Addr : Address) is
+ begin
+ case Decl.Kind is
+ when ON_Var_Decl | ON_Const_Decl =>
+ AddGlobalMapping (Engine, Decl.LLVM, Addr);
+ when ON_Subprg_Decl =>
+ null;
+ -- AddExternalFunction (GetValueName (Decl.LLVM), Addr);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Set_Address;
+
+ -- Get address of a global.
+ function Get_Address (Decl : O_Dnode) return Address
+ is
+ begin
+ case Decl.Kind is
+ when ON_Var_Decl | ON_Const_Decl =>
+ return GetPointerToGlobal (Engine, Decl.LLVM);
+ when ON_Subprg_Decl =>
+ return GetPointerToFunction (Engine, Decl.LLVM);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Get_Address;
+
+end Ortho_LLVM.Jit;
diff --git a/ortho/llvm/ortho_llvm-jit.ads b/ortho/llvm/ortho_llvm-jit.ads
new file mode 100644
index 000000000..5296e2ed8
--- /dev/null
+++ b/ortho/llvm/ortho_llvm-jit.ads
@@ -0,0 +1,31 @@
+-- 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; use System;
+with LLVM.ExecutionEngine; use LLVM.ExecutionEngine;
+
+package Ortho_LLVM.Jit is
+ -- Set address of non-defined global variables or functions.
+ procedure Set_Address (Decl : O_Dnode; Addr : Address);
+ -- Get address of a global.
+ function Get_Address (Decl : O_Dnode) return Address;
+
+ -- Execution engine
+ Engine : aliased ExecutionEngineRef;
+
+end Ortho_LLVM.Jit;
diff --git a/ortho/llvm/ortho_llvm-main.adb b/ortho/llvm/ortho_llvm-main.adb
new file mode 100644
index 000000000..f315fe44f
--- /dev/null
+++ b/ortho/llvm/ortho_llvm-main.adb
@@ -0,0 +1,77 @@
+-- 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;
+
+package body Ortho_LLVM.Main is
+ Dbg_Str : constant String := "dbg";
+
+ 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;
+
+ procedure Init is
+ begin
+ Builder := CreateBuilder;
+ Decl_Builder := CreateBuilder;
+
+ Char_Type := New_Unsigned_Type (8);
+ New_Type_Decl (Get_Identifier ("__llvm_char"), Char_Type);
+
+ if False then
+ Char_Ptr_Type := New_Access_Type (Char_Type);
+ New_Type_Decl (Get_Identifier ("__llvm_char_ptr"), Char_Ptr_Type);
+
+ Stacksave_Fun := AddFunction
+ (Module, Stacksave_Name'Address,
+ FunctionType (Get_LLVM_Type (Char_Ptr_Type),
+ TypeRefArray'(1 .. 0 => Null_TypeRef), 0, 0));
+
+ Stackrestore_Fun := AddFunction
+ (Module, Stackrestore_Name'Address,
+ FunctionType
+ (VoidType,
+ TypeRefArray'(1 => Get_LLVM_Type (Char_Ptr_Type)), 1, 0));
+ end if;
+
+ if Flag_Debug then
+ Debug_ID := GetMDKindID (Dbg_Str, Dbg_Str'Length);
+
+ declare
+ Atypes : TypeRefArray (1 .. 2);
+ Ftype : TypeRef;
+ Name : String := "llvm.dbg.declare" & ASCII.NUL;
+ begin
+ Atypes := (MetadataType, MetadataType);
+ Ftype := FunctionType (VoidType, Atypes, Atypes'Length, 0);
+ Llvm_Dbg_Declare := AddFunction (Module, Name'Address, Ftype);
+ AddFunctionAttr (Llvm_Dbg_Declare,
+ NoUnwindAttribute + ReadNoneAttribute);
+ end;
+ end if;
+ end Init;
+end Ortho_LLVM.Main;
diff --git a/ortho/llvm/ortho_llvm-main.ads b/ortho/llvm/ortho_llvm-main.ads
new file mode 100644
index 000000000..56bbdb44a
--- /dev/null
+++ b/ortho/llvm/ortho_llvm-main.ads
@@ -0,0 +1,57 @@
+-- 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 GNAT.Directory_Operations;
+with LLVM.Target; use LLVM.Target;
+with LLVM.TargetMachine; use LLVM.TargetMachine;
+
+package Ortho_LLVM.Main is
+ use LLVM.Core;
+
+ -- LLVM specific: the module.
+ Module : ModuleRef;
+
+ -- Descriptor for the layout.
+ Target_Data : TargetDataRef;
+
+ Target_Machine : TargetMachineRef;
+
+ -- Optimization level
+ Optimization : CodeGenOptLevel := CodeGenLevelDefault;
+
+ -- Set by -g to generate debug info.
+ Flag_Debug : Boolean := False;
+
+ Debug_ID : unsigned;
+
+ -- Some predefined types and functions.
+ Char_Type : O_Tnode;
+ Char_Ptr_Type : O_Tnode;
+
+ Stacksave_Fun : ValueRef;
+ Stacksave_Name : constant String := "llvm.stacksave" & ASCII.NUL;
+ Stackrestore_Fun : ValueRef;
+ Stackrestore_Name : constant String := "llvm.stackrestore" & ASCII.NUL;
+
+ Current_Directory : constant String :=
+ GNAT.Directory_Operations.Get_Current_Dir;
+
+ function To_String (C : Cstring) return String;
+
+ procedure Init;
+end Ortho_LLVM.Main;
diff --git a/ortho/llvm/ortho_llvm.adb b/ortho/llvm/ortho_llvm.adb
new file mode 100644
index 000000000..b18eae351
--- /dev/null
+++ b/ortho/llvm/ortho_llvm.adb
@@ -0,0 +1,2768 @@
+-- LLVM back-end for ortho.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Ortho_LLVM.Main; use Ortho_LLVM.Main;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with LLVM.Target; use LLVM.Target;
+
+package body Ortho_LLVM is
+
+ -- Target_Data : TargetDataRef;
+ Cur_Func : ValueRef;
+ Cur_Func_Decl : O_Dnode;
+ Unreach : Boolean;
+
+ type Declare_Block_Type;
+ type Declare_Block_Acc is access Declare_Block_Type;
+
+ type Declare_Block_Type is record
+ Stmt_Bb : BasicBlockRef;
+
+ Dbg_Scope : ValueRef;
+ Prev : Declare_Block_Acc;
+ end record;
+
+ Cur_Declare_Block : Declare_Block_Acc;
+ Old_Declare_Block : Declare_Block_Acc;
+
+ -- For debugging
+
+ DW_Version : constant := 16#c_0000#;
+ DW_TAG_Array_Type : constant := DW_Version + 16#01#;
+ DW_TAG_Enumeration_Type : constant := DW_Version + 16#04#;
+ DW_TAG_Lexical_Block : constant := DW_Version + 16#0b#;
+ DW_TAG_Member : constant := DW_Version + 16#0d#;
+ DW_TAG_Pointer_Type : constant := DW_Version + 16#0f#;
+ DW_TAG_Compile_Unit : constant := DW_Version + 16#11#;
+ DW_TAG_Structure_Type : constant := DW_Version + 16#13#;
+ DW_TAG_Subroutine_Type : constant := DW_Version + 16#15#;
+ DW_TAG_Subrange_Type : constant := DW_Version + 16#21#;
+ DW_TAG_Base_Type : constant := DW_Version + 16#24#;
+ DW_TAG_Enumerator : constant := DW_Version + 16#28#;
+ DW_TAG_File_Type : constant := DW_Version + 16#29#;
+ DW_TAG_Subprogram : constant := DW_Version + 16#2e#;
+ DW_TAG_Variable : constant := DW_Version + 16#34#;
+
+ DW_TAG_Auto_Variable : constant := DW_Version + 16#100#;
+ DW_TAG_Arg_Variable : constant := DW_Version + 16#101#;
+
+ DW_ATE_address : constant := 16#01#;
+ DW_ATE_boolean : constant := 16#02#;
+ DW_ATE_float : constant := 16#04#;
+ DW_ATE_signed : constant := 16#05#;
+ DW_ATE_unsigned : constant := 16#07#;
+ pragma Unreferenced (DW_ATE_address, DW_ATE_boolean);
+
+ -- File + Dir metadata
+ Dbg_Current_Filedir : ValueRef;
+ Dbg_Current_File : ValueRef; -- The DW_TAG_File_Type
+
+ Dbg_Current_Line : unsigned := 0;
+
+ Dbg_Current_Scope : ValueRef;
+ Scope_Uniq_Id : Unsigned_64 := 0;
+
+ -- Metadata for the instruction
+ Dbg_Insn_MD : ValueRef;
+ Dbg_Insn_MD_Line : unsigned := 0;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (ValueRefArray, ValueRefArray_Acc);
+
+ package Dbg_Utils is
+ type Dyn_MDNode is private;
+
+ procedure Append (D : in out Dyn_MDNode; Val : ValueRef);
+ function Get_Value (D : Dyn_MDNode) return ValueRef;
+
+ -- Reset D. FIXME: should be done automatically within Get_Value.
+ procedure Clear (D : out Dyn_MDNode);
+ private
+ Chunk_Length : constant unsigned := 32;
+ type MD_Chunk;
+ type MD_Chunk_Acc is access MD_Chunk;
+
+ type MD_Chunk is record
+ Vals : ValueRefArray (1 .. Chunk_Length);
+ Next : MD_Chunk_Acc;
+ end record;
+
+ type Dyn_MDNode is record
+ First : MD_Chunk_Acc;
+ Last : MD_Chunk_Acc;
+ Nbr : unsigned := 0;
+ end record;
+ end Dbg_Utils;
+
+ package body Dbg_Utils is
+ procedure Append (D : in out Dyn_MDNode; Val : ValueRef) is
+ Chunk : MD_Chunk_Acc;
+ Pos : constant unsigned := D.Nbr rem Chunk_Length;
+ begin
+ if Pos = 0 then
+ Chunk := new MD_Chunk;
+ if D.First = null then
+ D.First := Chunk;
+ else
+ D.Last.Next := Chunk;
+ end if;
+ D.Last := Chunk;
+ else
+ Chunk := D.Last;
+ end if;
+ Chunk.Vals (Pos + 1) := Val;
+ D.Nbr := D.Nbr + 1;
+ end Append;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (MD_Chunk, MD_Chunk_Acc);
+
+ function Get_Value (D : Dyn_MDNode) return ValueRef
+ is
+ Vals : ValueRefArray (1 .. D.Nbr);
+ Pos : unsigned;
+ Chunk : MD_Chunk_Acc := D.First;
+ Next_Chunk : MD_Chunk_Acc;
+ Nbr : constant unsigned := D.Nbr;
+ begin
+ Pos := 0;
+ -- Copy by chunks
+ while Pos + Chunk_Length < Nbr loop
+ Vals (Pos + 1 .. Pos + Chunk_Length) := Chunk.Vals;
+ Pos := Pos + Chunk_Length;
+ Next_Chunk := Chunk.Next;
+ Free (Chunk);
+ Chunk := Next_Chunk;
+ end loop;
+ -- Last chunk
+ if Pos < Nbr then
+ Vals (Pos + 1 .. Pos + Nbr - Pos) := Chunk.Vals (1 .. Nbr - Pos);
+ Free (Chunk);
+ end if;
+ return MDNode (Vals, Vals'Length);
+ end Get_Value;
+
+ procedure Clear (D : out Dyn_MDNode) is
+ begin
+ D := (null, null, 0);
+ end Clear;
+ end Dbg_Utils;
+
+ use Dbg_Utils;
+
+ -- List of debug info for subprograms.
+ Subprg_Nodes: Dyn_MDNode;
+
+ -- List of literals for enumerated type
+ Enum_Nodes : Dyn_MDNode;
+
+ -- List of global variables
+ Global_Nodes : Dyn_MDNode;
+
+ -- Create a MDString from an Ada string.
+ function MDString (Str : String) return ValueRef is
+ begin
+ return MDString (Str'Address, Str'Length);
+ end MDString;
+
+ function MDString (Id : O_Ident) return ValueRef is
+ begin
+ return MDString (Get_Cstring (Id), unsigned (Get_String_Length (Id)));
+ end MDString;
+
+ function Dbg_Size (Atype : TypeRef) return ValueRef is
+ begin
+ return ConstInt (Int64Type, 8 * ABISizeOfType (Target_Data, Atype), 0);
+ end Dbg_Size;
+
+ function Dbg_Align (Atype : TypeRef) return ValueRef is
+ begin
+ return ConstInt
+ (Int64Type,
+ Unsigned_64 (8 * ABIAlignmentOfType (Target_Data, Atype)), 0);
+ end Dbg_Align;
+
+ function Dbg_Line return ValueRef is
+ begin
+ return ConstInt (Int32Type, Unsigned_64 (Dbg_Current_Line), 0);
+ end Dbg_Line;
+
+ -- Set debug metadata on instruction INSN.
+ -- FIXME: check if INSN is really an instruction
+ procedure Set_Insn_Dbg (Insn : ValueRef) is
+ begin
+ if Flag_Debug then
+ if Dbg_Current_Line /= Dbg_Insn_MD_Line then
+ declare
+ Vals : ValueRefArray (0 .. 3);
+ begin
+ Vals := (Dbg_Line,
+ ConstInt (Int32Type, 0, 0), -- col
+ Dbg_Current_Scope, -- context
+ Null_ValueRef); -- inline
+ Dbg_Insn_MD := MDNode (Vals, Vals'Length);
+ Dbg_Insn_MD_Line := Dbg_Current_Line;
+ end;
+ end if;
+ SetMetadata (Insn, Debug_ID, Dbg_Insn_MD);
+ end if;
+ end Set_Insn_Dbg;
+
+ procedure Dbg_Create_Variable (Tag : Unsigned_32;
+ Ident : O_Ident;
+ Vtype : O_Tnode;
+ Argno : Natural;
+ Addr : ValueRef)
+ is
+ Vals : ValueRefArray (0 .. 7);
+ Str : constant ValueRef := MDString (Ident);
+ Call_Vals : ValueRefArray (0 .. 1);
+ Call : ValueRef;
+ begin
+ Vals := (ConstInt (Int32Type, Unsigned_64 (Tag), 0),
+ Dbg_Current_Scope,
+ Str,
+ Dbg_Current_File,
+ ConstInt (Int32Type,
+ Unsigned_64 (Dbg_Current_Line)
+ + Unsigned_64 (Argno) * 2 ** 24, 0),
+ Vtype.Dbg,
+ ConstInt (Int32Type, 0, 0), -- flags
+ ConstInt (Int32Type, 0, 0));
+
+ Call_Vals := (MDNode ((0 => Addr), 1),
+ MDNode (Vals, Vals'Length));
+ Call := BuildCall (Decl_Builder, Llvm_Dbg_Declare,
+ Call_Vals, Call_Vals'Length, Empty_Cstring);
+ Set_Insn_Dbg (Call);
+ end Dbg_Create_Variable;
+
+ procedure Create_Declare_Block
+ is
+ Res : Declare_Block_Acc;
+ begin
+ if Old_Declare_Block /= null then
+ Res := Old_Declare_Block;
+ Old_Declare_Block := Res.Prev;
+ else
+ Res := new Declare_Block_Type;
+ end if;
+
+ Res.Prev := Cur_Declare_Block;
+ Cur_Declare_Block := Res;
+
+ if not Unreach then
+ Res.Stmt_Bb := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ end if;
+ end Create_Declare_Block;
+
+ procedure Destroy_Declare_Block
+ is
+ Blk : constant Declare_Block_Acc := Cur_Declare_Block;
+ begin
+ Cur_Declare_Block := Blk.Prev;
+ Blk.Prev := Old_Declare_Block;
+ Old_Declare_Block := Blk;
+ end Destroy_Declare_Block;
+
+ -----------------------
+ -- Start_Record_Type --
+ -----------------------
+
+ procedure Start_Record_Type (Elements : out O_Element_List) is
+ begin
+ Elements := (Nbr_Elements => 0,
+ Rec_Type => O_Tnode_Null,
+ Size => 0,
+ Align => 0,
+ Align_Type => Null_TypeRef,
+ First_Elem => null,
+ Last_Elem => null);
+ end Start_Record_Type;
+
+ ----------------------
+ -- New_Record_Field --
+ ----------------------
+
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode)
+ is
+ O_El : O_Element_Acc;
+ begin
+ El := (Kind => OF_Record,
+ Index => Elements.Nbr_Elements,
+ Ftype => Etype);
+ Elements.Nbr_Elements := Elements.Nbr_Elements + 1;
+ O_El := new O_Element'(Next => null,
+ Etype => Etype,
+ Ident => Ident);
+ if Elements.First_Elem = null then
+ Elements.First_Elem := O_El;
+ else
+ Elements.Last_Elem.Next := O_El;
+ end if;
+ Elements.Last_Elem := O_El;
+ end New_Record_Field;
+
+ ------------------------
+ -- Finish_Record_Type --
+ ------------------------
+
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List;
+ Res : out O_Tnode)
+ is
+ procedure Free is new Ada.Unchecked_Deallocation
+ (O_Element, O_Element_Acc);
+
+ Count : constant unsigned := unsigned (Elements.Nbr_Elements);
+ El : O_Element_Acc;
+ Next_El : O_Element_Acc;
+ Types : TypeRefArray (1 .. Count);
+ begin
+ El := Elements.First_Elem;
+ for I in Types'Range loop
+ Types (I) := Get_LLVM_Type (El.Etype);
+ El := El.Next;
+ end loop;
+
+ if Elements.Rec_Type /= null then
+ -- Completion
+ StructSetBody (Elements.Rec_Type.LLVM, Types, Count, 0);
+ Res := Elements.Rec_Type;
+ else
+ Res := new O_Tnode_Type'(Kind => ON_Record_Type,
+ LLVM => StructType (Types, Count, 0),
+ Dbg => Null_ValueRef);
+ end if;
+
+ if Flag_Debug then
+ declare
+ Fields : ValueRefArray (1 .. Count);
+ Vals : ValueRefArray (0 .. 9);
+ Ftype : TypeRef;
+ Fields_Arr : ValueRef;
+ begin
+ El := Elements.First_Elem;
+ for I in Fields'Range loop
+ Ftype := Get_LLVM_Type (El.Etype);
+ Vals :=
+ (ConstInt (Int32Type, DW_TAG_Member, 0),
+ Dbg_Current_File,
+ Null_ValueRef,
+ MDString (El.Ident),
+ ConstInt (Int32Type, 0, 0), -- linenum
+ Dbg_Size (Ftype),
+ Dbg_Align (Ftype),
+ ConstInt
+ (Int32Type,
+ 8 * OffsetOfElement (Target_Data,
+ Res.LLVM, Unsigned_32 (I - 1)), 0),
+ ConstInt (Int32Type, 0, 0), -- Flags
+ El.Etype.Dbg);
+ Fields (I) := MDNode (Vals, Vals'Length);
+ El := El.Next;
+ end loop;
+ Fields_Arr := MDNode (Fields, Fields'Length);
+ if Elements.Rec_Type /= null then
+ -- Completion
+ MDNodeReplaceOperandWith (Res.Dbg, 10, Fields_Arr);
+ MDNodeReplaceOperandWith (Res.Dbg, 5, Dbg_Size (Res.LLVM));
+ MDNodeReplaceOperandWith (Res.Dbg, 6, Dbg_Align (Res.LLVM));
+ else
+ -- Temporary borrowed.
+ Res.Dbg := Fields_Arr;
+ end if;
+ end;
+ end if;
+
+ -- Free elements
+ El := Elements.First_Elem;
+ for I in Types'Range loop
+ Next_El := El.Next;
+ Free (El);
+ El := Next_El;
+ end loop;
+ end Finish_Record_Type;
+
+ --------------------------------
+ -- New_Uncomplete_Record_Type --
+ --------------------------------
+
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is
+ begin
+ -- LLVM type will be created when the type is declared.
+ Res := new O_Tnode_Type'(Kind => ON_Incomplete_Record_Type,
+ LLVM => Null_TypeRef,
+ Dbg => Null_ValueRef);
+ end New_Uncomplete_Record_Type;
+
+ ----------------------------------
+ -- Start_Uncomplete_Record_Type --
+ ----------------------------------
+
+ procedure Start_Uncomplete_Record_Type
+ (Res : O_Tnode;
+ Elements : out O_Element_List)
+ is
+ begin
+ if Res.Kind /= ON_Incomplete_Record_Type then
+ raise Program_Error;
+ end if;
+ Elements := (Nbr_Elements => 0,
+ Rec_Type => Res,
+ Size => 0,
+ Align => 0,
+ Align_Type => Null_TypeRef,
+ First_Elem => null,
+ Last_Elem => null);
+ end Start_Uncomplete_Record_Type;
+
+ ----------------------
+ -- Start_Union_Type --
+ ----------------------
+
+ procedure Start_Union_Type (Elements : out O_Element_List) is
+ begin
+ Elements := (Nbr_Elements => 0,
+ Rec_Type => O_Tnode_Null,
+ Size => 0,
+ Align => 0,
+ Align_Type => Null_TypeRef,
+ First_Elem => null,
+ Last_Elem => null);
+ end Start_Union_Type;
+
+ ---------------------
+ -- New_Union_Field --
+ ---------------------
+
+ procedure New_Union_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode)
+ is
+ pragma Unreferenced (Ident);
+
+ El_Type : constant TypeRef := Get_LLVM_Type (Etype);
+ Size : constant unsigned :=
+ unsigned (ABISizeOfType (Target_Data, El_Type));
+ Align : constant Unsigned_32 :=
+ ABIAlignmentOfType (Target_Data, El_Type);
+ begin
+ El := (Kind => OF_Union, Utype => El_Type, Ftype => Etype);
+ if Size > Elements.Size then
+ Elements.Size := Size;
+ end if;
+ if Elements.Align_Type = Null_TypeRef or else Align > Elements.Align then
+ Elements.Align := Align;
+ Elements.Align_Type := El_Type;
+ end if;
+ end New_Union_Field;
+
+ -----------------------
+ -- Finish_Union_Type --
+ -----------------------
+
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List;
+ Res : out O_Tnode)
+ is
+ Count : unsigned;
+ Types : TypeRefArray (1 .. 2);
+ Pad : unsigned;
+ begin
+ if Elements.Align_Type = Null_TypeRef then
+ -- An empty union. Is it allowed ?
+ Count := 0;
+ else
+ -- The first element is the field with the biggest alignment
+ Types (1) := Elements.Align_Type;
+ -- Possibly complete with an array of bytes.
+ Pad := Elements.Size
+ - unsigned (ABISizeOfType (Target_Data, Elements.Align_Type));
+ if Pad /= 0 then
+ Types (2) := ArrayType (Int8Type, Pad);
+ Count := 2;
+ else
+ Count := 1;
+ end if;
+ end if;
+ Res := new O_Tnode_Type'(Kind => ON_Union_Type,
+ LLVM => StructType (Types, Count, 0),
+ Dbg => Null_ValueRef,
+ Un_Size => Elements.Size,
+ Un_Main_Field => Elements.Align_Type);
+ end Finish_Union_Type;
+
+ ---------------------
+ -- New_Access_Type --
+ ---------------------
+
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode is
+ begin
+ if Dtype = O_Tnode_Null then
+ -- LLVM type will be built by New_Type_Decl, so that the name
+ -- can be used for the structure.
+ return new O_Tnode_Type'(Kind => ON_Incomplete_Access_Type,
+ LLVM => Null_TypeRef,
+ Dbg => Null_ValueRef,
+ Acc_Type => O_Tnode_Null);
+ else
+ return new O_Tnode_Type'(Kind => ON_Access_Type,
+ LLVM => PointerType (Get_LLVM_Type (Dtype)),
+ Dbg => Null_ValueRef,
+ Acc_Type => Dtype);
+ end if;
+ end New_Access_Type;
+
+ ------------------------
+ -- Finish_Access_Type --
+ ------------------------
+
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode)
+ is
+ Types : TypeRefArray (1 .. 1);
+ begin
+ if Atype.Kind /= ON_Incomplete_Access_Type then
+ -- Not an incomplete access type.
+ raise Program_Error;
+ end if;
+ if Atype.Acc_Type /= O_Tnode_Null then
+ -- Already completed.
+ raise Program_Error;
+ end if;
+ -- Completion
+ Types (1) := Get_LLVM_Type (Dtype);
+ StructSetBody (GetElementType (Atype.LLVM), Types, Types'Length, 0);
+ Atype.Acc_Type := Dtype;
+
+ -- Debug.
+ -- FIXME.
+ end Finish_Access_Type;
+
+ --------------------
+ -- New_Array_Type --
+ --------------------
+
+ function Dbg_Array (El_Type : O_Tnode; Len : ValueRef; Atype : O_Tnode)
+ return ValueRef
+ is
+ Rng : ValueRefArray (0 .. 2);
+ Rng_Arr : ValueRefArray (0 .. 0);
+ Vals : ValueRefArray (0 .. 14);
+ begin
+ Rng := (ConstInt (Int32Type, DW_TAG_Subrange_Type, 0),
+ ConstInt (Int64Type, 0, 0), -- Lo
+ Len); -- Count
+ Rng_Arr := (0 => MDNode (Rng, Rng'Length));
+ Vals := (ConstInt (Int32Type, DW_TAG_Array_Type, 0),
+ Null_ValueRef,
+ Null_ValueRef, -- context
+ Null_ValueRef,
+ ConstInt (Int32Type, 0, 0), -- line
+ Dbg_Size (Atype.LLVM),
+ Dbg_Align (Atype.LLVM),
+ ConstInt (Int32Type, 0, 0), -- Offset
+ ConstInt (Int32Type, 0, 0), -- Flags
+ El_Type.Dbg, -- element type
+ MDNode (Rng_Arr, Rng_Arr'Length), -- subscript
+ ConstInt (Int32Type, 0, 0),
+ Null_ValueRef,
+ Null_ValueRef,
+ Null_ValueRef); -- Runtime lang
+ return MDNode (Vals, Vals'Length);
+ end Dbg_Array;
+
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode
+ is
+ pragma Unreferenced (Index_Type);
+ Res : O_Tnode;
+ begin
+ Res := new O_Tnode_Type'
+ (Kind => ON_Array_Type,
+ LLVM => ArrayType (Get_LLVM_Type (El_Type), 0),
+ Dbg => Null_ValueRef,
+ Arr_El_Type => El_Type);
+
+ if Flag_Debug then
+ Res.Dbg := Dbg_Array
+ (El_Type, ConstInt (Int64Type, Unsigned_64'Last, 1), Res);
+ end if;
+
+ return Res;
+ end New_Array_Type;
+
+ --------------------------------
+ -- New_Constrained_Array_Type --
+ --------------------------------
+
+ function New_Constrained_Array_Type
+ (Atype : O_Tnode; Length : O_Cnode) return O_Tnode
+ is
+ Res : O_Tnode;
+ Len : constant unsigned := unsigned (ConstIntGetZExtValue (Length.LLVM));
+ begin
+ Res := new O_Tnode_Type'
+ (Kind => ON_Array_Sub_Type,
+ LLVM => ArrayType (GetElementType (Get_LLVM_Type (Atype)), Len),
+ Dbg => Null_ValueRef,
+ Arr_El_Type => Atype.Arr_El_Type);
+
+ if Flag_Debug then
+ Res.Dbg := Dbg_Array
+ (Atype.Arr_El_Type,
+ ConstInt (Int64Type, Unsigned_64 (Len), 0), Res);
+ end if;
+
+ return Res;
+ end New_Constrained_Array_Type;
+
+ -----------------------
+ -- New_Unsigned_Type --
+ -----------------------
+
+ function Size_To_Llvm (Size : Natural) return TypeRef is
+ Llvm : TypeRef;
+ begin
+ case Size is
+ when 8 =>
+ Llvm := Int8Type;
+ when 32 =>
+ Llvm := Int32Type;
+ when 64 =>
+ Llvm := Int64Type;
+ when others =>
+ raise Program_Error;
+ end case;
+ return Llvm;
+ end Size_To_Llvm;
+
+ function New_Unsigned_Type (Size : Natural) return O_Tnode is
+ begin
+ return new O_Tnode_Type'(Kind => ON_Unsigned_Type,
+ LLVM => Size_To_Llvm (Size),
+ Dbg => Null_ValueRef,
+ Scal_Size => Size);
+ end New_Unsigned_Type;
+
+ ---------------------
+ -- New_Signed_Type --
+ ---------------------
+
+ function New_Signed_Type (Size : Natural) return O_Tnode is
+ begin
+ return new O_Tnode_Type'(Kind => ON_Signed_Type,
+ LLVM => Size_To_Llvm (Size),
+ Dbg => Null_ValueRef,
+ Scal_Size => Size);
+ end New_Signed_Type;
+
+ --------------------
+ -- New_Float_Type --
+ --------------------
+
+ function New_Float_Type return O_Tnode is
+ begin
+ return new O_Tnode_Type'(Kind => ON_Float_Type,
+ LLVM => DoubleType,
+ Dbg => Null_ValueRef,
+ Scal_Size => 64);
+ end New_Float_Type;
+
+ procedure Dbg_Add_Enumeration (Id : O_Ident; Val : Unsigned_64) is
+ Vals : ValueRefArray (0 .. 2);
+ begin
+ Vals := (ConstInt (Int32Type, DW_TAG_Enumerator, 0),
+ MDString (Id),
+ ConstInt (Int64Type, Val, 0));
+ -- FIXME: make it local to List ?
+ Append (Enum_Nodes, MDNode (Vals, Vals'Length));
+ end Dbg_Add_Enumeration;
+
+
+ ----------------------
+ -- New_Boolean_Type --
+ ----------------------
+
+ procedure New_Boolean_Type
+ (Res : out O_Tnode;
+ False_Id : O_Ident; False_E : out O_Cnode;
+ True_Id : O_Ident; True_E : out O_Cnode)
+ is
+ begin
+ Res := new O_Tnode_Type'(Kind => ON_Boolean_Type,
+ LLVM => Int1Type,
+ Dbg => Null_ValueRef,
+ Scal_Size => 1);
+ False_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 0, 0),
+ Ctype => Res);
+ True_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 1, 0),
+ Ctype => Res);
+ if Flag_Debug then
+ Dbg_Add_Enumeration (False_Id, 0);
+ Dbg_Add_Enumeration (True_Id, 1);
+ end if;
+ end New_Boolean_Type;
+
+ ---------------------
+ -- Start_Enum_Type --
+ ---------------------
+
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural)
+ is
+ LLVM : constant TypeRef := Size_To_Llvm (Size);
+ begin
+ List := (LLVM => LLVM,
+ Num => 0,
+ Etype => new O_Tnode_Type'(Kind => ON_Enum_Type,
+ LLVM => LLVM,
+ Scal_Size => Size,
+ Dbg => Null_ValueRef));
+
+ end Start_Enum_Type;
+
+ ----------------------
+ -- New_Enum_Literal --
+ ----------------------
+
+ procedure New_Enum_Literal
+ (List : in out O_Enum_List; Ident : O_Ident; Res : out O_Cnode)
+ is
+ begin
+ Res := O_Cnode'(LLVM => ConstInt (List.LLVM, Unsigned_64 (List.Num), 0),
+ Ctype => List.Etype);
+ if Flag_Debug then
+ Dbg_Add_Enumeration (Ident, Unsigned_64 (List.Num));
+ end if;
+
+ List.Num := List.Num + 1;
+ end New_Enum_Literal;
+
+ ----------------------
+ -- Finish_Enum_Type --
+ ----------------------
+
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is
+ begin
+ Res := List.Etype;
+ end Finish_Enum_Type;
+
+ ------------------------
+ -- New_Signed_Literal --
+ ------------------------
+
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode
+ is
+ function To_Unsigned_64 is new Ada.Unchecked_Conversion
+ (Integer_64, Unsigned_64);
+ begin
+ return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype),
+ To_Unsigned_64 (Value), 1),
+ Ctype => Ltype);
+ end New_Signed_Literal;
+
+ --------------------------
+ -- New_Unsigned_Literal --
+ --------------------------
+
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode is
+ begin
+ return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype), Value, 0),
+ Ctype => Ltype);
+ end New_Unsigned_Literal;
+
+ -----------------------
+ -- New_Float_Literal --
+ -----------------------
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode is
+ begin
+ return O_Cnode'(LLVM => ConstReal (Get_LLVM_Type (Ltype),
+ Interfaces.C.double (Value)),
+ Ctype => Ltype);
+ end New_Float_Literal;
+
+ ---------------------
+ -- New_Null_Access --
+ ---------------------
+
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode is
+ begin
+ return O_Cnode'(LLVM => ConstNull (Get_LLVM_Type (Ltype)),
+ Ctype => Ltype);
+ end New_Null_Access;
+
+ -----------------------
+ -- Start_Record_Aggr --
+ -----------------------
+
+ procedure Start_Record_Aggr
+ (List : out O_Record_Aggr_List;
+ Atype : O_Tnode)
+ is
+ Llvm : constant TypeRef := Get_LLVM_Type (Atype);
+ begin
+ List :=
+ (Len => 0,
+ Vals => new ValueRefArray (1 .. CountStructElementTypes (Llvm)),
+ Atype => Atype);
+ end Start_Record_Aggr;
+
+ ------------------------
+ -- New_Record_Aggr_El --
+ ------------------------
+
+ procedure New_Record_Aggr_El
+ (List : in out O_Record_Aggr_List; Value : O_Cnode)
+ is
+ begin
+ List.Len := List.Len + 1;
+ List.Vals (List.Len) := Value.LLVM;
+ end New_Record_Aggr_El;
+
+ ------------------------
+ -- Finish_Record_Aggr --
+ ------------------------
+
+ procedure Finish_Record_Aggr
+ (List : in out O_Record_Aggr_List;
+ Res : out O_Cnode)
+ is
+ begin
+ Res := (LLVM => ConstStruct (List.Vals.all, List.Len, 0),
+ Ctype => List.Atype);
+ Free (List.Vals);
+ end Finish_Record_Aggr;
+
+ ----------------------
+ -- Start_Array_Aggr --
+ ----------------------
+
+ procedure Start_Array_Aggr
+ (List : out O_Array_Aggr_List;
+ Atype : O_Tnode)
+ is
+ Llvm : constant TypeRef := Get_LLVM_Type (Atype);
+ begin
+ List := (Len => 0,
+ Vals => new ValueRefArray (1 .. GetArrayLength (Llvm)),
+ El_Type => GetElementType (Llvm),
+ Atype => Atype);
+ end Start_Array_Aggr;
+
+ -----------------------
+ -- New_Array_Aggr_El --
+ -----------------------
+
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode)
+ is
+ begin
+ List.Len := List.Len + 1;
+ List.Vals (List.Len) := Value.LLVM;
+ end New_Array_Aggr_El;
+
+ -----------------------
+ -- Finish_Array_Aggr --
+ -----------------------
+
+ procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List;
+ Res : out O_Cnode)
+ is
+ begin
+ Res := (LLVM => ConstArray (List.El_Type,
+ List.Vals.all, List.Len),
+ Ctype => List.Atype);
+ Free (List.Vals);
+ end Finish_Array_Aggr;
+
+ --------------------
+ -- New_Union_Aggr --
+ --------------------
+
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode
+ is
+ Values : ValueRefArray (1 .. 2);
+ Count : unsigned;
+ Size : constant unsigned :=
+ unsigned (ABISizeOfType (Target_Data, Field.Utype));
+
+ begin
+ Values (1) := Value.LLVM;
+ if Size < Atype.Un_Size then
+ Values (2) := GetUndef (ArrayType (Int8Type, Atype.Un_Size - Size));
+ Count := 2;
+ else
+ Count := 1;
+ end if;
+
+ -- If `FIELD` is the main field of the union, create a struct using
+ -- the same type as the union (and possibly pad).
+ if Field.Utype = Atype.Un_Main_Field then
+ return O_Cnode'
+ (LLVM => ConstNamedStruct (Atype.LLVM, Values, Count),
+ Ctype => Atype);
+ else
+ -- Create an on-the-fly record.
+ return O_Cnode'(LLVM => ConstStruct (Values, Count, 0),
+ Ctype => Atype);
+ end if;
+ end New_Union_Aggr;
+
+ ----------------
+ -- New_Sizeof --
+ ----------------
+
+ -- Return VAL with type RTYPE (either unsigned or access)
+ function Const_To_Cnode (Rtype : O_Tnode; Val : Unsigned_64) return O_Cnode
+ is
+ Tmp : ValueRef;
+ begin
+ case Rtype.Kind is
+ when ON_Scalar_Types =>
+ -- Well, unsigned in fact.
+ return O_Cnode'(LLVM => ConstInt (Rtype.LLVM, Val, 0),
+ Ctype => Rtype);
+ when ON_Access_Type =>
+ Tmp := ConstInt (Int64Type, Val, 0);
+ return O_Cnode'(LLVM => ConstIntToPtr (Tmp, Rtype.LLVM),
+ Ctype => Rtype);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Const_To_Cnode;
+
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
+ begin
+ return Const_To_Cnode
+ (Rtype, ABISizeOfType (Target_Data, Get_LLVM_Type (Atype)));
+ end New_Sizeof;
+
+ -----------------
+ -- New_Alignof --
+ -----------------
+
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
+ begin
+ return Const_To_Cnode
+ (Rtype,
+ Unsigned_64
+ (ABIAlignmentOfType (Target_Data, Get_LLVM_Type (Atype))));
+ end New_Alignof;
+
+ ------------------
+ -- New_Offsetof --
+ ------------------
+
+ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode is
+ begin
+ return Const_To_Cnode
+ (Rtype,
+ OffsetOfElement (Target_Data,
+ Get_LLVM_Type (Atype),
+ Unsigned_32 (Field.Index)));
+ end New_Offsetof;
+
+ ----------------------------
+ -- New_Subprogram_Address --
+ ----------------------------
+
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode'
+ (LLVM => ConstBitCast (Subprg.LLVM, Get_LLVM_Type (Atype)),
+ Ctype => Atype);
+ end New_Subprogram_Address;
+
+ ------------------------
+ -- New_Global_Address --
+ ------------------------
+
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
+ Ctype => Atype);
+ end New_Global_Address;
+
+ ----------------------------------
+ -- New_Global_Unchecked_Address --
+ ----------------------------------
+
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode
+ is
+ begin
+ return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
+ Ctype => Atype);
+ end New_Global_Unchecked_Address;
+
+ -------------
+ -- New_Lit --
+ -------------
+
+ function New_Lit (Lit : O_Cnode) return O_Enode is
+ begin
+ return O_Enode'(LLVM => Lit.LLVM,
+ Etype => Lit.Ctype);
+ end New_Lit;
+
+ -------------------
+ -- New_Dyadic_Op --
+ -------------------
+
+ function New_Smod (L, R : ValueRef; Res_Type : TypeRef)
+ return ValueRef
+ is
+ Cond : ValueRef;
+ Br : ValueRef;
+ pragma Unreferenced (Br);
+
+ -- The result of 'L rem R'.
+ Rm : ValueRef;
+
+ -- Rm + R
+ Rm_Plus_R : ValueRef;
+
+ -- The result of 'L xor R'.
+ R_Xor : ValueRef;
+
+ Adj : ValueRef;
+ Phi : ValueRef;
+
+ -- Basic basic for the non-overflow branch
+ Normal_Bb : constant BasicBlockRef :=
+ AppendBasicBlock (Cur_Func, Empty_Cstring);
+
+ Adjust_Bb : constant BasicBlockRef :=
+ AppendBasicBlock (Cur_Func, Empty_Cstring);
+
+ -- Basic block after the result
+ Next_Bb : constant BasicBlockRef :=
+ AppendBasicBlock (Cur_Func, Empty_Cstring);
+
+ Vals : ValueRefArray (1 .. 3);
+ BBs : BasicBlockRefArray (1 .. 3);
+ begin
+ -- Avoid overflow with -1:
+ -- if R = -1 then
+ -- result := 0;
+ -- else
+ -- ...
+ Cond := BuildICmp
+ (Builder, IntEQ, R, ConstAllOnes (Res_Type), Empty_Cstring);
+ Br := BuildCondBr (Builder, Cond, Next_Bb, Normal_Bb);
+ Vals (1) := ConstNull (Res_Type);
+ BBs (1) := GetInsertBlock (Builder);
+
+ -- Rm := Left rem Right
+ PositionBuilderAtEnd (Builder, Normal_Bb);
+ Rm := BuildSRem (Builder, L, R, Empty_Cstring);
+
+ -- if R = 0 then
+ -- result := 0
+ -- else
+ Cond := BuildICmp
+ (Builder, IntEQ, Rm, ConstNull (Res_Type), Empty_Cstring);
+ Br := BuildCondBr (Builder, Cond, Next_Bb, Adjust_Bb);
+ Vals (2) := ConstNull (Res_Type);
+ BBs (2) := Normal_Bb;
+
+ -- if L xor R < 0 then
+ -- result := Rm + R
+ -- else
+ -- result := Rm;
+ -- end if;
+ PositionBuilderAtEnd (Builder, Adjust_Bb);
+ R_Xor := BuildXor (Builder, L, R, Empty_Cstring);
+ Cond := BuildICmp
+ (Builder, IntSLT, R_Xor, ConstNull (Res_Type), Empty_Cstring);
+ Rm_Plus_R := BuildAdd (Builder, Rm, R, Empty_Cstring);
+ Adj := BuildSelect (Builder, Cond, Rm_Plus_R, Rm, Empty_Cstring);
+ Br := BuildBr (Builder, Next_Bb);
+ Vals (3) := Adj;
+ BBs (3) := Adjust_Bb;
+
+ -- The Phi node
+ PositionBuilderAtEnd (Builder, Next_Bb);
+ Phi := BuildPhi (Builder, Res_Type, Empty_Cstring);
+ AddIncoming (Phi, Vals, BBs, Vals'Length);
+
+ return Phi;
+ end New_Smod;
+
+ type Dyadic_Builder_Acc is access
+ function (Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ pragma Convention (C, Dyadic_Builder_Acc);
+
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode
+ is
+ Build : Dyadic_Builder_Acc := null;
+ Res : ValueRef := Null_ValueRef;
+ begin
+ if Unreach then
+ return O_Enode'(LLVM => Null_ValueRef, Etype => Left.Etype);
+ end if;
+
+ case Left.Etype.Kind is
+ when ON_Integer_Types =>
+ case Kind is
+ when ON_And =>
+ Build := BuildAnd'Access;
+ when ON_Or =>
+ Build := BuildOr'Access;
+ when ON_Xor =>
+ Build := BuildXor'Access;
+
+ when ON_Add_Ov =>
+ Build := BuildAdd'Access;
+ when ON_Sub_Ov =>
+ Build := BuildSub'Access;
+ when ON_Mul_Ov =>
+ Build := BuildMul'Access;
+
+ when ON_Div_Ov =>
+ case Left.Etype.Kind is
+ when ON_Unsigned_Type =>
+ Build := BuildUDiv'Access;
+ when ON_Signed_Type =>
+ Build := BuildSDiv'Access;
+ when others =>
+ null;
+ end case;
+
+ when ON_Mod_Ov
+ | ON_Rem_Ov => -- FIXME...
+ case Left.Etype.Kind is
+ when ON_Unsigned_Type =>
+ Build := BuildURem'Access;
+ when ON_Signed_Type =>
+ if Kind = ON_Rem_Ov then
+ Build := BuildSRem'Access;
+ else
+ Res := New_Smod
+ (Left.LLVM, Right.LLVM, Left.Etype.LLVM);
+ end if;
+ when others =>
+ null;
+ end case;
+
+ when others =>
+ null;
+ end case;
+
+ when ON_Float_Type =>
+ case Kind is
+ when ON_Add_Ov =>
+ Build := BuildFAdd'Access;
+ when ON_Sub_Ov =>
+ Build := BuildFSub'Access;
+ when ON_Mul_Ov =>
+ Build := BuildFMul'Access;
+ when ON_Div_Ov =>
+ Build := BuildFDiv'Access;
+
+ when others =>
+ null;
+ end case;
+
+ when others =>
+ null;
+ end case;
+
+ if Build /= null then
+ pragma Assert (Res = Null_ValueRef);
+ Res := Build.all (Builder, Left.LLVM, Right.LLVM, Empty_Cstring);
+ end if;
+
+ if Res = Null_ValueRef then
+ raise Program_Error with "Unimplemented New_Dyadic_Op "
+ & ON_Dyadic_Op_Kind'Image (Kind)
+ & " for type "
+ & ON_Type_Kind'Image (Left.Etype.Kind);
+ end if;
+
+ Set_Insn_Dbg (Res);
+
+ return O_Enode'(LLVM => Res, Etype => Left.Etype);
+ end New_Dyadic_Op;
+
+ --------------------
+ -- New_Monadic_Op --
+ --------------------
+
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode
+ is
+ Res : ValueRef;
+ begin
+ case Operand.Etype.Kind is
+ when ON_Integer_Types =>
+ case Kind is
+ when ON_Not =>
+ Res := BuildNot (Builder, Operand.LLVM, Empty_Cstring);
+ when ON_Neg_Ov =>
+ Res := BuildNeg (Builder, Operand.LLVM, Empty_Cstring);
+ when ON_Abs_Ov =>
+ -- FIXME: float ?
+ Res := BuildSelect
+ (Builder,
+ BuildICmp (Builder, IntSLT,
+ Operand.LLVM,
+ ConstInt (Get_LLVM_Type (Operand.Etype), 0, 0),
+ Empty_Cstring),
+ BuildNeg (Builder, Operand.LLVM, Empty_Cstring),
+ Operand.LLVM,
+ Empty_Cstring);
+ end case;
+ when ON_Float_Type =>
+ case Kind is
+ when ON_Not =>
+ raise Program_Error;
+ when ON_Neg_Ov =>
+ Res := BuildFNeg (Builder, Operand.LLVM, Empty_Cstring);
+ when ON_Abs_Ov =>
+ Res := BuildSelect
+ (Builder,
+ BuildFCmp (Builder, RealOLT,
+ Operand.LLVM,
+ ConstReal (Get_LLVM_Type (Operand.Etype), 0.0),
+ Empty_Cstring),
+ BuildFNeg (Builder, Operand.LLVM, Empty_Cstring),
+ Operand.LLVM,
+ Empty_Cstring);
+ end case;
+ when others =>
+ raise Program_Error;
+ end case;
+
+ if IsAInstruction (Res) /= Null_ValueRef then
+ Set_Insn_Dbg (Res);
+ end if;
+
+ return O_Enode'(LLVM => Res, Etype => Operand.Etype);
+ end New_Monadic_Op;
+
+ --------------------
+ -- New_Compare_Op --
+ --------------------
+
+ type Compare_Op_Entry is record
+ Signed_Pred : IntPredicate;
+ Unsigned_Pred : IntPredicate;
+ Real_Pred : RealPredicate;
+ end record;
+
+ type Compare_Op_Table_Type is array (ON_Compare_Op_Kind) of
+ Compare_Op_Entry;
+
+ Compare_Op_Table : constant Compare_Op_Table_Type :=
+ (ON_Eq => (IntEQ, IntEQ, RealOEQ),
+ ON_Neq => (IntNE, IntNE, RealONE),
+ ON_Le => (IntSLE, IntULE, RealOLE),
+ ON_Lt => (IntSLT, IntULT, RealOLT),
+ ON_Ge => (IntSGE, IntUGE, RealOGE),
+ ON_Gt => (IntSGT, IntUGT, RealOGT));
+
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind;
+ Left, Right : O_Enode;
+ Ntype : O_Tnode)
+ return O_Enode
+ is
+ Res : ValueRef;
+ begin
+ case Left.Etype.Kind is
+ when ON_Unsigned_Type
+ | ON_Boolean_Type
+ | ON_Enum_Type
+ | ON_Access_Type
+ | ON_Incomplete_Access_Type =>
+ Res := BuildICmp (Builder, Compare_Op_Table (Kind).Unsigned_Pred,
+ Left.LLVM, Right.LLVM, Empty_Cstring);
+ when ON_Signed_Type =>
+ Res := BuildICmp (Builder, Compare_Op_Table (Kind).Signed_Pred,
+ Left.LLVM, Right.LLVM, Empty_Cstring);
+ when ON_Float_Type =>
+ Res := BuildFCmp (Builder, Compare_Op_Table (Kind).Real_Pred,
+ Left.LLVM, Right.LLVM, Empty_Cstring);
+ when ON_Array_Type
+ | ON_Array_Sub_Type
+ | ON_Record_Type
+ | ON_Incomplete_Record_Type
+ | ON_Union_Type
+ | ON_No_Type =>
+ raise Program_Error;
+ end case;
+ Set_Insn_Dbg (Res);
+ return O_Enode'(LLVM => Res, Etype => Ntype);
+ end New_Compare_Op;
+
+ -------------------------
+ -- New_Indexed_Element --
+ -------------------------
+
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) return O_Lnode
+ is
+ Idx : constant ValueRefArray (1 .. 2) :=
+ (ConstInt (Int32Type, 0, 0),
+ Index.LLVM);
+ begin
+ return O_Lnode'
+ (Direct => False,
+ LLVM => BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring),
+ Ltype => Arr.Ltype.Arr_El_Type);
+ end New_Indexed_Element;
+
+ ---------------
+ -- New_Slice --
+ ---------------
+
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode
+ is
+ Idx : constant ValueRefArray (1 .. 2) :=
+ (ConstInt (Int32Type, 0, 0),
+ Index.LLVM);
+ Tmp : ValueRef;
+ begin
+ Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring);
+ Tmp := BuildBitCast
+ (Builder, Tmp, PointerType (Get_LLVM_Type (Res_Type)), Empty_Cstring);
+ return O_Lnode'(Direct => False, LLVM => Tmp, Ltype => Res_Type);
+ end New_Slice;
+
+ --------------------------
+ -- New_Selected_Element --
+ --------------------------
+
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode
+ is
+ Res : ValueRef;
+ begin
+ if Unreach then
+ Res := Null_ValueRef;
+ else
+ declare
+ Idx : constant ValueRefArray (1 .. 2) :=
+ (ConstInt (Int32Type, 0, 0),
+ ConstInt (Int32Type, Unsigned_64 (El.Index), 0));
+ begin
+ Res := BuildGEP (Builder, Rec.LLVM, Idx, 2, Empty_Cstring);
+ end;
+ end if;
+ return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype);
+ end New_Selected_Element;
+
+ ------------------------
+ -- New_Access_Element --
+ ------------------------
+
+ function New_Access_Element (Acc : O_Enode) return O_Lnode
+ is
+ Res : ValueRef;
+ begin
+ case Acc.Etype.Kind is
+ when ON_Access_Type =>
+ Res := Acc.LLVM;
+ when ON_Incomplete_Access_Type =>
+ -- Unwrap the structure
+ declare
+ Idx : constant ValueRefArray (1 .. 2) :=
+ (ConstInt (Int32Type, 0, 0), ConstInt (Int32Type, 0, 0));
+ begin
+ Res := BuildGEP (Builder, Acc.LLVM, Idx, 2, Empty_Cstring);
+ end;
+ when others =>
+ raise Program_Error;
+ end case;
+ return O_Lnode'(Direct => False,
+ LLVM => Res,
+ Ltype => Acc.Etype.Acc_Type);
+ end New_Access_Element;
+
+ --------------------
+ -- New_Convert_Ov --
+ --------------------
+
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode
+ is
+ Res : ValueRef := Null_ValueRef;
+ begin
+ if Rtype = Val.Etype then
+ -- Convertion to itself: nothing to do.
+ return Val;
+ end if;
+ if Rtype.LLVM = Val.Etype.LLVM then
+ -- Same underlying LLVM type: nothing to do.
+ return Val;
+ end if;
+
+ case Rtype.Kind is
+ when ON_Integer_Types =>
+ case Val.Etype.Kind is
+ when ON_Integer_Types =>
+ -- Int to Int
+ if Val.Etype.Scal_Size > Rtype.Scal_Size then
+ -- Truncate
+ Res := BuildTrunc
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ elsif Val.Etype.Scal_Size < Rtype.Scal_Size then
+ if Val.Etype.Kind = ON_Signed_Type then
+ Res := BuildSExt
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ else
+ -- Unsigned, enum
+ Res := BuildZExt
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ end if;
+ else
+ Res := BuildBitCast
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ end if;
+
+ when ON_Float_Type =>
+ -- Float to Int
+ if Rtype.Kind = ON_Signed_Type then
+ Res := BuildFPToSI
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ end if;
+
+ when others =>
+ null;
+ end case;
+
+ when ON_Float_Type =>
+ if Val.Etype.Kind = ON_Signed_Type then
+ Res := BuildSIToFP
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ elsif Val.Etype.Kind = ON_Unsigned_Type then
+ Res := BuildUIToFP
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ end if;
+
+ when ON_Access_Type
+ | ON_Incomplete_Access_Type =>
+ if GetTypeKind (TypeOf (Val.LLVM)) /= PointerTypeKind then
+ raise Program_Error;
+ end if;
+ Res := BuildBitCast (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+
+ when others =>
+ null;
+ end case;
+ if Res /= Null_ValueRef then
+ -- FIXME: only if insn was generated
+ -- Set_Insn_Dbg (Res);
+ return O_Enode'(LLVM => Res, Etype => Rtype);
+ else
+ raise Program_Error with "New_Convert_Ov: not implemented for "
+ & ON_Type_Kind'Image (Val.Etype.Kind)
+ & " -> "
+ & ON_Type_Kind'Image (Rtype.Kind);
+ end if;
+ end New_Convert_Ov;
+
+ -----------------
+ -- New_Address --
+ -----------------
+
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is
+ begin
+ return O_Enode'
+ (LLVM => BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype),
+ Empty_Cstring),
+ Etype => Atype);
+ end New_Address;
+
+ ---------------------------
+ -- New_Unchecked_Address --
+ ---------------------------
+
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode
+ is
+ begin
+ return O_Enode'
+ (LLVM => BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype),
+ Empty_Cstring),
+ Etype => Atype);
+ end New_Unchecked_Address;
+
+ ---------------
+ -- New_Value --
+ ---------------
+
+ function New_Value (Lvalue : O_Lnode) return O_Enode
+ is
+ Res : ValueRef;
+ begin
+ if Unreach then
+ Res := Null_ValueRef;
+ else
+ Res := Lvalue.LLVM;
+ if not Lvalue.Direct then
+ Res := BuildLoad (Builder, Res, Empty_Cstring);
+ Set_Insn_Dbg (Res);
+ end if;
+ end if;
+ return O_Enode'(LLVM => Res, Etype => Lvalue.Ltype);
+ end New_Value;
+
+ -------------------
+ -- New_Obj_Value --
+ -------------------
+
+ function New_Obj_Value (Obj : O_Dnode) return O_Enode is
+ begin
+ return New_Value (New_Obj (Obj));
+ end New_Obj_Value;
+
+ -------------
+ -- New_Obj --
+ -------------
+
+ function New_Obj (Obj : O_Dnode) return O_Lnode is
+ begin
+ case Obj.Kind is
+ when ON_Const_Decl
+ | ON_Var_Decl
+ | ON_Local_Decl =>
+ return O_Lnode'(Direct => False,
+ LLVM => Obj.LLVM,
+ Ltype => Obj.Dtype);
+
+ when ON_Interface_Decl =>
+ if Flag_Debug then
+ -- The argument was allocated.
+ return O_Lnode'(Direct => False,
+ LLVM => Obj.Inter.Ival,
+ Ltype => Obj.Dtype);
+ else
+ return O_Lnode'(Direct => True,
+ LLVM => Obj.Inter.Ival,
+ Ltype => Obj.Dtype);
+ end if;
+
+ when ON_Type_Decl
+ | ON_Completed_Type_Decl
+ | ON_Subprg_Decl
+ | ON_No_Decl =>
+ raise Program_Error;
+ end case;
+ end New_Obj;
+
+ ----------------
+ -- New_Alloca --
+ ----------------
+
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode
+ is
+ Res : ValueRef;
+ begin
+ Res := BuildArrayAlloca (Builder, Int8Type, Size.LLVM, Empty_Cstring);
+ Set_Insn_Dbg (Res);
+ Res := BuildBitCast (Builder, Res, Get_LLVM_Type (Rtype), Empty_Cstring);
+ Set_Insn_Dbg (Res);
+ return O_Enode'(LLVM => Res, Etype => Rtype);
+ end New_Alloca;
+
+ -------------------
+ -- New_Type_Decl --
+ -------------------
+
+ function Add_Dbg_Basic_Type (Id : O_Ident; Btype : O_Tnode; Enc : Natural)
+ return ValueRef
+ is
+ Vals : ValueRefArray (0 .. 9);
+ begin
+ Vals := (ConstInt (Int32Type, DW_TAG_Base_Type, 0),
+ Null_ValueRef,
+ Null_ValueRef,
+ MDString (Id),
+ ConstInt (Int32Type, 0, 0), -- linenum
+ Dbg_Size (Btype.LLVM),
+ Dbg_Align (Btype.LLVM),
+ ConstInt (Int32Type, 0, 0), -- Offset
+ ConstInt (Int32Type, 0, 0), -- Flags
+ ConstInt (Int32Type, Unsigned_64 (Enc), 0)); -- Encoding
+ return MDNode (Vals, Vals'Length);
+ end Add_Dbg_Basic_Type;
+
+ function Add_Dbg_Enum_Type (Id : O_Ident; Etype : O_Tnode) return ValueRef
+ is
+ Vals : ValueRefArray (0 .. 14);
+ begin
+ Vals := (ConstInt (Int32Type, DW_TAG_Enumeration_Type, 0),
+ Dbg_Current_Filedir,
+ Null_ValueRef, -- context
+ MDString (Id),
+ Dbg_Line,
+ Dbg_Size (Etype.LLVM),
+ Dbg_Align (Etype.LLVM),
+ ConstInt (Int32Type, 0, 0), -- Offset
+ ConstInt (Int32Type, 0, 0), -- Flags
+ Null_ValueRef,
+ Get_Value (Enum_Nodes),
+ ConstInt (Int32Type, 0, 0),
+ Null_ValueRef,
+ Null_ValueRef,
+ Null_ValueRef); -- Runtime lang
+ Clear (Enum_Nodes);
+ return MDNode (Vals, Vals'Length);
+ end Add_Dbg_Enum_Type;
+
+ function Add_Dbg_Pointer_Type (Id : O_Ident; Ptype : O_Tnode)
+ return ValueRef
+ is
+ Vals : ValueRefArray (0 .. 9);
+ begin
+ pragma Assert (Ptype.Acc_Type.Dbg /= Null_ValueRef);
+
+ Vals := (ConstInt (Int32Type, DW_TAG_Pointer_Type, 0),
+ Dbg_Current_Filedir,
+ Null_ValueRef, -- context
+ MDString (Id),
+ Dbg_Line,
+ Dbg_Size (Ptype.LLVM),
+ Dbg_Align (Ptype.LLVM),
+ ConstInt (Int32Type, 0, 0), -- Offset
+ ConstInt (Int32Type, 1024, 0), -- Flags
+ Ptype.Acc_Type.Dbg);
+ return MDNode (Vals, Vals'Length);
+ end Add_Dbg_Pointer_Type;
+
+ function Add_Dbg_Record_Type (Id : O_Ident; Rtype : O_Tnode)
+ return ValueRef
+ is
+ Vals : ValueRefArray (0 .. 14);
+ begin
+ Vals := (ConstInt (Int32Type, DW_TAG_Structure_Type, 0),
+ Dbg_Current_Filedir,
+ Null_ValueRef, -- context
+ MDString (Id),
+ Dbg_Line,
+ Null_ValueRef, -- 5: Size
+ Null_ValueRef, -- 6: Align
+ ConstInt (Int32Type, 0, 0), -- Offset
+ ConstInt (Int32Type, 1024, 0), -- Flags
+ Null_ValueRef,
+ Null_ValueRef, -- 10
+ ConstInt (Int32Type, 0, 0), -- Runtime lang
+ Null_ValueRef, -- Vtable Holder
+ Null_ValueRef, -- ?
+ Null_ValueRef); -- Uniq Id
+ if Rtype /= O_Tnode_Null then
+ Vals (5) := Dbg_Size (Rtype.LLVM);
+ Vals (6) := Dbg_Align (Rtype.LLVM);
+ Vals (10) := Rtype.Dbg;
+ end if;
+
+ return MDNode (Vals, Vals'Length);
+ end Add_Dbg_Record_Type;
+
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is
+ begin
+ case Atype.Kind is
+ when ON_Incomplete_Record_Type =>
+ Atype.LLVM :=
+ StructCreateNamed (GetGlobalContext, Get_Cstring (Ident));
+ when ON_Incomplete_Access_Type =>
+ Atype.LLVM := PointerType
+ (StructCreateNamed (GetGlobalContext, Get_Cstring (Ident)));
+ when others =>
+ null;
+ end case;
+
+ -- Emit debug info
+ if Flag_Debug then
+ case Atype.Kind is
+ when ON_Unsigned_Type =>
+ Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_unsigned);
+ when ON_Signed_Type =>
+ Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_signed);
+ when ON_Float_Type =>
+ Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_float);
+ when ON_Enum_Type =>
+ Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype);
+ when ON_Boolean_Type =>
+ Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype);
+ when ON_Access_Type =>
+ Atype.Dbg := Add_Dbg_Pointer_Type (Ident, Atype);
+ when ON_Record_Type =>
+ Atype.Dbg := Add_Dbg_Record_Type (Ident, Atype);
+ when ON_Incomplete_Record_Type =>
+ Atype.Dbg := Add_Dbg_Record_Type (Ident, O_Tnode_Null);
+ when ON_Array_Type
+ | ON_Array_Sub_Type =>
+ -- FIXME: typedef
+ null;
+ when ON_Incomplete_Access_Type =>
+ -- FIXME: todo
+ null;
+ when ON_Union_Type =>
+ -- FIXME: todo
+ null;
+ when ON_No_Type =>
+ raise Program_Error;
+ end case;
+ end if;
+ end New_Type_Decl;
+
+ -----------------------------
+ -- New_Debug_Filename_Decl --
+ -----------------------------
+
+ procedure New_Debug_Filename_Decl (Filename : String) is
+ Vals : ValueRefArray (1 .. 2);
+ begin
+ if Flag_Debug then
+ Vals := (MDString (Filename),
+ MDString (Current_Directory));
+ Dbg_Current_Filedir := MDNode (Vals, 2);
+
+ Vals := (ConstInt (Int32Type, DW_TAG_File_Type, 0),
+ Dbg_Current_Filedir);
+ Dbg_Current_File := MDNode (Vals, 2);
+ end if;
+ end New_Debug_Filename_Decl;
+
+ -------------------------
+ -- New_Debug_Line_Decl --
+ -------------------------
+
+ procedure New_Debug_Line_Decl (Line : Natural) is
+ begin
+ Dbg_Current_Line := unsigned (Line);
+ end New_Debug_Line_Decl;
+
+ ----------------------------
+ -- New_Debug_Comment_Decl --
+ ----------------------------
+
+ procedure New_Debug_Comment_Decl (Comment : String) is
+ begin
+ null;
+ end New_Debug_Comment_Decl;
+
+ --------------------
+ -- New_Const_Decl --
+ --------------------
+
+ procedure Dbg_Add_Global_Var (Id : O_Ident;
+ Atype : O_Tnode;
+ Storage : O_Storage;
+ Decl : O_Dnode)
+ is
+ pragma Assert (Atype.Dbg /= Null_ValueRef);
+ Vals : ValueRefArray (0 .. 12);
+ Name : constant ValueRef := MDString (Id);
+ Is_Local : constant Boolean := Storage = O_Storage_Private;
+ Is_Def : constant Boolean := Storage /= O_Storage_External;
+ begin
+ Vals :=
+ (ConstInt (Int32Type, DW_TAG_Variable, 0),
+ Null_ValueRef,
+ Null_ValueRef, -- context
+ Name,
+ Name,
+ Null_ValueRef, -- linkageName
+ Dbg_Current_File,
+ Dbg_Line,
+ Atype.Dbg,
+ ConstInt (Int1Type, Boolean'Pos (Is_Local), 0), -- isLocal
+ ConstInt (Int1Type, Boolean'Pos (Is_Def), 0), -- isDef
+ Decl.LLVM,
+ Null_ValueRef);
+ Append (Global_Nodes, MDNode (Vals, Vals'Length));
+ end Dbg_Add_Global_Var;
+
+ procedure New_Const_Decl
+ (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode)
+ is
+ Decl : ValueRef;
+ begin
+ if Storage = O_Storage_External then
+ Decl := GetNamedGlobal (Module, Get_Cstring (Ident));
+ else
+ Decl := Null_ValueRef;
+ end if;
+ if Decl = Null_ValueRef then
+ Decl := AddGlobal
+ (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident));
+ end if;
+
+ Res := (Kind => ON_Const_Decl, LLVM => Decl, Dtype => Atype);
+ SetGlobalConstant (Res.LLVM, 1);
+ if Storage = O_Storage_Private then
+ SetLinkage (Res.LLVM, InternalLinkage);
+ end if;
+ if Flag_Debug then
+ Dbg_Add_Global_Var (Ident, Atype, Storage, Res);
+ end if;
+ end New_Const_Decl;
+
+ -----------------------
+ -- Start_Const_Value --
+ -----------------------
+
+ procedure Start_Const_Value (Const : in out O_Dnode) is
+ begin
+ null;
+ end Start_Const_Value;
+
+ ------------------------
+ -- Finish_Const_Value --
+ ------------------------
+
+ procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) is
+ begin
+ SetInitializer (Const.LLVM, Val.LLVM);
+ end Finish_Const_Value;
+
+ ------------------
+ -- New_Var_Decl --
+ ------------------
+
+ procedure New_Var_Decl
+ (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode)
+ is
+ Decl : ValueRef;
+ begin
+ if Storage = O_Storage_Local then
+ Res := (Kind => ON_Local_Decl,
+ LLVM => BuildAlloca
+ (Decl_Builder, Get_LLVM_Type (Atype), Get_Cstring (Ident)),
+ Dtype => Atype);
+ if Flag_Debug then
+ Dbg_Create_Variable (DW_TAG_Auto_Variable,
+ Ident, Atype, 0, Res.LLVM);
+ end if;
+ else
+ if Storage = O_Storage_External then
+ Decl := GetNamedGlobal (Module, Get_Cstring (Ident));
+ else
+ Decl := Null_ValueRef;
+ end if;
+ if Decl = Null_ValueRef then
+ Decl := AddGlobal
+ (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident));
+ end if;
+
+ Res := (Kind => ON_Var_Decl, LLVM => Decl, Dtype => Atype);
+
+ -- Set linkage.
+ case Storage is
+ when O_Storage_Private =>
+ SetLinkage (Res.LLVM, InternalLinkage);
+ when O_Storage_Public
+ | O_Storage_External =>
+ null;
+ when O_Storage_Local =>
+ raise Program_Error;
+ end case;
+
+ -- Set initializer.
+ case Storage is
+ when O_Storage_Private
+ | O_Storage_Public =>
+ SetInitializer (Res.LLVM, ConstNull (Get_LLVM_Type (Atype)));
+ when O_Storage_External =>
+ null;
+ when O_Storage_Local =>
+ raise Program_Error;
+ end case;
+
+ if Flag_Debug then
+ Dbg_Add_Global_Var (Ident, Atype, Storage, Res);
+ end if;
+ end if;
+ end New_Var_Decl;
+
+ -------------------------
+ -- Start_Function_Decl --
+ -------------------------
+
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode)
+ is
+ begin
+ Interfaces := (Ident => Ident,
+ Storage => Storage,
+ Res_Type => Rtype,
+ Nbr_Inter => 0,
+ First_Inter => null,
+ Last_Inter => null);
+ end Start_Function_Decl;
+
+ --------------------------
+ -- Start_Procedure_Decl --
+ --------------------------
+
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage)
+ is
+ begin
+ Interfaces := (Ident => Ident,
+ Storage => Storage,
+ Res_Type => O_Tnode_Null,
+ Nbr_Inter => 0,
+ First_Inter => null,
+ Last_Inter => null);
+ end Start_Procedure_Decl;
+
+ ------------------------
+ -- New_Interface_Decl --
+ ------------------------
+
+ procedure New_Interface_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode;
+ Ident : O_Ident;
+ Atype : O_Tnode)
+ is
+ Inter : constant O_Inter_Acc := new O_Inter'(Itype => Atype,
+ Ival => Null_ValueRef,
+ Ident => Ident,
+ Next => null);
+ begin
+ Res := (Kind => ON_Interface_Decl,
+ Dtype => Atype,
+ LLVM => Null_ValueRef,
+ Inter => Inter);
+ Interfaces.Nbr_Inter := Interfaces.Nbr_Inter + 1;
+ if Interfaces.First_Inter = null then
+ Interfaces.First_Inter := Inter;
+ else
+ Interfaces.Last_Inter.Next := Inter;
+ end if;
+ Interfaces.Last_Inter := Inter;
+ end New_Interface_Decl;
+
+ ----------------------------
+ -- Finish_Subprogram_Decl --
+ ----------------------------
+
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode)
+ is
+ Count : constant unsigned := unsigned (Interfaces.Nbr_Inter);
+ Inter : O_Inter_Acc;
+ Types : TypeRefArray (1 .. Count);
+ Ftype : TypeRef;
+ Rtype : TypeRef;
+ Decl : ValueRef;
+ Id : constant Cstring := Get_Cstring (Interfaces.Ident);
+ begin
+ -- Fill Types (from interfaces list)
+ Inter := Interfaces.First_Inter;
+ for I in 1 .. Count loop
+ Types (I) := Inter.Itype.LLVM;
+ Inter := Inter.Next;
+ end loop;
+
+ -- Build function type.
+ if Interfaces.Res_Type = O_Tnode_Null then
+ Rtype := VoidType;
+ else
+ Rtype := Interfaces.Res_Type.LLVM;
+ end if;
+ Ftype := FunctionType (Rtype, Types, Count, 0);
+
+ if Interfaces.Storage = O_Storage_External then
+ Decl := GetNamedFunction (Module, Id);
+ else
+ Decl := Null_ValueRef;
+ end if;
+ if Decl = Null_ValueRef then
+ Decl := AddFunction (Module, Id, Ftype);
+ end if;
+
+ Res := (Kind => ON_Subprg_Decl,
+ Dtype => Interfaces.Res_Type,
+ Subprg_Id => Interfaces.Ident,
+ Nbr_Args => Count,
+ Subprg_Inters => Interfaces.First_Inter,
+ LLVM => Decl);
+ SetFunctionCallConv (Res.LLVM, CCallConv);
+
+ -- Translate interfaces.
+ Inter := Interfaces.First_Inter;
+ for I in 1 .. Count loop
+ Inter.Ival := GetParam (Res.LLVM, I - 1);
+ SetValueName (Inter.Ival, Get_Cstring (Inter.Ident));
+ Inter := Inter.Next;
+ end loop;
+ end Finish_Subprogram_Decl;
+
+ ---------------------------
+ -- Start_Subprogram_Body --
+ ---------------------------
+
+ procedure Start_Subprogram_Body (Func : O_Dnode)
+ is
+ -- Basic block at function entry that contains all the declarations.
+ Decl_BB : BasicBlockRef;
+ begin
+ if Cur_Func /= Null_ValueRef then
+ -- No support for nested subprograms.
+ raise Program_Error;
+ end if;
+
+ Cur_Func := Func.LLVM;
+ Cur_Func_Decl := Func;
+ Unreach := False;
+
+ Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ PositionBuilderAtEnd (Decl_Builder, Decl_BB);
+
+ Create_Declare_Block;
+
+ PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb);
+
+ if Flag_Debug then
+ declare
+ Type_Vals : ValueRefArray (0 .. Func.Nbr_Args);
+ Vals : ValueRefArray (0 .. 14);
+ Arg : O_Inter_Acc;
+ Subprg_Type : ValueRef;
+
+ Subprg_Vals : ValueRefArray (0 .. 19);
+ Name : ValueRef;
+ begin
+ Arg := Func.Subprg_Inters;
+ if Func.Dtype /= O_Tnode_Null then
+ Type_Vals (0) := Func.Dtype.Dbg;
+ else
+ -- Void
+ Type_Vals (0) := Null_ValueRef;
+ end if;
+ for I in 1 .. Type_Vals'Last loop
+ Type_Vals (I) := Arg.Itype.Dbg;
+ Arg := Arg.Next;
+ end loop;
+ Vals :=
+ (ConstInt (Int32Type, DW_TAG_Subroutine_Type, 0),
+ ConstInt (Int32Type, 0, 0), -- 1 ??
+ Null_ValueRef, -- 2 Context
+ MDString (Empty_Cstring, 0), -- 3 name
+ ConstInt (Int32Type, 0, 0), -- 4 linenum
+ ConstInt (Int64Type, 0, 0), -- 5 size
+ ConstInt (Int64Type, 0, 0), -- 6 align
+ ConstInt (Int64Type, 0, 0), -- 7 offset
+ ConstInt (Int32Type, 0, 0), -- 8 flags
+ Null_ValueRef, -- 9 derived from
+ MDNode (Type_Vals, Type_Vals'Length), -- 10 type
+ ConstInt (Int32Type, 0, 0), -- 11 runtime lang
+ Null_ValueRef, -- 12 containing type
+ Null_ValueRef, -- 13 template params
+ Null_ValueRef); -- 14 ??
+ Subprg_Type := MDNode (Vals, Vals'Length);
+
+ -- Create TAG_subprogram.
+ Name := MDString (Func.Subprg_Id);
+
+ Subprg_Vals :=
+ (ConstInt (Int32Type, DW_TAG_Subprogram, 0),
+ Dbg_Current_Filedir, -- 1 loc
+ Dbg_Current_File, -- 2 context
+ Name, -- 3 name
+ Name, -- 4 display name
+ Null_ValueRef, -- 5 linkage name
+ Dbg_Line, -- 6 line num
+ Subprg_Type, -- 7 type
+ ConstInt (Int1Type, 0, 0), -- 8 islocal (FIXME)
+ ConstInt (Int1Type, 1, 0), -- 9 isdef (FIXME)
+ ConstInt (Int32Type, 0, 0), -- 10 virtuality
+ ConstInt (Int32Type, 0, 0), -- 11 virtual index
+ Null_ValueRef, -- 12 containing type
+ ConstInt (Int32Type, 256, 0), -- 13 flags: prototyped
+ ConstInt (Int1Type, 0, 0), -- 14 isOpt (FIXME)
+ Cur_Func, -- 15 function
+ Null_ValueRef, -- 16 template param
+ Null_ValueRef, -- 17 function decl
+ Null_ValueRef, -- 18 variables ???
+ Dbg_Line); -- 19 scope ln
+ Cur_Declare_Block.Dbg_Scope :=
+ MDNode (Subprg_Vals, Subprg_Vals'Length);
+ Append (Subprg_Nodes, Cur_Declare_Block.Dbg_Scope);
+ Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope;
+ end;
+
+ -- Create local variables for arguments.
+ declare
+ Arg : O_Inter_Acc;
+ Tmp : ValueRef;
+ St : ValueRef;
+ pragma Unreferenced (St);
+ Argno : Natural;
+ begin
+ Arg := Func.Subprg_Inters;
+ Argno := 1;
+ while Arg /= null loop
+ Tmp := BuildAlloca (Decl_Builder, Get_LLVM_Type (Arg.Itype),
+ Empty_Cstring);
+ Dbg_Create_Variable (DW_TAG_Arg_Variable,
+ Arg.Ident, Arg.Itype, Argno, Tmp);
+ St := BuildStore (Decl_Builder, Arg.Ival, Tmp);
+ Arg.Ival := Tmp;
+
+ Arg := Arg.Next;
+ Argno := Argno + 1;
+ end loop;
+ end;
+ end if;
+ end Start_Subprogram_Body;
+
+ ----------------------------
+ -- Finish_Subprogram_Body --
+ ----------------------------
+
+ procedure Finish_Subprogram_Body is
+ Ret : ValueRef;
+ pragma Unreferenced (Ret);
+ begin
+ -- Add a jump from the declare basic block to the first statement BB.
+ Ret := BuildBr (Decl_Builder, Cur_Declare_Block.Stmt_Bb);
+
+ -- Terminate the statement BB.
+ if not Unreach then
+ if Cur_Func_Decl.Dtype = O_Tnode_Null then
+ Ret := BuildRetVoid (Builder);
+ else
+ Ret := BuildUnreachable (Builder);
+ end if;
+ end if;
+
+ Destroy_Declare_Block;
+
+ Cur_Func := Null_ValueRef;
+ Dbg_Current_Scope := Null_ValueRef;
+ end Finish_Subprogram_Body;
+
+ -------------------------
+ -- New_Debug_Line_Stmt --
+ -------------------------
+
+ procedure New_Debug_Line_Stmt (Line : Natural) is
+ begin
+ Dbg_Current_Line := unsigned (Line);
+ end New_Debug_Line_Stmt;
+
+ ----------------------------
+ -- New_Debug_Comment_Stmt --
+ ----------------------------
+
+ procedure New_Debug_Comment_Stmt (Comment : String) is
+ begin
+ null;
+ end New_Debug_Comment_Stmt;
+
+ ------------------------
+ -- Start_Declare_Stmt --
+ ------------------------
+
+ procedure Start_Declare_Stmt
+ is
+ Br : ValueRef;
+ pragma Unreferenced (Br);
+ begin
+ Create_Declare_Block;
+
+ if Unreach then
+ return;
+ end if;
+
+ -- Add a jump to the new BB.
+ Br := BuildBr (Builder, Cur_Declare_Block.Stmt_Bb);
+
+ PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb);
+
+ if Flag_Debug then
+ declare
+ Vals : ValueRefArray (0 .. 5);
+ begin
+ Vals :=
+ (ConstInt (Int32Type, DW_TAG_Lexical_Block, 0),
+ Dbg_Current_Filedir, -- 1 loc
+ Dbg_Current_Scope, -- 2 context
+ Dbg_Line, -- 3 line num
+ ConstInt (Int32Type, 0, 0), -- 4 col
+ ConstInt (Int32Type, Scope_Uniq_Id, 0));
+ Cur_Declare_Block.Dbg_Scope := MDNode (Vals, Vals'Length);
+ Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope;
+ Scope_Uniq_Id := Scope_Uniq_Id + 1;
+ end;
+ end if;
+ end Start_Declare_Stmt;
+
+ -------------------------
+ -- Finish_Declare_Stmt --
+ -------------------------
+
+ procedure Finish_Declare_Stmt
+ is
+ Bb : BasicBlockRef;
+ Br : ValueRef;
+ pragma Unreferenced (Br);
+ begin
+ if not Unreach then
+ -- Create a basic block for the statements after the declare.
+ Bb := AppendBasicBlock (Cur_Func, Empty_Cstring);
+
+ -- Execution will continue on the next statement
+ Br := BuildBr (Builder, Bb);
+
+ PositionBuilderAtEnd (Builder, Bb);
+ end if;
+
+ -- Do not reset Unread.
+
+ Destroy_Declare_Block;
+
+ Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope;
+ end Finish_Declare_Stmt;
+
+ -----------------------
+ -- Start_Association --
+ -----------------------
+
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode)
+ is
+ begin
+ Assocs := (Subprg => Subprg,
+ Idx => 0,
+ Vals => new ValueRefArray (1 .. Subprg.Nbr_Args));
+ end Start_Association;
+
+ ---------------------
+ -- New_Association --
+ ---------------------
+
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is
+ begin
+ Assocs.Idx := Assocs.Idx + 1;
+ Assocs.Vals (Assocs.Idx) := Val.LLVM;
+ end New_Association;
+
+ -----------------------
+ -- New_Function_Call --
+ -----------------------
+
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode
+ is
+ Res : ValueRef;
+ Old_Vals : ValueRefArray_Acc;
+ begin
+ Res := BuildCall (Builder, Assocs.Subprg.LLVM,
+ Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring);
+ Old_Vals := Assocs.Vals;
+ Free (Old_Vals);
+ Set_Insn_Dbg (Res);
+ return O_Enode'(LLVM => Res, Etype => Assocs.Subprg.Dtype);
+ end New_Function_Call;
+
+ ------------------------
+ -- New_Procedure_Call --
+ ------------------------
+
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List)
+ is
+ Res : ValueRef;
+ begin
+ if not Unreach then
+ Res := BuildCall (Builder, Assocs.Subprg.LLVM,
+ Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring);
+ Set_Insn_Dbg (Res);
+ end if;
+ Free (Assocs.Vals);
+ end New_Procedure_Call;
+
+ ---------------------
+ -- New_Assign_Stmt --
+ ---------------------
+
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode)
+ is
+ Res : ValueRef;
+ begin
+ if Target.Direct then
+ raise Program_Error;
+ end if;
+ if not Unreach then
+ Res := BuildStore (Builder, Value.LLVM, Target.LLVM);
+ Set_Insn_Dbg (Res);
+ end if;
+ end New_Assign_Stmt;
+
+ ---------------------
+ -- New_Return_Stmt --
+ ---------------------
+
+ procedure New_Return_Stmt (Value : O_Enode) is
+ Res : ValueRef;
+ begin
+ if Unreach then
+ return;
+ end if;
+ Res := BuildRet (Builder, Value.LLVM);
+ Set_Insn_Dbg (Res);
+ Unreach := True;
+ end New_Return_Stmt;
+
+ ---------------------
+ -- New_Return_Stmt --
+ ---------------------
+
+ procedure New_Return_Stmt is
+ Res : ValueRef;
+ begin
+ if Unreach then
+ return;
+ end if;
+ Res := BuildRetVoid (Builder);
+ Set_Insn_Dbg (Res);
+ Unreach := True;
+ end New_Return_Stmt;
+
+ -------------------
+ -- Start_If_Stmt --
+ -------------------
+
+ procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is
+ Res : ValueRef;
+ Bb_Then : BasicBlockRef;
+ begin
+ -- FIXME: check Unreach
+ Bb_Then := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ Block := (Bb => AppendBasicBlock (Cur_Func, Empty_Cstring));
+ Res := BuildCondBr (Builder, Cond.LLVM, Bb_Then, Block.Bb);
+ Set_Insn_Dbg (Res);
+
+ PositionBuilderAtEnd (Builder, Bb_Then);
+ end Start_If_Stmt;
+
+ -------------------
+ -- New_Else_Stmt --
+ -------------------
+
+ procedure New_Else_Stmt (Block : in out O_If_Block) is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ Bb_Next : BasicBlockRef;
+ begin
+ if not Unreach then
+ Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ Res := BuildBr (Builder, Bb_Next);
+ else
+ Bb_Next := Null_BasicBlockRef;
+ end if;
+
+ PositionBuilderAtEnd (Builder, Block.Bb);
+
+ Block := (Bb => Bb_Next);
+ Unreach := False;
+ end New_Else_Stmt;
+
+ --------------------
+ -- Finish_If_Stmt --
+ --------------------
+
+ procedure Finish_If_Stmt (Block : in out O_If_Block) is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ Bb_Next : BasicBlockRef;
+ begin
+ if not Unreach then
+ -- The branch can continue.
+ if Block.Bb = Null_BasicBlockRef then
+ Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ else
+ Bb_Next := Block.Bb;
+ end if;
+ Res := BuildBr (Builder, Bb_Next);
+ PositionBuilderAtEnd (Builder, Bb_Next);
+ else
+ -- The branch doesn't continue.
+ if Block.Bb /= Null_BasicBlockRef then
+ -- There is a fall-through (either from the then branch, or
+ -- there is no else).
+ Unreach := False;
+ PositionBuilderAtEnd (Builder, Block.Bb);
+ else
+ Unreach := True;
+ end if;
+ end if;
+ end Finish_If_Stmt;
+
+ ---------------------
+ -- Start_Loop_Stmt --
+ ---------------------
+
+ procedure Start_Loop_Stmt (Label : out O_Snode)
+ is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ begin
+ -- FIXME: check Unreach
+ Label := (Bb_Entry => AppendBasicBlock (Cur_Func, Empty_Cstring),
+ Bb_Exit => AppendBasicBlock (Cur_Func, Empty_Cstring));
+ Res := BuildBr (Builder, Label.Bb_Entry);
+ PositionBuilderAtEnd (Builder, Label.Bb_Entry);
+ end Start_Loop_Stmt;
+
+ ----------------------
+ -- Finish_Loop_Stmt --
+ ----------------------
+
+ procedure Finish_Loop_Stmt (Label : in out O_Snode) is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ begin
+ if not Unreach then
+ Res := BuildBr (Builder, Label.Bb_Entry);
+ end if;
+ if Label.Bb_Exit /= Null_BasicBlockRef then
+ -- FIXME: always true...
+ PositionBuilderAtEnd (Builder, Label.Bb_Exit);
+ Unreach := False;
+ else
+ Unreach := True;
+ end if;
+ end Finish_Loop_Stmt;
+
+ -------------------
+ -- New_Exit_Stmt --
+ -------------------
+
+ procedure New_Exit_Stmt (L : O_Snode) is
+ Res : ValueRef;
+ begin
+ if not Unreach then
+ Res := BuildBr (Builder, L.Bb_Exit);
+ Set_Insn_Dbg (Res);
+ Unreach := True;
+ end if;
+ end New_Exit_Stmt;
+
+ -------------------
+ -- New_Next_Stmt --
+ -------------------
+
+ procedure New_Next_Stmt (L : O_Snode) is
+ Res : ValueRef;
+ begin
+ if not Unreach then
+ Res := BuildBr (Builder, L.Bb_Entry);
+ Set_Insn_Dbg (Res);
+ Unreach := True;
+ end if;
+ end New_Next_Stmt;
+
+ ---------------------
+ -- Start_Case_Stmt --
+ ---------------------
+
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is
+ begin
+ Block := (BB_Prev => GetInsertBlock (Builder),
+ Value => Value.LLVM,
+ Vtype => Value.Etype,
+ BB_Next => Null_BasicBlockRef,
+ BB_Others => Null_BasicBlockRef,
+ BB_Choice => Null_BasicBlockRef,
+ Nbr_Choices => 0,
+ Choices => new O_Choice_Array (1 .. 8));
+ end Start_Case_Stmt;
+
+ ------------------
+ -- Start_Choice --
+ ------------------
+
+ procedure Finish_Branch (Block : in out O_Case_Block) is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ begin
+ -- Close previous branch.
+ if not Unreach then
+ if Block.BB_Next = Null_BasicBlockRef then
+ Block.BB_Next := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ end if;
+ Res := BuildBr (Builder, Block.BB_Next);
+ end if;
+ end Finish_Branch;
+
+ procedure Start_Choice (Block : in out O_Case_Block) is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ begin
+ if Block.BB_Choice /= Null_BasicBlockRef then
+ -- Close previous branch.
+ Finish_Branch (Block);
+ end if;
+
+ Unreach := False;
+ Block.BB_Choice := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ PositionBuilderAtEnd (Builder, Block.BB_Choice);
+ end Start_Choice;
+
+ ---------------------
+ -- New_Expr_Choice --
+ ---------------------
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (O_Choice_Array, O_Choice_Array_Acc);
+
+ procedure New_Choice (Block : in out O_Case_Block;
+ Low, High : ValueRef)
+ is
+ Choices : O_Choice_Array_Acc;
+ begin
+ if Block.Nbr_Choices = Block.Choices'Last then
+ Choices := new O_Choice_Array (1 .. Block.Choices'Last * 2);
+ Choices (1 .. Block.Choices'Last) := Block.Choices.all;
+ Free (Block.Choices);
+ Block.Choices := Choices;
+ end if;
+ Block.Nbr_Choices := Block.Nbr_Choices + 1;
+ Block.Choices (Block.Nbr_Choices) := (Low => Low,
+ High => High,
+ Bb => Block.BB_Choice);
+ end New_Choice;
+
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is
+ begin
+ New_Choice (Block, Expr.LLVM, Null_ValueRef);
+ end New_Expr_Choice;
+
+ ----------------------
+ -- New_Range_Choice --
+ ----------------------
+
+ procedure New_Range_Choice
+ (Block : in out O_Case_Block; Low, High : O_Cnode)
+ is
+ begin
+ New_Choice (Block, Low.LLVM, High.LLVM);
+ end New_Range_Choice;
+
+ ------------------------
+ -- New_Default_Choice --
+ ------------------------
+
+ procedure New_Default_Choice (Block : in out O_Case_Block) is
+ begin
+ Block.BB_Others := Block.BB_Choice;
+ end New_Default_Choice;
+
+ -------------------
+ -- Finish_Choice --
+ -------------------
+
+ procedure Finish_Choice (Block : in out O_Case_Block) is
+ begin
+ null;
+ end Finish_Choice;
+
+ ----------------------
+ -- Finish_Case_Stmt --
+ ----------------------
+
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block)
+ is
+ Bb_Default : constant BasicBlockRef :=
+ AppendBasicBlock (Cur_Func, Empty_Cstring);
+ Bb_Default_Last : BasicBlockRef;
+ Nbr_Cases : unsigned := 0;
+ GE, LE : IntPredicate;
+ Res : ValueRef;
+ begin
+ if Block.BB_Choice /= Null_BasicBlockRef then
+ -- Close previous branch.
+ Finish_Branch (Block);
+ end if;
+
+ -- Strategy: use a switch instruction for simple choices, put range
+ -- choices in the default using if statements.
+ case Block.Vtype.Kind is
+ when ON_Unsigned_Type
+ | ON_Enum_Type
+ | ON_Boolean_Type =>
+ GE := IntUGE;
+ LE := IntULE;
+ when ON_Signed_Type =>
+ GE := IntSGE;
+ LE := IntSLE;
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- BB for the default case of the LLVM switch.
+ PositionBuilderAtEnd (Builder, Bb_Default);
+ Bb_Default_Last := Bb_Default;
+
+ for I in 1 .. Block.Nbr_Choices loop
+ declare
+ C : O_Choice_Type renames Block.Choices (I);
+ begin
+ if C.High /= Null_ValueRef then
+ Bb_Default_Last := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ Res := BuildCondBr (Builder,
+ BuildAnd (Builder,
+ BuildICmp (Builder, GE,
+ Block.Value, C.Low,
+ Empty_Cstring),
+ BuildICmp (Builder, LE,
+ Block.Value, C.High,
+ Empty_Cstring),
+ Empty_Cstring),
+ C.Bb, Bb_Default_Last);
+ PositionBuilderAtEnd (Builder, Bb_Default_Last);
+ else
+ Nbr_Cases := Nbr_Cases + 1;
+ end if;
+ end;
+ end loop;
+
+ -- Insert the switch
+ PositionBuilderAtEnd (Builder, Block.BB_Prev);
+ Res := BuildSwitch (Builder, Block.Value, Bb_Default, Nbr_Cases);
+ for I in 1 .. Block.Nbr_Choices loop
+ declare
+ C : O_Choice_Type renames Block.Choices (I);
+ begin
+ if C.High = Null_ValueRef then
+ AddCase (Res, C.Low, C.Bb);
+ end if;
+ end;
+ end loop;
+
+ -- Insert the others.
+ PositionBuilderAtEnd (Builder, Bb_Default_Last);
+ if Block.BB_Others /= Null_BasicBlockRef then
+ Res := BuildBr (Builder, Block.BB_Others);
+ else
+ Res := BuildUnreachable (Builder);
+ end if;
+
+ if Block.BB_Next /= Null_BasicBlockRef then
+ Unreach := False;
+ PositionBuilderAtEnd (Builder, Block.BB_Next);
+ else
+ Unreach := True;
+ end if;
+
+ Free (Block.Choices);
+ end Finish_Case_Stmt;
+
+ function Get_LLVM_Type (Atype : O_Tnode) return TypeRef is
+ begin
+ case Atype.Kind is
+ when ON_Incomplete_Record_Type
+ | ON_Incomplete_Access_Type =>
+ if Atype.LLVM = Null_TypeRef then
+ raise Program_Error with "early use of incomplete type";
+ end if;
+ return Atype.LLVM;
+ when ON_Union_Type
+ | ON_Scalar_Types
+ | ON_Access_Type
+ | ON_Array_Type
+ | ON_Array_Sub_Type
+ | ON_Record_Type =>
+ return Atype.LLVM;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Get_LLVM_Type;
+
+ procedure Finish_Debug is
+ begin
+ declare
+ Dbg_Cu : constant String := "llvm.dbg.cu" & ASCII.NUL;
+ Producer : constant String := "ortho llvm";
+ Vals : ValueRefArray (0 .. 12);
+ begin
+ Vals :=
+ (ConstInt (Int32Type, DW_TAG_Compile_Unit, 0),
+ Dbg_Current_Filedir, -- 1 file+dir
+ ConstInt (Int32Type, 1, 0), -- 2 language (C)
+ MDString (Producer), -- 3 producer
+ ConstInt (Int1Type, 0, 0), -- 4 isOpt
+ MDString (""), -- 5 flags
+ ConstInt (Int32Type, 0, 0), -- 6 runtime version
+ Null_ValueRef, -- 7 enum types
+ Null_ValueRef, -- 8 retained types
+ Get_Value (Subprg_Nodes), -- 9 subprograms
+ Get_Value (Global_Nodes), -- 10 global var
+ Null_ValueRef, -- 11 imported entities
+ Null_ValueRef); -- 12 split debug
+
+ AddNamedMetadataOperand
+ (Module, Dbg_Cu'Address, MDNode (Vals, Vals'Length));
+ end;
+
+ declare
+ Module_Flags : constant String := "llvm.module.flags" & ASCII.NUL;
+ Flags1 : ValueRefArray (0 .. 2);
+ Flags2 : ValueRefArray (0 .. 2);
+ begin
+ Flags1 := (ConstInt (Int32Type, 1, 0),
+ MDString ("Debug Info Version"),
+ ConstInt (Int32Type, 1, 0));
+ AddNamedMetadataOperand
+ (Module, Module_Flags'Address, MDNode (Flags1, Flags1'Length));
+ Flags2 := (ConstInt (Int32Type, 2, 0),
+ MDString ("Dwarf Version"),
+ ConstInt (Int32Type, 2, 0));
+ AddNamedMetadataOperand
+ (Module, Module_Flags'Address, MDNode (Flags2, Flags2'Length));
+ end;
+ end Finish_Debug;
+end Ortho_LLVM;
diff --git a/ortho/llvm/ortho_llvm.ads b/ortho/llvm/ortho_llvm.ads
new file mode 100644
index 000000000..070bec6d6
--- /dev/null
+++ b/ortho/llvm/ortho_llvm.ads
@@ -0,0 +1,724 @@
+-- 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;
+
+-- Interface to create nodes.
+package Ortho_LLVM is
+ --- PUBLIC DECLARATIONS
+ type O_Enode is private;
+ O_Enode_Null : constant O_Enode;
+ type O_Cnode is private;
+ O_Cnode_Null : constant O_Cnode;
+ type O_Lnode is private;
+ O_Lnode_Null : constant O_Lnode;
+ -- A node for a type.
+ type O_Tnode is private;
+ O_Tnode_Null : constant O_Tnode;
+ -- A node for a statement.
+ type O_Snode is private;
+ O_Snode_Null : constant O_Snode;
+ -- A node for a function.
+ type O_Dnode is private;
+ O_Dnode_Null : constant O_Dnode;
+ -- A node for a record element.
+ type O_Fnode is private;
+ O_Fnode_Null : constant O_Fnode;
+
+ procedure Finish_Debug;
+
+ ------------------------
+ -- Type definitions --
+ ------------------------
+
+ type O_Element_List is limited private;
+
+ -- Build a record type.
+ procedure Start_Record_Type (Elements : out O_Element_List);
+ -- Add a field in the record; not constrained array are prohibited, since
+ -- its size is unlimited.
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident; Etype : O_Tnode);
+ -- Finish the record type.
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Build an uncomplete record type:
+ -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type.
+ -- This type can be declared or used to define access types on it.
+ -- Then, complete (if necessary) the record type, by calling
+ -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE.
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode);
+ procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
+ Elements : out O_Element_List);
+
+ -- Build an union type.
+ procedure Start_Union_Type (Elements : out O_Element_List);
+ procedure New_Union_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode);
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Build an access type.
+ -- DTYPE may be O_tnode_null in order to build an incomplete access type.
+ -- It is completed with finish_access_type.
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode;
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode);
+
+ -- Build an array type.
+ -- The array is not constrained and unidimensional.
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode;
+
+ -- Build a constrained array type.
+ function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
+ return O_Tnode;
+
+ -- Build a scalar type; size may be 8, 16, 32 or 64.
+ function New_Unsigned_Type (Size : Natural) return O_Tnode;
+ function New_Signed_Type (Size : Natural) return O_Tnode;
+
+ -- Build a float type.
+ function New_Float_Type return O_Tnode;
+
+ -- Build a 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);
+
+ -- Create an enumeration
+ type O_Enum_List is limited private;
+
+ -- Elements are declared in order, the first is ordered from 0.
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural);
+ procedure New_Enum_Literal (List : in out O_Enum_List;
+ Ident : O_Ident; Res : out O_Cnode);
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode);
+
+ ----------------
+ -- Literals --
+ ----------------
+
+ -- Create a literal from an integer.
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode;
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode;
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode;
+
+ -- Create a null access literal.
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode;
+
+ -- Build a record/array aggregate.
+ -- The aggregate is constant, and therefore can be only used to initialize
+ -- constant declaration.
+ -- ATYPE must be either a record type or an array subtype.
+ -- Elements must be added in the order, and must be literals or aggregates.
+ type O_Record_Aggr_List is limited private;
+ type O_Array_Aggr_List is limited private;
+
+ procedure Start_Record_Aggr (List : out O_Record_Aggr_List;
+ Atype : O_Tnode);
+ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List;
+ Res : out O_Cnode);
+
+ procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode);
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List;
+ Res : out O_Cnode);
+
+ -- Build an union aggregate.
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode;
+
+ -- Returns the size in bytes of ATYPE. The result is a literal of
+ -- unsigned type RTYPE
+ -- ATYPE cannot be an unconstrained array type.
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the alignment in bytes for ATYPE. The result is a literal of
+ -- unsgined type RTYPE.
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the offset of FIELD in record ATYPE. The result is a literal
+ -- of unsigned type RTYPE.
+ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode;
+
+ -- Get the address of a subprogram.
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- Get the address of LVALUE.
+ -- ATYPE must be a type access whose designated type is the type of LVALUE.
+ -- FIXME: what about arrays.
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -------------------
+ -- Expressions --
+ -------------------
+
+ type ON_Op_Kind is
+ (
+ -- Not an operation; invalid.
+ ON_Nil,
+
+ -- Dyadic operations.
+ ON_Add_Ov, -- ON_Dyadic_Op_Kind
+ ON_Sub_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mul_Ov, -- ON_Dyadic_Op_Kind
+ ON_Div_Ov, -- ON_Dyadic_Op_Kind
+ ON_Rem_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mod_Ov, -- ON_Dyadic_Op_Kind
+
+ -- Binary operations.
+ ON_And, -- ON_Dyadic_Op_Kind
+ ON_Or, -- ON_Dyadic_Op_Kind
+ ON_Xor, -- ON_Dyadic_Op_Kind
+ ON_And_Then, -- ON_Dyadic_Op_Kind
+ ON_Or_Else, -- ON_Dyadic_Op_Kind
+
+ -- Monadic operations.
+ ON_Not, -- ON_Monadic_Op_Kind
+ ON_Neg_Ov, -- ON_Monadic_Op_Kind
+ ON_Abs_Ov, -- ON_Monadic_Op_Kind
+
+ -- Comparaisons
+ ON_Eq, -- ON_Compare_Op_Kind
+ ON_Neq, -- ON_Compare_Op_Kind
+ ON_Le, -- ON_Compare_Op_Kind
+ ON_Lt, -- ON_Compare_Op_Kind
+ ON_Ge, -- ON_Compare_Op_Kind
+ ON_Gt -- ON_Compare_Op_Kind
+ );
+
+ subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Or_Else;
+ subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov;
+ subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt;
+
+ type O_Storage is (O_Storage_External,
+ O_Storage_Public,
+ O_Storage_Private,
+ O_Storage_Local);
+ -- Specifies the storage kind of a declaration.
+ -- O_STORAGE_EXTERNAL:
+ -- The declaration do not either reserve memory nor generate code, and
+ -- is imported either from an other file or from a later place in the
+ -- current file.
+ -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE:
+ -- The declaration reserves memory or generates code.
+ -- With O_STORAGE_PUBLIC, the declaration is exported outside of the
+ -- file while with O_STORAGE_PRIVATE, the declaration is local to the
+ -- file.
+
+ Type_Error : exception;
+ Syntax_Error : exception;
+
+ -- Create a value from a literal.
+ function New_Lit (Lit : O_Cnode) return O_Enode;
+
+ -- Create a dyadic operation.
+ -- Left and right nodes must have the same type.
+ -- Binary operation is allowed only on boolean types.
+ -- The result is of the type of the operands.
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode;
+
+ -- Create a monadic operation.
+ -- Result is of the type of operand.
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode;
+
+ -- Create a comparaison operator.
+ -- NTYPE is the type of the result and must be a boolean type.
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
+ return O_Enode;
+
+
+ type O_Inter_List is limited private;
+ type O_Assoc_List is limited private;
+ type O_If_Block is limited private;
+ type O_Case_Block is limited private;
+
+
+ -- Get an element of an array.
+ -- INDEX must be of the type of the array index.
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get a slice of an array; this is equivalent to a conversion between
+ -- an array or an array subtype and an array subtype.
+ -- RES_TYPE must be an array_sub_type whose base type is the same as the
+ -- base type of ARR.
+ -- INDEX must be of the type of the array index.
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get an element of a record.
+ -- Type of REC must be a record type.
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode;
+
+ -- Reference an access.
+ -- Type of ACC must be an access type.
+ function New_Access_Element (Acc : O_Enode) return O_Lnode;
+
+ -- Do a conversion.
+ -- Allowed conversions are:
+ -- FIXME: to write.
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode;
+
+ -- Get the address of LVALUE.
+ -- ATYPE must be a type access whose designated type is the type of LVALUE.
+ -- FIXME: what about arrays.
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode;
+
+ -- Get the value of an Lvalue.
+ function New_Value (Lvalue : O_Lnode) return O_Enode;
+ function New_Obj_Value (Obj : O_Dnode) return O_Enode;
+
+ -- Get an lvalue from a declaration.
+ function New_Obj (Obj : O_Dnode) return O_Lnode;
+
+ -- Return a pointer of type RTPE to SIZE bytes allocated on the stack.
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
+
+ -- Declare a type.
+ -- This simply gives a name to a type.
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode);
+
+ ---------------------
+ -- Declarations. --
+ ---------------------
+
+ -- Filename of the next declaration.
+ procedure New_Debug_Filename_Decl (Filename : String);
+
+ -- Line number of the next declaration.
+ procedure New_Debug_Line_Decl (Line : Natural);
+
+ -- Add a comment in the declarative region.
+ procedure New_Debug_Comment_Decl (Comment : String);
+
+ -- Declare a constant.
+ -- This simply gives a name to a constant value or aggregate.
+ -- A constant cannot be modified and its storage cannot be local.
+ -- ATYPE must be constrained.
+ procedure New_Const_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ -- Set the value of a non-external constant.
+ procedure Start_Const_Value (Const : in out O_Dnode);
+ procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode);
+
+ -- Create a variable declaration.
+ -- A variable can be local only inside a function.
+ -- ATYPE must be constrained.
+ procedure New_Var_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ -- Start a subprogram declaration.
+ -- Note: nested subprograms are allowed, ie o_storage_local subprograms can
+ -- be declared inside a subprograms. It is not allowed to declare
+ -- o_storage_external subprograms inside a subprograms.
+ -- Return type and interfaces cannot be a composite type.
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode);
+ -- For a subprogram without return value.
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage);
+
+ -- Add an interface declaration to INTERFACES.
+ procedure New_Interface_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode;
+ Ident : O_Ident;
+ Atype : O_Tnode);
+ -- Finish the function declaration, get the node and a statement list.
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List; Res : out O_Dnode);
+ -- Start a subprogram body.
+ -- Note: the declaration may have an external storage, in this case it
+ -- becomes public.
+ procedure Start_Subprogram_Body (Func : O_Dnode);
+ -- Finish a subprogram body.
+ procedure Finish_Subprogram_Body;
+
+
+ -------------------
+ -- Statements. --
+ -------------------
+
+ -- Add a line number as a statement.
+ procedure New_Debug_Line_Stmt (Line : Natural);
+
+ -- Add a comment as a statement.
+ procedure New_Debug_Comment_Stmt (Comment : String);
+
+ -- Start a declarative region.
+ procedure Start_Declare_Stmt;
+ procedure Finish_Declare_Stmt;
+
+ -- Create a function call or a procedure call.
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode);
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode);
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode;
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List);
+
+ -- Assign VALUE to TARGET, type must be the same or compatible.
+ -- FIXME: what about slice assignment?
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode);
+
+ -- Exit from the subprogram and return VALUE.
+ procedure New_Return_Stmt (Value : O_Enode);
+ -- Exit from the subprogram, which doesn't return value.
+ procedure New_Return_Stmt;
+
+ -- Build an IF statement.
+ procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode);
+ procedure New_Else_Stmt (Block : in out O_If_Block);
+ procedure Finish_If_Stmt (Block : in out O_If_Block);
+
+ -- Create a infinite loop statement.
+ procedure Start_Loop_Stmt (Label : out O_Snode);
+ procedure Finish_Loop_Stmt (Label : in out O_Snode);
+
+ -- Exit from a loop stmt or from a for stmt.
+ procedure New_Exit_Stmt (L : O_Snode);
+ -- Go to the start of a loop stmt or of a for stmt.
+ -- Loops/Fors between L and the current points are exited.
+ procedure New_Next_Stmt (L : O_Snode);
+
+ -- Case statement.
+ -- VALUE is the selector and must be a discrete type.
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode);
+ -- A choice branch is composed of expr, range or default choices.
+ -- A choice branch is enclosed between a Start_Choice and a Finish_Choice.
+ -- The statements are after the finish_choice.
+ procedure Start_Choice (Block : in out O_Case_Block);
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode);
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode);
+ procedure New_Default_Choice (Block : in out O_Case_Block);
+ procedure Finish_Choice (Block : in out O_Case_Block);
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block);
+
+private
+ use LLVM.Core;
+
+ 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
+ Ftype : O_Tnode;
+ case Kind is
+ when OF_None =>
+ null;
+ when OF_Record =>
+ Index : Natural;
+ when OF_Union =>
+ Utype : 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
+ 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;
+
+ -- Builder for statements.
+ Builder : BuilderRef;
+
+ -- Builder for declarations (local variables).
+ Decl_Builder : BuilderRef;
+
+ Llvm_Dbg_Declare : ValueRef;
+end Ortho_LLVM;
diff --git a/ortho/llvm/ortho_nodes.ads b/ortho/llvm/ortho_nodes.ads
new file mode 100644
index 000000000..34d1dbbc9
--- /dev/null
+++ b/ortho/llvm/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-06 16:54:34 +0000