src/compiler/x86-64/macros.lisp

   1 ;;;; a bunch of handy macros for the x86
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 ;;;; instruction-like macros
  15
  16 (defmacro move (dst src)
  17   #!+sb-doc
  18   "Move SRC into DST unless they are location=."
  19   (once-only ((n-dst dst)
  20               (n-src src))
  21     `(unless (location= ,n-dst ,n-src)
  22        (sc-case ,n-dst
  23          (single-reg
  24           (inst movss ,n-dst ,n-src))
  25          (double-reg
  26           (inst movsd ,n-dst ,n-src))
  27          (t
  28           (inst mov ,n-dst ,n-src))))))
  29
  30 (defmacro make-ea-for-object-slot (ptr slot lowtag)
  31   `(make-ea :qword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
  32 (defmacro make-ea-for-object-slot-half (ptr slot lowtag)
  33   `(make-ea :dword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
  34
  35 (defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
  36   `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  37
  38 (defmacro storew (value ptr &optional (slot 0) (lowtag 0))
  39   (once-only ((value value))
  40     `(cond ((and (integerp ,value)
  41                  (not (typep ,value '(signed-byte 32))))
  42             (multiple-value-bind (lo hi) (dwords-for-quad ,value)
  43               (inst mov (make-ea-for-object-slot-half
  44                          ,ptr ,slot ,lowtag) lo)
  45               (inst mov (make-ea-for-object-slot-half
  46                          ,ptr (+ ,slot 1/2) ,lowtag) hi)))
  47            (t
  48             (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))))
  49
  50 (defmacro pushw (ptr &optional (slot 0) (lowtag 0))
  51   `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  52
  53 (defmacro popw (ptr &optional (slot 0) (lowtag 0))
  54   `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  55 \f
  56 ;;;; macros to generate useful values
  57
  58 (defmacro load-symbol (reg symbol)
  59   `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))
  60
  61 (defmacro make-ea-for-symbol-value (symbol)
  62   `(make-ea :qword
  63     :disp (+ nil-value
  64            (static-symbol-offset ',symbol)
  65            (ash symbol-value-slot word-shift)
  66            (- other-pointer-lowtag))))
  67
  68 (defmacro load-symbol-value (reg symbol)
  69   `(inst mov ,reg (make-ea-for-symbol-value ,symbol)))
  70
  71 (defmacro store-symbol-value (reg symbol)
  72   `(inst mov (make-ea-for-symbol-value ,symbol) ,reg))
  73
  74 #!+sb-thread
  75 (defmacro make-ea-for-symbol-tls-index (symbol)
  76   `(make-ea :qword
  77     :disp (+ nil-value
  78            (static-symbol-offset ',symbol)
  79            (ash symbol-tls-index-slot word-shift)
  80            (- other-pointer-lowtag))))
  81
  82 #!+sb-thread
  83 (defmacro load-tl-symbol-value (reg symbol)
  84   `(progn
  85     (inst mov ,reg (make-ea-for-symbol-tls-index ,symbol))
  86     (inst mov ,reg (make-ea :qword :base thread-base-tn :scale 1 :index ,reg))))
  87 #!-sb-thread
  88 (defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))
  89
  90 #!+sb-thread
  91 (defmacro store-tl-symbol-value (reg symbol temp)
  92   `(progn
  93     (inst mov ,temp (make-ea-for-symbol-tls-index ,symbol))
  94     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index ,temp) ,reg)))
  95 #!-sb-thread
  96 (defmacro store-tl-symbol-value (reg symbol temp)
  97   (declare (ignore temp))
  98   `(store-symbol-value ,reg ,symbol))
  99
 100 (defmacro load-binding-stack-pointer (reg)
 101   #!+sb-thread
 102   `(inst mov ,reg (make-ea :qword :base thread-base-tn
 103                    :disp (* 8 thread-binding-stack-pointer-slot)))
 104   #!-sb-thread
 105   `(load-symbol-value ,reg *binding-stack-pointer*))
 106
 107 (defmacro store-binding-stack-pointer (reg)
 108   #!+sb-thread
 109   `(inst mov (make-ea :qword :base thread-base-tn
 110               :disp (* 8 thread-binding-stack-pointer-slot))
 111     ,reg)
 112   #!-sb-thread
 113   `(store-symbol-value ,reg *binding-stack-pointer*))
 114
 115 (defmacro load-type (target source &optional (offset 0))
 116   #!+sb-doc
 117   "Loads the type bits of a pointer into target independent of
 118    byte-ordering issues."
 119   (once-only ((n-target target)
 120               (n-source source)
 121               (n-offset offset))
 122     (ecase *backend-byte-order*
 123       (:little-endian
 124        `(inst mov ,n-target
 125               (make-ea :byte :base ,n-source :disp ,n-offset)))
 126       (:big-endian
 127        `(inst mov ,n-target
 128               (make-ea :byte :base ,n-source
 129                              :disp (+ ,n-offset (1- n-word-bytes))))))))
 130 \f
 131 ;;;; allocation helpers
 132
 133 ;;; All allocation is done by calls to assembler routines that
 134 ;;; eventually invoke the C alloc() function.
 135
 136 ;;; Emit code to allocate an object with a size in bytes given by
 137 ;;; Size. The size may be an integer of a TN. If Inline is a VOP
 138 ;;; node-var then it is used to make an appropriate speed vs size
 139 ;;; decision.
 140
 141 (defun allocation-dynamic-extent (alloc-tn size)
 142   (inst sub rsp-tn size)
 143   ;; see comment in x86/macros.lisp implementation of this
 144   (inst and rsp-tn #.(lognot lowtag-mask))
 145   (aver (not (location= alloc-tn rsp-tn)))
 146   (inst mov alloc-tn rsp-tn)
 147   (values))
 148
 149 ;;; This macro should only be used inside a pseudo-atomic section,
 150 ;;; which should also cover subsequent initialization of the
 151 ;;; object.
 152 (defun allocation-tramp (alloc-tn size &optional ignored)
 153   (declare (ignore ignored))
 154   (inst push size)
 155   (inst lea temp-reg-tn (make-ea :qword
 156                             :disp (make-fixup "alloc_tramp" :foreign)))
 157   (inst call temp-reg-tn)
 158   (inst pop alloc-tn)
 159   (values))
 160
 161 (defun allocation (alloc-tn size &optional ignored dynamic-extent)
 162   (declare (ignore ignored))
 163   (when dynamic-extent
 164     (allocation-dynamic-extent alloc-tn size)
 165     (return-from allocation (values)))
 166   (let ((NOT-INLINE (gen-label))
 167         (DONE (gen-label))
 168         ;; Yuck.
 169         (in-elsewhere (eq *elsewhere* sb!assem::**current-segment**))
 170         ;; thread->alloc_region.free_pointer
 171         (free-pointer
 172          #!+sb-thread
 173          (make-ea :qword
 174                   :base thread-base-tn :scale 1
 175                   :disp (* n-word-bytes thread-alloc-region-slot))
 176          #!-sb-thread
 177          (make-ea :qword
 178                   :scale 1 :disp
 179                   (make-fixup "boxed_region" :foreign)))
 180         ;; thread->alloc_region.end_addr
 181         (end-addr
 182          #!+sb-thread
 183          (make-ea :qword
 184                   :base thread-base-tn :scale 1
 185                   :disp (* n-word-bytes (1+ thread-alloc-region-slot)))
 186          #!-sb-thread
 187          (make-ea :qword
 188                   :scale 1 :disp
 189                   (make-fixup "boxed_region" :foreign 8))))
 190     (cond (in-elsewhere
 191            (allocation-tramp alloc-tn size))
 192           (t
 193            (inst mov temp-reg-tn free-pointer)
 194            (if (tn-p size)
 195                (if (location= alloc-tn size)
 196                    (inst add alloc-tn temp-reg-tn)
 197                    (inst lea alloc-tn
 198                          (make-ea :qword :base temp-reg-tn :index size)))
 199                (inst lea alloc-tn
 200                      (make-ea :qword :base temp-reg-tn :disp size)))
 201            (inst cmp end-addr alloc-tn)
 202            (inst jmp :be NOT-INLINE)
 203            (inst mov free-pointer alloc-tn)
 204            (inst mov alloc-tn temp-reg-tn)
 205            (emit-label DONE)
 206            (assemble (*elsewhere*)
 207              (emit-label NOT-INLINE)
 208              (cond ((numberp size)
 209                     (allocation-tramp alloc-tn size))
 210                    (t
 211                     (inst sub alloc-tn free-pointer)
 212                     (allocation-tramp alloc-tn alloc-tn)))
 213              (inst jmp DONE))
 214            (values)))))
 215
 216 #+nil
 217 (defun allocation (alloc-tn size &optional ignored)
 218   (declare (ignore ignored))
 219   (inst push size)
 220   (inst lea temp-reg-tn (make-ea :qword
 221                             :disp (make-fixup "alloc_tramp" :foreign)))
 222   (inst call temp-reg-tn)
 223   (inst pop alloc-tn)
 224   (values))
 225
 226 ;;; Allocate an other-pointer object of fixed SIZE with a single word
 227 ;;; header having the specified WIDETAG value. The result is placed in
 228 ;;; RESULT-TN.
 229 (defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
 230                                  &body forms)
 231   (unless forms
 232     (bug "empty &body in WITH-FIXED-ALLOCATION"))
 233   (once-only ((result-tn result-tn) (size size))
 234     `(pseudo-atomic
 235       (allocation ,result-tn (pad-data-block ,size) ,inline)
 236       (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
 237               ,result-tn)
 238       (inst lea ,result-tn
 239             (make-ea :qword :base ,result-tn :disp other-pointer-lowtag))
 240       ,@forms)))
 241 \f
 242 ;;;; error code
 243 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 244   (defun emit-error-break (vop kind code values)
 245     (let ((vector (gensym)))
 246       `((progn
 247           #!-darwin (inst int 3)                  ; i386 breakpoint instruction
 248           ;; On Darwin, we need to use #x0b0f instead of int3 in order
 249           ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86
 250           ;; doesn't seem to be reliably firing SIGTRAP
 251           ;; handlers. Hopefully this will be fixed by Apple at a
 252           ;; later date. Do the same on x86-64 as we do on x86 until this gets
 253           ;; sorted out.
 254           #!+darwin (inst word #x0b0f))
 255
 256         ;; The return PC points here; note the location for the debugger.
 257         (let ((vop ,vop))
 258           (when vop
 259                 (note-this-location vop :internal-error)))
 260         (inst byte ,kind)                       ; eg trap_Xyyy
 261         (with-adjustable-vector (,vector)       ; interr arguments
 262           (write-var-integer (error-number-or-lose ',code) ,vector)
 263           ,@(mapcar (lambda (tn)
 264                       `(let ((tn ,tn))
 265                          ;; classic CMU CL comment:
 266                          ;;   zzzzz jrd here. tn-offset is zero for constant
 267                          ;;   tns.
 268                          (write-var-integer (make-sc-offset (sc-number
 269                                                              (tn-sc tn))
 270                                                             (or (tn-offset tn)
 271                                                                 0))
 272                                             ,vector)))
 273                     values)
 274           (inst byte (length ,vector))
 275           (dotimes (i (length ,vector))
 276             (inst byte (aref ,vector i))))))))
 277
 278 (defmacro error-call (vop error-code &rest values)
 279   #!+sb-doc
 280   "Cause an error. ERROR-CODE is the error to cause."
 281   (cons 'progn
 282         (emit-error-break vop error-trap error-code values)))
 283
 284 (defmacro generate-error-code (vop error-code &rest values)
 285   #!+sb-doc
 286   "Generate-Error-Code Error-code Value*
 287   Emit code for an error with the specified Error-Code and context Values."
 288   `(assemble (*elsewhere*)
 289      (let ((start-lab (gen-label)))
 290        (emit-label start-lab)
 291        (error-call ,vop ,error-code ,@values)
 292        start-lab)))
 293
 294 \f
 295 ;;;; PSEUDO-ATOMIC
 296
 297 ;;; This is used to wrap operations which leave untagged memory lying
 298 ;;; around.  It's an operation which the AOP weenies would describe as
 299 ;;; having "cross-cutting concerns", meaning it appears all over the
 300 ;;; place and there's no logical single place to attach documentation.
 301 ;;; grep (mostly in src/runtime) is your friend
 302
 303 ;;; FIXME: THIS NAME IS BACKWARDS!
 304 (defmacro maybe-pseudo-atomic (really-p &body body)
 305   `(if ,really-p
 306        (progn ,@body)
 307        (pseudo-atomic ,@body)))
 308
 309 #!+sb-thread
 310 (defmacro pseudo-atomic (&rest forms)
 311   (with-unique-names (label)
 312     `(let ((,label (gen-label)))
 313       (inst or (make-ea :byte
 314                  :base thread-base-tn
 315                  :disp (* 8 thread-pseudo-atomic-bits-slot))
 316             (fixnumize 1))
 317       ,@forms
 318       (inst xor (make-ea :byte
 319                  :base thread-base-tn
 320                  :disp (* 8 thread-pseudo-atomic-bits-slot))
 321             (fixnumize 1))
 322       (inst jmp :z ,label)
 323       ;; if PAI was set, interrupts were disabled at the same
 324       ;; time using the process signal mask.
 325       (inst break pending-interrupt-trap)
 326       (emit-label ,label))))
 327
 328
 329 #!-sb-thread
 330 (defmacro pseudo-atomic (&rest forms)
 331   (with-unique-names (label)
 332     `(let ((,label (gen-label)))
 333       ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
 334       ;; something. (perhaps SVLB, for static variable low byte)
 335       (inst or (make-ea :byte :disp (+ nil-value
 336                                        (static-symbol-offset
 337                                         '*pseudo-atomic-bits*)
 338                                        (ash symbol-value-slot word-shift)
 339                                        (- other-pointer-lowtag)))
 340             (fixnumize 1))
 341       ,@forms
 342       (inst xor (make-ea :byte :disp (+ nil-value
 343                                         (static-symbol-offset
 344                                          '*pseudo-atomic-bits*)
 345                                         (ash symbol-value-slot word-shift)
 346                                         (- other-pointer-lowtag)))
 347             (fixnumize 1))
 348       (inst jmp :z ,label)
 349       ;; if PAI was set, interrupts were disabled at the same time
 350       ;; using the process signal mask.
 351       (inst break pending-interrupt-trap)
 352       (emit-label ,label))))
 353
 354
 355 \f
 356 ;;;; indexed references
 357
 358 (defmacro define-full-compare-and-swap
 359     (name type offset lowtag scs el-type &optional translate)
 360   `(progn
 361      (define-vop (,name)
 362          ,@(when translate `((:translate ,translate)))
 363        (:policy :fast-safe)
 364        (:args (object :scs (descriptor-reg) :to :eval)
 365               (index :scs (any-reg) :to :result)
 366               (old-value :scs ,scs :target rax)
 367               (new-value :scs ,scs))
 368        (:arg-types ,type tagged-num ,el-type ,el-type)
 369        (:temporary (:sc descriptor-reg :offset rax-offset
 370                         :from (:argument 2) :to :result :target value)  rax)
 371        (:results (value :scs ,scs))
 372        (:result-types ,el-type)
 373        (:generator 5
 374          (move rax old-value)
 375          #!+sb-thread
 376          (inst lock)
 377          (inst cmpxchg (make-ea :qword :base object :index index
 378                                 :disp (- (* ,offset n-word-bytes) ,lowtag))
 379                new-value)
 380          (move value rax)))))
 381
 382 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
 383   `(progn
 384      (define-vop (,name)
 385        ,@(when translate
 386            `((:translate ,translate)))
 387        (:policy :fast-safe)
 388        (:args (object :scs (descriptor-reg))
 389               (index :scs (any-reg)))
 390        (:arg-types ,type tagged-num)
 391        (:results (value :scs ,scs))
 392        (:result-types ,el-type)
 393        (:generator 3                    ; pw was 5
 394          (inst mov value (make-ea :qword :base object :index index
 395                                   :disp (- (* ,offset n-word-bytes)
 396                                            ,lowtag)))))
 397      (define-vop (,(symbolicate name "-C"))
 398        ,@(when translate
 399            `((:translate ,translate)))
 400        (:policy :fast-safe)
 401        (:args (object :scs (descriptor-reg)))
 402        (:info index)
 403        (:arg-types ,type
 404                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 405                                                 ,(eval offset))))
 406        (:results (value :scs ,scs))
 407        (:result-types ,el-type)
 408        (:generator 2                    ; pw was 5
 409          (inst mov value (make-ea :qword :base object
 410                                   :disp (- (* (+ ,offset index) n-word-bytes)
 411                                            ,lowtag)))))))
 412
 413 (defmacro define-full-reffer+offset (name type offset lowtag scs el-type &optional translate)
 414   `(progn
 415      (define-vop (,name)
 416        ,@(when translate
 417            `((:translate ,translate)))
 418        (:policy :fast-safe)
 419        (:args (object :scs (descriptor-reg))
 420               (index :scs (any-reg)))
 421        (:info offset)
 422        (:arg-types ,type tagged-num
 423                    (:constant (constant-displacement other-pointer-lowtag
 424                                                      n-word-bytes vector-data-offset)))
 425        (:results (value :scs ,scs))
 426        (:result-types ,el-type)
 427        (:generator 3                    ; pw was 5
 428          (inst mov value (make-ea :qword :base object :index index
 429                                   :disp (- (* (+ ,offset offset) n-word-bytes)
 430                                            ,lowtag)))))
 431      (define-vop (,(symbolicate name "-C"))
 432        ,@(when translate
 433            `((:translate ,translate)))
 434        (:policy :fast-safe)
 435        (:args (object :scs (descriptor-reg)))
 436        (:info index offset)
 437        (:arg-types ,type
 438                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 439                                                 ,(eval offset)))
 440                    (:constant (constant-displacement other-pointer-lowtag
 441                                                      n-word-bytes vector-data-offset)))
 442        (:results (value :scs ,scs))
 443        (:result-types ,el-type)
 444        (:generator 2                    ; pw was 5
 445          (inst mov value (make-ea :qword :base object
 446                                   :disp (- (* (+ ,offset index offset) n-word-bytes)
 447                                            ,lowtag)))))))
 448
 449 (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
 450   `(progn
 451      (define-vop (,name)
 452        ,@(when translate
 453            `((:translate ,translate)))
 454        (:policy :fast-safe)
 455        (:args (object :scs (descriptor-reg))
 456               (index :scs (any-reg))
 457               (value :scs ,scs :target result))
 458        (:arg-types ,type tagged-num ,el-type)
 459        (:results (result :scs ,scs))
 460        (:result-types ,el-type)
 461        (:generator 4                    ; was 5
 462          (inst mov (make-ea :qword :base object :index index
 463                             :disp (- (* ,offset n-word-bytes) ,lowtag))
 464                value)
 465          (move result value)))
 466      (define-vop (,(symbolicate name "-C"))
 467        ,@(when translate
 468            `((:translate ,translate)))
 469        (:policy :fast-safe)
 470        (:args (object :scs (descriptor-reg))
 471               (value :scs ,scs :target result))
 472        (:info index)
 473        (:arg-types ,type
 474                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 475                                                 ,(eval offset)))
 476                    ,el-type)
 477        (:results (result :scs ,scs))
 478        (:result-types ,el-type)
 479        (:generator 3                    ; was 5
 480          (inst mov (make-ea :qword :base object
 481                             :disp (- (* (+ ,offset index) n-word-bytes)
 482                                      ,lowtag))
 483                value)
 484          (move result value)))))
 485
 486 (defmacro define-full-setter+offset (name type offset lowtag scs el-type &optional translate)
 487   `(progn
 488      (define-vop (,name)
 489        ,@(when translate
 490            `((:translate ,translate)))
 491        (:policy :fast-safe)
 492        (:args (object :scs (descriptor-reg))
 493               (index :scs (any-reg))
 494               (value :scs ,scs :target result))
 495        (:info offset)
 496        (:arg-types ,type tagged-num
 497                    (:constant (constant-displacement other-pointer-lowtag
 498                                                      n-word-bytes
 499                                                      vector-data-offset))
 500                    ,el-type)
 501        (:results (result :scs ,scs))
 502        (:result-types ,el-type)
 503        (:generator 4                    ; was 5
 504          (inst mov (make-ea :qword :base object :index index
 505                             :disp (- (* (+ ,offset offset) n-word-bytes) ,lowtag))
 506                value)
 507          (move result value)))
 508      (define-vop (,(symbolicate name "-C"))
 509        ,@(when translate
 510            `((:translate ,translate)))
 511        (:policy :fast-safe)
 512        (:args (object :scs (descriptor-reg))
 513               (value :scs ,scs :target result))
 514        (:info index offset)
 515        (:arg-types ,type
 516                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 517                                                 ,(eval offset)))
 518                    (:constant (constant-displacement other-pointer-lowtag
 519                                                      n-word-bytes
 520                                                      vector-data-offset))
 521                    ,el-type)
 522        (:results (result :scs ,scs))
 523        (:result-types ,el-type)
 524        (:generator 3                    ; was 5
 525          (inst mov (make-ea :qword :base object
 526                             :disp (- (* (+ ,offset index offset) n-word-bytes)
 527                                      ,lowtag))
 528                value)
 529          (move result value)))))
 530
 531 ;;; helper for alien stuff.
 532 (def!macro with-pinned-objects ((&rest objects) &body body)
 533   "Arrange with the garbage collector that the pages occupied by
 534 OBJECTS will not be moved in memory for the duration of BODY.
 535 Useful for e.g. foreign calls where another thread may trigger
 536 garbage collection"
 537   `(multiple-value-prog1
 538        (progn
 539          ,@(loop for p in objects
 540                  collect `(push-word-on-c-stack
 541                            (int-sap (sb!kernel:get-lisp-obj-address ,p))))
 542          ,@body)
 543      ;; If the body returned normally, we should restore the stack pointer
 544      ;; for the benefit of any following code in the same function.  If
 545      ;; there's a non-local exit in the body, sp is garbage anyway and
 546      ;; will get set appropriately from {a, the} frame pointer before it's
 547      ;; next needed
 548      (pop-words-from-c-stack ,(length objects))))