src/compiler/x86-64/cell.lisp

   1 ;;;; various primitive memory access VOPs for the x86 VM
   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 \f
  14 ;;;; data object ref/set stuff
  15
  16 (define-vop (slot)
  17   (:args (object :scs (descriptor-reg)))
  18   (:info name offset lowtag)
  19   (:ignore name)
  20   (:results (result :scs (descriptor-reg any-reg)))
  21   (:generator 1
  22    (loadw result object offset lowtag)))
  23
  24 (define-vop (set-slot)
  25   (:args (object :scs (descriptor-reg))
  26          (value :scs (descriptor-reg any-reg immediate)))
  27   (:temporary (:sc descriptor-reg) temp)
  28   (:info name offset lowtag)
  29  ;(:ignore name)
  30   (:results)
  31   (:generator 1
  32     (progn name) ; ignore it
  33     (generate-set-slot object value temp offset lowtag)))
  34
  35 (defun generate-set-slot (object value temp offset lowtag &optional zeroed)
  36     (if (sc-is value immediate)
  37         (move-immediate (make-ea :qword
  38                                  :base object
  39                                  :disp (- (* offset n-word-bytes)
  40                                           lowtag))
  41                         (encode-value-if-immediate value)
  42                         temp zeroed)
  43         ;; Else, value not immediate.
  44         (storew value object offset lowtag)))
  45
  46 ;; INIT-SLOT has to know about the :COMPACT-INSTANCE-HEADER feature.
  47 (define-vop (init-slot set-slot)
  48   (:info name dx-p offset lowtag)
  49   (:generator 1
  50     (progn name dx-p)
  51     (if (or #!+compact-instance-header
  52             (and (eq name '%make-structure-instance) (eql offset :layout)))
  53         ;; The layout is in the upper half of the header word.
  54         (inst mov
  55               (make-ea :dword :base object :disp (- 4 instance-pointer-lowtag))
  56               (if (sc-is value immediate)
  57                   (make-fixup (tn-value value) :layout)
  58                   (reg-in-size value :dword)))
  59         (generate-set-slot object value temp offset lowtag (not dx-p)))))
  60
  61 (define-vop (compare-and-swap-slot)
  62   (:args (object :scs (descriptor-reg) :to :eval)
  63          (old :scs (descriptor-reg any-reg) :target rax)
  64          (new :scs (descriptor-reg any-reg)))
  65   (:temporary (:sc descriptor-reg :offset rax-offset
  66                    :from (:argument 1) :to :result :target result)
  67               rax)
  68   (:info name offset lowtag)
  69   (:ignore name)
  70   (:results (result :scs (descriptor-reg any-reg)))
  71   (:generator 5
  72      (move rax old)
  73      (inst cmpxchg (make-ea :qword :base object
  74                             :disp (- (* offset n-word-bytes) lowtag))
  75            new :lock)
  76      (move result rax)))
  77 \f
  78 ;;;; symbol hacking VOPs
  79
  80 (define-vop (%set-symbol-global-value cell-set)
  81   (:variant symbol-value-slot other-pointer-lowtag))
  82
  83 (define-vop (fast-symbol-global-value cell-ref)
  84   (:variant symbol-value-slot other-pointer-lowtag)
  85   (:policy :fast)
  86   (:translate sym-global-val))
  87
  88 (define-vop (symbol-global-value)
  89   (:policy :fast-safe)
  90   (:translate sym-global-val)
  91   (:args (object :scs (descriptor-reg) :to (:result 1)))
  92   (:results (value :scs (descriptor-reg any-reg)))
  93   (:vop-var vop)
  94   (:save-p :compute-only)
  95   (:generator 9
  96     (let ((err-lab (generate-error-code vop 'unbound-symbol-error object)))
  97       (loadw value object symbol-value-slot other-pointer-lowtag)
  98       (inst cmp (reg-in-size value :dword) unbound-marker-widetag)
  99       (inst jmp :e err-lab))))
 100
 101 ;; Return the DISP field to use in an EA relative to thread-base-tn
 102 (defun load-time-tls-offset (symbol)
 103   (let ((where (info :variable :wired-tls symbol)))
 104     (cond ((integerp where) where)
 105           (t (make-fixup symbol :symbol-tls-index)))))
 106
 107 (deftransform %compare-and-swap-symbol-value ((symbol old new)
 108                                               ((constant-arg symbol) t t))
 109   (if (eq (info :variable :kind (sb!c::lvar-value symbol)) :global)
 110       `(%cas-symbol-global-value symbol old new)
 111       (sb!c::give-up-ir1-transform)))
 112
 113 (macrolet (;; Logic common to thread-aware SET and CAS. CELL is assigned
 114            ;; to the location that should be accessed to modify SYMBOL's
 115            ;; value either in the TLS or the symbol's value slot as follows:
 116            ;; (1) make it look as if the TLS cell were a symbol by biasing
 117            ;;     upward by other-pointer-lowtag less 1 word.
 118            ;; (2) conditionally make CELL point to the symbol itself
 119            (compute-virtual-symbol ()
 120              `(progn
 121                 (inst mov (reg-in-size cell :dword) (tls-index-of symbol))
 122                 (inst lea cell
 123                       (make-ea :qword :base thread-base-tn :index cell
 124                                :disp (- other-pointer-lowtag
 125                                         (ash symbol-value-slot word-shift))))
 126                 (inst cmp (access-value-slot cell :dword) ; TLS reference
 127                       no-tls-value-marker-widetag)
 128                 (inst cmov :e cell symbol))) ; now possibly get the symbol
 129            (access-wired-tls-val (sym) ; SYM is a symbol
 130              `(make-ea :qword :disp (load-time-tls-offset ,sym)
 131                        :base thread-base-tn))
 132            (access-tls-val (index size)
 133              `(make-ea ,size :base thread-base-tn :index ,index :scale 1))
 134            (access-value-slot (sym &optional (size :qword)) ; SYM is a TN
 135              (ecase size
 136                (:dword `(make-ea-for-object-slot-half
 137                          ,sym symbol-value-slot other-pointer-lowtag))
 138                (:qword `(make-ea-for-object-slot
 139                          ,sym symbol-value-slot other-pointer-lowtag)))))
 140
 141   (define-vop (%compare-and-swap-symbol-value)
 142     (:translate %compare-and-swap-symbol-value)
 143     (:args (symbol :scs (descriptor-reg) :to (:result 0))
 144            (old :scs (descriptor-reg any-reg) :target rax)
 145            (new :scs (descriptor-reg any-reg)))
 146     (:temporary (:sc descriptor-reg :offset rax-offset
 147                  :from (:argument 1) :to (:result 0)) rax)
 148     #!+sb-thread
 149     (:temporary (:sc descriptor-reg :to (:result 0)) cell)
 150     (:results (result :scs (descriptor-reg any-reg)))
 151     (:policy :fast-safe)
 152     (:vop-var vop)
 153     (:generator 15
 154     ;; This code has two pathological cases: NO-TLS-VALUE-MARKER
 155     ;; or UNBOUND-MARKER as NEW: in either case we would end up
 156     ;; doing possible damage with CMPXCHG -- so don't do that!
 157     ;; Even worse: don't supply old=NO-TLS-VALUE with a symbol whose
 158     ;; tls-index=0, because that would succeed, assigning NEW to each
 159     ;; symbol in existence having otherwise no thread-local value.
 160       (let ((unbound (generate-error-code vop 'unbound-symbol-error symbol)))
 161         #!+sb-thread (progn (compute-virtual-symbol)
 162                             (move rax old)
 163                             (inst cmpxchg (access-value-slot cell) new :lock))
 164         #!-sb-thread (progn (move rax old)
 165                             ;; is the :LOCK is necessary?
 166                             (inst cmpxchg (access-value-slot symbol) new :lock))
 167         (inst cmp (reg-in-size rax :dword) unbound-marker-widetag)
 168         (inst jmp :e unbound)
 169         (move result rax))))
 170
 171   (define-vop (%cas-symbol-global-value)
 172     (:translate %cas-symbol-global-value)
 173     (:args (symbol :scs (descriptor-reg immediate) :to (:result 0))
 174            (old :scs (descriptor-reg any-reg) :target rax)
 175            (new :scs (descriptor-reg any-reg)))
 176     (:temporary (:sc descriptor-reg :offset rax-offset
 177                  :from (:argument 1) :to (:result 0)) rax)
 178     (:results (result :scs (descriptor-reg any-reg)))
 179     (:policy :fast-safe)
 180     (:generator 10
 181       (move rax old)
 182       (inst cmpxchg
 183             (if (sc-is symbol immediate)
 184                 (symbol-slot-ea (tn-value symbol) symbol-value-slot)
 185                 (access-value-slot symbol))
 186             new :lock)
 187       (move result rax)))
 188
 189   #!+sb-thread
 190   (progn
 191     ;; TODO: SET could be shorter for any known wired-tls symbol.
 192     (define-vop (set)
 193       (:args (symbol :scs (descriptor-reg))
 194              (value :scs (descriptor-reg any-reg)
 195                     :load-if (or (not (sc-is value immediate))
 196                                  (not (typep (encode-value-if-immediate value)
 197                                              '(or (signed-byte 32) fixup))))))
 198       (:temporary (:sc descriptor-reg) cell)
 199       (:generator 4
 200         ;; Compute the address into which to store. CMOV can only move into
 201         ;; a register, so we can't conditionally move into the TLS and
 202         ;; conditionally move in the opposite flag sense to the symbol.
 203         (compute-virtual-symbol)
 204         (inst mov (access-value-slot cell)
 205               (encode-value-if-immediate value))))
 206
 207     ;; This code is tested by 'codegen.impure.lisp'
 208     (defun emit-symeval (value symbol symbol-reg check-boundp vop)
 209       (let* ((known-symbol-p (sc-is symbol constant immediate))
 210              (known-symbol (and known-symbol-p (tn-value symbol))))
 211         ;; In order from best to worst.
 212         (cond
 213          ((symbol-always-has-tls-value-p known-symbol) ; e.g. *HANDLER-CLUSTERS*
 214           (inst mov value (access-wired-tls-val known-symbol)))
 215          (t
 216           (cond
 217             ((symbol-always-has-tls-index-p known-symbol) ; e.g. CL:*PRINT-BASE*
 218              ;; Known nonzero TLS index, but possibly no per-thread value.
 219              ;; The TLS value and global value can be loaded independently.
 220              (inst mov value (access-wired-tls-val known-symbol))
 221              (when (sc-is symbol constant)
 222                (inst mov symbol-reg symbol))) ; = MOV Rxx, [RIP-N]
 223
 224             (known-symbol-p ; unknown TLS index, possibly 0
 225              (sc-case symbol
 226                (immediate
 227                ;; load the TLS index from the symbol. TODO: use [RIP-n] mode
 228                ;; for immobile code to make it automatically relocatable.
 229                (inst mov (reg-in-size value :dword)
 230                      ;; slot index 1/2 is the high half of the header word.
 231                      (symbol-slot-ea known-symbol 1/2 :dword))
 232                ;; read the TLS value using that index
 233                (inst mov value (access-tls-val value :qword)))
 234                (constant
 235
 236                ;; These reads are inextricably data-dependent
 237                (inst mov symbol-reg symbol) ; = MOV REG, [RIP-N]
 238                (inst mov (reg-in-size value :dword) (tls-index-of symbol-reg))
 239                (inst mov value (access-tls-val value :qword)))))
 240
 241             (t ; SYMBOL-VALUE of a random symbol
 242              (inst mov (reg-in-size symbol-reg :dword) (tls-index-of symbol))
 243              (inst mov value (access-tls-val symbol-reg :qword))
 244              (setq symbol-reg symbol)))
 245
 246           ;; Load the global value if the TLS value didn't exist
 247           (inst cmp (reg-in-size value :dword) no-tls-value-marker-widetag)
 248           (inst cmov :e value
 249                 (if (and known-symbol-p (sc-is symbol immediate))
 250                     (symbol-slot-ea known-symbol symbol-value-slot) ; MOV Rxx, imm32
 251                     (access-value-slot symbol-reg)))))
 252
 253         (when check-boundp
 254           (assemble ()
 255             (inst cmp (reg-in-size value :dword) unbound-marker-widetag)
 256             (let* ((immediatep (sc-is symbol immediate))
 257                    (staticp (and immediatep (static-symbol-p known-symbol)))
 258                    (*location-context* (make-restart-location RETRY value)))
 259               ;; IMMEDIATE sc symbols are not in a register (they are accessed
 260               ;; via absolute address), nor are they present in the code header.
 261               ;; So emit a MOV just before the INT opcode for such symbols,
 262               ;; out of the normal execution path. Most static symbols are
 263               ;; DEFCONSTANTs or DEFGLOBALs, so this case is infrequent.
 264               (inst jmp :e (generate-error-code+
 265                             (if staticp
 266                                 (lambda ()
 267                                   (load-immediate vop symbol symbol-reg)))
 268                             vop 'unbound-symbol-error
 269                             (if (and immediatep (not staticp))
 270                                 symbol
 271                                 symbol-reg))))
 272             RETRY))))
 273
 274   ;; With Symbol-Value, we check that the value isn't the trap object. So
 275   ;; Symbol-Value of NIL is NIL.
 276     (define-vop (symbol-value)
 277       (:translate symeval)
 278       (:policy :fast-safe)
 279       (:args (symbol :scs (descriptor-reg constant immediate) :to (:result 1)))
 280       ;; TODO: use no temp if the symbol is known to be thread-local
 281       ;; (probably IR1 should go SYMBOL-VALUE -> SYMBOL-TLS-VALUE)
 282       (:temporary (:sc descriptor-reg) symbol-reg)
 283       (:results (value :scs (descriptor-reg any-reg)))
 284       (:vop-var vop)
 285       (:save-p :compute-only)
 286       (:variant-vars check-boundp)
 287       (:variant t)
 288       (:generator 9 (emit-symeval value symbol symbol-reg check-boundp vop)))
 289
 290     (define-vop (fast-symbol-value symbol-value)
 291     ;; KLUDGE: not really fast, in fact, because we're going to have to
 292     ;; do a full lookup of the thread-local area anyway.  But half of
 293     ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
 294     ;; unbound", which is used in the implementation of COPY-SYMBOL.  --
 295     ;; CSR, 2003-04-22
 296       (:policy :fast)
 297       (:variant nil)
 298       (:variant-cost 5))
 299
 300     (define-vop (boundp)
 301       (:translate boundp)
 302       (:policy :fast-safe)
 303       (:args (object :scs (descriptor-reg)))
 304       (:conditional :ne)
 305       (:temporary (:sc dword-reg) temp)
 306       (:generator 9
 307         (inst mov temp (tls-index-of object))
 308         (inst mov temp (access-tls-val temp :dword))
 309         (inst cmp temp no-tls-value-marker-widetag)
 310         (inst cmov :e temp (access-value-slot object :dword))
 311         (inst cmp temp unbound-marker-widetag))))
 312
 313 ) ; END OF MACROLET
 314
 315 #!-sb-thread
 316 (progn
 317   (define-vop (symbol-value symbol-global-value)
 318     (:translate symeval))
 319   (define-vop (fast-symbol-value fast-symbol-global-value)
 320     (:translate symeval))
 321   (define-vop (set %set-symbol-global-value))
 322   (define-vop (boundp)
 323     (:translate boundp)
 324     (:policy :fast-safe)
 325     (:args (symbol :scs (descriptor-reg)))
 326     (:conditional :ne)
 327     (:generator 9
 328       (inst cmp (make-ea-for-object-slot-half
 329                  symbol symbol-value-slot other-pointer-lowtag)
 330             unbound-marker-widetag))))
 331
 332 (define-vop (symbol-hash)
 333   (:policy :fast-safe)
 334   (:translate symbol-hash)
 335   (:args (symbol :scs (descriptor-reg)))
 336   (:results (res :scs (any-reg)))
 337   (:result-types positive-fixnum)
 338   (:generator 2
 339     ;; The symbol-hash slot of NIL holds NIL because it is also the
 340     ;; cdr slot, so we have to zero the fixnum tag bit(s) to make sure
 341     ;; it is a fixnum.  The lowtag selection magic that is required to
 342     ;; ensure this is explained in the comment in objdef.lisp
 343     (loadw res symbol symbol-hash-slot other-pointer-lowtag)
 344     (inst and res (lognot fixnum-tag-mask))))
 345 \f
 346 ;;;; fdefinition (FDEFN) objects
 347
 348 (define-vop (fdefn-fun cell-ref)        ; /pfw - alpha
 349   (:variant fdefn-fun-slot other-pointer-lowtag))
 350
 351 (define-vop (safe-fdefn-fun)
 352   (:translate safe-fdefn-fun)
 353   (:policy :fast-safe)
 354   (:args (object :scs (descriptor-reg) :to (:result 1)))
 355   (:results (value :scs (descriptor-reg any-reg)))
 356   (:vop-var vop)
 357   (:save-p :compute-only)
 358   (:generator 10
 359     (loadw value object fdefn-fun-slot other-pointer-lowtag)
 360     ;; byte comparison works because lowtags of function and nil differ
 361     (inst cmp (reg-in-size value :byte) (logand nil-value #xff))
 362     (let* ((*location-context* (make-restart-location RETRY value))
 363            (err-lab (generate-error-code vop 'undefined-fun-error object)))
 364       (inst jmp :e err-lab))
 365     RETRY))
 366
 367 #!-immobile-code
 368 (define-vop (set-fdefn-fun)
 369   (:policy :fast-safe)
 370   (:translate (setf fdefn-fun))
 371   (:args (function :scs (descriptor-reg) :target result)
 372          (fdefn :scs (descriptor-reg)))
 373   (:temporary (:sc unsigned-reg) raw)
 374   (:results (result :scs (descriptor-reg)))
 375   (:generator 38
 376     (inst mov raw (make-fixup 'closure-tramp :assembly-routine))
 377     (inst cmp (make-ea :byte :base function :disp (- fun-pointer-lowtag))
 378           simple-fun-widetag)
 379     (inst cmov :e raw
 380           (make-ea :qword :base function
 381                    :disp (- (* simple-fun-self-slot n-word-bytes) fun-pointer-lowtag)))
 382     (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
 383     (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
 384     (move result function)))
 385
 386 (define-vop (fdefn-makunbound)
 387   (:policy :fast-safe)
 388   (:translate fdefn-makunbound)
 389   (:args (fdefn :scs (descriptor-reg) :target result))
 390   (:results (result :scs (descriptor-reg)))
 391   #!+immobile-code (:temporary (:sc unsigned-reg) temp)
 392   (:generator 38
 393     #!+immobile-code
 394     (let ((tramp (make-fixup 'undefined-tramp :assembly-routine)))
 395      (if sb!c::*code-is-immobile*
 396          (inst lea temp tramp)
 397          (inst mov temp tramp))
 398      ;; Compute displacement from the call site
 399      (inst sub (reg-in-size temp :dword) (reg-in-size fdefn :dword))
 400      (inst sub (reg-in-size temp :dword)
 401            (+ (- other-pointer-lowtag) (ash fdefn-raw-addr-slot word-shift) 5))
 402      ;; Compute the encoding of a "CALL rel32" instruction
 403      (inst shl temp 8)
 404      (inst or (reg-in-size temp :byte) #xE8)
 405      ;; Store
 406      (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
 407      (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag))
 408     #!-immobile-code
 409     (progn
 410      (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
 411      (storew (make-fixup 'undefined-tramp :assembly-routine)
 412              fdefn fdefn-raw-addr-slot other-pointer-lowtag))
 413     (move result fdefn)))
 414 \f
 415 ;;;; binding and unbinding
 416
 417 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
 418 ;;; the symbol on the binding stack and stuff the new value into the
 419 ;;; symbol.
 420 ;;; See the "Chapter 9: Specials" of the SBCL Internals Manual.
 421
 422 #!+sb-thread
 423 (progn
 424 (define-vop (dynbind) ; bind a symbol in a PROGV form
 425   (:args (val :scs (any-reg descriptor-reg))
 426          (symbol :scs (descriptor-reg)))
 427   (:temporary (:sc unsigned-reg :offset rax-offset) tls-index)
 428   (:temporary (:sc unsigned-reg) bsp tmp)
 429   (:vop-var vop)
 430   (:generator 10
 431     (load-binding-stack-pointer bsp)
 432     (inst mov (reg-in-size tls-index :dword) (tls-index-of symbol))
 433     (inst add bsp (* binding-size n-word-bytes))
 434     (store-binding-stack-pointer bsp)
 435     (inst test (reg-in-size tls-index :dword) (reg-in-size tls-index :dword))
 436     (inst jmp :ne TLS-INDEX-VALID)
 437     (inst mov tls-index symbol)
 438     (invoke-asm-routine 'call 'alloc-tls-index vop tmp)
 439     TLS-INDEX-VALID
 440     (inst mov tmp (make-ea :qword :base thread-base-tn :index tls-index))
 441     (storew tmp bsp (- binding-value-slot binding-size))
 442     (storew tls-index bsp (- binding-symbol-slot binding-size))
 443     (inst mov (make-ea :qword :base thread-base-tn :index tls-index) val)))
 444
 445 (define-vop (bind) ; bind a known symbol
 446   (:args (val :scs (any-reg descriptor-reg)))
 447   (:temporary (:sc unsigned-reg) bsp tmp)
 448   (:info symbol)
 449   (:generator 10
 450     (inst mov bsp (* binding-size n-word-bytes))
 451     (inst xadd
 452           (make-ea :qword :base thread-base-tn
 453                    :disp (ash thread-binding-stack-pointer-slot word-shift))
 454           bsp)
 455     (let* ((tls-index (load-time-tls-offset symbol))
 456            (tls-cell (make-ea :qword :base thread-base-tn :disp tls-index)))
 457       ;; Too bad we can't use "XCHG [r12+disp], val" to write the new value
 458       ;; and read the old value in one step. It will violate the constraints
 459       ;; prescribed in the internal documentation on special binding.
 460       (inst mov tmp tls-cell)
 461       (storew tmp bsp binding-value-slot)
 462       ;; Indices are small enough to be written as :DWORDs which avoids
 463       ;; a REX prefix if 'bsp' happens to be any of the low 8 registers.
 464       (inst mov (make-ea :dword :base bsp
 465                          :disp (ash binding-symbol-slot word-shift)) tls-index)
 466       (inst mov tls-cell val)))))
 467
 468 #!-sb-thread
 469 (define-vop (dynbind)
 470   (:args (val :scs (any-reg descriptor-reg))
 471          (symbol :scs (descriptor-reg)))
 472   (:temporary (:sc unsigned-reg) temp bsp)
 473   (:generator 5
 474     (load-symbol-value bsp *binding-stack-pointer*)
 475     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
 476     (inst add bsp (* binding-size n-word-bytes))
 477     (store-symbol-value bsp *binding-stack-pointer*)
 478     (storew temp bsp (- binding-value-slot binding-size))
 479     (storew symbol bsp (- binding-symbol-slot binding-size))
 480     (storew val symbol symbol-value-slot other-pointer-lowtag)))
 481
 482 #!+sb-thread
 483 (define-vop (unbind)
 484   (:temporary (:sc unsigned-reg) temp bsp)
 485   (:temporary (:sc complex-double-reg) zero)
 486   (:info symbols)
 487   (:generator 0
 488     (load-binding-stack-pointer bsp)
 489     (inst xorpd zero zero)
 490     (loop for symbol in symbols
 491           for tls-index = (load-time-tls-offset symbol)
 492           for tls-cell = (make-ea :qword :base thread-base-tn :disp tls-index)
 493           do
 494           (inst sub bsp (* binding-size n-word-bytes))
 495
 496           ;; Load VALUE from stack, then restore it to the TLS area.
 497           (loadw temp bsp binding-value-slot)
 498           (inst mov tls-cell temp)
 499           ;; Zero out the stack.
 500           (inst movapd (make-ea :qword :base bsp) zero))
 501     (store-binding-stack-pointer bsp)))
 502
 503 #!-sb-thread
 504 (define-vop (unbind)
 505   (:temporary (:sc unsigned-reg) symbol value bsp)
 506   (:generator 0
 507     (load-symbol-value bsp *binding-stack-pointer*)
 508     (loadw symbol bsp (- binding-symbol-slot binding-size))
 509     (loadw value bsp (- binding-value-slot binding-size))
 510     (storew value symbol symbol-value-slot other-pointer-lowtag)
 511     (storew 0 bsp (- binding-symbol-slot binding-size))
 512     (storew 0 bsp (- binding-value-slot binding-size))
 513     (inst sub bsp (* binding-size n-word-bytes))
 514     (store-symbol-value bsp *binding-stack-pointer*)))
 515
 516 (define-vop (unbind-to-here)
 517   (:args (where :scs (descriptor-reg any-reg)))
 518   (:temporary (:sc unsigned-reg) symbol value bsp)
 519   (:temporary (:sc complex-double-reg) zero)
 520   (:generator 0
 521     (load-binding-stack-pointer bsp)
 522     (inst cmp where bsp)
 523     (inst jmp :e DONE)
 524     (inst xorpd zero zero)
 525     LOOP
 526     (inst sub bsp (* binding-size n-word-bytes))
 527     ;; on sb-thread symbol is actually a tls-index, and it fits into
 528     ;; 32-bits.
 529     #!+sb-thread
 530     (let ((tls-index (reg-in-size symbol :dword)))
 531       (inst mov tls-index
 532             (make-ea :dword :base bsp :disp (* binding-symbol-slot n-word-bytes)))
 533       (inst test tls-index tls-index))
 534     #!-sb-thread
 535     (progn
 536       (loadw symbol bsp binding-symbol-slot)
 537       (inst test symbol symbol))
 538     (inst jmp :z SKIP)
 539     (loadw value bsp binding-value-slot)
 540     #!-sb-thread
 541     (storew value symbol symbol-value-slot other-pointer-lowtag)
 542     #!+sb-thread
 543     (inst mov (make-ea :qword :base thread-base-tn :index symbol)
 544           value)
 545
 546     SKIP
 547     (inst movapd (make-ea :qword :base bsp) zero)
 548
 549     (inst cmp where bsp)
 550     (inst jmp :ne LOOP)
 551     (store-binding-stack-pointer bsp)
 552
 553     DONE))
 554 \f
 555 ;;;; closure indexing
 556
 557 (define-full-reffer closure-index-ref *
 558   closure-info-offset fun-pointer-lowtag
 559   (any-reg descriptor-reg) * %closure-index-ref)
 560
 561 (define-full-setter set-funcallable-instance-info *
 562   funcallable-instance-info-offset fun-pointer-lowtag
 563   (any-reg descriptor-reg) * %set-funcallable-instance-info)
 564
 565 (define-full-reffer funcallable-instance-info *
 566   funcallable-instance-info-offset fun-pointer-lowtag
 567   (descriptor-reg any-reg) * %funcallable-instance-info)
 568
 569 (define-vop (closure-ref)
 570   (:args (object :scs (descriptor-reg)))
 571   (:results (value :scs (descriptor-reg any-reg)))
 572   (:info offset)
 573   (:generator 4
 574     (loadw value object (+ closure-info-offset offset) fun-pointer-lowtag)))
 575
 576 (define-vop (closure-init)
 577   (:args (object :scs (descriptor-reg))
 578          (value :scs (descriptor-reg any-reg immediate)))
 579   (:temporary (:sc unsigned-reg) temp)
 580   (:info offset)
 581   (:generator 4
 582      (generate-set-slot object value temp
 583                         (+ closure-info-offset offset) fun-pointer-lowtag)))
 584
 585 (define-vop (closure-init-from-fp)
 586   (:args (object :scs (descriptor-reg)))
 587   (:info offset)
 588   (:generator 4
 589     (storew rbp-tn object (+ closure-info-offset offset) fun-pointer-lowtag)))
 590 \f
 591 ;;;; value cell hackery
 592
 593 (define-vop (value-cell-ref cell-ref)
 594   (:variant value-cell-value-slot other-pointer-lowtag))
 595
 596 (define-vop (value-cell-set cell-set)
 597   (:variant value-cell-value-slot other-pointer-lowtag))
 598 \f
 599 ;;;; structure hackery
 600
 601 (define-vop (instance-length)
 602   (:policy :fast-safe)
 603   (:translate %instance-length)
 604   (:args (struct :scs (descriptor-reg)))
 605   (:results (res :scs (unsigned-reg)))
 606   (:result-types positive-fixnum)
 607   (:generator 4
 608     (inst mov (reg-in-size res :word)
 609               (make-ea :word :base struct
 610                        :disp (1+ (- instance-pointer-lowtag))))
 611     (inst movzx (reg-in-size res :dword) (reg-in-size res :word))))
 612
 613 #!+compact-instance-header
 614 (progn
 615  (define-vop (%instance-layout)
 616    (:translate %instance-layout)
 617    (:policy :fast-safe)
 618    (:args (object :scs (descriptor-reg)))
 619    (:results (res :scs (descriptor-reg)))
 620    (:variant-vars lowtag)
 621    (:variant instance-pointer-lowtag)
 622    (:generator 1
 623     (inst mov (reg-in-size res :dword) (make-ea :dword :base object :disp (- 4 lowtag)))))
 624  (define-vop (%set-instance-layout)
 625    (:translate %set-instance-layout)
 626    (:policy :fast-safe)
 627    (:args (object :scs (descriptor-reg))
 628           (value :scs (any-reg descriptor-reg) :target res))
 629    (:results (res :scs (any-reg descriptor-reg)))
 630    (:variant-vars lowtag)
 631    (:variant instance-pointer-lowtag)
 632    (:generator 2
 633     (inst mov (make-ea :dword :base object :disp (- 4 lowtag)) (reg-in-size value :dword))
 634     (move res value)))
 635  (define-vop (%funcallable-instance-layout %instance-layout)
 636    (:translate %funcallable-instance-layout)
 637    (:variant fun-pointer-lowtag))
 638  (define-vop (%set-funcallable-instance-layout %set-instance-layout)
 639    (:translate %set-funcallable-instance-layout)
 640    (:variant fun-pointer-lowtag)))
 641
 642 (define-full-reffer instance-index-ref * instance-slots-offset
 643   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
 644
 645 (define-full-setter instance-index-set * instance-slots-offset
 646   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
 647
 648 (define-full-compare-and-swap %instance-cas instance
 649   instance-slots-offset instance-pointer-lowtag
 650   (any-reg descriptor-reg) * %instance-cas)
 651 (define-full-compare-and-swap %raw-instance-cas/word instance
 652   instance-slots-offset instance-pointer-lowtag
 653   (unsigned-reg) unsigned-num %raw-instance-cas/word)
 654 \f
 655 ;;;; code object frobbing
 656
 657 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
 658   (any-reg descriptor-reg) * code-header-ref)
 659
 660 (define-full-setter code-header-set * 0 other-pointer-lowtag
 661   (any-reg descriptor-reg) * code-header-set)
 662 \f
 663 ;;;; raw instance slot accessors
 664
 665 (flet ((make-ea-for-raw-slot (object index)
 666          (etypecase index
 667            (integer
 668               (make-ea :qword
 669                        :base object
 670                        :disp (+ (* (+ instance-slots-offset index) n-word-bytes)
 671                                 (- instance-pointer-lowtag))))
 672            (tn
 673               (make-ea :qword
 674                        :base object
 675                        :index index
 676                        :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 677                        :disp (+ (* instance-slots-offset n-word-bytes)
 678                                 (- instance-pointer-lowtag)))))))
 679   (macrolet
 680       ((def (suffix result-sc result-type inst &optional (inst/c inst))
 681          `(progn
 682             (define-vop (,(symbolicate "RAW-INSTANCE-REF/" suffix))
 683               (:translate ,(symbolicate "%RAW-INSTANCE-REF/" suffix))
 684               (:policy :fast-safe)
 685               (:args (object :scs (descriptor-reg)) (index :scs (any-reg)))
 686               (:arg-types * tagged-num)
 687               (:results (value :scs (,result-sc)))
 688               (:result-types ,result-type)
 689               (:generator 5
 690                 (inst ,inst value (make-ea-for-raw-slot object index))))
 691             (define-vop (,(symbolicate "RAW-INSTANCE-REF-C/" suffix))
 692               (:translate ,(symbolicate "%RAW-INSTANCE-REF/" suffix))
 693               (:policy :fast-safe)
 694               (:args (object :scs (descriptor-reg)))
 695               ;; Why are we pedantic about the index constraint here
 696               ;; if we're not equally so in the init vop?
 697               (:arg-types * (:constant (load/store-index #.n-word-bytes
 698                                                          #.instance-pointer-lowtag
 699                                                          #.instance-slots-offset)))
 700               (:info index)
 701               (:results (value :scs (,result-sc)))
 702               (:result-types ,result-type)
 703               (:generator 4
 704                 (inst ,inst/c value (make-ea-for-raw-slot object index))))
 705             (define-vop (,(symbolicate "RAW-INSTANCE-SET/" suffix))
 706               (:translate ,(symbolicate "%RAW-INSTANCE-SET/" suffix))
 707               (:policy :fast-safe)
 708               (:args (object :scs (descriptor-reg))
 709                      (index :scs (any-reg))
 710                      (value :scs (,result-sc) :target result))
 711               (:arg-types * tagged-num ,result-type)
 712               (:results (result :scs (,result-sc)))
 713               (:result-types ,result-type)
 714               (:generator 5
 715                 (inst ,inst (make-ea-for-raw-slot object index) value)
 716                 (move result value)))
 717             (define-vop (,(symbolicate "RAW-INSTANCE-SET-C/" suffix))
 718               (:translate ,(symbolicate "%RAW-INSTANCE-SET/" suffix))
 719               (:policy :fast-safe)
 720               (:args (object :scs (descriptor-reg))
 721                      (value :scs (,result-sc) :target result))
 722               (:arg-types * (:constant (load/store-index #.n-word-bytes
 723                                                          #.instance-pointer-lowtag
 724                                                          #.instance-slots-offset))
 725                           ,result-type)
 726               (:info index)
 727               (:results (result :scs (,result-sc)))
 728               (:result-types ,result-type)
 729               (:generator 4
 730                 (inst ,inst/c (make-ea-for-raw-slot object index) value)
 731                 (move result value)))
 732             (define-vop (,(symbolicate "RAW-INSTANCE-INIT/" suffix))
 733               (:args (object :scs (descriptor-reg))
 734                      (value :scs (,result-sc)))
 735               (:arg-types * ,result-type)
 736               (:info index)
 737               (:generator 4
 738                 (inst ,inst/c (make-ea-for-raw-slot object index) value))))))
 739     (def word unsigned-reg unsigned-num mov)
 740     (def signed-word signed-reg signed-num mov)
 741     (def single single-reg single-float movss)
 742     (def double double-reg double-float movsd)
 743     (def complex-single complex-single-reg complex-single-float movq)
 744     (def complex-double complex-double-reg complex-double-float
 745          movupd (if (oddp index) 'movapd 'movupd)))
 746
 747   (define-vop (raw-instance-atomic-incf/word)
 748     (:translate %raw-instance-atomic-incf/word)
 749     (:policy :fast-safe)
 750     (:args (object :scs (descriptor-reg))
 751            (index :scs (any-reg))
 752            (diff :scs (unsigned-reg) :target result))
 753     (:arg-types * tagged-num unsigned-num)
 754     (:results (result :scs (unsigned-reg)))
 755     (:result-types unsigned-num)
 756     (:generator 5
 757       (inst xadd (make-ea-for-raw-slot object index) diff :lock)
 758       (move result diff)))
 759
 760   (define-vop (raw-instance-atomic-incf-c/word)
 761     (:translate %raw-instance-atomic-incf/word)
 762     (:policy :fast-safe)
 763     (:args (object :scs (descriptor-reg))
 764            (diff :scs (unsigned-reg) :target result))
 765     (:arg-types * (:constant (load/store-index #.n-word-bytes
 766                                                #.instance-pointer-lowtag
 767                                                #.instance-slots-offset))
 768                 unsigned-num)
 769     (:info index)
 770     (:results (result :scs (unsigned-reg)))
 771     (:result-types unsigned-num)
 772     (:generator 4
 773       (inst xadd (make-ea-for-raw-slot object index) diff :lock)
 774       (move result diff))))