llvm/llvm.lisp

   1 (eval-when (:compile-toplevel :load-toplevel :execute)
   2   (use-package :llvm))
   3
   4 ;; HACK! make sigabrt not abort.
   5 (cffi:defcfun "undoably_install_low_level_interrupt_handler" :void
   6   (signal :int)
   7   (handler :pointer))
   8
   9 (undoably-install-low-level-interrupt-handler 6 (cffi:null-pointer))
  10
  11 (defun sigabrt-handler (signal info context)
  12   (declare (ignore signal info))
  13   (declare (type system-area-pointer context))
  14   (sb-sys:with-interrupts
  15          (error "sigabrt at #X~X"
  16                 (with-alien ((context (* sb-sys:os-context-t) context))
  17                   (sb-sys:sap-int (sb-vm:context-pc context))))))
  18 (sb-sys:enable-interrupt sb-posix:sigabrt #'sigabrt-handler)
  19
  20 ;; END HACK
  21
  22 (declaim (optimize (debug 3)))
  23
  24 (cffi::defcallback intern :intptr ((name :string) (package :string))
  25   (sb-kernel:get-lisp-obj-address (intern name package)))
  26
  27 (cffi::defcallback symbol-function :intptr ((symbol :intptr))
  28   (sb-kernel:get-lisp-obj-address (symbol-function (sb-kernel:make-lisp-obj symbol))))
  29
  30 (defun LispObjType ()
  31   (LLVMInt64Type))
  32
  33 (defun declare-global-var (mod name type &key value thread-local constant linkage)
  34   (let ((previous-global (LLVMGetNamedGlobal mod name)))
  35     (if (cffi:pointer-eq previous-global (cffi:null-pointer))
  36         (let ((global (LLVMAddGlobal mod type name)))
  37           (when value
  38             (LLVMSetInitializer global (LLVMConstInt type value)))
  39           (when constant
  40             (LLVMSetGlobalConstant global t))
  41           (when thread-local
  42             (LLVMSetThreadLocal global t))
  43           (when linkage
  44             (LLVMSetLinkage global linkage))))))
  45
  46 (defun declare-intrinsic-function (mod name ret-type arg-types &key global-mapping attrs)
  47   (let ((previous-fun (LLVMGetNamedFunction mod name)))
  48     (if (cffi:pointer-eq previous-fun (cffi:null-pointer))
  49         (let ((function (LLVMAddFunction mod name
  50                                          (LLVMFunctionType ret-type arg-types nil))))
  51           (LLVMSetFunctionCallConv function (cffi:foreign-enum-value 'LLVMCallConv :LLVMCCallConv))
  52           (LLVMSetLinkage function :LLVMExternalLinkage)
  53           (assert (LLVMIsDeclaration function))
  54           (when (eql (mismatch "llvm." name) 5) ; name starts with llvm.
  55             (assert (/= 0 (LLVMGetIntrinsicID function))))
  56           (when global-mapping
  57             (LLVMAddGlobalMapping *jit-execution-engine*
  58                                   function
  59                                   global-mapping))
  60           (dolist (attr attrs)
  61             (LLVMAddFunctionAttr function attr))
  62           function)
  63         previous-fun)))
  64
  65 (defun define-support-fns (mod)
  66   (declare-intrinsic-function mod "intern"
  67                               (LispObjType) (list (LLVMPointerType (LLVMInt8Type) 0)
  68                                                   (LLVMPointerType (LLVMInt8Type) 0))
  69                               :global-mapping (cffi::callback intern))
  70   (declare-intrinsic-function mod "symbol-function"
  71                               (LispObjType) (list (LispObjType))
  72                               :global-mapping (cffi::callback symbol-function))
  73   (declare-intrinsic-function mod "llvm.atomic.load.sub.i64.p0i64"
  74                               (LLVMInt64Type)
  75                               (list (LLVMPointerType (LLVMInt64Type) 0) (LLVMInt64Type)))
  76   (declare-global-var mod "SBCL_nil" (LispObjType) :constant t :value (sb-kernel:get-lisp-obj-address nil))
  77   ;; Comes from SBCL runtime.
  78 ;  (declare-global-var mod "current_thread" (LispObjType) :thread-local t :linkage :LLVMExternalLinkage)
  79   (declare-global-var mod "specials" (LLVMInt32Type) :constant t)
  80   (declare-intrinsic-function mod "call_into_lisp"
  81     (LispObjType)
  82     (list (LispObjType) (LLVMPointerType (LispObjType) 0) (LLVMInt32Type)))
  83   (declare-intrinsic-function mod "alloc"
  84     (LLVMPointerType (LispObjType) 0)
  85     (list (LLVMInt64Type)))
  86   (declare-intrinsic-function mod "do_pending_interrupt"
  87     (LLVMVoidType)
  88     nil)
  89   (declare-intrinsic-function mod "pthread_getspecific"
  90     (LLVMPointerType (LLVMInt8Type) 0)
  91     (list (LLVMInt32Type)) :attrs '(:LLVMNoUnwindAttribute :LLVMReadNoneAttribute))
  92   ;; Function to get the TLS data. It's a bit odd that SBCL isn't using native TLS on
  93   ;; linux, but lucky for me, because LLVM's JIT doesn't support TLS yet.
  94   (CLLLVM_LLVMParseAssemblyString
  95 "define i64* @get_thread_data() nounwind readnone {
  96 start:
  97   %0 = load i32* @specials
  98   %1 = call i8* @pthread_getspecific(i32 %0)
  99   %2 = bitcast i8* %1 to i64*
 100   ret i64* %2
 101 }
 102 " *jit-module* *llvm-context*))
 103
 104
 105
 106
 107 ;  (LLVMAddGlobal mod (LLVMFunctionType (LispObjType) (list (LLVMPointerType (LispObjType) 0)) nil)
 108 ;                 "call_into_lisp"))
 109 ;  (CLLLVM_LLVMParseAssemblyString
 110 ;"declare i64 @call_into_lisp(i64, i64*, i32)
 111 ;"
 112 ;     *jit-module* *llvm-context*))
 113
 114 ;; Do it now!
 115 (define-support-fns *jit-module*)
 116 ;;(LLVMDumpModule *jit-module*)
 117
 118
 119 ;; Function to dump the IR1 nodes of a lambda expression, for debugging.
 120 (defun dump-ir1 (lambda)
 121   (let* ((component (first (sb-c::compile-to-ir1 nil lambda)))
 122          (fun (second (sb-c::component-lambdas component))))
 123     (let ((block (sb-c::ctran-block (sb-c::node-prev (sb-c::lambda-bind fun)))))
 124       (sb-c::do-blocks (block (sb-c::block-component block) :both)
 125         (setf (sb-c::block-flag block) nil))
 126       (labels ((walk (block)
 127                  (unless (sb-c::block-flag block)
 128                    (setf (sb-c::block-flag block) t)
 129                    (when (sb-c::block-start block)
 130                      (dump-block block))
 131                    (dolist (block (sb-c::block-succ block))
 132                      (walk block)))))
 133         (walk block)))))
 134
 135 (defun dump-block (block)
 136   (format t "block start ~s~%" (sb-c::block-number block))
 137   (do ((ctran (sb-c::block-start block) (sb-c::node-next (sb-c::ctran-next ctran))))
 138       ((not ctran))
 139     (let ((node (sb-c::ctran-next ctran)))
 140       (format t "~s~%" node))))
 141
 142 ;; Now, the actual LLVM compiler
 143
 144 ;;;; Utility functions...
 145
 146 (declaim (special *current-llfun* *current-builder*))
 147
 148 (defmacro build (name &rest args)
 149   (assert (symbolp name))
 150   `(,(intern (concatenate 'string (symbol-name 'LLVMBuild) (symbol-name name)))
 151      *current-builder*
 152      ,@args))
 153
 154 (defmacro build-after (block)
 155   `(LLVMPositionBuilderAtEnd *current-builder* ,block))
 156
 157 (defmacro with-builder ((builder) &body body)
 158   `(let ((*current-builder* ,builder))
 159      ,@body))
 160
 161 (defmacro with-load-time-builder (() &body body)
 162   `(progn ,@body))
 163 ;  `(with-builder *ltv-builder*)
 164 ;     ,@body)
 165
 166 (defmacro with-fresh-builder (() &body body)
 167   (let ((builder-v (gensym "BUILDER")))
 168     `(let ((,builder-v))
 169        (unwind-protect
 170             (progn (setf ,builder-v (LLVMCreateBuilder))
 171                    (let ((*current-builder* ,builder-v))
 172                      (progn ,@body)))
 173          (when ,builder-v (LLVMDisposeBuilder ,builder-v))))))
 174
 175 (defmacro with-entry-block-builder (() &body body)
 176   (let ((entry-block-v (gensym "entry-block")))
 177     `(with-fresh-builder ()
 178        (let ((,entry-block-v (LLVMGetEntryBasicBlock *current-llfun*)))
 179          (build-after ,entry-block-v)
 180          (progn ,@body)))))
 181
 182 (defun raw-ptr-to-lispobj (ptr lowtag)
 183   (build add
 184    (build ptrtoint ptr (LispObjType))
 185    (LLVMConstInt (LLVMInt64Type) lowtag)))
 186
 187 (defun raw-int-to-lispobj (ptr)
 188   (build call (LLVMGetNamedFunction *jit-module* "%raw-int-to-lispobj") (list ptr)))
 189
 190 (defun fixnumize (val)
 191   (LLVMConstInt (LispObjType) (* val 8))) ;; FIXME: hardcoded 8...
 192
 193 (defun LLVMBuildGEP* (builder ptr indices &optional (name ""))
 194   (let ((type (LLVMInt32Type)))
 195     (LLVMBuildGEP builder ptr
 196                   (map 'list (lambda (x) (LLVMConstInt type x)) indices)
 197                   name)))
 198
 199 (defun llvm-ensure-block (block)
 200   "Ensure that the given IR1 block has an associated LLVM block, and return it."
 201   (let ((existing-block (sb-c::block-info block)))
 202     (if existing-block
 203         existing-block
 204         (setf (sb-c::block-info block)
 205               (LLVMAppendBasicBlock *current-llfun* (format nil "block~d" (sb-c::block-number block)))))))
 206
 207
 208 (defun build-alloca-in-entry (name)
 209   (with-entry-block-builder ()
 210     (build alloca (LispObjType) name)))
 211
 212 (defun llvm-ensure-lvar (lvar)
 213   "Ensure that the given IR1 lvar object has an associated LLVM variable, and return it"
 214   (let ((existing-lvar (sb-c::lvar-info lvar)))
 215     (if existing-lvar
 216         existing-lvar
 217         (setf (sb-c::lvar-info lvar) (build-alloca-in-entry "lvar")))))
 218
 219 (eval-when (:compile-toplevel :load-toplevel :execute)
 220   (defvar *llvm-primitives* (make-hash-table :test 'eq)))
 221
 222 (defmacro def-llvmfun (name args &body body)
 223   "Sorta the equivalent of defining a VOP.
 224
 225    NAME should be a known function, and your function will be called to do something
 226    special instead of building a full call to that function."
 227   (let ((real-name (intern (concatenate 'string "LLVMFUN-" (symbol-name name)))))
 228     `(progn
 229        (defun ,real-name
 230            ,args
 231          ,@body)
 232        (setf (gethash ',name *llvm-primitives*) (function ,real-name)))))
 233
 234
 235
 236
 237
 238
 239
 240 ;; Main entry point
 241 (defun llvm-compile (lambda)
 242   (let* ((component (first (sb-c::compile-to-ir1 nil lambda)))
 243          (fun (second (sb-c::component-lambdas component))))
 244     (build-function fun *jit-module-provider*)))
 245
 246 (defun unboxed-type (ctype)
 247   (cond
 248     ((sb-c::csubtypep ctype '(unsigned-byte 64))
 249      :unsigned-int)
 250     ((sb-c::csubtypep ctype '(signed-byte 64))
 251      :signed-int)
 252     ;; FIXME: floats, whatever else we want unboxed...
 253     (t nil)))
 254
 255
 256 (defun build-function (fun mod-provider)
 257   (let* ((mod (CLLLVM_LLVMModuleProviderGetModule mod-provider))
 258          (n-args (length (sb-c::lambda-vars fun)))
 259          (fun-args (loop for n from 0 below n-args
 260                          collect (LispObjType)))
 261          (*current-llfun* (LLVMAddFunction mod "anonymous"
 262                                (LLVMFunctionType
 263                                 (LispObjType)
 264                                 fun-args
 265                                 nil)))
 266          (setup-block (LLVMAppendBasicBlock *current-llfun* "setup")))
 267     (LLVMSetFunctionCallConv *current-llfun* (cffi:foreign-enum-value 'LLVMCallConv :LLVMCCallConv))
 268
 269     (with-entry-block-builder ()
 270       (loop for node in (sb-c::lambda-vars fun)
 271             for n from 0
 272             do
 273             (let ((param-alloca (build alloca (LispObjType) "arg")))
 274               (setf (sb-c::leaf-info node) param-alloca)
 275               (build store (LLVMGetParam *current-llfun* n) param-alloca))))
 276
 277     (with-fresh-builder ()
 278       (let ((block (sb-c::ctran-block (sb-c::node-prev (sb-c::lambda-bind fun)))))
 279         (sb-c::do-blocks (block (sb-c::block-component block) :both)
 280           (setf (sb-c::block-flag block) nil))
 281         (labels ((walk (block)
 282                    (unless (sb-c::block-flag block)
 283                      (setf (sb-c::block-flag block) t)
 284                      (when (sb-c::block-start block)
 285                        (build-block block))
 286                      (dolist (block (sb-c::block-succ block))
 287                        (walk block)))))
 288           (walk block))
 289         (build-after setup-block)
 290         (build br (llvm-ensure-block block))))
 291
 292     (format t ";; Pre-optimization:~%")
 293     (LLVMDumpValue *current-llfun*)
 294     ;;(LLVMVerifyModule mod :LLVMPrintMessageAction (cffi:null-pointer))
 295     (LLVMRunFunctionPassManager *jit-pass-manager* *current-llfun*)
 296     (format t ";; Post-optimization:~%")
 297     (LLVMDumpValue *current-llfun*)
 298
 299     *current-llfun*))
 300
 301 ;; Call this to run your function!
 302 (defmacro run-fun (fun &rest args)
 303   (let ((ffp-args (loop for arg in args
 304                         collect :intptr
 305                         collect `(sb-kernel:get-lisp-obj-address ,arg)))
 306         (fun-ptr-v (gensym "fun-ptr")))
 307   `(let ((,fun-ptr-v (LLVMGetPointerToGlobal *jit-execution-engine* ,fun)))
 308      (sb-kernel:make-lisp-obj (cffi:foreign-funcall-pointer ,fun-ptr-v () ,@ffp-args :intptr)))))
 309
 310
 311 ;;;; Creating blocks...
 312
 313 (defun finish-block (block)
 314   (let* ((last (sb-c::block-last block))
 315          (succ (sb-c::block-succ block)))
 316     (unless (or (sb-c::if-p last) (sb-c::return-p last))
 317       (assert (sb-c::singleton-p succ))
 318       (let ((target (first succ)))
 319         (cond ((eq target (sb-c::component-tail (sb-c::block-component block)))
 320                ;; component-tail isn't a real block, so don't emit a branch to it.
 321                ;; This location ought to be unreachable, so tell LLVM that.
 322                (build unreachable))
 323               (t (build br (llvm-ensure-block target))))))))
 324
 325 (defun build-block (block)
 326   (format t "block start ~s~%" (sb-c::block-number block))
 327   (let ((llblock (llvm-ensure-block block)))
 328     (build-after llblock)
 329     (do ((ctran (sb-c::block-start block) (sb-c::node-next (sb-c::ctran-next ctran))))
 330         ((not ctran))
 331       (let ((node (sb-c::ctran-next ctran)))
 332         (format t "~s~%" node)
 333         (etypecase node
 334           (sb-c::bind nil) ;; Don't do anything; bind is entirely superfluous.
 335           (sb-c::ref (llvm-convert-ref node))
 336           (sb-c::combination
 337              (let ((fun (sb-c::ref-leaf (sb-c::lvar-uses (sb-c::combination-fun node)))))
 338                (if (and (sb-c::functional-p fun) (eq (sb-c::functional-kind fun) :let)) ; mv-let, assignment?
 339                    (llvm-convert-let node)
 340                    ;; FIXME: this data should really go into the fun-info struct from
 341                    ;; combination-fun-info, but for expediency, use a separate datastore
 342                    ;; for the moment.
 343                    (let ((llvm-primitive (gethash (sb-c::leaf-source-name fun) *llvm-primitives*)))
 344                      (if llvm-primitive
 345                          (llvm-convert-knowncombination node llvm-primitive)
 346                          (llvm-convert-combination node))))))
 347           (sb-c::creturn (llvm-convert-return node))
 348           (sb-c::cif (llvm-convert-if node))
 349           (sb-c::cset (llvm-convert-set node)))
 350         ))
 351     (finish-block block)))
 352
 353
 354
 355 ;;;; "Constant" support (many lisp constants are not LLVM constants, but rather set at load-time)
 356
 357 (defun llvm-emit-global-string (mod str)
 358   (let* ((ll-str (LLVMConstString str nil))
 359          (global (LLVMAddGlobal mod (LLVMTypeOf ll-str) ".str")))
 360       (LLVMSetInitializer global ll-str)
 361       (LLVMSetGlobalConstant global t)
 362       global))
 363
 364 (defun llvm-emit-symbol-ref (value)
 365   ;; Check for staticly-defined symbols?
 366   (let* ((global (LLVMAddGlobal *jit-module* (LispObjType) (symbol-name value)))
 367          (name-var (llvm-emit-global-string *jit-module* (symbol-name value)))
 368          (package-name-var (llvm-emit-global-string *jit-module* (package-name (symbol-package value)))))
 369     (LLVMSetLinkage global :LLVMInternalLinkage)
 370     (LLVMSetInitializer global (LLVMConstInt (LispObjType) 0))
 371     (with-load-time-builder ()
 372       (build store
 373              (build call (LLVMGetNamedFunction *jit-module* "intern")
 374                     (list
 375                      (build GEP* name-var (list 0 0))
 376                      (build GEP* package-name-var (list 0 0)))
 377                     "intern")
 378              global))
 379     (build load global "symbol")))
 380
 381 (defun llvm-emit-symbol-function (value)
 382   (build call (LLVMGetNamedFunction *jit-module* "symbol-function")
 383          (list
 384           (llvm-emit-symbol-ref value))
 385          "symbol-function"))
 386
 387 (defun llvm-emit-constant (leaf)
 388   (let ((value (sb-c::constant-value leaf)))
 389     (etypecase value
 390       ;; most-*-fixnum should have sb!xc: prefix
 391       ((integer #.most-negative-fixnum #.most-positive-fixnum)
 392          (fixnumize value))
 393       (integer
 394          (FIXME-BIGINT))
 395       (character
 396          (FIXME-CHARACTER))
 397       (symbol
 398          (llvm-emit-symbol-ref value))
 399 #|
 400       (when (static-symbol-p value)
 401         (sc-number-or-lose 'immediate)))
 402     (single-float
 403      (sc-number-or-lose
 404       (if (eql value 0f0) 'fp-single-zero 'fp-single-immediate)))
 405     (double-float
 406      (sc-number-or-lose
 407       (if (eql value 0d0) 'fp-double-zero 'fp-double-immediate)))
 408     ((complex single-float)
 409      (sc-number-or-lose
 410       (if (eql value #c(0f0 0f0))
 411           'fp-complex-single-zero
 412           'fp-complex-single-immediate)))
 413     ((complex double-float)
 414      (sc-number-or-lose
 415       (if (eql value #c(0d0 0d0))
 416           'fp-complex-double-zero
 417           'fp-complex-double-immediate)))|#)
 418     ))
 419
 420 ;;; Convert a REF node. The reference must not be delayed.
 421 (defun llvm-convert-ref (node)
 422   (declare (type sb-c::ref node))
 423   (let* ((lvar (sb-c::node-lvar node))
 424          (leaf (sb-c::ref-leaf node))
 425          (val
 426           (etypecase leaf
 427             (sb-c::lambda-var
 428                (let ((llvm-var (sb-c::leaf-info leaf)))
 429                  (if (sb-c::lambda-var-indirect leaf)
 430                      (FIXME) #|(vop value-cell-ref node block tn res)|#
 431                      (build load llvm-var))))
 432             (sb-c::constant
 433                (or (sb-c::leaf-info leaf)
 434                    (llvm-emit-constant leaf)))
 435             (sb-c::functional
 436                (if (eq (sb-c::functional-kind leaf) :let) ;; mv-let, assignment?
 437                    (return-from llvm-convert-ref nil) ;; Don't need to store anything
 438                    (FIXME-FUNCTIONAL) #|(ir2-convert-closure node block leaf res)|#))
 439             (sb-c::global-var
 440                (let ((unsafe (sb-c::policy node (zerop safety)))
 441                      (name (sb-c::leaf-source-name leaf)))
 442                  (declare (ignore unsafe))
 443                  (ecase (sb-c::global-var-kind leaf)
 444                    ((:special :unknown)
 445                       #|(aver (symbolp name))
 446                       (let ((name-tn (emit-constant name)))
 447                       (if (or unsafe (info :variable :always-bound name))
 448                       (vop fast-symbol-value node block name-tn res)
 449                       (vop symbol-value node block name-tn res)))|#)
 450                    (:global
 451                       #|(aver (symbolp name))
 452                       (let ((name-tn (emit-constant name)))
 453                       (if (or unsafe (info :variable :always-bound name))
 454                       (vop fast-symbol-global-value node block name-tn res)
 455                       (vop symbol-global-value node block name-tn res)))|#)
 456                    (:global-function
 457                       (llvm-emit-symbol-function name)
 458                       #|(let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
 459                       (if unsafe
 460                       (vop fdefn-fun node block fdefn-tn res)
 461                       (vop safe-fdefn-fun node block fdefn-tn res)))|#))))
 462             )))
 463     (assert val)
 464 ;    (print (CLLLVM_LLVMDumpValueToString val))
 465 ;    (print (CLLLVM_LLVMDumpTypeToString (LLVMTypeOf (llvm-ensure-lvar lvar))))
 466     ;; Store the value into the lvar.
 467     (build store val (llvm-ensure-lvar lvar)))
 468   (values))
 469
 470 (defun llvm-convert-let (node)
 471   (let ((fun (sb-c::ref-leaf (sb-c::lvar-uses (sb-c::combination-fun node))))
 472         (args (sb-c::combination-args node)))
 473     (loop for node in (sb-c::lambda-vars fun)
 474           for arg in args
 475           for n from 0
 476           do
 477           (let ((param-alloca (build-alloca-in-entry "let-var")))
 478             (setf (sb-c::leaf-info node) param-alloca)
 479             (build store (build load (llvm-ensure-lvar arg))
 480                    param-alloca)))))
 481
 482 (defun llvm-convert-combination (node)
 483   (let* ((lvar (sb-c::node-lvar node))
 484          (arg-count (length (sb-c::combination-args node)))
 485          (arg-count-llc (LLVMConstInt (LLVMInt32Type) arg-count))
 486          (arg-mem (build arrayalloca (LispObjType)
 487                          arg-count-llc "CIL-array")))
 488     (loop for arg in (sb-c::combination-args node)
 489           for n from 0
 490           do
 491           (let ((GEP (build GEP* arg-mem (list n))))
 492             (build store (build load (llvm-ensure-lvar arg)) GEP)))
 493
 494     ;; BuildGEP is because we pass array as pointer to first element.
 495     (let* ((arg-mem-ptr (build GEP* arg-mem (list 0)))
 496            (call-into-lisp (LLVMGetNamedFunction *jit-module* "call_into_lisp"))
 497            (callee (build load (llvm-ensure-lvar (sb-c::combination-fun node)))))
 498       (when (cffi:pointer-eq (cffi:null-pointer) call-into-lisp)
 499         (error "call-into-lisp not found!"))
 500       (let ((call-result (build call call-into-lisp
 501                                 (list callee arg-mem-ptr arg-count-llc) "call_into_lisp")))
 502         ;; When lvar exists, store result of call into it.
 503         (when lvar
 504           (build store call-result (llvm-ensure-lvar lvar)))))))
 505
 506 (defun llvm-convert-knowncombination (node primitivefun)
 507   (let* ((lvar (sb-c::node-lvar node))
 508          (args (sb-c::combination-args node))
 509          (call-result (funcall primitivefun args)))
 510     ;; When lvar exists, store result of call into it.
 511     (when lvar
 512       (build store call-result (llvm-ensure-lvar lvar)))))
 513
 514 (defun llvm-convert-return (node)
 515 ;  (print (sb-c::lvar-info (sb-c::return-result node)))
 516   (build ret (build load (llvm-ensure-lvar (sb-c::return-result node)))))
 517
 518
 519 (defun llvm-convert-if (node)
 520   (build condbr
 521          (build icmp :LLVMIntNE
 522                 (build load (llvm-ensure-lvar (sb-c::if-test node)))
 523                 (build load (LLVMGetNamedGlobal *jit-module* "SBCL_nil"))
 524                 "nil?")
 525          (llvm-ensure-block (sb-c::if-consequent node))
 526          (llvm-ensure-block (sb-c::if-alternative node))))
 527
 528 (defun llvm-convert-set (node)
 529   (let* ((lvar (sb-c::node-lvar node))
 530          (leaf (sb-c::set-var node))
 531          (val (sb-c::set-value node))
 532          (ll-val (build load (llvm-ensure-lvar val))))
 533     (etypecase leaf
 534       (sb-c::lambda-var
 535          (let ((llvm-var (sb-c::leaf-info leaf)))
 536            (if (sb-c::lambda-var-indirect leaf)
 537                (FIXME) #|(vop value-cell-ref node block tn res)|#
 538                (build store  ll-val llvm-var))))
 539       (sb-c::global-var
 540          (ecase (sb-c::global-var-kind leaf)
 541            ((:special)
 542               (FIXME) #|(vop set node block (emit-constant (leaf-source-name leaf)) val)|#)
 543            ((:global)
 544               (FIXME) #|(vop %set-symbol-global-value node
 545               block (emit-constant (leaf-source-name leaf)) val)|#))))
 546
 547     ;; *Also* store into the target lvar of this set node.
 548     (when lvar
 549       (build store ll-val (llvm-ensure-lvar lvar)))))
 550
 551
 552 (defun get-current-thread ()
 553   (build call
 554          (LLVMGetNamedFunction *jit-module* "get_thread_data")
 555          nil))
 556
 557 ;; FIXME: I don't really want or need to use an atomic op here, what I *really* need is an
 558 ;; atomic-against-signal operation.  On X86/X86-64, the tomic sub will by accident do the
 559 ;; right thing, since it emits a single load/modify/write LOCK SUB instruction. It might
 560 ;; make sense to just emit asm here, but LLVM's JIT doesn't deal with inline
 561 ;; target-specific asm at the moment, unfortunately.
 562 (defmacro with-pseudo-atomic (() &body body)
 563   ;; Store 2 (arbitrary-but-not-1 value) in *pseudo-atomic-bits*
 564   `(progn
 565      (build store
 566             (fixnumize 2)
 567             (build GEP* (get-current-thread) (list sb-vm::thread-pseudo-atomic-bits-slot)))
 568      ;; Run p-a-protected body
 569      (prog1
 570          (progn ,@body)
 571        ;; Check if we were interrupted
 572        (let ((orig-value (build call
 573                                 (LLVMGetNamedFunction *jit-module* "llvm.atomic.load.sub.i64.p0i64")
 574                                 (list (build GEP* (get-current-thread) (list sb-vm::thread-pseudo-atomic-bits-slot))
 575                                       (fixnumize 2))))
 576              (do-interruption-block (LLVMAppendBasicBlock *current-llfun* "do-interruption"))
 577              (continue-block (LLVMAppendBasicBlock *current-llfun* "continue")))
 578          ;; If we were, ...
 579          (build condbr (build icmp :LLVMIntEQ orig-value (fixnumize 2))
 580                 do-interruption-block
 581                 continue-block)
 582          ;; Handle the interruption.
 583          (build-after do-interruption-block)
 584          (build call (LLVMGetNamedFunction *jit-module* "do_pending_interrupt") nil)
 585          (build br continue-block)
 586
 587          ;; Otherwise, or then, ...continue with the rest of our code
 588          (build-after continue-block)))))
 589
 590
 591 (def-llvmfun cons (args)
 592   (assert (= (length args) 2))
 593   (with-pseudo-atomic ()
 594     (let* ((new-mem (build call (LLVMGetNamedFunction *jit-module* "alloc")
 595                            (list (LLVMConstInt (LLVMInt64Type) 16))))) ;; FIXME: 16 is number of bytes for a cons
 596       (build store (build load (llvm-ensure-lvar (first args)))
 597              (build GEP* new-mem (list sb-vm::cons-car-slot)))
 598       (build store (build load (llvm-ensure-lvar (second args)))
 599              (build GEP* new-mem (list sb-vm::cons-cdr-slot)))
 600       ;; returns:
 601       (raw-ptr-to-lispobj new-mem sb-vm::list-pointer-lowtag))))
 602