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         (let ((val (tn-value value)))
  34           (move-immediate (make-ea :qword
  35                                    :base object
  36                                    :disp (- (* offset n-word-bytes)
  37                                             lowtag))
  38                           (etypecase val
  39                             (integer
  40                              (fixnumize val))
  41                             (symbol
  42                              (+ nil-value (static-symbol-offset val)))
  43                             (character
  44                              (logior (ash (char-code val) n-widetag-bits)
  45                                      character-widetag)))
  46                           temp))
  47         ;; Else, value not immediate.
  48         (storew value object offset lowtag))))
  49
  50 (define-vop (init-slot set-slot))
  51
  52 (define-vop (compare-and-swap-slot)
  53   (:args (object :scs (descriptor-reg) :to :eval)
  54          (old :scs (descriptor-reg any-reg) :target rax)
  55          (new :scs (descriptor-reg any-reg)))
  56   (:temporary (:sc descriptor-reg :offset rax-offset
  57                    :from (:argument 1) :to :result :target result)
  58               rax)
  59   (:info name offset lowtag)
  60   (:ignore name)
  61   (:results (result :scs (descriptor-reg any-reg)))
  62   (:generator 5
  63      (move rax old)
  64      (inst cmpxchg (make-ea :qword :base object
  65                             :disp (- (* offset n-word-bytes) lowtag))
  66            new :lock)
  67      (move result rax)))
  68 \f
  69 ;;;; symbol hacking VOPs
  70
  71 (define-vop (%compare-and-swap-symbol-value)
  72   (:translate %compare-and-swap-symbol-value)
  73   (:args (symbol :scs (descriptor-reg) :to (:result 1))
  74          (old :scs (descriptor-reg any-reg) :target rax)
  75          (new :scs (descriptor-reg any-reg)))
  76   (:temporary (:sc descriptor-reg :offset rax-offset) rax)
  77   #!+sb-thread
  78   (:temporary (:sc descriptor-reg) tls)
  79   (:results (result :scs (descriptor-reg any-reg)))
  80   (:policy :fast-safe)
  81   (:vop-var vop)
  82   (:generator 15
  83     ;; This code has two pathological cases: NO-TLS-VALUE-MARKER
  84     ;; or UNBOUND-MARKER as NEW: in either case we would end up
  85     ;; doing possible damage with CMPXCHG -- so don't do that!
  86     (let ((unbound (generate-error-code vop 'unbound-symbol-error symbol))
  87           (check (gen-label)))
  88       (move rax old)
  89       #!+sb-thread
  90       (progn
  91         (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
  92         ;; Thread-local area, no LOCK needed.
  93         (inst cmpxchg (make-ea :qword :base thread-base-tn
  94                                :index tls :scale 1)
  95               new)
  96         (inst cmp rax no-tls-value-marker-widetag)
  97         (inst jmp :ne check)
  98         (move rax old))
  99       (inst cmpxchg (make-ea :qword :base symbol
 100                              :disp (- (* symbol-value-slot n-word-bytes)
 101                                       other-pointer-lowtag)
 102                              :scale 1)
 103             new :lock)
 104       (emit-label check)
 105       (move result rax)
 106       (inst cmp result unbound-marker-widetag)
 107       (inst jmp :e unbound))))
 108
 109 (define-vop (%set-symbol-global-value cell-set)
 110   (:variant symbol-value-slot other-pointer-lowtag))
 111
 112 (define-vop (fast-symbol-global-value cell-ref)
 113   (:variant symbol-value-slot other-pointer-lowtag)
 114   (:policy :fast)
 115   (:translate symbol-global-value))
 116
 117 (define-vop (symbol-global-value)
 118   (:policy :fast-safe)
 119   (:translate symbol-global-value)
 120   (:args (object :scs (descriptor-reg) :to (:result 1)))
 121   (:results (value :scs (descriptor-reg any-reg)))
 122   (:vop-var vop)
 123   (:save-p :compute-only)
 124   (:generator 9
 125     (let ((err-lab (generate-error-code vop 'unbound-symbol-error object)))
 126       (loadw value object symbol-value-slot other-pointer-lowtag)
 127       (inst cmp value unbound-marker-widetag)
 128       (inst jmp :e err-lab))))
 129
 130 #!+sb-thread
 131 (progn
 132   (define-vop (set)
 133     (:args (symbol :scs (descriptor-reg))
 134            (value :scs (descriptor-reg any-reg)))
 135     (:temporary (:sc descriptor-reg) tls)
 136     (:generator 4
 137       (let ((global-val (gen-label))
 138             (done (gen-label)))
 139         (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
 140         (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls)
 141               no-tls-value-marker-widetag)
 142         (inst jmp :z global-val)
 143         (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls)
 144               value)
 145         (inst jmp done)
 146         (emit-label global-val)
 147         (storew value symbol symbol-value-slot other-pointer-lowtag)
 148         (emit-label done))))
 149
 150   ;; With Symbol-Value, we check that the value isn't the trap object. So
 151   ;; Symbol-Value of NIL is NIL.
 152   (define-vop (symbol-value)
 153     (:translate symbol-value)
 154     (:policy :fast-safe)
 155     (:args (object :scs (descriptor-reg) :to (:result 1)))
 156     (:results (value :scs (descriptor-reg any-reg)))
 157     (:vop-var vop)
 158     (:save-p :compute-only)
 159     (:generator 9
 160       (let* ((check-unbound-label (gen-label))
 161              (err-lab (generate-error-code vop 'unbound-symbol-error object))
 162              (ret-lab (gen-label)))
 163         (loadw value object symbol-tls-index-slot other-pointer-lowtag)
 164         (inst mov value (make-ea :qword :base thread-base-tn
 165                                  :index value :scale 1))
 166         (inst cmp value no-tls-value-marker-widetag)
 167         (inst jmp :ne check-unbound-label)
 168         (loadw value object symbol-value-slot other-pointer-lowtag)
 169         (emit-label check-unbound-label)
 170         (inst cmp value unbound-marker-widetag)
 171         (inst jmp :e err-lab)
 172         (emit-label ret-lab))))
 173
 174   (define-vop (fast-symbol-value symbol-value)
 175     ;; KLUDGE: not really fast, in fact, because we're going to have to
 176     ;; do a full lookup of the thread-local area anyway.  But half of
 177     ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
 178     ;; unbound", which is used in the implementation of COPY-SYMBOL.  --
 179     ;; CSR, 2003-04-22
 180     (:policy :fast)
 181     (:translate symbol-value)
 182     (:generator 8
 183       (let ((ret-lab (gen-label)))
 184         (loadw value object symbol-tls-index-slot other-pointer-lowtag)
 185         (inst mov value
 186               (make-ea :qword :base thread-base-tn :index value :scale 1))
 187         (inst cmp value no-tls-value-marker-widetag)
 188         (inst jmp :ne ret-lab)
 189         (loadw value object symbol-value-slot other-pointer-lowtag)
 190         (emit-label ret-lab)))))
 191
 192 #!-sb-thread
 193 (progn
 194   (define-vop (symbol-value symbol-global-value)
 195     (:translate symbol-value))
 196   (define-vop (fast-symbol-value fast-symbol-global-value)
 197     (:translate symbol-value))
 198   (define-vop (set %set-symbol-global-value)))
 199
 200 #!+sb-thread
 201 (define-vop (boundp)
 202   (:translate boundp)
 203   (:policy :fast-safe)
 204   (:args (object :scs (descriptor-reg)))
 205   (:conditional :ne)
 206   (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
 207   (:generator 9
 208     (let ((check-unbound-label (gen-label)))
 209       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
 210       (inst mov value
 211             (make-ea :qword :base thread-base-tn :index value :scale 1))
 212       (inst cmp value no-tls-value-marker-widetag)
 213       (inst jmp :ne check-unbound-label)
 214       (loadw value object symbol-value-slot other-pointer-lowtag)
 215       (emit-label check-unbound-label)
 216       (inst cmp value unbound-marker-widetag))))
 217
 218 #!-sb-thread
 219 (define-vop (boundp)
 220   (:translate boundp)
 221   (:policy :fast-safe)
 222   (:args (object :scs (descriptor-reg)))
 223   (:conditional :ne)
 224   (:generator 9
 225     (inst cmp (make-ea-for-object-slot object symbol-value-slot
 226                                        other-pointer-lowtag)
 227           unbound-marker-widetag)))
 228
 229
 230 (define-vop (symbol-hash)
 231   (:policy :fast-safe)
 232   (:translate symbol-hash)
 233   (:args (symbol :scs (descriptor-reg)))
 234   (:results (res :scs (any-reg)))
 235   (:result-types positive-fixnum)
 236   (:generator 2
 237     ;; The symbol-hash slot of NIL holds NIL because it is also the
 238     ;; cdr slot, so we have to strip off the three low bits to make sure
 239     ;; it is a fixnum.  The lowtag selection magic that is required to
 240     ;; ensure this is explained in the comment in objdef.lisp
 241     (loadw res symbol symbol-hash-slot other-pointer-lowtag)
 242     (inst and res (lognot fixnum-tag-mask))))
 243 \f
 244 ;;;; fdefinition (FDEFN) objects
 245
 246 (define-vop (fdefn-fun cell-ref)        ; /pfw - alpha
 247   (:variant fdefn-fun-slot other-pointer-lowtag))
 248
 249 (define-vop (safe-fdefn-fun)
 250   (:args (object :scs (descriptor-reg) :to (:result 1)))
 251   (:results (value :scs (descriptor-reg any-reg)))
 252   (:vop-var vop)
 253   (:save-p :compute-only)
 254   (:generator 10
 255     (loadw value object fdefn-fun-slot other-pointer-lowtag)
 256     (inst cmp value nil-value)
 257     (let ((err-lab (generate-error-code vop 'undefined-fun-error object)))
 258       (inst jmp :e err-lab))))
 259
 260 (define-vop (set-fdefn-fun)
 261   (:policy :fast-safe)
 262   (:translate (setf fdefn-fun))
 263   (:args (function :scs (descriptor-reg) :target result)
 264          (fdefn :scs (descriptor-reg)))
 265   (:temporary (:sc unsigned-reg) raw)
 266   (:temporary (:sc unsigned-reg) type)
 267   (:results (result :scs (descriptor-reg)))
 268   (:generator 38
 269     (load-type type function (- fun-pointer-lowtag))
 270     (inst lea raw
 271           (make-ea :byte :base function
 272                    :disp (- (* simple-fun-code-offset n-word-bytes)
 273                             fun-pointer-lowtag)))
 274     (inst cmp (reg-in-size type :byte) simple-fun-header-widetag)
 275     (inst jmp :e NORMAL-FUN)
 276     (inst mov raw (make-fixup "closure_tramp" :foreign))
 277     NORMAL-FUN
 278     (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
 279     (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
 280     (move result function)))
 281
 282 (define-vop (fdefn-makunbound)
 283   (:policy :fast-safe)
 284   (:translate fdefn-makunbound)
 285   (:args (fdefn :scs (descriptor-reg) :target result))
 286   (:results (result :scs (descriptor-reg)))
 287   (:generator 38
 288     (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
 289     (storew (make-fixup "undefined_tramp" :foreign)
 290             fdefn fdefn-raw-addr-slot other-pointer-lowtag)
 291     (move result fdefn)))
 292 \f
 293 ;;;; binding and unbinding
 294
 295 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
 296 ;;; the symbol on the binding stack and stuff the new value into the
 297 ;;; symbol.
 298 ;;; See the "Chapter 9: Specials" of the SBCL Internals Manual.
 299
 300 #!+sb-thread
 301 (define-vop (bind)
 302   (:args (val :scs (any-reg descriptor-reg))
 303          (symbol :scs (descriptor-reg) :target tmp
 304                  :to :load))
 305   (:temporary (:sc unsigned-reg) tls-index bsp tmp)
 306   (:generator 10
 307     (load-binding-stack-pointer bsp)
 308     (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 309     (inst add bsp (* binding-size n-word-bytes))
 310     (store-binding-stack-pointer bsp)
 311     (inst test tls-index tls-index)
 312     (inst jmp :ne TLS-INDEX-VALID)
 313     (inst mov tls-index symbol)
 314     (inst mov tmp
 315           (make-fixup (ecase (tn-offset tls-index)
 316                         (#.rax-offset 'alloc-tls-index-in-rax)
 317                         (#.rcx-offset 'alloc-tls-index-in-rcx)
 318                         (#.rdx-offset 'alloc-tls-index-in-rdx)
 319                         (#.rbx-offset 'alloc-tls-index-in-rbx)
 320                         (#.rsi-offset 'alloc-tls-index-in-rsi)
 321                         (#.rdi-offset 'alloc-tls-index-in-rdi)
 322                         (#.r8-offset  'alloc-tls-index-in-r8)
 323                         (#.r9-offset  'alloc-tls-index-in-r9)
 324                         (#.r10-offset 'alloc-tls-index-in-r10)
 325                         (#.r12-offset 'alloc-tls-index-in-r12)
 326                         (#.r13-offset 'alloc-tls-index-in-r13)
 327                         (#.r14-offset 'alloc-tls-index-in-r14)
 328                         (#.r15-offset 'alloc-tls-index-in-r15))
 329                       :assembly-routine))
 330     (inst call tmp)
 331     TLS-INDEX-VALID
 332     (inst mov tmp (make-ea :qword :base thread-base-tn :scale 1 :index tls-index))
 333     (storew tls-index bsp (- binding-symbol-slot binding-size))
 334     (storew tmp bsp (- binding-value-slot binding-size))
 335     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
 336           val)))
 337
 338 #!-sb-thread
 339 (define-vop (bind)
 340   (:args (val :scs (any-reg descriptor-reg))
 341          (symbol :scs (descriptor-reg)))
 342   (:temporary (:sc unsigned-reg) temp bsp)
 343   (:generator 5
 344     (load-symbol-value bsp *binding-stack-pointer*)
 345     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
 346     (inst add bsp (* binding-size n-word-bytes))
 347     (store-symbol-value bsp *binding-stack-pointer*)
 348     (storew temp bsp (- binding-value-slot binding-size))
 349     (storew symbol bsp (- binding-symbol-slot binding-size))
 350     (storew val symbol symbol-value-slot other-pointer-lowtag)))
 351
 352 #!+sb-thread
 353 (define-vop (unbind)
 354   (:temporary (:sc unsigned-reg) temp bsp tls-index)
 355   (:generator 0
 356     (load-binding-stack-pointer bsp)
 357     (inst sub bsp (* binding-size n-word-bytes))
 358     ;; Load TLS-INDEX of the SYMBOL from stack
 359     (loadw tls-index bsp binding-symbol-slot)
 360     ;; Load VALUE from stack, then restore it to the TLS area.
 361     (loadw temp bsp binding-value-slot)
 362     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
 363           temp)
 364     ;; Zero out the stack.
 365     (zeroize temp)
 366
 367     (storew temp bsp binding-symbol-slot)
 368     (storew temp bsp binding-value-slot)
 369     (store-binding-stack-pointer bsp)))
 370
 371 #!-sb-thread
 372 (define-vop (unbind)
 373   (:temporary (:sc unsigned-reg) symbol value bsp)
 374   (:generator 0
 375     (load-symbol-value bsp *binding-stack-pointer*)
 376     (loadw symbol bsp (- binding-symbol-slot binding-size))
 377     (loadw value bsp (- binding-value-slot binding-size))
 378     (storew value symbol symbol-value-slot other-pointer-lowtag)
 379     (storew 0 bsp (- binding-symbol-slot binding-size))
 380     (storew 0 bsp (- binding-value-slot binding-size))
 381     (inst sub bsp (* binding-size n-word-bytes))
 382     (store-symbol-value bsp *binding-stack-pointer*)))
 383
 384 (define-vop (unbind-to-here)
 385   (:args (where :scs (descriptor-reg any-reg)))
 386   (:temporary (:sc unsigned-reg) symbol value bsp zero)
 387   (:generator 0
 388     (load-binding-stack-pointer bsp)
 389     (inst cmp where bsp)
 390     (inst jmp :e DONE)
 391     (zeroize zero)
 392     LOOP
 393     (inst sub bsp (* binding-size n-word-bytes))
 394     ;; on sb-thread symbol is actually a tls-index
 395     (loadw symbol bsp binding-symbol-slot)
 396     (inst test symbol symbol)
 397     (inst jmp :z SKIP)
 398     ;; Bind stack debug sentinels have the unbound marker in the symbol slot
 399     (inst cmp symbol unbound-marker-widetag)
 400     (inst jmp :eq SKIP)
 401     (loadw value bsp binding-value-slot)
 402     #!-sb-thread
 403     (storew value symbol symbol-value-slot other-pointer-lowtag)
 404     #!+sb-thread
 405     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index symbol)
 406           value)
 407     (storew zero bsp binding-symbol-slot)
 408
 409     SKIP
 410     (storew zero bsp binding-value-slot)
 411
 412     (inst cmp where bsp)
 413     (inst jmp :ne LOOP)
 414     (store-binding-stack-pointer bsp)
 415
 416     DONE))
 417
 418 (define-vop (bind-sentinel)
 419   (:temporary (:sc unsigned-reg) bsp)
 420   (:generator 1
 421      (load-binding-stack-pointer bsp)
 422      (inst add bsp (* binding-size n-word-bytes))
 423      (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
 424      (storew rbp-tn bsp (- binding-value-slot binding-size))
 425      (store-binding-stack-pointer bsp)))
 426
 427 (define-vop (unbind-sentinel)
 428   (:temporary (:sc unsigned-reg) bsp)
 429   (:generator 1
 430      (load-binding-stack-pointer bsp)
 431      (storew 0 bsp (- binding-value-slot binding-size))
 432      (storew 0 bsp (- binding-symbol-slot binding-size))
 433      (inst sub bsp (* binding-size n-word-bytes))
 434      (store-binding-stack-pointer bsp)))
 435
 436 \f
 437
 438 \f
 439 ;;;; closure indexing
 440
 441 (define-full-reffer closure-index-ref *
 442   closure-info-offset fun-pointer-lowtag
 443   (any-reg descriptor-reg) * %closure-index-ref)
 444
 445 (define-full-setter set-funcallable-instance-info *
 446   funcallable-instance-info-offset fun-pointer-lowtag
 447   (any-reg descriptor-reg) * %set-funcallable-instance-info)
 448
 449 (define-full-reffer funcallable-instance-info *
 450   funcallable-instance-info-offset fun-pointer-lowtag
 451   (descriptor-reg any-reg) * %funcallable-instance-info)
 452
 453 (define-vop (closure-ref slot-ref)
 454   (:variant closure-info-offset fun-pointer-lowtag))
 455
 456 (define-vop (closure-init slot-set)
 457   (:variant closure-info-offset fun-pointer-lowtag))
 458
 459 (define-vop (closure-init-from-fp)
 460   (:args (object :scs (descriptor-reg)))
 461   (:info offset)
 462   (:generator 4
 463     (storew rbp-tn object (+ closure-info-offset offset) fun-pointer-lowtag)))
 464 \f
 465 ;;;; value cell hackery
 466
 467 (define-vop (value-cell-ref cell-ref)
 468   (:variant value-cell-value-slot other-pointer-lowtag))
 469
 470 (define-vop (value-cell-set cell-set)
 471   (:variant value-cell-value-slot other-pointer-lowtag))
 472 \f
 473 ;;;; structure hackery
 474
 475 (define-vop (instance-length)
 476   (:policy :fast-safe)
 477   (:translate %instance-length)
 478   (:args (struct :scs (descriptor-reg)))
 479   (:results (res :scs (unsigned-reg)))
 480   (:result-types positive-fixnum)
 481   (:generator 4
 482     (loadw res struct 0 instance-pointer-lowtag)
 483     (inst shr res n-widetag-bits)))
 484
 485 (define-full-reffer instance-index-ref * instance-slots-offset
 486   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
 487
 488 (define-full-setter instance-index-set * instance-slots-offset
 489   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
 490
 491 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
 492   instance-slots-offset instance-pointer-lowtag
 493   (any-reg descriptor-reg) *
 494   %compare-and-swap-instance-ref)
 495 \f
 496 ;;;; code object frobbing
 497
 498 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
 499   (any-reg descriptor-reg) * code-header-ref)
 500
 501 (define-full-setter code-header-set * 0 other-pointer-lowtag
 502   (any-reg descriptor-reg) * code-header-set)
 503 \f
 504 ;;;; raw instance slot accessors
 505
 506 (defun make-ea-for-raw-slot (object instance-length
 507                              &key (index nil) (adjustment 0) (scale 1))
 508   (if (integerp instance-length)
 509       ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
 510       ;; at compile time.
 511       (make-ea :qword
 512                :base object
 513                :disp (+ (* (- instance-length instance-slots-offset index)
 514                            n-word-bytes)
 515                         (- instance-pointer-lowtag)
 516                         adjustment))
 517       (etypecase index
 518         (null
 519          (make-ea :qword :base object :index instance-length :scale scale
 520                   :disp (+ (* (1- instance-slots-offset) n-word-bytes)
 521                            (- instance-pointer-lowtag)
 522                            adjustment)))
 523         (integer
 524          (make-ea :qword :base object :index instance-length
 525                   :scale 8
 526                   :disp (+ (* (1- instance-slots-offset) n-word-bytes)
 527                            (- instance-pointer-lowtag)
 528                            adjustment
 529                            (* index (- n-word-bytes))))))))
 530
 531 (define-vop (raw-instance-ref/word)
 532   (:translate %raw-instance-ref/word)
 533   (:policy :fast-safe)
 534   (:args (object :scs (descriptor-reg)) (index :scs (any-reg)))
 535   (:arg-types * tagged-num)
 536   (:temporary (:sc unsigned-reg) tmp)
 537   (:results (value :scs (unsigned-reg)))
 538   (:result-types unsigned-num)
 539   (:generator 5
 540     (loadw tmp object 0 instance-pointer-lowtag)
 541     (inst shr tmp n-widetag-bits)
 542     (inst shl tmp n-fixnum-tag-bits)
 543     (inst sub tmp index)
 544     (inst mov value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 545
 546 (define-vop (raw-instance-ref-c/word)
 547   (:translate %raw-instance-ref/word)
 548   (:policy :fast-safe)
 549   (:args (object :scs (descriptor-reg)))
 550   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 551                                              #.instance-pointer-lowtag
 552                                              #.instance-slots-offset)))
 553   (:info index)
 554   (:temporary (:sc unsigned-reg) tmp)
 555   (:results (value :scs (unsigned-reg)))
 556   (:result-types unsigned-num)
 557   (:generator 4
 558     (loadw tmp object 0 instance-pointer-lowtag)
 559     (inst shr tmp n-widetag-bits)
 560     (inst mov value (make-ea-for-raw-slot object tmp :index index))))
 561
 562 (define-vop (raw-instance-set/word)
 563   (:translate %raw-instance-set/word)
 564   (:policy :fast-safe)
 565   (:args (object :scs (descriptor-reg))
 566          (index :scs (any-reg))
 567          (value :scs (unsigned-reg) :target result))
 568   (:arg-types * tagged-num unsigned-num)
 569   (:temporary (:sc unsigned-reg) tmp)
 570   (:results (result :scs (unsigned-reg)))
 571   (:result-types unsigned-num)
 572   (:generator 5
 573     (loadw tmp object 0 instance-pointer-lowtag)
 574     (inst shr tmp n-widetag-bits)
 575     (inst shl tmp n-fixnum-tag-bits)
 576     (inst sub tmp index)
 577     (inst mov (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)
 578     (move result value)))
 579
 580 (define-vop (raw-instance-set-c/word)
 581   (:translate %raw-instance-set/word)
 582   (:policy :fast-safe)
 583   (:args (object :scs (descriptor-reg))
 584          (value :scs (unsigned-reg) :target result))
 585   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 586                                              #.instance-pointer-lowtag
 587                                              #.instance-slots-offset))
 588               unsigned-num)
 589   (:info index)
 590   (:temporary (:sc unsigned-reg) tmp)
 591   (:results (result :scs (unsigned-reg)))
 592   (:result-types unsigned-num)
 593   (:generator 4
 594     (loadw tmp object 0 instance-pointer-lowtag)
 595     (inst shr tmp n-widetag-bits)
 596     (inst mov (make-ea-for-raw-slot object tmp :index index) value)
 597     (move result value)))
 598
 599 (define-vop (raw-instance-init/word)
 600   (:args (object :scs (descriptor-reg))
 601          (value :scs (unsigned-reg)))
 602   (:arg-types * unsigned-num)
 603   (:info instance-length index)
 604   (:generator 4
 605     (inst mov (make-ea-for-raw-slot object instance-length :index index) value)))
 606
 607 (define-vop (raw-instance-atomic-incf-c/word)
 608   (:translate %raw-instance-atomic-incf/word)
 609   (:policy :fast-safe)
 610   (:args (object :scs (descriptor-reg))
 611          (diff :scs (unsigned-reg) :target result))
 612   (:arg-types * (:constant (load/store-index #.n-word-bytes
 613                                              #.instance-pointer-lowtag
 614                                              #.instance-slots-offset))
 615               unsigned-num)
 616   (:info index)
 617   (:temporary (:sc unsigned-reg) tmp)
 618   (:results (result :scs (unsigned-reg)))
 619   (:result-types unsigned-num)
 620   (:generator 4
 621     (loadw tmp object 0 instance-pointer-lowtag)
 622     (inst shr tmp n-widetag-bits)
 623     (inst xadd (make-ea-for-raw-slot object tmp :index index) diff :lock)
 624     (move result diff)))
 625
 626 (define-vop (raw-instance-ref/single)
 627   (:translate %raw-instance-ref/single)
 628   (:policy :fast-safe)
 629   (:args (object :scs (descriptor-reg))
 630          (index :scs (any-reg)))
 631   (:arg-types * positive-fixnum)
 632   (:temporary (:sc unsigned-reg) tmp)
 633   (:results (value :scs (single-reg)))
 634   (:result-types single-float)
 635   (:generator 5
 636     (loadw tmp object 0 instance-pointer-lowtag)
 637     (inst shr tmp n-widetag-bits)
 638     (inst shl tmp n-fixnum-tag-bits)
 639     (inst sub tmp index)
 640     (inst movss value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 641
 642 (define-vop (raw-instance-ref-c/single)
 643   (:translate %raw-instance-ref/single)
 644   (:policy :fast-safe)
 645   (:args (object :scs (descriptor-reg)))
 646   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 647                                              #.instance-pointer-lowtag
 648                                              #.instance-slots-offset)))
 649   (:info index)
 650   (:temporary (:sc unsigned-reg) tmp)
 651   (:results (value :scs (single-reg)))
 652   (:result-types single-float)
 653   (:generator 4
 654     (loadw tmp object 0 instance-pointer-lowtag)
 655     (inst shr tmp n-widetag-bits)
 656     (inst movss value (make-ea-for-raw-slot object tmp :index index))))
 657
 658 (define-vop (raw-instance-set/single)
 659   (:translate %raw-instance-set/single)
 660   (:policy :fast-safe)
 661   (:args (object :scs (descriptor-reg))
 662          (index :scs (any-reg))
 663          (value :scs (single-reg) :target result))
 664   (:arg-types * positive-fixnum single-float)
 665   (:temporary (:sc unsigned-reg) tmp)
 666   (:results (result :scs (single-reg)))
 667   (:result-types single-float)
 668   (:generator 5
 669     (loadw tmp object 0 instance-pointer-lowtag)
 670     (inst shr tmp n-widetag-bits)
 671     (inst shl tmp n-fixnum-tag-bits)
 672     (inst sub tmp index)
 673     (inst movss (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)
 674     (move result value)))
 675
 676 (define-vop (raw-instance-set-c/single)
 677   (:translate %raw-instance-set/single)
 678   (:policy :fast-safe)
 679   (:args (object :scs (descriptor-reg))
 680          (value :scs (single-reg) :target result))
 681   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 682                                              #.instance-pointer-lowtag
 683                                              #.instance-slots-offset))
 684               single-float)
 685   (:info index)
 686   (:temporary (:sc unsigned-reg) tmp)
 687   (:results (result :scs (single-reg)))
 688   (:result-types single-float)
 689   (:generator 4
 690     (loadw tmp object 0 instance-pointer-lowtag)
 691     (inst shr tmp n-widetag-bits)
 692     (inst movss (make-ea-for-raw-slot object tmp :index index) value)
 693     (move result value)))
 694
 695 (define-vop (raw-instance-init/single)
 696   (:args (object :scs (descriptor-reg))
 697          (value :scs (single-reg)))
 698   (:arg-types * single-float)
 699   (:info instance-length index)
 700   (:generator 4
 701     (inst movss (make-ea-for-raw-slot object instance-length :index index) value)))
 702
 703 (define-vop (raw-instance-ref/double)
 704   (:translate %raw-instance-ref/double)
 705   (:policy :fast-safe)
 706   (:args (object :scs (descriptor-reg))
 707          (index :scs (any-reg)))
 708   (:arg-types * positive-fixnum)
 709   (:temporary (:sc unsigned-reg) tmp)
 710   (:results (value :scs (double-reg)))
 711   (:result-types double-float)
 712   (:generator 5
 713     (loadw tmp object 0 instance-pointer-lowtag)
 714     (inst shr tmp n-widetag-bits)
 715     (inst shl tmp n-fixnum-tag-bits)
 716     (inst sub tmp index)
 717     (inst movsd value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 718
 719 (define-vop (raw-instance-ref-c/double)
 720   (:translate %raw-instance-ref/double)
 721   (:policy :fast-safe)
 722   (:args (object :scs (descriptor-reg)))
 723   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 724                                              #.instance-pointer-lowtag
 725                                              #.instance-slots-offset)))
 726   (:info index)
 727   (:temporary (:sc unsigned-reg) tmp)
 728   (:results (value :scs (double-reg)))
 729   (:result-types double-float)
 730   (:generator 4
 731     (loadw tmp object 0 instance-pointer-lowtag)
 732     (inst shr tmp n-widetag-bits)
 733     (inst movsd value (make-ea-for-raw-slot object tmp :index index))))
 734
 735 (define-vop (raw-instance-set/double)
 736   (:translate %raw-instance-set/double)
 737   (:policy :fast-safe)
 738   (:args (object :scs (descriptor-reg))
 739          (index :scs (any-reg))
 740          (value :scs (double-reg) :target result))
 741   (:arg-types * positive-fixnum double-float)
 742   (:temporary (:sc unsigned-reg) tmp)
 743   (:results (result :scs (double-reg)))
 744   (:result-types double-float)
 745   (:generator 5
 746     (loadw tmp object 0 instance-pointer-lowtag)
 747     (inst shr tmp n-widetag-bits)
 748     (inst shl tmp n-fixnum-tag-bits)
 749     (inst sub tmp index)
 750     (inst movsd (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)
 751     (move result value)))
 752
 753 (define-vop (raw-instance-set-c/double)
 754   (:translate %raw-instance-set/double)
 755   (:policy :fast-safe)
 756   (:args (object :scs (descriptor-reg))
 757          (value :scs (double-reg) :target result))
 758   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 759                                              #.instance-pointer-lowtag
 760                                              #.instance-slots-offset))
 761               double-float)
 762   (:info index)
 763   (:temporary (:sc unsigned-reg) tmp)
 764   (:results (result :scs (double-reg)))
 765   (:result-types double-float)
 766   (:generator 4
 767     (loadw tmp object 0 instance-pointer-lowtag)
 768     (inst shr tmp n-widetag-bits)
 769     (inst movsd (make-ea-for-raw-slot object tmp :index index) value)
 770     (move result value)))
 771
 772 (define-vop (raw-instance-init/double)
 773   (:args (object :scs (descriptor-reg))
 774          (value :scs (double-reg)))
 775   (:arg-types * double-float)
 776   (:info instance-length index)
 777   (:generator 4
 778     (inst movsd (make-ea-for-raw-slot object instance-length :index index) value)))
 779
 780 (define-vop (raw-instance-ref/complex-single)
 781   (:translate %raw-instance-ref/complex-single)
 782   (:policy :fast-safe)
 783   (:args (object :scs (descriptor-reg))
 784          (index :scs (any-reg)))
 785   (:arg-types * positive-fixnum)
 786   (:temporary (:sc unsigned-reg) tmp)
 787   (:results (value :scs (complex-single-reg)))
 788   (:result-types complex-single-float)
 789   (:generator 5
 790     (loadw tmp object 0 instance-pointer-lowtag)
 791     (inst shr tmp n-widetag-bits)
 792     (inst shl tmp n-fixnum-tag-bits)
 793     (inst sub tmp index)
 794     (inst movq value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 795
 796 (define-vop (raw-instance-ref-c/complex-single)
 797   (:translate %raw-instance-ref/complex-single)
 798   (:policy :fast-safe)
 799   (:args (object :scs (descriptor-reg)))
 800   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 801                                              #.instance-pointer-lowtag
 802                                              #.instance-slots-offset)))
 803   (:info index)
 804   (:temporary (:sc unsigned-reg) tmp)
 805   (:results (value :scs (complex-single-reg)))
 806   (:result-types complex-single-float)
 807   (:generator 4
 808     (loadw tmp object 0 instance-pointer-lowtag)
 809     (inst shr tmp n-widetag-bits)
 810     (inst movq value (make-ea-for-raw-slot object tmp :index index))))
 811
 812 (define-vop (raw-instance-set/complex-single)
 813   (:translate %raw-instance-set/complex-single)
 814   (:policy :fast-safe)
 815   (:args (object :scs (descriptor-reg))
 816          (index :scs (any-reg))
 817          (value :scs (complex-single-reg) :target result))
 818   (:arg-types * positive-fixnum complex-single-float)
 819   (:temporary (:sc unsigned-reg) tmp)
 820   (:results (result :scs (complex-single-reg)))
 821   (:result-types complex-single-float)
 822   (:generator 5
 823     (loadw tmp object 0 instance-pointer-lowtag)
 824     (inst shr tmp n-widetag-bits)
 825     (inst shl tmp n-fixnum-tag-bits)
 826     (inst sub tmp index)
 827     (move result value)
 828     (inst movq (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)))
 829
 830 (define-vop (raw-instance-set-c/complex-single)
 831   (:translate %raw-instance-set/complex-single)
 832   (:policy :fast-safe)
 833   (:args (object :scs (descriptor-reg))
 834          (value :scs (complex-single-reg) :target result))
 835   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 836                                              #.instance-pointer-lowtag
 837                                              #.instance-slots-offset))
 838               complex-single-float)
 839   (:info index)
 840   (:temporary (:sc unsigned-reg) tmp)
 841   (:results (result :scs (complex-single-reg)))
 842   (:result-types complex-single-float)
 843   (:generator 4
 844     (loadw tmp object 0 instance-pointer-lowtag)
 845     (inst shr tmp n-widetag-bits)
 846     (move result value)
 847     (inst movq (make-ea-for-raw-slot object tmp :index index) value)))
 848
 849 (define-vop (raw-instance-init/complex-single)
 850   (:args (object :scs (descriptor-reg))
 851          (value :scs (complex-single-reg)))
 852   (:arg-types * complex-single-float)
 853   (:info instance-length index)
 854   (:generator 4
 855     (inst movq (make-ea-for-raw-slot object instance-length :index index) value)))
 856
 857 (define-vop (raw-instance-ref/complex-double)
 858   (:translate %raw-instance-ref/complex-double)
 859   (:policy :fast-safe)
 860   (:args (object :scs (descriptor-reg))
 861          (index :scs (any-reg)))
 862   (:arg-types * positive-fixnum)
 863   (:temporary (:sc unsigned-reg) tmp)
 864   (:results (value :scs (complex-double-reg)))
 865   (:result-types complex-double-float)
 866   (:generator 5
 867     (loadw tmp object 0 instance-pointer-lowtag)
 868     (inst shr tmp n-widetag-bits)
 869     (inst shl tmp n-fixnum-tag-bits)
 870     (inst sub tmp index)
 871     (inst movdqu value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)) :adjustment -8))))
 872
 873 (define-vop (raw-instance-ref-c/complex-double)
 874   (:translate %raw-instance-ref/complex-double)
 875   (:policy :fast-safe)
 876   (:args (object :scs (descriptor-reg)))
 877   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 878                                              #.instance-pointer-lowtag
 879                                              #.instance-slots-offset)))
 880   (:info index)
 881   (:temporary (:sc unsigned-reg) tmp)
 882   (:results (value :scs (complex-double-reg)))
 883   (:result-types complex-double-float)
 884   (:generator 4
 885     (loadw tmp object 0 instance-pointer-lowtag)
 886     (inst shr tmp n-widetag-bits)
 887     (inst movdqu value (make-ea-for-raw-slot object tmp :index index :adjustment -8))))
 888
 889 (define-vop (raw-instance-set/complex-double)
 890   (:translate %raw-instance-set/complex-double)
 891   (:policy :fast-safe)
 892   (:args (object :scs (descriptor-reg))
 893          (index :scs (any-reg))
 894          (value :scs (complex-double-reg) :target result))
 895   (:arg-types * positive-fixnum complex-double-float)
 896   (:temporary (:sc unsigned-reg) tmp)
 897   (:results (result :scs (complex-double-reg)))
 898   (:result-types complex-double-float)
 899   (:generator 5
 900     (loadw tmp object 0 instance-pointer-lowtag)
 901     (inst shr tmp n-widetag-bits)
 902     (inst shl tmp n-fixnum-tag-bits)
 903     (inst sub tmp index)
 904     (move result value)
 905     (inst movdqu (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)) :adjustment -8) value)))
 906
 907 (define-vop (raw-instance-set-c/complex-double)
 908   (:translate %raw-instance-set/complex-double)
 909   (:policy :fast-safe)
 910   (:args (object :scs (descriptor-reg))
 911          (value :scs (complex-double-reg) :target result))
 912   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 913                                              #.instance-pointer-lowtag
 914                                              #.instance-slots-offset))
 915               complex-double-float)
 916   (:info index)
 917   (:temporary (:sc unsigned-reg) tmp)
 918   (:results (result :scs (complex-double-reg)))
 919   (:result-types complex-double-float)
 920   (:generator 4
 921     (loadw tmp object 0 instance-pointer-lowtag)
 922     (inst shr tmp n-widetag-bits)
 923     (move result value)
 924     (inst movdqu (make-ea-for-raw-slot object tmp :index index :adjustment -8) value)))
 925
 926 (define-vop (raw-instance-init/complex-double)
 927   (:args (object :scs (descriptor-reg))
 928          (value :scs (complex-double-reg)))
 929   (:arg-types * complex-double-float)
 930   (:info instance-length index)
 931   (:generator 4
 932     (inst movdqu (make-ea-for-raw-slot object instance-length :index index :adjustment -8) value)))