llvm/llvm.lisp

   1 ;; HACK! make sigabrt not abort.
   2 (cffi:defcfun "undoably_install_low_level_interrupt_handler" :void
   3   (signal :int)
   4   (handler :pointer))
   5
   6 (undoably-install-low-level-interrupt-handler 6 (cffi:null-pointer))
   7
   8 (defun sigabrt-handler (signal info context)
   9   (declare (ignore signal info))
  10   (declare (type system-area-pointer context))
  11   (sb-sys:with-interrupts
  12          (error "sigabrt at #X~X"
  13                 (with-alien ((context (* sb-sys:os-context-t) context))
  14                   (sb-sys:sap-int (sb-vm:context-pc context))))))
  15 (sb-sys:enable-interrupt sb-posix:sigabrt #'sigabrt-handler)
  16
  17
  18
  19 (defun LispObjType ()
  20   (LLVMInt64TypeInContext *llvm-context*))
  21
  22 (defun define-support-fns (mod)
  23   (LLVMAddFunction mod "call_into_lisp"
  24                    (LLVMFunctionType* (LispObjType) (list (LispObjType) (LLVMPointerType (LispObjType) 0) (LLVMInt32TypeInContext *llvm-context*)) 0))
  25 )
  26 ;  (LLVMAddGlobal mod (LLVMFunctionType* (LispObjType) (list (LLVMPointerType (LispObjType) 0)) 0)
  27 ;                 "call_into_lisp"))
  28 ;  (CLLLVM_LLVMParseAssemblyString
  29 ;"declare i64 @call_into_lisp(i64, i64*, i32)
  30 ;"
  31 ;     *jit-module* *llvm-context*))
  32
  33 ;; Do it now!
  34 (define-support-fns *jit-module*)
  35 (LLVMDumpModule *jit-module*)
  36
  37 (defvar *lambda-var-hash*)
  38
  39 (defun llvm-compile (lambda)
  40   (let* ((component (first (sb-c::compile-to-ir1 nil lambda)))
  41          (fun (second (sb-c::component-lambdas component))))
  42     (build-function fun *jit-module-provider*)))
  43
  44 (defun build-function (fun mod-provider)
  45   (let* ((mod (CLLLVM_LLVMModuleProviderGetModule mod-provider))
  46          (n-args (length (sb-c::lambda-vars fun)))
  47          (fun-args (loop for n from 0 below n-args
  48                          collect (LispObjType)))
  49          (llfun (LLVMAddFunction mod "anonymous"
  50                                (LLVMFunctionType*
  51                                 (LispObjType)
  52                                 fun-args
  53                                 0)))
  54          ;; From lambda-var -> llvm var
  55          (*lambda-var-hash* (make-hash-table :test 'eq))
  56 ;         (block-hash (make-hash-table :test 'eq))
  57          (builder (LLVMCreateBuilderInContext *llvm-context*)))
  58     (LLVMSetFunctionCallConv llfun (cffi:foreign-enum-value 'LLVMCallConv :LLVMCCallConv))
  59     (loop for node in (sb-c::lambda-vars fun)
  60           for n from 0
  61           do
  62           (setf (gethash node *lambda-var-hash*) (LLVMGetParam llfun n)))
  63
  64     (let ((block (sb-c::ctran-block (sb-c::node-prev (sb-c::lambda-bind fun)))))
  65       (sb-c::do-blocks (block (sb-c::block-component block) :both)
  66         (setf (sb-c::block-flag block) nil))
  67       (labels ((walk (block)
  68                  (unless (sb-c::block-flag block)
  69                    (setf (sb-c::block-flag block) t)
  70                    (when (sb-c::block-start block)
  71                      (build-block llfun builder block))
  72                    (dolist (block (sb-c::block-succ block))
  73                      (walk block)))))
  74         (walk block)))
  75
  76     (LLVMDumpValue llfun)
  77     llfun))
  78
  79 ;; Run the code!
  80 (defun run-fun (fun a b c)
  81   (let ((fun-ptr (LLVMGetPointerToGlobal *jit-execution-engine* fun)))
  82     (cffi:foreign-funcall-pointer fun-ptr () :int64 a :int64 b :int64 c :int64)))
  83
  84 (defun build-block (llfun builder block)
  85   (format t "block start~%")
  86   (let ((llblock (LLVMAppendBasicBlockInContext *llvm-context* llfun "blockname")))
  87     (LLVMPositionBuilderAtEnd builder llblock)
  88     (do ((ctran (sb-c::block-start block) (sb-c::node-next (sb-c::ctran-next ctran))))
  89         ((not ctran))
  90       (let ((node (sb-c::ctran-next ctran)))
  91         (format t "~s~%" node)
  92         (etypecase node
  93           ;; Don't do anything; this is entirely superfluous.
  94           (sb-c::bind nil)
  95           (sb-c::ref (llvm-convert-ref llfun builder node))
  96           (sb-c::combination (llvm-convert-combination llfun builder node))
  97           (sb-c::creturn (llvm-convert-return llfun builder node)))
  98         ))))
  99
 100 ;;; Convert a REF node. The reference must not be delayed.
 101 (defun llvm-convert-ref (llfun builder node)
 102   (declare (type sb-c::ref node))
 103   (let* ((lvar (sb-c::node-lvar node))
 104          (leaf (sb-c::ref-leaf node)))
 105     (etypecase leaf
 106       (sb-c::lambda-var
 107        (let ((llvm-var (gethash leaf *lambda-var-hash*)))
 108          (if (sb-c::lambda-var-indirect leaf)
 109              FIXME #|(vop value-cell-ref node block tn res)|#
 110              (setf (sb-c::lvar-info lvar) llvm-var))))
 111       (sb-c::constant
 112          FIXME #|(emit-move node block (constant-tn leaf) res)|#)
 113       (sb-c::functional
 114          FIXME #|(ir2-convert-closure node block leaf res)|#)
 115       (sb-c::global-var
 116          FIXME
 117        #|(let ((unsafe (policy node (zerop safety)))
 118              (name (leaf-source-name leaf)))
 119          (ecase (global-var-kind leaf)
 120            ((:special :unknown)
 121             (aver (symbolp name))
 122             (let ((name-tn (emit-constant name)))
 123               (if (or unsafe (info :variable :always-bound name))
 124                   (vop fast-symbol-value node block name-tn res)
 125                   (vop symbol-value node block name-tn res))))
 126            (:global
 127             (aver (symbolp name))
 128             (let ((name-tn (emit-constant name)))
 129               (if (or unsafe (info :variable :always-bound name))
 130                   (vop fast-symbol-global-value node block name-tn res)
 131                   (vop symbol-global-value node block name-tn res))))
 132            (:global-function
 133             (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
 134               (if unsafe
 135                   (vop fdefn-fun node block fdefn-tn res)
 136                   (vop safe-fdefn-fun node block fdefn-tn res))))))|#)
 137          ))
 138   (values))
 139
 140 (defun llvmconstify (type list)
 141   (map 'list (lambda (x) (LLVMConstInt type x 0))
 142        list))
 143
 144 (defun llvm-convert-combination (llfun builder node)
 145   (let* ((lvar (sb-c::node-lvar node))
 146          (arg-count (length (sb-c::combination-args node)))
 147          (arg-count-llc (LLVMConstInt (LLVMInt32TypeInContext *llvm-context*) arg-count 0))
 148          (arg-mem (LLVMBuildArrayAlloca builder (LispObjType)
 149                                       arg-count-llc "CIL-array")))
 150 ;    (setf (sb-c::lvar-info lvar) (sb-c::lvar-info (sb-c::combination-fun node)))
 151 ;    (return-from llvm-convert-combination nil)
 152     (loop for arg in (sb-c::combination-args node)
 153           for n from 0
 154           do
 155           (let ((GEP (LLVMBuildGEP* builder arg-mem (llvmconstify (LLVMInt32TypeInContext *llvm-context*) (list n)))))
 156             (LLVMBuildStore builder (sb-c::lvar-info arg) GEP)))
 157
 158  ; pass array as pointer to first element.
 159     (let* ((arg-mem-ptr (LLVMBuildGEP* builder arg-mem (llvmconstify (LLVMInt32TypeInContext *llvm-context*) (list 0))))
 160            (call-into-lisp (LLVMGetNamedFunction *jit-module* "call_into_lisp"))
 161            (callee (sb-c::lvar-info (sb-c::combination-fun node))))
 162       (when (cffi:pointer-eq (cffi:null-pointer) call-into-lisp)
 163         (error "call-into-lisp not found!"))
 164       (setf (sb-c::lvar-info lvar)
 165             (LLVMBuildCall* builder call-into-lisp (list callee arg-mem-ptr arg-count-llc) "call_into_lisp")))))
 166
 167 (defun llvm-convert-return (llfun builder node)
 168   (LLVMBuildRet builder (sb-c::lvar-info (sb-c::return-result node))))
 169
 170
 171
 172 #|
 173 (defun print-nodes (fun block)
 174   (do ((ctran (block-start block) (node-next (ctran-next ctran))))
 175       ((not ctran))
 176     (let ((node (ctran-next ctran)))
 177       (format t "~3D>~:[    ~;~:*~3D:~] "
 178               (cont-num ctran)
 179               (when (and (valued-node-p node) (node-lvar node))
 180                 (cont-num (node-lvar node))))
 181       (etypecase node
 182         (ref (print-leaf (ref-leaf node)))
 183         (basic-combination
 184            (let ((kind (basic-combination-kind node)))
 185              (format t "~(~A~A ~A~) "
 186                      (if (node-tail-p node) "tail " "")
 187                      kind
 188                      (type-of node))
 189              (print-lvar (basic-combination-fun node))
 190              (dolist (arg (basic-combination-args node))
 191                (if arg
 192                    (print-lvar arg)
 193                    (format t "<none> ")))))
 194         (cset
 195            (write-string "set ")
 196            (print-leaf (set-var node))
 197            (write-char #\space)
 198            (print-lvar (set-value node)))
 199         (cif
 200            (write-string "if ")
 201            (print-lvar (if-test node))
 202            (print-ctran (block-start (if-consequent node)))
 203            (print-ctran (block-start (if-alternative node))))
 204         (bind
 205            (write-string "bind ")
 206            (print-leaf (bind-lambda node))
 207            (when (functional-kind (bind-lambda node))
 208              (format t " ~S ~S" :kind (functional-kind (bind-lambda node)))))
 209         (creturn
 210            (write-string "return ")
 211            (print-lvar (return-result node))
 212            (print-leaf (return-lambda node)))
 213         (entry
 214            (let ((cleanup (entry-cleanup node)))
 215              (case (cleanup-kind cleanup)
 216                ((:dynamic-extent)
 217                   (format t "entry DX~{ v~D~}"
 218                           (mapcar (lambda (lvar-or-cell)
 219                                     (if (consp lvar-or-cell)
 220                                         (cons (car lvar-or-cell)
 221                                               (cont-num (cdr lvar-or-cell)))
 222                                         (cont-num lvar-or-cell)))
 223                                   (cleanup-info cleanup))))
 224                (t
 225                   (format t "entry ~S" (entry-exits node))))))
 226         (exit
 227            (let ((value (exit-value node)))
 228              (cond (value
 229                     (format t "exit ")
 230                     (print-lvar value))
 231                ((exit-entry node)
 232                 (format t "exit <no value>"))
 233                (t
 234                 (format t "exit <degenerate>")))))
 235         (cast
 236            (let ((value (cast-value node)))
 237              (format t "cast v~D ~A[~S -> ~S]" (cont-num value)
 238                      (if (cast-%type-check node) #\+ #\-)
 239                      (cast-type-to-check node)
 240                      (cast-asserted-type node)))))
 241       (pprint-newline :mandatory)))
 242 |#