From ddc2574f128b9df994d73aef1b8d6a24ac215b9b Mon Sep 17 00:00:00 2001 From: James Y Knight Date: Tue, 15 Dec 2009 05:58:47 -0500 Subject: [PATCH] Initial revision. --- Makefile | 20 ++++++++++++ Target.i | 26 +++++++++++++++ cl-llvm.asd | 17 ++++++++++ examples/test.lisp | 81 ++++++++++++++++++++++++++++++++++++++++++++++ examples/test.ll | 30 +++++++++++++++++ llvm-extras.cpp | 27 ++++++++++++++++ src/stuff.lisp | 95 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 296 insertions(+) create mode 100644 Makefile create mode 100644 Target.i create mode 100644 cl-llvm.asd create mode 100644 examples/test.lisp create mode 100644 examples/test.ll create mode 100644 llvm-extras.cpp create mode 100644 src/stuff.lisp diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..05e494f --- /dev/null +++ b/Makefile @@ -0,0 +1,20 @@ +all: cl-llvm.so + +bindings: + swig -cffi -noswig-lisp -outdir src/generated -module core /usr/include/llvm-c/Core.h + swig -cffi -noswig-lisp -outdir src/generated -module analysis /usr/include/llvm-c/Analysis.h + swig -cffi -noswig-lisp -outdir src/generated -module execution-engine /usr/include/llvm-c/ExecutionEngine.h + swig -cffi -noswig-lisp -outdir src/generated -module target Target.i + swig -cffi -noswig-lisp -outdir src/generated -module transforms-scalar /usr/include/llvm-c/Transforms/Scalar.h + +CFLAGS=$(shell llvm-config --cflags) +CXXFLAGS=$(CFLAGS) +LDFLAGS=$(shell llvm-config --ldflags) +LINKER=g++ + +LIBS=-Wl,--whole-archive $(shell llvm-config --libs core jit interpreter native asmparser) -Wl,--no-whole-archive + +llvm-extras.o: llvm-extras.cpp + +cl-llvm.so: llvm-extras.o + $(LINKER) -shared -o $@ $(LDFLAGS) $^ $(LIBS) diff --git a/Target.i b/Target.i new file mode 100644 index 0000000..e300d7e --- /dev/null +++ b/Target.i @@ -0,0 +1,26 @@ + // Target is annoying, handle it manually. :( +%{ +#include "/usr/include/llvm-c/Target.h" +%} + +LLVMTargetDataRef LLVMCreateTargetData(const char *StringRep); + +void LLVMAddTargetData(LLVMTargetDataRef, LLVMPassManagerRef); +char *LLVMCopyStringRepOfTargetData(LLVMTargetDataRef); +LLVMByteOrdering LLVMByteOrder(LLVMTargetDataRef); +unsigned LLVMPointerSize(LLVMTargetDataRef); +LLVMTypeRef LLVMIntPtrType(LLVMTargetDataRef); +unsigned long long LLVMSizeOfTypeInBits(LLVMTargetDataRef, LLVMTypeRef); +unsigned long long LLVMStoreSizeOfType(LLVMTargetDataRef, LLVMTypeRef); +unsigned long long LLVMABISizeOfType(LLVMTargetDataRef, LLVMTypeRef); +unsigned LLVMABIAlignmentOfType(LLVMTargetDataRef, LLVMTypeRef); +unsigned LLVMCallFrameAlignmentOfType(LLVMTargetDataRef, LLVMTypeRef); +unsigned LLVMPreferredAlignmentOfType(LLVMTargetDataRef, LLVMTypeRef); +unsigned LLVMPreferredAlignmentOfGlobal(LLVMTargetDataRef, + LLVMValueRef GlobalVar); +unsigned LLVMElementAtOffset(LLVMTargetDataRef, LLVMTypeRef StructTy, + unsigned long long Offset); +unsigned long long LLVMOffsetOfElement(LLVMTargetDataRef, LLVMTypeRef StructTy, + unsigned Element); +void LLVMInvalidateStructLayout(LLVMTargetDataRef, LLVMTypeRef StructTy); +void LLVMDisposeTargetData(LLVMTargetDataRef); diff --git a/cl-llvm.asd b/cl-llvm.asd new file mode 100644 index 0000000..cd9b03a --- /dev/null +++ b/cl-llvm.asd @@ -0,0 +1,17 @@ +;; -*- Lisp -*- + +(defsystem :cl-llvm + :author "James Knight" + :depends-on (:cffi) + :version "0.1" + :components + ((:module "src" + :serial t + :components ((:file "load-c-lib") + (:module "generated" + :components ((:file "core") + (:file "analysis") + (:file "execution-engine") + (:file "target") + (:file "transforms-scalar"))) + (:file "stuff"))))) diff --git a/examples/test.lisp b/examples/test.lisp new file mode 100644 index 0000000..53ab927 --- /dev/null +++ b/examples/test.lisp @@ -0,0 +1,81 @@ +(require 'cl-llvm) + +;;; HACK! make sigabrt not abort. +(defun sigabrt-handler (signal info context) + (declare (ignore signal info)) + (declare (type system-area-pointer context)) + (sb-sys:with-interrupts + (error "sigabrt at #X~X" + (with-alien ((context (* sb-sys:os-context-t) context)) + (sb-sys:sap-int (sb-vm:context-pc context)))))) +(sb-sys:enable-interrupt sb-posix:sigabrt #'sigabrt-handler) + +;; Make a factorial function! +(defun build-fac-fun () + (let* ((mod *jit-module*)) + ;; Build it + (let* ((fac_args (list (LLVMInt32TypeInContext *llvm-context*))) + (fac (LLVMAddFunction mod "fac" (LLVMFunctionType* (LLVMInt32TypeInContext *llvm-context*) + fac_args 0))) + ;; Create code-builder object; this is reused throughout the rest of the function. + (builder (LLVMCreateBuilderInContext *llvm-context*))) + + ;; Use the c-call calling convention (the default) + (LLVMSetFunctionCallConv fac (cffi:foreign-enum-value 'LLVMCallConv :LLVMCCallConv)) + + ;; Create 4 new basic blocks: entry, iftrue, iffalse, end + (let* ((entry (LLVMAppendBasicBlockInContext *llvm-context* fac "entry")) + (iftrue (LLVMAppendBasicBlockInContext *llvm-context* fac "iftrue")) + (iffalse (LLVMAppendBasicBlockInContext *llvm-context* fac "iffalse")) + (end (LLVMAppendBasicBlock fac "end")) + ;; get 0th function argument + (n (LLVMGetParam fac 0)) + ;; make some extra vars to stick stuff in + res-iftrue res-iffalse) + + ;; Create entry BB + (LLVMPositionBuilderAtEnd builder entry) + (let* ((IfNode (LLVMBuildICmp builder :LLVMIntEQ n + (LLVMConstInt (LLVMInt32TypeInContext *llvm-context*) 0 0) + "n == 0"))) + (LLVMBuildCondBr builder IfNode iftrue iffalse)) + + ;; Create true BB + (LLVMPositionBuilderAtEnd builder iftrue) + (setf res-iftrue (LLVMConstInt (LLVMInt32TypeInContext *llvm-context*) 1 0)) + (LLVMBuildBr builder end) + + ;; Create false BB + (LLVMPositionBuilderAtEnd builder iffalse) + (let* ((n-minus (LLVMBuildSub builder n (LLVMConstInt (LLVMInt32TypeInContext *llvm-context*) 1 0) "n - 1")) + (call-fac (LLVMBuildCall* builder fac (list n-minus) "fac(n - 1)"))) + (setf res-iffalse (LLVMBuildMul builder n call-fac "n * fac(n - 1)"))) + (LLVMBuildBr builder end) + + ;; Create end BB + (LLVMPositionBuilderAtEnd builder end) + (let ((res (LLVMBuildPhi builder (LLVMInt32TypeInContext *llvm-context*) "result"))) + (LLVMAddIncoming* res res-iftrue iftrue) + (LLVMAddIncoming* res res-iffalse iffalse) + (LLVMBuildRet builder res))) + + ;; Verify that module is valid + (when (/= 0 (LLVMVerifyModule mod :LLVMPrintMessageAction (cffi:null-pointer))) + (error "Module didn't verify!")) + + ;; Dump textual description for debugging purposes + (LLVMDumpValue fac) + ;; Run some optimizations + (LLVMRunFunctionPassManager *jit-pass-manager* fac) + (LLVMDumpValue fac) + + ;; Clean up + (LLVMDisposeBuilder builder) + fac))) + +;; Run the code! +(defun run-fun (fun n) + (let ((fun-ptr (LLVMGetPointerToGlobal *jit-execution-engine* fun))) + (cffi:foreign-funcall-pointer fun-ptr () :int64 n :int64))) + + diff --git a/examples/test.ll b/examples/test.ll new file mode 100644 index 0000000..eceaca6 --- /dev/null +++ b/examples/test.ll @@ -0,0 +1,30 @@ +declare {i32, i1} @llvm.sadd.with.overflow.i32(i32 %a, i32 %b) + +define i32 @add(i32, i32) { + %l = and i32 %0, 3 + %l0 = icmp ne i32 %l, 0 + br i1 %l0, label %undef, label %go1 +go1: + %r = and i32 %1, 3 + %r0 = icmp ne i32 %r, 0 + br i1 %r0, label %undef, label %go2 +go2: + %3 = lshr i32 %0, 2 + %4 = lshr i32 %1, 2 + %res = call {i32, i1} @llvm.sadd.with.overflow.i32(i32 %3, i32 %4) + %5 = extractvalue {i32, i1} %res, 0 + %ov = extractvalue {i32, i1} %res, 1 + br i1 %ov, label %undef, label %go3 +go3: + %6 = shl i32 %5, 2 + ret i32 %6 +undef: + unreachable +} + + +define i32 @add3(i32, i32, i32) { + %4 = call i32 @add(i32 %0, i32 %1) + %5 = call i32 @add(i32 %4, i32 %2) + ret i32 %5 +} diff --git a/llvm-extras.cpp b/llvm-extras.cpp new file mode 100644 index 0000000..b04a08b --- /dev/null +++ b/llvm-extras.cpp @@ -0,0 +1,27 @@ +#include +#include +#include +#include +#include + +extern "C" { +// Declare here so the inline definition gets into the lib. Why is +// there an inline function in a binding header anyways. :( +int CLLLVM_LLVMInitializeNativeTarget() { + LLVMInitializeNativeTarget(); +} + +LLVMModuleRef CLLLVM_LLVMModuleProviderGetModule(LLVMModuleProviderRef modprovider) { + return llvm::wrap(llvm::unwrap(modprovider)->getModule()); +} + +LLVMModuleRef CLLLVM_LLVMParseAssemblyString(const char *AsmString, + LLVMModuleRef M, + LLVMContextRef Context) { + class llvm::SMDiagnostic Error; + LLVMModuleRef res = + llvm::wrap(llvm::ParseAssemblyString(AsmString, llvm::unwrap(M), Error, *llvm::unwrap(Context))); + Error.Print("sbcl", llvm::errs()); +} + +} diff --git a/src/stuff.lisp b/src/stuff.lisp new file mode 100644 index 0000000..dee0aaf --- /dev/null +++ b/src/stuff.lisp @@ -0,0 +1,95 @@ +;; Define some wrappers around the low-level C API functions to make them easier to use. + +(defun LLVMFunctionType* (ret params is-var-arg) + (let ((len (length params))) + (cffi:with-foreign-object (array :pointer len) + (loop for param in params + for i from 0 + do + (setf (cffi:mem-aref array :pointer i) param)) + (LLVMFunctionType ret array len is-var-arg)))) + +(defun LLVMBuildCall* (builder fn args name) + (let ((len (length args))) + (cffi:with-foreign-object (array :pointer len) + (loop for arg in args + for i from 0 + do + (setf (cffi:mem-aref array :pointer i) arg)) + (LLVMBuildCall builder fn array len name)))) + +(defun LLVMAddIncoming* (phi-node incoming-val incoming-block) + (cffi:with-foreign-objects ((incoming-vals :pointer) + (incoming-blocks :pointer)) + (setf (cffi:mem-aref incoming-vals :pointer 0) incoming-val) + (setf (cffi:mem-aref incoming-blocks :pointer 0) incoming-block) + (LLVMAddIncoming phi-node incoming-vals incoming-blocks 1))) + +(defun LLVMCreateJITCompiler* (provider opt) + (cffi:with-foreign-objects ((out-engine :pointer) + (out-error-str :pointer)) + (if (= 0 (LLVMCreateJITCompiler out-engine provider opt out-error-str)) + (cffi:mem-ref out-engine :pointer) + (let* ((error-str (cffi:mem-ref out-error-str :pointer)) + (error-str-lisp (cffi:foreign-string-to-lisp error-str))) + (LLVMDisposeMessage error-str) + (error "LLVMCreateJITCompiler: ~s" error-str-lisp))))) + + +(defun LLVMBuildGEP* (builder ptr indices) + (let ((len (length indices))) + (cffi:with-foreign-object (array :pointer len) + (loop for arg in indices + for i from 0 + do + (setf (cffi:mem-aref array :pointer i) arg)) + (LLVMBuildGEP builder ptr array len "")))) + + + + +;; Load up the native codegen. +(cffi:defcfun ("CLLLVM_LLVMInitializeNativeTarget" CLLLVM_LLVMInitializeNativeTarget) :int) +(cffi:defcfun ("CLLLVM_LLVMModuleProviderGetModule" CLLLVM_LLVMModuleProviderGetModule) :pointer + (modprovider :pointer)) +(cffi:defcfun ("CLLLVM_LLVMParseAssemblyString" CLLLVM_LLVMParseAssemblyString) :pointer + (asm-string :string) + (module :pointer) + (context :pointer)) + +(CLLLVM_LLVMInitializeNativeTarget) + +;; A global context. Most of LLVM is only thread-safe within a single "context". There is an +;; internal-to-LLVM C default global context, implicitly used by a number of functions like +;; LLVM*Type (without InContext on the end), but I make a lisp-side global context here for clarity. +;; +;; Delete with LLVMContextDispose when done. +;; +;; ...FIXME...or not. For some reason making a custom context makes things fail to verify, stating +;; that I've mixed contexts. Need to figure out if this is my fault or a bug in LLVM. +;; +;; So just use the standard global context +;; (defvar *llvm-context* (LLVMContextCreate)) +(defvar *llvm-context* (LLVMGetGlobalContext)) + +;; Top-level LLVM module for running the JIT in. Other modules can be made for codegen-to-disk, but +;; only a single module for JIT execution can exist in the process. +(defvar *jit-module* (LLVMModuleCreateWithNameInContext "jit-module" *llvm-context*)) + +;; Module provider...dunno what the purpose of this is, it wraps the module +;; Delete with LLVMDisposeModuleProvider; don't delete the wrapped module +(defvar *jit-module-provider* (LLVMCreateModuleProviderForExistingModule *jit-module*)) + +;; Create the JIT compiler, optimization level 2 (whatever that means). This call fails if you run +;; it twice in a process. (which is why we can have only one module for JIT code) +(defvar *jit-execution-engine* (LLVMCreateJITCompiler* *jit-module-provider* 2)) + +;; Optimization passes. Cleanup with LLVMDisposePassManager. +(defvar *jit-pass-manager* (LLVMCreateFunctionPassManager *jit-module-provider*)) +(let ((pass *jit-pass-manager*)) + (LLVMAddTargetData (LLVMGetExecutionEngineTargetData *jit-execution-engine*) pass) + (LLVMAddConstantPropagationPass pass) + (LLVMAddInstructionCombiningPass pass) + (LLVMAddPromoteMemoryToRegisterPass pass) + (LLVMAddGVNPass pass) + (LLVMAddCFGSimplificationPass pass)) -- 2.11.4.GIT