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