Initial revision.
authorJames Y Knight <foom@fuhm.net>
Tue, 15 Dec 2009 10:58:47 +0000 (15 05:58 -0500)
committerJames Y Knight <foom@fuhm.net>
Tue, 15 Dec 2009 10:58:47 +0000 (15 05:58 -0500)
Makefile [new file with mode: 0644]
Target.i [new file with mode: 0644]
cl-llvm.asd [new file with mode: 0644]
examples/test.lisp [new file with mode: 0644]
examples/test.ll [new file with mode: 0644]
llvm-extras.cpp [new file with mode: 0644]
src/stuff.lisp [new file with mode: 0644]

diff --git a/Makefile b/Makefile
new file mode 100644 (file)
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 (file)
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 (file)
index 0000000..cd9b03a
--- /dev/null
@@ -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 (file)
index 0000000..53ab927
--- /dev/null
@@ -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 (file)
index 0000000..eceaca6
--- /dev/null
@@ -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 (file)
index 0000000..b04a08b
--- /dev/null
@@ -0,0 +1,27 @@
+#include <llvm-c/Target.h>
+#include <llvm/ModuleProvider.h>
+#include <llvm/Support/SourceMgr.h>
+#include <llvm/Support/raw_ostream.h>
+#include <llvm/Assembly/Parser.h>
+
+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 (file)
index 0000000..dee0aaf
--- /dev/null
@@ -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))