diff options
Diffstat (limited to 'src/ortho/llvm6')
-rw-r--r-- | src/ortho/llvm6/Makefile | 34 | ||||
-rw-r--r-- | src/ortho/llvm6/llvm-cbindings.cpp | 2264 | ||||
-rw-r--r-- | src/ortho/llvm6/ortho_code_main.adb | 187 | ||||
-rw-r--r-- | src/ortho/llvm6/ortho_ident.adb | 134 | ||||
-rw-r--r-- | src/ortho/llvm6/ortho_ident.ads | 44 | ||||
-rw-r--r-- | src/ortho/llvm6/ortho_llvm.adb | 39 | ||||
-rw-r--r-- | src/ortho/llvm6/ortho_llvm.ads | 885 | ||||
-rw-r--r-- | src/ortho/llvm6/ortho_llvm.private.ads | 440 | ||||
-rw-r--r-- | src/ortho/llvm6/ortho_nodes.ads | 20 |
9 files changed, 4047 insertions, 0 deletions
diff --git a/src/ortho/llvm6/Makefile b/src/ortho/llvm6/Makefile new file mode 100644 index 000000000..31f25c9fa --- /dev/null +++ b/src/ortho/llvm6/Makefile @@ -0,0 +1,34 @@ +ortho_srcdir=.. +GNATFLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwael +CXX=clang++ +LLVM_CONFIG=llvm-config +GNATMAKE=gnatmake +SED=sed +BE=llvm6 + +LLVM_LDFLAGS=$(LLVM_CONFIG) --ldflags --libs --system-libs + +all: $(ortho_exec) + +$(ortho_exec): $(ortho_srcdir)/llvm6/ortho_llvm.ads force llvm-cbindings.o + $(GNATMAKE) -o $@ -aI$(ortho_srcdir)/llvm6 -aI$(ortho_srcdir) \ + $(GNATFLAGS) ortho_code_main -bargs -E \ + -largs llvm-cbindings.o --LINK=$(CXX) \ + $(LDFLAGS) `$(LLVM_LDFLAGS)` + +llvm-cbindings.o: $(ortho_srcdir)/llvm6/llvm-cbindings.cpp + $(CXX) -c `$(LLVM_CONFIG) --cxxflags` $(CFLAGS) -o $@ $< + +clean: + $(RM) -f *.o *.ali ortho_code_main + $(RM) b~*.ad? *~ + +distclean: clean + + +force: + +.PHONY: force all clean + +ORTHO_BASENAME=ortho_llvm +include $(ortho_srcdir)/Makefile.inc diff --git a/src/ortho/llvm6/llvm-cbindings.cpp b/src/ortho/llvm6/llvm-cbindings.cpp new file mode 100644 index 000000000..6002fd05f --- /dev/null +++ b/src/ortho/llvm6/llvm-cbindings.cpp @@ -0,0 +1,2264 @@ +/* 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/Value.h" +#include "llvm/IR/LLVMContext.h" +#include "llvm/Config/llvm-config.h" +#include "llvm-c/TargetMachine.h" +#include "llvm-c/Core.h" +#include "llvm-c/BitWriter.h" +#include "llvm-c/Analysis.h" +#include "llvm-c/Transforms/Scalar.h" + +#include "llvm/IR/IRBuilder.h" +#include "llvm/IR/DIBuilder.h" +#include "llvm/Support/FileSystem.h" +#include <vector> + +using namespace llvm; + +// True if the LLVM output must be displayed (set by '--dump-llvm') +static bool FlagDumpLLVM = false; + +// Verify generated LLVM code. +static bool FlagVerifyLLVM = false; + +static bool FlagDebugLines = true; + +static LLVMModuleRef TheModule; +static LLVMTargetRef TheTarget; +static LLVMTargetMachineRef TheTargetMachine; +static LLVMTargetDataRef TheTargetData; +static LLVMRelocMode TheReloc = LLVMRelocDefault; +static LLVMCodeGenOptLevel Optimization = LLVMCodeGenLevelDefault; + +static LLVMBuilderRef Builder; +static LLVMBuilderRef DeclBuilder; +static LLVMBuilderRef ExtraBuilder; + +static LLVMValueRef StackSaveFun; +static LLVMValueRef StackRestoreFun; +static LLVMValueRef CopySignFun; + +static LLVMValueRef Fp0_5; +static LLVMAttributeRef NounwindAttr; +static LLVMAttributeRef UwtableAttr; + +static bool Unreach; + +static unsigned DebugCurrentLine; +static std::string *DebugCurrentFilename; +static std::string *DebugCurrentDirectory; +static DIFile *DebugCurrentFile; + +static DIBuilder *DBuilder; + +extern "C" void +set_optimization_level (unsigned level) +{ + switch(level) { + case 0: + Optimization = LLVMCodeGenLevelNone; + break; + case 1: + Optimization = LLVMCodeGenLevelLess; + break; + case 2: + Optimization = LLVMCodeGenLevelDefault; + break; + default: + Optimization = LLVMCodeGenLevelAggressive; + break; + } +} + +extern "C" void +set_dump_llvm (unsigned Flag) +{ + FlagDumpLLVM = Flag != 0; +} + +extern "C" void +set_verify_llvm (unsigned Flag) +{ + FlagVerifyLLVM = Flag != 0; +} + +extern "C" void +set_pic_flag (unsigned Flag) +{ + TheReloc = Flag ? LLVMRelocPIC : LLVMRelocStatic; +} + +static void +generateError(const char *Filename, char *Msg) +{ + fprintf(stderr, "error while writing to %s\n", Filename); + if (Msg) { + fprintf(stderr, "message: %s\n", Msg); + LLVMDisposeMessage(Msg); + } + exit(2); +} + +static void +generateCommon() +{ + char *Msg; + + if (FlagDumpLLVM) + LLVMDumpModule(TheModule); + + if (FlagVerifyLLVM) { + if (LLVMVerifyModule(TheModule, LLVMPrintMessageAction, &Msg)) { + LLVMDisposeMessage (Msg); + abort(); + } + } + + if (Optimization > LLVMCodeGenLevelNone) { + LLVMPassManagerRef PassManager; + PassManager = LLVMCreateFunctionPassManagerForModule (TheModule); + + LLVMAddPromoteMemoryToRegisterPass (PassManager); + LLVMAddCFGSimplificationPass (PassManager); + + for (LLVMValueRef Func = LLVMGetFirstFunction (TheModule); + Func != nullptr; + Func = LLVMGetNextFunction(Func)) { + LLVMRunFunctionPassManager (PassManager, Func); + } + } +} +extern "C" void +generate_object(char *Filename) +{ + char *Msg; + + generateCommon(); + + if (LLVMTargetMachineEmitToFile (TheTargetMachine, TheModule, Filename, + LLVMObjectFile, &Msg)) + generateError(Filename, Msg); +} + +extern "C" void +generate_assembly(char *Filename) +{ + char *Msg; + + generateCommon(); + + if (LLVMTargetMachineEmitToFile (TheTargetMachine, TheModule, Filename, + LLVMAssemblyFile, &Msg)) + generateError(Filename, Msg); +} + +extern "C" void +generate_bitcode(const char *Filename) +{ + generateCommon(); + + if (LLVMWriteBitcodeToFile(TheModule, Filename)) { + generateError(Filename, nullptr); + } +} + +extern "C" void +generate_llvm(char *Filename) +{ + char *Msg; + + generateCommon(); + + if (LLVMPrintModuleToFile(TheModule, Filename, &Msg)) { + generateError(Filename, Msg); + } +} + +extern "C" void +ortho_llvm_init(const char *Filename, unsigned FilenameLength) +{ + char *Msg; + + LLVMInitializeNativeTarget(); + LLVMInitializeNativeAsmPrinter(); + + TheModule = LLVMModuleCreateWithName ("ortho"); + + // Get target triple (from how llvm was configured). + char *Triple = LLVMGetDefaultTargetTriple(); + +#if LLVM_VERSION_MAJOR >= 7 + { + char *RawTriple = Triple; + Triple = LLVMNormalizeTargetTriple(Triple); + LLVMDisposeMessage(RawTriple); + } +#endif + LLVMSetTarget(TheModule, Triple); + + // Get target - this is a struct that corresponds to the triple. + if (LLVMGetTargetFromTriple(Triple, &TheTarget, &Msg) != 0) { + fprintf(stderr, "llvm: cannot find target %s: %s\n", Triple, Msg); + LLVMDisposeMessage(Msg); + exit (1); + } + + // Create a target machine + TheTargetMachine = LLVMCreateTargetMachine + (TheTarget, Triple, NULL, NULL, Optimization, TheReloc, + LLVMCodeModelDefault); + + TheTargetData = LLVMCreateTargetDataLayout(TheTargetMachine); + LLVMSetModuleDataLayout(TheModule, TheTargetData); + + Builder = LLVMCreateBuilder(); + DeclBuilder = LLVMCreateBuilder(); + ExtraBuilder = LLVMCreateBuilder(); + + LLVMTypeRef I8Ptr = LLVMPointerType(LLVMInt8Type(), 0); + + StackSaveFun = LLVMAddFunction + (TheModule, "llvm.stacksave", LLVMFunctionType (I8Ptr, NULL, 0, false)); + + LLVMTypeRef ParamTypes[2]; + + ParamTypes[0] = I8Ptr; + StackRestoreFun = LLVMAddFunction + (TheModule, "llvm.stackrestore", + LLVMFunctionType(LLVMVoidType(), ParamTypes, 1, false)); + + ParamTypes[0] = LLVMDoubleType(); + ParamTypes[1] = LLVMDoubleType(); + CopySignFun = LLVMAddFunction + (TheModule, "llvm.copysign.f64", + LLVMFunctionType(LLVMDoubleType(), ParamTypes, 2, false)); + + Fp0_5 = LLVMConstReal(LLVMDoubleType(), 0.5); + + unsigned AttrId; + + AttrId = LLVMGetEnumAttributeKindForName("nounwind", 8); + assert (AttrId != 0); + NounwindAttr = LLVMCreateEnumAttribute(LLVMGetGlobalContext(), AttrId, 0); + + AttrId = LLVMGetEnumAttributeKindForName("uwtable", 7); + assert (AttrId != 0); + UwtableAttr = LLVMCreateEnumAttribute(LLVMGetGlobalContext(), AttrId, 0); + + if (FlagDebugLines) { + DBuilder = new DIBuilder(*unwrap(TheModule)); + + DebugCurrentFilename = new std::string(Filename, FilenameLength); + SmallString<128> CurrentDir; + llvm::sys::fs::current_path(CurrentDir); + DebugCurrentDirectory = new std::string(CurrentDir.data(), + CurrentDir.size()); + + DebugCurrentFile = DBuilder->createFile(StringRef(*DebugCurrentFilename), + StringRef(*DebugCurrentDirectory)); + } +} + +enum OTKind : unsigned char { + OTKUnsigned, OTKSigned, OTKFloat, + OTKEnum, OTKBool, + OTKAccess, OTKIncompleteAccess, + OTKRecord, OTKIncompleteRecord, + OTKUnion, + OTKArray +}; + +struct OTnodeBase { + LLVMTypeRef Ref; + LLVMValueRef Dbg; + + OTKind Kind; + bool Bounded; + OTnodeBase (LLVMTypeRef R, OTKind K, bool Bounded) : + Ref(R), Dbg(nullptr), Kind(K), Bounded(Bounded) {} +}; + +typedef OTnodeBase *OTnode; + +struct OTnodeScal : OTnodeBase { + // For scalar: the size + unsigned ScalSize; + + OTnodeScal (LLVMTypeRef R, OTKind K, unsigned Sz) : + OTnodeBase(R, K, true), ScalSize(Sz) {} +}; + +struct OTnodeUnsigned : OTnodeScal { + OTnodeUnsigned (LLVMTypeRef R, unsigned Sz) : + OTnodeScal(R, OTKUnsigned, Sz) {} +}; + +struct OTnodeSigned : OTnodeScal { + OTnodeSigned (LLVMTypeRef R, unsigned Sz) : + OTnodeScal(R, OTKSigned, Sz) {} +}; + +struct OTnodeFloat : OTnodeScal { + OTnodeFloat (LLVMTypeRef R, unsigned Sz) : + OTnodeScal(R, OTKFloat, Sz) {} +}; + +struct OTnodeEnum : OTnodeScal { + OTnodeEnum (LLVMTypeRef R, unsigned Sz) : + OTnodeScal(R, OTKEnum, Sz) {} +}; + +struct OTnodeBool : OTnodeScal { + OTnodeBool (LLVMTypeRef R) : OTnodeScal(R, OTKBool, 1) {} +}; + +static LLVMTypeRef +SizeToLLVM (unsigned Sz) +{ + switch (Sz) { + case 8: + return LLVMInt8Type(); + case 32: + return LLVMInt32Type(); + case 64: + return LLVMInt64Type(); + default: + abort(); + } +} + +extern "C" OTnode +new_unsigned_type(unsigned Sz) +{ + return new OTnodeUnsigned(SizeToLLVM(Sz), Sz); +} + +extern "C" OTnode +new_signed_type(unsigned Sz) +{ + return new OTnodeSigned(SizeToLLVM(Sz), Sz); +} + +extern "C" OTnode +new_float_type() +{ + return new OTnodeFloat(LLVMDoubleType(), 64); +} + +struct OEnumList { + LLVMTypeRef Ref; + unsigned Pos; + OTnodeEnum *Etype; +}; + +extern "C" void +start_enum_type (OEnumList *List, unsigned Sz) +{ + LLVMTypeRef T = SizeToLLVM(Sz); + + *List = {T, 0, new OTnodeEnum(T, Sz)}; +} + +struct OCnode { + LLVMValueRef Ref; + OTnode Ctype; +}; + +struct OIdent { + const char *cstr; +}; + +extern "C" void +new_enum_literal (OEnumList *List, OIdent Ident, OCnode *Res) +{ + *Res = {LLVMConstInt(List->Ref, List->Pos++, 0), + List->Etype}; +} + +extern "C" void +finish_enum_type (OEnumList *List, OTnode *Res) +{ + *Res = List->Etype; +} + +extern "C" void +new_boolean_type(OTnode *Res, + OIdent False_Id, OCnode *False_E, + OIdent True_Id, OCnode *True_E) +{ + OTnodeBool *T = new OTnodeBool(LLVMInt1Type()); + *Res = T; + + *False_E = {LLVMConstInt(T->Ref, 0, 0), T}; + *True_E = {LLVMConstInt(T->Ref, 1, 0), T}; +} + +extern "C" OCnode +new_signed_literal (OTnode LType, int64_t Value) +{ + return {LLVMConstInt(LType->Ref, Value, 1), LType}; +} + +extern "C" OCnode +new_unsigned_literal (OTnode LType, uint64_t Value) +{ + return {LLVMConstInt(LType->Ref, Value, 0), LType}; +} + +extern "C" OCnode +new_float_literal (OTnode LType, double Value) +{ + return {LLVMConstReal(LType->Ref, Value), LType}; +} + +struct OTnodeAccBase : OTnodeBase { + // For accesses + OTnode Acc; + + OTnodeAccBase (LLVMTypeRef R, OTKind Kind, OTnode Acc) : + OTnodeBase(R, Kind, true), Acc(Acc) {} +}; + +struct OTnodeAcc : OTnodeAccBase { + OTnodeAcc (LLVMTypeRef R, OTnode Acc) : + OTnodeAccBase(R, OTKAccess, Acc) {} +}; + +struct OTnodeIncompleteAcc : OTnodeAccBase { + OTnodeIncompleteAcc () : + OTnodeAccBase(nullptr, OTKIncompleteAccess, nullptr) {} +}; + +extern "C" OTnode +new_access_type(OTnode DType) +{ + if (DType == nullptr) { + return new OTnodeIncompleteAcc(); + } else { + return new OTnodeAcc(LLVMPointerType(DType->Ref, 0), DType); + } +} + +extern "C" void +finish_access_type(OTnodeAcc *AccType, OTnode DType) +{ + // Must be incomplete. + assert (AccType->Acc -= nullptr); + + LLVMTypeRef Types[1] = { DType->Ref }; + LLVMStructSetBody(LLVMGetElementType(AccType->Ref), Types, 1, 0); + AccType->Acc = DType; +} + +extern "C" OCnode +new_null_access (OTnode LType) +{ + return {LLVMConstNull(LType->Ref), LType}; +} + +enum OFKind { OF_Record, OF_Union}; + +struct OElement { + // Identifier for the element + OIdent Ident; + + // Type of the element + OTnode Etype; + + // Next element (in the linked list) + OElement *Next; +}; + +struct OElementList { + OFKind Kind; + + // Number of fields. + unsigned Count; + + // For record: the access to the incomplete (but named) type. + OTnode RecType; + + // For unions: biggest for size and alignment + unsigned Size; + unsigned Align; + // For unions: type with the biggest alignment. + LLVMTypeRef AlignType; + + struct OElement *FirstElem; + struct OElement *LastElem; +}; + +extern "C" void +start_record_type (OElementList *Elements) +{ + *Elements = {OF_Record, + 0, + nullptr, + 0, 0, nullptr, + nullptr, + nullptr}; +} + +static void +addField(OElementList *Elements, OIdent Ident, OTnode Etype) +{ + Elements->Count++; + + OElement *El = new OElement{Ident, Etype, nullptr}; + if (Elements->FirstElem == nullptr) + Elements->FirstElem = El; + else + Elements->LastElem->Next = El; + Elements->LastElem = El; +} + +struct OFnodeBase { + OFKind Kind; + OTnode FType; + OFnodeBase(OFKind Kind, OTnode FType) : Kind(Kind), FType(FType) {} +}; + +struct OFnodeRec : OFnodeBase { + unsigned Index; + OFnodeRec(OTnode Etype, unsigned Index) : + OFnodeBase(OF_Record, Etype), Index(Index) {} +}; + +struct OFnodeUnion : OFnodeBase { + LLVMTypeRef Utype; + // Pointer type - used to do conversion between the union and the field. + LLVMTypeRef PtrType; + OFnodeUnion(OTnode Etype, LLVMTypeRef PtrType) : + OFnodeBase(OF_Union, Etype), Utype(Etype->Ref), PtrType(PtrType) {} +}; + +extern "C" void +new_record_field(OElementList *Elements, + OFnodeRec **El, OIdent Ident, OTnode Etype) +{ + *El = new OFnodeRec(Etype, Elements->Count); + addField(Elements, Ident, Etype); +} + +static void +freeElements(OElementList *Els) +{ + OElement *El, *NEl; + + for (El = Els->FirstElem; El != nullptr; El = NEl) { + NEl = El->Next; + delete El; + } + Els->FirstElem = nullptr; + Els->LastElem = nullptr; +} + +struct OTnodeRecBase : OTnodeBase { + OTnodeRecBase (LLVMTypeRef R, OTKind Kind, bool Bounded) : + OTnodeBase(R, Kind, Bounded) {} +}; + +struct OTnodeRec : OTnodeRecBase { + OTnodeRec (LLVMTypeRef R, bool Bounded) : + OTnodeRecBase(R, OTKRecord, Bounded) {} +}; + +struct OTnodeIncompleteRec : OTnodeRecBase { + OTnodeIncompleteRec () : + OTnodeRecBase(nullptr, OTKIncompleteRecord, false) {} +}; + +extern "C" void +finish_record_type(OElementList *Els, OTnode *Res) +{ + LLVMTypeRef *Types = new LLVMTypeRef[Els->Count]; + + OElement *El; + int i; + bool Bounded = true; + for (i = 0, El = Els->FirstElem; El != nullptr; El = El->Next, i++) { + Bounded &= El->Etype->Bounded; + Types[i] = El->Etype->Ref; + } + + if (Els->RecType != nullptr) { + // Completion + LLVMStructSetBody (Els->RecType->Ref, Types, Els->Count, 0); + Els->RecType->Bounded = Bounded; + *Res = Els->RecType; + } else { + *Res = new OTnodeRec(LLVMStructType(Types, Els->Count, 0), Bounded); + } + freeElements(Els); +} + +extern "C" void +new_uncomplete_record_type(OTnode *Res) +{ + *Res = new OTnodeIncompleteRec(); +} + +extern "C" void +start_uncomplete_record_type(OTnodeRec *Res, OElementList *Els) +{ + // Must be incomplete. + assert (Res->Ref == nullptr); + + *Els = {OF_Record, + 0, + Res, + 0, 0, nullptr, + nullptr, + nullptr}; +} + +extern "C" void +start_union_type(OElementList *Els) +{ + *Els = {OF_Union, + 0, + nullptr, + 0, 0, nullptr, + nullptr, + nullptr}; +} + +extern "C" void +new_union_field(OElementList *Els, OFnodeUnion **El, + OIdent Ident, OTnode Etype) +{ + unsigned Size = LLVMABISizeOfType(TheTargetData, Etype->Ref); + unsigned Align = LLVMABIAlignmentOfType(TheTargetData, Etype->Ref); + + *El = new OFnodeUnion(Etype, LLVMPointerType(Etype->Ref, 0)); + + if (Size > Els->Size) + Els->Size = Size; + if (Els->AlignType == nullptr || Align > Els->Align) { + Els->Align = Align; + Els->AlignType = Etype->Ref; + } + addField(Els, Ident, Etype); +} + +struct OTnodeUnion : OTnodeBase { + // For unions + unsigned Size; + LLVMTypeRef MainField; + + OTnodeUnion(LLVMTypeRef R, unsigned Sz, LLVMTypeRef Main) : + OTnodeBase(R, OTKUnion, true), Size(Sz), MainField(Main) {} +}; + + +extern "C" void +finish_union_type(OElementList *Els, OTnode *Res) +{ + unsigned Count; + LLVMTypeRef Types[2]; + + if (Els->AlignType == nullptr) { + // An empty union + Count = 0; + } else { + unsigned Pad; + + Types[0] = Els->AlignType; + Pad = Els->Size - LLVMABISizeOfType(TheTargetData, Els->AlignType); + if (Pad != 0) { + Types[1] = LLVMArrayType(LLVMInt8Type(), Pad); + Count = 2; + } else { + Count = 1; + } + } + + *Res = new OTnodeUnion(LLVMStructType(Types, Count, 0), + Els->Size, Els->AlignType); + freeElements(Els); +} + +struct OTnodeArr : OTnodeBase { + // For arrays: type of the element + OTnode ElType; + + OTnodeArr(LLVMTypeRef R, bool Complete, OTnode E) : + OTnodeBase(R, OTKArray, Complete), ElType(E) {} +}; + +extern "C" OTnode +new_array_type(OTnode ElType, OTnode IndexType) +{ + return new OTnodeArr(LLVMArrayType(ElType->Ref, 0), false, ElType); +} + +extern "C" OTnode +new_constrained_array_type(OTnodeArr *ArrType, OCnode *Length) +{ + unsigned Len = LLVMConstIntGetZExtValue(Length->Ref); + + return new OTnodeArr(LLVMArrayType(ArrType->ElType->Ref, Len), + ArrType->ElType->Bounded, + ArrType->ElType); +} + +extern "C" void +new_type_decl(OIdent Ident, OTnode Atype) +{ + switch(Atype->Kind) { + case OTKIncompleteAccess: + Atype->Ref = LLVMPointerType + (LLVMStructCreateNamed(LLVMGetGlobalContext(), Ident.cstr), 0); + break; + case OTKIncompleteRecord: + Atype->Ref = LLVMStructCreateNamed(LLVMGetGlobalContext(), Ident.cstr); + break; + default: + break; + } +} + +struct ORecordAggrList { + unsigned Len; + LLVMValueRef *Els; + OTnode Atype; +}; + +extern "C" void +start_record_aggr(ORecordAggrList *List, OTnode Atype) +{ + unsigned Count = LLVMCountStructElementTypes(Atype->Ref); + *List = {0, new LLVMValueRef[Count], Atype}; +} + +extern "C" void +new_record_aggr_el(ORecordAggrList *List, OCnode *Val) +{ + List->Els[List->Len++] = Val->Ref; +} + +extern "C" void +finish_record_aggr(ORecordAggrList *List, OCnode *Res) +{ + *Res = {LLVMConstStruct(List->Els, List->Len, 0), List->Atype}; + delete List->Els; +} + +struct OArrayAggrList { + unsigned Len; + LLVMValueRef *Els; + LLVMTypeRef ElType; + OTnode Atype; +}; + +extern "C" void +start_array_aggr(OArrayAggrList *List, OTnodeArr *Atype, unsigned len) +{ + *List = {0, new LLVMValueRef[len], Atype->ElType->Ref, Atype}; +} + +extern "C" void +new_array_aggr_el(OArrayAggrList *List, OCnode *Value) +{ + List->Els[List->Len++] = Value->Ref; +} + +extern "C" void +finish_array_aggr(OArrayAggrList *List, OCnode *Res) +{ + *Res = {LLVMConstArray(List->ElType, List->Els, List->Len), List->Atype}; + delete List->Els; +} + +extern "C" OCnode +new_union_aggr(OTnodeUnion *Atype, OFnodeUnion *Field, OCnode *Value) +{ + unsigned Size = LLVMABISizeOfType(TheTargetData, Field->Utype); + LLVMValueRef Vals[2]; + unsigned Count; + + Vals[0] = Value->Ref; + if (Size < Atype->Size) { + // Add padding. + Vals[1] = LLVMGetUndef(LLVMArrayType(LLVMInt8Type(), Atype->Size - Size)); + Count = 2; + } else { + Count = 1; + } + + return {LLVMConstStruct(Vals, Count, false), Atype}; +} + +extern "C" OCnode +new_default_value(OTnode Ltype) +{ + return {LLVMConstNull(Ltype->Ref), Ltype}; +} + +static OCnode +constToConst(OTnode Rtype, uint64_t Val) +{ + LLVMValueRef Ref; + + switch (Rtype->Kind) { + case OTKUnsigned: + case OTKSigned: + Ref = LLVMConstInt(Rtype->Ref, Val, 0); + break; + case OTKAccess: + // It is possible to use an access type for offsetof. + Ref = LLVMConstInt(LLVMInt64Type(), Val, 0); + Ref = LLVMConstIntToPtr(Ref, Rtype->Ref); + break; + default: + abort(); + } + return {Ref, Rtype}; +} + +extern "C" OCnode +new_sizeof(OTnode Atype, OTnode Rtype) +{ + return constToConst(Rtype, LLVMABISizeOfType(TheTargetData, Atype->Ref)); +} + +extern "C" OCnode +new_alignof(OTnode Atype, OTnode Rtype) +{ + return constToConst + (Rtype, LLVMABIAlignmentOfType(TheTargetData, Atype->Ref)); +} + +extern "C" OCnode +new_offsetof(OTnode Atype, OFnodeRec *Field, OTnode Rtype) +{ + return constToConst + (Rtype, LLVMOffsetOfElement(TheTargetData, Atype->Ref, Field->Index)); +} + +struct OEnode { + LLVMValueRef Ref; + OTnode Etype; +}; + +extern "C" OEnode +new_lit(OCnode *Lit) +{ + return {Lit->Ref, Lit->Ctype}; +} + +enum ODKind : unsigned char { + ODKConst, + ODKVar, + ODKLocal, + ODKInterface, + ODKType, + ODKSubprg +}; + +struct ODnodeBase { + LLVMValueRef Ref; + OTnode Dtype; + virtual ODKind getKind() const = 0; + ODnodeBase(LLVMValueRef R, OTnode T) : Ref(R), Dtype(T) {} + virtual ~ODnodeBase() {} +}; + +typedef ODnodeBase *ODnode; + +struct ODnodeVar : ODnodeBase { + ODKind getKind() const override { return ODKVar; } + ODnodeVar(LLVMValueRef R, OTnode T) : ODnodeBase(R, T) {} +}; + +struct ODnodeLocalVar : ODnodeBase { + ODKind getKind() const override { return ODKLocal; } + ODnodeLocalVar(LLVMValueRef R, OTnode T) : ODnodeBase(R, T) {} +}; + +enum OStorage { + O_Storage_External, + O_Storage_Public, + O_Storage_Private, + O_Storage_Local +}; + +extern "C" void +new_var_decl(ODnode *Res, OIdent Ident, OStorage Storage, OTnode Atype) +{ + LLVMValueRef Decl; + + if (Storage == O_Storage_Local) { + if (Unreach) + Decl = nullptr; + else + Decl = LLVMBuildAlloca (DeclBuilder, Atype->Ref, Ident.cstr); + *Res = new ODnodeLocalVar(Decl, Atype); + } else { + if (Storage == O_Storage_External) { + Decl = LLVMGetNamedGlobal(TheModule, Ident.cstr); + } else { + Decl = nullptr; + } + if (Decl == nullptr) + Decl = LLVMAddGlobal(TheModule, Atype->Ref, Ident.cstr); + + *Res = new ODnodeVar(Decl, Atype); + if (Storage == O_Storage_Private) + LLVMSetLinkage(Decl, LLVMInternalLinkage); + + switch(Storage) { + case O_Storage_Public: + case O_Storage_Private: + LLVMSetInitializer(Decl, LLVMConstNull(Atype->Ref)); + break; + default: + break; + } + } +} + +struct ODnodeConst : ODnodeBase { + OStorage Storage; + OIdent Ident; + ODKind getKind() const override { return ODKConst; } + ODnodeConst(LLVMValueRef R, OTnode T, OStorage S, OIdent I) : + ODnodeBase(R, T), Storage(S), Ident(I) {} +}; + +static void +setConstAttributes(LLVMValueRef Ref, OStorage Storage) +{ + LLVMSetGlobalConstant(Ref, true); + if (Storage == O_Storage_Private) + LLVMSetLinkage(Ref, LLVMInternalLinkage); +} + +extern "C" void +new_const_decl(ODnode *Res, OIdent Ident, OStorage Storage, OTnode Atype) +{ + LLVMValueRef Decl; + + if (Storage == O_Storage_External) { + // It is possible to re-declare an external const. + Decl = LLVMGetNamedGlobal(TheModule, Ident.cstr); + if (Decl == nullptr) + Decl = LLVMAddGlobal(TheModule, Atype->Ref, Ident.cstr); + setConstAttributes(Decl, Storage); + } else { + // If the type of the constant is not yet bounded, delay the creation + // of the constant until its initialization. + if (Atype->Bounded) { + Decl = LLVMAddGlobal(TheModule, Atype->Ref, Ident.cstr); + setConstAttributes(Decl, Storage); + } else { + Decl = nullptr; + } + } + + *Res = new ODnodeConst(Decl, Atype, Storage, Ident); +} + +extern "C" void +start_init_value(ODnodeConst **Decl) +{ +} + +extern "C" void +finish_init_value(ODnodeConst **Decl, OCnode *Val) +{ + LLVMValueRef Ref = (*Decl)->Ref; + + if (Ref == nullptr) { + Ref = LLVMAddGlobal(TheModule, LLVMTypeOf(Val->Ref), (*Decl)->Ident.cstr); + setConstAttributes(Ref, (*Decl)->Storage); + (*Decl)->Ref = Ref; + } + + LLVMSetInitializer(Ref, Val->Ref); +} + +struct ODnodeInter : ODnodeBase { + ODKind getKind() const override { return ODKInterface; } + ODnodeInter(LLVMValueRef R, OTnode T) : ODnodeBase(R, T) {} +}; + +struct OInter { + ODnodeInter *Decl; + OIdent Ident; + OInter *Next; +}; + +struct OInterList { + OIdent Ident; + OStorage Storage; + OTnode Rtype; + + // Number of interfaces. + unsigned Count; + OInter *FirstInter; + OInter *LastInter; +}; + +extern "C" void +start_function_decl(OInterList *Inters, OIdent Ident, OStorage Storage, + OTnode Rtype) +{ + *Inters = { Ident, Storage, Rtype, 0, nullptr, nullptr }; +} + +extern "C" void +start_procedure_decl(OInterList *Inters, OIdent Ident, OStorage Storage) +{ + *Inters = { Ident, Storage, nullptr, 0, nullptr, nullptr }; +} + +extern "C" void +new_interface_decl(OInterList *Inters, + ODnode *Res, OIdent Ident, OTnode Itype) +{ + ODnodeInter *Decl = new ODnodeInter(nullptr, Itype); + OInter *Inter = new OInter{Decl, Ident, nullptr}; + + *Res = Decl; + Inters->Count++; + if (Inters->FirstInter == nullptr) + Inters->FirstInter = Inter; + else + Inters->LastInter->Next = Inter; + Inters->LastInter = Inter; +} + +struct ODnodeSubprg : ODnodeBase { + // Number of interfaces. + unsigned Count; + ODKind getKind() const override { return ODKSubprg; } + ODnodeSubprg(LLVMValueRef R, OTnode T, unsigned Count) : + ODnodeBase(R, T), Count(Count) {} +}; + +extern "C" void +finish_subprogram_decl(OInterList *Inters, ODnode *Res) +{ + LLVMTypeRef *Types = new LLVMTypeRef[Inters->Count]; + + // Build array of interface types. + int i = 0; + for (OInter *Inter = Inters->FirstInter; Inter; Inter = Inter->Next, i++) + Types[i] = Inter->Decl->Dtype->Ref; + + LLVMTypeRef Rtype; + if (Inters->Rtype == nullptr) + Rtype = LLVMVoidType(); + else + Rtype = Inters->Rtype->Ref; + + LLVMTypeRef Ftype = LLVMFunctionType(Rtype, Types, Inters->Count, 0); + + LLVMValueRef Decl; + if (Inters->Storage == O_Storage_External) + Decl = LLVMGetNamedFunction(TheModule, Inters->Ident.cstr); + else + Decl = nullptr; + if (Decl == nullptr) { + Decl = LLVMAddFunction(TheModule, Inters->Ident.cstr, Ftype); + LLVMAddAttributeAtIndex(Decl, LLVMAttributeFunctionIndex, NounwindAttr); + LLVMAddAttributeAtIndex(Decl, LLVMAttributeFunctionIndex, UwtableAttr); + LLVMSetFunctionCallConv(Decl, LLVMCCallConv); + } + + *Res = new ODnodeSubprg(Decl, Inters->Rtype, Inters->Count); + + // Translate interfaces + i = 0; + for (OInter *Inter = Inters->FirstInter, *Next; Inter; Inter = Next, i++) { + Inter->Decl->Ref = LLVMGetParam(Decl, i); + LLVMSetValueName(Inter->Decl->Ref, Inter->Ident.cstr); + Next = Inter->Next; + delete Inter; + } +} + +// Data for a declare block. +struct DeclareBlock { + // First basic block of the declare. + LLVMBasicBlockRef StmtBB; + + // To handle allocb: stack pointer at the entry of the block, that needs + // to be restored when leaving the block (either by falling through or + // via exit/next). Set only of New_Alloca is used. + LLVMValueRef StackValue; + + // Previous value block. + DeclareBlock *Prev; +}; + +static DeclareBlock *CurrentDeclareBlock; +static DeclareBlock *OldDeclareBlock; + +static LLVMValueRef CurrentFunc; +static ODnodeSubprg *CurrentFuncDecl; + +static void +CreateDeclareBlock() +{ + DeclareBlock *Res; + + // Allocate a declare block + if (OldDeclareBlock != nullptr) { + Res = OldDeclareBlock; + OldDeclareBlock = Res->Prev; + } else { + Res = new DeclareBlock; + } + *Res = { nullptr, nullptr, CurrentDeclareBlock }; + CurrentDeclareBlock = Res; + + if (!Unreach) { + Res->StmtBB = LLVMAppendBasicBlock(CurrentFunc, ""); + } +} + +static void +DestroyDeclareBlock() +{ + DeclareBlock *Blk = CurrentDeclareBlock; + + CurrentDeclareBlock = Blk->Prev; + + Blk->Prev = OldDeclareBlock; + OldDeclareBlock = Blk; +} + +extern "C" void +start_subprogram_body(ODnodeSubprg *Func) +{ + LLVMBasicBlockRef DeclBB; + + // Nested subprograms are not supported. + assert (CurrentFunc == nullptr); + + CurrentFunc = Func->Ref; + CurrentFuncDecl = Func; + + assert(!Unreach); + + DeclBB = LLVMAppendBasicBlock(CurrentFunc, ""); + LLVMPositionBuilderAtEnd(DeclBuilder, DeclBB); + + CreateDeclareBlock(); + LLVMPositionBuilderAtEnd(Builder, CurrentDeclareBlock->StmtBB); +} + +extern "C" void +finish_subprogram_body() +{ + // Add a jump from the declare basic block to the first statement BB. + LLVMBuildBr(DeclBuilder, CurrentDeclareBlock->StmtBB); + + // Terminate the statement BB + if (!Unreach) { + if (CurrentFuncDecl->Dtype == nullptr) + LLVMBuildRetVoid (Builder); + else + LLVMBuildUnreachable (Builder); + } + + DestroyDeclareBlock(); + + CurrentFunc = nullptr; + Unreach = false; +} + +extern "C" void +start_declare_stmt () +{ + CreateDeclareBlock(); + + if (Unreach) + return; + + // Add a jump to the new BB. + LLVMBuildBr(Builder, CurrentDeclareBlock->StmtBB); + + LLVMPositionBuilderAtEnd(Builder, CurrentDeclareBlock->StmtBB); +} + +extern "C" void +finish_declare_stmt () +{ + if (!Unreach) { + LLVMBasicBlockRef Bb; + + // Create a basic block for the statements after the dclare + Bb = LLVMAppendBasicBlock(CurrentFunc, ""); + + if (CurrentDeclareBlock->StackValue != nullptr) { + // Restore stack pointer + LLVMBuildCall(Builder, StackRestoreFun, + &CurrentDeclareBlock->StackValue, 1, ""); + } + // Execution will continue on the next statement + LLVMBuildBr(Builder, Bb); + + LLVMPositionBuilderAtEnd(Builder, Bb); + } + + // Do not reset Unreach. + DestroyDeclareBlock(); +} + +struct OSNode { + // BB at the entry of the loop. Will branch to it on next statement and + // at the end of the loop. + LLVMBasicBlockRef BBEntry; + // BB after the loop. Exit statement branches to it. + LLVMBasicBlockRef BBExit; +}; + +extern "C" void +start_loop_stmt (OSNode *Label) +{ + if (Unreach) { + *Label = { nullptr, nullptr }; + return; + } + + *Label = { LLVMAppendBasicBlock(CurrentFunc, ""), nullptr }; +#if 1 + Label->BBExit = LLVMAppendBasicBlock(CurrentFunc, ""); +#endif + LLVMBuildBr(Builder, Label->BBEntry); + LLVMPositionBuilderAtEnd(Builder, Label->BBEntry); +} + +extern "C" void +finish_loop_stmt (OSNode *Label) +{ + if (!Unreach) + LLVMBuildBr(Builder, Label->BBEntry); + + if (Label->BBExit != nullptr) { + // Continue only if the exit was reachable. + LLVMPositionBuilderAtEnd(Builder, Label->BBExit); + Unreach = false; + } else { + Unreach = true; + } +} + +extern "C" void +new_exit_stmt (OSNode *Label) +{ + if (Unreach) + return; + +#if 0 + // Currently LABEL is an input (so cannot be modified) + if (Label->BBExit == nullptr) { + // We know the end of the loop is reachable + Label->BBExit = LLVMAppendBasicBlock(CurrentFunc, ""); + } +#endif + + LLVMBuildBr(Builder, Label->BBExit); + Unreach = true; +} + +extern "C" void +new_next_stmt (OSNode *Label) +{ + if (Unreach) + return; + + LLVMBuildBr(Builder, Label->BBEntry); + Unreach = true; +} + +struct OIFBlock { + LLVMBasicBlockRef Bb; +}; + +extern "C" void +start_if_stmt (OIFBlock *Blk, OEnode Cond) +{ + if (Unreach) { + *Blk = { nullptr}; + return; + } + + LLVMBasicBlockRef BBThen; + + // Create BB for Then and Else. + BBThen = LLVMAppendBasicBlock(CurrentFunc, ""); + *Blk = { LLVMAppendBasicBlock(CurrentFunc, "") }; + + LLVMBuildCondBr(Builder, Cond.Ref, BBThen, Blk->Bb); + LLVMPositionBuilderAtEnd(Builder, BBThen); +} + +extern "C" void +new_else_stmt (OIFBlock *Blk) +{ + LLVMBasicBlockRef BBNext; + + if (!Unreach) { + // Create a BB for after the If statement + BBNext = LLVMAppendBasicBlock(CurrentFunc, ""); + // And jump to it. + LLVMBuildBr(Builder, BBNext); + } else { + if (Blk->Bb == nullptr) { + // The IF statement was unreachable, so is the Else part. + return; + } + // Do not yet create the BB for after the If statement, as we don't + // know if it is reachable. + BBNext = nullptr; + } + + // Use the BB for the Else part. + LLVMPositionBuilderAtEnd(Builder, Blk->Bb); + + Blk->Bb = BBNext; + // The Else part is reachable. + Unreach = false; +} + +extern "C" void +finish_if_stmt (OIFBlock *Blk) +{ + LLVMBasicBlockRef BBNext; + + if (!Unreach) { + if (Blk->Bb == nullptr) + BBNext = LLVMAppendBasicBlock(CurrentFunc, ""); + else + BBNext = Blk->Bb; + LLVMBuildBr(Builder, BBNext); + LLVMPositionBuilderAtEnd(Builder, BBNext); + } else { + // The branch doesn't continue. + if (Blk->Bb != nullptr) { + // There is at least one fall-through (either from the Then or from + // the Else. + Unreach = false; + LLVMPositionBuilderAtEnd(Builder, Blk->Bb); + } + } +} + +struct OChoice { + LLVMValueRef Low, High; + LLVMBasicBlockRef BB; +}; + +struct OCaseBlock { + // BB before the case. + LLVMBasicBlockRef BBPrev; + + // Select expression + LLVMValueRef Value; + OTnode Vtype; + + // BB after the case statement + LLVMBasicBlockRef BBNext; + + // BB for others + LLVMBasicBlockRef BBOthers; + + // BB for the current choice + LLVMBasicBlockRef BBChoice; + + std::vector<OChoice> *Choices; +}; + +extern "C" void +start_case_stmt (OCaseBlock *Blk, OEnode Value) +{ + LLVMBasicBlockRef BB; + std::vector<OChoice> *Choices; + + if (Unreach) { + // The case statement is unreachable, discard it completly. + BB = nullptr; + Choices = nullptr; + } else { + BB = LLVMGetInsertBlock(Builder); + Choices = new std::vector<OChoice>; + } + + *Blk = { BB, + Value.Ref, + Value.Etype, + nullptr, + nullptr, + nullptr, + Choices }; +} + +// Close previous branch +static void +finishBranch (OCaseBlock *Blk) +{ + if (Unreach) { + // No need to close it as this point is not reachable. + return; + } + + if (Blk->BBNext == nullptr) { + // Create the BB for after the case statement. + // It also means the end is reachable. + Blk->BBNext = LLVMAppendBasicBlock(CurrentFunc, ""); + } + LLVMBuildBr(Builder, Blk->BBNext); +} + +extern "C" void +start_choice (OCaseBlock *Blk) +{ + if (Blk->BBPrev == nullptr) { + // The wholse case statement was unreachable + assert(Unreach); + return; + } + + if (Blk->BBChoice != nullptr) { + // Close previous branch + finishBranch(Blk); + } + + // This new choice is reachable from the start of the case statement. + Unreach = false; + + // Create a new BB. + Blk->BBChoice = LLVMAppendBasicBlock(CurrentFunc, ""); + LLVMPositionBuilderAtEnd(Builder, Blk->BBChoice); +} + +// Add a choice that will branch to Blk->BBChoice. +static void +newChoice(OCaseBlock *Blk, LLVMValueRef Low, LLVMValueRef High) +{ + if (Unreach) + return; + + Blk->Choices->push_back({Low, High, Blk->BBChoice}); +} + +extern "C" void +new_expr_choice (OCaseBlock *Blk, OCnode *Expr) +{ + newChoice(Blk, Expr->Ref, nullptr); +} + +extern "C" void +new_range_choice (OCaseBlock *Blk, OCnode *Low, OCnode *High) +{ + newChoice(Blk, Low->Ref, High->Ref); +} + +extern "C" void +new_default_choice (OCaseBlock *Blk) +{ + if (Unreach) + return; + + Blk->BBOthers = Blk->BBChoice; +} + +extern "C" void +finish_choice (OCaseBlock *Blk) +{ +} + +extern "C" void +finish_case_stmt (OCaseBlock *Blk) +{ + LLVMIntPredicate GE, LE; + + if (Blk->BBPrev == nullptr) { + // The whole case statement is not reachable. + return; + } + + if (Blk->BBChoice != nullptr) { + // Close previous branch + finishBranch(Blk); + } + + // Strategy: use a switch instruction for simple choices, put range choices + // in the default branch, using if statements. + // TODO: could improve the handling of ranges (dichotomy, decision tree...) + switch (Blk->Vtype->Kind) { + case OTKUnsigned: + case OTKEnum: + case OTKBool: + GE = LLVMIntUGE; + LE = LLVMIntULE; + break; + case OTKSigned: + GE = LLVMIntSGE; + LE = LLVMIntSLE; + break; + default: + llvm_unreachable(); + } + + // BB for the default case. + LLVMBasicBlockRef BBDefault = LLVMAppendBasicBlock(CurrentFunc, ""); + LLVMPositionBuilderAtEnd(Builder, BBDefault); + + // Put range choices in the default case. + unsigned int Count = 0; + LLVMBasicBlockRef BBLast = BBDefault; + for(auto &c: *Blk->Choices) { + if (c.High != nullptr) { + BBLast = LLVMAppendBasicBlock(CurrentFunc, ""); + LLVMBuildCondBr(Builder, + LLVMBuildAnd(Builder, + LLVMBuildICmp(Builder, GE, + Blk->Value, c.Low, ""), + LLVMBuildICmp(Builder, LE, + Blk->Value, c.High, ""), + ""), + c.BB, BBLast); + LLVMPositionBuilderAtEnd(Builder, BBLast); + } else { + Count++; + } + } + + // Insert the switch + LLVMPositionBuilderAtEnd(Builder, Blk->BBPrev); + LLVMValueRef Sw = LLVMBuildSwitch(Builder, Blk->Value, BBDefault, Count); + for(auto &c: *Blk->Choices) { + if (c.High == nullptr) { + LLVMAddCase(Sw, c.Low, c.BB); + } + } + + // Insert the others (if there is one). + LLVMPositionBuilderAtEnd(Builder, BBLast); + if (Blk->BBOthers != nullptr) + LLVMBuildBr(Builder, Blk->BBOthers); + else + LLVMBuildUnreachable(Builder); + + // Next BB. + if (Blk->BBNext != nullptr) { + Unreach = false; + LLVMPositionBuilderAtEnd(Builder, Blk->BBNext); + } else { + // No branch falls through + Unreach = true; + } + delete Blk->Choices; +} + +struct OAssocList { + ODnodeSubprg *Subprg; + unsigned Idx; + LLVMValueRef *Vals; +}; + +extern "C" void +start_association (OAssocList *Assocs, ODnodeSubprg *Subprg) +{ + *Assocs = { Subprg, 0, new LLVMValueRef[Subprg->Count] }; +} + +extern "C" void +new_association (OAssocList *Assocs, OEnode Val) +{ + Assocs->Vals[Assocs->Idx++] = Val.Ref; +} + +extern "C" OEnode +new_function_call (OAssocList *Assocs) +{ + LLVMValueRef Res; + + if (!Unreach) { + Res = LLVMBuildCall(Builder, Assocs->Subprg->Ref, + Assocs->Vals, Assocs->Subprg->Count, ""); + } else { + Res = nullptr; + } + delete Assocs->Vals; + return { Res, Assocs->Subprg->Dtype }; +} + +extern "C" void +new_procedure_call (OAssocList *Assocs) +{ + if (!Unreach) { + LLVMBuildCall(Builder, Assocs->Subprg->Ref, + Assocs->Vals, Assocs->Subprg->Count, ""); + } + delete Assocs->Vals; +} + +extern "C" void +new_func_return_stmt (OEnode Value) +{ + if (Unreach) + return; + LLVMBuildRet(Builder, Value.Ref); + Unreach = true; +} + +extern "C" void +new_proc_return_stmt () +{ + if (Unreach) + return; + LLVMBuildRetVoid(Builder); + Unreach = true; +} + +enum ONOpKind { + /* Not an operation; invalid. */ + ON_Nil, + + /* Dyadic operations. */ + ON_Add_Ov, + ON_Sub_Ov, + ON_Mul_Ov, + ON_Div_Ov, + ON_Rem_Ov, + ON_Mod_Ov, + + /* Binary operations. */ + ON_And, + ON_Or, + ON_Xor, + + /* Monadic operations. */ + ON_Not, + ON_Neg_Ov, + ON_Abs_Ov, + + /* Comparaisons */ + ON_Eq, + ON_Neq, + ON_Le, + ON_Lt, + ON_Ge, + ON_Gt, + + ON_LAST +}; + +struct ComparePred { + LLVMIntPredicate SignedPred; + LLVMIntPredicate UnsignedPred; + LLVMRealPredicate RealPred; +}; + +static const ComparePred CompareTable[] = { + {LLVMIntEQ, LLVMIntEQ, LLVMRealOEQ }, // Eq + {LLVMIntNE, LLVMIntNE, LLVMRealONE }, // Ne + {LLVMIntSLE, LLVMIntULE, LLVMRealOLE }, // Le + {LLVMIntSLT, LLVMIntULT, LLVMRealOLT }, // Lt + {LLVMIntSGE, LLVMIntUGE, LLVMRealOGE }, // Ge + {LLVMIntSGT, LLVMIntUGT, LLVMRealOGT } // Gt +}; + +extern "C" OEnode +new_compare_op (ONOpKind Kind, OEnode Left, OEnode Right, OTnode Rtype) +{ + LLVMValueRef Res; + + if (Unreach) + return {nullptr, Rtype}; + + // Cannot apply C convention to ON_Op_Kind, so we need to truncate it + // (as it is represented by a byte from Ada and by int from C) + Kind = static_cast<ONOpKind>(Kind & 0xff); + + switch(Left.Etype->Kind) { + case OTKUnsigned: + case OTKEnum: + case OTKBool: + case OTKAccess: + case OTKIncompleteAccess: + Res = LLVMBuildICmp(Builder, CompareTable[Kind - ON_Eq].UnsignedPred, + Left.Ref, Right.Ref, ""); + break; + case OTKSigned: + Res = LLVMBuildICmp(Builder, CompareTable[Kind - ON_Eq].SignedPred, + Left.Ref, Right.Ref, ""); + break; + case OTKFloat: + Res = LLVMBuildFCmp(Builder, CompareTable[Kind - ON_Eq].RealPred, + Left.Ref, Right.Ref, ""); + break; + default: + abort(); + } + return {Res, Rtype}; +} + +extern "C" OEnode +new_monadic_op (ONOpKind Kind, OEnode Operand) +{ + LLVMValueRef Res; + + if (Unreach) + return { nullptr, Operand.Etype}; + + // Cannot apply C convention to ON_Op_Kind, so we need to truncate it + // (as it is represented by a byte from Ada and by int from C) + Kind = static_cast<ONOpKind>(Kind & 0xff); + + switch (Operand.Etype->Kind) { + case OTKUnsigned: + case OTKSigned: + case OTKBool: + switch (Kind) { + case ON_Not: + Res = LLVMBuildNot(Builder, Operand.Ref, ""); + break; + case ON_Neg_Ov: + Res = LLVMBuildNeg(Builder, Operand.Ref, ""); + break; + case ON_Abs_Ov: + Res = LLVMBuildSelect + (Builder, + LLVMBuildICmp (Builder, LLVMIntSLT, + Operand.Ref, + LLVMConstInt(Operand.Etype->Ref, 0, 0), + ""), + LLVMBuildNeg(Builder, Operand.Ref, ""), + Operand.Ref, + ""); + break; + default: + llvm_unreachable(); + } + break; + case OTKFloat: + switch (Kind) { + case ON_Neg_Ov: + Res = LLVMBuildFNeg(Builder, Operand.Ref, ""); + break; + case ON_Abs_Ov: + Res = LLVMBuildSelect + (Builder, + LLVMBuildFCmp (Builder, LLVMRealOLT, + Operand.Ref, + LLVMConstReal(Operand.Etype->Ref, 0.0), + ""), + LLVMBuildFNeg(Builder, Operand.Ref, ""), + Operand.Ref, + ""); + break; + default: + abort(); + } + break; + default: + abort(); + } + return {Res, Operand.Etype}; +} + +static LLVMValueRef +BuildSMod(LLVMBuilderRef Build, LLVMValueRef L, LLVMValueRef R, const char *s) +{ + LLVMTypeRef T = LLVMTypeOf(L); + LLVMBasicBlockRef NormalBB; + LLVMBasicBlockRef AdjustBB; + LLVMBasicBlockRef NextBB; + LLVMValueRef PhiVals[3]; + LLVMBasicBlockRef PhiBB[3]; + + NextBB = LLVMAppendBasicBlock(CurrentFunc, ""); + NormalBB = LLVMAppendBasicBlock(CurrentFunc, ""); + + // Avoid overflow with -1 + // if R = -1 then + // result := 0; + // else + // ... + LLVMValueRef Cond; + Cond = LLVMBuildICmp(Builder, LLVMIntEQ, R, LLVMConstAllOnes(T), ""); + LLVMBuildCondBr(Builder, Cond, NextBB, NormalBB); + PhiBB[0] = LLVMGetInsertBlock(Builder); + PhiVals[0] = LLVMConstNull(T); + + // Rm := Left rem Right + LLVMPositionBuilderAtEnd(Builder, NormalBB); + LLVMValueRef Rm = LLVMBuildSRem(Builder, L, R, s); + + // if Rm = 0 then + // result := 0 + // else + AdjustBB = LLVMAppendBasicBlock(CurrentFunc, ""); + Cond = LLVMBuildICmp(Builder, LLVMIntEQ, Rm, LLVMConstNull(T), ""); + LLVMBuildCondBr(Builder, Cond, NextBB, AdjustBB); + PhiBB[1] = NormalBB; + PhiVals[1] = LLVMConstNull(T); + + // if (L xor R) < 0 then + // result := Rm + R + // else + // result := Rm + LLVMPositionBuilderAtEnd(Builder, AdjustBB); + LLVMValueRef RXor = LLVMBuildXor(Builder, L, R, ""); + Cond = LLVMBuildICmp(Builder, LLVMIntSLT, RXor, LLVMConstNull(T), ""); + LLVMValueRef RmPlusR = LLVMBuildAdd(Builder, Rm, R, ""); + LLVMValueRef Adj = LLVMBuildSelect(Builder, Cond, RmPlusR, Rm, ""); + LLVMBuildBr(Builder, NextBB); + PhiBB[2] = AdjustBB; + PhiVals[2] = Adj; + + // The Phi node + LLVMPositionBuilderAtEnd(Builder, NextBB); + LLVMValueRef Phi = LLVMBuildPhi(Builder, T, ""); + LLVMAddIncoming(Phi, PhiVals, PhiBB, 3); + + return Phi; +} + +extern "C" OEnode +new_dyadic_op (ONOpKind Kind, OEnode Left, OEnode Right) +{ + LLVMValueRef Res; + LLVMValueRef (*Build)(LLVMBuilderRef, LLVMValueRef, LLVMValueRef, const char *); + OTKind ArgKind = Left.Etype->Kind; + + if (Unreach) + return { nullptr, Left.Etype}; + + // Cannot apply C convention to ON_Op_Kind, so we need to truncate it + // (as it is represented by a byte from Ada and by int from C) + Kind = static_cast<ONOpKind>(Kind & 0xff); + + switch (ArgKind) { + case OTKUnsigned: + case OTKSigned: + case OTKBool: + case OTKEnum: + switch (Kind) { + case ON_And: + Build = &LLVMBuildAnd; + break; + case ON_Or: + Build = &LLVMBuildOr; + break; + case ON_Xor: + Build = &LLVMBuildXor; + break; + + case ON_Add_Ov: + Build = &LLVMBuildAdd; + break; + case ON_Sub_Ov: + Build = &LLVMBuildSub; + break; + case ON_Mul_Ov: + Build = &LLVMBuildMul; + break; + case ON_Div_Ov: + if (ArgKind == OTKUnsigned) + Build = &LLVMBuildUDiv; + else + Build = &LLVMBuildSDiv; + break; + case ON_Mod_Ov: + if (ArgKind == OTKUnsigned) + Build = &LLVMBuildURem; + else + Build = &BuildSMod; + break; + case ON_Rem_Ov: + if (ArgKind == OTKUnsigned) + Build = &LLVMBuildURem; + else + Build = &LLVMBuildSRem; + break; + default: + abort(); + } + break; + + case OTKFloat: + switch (Kind) { + case ON_Add_Ov: + Build = &LLVMBuildFAdd; + break; + case ON_Sub_Ov: + Build = &LLVMBuildFSub; + break; + case ON_Mul_Ov: + Build = &LLVMBuildFMul; + break; + case ON_Div_Ov: + Build = &LLVMBuildFDiv; + break; + default: + llvm_unreachable(); + } + break; + + default: + abort(); + } + + Res = Build(Builder, Left.Ref, Right.Ref, ""); + return {Res, Left.Etype}; +} + +extern "C" OEnode +new_convert_ov (OEnode Val, OTnode Rtype) +{ + if (Unreach) { + return {nullptr, Rtype}; + } + + if (Rtype == Val.Etype) { + // Same type, nothing to do + return Val; + } + + if (Rtype->Ref == Val.Etype->Ref) { + // Same undelaying LLVM type. No conversion. + return {Val.Ref, Rtype}; + } + + LLVMValueRef Res; + + switch(Rtype->Kind) { + case OTKUnsigned: + case OTKSigned: + case OTKEnum: + case OTKBool: + switch(Val.Etype->Kind) { + case OTKUnsigned: + case OTKSigned: + case OTKEnum: + case OTKBool: + // Int to Int + if (static_cast<OTnodeScal*>(Val.Etype)->ScalSize + > static_cast<OTnodeScal*>(Rtype)->ScalSize) + Res = LLVMBuildTrunc(Builder, Val.Ref, Rtype->Ref, ""); + else if (static_cast<OTnodeScal*>(Val.Etype)->ScalSize + < static_cast<OTnodeScal*>(Rtype)->ScalSize) { + if (Val.Etype->Kind == OTKSigned) + Res = LLVMBuildSExt(Builder, Val.Ref, Rtype->Ref, ""); + else + Res = LLVMBuildZExt(Builder, Val.Ref, Rtype->Ref, ""); + } else { + Res = LLVMBuildBitCast(Builder, Val.Ref, Rtype->Ref, ""); + } + break; + case OTKFloat: + // Float to Int + { + LLVMValueRef V; + LLVMValueRef Args[2]; + Args[0] = Fp0_5; + Args[1] = Val.Ref; + V = LLVMBuildCall(Builder, CopySignFun, Args, 2, ""); + V = LLVMBuildFAdd(Builder, V, Val.Ref, ""); + Res = LLVMBuildFPToSI(Builder, V, Rtype->Ref, ""); + } + break; + default: + llvm_unreachable(); + } + break; + case OTKFloat: + // x to Float + switch (Val.Etype->Kind) { + case OTKSigned: + Res = LLVMBuildSIToFP(Builder, Val.Ref, Rtype->Ref, ""); + break; + case OTKUnsigned: + Res = LLVMBuildUIToFP(Builder, Val.Ref, Rtype->Ref, ""); + break; + default: + abort(); + } + break; + case OTKAccess: + case OTKIncompleteAccess: + assert(LLVMGetTypeKind(LLVMTypeOf(Val.Ref)) == LLVMPointerTypeKind); + Res = LLVMBuildBitCast(Builder, Val.Ref, Rtype->Ref, ""); + break; + default: + abort(); + } + return {Res, Rtype}; +} + +extern "C" OEnode +new_alloca (OTnode Rtype, OEnode Size) +{ + LLVMValueRef Res; + + if (Unreach) + Res = nullptr; + else { + if (CurrentDeclareBlock->StackValue != nullptr + && CurrentDeclareBlock->Prev != nullptr) { + // Save the stack pointer at the entry of the block. + LLVMValueRef FirstInsn = + LLVMGetFirstInstruction(CurrentDeclareBlock->StmtBB); + LLVMBuilderRef Bld; + if (FirstInsn == nullptr) { + // Alloca is the first instruction + Bld = Builder; + } else { + LLVMPositionBuilderBefore(ExtraBuilder, FirstInsn); + Bld = ExtraBuilder; + } + CurrentDeclareBlock->StackValue = + LLVMBuildCall(Bld, StackSaveFun, nullptr, 0, ""); + } + Res = LLVMBuildArrayAlloca(Builder, LLVMInt8Type(), Size.Ref, ""); + // Convert + Res = LLVMBuildBitCast(Builder, Res, Rtype->Ref, ""); + } + return {Res, Rtype}; +} + +extern "C" OCnode +new_subprogram_address (ODnodeSubprg *Subprg, OTnode Atype) +{ + return { LLVMConstBitCast(Subprg->Ref, Atype->Ref), Atype }; +} + +struct OGnode { + LLVMValueRef Ref; + OTnode Gtype; +}; + +extern "C" OGnode +new_global (ODnode Decl) +{ + return {Decl->Ref, Decl->Dtype }; +} + +extern "C" OGnode +new_global_selected_element (OGnode Rec, OFnodeBase *El) +{ + LLVMValueRef Res; + + switch(El->Kind) { + case OF_Record: + { + LLVMValueRef Idx[2]; + Idx[0] = LLVMConstInt(LLVMInt32Type(), 0, 0); + Idx[1] = LLVMConstInt(LLVMInt32Type(), + static_cast<OFnodeRec *>(El)->Index, 0); + Res = LLVMConstGEP(Rec.Ref, Idx, 2); + } + break; + case OF_Union: + Res = LLVMConstBitCast(Rec.Ref, static_cast<OFnodeUnion *>(El)->PtrType); + break; + } + return {Res, El->FType}; +} + +extern "C" OCnode +new_global_unchecked_address (OGnode Lvalue, OTnode Atype) +{ + return {LLVMConstBitCast(Lvalue.Ref, Atype->Ref), Atype}; +} + +extern "C" OCnode +new_global_address (OGnode Lvalue, OTnode Atype) +{ + return new_global_unchecked_address(Lvalue, Atype); +} + +struct OLnode { + bool Direct; + LLVMValueRef Ref; + OTnode Ltype; +}; + +extern "C" OLnode +new_obj (ODnode Obj) +{ + switch(Obj->getKind()) { + case ODKConst: + case ODKVar: + case ODKLocal: + return { false, Obj->Ref, Obj->Dtype }; + case ODKInterface: + return { true, Obj->Ref, Obj->Dtype }; + case ODKType: + case ODKSubprg: + llvm_unreachable(); + } +} + +extern "C" OEnode +new_value (OLnode *Lvalue) +{ + LLVMValueRef Res; + + if (Unreach) + Res = nullptr; + else { + if (Lvalue->Direct) + Res = Lvalue->Ref; + else + Res = LLVMBuildLoad(Builder, Lvalue->Ref, ""); + } + return {Res, Lvalue->Ltype }; +} + +extern "C" OEnode +new_obj_value (ODnode Obj) +{ + OLnode t = new_obj(Obj); + return new_value (&t); +} + +extern "C" OLnode +new_indexed_element (OLnode *Arr, OEnode Index) +{ + LLVMValueRef Idx[2]; + LLVMValueRef Res; + + if (Unreach) + Res = nullptr; + else { + Idx[0] = LLVMConstInt(LLVMInt32Type(), 0, 0); + Idx[1] = Index.Ref; + Res = LLVMBuildGEP(Builder, Arr->Ref, Idx, 2, ""); + } + return { false, Res, static_cast<OTnodeArr *>(Arr->Ltype)->ElType }; +} + +extern "C" OLnode +new_slice (OLnode *Arr, OTnode Rtype, OEnode Index) +{ + LLVMValueRef Idx[2]; + LLVMValueRef Res; + + if (Unreach) + Res = nullptr; + else { + Idx[0] = LLVMConstInt(LLVMInt32Type(), 0, 0); + Idx[1] = Index.Ref; + Res = LLVMBuildGEP(Builder, Arr->Ref, Idx, 2, ""); + Res = LLVMBuildBitCast(Builder, Res, LLVMPointerType(Rtype->Ref, 0), ""); + } + return { false, Res, Rtype}; +} + +extern "C" OLnode +new_selected_element (OLnode *Rec, OFnodeBase *El) +{ + LLVMValueRef Res; + + if (Unreach) + Res = nullptr; + else { + switch(El->Kind) { + case OF_Record: + { + LLVMValueRef Idx[2]; + Idx[0] = LLVMConstInt(LLVMInt32Type(), 0, 0); + Idx[1] = LLVMConstInt(LLVMInt32Type(), + static_cast<OFnodeRec *>(El)->Index, 0); + Res = LLVMBuildGEP(Builder, Rec->Ref, Idx, 2, ""); + } + break; + case OF_Union: + Res = LLVMBuildBitCast(Builder, Rec->Ref, + static_cast<OFnodeUnion *>(El)->PtrType, ""); + break; + } + } + return { false, Res, El->FType }; +} + +extern "C" OLnode +new_access_element (OEnode Acc) +{ + LLVMValueRef Res; + + switch(Acc.Etype->Kind) { + case OTKAccess: + Res = Acc.Ref; + break; + case OTKIncompleteAccess: + // Unwrap the structure + { + LLVMValueRef Idx[2]; + + Idx[0] = LLVMConstInt(LLVMInt32Type(), 0, 0); + Idx[1] = LLVMConstInt(LLVMInt32Type(), 0, 0); + Res = LLVMBuildGEP(Builder, Acc.Ref, Idx, 2, ""); + } + break; + default: + llvm_unreachable(); + } + return {false, Res, static_cast<OTnodeAccBase *>(Acc.Etype)->Acc }; +} + +extern "C" OEnode +new_unchecked_address (OLnode *Lvalue, OTnode Atype) +{ + LLVMValueRef Res; + + if (Unreach) + Res = nullptr; + else + Res = LLVMBuildBitCast(Builder, Lvalue->Ref, Atype->Ref, ""); + return {Res, Atype}; +} + +extern "C" OEnode +new_address (OLnode *Lvalue, OTnode Atype) +{ + return new_unchecked_address(Lvalue, Atype); +} + +extern "C" void +new_assign_stmt (OLnode *Target, OEnode Value) +{ + assert (!Targ->Direct); + if (!Unreach) { + LLVMBuildStore(Builder, Value.Ref, Target->Ref); + } +} + +extern "C" void +new_debug_line_decl (unsigned Line) +{ + DebugCurrentLine = Line; +} + +extern "C" void +new_debug_line_stmt (unsigned Line) +{ + DebugCurrentLine = Line; +} diff --git a/src/ortho/llvm6/ortho_code_main.adb b/src/ortho/llvm6/ortho_code_main.adb new file mode 100644 index 000000000..c539070da --- /dev/null +++ b/src/ortho/llvm6/ortho_code_main.adb @@ -0,0 +1,187 @@ +-- 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 Ortho_LLVM; use Ortho_LLVM; + +procedure Ortho_Code_Main is + -- Name of the output filename (given by option '-o'). + Output : String_Acc := null; + + type Output_Kind_Type is (Output_Llvm, Output_Bitcode, + Output_Assembly, Output_Object); + Output_Kind : Output_Kind_Type := Output_Object; + + -- Index of the first file argument. + First_File : Natural; + + -- Current option index. + Optind : Natural; + + -- Number of arguments. + Argc : constant Natural := Argument_Count; +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 + Set_Dump_LLVM (1); + elsif Arg = "--verify-llvm" then + Set_Verify_LLVM (1); + 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; + elsif Arg = "-O0" then + Set_Optimization_Level (0); + elsif Arg = "-O1" or else Arg = "-O" then + Set_Optimization_Level (1); + elsif Arg = "-O2" then + Set_Optimization_Level (2); + elsif Arg = "-O3" then + Set_Optimization_Level (3); + elsif Arg = "-fpic" or Arg = "-fPIC" then + Set_PIC_Flag (1); + elsif Arg = "-fno-pic" then + Set_PIC_Flag (0); + elsif Arg = "--emit-llvm" then + Output_Kind := Output_Llvm; + elsif Arg = "--emit-bc" then + Output_Kind := Output_Bitcode; + 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; + + if First_File < Argument_Count then + Put_Line (Standard_Error, "error: too many source filenames"); + return; + end if; + + Set_Exit_Status (Failure); + + declare + Filename : String_Acc; + begin + if First_File > Argument_Count then + Filename := new String'("*stdin*"); + else + Filename := new String'(Argument (First_File)); + end if; + + Ortho_LLVM.Init (Filename.all, Filename'Length); + + if not Parse (Filename) then + -- Parse error. + return; + end if; + exception + when others => + return; + end; + + if Output /= null then + case Output_Kind is + when Output_Object => + Generate_Object (Output.all'Address); + when Output_Assembly => + Generate_Assembly (Output.all'Address); + when Output_Bitcode => + Generate_Bitcode (Output.all'Address); + when Output_Llvm => + Generate_Llvm (Output.all'Address); + end case; + end if; + + Set_Exit_Status (Success); +exception + when others => + Set_Exit_Status (2); + raise; +end Ortho_Code_Main; diff --git a/src/ortho/llvm6/ortho_ident.adb b/src/ortho/llvm6/ortho_ident.adb new file mode 100644 index 000000000..e7b650539 --- /dev/null +++ b/src/ortho/llvm6/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/llvm6/ortho_ident.ads b/src/ortho/llvm6/ortho_ident.ads new file mode 100644 index 000000000..4a69d4d6b --- /dev/null +++ b/src/ortho/llvm6/ortho_ident.ads @@ -0,0 +1,44 @@ +-- 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; + pragma Convention (C_Pass_By_Copy, O_Ident); + + O_Ident_Nul : constant O_Ident := (Addr => System.Null_Address); + + pragma Inline (Get_Cstring); +end Ortho_Ident; diff --git a/src/ortho/llvm6/ortho_llvm.adb b/src/ortho/llvm6/ortho_llvm.adb new file mode 100644 index 000000000..7ed28944a --- /dev/null +++ b/src/ortho/llvm6/ortho_llvm.adb @@ -0,0 +1,39 @@ +-- GCC back-end for ortho. +-- Copyright (C) 2002-1014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package body Ortho_LLVM is + procedure New_Debug_Filename_Decl (Filename : String) is + begin + null; + end New_Debug_Filename_Decl; + + procedure New_Debug_Comment_Decl (Comment : String) + is + pragma Unreferenced (Comment); + begin + null; + end New_Debug_Comment_Decl; + + procedure New_Debug_Comment_Stmt (Comment : String) + is + pragma Unreferenced (Comment); + begin + null; + end New_Debug_Comment_Stmt; + +end Ortho_LLVM; diff --git a/src/ortho/llvm6/ortho_llvm.ads b/src/ortho/llvm6/ortho_llvm.ads new file mode 100644 index 000000000..f73c5921d --- /dev/null +++ b/src/ortho/llvm6/ortho_llvm.ads @@ -0,0 +1,885 @@ +-- 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 System; +with Interfaces; use Interfaces; +with Interfaces.C; use Interfaces.C; +with Ortho_Ident; use Ortho_Ident; + +-- Interface to create nodes. +package Ortho_LLVM is + procedure Init (Filename : String; Filename_Length : Natural); + pragma Import (C, Init, "ortho_llvm_init"); + + type Opaque_Type is null record; + + procedure Set_Optimization_Level (Level : Natural); + pragma Import (C, Set_Optimization_Level); + + procedure Set_Dump_LLVM (Flag : Natural); + pragma Import (C, Set_Dump_LLVM); + + procedure Set_Verify_LLVM (Flag : Natural); + pragma Import (C, Set_Verify_LLVM); + + procedure Set_PIC_Flag (Flag : Natural); + pragma Import (C, Set_PIC_Flag); + + procedure Generate_Object (Filename : System.Address); + pragma Import (C, Generate_Object); + procedure Generate_Assembly (Filename : System.Address); + pragma Import (C, Generate_Assembly); + procedure Generate_Llvm (Filename : System.Address); + pragma Import (C, Generate_Llvm); + procedure Generate_Bitcode (Filename : System.Address); + pragma Import (C, Generate_Bitcode); + + -- 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_Gnode is private; + type O_Fnode is private; + + O_Cnode_Null : constant O_Cnode; + O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; + O_Enode_Null : constant O_Enode; + O_Fnode_Null : constant O_Fnode; + O_Lnode_Null : constant O_Lnode; + O_Snode_Null : constant O_Snode; + O_Tnode_Null : constant O_Tnode; + + -- True if the code generated supports nested subprograms. + Has_Nested_Subprograms : constant Boolean; + + ------------------------ + -- Type definitions -- + ------------------------ + + type O_Element_List is limited private; + + -- Build a record type. + procedure Start_Record_Type (Elements : out O_Element_List); + -- Add a field in the record; not constrained array are prohibited, since + -- its size is unlimited. + procedure New_Record_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; Etype : O_Tnode); + -- Finish the record type. + procedure Finish_Record_Type + (Elements : in out O_Element_List; Res : out O_Tnode); + + -- Build an uncomplete record type: + -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type. + -- This type can be declared or used to define access types on it. + -- Then, complete (if necessary) the record type, by calling + -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE. + procedure New_Uncomplete_Record_Type (Res : out O_Tnode); + procedure Start_Uncomplete_Record_Type (Res : O_Tnode; + Elements : out O_Element_List); + + -- Build an union type. + procedure Start_Union_Type (Elements : out O_Element_List); + procedure New_Union_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; + Etype : O_Tnode); + procedure Finish_Union_Type + (Elements : in out O_Element_List; Res : out O_Tnode); + + -- Build an access type. + -- DTYPE may be O_tnode_null in order to build an incomplete access type. + -- It is completed with finish_access_type. + function New_Access_Type (Dtype : O_Tnode) return O_Tnode; + procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode); + + -- Build an array type. + -- The array is not constrained and unidimensional. + function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) + return O_Tnode; + + -- Build a constrained array type. + function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) + return O_Tnode; + + -- Build a scalar type; size may be 8, 16, 32 or 64. + function New_Unsigned_Type (Size : Natural) return O_Tnode; + function New_Signed_Type (Size : Natural) return O_Tnode; + + -- Build a float type. + function New_Float_Type return O_Tnode; + + -- Build a boolean type. + procedure New_Boolean_Type (Res : out O_Tnode; + False_Id : O_Ident; + False_E : out O_Cnode; + True_Id : O_Ident; + True_E : out O_Cnode); + + -- Create an enumeration + type O_Enum_List is limited private; + + -- Elements are declared in order, the first is ordered from 0. + procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural); + procedure New_Enum_Literal (List : in out O_Enum_List; + Ident : O_Ident; Res : out O_Cnode); + procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode); + + ---------------- + -- Literals -- + ---------------- + + -- Create a literal from an integer. + function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) + return O_Cnode; + function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) + return O_Cnode; + + function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) + return O_Cnode; + + -- Create a null access literal. + function New_Null_Access (Ltype : O_Tnode) return O_Cnode; + + -- Create a literal with default (null) values. Can only be used to + -- define the initial value of a static decalaration. + function New_Default_Value (Ltype : O_Tnode) return O_Cnode; + + -- Build a record/array aggregate. + -- The aggregate is constant, and therefore can be only used to initialize + -- constant declaration. + -- ATYPE must be either a record type or an array subtype. + -- Elements must be added in the order, and must be literals or aggregates. + type O_Record_Aggr_List is limited private; + type O_Array_Aggr_List is limited private; + + procedure Start_Record_Aggr (List : out O_Record_Aggr_List; + Atype : O_Tnode); + procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; + Value : O_Cnode); + procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; + Res : out O_Cnode); + + procedure Start_Array_Aggr + (List : out O_Array_Aggr_List; Atype : O_Tnode; Len : Unsigned_32); + procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; + Value : O_Cnode); + procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; + Res : out O_Cnode); + + -- Build an union aggregate. + function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) + return O_Cnode; + + -- Returns the size in bytes of ATYPE. The result is a literal of + -- unsigned type RTYPE + -- ATYPE cannot be an unconstrained array type. + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; + + -- Returns the alignment in bytes for ATYPE. The result is a literal of + -- unsgined type RTYPE. + function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; + + -- Returns the offset of FIELD in its record ATYPE. The result is a + -- literal of unsigned type or access type RTYPE. + function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) + return O_Cnode; + + -- Get the address of a subprogram. + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode; + + -- Get the address of LVALUE. + -- ATYPE must be a type access whose designated type is the type of LVALUE. + -- FIXME: what about arrays. + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; + + -- Same as New_Address but without any restriction. + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; + + ------------------- + -- Expressions -- + ------------------- + + type ON_Op_Kind is + ( + -- Not an operation; invalid. + ON_Nil, + + -- Dyadic operations. + ON_Add_Ov, -- ON_Dyadic_Op_Kind + ON_Sub_Ov, -- ON_Dyadic_Op_Kind + ON_Mul_Ov, -- ON_Dyadic_Op_Kind + ON_Div_Ov, -- ON_Dyadic_Op_Kind + ON_Rem_Ov, -- ON_Dyadic_Op_Kind + ON_Mod_Ov, -- ON_Dyadic_Op_Kind + + -- Binary operations. + ON_And, -- ON_Dyadic_Op_Kind + ON_Or, -- ON_Dyadic_Op_Kind + ON_Xor, -- ON_Dyadic_Op_Kind + + -- Monadic operations. + ON_Not, -- ON_Monadic_Op_Kind + ON_Neg_Ov, -- ON_Monadic_Op_Kind + ON_Abs_Ov, -- ON_Monadic_Op_Kind + + -- Comparaisons + ON_Eq, -- ON_Compare_Op_Kind + ON_Neq, -- ON_Compare_Op_Kind + ON_Le, -- ON_Compare_Op_Kind + ON_Lt, -- ON_Compare_Op_Kind + ON_Ge, -- ON_Compare_Op_Kind + ON_Gt -- ON_Compare_Op_Kind + ); + + subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor; + subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov; + subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt; + + type O_Storage is (O_Storage_External, + O_Storage_Public, + O_Storage_Private, + O_Storage_Local); + -- Specifies the storage kind of a declaration. + -- O_STORAGE_EXTERNAL: + -- The declaration do not either reserve memory nor generate code, and + -- is imported either from an other file or from a later place in the + -- current file. + -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE: + -- The declaration reserves memory or generates code. + -- With O_STORAGE_PUBLIC, the declaration is exported outside of the + -- file while with O_STORAGE_PRIVATE, the declaration is local to the + -- file. + + Type_Error : exception; + Syntax_Error : exception; + + -- Create a value from a literal. + function New_Lit (Lit : O_Cnode) return O_Enode; + + -- Create a dyadic operation. + -- Left and right nodes must have the same type. + -- Binary operation is allowed only on boolean types. + -- The result is of the type of the operands. + function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) + return O_Enode; + + -- Create a monadic operation. + -- Result is of the type of operand. + function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) + return O_Enode; + + -- Create a comparaison operator. + -- NTYPE is the type of the result and must be a boolean type. + function New_Compare_Op + (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) + return O_Enode; + + + type O_Inter_List is limited private; + type O_Assoc_List is limited private; + type O_If_Block is limited private; + type O_Case_Block is limited private; + + + -- Get an element of an array. + -- INDEX must be of the type of the array index. + function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) + return O_Lnode; + + -- Get a slice of an array; this is equivalent to a conversion between + -- an array or an array subtype and an array subtype. + -- RES_TYPE must be an array_sub_type whose base type is the same as the + -- base type of ARR. + -- INDEX must be of the type of the array index. + function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) + return O_Lnode; + + -- Get an element of a record or a union. + -- Type of REC must be a record or a union type. + function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; + + -- Reference an access. + -- Type of ACC must be an access type. + function New_Access_Element (Acc : O_Enode) return O_Lnode; + + -- Do a conversion. + -- Allowed conversions are: + -- FIXME: to write. + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; + + -- Get the address of LVALUE. + -- ATYPE must be a type access whose designated type is the type of LVALUE. + -- FIXME: what about arrays. + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; + + -- Same as New_Address but without any restriction. + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode; + + -- Get the value of an Lvalue. + function New_Value (Lvalue : O_Lnode) return O_Enode; + function New_Obj_Value (Obj : O_Dnode) return O_Enode; + + -- Get an lvalue from a declaration. + function New_Obj (Obj : O_Dnode) return O_Lnode; + + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. + function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; + + -- Declare a type. + -- This simply gives a name to a type. + procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode); + + --------------------- + -- Declarations. -- + --------------------- + + -- Filename of the next declaration. + procedure New_Debug_Filename_Decl (Filename : String); + + -- Line number of the next declaration. + procedure New_Debug_Line_Decl (Line : Natural); + + -- Add a comment in the declarative region. + procedure New_Debug_Comment_Decl (Comment : String); + + -- Declare a constant. + -- This simply gives a name to a constant value or aggregate. + -- A constant cannot be modified and its storage cannot be local. + -- ATYPE must be constrained. + procedure New_Const_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode); + + -- Set the value of a non-external constant or variable. + procedure Start_Init_Value (Decl : in out O_Dnode); + procedure Finish_Init_Value (Decl : in out O_Dnode; Val : O_Cnode); + + -- Create a variable declaration. + -- A variable can be local only inside a function. + -- ATYPE must be constrained. + procedure New_Var_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode); + + -- Start a subprogram declaration. + -- Note: nested subprograms are allowed, ie o_storage_local subprograms can + -- be declared inside a subprograms. It is not allowed to declare + -- o_storage_external subprograms inside a subprograms. + -- Return type and interfaces cannot be a composite type. + procedure Start_Function_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode); + -- For a subprogram without return value. + procedure Start_Procedure_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage); + + -- Add an interface declaration to INTERFACES. + procedure New_Interface_Decl + (Interfaces : in out O_Inter_List; + Res : out O_Dnode; + Ident : O_Ident; + Atype : O_Tnode); + -- Finish the function declaration, get the node and a statement list. + procedure Finish_Subprogram_Decl + (Interfaces : in out O_Inter_List; Res : out O_Dnode); + -- Start a subprogram body. + -- Note: the declaration may have an external storage, in this case it + -- becomes public. + procedure Start_Subprogram_Body (Func : O_Dnode); + -- Finish a subprogram body. + procedure Finish_Subprogram_Body; + + + ------------------- + -- Statements. -- + ------------------- + + -- Add a line number as a statement. + procedure New_Debug_Line_Stmt (Line : Natural); + + -- Add a comment as a statement. + procedure New_Debug_Comment_Stmt (Comment : String); + + -- Start a declarative region. + procedure Start_Declare_Stmt; + procedure Finish_Declare_Stmt; + + -- Create a function call or a procedure call. + procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode); + procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode); + function New_Function_Call (Assocs : O_Assoc_List) return O_Enode; + procedure New_Procedure_Call (Assocs : in out O_Assoc_List); + + -- Assign VALUE to TARGET, type must be the same or compatible. + -- FIXME: what about slice assignment? + procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode); + + -- Exit from the subprogram and return VALUE. + procedure New_Return_Stmt (Value : O_Enode); + -- Exit from the subprogram, which doesn't return value. + procedure New_Return_Stmt; + + -- Build an IF statement. + procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode); + procedure New_Else_Stmt (Block : in out O_If_Block); + procedure Finish_If_Stmt (Block : in out O_If_Block); + + -- Create a infinite loop statement. + procedure Start_Loop_Stmt (Label : out O_Snode); + procedure Finish_Loop_Stmt (Label : in out O_Snode); + + -- Exit from a loop stmt or from a for stmt. + procedure New_Exit_Stmt (L : O_Snode); + -- Go to the start of a loop stmt or of a for stmt. + -- Loops/Fors between L and the current points are exited. + procedure New_Next_Stmt (L : O_Snode); + + -- Case statement. + -- VALUE is the selector and must be a discrete type. + procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode); + -- A choice branch is composed of expr, range or default choices. + -- A choice branch is enclosed between a Start_Choice and a Finish_Choice. + -- The statements are after the finish_choice. + procedure Start_Choice (Block : in out O_Case_Block); + procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode); + procedure New_Range_Choice (Block : in out O_Case_Block; + Low, High : O_Cnode); + procedure New_Default_Choice (Block : in out O_Case_Block); + procedure Finish_Choice (Block : in out O_Case_Block); + procedure Finish_Case_Stmt (Block : in out O_Case_Block); + +-- End of common part +private + pragma Convention (C, O_Storage); + + -- No support for nested subprograms in LLVM. + Has_Nested_Subprograms : constant Boolean := False; + + type TypeRef is access Opaque_Type; + pragma Convention (C, TypeRef); + + type BasicBlockRef is access Opaque_Type; + pragma Convention (C, BasicBlockRef); + + Null_BasicBlockRef : constant BasicBlockRef := null; + + type ValueRef is access Opaque_Type; + pragma Convention (C, ValueRef); + + Null_ValueRef : constant ValueRef := null; + + type O_Tnode is access Opaque_Type; + pragma Convention (C, O_Tnode); + + O_Tnode_Null : constant O_Tnode := null; + + type O_Inter; + type O_Inter_Acc is access O_Inter; + type O_Inter is record + Ival : ValueRef; + Ident : O_Ident; + Itype : O_Tnode; + Next : O_Inter_Acc; + end record; + pragma Convention (C, O_Inter); + + type O_Dnode is access Opaque_Type; + pragma Convention (C, O_Dnode); + + 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 := null; + + type OF_Kind is (OF_None, OF_Record, OF_Union); + pragma Convention (C, OF_Kind); + + type O_Fnode is access Opaque_Type; + pragma Convention (C, O_Fnode); + + O_Fnode_Null : constant O_Fnode := 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; + -- Note: this record is always passed by reference. + pragma Convention (C, O_Cnode); + + 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; + pragma Convention (C_Pass_By_Copy, O_Enode); + + 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; + -- Note: this record is always passed by reference. + pragma Convention (C, O_Lnode); + + O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + + type O_Gnode is record + Ref : ValueRef; + Ltype : O_Tnode; + end record; + pragma Convention (C_Pass_By_Copy, O_Gnode); + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + + type O_Snode is record + -- First BB in the loop body. + Bb_Entry : BasicBlockRef; + + -- BB after the loop. + Bb_Exit : BasicBlockRef; + end record; + pragma Convention (C, O_Snode); + + 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; + pragma Convention (C, O_Inter_List); + + type O_Element; + type O_Element_Acc is access O_Element; + pragma Convention (C, O_Element_Acc); + + 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; + pragma Convention (C, O_Element); + + -- 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; + pragma Convention (C, O_Element_List); + + type ValueRefArray_Acc is access Opaque_Type; + pragma Convention (C, ValueRefArray_Acc); + + 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; + pragma Convention (C, O_Record_Aggr_List); + + 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; + pragma Convention (C, O_Array_Aggr_List); + + type O_Assoc_List is record + Subprg : O_Dnode; + Idx : unsigned; + Vals : ValueRefArray_Acc; + end record; + pragma Convention (C, O_Assoc_List); + + 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. + Choices : O_Choice_Array_Acc; + end record; + pragma Convention (C, O_Case_Block); + + 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; + pragma Convention (C, O_If_Block); + + -- function Get_LLVM_Type (Atype : O_Tnode) return TypeRef; + + pragma Import (C, New_Dyadic_Op); + pragma Import (C, New_Monadic_Op); + pragma Import (C, New_Compare_Op); + + pragma Import (C, New_Convert_Ov); + pragma Import (C, New_Alloca); + + pragma Import (C, New_Signed_Literal); + pragma Import (C, New_Unsigned_Literal); + pragma Import (C, New_Float_Literal); + pragma Import (C, New_Null_Access); + + pragma Import (C, Start_Record_Type); + pragma Import (C, New_Record_Field); + pragma Import (C, Finish_Record_Type); + pragma Import (C, New_Uncomplete_Record_Type); + pragma Import (C, Start_Uncomplete_Record_Type); + + pragma Import (C, Start_Union_Type); + pragma Import (C, New_Union_Field); + pragma Import (C, Finish_Union_Type); + + pragma Import (C, New_Unsigned_Type); + pragma Import (C, New_Signed_Type); + pragma Import (C, New_Float_Type); + + pragma Import (C, New_Access_Type); + pragma Import (C, Finish_Access_Type); + + pragma Import (C, New_Array_Type); + pragma Import (C, New_Constrained_Array_Type); + + pragma Import (C, New_Boolean_Type); + pragma Import (C, Start_Enum_Type); + pragma Import (C, New_Enum_Literal); + pragma Import (C, Finish_Enum_Type); + + pragma Import (C, Start_Record_Aggr); + pragma Import (C, New_Record_Aggr_El); + pragma Import (C, Finish_Record_Aggr); + pragma Import (C, Start_Array_Aggr); + pragma Import (C, New_Array_Aggr_El); + pragma Import (C, Finish_Array_Aggr); + pragma Import (C, New_Union_Aggr); + pragma Import (C, New_Default_Value); + + pragma Import (C, New_Indexed_Element); + pragma Import (C, New_Slice); + pragma Import (C, New_Selected_Element); + pragma Import (C, New_Access_Element); + + pragma Import (C, New_Sizeof); + pragma Import (C, New_Alignof); + pragma Import (C, New_Offsetof); + + pragma Import (C, New_Address); + pragma Import (C, New_Global_Address); + pragma Import (C, New_Unchecked_Address); + pragma Import (C, New_Global_Unchecked_Address); + pragma Import (C, New_Subprogram_Address); + + pragma Import (C, New_Lit); + pragma Import (C, New_Obj); + pragma Import (C, New_Obj_Value); + pragma Import (C, New_Global); + pragma Import (C, New_Global_Selected_Element); + pragma Import (C, New_Value); + + pragma Import (C, New_Type_Decl); + pragma Import (C, New_Debug_Line_Decl); + pragma Import (C, New_Const_Decl); + pragma Import (C, New_Var_Decl); + + pragma Import (C, Start_Init_Value); + pragma Import (C, Finish_Init_Value); + + pragma Import (C, Start_Function_Decl); + pragma Import (C, Start_Procedure_Decl); + pragma Import (C, New_Interface_Decl); + pragma Import (C, Finish_Subprogram_Decl); + + pragma Import (C, Start_Subprogram_Body); + pragma Import (C, Finish_Subprogram_Body); + + pragma Import (C, New_Debug_Line_Stmt); + pragma Import (C, Start_Declare_Stmt); + pragma Import (C, Finish_Declare_Stmt); + pragma Import (C, Start_Association); + pragma Import (C, New_Association); + pragma Import (C, New_Function_Call); + pragma Import (C, New_Procedure_Call); + + pragma Import (C, New_Assign_Stmt); + + pragma Import (C, Start_If_Stmt); + pragma Import (C, New_Else_Stmt); + pragma Import (C, Finish_If_Stmt); + + pragma Import (C, New_Return_Stmt); + pragma Import_Procedure (New_Return_Stmt, + "new_func_return_stmt", (O_Enode)); + pragma Import_Procedure (New_Return_Stmt, + "new_proc_return_stmt", null); + + pragma Import (C, Start_Loop_Stmt); + pragma Import (C, Finish_Loop_Stmt); + pragma Import (C, New_Exit_Stmt); + pragma Import (C, New_Next_Stmt); + + pragma Import (C, Start_Case_Stmt); + pragma Import (C, Start_Choice); + pragma Import (C, New_Expr_Choice); + pragma Import (C, New_Range_Choice); + pragma Import (C, New_Default_Choice); + pragma Import (C, Finish_Choice); + pragma Import (C, Finish_Case_Stmt); +end Ortho_LLVM; diff --git a/src/ortho/llvm6/ortho_llvm.private.ads b/src/ortho/llvm6/ortho_llvm.private.ads new file mode 100644 index 000000000..6a4c80b98 --- /dev/null +++ b/src/ortho/llvm6/ortho_llvm.private.ads @@ -0,0 +1,440 @@ +-- 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; +with Interfaces; use Interfaces; +with Interfaces.C; use Interfaces.C; +with Ortho_Ident; use Ortho_Ident; + +-- Interface to create nodes. +package Ortho_LLVM is + procedure Init (Filename : String; Filename_Length : Natural); + pragma Import (C, Init, "ortho_llvm_init"); + + type Opaque_Type is null record; + + procedure Set_Optimization_Level (Level : Natural); + pragma Import (C, Set_Optimization_Level); + + procedure Set_Dump_LLVM (Flag : Natural); + pragma Import (C, Set_Dump_LLVM); + + procedure Set_Verify_LLVM (Flag : Natural); + pragma Import (C, Set_Verify_LLVM); + + procedure Set_PIC_Flag (Flag : Natural); + pragma Import (C, Set_PIC_Flag); + + procedure Generate_Object (Filename : System.Address); + pragma Import (C, Generate_Object); + procedure Generate_Assembly (Filename : System.Address); + pragma Import (C, Generate_Assembly); + procedure Generate_Llvm (Filename : System.Address); + pragma Import (C, Generate_Llvm); + procedure Generate_Bitcode (Filename : System.Address); + pragma Import (C, Generate_Bitcode); + + -- 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 + pragma Convention (C, O_Storage); + + -- No support for nested subprograms in LLVM. + Has_Nested_Subprograms : constant Boolean := False; + + type TypeRef is access Opaque_Type; + pragma Convention (C, TypeRef); + + type BasicBlockRef is access Opaque_Type; + pragma Convention (C, BasicBlockRef); + + Null_BasicBlockRef : constant BasicBlockRef := null; + + type ValueRef is access Opaque_Type; + pragma Convention (C, ValueRef); + + Null_ValueRef : constant ValueRef := null; + + type O_Tnode is access Opaque_Type; + pragma Convention (C, O_Tnode); + + O_Tnode_Null : constant O_Tnode := null; + + type O_Inter; + type O_Inter_Acc is access O_Inter; + type O_Inter is record + Ival : ValueRef; + Ident : O_Ident; + Itype : O_Tnode; + Next : O_Inter_Acc; + end record; + pragma Convention (C, O_Inter); + + type O_Dnode is access Opaque_Type; + pragma Convention (C, O_Dnode); + + 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 := null; + + type OF_Kind is (OF_None, OF_Record, OF_Union); + pragma Convention (C, OF_Kind); + + type O_Fnode is access Opaque_Type; + pragma Convention (C, O_Fnode); + + O_Fnode_Null : constant O_Fnode := 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; + -- Note: this record is always passed by reference. + pragma Convention (C, O_Cnode); + + 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; + pragma Convention (C_Pass_By_Copy, O_Enode); + + 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; + -- Note: this record is always passed by reference. + pragma Convention (C, O_Lnode); + + O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + + type O_Gnode is record + Ref : ValueRef; + Ltype : O_Tnode; + end record; + pragma Convention (C_Pass_By_Copy, O_Gnode); + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + + type O_Snode is record + -- First BB in the loop body. + Bb_Entry : BasicBlockRef; + + -- BB after the loop. + Bb_Exit : BasicBlockRef; + end record; + pragma Convention (C, O_Snode); + + 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; + pragma Convention (C, O_Inter_List); + + type O_Element; + type O_Element_Acc is access O_Element; + pragma Convention (C, O_Element_Acc); + + 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; + pragma Convention (C, O_Element); + + -- 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; + pragma Convention (C, O_Element_List); + + type ValueRefArray_Acc is access Opaque_Type; + pragma Convention (C, ValueRefArray_Acc); + + 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; + pragma Convention (C, O_Record_Aggr_List); + + 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; + pragma Convention (C, O_Array_Aggr_List); + + type O_Assoc_List is record + Subprg : O_Dnode; + Idx : unsigned; + Vals : ValueRefArray_Acc; + end record; + pragma Convention (C, O_Assoc_List); + + 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. + Choices : O_Choice_Array_Acc; + end record; + pragma Convention (C, O_Case_Block); + + 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; + pragma Convention (C, O_If_Block); + + -- function Get_LLVM_Type (Atype : O_Tnode) return TypeRef; + + pragma Import (C, New_Dyadic_Op); + pragma Import (C, New_Monadic_Op); + pragma Import (C, New_Compare_Op); + + pragma Import (C, New_Convert_Ov); + pragma Import (C, New_Alloca); + + pragma Import (C, New_Signed_Literal); + pragma Import (C, New_Unsigned_Literal); + pragma Import (C, New_Float_Literal); + pragma Import (C, New_Null_Access); + + pragma Import (C, Start_Record_Type); + pragma Import (C, New_Record_Field); + pragma Import (C, Finish_Record_Type); + pragma Import (C, New_Uncomplete_Record_Type); + pragma Import (C, Start_Uncomplete_Record_Type); + + pragma Import (C, Start_Union_Type); + pragma Import (C, New_Union_Field); + pragma Import (C, Finish_Union_Type); + + pragma Import (C, New_Unsigned_Type); + pragma Import (C, New_Signed_Type); + pragma Import (C, New_Float_Type); + + pragma Import (C, New_Access_Type); + pragma Import (C, Finish_Access_Type); + + pragma Import (C, New_Array_Type); + pragma Import (C, New_Constrained_Array_Type); + + pragma Import (C, New_Boolean_Type); + pragma Import (C, Start_Enum_Type); + pragma Import (C, New_Enum_Literal); + pragma Import (C, Finish_Enum_Type); + + pragma Import (C, Start_Record_Aggr); + pragma Import (C, New_Record_Aggr_El); + pragma Import (C, Finish_Record_Aggr); + pragma Import (C, Start_Array_Aggr); + pragma Import (C, New_Array_Aggr_El); + pragma Import (C, Finish_Array_Aggr); + pragma Import (C, New_Union_Aggr); + pragma Import (C, New_Default_Value); + + pragma Import (C, New_Indexed_Element); + pragma Import (C, New_Slice); + pragma Import (C, New_Selected_Element); + pragma Import (C, New_Access_Element); + + pragma Import (C, New_Sizeof); + pragma Import (C, New_Alignof); + pragma Import (C, New_Offsetof); + + pragma Import (C, New_Address); + pragma Import (C, New_Global_Address); + pragma Import (C, New_Unchecked_Address); + pragma Import (C, New_Global_Unchecked_Address); + pragma Import (C, New_Subprogram_Address); + + pragma Import (C, New_Lit); + pragma Import (C, New_Obj); + pragma Import (C, New_Obj_Value); + pragma Import (C, New_Global); + pragma Import (C, New_Global_Selected_Element); + pragma Import (C, New_Value); + + pragma Import (C, New_Type_Decl); + pragma Import (C, New_Debug_Line_Decl); + pragma Import (C, New_Const_Decl); + pragma Import (C, New_Var_Decl); + + pragma Import (C, Start_Init_Value); + pragma Import (C, Finish_Init_Value); + + pragma Import (C, Start_Function_Decl); + pragma Import (C, Start_Procedure_Decl); + pragma Import (C, New_Interface_Decl); + pragma Import (C, Finish_Subprogram_Decl); + + pragma Import (C, Start_Subprogram_Body); + pragma Import (C, Finish_Subprogram_Body); + + pragma Import (C, New_Debug_Line_Stmt); + pragma Import (C, Start_Declare_Stmt); + pragma Import (C, Finish_Declare_Stmt); + pragma Import (C, Start_Association); + pragma Import (C, New_Association); + pragma Import (C, New_Function_Call); + pragma Import (C, New_Procedure_Call); + + pragma Import (C, New_Assign_Stmt); + + pragma Import (C, Start_If_Stmt); + pragma Import (C, New_Else_Stmt); + pragma Import (C, Finish_If_Stmt); + + pragma Import (C, New_Return_Stmt); + pragma Import_Procedure (New_Return_Stmt, + "new_func_return_stmt", (O_Enode)); + pragma Import_Procedure (New_Return_Stmt, + "new_proc_return_stmt", null); + + pragma Import (C, Start_Loop_Stmt); + pragma Import (C, Finish_Loop_Stmt); + pragma Import (C, New_Exit_Stmt); + pragma Import (C, New_Next_Stmt); + + pragma Import (C, Start_Case_Stmt); + pragma Import (C, Start_Choice); + pragma Import (C, New_Expr_Choice); + pragma Import (C, New_Range_Choice); + pragma Import (C, New_Default_Choice); + pragma Import (C, Finish_Choice); + pragma Import (C, Finish_Case_Stmt); +end Ortho_LLVM; diff --git a/src/ortho/llvm6/ortho_nodes.ads b/src/ortho/llvm6/ortho_nodes.ads new file mode 100644 index 000000000..34d1dbbc9 --- /dev/null +++ b/src/ortho/llvm6/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; |