3 ;;; HACK! make sigabrt not abort.
4 ;; (defun sigabrt-handler (signal info context)
5 ;; (declare (ignore signal info))
6 ;; (declare (type system-area-pointer context))
7 ;; (sb-sys:with-interrupts
8 ;; (error "sigabrt at #X~X"
9 ;; (with-alien ((context (* sb-sys:os-context-t) context))
10 ;; (sb-sys:sap-int (sb-vm:context-pc context))))))
11 ;; (sb-sys:enable-interrupt sb-posix:sigabrt #'sigabrt-handler)
13 ;; Make a factorial function!
14 (defun build-fac-fun ()
15 (let* ((mod *jit-module
*))
17 (let* ((fac_args (list (LLVMInt32TypeInContext *llvm-context
*)))
18 (fac (LLVMAddFunction mod
"fac" (LLVMFunctionType* (LLVMInt32TypeInContext *llvm-context
*)
20 ;; Create code-builder object; this is reused throughout the rest of the function.
21 (builder (LLVMCreateBuilderInContext *llvm-context
*)))
23 ;; Use the c-call calling convention (the default)
24 (LLVMSetFunctionCallConv fac
(cffi:foreign-enum-value
'LLVMCallConv
:LLVMCCallConv
))
26 ;; Create 4 new basic blocks: entry, iftrue, iffalse, end
27 (let* ((entry (LLVMAppendBasicBlockInContext *llvm-context
* fac
"entry"))
28 (iftrue (LLVMAppendBasicBlockInContext *llvm-context
* fac
"iftrue"))
29 (iffalse (LLVMAppendBasicBlockInContext *llvm-context
* fac
"iffalse"))
30 (end (LLVMAppendBasicBlock fac
"end"))
31 ;; get 0th function argument
32 (n (LLVMGetParam fac
0))
33 ;; make some extra vars to stick stuff in
34 res-iftrue res-iffalse
)
37 (LLVMPositionBuilderAtEnd builder entry
)
38 (let* ((IfNode (LLVMBuildICmp builder
:LLVMIntEQ n
39 (LLVMConstInt (LLVMInt32TypeInContext *llvm-context
*) 0 0)
41 (LLVMBuildCondBr builder IfNode iftrue iffalse
))
44 (LLVMPositionBuilderAtEnd builder iftrue
)
45 (setf res-iftrue
(LLVMConstInt (LLVMInt32TypeInContext *llvm-context
*) 1 0))
46 (LLVMBuildBr builder end
)
49 (LLVMPositionBuilderAtEnd builder iffalse
)
50 (let* ((n-minus (LLVMBuildSub builder n
(LLVMConstInt (LLVMInt32TypeInContext *llvm-context
*) 1 0) "n - 1"))
51 (call-fac (LLVMBuildCall* builder fac
(list n-minus
) "fac(n - 1)")))
52 (setf res-iffalse
(LLVMBuildMul builder n call-fac
"n * fac(n - 1)")))
53 (LLVMBuildBr builder end
)
56 (LLVMPositionBuilderAtEnd builder end
)
57 (let ((res (LLVMBuildPhi builder
(LLVMInt32TypeInContext *llvm-context
*) "result")))
58 (LLVMAddIncoming* res res-iftrue iftrue
)
59 (LLVMAddIncoming* res res-iffalse iffalse
)
60 (LLVMBuildRet builder res
)))
62 ;; Verify that module is valid
63 (when (/= 0 (LLVMVerifyModule mod
:LLVMPrintMessageAction
(cffi:null-pointer
)))
64 (error "Module didn't verify!"))
66 ;; Dump textual description for debugging purposes
68 ;; Run some optimizations
69 (LLVMRunFunctionPassManager *jit-pass-manager
* fac
)
73 (LLVMDisposeBuilder builder
)
76 (defun build-string-fun ()
77 (let* ((mod *jit-module
*))
79 (let* ((fac_args (list (LLVMInt32TypeInContext *llvm-context
*)))
80 (fac (LLVMAddFunction mod
"fac" (LLVMFunctionType* (LLVMInt32TypeInContext *llvm-context
*)
82 ;; Create code-builder object; this is reused throughout the rest of the function.
83 (builder (LLVMCreateBuilderInContext *llvm-context
*)))
85 ;; Use the c-call calling convention (the default)
86 (LLVMSetFunctionCallConv fac
(cffi:foreign-enum-value
'LLVMCallConv
:LLVMCCallConv
))
88 ;; Create 4 new basic blocks: entry, iftrue, iffalse, end
89 (let* ((entry (LLVMAppendBasicBlockInContext *llvm-context
* fac
"entry")))
90 (LLVMPositionBuilderAtEnd builder entry
)
91 (let ((global (LLVMAddGlobal mod
(LLVMArrayType (LLVMInt8Type) 5) ".str")))
92 (LLVMSetInitializer global
(LLVMConstStringInContext *llvm-context
* "asdf" 4 0))
93 (LLVMSetGlobalConstant global
1)
94 (LLVMBuildRet builder
(LLVMBuildGEP* builder global
(list (LLVMConstInt (LLVMInt32Type) 0 0)
95 (LLVMConstInt (LLVMInt32Type) 0 0))))))
97 ;; Dump textual description for debugging purposes
100 ;; Verify that module is valid
101 (when (/= 0 (LLVMVerifyModule mod
:LLVMPrintMessageAction
(cffi:null-pointer
)))
102 (error "Module didn't verify!"))
104 ;; Run some optimizations
105 ; (LLVMRunFunctionPassManager *jit-pass-manager* fac)
106 ; (LLVMDumpValue fac)
109 (LLVMDisposeBuilder builder
)
113 (defun run-fun (fun n
)
114 (let ((fun-ptr (LLVMGetPointerToGlobal *jit-execution-engine
* fun
)))
115 (cffi:foreign-funcall-pointer fun-ptr
() :int64 n
:int64
)))