From 9ae489208b280545dd0f1b2479645204b2bb86a7 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Thu, 16 May 2019 06:28:55 +0200 Subject: ortho: move llvm to llvm35 --- configure | 2 +- src/ortho/llvm/Makefile | 32 - src/ortho/llvm/llvm-analysis.ads | 53 - src/ortho/llvm/llvm-bitwriter.ads | 34 - src/ortho/llvm/llvm-cbindings.cpp | 61 - src/ortho/llvm/llvm-core.ads | 1283 ----------- src/ortho/llvm/llvm-executionengine.ads | 163 -- src/ortho/llvm/llvm-target.ads | 84 - src/ortho/llvm/llvm-targetmachine.ads | 122 -- src/ortho/llvm/llvm-transforms-scalar.ads | 169 -- src/ortho/llvm/llvm-transforms.ads | 21 - src/ortho/llvm/llvm.ads | 21 - src/ortho/llvm/ortho_code_main.adb | 395 ---- src/ortho/llvm/ortho_ident.adb | 134 -- src/ortho/llvm/ortho_ident.ads | 42 - src/ortho/llvm/ortho_jit.adb | 151 -- src/ortho/llvm/ortho_llvm-jit.adb | 55 - src/ortho/llvm/ortho_llvm-jit.ads | 31 - src/ortho/llvm/ortho_llvm.adb | 3096 --------------------------- src/ortho/llvm/ortho_llvm.ads | 765 ------- src/ortho/llvm/ortho_llvm.private.ads | 321 --- src/ortho/llvm/ortho_nodes.ads | 20 - src/ortho/llvm35/Makefile | 32 + src/ortho/llvm35/llvm-analysis.ads | 53 + src/ortho/llvm35/llvm-bitwriter.ads | 34 + src/ortho/llvm35/llvm-cbindings.cpp | 61 + src/ortho/llvm35/llvm-core.ads | 1283 +++++++++++ src/ortho/llvm35/llvm-executionengine.ads | 163 ++ src/ortho/llvm35/llvm-target.ads | 84 + src/ortho/llvm35/llvm-targetmachine.ads | 122 ++ src/ortho/llvm35/llvm-transforms-scalar.ads | 169 ++ src/ortho/llvm35/llvm-transforms.ads | 21 + src/ortho/llvm35/llvm.ads | 21 + src/ortho/llvm35/ortho_code_main.adb | 395 ++++ src/ortho/llvm35/ortho_ident.adb | 134 ++ src/ortho/llvm35/ortho_ident.ads | 42 + src/ortho/llvm35/ortho_jit.adb | 151 ++ src/ortho/llvm35/ortho_llvm-jit.adb | 55 + src/ortho/llvm35/ortho_llvm-jit.ads | 31 + src/ortho/llvm35/ortho_llvm.adb | 3096 +++++++++++++++++++++++++++ src/ortho/llvm35/ortho_llvm.ads | 765 +++++++ src/ortho/llvm35/ortho_llvm.private.ads | 321 +++ src/ortho/llvm35/ortho_nodes.ads | 20 + 43 files changed, 7054 insertions(+), 7054 deletions(-) delete mode 100644 src/ortho/llvm/Makefile delete mode 100644 src/ortho/llvm/llvm-analysis.ads delete mode 100644 src/ortho/llvm/llvm-bitwriter.ads delete mode 100644 src/ortho/llvm/llvm-cbindings.cpp delete mode 100644 src/ortho/llvm/llvm-core.ads delete mode 100644 src/ortho/llvm/llvm-executionengine.ads delete mode 100644 src/ortho/llvm/llvm-target.ads delete mode 100644 src/ortho/llvm/llvm-targetmachine.ads delete mode 100644 src/ortho/llvm/llvm-transforms-scalar.ads delete mode 100644 src/ortho/llvm/llvm-transforms.ads delete mode 100644 src/ortho/llvm/llvm.ads delete mode 100644 src/ortho/llvm/ortho_code_main.adb delete mode 100644 src/ortho/llvm/ortho_ident.adb delete mode 100644 src/ortho/llvm/ortho_ident.ads delete mode 100644 src/ortho/llvm/ortho_jit.adb delete mode 100644 src/ortho/llvm/ortho_llvm-jit.adb delete mode 100644 src/ortho/llvm/ortho_llvm-jit.ads delete mode 100644 src/ortho/llvm/ortho_llvm.adb delete mode 100644 src/ortho/llvm/ortho_llvm.ads delete mode 100644 src/ortho/llvm/ortho_llvm.private.ads delete mode 100644 src/ortho/llvm/ortho_nodes.ads create mode 100644 src/ortho/llvm35/Makefile create mode 100644 src/ortho/llvm35/llvm-analysis.ads create mode 100644 src/ortho/llvm35/llvm-bitwriter.ads create mode 100644 src/ortho/llvm35/llvm-cbindings.cpp create mode 100644 src/ortho/llvm35/llvm-core.ads create mode 100644 src/ortho/llvm35/llvm-executionengine.ads create mode 100644 src/ortho/llvm35/llvm-target.ads create mode 100644 src/ortho/llvm35/llvm-targetmachine.ads create mode 100644 src/ortho/llvm35/llvm-transforms-scalar.ads create mode 100644 src/ortho/llvm35/llvm-transforms.ads create mode 100644 src/ortho/llvm35/llvm.ads create mode 100644 src/ortho/llvm35/ortho_code_main.adb create mode 100644 src/ortho/llvm35/ortho_ident.adb create mode 100644 src/ortho/llvm35/ortho_ident.ads create mode 100644 src/ortho/llvm35/ortho_jit.adb create mode 100644 src/ortho/llvm35/ortho_llvm-jit.adb create mode 100644 src/ortho/llvm35/ortho_llvm-jit.ads create mode 100644 src/ortho/llvm35/ortho_llvm.adb create mode 100644 src/ortho/llvm35/ortho_llvm.ads create mode 100644 src/ortho/llvm35/ortho_llvm.private.ads create mode 100644 src/ortho/llvm35/ortho_nodes.ads diff --git a/configure b/configure index a8484acec..099528b6a 100755 --- a/configure +++ b/configure @@ -239,7 +239,7 @@ if test $backend = llvm; then exit 1 fi if check_version 3.5 $llvm_version; then - llvm_be=llvm + llvm_be=llvm35 elif check_version 3.6 $llvm_version || check_version 3.7 $llvm_version || check_version 3.8 $llvm_version || diff --git a/src/ortho/llvm/Makefile b/src/ortho/llvm/Makefile deleted file mode 100644 index e1940c7a3..000000000 --- a/src/ortho/llvm/Makefile +++ /dev/null @@ -1,32 +0,0 @@ -ortho_srcdir=.. -GNATFLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwael -CXX=clang++ -LLVM_CONFIG=llvm-config -GNATMAKE=gnatmake -SED=sed -BE=llvm - -all: $(ortho_exec) - -$(ortho_exec): $(ortho_srcdir)/llvm/ortho_llvm.ads force llvm-cbindings.o - $(GNATMAKE) -o $@ -aI$(ortho_srcdir)/llvm -aI$(ortho_srcdir) \ - $(GNATFLAGS) ortho_code_main -bargs -E \ - -largs llvm-cbindings.o --LINK=$(CXX) \ - $(LDFLAGS) `$(LLVM_CONFIG) --ldflags --libs --system-libs` - -llvm-cbindings.o: $(ortho_srcdir)/llvm/llvm-cbindings.cpp - $(CXX) -c `$(LLVM_CONFIG) --cxxflags` -o $@ $< - -clean: - $(RM) -f *.o *.ali ortho_code_main - $(RM) b~*.ad? *~ - -distclean: clean - - -force: - -.PHONY: force all clean - -ORTHO_BASENAME=ortho_llvm -include $(ortho_srcdir)/Makefile.inc diff --git a/src/ortho/llvm/llvm-analysis.ads b/src/ortho/llvm/llvm-analysis.ads deleted file mode 100644 index bfecec579..000000000 --- a/src/ortho/llvm/llvm-analysis.ads +++ /dev/null @@ -1,53 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with LLVM.Core; use LLVM.Core; - -package LLVM.Analysis is - type VerifierFailureAction is - ( - AbortProcessAction, -- verifier will print to stderr and abort() - PrintMessageAction, -- verifier will print to stderr and return 1 - ReturnStatusAction -- verifier will just return 1 - ); - pragma Convention (C, VerifierFailureAction); - - -- Verifies that a module is valid, taking the specified action if not. - -- Optionally returns a human-readable description of any invalid - -- constructs. - -- OutMessage must be disposed with DisposeMessage. */ - function VerifyModule(M : ModuleRef; - Action : VerifierFailureAction; - OutMessage : access Cstring) - return Integer; - - -- Verifies that a single function is valid, taking the specified - -- action. Useful for debugging. - function VerifyFunction(Fn : ValueRef; Action : VerifierFailureAction) - return Integer; - - -- Open up a ghostview window that displays the CFG of the current function. - -- Useful for debugging. - procedure ViewFunctionCFG(Fn : ValueRef); - procedure ViewFunctionCFGOnly(Fn : ValueRef); -private - pragma Import (C, VerifyModule, "LLVMVerifyModule"); - pragma Import (C, VerifyFunction, "LLVMVerifyFunction"); - pragma Import (C, ViewFunctionCFG, "LLVMViewFunctionCFG"); - pragma Import (C, ViewFunctionCFGOnly, "LLVMViewFunctionCFGOnly"); -end LLVM.Analysis; - diff --git a/src/ortho/llvm/llvm-bitwriter.ads b/src/ortho/llvm/llvm-bitwriter.ads deleted file mode 100644 index 3f9c518e4..000000000 --- a/src/ortho/llvm/llvm-bitwriter.ads +++ /dev/null @@ -1,34 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with LLVM.Core; use LLVM.Core; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Interfaces.C; use Interfaces.C; - -package LLVM.BitWriter is - -- Writes a module to an open file descriptor. Returns 0 on success. - -- Closes the Handle. Use dup first if this is not what you want. - function WriteBitcodeToFileHandle(M : ModuleRef; Handle : File_Descriptor) - return int; - - -- Writes a module to the specified path. Returns 0 on success. - function WriteBitcodeToFile(M : ModuleRef; Path : Cstring) - return int; -private - pragma Import (C, WriteBitcodeToFileHandle, "LLVMWriteBitcodeToFileHandle"); - pragma Import (C, WriteBitcodeToFile, "LLVMWriteBitcodeToFile"); -end LLVM.BitWriter; diff --git a/src/ortho/llvm/llvm-cbindings.cpp b/src/ortho/llvm/llvm-cbindings.cpp deleted file mode 100644 index e4d666ade..000000000 --- a/src/ortho/llvm/llvm-cbindings.cpp +++ /dev/null @@ -1,61 +0,0 @@ -/* 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(unwrap(N)); - MD->replaceOperandWith (i, unwrap(V)); -} - -void *LLVMGetPointerToFunction(LLVMExecutionEngineRef EE, LLVMValueRef Func) -{ - return unwrap(EE)->getPointerToFunction(unwrap(Func)); -} - -} diff --git a/src/ortho/llvm/llvm-core.ads b/src/ortho/llvm/llvm-core.ads deleted file mode 100644 index 7ec85c284..000000000 --- a/src/ortho/llvm/llvm-core.ads +++ /dev/null @@ -1,1283 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with Interfaces.C; use Interfaces.C; -use Interfaces; - -package LLVM.Core is - - subtype Cstring is System.Address; - function "=" (L, R : Cstring) return Boolean renames System."="; - -- Null_Cstring : constant Cstring := Null_Address; - Nul : constant String := (1 => Character'Val (0)); - Empty_Cstring : constant Cstring := Nul'Address; - - -- The top-level container for all LLVM global data. See the LLVMContext - -- class. - type ContextRef is new System.Address; - - -- The top-level container for all other LLVM Intermediate - -- Representation (IR) objects. See the llvm::Module class. - type ModuleRef is new System.Address; - - subtype Bool is int; - - -- Each value in the LLVM IR has a type, an LLVMTypeRef. See the llvm::Type - -- class. - type TypeRef is new System.Address; - Null_TypeRef : constant TypeRef := TypeRef (System.Null_Address); - type TypeRefArray is array (unsigned range <>) of TypeRef; - pragma Convention (C, TypeRefArray); - - type ValueRef is new System.Address; - Null_ValueRef : constant ValueRef := ValueRef (System.Null_Address); - type ValueRefArray is array (unsigned range <>) of ValueRef; -- Ada - pragma Convention (C, ValueRefArray); - - type BasicBlockRef is new System.Address; - Null_BasicBlockRef : constant BasicBlockRef := - BasicBlockRef (System.Null_Address); - type BasicBlockRefArray is - array (unsigned range <>) of BasicBlockRef; -- Ada - pragma Convention (C, BasicBlockRefArray); - - type BuilderRef is new System.Address; - - -- Used to provide a module to JIT or interpreter. - -- See the llvm::MemoryBuffer class. - type MemoryBufferRef is new System.Address; - - -- See the llvm::PassManagerBase class. - type PassManagerRef is new System.Address; - - type Attribute is new unsigned; - ZExtAttribute : constant Attribute := 2**0; - SExtAttribute : constant Attribute := 2**1; - NoReturnAttribute : constant Attribute := 2**2; - InRegAttribute : constant Attribute := 2**3; - StructRetAttribute : constant Attribute := 2**4; - NoUnwindAttribute : constant Attribute := 2**5; - NoAliasAttribute : constant Attribute := 2**6; - ByValAttribute : constant Attribute := 2**7; - NestAttribute : constant Attribute := 2**8; - ReadNoneAttribute : constant Attribute := 2**9; - ReadOnlyAttribute : constant Attribute := 2**10; - NoInlineAttribute : constant Attribute := 2**11; - AlwaysInlineAttribute : constant Attribute := 2**12; - OptimizeForSizeAttribute : constant Attribute := 2**13; - StackProtectAttribute : constant Attribute := 2**14; - StackProtectReqAttribute : constant Attribute := 2**15; - Alignment : constant Attribute := 31 * 2**16; - NoCaptureAttribute : constant Attribute := 2**21; - NoRedZoneAttribute : constant Attribute := 2**22; - NoImplicitFloatAttribute : constant Attribute := 2**23; - NakedAttribute : constant Attribute := 2**24; - InlineHintAttribute : constant Attribute := 2**25; - StackAlignment : constant Attribute := 7 * 2**26; - ReturnsTwice : constant Attribute := 2**29; - UWTable : constant Attribute := 2**30; - NonLazyBind : constant Attribute := 2**31; - - type TypeKind is - ( - VoidTypeKind, -- type with no size - HalfTypeKind, -- 16 bit floating point type - FloatTypeKind, -- 32 bit floating point type - DoubleTypeKind, -- 64 bit floating point type - X86_FP80TypeKind, -- 80 bit floating point type (X87) - FP128TypeKind, -- 128 bit floating point type (112-bit mantissa) - PPC_FP128TypeKind, -- 128 bit floating point type (two 64-bits) - LabelTypeKind, -- Labels - IntegerTypeKind, -- Arbitrary bit width integers - FunctionTypeKind, -- Functions - StructTypeKind, -- Structures - ArrayTypeKind, -- Arrays - PointerTypeKind, -- Pointers - VectorTypeKind, -- SIMD 'packed' format, or other vector type - MetadataTypeKind, -- Metadata - X86_MMXTypeKind -- X86 MMX - ); - pragma Convention (C, TypeKind); - - type Linkage is - ( - ExternalLinkage, -- Externally visible function - AvailableExternallyLinkage, - LinkOnceAnyLinkage, -- Keep one copy of function when linking (inline) - LinkOnceODRLinkage, -- Same, but only replaced by someth equivalent. - LinkOnceODRAutoHideLinkage, -- Obsolete - WeakAnyLinkage, -- Keep one copy of function when linking (weak) - WeakODRLinkage, -- Same, but only replaced by someth equivalent. - AppendingLinkage, -- Special purpose, only applies to global arrays - InternalLinkage, -- Rename collisions when linking (static func) - PrivateLinkage, -- Like Internal, but omit from symbol table - DLLImportLinkage, -- Obsolete - DLLExportLinkage, -- Obsolete - ExternalWeakLinkage,-- ExternalWeak linkage description - GhostLinkage, -- Obsolete - CommonLinkage, -- Tentative definitions - LinkerPrivateLinkage, -- Like Private, but linker removes. - LinkerPrivateWeakLinkage -- Like LinkerPrivate, but is weak. - ); - pragma Convention (C, Linkage); - - type Visibility is - ( - DefaultVisibility, -- The GV is visible - HiddenVisibility, -- The GV is hidden - ProtectedVisibility -- The GV is protected - ); - pragma Convention (C, Visibility); - - type CallConv is new unsigned; - CCallConv : constant CallConv := 0; - FastCallConv : constant CallConv := 8; - ColdCallConv : constant CallConv := 9; - X86StdcallCallConv : constant CallConv := 64; - X86FastcallCallConv : constant CallConv := 6; - - type IntPredicate is new unsigned; - IntEQ : constant IntPredicate := 32; -- equal - IntNE : constant IntPredicate := 33; -- not equal - IntUGT : constant IntPredicate := 34; -- unsigned greater than - IntUGE : constant IntPredicate := 35; -- unsigned greater or equal - IntULT : constant IntPredicate := 36; -- unsigned less than - IntULE : constant IntPredicate := 37; -- unsigned less or equal - IntSGT : constant IntPredicate := 38; -- signed greater than - IntSGE : constant IntPredicate := 39; -- signed greater or equal - IntSLT : constant IntPredicate := 40; -- signed less than - IntSLE : constant IntPredicate := 41; -- signed less or equal - - type RealPredicate is - ( - RealPredicateFalse, -- Always false (always folded) - RealOEQ, -- True if ordered and equal - RealOGT, -- True if ordered and greater than - RealOGE, -- True if ordered and greater than or equal - RealOLT, -- True if ordered and less than - RealOLE, -- True if ordered and less than or equal - RealONE, -- True if ordered and operands are unequal - RealORD, -- True if ordered (no nans) - RealUNO, -- True if unordered: isnan(X) | isnan(Y) - RealUEQ, -- True if unordered or equal - RealUGT, -- True if unordered or greater than - RealUGE, -- True if unordered, greater than, or equal - RealULT, -- True if unordered or less than - RealULE, -- True if unordered, less than, or equal - RealUNE, -- True if unordered or not equal - RealPredicateTrue -- Always true (always folded) - ); - - -- Error handling ---------------------------------------------------- - - procedure DisposeMessage (Message : Cstring); - - - -- Context - - -- Create a new context. - -- Every call to this function should be paired with a call to - -- LLVMContextDispose() or the context will leak memory. - function ContextCreate return ContextRef; - - -- Obtain the global context instance. - function GetGlobalContext return ContextRef; - - -- Destroy a context instance. - -- This should be called for every call to LLVMContextCreate() or memory - -- will be leaked. - procedure ContextDispose (C : ContextRef); - - 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; - - -- See Module::dump. - procedure DumpType(T : TypeRef); - - -- Values ------------------------------------------------------------ - -- The bulk of LLVM's object model consists of values, which comprise a very - -- rich type hierarchy. - -- - -- values: - -- constants: - -- scalar constants - -- composite contants - -- globals: - -- global variable - -- function - -- alias - -- basic blocks - - -- Operations on all values - function TypeOf(Val : ValueRef) return TypeRef; - function GetValueName(Val : ValueRef) return Cstring; - procedure SetValueName(Val : ValueRef; Name : Cstring); - procedure DumpValue(Val : ValueRef); - - -- Operations on constants of any type - function ConstNull(Ty : TypeRef) return ValueRef; -- All zero - function ConstAllOnes(Ty : TypeRef) return ValueRef; -- Int or Vec - function GetUndef(Ty : TypeRef) return ValueRef; - function IsConstant(Val : ValueRef) return int; - function IsNull(Val : ValueRef) return int; - function IsUndef(Val : ValueRef) return int; - - -- Convert value instances between types. - -- - -- Internally, an LLVMValueRef is "pinned" to a specific type. This - -- series of functions allows you to cast an instance to a specific - -- type. - -- - -- If the cast is not valid for the specified type, NULL is returned. - -- - -- @see llvm::dyn_cast_or_null<> - function IsAInstruction (Val : ValueRef) return ValueRef; - - -- Operations on scalar constants - function ConstInt(IntTy : TypeRef; N : Unsigned_64; SignExtend : int) - return ValueRef; - function ConstReal(RealTy : TypeRef; N : double) return ValueRef; - function ConstRealOfString(RealTy : TypeRef; Text : Cstring) - return ValueRef; - - - -- Obtain the zero extended value for an integer constant value. - -- @see llvm::ConstantInt::getZExtValue() - function ConstIntGetZExtValue (ConstantVal : ValueRef) return Unsigned_64; - - -- Operations on composite constants - function ConstString(Str : Cstring; - Length : unsigned; DontNullTerminate : int) - return ValueRef; - function ConstArray(ElementTy : TypeRef; - ConstantVals : ValueRefArray; Length : unsigned) - return ValueRef; - function ConstStruct(ConstantVals : ValueRefArray; - Count : unsigned; packed : int) return ValueRef; - - -- Create a non-anonymous ConstantStruct from values. - -- @see llvm::ConstantStruct::get() - function ConstNamedStruct(StructTy : TypeRef; - ConstantVals : ValueRefArray; - Count : unsigned) return ValueRef; - - function ConstVector(ScalarConstantVals : ValueRefArray; Size : unsigned) - return ValueRef; - - -- Constant expressions - function SizeOf(Ty : TypeRef) return ValueRef; - function AlignOf(Ty : TypeRef) return ValueRef; - - function ConstNeg(ConstantVal : ValueRef) return ValueRef; - function ConstNot(ConstantVal : ValueRef) return ValueRef; - function ConstAdd(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstSub(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstMul(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstUDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstSDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstFDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstURem(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstSRem(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstFRem(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstAnd(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstOr(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstXor(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstICmp(Predicate : IntPredicate; - LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstFCmp(Predicate : RealPredicate; - LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstShl(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstLShr(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstAShr(LHSConstant : ValueRef; RHSConstant : ValueRef) - return ValueRef; - function ConstGEP(ConstantVal : ValueRef; - ConstantIndices : ValueRefArray; NumIndices : unsigned) - return ValueRef; - function ConstTrunc(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstSExt(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstZExt(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstFPTrunc(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstFPExt(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstUIToFP(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstSIToFP(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstFPToUI(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstFPToSI(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstPtrToInt(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstIntToPtr(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - function ConstBitCast(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - - function ConstTruncOrBitCast(ConstantVal : ValueRef; ToType : TypeRef) - return ValueRef; - - function ConstSelect(ConstantCondition : ValueRef; - ConstantIfTrue : ValueRef; - ConstantIfFalse : ValueRef) return ValueRef; - function ConstExtractElement(VectorConstant : ValueRef; - IndexConstant : ValueRef) return ValueRef; - function ConstInsertElement(VectorConstant : ValueRef; - ElementValueConstant : ValueRef; - IndexConstant : ValueRef) return ValueRef; - function ConstShuffleVector(VectorAConstant : ValueRef; - VectorBConstant : ValueRef; - MaskConstant : ValueRef) return ValueRef; - - -- Operations on global variables, functions, and aliases (globals) - function GetGlobalParent(Global : ValueRef) return ModuleRef; - function IsDeclaration(Global : ValueRef) return int; - function GetLinkage(Global : ValueRef) return Linkage; - procedure SetLinkage(Global : ValueRef; Link : Linkage); - function GetSection(Global : ValueRef) return Cstring; - procedure SetSection(Global : ValueRef; Section : Cstring); - function GetVisibility(Global : ValueRef) return Visibility; - procedure SetVisibility(Global : ValueRef; Viz : Visibility); - function GetAlignment(Global : ValueRef) return unsigned; - procedure SetAlignment(Global : ValueRef; Bytes : unsigned); - - -- Operations on global variables - function AddGlobal(M : ModuleRef; Ty : TypeRef; Name : Cstring) - return ValueRef; - function GetNamedGlobal(M : ModuleRef; Name : Cstring) return ValueRef; - function GetFirstGlobal(M : ModuleRef) return ValueRef; - function GetLastGlobal(M : ModuleRef) return ValueRef; - function GetNextGlobal(GlobalVar : ValueRef) return ValueRef; - function GetPreviousGlobal(GlobalVar : ValueRef) return ValueRef; - procedure DeleteGlobal(GlobalVar : ValueRef); - function GetInitializer(GlobalVar : ValueRef) return ValueRef; - procedure SetInitializer(GlobalVar : ValueRef; ConstantVal : ValueRef); - function IsThreadLocal(GlobalVar : ValueRef) return int; - procedure SetThreadLocal(GlobalVar : ValueRef; IsThreadLocal : int); - function IsGlobalConstant(GlobalVar : ValueRef) return int; - procedure SetGlobalConstant(GlobalVar : ValueRef; IsConstant : int); - - -- 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, DumpType, "LLVMDumpType"); - - pragma Import (C, TypeOf, "LLVMTypeOf"); - pragma Import (C, GetValueName, "LLVMGetValueName"); - pragma Import (C, SetValueName, "LLVMSetValueName"); - pragma Import (C, DumpValue, "LLVMDumpValue"); - - pragma Import (C, ConstNull, "LLVMConstNull"); - pragma Import (C, ConstAllOnes, "LLVMConstAllOnes"); - pragma Import (C, GetUndef, "LLVMGetUndef"); - pragma Import (C, IsConstant, "LLVMIsConstant"); - pragma Import (C, IsNull, "LLVMIsNull"); - pragma Import (C, IsUndef, "LLVMIsUndef"); - pragma Import (C, IsAInstruction, "LLVMIsAInstruction"); - - pragma Import (C, ConstInt, "LLVMConstInt"); - pragma Import (C, ConstReal, "LLVMConstReal"); - pragma Import (C, ConstIntGetZExtValue, "LLVMConstIntGetZExtValue"); - pragma Import (C, ConstRealOfString, "LLVMConstRealOfString"); - pragma Import (C, ConstString, "LLVMConstString"); - pragma Import (C, ConstArray, "LLVMConstArray"); - pragma Import (C, ConstStruct, "LLVMConstStruct"); - pragma Import (C, ConstNamedStruct, "LLVMConstNamedStruct"); - pragma Import (C, ConstVector, "LLVMConstVector"); - - pragma Import (C, SizeOf, "LLVMSizeOf"); - pragma Import (C, AlignOf, "LLVMAlignOf"); - pragma Import (C, ConstNeg, "LLVMConstNeg"); - pragma Import (C, ConstNot, "LLVMConstNot"); - pragma Import (C, ConstAdd, "LLVMConstAdd"); - pragma Import (C, ConstSub, "LLVMConstSub"); - pragma Import (C, ConstMul, "LLVMConstMul"); - pragma Import (C, ConstUDiv, "LLVMConstUDiv"); - pragma Import (C, ConstSDiv, "LLVMConstSDiv"); - pragma Import (C, ConstFDiv, "LLVMConstFDiv"); - pragma Import (C, ConstURem, "LLVMConstURem"); - pragma Import (C, ConstSRem, "LLVMConstSRem"); - pragma Import (C, ConstFRem, "LLVMConstFRem"); - pragma Import (C, ConstAnd, "LLVMConstAnd"); - pragma Import (C, ConstOr, "LLVMConstOr"); - pragma Import (C, ConstXor, "LLVMConstXor"); - pragma Import (C, ConstICmp, "LLVMConstICmp"); - pragma Import (C, ConstFCmp, "LLVMConstFCmp"); - pragma Import (C, ConstShl, "LLVMConstShl"); - pragma Import (C, ConstLShr, "LLVMConstLShr"); - pragma Import (C, ConstAShr, "LLVMConstAShr"); - pragma Import (C, ConstGEP, "LLVMConstGEP"); - pragma Import (C, ConstTrunc, "LLVMConstTrunc"); - pragma Import (C, ConstSExt, "LLVMConstSExt"); - pragma Import (C, ConstZExt, "LLVMConstZExt"); - pragma Import (C, ConstFPTrunc, "LLVMConstFPTrunc"); - pragma Import (C, ConstFPExt, "LLVMConstFPExt"); - pragma Import (C, ConstUIToFP, "LLVMConstUIToFP"); - pragma Import (C, ConstSIToFP, "LLVMConstSIToFP"); - pragma Import (C, ConstFPToUI, "LLVMConstFPToUI"); - pragma Import (C, ConstFPToSI, "LLVMConstFPToSI"); - pragma Import (C, ConstPtrToInt, "LLVMConstPtrToInt"); - pragma Import (C, ConstIntToPtr, "LLVMConstIntToPtr"); - pragma Import (C, ConstBitCast, "LLVMConstBitCast"); - pragma Import (C, ConstTruncOrBitCast, "LLVMConstTruncOrBitCast"); - pragma Import (C, ConstSelect, "LLVMConstSelect"); - pragma Import (C, ConstExtractElement, "LLVMConstExtractElement"); - pragma Import (C, ConstInsertElement, "LLVMConstInsertElement"); - pragma Import (C, ConstShuffleVector, "LLVMConstShuffleVector"); - - pragma Import (C, GetGlobalParent, "LLVMGetGlobalParent"); - pragma Import (C, IsDeclaration, "LLVMIsDeclaration"); - pragma Import (C, GetLinkage, "LLVMGetLinkage"); - pragma Import (C, SetLinkage, "LLVMSetLinkage"); - pragma Import (C, GetSection, "LLVMGetSection"); - pragma Import (C, SetSection, "LLVMSetSection"); - pragma Import (C, GetVisibility, "LLVMGetVisibility"); - pragma Import (C, SetVisibility, "LLVMSetVisibility"); - pragma Import (C, GetAlignment, "LLVMGetAlignment"); - pragma Import (C, SetAlignment, "LLVMSetAlignment"); - - pragma Import (C, AddGlobal, "LLVMAddGlobal"); - pragma Import (C, GetNamedGlobal, "LLVMGetNamedGlobal"); - pragma Import (C, GetFirstGlobal, "LLVMGetFirstGlobal"); - pragma Import (C, GetLastGlobal, "LLVMGetLastGlobal"); - pragma Import (C, GetNextGlobal, "LLVMGetNextGlobal"); - pragma Import (C, GetPreviousGlobal, "LLVMGetPreviousGlobal"); - pragma Import (C, DeleteGlobal, "LLVMDeleteGlobal"); - pragma Import (C, GetInitializer, "LLVMGetInitializer"); - pragma Import (C, SetInitializer, "LLVMSetInitializer"); - pragma Import (C, IsThreadLocal, "LLVMIsThreadLocal"); - pragma Import (C, SetThreadLocal, "LLVMSetThreadLocal"); - pragma Import (C, IsGlobalConstant, "LLVMIsGlobalConstant"); - pragma Import (C, SetGlobalConstant, "LLVMSetGlobalConstant"); - - pragma Import (C, 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/src/ortho/llvm/llvm-executionengine.ads b/src/ortho/llvm/llvm-executionengine.ads deleted file mode 100644 index 72d4cda2f..000000000 --- a/src/ortho/llvm/llvm-executionengine.ads +++ /dev/null @@ -1,163 +0,0 @@ --- 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/src/ortho/llvm/llvm-target.ads b/src/ortho/llvm/llvm-target.ads deleted file mode 100644 index b7c35848a..000000000 --- a/src/ortho/llvm/llvm-target.ads +++ /dev/null @@ -1,84 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with Interfaces; use Interfaces; -with Interfaces.C; use Interfaces.C; -with LLVM.Core; use LLVM.Core; - -package LLVM.Target is - - type TargetDataRef is new System.Address; - - -- LLVMInitializeNativeTarget - The main program should call this function - -- to initialize the native target corresponding to the host. This is - -- useful for JIT applications to ensure that the target gets linked in - -- correctly. - procedure InitializeNativeTarget; - pragma Import (C, InitializeNativeTarget, - "LLVMInitializeNativeTarget_noinline"); - - -- LLVMInitializeNativeTargetAsmPrinter - The main program should call this - -- function to initialize the printer for the native target corresponding - -- to the host. - procedure InitializeNativeAsmPrinter; - pragma Import (C, InitializeNativeAsmPrinter, - "LLVMInitializeNativeAsmPrinter_noinline"); - - -- Creates target data from a target layout string. - -- See the constructor llvm::DataLayout::DataLayout. - function CreateTargetData (StringRep : Cstring) return TargetDataRef; - pragma Import (C, CreateTargetData, "LLVMCreateTargetData"); - - -- Adds target data information to a pass manager. This does not take - -- ownership of the target data. - -- See the method llvm::PassManagerBase::add. - procedure AddTargetData(TD : TargetDataRef; PM : PassManagerRef); - pragma Import (C, AddTargetData, "LLVMAddTargetData"); - - -- Converts target data to a target layout string. The string must be - -- disposed with LLVMDisposeMessage. - -- See the constructor llvm::DataLayout::DataLayout. */ - function CopyStringRepOfTargetData(TD :TargetDataRef) return Cstring; - pragma Import (C, CopyStringRepOfTargetData, - "LLVMCopyStringRepOfTargetData"); - - -- Returns the pointer size in bytes for a target. - -- See the method llvm::DataLayout::getPointerSize. - function PointerSize(TD : TargetDataRef) return unsigned; - pragma Import (C, PointerSize, "LLVMPointerSize"); - - -- Computes the ABI size of a type in bytes for a target. - -- See the method llvm::DataLayout::getTypeAllocSize. - function ABISizeOfType (TD : TargetDataRef; Ty: TypeRef) return Unsigned_64; - pragma Import (C, ABISizeOfType, "LLVMABISizeOfType"); - - -- Computes the ABI alignment of a type in bytes for a target. - -- See the method llvm::DataLayout::getTypeABISize. - function ABIAlignmentOfType (TD : TargetDataRef; Ty: TypeRef) - return Unsigned_32; - pragma Import (C, ABIAlignmentOfType, "LLVMABIAlignmentOfType"); - - -- Computes the byte offset of the indexed struct element for a target. - -- See the method llvm::StructLayout::getElementContainingOffset. - function OffsetOfElement(TD : TargetDataRef; - StructTy : TypeRef; - Element : Unsigned_32) - return Unsigned_64; - pragma Import (C, OffsetOfElement, "LLVMOffsetOfElement"); - -end LLVM.Target; diff --git a/src/ortho/llvm/llvm-targetmachine.ads b/src/ortho/llvm/llvm-targetmachine.ads deleted file mode 100644 index cbf074940..000000000 --- a/src/ortho/llvm/llvm-targetmachine.ads +++ /dev/null @@ -1,122 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with LLVM.Core; use LLVM.Core; -with LLVM.Target; use LLVM.Target; - -package LLVM.TargetMachine is - - type TargetMachineRef is new System.Address; - Null_TargetMachineRef : constant TargetMachineRef := - TargetMachineRef (System.Null_Address); - - type TargetRef is new System.Address; - Null_TargetRef : constant TargetRef := TargetRef (System.Null_Address); - - type CodeGenOptLevel is (CodeGenLevelNone, - CodeGenLevelLess, - CodeGenLevelDefault, - CodeGenLevelAggressive); - pragma Convention (C, CodeGenOptLevel); - - type RelocMode is (RelocDefault, - RelocStatic, - RelocPIC, - RelocDynamicNoPic); - pragma Convention (C, RelocMode); - - type CodeModel is (CodeModelDefault, - CodeModelJITDefault, - CodeModelSmall, - CodeModelKernel, - CodeModelMedium, - CodeModelLarge); - pragma Convention (C, CodeModel); - - type CodeGenFileType is (AssemblyFile, - ObjectFile); - pragma Convention (C, CodeGenFileType); - - -- Returns the first llvm::Target in the registered targets list. - function GetFirstTarget return TargetRef; - pragma Import (C, GetFirstTarget, "LLVMGetFirstTarget"); - - -- Returns the next llvm::Target given a previous one (or null if there's - -- none) */ - function GetNextTarget(T : TargetRef) return TargetRef; - pragma Import (C, GetNextTarget, "LLVMGetNextTarget"); - - -- Target - - -- Finds the target corresponding to the given name and stores it in T. - -- Returns 0 on success. - function GetTargetFromName (Name : Cstring) return TargetRef; - pragma Import (C, GetTargetFromName, "LLVMGetTargetFromName"); - - -- Finds the target corresponding to the given triple and stores it in T. - -- Returns 0 on success. Optionally returns any error in ErrorMessage. - -- Use LLVMDisposeMessage to dispose the message. - -- Ada: ErrorMessage is the address of a Cstring. - function GetTargetFromTriple - (Triple : Cstring; T : access TargetRef; ErrorMessage : access Cstring) - return Bool; - pragma Import (C, GetTargetFromTriple, "LLVMGetTargetFromTriple"); - - -- Returns the name of a target. See llvm::Target::getName - function GetTargetName (T: TargetRef) return Cstring; - pragma Import (C, GetTargetName, "LLVMGetTargetName"); - - -- Returns the description of a target. See llvm::Target::getDescription - function GetTargetDescription (T : TargetRef) return Cstring; - pragma Import (C, GetTargetDescription, "LLVMGetTargetDescription"); - - -- Target Machine ---------------------------------------------------- - - -- Creates a new llvm::TargetMachine. See llvm::Target::createTargetMachine - - function CreateTargetMachine(T : TargetRef; - Triple : Cstring; - CPU : Cstring; - Features : Cstring; - Level : CodeGenOptLevel; - Reloc : RelocMode; - CM : CodeModel) - return TargetMachineRef; - pragma Import (C, CreateTargetMachine, "LLVMCreateTargetMachine"); - - -- Returns the llvm::DataLayout used for this llvm:TargetMachine. - function GetTargetMachineData(T : TargetMachineRef) return TargetDataRef; - pragma Import (C, GetTargetMachineData, "LLVMGetTargetMachineData"); - - -- Emits an asm or object file for the given module to the filename. This - -- wraps several c++ only classes (among them a file stream). Returns any - -- error in ErrorMessage. Use LLVMDisposeMessage to dispose the message. - function TargetMachineEmitToFile(T : TargetMachineRef; - M : ModuleRef; - Filename : Cstring; - Codegen : CodeGenFileType; - ErrorMessage : access Cstring) - return Bool; - pragma Import (C, TargetMachineEmitToFile, - "LLVMTargetMachineEmitToFile"); - - -- Get a triple for the host machine as a string. The result needs to be - -- disposed with LLVMDisposeMessage. - function GetDefaultTargetTriple return Cstring; - pragma Import (C, GetDefaultTargetTriple, "LLVMGetDefaultTargetTriple"); -end LLVM.TargetMachine; diff --git a/src/ortho/llvm/llvm-transforms-scalar.ads b/src/ortho/llvm/llvm-transforms-scalar.ads deleted file mode 100644 index 0f23ce87e..000000000 --- a/src/ortho/llvm/llvm-transforms-scalar.ads +++ /dev/null @@ -1,169 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with LLVM.Core; use LLVM.Core; - -package LLVM.Transforms.Scalar is - -- See llvm::createAggressiveDCEPass function. - procedure AddAggressiveDCEPass(PM : PassManagerRef); - pragma Import (C, AddAggressiveDCEPass, "LLVMAddAggressiveDCEPass"); - - -- See llvm::createCFGSimplificationPass function. - procedure AddCFGSimplificationPass(PM : PassManagerRef); - pragma Import (C, AddCFGSimplificationPass, "LLVMAddCFGSimplificationPass"); - - -- See llvm::createDeadStoreEliminationPass function. - procedure AddDeadStoreEliminationPass(PM : PassManagerRef); - pragma Import (C, AddDeadStoreEliminationPass, - "LLVMAddDeadStoreEliminationPass"); - - -- See llvm::createScalarizerPass function. - procedure AddScalarizerPass(PM : PassManagerRef); - pragma Import (C, AddScalarizerPass, "LLVMAddScalarizerPass"); - - -- See llvm::createGVNPass function. - procedure AddGVNPass(PM : PassManagerRef); - pragma Import (C, AddGVNPass, "LLVMAddGVNPass"); - - -- See llvm::createIndVarSimplifyPass function. - procedure AddIndVarSimplifyPass(PM : PassManagerRef); - pragma Import (C, AddIndVarSimplifyPass, "LLVMAddIndVarSimplifyPass"); - - -- See llvm::createInstructionCombiningPass function. - procedure AddInstructionCombiningPass(PM : PassManagerRef); - pragma Import (C, AddInstructionCombiningPass, - "LLVMAddInstructionCombiningPass"); - - -- See llvm::createJumpThreadingPass function. - procedure AddJumpThreadingPass(PM : PassManagerRef); - pragma Import (C, AddJumpThreadingPass, "LLVMAddJumpThreadingPass"); - - -- See llvm::createLICMPass function. - procedure AddLICMPass(PM : PassManagerRef); - pragma Import (C, AddLICMPass, "LLVMAddLICMPass"); - - -- See llvm::createLoopDeletionPass function. - procedure AddLoopDeletionPass(PM : PassManagerRef); - pragma Import (C, AddLoopDeletionPass, "LLVMAddLoopDeletionPass"); - - -- See llvm::createLoopIdiomPass function - procedure AddLoopIdiomPass(PM : PassManagerRef); - pragma Import (C, AddLoopIdiomPass, "LLVMAddLoopIdiomPass"); - - -- See llvm::createLoopRotatePass function. - procedure AddLoopRotatePass(PM : PassManagerRef); - pragma Import (C, AddLoopRotatePass, "LLVMAddLoopRotatePass"); - - -- See llvm::createLoopRerollPass function. - procedure AddLoopRerollPass(PM : PassManagerRef); - pragma Import (C, AddLoopRerollPass, "LLVMAddLoopRerollPass"); - - -- See llvm::createLoopUnrollPass function. - procedure AddLoopUnrollPass(PM : PassManagerRef); - pragma Import (C, AddLoopUnrollPass, "LLVMAddLoopUnrollPass"); - - -- See llvm::createLoopUnswitchPass function. - procedure AddLoopUnswitchPass(PM : PassManagerRef); - pragma Import (C, AddLoopUnswitchPass, "LLVMAddLoopUnswitchPass"); - - -- See llvm::createMemCpyOptPass function. - procedure AddMemCpyOptPass(PM : PassManagerRef); - pragma Import (C, AddMemCpyOptPass, "LLVMAddMemCpyOptPass"); - - -- See llvm::createPartiallyInlineLibCallsPass function. - procedure AddPartiallyInlineLibCallsPass(PM : PassManagerRef); - pragma Import (C, AddPartiallyInlineLibCallsPass, - "LLVMAddPartiallyInlineLibCallsPass"); - - -- See llvm::createPromoteMemoryToRegisterPass function. - procedure AddPromoteMemoryToRegisterPass(PM : PassManagerRef); - pragma Import (C, AddPromoteMemoryToRegisterPass, - "LLVMAddPromoteMemoryToRegisterPass"); - - -- See llvm::createReassociatePass function. - procedure AddReassociatePass(PM : PassManagerRef); - pragma Import (C, AddReassociatePass, "LLVMAddReassociatePass"); - - -- See llvm::createSCCPPass function. - procedure AddSCCPPass(PM : PassManagerRef); - pragma Import (C, AddSCCPPass, "LLVMAddSCCPPass"); - - -- See llvm::createScalarReplAggregatesPass function. - procedure AddScalarReplAggregatesPass(PM : PassManagerRef); - pragma Import (C, AddScalarReplAggregatesPass, - "LLVMAddScalarReplAggregatesPass"); - - -- See llvm::createScalarReplAggregatesPass function. - procedure AddScalarReplAggregatesPassSSA(PM : PassManagerRef); - pragma Import (C, AddScalarReplAggregatesPassSSA, - "LLVMAddScalarReplAggregatesPassSSA"); - - -- See llvm::createScalarReplAggregatesPass function. - procedure AddScalarReplAggregatesPassWithThreshold - (PM : PassManagerRef; Threshold : Integer); - pragma Import (C, AddScalarReplAggregatesPassWithThreshold, - "LLVMAddScalarReplAggregatesPassWithThreshold"); - - -- See llvm::createSimplifyLibCallsPass function. - procedure AddSimplifyLibCallsPass(PM : PassManagerRef); - pragma Import (C, AddSimplifyLibCallsPass, "LLVMAddSimplifyLibCallsPass"); - - -- See llvm::createTailCallEliminationPass function. - procedure AddTailCallEliminationPass(PM : PassManagerRef); - pragma Import (C, AddTailCallEliminationPass, - "LLVMAddTailCallEliminationPass"); - - -- See llvm::createConstantPropagationPass function. - procedure AddConstantPropagationPass(PM : PassManagerRef); - pragma Import (C, AddConstantPropagationPass, - "LLVMAddConstantPropagationPass"); - - -- See llvm::demotePromoteMemoryToRegisterPass function. - procedure AddDemoteMemoryToRegisterPass(PM : PassManagerRef); - pragma Import (C, AddDemoteMemoryToRegisterPass, - "LLVMAddDemoteMemoryToRegisterPass"); - - -- See llvm::createVerifierPass function. - procedure AddVerifierPass(PM : PassManagerRef); - pragma Import (C, AddVerifierPass, "LLVMAddVerifierPass"); - - -- See llvm::createCorrelatedValuePropagationPass function - procedure AddCorrelatedValuePropagationPass(PM : PassManagerRef); - pragma Import (C, AddCorrelatedValuePropagationPass, - "LLVMAddCorrelatedValuePropagationPass"); - - -- See llvm::createEarlyCSEPass function - procedure AddEarlyCSEPass(PM : PassManagerRef); - pragma Import (C, AddEarlyCSEPass, "LLVMAddEarlyCSEPass"); - - -- See llvm::createLowerExpectIntrinsicPass function - procedure AddLowerExpectIntrinsicPass(PM : PassManagerRef); - pragma Import (C, AddLowerExpectIntrinsicPass, - "LLVMAddLowerExpectIntrinsicPass"); - - -- See llvm::createTypeBasedAliasAnalysisPass function - procedure AddTypeBasedAliasAnalysisPass(PM : PassManagerRef); - pragma Import (C, AddTypeBasedAliasAnalysisPass, - "LLVMAddTypeBasedAliasAnalysisPass"); - - -- See llvm::createBasicAliasAnalysisPass function - procedure AddBasicAliasAnalysisPass(PM : PassManagerRef); - pragma Import (C, AddBasicAliasAnalysisPass, - "LLVMAddBasicAliasAnalysisPass"); -end LLVM.Transforms.Scalar; - - diff --git a/src/ortho/llvm/llvm-transforms.ads b/src/ortho/llvm/llvm-transforms.ads deleted file mode 100644 index d5a8011ce..000000000 --- a/src/ortho/llvm/llvm-transforms.ads +++ /dev/null @@ -1,21 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package LLVM.Transforms is - pragma Pure (LLVM.Transforms); -end LLVM.Transforms; diff --git a/src/ortho/llvm/llvm.ads b/src/ortho/llvm/llvm.ads deleted file mode 100644 index 80d036b84..000000000 --- a/src/ortho/llvm/llvm.ads +++ /dev/null @@ -1,21 +0,0 @@ --- LLVM binding --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package LLVM is - pragma Pure (LLVM); -end LLVM; diff --git a/src/ortho/llvm/ortho_code_main.adb b/src/ortho/llvm/ortho_code_main.adb deleted file mode 100644 index 4b6dbd856..000000000 --- a/src/ortho/llvm/ortho_code_main.adb +++ /dev/null @@ -1,395 +0,0 @@ --- LLVM back-end for ortho - Main subprogram. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Unchecked_Deallocation; -with Ada.Unchecked_Conversion; -with Ada.Text_IO; use Ada.Text_IO; - -with Ortho_Front; use Ortho_Front; -with LLVM.BitWriter; -with LLVM.Core; use LLVM.Core; -with LLVM.ExecutionEngine; use LLVM.ExecutionEngine; -with LLVM.Target; use LLVM.Target; -with LLVM.TargetMachine; use LLVM.TargetMachine; -with LLVM.Analysis; -with LLVM.Transforms.Scalar; -with Ortho_LLVM; use Ortho_LLVM; -with Interfaces; -with Interfaces.C; use Interfaces.C; - -procedure Ortho_Code_Main is - -- Name of the output filename (given by option '-o'). - Output : String_Acc := null; - - type Output_Kind_Type is (Output_Llvm, Output_Bytecode, - Output_Assembly, Output_Object); - Output_Kind : Output_Kind_Type := Output_Object; - - -- 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 : RelocMode := RelocDefault; - - function To_String (C : Cstring) return String is - function Strlen (C : Cstring) return Natural; - pragma Import (C, Strlen); - - subtype Fat_String is String (Positive); - type Fat_String_Acc is access Fat_String; - - function To_Fat_String_Acc is new - Ada.Unchecked_Conversion (Cstring, Fat_String_Acc); - begin - return To_Fat_String_Acc (C)(1 .. Strlen (C)); - end To_String; - - Codegen : CodeGenFileType := ObjectFile; - - Msg : aliased Cstring; -begin - Ortho_Front.Init; - - -- Decode options. - First_File := Natural'Last; - Optind := 1; - while Optind <= Argc loop - declare - Arg : constant String := Argument (Optind); - begin - if Arg (1) = '-' then - if Arg = "--dump-llvm" then - Flag_Dump_Llvm := True; - elsif Arg = "-o" then - if Optind = Argc then - Put_Line (Standard_Error, "error: missing filename to '-o'"); - return; - end if; - Output := new String'(Argument (Optind + 1) & ASCII.Nul); - Optind := Optind + 1; - elsif Arg = "-quiet" then - -- Skip silently. - null; - elsif Arg = "-S" then - Output_Kind := Output_Assembly; - Codegen := AssemblyFile; - elsif Arg = "-c" then - Output_Kind := Output_Object; - Codegen := ObjectFile; - elsif Arg = "-O0" then - Optimization := CodeGenLevelNone; - elsif Arg = "-O1" or else Arg = "-O" then - Optimization := CodeGenLevelLess; - elsif Arg = "-O2" then - Optimization := CodeGenLevelDefault; - elsif Arg = "-O3" then - Optimization := CodeGenLevelAggressive; - elsif Arg = "-fpic" or Arg = "-fPIC" then - Reloc := RelocPIC; - elsif Arg = "-fno-pic" then - Reloc := RelocStatic; - 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 = "-glines" - or else Arg = "-gline-tables-only" - then - Flag_Debug_Line := True; - elsif Arg = "-g" then - Flag_Debug_Line := True; - 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 - Opt_Arg := null; - if Optind < Argument_Count then - declare - Arg1 : constant String := Argument (Optind + 1); - begin - if Arg1 (Arg1'First) /= '-' then - Opt_Arg := new String'(Arg1); - end if; - end; - end if; - - Res := Ortho_Front.Decode_Option (Opt, Opt_Arg); - case Res is - when 0 => - Put_Line (Standard_Error, - "unknown option '" & Arg & "'"); - return; - when 1 => - null; - when 2 => - Optind := Optind + 1; - when others => - raise Program_Error; - end case; - Unchecked_Deallocation (Opt); - Unchecked_Deallocation (Opt_Arg); - end; - end if; - else - First_File := Optind; - exit; - end if; - end; - Optind := Optind + 1; - end loop; - - -- Link with LLVM libraries. - InitializeNativeTarget; - InitializeNativeAsmPrinter; - - LinkInJIT; - - Module := ModuleCreateWithName (Module_Name'Address); - - 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.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_Line then - Ortho_LLVM.Finish_Debug; - end if; - - -- Ortho_Mcode.Finish; - - if Flag_Dump_Llvm then - DumpModule (Module); - end if; - - -- Verify module. - if False then - if LLVM.Analysis.VerifyModule - (Module, LLVM.Analysis.PrintMessageAction, Msg'Access) /= 0 - then - DisposeMessage (Msg); - raise Program_Error; - end if; - end if; - - if Optimization > CodeGenLevelNone then - declare - use LLVM.Transforms.Scalar; - Global_Manager : constant Boolean := False; - Pass_Manager : PassManagerRef; - Res : Bool; - pragma Unreferenced (Res); - A_Func : ValueRef; - begin - if Global_Manager then - Pass_Manager := CreatePassManager; - else - Pass_Manager := CreateFunctionPassManagerForModule (Module); - end if; - - LLVM.Target.AddTargetData (Target_Data, Pass_Manager); - AddPromoteMemoryToRegisterPass (Pass_Manager); - AddCFGSimplificationPass (Pass_Manager); - - if Global_Manager then - Res := RunPassManager (Pass_Manager, Module); - else - A_Func := GetFirstFunction (Module); - while A_Func /= Null_ValueRef loop - Res := RunFunctionPassManager (Pass_Manager, A_Func); - A_Func := GetNextFunction (A_Func); - end loop; - end if; - end; - end if; - - if Output /= null then - declare - Error : Boolean; - begin - Msg := Empty_Cstring; - - case Output_Kind is - when Output_Assembly - | Output_Object => - Error := LLVM.TargetMachine.TargetMachineEmitToFile - (Target_Machine, Module, - Output.all'Address, Codegen, Msg'Access) /= 0; - when Output_Bytecode => - Error := LLVM.BitWriter.WriteBitcodeToFile - (Module, Output.all'Address) /= 0; - when Output_Llvm => - Error := PrintModuleToFile - (Module, Output.all'Address, Msg'Access) /= 0; - end case; - if Error then - Put_Line (Standard_Error, - "error while writing to " & Output.all); - if Msg /= Empty_Cstring then - Put_Line (Standard_Error, - "message: " & To_String (Msg)); - DisposeMessage (Msg); - end if; - Set_Exit_Status (2); - return; - end if; - end; - 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 - DumpModule (Module); - end if; - - Set_Exit_Status (Success); -exception - when others => - Set_Exit_Status (2); - raise; -end Ortho_Code_Main; diff --git a/src/ortho/llvm/ortho_ident.adb b/src/ortho/llvm/ortho_ident.adb deleted file mode 100644 index e7b650539..000000000 --- a/src/ortho/llvm/ortho_ident.adb +++ /dev/null @@ -1,134 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package body Ortho_Ident is - type Chunk (Max : Positive); - type Chunk_Acc is access Chunk; - - type Chunk (Max : Positive) is record - Prev : Chunk_Acc; - Len : Natural := 0; - S : String (1 .. Max); - end record; - - Cur_Chunk : Chunk_Acc := null; - - subtype Fat_String is String (Positive); - - function Get_Identifier (Str : String) return O_Ident - is - Len : constant Natural := Str'Length; - Max : Positive; - Org : Positive; - begin - if Cur_Chunk = null or else Cur_Chunk.Len + Len >= Cur_Chunk.Max then - if Cur_Chunk = null then - Max := 32 * 1024; - else - Max := 2 * Cur_Chunk.Max; - end if; - if Len + 2 > Max then - Max := 2 * (Len + 2); - end if; - declare - New_Chunk : Chunk_Acc; - begin - -- Do not use allocator by expression, as we don't want to - -- initialize S. - New_Chunk := new Chunk (Max); - New_Chunk.Len := 0; - New_Chunk.Prev := Cur_Chunk; - Cur_Chunk := New_Chunk; - end; - end if; - - Org := Cur_Chunk.Len + 1; - Cur_Chunk.S (Org .. Org + Len - 1) := Str; - Cur_Chunk.S (Org + Len) := ASCII.NUL; - Cur_Chunk.Len := Org + Len; - - return (Addr => Cur_Chunk.S (Org)'Address); - end Get_Identifier; - - function Is_Equal (L, R : O_Ident) return Boolean - is - begin - return L = R; - end Is_Equal; - - function Get_String_Length (Id : O_Ident) return Natural - is - Str : Fat_String; - pragma Import (Ada, Str); - for Str'Address use Id.Addr; - begin - for I in Str'Range loop - if Str (I) = ASCII.NUL then - return I - 1; - end if; - end loop; - raise Program_Error; - end Get_String_Length; - - function Get_String (Id : O_Ident) return String - is - Str : Fat_String; - pragma Import (Ada, Str); - for Str'Address use Id.Addr; - begin - for I in Str'Range loop - if Str (I) = ASCII.NUL then - return Str (1 .. I - 1); - end if; - end loop; - raise Program_Error; - end Get_String; - - function Get_Cstring (Id : O_Ident) return System.Address is - begin - return Id.Addr; - end Get_Cstring; - - function Is_Equal (Id : O_Ident; Str : String) return Boolean - is - Istr : Fat_String; - pragma Import (Ada, Istr); - for Istr'Address use Id.Addr; - - Str_Len : constant Natural := Str'Length; - begin - for I in Istr'Range loop - if Istr (I) = ASCII.NUL then - return I - 1 = Str_Len; - end if; - if I > Str_Len then - return False; - end if; - if Istr (I) /= Str (Str'First + I - 1) then - return False; - end if; - end loop; - raise Program_Error; - end Is_Equal; - - function Is_Nul (Id : O_Ident) return Boolean is - begin - return Id = O_Ident_Nul; - end Is_Nul; - -end Ortho_Ident; diff --git a/src/ortho/llvm/ortho_ident.ads b/src/ortho/llvm/ortho_ident.ads deleted file mode 100644 index 7d3955c02..000000000 --- a/src/ortho/llvm/ortho_ident.ads +++ /dev/null @@ -1,42 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; - -package Ortho_Ident is - type O_Ident is private; - - function Get_Identifier (Str : String) return O_Ident; - function Is_Equal (L, R : O_Ident) return Boolean; - function Is_Equal (Id : O_Ident; Str : String) return Boolean; - function Is_Nul (Id : O_Ident) return Boolean; - function Get_String (Id : O_Ident) return String; - function Get_String_Length (Id : O_Ident) return Natural; - - -- Note: the address is always valid. - function Get_Cstring (Id : O_Ident) return System.Address; - - O_Ident_Nul : constant O_Ident; - -private - type O_Ident is record - Addr : System.Address; - end record; - O_Ident_Nul : constant O_Ident := (Addr => System.Null_Address); - - pragma Inline (Get_Cstring); -end Ortho_Ident; diff --git a/src/ortho/llvm/ortho_jit.adb b/src/ortho/llvm/ortho_jit.adb deleted file mode 100644 index fdda667d9..000000000 --- a/src/ortho/llvm/ortho_jit.adb +++ /dev/null @@ -1,151 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- with GNAT.OS_Lib; use GNAT.OS_Lib; -with Ada.Text_IO; use Ada.Text_IO; - -with Ortho_LLVM; use Ortho_LLVM; -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 execution engine"); - raise Program_Error; - end if; - - Target_Data := GetExecutionEngineTargetData (Ortho_LLVM.Jit.Engine); - SetDataLayout (Module, CopyStringRepOfTargetData (Target_Data)); - - Ortho_LLVM.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; - - function Get_Jit_Name return String is - begin - return "LLVM"; - end Get_Jit_Name; - -end Ortho_Jit; diff --git a/src/ortho/llvm/ortho_llvm-jit.adb b/src/ortho/llvm/ortho_llvm-jit.adb deleted file mode 100644 index 9155a02c7..000000000 --- a/src/ortho/llvm/ortho_llvm-jit.adb +++ /dev/null @@ -1,55 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -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/src/ortho/llvm/ortho_llvm-jit.ads b/src/ortho/llvm/ortho_llvm-jit.ads deleted file mode 100644 index 5296e2ed8..000000000 --- a/src/ortho/llvm/ortho_llvm-jit.ads +++ /dev/null @@ -1,31 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with 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/src/ortho/llvm/ortho_llvm.adb b/src/ortho/llvm/ortho_llvm.adb deleted file mode 100644 index 250870224..000000000 --- a/src/ortho/llvm/ortho_llvm.adb +++ /dev/null @@ -1,3096 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; -with LLVM.Target; use LLVM.Target; -with GNAT.Directory_Operations; - -package body Ortho_LLVM is - -- The current function for LLVM (needed to add new basic blocks). - Cur_Func : ValueRef; - - -- The current function node (needed for return type). - Cur_Func_Decl : O_Dnode; - - -- Whether the code is currently unreachable. LLVM doesn't accept basic - -- blocks that cannot be reached (using trivial rules). So we need to - -- discard instructions after a return, a next or an exit statement. - Unreach : Boolean; - - -- Builder for statements. - Builder : BuilderRef; - - -- Builder for declarations (local variables). - Decl_Builder : BuilderRef; - - -- Temporary builder. - Extra_Builder : BuilderRef; - - -- Declaration of llvm.dbg.declare - Llvm_Dbg_Declare : ValueRef; - - Debug_ID : unsigned; - - Current_Directory : constant String := - GNAT.Directory_Operations.Get_Current_Dir; - - -- Additional data for declare blocks. - type Declare_Block_Type; - type Declare_Block_Acc is access Declare_Block_Type; - - type Declare_Block_Type is record - -- First basic block of the declare. - Stmt_Bb : BasicBlockRef; - - -- Stack pointer at entry of the block. This value has to be restore - -- when leaving the block (either normally or via exit/next). Set only - -- if New_Alloca was used. - -- FIXME: TODO: restore stack pointer on exit/next stmts. - Stack_Value : ValueRef; - - -- Debug data for the scope of the declare block. - Dbg_Scope : ValueRef; - - -- Previous element in the stack. - Prev : Declare_Block_Acc; - end record; - - -- Current declare block. - Cur_Declare_Block : Declare_Block_Acc; - - -- Chain of unused blocks to be recycled. - Old_Declare_Block : Declare_Block_Acc; - - Stacksave_Fun : ValueRef; - Stacksave_Name : constant String := "llvm.stacksave" & ASCII.NUL; - Stackrestore_Fun : ValueRef; - Stackrestore_Name : constant String := "llvm.stackrestore" & ASCII.NUL; - Copysign_Fun : ValueRef; - Copysign_Name : constant String := "llvm.copysign.f64" & ASCII.NUL; - Fp_0_5 : ValueRef; - - -- 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_Union_Type : constant := DW_Version + 16#17#; - 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 := Null_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_Line and then IsAInstruction (Insn) /= Null_ValueRef then - if Dbg_Current_Line /= Dbg_Insn_MD_Line then - declare - Vals : ValueRefArray (0 .. 3); - begin - Vals := (Dbg_Line, - ConstInt (Int32Type, 0, 0), -- col - Dbg_Current_Scope, -- context - Null_ValueRef); -- inline - Dbg_Insn_MD := MDNode (Vals, Vals'Length); - Dbg_Insn_MD_Line := Dbg_Current_Line; - end; - end if; - SetMetadata (Insn, Debug_ID, Dbg_Insn_MD); - end if; - end Set_Insn_Dbg; - - procedure Dbg_Create_Variable (Tag : Unsigned_32; - Ident : O_Ident; - Vtype : O_Tnode; - Argno : Natural; - Addr : ValueRef) - is - Vals : ValueRefArray (0 .. 7); - Str : constant ValueRef := MDString (Ident); - Call_Vals : ValueRefArray (0 .. 1); - Call : ValueRef; - begin - Vals := (ConstInt (Int32Type, Unsigned_64 (Tag), 0), - Dbg_Current_Scope, - Str, - Dbg_Current_File, - ConstInt (Int32Type, - Unsigned_64 (Dbg_Current_Line) - + Unsigned_64 (Argno) * 2 ** 24, 0), - Vtype.Dbg, - ConstInt (Int32Type, 0, 0), -- flags - ConstInt (Int32Type, 0, 0)); - - Call_Vals := (MDNode ((0 => Addr), 1), - MDNode (Vals, Vals'Length)); - Call := BuildCall (Decl_Builder, Llvm_Dbg_Declare, - Call_Vals, Call_Vals'Length, Empty_Cstring); - Set_Insn_Dbg (Call); - end Dbg_Create_Variable; - - procedure Create_Declare_Block - is - Res : Declare_Block_Acc; - begin - -- Try to recycle an unused record. - if Old_Declare_Block /= null then - Res := Old_Declare_Block; - Old_Declare_Block := Res.Prev; - else - -- Create a new one if no unused records. - Res := new Declare_Block_Type; - end if; - - -- Chain. - Res.all := (Stmt_Bb => Null_BasicBlockRef, - Stack_Value => Null_ValueRef, - Dbg_Scope => Null_ValueRef, - Prev => Cur_Declare_Block); - Cur_Declare_Block := Res; - - if not Unreach then - Res.Stmt_Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); - end if; - end Create_Declare_Block; - - procedure Destroy_Declare_Block - is - Blk : constant Declare_Block_Acc := Cur_Declare_Block; - begin - -- Unchain. - Cur_Declare_Block := Blk.Prev; - - -- Put on the recyle list. - Blk.Prev := Old_Declare_Block; - Old_Declare_Block := Blk; - end Destroy_Declare_Block; - - ----------------------- - -- Start_Record_Type -- - ----------------------- - - procedure Start_Record_Type (Elements : out O_Element_List) is - begin - Elements := (Kind => OF_Record, - Nbr_Elements => 0, - Rec_Type => O_Tnode_Null, - Size => 0, - Align => 0, - Align_Type => Null_TypeRef, - First_Elem => null, - Last_Elem => null); - end Start_Record_Type; - - ---------------------- - -- New_Record_Field -- - ---------------------- - - procedure Add_Field - (Elements : in out O_Element_List; Ident : O_Ident; Etype : O_Tnode) - is - O_El : O_Element_Acc; - begin - Elements.Nbr_Elements := Elements.Nbr_Elements + 1; - O_El := new O_Element'(Next => null, - Etype => Etype, - Ident => Ident); - if Elements.First_Elem = null then - Elements.First_Elem := O_El; - else - Elements.Last_Elem.Next := O_El; - end if; - Elements.Last_Elem := O_El; - end Add_Field; - - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode) is - begin - El := (Kind => OF_Record, - Index => Elements.Nbr_Elements, - Ftype => Etype); - Add_Field (Elements, Ident, Etype); - end New_Record_Field; - - ------------------------ - -- Finish_Record_Type -- - ------------------------ - - procedure Add_Dbg_Fields - (Elements : in out O_Element_List; Res : O_Tnode) - is - Count : constant unsigned := unsigned (Elements.Nbr_Elements); - Fields : ValueRefArray (1 .. Count); - Vals : ValueRefArray (0 .. 9); - Ftype : TypeRef; - Fields_Arr : ValueRef; - Off : Unsigned_64; - El : O_Element_Acc; - begin - El := Elements.First_Elem; - for I in Fields'Range loop - Ftype := Get_LLVM_Type (El.Etype); - case Elements.Kind is - when OF_Record => - Off := 8 * OffsetOfElement (Target_Data, - Res.LLVM, Unsigned_32 (I - 1)); - when OF_Union => - Off := 0; - when OF_None => - raise Program_Error; - end case; - 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, Off, 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 Add_Dbg_Fields; - - procedure Free_Elements (Elements : in out O_Element_List) - is - procedure Free is new Ada.Unchecked_Deallocation - (O_Element, O_Element_Acc); - El : O_Element_Acc; - Next_El : O_Element_Acc; - begin - -- Free elements - El := Elements.First_Elem; - while El /= null loop - Next_El := El.Next; - Free (El); - El := Next_El; - end loop; - Elements.First_Elem := null; - Elements.Last_Elem := null; - end Free_Elements; - - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode) - is - Count : constant unsigned := unsigned (Elements.Nbr_Elements); - El : O_Element_Acc; - Types : TypeRefArray (1 .. Count); - begin - El := Elements.First_Elem; - for I in Types'Range loop - Types (I) := Get_LLVM_Type (El.Etype); - El := El.Next; - end loop; - - if Elements.Rec_Type /= null then - -- Completion - StructSetBody (Elements.Rec_Type.LLVM, Types, Count, 0); - Res := Elements.Rec_Type; - else - Res := new O_Tnode_Type'(Kind => ON_Record_Type, - LLVM => StructType (Types, Count, 0), - Dbg => Null_ValueRef); - end if; - - if Flag_Debug then - Add_Dbg_Fields (Elements, Res); - end if; - - Free_Elements (Elements); - end Finish_Record_Type; - - -------------------------------- - -- New_Uncomplete_Record_Type -- - -------------------------------- - - procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is - begin - -- LLVM type will be created when the type is declared, as the name - -- is required (for unification). - Res := new O_Tnode_Type'(Kind => ON_Incomplete_Record_Type, - LLVM => Null_TypeRef, - Dbg => Null_ValueRef); - end New_Uncomplete_Record_Type; - - ---------------------------------- - -- Start_Uncomplete_Record_Type -- - ---------------------------------- - - procedure Start_Uncomplete_Record_Type - (Res : O_Tnode; - Elements : out O_Element_List) - is - begin - if Res.Kind /= ON_Incomplete_Record_Type then - raise Program_Error; - end if; - Elements := (Kind => OF_Record, - Nbr_Elements => 0, - Rec_Type => Res, - Size => 0, - Align => 0, - Align_Type => Null_TypeRef, - First_Elem => null, - Last_Elem => null); - end Start_Uncomplete_Record_Type; - - ---------------------- - -- Start_Union_Type -- - ---------------------- - - procedure Start_Union_Type (Elements : out O_Element_List) is - begin - Elements := (Kind => OF_Union, - Nbr_Elements => 0, - Rec_Type => O_Tnode_Null, - Size => 0, - Align => 0, - Align_Type => Null_TypeRef, - First_Elem => null, - Last_Elem => null); - end Start_Union_Type; - - --------------------- - -- New_Union_Field -- - --------------------- - - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode) - is - El_Type : constant TypeRef := Get_LLVM_Type (Etype); - Size : constant unsigned := - unsigned (ABISizeOfType (Target_Data, El_Type)); - Align : constant Unsigned_32 := - ABIAlignmentOfType (Target_Data, El_Type); - begin - El := (Kind => OF_Union, - Ftype => Etype, - Utype => El_Type, - Ptr_Type => PointerType (El_Type)); - if Size > Elements.Size then - Elements.Size := Size; - end if; - if Elements.Align_Type = Null_TypeRef or else Align > Elements.Align then - Elements.Align := Align; - Elements.Align_Type := El_Type; - end if; - Add_Field (Elements, Ident, Etype); - end New_Union_Field; - - ----------------------- - -- Finish_Union_Type -- - ----------------------- - - procedure Finish_Union_Type - (Elements : in out O_Element_List; - Res : out O_Tnode) - is - Count : unsigned; - Types : TypeRefArray (1 .. 2); - Pad : unsigned; - begin - if Elements.Align_Type = Null_TypeRef then - -- An empty union. Is it allowed ? - Count := 0; - else - -- The first element is the field with the biggest alignment - Types (1) := Elements.Align_Type; - -- Possibly complete with an array of bytes. - Pad := Elements.Size - - unsigned (ABISizeOfType (Target_Data, Elements.Align_Type)); - if Pad /= 0 then - Types (2) := ArrayType (Int8Type, Pad); - Count := 2; - else - Count := 1; - end if; - end if; - Res := new O_Tnode_Type'(Kind => ON_Union_Type, - LLVM => StructType (Types, Count, 0), - Dbg => Null_ValueRef, - Un_Size => Elements.Size, - Un_Main_Field => Elements.Align_Type); - - if Flag_Debug then - Add_Dbg_Fields (Elements, Res); - end if; - Free_Elements (Elements); - end Finish_Union_Type; - - --------------------- - -- New_Access_Type -- - --------------------- - - function New_Access_Type (Dtype : O_Tnode) return O_Tnode is - begin - if Dtype = O_Tnode_Null then - -- LLVM type will be built by New_Type_Decl, so that the name - -- can be used for the structure. - return new O_Tnode_Type'(Kind => ON_Incomplete_Access_Type, - LLVM => Null_TypeRef, - Dbg => Null_ValueRef, - Acc_Type => O_Tnode_Null); - else - return new O_Tnode_Type'(Kind => ON_Access_Type, - LLVM => PointerType (Get_LLVM_Type (Dtype)), - Dbg => Null_ValueRef, - Acc_Type => Dtype); - end if; - end New_Access_Type; - - ------------------------ - -- Finish_Access_Type -- - ------------------------ - - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) - is - Types : TypeRefArray (1 .. 1); - begin - if Atype.Kind /= ON_Incomplete_Access_Type then - -- Not an incomplete access type. - raise Program_Error; - end if; - if Atype.Acc_Type /= O_Tnode_Null then - -- Already completed. - raise Program_Error; - end if; - -- Completion - Types (1) := Get_LLVM_Type (Dtype); - StructSetBody (GetElementType (Atype.LLVM), Types, Types'Length, 0); - Atype.Acc_Type := Dtype; - - -- Debug. - if Atype.Dbg /= Null_ValueRef then - pragma Assert (GetMDNodeNumOperands (Atype.Dbg) = 10); - MDNodeReplaceOperandWith (Atype.Dbg, 9, Dtype.Dbg); - end if; - 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 - V : ValueRef; - begin - if List.Atype.Kind = ON_Incomplete_Record_Type then - V := ConstNamedStruct (Get_LLVM_Type (List.Atype), - List.Vals.all, List.Len); - else - V := ConstStruct (List.Vals.all, List.Len, 0); - end if; - Res := (LLVM => V, Ctype => List.Atype); - Free (List.Vals); - end Finish_Record_Aggr; - - ---------------------- - -- Start_Array_Aggr -- - ---------------------- - - procedure Start_Array_Aggr - (List : out O_Array_Aggr_List; - Atype : O_Tnode) - is - Llvm : constant TypeRef := Get_LLVM_Type (Atype); - begin - List := (Len => 0, - Vals => new ValueRefArray (1 .. GetArrayLength (Llvm)), - El_Type => GetElementType (Llvm), - Atype => Atype); - end Start_Array_Aggr; - - ----------------------- - -- New_Array_Aggr_El -- - ----------------------- - - procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; - Value : O_Cnode) - is - begin - List.Len := List.Len + 1; - List.Vals (List.Len) := Value.LLVM; - end New_Array_Aggr_El; - - ----------------------- - -- Finish_Array_Aggr -- - ----------------------- - - procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; - Res : out O_Cnode) - is - begin - Res := (LLVM => ConstArray (List.El_Type, - List.Vals.all, List.Len), - Ctype => List.Atype); - Free (List.Vals); - end Finish_Array_Aggr; - - -------------------- - -- New_Union_Aggr -- - -------------------- - - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode - is - Values : ValueRefArray (1 .. 2); - Count : unsigned; - Size : constant unsigned := - unsigned (ABISizeOfType (Target_Data, Field.Utype)); - - begin - Values (1) := Value.LLVM; - if Size < Atype.Un_Size then - Values (2) := GetUndef (ArrayType (Int8Type, Atype.Un_Size - Size)); - Count := 2; - else - Count := 1; - end if; - - -- If `FIELD` is the main field of the union, create a struct using - -- the same type as the union (and possibly pad). - if Field.Utype = Atype.Un_Main_Field then - return O_Cnode' - (LLVM => ConstNamedStruct (Atype.LLVM, Values, Count), - Ctype => Atype); - else - -- Create an on-the-fly record. - return O_Cnode'(LLVM => ConstStruct (Values, Count, 0), - Ctype => Atype); - end if; - end New_Union_Aggr; - - ----------------------- - -- New_Default_Value -- - ----------------------- - - function New_Default_Value (Ltype : O_Tnode) return O_Cnode is - begin - return O_Cnode'(LLVM => ConstNull (Ltype.LLVM), - Ctype => Ltype); - end New_Default_Value; - - ---------------- - -- New_Sizeof -- - ---------------- - - -- Return VAL with type RTYPE (either unsigned or access) - function Const_To_Cnode (Rtype : O_Tnode; Val : Unsigned_64) return O_Cnode - is - Tmp : ValueRef; - begin - case Rtype.Kind is - when ON_Scalar_Types => - -- Well, unsigned in fact. - return O_Cnode'(LLVM => ConstInt (Rtype.LLVM, Val, 0), - Ctype => Rtype); - when ON_Access_Type => - Tmp := ConstInt (Int64Type, Val, 0); - return O_Cnode'(LLVM => ConstIntToPtr (Tmp, Rtype.LLVM), - Ctype => Rtype); - when others => - raise Program_Error; - end case; - end Const_To_Cnode; - - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is - begin - return Const_To_Cnode - (Rtype, ABISizeOfType (Target_Data, Get_LLVM_Type (Atype))); - end New_Sizeof; - - ----------------- - -- New_Alignof -- - ----------------- - - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is - begin - return Const_To_Cnode - (Rtype, - Unsigned_64 - (ABIAlignmentOfType (Target_Data, Get_LLVM_Type (Atype)))); - end New_Alignof; - - ------------------ - -- New_Offsetof -- - ------------------ - - function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode is - begin - return Const_To_Cnode - (Rtype, - OffsetOfElement (Target_Data, - Get_LLVM_Type (Atype), - Unsigned_32 (Field.Index))); - end New_Offsetof; - - ---------------------------- - -- New_Subprogram_Address -- - ---------------------------- - - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode is - begin - return O_Cnode' - (LLVM => ConstBitCast (Subprg.LLVM, Get_LLVM_Type (Atype)), - Ctype => Atype); - end New_Subprogram_Address; - - ------------------------ - -- New_Global_Address -- - ------------------------ - - function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) - return O_Cnode is - begin - return New_Global_Unchecked_Address (Lvalue, Atype); - end New_Global_Address; - - ---------------------------------- - -- New_Global_Unchecked_Address -- - ---------------------------------- - - function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) - return O_Cnode is - begin - return O_Cnode'(LLVM => ConstBitCast (Lvalue.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_Global -- - ---------------- - - function New_Global (Decl : O_Dnode) return O_Gnode is - begin - -- Can be used to build global objects, even when Unreach is set. - -- As this doesn't generate code, this is ok. - case Decl.Kind is - when ON_Const_Decl - | ON_Var_Decl => - return O_Gnode'(LLVM => Decl.LLVM, - Ltype => Decl.Dtype); - when others => - raise Program_Error; - end case; - end New_Global; - - ------------------- - -- New_Dyadic_Op -- - ------------------- - - function New_Smod (L, R : ValueRef; Res_Type : TypeRef) - return ValueRef - is - Cond : ValueRef; - Br : ValueRef; - pragma Unreferenced (Br); - - -- The result of 'L rem R'. - Rm : ValueRef; - - -- Rm + R - Rm_Plus_R : ValueRef; - - -- The result of 'L xor R'. - R_Xor : ValueRef; - - Adj : ValueRef; - Phi : ValueRef; - - -- Basic basic for the non-overflow branch - Normal_Bb : constant BasicBlockRef := - AppendBasicBlock (Cur_Func, Empty_Cstring); - - Adjust_Bb : constant BasicBlockRef := - AppendBasicBlock (Cur_Func, Empty_Cstring); - - -- Basic block after the result - Next_Bb : constant BasicBlockRef := - AppendBasicBlock (Cur_Func, Empty_Cstring); - - Vals : ValueRefArray (1 .. 3); - BBs : BasicBlockRefArray (1 .. 3); - begin - -- Avoid overflow with -1: - -- if R = -1 then - -- result := 0; - -- else - -- ... - Cond := BuildICmp - (Builder, IntEQ, R, ConstAllOnes (Res_Type), Empty_Cstring); - Br := BuildCondBr (Builder, Cond, Next_Bb, Normal_Bb); - Vals (1) := ConstNull (Res_Type); - BBs (1) := GetInsertBlock (Builder); - - -- Rm := Left rem Right - PositionBuilderAtEnd (Builder, Normal_Bb); - Rm := BuildSRem (Builder, L, R, Empty_Cstring); - - -- if Rm = 0 then - -- result := 0 - -- else - Cond := BuildICmp - (Builder, IntEQ, Rm, ConstNull (Res_Type), Empty_Cstring); - Br := BuildCondBr (Builder, Cond, Next_Bb, Adjust_Bb); - Vals (2) := ConstNull (Res_Type); - BBs (2) := Normal_Bb; - - -- if (L xor R) < 0 then - -- result := Rm + R - -- else - -- result := Rm; - -- end if; - PositionBuilderAtEnd (Builder, Adjust_Bb); - R_Xor := BuildXor (Builder, L, R, Empty_Cstring); - Cond := BuildICmp - (Builder, IntSLT, R_Xor, ConstNull (Res_Type), Empty_Cstring); - Rm_Plus_R := BuildAdd (Builder, Rm, R, Empty_Cstring); - Adj := BuildSelect (Builder, Cond, Rm_Plus_R, Rm, Empty_Cstring); - Br := BuildBr (Builder, Next_Bb); - Vals (3) := Adj; - BBs (3) := Adjust_Bb; - - -- The Phi node - PositionBuilderAtEnd (Builder, Next_Bb); - Phi := BuildPhi (Builder, Res_Type, Empty_Cstring); - AddIncoming (Phi, Vals, BBs, Vals'Length); - - return Phi; - end New_Smod; - - type Dyadic_Builder_Acc is access - function (Builder : BuilderRef; - LHS : ValueRef; RHS : ValueRef; Name : Cstring) - return ValueRef; - pragma Convention (C, Dyadic_Builder_Acc); - - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode - is - Build : Dyadic_Builder_Acc := null; - Res : ValueRef := Null_ValueRef; - begin - if Unreach then - return O_Enode'(LLVM => Null_ValueRef, Etype => Left.Etype); - end if; - - case Left.Etype.Kind is - when ON_Integer_Types => - case Kind is - when ON_And => - Build := BuildAnd'Access; - when ON_Or => - Build := BuildOr'Access; - when ON_Xor => - Build := BuildXor'Access; - - when ON_Add_Ov => - Build := BuildAdd'Access; - when ON_Sub_Ov => - Build := BuildSub'Access; - when ON_Mul_Ov => - Build := BuildMul'Access; - - when ON_Div_Ov => - case Left.Etype.Kind is - when ON_Unsigned_Type => - Build := BuildUDiv'Access; - when ON_Signed_Type => - Build := BuildSDiv'Access; - when others => - null; - end case; - - when ON_Mod_Ov - | ON_Rem_Ov => -- FIXME... - case Left.Etype.Kind is - when ON_Unsigned_Type => - Build := BuildURem'Access; - when ON_Signed_Type => - if Kind = ON_Rem_Ov then - Build := BuildSRem'Access; - else - Res := New_Smod - (Left.LLVM, Right.LLVM, Left.Etype.LLVM); - end if; - when others => - null; - end case; - end case; - - when ON_Float_Type => - case Kind is - when ON_Add_Ov => - Build := BuildFAdd'Access; - when ON_Sub_Ov => - Build := BuildFSub'Access; - when ON_Mul_Ov => - Build := BuildFMul'Access; - when ON_Div_Ov => - Build := BuildFDiv'Access; - - when others => - null; - end case; - - when others => - null; - end case; - - if Build /= null then - pragma Assert (Res = Null_ValueRef); - Res := Build.all (Builder, Left.LLVM, Right.LLVM, Empty_Cstring); - end if; - - if Res = Null_ValueRef then - raise Program_Error with "Unimplemented New_Dyadic_Op " - & ON_Dyadic_Op_Kind'Image (Kind) - & " for type " - & ON_Type_Kind'Image (Left.Etype.Kind); - end if; - - 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 - if Unreach then - return O_Enode'(LLVM => Null_ValueRef, Etype => Operand.Etype); - end if; - - case Operand.Etype.Kind is - when ON_Integer_Types => - case Kind is - when ON_Not => - Res := BuildNot (Builder, Operand.LLVM, Empty_Cstring); - when ON_Neg_Ov => - Res := BuildNeg (Builder, Operand.LLVM, Empty_Cstring); - when ON_Abs_Ov => - Res := BuildSelect - (Builder, - BuildICmp (Builder, IntSLT, - Operand.LLVM, - ConstInt (Get_LLVM_Type (Operand.Etype), 0, 0), - Empty_Cstring), - BuildNeg (Builder, Operand.LLVM, Empty_Cstring), - Operand.LLVM, - Empty_Cstring); - end case; - when ON_Float_Type => - case Kind is - when ON_Not => - raise Program_Error; - when ON_Neg_Ov => - Res := BuildFNeg (Builder, Operand.LLVM, Empty_Cstring); - when ON_Abs_Ov => - Res := BuildSelect - (Builder, - BuildFCmp (Builder, RealOLT, - Operand.LLVM, - ConstReal (Get_LLVM_Type (Operand.Etype), 0.0), - Empty_Cstring), - BuildFNeg (Builder, Operand.LLVM, Empty_Cstring), - Operand.LLVM, - Empty_Cstring); - end case; - when others => - raise Program_Error; - end case; - - 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 - if Unreach then - return O_Enode'(LLVM => Null_ValueRef, Etype => Ntype); - end if; - - case Left.Etype.Kind is - when ON_Unsigned_Type - | ON_Boolean_Type - | ON_Enum_Type - | ON_Access_Type - | ON_Incomplete_Access_Type => - Res := BuildICmp (Builder, Compare_Op_Table (Kind).Unsigned_Pred, - Left.LLVM, Right.LLVM, Empty_Cstring); - when ON_Signed_Type => - Res := BuildICmp (Builder, Compare_Op_Table (Kind).Signed_Pred, - Left.LLVM, Right.LLVM, Empty_Cstring); - when ON_Float_Type => - Res := BuildFCmp (Builder, Compare_Op_Table (Kind).Real_Pred, - Left.LLVM, Right.LLVM, Empty_Cstring); - when ON_Array_Type - | ON_Array_Sub_Type - | ON_Record_Type - | ON_Incomplete_Record_Type - | ON_Union_Type - | ON_No_Type => - raise Program_Error; - end case; - 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); - Tmp : ValueRef; - begin - if Unreach then - Tmp := Null_ValueRef; - else - Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring); - end if; - return O_Lnode'(Direct => False, - LLVM => Tmp, - Ltype => Arr.Ltype.Arr_El_Type); - end New_Indexed_Element; - - --------------- - -- New_Slice -- - --------------- - - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode - is - Idx : constant ValueRefArray (1 .. 2) := - (ConstInt (Int32Type, 0, 0), - Index.LLVM); - Tmp : ValueRef; - begin - if Unreach then - Tmp := Null_ValueRef; - else - Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring); - Tmp := BuildBitCast - (Builder, Tmp, PointerType (Get_LLVM_Type (Res_Type)), - Empty_Cstring); - end if; - return O_Lnode'(Direct => False, LLVM => Tmp, Ltype => Res_Type); - end New_Slice; - - -------------------------- - -- New_Selected_Element -- - -------------------------- - - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode - is - Res : ValueRef; - begin - if Unreach then - Res := Null_ValueRef; - else - case El.Kind is - when OF_Record => - declare - Idx : constant ValueRefArray (1 .. 2) := - (ConstInt (Int32Type, 0, 0), - ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); - begin - Res := BuildGEP (Builder, Rec.LLVM, Idx, 2, Empty_Cstring); - end; - when OF_Union => - Res := BuildBitCast (Builder, - Rec.LLVM, El.Ptr_Type, Empty_Cstring); - when OF_None => - raise Program_Error; - end case; - end if; - return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); - end New_Selected_Element; - - function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) - return O_Gnode - is - Res : ValueRef; - begin - case El.Kind is - when OF_Record => - declare - Idx : constant ValueRefArray (1 .. 2) := - (ConstInt (Int32Type, 0, 0), - ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); - begin - Res := ConstGEP (Rec.LLVM, Idx, 2); - end; - when OF_Union => - Res := ConstBitCast (Rec.LLVM, El.Ptr_Type); - when OF_None => - raise Program_Error; - end case; - return O_Gnode'(LLVM => Res, Ltype => El.Ftype); - end New_Global_Selected_Element; - - ------------------------ - -- New_Access_Element -- - ------------------------ - - function New_Access_Element (Acc : O_Enode) return O_Lnode - is - Res : ValueRef; - begin - case Acc.Etype.Kind is - when ON_Access_Type => - Res := Acc.LLVM; - when ON_Incomplete_Access_Type => - -- Unwrap the structure - declare - Idx : constant ValueRefArray (1 .. 2) := - (ConstInt (Int32Type, 0, 0), ConstInt (Int32Type, 0, 0)); - begin - Res := BuildGEP (Builder, Acc.LLVM, Idx, 2, Empty_Cstring); - end; - when others => - raise Program_Error; - end case; - return O_Lnode'(Direct => False, - LLVM => Res, - Ltype => Acc.Etype.Acc_Type); - end New_Access_Element; - - -------------------- - -- New_Convert_Ov -- - -------------------- - - function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode - is - Res : ValueRef := Null_ValueRef; - begin - if Rtype = Val.Etype then - -- Convertion to itself: nothing to do. - return Val; - end if; - if Rtype.LLVM = Val.Etype.LLVM then - -- Same underlying LLVM type: no conversion but keep new type in - -- case of change of sign. - return O_Enode'(LLVM => Val.LLVM, Etype => Rtype); - end if; - if Unreach then - return O_Enode'(LLVM => Val.LLVM, Etype => Rtype); - end if; - - case Rtype.Kind is - when ON_Integer_Types => - case Val.Etype.Kind is - when ON_Integer_Types => - -- Int to Int - if Val.Etype.Scal_Size > Rtype.Scal_Size then - -- Truncate - Res := BuildTrunc - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - elsif Val.Etype.Scal_Size < Rtype.Scal_Size then - if Val.Etype.Kind = ON_Signed_Type then - Res := BuildSExt - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - else - -- Unsigned, enum - Res := BuildZExt - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - end if; - else - Res := BuildBitCast - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - end if; - - when ON_Float_Type => - -- Float to Int - if Rtype.Kind = ON_Signed_Type then - -- FPtoSI rounds toward zero, so we need to add - -- copysign (0.5, x). - declare - V : ValueRef; - begin - V := BuildCall (Builder, Copysign_Fun, - (Fp_0_5, Val.LLVM), 2, Empty_Cstring); - V := BuildFAdd (Builder, Val.LLVM, V, Empty_Cstring); - Res := BuildFPToSI - (Builder, V, Get_LLVM_Type (Rtype), Empty_Cstring); - end; - end if; - - when others => - null; - end case; - - when ON_Float_Type => - if Val.Etype.Kind = ON_Signed_Type then - Res := BuildSIToFP - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - elsif Val.Etype.Kind = ON_Unsigned_Type then - Res := BuildUIToFP - (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - end if; - - when ON_Access_Type - | ON_Incomplete_Access_Type => - if GetTypeKind (TypeOf (Val.LLVM)) /= PointerTypeKind then - raise Program_Error; - end if; - Res := BuildBitCast (Builder, Val.LLVM, Get_LLVM_Type (Rtype), - Empty_Cstring); - - when others => - null; - end case; - if Res /= Null_ValueRef then - -- FIXME: only if insn was generated - -- Set_Insn_Dbg (Res); - return O_Enode'(LLVM => Res, Etype => Rtype); - else - raise Program_Error with "New_Convert_Ov: not implemented for " - & ON_Type_Kind'Image (Val.Etype.Kind) - & " -> " - & ON_Type_Kind'Image (Rtype.Kind); - end if; - end New_Convert_Ov; - - ----------------- - -- New_Address -- - ----------------- - - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is - begin - return New_Unchecked_Address (Lvalue, Atype); - end New_Address; - - --------------------------- - -- New_Unchecked_Address -- - --------------------------- - - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode - is - Res : ValueRef; - begin - if Unreach then - Res := Null_ValueRef; - else - Res := BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype), - Empty_Cstring); - end if; - return O_Enode'(LLVM => Res, Etype => Atype); - end New_Unchecked_Address; - - --------------- - -- New_Value -- - --------------- - - function New_Value (Lvalue : O_Lnode) return O_Enode - is - Res : ValueRef; - begin - if Unreach then - Res := Null_ValueRef; - else - Res := Lvalue.LLVM; - if not Lvalue.Direct then - Res := BuildLoad (Builder, Res, Empty_Cstring); - 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 - -- Can be used to build global objects, even when Unreach is set. - -- As this doesn't generate code, this is ok. - case Obj.Kind is - when ON_Const_Decl - | ON_Var_Decl - | ON_Local_Decl => - return O_Lnode'(Direct => False, - LLVM => Obj.LLVM, - Ltype => Obj.Dtype); - - when ON_Interface_Decl => - if Flag_Debug then - -- The argument was allocated. - return O_Lnode'(Direct => False, - LLVM => Obj.Inter.Ival, - Ltype => Obj.Dtype); - else - return O_Lnode'(Direct => True, - LLVM => Obj.Inter.Ival, - Ltype => Obj.Dtype); - end if; - - when ON_Type_Decl - | ON_Completed_Type_Decl - | ON_Subprg_Decl - | ON_No_Decl => - raise Program_Error; - end case; - end New_Obj; - - ---------------- - -- New_Alloca -- - ---------------- - - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode - is - Res : ValueRef; - begin - if Unreach then - Res := Null_ValueRef; - else - if Cur_Declare_Block.Stack_Value = Null_ValueRef - and then Cur_Declare_Block.Prev /= null - then - -- Save stack pointer at entry of block - declare - First_Insn : ValueRef; - Bld : BuilderRef; - begin - First_Insn := GetFirstInstruction (Cur_Declare_Block.Stmt_Bb); - if First_Insn = Null_ValueRef then - -- Alloca is the first instruction, save the stack now. - Bld := Builder; - else - -- There are instructions before alloca, insert the save - -- at the beginning. - PositionBuilderBefore (Extra_Builder, First_Insn); - Bld := Extra_Builder; - end if; - - Cur_Declare_Block.Stack_Value := - BuildCall (Bld, Stacksave_Fun, - (1 .. 0 => Null_ValueRef), 0, Empty_Cstring); - end; - end if; - - Res := BuildArrayAlloca - (Builder, Int8Type, Size.LLVM, Empty_Cstring); - Set_Insn_Dbg (Res); - - Res := BuildBitCast - (Builder, Res, Get_LLVM_Type (Rtype), Empty_Cstring); - Set_Insn_Dbg (Res); - end if; - - return O_Enode'(LLVM => Res, Etype => Rtype); - end New_Alloca; - - ------------------- - -- New_Type_Decl -- - ------------------- - - function Add_Dbg_Basic_Type (Id : O_Ident; Btype : O_Tnode; Enc : Natural) - return ValueRef - is - Vals : ValueRefArray (0 .. 9); - begin - Vals := (ConstInt (Int32Type, DW_TAG_Base_Type, 0), - Null_ValueRef, - Null_ValueRef, - MDString (Id), - ConstInt (Int32Type, 0, 0), -- linenum - Dbg_Size (Btype.LLVM), - Dbg_Align (Btype.LLVM), - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 0, 0), -- Flags - ConstInt (Int32Type, Unsigned_64 (Enc), 0)); -- Encoding - return MDNode (Vals, Vals'Length); - end Add_Dbg_Basic_Type; - - function Add_Dbg_Enum_Type (Id : O_Ident; Etype : O_Tnode) return ValueRef - is - Vals : ValueRefArray (0 .. 14); - begin - Vals := (ConstInt (Int32Type, DW_TAG_Enumeration_Type, 0), - Dbg_Current_Filedir, - Null_ValueRef, -- context - MDString (Id), - Dbg_Line, - Dbg_Size (Etype.LLVM), - Dbg_Align (Etype.LLVM), - ConstInt (Int32Type, 0, 0), -- Offset - ConstInt (Int32Type, 0, 0), -- Flags - Null_ValueRef, - Get_Value (Enum_Nodes), - ConstInt (Int32Type, 0, 0), - Null_ValueRef, - Null_ValueRef, - Null_ValueRef); -- Runtime lang - Clear (Enum_Nodes); - return MDNode (Vals, Vals'Length); - end Add_Dbg_Enum_Type; - - function Add_Dbg_Pointer_Type - (Id : O_Ident; Ptype : O_Tnode; Designated_Dbg : ValueRef) - return ValueRef - is - Vals : ValueRefArray (0 .. 9); - begin - 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 - Designated_Dbg); - return MDNode (Vals, Vals'Length); - end Add_Dbg_Pointer_Type; - - function Add_Dbg_Pointer_Type (Id : O_Ident; Ptype : O_Tnode) - return ValueRef is - begin - pragma Assert (Ptype.Acc_Type /= null); - pragma Assert (Ptype.Acc_Type.Dbg /= Null_ValueRef); - return Add_Dbg_Pointer_Type (Id, Ptype, Ptype.Acc_Type.Dbg); - end Add_Dbg_Pointer_Type; - - function Add_Dbg_Incomplete_Pointer_Type (Id : O_Ident; Ptype : O_Tnode) - return ValueRef is - begin - return Add_Dbg_Pointer_Type (Id, Ptype, Null_ValueRef); - end Add_Dbg_Incomplete_Pointer_Type; - - function Add_Dbg_Record_Type - (Id : O_Ident; Rtype : O_Tnode; Tag : Unsigned_64) return ValueRef - is - Vals : ValueRefArray (0 .. 14); - begin - Vals := (ConstInt (Int32Type, Tag, 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 - -- Create the incomplete structure. This is the only way in LLVM to - -- build recursive types. - case Atype.Kind is - when ON_Incomplete_Record_Type => - Atype.LLVM := - StructCreateNamed (GetGlobalContext, Get_Cstring (Ident)); - when ON_Incomplete_Access_Type => - Atype.LLVM := PointerType - (StructCreateNamed (GetGlobalContext, Get_Cstring (Ident))); - when others => - null; - end case; - - -- 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_Incomplete_Access_Type => - Atype.Dbg := Add_Dbg_Incomplete_Pointer_Type (Ident, Atype); - when ON_Record_Type => - Atype.Dbg := Add_Dbg_Record_Type - (Ident, Atype, DW_TAG_Structure_Type); - when ON_Incomplete_Record_Type => - Atype.Dbg := Add_Dbg_Record_Type - (Ident, O_Tnode_Null, DW_TAG_Structure_Type); - when ON_Array_Type - | ON_Array_Sub_Type => - -- FIXME: typedef - null; - when ON_Union_Type => - Atype.Dbg := Add_Dbg_Record_Type - (Ident, Atype, DW_TAG_Union_Type); - 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_Line 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_Init_Value -- - ----------------------- - - procedure Start_Init_Value (Decl : in out O_Dnode) is - begin - null; - end Start_Init_Value; - - ------------------------ - -- Finish_Init_Value -- - ------------------------ - - procedure Finish_Init_Value (Decl : in out O_Dnode; Val : O_Cnode) is - begin - SetInitializer (Decl.LLVM, Val.LLVM); - end Finish_Init_Value; - - ------------------ - -- New_Var_Decl -- - ------------------ - - procedure New_Var_Decl - (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) - is - Decl : ValueRef; - begin - if Storage = O_Storage_Local then - Res := (Kind => ON_Local_Decl, - LLVM => BuildAlloca - (Decl_Builder, Get_LLVM_Type (Atype), Get_Cstring (Ident)), - Dtype => Atype); - 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); - AddFunctionAttr (Decl, NoUnwindAttribute + UWTable); - end if; - - Res := (Kind => ON_Subprg_Decl, - Dtype => Interfaces.Res_Type, - Subprg_Id => Interfaces.Ident, - Nbr_Args => Count, - Subprg_Inters => Interfaces.First_Inter, - LLVM => Decl); - SetFunctionCallConv (Res.LLVM, CCallConv); - - -- Translate interfaces. - Inter := Interfaces.First_Inter; - for I in 1 .. Count loop - Inter.Ival := GetParam (Res.LLVM, I - 1); - SetValueName (Inter.Ival, Get_Cstring (Inter.Ident)); - Inter := Inter.Next; - end loop; - end Finish_Subprogram_Decl; - - --------------------------- - -- Start_Subprogram_Body -- - --------------------------- - - procedure Start_Subprogram_Body (Func : O_Dnode) - is - -- Basic block at function entry that contains all the declarations. - Decl_BB : BasicBlockRef; - begin - if Cur_Func /= Null_ValueRef then - -- No support for nested subprograms. - raise Program_Error; - end if; - - Cur_Func := Func.LLVM; - Cur_Func_Decl := Func; - - pragma Assert (not Unreach); - - 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_Line then - declare - Type_Vals : ValueRefArray (0 .. Func.Nbr_Args); - Types : ValueRef; - Vals : ValueRefArray (0 .. 14); - Arg : O_Inter_Acc; - Subprg_Type : ValueRef; - - Subprg_Vals : ValueRefArray (0 .. 19); - Name : ValueRef; - begin - if Flag_Debug then - -- Create a full subroutine_type. - 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; - Types := MDNode (Type_Vals, Type_Vals'Length); - else - -- Create a dummy subroutine_type. - -- FIXME: create only one subroutine_type ? - Type_Vals (0) := ConstInt (Int32Type, 0, 0); - Types := MDNode (Type_Vals, 1); - end if; - - 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 - Types, -- 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; - - -- Kill current debug metadata, as it is not upto date. - Dbg_Insn_MD := Null_ValueRef; - end; - end if; - - if Flag_Debug then - -- 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; - - Unreach := False; - - Dbg_Current_Scope := Null_ValueRef; - Dbg_Insn_MD := Null_ValueRef; - end Finish_Subprogram_Body; - - ------------------------- - -- New_Debug_Line_Stmt -- - ------------------------- - - procedure New_Debug_Line_Stmt (Line : Natural) is - begin - Dbg_Current_Line := unsigned (Line); - end New_Debug_Line_Stmt; - - ---------------------------- - -- New_Debug_Comment_Stmt -- - ---------------------------- - - procedure New_Debug_Comment_Stmt (Comment : String) is - begin - null; - end New_Debug_Comment_Stmt; - - ------------------------ - -- Start_Declare_Stmt -- - ------------------------ - - procedure Start_Declare_Stmt - is - Br : ValueRef; - pragma Unreferenced (Br); - begin - Create_Declare_Block; - - if Unreach then - return; - end if; - - -- Add a jump to the new BB. - Br := BuildBr (Builder, Cur_Declare_Block.Stmt_Bb); - - PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb); - - if Flag_Debug then - declare - Vals : ValueRefArray (0 .. 5); - begin - Vals := - (ConstInt (Int32Type, DW_TAG_Lexical_Block, 0), - Dbg_Current_Filedir, -- 1 loc - Dbg_Current_Scope, -- 2 context - Dbg_Line, -- 3 line num - ConstInt (Int32Type, 0, 0), -- 4 col - ConstInt (Int32Type, Scope_Uniq_Id, 0)); - Cur_Declare_Block.Dbg_Scope := MDNode (Vals, Vals'Length); - Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; - Scope_Uniq_Id := Scope_Uniq_Id + 1; - end; - end if; - end Start_Declare_Stmt; - - ------------------------- - -- Finish_Declare_Stmt -- - ------------------------- - - procedure Finish_Declare_Stmt - is - Bb : BasicBlockRef; - Br : ValueRef; - Tmp : ValueRef; - pragma Unreferenced (Br, Tmp); - begin - if not Unreach then - -- Create a basic block for the statements after the declare. - Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); - - if Cur_Declare_Block.Stack_Value /= Null_ValueRef then - -- Restore stack pointer. - Tmp := BuildCall (Builder, Stackrestore_Fun, - (1 .. 1 => Cur_Declare_Block.Stack_Value), 1, - Empty_Cstring); - end if; - - -- Execution will continue on the next statement - Br := BuildBr (Builder, Bb); - - PositionBuilderAtEnd (Builder, Bb); - end if; - - -- Do not reset Unread. - - Destroy_Declare_Block; - - Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; - end Finish_Declare_Stmt; - - ----------------------- - -- Start_Association -- - ----------------------- - - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) - is - begin - Assocs := (Subprg => Subprg, - Idx => 0, - Vals => new ValueRefArray (1 .. Subprg.Nbr_Args)); - end Start_Association; - - --------------------- - -- New_Association -- - --------------------- - - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is - begin - Assocs.Idx := Assocs.Idx + 1; - Assocs.Vals (Assocs.Idx) := Val.LLVM; - end New_Association; - - ----------------------- - -- New_Function_Call -- - ----------------------- - - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode - is - Res : ValueRef; - Old_Vals : ValueRefArray_Acc; - begin - if not Unreach then - Res := BuildCall (Builder, Assocs.Subprg.LLVM, - Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); - Old_Vals := Assocs.Vals; - Free (Old_Vals); - Set_Insn_Dbg (Res); - else - Res := Null_ValueRef; - end if; - return O_Enode'(LLVM => Res, Etype => Assocs.Subprg.Dtype); - end New_Function_Call; - - ------------------------ - -- New_Procedure_Call -- - ------------------------ - - procedure New_Procedure_Call (Assocs : in out O_Assoc_List) - is - Res : ValueRef; - 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 - if Unreach then - Block := (Bb => Null_BasicBlockRef); - return; - end if; - - Bb_Then := AppendBasicBlock (Cur_Func, Empty_Cstring); - Block := (Bb => AppendBasicBlock (Cur_Func, Empty_Cstring)); - Res := BuildCondBr (Builder, Cond.LLVM, Bb_Then, Block.Bb); - 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 - if Block.Bb = Null_BasicBlockRef then - -- The IF statement was unreachable. Else part is also - -- unreachable. - return; - end if; - Bb_Next := Null_BasicBlockRef; - end if; - - PositionBuilderAtEnd (Builder, Block.Bb); - - Block := (Bb => Bb_Next); - Unreach := False; - end New_Else_Stmt; - - -------------------- - -- Finish_If_Stmt -- - -------------------- - - procedure Finish_If_Stmt (Block : in out O_If_Block) is - Res : ValueRef; - pragma Unreferenced (Res); - Bb_Next : BasicBlockRef; - begin - if not Unreach then - -- The branch can continue. - if Block.Bb = Null_BasicBlockRef then - Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); - else - Bb_Next := Block.Bb; - end if; - Res := BuildBr (Builder, Bb_Next); - PositionBuilderAtEnd (Builder, Bb_Next); - else - -- The branch doesn't continue. - if Block.Bb /= Null_BasicBlockRef then - -- There is a fall-through (either from the then branch, or - -- there is no else). - Unreach := False; - PositionBuilderAtEnd (Builder, Block.Bb); - else - Unreach := True; - end if; - end if; - end Finish_If_Stmt; - - --------------------- - -- Start_Loop_Stmt -- - --------------------- - - procedure Start_Loop_Stmt (Label : out O_Snode) - is - Res : ValueRef; - pragma Unreferenced (Res); - begin - if Unreach then - Label := (Null_BasicBlockRef, Null_BasicBlockRef); - else - 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 if; - end Start_Loop_Stmt; - - ---------------------- - -- Finish_Loop_Stmt -- - ---------------------- - - procedure Finish_Loop_Stmt (Label : in out O_Snode) is - Res : ValueRef; - pragma Unreferenced (Res); - begin - if not Unreach then - Res := BuildBr (Builder, Label.Bb_Entry); - end if; - if Label.Bb_Exit /= Null_BasicBlockRef then - -- FIXME: always true... - PositionBuilderAtEnd (Builder, Label.Bb_Exit); - Unreach := False; - else - Unreach := True; - end if; - end Finish_Loop_Stmt; - - ------------------- - -- New_Exit_Stmt -- - ------------------- - - procedure New_Exit_Stmt (L : O_Snode) is - Res : ValueRef; - begin - if not Unreach then - Res := BuildBr (Builder, L.Bb_Exit); - Set_Insn_Dbg (Res); - Unreach := True; - end if; - end New_Exit_Stmt; - - ------------------- - -- New_Next_Stmt -- - ------------------- - - procedure New_Next_Stmt (L : O_Snode) is - Res : ValueRef; - begin - if not Unreach then - Res := BuildBr (Builder, L.Bb_Entry); - Set_Insn_Dbg (Res); - Unreach := True; - end if; - end New_Next_Stmt; - - --------------------- - -- Start_Case_Stmt -- - --------------------- - - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is - begin - Block := (BB_Prev => GetInsertBlock (Builder), - Value => Value.LLVM, - Vtype => Value.Etype, - BB_Next => Null_BasicBlockRef, - BB_Others => Null_BasicBlockRef, - BB_Choice => Null_BasicBlockRef, - Nbr_Choices => 0, - Choices => new O_Choice_Array (1 .. 8)); - end Start_Case_Stmt; - - ------------------ - -- Start_Choice -- - ------------------ - - procedure Finish_Branch (Block : in out O_Case_Block) is - Res : ValueRef; - pragma Unreferenced (Res); - begin - -- Close previous branch. - if not Unreach then - if Block.BB_Next = Null_BasicBlockRef then - Block.BB_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); - end if; - Res := BuildBr (Builder, Block.BB_Next); - end if; - end Finish_Branch; - - procedure Start_Choice (Block : in out O_Case_Block) is - Res : ValueRef; - pragma Unreferenced (Res); - begin - if Block.BB_Choice /= Null_BasicBlockRef then - -- Close previous branch. - Finish_Branch (Block); - end if; - - Unreach := False; - Block.BB_Choice := AppendBasicBlock (Cur_Func, Empty_Cstring); - PositionBuilderAtEnd (Builder, Block.BB_Choice); - end Start_Choice; - - --------------------- - -- New_Expr_Choice -- - --------------------- - - procedure Free is new Ada.Unchecked_Deallocation - (O_Choice_Array, O_Choice_Array_Acc); - - procedure New_Choice (Block : in out O_Case_Block; - Low, High : ValueRef) - is - Choices : O_Choice_Array_Acc; - begin - if Block.Nbr_Choices = Block.Choices'Last then - Choices := new O_Choice_Array (1 .. Block.Choices'Last * 2); - Choices (1 .. Block.Choices'Last) := Block.Choices.all; - Free (Block.Choices); - Block.Choices := Choices; - end if; - Block.Nbr_Choices := Block.Nbr_Choices + 1; - Block.Choices (Block.Nbr_Choices) := (Low => Low, - High => High, - Bb => Block.BB_Choice); - end New_Choice; - - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is - begin - New_Choice (Block, Expr.LLVM, Null_ValueRef); - end New_Expr_Choice; - - ---------------------- - -- New_Range_Choice -- - ---------------------- - - procedure New_Range_Choice - (Block : in out O_Case_Block; Low, High : O_Cnode) - is - begin - New_Choice (Block, Low.LLVM, High.LLVM); - end New_Range_Choice; - - ------------------------ - -- New_Default_Choice -- - ------------------------ - - procedure New_Default_Choice (Block : in out O_Case_Block) is - begin - Block.BB_Others := Block.BB_Choice; - end New_Default_Choice; - - ------------------- - -- Finish_Choice -- - ------------------- - - procedure Finish_Choice (Block : in out O_Case_Block) is - begin - null; - end Finish_Choice; - - ---------------------- - -- Finish_Case_Stmt -- - ---------------------- - - procedure Finish_Case_Stmt (Block : in out O_Case_Block) - is - Bb_Default : constant BasicBlockRef := - AppendBasicBlock (Cur_Func, Empty_Cstring); - Bb_Default_Last : BasicBlockRef; - Nbr_Cases : unsigned := 0; - GE, LE : IntPredicate; - Res : ValueRef; - begin - if Block.BB_Choice /= Null_BasicBlockRef then - -- Close previous branch. - Finish_Branch (Block); - end if; - - -- Strategy: use a switch instruction for simple choices, put range - -- choices in the default using if statements. - case Block.Vtype.Kind is - when ON_Unsigned_Type - | ON_Enum_Type - | ON_Boolean_Type => - GE := IntUGE; - LE := IntULE; - when ON_Signed_Type => - GE := IntSGE; - LE := IntSLE; - when others => - raise Program_Error; - end case; - - -- BB for the default case of the LLVM switch. - PositionBuilderAtEnd (Builder, Bb_Default); - Bb_Default_Last := Bb_Default; - - for I in 1 .. Block.Nbr_Choices loop - declare - C : O_Choice_Type renames Block.Choices (I); - begin - if C.High /= Null_ValueRef then - Bb_Default_Last := AppendBasicBlock (Cur_Func, Empty_Cstring); - Res := BuildCondBr (Builder, - BuildAnd (Builder, - BuildICmp (Builder, GE, - Block.Value, C.Low, - Empty_Cstring), - BuildICmp (Builder, LE, - Block.Value, C.High, - Empty_Cstring), - Empty_Cstring), - C.Bb, Bb_Default_Last); - PositionBuilderAtEnd (Builder, Bb_Default_Last); - else - Nbr_Cases := Nbr_Cases + 1; - end if; - end; - end loop; - - -- Insert the switch - PositionBuilderAtEnd (Builder, Block.BB_Prev); - Res := BuildSwitch (Builder, Block.Value, Bb_Default, Nbr_Cases); - for I in 1 .. Block.Nbr_Choices loop - declare - C : O_Choice_Type renames Block.Choices (I); - begin - if C.High = Null_ValueRef then - AddCase (Res, C.Low, C.Bb); - end if; - end; - end loop; - - -- Insert the others. - PositionBuilderAtEnd (Builder, Bb_Default_Last); - if Block.BB_Others /= Null_BasicBlockRef then - Res := BuildBr (Builder, Block.BB_Others); - else - Res := BuildUnreachable (Builder); - end if; - - if Block.BB_Next /= Null_BasicBlockRef then - Unreach := False; - PositionBuilderAtEnd (Builder, Block.BB_Next); - else - Unreach := True; - end if; - - Free (Block.Choices); - end Finish_Case_Stmt; - - function Get_LLVM_Type (Atype : O_Tnode) return TypeRef is - begin - case Atype.Kind is - when ON_Incomplete_Record_Type - | ON_Incomplete_Access_Type => - if Atype.LLVM = Null_TypeRef then - raise Program_Error with "early use of incomplete type"; - end if; - return Atype.LLVM; - when ON_Union_Type - | ON_Scalar_Types - | ON_Access_Type - | ON_Array_Type - | ON_Array_Sub_Type - | ON_Record_Type => - return Atype.LLVM; - when others => - raise Program_Error; - end case; - end Get_LLVM_Type; - - procedure Finish_Debug is - begin - declare - Dbg_Cu : constant String := "llvm.dbg.cu" & ASCII.NUL; - Producer : constant String := "ortho llvm"; - Vals : ValueRefArray (0 .. 12); - begin - Vals := - (ConstInt (Int32Type, DW_TAG_Compile_Unit, 0), - Dbg_Current_Filedir, -- 1 file+dir - ConstInt (Int32Type, 1, 0), -- 2 language (C) - MDString (Producer), -- 3 producer - ConstInt (Int1Type, 0, 0), -- 4 isOpt - MDString (""), -- 5 flags - ConstInt (Int32Type, 0, 0), -- 6 runtime version - Null_ValueRef, -- 7 enum types - Null_ValueRef, -- 8 retained types - Get_Value (Subprg_Nodes), -- 9 subprograms - Get_Value (Global_Nodes), -- 10 global var - Null_ValueRef, -- 11 imported entities - Null_ValueRef); -- 12 split debug - - AddNamedMetadataOperand - (Module, Dbg_Cu'Address, MDNode (Vals, Vals'Length)); - end; - - declare - Module_Flags : constant String := "llvm.module.flags" & ASCII.NUL; - Flags1 : ValueRefArray (0 .. 2); - Flags2 : ValueRefArray (0 .. 2); - begin - Flags1 := (ConstInt (Int32Type, 1, 0), - MDString ("Debug Info Version"), - ConstInt (Int32Type, 1, 0)); - AddNamedMetadataOperand - (Module, Module_Flags'Address, MDNode (Flags1, Flags1'Length)); - Flags2 := (ConstInt (Int32Type, 2, 0), - MDString ("Dwarf Version"), - ConstInt (Int32Type, 2, 0)); - AddNamedMetadataOperand - (Module, Module_Flags'Address, MDNode (Flags2, Flags2'Length)); - end; - end Finish_Debug; - - Dbg_Str : constant String := "dbg"; - - procedure Init is - -- Some predefined types and functions. - I8_Ptr_Type : TypeRef; - begin - Builder := CreateBuilder; - Decl_Builder := CreateBuilder; - Extra_Builder := CreateBuilder; - - -- Create type i8 *. - I8_Ptr_Type := PointerType (Int8Type); - - -- Create intrinsic 'i8 *stacksave (void)'. - Stacksave_Fun := AddFunction - (Module, Stacksave_Name'Address, - FunctionType (I8_Ptr_Type, (1 .. 0 => Null_TypeRef), 0, 0)); - - -- Create intrinsic 'void stackrestore (i8 *)'. - Stackrestore_Fun := AddFunction - (Module, Stackrestore_Name'Address, - FunctionType (VoidType, (1 => I8_Ptr_Type), 1, 0)); - - -- Create intrinsic 'double llvm.copysign.f64 (double, double)'. - Copysign_Fun := AddFunction - (Module, Copysign_Name'Address, - FunctionType (DoubleType, (0 .. 1 => DoubleType), 2, 0)); - - Fp_0_5 := ConstReal (DoubleType, 0.5); - - if Flag_Debug_Line 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; diff --git a/src/ortho/llvm/ortho_llvm.ads b/src/ortho/llvm/ortho_llvm.ads deleted file mode 100644 index 2779d0233..000000000 --- a/src/ortho/llvm/ortho_llvm.ads +++ /dev/null @@ -1,765 +0,0 @@ --- DO NOT MODIFY - this file was generated from: --- ortho_nodes.common.ads and ortho_llvm.private.ads --- --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Interfaces; use Interfaces; -with Interfaces.C; use Interfaces.C; -with Ortho_Ident; use Ortho_Ident; -with LLVM.Core; use LLVM.Core; -with LLVM.TargetMachine; -with LLVM.Target; - --- Interface to create nodes. -package Ortho_LLVM is - procedure Init; - procedure Finish_Debug; - - -- LLVM specific: the module. - Module : ModuleRef; - - -- Descriptor for the layout. - Target_Data : LLVM.Target.TargetDataRef; - - Target_Machine : LLVM.TargetMachine.TargetMachineRef; - - -- Optimization level - Optimization : LLVM.TargetMachine.CodeGenOptLevel := - LLVM.TargetMachine.CodeGenLevelDefault; - - -- Set by -g to generate full debug info. - Flag_Debug : Boolean := False; - - -- Set by -g or -glines to generate line debug info. - Flag_Debug_Line : Boolean := False; - --- Start of common part - - type O_Enode is private; - type O_Cnode is private; - type O_Lnode is private; - type O_Tnode is private; - type O_Snode is private; - type O_Dnode is private; - type O_Gnode is private; - type O_Fnode is private; - - O_Cnode_Null : constant O_Cnode; - O_Dnode_Null : constant O_Dnode; - O_Gnode_Null : constant O_Gnode; - O_Enode_Null : constant O_Enode; - O_Fnode_Null : constant O_Fnode; - O_Lnode_Null : constant O_Lnode; - O_Snode_Null : constant O_Snode; - O_Tnode_Null : constant O_Tnode; - - -- True if the code generated supports nested subprograms. - Has_Nested_Subprograms : constant Boolean; - - ------------------------ - -- 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; - - -- Create a literal with default (null) values. Can only be used to - -- define the initial value of a static decalaration. - function New_Default_Value (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 its record ATYPE. The result is a - -- literal of unsigned type or access 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 (Lvalue : O_Gnode; Atype : O_Tnode) - return O_Cnode; - - -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Lvalue : O_Gnode; 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 - - -- 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_Xor; - 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 or a union. - -- Type of REC must be a record or a union type. - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; - - function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) - return O_Gnode; - - -- 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; - - -- Get a global lvalue from a declaration. - function New_Global (Decl : O_Dnode) return O_Gnode; - - -- 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 or variable. - procedure Start_Init_Value (Decl : in out O_Dnode); - procedure Finish_Init_Value (Decl : 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); - --- End of common part -private - -- No support for nested subprograms in LLVM. - Has_Nested_Subprograms : constant Boolean := False; - - type O_Tnode_Type (<>); - type O_Tnode is access O_Tnode_Type; - O_Tnode_Null : constant O_Tnode := null; - - type ON_Type_Kind is - (ON_No_Type, - ON_Unsigned_Type, ON_Signed_Type, ON_Enum_Type, ON_Boolean_Type, - ON_Float_Type, - ON_Array_Type, ON_Array_Sub_Type, - ON_Incomplete_Record_Type, - ON_Record_Type, ON_Union_Type, - ON_Incomplete_Access_Type, ON_Access_Type); - - subtype ON_Scalar_Types is ON_Type_Kind range - ON_Unsigned_Type .. ON_Float_Type; - - subtype ON_Integer_Types is ON_Type_Kind range - ON_Unsigned_Type .. ON_Boolean_Type; - - type O_Tnode_Type (Kind : ON_Type_Kind := ON_No_Type) is record - LLVM : TypeRef; - Dbg : ValueRef; - case Kind is - when ON_No_Type => - null; - when ON_Union_Type => - Un_Size : unsigned; - Un_Main_Field : TypeRef; - when ON_Access_Type - | ON_Incomplete_Access_Type => - Acc_Type : O_Tnode; - when ON_Scalar_Types => - Scal_Size : Natural; - when ON_Array_Type - | ON_Array_Sub_Type => - -- Type of the element - Arr_El_Type : O_Tnode; - when ON_Record_Type - | ON_Incomplete_Record_Type => - null; - end case; - end record; - - type O_Inter; - type O_Inter_Acc is access O_Inter; - type O_Inter is record - Itype : O_Tnode; - Ival : ValueRef; - Ident : O_Ident; - Next : O_Inter_Acc; - end record; - - type On_Decl_Kind is - (ON_Type_Decl, ON_Completed_Type_Decl, - ON_Const_Decl, - ON_Var_Decl, ON_Local_Decl, ON_Interface_Decl, - ON_Subprg_Decl, - ON_No_Decl); - - type O_Dnode (Kind : On_Decl_Kind := ON_No_Decl) is record - Dtype : O_Tnode; - LLVM : ValueRef; - case Kind is - when ON_Var_Decl - | ON_Const_Decl - | ON_Local_Decl => - null; - when ON_Subprg_Decl => - Subprg_Id : O_Ident; - Nbr_Args : unsigned; - Subprg_Inters : O_Inter_Acc; - when ON_Interface_Decl => - Inter : O_Inter_Acc; - when others => - null; - end case; - end record; - - O_Dnode_Null : constant O_Dnode := (Kind => ON_No_Decl, - Dtype => O_Tnode_Null, - LLVM => Null_ValueRef); - - type OF_Kind is (OF_None, OF_Record, OF_Union); - type O_Fnode (Kind : OF_Kind := OF_None) is record - -- Type of the field. - Ftype : O_Tnode; - case Kind is - when OF_None => - null; - when OF_Record => - -- Field index (starting from 0). - Index : Natural; - when OF_Union => - Utype : TypeRef; - Ptr_Type : TypeRef; - end case; - end record; - - O_Fnode_Null : constant O_Fnode := (Kind => OF_None, - Ftype => O_Tnode_Null); - - type O_Anode_Type; - type O_Anode is access O_Anode_Type; - type O_Anode_Type is record - Next : O_Anode; - Formal : O_Dnode; - Actual : O_Enode; - end record; - - type O_Cnode is record - LLVM : ValueRef; - Ctype : O_Tnode; - end record; - O_Cnode_Null : constant O_Cnode := (LLVM => Null_ValueRef, - Ctype => O_Tnode_Null); - - type O_Enode is record - LLVM : ValueRef; - Etype : O_Tnode; - end record; - O_Enode_Null : constant O_Enode := (LLVM => Null_ValueRef, - Etype => O_Tnode_Null); - - - type O_Lnode is record - -- If True, the LLVM component is the value (used for arguments). - -- If False, the LLVM component is the address of the value (used - -- for everything else). - Direct : Boolean; - LLVM : ValueRef; - Ltype : O_Tnode; - end record; - - O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); - - type O_Gnode is record - LLVM : ValueRef; - Ltype : O_Tnode; - end record; - - O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); - - type O_Snode is record - -- First BB in the loop body. - Bb_Entry : BasicBlockRef; - - -- BB after the loop. - Bb_Exit : BasicBlockRef; - end record; - - O_Snode_Null : constant O_Snode := (Null_BasicBlockRef, - Null_BasicBlockRef); - - type O_Inter_List is record - Ident : O_Ident; - Storage : O_Storage; - Res_Type : O_Tnode; - Nbr_Inter : Natural; - First_Inter, Last_Inter : O_Inter_Acc; - end record; - - type O_Element; - type O_Element_Acc is access O_Element; - type O_Element is record - -- Identifier for the element - Ident : O_Ident; - - -- Type of the element - Etype : O_Tnode; - - -- Next element (in the linked list) - Next : O_Element_Acc; - end record; - - -- Record and union builder. - type O_Element_List is record - Kind : OF_Kind; - - -- Number of fields. - Nbr_Elements : Natural; - - -- For record: the access to the incomplete (but named) type. - Rec_Type : O_Tnode; - - -- For unions: biggest for size and alignment - Size : unsigned; - Align : Unsigned_32; - Align_Type : TypeRef; - - First_Elem, Last_Elem : O_Element_Acc; - end record; - - type ValueRefArray_Acc is access ValueRefArray; - - type O_Record_Aggr_List is record - -- Current number of elements in Vals. - Len : unsigned; - - -- Value of elements. - Vals : ValueRefArray_Acc; - - -- Type of the aggregate. - Atype : O_Tnode; - end record; - - type O_Array_Aggr_List is record - -- Current number of elements in Vals. - Len : unsigned; - - -- Value of elements. - Vals : ValueRefArray_Acc; - El_Type : TypeRef; - - -- Type of the aggregate. - Atype : O_Tnode; - end record; - - type O_Assoc_List is record - Subprg : O_Dnode; - Idx : unsigned; - Vals : ValueRefArray_Acc; - end record; - - type O_Enum_List is record - LLVM : TypeRef; - Num : Natural; - Etype : O_Tnode; - end record; - - type O_Choice_Type is record - Low, High : ValueRef; - Bb : BasicBlockRef; - end record; - - type O_Choice_Array is array (Natural range <>) of O_Choice_Type; - type O_Choice_Array_Acc is access O_Choice_Array; - - type O_Case_Block is record - -- BB before the case. - BB_Prev : BasicBlockRef; - - -- Select expression - Value : ValueRef; - Vtype : O_Tnode; - - -- BB after the case statement. - BB_Next : BasicBlockRef; - - -- BB for others - BB_Others : BasicBlockRef; - - -- BB for the current choice - BB_Choice : BasicBlockRef; - - -- List of choices. - Nbr_Choices : Natural; - Choices : O_Choice_Array_Acc; - end record; - - type O_If_Block is record - -- The next basic block. - -- After the 'If', this is the BB for the else part. If there is no - -- else part, this is the BB for statements after the if. - -- After the 'else', this is the BB for statements after the if. - Bb : BasicBlockRef; - end record; - - function Get_LLVM_Type (Atype : O_Tnode) return TypeRef; -end Ortho_LLVM; diff --git a/src/ortho/llvm/ortho_llvm.private.ads b/src/ortho/llvm/ortho_llvm.private.ads deleted file mode 100644 index ce0685a90..000000000 --- a/src/ortho/llvm/ortho_llvm.private.ads +++ /dev/null @@ -1,321 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Interfaces; use Interfaces; -with Interfaces.C; use Interfaces.C; -with Ortho_Ident; use Ortho_Ident; -with LLVM.Core; use LLVM.Core; -with LLVM.TargetMachine; -with LLVM.Target; - --- Interface to create nodes. -package Ortho_LLVM is - procedure Init; - procedure Finish_Debug; - - -- LLVM specific: the module. - Module : ModuleRef; - - -- Descriptor for the layout. - Target_Data : LLVM.Target.TargetDataRef; - - Target_Machine : LLVM.TargetMachine.TargetMachineRef; - - -- Optimization level - Optimization : LLVM.TargetMachine.CodeGenOptLevel := - LLVM.TargetMachine.CodeGenLevelDefault; - - -- Set by -g to generate full debug info. - Flag_Debug : Boolean := False; - - -- Set by -g or -glines to generate line debug info. - Flag_Debug_Line : Boolean := False; - -private - -- No support for nested subprograms in LLVM. - Has_Nested_Subprograms : constant Boolean := False; - - type O_Tnode_Type (<>); - type O_Tnode is access O_Tnode_Type; - O_Tnode_Null : constant O_Tnode := null; - - type ON_Type_Kind is - (ON_No_Type, - ON_Unsigned_Type, ON_Signed_Type, ON_Enum_Type, ON_Boolean_Type, - ON_Float_Type, - ON_Array_Type, ON_Array_Sub_Type, - ON_Incomplete_Record_Type, - ON_Record_Type, ON_Union_Type, - ON_Incomplete_Access_Type, ON_Access_Type); - - subtype ON_Scalar_Types is ON_Type_Kind range - ON_Unsigned_Type .. ON_Float_Type; - - subtype ON_Integer_Types is ON_Type_Kind range - ON_Unsigned_Type .. ON_Boolean_Type; - - type O_Tnode_Type (Kind : ON_Type_Kind := ON_No_Type) is record - LLVM : TypeRef; - Dbg : ValueRef; - case Kind is - when ON_No_Type => - null; - when ON_Union_Type => - Un_Size : unsigned; - Un_Main_Field : TypeRef; - when ON_Access_Type - | ON_Incomplete_Access_Type => - Acc_Type : O_Tnode; - when ON_Scalar_Types => - Scal_Size : Natural; - when ON_Array_Type - | ON_Array_Sub_Type => - -- Type of the element - Arr_El_Type : O_Tnode; - when ON_Record_Type - | ON_Incomplete_Record_Type => - null; - end case; - end record; - - type O_Inter; - type O_Inter_Acc is access O_Inter; - type O_Inter is record - Itype : O_Tnode; - Ival : ValueRef; - Ident : O_Ident; - Next : O_Inter_Acc; - end record; - - type On_Decl_Kind is - (ON_Type_Decl, ON_Completed_Type_Decl, - ON_Const_Decl, - ON_Var_Decl, ON_Local_Decl, ON_Interface_Decl, - ON_Subprg_Decl, - ON_No_Decl); - - type O_Dnode (Kind : On_Decl_Kind := ON_No_Decl) is record - Dtype : O_Tnode; - LLVM : ValueRef; - case Kind is - when ON_Var_Decl - | ON_Const_Decl - | ON_Local_Decl => - null; - when ON_Subprg_Decl => - Subprg_Id : O_Ident; - Nbr_Args : unsigned; - Subprg_Inters : O_Inter_Acc; - when ON_Interface_Decl => - Inter : O_Inter_Acc; - when others => - null; - end case; - end record; - - O_Dnode_Null : constant O_Dnode := (Kind => ON_No_Decl, - Dtype => O_Tnode_Null, - LLVM => Null_ValueRef); - - type OF_Kind is (OF_None, OF_Record, OF_Union); - type O_Fnode (Kind : OF_Kind := OF_None) is record - -- Type of the field. - Ftype : O_Tnode; - case Kind is - when OF_None => - null; - when OF_Record => - -- Field index (starting from 0). - Index : Natural; - when OF_Union => - Utype : TypeRef; - Ptr_Type : TypeRef; - end case; - end record; - - O_Fnode_Null : constant O_Fnode := (Kind => OF_None, - Ftype => O_Tnode_Null); - - type O_Anode_Type; - type O_Anode is access O_Anode_Type; - type O_Anode_Type is record - Next : O_Anode; - Formal : O_Dnode; - Actual : O_Enode; - end record; - - type O_Cnode is record - LLVM : ValueRef; - Ctype : O_Tnode; - end record; - O_Cnode_Null : constant O_Cnode := (LLVM => Null_ValueRef, - Ctype => O_Tnode_Null); - - type O_Enode is record - LLVM : ValueRef; - Etype : O_Tnode; - end record; - O_Enode_Null : constant O_Enode := (LLVM => Null_ValueRef, - Etype => O_Tnode_Null); - - - type O_Lnode is record - -- If True, the LLVM component is the value (used for arguments). - -- If False, the LLVM component is the address of the value (used - -- for everything else). - Direct : Boolean; - LLVM : ValueRef; - Ltype : O_Tnode; - end record; - - O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); - - type O_Gnode is record - LLVM : ValueRef; - Ltype : O_Tnode; - end record; - - O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); - - type O_Snode is record - -- First BB in the loop body. - Bb_Entry : BasicBlockRef; - - -- BB after the loop. - Bb_Exit : BasicBlockRef; - end record; - - O_Snode_Null : constant O_Snode := (Null_BasicBlockRef, - Null_BasicBlockRef); - - type O_Inter_List is record - Ident : O_Ident; - Storage : O_Storage; - Res_Type : O_Tnode; - Nbr_Inter : Natural; - First_Inter, Last_Inter : O_Inter_Acc; - end record; - - type O_Element; - type O_Element_Acc is access O_Element; - type O_Element is record - -- Identifier for the element - Ident : O_Ident; - - -- Type of the element - Etype : O_Tnode; - - -- Next element (in the linked list) - Next : O_Element_Acc; - end record; - - -- Record and union builder. - type O_Element_List is record - Kind : OF_Kind; - - -- Number of fields. - Nbr_Elements : Natural; - - -- For record: the access to the incomplete (but named) type. - Rec_Type : O_Tnode; - - -- For unions: biggest for size and alignment - Size : unsigned; - Align : Unsigned_32; - Align_Type : TypeRef; - - First_Elem, Last_Elem : O_Element_Acc; - end record; - - type ValueRefArray_Acc is access ValueRefArray; - - type O_Record_Aggr_List is record - -- Current number of elements in Vals. - Len : unsigned; - - -- Value of elements. - Vals : ValueRefArray_Acc; - - -- Type of the aggregate. - Atype : O_Tnode; - end record; - - type O_Array_Aggr_List is record - -- Current number of elements in Vals. - Len : unsigned; - - -- Value of elements. - Vals : ValueRefArray_Acc; - El_Type : TypeRef; - - -- Type of the aggregate. - Atype : O_Tnode; - end record; - - type O_Assoc_List is record - Subprg : O_Dnode; - Idx : unsigned; - Vals : ValueRefArray_Acc; - end record; - - type O_Enum_List is record - LLVM : TypeRef; - Num : Natural; - Etype : O_Tnode; - end record; - - type O_Choice_Type is record - Low, High : ValueRef; - Bb : BasicBlockRef; - end record; - - type O_Choice_Array is array (Natural range <>) of O_Choice_Type; - type O_Choice_Array_Acc is access O_Choice_Array; - - type O_Case_Block is record - -- BB before the case. - BB_Prev : BasicBlockRef; - - -- Select expression - Value : ValueRef; - Vtype : O_Tnode; - - -- BB after the case statement. - BB_Next : BasicBlockRef; - - -- BB for others - BB_Others : BasicBlockRef; - - -- BB for the current choice - BB_Choice : BasicBlockRef; - - -- List of choices. - Nbr_Choices : Natural; - Choices : O_Choice_Array_Acc; - end record; - - type O_If_Block is record - -- The next basic block. - -- After the 'If', this is the BB for the else part. If there is no - -- else part, this is the BB for statements after the if. - -- After the 'else', this is the BB for statements after the if. - Bb : BasicBlockRef; - end record; - - function Get_LLVM_Type (Atype : O_Tnode) return TypeRef; -end Ortho_LLVM; diff --git a/src/ortho/llvm/ortho_nodes.ads b/src/ortho/llvm/ortho_nodes.ads deleted file mode 100644 index 34d1dbbc9..000000000 --- a/src/ortho/llvm/ortho_nodes.ads +++ /dev/null @@ -1,20 +0,0 @@ --- LLVM back-end for ortho. --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ortho_LLVM; -package Ortho_Nodes renames Ortho_LLVM; diff --git a/src/ortho/llvm35/Makefile b/src/ortho/llvm35/Makefile new file mode 100644 index 000000000..5abe441da --- /dev/null +++ b/src/ortho/llvm35/Makefile @@ -0,0 +1,32 @@ +ortho_srcdir=.. +GNATFLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwael +CXX=clang++ +LLVM_CONFIG=llvm-config +GNATMAKE=gnatmake +SED=sed +BE=llvm35 + +all: $(ortho_exec) + +$(ortho_exec): $(ortho_srcdir)/llvm35/ortho_llvm.ads force llvm-cbindings.o + $(GNATMAKE) -o $@ -aI$(ortho_srcdir)/llvm -aI$(ortho_srcdir) \ + $(GNATFLAGS) ortho_code_main -bargs -E \ + -largs llvm-cbindings.o --LINK=$(CXX) \ + $(LDFLAGS) `$(LLVM_CONFIG) --ldflags --libs --system-libs` + +llvm-cbindings.o: $(ortho_srcdir)/llvm35/llvm-cbindings.cpp + $(CXX) -c `$(LLVM_CONFIG) --cxxflags` -o $@ $< + +clean: + $(RM) -f *.o *.ali ortho_code_main + $(RM) b~*.ad? *~ + +distclean: clean + + +force: + +.PHONY: force all clean + +ORTHO_BASENAME=ortho_llvm +include $(ortho_srcdir)/Makefile.inc diff --git a/src/ortho/llvm35/llvm-analysis.ads b/src/ortho/llvm35/llvm-analysis.ads new file mode 100644 index 000000000..bfecec579 --- /dev/null +++ b/src/ortho/llvm35/llvm-analysis.ads @@ -0,0 +1,53 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with LLVM.Core; use LLVM.Core; + +package LLVM.Analysis is + type VerifierFailureAction is + ( + AbortProcessAction, -- verifier will print to stderr and abort() + PrintMessageAction, -- verifier will print to stderr and return 1 + ReturnStatusAction -- verifier will just return 1 + ); + pragma Convention (C, VerifierFailureAction); + + -- Verifies that a module is valid, taking the specified action if not. + -- Optionally returns a human-readable description of any invalid + -- constructs. + -- OutMessage must be disposed with DisposeMessage. */ + function VerifyModule(M : ModuleRef; + Action : VerifierFailureAction; + OutMessage : access Cstring) + return Integer; + + -- Verifies that a single function is valid, taking the specified + -- action. Useful for debugging. + function VerifyFunction(Fn : ValueRef; Action : VerifierFailureAction) + return Integer; + + -- Open up a ghostview window that displays the CFG of the current function. + -- Useful for debugging. + procedure ViewFunctionCFG(Fn : ValueRef); + procedure ViewFunctionCFGOnly(Fn : ValueRef); +private + pragma Import (C, VerifyModule, "LLVMVerifyModule"); + pragma Import (C, VerifyFunction, "LLVMVerifyFunction"); + pragma Import (C, ViewFunctionCFG, "LLVMViewFunctionCFG"); + pragma Import (C, ViewFunctionCFGOnly, "LLVMViewFunctionCFGOnly"); +end LLVM.Analysis; + diff --git a/src/ortho/llvm35/llvm-bitwriter.ads b/src/ortho/llvm35/llvm-bitwriter.ads new file mode 100644 index 000000000..3f9c518e4 --- /dev/null +++ b/src/ortho/llvm35/llvm-bitwriter.ads @@ -0,0 +1,34 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with LLVM.Core; use LLVM.Core; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Interfaces.C; use Interfaces.C; + +package LLVM.BitWriter is + -- Writes a module to an open file descriptor. Returns 0 on success. + -- Closes the Handle. Use dup first if this is not what you want. + function WriteBitcodeToFileHandle(M : ModuleRef; Handle : File_Descriptor) + return int; + + -- Writes a module to the specified path. Returns 0 on success. + function WriteBitcodeToFile(M : ModuleRef; Path : Cstring) + return int; +private + pragma Import (C, WriteBitcodeToFileHandle, "LLVMWriteBitcodeToFileHandle"); + pragma Import (C, WriteBitcodeToFile, "LLVMWriteBitcodeToFile"); +end LLVM.BitWriter; diff --git a/src/ortho/llvm35/llvm-cbindings.cpp b/src/ortho/llvm35/llvm-cbindings.cpp new file mode 100644 index 000000000..e4d666ade --- /dev/null +++ b/src/ortho/llvm35/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(unwrap(N)); + MD->replaceOperandWith (i, unwrap(V)); +} + +void *LLVMGetPointerToFunction(LLVMExecutionEngineRef EE, LLVMValueRef Func) +{ + return unwrap(EE)->getPointerToFunction(unwrap(Func)); +} + +} diff --git a/src/ortho/llvm35/llvm-core.ads b/src/ortho/llvm35/llvm-core.ads new file mode 100644 index 000000000..7ec85c284 --- /dev/null +++ b/src/ortho/llvm35/llvm-core.ads @@ -0,0 +1,1283 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System; +with Interfaces.C; use Interfaces.C; +use Interfaces; + +package LLVM.Core is + + subtype Cstring is System.Address; + function "=" (L, R : Cstring) return Boolean renames System."="; + -- Null_Cstring : constant Cstring := Null_Address; + Nul : constant String := (1 => Character'Val (0)); + Empty_Cstring : constant Cstring := Nul'Address; + + -- The top-level container for all LLVM global data. See the LLVMContext + -- class. + type ContextRef is new System.Address; + + -- The top-level container for all other LLVM Intermediate + -- Representation (IR) objects. See the llvm::Module class. + type ModuleRef is new System.Address; + + subtype Bool is int; + + -- Each value in the LLVM IR has a type, an LLVMTypeRef. See the llvm::Type + -- class. + type TypeRef is new System.Address; + Null_TypeRef : constant TypeRef := TypeRef (System.Null_Address); + type TypeRefArray is array (unsigned range <>) of TypeRef; + pragma Convention (C, TypeRefArray); + + type ValueRef is new System.Address; + Null_ValueRef : constant ValueRef := ValueRef (System.Null_Address); + type ValueRefArray is array (unsigned range <>) of ValueRef; -- Ada + pragma Convention (C, ValueRefArray); + + type BasicBlockRef is new System.Address; + Null_BasicBlockRef : constant BasicBlockRef := + BasicBlockRef (System.Null_Address); + type BasicBlockRefArray is + array (unsigned range <>) of BasicBlockRef; -- Ada + pragma Convention (C, BasicBlockRefArray); + + type BuilderRef is new System.Address; + + -- Used to provide a module to JIT or interpreter. + -- See the llvm::MemoryBuffer class. + type MemoryBufferRef is new System.Address; + + -- See the llvm::PassManagerBase class. + type PassManagerRef is new System.Address; + + type Attribute is new unsigned; + ZExtAttribute : constant Attribute := 2**0; + SExtAttribute : constant Attribute := 2**1; + NoReturnAttribute : constant Attribute := 2**2; + InRegAttribute : constant Attribute := 2**3; + StructRetAttribute : constant Attribute := 2**4; + NoUnwindAttribute : constant Attribute := 2**5; + NoAliasAttribute : constant Attribute := 2**6; + ByValAttribute : constant Attribute := 2**7; + NestAttribute : constant Attribute := 2**8; + ReadNoneAttribute : constant Attribute := 2**9; + ReadOnlyAttribute : constant Attribute := 2**10; + NoInlineAttribute : constant Attribute := 2**11; + AlwaysInlineAttribute : constant Attribute := 2**12; + OptimizeForSizeAttribute : constant Attribute := 2**13; + StackProtectAttribute : constant Attribute := 2**14; + StackProtectReqAttribute : constant Attribute := 2**15; + Alignment : constant Attribute := 31 * 2**16; + NoCaptureAttribute : constant Attribute := 2**21; + NoRedZoneAttribute : constant Attribute := 2**22; + NoImplicitFloatAttribute : constant Attribute := 2**23; + NakedAttribute : constant Attribute := 2**24; + InlineHintAttribute : constant Attribute := 2**25; + StackAlignment : constant Attribute := 7 * 2**26; + ReturnsTwice : constant Attribute := 2**29; + UWTable : constant Attribute := 2**30; + NonLazyBind : constant Attribute := 2**31; + + type TypeKind is + ( + VoidTypeKind, -- type with no size + HalfTypeKind, -- 16 bit floating point type + FloatTypeKind, -- 32 bit floating point type + DoubleTypeKind, -- 64 bit floating point type + X86_FP80TypeKind, -- 80 bit floating point type (X87) + FP128TypeKind, -- 128 bit floating point type (112-bit mantissa) + PPC_FP128TypeKind, -- 128 bit floating point type (two 64-bits) + LabelTypeKind, -- Labels + IntegerTypeKind, -- Arbitrary bit width integers + FunctionTypeKind, -- Functions + StructTypeKind, -- Structures + ArrayTypeKind, -- Arrays + PointerTypeKind, -- Pointers + VectorTypeKind, -- SIMD 'packed' format, or other vector type + MetadataTypeKind, -- Metadata + X86_MMXTypeKind -- X86 MMX + ); + pragma Convention (C, TypeKind); + + type Linkage is + ( + ExternalLinkage, -- Externally visible function + AvailableExternallyLinkage, + LinkOnceAnyLinkage, -- Keep one copy of function when linking (inline) + LinkOnceODRLinkage, -- Same, but only replaced by someth equivalent. + LinkOnceODRAutoHideLinkage, -- Obsolete + WeakAnyLinkage, -- Keep one copy of function when linking (weak) + WeakODRLinkage, -- Same, but only replaced by someth equivalent. + AppendingLinkage, -- Special purpose, only applies to global arrays + InternalLinkage, -- Rename collisions when linking (static func) + PrivateLinkage, -- Like Internal, but omit from symbol table + DLLImportLinkage, -- Obsolete + DLLExportLinkage, -- Obsolete + ExternalWeakLinkage,-- ExternalWeak linkage description + GhostLinkage, -- Obsolete + CommonLinkage, -- Tentative definitions + LinkerPrivateLinkage, -- Like Private, but linker removes. + LinkerPrivateWeakLinkage -- Like LinkerPrivate, but is weak. + ); + pragma Convention (C, Linkage); + + type Visibility is + ( + DefaultVisibility, -- The GV is visible + HiddenVisibility, -- The GV is hidden + ProtectedVisibility -- The GV is protected + ); + pragma Convention (C, Visibility); + + type CallConv is new unsigned; + CCallConv : constant CallConv := 0; + FastCallConv : constant CallConv := 8; + ColdCallConv : constant CallConv := 9; + X86StdcallCallConv : constant CallConv := 64; + X86FastcallCallConv : constant CallConv := 6; + + type IntPredicate is new unsigned; + IntEQ : constant IntPredicate := 32; -- equal + IntNE : constant IntPredicate := 33; -- not equal + IntUGT : constant IntPredicate := 34; -- unsigned greater than + IntUGE : constant IntPredicate := 35; -- unsigned greater or equal + IntULT : constant IntPredicate := 36; -- unsigned less than + IntULE : constant IntPredicate := 37; -- unsigned less or equal + IntSGT : constant IntPredicate := 38; -- signed greater than + IntSGE : constant IntPredicate := 39; -- signed greater or equal + IntSLT : constant IntPredicate := 40; -- signed less than + IntSLE : constant IntPredicate := 41; -- signed less or equal + + type RealPredicate is + ( + RealPredicateFalse, -- Always false (always folded) + RealOEQ, -- True if ordered and equal + RealOGT, -- True if ordered and greater than + RealOGE, -- True if ordered and greater than or equal + RealOLT, -- True if ordered and less than + RealOLE, -- True if ordered and less than or equal + RealONE, -- True if ordered and operands are unequal + RealORD, -- True if ordered (no nans) + RealUNO, -- True if unordered: isnan(X) | isnan(Y) + RealUEQ, -- True if unordered or equal + RealUGT, -- True if unordered or greater than + RealUGE, -- True if unordered, greater than, or equal + RealULT, -- True if unordered or less than + RealULE, -- True if unordered, less than, or equal + RealUNE, -- True if unordered or not equal + RealPredicateTrue -- Always true (always folded) + ); + + -- Error handling ---------------------------------------------------- + + procedure DisposeMessage (Message : Cstring); + + + -- Context + + -- Create a new context. + -- Every call to this function should be paired with a call to + -- LLVMContextDispose() or the context will leak memory. + function ContextCreate return ContextRef; + + -- Obtain the global context instance. + function GetGlobalContext return ContextRef; + + -- Destroy a context instance. + -- This should be called for every call to LLVMContextCreate() or memory + -- will be leaked. + procedure ContextDispose (C : ContextRef); + + 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; + + -- See Module::dump. + procedure DumpType(T : TypeRef); + + -- Values ------------------------------------------------------------ + -- The bulk of LLVM's object model consists of values, which comprise a very + -- rich type hierarchy. + -- + -- values: + -- constants: + -- scalar constants + -- composite contants + -- globals: + -- global variable + -- function + -- alias + -- basic blocks + + -- Operations on all values + function TypeOf(Val : ValueRef) return TypeRef; + function GetValueName(Val : ValueRef) return Cstring; + procedure SetValueName(Val : ValueRef; Name : Cstring); + procedure DumpValue(Val : ValueRef); + + -- Operations on constants of any type + function ConstNull(Ty : TypeRef) return ValueRef; -- All zero + function ConstAllOnes(Ty : TypeRef) return ValueRef; -- Int or Vec + function GetUndef(Ty : TypeRef) return ValueRef; + function IsConstant(Val : ValueRef) return int; + function IsNull(Val : ValueRef) return int; + function IsUndef(Val : ValueRef) return int; + + -- Convert value instances between types. + -- + -- Internally, an LLVMValueRef is "pinned" to a specific type. This + -- series of functions allows you to cast an instance to a specific + -- type. + -- + -- If the cast is not valid for the specified type, NULL is returned. + -- + -- @see llvm::dyn_cast_or_null<> + function IsAInstruction (Val : ValueRef) return ValueRef; + + -- Operations on scalar constants + function ConstInt(IntTy : TypeRef; N : Unsigned_64; SignExtend : int) + return ValueRef; + function ConstReal(RealTy : TypeRef; N : double) return ValueRef; + function ConstRealOfString(RealTy : TypeRef; Text : Cstring) + return ValueRef; + + + -- Obtain the zero extended value for an integer constant value. + -- @see llvm::ConstantInt::getZExtValue() + function ConstIntGetZExtValue (ConstantVal : ValueRef) return Unsigned_64; + + -- Operations on composite constants + function ConstString(Str : Cstring; + Length : unsigned; DontNullTerminate : int) + return ValueRef; + function ConstArray(ElementTy : TypeRef; + ConstantVals : ValueRefArray; Length : unsigned) + return ValueRef; + function ConstStruct(ConstantVals : ValueRefArray; + Count : unsigned; packed : int) return ValueRef; + + -- Create a non-anonymous ConstantStruct from values. + -- @see llvm::ConstantStruct::get() + function ConstNamedStruct(StructTy : TypeRef; + ConstantVals : ValueRefArray; + Count : unsigned) return ValueRef; + + function ConstVector(ScalarConstantVals : ValueRefArray; Size : unsigned) + return ValueRef; + + -- Constant expressions + function SizeOf(Ty : TypeRef) return ValueRef; + function AlignOf(Ty : TypeRef) return ValueRef; + + function ConstNeg(ConstantVal : ValueRef) return ValueRef; + function ConstNot(ConstantVal : ValueRef) return ValueRef; + function ConstAdd(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstSub(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstMul(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstUDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstSDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstFDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstURem(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstSRem(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstFRem(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstAnd(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstOr(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstXor(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstICmp(Predicate : IntPredicate; + LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstFCmp(Predicate : RealPredicate; + LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstShl(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstLShr(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstAShr(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstGEP(ConstantVal : ValueRef; + ConstantIndices : ValueRefArray; NumIndices : unsigned) + return ValueRef; + function ConstTrunc(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstSExt(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstZExt(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstFPTrunc(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstFPExt(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstUIToFP(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstSIToFP(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstFPToUI(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstFPToSI(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstPtrToInt(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstIntToPtr(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstBitCast(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + + function ConstTruncOrBitCast(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + + function ConstSelect(ConstantCondition : ValueRef; + ConstantIfTrue : ValueRef; + ConstantIfFalse : ValueRef) return ValueRef; + function ConstExtractElement(VectorConstant : ValueRef; + IndexConstant : ValueRef) return ValueRef; + function ConstInsertElement(VectorConstant : ValueRef; + ElementValueConstant : ValueRef; + IndexConstant : ValueRef) return ValueRef; + function ConstShuffleVector(VectorAConstant : ValueRef; + VectorBConstant : ValueRef; + MaskConstant : ValueRef) return ValueRef; + + -- Operations on global variables, functions, and aliases (globals) + function GetGlobalParent(Global : ValueRef) return ModuleRef; + function IsDeclaration(Global : ValueRef) return int; + function GetLinkage(Global : ValueRef) return Linkage; + procedure SetLinkage(Global : ValueRef; Link : Linkage); + function GetSection(Global : ValueRef) return Cstring; + procedure SetSection(Global : ValueRef; Section : Cstring); + function GetVisibility(Global : ValueRef) return Visibility; + procedure SetVisibility(Global : ValueRef; Viz : Visibility); + function GetAlignment(Global : ValueRef) return unsigned; + procedure SetAlignment(Global : ValueRef; Bytes : unsigned); + + -- Operations on global variables + function AddGlobal(M : ModuleRef; Ty : TypeRef; Name : Cstring) + return ValueRef; + function GetNamedGlobal(M : ModuleRef; Name : Cstring) return ValueRef; + function GetFirstGlobal(M : ModuleRef) return ValueRef; + function GetLastGlobal(M : ModuleRef) return ValueRef; + function GetNextGlobal(GlobalVar : ValueRef) return ValueRef; + function GetPreviousGlobal(GlobalVar : ValueRef) return ValueRef; + procedure DeleteGlobal(GlobalVar : ValueRef); + function GetInitializer(GlobalVar : ValueRef) return ValueRef; + procedure SetInitializer(GlobalVar : ValueRef; ConstantVal : ValueRef); + function IsThreadLocal(GlobalVar : ValueRef) return int; + procedure SetThreadLocal(GlobalVar : ValueRef; IsThreadLocal : int); + function IsGlobalConstant(GlobalVar : ValueRef) return int; + procedure SetGlobalConstant(GlobalVar : ValueRef; IsConstant : int); + + -- 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, DumpType, "LLVMDumpType"); + + pragma Import (C, TypeOf, "LLVMTypeOf"); + pragma Import (C, GetValueName, "LLVMGetValueName"); + pragma Import (C, SetValueName, "LLVMSetValueName"); + pragma Import (C, DumpValue, "LLVMDumpValue"); + + pragma Import (C, ConstNull, "LLVMConstNull"); + pragma Import (C, ConstAllOnes, "LLVMConstAllOnes"); + pragma Import (C, GetUndef, "LLVMGetUndef"); + pragma Import (C, IsConstant, "LLVMIsConstant"); + pragma Import (C, IsNull, "LLVMIsNull"); + pragma Import (C, IsUndef, "LLVMIsUndef"); + pragma Import (C, IsAInstruction, "LLVMIsAInstruction"); + + pragma Import (C, ConstInt, "LLVMConstInt"); + pragma Import (C, ConstReal, "LLVMConstReal"); + pragma Import (C, ConstIntGetZExtValue, "LLVMConstIntGetZExtValue"); + pragma Import (C, ConstRealOfString, "LLVMConstRealOfString"); + pragma Import (C, ConstString, "LLVMConstString"); + pragma Import (C, ConstArray, "LLVMConstArray"); + pragma Import (C, ConstStruct, "LLVMConstStruct"); + pragma Import (C, ConstNamedStruct, "LLVMConstNamedStruct"); + pragma Import (C, ConstVector, "LLVMConstVector"); + + pragma Import (C, SizeOf, "LLVMSizeOf"); + pragma Import (C, AlignOf, "LLVMAlignOf"); + pragma Import (C, ConstNeg, "LLVMConstNeg"); + pragma Import (C, ConstNot, "LLVMConstNot"); + pragma Import (C, ConstAdd, "LLVMConstAdd"); + pragma Import (C, ConstSub, "LLVMConstSub"); + pragma Import (C, ConstMul, "LLVMConstMul"); + pragma Import (C, ConstUDiv, "LLVMConstUDiv"); + pragma Import (C, ConstSDiv, "LLVMConstSDiv"); + pragma Import (C, ConstFDiv, "LLVMConstFDiv"); + pragma Import (C, ConstURem, "LLVMConstURem"); + pragma Import (C, ConstSRem, "LLVMConstSRem"); + pragma Import (C, ConstFRem, "LLVMConstFRem"); + pragma Import (C, ConstAnd, "LLVMConstAnd"); + pragma Import (C, ConstOr, "LLVMConstOr"); + pragma Import (C, ConstXor, "LLVMConstXor"); + pragma Import (C, ConstICmp, "LLVMConstICmp"); + pragma Import (C, ConstFCmp, "LLVMConstFCmp"); + pragma Import (C, ConstShl, "LLVMConstShl"); + pragma Import (C, ConstLShr, "LLVMConstLShr"); + pragma Import (C, ConstAShr, "LLVMConstAShr"); + pragma Import (C, ConstGEP, "LLVMConstGEP"); + pragma Import (C, ConstTrunc, "LLVMConstTrunc"); + pragma Import (C, ConstSExt, "LLVMConstSExt"); + pragma Import (C, ConstZExt, "LLVMConstZExt"); + pragma Import (C, ConstFPTrunc, "LLVMConstFPTrunc"); + pragma Import (C, ConstFPExt, "LLVMConstFPExt"); + pragma Import (C, ConstUIToFP, "LLVMConstUIToFP"); + pragma Import (C, ConstSIToFP, "LLVMConstSIToFP"); + pragma Import (C, ConstFPToUI, "LLVMConstFPToUI"); + pragma Import (C, ConstFPToSI, "LLVMConstFPToSI"); + pragma Import (C, ConstPtrToInt, "LLVMConstPtrToInt"); + pragma Import (C, ConstIntToPtr, "LLVMConstIntToPtr"); + pragma Import (C, ConstBitCast, "LLVMConstBitCast"); + pragma Import (C, ConstTruncOrBitCast, "LLVMConstTruncOrBitCast"); + pragma Import (C, ConstSelect, "LLVMConstSelect"); + pragma Import (C, ConstExtractElement, "LLVMConstExtractElement"); + pragma Import (C, ConstInsertElement, "LLVMConstInsertElement"); + pragma Import (C, ConstShuffleVector, "LLVMConstShuffleVector"); + + pragma Import (C, GetGlobalParent, "LLVMGetGlobalParent"); + pragma Import (C, IsDeclaration, "LLVMIsDeclaration"); + pragma Import (C, GetLinkage, "LLVMGetLinkage"); + pragma Import (C, SetLinkage, "LLVMSetLinkage"); + pragma Import (C, GetSection, "LLVMGetSection"); + pragma Import (C, SetSection, "LLVMSetSection"); + pragma Import (C, GetVisibility, "LLVMGetVisibility"); + pragma Import (C, SetVisibility, "LLVMSetVisibility"); + pragma Import (C, GetAlignment, "LLVMGetAlignment"); + pragma Import (C, SetAlignment, "LLVMSetAlignment"); + + pragma Import (C, AddGlobal, "LLVMAddGlobal"); + pragma Import (C, GetNamedGlobal, "LLVMGetNamedGlobal"); + pragma Import (C, GetFirstGlobal, "LLVMGetFirstGlobal"); + pragma Import (C, GetLastGlobal, "LLVMGetLastGlobal"); + pragma Import (C, GetNextGlobal, "LLVMGetNextGlobal"); + pragma Import (C, GetPreviousGlobal, "LLVMGetPreviousGlobal"); + pragma Import (C, DeleteGlobal, "LLVMDeleteGlobal"); + pragma Import (C, GetInitializer, "LLVMGetInitializer"); + pragma Import (C, SetInitializer, "LLVMSetInitializer"); + pragma Import (C, IsThreadLocal, "LLVMIsThreadLocal"); + pragma Import (C, SetThreadLocal, "LLVMSetThreadLocal"); + pragma Import (C, IsGlobalConstant, "LLVMIsGlobalConstant"); + pragma Import (C, SetGlobalConstant, "LLVMSetGlobalConstant"); + + pragma Import (C, 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/src/ortho/llvm35/llvm-executionengine.ads b/src/ortho/llvm35/llvm-executionengine.ads new file mode 100644 index 000000000..72d4cda2f --- /dev/null +++ b/src/ortho/llvm35/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/src/ortho/llvm35/llvm-target.ads b/src/ortho/llvm35/llvm-target.ads new file mode 100644 index 000000000..b7c35848a --- /dev/null +++ b/src/ortho/llvm35/llvm-target.ads @@ -0,0 +1,84 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System; +with Interfaces; use Interfaces; +with Interfaces.C; use Interfaces.C; +with LLVM.Core; use LLVM.Core; + +package LLVM.Target is + + type TargetDataRef is new System.Address; + + -- LLVMInitializeNativeTarget - The main program should call this function + -- to initialize the native target corresponding to the host. This is + -- useful for JIT applications to ensure that the target gets linked in + -- correctly. + procedure InitializeNativeTarget; + pragma Import (C, InitializeNativeTarget, + "LLVMInitializeNativeTarget_noinline"); + + -- LLVMInitializeNativeTargetAsmPrinter - The main program should call this + -- function to initialize the printer for the native target corresponding + -- to the host. + procedure InitializeNativeAsmPrinter; + pragma Import (C, InitializeNativeAsmPrinter, + "LLVMInitializeNativeAsmPrinter_noinline"); + + -- Creates target data from a target layout string. + -- See the constructor llvm::DataLayout::DataLayout. + function CreateTargetData (StringRep : Cstring) return TargetDataRef; + pragma Import (C, CreateTargetData, "LLVMCreateTargetData"); + + -- Adds target data information to a pass manager. This does not take + -- ownership of the target data. + -- See the method llvm::PassManagerBase::add. + procedure AddTargetData(TD : TargetDataRef; PM : PassManagerRef); + pragma Import (C, AddTargetData, "LLVMAddTargetData"); + + -- Converts target data to a target layout string. The string must be + -- disposed with LLVMDisposeMessage. + -- See the constructor llvm::DataLayout::DataLayout. */ + function CopyStringRepOfTargetData(TD :TargetDataRef) return Cstring; + pragma Import (C, CopyStringRepOfTargetData, + "LLVMCopyStringRepOfTargetData"); + + -- Returns the pointer size in bytes for a target. + -- See the method llvm::DataLayout::getPointerSize. + function PointerSize(TD : TargetDataRef) return unsigned; + pragma Import (C, PointerSize, "LLVMPointerSize"); + + -- Computes the ABI size of a type in bytes for a target. + -- See the method llvm::DataLayout::getTypeAllocSize. + function ABISizeOfType (TD : TargetDataRef; Ty: TypeRef) return Unsigned_64; + pragma Import (C, ABISizeOfType, "LLVMABISizeOfType"); + + -- Computes the ABI alignment of a type in bytes for a target. + -- See the method llvm::DataLayout::getTypeABISize. + function ABIAlignmentOfType (TD : TargetDataRef; Ty: TypeRef) + return Unsigned_32; + pragma Import (C, ABIAlignmentOfType, "LLVMABIAlignmentOfType"); + + -- Computes the byte offset of the indexed struct element for a target. + -- See the method llvm::StructLayout::getElementContainingOffset. + function OffsetOfElement(TD : TargetDataRef; + StructTy : TypeRef; + Element : Unsigned_32) + return Unsigned_64; + pragma Import (C, OffsetOfElement, "LLVMOffsetOfElement"); + +end LLVM.Target; diff --git a/src/ortho/llvm35/llvm-targetmachine.ads b/src/ortho/llvm35/llvm-targetmachine.ads new file mode 100644 index 000000000..cbf074940 --- /dev/null +++ b/src/ortho/llvm35/llvm-targetmachine.ads @@ -0,0 +1,122 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System; +with LLVM.Core; use LLVM.Core; +with LLVM.Target; use LLVM.Target; + +package LLVM.TargetMachine is + + type TargetMachineRef is new System.Address; + Null_TargetMachineRef : constant TargetMachineRef := + TargetMachineRef (System.Null_Address); + + type TargetRef is new System.Address; + Null_TargetRef : constant TargetRef := TargetRef (System.Null_Address); + + type CodeGenOptLevel is (CodeGenLevelNone, + CodeGenLevelLess, + CodeGenLevelDefault, + CodeGenLevelAggressive); + pragma Convention (C, CodeGenOptLevel); + + type RelocMode is (RelocDefault, + RelocStatic, + RelocPIC, + RelocDynamicNoPic); + pragma Convention (C, RelocMode); + + type CodeModel is (CodeModelDefault, + CodeModelJITDefault, + CodeModelSmall, + CodeModelKernel, + CodeModelMedium, + CodeModelLarge); + pragma Convention (C, CodeModel); + + type CodeGenFileType is (AssemblyFile, + ObjectFile); + pragma Convention (C, CodeGenFileType); + + -- Returns the first llvm::Target in the registered targets list. + function GetFirstTarget return TargetRef; + pragma Import (C, GetFirstTarget, "LLVMGetFirstTarget"); + + -- Returns the next llvm::Target given a previous one (or null if there's + -- none) */ + function GetNextTarget(T : TargetRef) return TargetRef; + pragma Import (C, GetNextTarget, "LLVMGetNextTarget"); + + -- Target + + -- Finds the target corresponding to the given name and stores it in T. + -- Returns 0 on success. + function GetTargetFromName (Name : Cstring) return TargetRef; + pragma Import (C, GetTargetFromName, "LLVMGetTargetFromName"); + + -- Finds the target corresponding to the given triple and stores it in T. + -- Returns 0 on success. Optionally returns any error in ErrorMessage. + -- Use LLVMDisposeMessage to dispose the message. + -- Ada: ErrorMessage is the address of a Cstring. + function GetTargetFromTriple + (Triple : Cstring; T : access TargetRef; ErrorMessage : access Cstring) + return Bool; + pragma Import (C, GetTargetFromTriple, "LLVMGetTargetFromTriple"); + + -- Returns the name of a target. See llvm::Target::getName + function GetTargetName (T: TargetRef) return Cstring; + pragma Import (C, GetTargetName, "LLVMGetTargetName"); + + -- Returns the description of a target. See llvm::Target::getDescription + function GetTargetDescription (T : TargetRef) return Cstring; + pragma Import (C, GetTargetDescription, "LLVMGetTargetDescription"); + + -- Target Machine ---------------------------------------------------- + + -- Creates a new llvm::TargetMachine. See llvm::Target::createTargetMachine + + function CreateTargetMachine(T : TargetRef; + Triple : Cstring; + CPU : Cstring; + Features : Cstring; + Level : CodeGenOptLevel; + Reloc : RelocMode; + CM : CodeModel) + return TargetMachineRef; + pragma Import (C, CreateTargetMachine, "LLVMCreateTargetMachine"); + + -- Returns the llvm::DataLayout used for this llvm:TargetMachine. + function GetTargetMachineData(T : TargetMachineRef) return TargetDataRef; + pragma Import (C, GetTargetMachineData, "LLVMGetTargetMachineData"); + + -- Emits an asm or object file for the given module to the filename. This + -- wraps several c++ only classes (among them a file stream). Returns any + -- error in ErrorMessage. Use LLVMDisposeMessage to dispose the message. + function TargetMachineEmitToFile(T : TargetMachineRef; + M : ModuleRef; + Filename : Cstring; + Codegen : CodeGenFileType; + ErrorMessage : access Cstring) + return Bool; + pragma Import (C, TargetMachineEmitToFile, + "LLVMTargetMachineEmitToFile"); + + -- Get a triple for the host machine as a string. The result needs to be + -- disposed with LLVMDisposeMessage. + function GetDefaultTargetTriple return Cstring; + pragma Import (C, GetDefaultTargetTriple, "LLVMGetDefaultTargetTriple"); +end LLVM.TargetMachine; diff --git a/src/ortho/llvm35/llvm-transforms-scalar.ads b/src/ortho/llvm35/llvm-transforms-scalar.ads new file mode 100644 index 000000000..0f23ce87e --- /dev/null +++ b/src/ortho/llvm35/llvm-transforms-scalar.ads @@ -0,0 +1,169 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with LLVM.Core; use LLVM.Core; + +package LLVM.Transforms.Scalar is + -- See llvm::createAggressiveDCEPass function. + procedure AddAggressiveDCEPass(PM : PassManagerRef); + pragma Import (C, AddAggressiveDCEPass, "LLVMAddAggressiveDCEPass"); + + -- See llvm::createCFGSimplificationPass function. + procedure AddCFGSimplificationPass(PM : PassManagerRef); + pragma Import (C, AddCFGSimplificationPass, "LLVMAddCFGSimplificationPass"); + + -- See llvm::createDeadStoreEliminationPass function. + procedure AddDeadStoreEliminationPass(PM : PassManagerRef); + pragma Import (C, AddDeadStoreEliminationPass, + "LLVMAddDeadStoreEliminationPass"); + + -- See llvm::createScalarizerPass function. + procedure AddScalarizerPass(PM : PassManagerRef); + pragma Import (C, AddScalarizerPass, "LLVMAddScalarizerPass"); + + -- See llvm::createGVNPass function. + procedure AddGVNPass(PM : PassManagerRef); + pragma Import (C, AddGVNPass, "LLVMAddGVNPass"); + + -- See llvm::createIndVarSimplifyPass function. + procedure AddIndVarSimplifyPass(PM : PassManagerRef); + pragma Import (C, AddIndVarSimplifyPass, "LLVMAddIndVarSimplifyPass"); + + -- See llvm::createInstructionCombiningPass function. + procedure AddInstructionCombiningPass(PM : PassManagerRef); + pragma Import (C, AddInstructionCombiningPass, + "LLVMAddInstructionCombiningPass"); + + -- See llvm::createJumpThreadingPass function. + procedure AddJumpThreadingPass(PM : PassManagerRef); + pragma Import (C, AddJumpThreadingPass, "LLVMAddJumpThreadingPass"); + + -- See llvm::createLICMPass function. + procedure AddLICMPass(PM : PassManagerRef); + pragma Import (C, AddLICMPass, "LLVMAddLICMPass"); + + -- See llvm::createLoopDeletionPass function. + procedure AddLoopDeletionPass(PM : PassManagerRef); + pragma Import (C, AddLoopDeletionPass, "LLVMAddLoopDeletionPass"); + + -- See llvm::createLoopIdiomPass function + procedure AddLoopIdiomPass(PM : PassManagerRef); + pragma Import (C, AddLoopIdiomPass, "LLVMAddLoopIdiomPass"); + + -- See llvm::createLoopRotatePass function. + procedure AddLoopRotatePass(PM : PassManagerRef); + pragma Import (C, AddLoopRotatePass, "LLVMAddLoopRotatePass"); + + -- See llvm::createLoopRerollPass function. + procedure AddLoopRerollPass(PM : PassManagerRef); + pragma Import (C, AddLoopRerollPass, "LLVMAddLoopRerollPass"); + + -- See llvm::createLoopUnrollPass function. + procedure AddLoopUnrollPass(PM : PassManagerRef); + pragma Import (C, AddLoopUnrollPass, "LLVMAddLoopUnrollPass"); + + -- See llvm::createLoopUnswitchPass function. + procedure AddLoopUnswitchPass(PM : PassManagerRef); + pragma Import (C, AddLoopUnswitchPass, "LLVMAddLoopUnswitchPass"); + + -- See llvm::createMemCpyOptPass function. + procedure AddMemCpyOptPass(PM : PassManagerRef); + pragma Import (C, AddMemCpyOptPass, "LLVMAddMemCpyOptPass"); + + -- See llvm::createPartiallyInlineLibCallsPass function. + procedure AddPartiallyInlineLibCallsPass(PM : PassManagerRef); + pragma Import (C, AddPartiallyInlineLibCallsPass, + "LLVMAddPartiallyInlineLibCallsPass"); + + -- See llvm::createPromoteMemoryToRegisterPass function. + procedure AddPromoteMemoryToRegisterPass(PM : PassManagerRef); + pragma Import (C, AddPromoteMemoryToRegisterPass, + "LLVMAddPromoteMemoryToRegisterPass"); + + -- See llvm::createReassociatePass function. + procedure AddReassociatePass(PM : PassManagerRef); + pragma Import (C, AddReassociatePass, "LLVMAddReassociatePass"); + + -- See llvm::createSCCPPass function. + procedure AddSCCPPass(PM : PassManagerRef); + pragma Import (C, AddSCCPPass, "LLVMAddSCCPPass"); + + -- See llvm::createScalarReplAggregatesPass function. + procedure AddScalarReplAggregatesPass(PM : PassManagerRef); + pragma Import (C, AddScalarReplAggregatesPass, + "LLVMAddScalarReplAggregatesPass"); + + -- See llvm::createScalarReplAggregatesPass function. + procedure AddScalarReplAggregatesPassSSA(PM : PassManagerRef); + pragma Import (C, AddScalarReplAggregatesPassSSA, + "LLVMAddScalarReplAggregatesPassSSA"); + + -- See llvm::createScalarReplAggregatesPass function. + procedure AddScalarReplAggregatesPassWithThreshold + (PM : PassManagerRef; Threshold : Integer); + pragma Import (C, AddScalarReplAggregatesPassWithThreshold, + "LLVMAddScalarReplAggregatesPassWithThreshold"); + + -- See llvm::createSimplifyLibCallsPass function. + procedure AddSimplifyLibCallsPass(PM : PassManagerRef); + pragma Import (C, AddSimplifyLibCallsPass, "LLVMAddSimplifyLibCallsPass"); + + -- See llvm::createTailCallEliminationPass function. + procedure AddTailCallEliminationPass(PM : PassManagerRef); + pragma Import (C, AddTailCallEliminationPass, + "LLVMAddTailCallEliminationPass"); + + -- See llvm::createConstantPropagationPass function. + procedure AddConstantPropagationPass(PM : PassManagerRef); + pragma Import (C, AddConstantPropagationPass, + "LLVMAddConstantPropagationPass"); + + -- See llvm::demotePromoteMemoryToRegisterPass function. + procedure AddDemoteMemoryToRegisterPass(PM : PassManagerRef); + pragma Import (C, AddDemoteMemoryToRegisterPass, + "LLVMAddDemoteMemoryToRegisterPass"); + + -- See llvm::createVerifierPass function. + procedure AddVerifierPass(PM : PassManagerRef); + pragma Import (C, AddVerifierPass, "LLVMAddVerifierPass"); + + -- See llvm::createCorrelatedValuePropagationPass function + procedure AddCorrelatedValuePropagationPass(PM : PassManagerRef); + pragma Import (C, AddCorrelatedValuePropagationPass, + "LLVMAddCorrelatedValuePropagationPass"); + + -- See llvm::createEarlyCSEPass function + procedure AddEarlyCSEPass(PM : PassManagerRef); + pragma Import (C, AddEarlyCSEPass, "LLVMAddEarlyCSEPass"); + + -- See llvm::createLowerExpectIntrinsicPass function + procedure AddLowerExpectIntrinsicPass(PM : PassManagerRef); + pragma Import (C, AddLowerExpectIntrinsicPass, + "LLVMAddLowerExpectIntrinsicPass"); + + -- See llvm::createTypeBasedAliasAnalysisPass function + procedure AddTypeBasedAliasAnalysisPass(PM : PassManagerRef); + pragma Import (C, AddTypeBasedAliasAnalysisPass, + "LLVMAddTypeBasedAliasAnalysisPass"); + + -- See llvm::createBasicAliasAnalysisPass function + procedure AddBasicAliasAnalysisPass(PM : PassManagerRef); + pragma Import (C, AddBasicAliasAnalysisPass, + "LLVMAddBasicAliasAnalysisPass"); +end LLVM.Transforms.Scalar; + + diff --git a/src/ortho/llvm35/llvm-transforms.ads b/src/ortho/llvm35/llvm-transforms.ads new file mode 100644 index 000000000..d5a8011ce --- /dev/null +++ b/src/ortho/llvm35/llvm-transforms.ads @@ -0,0 +1,21 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package LLVM.Transforms is + pragma Pure (LLVM.Transforms); +end LLVM.Transforms; diff --git a/src/ortho/llvm35/llvm.ads b/src/ortho/llvm35/llvm.ads new file mode 100644 index 000000000..80d036b84 --- /dev/null +++ b/src/ortho/llvm35/llvm.ads @@ -0,0 +1,21 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package LLVM is + pragma Pure (LLVM); +end LLVM; diff --git a/src/ortho/llvm35/ortho_code_main.adb b/src/ortho/llvm35/ortho_code_main.adb new file mode 100644 index 000000000..4b6dbd856 --- /dev/null +++ b/src/ortho/llvm35/ortho_code_main.adb @@ -0,0 +1,395 @@ +-- LLVM back-end for ortho - Main subprogram. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Unchecked_Deallocation; +with Ada.Unchecked_Conversion; +with Ada.Text_IO; use Ada.Text_IO; + +with Ortho_Front; use Ortho_Front; +with LLVM.BitWriter; +with LLVM.Core; use LLVM.Core; +with LLVM.ExecutionEngine; use LLVM.ExecutionEngine; +with LLVM.Target; use LLVM.Target; +with LLVM.TargetMachine; use LLVM.TargetMachine; +with LLVM.Analysis; +with LLVM.Transforms.Scalar; +with Ortho_LLVM; use Ortho_LLVM; +with Interfaces; +with Interfaces.C; use Interfaces.C; + +procedure Ortho_Code_Main is + -- Name of the output filename (given by option '-o'). + Output : String_Acc := null; + + type Output_Kind_Type is (Output_Llvm, Output_Bytecode, + Output_Assembly, Output_Object); + Output_Kind : Output_Kind_Type := Output_Object; + + -- 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 : RelocMode := RelocDefault; + + function To_String (C : Cstring) return String is + function Strlen (C : Cstring) return Natural; + pragma Import (C, Strlen); + + subtype Fat_String is String (Positive); + type Fat_String_Acc is access Fat_String; + + function To_Fat_String_Acc is new + Ada.Unchecked_Conversion (Cstring, Fat_String_Acc); + begin + return To_Fat_String_Acc (C)(1 .. Strlen (C)); + end To_String; + + Codegen : CodeGenFileType := ObjectFile; + + Msg : aliased Cstring; +begin + Ortho_Front.Init; + + -- Decode options. + First_File := Natural'Last; + Optind := 1; + while Optind <= Argc loop + declare + Arg : constant String := Argument (Optind); + begin + if Arg (1) = '-' then + if Arg = "--dump-llvm" then + Flag_Dump_Llvm := True; + elsif Arg = "-o" then + if Optind = Argc then + Put_Line (Standard_Error, "error: missing filename to '-o'"); + return; + end if; + Output := new String'(Argument (Optind + 1) & ASCII.Nul); + Optind := Optind + 1; + elsif Arg = "-quiet" then + -- Skip silently. + null; + elsif Arg = "-S" then + Output_Kind := Output_Assembly; + Codegen := AssemblyFile; + elsif Arg = "-c" then + Output_Kind := Output_Object; + Codegen := ObjectFile; + elsif Arg = "-O0" then + Optimization := CodeGenLevelNone; + elsif Arg = "-O1" or else Arg = "-O" then + Optimization := CodeGenLevelLess; + elsif Arg = "-O2" then + Optimization := CodeGenLevelDefault; + elsif Arg = "-O3" then + Optimization := CodeGenLevelAggressive; + elsif Arg = "-fpic" or Arg = "-fPIC" then + Reloc := RelocPIC; + elsif Arg = "-fno-pic" then + Reloc := RelocStatic; + 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 = "-glines" + or else Arg = "-gline-tables-only" + then + Flag_Debug_Line := True; + elsif Arg = "-g" then + Flag_Debug_Line := True; + 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 + Opt_Arg := null; + if Optind < Argument_Count then + declare + Arg1 : constant String := Argument (Optind + 1); + begin + if Arg1 (Arg1'First) /= '-' then + Opt_Arg := new String'(Arg1); + end if; + end; + end if; + + Res := Ortho_Front.Decode_Option (Opt, Opt_Arg); + case Res is + when 0 => + Put_Line (Standard_Error, + "unknown option '" & Arg & "'"); + return; + when 1 => + null; + when 2 => + Optind := Optind + 1; + when others => + raise Program_Error; + end case; + Unchecked_Deallocation (Opt); + Unchecked_Deallocation (Opt_Arg); + end; + end if; + else + First_File := Optind; + exit; + end if; + end; + Optind := Optind + 1; + end loop; + + -- Link with LLVM libraries. + InitializeNativeTarget; + InitializeNativeAsmPrinter; + + LinkInJIT; + + Module := ModuleCreateWithName (Module_Name'Address); + + 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.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_Line then + Ortho_LLVM.Finish_Debug; + end if; + + -- Ortho_Mcode.Finish; + + if Flag_Dump_Llvm then + DumpModule (Module); + end if; + + -- Verify module. + if False then + if LLVM.Analysis.VerifyModule + (Module, LLVM.Analysis.PrintMessageAction, Msg'Access) /= 0 + then + DisposeMessage (Msg); + raise Program_Error; + end if; + end if; + + if Optimization > CodeGenLevelNone then + declare + use LLVM.Transforms.Scalar; + Global_Manager : constant Boolean := False; + Pass_Manager : PassManagerRef; + Res : Bool; + pragma Unreferenced (Res); + A_Func : ValueRef; + begin + if Global_Manager then + Pass_Manager := CreatePassManager; + else + Pass_Manager := CreateFunctionPassManagerForModule (Module); + end if; + + LLVM.Target.AddTargetData (Target_Data, Pass_Manager); + AddPromoteMemoryToRegisterPass (Pass_Manager); + AddCFGSimplificationPass (Pass_Manager); + + if Global_Manager then + Res := RunPassManager (Pass_Manager, Module); + else + A_Func := GetFirstFunction (Module); + while A_Func /= Null_ValueRef loop + Res := RunFunctionPassManager (Pass_Manager, A_Func); + A_Func := GetNextFunction (A_Func); + end loop; + end if; + end; + end if; + + if Output /= null then + declare + Error : Boolean; + begin + Msg := Empty_Cstring; + + case Output_Kind is + when Output_Assembly + | Output_Object => + Error := LLVM.TargetMachine.TargetMachineEmitToFile + (Target_Machine, Module, + Output.all'Address, Codegen, Msg'Access) /= 0; + when Output_Bytecode => + Error := LLVM.BitWriter.WriteBitcodeToFile + (Module, Output.all'Address) /= 0; + when Output_Llvm => + Error := PrintModuleToFile + (Module, Output.all'Address, Msg'Access) /= 0; + end case; + if Error then + Put_Line (Standard_Error, + "error while writing to " & Output.all); + if Msg /= Empty_Cstring then + Put_Line (Standard_Error, + "message: " & To_String (Msg)); + DisposeMessage (Msg); + end if; + Set_Exit_Status (2); + return; + end if; + end; + 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 + DumpModule (Module); + end if; + + Set_Exit_Status (Success); +exception + when others => + Set_Exit_Status (2); + raise; +end Ortho_Code_Main; diff --git a/src/ortho/llvm35/ortho_ident.adb b/src/ortho/llvm35/ortho_ident.adb new file mode 100644 index 000000000..e7b650539 --- /dev/null +++ b/src/ortho/llvm35/ortho_ident.adb @@ -0,0 +1,134 @@ +-- LLVM back-end for ortho. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package body Ortho_Ident is + type Chunk (Max : Positive); + type Chunk_Acc is access Chunk; + + type Chunk (Max : Positive) is record + Prev : Chunk_Acc; + Len : Natural := 0; + S : String (1 .. Max); + end record; + + Cur_Chunk : Chunk_Acc := null; + + subtype Fat_String is String (Positive); + + function Get_Identifier (Str : String) return O_Ident + is + Len : constant Natural := Str'Length; + Max : Positive; + Org : Positive; + begin + if Cur_Chunk = null or else Cur_Chunk.Len + Len >= Cur_Chunk.Max then + if Cur_Chunk = null then + Max := 32 * 1024; + else + Max := 2 * Cur_Chunk.Max; + end if; + if Len + 2 > Max then + Max := 2 * (Len + 2); + end if; + declare + New_Chunk : Chunk_Acc; + begin + -- Do not use allocator by expression, as we don't want to + -- initialize S. + New_Chunk := new Chunk (Max); + New_Chunk.Len := 0; + New_Chunk.Prev := Cur_Chunk; + Cur_Chunk := New_Chunk; + end; + end if; + + Org := Cur_Chunk.Len + 1; + Cur_Chunk.S (Org .. Org + Len - 1) := Str; + Cur_Chunk.S (Org + Len) := ASCII.NUL; + Cur_Chunk.Len := Org + Len; + + return (Addr => Cur_Chunk.S (Org)'Address); + end Get_Identifier; + + function Is_Equal (L, R : O_Ident) return Boolean + is + begin + return L = R; + end Is_Equal; + + function Get_String_Length (Id : O_Ident) return Natural + is + Str : Fat_String; + pragma Import (Ada, Str); + for Str'Address use Id.Addr; + begin + for I in Str'Range loop + if Str (I) = ASCII.NUL then + return I - 1; + end if; + end loop; + raise Program_Error; + end Get_String_Length; + + function Get_String (Id : O_Ident) return String + is + Str : Fat_String; + pragma Import (Ada, Str); + for Str'Address use Id.Addr; + begin + for I in Str'Range loop + if Str (I) = ASCII.NUL then + return Str (1 .. I - 1); + end if; + end loop; + raise Program_Error; + end Get_String; + + function Get_Cstring (Id : O_Ident) return System.Address is + begin + return Id.Addr; + end Get_Cstring; + + function Is_Equal (Id : O_Ident; Str : String) return Boolean + is + Istr : Fat_String; + pragma Import (Ada, Istr); + for Istr'Address use Id.Addr; + + Str_Len : constant Natural := Str'Length; + begin + for I in Istr'Range loop + if Istr (I) = ASCII.NUL then + return I - 1 = Str_Len; + end if; + if I > Str_Len then + return False; + end if; + if Istr (I) /= Str (Str'First + I - 1) then + return False; + end if; + end loop; + raise Program_Error; + end Is_Equal; + + function Is_Nul (Id : O_Ident) return Boolean is + begin + return Id = O_Ident_Nul; + end Is_Nul; + +end Ortho_Ident; diff --git a/src/ortho/llvm35/ortho_ident.ads b/src/ortho/llvm35/ortho_ident.ads new file mode 100644 index 000000000..7d3955c02 --- /dev/null +++ b/src/ortho/llvm35/ortho_ident.ads @@ -0,0 +1,42 @@ +-- LLVM back-end for ortho. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System; + +package Ortho_Ident is + type O_Ident is private; + + function Get_Identifier (Str : String) return O_Ident; + function Is_Equal (L, R : O_Ident) return Boolean; + function Is_Equal (Id : O_Ident; Str : String) return Boolean; + function Is_Nul (Id : O_Ident) return Boolean; + function Get_String (Id : O_Ident) return String; + function Get_String_Length (Id : O_Ident) return Natural; + + -- Note: the address is always valid. + function Get_Cstring (Id : O_Ident) return System.Address; + + O_Ident_Nul : constant O_Ident; + +private + type O_Ident is record + Addr : System.Address; + end record; + O_Ident_Nul : constant O_Ident := (Addr => System.Null_Address); + + pragma Inline (Get_Cstring); +end Ortho_Ident; diff --git a/src/ortho/llvm35/ortho_jit.adb b/src/ortho/llvm35/ortho_jit.adb new file mode 100644 index 000000000..fdda667d9 --- /dev/null +++ b/src/ortho/llvm35/ortho_jit.adb @@ -0,0 +1,151 @@ +-- 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; use Ortho_LLVM; +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 execution engine"); + raise Program_Error; + end if; + + Target_Data := GetExecutionEngineTargetData (Ortho_LLVM.Jit.Engine); + SetDataLayout (Module, CopyStringRepOfTargetData (Target_Data)); + + Ortho_LLVM.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; + + function Get_Jit_Name return String is + begin + return "LLVM"; + end Get_Jit_Name; + +end Ortho_Jit; diff --git a/src/ortho/llvm35/ortho_llvm-jit.adb b/src/ortho/llvm35/ortho_llvm-jit.adb new file mode 100644 index 000000000..9155a02c7 --- /dev/null +++ b/src/ortho/llvm35/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/src/ortho/llvm35/ortho_llvm-jit.ads b/src/ortho/llvm35/ortho_llvm-jit.ads new file mode 100644 index 000000000..5296e2ed8 --- /dev/null +++ b/src/ortho/llvm35/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/src/ortho/llvm35/ortho_llvm.adb b/src/ortho/llvm35/ortho_llvm.adb new file mode 100644 index 000000000..250870224 --- /dev/null +++ b/src/ortho/llvm35/ortho_llvm.adb @@ -0,0 +1,3096 @@ +-- LLVM back-end for ortho. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with LLVM.Target; use LLVM.Target; +with GNAT.Directory_Operations; + +package body Ortho_LLVM is + -- The current function for LLVM (needed to add new basic blocks). + Cur_Func : ValueRef; + + -- The current function node (needed for return type). + Cur_Func_Decl : O_Dnode; + + -- Whether the code is currently unreachable. LLVM doesn't accept basic + -- blocks that cannot be reached (using trivial rules). So we need to + -- discard instructions after a return, a next or an exit statement. + Unreach : Boolean; + + -- Builder for statements. + Builder : BuilderRef; + + -- Builder for declarations (local variables). + Decl_Builder : BuilderRef; + + -- Temporary builder. + Extra_Builder : BuilderRef; + + -- Declaration of llvm.dbg.declare + Llvm_Dbg_Declare : ValueRef; + + Debug_ID : unsigned; + + Current_Directory : constant String := + GNAT.Directory_Operations.Get_Current_Dir; + + -- Additional data for declare blocks. + type Declare_Block_Type; + type Declare_Block_Acc is access Declare_Block_Type; + + type Declare_Block_Type is record + -- First basic block of the declare. + Stmt_Bb : BasicBlockRef; + + -- Stack pointer at entry of the block. This value has to be restore + -- when leaving the block (either normally or via exit/next). Set only + -- if New_Alloca was used. + -- FIXME: TODO: restore stack pointer on exit/next stmts. + Stack_Value : ValueRef; + + -- Debug data for the scope of the declare block. + Dbg_Scope : ValueRef; + + -- Previous element in the stack. + Prev : Declare_Block_Acc; + end record; + + -- Current declare block. + Cur_Declare_Block : Declare_Block_Acc; + + -- Chain of unused blocks to be recycled. + Old_Declare_Block : Declare_Block_Acc; + + Stacksave_Fun : ValueRef; + Stacksave_Name : constant String := "llvm.stacksave" & ASCII.NUL; + Stackrestore_Fun : ValueRef; + Stackrestore_Name : constant String := "llvm.stackrestore" & ASCII.NUL; + Copysign_Fun : ValueRef; + Copysign_Name : constant String := "llvm.copysign.f64" & ASCII.NUL; + Fp_0_5 : ValueRef; + + -- 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_Union_Type : constant := DW_Version + 16#17#; + 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 := Null_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_Line and then IsAInstruction (Insn) /= Null_ValueRef then + if Dbg_Current_Line /= Dbg_Insn_MD_Line then + declare + Vals : ValueRefArray (0 .. 3); + begin + Vals := (Dbg_Line, + ConstInt (Int32Type, 0, 0), -- col + Dbg_Current_Scope, -- context + Null_ValueRef); -- inline + Dbg_Insn_MD := MDNode (Vals, Vals'Length); + Dbg_Insn_MD_Line := Dbg_Current_Line; + end; + end if; + SetMetadata (Insn, Debug_ID, Dbg_Insn_MD); + end if; + end Set_Insn_Dbg; + + procedure Dbg_Create_Variable (Tag : Unsigned_32; + Ident : O_Ident; + Vtype : O_Tnode; + Argno : Natural; + Addr : ValueRef) + is + Vals : ValueRefArray (0 .. 7); + Str : constant ValueRef := MDString (Ident); + Call_Vals : ValueRefArray (0 .. 1); + Call : ValueRef; + begin + Vals := (ConstInt (Int32Type, Unsigned_64 (Tag), 0), + Dbg_Current_Scope, + Str, + Dbg_Current_File, + ConstInt (Int32Type, + Unsigned_64 (Dbg_Current_Line) + + Unsigned_64 (Argno) * 2 ** 24, 0), + Vtype.Dbg, + ConstInt (Int32Type, 0, 0), -- flags + ConstInt (Int32Type, 0, 0)); + + Call_Vals := (MDNode ((0 => Addr), 1), + MDNode (Vals, Vals'Length)); + Call := BuildCall (Decl_Builder, Llvm_Dbg_Declare, + Call_Vals, Call_Vals'Length, Empty_Cstring); + Set_Insn_Dbg (Call); + end Dbg_Create_Variable; + + procedure Create_Declare_Block + is + Res : Declare_Block_Acc; + begin + -- Try to recycle an unused record. + if Old_Declare_Block /= null then + Res := Old_Declare_Block; + Old_Declare_Block := Res.Prev; + else + -- Create a new one if no unused records. + Res := new Declare_Block_Type; + end if; + + -- Chain. + Res.all := (Stmt_Bb => Null_BasicBlockRef, + Stack_Value => Null_ValueRef, + Dbg_Scope => Null_ValueRef, + Prev => Cur_Declare_Block); + Cur_Declare_Block := Res; + + if not Unreach then + Res.Stmt_Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); + end if; + end Create_Declare_Block; + + procedure Destroy_Declare_Block + is + Blk : constant Declare_Block_Acc := Cur_Declare_Block; + begin + -- Unchain. + Cur_Declare_Block := Blk.Prev; + + -- Put on the recyle list. + Blk.Prev := Old_Declare_Block; + Old_Declare_Block := Blk; + end Destroy_Declare_Block; + + ----------------------- + -- Start_Record_Type -- + ----------------------- + + procedure Start_Record_Type (Elements : out O_Element_List) is + begin + Elements := (Kind => OF_Record, + Nbr_Elements => 0, + Rec_Type => O_Tnode_Null, + Size => 0, + Align => 0, + Align_Type => Null_TypeRef, + First_Elem => null, + Last_Elem => null); + end Start_Record_Type; + + ---------------------- + -- New_Record_Field -- + ---------------------- + + procedure Add_Field + (Elements : in out O_Element_List; Ident : O_Ident; Etype : O_Tnode) + is + O_El : O_Element_Acc; + begin + Elements.Nbr_Elements := Elements.Nbr_Elements + 1; + O_El := new O_Element'(Next => null, + Etype => Etype, + Ident => Ident); + if Elements.First_Elem = null then + Elements.First_Elem := O_El; + else + Elements.Last_Elem.Next := O_El; + end if; + Elements.Last_Elem := O_El; + end Add_Field; + + procedure New_Record_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; + Etype : O_Tnode) is + begin + El := (Kind => OF_Record, + Index => Elements.Nbr_Elements, + Ftype => Etype); + Add_Field (Elements, Ident, Etype); + end New_Record_Field; + + ------------------------ + -- Finish_Record_Type -- + ------------------------ + + procedure Add_Dbg_Fields + (Elements : in out O_Element_List; Res : O_Tnode) + is + Count : constant unsigned := unsigned (Elements.Nbr_Elements); + Fields : ValueRefArray (1 .. Count); + Vals : ValueRefArray (0 .. 9); + Ftype : TypeRef; + Fields_Arr : ValueRef; + Off : Unsigned_64; + El : O_Element_Acc; + begin + El := Elements.First_Elem; + for I in Fields'Range loop + Ftype := Get_LLVM_Type (El.Etype); + case Elements.Kind is + when OF_Record => + Off := 8 * OffsetOfElement (Target_Data, + Res.LLVM, Unsigned_32 (I - 1)); + when OF_Union => + Off := 0; + when OF_None => + raise Program_Error; + end case; + 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, Off, 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 Add_Dbg_Fields; + + procedure Free_Elements (Elements : in out O_Element_List) + is + procedure Free is new Ada.Unchecked_Deallocation + (O_Element, O_Element_Acc); + El : O_Element_Acc; + Next_El : O_Element_Acc; + begin + -- Free elements + El := Elements.First_Elem; + while El /= null loop + Next_El := El.Next; + Free (El); + El := Next_El; + end loop; + Elements.First_Elem := null; + Elements.Last_Elem := null; + end Free_Elements; + + procedure Finish_Record_Type + (Elements : in out O_Element_List; Res : out O_Tnode) + is + Count : constant unsigned := unsigned (Elements.Nbr_Elements); + El : O_Element_Acc; + Types : TypeRefArray (1 .. Count); + begin + El := Elements.First_Elem; + for I in Types'Range loop + Types (I) := Get_LLVM_Type (El.Etype); + El := El.Next; + end loop; + + if Elements.Rec_Type /= null then + -- Completion + StructSetBody (Elements.Rec_Type.LLVM, Types, Count, 0); + Res := Elements.Rec_Type; + else + Res := new O_Tnode_Type'(Kind => ON_Record_Type, + LLVM => StructType (Types, Count, 0), + Dbg => Null_ValueRef); + end if; + + if Flag_Debug then + Add_Dbg_Fields (Elements, Res); + end if; + + Free_Elements (Elements); + end Finish_Record_Type; + + -------------------------------- + -- New_Uncomplete_Record_Type -- + -------------------------------- + + procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is + begin + -- LLVM type will be created when the type is declared, as the name + -- is required (for unification). + Res := new O_Tnode_Type'(Kind => ON_Incomplete_Record_Type, + LLVM => Null_TypeRef, + Dbg => Null_ValueRef); + end New_Uncomplete_Record_Type; + + ---------------------------------- + -- Start_Uncomplete_Record_Type -- + ---------------------------------- + + procedure Start_Uncomplete_Record_Type + (Res : O_Tnode; + Elements : out O_Element_List) + is + begin + if Res.Kind /= ON_Incomplete_Record_Type then + raise Program_Error; + end if; + Elements := (Kind => OF_Record, + Nbr_Elements => 0, + Rec_Type => Res, + Size => 0, + Align => 0, + Align_Type => Null_TypeRef, + First_Elem => null, + Last_Elem => null); + end Start_Uncomplete_Record_Type; + + ---------------------- + -- Start_Union_Type -- + ---------------------- + + procedure Start_Union_Type (Elements : out O_Element_List) is + begin + Elements := (Kind => OF_Union, + Nbr_Elements => 0, + Rec_Type => O_Tnode_Null, + Size => 0, + Align => 0, + Align_Type => Null_TypeRef, + First_Elem => null, + Last_Elem => null); + end Start_Union_Type; + + --------------------- + -- New_Union_Field -- + --------------------- + + procedure New_Union_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; + Etype : O_Tnode) + is + El_Type : constant TypeRef := Get_LLVM_Type (Etype); + Size : constant unsigned := + unsigned (ABISizeOfType (Target_Data, El_Type)); + Align : constant Unsigned_32 := + ABIAlignmentOfType (Target_Data, El_Type); + begin + El := (Kind => OF_Union, + Ftype => Etype, + Utype => El_Type, + Ptr_Type => PointerType (El_Type)); + if Size > Elements.Size then + Elements.Size := Size; + end if; + if Elements.Align_Type = Null_TypeRef or else Align > Elements.Align then + Elements.Align := Align; + Elements.Align_Type := El_Type; + end if; + Add_Field (Elements, Ident, Etype); + end New_Union_Field; + + ----------------------- + -- Finish_Union_Type -- + ----------------------- + + procedure Finish_Union_Type + (Elements : in out O_Element_List; + Res : out O_Tnode) + is + Count : unsigned; + Types : TypeRefArray (1 .. 2); + Pad : unsigned; + begin + if Elements.Align_Type = Null_TypeRef then + -- An empty union. Is it allowed ? + Count := 0; + else + -- The first element is the field with the biggest alignment + Types (1) := Elements.Align_Type; + -- Possibly complete with an array of bytes. + Pad := Elements.Size + - unsigned (ABISizeOfType (Target_Data, Elements.Align_Type)); + if Pad /= 0 then + Types (2) := ArrayType (Int8Type, Pad); + Count := 2; + else + Count := 1; + end if; + end if; + Res := new O_Tnode_Type'(Kind => ON_Union_Type, + LLVM => StructType (Types, Count, 0), + Dbg => Null_ValueRef, + Un_Size => Elements.Size, + Un_Main_Field => Elements.Align_Type); + + if Flag_Debug then + Add_Dbg_Fields (Elements, Res); + end if; + Free_Elements (Elements); + end Finish_Union_Type; + + --------------------- + -- New_Access_Type -- + --------------------- + + function New_Access_Type (Dtype : O_Tnode) return O_Tnode is + begin + if Dtype = O_Tnode_Null then + -- LLVM type will be built by New_Type_Decl, so that the name + -- can be used for the structure. + return new O_Tnode_Type'(Kind => ON_Incomplete_Access_Type, + LLVM => Null_TypeRef, + Dbg => Null_ValueRef, + Acc_Type => O_Tnode_Null); + else + return new O_Tnode_Type'(Kind => ON_Access_Type, + LLVM => PointerType (Get_LLVM_Type (Dtype)), + Dbg => Null_ValueRef, + Acc_Type => Dtype); + end if; + end New_Access_Type; + + ------------------------ + -- Finish_Access_Type -- + ------------------------ + + procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) + is + Types : TypeRefArray (1 .. 1); + begin + if Atype.Kind /= ON_Incomplete_Access_Type then + -- Not an incomplete access type. + raise Program_Error; + end if; + if Atype.Acc_Type /= O_Tnode_Null then + -- Already completed. + raise Program_Error; + end if; + -- Completion + Types (1) := Get_LLVM_Type (Dtype); + StructSetBody (GetElementType (Atype.LLVM), Types, Types'Length, 0); + Atype.Acc_Type := Dtype; + + -- Debug. + if Atype.Dbg /= Null_ValueRef then + pragma Assert (GetMDNodeNumOperands (Atype.Dbg) = 10); + MDNodeReplaceOperandWith (Atype.Dbg, 9, Dtype.Dbg); + end if; + 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 + V : ValueRef; + begin + if List.Atype.Kind = ON_Incomplete_Record_Type then + V := ConstNamedStruct (Get_LLVM_Type (List.Atype), + List.Vals.all, List.Len); + else + V := ConstStruct (List.Vals.all, List.Len, 0); + end if; + Res := (LLVM => V, Ctype => List.Atype); + Free (List.Vals); + end Finish_Record_Aggr; + + ---------------------- + -- Start_Array_Aggr -- + ---------------------- + + procedure Start_Array_Aggr + (List : out O_Array_Aggr_List; + Atype : O_Tnode) + is + Llvm : constant TypeRef := Get_LLVM_Type (Atype); + begin + List := (Len => 0, + Vals => new ValueRefArray (1 .. GetArrayLength (Llvm)), + El_Type => GetElementType (Llvm), + Atype => Atype); + end Start_Array_Aggr; + + ----------------------- + -- New_Array_Aggr_El -- + ----------------------- + + procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; + Value : O_Cnode) + is + begin + List.Len := List.Len + 1; + List.Vals (List.Len) := Value.LLVM; + end New_Array_Aggr_El; + + ----------------------- + -- Finish_Array_Aggr -- + ----------------------- + + procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; + Res : out O_Cnode) + is + begin + Res := (LLVM => ConstArray (List.El_Type, + List.Vals.all, List.Len), + Ctype => List.Atype); + Free (List.Vals); + end Finish_Array_Aggr; + + -------------------- + -- New_Union_Aggr -- + -------------------- + + function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) + return O_Cnode + is + Values : ValueRefArray (1 .. 2); + Count : unsigned; + Size : constant unsigned := + unsigned (ABISizeOfType (Target_Data, Field.Utype)); + + begin + Values (1) := Value.LLVM; + if Size < Atype.Un_Size then + Values (2) := GetUndef (ArrayType (Int8Type, Atype.Un_Size - Size)); + Count := 2; + else + Count := 1; + end if; + + -- If `FIELD` is the main field of the union, create a struct using + -- the same type as the union (and possibly pad). + if Field.Utype = Atype.Un_Main_Field then + return O_Cnode' + (LLVM => ConstNamedStruct (Atype.LLVM, Values, Count), + Ctype => Atype); + else + -- Create an on-the-fly record. + return O_Cnode'(LLVM => ConstStruct (Values, Count, 0), + Ctype => Atype); + end if; + end New_Union_Aggr; + + ----------------------- + -- New_Default_Value -- + ----------------------- + + function New_Default_Value (Ltype : O_Tnode) return O_Cnode is + begin + return O_Cnode'(LLVM => ConstNull (Ltype.LLVM), + Ctype => Ltype); + end New_Default_Value; + + ---------------- + -- New_Sizeof -- + ---------------- + + -- Return VAL with type RTYPE (either unsigned or access) + function Const_To_Cnode (Rtype : O_Tnode; Val : Unsigned_64) return O_Cnode + is + Tmp : ValueRef; + begin + case Rtype.Kind is + when ON_Scalar_Types => + -- Well, unsigned in fact. + return O_Cnode'(LLVM => ConstInt (Rtype.LLVM, Val, 0), + Ctype => Rtype); + when ON_Access_Type => + Tmp := ConstInt (Int64Type, Val, 0); + return O_Cnode'(LLVM => ConstIntToPtr (Tmp, Rtype.LLVM), + Ctype => Rtype); + when others => + raise Program_Error; + end case; + end Const_To_Cnode; + + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is + begin + return Const_To_Cnode + (Rtype, ABISizeOfType (Target_Data, Get_LLVM_Type (Atype))); + end New_Sizeof; + + ----------------- + -- New_Alignof -- + ----------------- + + function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is + begin + return Const_To_Cnode + (Rtype, + Unsigned_64 + (ABIAlignmentOfType (Target_Data, Get_LLVM_Type (Atype)))); + end New_Alignof; + + ------------------ + -- New_Offsetof -- + ------------------ + + function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) + return O_Cnode is + begin + return Const_To_Cnode + (Rtype, + OffsetOfElement (Target_Data, + Get_LLVM_Type (Atype), + Unsigned_32 (Field.Index))); + end New_Offsetof; + + ---------------------------- + -- New_Subprogram_Address -- + ---------------------------- + + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode is + begin + return O_Cnode' + (LLVM => ConstBitCast (Subprg.LLVM, Get_LLVM_Type (Atype)), + Ctype => Atype); + end New_Subprogram_Address; + + ------------------------ + -- New_Global_Address -- + ------------------------ + + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is + begin + return New_Global_Unchecked_Address (Lvalue, Atype); + end New_Global_Address; + + ---------------------------------- + -- New_Global_Unchecked_Address -- + ---------------------------------- + + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is + begin + return O_Cnode'(LLVM => ConstBitCast (Lvalue.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_Global -- + ---------------- + + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. + case Decl.Kind is + when ON_Const_Decl + | ON_Var_Decl => + return O_Gnode'(LLVM => Decl.LLVM, + Ltype => Decl.Dtype); + when others => + raise Program_Error; + end case; + end New_Global; + + ------------------- + -- New_Dyadic_Op -- + ------------------- + + function New_Smod (L, R : ValueRef; Res_Type : TypeRef) + return ValueRef + is + Cond : ValueRef; + Br : ValueRef; + pragma Unreferenced (Br); + + -- The result of 'L rem R'. + Rm : ValueRef; + + -- Rm + R + Rm_Plus_R : ValueRef; + + -- The result of 'L xor R'. + R_Xor : ValueRef; + + Adj : ValueRef; + Phi : ValueRef; + + -- Basic basic for the non-overflow branch + Normal_Bb : constant BasicBlockRef := + AppendBasicBlock (Cur_Func, Empty_Cstring); + + Adjust_Bb : constant BasicBlockRef := + AppendBasicBlock (Cur_Func, Empty_Cstring); + + -- Basic block after the result + Next_Bb : constant BasicBlockRef := + AppendBasicBlock (Cur_Func, Empty_Cstring); + + Vals : ValueRefArray (1 .. 3); + BBs : BasicBlockRefArray (1 .. 3); + begin + -- Avoid overflow with -1: + -- if R = -1 then + -- result := 0; + -- else + -- ... + Cond := BuildICmp + (Builder, IntEQ, R, ConstAllOnes (Res_Type), Empty_Cstring); + Br := BuildCondBr (Builder, Cond, Next_Bb, Normal_Bb); + Vals (1) := ConstNull (Res_Type); + BBs (1) := GetInsertBlock (Builder); + + -- Rm := Left rem Right + PositionBuilderAtEnd (Builder, Normal_Bb); + Rm := BuildSRem (Builder, L, R, Empty_Cstring); + + -- if Rm = 0 then + -- result := 0 + -- else + Cond := BuildICmp + (Builder, IntEQ, Rm, ConstNull (Res_Type), Empty_Cstring); + Br := BuildCondBr (Builder, Cond, Next_Bb, Adjust_Bb); + Vals (2) := ConstNull (Res_Type); + BBs (2) := Normal_Bb; + + -- if (L xor R) < 0 then + -- result := Rm + R + -- else + -- result := Rm; + -- end if; + PositionBuilderAtEnd (Builder, Adjust_Bb); + R_Xor := BuildXor (Builder, L, R, Empty_Cstring); + Cond := BuildICmp + (Builder, IntSLT, R_Xor, ConstNull (Res_Type), Empty_Cstring); + Rm_Plus_R := BuildAdd (Builder, Rm, R, Empty_Cstring); + Adj := BuildSelect (Builder, Cond, Rm_Plus_R, Rm, Empty_Cstring); + Br := BuildBr (Builder, Next_Bb); + Vals (3) := Adj; + BBs (3) := Adjust_Bb; + + -- The Phi node + PositionBuilderAtEnd (Builder, Next_Bb); + Phi := BuildPhi (Builder, Res_Type, Empty_Cstring); + AddIncoming (Phi, Vals, BBs, Vals'Length); + + return Phi; + end New_Smod; + + type Dyadic_Builder_Acc is access + function (Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + pragma Convention (C, Dyadic_Builder_Acc); + + function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) + return O_Enode + is + Build : Dyadic_Builder_Acc := null; + Res : ValueRef := Null_ValueRef; + begin + if Unreach then + return O_Enode'(LLVM => Null_ValueRef, Etype => Left.Etype); + end if; + + case Left.Etype.Kind is + when ON_Integer_Types => + case Kind is + when ON_And => + Build := BuildAnd'Access; + when ON_Or => + Build := BuildOr'Access; + when ON_Xor => + Build := BuildXor'Access; + + when ON_Add_Ov => + Build := BuildAdd'Access; + when ON_Sub_Ov => + Build := BuildSub'Access; + when ON_Mul_Ov => + Build := BuildMul'Access; + + when ON_Div_Ov => + case Left.Etype.Kind is + when ON_Unsigned_Type => + Build := BuildUDiv'Access; + when ON_Signed_Type => + Build := BuildSDiv'Access; + when others => + null; + end case; + + when ON_Mod_Ov + | ON_Rem_Ov => -- FIXME... + case Left.Etype.Kind is + when ON_Unsigned_Type => + Build := BuildURem'Access; + when ON_Signed_Type => + if Kind = ON_Rem_Ov then + Build := BuildSRem'Access; + else + Res := New_Smod + (Left.LLVM, Right.LLVM, Left.Etype.LLVM); + end if; + when others => + null; + end case; + end case; + + when ON_Float_Type => + case Kind is + when ON_Add_Ov => + Build := BuildFAdd'Access; + when ON_Sub_Ov => + Build := BuildFSub'Access; + when ON_Mul_Ov => + Build := BuildFMul'Access; + when ON_Div_Ov => + Build := BuildFDiv'Access; + + when others => + null; + end case; + + when others => + null; + end case; + + if Build /= null then + pragma Assert (Res = Null_ValueRef); + Res := Build.all (Builder, Left.LLVM, Right.LLVM, Empty_Cstring); + end if; + + if Res = Null_ValueRef then + raise Program_Error with "Unimplemented New_Dyadic_Op " + & ON_Dyadic_Op_Kind'Image (Kind) + & " for type " + & ON_Type_Kind'Image (Left.Etype.Kind); + end if; + + 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 + if Unreach then + return O_Enode'(LLVM => Null_ValueRef, Etype => Operand.Etype); + end if; + + case Operand.Etype.Kind is + when ON_Integer_Types => + case Kind is + when ON_Not => + Res := BuildNot (Builder, Operand.LLVM, Empty_Cstring); + when ON_Neg_Ov => + Res := BuildNeg (Builder, Operand.LLVM, Empty_Cstring); + when ON_Abs_Ov => + Res := BuildSelect + (Builder, + BuildICmp (Builder, IntSLT, + Operand.LLVM, + ConstInt (Get_LLVM_Type (Operand.Etype), 0, 0), + Empty_Cstring), + BuildNeg (Builder, Operand.LLVM, Empty_Cstring), + Operand.LLVM, + Empty_Cstring); + end case; + when ON_Float_Type => + case Kind is + when ON_Not => + raise Program_Error; + when ON_Neg_Ov => + Res := BuildFNeg (Builder, Operand.LLVM, Empty_Cstring); + when ON_Abs_Ov => + Res := BuildSelect + (Builder, + BuildFCmp (Builder, RealOLT, + Operand.LLVM, + ConstReal (Get_LLVM_Type (Operand.Etype), 0.0), + Empty_Cstring), + BuildFNeg (Builder, Operand.LLVM, Empty_Cstring), + Operand.LLVM, + Empty_Cstring); + end case; + when others => + raise Program_Error; + end case; + + 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 + if Unreach then + return O_Enode'(LLVM => Null_ValueRef, Etype => Ntype); + end if; + + case Left.Etype.Kind is + when ON_Unsigned_Type + | ON_Boolean_Type + | ON_Enum_Type + | ON_Access_Type + | ON_Incomplete_Access_Type => + Res := BuildICmp (Builder, Compare_Op_Table (Kind).Unsigned_Pred, + Left.LLVM, Right.LLVM, Empty_Cstring); + when ON_Signed_Type => + Res := BuildICmp (Builder, Compare_Op_Table (Kind).Signed_Pred, + Left.LLVM, Right.LLVM, Empty_Cstring); + when ON_Float_Type => + Res := BuildFCmp (Builder, Compare_Op_Table (Kind).Real_Pred, + Left.LLVM, Right.LLVM, Empty_Cstring); + when ON_Array_Type + | ON_Array_Sub_Type + | ON_Record_Type + | ON_Incomplete_Record_Type + | ON_Union_Type + | ON_No_Type => + raise Program_Error; + end case; + 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); + Tmp : ValueRef; + begin + if Unreach then + Tmp := Null_ValueRef; + else + Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring); + end if; + return O_Lnode'(Direct => False, + LLVM => Tmp, + Ltype => Arr.Ltype.Arr_El_Type); + end New_Indexed_Element; + + --------------- + -- New_Slice -- + --------------- + + function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) + return O_Lnode + is + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + Index.LLVM); + Tmp : ValueRef; + begin + if Unreach then + Tmp := Null_ValueRef; + else + Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring); + Tmp := BuildBitCast + (Builder, Tmp, PointerType (Get_LLVM_Type (Res_Type)), + Empty_Cstring); + end if; + return O_Lnode'(Direct => False, LLVM => Tmp, Ltype => Res_Type); + end New_Slice; + + -------------------------- + -- New_Selected_Element -- + -------------------------- + + function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) + return O_Lnode + is + Res : ValueRef; + begin + if Unreach then + Res := Null_ValueRef; + else + case El.Kind is + when OF_Record => + declare + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); + begin + Res := BuildGEP (Builder, Rec.LLVM, Idx, 2, Empty_Cstring); + end; + when OF_Union => + Res := BuildBitCast (Builder, + Rec.LLVM, El.Ptr_Type, Empty_Cstring); + when OF_None => + raise Program_Error; + end case; + end if; + return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); + end New_Selected_Element; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode + is + Res : ValueRef; + begin + case El.Kind is + when OF_Record => + declare + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); + begin + Res := ConstGEP (Rec.LLVM, Idx, 2); + end; + when OF_Union => + Res := ConstBitCast (Rec.LLVM, El.Ptr_Type); + when OF_None => + raise Program_Error; + end case; + return O_Gnode'(LLVM => Res, Ltype => El.Ftype); + end New_Global_Selected_Element; + + ------------------------ + -- New_Access_Element -- + ------------------------ + + function New_Access_Element (Acc : O_Enode) return O_Lnode + is + Res : ValueRef; + begin + case Acc.Etype.Kind is + when ON_Access_Type => + Res := Acc.LLVM; + when ON_Incomplete_Access_Type => + -- Unwrap the structure + declare + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), ConstInt (Int32Type, 0, 0)); + begin + Res := BuildGEP (Builder, Acc.LLVM, Idx, 2, Empty_Cstring); + end; + when others => + raise Program_Error; + end case; + return O_Lnode'(Direct => False, + LLVM => Res, + Ltype => Acc.Etype.Acc_Type); + end New_Access_Element; + + -------------------- + -- New_Convert_Ov -- + -------------------- + + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode + is + Res : ValueRef := Null_ValueRef; + begin + if Rtype = Val.Etype then + -- Convertion to itself: nothing to do. + return Val; + end if; + if Rtype.LLVM = Val.Etype.LLVM then + -- Same underlying LLVM type: no conversion but keep new type in + -- case of change of sign. + return O_Enode'(LLVM => Val.LLVM, Etype => Rtype); + end if; + if Unreach then + return O_Enode'(LLVM => Val.LLVM, Etype => Rtype); + end if; + + case Rtype.Kind is + when ON_Integer_Types => + case Val.Etype.Kind is + when ON_Integer_Types => + -- Int to Int + if Val.Etype.Scal_Size > Rtype.Scal_Size then + -- Truncate + Res := BuildTrunc + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + elsif Val.Etype.Scal_Size < Rtype.Scal_Size then + if Val.Etype.Kind = ON_Signed_Type then + Res := BuildSExt + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + else + -- Unsigned, enum + Res := BuildZExt + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + end if; + else + Res := BuildBitCast + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + end if; + + when ON_Float_Type => + -- Float to Int + if Rtype.Kind = ON_Signed_Type then + -- FPtoSI rounds toward zero, so we need to add + -- copysign (0.5, x). + declare + V : ValueRef; + begin + V := BuildCall (Builder, Copysign_Fun, + (Fp_0_5, Val.LLVM), 2, Empty_Cstring); + V := BuildFAdd (Builder, Val.LLVM, V, Empty_Cstring); + Res := BuildFPToSI + (Builder, V, Get_LLVM_Type (Rtype), Empty_Cstring); + end; + end if; + + when others => + null; + end case; + + when ON_Float_Type => + if Val.Etype.Kind = ON_Signed_Type then + Res := BuildSIToFP + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + elsif Val.Etype.Kind = ON_Unsigned_Type then + Res := BuildUIToFP + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + end if; + + when ON_Access_Type + | ON_Incomplete_Access_Type => + if GetTypeKind (TypeOf (Val.LLVM)) /= PointerTypeKind then + raise Program_Error; + end if; + Res := BuildBitCast (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + + when others => + null; + end case; + if Res /= Null_ValueRef then + -- FIXME: only if insn was generated + -- Set_Insn_Dbg (Res); + return O_Enode'(LLVM => Res, Etype => Rtype); + else + raise Program_Error with "New_Convert_Ov: not implemented for " + & ON_Type_Kind'Image (Val.Etype.Kind) + & " -> " + & ON_Type_Kind'Image (Rtype.Kind); + end if; + end New_Convert_Ov; + + ----------------- + -- New_Address -- + ----------------- + + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is + begin + return New_Unchecked_Address (Lvalue, Atype); + end New_Address; + + --------------------------- + -- New_Unchecked_Address -- + --------------------------- + + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode + is + Res : ValueRef; + begin + if Unreach then + Res := Null_ValueRef; + else + Res := BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype), + Empty_Cstring); + end if; + return O_Enode'(LLVM => Res, Etype => Atype); + end New_Unchecked_Address; + + --------------- + -- New_Value -- + --------------- + + function New_Value (Lvalue : O_Lnode) return O_Enode + is + Res : ValueRef; + begin + if Unreach then + Res := Null_ValueRef; + else + Res := Lvalue.LLVM; + if not Lvalue.Direct then + Res := BuildLoad (Builder, Res, Empty_Cstring); + 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 + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. + case Obj.Kind is + when ON_Const_Decl + | ON_Var_Decl + | ON_Local_Decl => + return O_Lnode'(Direct => False, + LLVM => Obj.LLVM, + Ltype => Obj.Dtype); + + when ON_Interface_Decl => + if Flag_Debug then + -- The argument was allocated. + return O_Lnode'(Direct => False, + LLVM => Obj.Inter.Ival, + Ltype => Obj.Dtype); + else + return O_Lnode'(Direct => True, + LLVM => Obj.Inter.Ival, + Ltype => Obj.Dtype); + end if; + + when ON_Type_Decl + | ON_Completed_Type_Decl + | ON_Subprg_Decl + | ON_No_Decl => + raise Program_Error; + end case; + end New_Obj; + + ---------------- + -- New_Alloca -- + ---------------- + + function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode + is + Res : ValueRef; + begin + if Unreach then + Res := Null_ValueRef; + else + if Cur_Declare_Block.Stack_Value = Null_ValueRef + and then Cur_Declare_Block.Prev /= null + then + -- Save stack pointer at entry of block + declare + First_Insn : ValueRef; + Bld : BuilderRef; + begin + First_Insn := GetFirstInstruction (Cur_Declare_Block.Stmt_Bb); + if First_Insn = Null_ValueRef then + -- Alloca is the first instruction, save the stack now. + Bld := Builder; + else + -- There are instructions before alloca, insert the save + -- at the beginning. + PositionBuilderBefore (Extra_Builder, First_Insn); + Bld := Extra_Builder; + end if; + + Cur_Declare_Block.Stack_Value := + BuildCall (Bld, Stacksave_Fun, + (1 .. 0 => Null_ValueRef), 0, Empty_Cstring); + end; + end if; + + Res := BuildArrayAlloca + (Builder, Int8Type, Size.LLVM, Empty_Cstring); + Set_Insn_Dbg (Res); + + Res := BuildBitCast + (Builder, Res, Get_LLVM_Type (Rtype), Empty_Cstring); + Set_Insn_Dbg (Res); + end if; + + return O_Enode'(LLVM => Res, Etype => Rtype); + end New_Alloca; + + ------------------- + -- New_Type_Decl -- + ------------------- + + function Add_Dbg_Basic_Type (Id : O_Ident; Btype : O_Tnode; Enc : Natural) + return ValueRef + is + Vals : ValueRefArray (0 .. 9); + begin + Vals := (ConstInt (Int32Type, DW_TAG_Base_Type, 0), + Null_ValueRef, + Null_ValueRef, + MDString (Id), + ConstInt (Int32Type, 0, 0), -- linenum + Dbg_Size (Btype.LLVM), + Dbg_Align (Btype.LLVM), + ConstInt (Int32Type, 0, 0), -- Offset + ConstInt (Int32Type, 0, 0), -- Flags + ConstInt (Int32Type, Unsigned_64 (Enc), 0)); -- Encoding + return MDNode (Vals, Vals'Length); + end Add_Dbg_Basic_Type; + + function Add_Dbg_Enum_Type (Id : O_Ident; Etype : O_Tnode) return ValueRef + is + Vals : ValueRefArray (0 .. 14); + begin + Vals := (ConstInt (Int32Type, DW_TAG_Enumeration_Type, 0), + Dbg_Current_Filedir, + Null_ValueRef, -- context + MDString (Id), + Dbg_Line, + Dbg_Size (Etype.LLVM), + Dbg_Align (Etype.LLVM), + ConstInt (Int32Type, 0, 0), -- Offset + ConstInt (Int32Type, 0, 0), -- Flags + Null_ValueRef, + Get_Value (Enum_Nodes), + ConstInt (Int32Type, 0, 0), + Null_ValueRef, + Null_ValueRef, + Null_ValueRef); -- Runtime lang + Clear (Enum_Nodes); + return MDNode (Vals, Vals'Length); + end Add_Dbg_Enum_Type; + + function Add_Dbg_Pointer_Type + (Id : O_Ident; Ptype : O_Tnode; Designated_Dbg : ValueRef) + return ValueRef + is + Vals : ValueRefArray (0 .. 9); + begin + 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 + Designated_Dbg); + return MDNode (Vals, Vals'Length); + end Add_Dbg_Pointer_Type; + + function Add_Dbg_Pointer_Type (Id : O_Ident; Ptype : O_Tnode) + return ValueRef is + begin + pragma Assert (Ptype.Acc_Type /= null); + pragma Assert (Ptype.Acc_Type.Dbg /= Null_ValueRef); + return Add_Dbg_Pointer_Type (Id, Ptype, Ptype.Acc_Type.Dbg); + end Add_Dbg_Pointer_Type; + + function Add_Dbg_Incomplete_Pointer_Type (Id : O_Ident; Ptype : O_Tnode) + return ValueRef is + begin + return Add_Dbg_Pointer_Type (Id, Ptype, Null_ValueRef); + end Add_Dbg_Incomplete_Pointer_Type; + + function Add_Dbg_Record_Type + (Id : O_Ident; Rtype : O_Tnode; Tag : Unsigned_64) return ValueRef + is + Vals : ValueRefArray (0 .. 14); + begin + Vals := (ConstInt (Int32Type, Tag, 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 + -- Create the incomplete structure. This is the only way in LLVM to + -- build recursive types. + case Atype.Kind is + when ON_Incomplete_Record_Type => + Atype.LLVM := + StructCreateNamed (GetGlobalContext, Get_Cstring (Ident)); + when ON_Incomplete_Access_Type => + Atype.LLVM := PointerType + (StructCreateNamed (GetGlobalContext, Get_Cstring (Ident))); + when others => + null; + end case; + + -- 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_Incomplete_Access_Type => + Atype.Dbg := Add_Dbg_Incomplete_Pointer_Type (Ident, Atype); + when ON_Record_Type => + Atype.Dbg := Add_Dbg_Record_Type + (Ident, Atype, DW_TAG_Structure_Type); + when ON_Incomplete_Record_Type => + Atype.Dbg := Add_Dbg_Record_Type + (Ident, O_Tnode_Null, DW_TAG_Structure_Type); + when ON_Array_Type + | ON_Array_Sub_Type => + -- FIXME: typedef + null; + when ON_Union_Type => + Atype.Dbg := Add_Dbg_Record_Type + (Ident, Atype, DW_TAG_Union_Type); + 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_Line 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_Init_Value -- + ----------------------- + + procedure Start_Init_Value (Decl : in out O_Dnode) is + begin + null; + end Start_Init_Value; + + ------------------------ + -- Finish_Init_Value -- + ------------------------ + + procedure Finish_Init_Value (Decl : in out O_Dnode; Val : O_Cnode) is + begin + SetInitializer (Decl.LLVM, Val.LLVM); + end Finish_Init_Value; + + ------------------ + -- New_Var_Decl -- + ------------------ + + procedure New_Var_Decl + (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) + is + Decl : ValueRef; + begin + if Storage = O_Storage_Local then + Res := (Kind => ON_Local_Decl, + LLVM => BuildAlloca + (Decl_Builder, Get_LLVM_Type (Atype), Get_Cstring (Ident)), + Dtype => Atype); + 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); + AddFunctionAttr (Decl, NoUnwindAttribute + UWTable); + end if; + + Res := (Kind => ON_Subprg_Decl, + Dtype => Interfaces.Res_Type, + Subprg_Id => Interfaces.Ident, + Nbr_Args => Count, + Subprg_Inters => Interfaces.First_Inter, + LLVM => Decl); + SetFunctionCallConv (Res.LLVM, CCallConv); + + -- Translate interfaces. + Inter := Interfaces.First_Inter; + for I in 1 .. Count loop + Inter.Ival := GetParam (Res.LLVM, I - 1); + SetValueName (Inter.Ival, Get_Cstring (Inter.Ident)); + Inter := Inter.Next; + end loop; + end Finish_Subprogram_Decl; + + --------------------------- + -- Start_Subprogram_Body -- + --------------------------- + + procedure Start_Subprogram_Body (Func : O_Dnode) + is + -- Basic block at function entry that contains all the declarations. + Decl_BB : BasicBlockRef; + begin + if Cur_Func /= Null_ValueRef then + -- No support for nested subprograms. + raise Program_Error; + end if; + + Cur_Func := Func.LLVM; + Cur_Func_Decl := Func; + + pragma Assert (not Unreach); + + 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_Line then + declare + Type_Vals : ValueRefArray (0 .. Func.Nbr_Args); + Types : ValueRef; + Vals : ValueRefArray (0 .. 14); + Arg : O_Inter_Acc; + Subprg_Type : ValueRef; + + Subprg_Vals : ValueRefArray (0 .. 19); + Name : ValueRef; + begin + if Flag_Debug then + -- Create a full subroutine_type. + 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; + Types := MDNode (Type_Vals, Type_Vals'Length); + else + -- Create a dummy subroutine_type. + -- FIXME: create only one subroutine_type ? + Type_Vals (0) := ConstInt (Int32Type, 0, 0); + Types := MDNode (Type_Vals, 1); + end if; + + 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 + Types, -- 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; + + -- Kill current debug metadata, as it is not upto date. + Dbg_Insn_MD := Null_ValueRef; + end; + end if; + + if Flag_Debug then + -- 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; + + Unreach := False; + + Dbg_Current_Scope := Null_ValueRef; + Dbg_Insn_MD := Null_ValueRef; + end Finish_Subprogram_Body; + + ------------------------- + -- New_Debug_Line_Stmt -- + ------------------------- + + procedure New_Debug_Line_Stmt (Line : Natural) is + begin + Dbg_Current_Line := unsigned (Line); + end New_Debug_Line_Stmt; + + ---------------------------- + -- New_Debug_Comment_Stmt -- + ---------------------------- + + procedure New_Debug_Comment_Stmt (Comment : String) is + begin + null; + end New_Debug_Comment_Stmt; + + ------------------------ + -- Start_Declare_Stmt -- + ------------------------ + + procedure Start_Declare_Stmt + is + Br : ValueRef; + pragma Unreferenced (Br); + begin + Create_Declare_Block; + + if Unreach then + return; + end if; + + -- Add a jump to the new BB. + Br := BuildBr (Builder, Cur_Declare_Block.Stmt_Bb); + + PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb); + + if Flag_Debug then + declare + Vals : ValueRefArray (0 .. 5); + begin + Vals := + (ConstInt (Int32Type, DW_TAG_Lexical_Block, 0), + Dbg_Current_Filedir, -- 1 loc + Dbg_Current_Scope, -- 2 context + Dbg_Line, -- 3 line num + ConstInt (Int32Type, 0, 0), -- 4 col + ConstInt (Int32Type, Scope_Uniq_Id, 0)); + Cur_Declare_Block.Dbg_Scope := MDNode (Vals, Vals'Length); + Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; + Scope_Uniq_Id := Scope_Uniq_Id + 1; + end; + end if; + end Start_Declare_Stmt; + + ------------------------- + -- Finish_Declare_Stmt -- + ------------------------- + + procedure Finish_Declare_Stmt + is + Bb : BasicBlockRef; + Br : ValueRef; + Tmp : ValueRef; + pragma Unreferenced (Br, Tmp); + begin + if not Unreach then + -- Create a basic block for the statements after the declare. + Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); + + if Cur_Declare_Block.Stack_Value /= Null_ValueRef then + -- Restore stack pointer. + Tmp := BuildCall (Builder, Stackrestore_Fun, + (1 .. 1 => Cur_Declare_Block.Stack_Value), 1, + Empty_Cstring); + end if; + + -- Execution will continue on the next statement + Br := BuildBr (Builder, Bb); + + PositionBuilderAtEnd (Builder, Bb); + end if; + + -- Do not reset Unread. + + Destroy_Declare_Block; + + Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope; + end Finish_Declare_Stmt; + + ----------------------- + -- Start_Association -- + ----------------------- + + procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) + is + begin + Assocs := (Subprg => Subprg, + Idx => 0, + Vals => new ValueRefArray (1 .. Subprg.Nbr_Args)); + end Start_Association; + + --------------------- + -- New_Association -- + --------------------- + + procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is + begin + Assocs.Idx := Assocs.Idx + 1; + Assocs.Vals (Assocs.Idx) := Val.LLVM; + end New_Association; + + ----------------------- + -- New_Function_Call -- + ----------------------- + + function New_Function_Call (Assocs : O_Assoc_List) return O_Enode + is + Res : ValueRef; + Old_Vals : ValueRefArray_Acc; + begin + if not Unreach then + Res := BuildCall (Builder, Assocs.Subprg.LLVM, + Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); + Old_Vals := Assocs.Vals; + Free (Old_Vals); + Set_Insn_Dbg (Res); + else + Res := Null_ValueRef; + end if; + return O_Enode'(LLVM => Res, Etype => Assocs.Subprg.Dtype); + end New_Function_Call; + + ------------------------ + -- New_Procedure_Call -- + ------------------------ + + procedure New_Procedure_Call (Assocs : in out O_Assoc_List) + is + Res : ValueRef; + 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 + if Unreach then + Block := (Bb => Null_BasicBlockRef); + return; + end if; + + Bb_Then := AppendBasicBlock (Cur_Func, Empty_Cstring); + Block := (Bb => AppendBasicBlock (Cur_Func, Empty_Cstring)); + Res := BuildCondBr (Builder, Cond.LLVM, Bb_Then, Block.Bb); + 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 + if Block.Bb = Null_BasicBlockRef then + -- The IF statement was unreachable. Else part is also + -- unreachable. + return; + end if; + Bb_Next := Null_BasicBlockRef; + end if; + + PositionBuilderAtEnd (Builder, Block.Bb); + + Block := (Bb => Bb_Next); + Unreach := False; + end New_Else_Stmt; + + -------------------- + -- Finish_If_Stmt -- + -------------------- + + procedure Finish_If_Stmt (Block : in out O_If_Block) is + Res : ValueRef; + pragma Unreferenced (Res); + Bb_Next : BasicBlockRef; + begin + if not Unreach then + -- The branch can continue. + if Block.Bb = Null_BasicBlockRef then + Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); + else + Bb_Next := Block.Bb; + end if; + Res := BuildBr (Builder, Bb_Next); + PositionBuilderAtEnd (Builder, Bb_Next); + else + -- The branch doesn't continue. + if Block.Bb /= Null_BasicBlockRef then + -- There is a fall-through (either from the then branch, or + -- there is no else). + Unreach := False; + PositionBuilderAtEnd (Builder, Block.Bb); + else + Unreach := True; + end if; + end if; + end Finish_If_Stmt; + + --------------------- + -- Start_Loop_Stmt -- + --------------------- + + procedure Start_Loop_Stmt (Label : out O_Snode) + is + Res : ValueRef; + pragma Unreferenced (Res); + begin + if Unreach then + Label := (Null_BasicBlockRef, Null_BasicBlockRef); + else + 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 if; + end Start_Loop_Stmt; + + ---------------------- + -- Finish_Loop_Stmt -- + ---------------------- + + procedure Finish_Loop_Stmt (Label : in out O_Snode) is + Res : ValueRef; + pragma Unreferenced (Res); + begin + if not Unreach then + Res := BuildBr (Builder, Label.Bb_Entry); + end if; + if Label.Bb_Exit /= Null_BasicBlockRef then + -- FIXME: always true... + PositionBuilderAtEnd (Builder, Label.Bb_Exit); + Unreach := False; + else + Unreach := True; + end if; + end Finish_Loop_Stmt; + + ------------------- + -- New_Exit_Stmt -- + ------------------- + + procedure New_Exit_Stmt (L : O_Snode) is + Res : ValueRef; + begin + if not Unreach then + Res := BuildBr (Builder, L.Bb_Exit); + Set_Insn_Dbg (Res); + Unreach := True; + end if; + end New_Exit_Stmt; + + ------------------- + -- New_Next_Stmt -- + ------------------- + + procedure New_Next_Stmt (L : O_Snode) is + Res : ValueRef; + begin + if not Unreach then + Res := BuildBr (Builder, L.Bb_Entry); + Set_Insn_Dbg (Res); + Unreach := True; + end if; + end New_Next_Stmt; + + --------------------- + -- Start_Case_Stmt -- + --------------------- + + procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is + begin + Block := (BB_Prev => GetInsertBlock (Builder), + Value => Value.LLVM, + Vtype => Value.Etype, + BB_Next => Null_BasicBlockRef, + BB_Others => Null_BasicBlockRef, + BB_Choice => Null_BasicBlockRef, + Nbr_Choices => 0, + Choices => new O_Choice_Array (1 .. 8)); + end Start_Case_Stmt; + + ------------------ + -- Start_Choice -- + ------------------ + + procedure Finish_Branch (Block : in out O_Case_Block) is + Res : ValueRef; + pragma Unreferenced (Res); + begin + -- Close previous branch. + if not Unreach then + if Block.BB_Next = Null_BasicBlockRef then + Block.BB_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); + end if; + Res := BuildBr (Builder, Block.BB_Next); + end if; + end Finish_Branch; + + procedure Start_Choice (Block : in out O_Case_Block) is + Res : ValueRef; + pragma Unreferenced (Res); + begin + if Block.BB_Choice /= Null_BasicBlockRef then + -- Close previous branch. + Finish_Branch (Block); + end if; + + Unreach := False; + Block.BB_Choice := AppendBasicBlock (Cur_Func, Empty_Cstring); + PositionBuilderAtEnd (Builder, Block.BB_Choice); + end Start_Choice; + + --------------------- + -- New_Expr_Choice -- + --------------------- + + procedure Free is new Ada.Unchecked_Deallocation + (O_Choice_Array, O_Choice_Array_Acc); + + procedure New_Choice (Block : in out O_Case_Block; + Low, High : ValueRef) + is + Choices : O_Choice_Array_Acc; + begin + if Block.Nbr_Choices = Block.Choices'Last then + Choices := new O_Choice_Array (1 .. Block.Choices'Last * 2); + Choices (1 .. Block.Choices'Last) := Block.Choices.all; + Free (Block.Choices); + Block.Choices := Choices; + end if; + Block.Nbr_Choices := Block.Nbr_Choices + 1; + Block.Choices (Block.Nbr_Choices) := (Low => Low, + High => High, + Bb => Block.BB_Choice); + end New_Choice; + + procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is + begin + New_Choice (Block, Expr.LLVM, Null_ValueRef); + end New_Expr_Choice; + + ---------------------- + -- New_Range_Choice -- + ---------------------- + + procedure New_Range_Choice + (Block : in out O_Case_Block; Low, High : O_Cnode) + is + begin + New_Choice (Block, Low.LLVM, High.LLVM); + end New_Range_Choice; + + ------------------------ + -- New_Default_Choice -- + ------------------------ + + procedure New_Default_Choice (Block : in out O_Case_Block) is + begin + Block.BB_Others := Block.BB_Choice; + end New_Default_Choice; + + ------------------- + -- Finish_Choice -- + ------------------- + + procedure Finish_Choice (Block : in out O_Case_Block) is + begin + null; + end Finish_Choice; + + ---------------------- + -- Finish_Case_Stmt -- + ---------------------- + + procedure Finish_Case_Stmt (Block : in out O_Case_Block) + is + Bb_Default : constant BasicBlockRef := + AppendBasicBlock (Cur_Func, Empty_Cstring); + Bb_Default_Last : BasicBlockRef; + Nbr_Cases : unsigned := 0; + GE, LE : IntPredicate; + Res : ValueRef; + begin + if Block.BB_Choice /= Null_BasicBlockRef then + -- Close previous branch. + Finish_Branch (Block); + end if; + + -- Strategy: use a switch instruction for simple choices, put range + -- choices in the default using if statements. + case Block.Vtype.Kind is + when ON_Unsigned_Type + | ON_Enum_Type + | ON_Boolean_Type => + GE := IntUGE; + LE := IntULE; + when ON_Signed_Type => + GE := IntSGE; + LE := IntSLE; + when others => + raise Program_Error; + end case; + + -- BB for the default case of the LLVM switch. + PositionBuilderAtEnd (Builder, Bb_Default); + Bb_Default_Last := Bb_Default; + + for I in 1 .. Block.Nbr_Choices loop + declare + C : O_Choice_Type renames Block.Choices (I); + begin + if C.High /= Null_ValueRef then + Bb_Default_Last := AppendBasicBlock (Cur_Func, Empty_Cstring); + Res := BuildCondBr (Builder, + BuildAnd (Builder, + BuildICmp (Builder, GE, + Block.Value, C.Low, + Empty_Cstring), + BuildICmp (Builder, LE, + Block.Value, C.High, + Empty_Cstring), + Empty_Cstring), + C.Bb, Bb_Default_Last); + PositionBuilderAtEnd (Builder, Bb_Default_Last); + else + Nbr_Cases := Nbr_Cases + 1; + end if; + end; + end loop; + + -- Insert the switch + PositionBuilderAtEnd (Builder, Block.BB_Prev); + Res := BuildSwitch (Builder, Block.Value, Bb_Default, Nbr_Cases); + for I in 1 .. Block.Nbr_Choices loop + declare + C : O_Choice_Type renames Block.Choices (I); + begin + if C.High = Null_ValueRef then + AddCase (Res, C.Low, C.Bb); + end if; + end; + end loop; + + -- Insert the others. + PositionBuilderAtEnd (Builder, Bb_Default_Last); + if Block.BB_Others /= Null_BasicBlockRef then + Res := BuildBr (Builder, Block.BB_Others); + else + Res := BuildUnreachable (Builder); + end if; + + if Block.BB_Next /= Null_BasicBlockRef then + Unreach := False; + PositionBuilderAtEnd (Builder, Block.BB_Next); + else + Unreach := True; + end if; + + Free (Block.Choices); + end Finish_Case_Stmt; + + function Get_LLVM_Type (Atype : O_Tnode) return TypeRef is + begin + case Atype.Kind is + when ON_Incomplete_Record_Type + | ON_Incomplete_Access_Type => + if Atype.LLVM = Null_TypeRef then + raise Program_Error with "early use of incomplete type"; + end if; + return Atype.LLVM; + when ON_Union_Type + | ON_Scalar_Types + | ON_Access_Type + | ON_Array_Type + | ON_Array_Sub_Type + | ON_Record_Type => + return Atype.LLVM; + when others => + raise Program_Error; + end case; + end Get_LLVM_Type; + + procedure Finish_Debug is + begin + declare + Dbg_Cu : constant String := "llvm.dbg.cu" & ASCII.NUL; + Producer : constant String := "ortho llvm"; + Vals : ValueRefArray (0 .. 12); + begin + Vals := + (ConstInt (Int32Type, DW_TAG_Compile_Unit, 0), + Dbg_Current_Filedir, -- 1 file+dir + ConstInt (Int32Type, 1, 0), -- 2 language (C) + MDString (Producer), -- 3 producer + ConstInt (Int1Type, 0, 0), -- 4 isOpt + MDString (""), -- 5 flags + ConstInt (Int32Type, 0, 0), -- 6 runtime version + Null_ValueRef, -- 7 enum types + Null_ValueRef, -- 8 retained types + Get_Value (Subprg_Nodes), -- 9 subprograms + Get_Value (Global_Nodes), -- 10 global var + Null_ValueRef, -- 11 imported entities + Null_ValueRef); -- 12 split debug + + AddNamedMetadataOperand + (Module, Dbg_Cu'Address, MDNode (Vals, Vals'Length)); + end; + + declare + Module_Flags : constant String := "llvm.module.flags" & ASCII.NUL; + Flags1 : ValueRefArray (0 .. 2); + Flags2 : ValueRefArray (0 .. 2); + begin + Flags1 := (ConstInt (Int32Type, 1, 0), + MDString ("Debug Info Version"), + ConstInt (Int32Type, 1, 0)); + AddNamedMetadataOperand + (Module, Module_Flags'Address, MDNode (Flags1, Flags1'Length)); + Flags2 := (ConstInt (Int32Type, 2, 0), + MDString ("Dwarf Version"), + ConstInt (Int32Type, 2, 0)); + AddNamedMetadataOperand + (Module, Module_Flags'Address, MDNode (Flags2, Flags2'Length)); + end; + end Finish_Debug; + + Dbg_Str : constant String := "dbg"; + + procedure Init is + -- Some predefined types and functions. + I8_Ptr_Type : TypeRef; + begin + Builder := CreateBuilder; + Decl_Builder := CreateBuilder; + Extra_Builder := CreateBuilder; + + -- Create type i8 *. + I8_Ptr_Type := PointerType (Int8Type); + + -- Create intrinsic 'i8 *stacksave (void)'. + Stacksave_Fun := AddFunction + (Module, Stacksave_Name'Address, + FunctionType (I8_Ptr_Type, (1 .. 0 => Null_TypeRef), 0, 0)); + + -- Create intrinsic 'void stackrestore (i8 *)'. + Stackrestore_Fun := AddFunction + (Module, Stackrestore_Name'Address, + FunctionType (VoidType, (1 => I8_Ptr_Type), 1, 0)); + + -- Create intrinsic 'double llvm.copysign.f64 (double, double)'. + Copysign_Fun := AddFunction + (Module, Copysign_Name'Address, + FunctionType (DoubleType, (0 .. 1 => DoubleType), 2, 0)); + + Fp_0_5 := ConstReal (DoubleType, 0.5); + + if Flag_Debug_Line 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; diff --git a/src/ortho/llvm35/ortho_llvm.ads b/src/ortho/llvm35/ortho_llvm.ads new file mode 100644 index 000000000..2779d0233 --- /dev/null +++ b/src/ortho/llvm35/ortho_llvm.ads @@ -0,0 +1,765 @@ +-- DO NOT MODIFY - this file was generated from: +-- ortho_nodes.common.ads and ortho_llvm.private.ads +-- +-- LLVM back-end for ortho. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Interfaces; use Interfaces; +with Interfaces.C; use Interfaces.C; +with Ortho_Ident; use Ortho_Ident; +with LLVM.Core; use LLVM.Core; +with LLVM.TargetMachine; +with LLVM.Target; + +-- Interface to create nodes. +package Ortho_LLVM is + procedure Init; + procedure Finish_Debug; + + -- LLVM specific: the module. + Module : ModuleRef; + + -- Descriptor for the layout. + Target_Data : LLVM.Target.TargetDataRef; + + Target_Machine : LLVM.TargetMachine.TargetMachineRef; + + -- Optimization level + Optimization : LLVM.TargetMachine.CodeGenOptLevel := + LLVM.TargetMachine.CodeGenLevelDefault; + + -- Set by -g to generate full debug info. + Flag_Debug : Boolean := False; + + -- Set by -g or -glines to generate line debug info. + Flag_Debug_Line : Boolean := False; + +-- Start of common part + + type O_Enode is private; + type O_Cnode is private; + type O_Lnode is private; + type O_Tnode is private; + type O_Snode is private; + type O_Dnode is private; + type O_Gnode is private; + type O_Fnode is private; + + O_Cnode_Null : constant O_Cnode; + O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; + O_Enode_Null : constant O_Enode; + O_Fnode_Null : constant O_Fnode; + O_Lnode_Null : constant O_Lnode; + O_Snode_Null : constant O_Snode; + O_Tnode_Null : constant O_Tnode; + + -- True if the code generated supports nested subprograms. + Has_Nested_Subprograms : constant Boolean; + + ------------------------ + -- 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; + + -- Create a literal with default (null) values. Can only be used to + -- define the initial value of a static decalaration. + function New_Default_Value (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 its record ATYPE. The result is a + -- literal of unsigned type or access 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 (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; + + -- Same as New_Address but without any restriction. + function New_Global_Unchecked_Address (Lvalue : O_Gnode; 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 + + -- 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_Xor; + 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 or a union. + -- Type of REC must be a record or a union type. + function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; + + -- 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; + + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + + -- 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 or variable. + procedure Start_Init_Value (Decl : in out O_Dnode); + procedure Finish_Init_Value (Decl : 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); + +-- End of common part +private + -- No support for nested subprograms in LLVM. + Has_Nested_Subprograms : constant Boolean := False; + + type O_Tnode_Type (<>); + type O_Tnode is access O_Tnode_Type; + O_Tnode_Null : constant O_Tnode := null; + + type ON_Type_Kind is + (ON_No_Type, + ON_Unsigned_Type, ON_Signed_Type, ON_Enum_Type, ON_Boolean_Type, + ON_Float_Type, + ON_Array_Type, ON_Array_Sub_Type, + ON_Incomplete_Record_Type, + ON_Record_Type, ON_Union_Type, + ON_Incomplete_Access_Type, ON_Access_Type); + + subtype ON_Scalar_Types is ON_Type_Kind range + ON_Unsigned_Type .. ON_Float_Type; + + subtype ON_Integer_Types is ON_Type_Kind range + ON_Unsigned_Type .. ON_Boolean_Type; + + type O_Tnode_Type (Kind : ON_Type_Kind := ON_No_Type) is record + LLVM : TypeRef; + Dbg : ValueRef; + case Kind is + when ON_No_Type => + null; + when ON_Union_Type => + Un_Size : unsigned; + Un_Main_Field : TypeRef; + when ON_Access_Type + | ON_Incomplete_Access_Type => + Acc_Type : O_Tnode; + when ON_Scalar_Types => + Scal_Size : Natural; + when ON_Array_Type + | ON_Array_Sub_Type => + -- Type of the element + Arr_El_Type : O_Tnode; + when ON_Record_Type + | ON_Incomplete_Record_Type => + null; + end case; + end record; + + type O_Inter; + type O_Inter_Acc is access O_Inter; + type O_Inter is record + Itype : O_Tnode; + Ival : ValueRef; + Ident : O_Ident; + Next : O_Inter_Acc; + end record; + + type On_Decl_Kind is + (ON_Type_Decl, ON_Completed_Type_Decl, + ON_Const_Decl, + ON_Var_Decl, ON_Local_Decl, ON_Interface_Decl, + ON_Subprg_Decl, + ON_No_Decl); + + type O_Dnode (Kind : On_Decl_Kind := ON_No_Decl) is record + Dtype : O_Tnode; + LLVM : ValueRef; + case Kind is + when ON_Var_Decl + | ON_Const_Decl + | ON_Local_Decl => + null; + when ON_Subprg_Decl => + Subprg_Id : O_Ident; + Nbr_Args : unsigned; + Subprg_Inters : O_Inter_Acc; + when ON_Interface_Decl => + Inter : O_Inter_Acc; + when others => + null; + end case; + end record; + + O_Dnode_Null : constant O_Dnode := (Kind => ON_No_Decl, + Dtype => O_Tnode_Null, + LLVM => Null_ValueRef); + + type OF_Kind is (OF_None, OF_Record, OF_Union); + type O_Fnode (Kind : OF_Kind := OF_None) is record + -- Type of the field. + Ftype : O_Tnode; + case Kind is + when OF_None => + null; + when OF_Record => + -- Field index (starting from 0). + Index : Natural; + when OF_Union => + Utype : TypeRef; + Ptr_Type : TypeRef; + end case; + end record; + + O_Fnode_Null : constant O_Fnode := (Kind => OF_None, + Ftype => O_Tnode_Null); + + type O_Anode_Type; + type O_Anode is access O_Anode_Type; + type O_Anode_Type is record + Next : O_Anode; + Formal : O_Dnode; + Actual : O_Enode; + end record; + + type O_Cnode is record + LLVM : ValueRef; + Ctype : O_Tnode; + end record; + O_Cnode_Null : constant O_Cnode := (LLVM => Null_ValueRef, + Ctype => O_Tnode_Null); + + type O_Enode is record + LLVM : ValueRef; + Etype : O_Tnode; + end record; + O_Enode_Null : constant O_Enode := (LLVM => Null_ValueRef, + Etype => O_Tnode_Null); + + + type O_Lnode is record + -- If True, the LLVM component is the value (used for arguments). + -- If False, the LLVM component is the address of the value (used + -- for everything else). + Direct : Boolean; + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + + type O_Snode is record + -- First BB in the loop body. + Bb_Entry : BasicBlockRef; + + -- BB after the loop. + Bb_Exit : BasicBlockRef; + end record; + + O_Snode_Null : constant O_Snode := (Null_BasicBlockRef, + Null_BasicBlockRef); + + type O_Inter_List is record + Ident : O_Ident; + Storage : O_Storage; + Res_Type : O_Tnode; + Nbr_Inter : Natural; + First_Inter, Last_Inter : O_Inter_Acc; + end record; + + type O_Element; + type O_Element_Acc is access O_Element; + type O_Element is record + -- Identifier for the element + Ident : O_Ident; + + -- Type of the element + Etype : O_Tnode; + + -- Next element (in the linked list) + Next : O_Element_Acc; + end record; + + -- Record and union builder. + type O_Element_List is record + Kind : OF_Kind; + + -- Number of fields. + Nbr_Elements : Natural; + + -- For record: the access to the incomplete (but named) type. + Rec_Type : O_Tnode; + + -- For unions: biggest for size and alignment + Size : unsigned; + Align : Unsigned_32; + Align_Type : TypeRef; + + First_Elem, Last_Elem : O_Element_Acc; + end record; + + type ValueRefArray_Acc is access ValueRefArray; + + type O_Record_Aggr_List is record + -- Current number of elements in Vals. + Len : unsigned; + + -- Value of elements. + Vals : ValueRefArray_Acc; + + -- Type of the aggregate. + Atype : O_Tnode; + end record; + + type O_Array_Aggr_List is record + -- Current number of elements in Vals. + Len : unsigned; + + -- Value of elements. + Vals : ValueRefArray_Acc; + El_Type : TypeRef; + + -- Type of the aggregate. + Atype : O_Tnode; + end record; + + type O_Assoc_List is record + Subprg : O_Dnode; + Idx : unsigned; + Vals : ValueRefArray_Acc; + end record; + + type O_Enum_List is record + LLVM : TypeRef; + Num : Natural; + Etype : O_Tnode; + end record; + + type O_Choice_Type is record + Low, High : ValueRef; + Bb : BasicBlockRef; + end record; + + type O_Choice_Array is array (Natural range <>) of O_Choice_Type; + type O_Choice_Array_Acc is access O_Choice_Array; + + type O_Case_Block is record + -- BB before the case. + BB_Prev : BasicBlockRef; + + -- Select expression + Value : ValueRef; + Vtype : O_Tnode; + + -- BB after the case statement. + BB_Next : BasicBlockRef; + + -- BB for others + BB_Others : BasicBlockRef; + + -- BB for the current choice + BB_Choice : BasicBlockRef; + + -- List of choices. + Nbr_Choices : Natural; + Choices : O_Choice_Array_Acc; + end record; + + type O_If_Block is record + -- The next basic block. + -- After the 'If', this is the BB for the else part. If there is no + -- else part, this is the BB for statements after the if. + -- After the 'else', this is the BB for statements after the if. + Bb : BasicBlockRef; + end record; + + function Get_LLVM_Type (Atype : O_Tnode) return TypeRef; +end Ortho_LLVM; diff --git a/src/ortho/llvm35/ortho_llvm.private.ads b/src/ortho/llvm35/ortho_llvm.private.ads new file mode 100644 index 000000000..ce0685a90 --- /dev/null +++ b/src/ortho/llvm35/ortho_llvm.private.ads @@ -0,0 +1,321 @@ +-- LLVM back-end for ortho. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Interfaces; use Interfaces; +with Interfaces.C; use Interfaces.C; +with Ortho_Ident; use Ortho_Ident; +with LLVM.Core; use LLVM.Core; +with LLVM.TargetMachine; +with LLVM.Target; + +-- Interface to create nodes. +package Ortho_LLVM is + procedure Init; + procedure Finish_Debug; + + -- LLVM specific: the module. + Module : ModuleRef; + + -- Descriptor for the layout. + Target_Data : LLVM.Target.TargetDataRef; + + Target_Machine : LLVM.TargetMachine.TargetMachineRef; + + -- Optimization level + Optimization : LLVM.TargetMachine.CodeGenOptLevel := + LLVM.TargetMachine.CodeGenLevelDefault; + + -- Set by -g to generate full debug info. + Flag_Debug : Boolean := False; + + -- Set by -g or -glines to generate line debug info. + Flag_Debug_Line : Boolean := False; + +private + -- No support for nested subprograms in LLVM. + Has_Nested_Subprograms : constant Boolean := False; + + type O_Tnode_Type (<>); + type O_Tnode is access O_Tnode_Type; + O_Tnode_Null : constant O_Tnode := null; + + type ON_Type_Kind is + (ON_No_Type, + ON_Unsigned_Type, ON_Signed_Type, ON_Enum_Type, ON_Boolean_Type, + ON_Float_Type, + ON_Array_Type, ON_Array_Sub_Type, + ON_Incomplete_Record_Type, + ON_Record_Type, ON_Union_Type, + ON_Incomplete_Access_Type, ON_Access_Type); + + subtype ON_Scalar_Types is ON_Type_Kind range + ON_Unsigned_Type .. ON_Float_Type; + + subtype ON_Integer_Types is ON_Type_Kind range + ON_Unsigned_Type .. ON_Boolean_Type; + + type O_Tnode_Type (Kind : ON_Type_Kind := ON_No_Type) is record + LLVM : TypeRef; + Dbg : ValueRef; + case Kind is + when ON_No_Type => + null; + when ON_Union_Type => + Un_Size : unsigned; + Un_Main_Field : TypeRef; + when ON_Access_Type + | ON_Incomplete_Access_Type => + Acc_Type : O_Tnode; + when ON_Scalar_Types => + Scal_Size : Natural; + when ON_Array_Type + | ON_Array_Sub_Type => + -- Type of the element + Arr_El_Type : O_Tnode; + when ON_Record_Type + | ON_Incomplete_Record_Type => + null; + end case; + end record; + + type O_Inter; + type O_Inter_Acc is access O_Inter; + type O_Inter is record + Itype : O_Tnode; + Ival : ValueRef; + Ident : O_Ident; + Next : O_Inter_Acc; + end record; + + type On_Decl_Kind is + (ON_Type_Decl, ON_Completed_Type_Decl, + ON_Const_Decl, + ON_Var_Decl, ON_Local_Decl, ON_Interface_Decl, + ON_Subprg_Decl, + ON_No_Decl); + + type O_Dnode (Kind : On_Decl_Kind := ON_No_Decl) is record + Dtype : O_Tnode; + LLVM : ValueRef; + case Kind is + when ON_Var_Decl + | ON_Const_Decl + | ON_Local_Decl => + null; + when ON_Subprg_Decl => + Subprg_Id : O_Ident; + Nbr_Args : unsigned; + Subprg_Inters : O_Inter_Acc; + when ON_Interface_Decl => + Inter : O_Inter_Acc; + when others => + null; + end case; + end record; + + O_Dnode_Null : constant O_Dnode := (Kind => ON_No_Decl, + Dtype => O_Tnode_Null, + LLVM => Null_ValueRef); + + type OF_Kind is (OF_None, OF_Record, OF_Union); + type O_Fnode (Kind : OF_Kind := OF_None) is record + -- Type of the field. + Ftype : O_Tnode; + case Kind is + when OF_None => + null; + when OF_Record => + -- Field index (starting from 0). + Index : Natural; + when OF_Union => + Utype : TypeRef; + Ptr_Type : TypeRef; + end case; + end record; + + O_Fnode_Null : constant O_Fnode := (Kind => OF_None, + Ftype => O_Tnode_Null); + + type O_Anode_Type; + type O_Anode is access O_Anode_Type; + type O_Anode_Type is record + Next : O_Anode; + Formal : O_Dnode; + Actual : O_Enode; + end record; + + type O_Cnode is record + LLVM : ValueRef; + Ctype : O_Tnode; + end record; + O_Cnode_Null : constant O_Cnode := (LLVM => Null_ValueRef, + Ctype => O_Tnode_Null); + + type O_Enode is record + LLVM : ValueRef; + Etype : O_Tnode; + end record; + O_Enode_Null : constant O_Enode := (LLVM => Null_ValueRef, + Etype => O_Tnode_Null); + + + type O_Lnode is record + -- If True, the LLVM component is the value (used for arguments). + -- If False, the LLVM component is the address of the value (used + -- for everything else). + Direct : Boolean; + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + + type O_Snode is record + -- First BB in the loop body. + Bb_Entry : BasicBlockRef; + + -- BB after the loop. + Bb_Exit : BasicBlockRef; + end record; + + O_Snode_Null : constant O_Snode := (Null_BasicBlockRef, + Null_BasicBlockRef); + + type O_Inter_List is record + Ident : O_Ident; + Storage : O_Storage; + Res_Type : O_Tnode; + Nbr_Inter : Natural; + First_Inter, Last_Inter : O_Inter_Acc; + end record; + + type O_Element; + type O_Element_Acc is access O_Element; + type O_Element is record + -- Identifier for the element + Ident : O_Ident; + + -- Type of the element + Etype : O_Tnode; + + -- Next element (in the linked list) + Next : O_Element_Acc; + end record; + + -- Record and union builder. + type O_Element_List is record + Kind : OF_Kind; + + -- Number of fields. + Nbr_Elements : Natural; + + -- For record: the access to the incomplete (but named) type. + Rec_Type : O_Tnode; + + -- For unions: biggest for size and alignment + Size : unsigned; + Align : Unsigned_32; + Align_Type : TypeRef; + + First_Elem, Last_Elem : O_Element_Acc; + end record; + + type ValueRefArray_Acc is access ValueRefArray; + + type O_Record_Aggr_List is record + -- Current number of elements in Vals. + Len : unsigned; + + -- Value of elements. + Vals : ValueRefArray_Acc; + + -- Type of the aggregate. + Atype : O_Tnode; + end record; + + type O_Array_Aggr_List is record + -- Current number of elements in Vals. + Len : unsigned; + + -- Value of elements. + Vals : ValueRefArray_Acc; + El_Type : TypeRef; + + -- Type of the aggregate. + Atype : O_Tnode; + end record; + + type O_Assoc_List is record + Subprg : O_Dnode; + Idx : unsigned; + Vals : ValueRefArray_Acc; + end record; + + type O_Enum_List is record + LLVM : TypeRef; + Num : Natural; + Etype : O_Tnode; + end record; + + type O_Choice_Type is record + Low, High : ValueRef; + Bb : BasicBlockRef; + end record; + + type O_Choice_Array is array (Natural range <>) of O_Choice_Type; + type O_Choice_Array_Acc is access O_Choice_Array; + + type O_Case_Block is record + -- BB before the case. + BB_Prev : BasicBlockRef; + + -- Select expression + Value : ValueRef; + Vtype : O_Tnode; + + -- BB after the case statement. + BB_Next : BasicBlockRef; + + -- BB for others + BB_Others : BasicBlockRef; + + -- BB for the current choice + BB_Choice : BasicBlockRef; + + -- List of choices. + Nbr_Choices : Natural; + Choices : O_Choice_Array_Acc; + end record; + + type O_If_Block is record + -- The next basic block. + -- After the 'If', this is the BB for the else part. If there is no + -- else part, this is the BB for statements after the if. + -- After the 'else', this is the BB for statements after the if. + Bb : BasicBlockRef; + end record; + + function Get_LLVM_Type (Atype : O_Tnode) return TypeRef; +end Ortho_LLVM; diff --git a/src/ortho/llvm35/ortho_nodes.ads b/src/ortho/llvm35/ortho_nodes.ads new file mode 100644 index 000000000..34d1dbbc9 --- /dev/null +++ b/src/ortho/llvm35/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; -- cgit v1.2.3