diff options
Diffstat (limited to 'src/ortho')
-rw-r--r-- | src/ortho/llvm4-nodebug/Makefile | 40 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/llvm-analysis.ads | 53 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/llvm-bitwriter.ads | 34 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/llvm-cbindings.cpp | 38 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/llvm-core.ads | 1160 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/llvm-target.ads | 97 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/llvm-targetmachine.ads | 126 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/llvm-transforms-scalar.ads | 169 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/llvm-transforms.ads | 21 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/llvm.ads | 21 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/ortho_code_main4.adb | 318 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/ortho_ident.adb | 134 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/ortho_ident.ads | 42 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/ortho_llvm.adb | 2340 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/ortho_llvm.ads | 743 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/ortho_llvm.private.ads | 307 | ||||
-rw-r--r-- | src/ortho/llvm4-nodebug/ortho_nodes.ads | 20 |
17 files changed, 5663 insertions, 0 deletions
diff --git a/src/ortho/llvm4-nodebug/Makefile b/src/ortho/llvm4-nodebug/Makefile new file mode 100644 index 000000000..3868566f4 --- /dev/null +++ b/src/ortho/llvm4-nodebug/Makefile @@ -0,0 +1,40 @@ +ortho_srcdir=.. +GNAT_FLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwael -gnat05 +CXX=clang++ +LLVM_CONFIG=llvm-config +GNATMAKE=gnatmake +SED=sed +BE=llvm4-nodebug + +all: $(ortho_exec) + +$(ortho_exec): $(ortho_srcdir)/llvm4-nodebug/ortho_llvm.ads force llvm-cbindings.o ortho_code_main.adb + $(GNATMAKE) -o $@ -aI$(ortho_srcdir)/llvm4-nodebug -aI$(ortho_srcdir) \ + $(GNAT_FLAGS) ortho_code_main -bargs -E \ + -largs llvm-cbindings.o --LINK=$(CXX) \ + $(LDFLAGS) `$(LLVM_CONFIG) --ldflags --libs --system-libs` + +llvm-cbindings.o: $(ortho_srcdir)/llvm4-nodebug/llvm-cbindings.cpp + $(CXX) -c `$(LLVM_CONFIG) --cxxflags` -o $@ $< + +ortho_code_main.adb: + echo "with Ortho_Code_Main$(llvm_be_ver);" > ortho_code_main.tmp + echo "procedure Ortho_Code_Main is" >> ortho_code_main.tmp + echo "begin" >> ortho_code_main.tmp + echo " Ortho_Code_Main$(llvm_be_ver);" >> ortho_code_main.tmp + echo "end Ortho_Code_Main;" >> ortho_code_main.tmp + mv ortho_code_main.tmp $@ + +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/llvm4-nodebug/llvm-analysis.ads b/src/ortho/llvm4-nodebug/llvm-analysis.ads new file mode 100644 index 000000000..bfecec579 --- /dev/null +++ b/src/ortho/llvm4-nodebug/llvm-analysis.ads @@ -0,0 +1,53 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with LLVM.Core; use LLVM.Core; + +package LLVM.Analysis is + type VerifierFailureAction is + ( + AbortProcessAction, -- verifier will print to stderr and abort() + PrintMessageAction, -- verifier will print to stderr and return 1 + ReturnStatusAction -- verifier will just return 1 + ); + pragma Convention (C, VerifierFailureAction); + + -- Verifies that a module is valid, taking the specified action if not. + -- Optionally returns a human-readable description of any invalid + -- constructs. + -- OutMessage must be disposed with DisposeMessage. */ + function VerifyModule(M : ModuleRef; + Action : VerifierFailureAction; + OutMessage : access Cstring) + return Integer; + + -- Verifies that a single function is valid, taking the specified + -- action. Useful for debugging. + function VerifyFunction(Fn : ValueRef; Action : VerifierFailureAction) + return Integer; + + -- Open up a ghostview window that displays the CFG of the current function. + -- Useful for debugging. + procedure ViewFunctionCFG(Fn : ValueRef); + procedure ViewFunctionCFGOnly(Fn : ValueRef); +private + pragma Import (C, VerifyModule, "LLVMVerifyModule"); + pragma Import (C, VerifyFunction, "LLVMVerifyFunction"); + pragma Import (C, ViewFunctionCFG, "LLVMViewFunctionCFG"); + pragma Import (C, ViewFunctionCFGOnly, "LLVMViewFunctionCFGOnly"); +end LLVM.Analysis; + diff --git a/src/ortho/llvm4-nodebug/llvm-bitwriter.ads b/src/ortho/llvm4-nodebug/llvm-bitwriter.ads new file mode 100644 index 000000000..3f9c518e4 --- /dev/null +++ b/src/ortho/llvm4-nodebug/llvm-bitwriter.ads @@ -0,0 +1,34 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with LLVM.Core; use LLVM.Core; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Interfaces.C; use Interfaces.C; + +package LLVM.BitWriter is + -- Writes a module to an open file descriptor. Returns 0 on success. + -- Closes the Handle. Use dup first if this is not what you want. + function WriteBitcodeToFileHandle(M : ModuleRef; Handle : File_Descriptor) + return int; + + -- Writes a module to the specified path. Returns 0 on success. + function WriteBitcodeToFile(M : ModuleRef; Path : Cstring) + return int; +private + pragma Import (C, WriteBitcodeToFileHandle, "LLVMWriteBitcodeToFileHandle"); + pragma Import (C, WriteBitcodeToFile, "LLVMWriteBitcodeToFile"); +end LLVM.BitWriter; diff --git a/src/ortho/llvm4-nodebug/llvm-cbindings.cpp b/src/ortho/llvm4-nodebug/llvm-cbindings.cpp new file mode 100644 index 000000000..4a61ad552 --- /dev/null +++ b/src/ortho/llvm4-nodebug/llvm-cbindings.cpp @@ -0,0 +1,38 @@ +/* LLVM binding + Copyright (C) 2014 Tristan Gingold + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GHDL; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ +#include "llvm-c/Target.h" +#include "llvm/IR/Type.h" +#include "llvm/IR/LLVMContext.h" + +using namespace llvm; + +extern "C" { + +void +LLVMInitializeNativeTarget_noinline (void) +{ + LLVMInitializeNativeTarget (); +} + +void +LLVMInitializeNativeAsmPrinter_noinline (void) +{ + LLVMInitializeNativeAsmPrinter(); +} + +} diff --git a/src/ortho/llvm4-nodebug/llvm-core.ads b/src/ortho/llvm4-nodebug/llvm-core.ads new file mode 100644 index 000000000..29dc157e9 --- /dev/null +++ b/src/ortho/llvm4-nodebug/llvm-core.ads @@ -0,0 +1,1160 @@ +-- 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 AttributeIndex is new unsigned; + AttributeReturnIndex : constant AttributeIndex := 0; + AttributeFunctionIndex : constant AttributeIndex := 16#ffff_ffff#; + + type AttributeRef is new System.Address; + + type TypeKind is + ( + VoidTypeKind, -- type with no size + HalfTypeKind, -- 16 bit floating point type + FloatTypeKind, -- 32 bit floating point type + DoubleTypeKind, -- 64 bit floating point type + X86_FP80TypeKind, -- 80 bit floating point type (X87) + FP128TypeKind, -- 128 bit floating point type (112-bit mantissa) + PPC_FP128TypeKind, -- 128 bit floating point type (two 64-bits) + LabelTypeKind, -- Labels + IntegerTypeKind, -- Arbitrary bit width integers + FunctionTypeKind, -- Functions + StructTypeKind, -- Structures + ArrayTypeKind, -- Arrays + PointerTypeKind, -- Pointers + VectorTypeKind, -- SIMD 'packed' format, or other vector type + MetadataTypeKind, -- Metadata + X86_MMXTypeKind -- X86 MMX + ); + pragma Convention (C, TypeKind); + + type Linkage is + ( + ExternalLinkage, -- Externally visible function + AvailableExternallyLinkage, + LinkOnceAnyLinkage, -- Keep one copy of function when linking (inline) + LinkOnceODRLinkage, -- Same, but only replaced by someth equivalent. + LinkOnceODRAutoHideLinkage, -- Obsolete + WeakAnyLinkage, -- Keep one copy of function when linking (weak) + WeakODRLinkage, -- Same, but only replaced by someth equivalent. + AppendingLinkage, -- Special purpose, only applies to global arrays + InternalLinkage, -- Rename collisions when linking (static func) + PrivateLinkage, -- Like Internal, but omit from symbol table + DLLImportLinkage, -- Obsolete + DLLExportLinkage, -- Obsolete + ExternalWeakLinkage,-- ExternalWeak linkage description + GhostLinkage, -- Obsolete + CommonLinkage, -- Tentative definitions + LinkerPrivateLinkage, -- Like Private, but linker removes. + LinkerPrivateWeakLinkage -- Like LinkerPrivate, but is weak. + ); + pragma Convention (C, Linkage); + + type Visibility is + ( + DefaultVisibility, -- The GV is visible + HiddenVisibility, -- The GV is hidden + ProtectedVisibility -- The GV is protected + ); + pragma Convention (C, Visibility); + + type CallConv is new unsigned; + CCallConv : constant CallConv := 0; + FastCallConv : constant CallConv := 8; + ColdCallConv : constant CallConv := 9; + X86StdcallCallConv : constant CallConv := 64; + X86FastcallCallConv : constant CallConv := 6; + + type IntPredicate is new unsigned; + IntEQ : constant IntPredicate := 32; -- equal + IntNE : constant IntPredicate := 33; -- not equal + IntUGT : constant IntPredicate := 34; -- unsigned greater than + IntUGE : constant IntPredicate := 35; -- unsigned greater or equal + IntULT : constant IntPredicate := 36; -- unsigned less than + IntULE : constant IntPredicate := 37; -- unsigned less or equal + IntSGT : constant IntPredicate := 38; -- signed greater than + IntSGE : constant IntPredicate := 39; -- signed greater or equal + IntSLT : constant IntPredicate := 40; -- signed less than + IntSLE : constant IntPredicate := 41; -- signed less or equal + + type RealPredicate is + ( + RealPredicateFalse, -- Always false (always folded) + RealOEQ, -- True if ordered and equal + RealOGT, -- True if ordered and greater than + RealOGE, -- True if ordered and greater than or equal + RealOLT, -- True if ordered and less than + RealOLE, -- True if ordered and less than or equal + RealONE, -- True if ordered and operands are unequal + RealORD, -- True if ordered (no nans) + RealUNO, -- True if unordered: isnan(X) | isnan(Y) + RealUEQ, -- True if unordered or equal + RealUGT, -- True if unordered or greater than + RealUGE, -- True if unordered, greater than, or equal + RealULT, -- True if unordered or less than + RealULE, -- True if unordered, less than, or equal + RealUNE, -- True if unordered or not equal + RealPredicateTrue -- Always true (always folded) + ); + + -- Error handling ---------------------------------------------------- + + procedure DisposeMessage (Message : Cstring); + + + -- Context + + -- Create a new context. + -- Every call to this function should be paired with a call to + -- LLVMContextDispose() or the context will leak memory. + function ContextCreate return ContextRef; + + -- Obtain the global context instance. + function GetGlobalContext return ContextRef; + + -- Destroy a context instance. + -- This should be called for every call to LLVMContextCreate() or memory + -- will be leaked. + procedure ContextDispose (C : ContextRef); + + -- Modules ----------------------------------------------------------- + + -- Create and destroy modules. + -- See llvm::Module::Module. + function ModuleCreateWithName (ModuleID : Cstring) return ModuleRef; + + -- See llvm::Module::~Module. + procedure DisposeModule (M : ModuleRef); + + -- Data layout. See Module::getDataLayout. + function GetDataLayout(M : ModuleRef) return Cstring; + procedure SetDataLayout(M : ModuleRef; Triple : Cstring); + + -- Target triple. See Module::getTargetTriple. + function GetTarget (M : ModuleRef) return Cstring; + procedure SetTarget (M : ModuleRef; Triple : Cstring); + + -- See Module::dump. + procedure DumpModule(M : ModuleRef); + + -- Print a representation of a module to a file. The ErrorMessage needs to + -- be disposed with LLVMDisposeMessage. Returns 0 on success, 1 otherwise. + -- + -- @see Module::print() + function PrintModuleToFile(M : ModuleRef; + Filename : Cstring; + ErrorMessage : access Cstring) return Bool; + + + -- Types ------------------------------------------------------------- + + -- LLVM types conform to the following hierarchy: + -- + -- types: + -- integer type + -- real type + -- function type + -- sequence types: + -- array type + -- pointer type + -- vector type + -- void type + -- label type + -- opaque type + + -- See llvm::LLVMTypeKind::getTypeID. + function GetTypeKind (Ty : TypeRef) return TypeKind; + + -- Operations on integer types + function Int1Type return TypeRef; + function Int8Type return TypeRef; + function Int16Type return TypeRef; + function Int32Type return TypeRef; + function Int64Type return TypeRef; + function IntType(NumBits : unsigned) return TypeRef; + function GetIntTypeWidth(IntegerTy : TypeRef) return unsigned; + + function MetadataType return TypeRef; + + -- Operations on real types + function FloatType return TypeRef; + function DoubleType return TypeRef; + function X86FP80Type return TypeRef; + function FP128Type return TypeRef; + function PPCFP128Type return TypeRef; + + -- Operations on function types + function FunctionType(ReturnType : TypeRef; + ParamTypes : TypeRefArray; + ParamCount : unsigned; + IsVarArg : int) return TypeRef; + + function IsFunctionVarArg(FunctionTy : TypeRef) return int; + function GetReturnType(FunctionTy : TypeRef) return TypeRef; + function CountParamTypes(FunctionTy : TypeRef) return unsigned; + procedure GetParamTypes(FunctionTy : TypeRef; Dest : out TypeRefArray); + + -- Operations on struct types + function StructType(ElementTypes : TypeRefArray; + ElementCount : unsigned; + Packed : Bool) return TypeRef; + function StructCreateNamed(C : ContextRef; Name : Cstring) return TypeRef; + procedure StructSetBody(StructTy : TypeRef; + ElementTypes : TypeRefArray; + ElementCount : unsigned; + Packed : Bool); + function CountStructElementTypes(StructTy : TypeRef) return unsigned; + procedure GetStructElementTypes(StructTy : TypeRef; + Dest : out TypeRefArray); + function IsPackedStruct(StructTy : TypeRef) return Bool; + + + -- Operations on array, pointer, and vector types (sequence types) + function ArrayType(ElementType : TypeRef; ElementCount : unsigned) + return TypeRef; + function PointerType(ElementType : TypeRef; AddressSpace : unsigned := 0) + return TypeRef; + function VectorType(ElementType : TypeRef; ElementCount : unsigned) + return TypeRef; + + function GetElementType(Ty : TypeRef) return TypeRef; + function GetArrayLength(ArrayTy : TypeRef) return unsigned; + function GetPointerAddressSpace(PointerTy : TypeRef) return unsigned; + function GetVectorSize(VectorTy : TypeRef) return unsigned; + + -- Operations on other types. + function VoidType return TypeRef; + function LabelType return TypeRef; + + -- See Module::dump. + procedure DumpType(T : TypeRef); + + -- Values ------------------------------------------------------------ + -- The bulk of LLVM's object model consists of values, which comprise a very + -- rich type hierarchy. + -- + -- values: + -- constants: + -- scalar constants + -- composite contants + -- globals: + -- global variable + -- function + -- alias + -- basic blocks + + -- Operations on all values + function TypeOf(Val : ValueRef) return TypeRef; + function GetValueName(Val : ValueRef) return Cstring; + procedure SetValueName(Val : ValueRef; Name : Cstring); + procedure DumpValue(Val : ValueRef); + + -- Operations on constants of any type + function ConstNull(Ty : TypeRef) return ValueRef; -- All zero + function ConstAllOnes(Ty : TypeRef) return ValueRef; -- Int or Vec + function GetUndef(Ty : TypeRef) return ValueRef; + function IsConstant(Val : ValueRef) return int; + function IsNull(Val : ValueRef) return int; + function IsUndef(Val : ValueRef) return int; + + -- Convert value instances between types. + -- + -- Internally, an LLVMValueRef is "pinned" to a specific type. This + -- series of functions allows you to cast an instance to a specific + -- type. + -- + -- If the cast is not valid for the specified type, NULL is returned. + -- + -- @see llvm::dyn_cast_or_null<> + function IsAInstruction (Val : ValueRef) return ValueRef; + + -- Operations on scalar constants + function ConstInt(IntTy : TypeRef; N : Unsigned_64; SignExtend : int) + return ValueRef; + function ConstReal(RealTy : TypeRef; N : double) return ValueRef; + function ConstRealOfString(RealTy : TypeRef; Text : Cstring) + return ValueRef; + + + -- Obtain the zero extended value for an integer constant value. + -- @see llvm::ConstantInt::getZExtValue() + function ConstIntGetZExtValue (ConstantVal : ValueRef) return Unsigned_64; + + -- Operations on composite constants + function ConstString(Str : Cstring; + Length : unsigned; DontNullTerminate : int) + return ValueRef; + function ConstArray(ElementTy : TypeRef; + ConstantVals : ValueRefArray; Length : unsigned) + return ValueRef; + function ConstStruct(ConstantVals : ValueRefArray; + Count : unsigned; packed : int) return ValueRef; + + -- Create a non-anonymous ConstantStruct from values. + -- @see llvm::ConstantStruct::get() + function ConstNamedStruct(StructTy : TypeRef; + ConstantVals : ValueRefArray; + Count : unsigned) return ValueRef; + + function ConstVector(ScalarConstantVals : ValueRefArray; Size : unsigned) + return ValueRef; + + -- Constant expressions + function SizeOf(Ty : TypeRef) return ValueRef; + function AlignOf(Ty : TypeRef) return ValueRef; + + function ConstNeg(ConstantVal : ValueRef) return ValueRef; + function ConstNot(ConstantVal : ValueRef) return ValueRef; + function ConstAdd(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstSub(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstMul(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstUDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstSDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstFDiv(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstURem(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstSRem(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstFRem(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstAnd(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstOr(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstXor(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstICmp(Predicate : IntPredicate; + LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstFCmp(Predicate : RealPredicate; + LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstShl(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstLShr(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstAShr(LHSConstant : ValueRef; RHSConstant : ValueRef) + return ValueRef; + function ConstGEP(ConstantVal : ValueRef; + ConstantIndices : ValueRefArray; NumIndices : unsigned) + return ValueRef; + function ConstTrunc(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstSExt(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstZExt(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstFPTrunc(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstFPExt(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstUIToFP(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstSIToFP(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstFPToUI(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstFPToSI(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstPtrToInt(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstIntToPtr(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + function ConstBitCast(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + + function ConstTruncOrBitCast(ConstantVal : ValueRef; ToType : TypeRef) + return ValueRef; + + function ConstSelect(ConstantCondition : ValueRef; + ConstantIfTrue : ValueRef; + ConstantIfFalse : ValueRef) return ValueRef; + function ConstExtractElement(VectorConstant : ValueRef; + IndexConstant : ValueRef) return ValueRef; + function ConstInsertElement(VectorConstant : ValueRef; + ElementValueConstant : ValueRef; + IndexConstant : ValueRef) return ValueRef; + function ConstShuffleVector(VectorAConstant : ValueRef; + VectorBConstant : ValueRef; + MaskConstant : ValueRef) return ValueRef; + + -- Operations on global variables, functions, and aliases (globals) + function GetGlobalParent(Global : ValueRef) return ModuleRef; + function IsDeclaration(Global : ValueRef) return int; + function GetLinkage(Global : ValueRef) return Linkage; + procedure SetLinkage(Global : ValueRef; Link : Linkage); + function GetSection(Global : ValueRef) return Cstring; + procedure SetSection(Global : ValueRef; Section : Cstring); + function GetVisibility(Global : ValueRef) return Visibility; + procedure SetVisibility(Global : ValueRef; Viz : Visibility); + function GetAlignment(Global : ValueRef) return unsigned; + procedure SetAlignment(Global : ValueRef; Bytes : unsigned); + + -- Operations on global variables + function AddGlobal(M : ModuleRef; Ty : TypeRef; Name : Cstring) + return ValueRef; + function GetNamedGlobal(M : ModuleRef; Name : Cstring) return ValueRef; + function GetFirstGlobal(M : ModuleRef) return ValueRef; + function GetLastGlobal(M : ModuleRef) return ValueRef; + function GetNextGlobal(GlobalVar : ValueRef) return ValueRef; + function GetPreviousGlobal(GlobalVar : ValueRef) return ValueRef; + procedure DeleteGlobal(GlobalVar : ValueRef); + function GetInitializer(GlobalVar : ValueRef) return ValueRef; + procedure SetInitializer(GlobalVar : ValueRef; ConstantVal : ValueRef); + function IsThreadLocal(GlobalVar : ValueRef) return int; + procedure SetThreadLocal(GlobalVar : ValueRef; IsThreadLocal : int); + function IsGlobalConstant(GlobalVar : ValueRef) return int; + procedure SetGlobalConstant(GlobalVar : ValueRef; IsConstant : int); + + -- Operations on functions + function AddFunction(M : ModuleRef; Name : Cstring; FunctionTy : TypeRef) + return ValueRef; + function GetNamedFunction(M : ModuleRef; Name : Cstring) return ValueRef; + function GetFirstFunction(M : ModuleRef) return ValueRef; + function GetLastFunction(M : ModuleRef) return ValueRef; + function GetNextFunction(Fn : ValueRef) return ValueRef; + function GetPreviousFunction(Fn : ValueRef) return ValueRef; + procedure DeleteFunction(Fn : ValueRef); + function GetIntrinsicID(Fn : ValueRef) return unsigned; + function GetFunctionCallConv(Fn : ValueRef) return CallConv; + procedure SetFunctionCallConv(Fn : ValueRef; CC : CallConv); + function GetGC(Fn : ValueRef) return Cstring; + procedure SetGC(Fn : ValueRef; Name : Cstring); + + -- Attribute index + function GetEnumAttributeKindForName (Name : Cstring; Len : unsigned) + return unsigned; + function GetLastEnumAttributeKind return unsigned; + + function CreateEnumAttribute + (C : ContextRef; KindID : unsigned; Val : Unsigned_64) + return AttributeRef; + + procedure AddAttributeAtIndex + (F : ValueRef; Idx : AttributeIndex; A : AttributeRef); + + -- 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 SetParamAlignment(Arg : ValueRef; align : unsigned); + + -- Operations on basic blocks + function BasicBlockAsValue(BB : BasicBlockRef) return ValueRef; + function ValueIsBasicBlock(Val : ValueRef) return int; + function ValueAsBasicBlock(Val : ValueRef) return BasicBlockRef; + function GetBasicBlockParent(BB : BasicBlockRef) return ValueRef; + function CountBasicBlocks(Fn : ValueRef) return unsigned; + procedure GetBasicBlocks(Fn : ValueRef; BasicBlocks : BasicBlockRefArray); + function GetFirstBasicBlock(Fn : ValueRef) return BasicBlockRef; + function GetLastBasicBlock(Fn : ValueRef) return BasicBlockRef; + function GetNextBasicBlock(BB : BasicBlockRef) return BasicBlockRef; + function GetPreviousBasicBlock(BB : BasicBlockRef) return BasicBlockRef; + function GetEntryBasicBlock(Fn : ValueRef) return BasicBlockRef; + function AppendBasicBlock(Fn : ValueRef; Name : Cstring) + return BasicBlockRef; + function InsertBasicBlock(InsertBeforeBB : BasicBlockRef; + Name : Cstring) return BasicBlockRef; + procedure DeleteBasicBlock(BB : BasicBlockRef); + + -- Operations on instructions + + -- Determine whether an instruction has any metadata attached. + function HasMetadata(Val: ValueRef) return Bool; + + -- Return metadata associated with an instruction value. + function GetMetadata(Val : ValueRef; KindID : unsigned) return ValueRef; + + -- Set metadata associated with an instruction value. + procedure SetMetadata(Val : ValueRef; KindID : unsigned; Node : ValueRef); + + function GetInstructionParent(Inst : ValueRef) return BasicBlockRef; + function GetFirstInstruction(BB : BasicBlockRef) return ValueRef; + function GetLastInstruction(BB : BasicBlockRef) return ValueRef; + function GetNextInstruction(Inst : ValueRef) return ValueRef; + function GetPreviousInstruction(Inst : ValueRef) return ValueRef; + + -- Operations on call sites + procedure SetInstructionCallConv(Instr : ValueRef; CC : unsigned); + function GetInstructionCallConv(Instr : ValueRef) return unsigned; + procedure SetInstrParamAlignment(Instr : ValueRef; + index : unsigned; align : unsigned); + + -- Operations on call instructions (only) + function IsTailCall(CallInst : ValueRef) return int; + procedure SetTailCall(CallInst : ValueRef; IsTailCall : int); + + -- Operations on phi nodes + procedure AddIncoming(PhiNode : ValueRef; IncomingValues : ValueRefArray; + IncomingBlocks : BasicBlockRefArray; Count : unsigned); + function CountIncoming(PhiNode : ValueRef) return unsigned; + function GetIncomingValue(PhiNode : ValueRef; Index : unsigned) + return ValueRef; + function GetIncomingBlock(PhiNode : ValueRef; Index : unsigned) + return BasicBlockRef; + + -- Instruction builders ---------------------------------------------- + -- An instruction builder represents a point within a basic block, + -- and is the exclusive means of building instructions using the C + -- interface. + + function CreateBuilder return BuilderRef; + procedure PositionBuilder(Builder : BuilderRef; + Block : BasicBlockRef; Instr : ValueRef); + procedure PositionBuilderBefore(Builder : BuilderRef; Instr : ValueRef); + procedure PositionBuilderAtEnd(Builder : BuilderRef; Block : BasicBlockRef); + function GetInsertBlock(Builder : BuilderRef) return BasicBlockRef; + procedure DisposeBuilder(Builder : BuilderRef); + + -- Terminators + function BuildRetVoid(Builder : BuilderRef) return ValueRef; + function BuildRet(Builder : BuilderRef; V : ValueRef) return ValueRef; + function BuildBr(Builder : BuilderRef; Dest : BasicBlockRef) + return ValueRef; + function BuildCondBr(Builder : BuilderRef; + If_Br : ValueRef; + Then_Br : BasicBlockRef; Else_Br : BasicBlockRef) + return ValueRef; + function BuildSwitch(Builder : BuilderRef; + V : ValueRef; + Else_Br : BasicBlockRef; NumCases : unsigned) + return ValueRef; + function BuildInvoke(Builder : BuilderRef; + Fn : ValueRef; + Args : ValueRefArray; + NumArgs : unsigned; + Then_Br : BasicBlockRef; + Catch : BasicBlockRef; + Name : Cstring) return ValueRef; + function BuildUnwind(Builder : BuilderRef) return ValueRef; + function BuildUnreachable(Builder : BuilderRef) return ValueRef; + + -- Add a case to the switch instruction + procedure AddCase(Switch : ValueRef; + OnVal : ValueRef; Dest : BasicBlockRef); + + -- Arithmetic + function BuildAdd(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildNSWAdd(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildNUWAdd(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildFAdd(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + + function BuildSub(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildNSWSub(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildNUWSub(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildFSub(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + + function BuildMul(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildFMul(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + + function BuildUDiv(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildSDiv(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildFDiv(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildURem(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildSRem(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildFRem(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildShl(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildLShr(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildAShr(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildAnd(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildOr(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildXor(Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildNeg(Builder : BuilderRef; V : ValueRef; Name : Cstring) + return ValueRef; + function BuildFNeg(Builder : BuilderRef; V : ValueRef; Name : Cstring) + return ValueRef; + function BuildNot(Builder : BuilderRef; V : ValueRef; Name : Cstring) + return ValueRef; + + -- Memory + function BuildMalloc(Builder : BuilderRef; Ty : TypeRef; Name : Cstring) + return ValueRef; + function BuildArrayMalloc(Builder : BuilderRef; + Ty : TypeRef; Val : ValueRef; Name : Cstring) + return ValueRef; + function BuildAlloca(Builder : BuilderRef; Ty : TypeRef; Name : Cstring) + return ValueRef; + function BuildArrayAlloca(Builder : BuilderRef; + Ty : TypeRef; Val : ValueRef; Name : Cstring) + return ValueRef; + function BuildFree(Builder : BuilderRef; PointerVal : ValueRef) + return ValueRef; + function BuildLoad(Builder : BuilderRef; PointerVal : ValueRef; + Name : Cstring) return ValueRef; + function BuildStore(Builder : BuilderRef; Val : ValueRef; Ptr : ValueRef) + return ValueRef; + function BuildGEP(Builder : BuilderRef; + Pointer : ValueRef; + Indices : ValueRefArray; + NumIndices : unsigned; Name : Cstring) return ValueRef; + + -- Casts + function BuildTrunc(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + function BuildZExt(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + function BuildSExt(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + function BuildFPToUI(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + function BuildFPToSI(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + function BuildUIToFP(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + function BuildSIToFP(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + function BuildFPTrunc(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + function BuildFPExt(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + function BuildPtrToInt(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + function BuildIntToPtr(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + function BuildBitCast(Builder : BuilderRef; + Val : ValueRef; DestTy : TypeRef; Name : Cstring) + return ValueRef; + + -- Comparisons + function BuildICmp(Builder : BuilderRef; + Op : IntPredicate; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + function BuildFCmp(Builder : BuilderRef; + Op : RealPredicate; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + + -- Miscellaneous instructions + function BuildPhi(Builder : BuilderRef; Ty : TypeRef; Name : Cstring) + return ValueRef; + function BuildCall(Builder : BuilderRef; + Fn : ValueRef; + Args : ValueRefArray; NumArgs : unsigned; Name : Cstring) + return ValueRef; + function BuildSelect(Builder : BuilderRef; + If_Sel : ValueRef; + Then_Sel : ValueRef; + Else_Sel : ValueRef; + Name : Cstring) return ValueRef; + function BuildVAArg(Builder : BuilderRef; + List : ValueRef; Ty : TypeRef; Name : Cstring) + return ValueRef; + function BuildExtractElement(Builder : BuilderRef; + VecVal : ValueRef; + Index : ValueRef; + Name : Cstring) return ValueRef; + function BuildInsertElement(Builder : BuilderRef; + VecVal : ValueRef; + EltVal : ValueRef; + Index : ValueRef; + Name : Cstring) return ValueRef; + function BuildShuffleVector(Builder : BuilderRef; + V1 : ValueRef; + V2 : ValueRef; + Mask : ValueRef; + Name : Cstring) return ValueRef; + + -- Memory buffers ---------------------------------------------------- + + function CreateMemoryBufferWithContentsOfFile + (Path : Cstring; + OutMemBuf : access MemoryBufferRef; + OutMessage : access Cstring) return int; + function CreateMemoryBufferWithSTDIN + (OutMemBuf : access MemoryBufferRef; + OutMessage : access Cstring) return int; + procedure DisposeMemoryBuffer(MemBuf : MemoryBufferRef); + + + -- Pass Managers ----------------------------------------------------- + + -- Constructs a new whole-module pass pipeline. This type of pipeline is + -- suitable for link-time optimization and whole-module transformations. + -- See llvm::PassManager::PassManager. + function CreatePassManager return PassManagerRef; + + -- Constructs a new function-by-function pass pipeline over the module + -- provider. It does not take ownership of the module provider. This type of + -- pipeline is suitable for code generation and JIT compilation tasks. + -- See llvm::FunctionPassManager::FunctionPassManager. + function CreateFunctionPassManagerForModule(M : ModuleRef) + return PassManagerRef; + + -- Initializes, executes on the provided module, and finalizes all of the + -- passes scheduled in the pass manager. Returns 1 if any of the passes + -- modified the module, 0 otherwise. See llvm::PassManager::run(Module&). + function RunPassManager(PM : PassManagerRef; M : ModuleRef) + return int; + + -- Initializes all of the function passes scheduled in the function pass + -- manager. Returns 1 if any of the passes modified the module, 0 otherwise. + -- See llvm::FunctionPassManager::doInitialization. + function InitializeFunctionPassManager(FPM : PassManagerRef) + return int; + + -- Executes all of the function passes scheduled in the function + -- pass manager on the provided function. Returns 1 if any of the + -- passes modified the function, false otherwise. + -- See llvm::FunctionPassManager::run(Function&). + function RunFunctionPassManager (FPM : PassManagerRef; F : ValueRef) + return int; + + -- Finalizes all of the function passes scheduled in in the function pass + -- manager. Returns 1 if any of the passes modified the module, 0 otherwise. + -- See llvm::FunctionPassManager::doFinalization. + function FinalizeFunctionPassManager(FPM : PassManagerRef) + return int; + + -- Frees the memory of a pass pipeline. For function pipelines, + -- does not free the module provider. + -- See llvm::PassManagerBase::~PassManagerBase. + procedure DisposePassManager(PM : PassManagerRef); + +private + pragma Import (C, ContextCreate, "LLVMContextCreate"); + pragma Import (C, GetGlobalContext, "LLVMGetGlobalContext"); + pragma Import (C, ContextDispose, "LLVMContextDispose"); + + pragma Import (C, DisposeMessage, "LLVMDisposeMessage"); + pragma Import (C, ModuleCreateWithName, "LLVMModuleCreateWithName"); + pragma Import (C, DisposeModule, "LLVMDisposeModule"); + pragma Import (C, GetDataLayout, "LLVMGetDataLayout"); + pragma Import (C, SetDataLayout, "LLVMSetDataLayout"); + pragma Import (C, GetTarget, "LLVMGetTarget"); + pragma Import (C, SetTarget, "LLVMSetTarget"); + pragma Import (C, DumpModule, "LLVMDumpModule"); + pragma Import (C, PrintModuleToFile, "LLVMPrintModuleToFile"); + pragma Import (C, GetTypeKind, "LLVMGetTypeKind"); + pragma Import (C, Int1Type, "LLVMInt1Type"); + pragma Import (C, Int8Type, "LLVMInt8Type"); + pragma Import (C, Int16Type, "LLVMInt16Type"); + pragma Import (C, Int32Type, "LLVMInt32Type"); + pragma Import (C, Int64Type, "LLVMInt64Type"); + pragma Import (C, IntType, "LLVMIntType"); + pragma Import (C, GetIntTypeWidth, "LLVMGetIntTypeWidth"); + pragma Import (C, MetadataType, "LLVMMetadataType_extra"); + + pragma Import (C, FloatType, "LLVMFloatType"); + pragma Import (C, DoubleType, "LLVMDoubleType"); + pragma Import (C, X86FP80Type, "LLVMX86FP80Type"); + pragma Import (C, FP128Type, "LLVMFP128Type"); + pragma Import (C, PPCFP128Type, "LLVMPPCFP128Type"); + + pragma Import (C, FunctionType, "LLVMFunctionType"); + pragma Import (C, IsFunctionVarArg, "LLVMIsFunctionVarArg"); + pragma Import (C, GetReturnType, "LLVMGetReturnType"); + pragma Import (C, CountParamTypes, "LLVMCountParamTypes"); + pragma Import (C, GetParamTypes, "LLVMGetParamTypes"); + + pragma Import (C, StructType, "LLVMStructType"); + pragma Import (C, StructCreateNamed, "LLVMStructCreateNamed"); + pragma Import (C, StructSetBody, "LLVMStructSetBody"); + pragma Import (C, CountStructElementTypes, "LLVMCountStructElementTypes"); + pragma Import (C, GetStructElementTypes, "LLVMGetStructElementTypes"); + pragma Import (C, IsPackedStruct, "LLVMIsPackedStruct"); + + pragma Import (C, ArrayType, "LLVMArrayType"); + pragma Import (C, PointerType, "LLVMPointerType"); + pragma Import (C, VectorType, "LLVMVectorType"); + pragma Import (C, GetElementType, "LLVMGetElementType"); + pragma Import (C, GetArrayLength, "LLVMGetArrayLength"); + pragma Import (C, GetPointerAddressSpace, "LLVMGetPointerAddressSpace"); + pragma Import (C, GetVectorSize, "LLVMGetVectorSize"); + + pragma Import (C, VoidType, "LLVMVoidType"); + pragma Import (C, LabelType, "LLVMLabelType"); + pragma Import (C, DumpType, "LLVMDumpType"); + + pragma Import (C, TypeOf, "LLVMTypeOf"); + pragma Import (C, GetValueName, "LLVMGetValueName"); + pragma Import (C, SetValueName, "LLVMSetValueName"); + pragma Import (C, DumpValue, "LLVMDumpValue"); + + pragma Import (C, ConstNull, "LLVMConstNull"); + pragma Import (C, ConstAllOnes, "LLVMConstAllOnes"); + pragma Import (C, GetUndef, "LLVMGetUndef"); + pragma Import (C, IsConstant, "LLVMIsConstant"); + pragma Import (C, IsNull, "LLVMIsNull"); + pragma Import (C, IsUndef, "LLVMIsUndef"); + pragma Import (C, IsAInstruction, "LLVMIsAInstruction"); + + pragma Import (C, ConstInt, "LLVMConstInt"); + pragma Import (C, ConstReal, "LLVMConstReal"); + pragma Import (C, ConstIntGetZExtValue, "LLVMConstIntGetZExtValue"); + pragma Import (C, ConstRealOfString, "LLVMConstRealOfString"); + pragma Import (C, ConstString, "LLVMConstString"); + pragma Import (C, ConstArray, "LLVMConstArray"); + pragma Import (C, ConstStruct, "LLVMConstStruct"); + pragma Import (C, ConstNamedStruct, "LLVMConstNamedStruct"); + pragma Import (C, ConstVector, "LLVMConstVector"); + + pragma Import (C, SizeOf, "LLVMSizeOf"); + pragma Import (C, AlignOf, "LLVMAlignOf"); + pragma Import (C, ConstNeg, "LLVMConstNeg"); + pragma Import (C, ConstNot, "LLVMConstNot"); + pragma Import (C, ConstAdd, "LLVMConstAdd"); + pragma Import (C, ConstSub, "LLVMConstSub"); + pragma Import (C, ConstMul, "LLVMConstMul"); + pragma Import (C, ConstUDiv, "LLVMConstUDiv"); + pragma Import (C, ConstSDiv, "LLVMConstSDiv"); + pragma Import (C, ConstFDiv, "LLVMConstFDiv"); + pragma Import (C, ConstURem, "LLVMConstURem"); + pragma Import (C, ConstSRem, "LLVMConstSRem"); + pragma Import (C, ConstFRem, "LLVMConstFRem"); + pragma Import (C, ConstAnd, "LLVMConstAnd"); + pragma Import (C, ConstOr, "LLVMConstOr"); + pragma Import (C, ConstXor, "LLVMConstXor"); + pragma Import (C, ConstICmp, "LLVMConstICmp"); + pragma Import (C, ConstFCmp, "LLVMConstFCmp"); + pragma Import (C, ConstShl, "LLVMConstShl"); + pragma Import (C, ConstLShr, "LLVMConstLShr"); + pragma Import (C, ConstAShr, "LLVMConstAShr"); + pragma Import (C, ConstGEP, "LLVMConstGEP"); + pragma Import (C, ConstTrunc, "LLVMConstTrunc"); + pragma Import (C, ConstSExt, "LLVMConstSExt"); + pragma Import (C, ConstZExt, "LLVMConstZExt"); + pragma Import (C, ConstFPTrunc, "LLVMConstFPTrunc"); + pragma Import (C, ConstFPExt, "LLVMConstFPExt"); + pragma Import (C, ConstUIToFP, "LLVMConstUIToFP"); + pragma Import (C, ConstSIToFP, "LLVMConstSIToFP"); + pragma Import (C, ConstFPToUI, "LLVMConstFPToUI"); + pragma Import (C, ConstFPToSI, "LLVMConstFPToSI"); + pragma Import (C, ConstPtrToInt, "LLVMConstPtrToInt"); + pragma Import (C, ConstIntToPtr, "LLVMConstIntToPtr"); + pragma Import (C, ConstBitCast, "LLVMConstBitCast"); + pragma Import (C, ConstTruncOrBitCast, "LLVMConstTruncOrBitCast"); + pragma Import (C, ConstSelect, "LLVMConstSelect"); + pragma Import (C, ConstExtractElement, "LLVMConstExtractElement"); + pragma Import (C, ConstInsertElement, "LLVMConstInsertElement"); + pragma Import (C, ConstShuffleVector, "LLVMConstShuffleVector"); + + pragma Import (C, GetGlobalParent, "LLVMGetGlobalParent"); + pragma Import (C, IsDeclaration, "LLVMIsDeclaration"); + pragma Import (C, GetLinkage, "LLVMGetLinkage"); + pragma Import (C, SetLinkage, "LLVMSetLinkage"); + pragma Import (C, GetSection, "LLVMGetSection"); + pragma Import (C, SetSection, "LLVMSetSection"); + pragma Import (C, GetVisibility, "LLVMGetVisibility"); + pragma Import (C, SetVisibility, "LLVMSetVisibility"); + pragma Import (C, GetAlignment, "LLVMGetAlignment"); + pragma Import (C, SetAlignment, "LLVMSetAlignment"); + + pragma Import (C, AddGlobal, "LLVMAddGlobal"); + pragma Import (C, GetNamedGlobal, "LLVMGetNamedGlobal"); + pragma Import (C, GetFirstGlobal, "LLVMGetFirstGlobal"); + pragma Import (C, GetLastGlobal, "LLVMGetLastGlobal"); + pragma Import (C, GetNextGlobal, "LLVMGetNextGlobal"); + pragma Import (C, GetPreviousGlobal, "LLVMGetPreviousGlobal"); + pragma Import (C, DeleteGlobal, "LLVMDeleteGlobal"); + pragma Import (C, GetInitializer, "LLVMGetInitializer"); + pragma Import (C, SetInitializer, "LLVMSetInitializer"); + pragma Import (C, IsThreadLocal, "LLVMIsThreadLocal"); + pragma Import (C, SetThreadLocal, "LLVMSetThreadLocal"); + pragma Import (C, IsGlobalConstant, "LLVMIsGlobalConstant"); + pragma Import (C, SetGlobalConstant, "LLVMSetGlobalConstant"); + + pragma Import (C, AddFunction, "LLVMAddFunction"); + pragma Import (C, GetNamedFunction, "LLVMGetNamedFunction"); + pragma Import (C, GetFirstFunction, "LLVMGetFirstFunction"); + pragma Import (C, GetLastFunction, "LLVMGetLastFunction"); + pragma Import (C, GetNextFunction, "LLVMGetNextFunction"); + pragma Import (C, GetPreviousFunction, "LLVMGetPreviousFunction"); + pragma Import (C, DeleteFunction, "LLVMDeleteFunction"); + pragma Import (C, GetIntrinsicID, "LLVMGetIntrinsicID"); + pragma Import (C, GetFunctionCallConv, "LLVMGetFunctionCallConv"); + pragma Import (C, SetFunctionCallConv, "LLVMSetFunctionCallConv"); + pragma Import (C, GetGC, "LLVMGetGC"); + pragma Import (C, SetGC, "LLVMSetGC"); + + pragma Import (C, GetEnumAttributeKindForName, + "LLVMGetEnumAttributeKindForName"); + pragma Import (C, GetLastEnumAttributeKind, + "LLVMGetLastEnumAttributeKind"); + pragma Import (C, CreateEnumAttribute, + "LLVMCreateEnumAttribute"); + pragma Import (C, AddAttributeAtIndex, + "LLVMAddAttributeAtIndex"); + + 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, SetParamAlignment, "LLVMSetParamAlignment"); + + pragma Import (C, BasicBlockAsValue, "LLVMBasicBlockAsValue"); + pragma Import (C, ValueIsBasicBlock, "LLVMValueIsBasicBlock"); + pragma Import (C, ValueAsBasicBlock, "LLVMValueAsBasicBlock"); + pragma Import (C, GetBasicBlockParent, "LLVMGetBasicBlockParent"); + pragma Import (C, CountBasicBlocks, "LLVMCountBasicBlocks"); + pragma Import (C, GetBasicBlocks, "LLVMGetBasicBlocks"); + pragma Import (C, GetFirstBasicBlock, "LLVMGetFirstBasicBlock"); + pragma Import (C, GetLastBasicBlock, "LLVMGetLastBasicBlock"); + pragma Import (C, GetNextBasicBlock, "LLVMGetNextBasicBlock"); + pragma Import (C, GetPreviousBasicBlock, "LLVMGetPreviousBasicBlock"); + pragma Import (C, GetEntryBasicBlock, "LLVMGetEntryBasicBlock"); + pragma Import (C, AppendBasicBlock, "LLVMAppendBasicBlock"); + pragma Import (C, InsertBasicBlock, "LLVMInsertBasicBlock"); + pragma Import (C, DeleteBasicBlock, "LLVMDeleteBasicBlock"); + + pragma Import (C, HasMetadata, "LLVMHasMetadata"); + pragma Import (C, GetMetadata, "LLVMGetMetadata"); + pragma Import (C, SetMetadata, "LLVMSetMetadata"); + + pragma Import (C, GetInstructionParent, "LLVMGetInstructionParent"); + pragma Import (C, GetFirstInstruction, "LLVMGetFirstInstruction"); + pragma Import (C, GetLastInstruction, "LLVMGetLastInstruction"); + pragma Import (C, GetNextInstruction, "LLVMGetNextInstruction"); + pragma Import (C, GetPreviousInstruction, "LLVMGetPreviousInstruction"); + + pragma Import (C, SetInstructionCallConv, "LLVMSetInstructionCallConv"); + pragma Import (C, GetInstructionCallConv, "LLVMGetInstructionCallConv"); + pragma Import (C, 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/llvm4-nodebug/llvm-target.ads b/src/ortho/llvm4-nodebug/llvm-target.ads new file mode 100644 index 000000000..c5c89d84f --- /dev/null +++ b/src/ortho/llvm4-nodebug/llvm-target.ads @@ -0,0 +1,97 @@ +-- 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"); + + -- Target Data + + -- Obtain the data layout for a module. + -- see Module::getDataLayout() + function GetModuleDataLayout (M : ModuleRef) return TargetDataRef; + pragma Import (C, GetModuleDataLayout, "LLVMGetModuleDataLayout"); + + -- Set the data layout for a module. + -- see Module::setDataLayout() + procedure SetModuleDataLayout (M : ModuleRef; DL : TargetDataRef); + pragma Import (C, SetModuleDataLayout, "LLVMSetModuleDataLayout"); + + -- 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"); + + -- Removed in LLVM 3.9 !! + -- 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/llvm4-nodebug/llvm-targetmachine.ads b/src/ortho/llvm4-nodebug/llvm-targetmachine.ads new file mode 100644 index 000000000..e753acf1d --- /dev/null +++ b/src/ortho/llvm4-nodebug/llvm-targetmachine.ads @@ -0,0 +1,126 @@ +-- 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"); + + -- Create a DataLayout based on the targetMachine. + function CreateTargetDataLayout (T : TargetMachineRef) return TargetDataRef; + pragma Import (C, CreateTargetDataLayout, "LLVMCreateTargetDataLayout"); + + -- 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/llvm4-nodebug/llvm-transforms-scalar.ads b/src/ortho/llvm4-nodebug/llvm-transforms-scalar.ads new file mode 100644 index 000000000..0f23ce87e --- /dev/null +++ b/src/ortho/llvm4-nodebug/llvm-transforms-scalar.ads @@ -0,0 +1,169 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with LLVM.Core; use LLVM.Core; + +package LLVM.Transforms.Scalar is + -- See llvm::createAggressiveDCEPass function. + procedure AddAggressiveDCEPass(PM : PassManagerRef); + pragma Import (C, AddAggressiveDCEPass, "LLVMAddAggressiveDCEPass"); + + -- See llvm::createCFGSimplificationPass function. + procedure AddCFGSimplificationPass(PM : PassManagerRef); + pragma Import (C, AddCFGSimplificationPass, "LLVMAddCFGSimplificationPass"); + + -- See llvm::createDeadStoreEliminationPass function. + procedure AddDeadStoreEliminationPass(PM : PassManagerRef); + pragma Import (C, AddDeadStoreEliminationPass, + "LLVMAddDeadStoreEliminationPass"); + + -- See llvm::createScalarizerPass function. + procedure AddScalarizerPass(PM : PassManagerRef); + pragma Import (C, AddScalarizerPass, "LLVMAddScalarizerPass"); + + -- See llvm::createGVNPass function. + procedure AddGVNPass(PM : PassManagerRef); + pragma Import (C, AddGVNPass, "LLVMAddGVNPass"); + + -- See llvm::createIndVarSimplifyPass function. + procedure AddIndVarSimplifyPass(PM : PassManagerRef); + pragma Import (C, AddIndVarSimplifyPass, "LLVMAddIndVarSimplifyPass"); + + -- See llvm::createInstructionCombiningPass function. + procedure AddInstructionCombiningPass(PM : PassManagerRef); + pragma Import (C, AddInstructionCombiningPass, + "LLVMAddInstructionCombiningPass"); + + -- See llvm::createJumpThreadingPass function. + procedure AddJumpThreadingPass(PM : PassManagerRef); + pragma Import (C, AddJumpThreadingPass, "LLVMAddJumpThreadingPass"); + + -- See llvm::createLICMPass function. + procedure AddLICMPass(PM : PassManagerRef); + pragma Import (C, AddLICMPass, "LLVMAddLICMPass"); + + -- See llvm::createLoopDeletionPass function. + procedure AddLoopDeletionPass(PM : PassManagerRef); + pragma Import (C, AddLoopDeletionPass, "LLVMAddLoopDeletionPass"); + + -- See llvm::createLoopIdiomPass function + procedure AddLoopIdiomPass(PM : PassManagerRef); + pragma Import (C, AddLoopIdiomPass, "LLVMAddLoopIdiomPass"); + + -- See llvm::createLoopRotatePass function. + procedure AddLoopRotatePass(PM : PassManagerRef); + pragma Import (C, AddLoopRotatePass, "LLVMAddLoopRotatePass"); + + -- See llvm::createLoopRerollPass function. + procedure AddLoopRerollPass(PM : PassManagerRef); + pragma Import (C, AddLoopRerollPass, "LLVMAddLoopRerollPass"); + + -- See llvm::createLoopUnrollPass function. + procedure AddLoopUnrollPass(PM : PassManagerRef); + pragma Import (C, AddLoopUnrollPass, "LLVMAddLoopUnrollPass"); + + -- See llvm::createLoopUnswitchPass function. + procedure AddLoopUnswitchPass(PM : PassManagerRef); + pragma Import (C, AddLoopUnswitchPass, "LLVMAddLoopUnswitchPass"); + + -- See llvm::createMemCpyOptPass function. + procedure AddMemCpyOptPass(PM : PassManagerRef); + pragma Import (C, AddMemCpyOptPass, "LLVMAddMemCpyOptPass"); + + -- See llvm::createPartiallyInlineLibCallsPass function. + procedure AddPartiallyInlineLibCallsPass(PM : PassManagerRef); + pragma Import (C, AddPartiallyInlineLibCallsPass, + "LLVMAddPartiallyInlineLibCallsPass"); + + -- See llvm::createPromoteMemoryToRegisterPass function. + procedure AddPromoteMemoryToRegisterPass(PM : PassManagerRef); + pragma Import (C, AddPromoteMemoryToRegisterPass, + "LLVMAddPromoteMemoryToRegisterPass"); + + -- See llvm::createReassociatePass function. + procedure AddReassociatePass(PM : PassManagerRef); + pragma Import (C, AddReassociatePass, "LLVMAddReassociatePass"); + + -- See llvm::createSCCPPass function. + procedure AddSCCPPass(PM : PassManagerRef); + pragma Import (C, AddSCCPPass, "LLVMAddSCCPPass"); + + -- See llvm::createScalarReplAggregatesPass function. + procedure AddScalarReplAggregatesPass(PM : PassManagerRef); + pragma Import (C, AddScalarReplAggregatesPass, + "LLVMAddScalarReplAggregatesPass"); + + -- See llvm::createScalarReplAggregatesPass function. + procedure AddScalarReplAggregatesPassSSA(PM : PassManagerRef); + pragma Import (C, AddScalarReplAggregatesPassSSA, + "LLVMAddScalarReplAggregatesPassSSA"); + + -- See llvm::createScalarReplAggregatesPass function. + procedure AddScalarReplAggregatesPassWithThreshold + (PM : PassManagerRef; Threshold : Integer); + pragma Import (C, AddScalarReplAggregatesPassWithThreshold, + "LLVMAddScalarReplAggregatesPassWithThreshold"); + + -- See llvm::createSimplifyLibCallsPass function. + procedure AddSimplifyLibCallsPass(PM : PassManagerRef); + pragma Import (C, AddSimplifyLibCallsPass, "LLVMAddSimplifyLibCallsPass"); + + -- See llvm::createTailCallEliminationPass function. + procedure AddTailCallEliminationPass(PM : PassManagerRef); + pragma Import (C, AddTailCallEliminationPass, + "LLVMAddTailCallEliminationPass"); + + -- See llvm::createConstantPropagationPass function. + procedure AddConstantPropagationPass(PM : PassManagerRef); + pragma Import (C, AddConstantPropagationPass, + "LLVMAddConstantPropagationPass"); + + -- See llvm::demotePromoteMemoryToRegisterPass function. + procedure AddDemoteMemoryToRegisterPass(PM : PassManagerRef); + pragma Import (C, AddDemoteMemoryToRegisterPass, + "LLVMAddDemoteMemoryToRegisterPass"); + + -- See llvm::createVerifierPass function. + procedure AddVerifierPass(PM : PassManagerRef); + pragma Import (C, AddVerifierPass, "LLVMAddVerifierPass"); + + -- See llvm::createCorrelatedValuePropagationPass function + procedure AddCorrelatedValuePropagationPass(PM : PassManagerRef); + pragma Import (C, AddCorrelatedValuePropagationPass, + "LLVMAddCorrelatedValuePropagationPass"); + + -- See llvm::createEarlyCSEPass function + procedure AddEarlyCSEPass(PM : PassManagerRef); + pragma Import (C, AddEarlyCSEPass, "LLVMAddEarlyCSEPass"); + + -- See llvm::createLowerExpectIntrinsicPass function + procedure AddLowerExpectIntrinsicPass(PM : PassManagerRef); + pragma Import (C, AddLowerExpectIntrinsicPass, + "LLVMAddLowerExpectIntrinsicPass"); + + -- See llvm::createTypeBasedAliasAnalysisPass function + procedure AddTypeBasedAliasAnalysisPass(PM : PassManagerRef); + pragma Import (C, AddTypeBasedAliasAnalysisPass, + "LLVMAddTypeBasedAliasAnalysisPass"); + + -- See llvm::createBasicAliasAnalysisPass function + procedure AddBasicAliasAnalysisPass(PM : PassManagerRef); + pragma Import (C, AddBasicAliasAnalysisPass, + "LLVMAddBasicAliasAnalysisPass"); +end LLVM.Transforms.Scalar; + + diff --git a/src/ortho/llvm4-nodebug/llvm-transforms.ads b/src/ortho/llvm4-nodebug/llvm-transforms.ads new file mode 100644 index 000000000..d5a8011ce --- /dev/null +++ b/src/ortho/llvm4-nodebug/llvm-transforms.ads @@ -0,0 +1,21 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package LLVM.Transforms is + pragma Pure (LLVM.Transforms); +end LLVM.Transforms; diff --git a/src/ortho/llvm4-nodebug/llvm.ads b/src/ortho/llvm4-nodebug/llvm.ads new file mode 100644 index 000000000..80d036b84 --- /dev/null +++ b/src/ortho/llvm4-nodebug/llvm.ads @@ -0,0 +1,21 @@ +-- LLVM binding +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package LLVM is + pragma Pure (LLVM); +end LLVM; diff --git a/src/ortho/llvm4-nodebug/ortho_code_main4.adb b/src/ortho/llvm4-nodebug/ortho_code_main4.adb new file mode 100644 index 000000000..cbe82c24b --- /dev/null +++ b/src/ortho/llvm4-nodebug/ortho_code_main4.adb @@ -0,0 +1,318 @@ +-- LLVM back-end for ortho - Main subprogram. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Unchecked_Deallocation; +with Ada.Unchecked_Conversion; +with Ada.Text_IO; use Ada.Text_IO; + +with Ortho_Front; use Ortho_Front; +with LLVM.BitWriter; +with LLVM.Core; use LLVM.Core; +with LLVM.Target; use LLVM.Target; +with LLVM.TargetMachine; use LLVM.TargetMachine; +with LLVM.Analysis; +with LLVM.Transforms.Scalar; +with Ortho_LLVM; use Ortho_LLVM; +with Interfaces; +with Interfaces.C; use Interfaces.C; + +procedure Ortho_Code_Main4 is + -- Name of the output filename (given by option '-o'). + Output : String_Acc := null; + + type Output_Kind_Type is (Output_Llvm, Output_Bytecode, + Output_Assembly, Output_Object); + Output_Kind : Output_Kind_Type := Output_Llvm; + + -- True if the LLVM output must be displayed (set by '--dump-llvm') + Flag_Dump_Llvm : Boolean := False; + + -- Index of the first file argument. + First_File : Natural; + + -- Current option index. + Optind : Natural; + + -- Number of arguments. + Argc : constant Natural := Argument_Count; + + -- Name of the module. + Module_Name : String := "ortho" & Ascii.Nul; + + -- Target triple. + Triple : Cstring := Empty_Cstring; + + Target : aliased TargetRef; + + CPU : constant Cstring := Empty_Cstring; + Features : constant Cstring := Empty_Cstring; + Reloc : 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 = "-glines" + or else Arg = "-gline-tables-only" + then + null; + elsif Arg = "-g" then + null; + else + -- This is really an argument. + declare + procedure Unchecked_Deallocation is + new Ada.Unchecked_Deallocation + (Name => String_Acc, Object => String); + + Opt : String_Acc := new String'(Arg); + Opt_Arg : String_Acc; + Res : Natural; + begin + Opt_Arg := null; + if Optind < Argument_Count then + declare + Arg1 : constant String := Argument (Optind + 1); + begin + if Arg1 (Arg1'First) /= '-' then + Opt_Arg := new String'(Arg1); + end if; + end; + end if; + + Res := Ortho_Front.Decode_Option (Opt, Opt_Arg); + case Res is + when 0 => + Put_Line (Standard_Error, + "unknown option '" & Arg & "'"); + return; + when 1 => + null; + when 2 => + Optind := Optind + 1; + when others => + raise Program_Error; + end case; + Unchecked_Deallocation (Opt); + Unchecked_Deallocation (Opt_Arg); + end; + end if; + else + First_File := Optind; + exit; + end if; + end; + Optind := Optind + 1; + end loop; + + -- Link with LLVM libraries. + InitializeNativeTarget; + InitializeNativeAsmPrinter; + + -- LinkInJIT; + + Module := ModuleCreateWithName (Module_Name'Address); + + -- Extract target triple + Triple := GetDefaultTargetTriple; + SetTarget (Module, Triple); + + -- Get Target + if GetTargetFromTriple (Triple, Target'Access, Msg'Access) /= 0 then + raise Program_Error; + end if; + + -- Create a target machine + Target_Machine := CreateTargetMachine + (Target, Triple, CPU, Features, Optimization, Reloc, CodeModelDefault); + + Target_Data := CreateTargetDataLayout (Target_Machine); + SetModuleDataLayout (Module, Target_Data); + + Ortho_LLVM.Init; + + Set_Exit_Status (Failure); + + if First_File > Argument_Count then + begin + if not Parse (null) then + return; + end if; + exception + when others => + return; + end; + else + for I in First_File .. Argument_Count loop + declare + Filename : constant String_Acc := + new String'(Argument (First_File)); + begin + if not Parse (Filename) then + return; + end if; + exception + when others => + return; + end; + end loop; + end if; + + if Flag_Dump_Llvm then + DumpModule (Module); + end if; + + -- Verify module. + if False then + if LLVM.Analysis.VerifyModule + (Module, LLVM.Analysis.PrintMessageAction, Msg'Access) /= 0 + then + DisposeMessage (Msg); + raise Program_Error; + end if; + end if; + + if Optimization > CodeGenLevelNone then + declare + use LLVM.Transforms.Scalar; + Global_Manager : constant Boolean := False; + Pass_Manager : PassManagerRef; + Res : Bool; + pragma Unreferenced (Res); + A_Func : ValueRef; + begin + if Global_Manager then + Pass_Manager := CreatePassManager; + else + Pass_Manager := CreateFunctionPassManagerForModule (Module); + end if; + + AddPromoteMemoryToRegisterPass (Pass_Manager); + AddCFGSimplificationPass (Pass_Manager); + + if Global_Manager then + Res := RunPassManager (Pass_Manager, Module); + else + A_Func := GetFirstFunction (Module); + while A_Func /= Null_ValueRef loop + Res := RunFunctionPassManager (Pass_Manager, A_Func); + A_Func := GetNextFunction (A_Func); + end loop; + end if; + end; + end if; + + if Output /= null then + declare + Error : Boolean; + begin + Msg := Empty_Cstring; + + case Output_Kind is + when Output_Assembly + | Output_Object => + Error := LLVM.TargetMachine.TargetMachineEmitToFile + (Target_Machine, Module, + Output.all'Address, Codegen, Msg'Access) /= 0; + when Output_Bytecode => + Error := LLVM.BitWriter.WriteBitcodeToFile + (Module, Output.all'Address) /= 0; + when Output_Llvm => + Error := PrintModuleToFile + (Module, Output.all'Address, Msg'Access) /= 0; + end case; + if Error then + Put_Line (Standard_Error, + "error while writing to " & Output.all); + if Msg /= Empty_Cstring then + Put_Line (Standard_Error, + "message: " & To_String (Msg)); + DisposeMessage (Msg); + end if; + Set_Exit_Status (2); + return; + end if; + end; + else + DumpModule (Module); + end if; + + Set_Exit_Status (Success); +exception + when others => + Set_Exit_Status (2); + raise; +end Ortho_Code_Main4; diff --git a/src/ortho/llvm4-nodebug/ortho_ident.adb b/src/ortho/llvm4-nodebug/ortho_ident.adb new file mode 100644 index 000000000..e7b650539 --- /dev/null +++ b/src/ortho/llvm4-nodebug/ortho_ident.adb @@ -0,0 +1,134 @@ +-- LLVM back-end for ortho. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package body Ortho_Ident is + type Chunk (Max : Positive); + type Chunk_Acc is access Chunk; + + type Chunk (Max : Positive) is record + Prev : Chunk_Acc; + Len : Natural := 0; + S : String (1 .. Max); + end record; + + Cur_Chunk : Chunk_Acc := null; + + subtype Fat_String is String (Positive); + + function Get_Identifier (Str : String) return O_Ident + is + Len : constant Natural := Str'Length; + Max : Positive; + Org : Positive; + begin + if Cur_Chunk = null or else Cur_Chunk.Len + Len >= Cur_Chunk.Max then + if Cur_Chunk = null then + Max := 32 * 1024; + else + Max := 2 * Cur_Chunk.Max; + end if; + if Len + 2 > Max then + Max := 2 * (Len + 2); + end if; + declare + New_Chunk : Chunk_Acc; + begin + -- Do not use allocator by expression, as we don't want to + -- initialize S. + New_Chunk := new Chunk (Max); + New_Chunk.Len := 0; + New_Chunk.Prev := Cur_Chunk; + Cur_Chunk := New_Chunk; + end; + end if; + + Org := Cur_Chunk.Len + 1; + Cur_Chunk.S (Org .. Org + Len - 1) := Str; + Cur_Chunk.S (Org + Len) := ASCII.NUL; + Cur_Chunk.Len := Org + Len; + + return (Addr => Cur_Chunk.S (Org)'Address); + end Get_Identifier; + + function Is_Equal (L, R : O_Ident) return Boolean + is + begin + return L = R; + end Is_Equal; + + function Get_String_Length (Id : O_Ident) return Natural + is + Str : Fat_String; + pragma Import (Ada, Str); + for Str'Address use Id.Addr; + begin + for I in Str'Range loop + if Str (I) = ASCII.NUL then + return I - 1; + end if; + end loop; + raise Program_Error; + end Get_String_Length; + + function Get_String (Id : O_Ident) return String + is + Str : Fat_String; + pragma Import (Ada, Str); + for Str'Address use Id.Addr; + begin + for I in Str'Range loop + if Str (I) = ASCII.NUL then + return Str (1 .. I - 1); + end if; + end loop; + raise Program_Error; + end Get_String; + + function Get_Cstring (Id : O_Ident) return System.Address is + begin + return Id.Addr; + end Get_Cstring; + + function Is_Equal (Id : O_Ident; Str : String) return Boolean + is + Istr : Fat_String; + pragma Import (Ada, Istr); + for Istr'Address use Id.Addr; + + Str_Len : constant Natural := Str'Length; + begin + for I in Istr'Range loop + if Istr (I) = ASCII.NUL then + return I - 1 = Str_Len; + end if; + if I > Str_Len then + return False; + end if; + if Istr (I) /= Str (Str'First + I - 1) then + return False; + end if; + end loop; + raise Program_Error; + end Is_Equal; + + function Is_Nul (Id : O_Ident) return Boolean is + begin + return Id = O_Ident_Nul; + end Is_Nul; + +end Ortho_Ident; diff --git a/src/ortho/llvm4-nodebug/ortho_ident.ads b/src/ortho/llvm4-nodebug/ortho_ident.ads new file mode 100644 index 000000000..7d3955c02 --- /dev/null +++ b/src/ortho/llvm4-nodebug/ortho_ident.ads @@ -0,0 +1,42 @@ +-- LLVM back-end for ortho. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System; + +package Ortho_Ident is + type O_Ident is private; + + function Get_Identifier (Str : String) return O_Ident; + function Is_Equal (L, R : O_Ident) return Boolean; + function Is_Equal (Id : O_Ident; Str : String) return Boolean; + function Is_Nul (Id : O_Ident) return Boolean; + function Get_String (Id : O_Ident) return String; + function Get_String_Length (Id : O_Ident) return Natural; + + -- Note: the address is always valid. + function Get_Cstring (Id : O_Ident) return System.Address; + + O_Ident_Nul : constant O_Ident; + +private + type O_Ident is record + Addr : System.Address; + end record; + O_Ident_Nul : constant O_Ident := (Addr => System.Null_Address); + + pragma Inline (Get_Cstring); +end Ortho_Ident; diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.adb b/src/ortho/llvm4-nodebug/ortho_llvm.adb new file mode 100644 index 000000000..53f8dbe31 --- /dev/null +++ b/src/ortho/llvm4-nodebug/ortho_llvm.adb @@ -0,0 +1,2340 @@ +-- LLVM back-end for ortho. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with LLVM.Target; use LLVM.Target; + +package body Ortho_LLVM is + -- The current function for LLVM (needed to add new basic blocks). + Cur_Func : ValueRef; + + -- The current function node (needed for return type). + Cur_Func_Decl : O_Dnode; + + -- Wether the code is currently unreachable. LLVM doesn't accept basic + -- blocks that cannot be reached (using trivial rules). So we need to + -- discard instructions after a return, a next or an exit statement. + Unreach : Boolean; + + -- Builder for statements. + Builder : BuilderRef; + + -- Builder for declarations (local variables). + Decl_Builder : BuilderRef; + + -- Temporary builder. + Extra_Builder : BuilderRef; + + -- Additional data for declare blocks. + type Declare_Block_Type; + type Declare_Block_Acc is access Declare_Block_Type; + + type Declare_Block_Type is record + -- First basic block of the declare. + Stmt_Bb : BasicBlockRef; + + -- Stack pointer at entry of the block. This value has to be restore + -- when leaving the block (either normally or via exit/next). Set only + -- if New_Alloca was used. + -- FIXME: TODO: restore stack pointer on exit/next stmts. + Stack_Value : ValueRef; + + -- Debug data for the scope of the declare block. + Dbg_Scope : ValueRef; + + -- Previous element in the stack. + Prev : Declare_Block_Acc; + end record; + + -- Current declare block. + Cur_Declare_Block : Declare_Block_Acc; + + -- Chain of unused blocks to be recycled. + Old_Declare_Block : Declare_Block_Acc; + + Stacksave_Fun : ValueRef; + Stacksave_Name : constant String := "llvm.stacksave" & ASCII.NUL; + Stackrestore_Fun : ValueRef; + Stackrestore_Name : constant String := "llvm.stackrestore" & ASCII.NUL; + Copysign_Fun : ValueRef; + Copysign_Name : constant String := "llvm.copysign.f64" & ASCII.NUL; + Fp_0_5 : ValueRef; + + Nounwind_Attr : AttributeRef; + Uwtable_Attr : AttributeRef; + + procedure Free is new Ada.Unchecked_Deallocation + (ValueRefArray, ValueRefArray_Acc); + + procedure Create_Declare_Block + is + Res : Declare_Block_Acc; + begin + -- Try to recycle an unused record. + if Old_Declare_Block /= null then + Res := Old_Declare_Block; + Old_Declare_Block := Res.Prev; + else + -- Create a new one if no unused records. + Res := new Declare_Block_Type; + end if; + + -- Chain. + Res.all := (Stmt_Bb => Null_BasicBlockRef, + Stack_Value => Null_ValueRef, + Dbg_Scope => Null_ValueRef, + Prev => Cur_Declare_Block); + Cur_Declare_Block := Res; + + if not Unreach then + Res.Stmt_Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); + end if; + end Create_Declare_Block; + + procedure Destroy_Declare_Block + is + Blk : constant Declare_Block_Acc := Cur_Declare_Block; + begin + -- Unchain. + Cur_Declare_Block := Blk.Prev; + + -- Put on the recyle list. + Blk.Prev := Old_Declare_Block; + Old_Declare_Block := Blk; + end Destroy_Declare_Block; + + ----------------------- + -- Start_Record_Type -- + ----------------------- + + procedure Start_Record_Type (Elements : out O_Element_List) is + begin + Elements := (Kind => OF_Record, + Nbr_Elements => 0, + Rec_Type => O_Tnode_Null, + Size => 0, + Align => 0, + Align_Type => Null_TypeRef, + First_Elem => null, + Last_Elem => null); + end Start_Record_Type; + + ---------------------- + -- New_Record_Field -- + ---------------------- + + procedure Add_Field + (Elements : in out O_Element_List; Ident : O_Ident; Etype : O_Tnode) + is + O_El : O_Element_Acc; + begin + Elements.Nbr_Elements := Elements.Nbr_Elements + 1; + O_El := new O_Element'(Next => null, + Etype => Etype, + Ident => Ident); + if Elements.First_Elem = null then + Elements.First_Elem := O_El; + else + Elements.Last_Elem.Next := O_El; + end if; + Elements.Last_Elem := O_El; + end Add_Field; + + procedure New_Record_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; + Etype : O_Tnode) is + begin + El := (Kind => OF_Record, + Index => Elements.Nbr_Elements, + Ftype => Etype); + Add_Field (Elements, Ident, Etype); + end New_Record_Field; + + ------------------------ + -- Finish_Record_Type -- + ------------------------ + + procedure Free_Elements (Elements : in out O_Element_List) + is + procedure Free is new Ada.Unchecked_Deallocation + (O_Element, O_Element_Acc); + El : O_Element_Acc; + Next_El : O_Element_Acc; + begin + -- Free elements + El := Elements.First_Elem; + while El /= null loop + Next_El := El.Next; + Free (El); + El := Next_El; + end loop; + Elements.First_Elem := null; + Elements.Last_Elem := null; + end Free_Elements; + + procedure Finish_Record_Type + (Elements : in out O_Element_List; Res : out O_Tnode) + is + Count : constant unsigned := unsigned (Elements.Nbr_Elements); + El : O_Element_Acc; + Types : TypeRefArray (1 .. Count); + begin + El := Elements.First_Elem; + for I in Types'Range loop + Types (I) := Get_LLVM_Type (El.Etype); + El := El.Next; + end loop; + + if Elements.Rec_Type /= null then + -- Completion + StructSetBody (Elements.Rec_Type.LLVM, Types, Count, 0); + Res := Elements.Rec_Type; + else + Res := new O_Tnode_Type'(Kind => ON_Record_Type, + LLVM => StructType (Types, Count, 0), + Dbg => Null_ValueRef); + end if; + + Free_Elements (Elements); + end Finish_Record_Type; + + -------------------------------- + -- New_Uncomplete_Record_Type -- + -------------------------------- + + procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is + begin + -- LLVM type will be created when the type is declared, as the name + -- is required (for unification). + Res := new O_Tnode_Type'(Kind => ON_Incomplete_Record_Type, + LLVM => Null_TypeRef, + Dbg => Null_ValueRef); + end New_Uncomplete_Record_Type; + + ---------------------------------- + -- Start_Uncomplete_Record_Type -- + ---------------------------------- + + procedure Start_Uncomplete_Record_Type + (Res : O_Tnode; + Elements : out O_Element_List) + is + begin + if Res.Kind /= ON_Incomplete_Record_Type then + raise Program_Error; + end if; + Elements := (Kind => OF_Record, + Nbr_Elements => 0, + Rec_Type => Res, + Size => 0, + Align => 0, + Align_Type => Null_TypeRef, + First_Elem => null, + Last_Elem => null); + end Start_Uncomplete_Record_Type; + + ---------------------- + -- Start_Union_Type -- + ---------------------- + + procedure Start_Union_Type (Elements : out O_Element_List) is + begin + Elements := (Kind => OF_Union, + Nbr_Elements => 0, + Rec_Type => O_Tnode_Null, + Size => 0, + Align => 0, + Align_Type => Null_TypeRef, + First_Elem => null, + Last_Elem => null); + end Start_Union_Type; + + --------------------- + -- New_Union_Field -- + --------------------- + + procedure New_Union_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; + Etype : O_Tnode) + is + El_Type : constant TypeRef := Get_LLVM_Type (Etype); + Size : constant unsigned := + unsigned (ABISizeOfType (Target_Data, El_Type)); + Align : constant Unsigned_32 := + ABIAlignmentOfType (Target_Data, El_Type); + begin + El := (Kind => OF_Union, + Ftype => Etype, + Utype => El_Type, + Ptr_Type => PointerType (El_Type)); + if Size > Elements.Size then + Elements.Size := Size; + end if; + if Elements.Align_Type = Null_TypeRef or else Align > Elements.Align then + Elements.Align := Align; + Elements.Align_Type := El_Type; + end if; + Add_Field (Elements, Ident, Etype); + end New_Union_Field; + + ----------------------- + -- Finish_Union_Type -- + ----------------------- + + procedure Finish_Union_Type + (Elements : in out O_Element_List; + Res : out O_Tnode) + is + Count : unsigned; + Types : TypeRefArray (1 .. 2); + Pad : unsigned; + begin + if Elements.Align_Type = Null_TypeRef then + -- An empty union. Is it allowed ? + Count := 0; + else + -- The first element is the field with the biggest alignment + Types (1) := Elements.Align_Type; + -- Possibly complete with an array of bytes. + Pad := Elements.Size + - unsigned (ABISizeOfType (Target_Data, Elements.Align_Type)); + if Pad /= 0 then + Types (2) := ArrayType (Int8Type, Pad); + Count := 2; + else + Count := 1; + end if; + end if; + Res := new O_Tnode_Type'(Kind => ON_Union_Type, + LLVM => StructType (Types, Count, 0), + Dbg => Null_ValueRef, + Un_Size => Elements.Size, + Un_Main_Field => Elements.Align_Type); + + Free_Elements (Elements); + end Finish_Union_Type; + + --------------------- + -- New_Access_Type -- + --------------------- + + function New_Access_Type (Dtype : O_Tnode) return O_Tnode is + begin + if Dtype = O_Tnode_Null then + -- LLVM type will be built by New_Type_Decl, so that the name + -- can be used for the structure. + return new O_Tnode_Type'(Kind => ON_Incomplete_Access_Type, + LLVM => Null_TypeRef, + Dbg => Null_ValueRef, + Acc_Type => O_Tnode_Null); + else + return new O_Tnode_Type'(Kind => ON_Access_Type, + LLVM => PointerType (Get_LLVM_Type (Dtype)), + Dbg => Null_ValueRef, + Acc_Type => Dtype); + end if; + end New_Access_Type; + + ------------------------ + -- Finish_Access_Type -- + ------------------------ + + procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) + is + Types : TypeRefArray (1 .. 1); + begin + if Atype.Kind /= ON_Incomplete_Access_Type then + -- Not an incomplete access type. + raise Program_Error; + end if; + if Atype.Acc_Type /= O_Tnode_Null then + -- Already completed. + raise Program_Error; + end if; + -- Completion + Types (1) := Get_LLVM_Type (Dtype); + StructSetBody (GetElementType (Atype.LLVM), Types, Types'Length, 0); + Atype.Acc_Type := Dtype; + end Finish_Access_Type; + + -------------------- + -- New_Array_Type -- + -------------------- + + function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) + return O_Tnode + is + pragma Unreferenced (Index_Type); + Res : O_Tnode; + begin + Res := new O_Tnode_Type' + (Kind => ON_Array_Type, + LLVM => ArrayType (Get_LLVM_Type (El_Type), 0), + Dbg => Null_ValueRef, + Arr_El_Type => El_Type); + + return Res; + end New_Array_Type; + + -------------------------------- + -- New_Constrained_Array_Type -- + -------------------------------- + + function New_Constrained_Array_Type + (Atype : O_Tnode; Length : O_Cnode) return O_Tnode + is + Res : O_Tnode; + Len : constant unsigned := unsigned (ConstIntGetZExtValue (Length.LLVM)); + begin + Res := new O_Tnode_Type' + (Kind => ON_Array_Sub_Type, + LLVM => ArrayType (GetElementType (Get_LLVM_Type (Atype)), Len), + Dbg => Null_ValueRef, + Arr_El_Type => Atype.Arr_El_Type); + + return Res; + end New_Constrained_Array_Type; + + ----------------------- + -- New_Unsigned_Type -- + ----------------------- + + function Size_To_Llvm (Size : Natural) return TypeRef is + Llvm : TypeRef; + begin + case Size is + when 8 => + Llvm := Int8Type; + when 32 => + Llvm := Int32Type; + when 64 => + Llvm := Int64Type; + when others => + raise Program_Error; + end case; + return Llvm; + end Size_To_Llvm; + + function New_Unsigned_Type (Size : Natural) return O_Tnode is + begin + return new O_Tnode_Type'(Kind => ON_Unsigned_Type, + LLVM => Size_To_Llvm (Size), + Dbg => Null_ValueRef, + Scal_Size => Size); + end New_Unsigned_Type; + + --------------------- + -- New_Signed_Type -- + --------------------- + + function New_Signed_Type (Size : Natural) return O_Tnode is + begin + return new O_Tnode_Type'(Kind => ON_Signed_Type, + LLVM => Size_To_Llvm (Size), + Dbg => Null_ValueRef, + Scal_Size => Size); + end New_Signed_Type; + + -------------------- + -- New_Float_Type -- + -------------------- + + function New_Float_Type return O_Tnode is + begin + return new O_Tnode_Type'(Kind => ON_Float_Type, + LLVM => DoubleType, + Dbg => Null_ValueRef, + Scal_Size => 64); + end New_Float_Type; + + ---------------------- + -- New_Boolean_Type -- + ---------------------- + + procedure New_Boolean_Type + (Res : out O_Tnode; + False_Id : O_Ident; False_E : out O_Cnode; + True_Id : O_Ident; True_E : out O_Cnode) + is + pragma Unreferenced (False_Id, True_Id); + begin + Res := new O_Tnode_Type'(Kind => ON_Boolean_Type, + LLVM => Int1Type, + Dbg => Null_ValueRef, + Scal_Size => 1); + False_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 0, 0), + Ctype => Res); + True_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 1, 0), + Ctype => Res); + end New_Boolean_Type; + + --------------------- + -- Start_Enum_Type -- + --------------------- + + procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) + is + LLVM : constant TypeRef := Size_To_Llvm (Size); + begin + List := (LLVM => LLVM, + Num => 0, + Etype => new O_Tnode_Type'(Kind => ON_Enum_Type, + LLVM => LLVM, + Scal_Size => Size, + Dbg => Null_ValueRef)); + + end Start_Enum_Type; + + ---------------------- + -- New_Enum_Literal -- + ---------------------- + + procedure New_Enum_Literal + (List : in out O_Enum_List; Ident : O_Ident; Res : out O_Cnode) + is + pragma Unreferenced (Ident); + begin + Res := O_Cnode'(LLVM => ConstInt (List.LLVM, Unsigned_64 (List.Num), 0), + Ctype => List.Etype); + + List.Num := List.Num + 1; + end New_Enum_Literal; + + ---------------------- + -- Finish_Enum_Type -- + ---------------------- + + procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is + begin + Res := List.Etype; + end Finish_Enum_Type; + + ------------------------ + -- New_Signed_Literal -- + ------------------------ + + function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) + return O_Cnode + is + function To_Unsigned_64 is new Ada.Unchecked_Conversion + (Integer_64, Unsigned_64); + begin + return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype), + To_Unsigned_64 (Value), 1), + Ctype => Ltype); + end New_Signed_Literal; + + -------------------------- + -- New_Unsigned_Literal -- + -------------------------- + + function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) + return O_Cnode is + begin + return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype), Value, 0), + Ctype => Ltype); + end New_Unsigned_Literal; + + ----------------------- + -- New_Float_Literal -- + ----------------------- + + function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) + return O_Cnode is + begin + return O_Cnode'(LLVM => ConstReal (Get_LLVM_Type (Ltype), + Interfaces.C.double (Value)), + Ctype => Ltype); + end New_Float_Literal; + + --------------------- + -- New_Null_Access -- + --------------------- + + function New_Null_Access (Ltype : O_Tnode) return O_Cnode is + begin + return O_Cnode'(LLVM => ConstNull (Get_LLVM_Type (Ltype)), + Ctype => Ltype); + end New_Null_Access; + + ----------------------- + -- Start_Record_Aggr -- + ----------------------- + + procedure Start_Record_Aggr + (List : out O_Record_Aggr_List; + Atype : O_Tnode) + is + Llvm : constant TypeRef := Get_LLVM_Type (Atype); + begin + List := + (Len => 0, + Vals => new ValueRefArray (1 .. CountStructElementTypes (Llvm)), + Atype => Atype); + end Start_Record_Aggr; + + ------------------------ + -- New_Record_Aggr_El -- + ------------------------ + + procedure New_Record_Aggr_El + (List : in out O_Record_Aggr_List; Value : O_Cnode) + is + begin + List.Len := List.Len + 1; + List.Vals (List.Len) := Value.LLVM; + end New_Record_Aggr_El; + + ------------------------ + -- Finish_Record_Aggr -- + ------------------------ + + procedure Finish_Record_Aggr + (List : in out O_Record_Aggr_List; + Res : out O_Cnode) + is + V : ValueRef; + begin + if List.Atype.Kind = ON_Incomplete_Record_Type then + V := ConstNamedStruct (Get_LLVM_Type (List.Atype), + List.Vals.all, List.Len); + else + V := ConstStruct (List.Vals.all, List.Len, 0); + end if; + Res := (LLVM => V, Ctype => List.Atype); + Free (List.Vals); + end Finish_Record_Aggr; + + ---------------------- + -- Start_Array_Aggr -- + ---------------------- + + procedure Start_Array_Aggr + (List : out O_Array_Aggr_List; + Atype : O_Tnode) + is + Llvm : constant TypeRef := Get_LLVM_Type (Atype); + begin + List := (Len => 0, + Vals => new ValueRefArray (1 .. GetArrayLength (Llvm)), + El_Type => GetElementType (Llvm), + Atype => Atype); + end Start_Array_Aggr; + + ----------------------- + -- New_Array_Aggr_El -- + ----------------------- + + procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; + Value : O_Cnode) + is + begin + List.Len := List.Len + 1; + List.Vals (List.Len) := Value.LLVM; + end New_Array_Aggr_El; + + ----------------------- + -- Finish_Array_Aggr -- + ----------------------- + + procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; + Res : out O_Cnode) + is + begin + Res := (LLVM => ConstArray (List.El_Type, + List.Vals.all, List.Len), + Ctype => List.Atype); + Free (List.Vals); + end Finish_Array_Aggr; + + -------------------- + -- New_Union_Aggr -- + -------------------- + + function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) + return O_Cnode + is + Values : ValueRefArray (1 .. 2); + Count : unsigned; + Size : constant unsigned := + unsigned (ABISizeOfType (Target_Data, Field.Utype)); + + begin + Values (1) := Value.LLVM; + if Size < Atype.Un_Size then + Values (2) := GetUndef (ArrayType (Int8Type, Atype.Un_Size - Size)); + Count := 2; + else + Count := 1; + end if; + + -- If `FIELD` is the main field of the union, create a struct using + -- the same type as the union (and possibly pad). + if Field.Utype = Atype.Un_Main_Field then + return O_Cnode' + (LLVM => ConstNamedStruct (Atype.LLVM, Values, Count), + Ctype => Atype); + else + -- Create an on-the-fly record. + return O_Cnode'(LLVM => ConstStruct (Values, Count, 0), + Ctype => Atype); + end if; + end New_Union_Aggr; + + ----------------------- + -- New_Default_Value -- + ----------------------- + + function New_Default_Value (Ltype : O_Tnode) return O_Cnode is + begin + return O_Cnode'(LLVM => ConstNull (Ltype.LLVM), + Ctype => Ltype); + end New_Default_Value; + + ---------------- + -- New_Sizeof -- + ---------------- + + -- Return VAL with type RTYPE (either unsigned or access) + function Const_To_Cnode (Rtype : O_Tnode; Val : Unsigned_64) return O_Cnode + is + Tmp : ValueRef; + begin + case Rtype.Kind is + when ON_Scalar_Types => + -- Well, unsigned in fact. + return O_Cnode'(LLVM => ConstInt (Rtype.LLVM, Val, 0), + Ctype => Rtype); + when ON_Access_Type => + Tmp := ConstInt (Int64Type, Val, 0); + return O_Cnode'(LLVM => ConstIntToPtr (Tmp, Rtype.LLVM), + Ctype => Rtype); + when others => + raise Program_Error; + end case; + end Const_To_Cnode; + + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is + begin + return Const_To_Cnode + (Rtype, ABISizeOfType (Target_Data, Get_LLVM_Type (Atype))); + end New_Sizeof; + + ----------------- + -- New_Alignof -- + ----------------- + + function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is + begin + return Const_To_Cnode + (Rtype, + Unsigned_64 + (ABIAlignmentOfType (Target_Data, Get_LLVM_Type (Atype)))); + end New_Alignof; + + ------------------ + -- New_Offsetof -- + ------------------ + + function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) + return O_Cnode is + begin + return Const_To_Cnode + (Rtype, + OffsetOfElement (Target_Data, + Get_LLVM_Type (Atype), + Unsigned_32 (Field.Index))); + end New_Offsetof; + + ---------------------------- + -- New_Subprogram_Address -- + ---------------------------- + + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode is + begin + return O_Cnode' + (LLVM => ConstBitCast (Subprg.LLVM, Get_LLVM_Type (Atype)), + Ctype => Atype); + end New_Subprogram_Address; + + ------------------------ + -- New_Global_Address -- + ------------------------ + + function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode is + begin + return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), + Ctype => Atype); + end New_Global_Address; + + ---------------------------------- + -- New_Global_Unchecked_Address -- + ---------------------------------- + + function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode + is + begin + return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), + Ctype => Atype); + end New_Global_Unchecked_Address; + + ------------- + -- New_Lit -- + ------------- + + function New_Lit (Lit : O_Cnode) return O_Enode is + begin + return O_Enode'(LLVM => Lit.LLVM, + Etype => Lit.Ctype); + end New_Lit; + + ------------------- + -- New_Dyadic_Op -- + ------------------- + + function New_Smod (L, R : ValueRef; Res_Type : TypeRef) + return ValueRef + is + Cond : ValueRef; + Br : ValueRef; + pragma Unreferenced (Br); + + -- The result of 'L rem R'. + Rm : ValueRef; + + -- Rm + R + Rm_Plus_R : ValueRef; + + -- The result of 'L xor R'. + R_Xor : ValueRef; + + Adj : ValueRef; + Phi : ValueRef; + + -- Basic basic for the non-overflow branch + Normal_Bb : constant BasicBlockRef := + AppendBasicBlock (Cur_Func, Empty_Cstring); + + Adjust_Bb : constant BasicBlockRef := + AppendBasicBlock (Cur_Func, Empty_Cstring); + + -- Basic block after the result + Next_Bb : constant BasicBlockRef := + AppendBasicBlock (Cur_Func, Empty_Cstring); + + Vals : ValueRefArray (1 .. 3); + BBs : BasicBlockRefArray (1 .. 3); + begin + -- Avoid overflow with -1: + -- if R = -1 then + -- result := 0; + -- else + -- ... + Cond := BuildICmp + (Builder, IntEQ, R, ConstAllOnes (Res_Type), Empty_Cstring); + Br := BuildCondBr (Builder, Cond, Next_Bb, Normal_Bb); + Vals (1) := ConstNull (Res_Type); + BBs (1) := GetInsertBlock (Builder); + + -- Rm := Left rem Right + PositionBuilderAtEnd (Builder, Normal_Bb); + Rm := BuildSRem (Builder, L, R, Empty_Cstring); + + -- if Rm = 0 then + -- result := 0 + -- else + Cond := BuildICmp + (Builder, IntEQ, Rm, ConstNull (Res_Type), Empty_Cstring); + Br := BuildCondBr (Builder, Cond, Next_Bb, Adjust_Bb); + Vals (2) := ConstNull (Res_Type); + BBs (2) := Normal_Bb; + + -- if (L xor R) < 0 then + -- result := Rm + R + -- else + -- result := Rm; + -- end if; + PositionBuilderAtEnd (Builder, Adjust_Bb); + R_Xor := BuildXor (Builder, L, R, Empty_Cstring); + Cond := BuildICmp + (Builder, IntSLT, R_Xor, ConstNull (Res_Type), Empty_Cstring); + Rm_Plus_R := BuildAdd (Builder, Rm, R, Empty_Cstring); + Adj := BuildSelect (Builder, Cond, Rm_Plus_R, Rm, Empty_Cstring); + Br := BuildBr (Builder, Next_Bb); + Vals (3) := Adj; + BBs (3) := Adjust_Bb; + + -- The Phi node + PositionBuilderAtEnd (Builder, Next_Bb); + Phi := BuildPhi (Builder, Res_Type, Empty_Cstring); + AddIncoming (Phi, Vals, BBs, Vals'Length); + + return Phi; + end New_Smod; + + type Dyadic_Builder_Acc is access + function (Builder : BuilderRef; + LHS : ValueRef; RHS : ValueRef; Name : Cstring) + return ValueRef; + pragma Convention (C, Dyadic_Builder_Acc); + + function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) + return O_Enode + is + Build : Dyadic_Builder_Acc := null; + Res : ValueRef := Null_ValueRef; + begin + if Unreach then + return O_Enode'(LLVM => Null_ValueRef, Etype => Left.Etype); + end if; + + case Left.Etype.Kind is + when ON_Integer_Types => + case Kind is + when ON_And => + Build := BuildAnd'Access; + when ON_Or => + Build := BuildOr'Access; + when ON_Xor => + Build := BuildXor'Access; + + when ON_Add_Ov => + Build := BuildAdd'Access; + when ON_Sub_Ov => + Build := BuildSub'Access; + when ON_Mul_Ov => + Build := BuildMul'Access; + + when ON_Div_Ov => + case Left.Etype.Kind is + when ON_Unsigned_Type => + Build := BuildUDiv'Access; + when ON_Signed_Type => + Build := BuildSDiv'Access; + when others => + null; + end case; + + when ON_Mod_Ov + | ON_Rem_Ov => -- FIXME... + case Left.Etype.Kind is + when ON_Unsigned_Type => + Build := BuildURem'Access; + when ON_Signed_Type => + if Kind = ON_Rem_Ov then + Build := BuildSRem'Access; + else + Res := New_Smod + (Left.LLVM, Right.LLVM, Left.Etype.LLVM); + end if; + when others => + null; + end case; + end case; + + when ON_Float_Type => + case Kind is + when ON_Add_Ov => + Build := BuildFAdd'Access; + when ON_Sub_Ov => + Build := BuildFSub'Access; + when ON_Mul_Ov => + Build := BuildFMul'Access; + when ON_Div_Ov => + Build := BuildFDiv'Access; + + when others => + null; + end case; + + when others => + null; + end case; + + if Build /= null then + pragma Assert (Res = Null_ValueRef); + Res := Build.all (Builder, Left.LLVM, Right.LLVM, Empty_Cstring); + end if; + + if Res = Null_ValueRef then + raise Program_Error with "Unimplemented New_Dyadic_Op " + & ON_Dyadic_Op_Kind'Image (Kind) + & " for type " + & ON_Type_Kind'Image (Left.Etype.Kind); + end if; + + return O_Enode'(LLVM => Res, Etype => Left.Etype); + end New_Dyadic_Op; + + -------------------- + -- New_Monadic_Op -- + -------------------- + + function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) + return O_Enode + is + Res : ValueRef; + begin + if Unreach then + return O_Enode'(LLVM => Null_ValueRef, Etype => Operand.Etype); + end if; + + case Operand.Etype.Kind is + when ON_Integer_Types => + case Kind is + when ON_Not => + Res := BuildNot (Builder, Operand.LLVM, Empty_Cstring); + when ON_Neg_Ov => + Res := BuildNeg (Builder, Operand.LLVM, Empty_Cstring); + when ON_Abs_Ov => + Res := BuildSelect + (Builder, + BuildICmp (Builder, IntSLT, + Operand.LLVM, + ConstInt (Get_LLVM_Type (Operand.Etype), 0, 0), + Empty_Cstring), + BuildNeg (Builder, Operand.LLVM, Empty_Cstring), + Operand.LLVM, + Empty_Cstring); + end case; + when ON_Float_Type => + case Kind is + when ON_Not => + raise Program_Error; + when ON_Neg_Ov => + Res := BuildFNeg (Builder, Operand.LLVM, Empty_Cstring); + when ON_Abs_Ov => + Res := BuildSelect + (Builder, + BuildFCmp (Builder, RealOLT, + Operand.LLVM, + ConstReal (Get_LLVM_Type (Operand.Etype), 0.0), + Empty_Cstring), + BuildFNeg (Builder, Operand.LLVM, Empty_Cstring), + Operand.LLVM, + Empty_Cstring); + end case; + when others => + raise Program_Error; + end case; + + return O_Enode'(LLVM => Res, Etype => Operand.Etype); + end New_Monadic_Op; + + -------------------- + -- New_Compare_Op -- + -------------------- + + type Compare_Op_Entry is record + Signed_Pred : IntPredicate; + Unsigned_Pred : IntPredicate; + Real_Pred : RealPredicate; + end record; + + type Compare_Op_Table_Type is array (ON_Compare_Op_Kind) of + Compare_Op_Entry; + + Compare_Op_Table : constant Compare_Op_Table_Type := + (ON_Eq => (IntEQ, IntEQ, RealOEQ), + ON_Neq => (IntNE, IntNE, RealONE), + ON_Le => (IntSLE, IntULE, RealOLE), + ON_Lt => (IntSLT, IntULT, RealOLT), + ON_Ge => (IntSGE, IntUGE, RealOGE), + ON_Gt => (IntSGT, IntUGT, RealOGT)); + + function New_Compare_Op + (Kind : ON_Compare_Op_Kind; + Left, Right : O_Enode; + Ntype : O_Tnode) + return O_Enode + is + Res : ValueRef; + begin + if Unreach then + return O_Enode'(LLVM => Null_ValueRef, Etype => Ntype); + end if; + + case Left.Etype.Kind is + when ON_Unsigned_Type + | ON_Boolean_Type + | ON_Enum_Type + | ON_Access_Type + | ON_Incomplete_Access_Type => + Res := BuildICmp (Builder, Compare_Op_Table (Kind).Unsigned_Pred, + Left.LLVM, Right.LLVM, Empty_Cstring); + when ON_Signed_Type => + Res := BuildICmp (Builder, Compare_Op_Table (Kind).Signed_Pred, + Left.LLVM, Right.LLVM, Empty_Cstring); + when ON_Float_Type => + Res := BuildFCmp (Builder, Compare_Op_Table (Kind).Real_Pred, + Left.LLVM, Right.LLVM, Empty_Cstring); + when ON_Array_Type + | ON_Array_Sub_Type + | ON_Record_Type + | ON_Incomplete_Record_Type + | ON_Union_Type + | ON_No_Type => + raise Program_Error; + end case; + return O_Enode'(LLVM => Res, Etype => Ntype); + end New_Compare_Op; + + ------------------------- + -- New_Indexed_Element -- + ------------------------- + + function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) return O_Lnode + is + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + Index.LLVM); + begin + return O_Lnode' + (Direct => False, + LLVM => BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring), + Ltype => Arr.Ltype.Arr_El_Type); + end New_Indexed_Element; + + --------------- + -- New_Slice -- + --------------- + + function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) + return O_Lnode + is + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + Index.LLVM); + Tmp : ValueRef; + begin + if Unreach then + Tmp := Null_ValueRef; + else + Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring); + Tmp := BuildBitCast + (Builder, Tmp, PointerType (Get_LLVM_Type (Res_Type)), + Empty_Cstring); + end if; + return O_Lnode'(Direct => False, LLVM => Tmp, Ltype => Res_Type); + end New_Slice; + + -------------------------- + -- New_Selected_Element -- + -------------------------- + + function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) + return O_Lnode + is + Res : ValueRef; + begin + if Unreach then + Res := Null_ValueRef; + else + case El.Kind is + when OF_Record => + declare + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); + begin + Res := BuildGEP (Builder, Rec.LLVM, Idx, 2, Empty_Cstring); + end; + when OF_Union => + Res := BuildBitCast (Builder, + Rec.LLVM, El.Ptr_Type, Empty_Cstring); + when OF_None => + raise Program_Error; + end case; + end if; + return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); + end New_Selected_Element; + + ------------------------ + -- New_Access_Element -- + ------------------------ + + function New_Access_Element (Acc : O_Enode) return O_Lnode + is + Res : ValueRef; + begin + case Acc.Etype.Kind is + when ON_Access_Type => + Res := Acc.LLVM; + when ON_Incomplete_Access_Type => + -- Unwrap the structure + declare + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), ConstInt (Int32Type, 0, 0)); + begin + Res := BuildGEP (Builder, Acc.LLVM, Idx, 2, Empty_Cstring); + end; + when others => + raise Program_Error; + end case; + return O_Lnode'(Direct => False, + LLVM => Res, + Ltype => Acc.Etype.Acc_Type); + end New_Access_Element; + + -------------------- + -- New_Convert_Ov -- + -------------------- + + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode + is + Res : ValueRef := Null_ValueRef; + begin + if Rtype = Val.Etype then + -- Convertion to itself: nothing to do. + return Val; + end if; + if Rtype.LLVM = Val.Etype.LLVM then + -- Same underlying LLVM type: no conversion but keep new type in + -- case of change of sign. + return O_Enode'(LLVM => Val.LLVM, Etype => Rtype); + end if; + if Unreach then + return O_Enode'(LLVM => Val.LLVM, Etype => Rtype); + end if; + + case Rtype.Kind is + when ON_Integer_Types => + case Val.Etype.Kind is + when ON_Integer_Types => + -- Int to Int + if Val.Etype.Scal_Size > Rtype.Scal_Size then + -- Truncate + Res := BuildTrunc + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + elsif Val.Etype.Scal_Size < Rtype.Scal_Size then + if Val.Etype.Kind = ON_Signed_Type then + Res := BuildSExt + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + else + -- Unsigned, enum + Res := BuildZExt + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + end if; + else + Res := BuildBitCast + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + end if; + + when ON_Float_Type => + -- Float to Int + if Rtype.Kind = ON_Signed_Type then + -- FPtoSI rounds toward zero, so we need to add + -- copysign (0.5, x). + declare + V : ValueRef; + begin + V := BuildCall (Builder, Copysign_Fun, + (Fp_0_5, Val.LLVM), 2, Empty_Cstring); + V := BuildFAdd (Builder, Val.LLVM, V, Empty_Cstring); + Res := BuildFPToSI + (Builder, V, Get_LLVM_Type (Rtype), Empty_Cstring); + end; + end if; + + when others => + null; + end case; + + when ON_Float_Type => + if Val.Etype.Kind = ON_Signed_Type then + Res := BuildSIToFP + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + elsif Val.Etype.Kind = ON_Unsigned_Type then + Res := BuildUIToFP + (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + end if; + + when ON_Access_Type + | ON_Incomplete_Access_Type => + if GetTypeKind (TypeOf (Val.LLVM)) /= PointerTypeKind then + raise Program_Error; + end if; + Res := BuildBitCast (Builder, Val.LLVM, Get_LLVM_Type (Rtype), + Empty_Cstring); + + when others => + null; + end case; + if Res /= Null_ValueRef then + -- FIXME: only if insn was generated + -- Set_Insn_Dbg (Res); + return O_Enode'(LLVM => Res, Etype => Rtype); + else + raise Program_Error with "New_Convert_Ov: not implemented for " + & ON_Type_Kind'Image (Val.Etype.Kind) + & " -> " + & ON_Type_Kind'Image (Rtype.Kind); + end if; + end New_Convert_Ov; + + ----------------- + -- New_Address -- + ----------------- + + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is + begin + return New_Unchecked_Address (Lvalue, Atype); + end New_Address; + + --------------------------- + -- New_Unchecked_Address -- + --------------------------- + + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode + is + Res : ValueRef; + begin + if Unreach then + Res := Null_ValueRef; + else + Res := BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype), + Empty_Cstring); + end if; + return O_Enode'(LLVM => Res, Etype => Atype); + end New_Unchecked_Address; + + --------------- + -- New_Value -- + --------------- + + function New_Value (Lvalue : O_Lnode) return O_Enode + is + Res : ValueRef; + begin + if Unreach then + Res := Null_ValueRef; + else + Res := Lvalue.LLVM; + if not Lvalue.Direct then + Res := BuildLoad (Builder, Res, Empty_Cstring); + end if; + end if; + return O_Enode'(LLVM => Res, Etype => Lvalue.Ltype); + end New_Value; + + ------------------- + -- New_Obj_Value -- + ------------------- + + function New_Obj_Value (Obj : O_Dnode) return O_Enode is + begin + return New_Value (New_Obj (Obj)); + end New_Obj_Value; + + ------------- + -- New_Obj -- + ------------- + + function New_Obj (Obj : O_Dnode) return O_Lnode is + begin + if Unreach then + return O_Lnode'(Direct => False, + LLVM => Null_ValueRef, + Ltype => Obj.Dtype); + end if; + + case Obj.Kind is + when ON_Const_Decl + | ON_Var_Decl + | ON_Local_Decl => + return O_Lnode'(Direct => False, + LLVM => Obj.LLVM, + Ltype => Obj.Dtype); + + when ON_Interface_Decl => + return O_Lnode'(Direct => True, + LLVM => Obj.Inter.Ival, + Ltype => Obj.Dtype); + + when ON_Type_Decl + | ON_Completed_Type_Decl + | ON_Subprg_Decl + | ON_No_Decl => + raise Program_Error; + end case; + end New_Obj; + + ---------------- + -- New_Alloca -- + ---------------- + + function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode + is + Res : ValueRef; + begin + if Unreach then + Res := Null_ValueRef; + else + if Cur_Declare_Block.Stack_Value = Null_ValueRef + and then Cur_Declare_Block.Prev /= null + then + -- Save stack pointer at entry of block + declare + First_Insn : ValueRef; + Bld : BuilderRef; + begin + First_Insn := GetFirstInstruction (Cur_Declare_Block.Stmt_Bb); + if First_Insn = Null_ValueRef then + -- Alloca is the first instruction, save the stack now. + Bld := Builder; + else + -- There are instructions before alloca, insert the save + -- at the beginning. + PositionBuilderBefore (Extra_Builder, First_Insn); + Bld := Extra_Builder; + end if; + + Cur_Declare_Block.Stack_Value := + BuildCall (Bld, Stacksave_Fun, + (1 .. 0 => Null_ValueRef), 0, Empty_Cstring); + end; + end if; + + Res := BuildArrayAlloca + (Builder, Int8Type, Size.LLVM, Empty_Cstring); + + Res := BuildBitCast + (Builder, Res, Get_LLVM_Type (Rtype), Empty_Cstring); + end if; + + return O_Enode'(LLVM => Res, Etype => Rtype); + end New_Alloca; + + ------------------- + -- New_Type_Decl -- + ------------------- + + procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is + begin + -- Create the incomplete structure. This is the only way in LLVM to + -- build recursive types. + case Atype.Kind is + when ON_Incomplete_Record_Type => + Atype.LLVM := + StructCreateNamed (GetGlobalContext, Get_Cstring (Ident)); + when ON_Incomplete_Access_Type => + Atype.LLVM := PointerType + (StructCreateNamed (GetGlobalContext, Get_Cstring (Ident))); + when others => + null; + end case; + end New_Type_Decl; + + ----------------------------- + -- New_Debug_Filename_Decl -- + ----------------------------- + + procedure New_Debug_Filename_Decl (Filename : String) is + begin + null; + end New_Debug_Filename_Decl; + + ------------------------- + -- New_Debug_Line_Decl -- + ------------------------- + + procedure New_Debug_Line_Decl (Line : Natural) is + begin + null; + end New_Debug_Line_Decl; + + ---------------------------- + -- New_Debug_Comment_Decl -- + ---------------------------- + + procedure New_Debug_Comment_Decl (Comment : String) is + begin + null; + end New_Debug_Comment_Decl; + + -------------------- + -- New_Const_Decl -- + -------------------- + + procedure New_Const_Decl + (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) + is + Decl : ValueRef; + begin + if Storage = O_Storage_External then + Decl := GetNamedGlobal (Module, Get_Cstring (Ident)); + else + Decl := Null_ValueRef; + end if; + if Decl = Null_ValueRef then + Decl := AddGlobal + (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident)); + end if; + + Res := (Kind => ON_Const_Decl, LLVM => Decl, Dtype => Atype); + SetGlobalConstant (Res.LLVM, 1); + if Storage = O_Storage_Private then + SetLinkage (Res.LLVM, InternalLinkage); + end if; + end New_Const_Decl; + + ----------------------- + -- Start_Init_Value -- + ----------------------- + + procedure Start_Init_Value (Decl : in out O_Dnode) is + begin + null; + end Start_Init_Value; + + ------------------------ + -- Finish_Init_Value -- + ------------------------ + + procedure Finish_Init_Value (Decl : in out O_Dnode; Val : O_Cnode) is + begin + SetInitializer (Decl.LLVM, Val.LLVM); + end Finish_Init_Value; + + ------------------ + -- New_Var_Decl -- + ------------------ + + procedure New_Var_Decl + (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) + is + Decl : ValueRef; + begin + if Storage = O_Storage_Local then + Res := (Kind => ON_Local_Decl, + LLVM => BuildAlloca + (Decl_Builder, Get_LLVM_Type (Atype), Get_Cstring (Ident)), + Dtype => Atype); + else + if Storage = O_Storage_External then + Decl := GetNamedGlobal (Module, Get_Cstring (Ident)); + else + Decl := Null_ValueRef; + end if; + if Decl = Null_ValueRef then + Decl := AddGlobal + (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident)); + end if; + + Res := (Kind => ON_Var_Decl, LLVM => Decl, Dtype => Atype); + + -- Set linkage. + case Storage is + when O_Storage_Private => + SetLinkage (Res.LLVM, InternalLinkage); + when O_Storage_Public + | O_Storage_External => + null; + when O_Storage_Local => + raise Program_Error; + end case; + + -- Set initializer. + case Storage is + when O_Storage_Private + | O_Storage_Public => + SetInitializer (Res.LLVM, ConstNull (Get_LLVM_Type (Atype))); + when O_Storage_External => + null; + when O_Storage_Local => + raise Program_Error; + end case; + end if; + end New_Var_Decl; + + ------------------------- + -- Start_Function_Decl -- + ------------------------- + + procedure Start_Function_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode) + is + begin + Interfaces := (Ident => Ident, + Storage => Storage, + Res_Type => Rtype, + Nbr_Inter => 0, + First_Inter => null, + Last_Inter => null); + end Start_Function_Decl; + + -------------------------- + -- Start_Procedure_Decl -- + -------------------------- + + procedure Start_Procedure_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage) + is + begin + Interfaces := (Ident => Ident, + Storage => Storage, + Res_Type => O_Tnode_Null, + Nbr_Inter => 0, + First_Inter => null, + Last_Inter => null); + end Start_Procedure_Decl; + + ------------------------ + -- New_Interface_Decl -- + ------------------------ + + procedure New_Interface_Decl + (Interfaces : in out O_Inter_List; + Res : out O_Dnode; + Ident : O_Ident; + Atype : O_Tnode) + is + Inter : constant O_Inter_Acc := new O_Inter'(Itype => Atype, + Ival => Null_ValueRef, + Ident => Ident, + Next => null); + begin + Res := (Kind => ON_Interface_Decl, + Dtype => Atype, + LLVM => Null_ValueRef, + Inter => Inter); + Interfaces.Nbr_Inter := Interfaces.Nbr_Inter + 1; + if Interfaces.First_Inter = null then + Interfaces.First_Inter := Inter; + else + Interfaces.Last_Inter.Next := Inter; + end if; + Interfaces.Last_Inter := Inter; + end New_Interface_Decl; + + ---------------------------- + -- Finish_Subprogram_Decl -- + ---------------------------- + + procedure Finish_Subprogram_Decl + (Interfaces : in out O_Inter_List; + Res : out O_Dnode) + is + Count : constant unsigned := unsigned (Interfaces.Nbr_Inter); + Inter : O_Inter_Acc; + Types : TypeRefArray (1 .. Count); + Ftype : TypeRef; + Rtype : TypeRef; + Decl : ValueRef; + Id : constant Cstring := Get_Cstring (Interfaces.Ident); + begin + -- Fill Types (from interfaces list) + Inter := Interfaces.First_Inter; + for I in 1 .. Count loop + Types (I) := Inter.Itype.LLVM; + Inter := Inter.Next; + end loop; + + -- Build function type. + if Interfaces.Res_Type = O_Tnode_Null then + Rtype := VoidType; + else + Rtype := Interfaces.Res_Type.LLVM; + end if; + Ftype := FunctionType (Rtype, Types, Count, 0); + + if Interfaces.Storage = O_Storage_External then + Decl := GetNamedFunction (Module, Id); + else + Decl := Null_ValueRef; + end if; + if Decl = Null_ValueRef then + Decl := AddFunction (Module, Id, Ftype); + AddAttributeAtIndex (Decl, AttributeFunctionIndex, Nounwind_Attr); + AddAttributeAtIndex (Decl, AttributeFunctionIndex, Uwtable_Attr); + end if; + + Res := (Kind => ON_Subprg_Decl, + Dtype => Interfaces.Res_Type, + Subprg_Id => Interfaces.Ident, + Nbr_Args => Count, + Subprg_Inters => Interfaces.First_Inter, + LLVM => Decl); + SetFunctionCallConv (Res.LLVM, CCallConv); + + -- Translate interfaces. + Inter := Interfaces.First_Inter; + for I in 1 .. Count loop + Inter.Ival := GetParam (Res.LLVM, I - 1); + SetValueName (Inter.Ival, Get_Cstring (Inter.Ident)); + Inter := Inter.Next; + end loop; + end Finish_Subprogram_Decl; + + --------------------------- + -- Start_Subprogram_Body -- + --------------------------- + + procedure Start_Subprogram_Body (Func : O_Dnode) + is + -- Basic block at function entry that contains all the declarations. + Decl_BB : BasicBlockRef; + begin + if Cur_Func /= Null_ValueRef then + -- No support for nested subprograms. + raise Program_Error; + end if; + + Cur_Func := Func.LLVM; + Cur_Func_Decl := Func; + Unreach := False; + + Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring); + PositionBuilderAtEnd (Decl_Builder, Decl_BB); + + Create_Declare_Block; + + PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb); + end Start_Subprogram_Body; + + ---------------------------- + -- Finish_Subprogram_Body -- + ---------------------------- + + procedure Finish_Subprogram_Body is + Ret : ValueRef; + pragma Unreferenced (Ret); + begin + -- Add a jump from the declare basic block to the first statement BB. + Ret := BuildBr (Decl_Builder, Cur_Declare_Block.Stmt_Bb); + + -- Terminate the statement BB. + if not Unreach then + if Cur_Func_Decl.Dtype = O_Tnode_Null then + Ret := BuildRetVoid (Builder); + else + Ret := BuildUnreachable (Builder); + end if; + end if; + + Destroy_Declare_Block; + + Cur_Func := Null_ValueRef; + end Finish_Subprogram_Body; + + ------------------------- + -- New_Debug_Line_Stmt -- + ------------------------- + + procedure New_Debug_Line_Stmt (Line : Natural) is + begin + null; + end New_Debug_Line_Stmt; + + ---------------------------- + -- New_Debug_Comment_Stmt -- + ---------------------------- + + procedure New_Debug_Comment_Stmt (Comment : String) is + begin + null; + end New_Debug_Comment_Stmt; + + ------------------------ + -- Start_Declare_Stmt -- + ------------------------ + + procedure Start_Declare_Stmt + is + Br : ValueRef; + pragma Unreferenced (Br); + begin + Create_Declare_Block; + + if Unreach then + return; + end if; + + -- Add a jump to the new BB. + Br := BuildBr (Builder, Cur_Declare_Block.Stmt_Bb); + + PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb); + end Start_Declare_Stmt; + + ------------------------- + -- Finish_Declare_Stmt -- + ------------------------- + + procedure Finish_Declare_Stmt + is + Bb : BasicBlockRef; + Br : ValueRef; + Tmp : ValueRef; + pragma Unreferenced (Br, Tmp); + begin + if not Unreach then + -- Create a basic block for the statements after the declare. + Bb := AppendBasicBlock (Cur_Func, Empty_Cstring); + + if Cur_Declare_Block.Stack_Value /= Null_ValueRef then + -- Restore stack pointer. + Tmp := BuildCall (Builder, Stackrestore_Fun, + (1 .. 1 => Cur_Declare_Block.Stack_Value), 1, + Empty_Cstring); + end if; + + -- Execution will continue on the next statement + Br := BuildBr (Builder, Bb); + + PositionBuilderAtEnd (Builder, Bb); + end if; + + -- Do not reset Unread. + + Destroy_Declare_Block; + end Finish_Declare_Stmt; + + ----------------------- + -- Start_Association -- + ----------------------- + + procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) + is + begin + Assocs := (Subprg => Subprg, + Idx => 0, + Vals => new ValueRefArray (1 .. Subprg.Nbr_Args)); + end Start_Association; + + --------------------- + -- New_Association -- + --------------------- + + procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is + begin + Assocs.Idx := Assocs.Idx + 1; + Assocs.Vals (Assocs.Idx) := Val.LLVM; + end New_Association; + + ----------------------- + -- New_Function_Call -- + ----------------------- + + function New_Function_Call (Assocs : O_Assoc_List) return O_Enode + is + Res : ValueRef; + Old_Vals : ValueRefArray_Acc; + begin + if not Unreach then + Res := BuildCall (Builder, Assocs.Subprg.LLVM, + Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); + Old_Vals := Assocs.Vals; + Free (Old_Vals); + else + Res := Null_ValueRef; + end if; + return O_Enode'(LLVM => Res, Etype => Assocs.Subprg.Dtype); + end New_Function_Call; + + ------------------------ + -- New_Procedure_Call -- + ------------------------ + + procedure New_Procedure_Call (Assocs : in out O_Assoc_List) + is + Res : ValueRef; + pragma Unreferenced (Res); + begin + if not Unreach then + Res := BuildCall (Builder, Assocs.Subprg.LLVM, + Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring); + end if; + Free (Assocs.Vals); + end New_Procedure_Call; + + --------------------- + -- New_Assign_Stmt -- + --------------------- + + procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) + is + Res : ValueRef; + pragma Unreferenced (Res); + begin + if Target.Direct then + raise Program_Error; + end if; + if not Unreach then + Res := BuildStore (Builder, Value.LLVM, Target.LLVM); + end if; + end New_Assign_Stmt; + + --------------------- + -- New_Return_Stmt -- + --------------------- + + procedure New_Return_Stmt (Value : O_Enode) + is + Res : ValueRef; + pragma Unreferenced (Res); + begin + if Unreach then + return; + end if; + Res := BuildRet (Builder, Value.LLVM); + Unreach := True; + end New_Return_Stmt; + + --------------------- + -- New_Return_Stmt -- + --------------------- + + procedure New_Return_Stmt + is + Res : ValueRef; + pragma Unreferenced (Res); + begin + if Unreach then + return; + end if; + Res := BuildRetVoid (Builder); + Unreach := True; + end New_Return_Stmt; + + ------------------- + -- Start_If_Stmt -- + ------------------- + + procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) + is + Res : ValueRef; + pragma Unreferenced (Res); + Bb_Then : BasicBlockRef; + begin + if Unreach then + Block := (Bb => Null_BasicBlockRef); + return; + end if; + + Bb_Then := AppendBasicBlock (Cur_Func, Empty_Cstring); + Block := (Bb => AppendBasicBlock (Cur_Func, Empty_Cstring)); + Res := BuildCondBr (Builder, Cond.LLVM, Bb_Then, Block.Bb); + + PositionBuilderAtEnd (Builder, Bb_Then); + end Start_If_Stmt; + + ------------------- + -- New_Else_Stmt -- + ------------------- + + procedure New_Else_Stmt (Block : in out O_If_Block) is + Res : ValueRef; + pragma Unreferenced (Res); + Bb_Next : BasicBlockRef; + begin + if not Unreach then + Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); + Res := BuildBr (Builder, Bb_Next); + else + if Block.Bb = Null_BasicBlockRef then + -- The IF statement was unreachable. Else part is also + -- unreachable. + return; + end if; + Bb_Next := Null_BasicBlockRef; + end if; + + PositionBuilderAtEnd (Builder, Block.Bb); + + Block := (Bb => Bb_Next); + Unreach := False; + end New_Else_Stmt; + + -------------------- + -- Finish_If_Stmt -- + -------------------- + + procedure Finish_If_Stmt (Block : in out O_If_Block) is + Res : ValueRef; + pragma Unreferenced (Res); + Bb_Next : BasicBlockRef; + begin + if not Unreach then + -- The branch can continue. + if Block.Bb = Null_BasicBlockRef then + Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); + else + Bb_Next := Block.Bb; + end if; + Res := BuildBr (Builder, Bb_Next); + PositionBuilderAtEnd (Builder, Bb_Next); + else + -- The branch doesn't continue. + if Block.Bb /= Null_BasicBlockRef then + -- There is a fall-through (either from the then branch, or + -- there is no else). + Unreach := False; + PositionBuilderAtEnd (Builder, Block.Bb); + else + Unreach := True; + end if; + end if; + end Finish_If_Stmt; + + --------------------- + -- Start_Loop_Stmt -- + --------------------- + + procedure Start_Loop_Stmt (Label : out O_Snode) + is + Res : ValueRef; + pragma Unreferenced (Res); + begin + -- FIXME: check Unreach + Label := (Bb_Entry => AppendBasicBlock (Cur_Func, Empty_Cstring), + Bb_Exit => AppendBasicBlock (Cur_Func, Empty_Cstring)); + Res := BuildBr (Builder, Label.Bb_Entry); + PositionBuilderAtEnd (Builder, Label.Bb_Entry); + end Start_Loop_Stmt; + + ---------------------- + -- Finish_Loop_Stmt -- + ---------------------- + + procedure Finish_Loop_Stmt (Label : in out O_Snode) is + Res : ValueRef; + pragma Unreferenced (Res); + begin + if not Unreach then + Res := BuildBr (Builder, Label.Bb_Entry); + end if; + if Label.Bb_Exit /= Null_BasicBlockRef then + -- FIXME: always true... + PositionBuilderAtEnd (Builder, Label.Bb_Exit); + Unreach := False; + else + Unreach := True; + end if; + end Finish_Loop_Stmt; + + ------------------- + -- New_Exit_Stmt -- + ------------------- + + procedure New_Exit_Stmt (L : O_Snode) is + Res : ValueRef; + pragma Unreferenced (Res); + begin + if not Unreach then + Res := BuildBr (Builder, L.Bb_Exit); + Unreach := True; + end if; + end New_Exit_Stmt; + + ------------------- + -- New_Next_Stmt -- + ------------------- + + procedure New_Next_Stmt (L : O_Snode) is + Res : ValueRef; + pragma Unreferenced (Res); + begin + if not Unreach then + Res := BuildBr (Builder, L.Bb_Entry); + Unreach := True; + end if; + end New_Next_Stmt; + + --------------------- + -- Start_Case_Stmt -- + --------------------- + + procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is + begin + Block := (BB_Prev => GetInsertBlock (Builder), + Value => Value.LLVM, + Vtype => Value.Etype, + BB_Next => Null_BasicBlockRef, + BB_Others => Null_BasicBlockRef, + BB_Choice => Null_BasicBlockRef, + Nbr_Choices => 0, + Choices => new O_Choice_Array (1 .. 8)); + end Start_Case_Stmt; + + ------------------ + -- Start_Choice -- + ------------------ + + procedure Finish_Branch (Block : in out O_Case_Block) is + Res : ValueRef; + pragma Unreferenced (Res); + begin + -- Close previous branch. + if not Unreach then + if Block.BB_Next = Null_BasicBlockRef then + Block.BB_Next := AppendBasicBlock (Cur_Func, Empty_Cstring); + end if; + Res := BuildBr (Builder, Block.BB_Next); + end if; + end Finish_Branch; + + procedure Start_Choice (Block : in out O_Case_Block) is + Res : ValueRef; + pragma Unreferenced (Res); + begin + if Block.BB_Choice /= Null_BasicBlockRef then + -- Close previous branch. + Finish_Branch (Block); + end if; + + Unreach := False; + Block.BB_Choice := AppendBasicBlock (Cur_Func, Empty_Cstring); + PositionBuilderAtEnd (Builder, Block.BB_Choice); + end Start_Choice; + + --------------------- + -- New_Expr_Choice -- + --------------------- + + procedure Free is new Ada.Unchecked_Deallocation + (O_Choice_Array, O_Choice_Array_Acc); + + procedure New_Choice (Block : in out O_Case_Block; + Low, High : ValueRef) + is + Choices : O_Choice_Array_Acc; + begin + if Block.Nbr_Choices = Block.Choices'Last then + Choices := new O_Choice_Array (1 .. Block.Choices'Last * 2); + Choices (1 .. Block.Choices'Last) := Block.Choices.all; + Free (Block.Choices); + Block.Choices := Choices; + end if; + Block.Nbr_Choices := Block.Nbr_Choices + 1; + Block.Choices (Block.Nbr_Choices) := (Low => Low, + High => High, + Bb => Block.BB_Choice); + end New_Choice; + + procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is + begin + New_Choice (Block, Expr.LLVM, Null_ValueRef); + end New_Expr_Choice; + + ---------------------- + -- New_Range_Choice -- + ---------------------- + + procedure New_Range_Choice + (Block : in out O_Case_Block; Low, High : O_Cnode) + is + begin + New_Choice (Block, Low.LLVM, High.LLVM); + end New_Range_Choice; + + ------------------------ + -- New_Default_Choice -- + ------------------------ + + procedure New_Default_Choice (Block : in out O_Case_Block) is + begin + Block.BB_Others := Block.BB_Choice; + end New_Default_Choice; + + ------------------- + -- Finish_Choice -- + ------------------- + + procedure Finish_Choice (Block : in out O_Case_Block) is + begin + null; + end Finish_Choice; + + ---------------------- + -- Finish_Case_Stmt -- + ---------------------- + + procedure Finish_Case_Stmt (Block : in out O_Case_Block) + is + Bb_Default : constant BasicBlockRef := + AppendBasicBlock (Cur_Func, Empty_Cstring); + Bb_Default_Last : BasicBlockRef; + Nbr_Cases : unsigned := 0; + GE, LE : IntPredicate; + Res : ValueRef; + begin + if Block.BB_Choice /= Null_BasicBlockRef then + -- Close previous branch. + Finish_Branch (Block); + end if; + + -- Strategy: use a switch instruction for simple choices, put range + -- choices in the default using if statements. + case Block.Vtype.Kind is + when ON_Unsigned_Type + | ON_Enum_Type + | ON_Boolean_Type => + GE := IntUGE; + LE := IntULE; + when ON_Signed_Type => + GE := IntSGE; + LE := IntSLE; + when others => + raise Program_Error; + end case; + + -- BB for the default case of the LLVM switch. + PositionBuilderAtEnd (Builder, Bb_Default); + Bb_Default_Last := Bb_Default; + + for I in 1 .. Block.Nbr_Choices loop + declare + C : O_Choice_Type renames Block.Choices (I); + begin + if C.High /= Null_ValueRef then + Bb_Default_Last := AppendBasicBlock (Cur_Func, Empty_Cstring); + Res := BuildCondBr (Builder, + BuildAnd (Builder, + BuildICmp (Builder, GE, + Block.Value, C.Low, + Empty_Cstring), + BuildICmp (Builder, LE, + Block.Value, C.High, + Empty_Cstring), + Empty_Cstring), + C.Bb, Bb_Default_Last); + PositionBuilderAtEnd (Builder, Bb_Default_Last); + else + Nbr_Cases := Nbr_Cases + 1; + end if; + end; + end loop; + + -- Insert the switch + PositionBuilderAtEnd (Builder, Block.BB_Prev); + Res := BuildSwitch (Builder, Block.Value, Bb_Default, Nbr_Cases); + for I in 1 .. Block.Nbr_Choices loop + declare + C : O_Choice_Type renames Block.Choices (I); + begin + if C.High = Null_ValueRef then + AddCase (Res, C.Low, C.Bb); + end if; + end; + end loop; + + -- Insert the others. + PositionBuilderAtEnd (Builder, Bb_Default_Last); + if Block.BB_Others /= Null_BasicBlockRef then + Res := BuildBr (Builder, Block.BB_Others); + else + Res := BuildUnreachable (Builder); + end if; + + if Block.BB_Next /= Null_BasicBlockRef then + Unreach := False; + PositionBuilderAtEnd (Builder, Block.BB_Next); + else + Unreach := True; + end if; + + Free (Block.Choices); + end Finish_Case_Stmt; + + function Get_LLVM_Type (Atype : O_Tnode) return TypeRef is + begin + case Atype.Kind is + when ON_Incomplete_Record_Type + | ON_Incomplete_Access_Type => + if Atype.LLVM = Null_TypeRef then + raise Program_Error with "early use of incomplete type"; + end if; + return Atype.LLVM; + when ON_Union_Type + | ON_Scalar_Types + | ON_Access_Type + | ON_Array_Type + | ON_Array_Sub_Type + | ON_Record_Type => + return Atype.LLVM; + when others => + raise Program_Error; + end case; + end Get_LLVM_Type; + + function CreateAttribute (Name : String; Val : Unsigned_64 := 0) + return AttributeRef + is + Id : unsigned; + begin + Id := GetEnumAttributeKindForName (Name'Address, Name'Length); + if Id = 0 then + -- Unknown attribute + raise Program_Error; + end if; + return CreateEnumAttribute (GetGlobalContext, Id, Val); + end CreateAttribute; + + 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); + + Nounwind_Attr := CreateAttribute ("nounwind"); + Uwtable_Attr := CreateAttribute ("uwtable"); + end Init; + +end Ortho_LLVM; diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.ads b/src/ortho/llvm4-nodebug/ortho_llvm.ads new file mode 100644 index 000000000..772a91894 --- /dev/null +++ b/src/ortho/llvm4-nodebug/ortho_llvm.ads @@ -0,0 +1,743 @@ +-- 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; + + -- 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; + +-- 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_Fnode is private; + + O_Cnode_Null : constant O_Cnode; + O_Dnode_Null : constant O_Dnode; + 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 (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode; + + -- Same as New_Address but without any restriction. + function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode; + + ------------------- + -- Expressions -- + ------------------- + + type ON_Op_Kind is + ( + -- Not an operation; invalid. + ON_Nil, + + -- Dyadic operations. + ON_Add_Ov, -- ON_Dyadic_Op_Kind + ON_Sub_Ov, -- ON_Dyadic_Op_Kind + ON_Mul_Ov, -- ON_Dyadic_Op_Kind + ON_Div_Ov, -- ON_Dyadic_Op_Kind + ON_Rem_Ov, -- ON_Dyadic_Op_Kind + ON_Mod_Ov, -- ON_Dyadic_Op_Kind + + -- Binary operations. + ON_And, -- ON_Dyadic_Op_Kind + ON_Or, -- ON_Dyadic_Op_Kind + ON_Xor, -- ON_Dyadic_Op_Kind + + -- 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; + + -- Reference an access. + -- Type of ACC must be an access type. + function New_Access_Element (Acc : O_Enode) return O_Lnode; + + -- Do a conversion. + -- Allowed conversions are: + -- FIXME: to write. + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; + + -- Get the address of LVALUE. + -- ATYPE must be a type access whose designated type is the type of LVALUE. + -- FIXME: what about arrays. + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; + + -- Same as New_Address but without any restriction. + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode; + + -- Get the value of an Lvalue. + function New_Value (Lvalue : O_Lnode) return O_Enode; + function New_Obj_Value (Obj : O_Dnode) return O_Enode; + + -- Get an lvalue from a declaration. + function New_Obj (Obj : O_Dnode) return O_Lnode; + + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. + function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; + + -- Declare a type. + -- This simply gives a name to a type. + procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode); + + --------------------- + -- Declarations. -- + --------------------- + + -- Filename of the next declaration. + procedure New_Debug_Filename_Decl (Filename : String); + + -- Line number of the next declaration. + procedure New_Debug_Line_Decl (Line : Natural); + + -- Add a comment in the declarative region. + procedure New_Debug_Comment_Decl (Comment : String); + + -- Declare a constant. + -- This simply gives a name to a constant value or aggregate. + -- A constant cannot be modified and its storage cannot be local. + -- ATYPE must be constrained. + procedure New_Const_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode); + + -- Set the value of a non-external constant 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_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/llvm4-nodebug/ortho_llvm.private.ads b/src/ortho/llvm4-nodebug/ortho_llvm.private.ads new file mode 100644 index 000000000..e5527a734 --- /dev/null +++ b/src/ortho/llvm4-nodebug/ortho_llvm.private.ads @@ -0,0 +1,307 @@ +-- LLVM back-end for ortho. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Interfaces; use Interfaces; +with Interfaces.C; use Interfaces.C; +with Ortho_Ident; use Ortho_Ident; +with LLVM.Core; use LLVM.Core; +with LLVM.TargetMachine; +with LLVM.Target; + +-- Interface to create nodes. +package Ortho_LLVM is + procedure Init; + + -- LLVM specific: the module. + Module : ModuleRef; + + -- Descriptor for the layout. + Target_Data : LLVM.Target.TargetDataRef; + + Target_Machine : LLVM.TargetMachine.TargetMachineRef; + + -- Optimization level + Optimization : LLVM.TargetMachine.CodeGenOptLevel := + LLVM.TargetMachine.CodeGenLevelDefault; + +private + -- No support for nested subprograms in LLVM. + Has_Nested_Subprograms : constant Boolean := False; + + type O_Tnode_Type (<>); + type O_Tnode is access O_Tnode_Type; + O_Tnode_Null : constant O_Tnode := null; + + type ON_Type_Kind is + (ON_No_Type, + ON_Unsigned_Type, ON_Signed_Type, ON_Enum_Type, ON_Boolean_Type, + ON_Float_Type, + ON_Array_Type, ON_Array_Sub_Type, + ON_Incomplete_Record_Type, + ON_Record_Type, ON_Union_Type, + ON_Incomplete_Access_Type, ON_Access_Type); + + subtype ON_Scalar_Types is ON_Type_Kind range + ON_Unsigned_Type .. ON_Float_Type; + + subtype ON_Integer_Types is ON_Type_Kind range + ON_Unsigned_Type .. ON_Boolean_Type; + + type O_Tnode_Type (Kind : ON_Type_Kind := ON_No_Type) is record + LLVM : TypeRef; + Dbg : ValueRef; + case Kind is + when ON_No_Type => + null; + when ON_Union_Type => + Un_Size : unsigned; + Un_Main_Field : TypeRef; + when ON_Access_Type + | ON_Incomplete_Access_Type => + Acc_Type : O_Tnode; + when ON_Scalar_Types => + Scal_Size : Natural; + when ON_Array_Type + | ON_Array_Sub_Type => + -- Type of the element + Arr_El_Type : O_Tnode; + when ON_Record_Type + | ON_Incomplete_Record_Type => + null; + end case; + end record; + + type O_Inter; + type O_Inter_Acc is access O_Inter; + type O_Inter is record + Itype : O_Tnode; + Ival : ValueRef; + Ident : O_Ident; + Next : O_Inter_Acc; + end record; + + type On_Decl_Kind is + (ON_Type_Decl, ON_Completed_Type_Decl, + ON_Const_Decl, + ON_Var_Decl, ON_Local_Decl, ON_Interface_Decl, + ON_Subprg_Decl, + ON_No_Decl); + + type O_Dnode (Kind : On_Decl_Kind := ON_No_Decl) is record + Dtype : O_Tnode; + LLVM : ValueRef; + case Kind is + when ON_Var_Decl + | ON_Const_Decl + | ON_Local_Decl => + null; + when ON_Subprg_Decl => + Subprg_Id : O_Ident; + Nbr_Args : unsigned; + Subprg_Inters : O_Inter_Acc; + when ON_Interface_Decl => + Inter : O_Inter_Acc; + when others => + null; + end case; + end record; + + O_Dnode_Null : constant O_Dnode := (Kind => ON_No_Decl, + Dtype => O_Tnode_Null, + LLVM => Null_ValueRef); + + type OF_Kind is (OF_None, OF_Record, OF_Union); + type O_Fnode (Kind : OF_Kind := OF_None) is record + -- Type of the field. + Ftype : O_Tnode; + case Kind is + when OF_None => + null; + when OF_Record => + -- Field index (starting from 0). + Index : Natural; + when OF_Union => + Utype : TypeRef; + Ptr_Type : TypeRef; + end case; + end record; + + O_Fnode_Null : constant O_Fnode := (Kind => OF_None, + Ftype => O_Tnode_Null); + + type O_Anode_Type; + type O_Anode is access O_Anode_Type; + type O_Anode_Type is record + Next : O_Anode; + Formal : O_Dnode; + Actual : O_Enode; + end record; + + type O_Cnode is record + LLVM : ValueRef; + Ctype : O_Tnode; + end record; + O_Cnode_Null : constant O_Cnode := (LLVM => Null_ValueRef, + Ctype => O_Tnode_Null); + + type O_Enode is record + LLVM : ValueRef; + Etype : O_Tnode; + end record; + O_Enode_Null : constant O_Enode := (LLVM => Null_ValueRef, + Etype => O_Tnode_Null); + + + type O_Lnode is record + -- If True, the LLVM component is the value (used for arguments). + -- If False, the LLVM component is the address of the value (used + -- for everything else). + Direct : Boolean; + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + + type O_Snode is record + -- First BB in the loop body. + Bb_Entry : BasicBlockRef; + + -- BB after the loop. + Bb_Exit : BasicBlockRef; + end record; + + O_Snode_Null : constant O_Snode := (Null_BasicBlockRef, + Null_BasicBlockRef); + + type O_Inter_List is record + Ident : O_Ident; + Storage : O_Storage; + Res_Type : O_Tnode; + Nbr_Inter : Natural; + First_Inter, Last_Inter : O_Inter_Acc; + end record; + + type O_Element; + type O_Element_Acc is access O_Element; + type O_Element is record + -- Identifier for the element + Ident : O_Ident; + + -- Type of the element + Etype : O_Tnode; + + -- Next element (in the linked list) + Next : O_Element_Acc; + end record; + + -- Record and union builder. + type O_Element_List is record + Kind : OF_Kind; + + -- Number of fields. + Nbr_Elements : Natural; + + -- For record: the access to the incomplete (but named) type. + Rec_Type : O_Tnode; + + -- For unions: biggest for size and alignment + Size : unsigned; + Align : Unsigned_32; + Align_Type : TypeRef; + + First_Elem, Last_Elem : O_Element_Acc; + end record; + + type ValueRefArray_Acc is access ValueRefArray; + + type O_Record_Aggr_List is record + -- Current number of elements in Vals. + Len : unsigned; + + -- Value of elements. + Vals : ValueRefArray_Acc; + + -- Type of the aggregate. + Atype : O_Tnode; + end record; + + type O_Array_Aggr_List is record + -- Current number of elements in Vals. + Len : unsigned; + + -- Value of elements. + Vals : ValueRefArray_Acc; + El_Type : TypeRef; + + -- Type of the aggregate. + Atype : O_Tnode; + end record; + + type O_Assoc_List is record + Subprg : O_Dnode; + Idx : unsigned; + Vals : ValueRefArray_Acc; + end record; + + type O_Enum_List is record + LLVM : TypeRef; + Num : Natural; + Etype : O_Tnode; + end record; + + type O_Choice_Type is record + Low, High : ValueRef; + Bb : BasicBlockRef; + end record; + + type O_Choice_Array is array (Natural range <>) of O_Choice_Type; + type O_Choice_Array_Acc is access O_Choice_Array; + + type O_Case_Block is record + -- BB before the case. + BB_Prev : BasicBlockRef; + + -- Select expression + Value : ValueRef; + Vtype : O_Tnode; + + -- BB after the case statement. + BB_Next : BasicBlockRef; + + -- BB for others + BB_Others : BasicBlockRef; + + -- BB for the current choice + BB_Choice : BasicBlockRef; + + -- List of choices. + Nbr_Choices : Natural; + Choices : O_Choice_Array_Acc; + end record; + + type O_If_Block is record + -- The next basic block. + -- After the 'If', this is the BB for the else part. If there is no + -- else part, this is the BB for statements after the if. + -- After the 'else', this is the BB for statements after the if. + Bb : BasicBlockRef; + end record; + + function Get_LLVM_Type (Atype : O_Tnode) return TypeRef; +end Ortho_LLVM; diff --git a/src/ortho/llvm4-nodebug/ortho_nodes.ads b/src/ortho/llvm4-nodebug/ortho_nodes.ads new file mode 100644 index 000000000..34d1dbbc9 --- /dev/null +++ b/src/ortho/llvm4-nodebug/ortho_nodes.ads @@ -0,0 +1,20 @@ +-- LLVM back-end for ortho. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ortho_LLVM; +package Ortho_Nodes renames Ortho_LLVM; |