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 :index tls-index))
 333     (storew tmp bsp (- binding-value-slot binding-size))
 334     (storew tls-index bsp (- binding-symbol-slot binding-size))
 335     (inst mov (make-ea :qword :base thread-base-tn :index tls-index) val)))
 336
 337 #!-sb-thread
 338 (define-vop (bind)
 339   (:args (val :scs (any-reg descriptor-reg))
 340          (symbol :scs (descriptor-reg)))
 341   (:temporary (:sc unsigned-reg) temp bsp)
 342   (:generator 5
 343     (load-symbol-value bsp *binding-stack-pointer*)
 344     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
 345     (inst add bsp (* binding-size n-word-bytes))
 346     (store-symbol-value bsp *binding-stack-pointer*)
 347     (storew temp bsp (- binding-value-slot binding-size))
 348     (storew symbol bsp (- binding-symbol-slot binding-size))
 349     (storew val symbol symbol-value-slot other-pointer-lowtag)))
 350
 351 #!+sb-thread
 352 (define-vop (unbind)
 353   (:temporary (:sc unsigned-reg) temp bsp tls-index)
 354   (:generator 0
 355     (load-binding-stack-pointer bsp)
 356     (inst sub bsp (* binding-size n-word-bytes))
 357     ;; Load TLS-INDEX of the SYMBOL from stack
 358     (loadw tls-index bsp binding-symbol-slot)
 359     ;; Load VALUE from stack, then restore it to the TLS area.
 360     (loadw temp bsp binding-value-slot)
 361     (inst mov (make-ea :qword :base thread-base-tn :index tls-index)
 362           temp)
 363     ;; Zero out the stack.
 364     (zeroize temp)
 365
 366     (storew temp bsp binding-symbol-slot)
 367     (storew temp bsp binding-value-slot)
 368     (store-binding-stack-pointer bsp)))
 369
 370 #!-sb-thread
 371 (define-vop (unbind)
 372   (:temporary (:sc unsigned-reg) symbol value bsp)
 373   (:generator 0
 374     (load-symbol-value bsp *binding-stack-pointer*)
 375     (loadw symbol bsp (- binding-symbol-slot binding-size))
 376     (loadw value bsp (- binding-value-slot binding-size))
 377     (storew value symbol symbol-value-slot other-pointer-lowtag)
 378     (storew 0 bsp (- binding-symbol-slot binding-size))
 379     (storew 0 bsp (- binding-value-slot binding-size))
 380     (inst sub bsp (* binding-size n-word-bytes))
 381     (store-symbol-value bsp *binding-stack-pointer*)))
 382
 383 (define-vop (unbind-to-here)
 384   (:args (where :scs (descriptor-reg any-reg)))
 385   (:temporary (:sc unsigned-reg) symbol value bsp zero)
 386   (:generator 0
 387     (load-binding-stack-pointer bsp)
 388     (inst cmp where bsp)
 389     (inst jmp :e DONE)
 390     (zeroize zero)
 391     LOOP
 392     (inst sub bsp (* binding-size n-word-bytes))
 393     ;; on sb-thread symbol is actually a tls-index
 394     (loadw symbol bsp binding-symbol-slot)
 395     (inst test symbol symbol)
 396     (inst jmp :z SKIP)
 397     ;; Bind stack debug sentinels have the unbound marker in the symbol slot
 398     (inst cmp symbol unbound-marker-widetag)
 399     (inst jmp :eq SKIP)
 400     (loadw value bsp binding-value-slot)
 401     #!-sb-thread
 402     (storew value symbol symbol-value-slot other-pointer-lowtag)
 403     #!+sb-thread
 404     (inst mov (make-ea :qword :base thread-base-tn :index symbol)
 405           value)
 406     (storew zero bsp binding-symbol-slot)
 407
 408     SKIP
 409     (storew zero bsp binding-value-slot)
 410
 411     (inst cmp where bsp)
 412     (inst jmp :ne LOOP)
 413     (store-binding-stack-pointer bsp)
 414
 415     DONE))
 416
 417 (define-vop (bind-sentinel)
 418   (:temporary (:sc unsigned-reg) bsp)
 419   (:generator 1
 420      (load-binding-stack-pointer bsp)
 421      (inst add bsp (* binding-size n-word-bytes))
 422      (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
 423      (storew rbp-tn bsp (- binding-value-slot binding-size))
 424      (store-binding-stack-pointer bsp)))
 425
 426 (define-vop (unbind-sentinel)
 427   (:temporary (:sc unsigned-reg) bsp)
 428   (:generator 1
 429      (load-binding-stack-pointer bsp)
 430      (storew 0 bsp (- binding-value-slot binding-size))
 431      (storew 0 bsp (- binding-symbol-slot binding-size))
 432      (inst sub bsp (* binding-size n-word-bytes))
 433      (store-binding-stack-pointer bsp)))
 434
 435 \f
 436
 437 \f
 438 ;;;; closure indexing
 439
 440 (define-full-reffer closure-index-ref *
 441   closure-info-offset fun-pointer-lowtag
 442   (any-reg descriptor-reg) * %closure-index-ref)
 443
 444 (define-full-setter set-funcallable-instance-info *
 445   funcallable-instance-info-offset fun-pointer-lowtag
 446   (any-reg descriptor-reg) * %set-funcallable-instance-info)
 447
 448 (define-full-reffer funcallable-instance-info *
 449   funcallable-instance-info-offset fun-pointer-lowtag
 450   (descriptor-reg any-reg) * %funcallable-instance-info)
 451
 452 (define-vop (closure-ref slot-ref)
 453   (:variant closure-info-offset fun-pointer-lowtag))
 454
 455 (define-vop (closure-init slot-set)
 456   (:variant closure-info-offset fun-pointer-lowtag))
 457
 458 (define-vop (closure-init-from-fp)
 459   (:args (object :scs (descriptor-reg)))
 460   (:info offset)
 461   (:generator 4
 462     (storew rbp-tn object (+ closure-info-offset offset) fun-pointer-lowtag)))
 463 \f
 464 ;;;; value cell hackery
 465
 466 (define-vop (value-cell-ref cell-ref)
 467   (:variant value-cell-value-slot other-pointer-lowtag))
 468
 469 (define-vop (value-cell-set cell-set)
 470   (:variant value-cell-value-slot other-pointer-lowtag))
 471 \f
 472 ;;;; structure hackery
 473
 474 (define-vop (instance-length)
 475   (:policy :fast-safe)
 476   (:translate %instance-length)
 477   (:args (struct :scs (descriptor-reg)))
 478   (:results (res :scs (unsigned-reg)))
 479   (:result-types positive-fixnum)
 480   (:generator 4
 481     (loadw res struct 0 instance-pointer-lowtag)
 482     (inst shr res n-widetag-bits)))
 483
 484 (define-full-reffer instance-index-ref * instance-slots-offset
 485   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
 486
 487 (define-full-setter instance-index-set * instance-slots-offset
 488   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
 489
 490 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
 491   instance-slots-offset instance-pointer-lowtag
 492   (any-reg descriptor-reg) *
 493   %compare-and-swap-instance-ref)
 494 \f
 495 ;;;; code object frobbing
 496
 497 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
 498   (any-reg descriptor-reg) * code-header-ref)
 499
 500 (define-full-setter code-header-set * 0 other-pointer-lowtag
 501   (any-reg descriptor-reg) * code-header-set)
 502 \f
 503 ;;;; raw instance slot accessors
 504
 505 (defun make-ea-for-raw-slot (object instance-length
 506                              &key (index nil) (adjustment 0) (scale 1))
 507   (if (integerp instance-length)
 508       ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
 509       ;; at compile time.
 510       (make-ea :qword
 511                :base object
 512                :disp (+ (* (- instance-length instance-slots-offset index)
 513                            n-word-bytes)
 514                         (- instance-pointer-lowtag)
 515                         adjustment))
 516       (etypecase index
 517         (null
 518          (make-ea :qword :base object :index instance-length :scale scale
 519                   :disp (+ (* (1- instance-slots-offset) n-word-bytes)
 520                            (- instance-pointer-lowtag)
 521                            adjustment)))
 522         (integer
 523          (make-ea :qword :base object :index instance-length
 524                   :scale 8
 525                   :disp (+ (* (1- instance-slots-offset) n-word-bytes)
 526                            (- instance-pointer-lowtag)
 527                            adjustment
 528                            (* index (- n-word-bytes))))))))
 529
 530 (define-vop (raw-instance-ref/word)
 531   (:translate %raw-instance-ref/word)
 532   (:policy :fast-safe)
 533   (:args (object :scs (descriptor-reg)) (index :scs (any-reg)))
 534   (:arg-types * tagged-num)
 535   (:temporary (:sc unsigned-reg) tmp)
 536   (:results (value :scs (unsigned-reg)))
 537   (:result-types unsigned-num)
 538   (:generator 5
 539     (loadw tmp object 0 instance-pointer-lowtag)
 540     (inst shr tmp n-widetag-bits)
 541     (inst shl tmp n-fixnum-tag-bits)
 542     (inst sub tmp index)
 543     (inst mov value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 544
 545 (define-vop (raw-instance-ref-c/word)
 546   (:translate %raw-instance-ref/word)
 547   (:policy :fast-safe)
 548   (:args (object :scs (descriptor-reg)))
 549   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 550                                              #.instance-pointer-lowtag
 551                                              #.instance-slots-offset)))
 552   (:info index)
 553   (:temporary (:sc unsigned-reg) tmp)
 554   (:results (value :scs (unsigned-reg)))
 555   (:result-types unsigned-num)
 556   (:generator 4
 557     (loadw tmp object 0 instance-pointer-lowtag)
 558     (inst shr tmp n-widetag-bits)
 559     (inst mov value (make-ea-for-raw-slot object tmp :index index))))
 560
 561 (define-vop (raw-instance-set/word)
 562   (:translate %raw-instance-set/word)
 563   (:policy :fast-safe)
 564   (:args (object :scs (descriptor-reg))
 565          (index :scs (any-reg))
 566          (value :scs (unsigned-reg) :target result))
 567   (:arg-types * tagged-num unsigned-num)
 568   (:temporary (:sc unsigned-reg) tmp)
 569   (:results (result :scs (unsigned-reg)))
 570   (:result-types unsigned-num)
 571   (:generator 5
 572     (loadw tmp object 0 instance-pointer-lowtag)
 573     (inst shr tmp n-widetag-bits)
 574     (inst shl tmp n-fixnum-tag-bits)
 575     (inst sub tmp index)
 576     (inst mov (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)
 577     (move result value)))
 578
 579 (define-vop (raw-instance-set-c/word)
 580   (:translate %raw-instance-set/word)
 581   (:policy :fast-safe)
 582   (:args (object :scs (descriptor-reg))
 583          (value :scs (unsigned-reg) :target result))
 584   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 585                                              #.instance-pointer-lowtag
 586                                              #.instance-slots-offset))
 587               unsigned-num)
 588   (:info index)
 589   (:temporary (:sc unsigned-reg) tmp)
 590   (:results (result :scs (unsigned-reg)))
 591   (:result-types unsigned-num)
 592   (:generator 4
 593     (loadw tmp object 0 instance-pointer-lowtag)
 594     (inst shr tmp n-widetag-bits)
 595     (inst mov (make-ea-for-raw-slot object tmp :index index) value)
 596     (move result value)))
 597
 598 (define-vop (raw-instance-init/word)
 599   (:args (object :scs (descriptor-reg))
 600          (value :scs (unsigned-reg)))
 601   (:arg-types * unsigned-num)
 602   (:info instance-length index)
 603   (:generator 4
 604     (inst mov (make-ea-for-raw-slot object instance-length :index index) value)))
 605
 606 (define-vop (raw-instance-atomic-incf-c/word)
 607   (:translate %raw-instance-atomic-incf/word)
 608   (:policy :fast-safe)
 609   (:args (object :scs (descriptor-reg))
 610          (diff :scs (unsigned-reg) :target result))
 611   (:arg-types * (:constant (load/store-index #.n-word-bytes
 612                                              #.instance-pointer-lowtag
 613                                              #.instance-slots-offset))
 614               unsigned-num)
 615   (:info index)
 616   (:temporary (:sc unsigned-reg) tmp)
 617   (:results (result :scs (unsigned-reg)))
 618   (:result-types unsigned-num)
 619   (:generator 4
 620     (loadw tmp object 0 instance-pointer-lowtag)
 621     (inst shr tmp n-widetag-bits)
 622     (inst xadd (make-ea-for-raw-slot object tmp :index index) diff :lock)
 623     (move result diff)))
 624
 625 (define-vop (raw-instance-ref/single)
 626   (:translate %raw-instance-ref/single)
 627   (:policy :fast-safe)
 628   (:args (object :scs (descriptor-reg))
 629          (index :scs (any-reg)))
 630   (:arg-types * positive-fixnum)
 631   (:temporary (:sc unsigned-reg) tmp)
 632   (:results (value :scs (single-reg)))
 633   (:result-types single-float)
 634   (:generator 5
 635     (loadw tmp object 0 instance-pointer-lowtag)
 636     (inst shr tmp n-widetag-bits)
 637     (inst shl tmp n-fixnum-tag-bits)
 638     (inst sub tmp index)
 639     (inst movss value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 640
 641 (define-vop (raw-instance-ref-c/single)
 642   (:translate %raw-instance-ref/single)
 643   (:policy :fast-safe)
 644   (:args (object :scs (descriptor-reg)))
 645   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 646                                              #.instance-pointer-lowtag
 647                                              #.instance-slots-offset)))
 648   (:info index)
 649   (:temporary (:sc unsigned-reg) tmp)
 650   (:results (value :scs (single-reg)))
 651   (:result-types single-float)
 652   (:generator 4
 653     (loadw tmp object 0 instance-pointer-lowtag)
 654     (inst shr tmp n-widetag-bits)
 655     (inst movss value (make-ea-for-raw-slot object tmp :index index))))
 656
 657 (define-vop (raw-instance-set/single)
 658   (:translate %raw-instance-set/single)
 659   (:policy :fast-safe)
 660   (:args (object :scs (descriptor-reg))
 661          (index :scs (any-reg))
 662          (value :scs (single-reg) :target result))
 663   (:arg-types * positive-fixnum single-float)
 664   (:temporary (:sc unsigned-reg) tmp)
 665   (:results (result :scs (single-reg)))
 666   (:result-types single-float)
 667   (:generator 5
 668     (loadw tmp object 0 instance-pointer-lowtag)
 669     (inst shr tmp n-widetag-bits)
 670     (inst shl tmp n-fixnum-tag-bits)
 671     (inst sub tmp index)
 672     (inst movss (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)
 673     (move result value)))
 674
 675 (define-vop (raw-instance-set-c/single)
 676   (:translate %raw-instance-set/single)
 677   (:policy :fast-safe)
 678   (:args (object :scs (descriptor-reg))
 679          (value :scs (single-reg) :target result))
 680   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 681                                              #.instance-pointer-lowtag
 682                                              #.instance-slots-offset))
 683               single-float)
 684   (:info index)
 685   (:temporary (:sc unsigned-reg) tmp)
 686   (:results (result :scs (single-reg)))
 687   (:result-types single-float)
 688   (:generator 4
 689     (loadw tmp object 0 instance-pointer-lowtag)
 690     (inst shr tmp n-widetag-bits)
 691     (inst movss (make-ea-for-raw-slot object tmp :index index) value)
 692     (move result value)))
 693
 694 (define-vop (raw-instance-init/single)
 695   (:args (object :scs (descriptor-reg))
 696          (value :scs (single-reg)))
 697   (:arg-types * single-float)
 698   (:info instance-length index)
 699   (:generator 4
 700     (inst movss (make-ea-for-raw-slot object instance-length :index index) value)))
 701
 702 (define-vop (raw-instance-ref/double)
 703   (:translate %raw-instance-ref/double)
 704   (:policy :fast-safe)
 705   (:args (object :scs (descriptor-reg))
 706          (index :scs (any-reg)))
 707   (:arg-types * positive-fixnum)
 708   (:temporary (:sc unsigned-reg) tmp)
 709   (:results (value :scs (double-reg)))
 710   (:result-types double-float)
 711   (:generator 5
 712     (loadw tmp object 0 instance-pointer-lowtag)
 713     (inst shr tmp n-widetag-bits)
 714     (inst shl tmp n-fixnum-tag-bits)
 715     (inst sub tmp index)
 716     (inst movsd value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 717
 718 (define-vop (raw-instance-ref-c/double)
 719   (:translate %raw-instance-ref/double)
 720   (:policy :fast-safe)
 721   (:args (object :scs (descriptor-reg)))
 722   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 723                                              #.instance-pointer-lowtag
 724                                              #.instance-slots-offset)))
 725   (:info index)
 726   (:temporary (:sc unsigned-reg) tmp)
 727   (:results (value :scs (double-reg)))
 728   (:result-types double-float)
 729   (:generator 4
 730     (loadw tmp object 0 instance-pointer-lowtag)
 731     (inst shr tmp n-widetag-bits)
 732     (inst movsd value (make-ea-for-raw-slot object tmp :index index))))
 733
 734 (define-vop (raw-instance-set/double)
 735   (:translate %raw-instance-set/double)
 736   (:policy :fast-safe)
 737   (:args (object :scs (descriptor-reg))
 738          (index :scs (any-reg))
 739          (value :scs (double-reg) :target result))
 740   (:arg-types * positive-fixnum double-float)
 741   (:temporary (:sc unsigned-reg) tmp)
 742   (:results (result :scs (double-reg)))
 743   (:result-types double-float)
 744   (:generator 5
 745     (loadw tmp object 0 instance-pointer-lowtag)
 746     (inst shr tmp n-widetag-bits)
 747     (inst shl tmp n-fixnum-tag-bits)
 748     (inst sub tmp index)
 749     (inst movsd (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)
 750     (move result value)))
 751
 752 (define-vop (raw-instance-set-c/double)
 753   (:translate %raw-instance-set/double)
 754   (:policy :fast-safe)
 755   (:args (object :scs (descriptor-reg))
 756          (value :scs (double-reg) :target result))
 757   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 758                                              #.instance-pointer-lowtag
 759                                              #.instance-slots-offset))
 760               double-float)
 761   (:info index)
 762   (:temporary (:sc unsigned-reg) tmp)
 763   (:results (result :scs (double-reg)))
 764   (:result-types double-float)
 765   (:generator 4
 766     (loadw tmp object 0 instance-pointer-lowtag)
 767     (inst shr tmp n-widetag-bits)
 768     (inst movsd (make-ea-for-raw-slot object tmp :index index) value)
 769     (move result value)))
 770
 771 (define-vop (raw-instance-init/double)
 772   (:args (object :scs (descriptor-reg))
 773          (value :scs (double-reg)))
 774   (:arg-types * double-float)
 775   (:info instance-length index)
 776   (:generator 4
 777     (inst movsd (make-ea-for-raw-slot object instance-length :index index) value)))
 778
 779 (define-vop (raw-instance-ref/complex-single)
 780   (:translate %raw-instance-ref/complex-single)
 781   (:policy :fast-safe)
 782   (:args (object :scs (descriptor-reg))
 783          (index :scs (any-reg)))
 784   (:arg-types * positive-fixnum)
 785   (:temporary (:sc unsigned-reg) tmp)
 786   (:results (value :scs (complex-single-reg)))
 787   (:result-types complex-single-float)
 788   (:generator 5
 789     (loadw tmp object 0 instance-pointer-lowtag)
 790     (inst shr tmp n-widetag-bits)
 791     (inst shl tmp n-fixnum-tag-bits)
 792     (inst sub tmp index)
 793     (inst movq value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 794
 795 (define-vop (raw-instance-ref-c/complex-single)
 796   (:translate %raw-instance-ref/complex-single)
 797   (:policy :fast-safe)
 798   (:args (object :scs (descriptor-reg)))
 799   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 800                                              #.instance-pointer-lowtag
 801                                              #.instance-slots-offset)))
 802   (:info index)
 803   (:temporary (:sc unsigned-reg) tmp)
 804   (:results (value :scs (complex-single-reg)))
 805   (:result-types complex-single-float)
 806   (:generator 4
 807     (loadw tmp object 0 instance-pointer-lowtag)
 808     (inst shr tmp n-widetag-bits)
 809     (inst movq value (make-ea-for-raw-slot object tmp :index index))))
 810
 811 (define-vop (raw-instance-set/complex-single)
 812   (:translate %raw-instance-set/complex-single)
 813   (:policy :fast-safe)
 814   (:args (object :scs (descriptor-reg))
 815          (index :scs (any-reg))
 816          (value :scs (complex-single-reg) :target result))
 817   (:arg-types * positive-fixnum complex-single-float)
 818   (:temporary (:sc unsigned-reg) tmp)
 819   (:results (result :scs (complex-single-reg)))
 820   (:result-types complex-single-float)
 821   (:generator 5
 822     (loadw tmp object 0 instance-pointer-lowtag)
 823     (inst shr tmp n-widetag-bits)
 824     (inst shl tmp n-fixnum-tag-bits)
 825     (inst sub tmp index)
 826     (move result value)
 827     (inst movq (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)))
 828
 829 (define-vop (raw-instance-set-c/complex-single)
 830   (:translate %raw-instance-set/complex-single)
 831   (:policy :fast-safe)
 832   (:args (object :scs (descriptor-reg))
 833          (value :scs (complex-single-reg) :target result))
 834   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 835                                              #.instance-pointer-lowtag
 836                                              #.instance-slots-offset))
 837               complex-single-float)
 838   (:info index)
 839   (:temporary (:sc unsigned-reg) tmp)
 840   (:results (result :scs (complex-single-reg)))
 841   (:result-types complex-single-float)
 842   (:generator 4
 843     (loadw tmp object 0 instance-pointer-lowtag)
 844     (inst shr tmp n-widetag-bits)
 845     (move result value)
 846     (inst movq (make-ea-for-raw-slot object tmp :index index) value)))
 847
 848 (define-vop (raw-instance-init/complex-single)
 849   (:args (object :scs (descriptor-reg))
 850          (value :scs (complex-single-reg)))
 851   (:arg-types * complex-single-float)
 852   (:info instance-length index)
 853   (:generator 4
 854     (inst movq (make-ea-for-raw-slot object instance-length :index index) value)))
 855
 856 (define-vop (raw-instance-ref/complex-double)
 857   (:translate %raw-instance-ref/complex-double)
 858   (:policy :fast-safe)
 859   (:args (object :scs (descriptor-reg))
 860          (index :scs (any-reg)))
 861   (:arg-types * positive-fixnum)
 862   (:temporary (:sc unsigned-reg) tmp)
 863   (:results (value :scs (complex-double-reg)))
 864   (:result-types complex-double-float)
 865   (:generator 5
 866     (loadw tmp object 0 instance-pointer-lowtag)
 867     (inst shr tmp n-widetag-bits)
 868     (inst shl tmp n-fixnum-tag-bits)
 869     (inst sub tmp index)
 870     (inst movdqu value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)) :adjustment -8))))
 871
 872 (define-vop (raw-instance-ref-c/complex-double)
 873   (:translate %raw-instance-ref/complex-double)
 874   (:policy :fast-safe)
 875   (:args (object :scs (descriptor-reg)))
 876   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 877                                              #.instance-pointer-lowtag
 878                                              #.instance-slots-offset)))
 879   (:info index)
 880   (:temporary (:sc unsigned-reg) tmp)
 881   (:results (value :scs (complex-double-reg)))
 882   (:result-types complex-double-float)
 883   (:generator 4
 884     (loadw tmp object 0 instance-pointer-lowtag)
 885     (inst shr tmp n-widetag-bits)
 886     (inst movdqu value (make-ea-for-raw-slot object tmp :index index :adjustment -8))))
 887
 888 (define-vop (raw-instance-set/complex-double)
 889   (:translate %raw-instance-set/complex-double)
 890   (:policy :fast-safe)
 891   (:args (object :scs (descriptor-reg))
 892          (index :scs (any-reg))
 893          (value :scs (complex-double-reg) :target result))
 894   (:arg-types * positive-fixnum complex-double-float)
 895   (:temporary (:sc unsigned-reg) tmp)
 896   (:results (result :scs (complex-double-reg)))
 897   (:result-types complex-double-float)
 898   (:generator 5
 899     (loadw tmp object 0 instance-pointer-lowtag)
 900     (inst shr tmp n-widetag-bits)
 901     (inst shl tmp n-fixnum-tag-bits)
 902     (inst sub tmp index)
 903     (move result value)
 904     (inst movdqu (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)) :adjustment -8) value)))
 905
 906 (define-vop (raw-instance-set-c/complex-double)
 907   (:translate %raw-instance-set/complex-double)
 908   (:policy :fast-safe)
 909   (:args (object :scs (descriptor-reg))
 910          (value :scs (complex-double-reg) :target result))
 911   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 912                                              #.instance-pointer-lowtag
 913                                              #.instance-slots-offset))
 914               complex-double-float)
 915   (:info index)
 916   (:temporary (:sc unsigned-reg) tmp)
 917   (:results (result :scs (complex-double-reg)))
 918   (:result-types complex-double-float)
 919   (:generator 4
 920     (loadw tmp object 0 instance-pointer-lowtag)
 921     (inst shr tmp n-widetag-bits)
 922     (move result value)
 923     (inst movdqu (make-ea-for-raw-slot object tmp :index index :adjustment -8) value)))
 924
 925 (define-vop (raw-instance-init/complex-double)
 926   (:args (object :scs (descriptor-reg))
 927          (value :scs (complex-double-reg)))
 928   (:arg-types * complex-double-float)
 929   (:info instance-length index)
 930   (:generator 4
 931     (inst movdqu (make-ea-for-raw-slot object instance-length :index index :adjustment -8) value)))