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