src/compiler/x86/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   (:info name offset lowtag)
  28   (:ignore name)
  29   (:results)
  30   (:generator 1
  31      (storew (encode-value-if-immediate value) object offset lowtag)))
  32
  33 (define-vop (compare-and-swap-slot)
  34   (:args (object :scs (descriptor-reg) :to :eval)
  35          (old :scs (descriptor-reg any-reg) :target eax)
  36          (new :scs (descriptor-reg any-reg)))
  37   (:temporary (:sc descriptor-reg :offset eax-offset
  38                    :from (:argument 1) :to :result :target result)
  39               eax)
  40   (:info name offset lowtag)
  41   (:ignore name)
  42   (:results (result :scs (descriptor-reg any-reg)))
  43   (:generator 5
  44      (move eax old)
  45      #!+sb-thread
  46      (inst lock)
  47      (inst cmpxchg (make-ea :dword :base object
  48                             :disp (- (* offset n-word-bytes) lowtag))
  49            new)
  50      (move result eax)))
  51 \f
  52 ;;;; symbol hacking VOPs
  53
  54 (define-vop (%compare-and-swap-symbol-value)
  55   (:translate %compare-and-swap-symbol-value)
  56   (:args (symbol :scs (descriptor-reg) :to (:result 1))
  57          (old :scs (descriptor-reg any-reg) :target eax)
  58          (new :scs (descriptor-reg any-reg)))
  59   (:temporary (:sc descriptor-reg :offset eax-offset) eax)
  60   #!+sb-thread
  61   (:temporary (:sc descriptor-reg) tls)
  62   (:results (result :scs (descriptor-reg any-reg)))
  63   (:policy :fast-safe)
  64   (:vop-var vop)
  65   (:generator 15
  66     ;; This code has to pathological cases: NO-TLS-VALUE-MARKER
  67     ;; or UNBOUND-MARKER as NEW: in either case we would end up
  68     ;; doing possible damage with CMPXCHG -- so don't do that!
  69     (let ((unbound (generate-error-code vop unbound-symbol-error symbol))
  70           (check (gen-label)))
  71       (move eax old)
  72       #!+sb-thread
  73       (progn
  74         (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
  75         ;; Thread-local area, no LOCK needed.
  76         (inst fs-segment-prefix)
  77         (inst cmpxchg (make-ea :dword :base tls) new)
  78         (inst cmp eax no-tls-value-marker-widetag)
  79         (inst jmp :ne check)
  80         (move eax old)
  81         (inst lock))
  82       (inst cmpxchg (make-ea :dword :base symbol
  83                              :disp (- (* symbol-value-slot n-word-bytes)
  84                                       other-pointer-lowtag))
  85             new)
  86       (emit-label check)
  87       (move result eax)
  88       (inst cmp result unbound-marker-widetag)
  89       (inst jmp :e unbound))))
  90
  91 ;;; these next two cf the sparc version, by jrd.
  92 ;;; FIXME: Deref this ^ reference.
  93
  94
  95 ;;; The compiler likes to be able to directly SET symbols.
  96 #!+sb-thread
  97 (define-vop (set)
  98   (:args (symbol :scs (descriptor-reg))
  99          (value :scs (descriptor-reg any-reg)))
 100   (:temporary (:sc descriptor-reg) tls)
 101   ;;(:policy :fast-safe)
 102   (:generator 4
 103     (let ((global-val (gen-label))
 104           (done (gen-label)))
 105       (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
 106       (inst fs-segment-prefix)
 107       (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag)
 108       (inst jmp :z global-val)
 109       (inst fs-segment-prefix)
 110       (inst mov (make-ea :dword :base tls) value)
 111       (inst jmp done)
 112       (emit-label global-val)
 113       (storew value symbol symbol-value-slot other-pointer-lowtag)
 114       (emit-label done))))
 115
 116 ;; unithreaded it's a lot simpler ...
 117 #!-sb-thread
 118 (define-vop (set cell-set)
 119   (:variant symbol-value-slot other-pointer-lowtag))
 120
 121 ;;; With Symbol-Value, we check that the value isn't the trap object. So
 122 ;;; Symbol-Value of NIL is NIL.
 123 #!+sb-thread
 124 (define-vop (symbol-value)
 125   (:translate symbol-value)
 126   (:policy :fast-safe)
 127   (:args (object :scs (descriptor-reg) :to (:result 1)))
 128   (:results (value :scs (descriptor-reg any-reg)))
 129   (:vop-var vop)
 130   (:save-p :compute-only)
 131   (:generator 9
 132     (let* ((check-unbound-label (gen-label))
 133            (err-lab (generate-error-code vop unbound-symbol-error object))
 134            (ret-lab (gen-label)))
 135       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
 136       (inst fs-segment-prefix)
 137       (inst mov value (make-ea :dword :base value))
 138       (inst cmp value no-tls-value-marker-widetag)
 139       (inst jmp :ne check-unbound-label)
 140       (loadw value object symbol-value-slot other-pointer-lowtag)
 141       (emit-label check-unbound-label)
 142       (inst cmp value unbound-marker-widetag)
 143       (inst jmp :e err-lab)
 144       (emit-label ret-lab))))
 145
 146 #!+sb-thread
 147 (define-vop (fast-symbol-value symbol-value)
 148   ;; KLUDGE: not really fast, in fact, because we're going to have to
 149   ;; do a full lookup of the thread-local area anyway.  But half of
 150   ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
 151   ;; unbound", which is used in the implementation of COPY-SYMBOL.  --
 152   ;; CSR, 2003-04-22
 153   (:policy :fast)
 154   (:translate symbol-value)
 155   (:generator 8
 156     (let ((ret-lab (gen-label)))
 157       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
 158       (inst fs-segment-prefix)
 159       (inst mov value (make-ea :dword :base value))
 160       (inst cmp value no-tls-value-marker-widetag)
 161       (inst jmp :ne ret-lab)
 162       (loadw value object symbol-value-slot other-pointer-lowtag)
 163       (emit-label ret-lab))))
 164
 165 #!-sb-thread
 166 (define-vop (symbol-value)
 167   (:translate symbol-value)
 168   (:policy :fast-safe)
 169   (:args (object :scs (descriptor-reg) :to (:result 1)))
 170   (:results (value :scs (descriptor-reg any-reg)))
 171   (:vop-var vop)
 172   (:save-p :compute-only)
 173   (:generator 9
 174     (let ((err-lab (generate-error-code vop unbound-symbol-error object)))
 175       (loadw value object symbol-value-slot other-pointer-lowtag)
 176       (inst cmp value unbound-marker-widetag)
 177       (inst jmp :e err-lab))))
 178
 179 #!-sb-thread
 180 (define-vop (fast-symbol-value cell-ref)
 181   (:variant symbol-value-slot other-pointer-lowtag)
 182   (:policy :fast)
 183   (:translate symbol-value))
 184
 185 (defknown locked-symbol-global-value-add (symbol fixnum) fixnum ())
 186
 187 (define-vop (locked-symbol-global-value-add)
 188     (:args (object :scs (descriptor-reg) :to :result)
 189            (value :scs (any-reg) :target result))
 190   (:arg-types * tagged-num)
 191   (:results (result :scs (any-reg) :from (:argument 1)))
 192   (:policy :fast)
 193   (:translate locked-symbol-global-value-add)
 194   (:result-types tagged-num)
 195   (:policy :fast-safe)
 196   (:generator 4
 197     (move result value)
 198     (inst lock)
 199     (inst add (make-ea-for-object-slot object symbol-value-slot
 200                                        other-pointer-lowtag)
 201           value)))
 202
 203 #!+sb-thread
 204 (define-vop (boundp)
 205   (:translate boundp)
 206   (:policy :fast-safe)
 207   (:args (object :scs (descriptor-reg)))
 208   (:conditional)
 209   (:info target not-p)
 210   (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
 211   (:generator 9
 212     (let ((check-unbound-label (gen-label)))
 213       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
 214       (inst fs-segment-prefix)
 215       (inst mov value (make-ea :dword :base value))
 216       (inst cmp value no-tls-value-marker-widetag)
 217       (inst jmp :ne check-unbound-label)
 218       (loadw value object symbol-value-slot other-pointer-lowtag)
 219       (emit-label check-unbound-label)
 220       (inst cmp value unbound-marker-widetag)
 221       (inst jmp (if not-p :e :ne) target))))
 222
 223 #!-sb-thread
 224 (define-vop (boundp)
 225   (:translate boundp)
 226   (:policy :fast-safe)
 227   (:args (object :scs (descriptor-reg)))
 228   (:conditional)
 229   (:info target not-p)
 230   (:generator 9
 231     (inst cmp (make-ea-for-object-slot object symbol-value-slot
 232                                        other-pointer-lowtag)
 233           unbound-marker-widetag)
 234     (inst jmp (if not-p :e :ne) target)))
 235
 236
 237 (define-vop (symbol-hash)
 238   (:policy :fast-safe)
 239   (:translate symbol-hash)
 240   (:args (symbol :scs (descriptor-reg)))
 241   (:results (res :scs (any-reg)))
 242   (:result-types positive-fixnum)
 243   (:generator 2
 244     ;; The symbol-hash slot of NIL holds NIL because it is also the
 245     ;; cdr slot, so we have to strip off the two low bits to make sure
 246     ;; it is a fixnum.  The lowtag selection magic that is required to
 247     ;; ensure this is explained in the comment in objdef.lisp
 248     (loadw res symbol symbol-hash-slot other-pointer-lowtag)
 249     (inst and res (lognot #b11))))
 250 \f
 251 ;;;; fdefinition (FDEFN) objects
 252
 253 (define-vop (fdefn-fun cell-ref)        ; /pfw - alpha
 254   (:variant fdefn-fun-slot other-pointer-lowtag))
 255
 256 (define-vop (safe-fdefn-fun)
 257   (:args (object :scs (descriptor-reg) :to (:result 1)))
 258   (:results (value :scs (descriptor-reg any-reg)))
 259   (:vop-var vop)
 260   (:save-p :compute-only)
 261   (:generator 10
 262     (loadw value object fdefn-fun-slot other-pointer-lowtag)
 263     (inst cmp value nil-value)
 264     (let ((err-lab (generate-error-code vop undefined-fun-error object)))
 265       (inst jmp :e err-lab))))
 266
 267 (define-vop (set-fdefn-fun)
 268   (:policy :fast-safe)
 269   (:translate (setf fdefn-fun))
 270   (:args (function :scs (descriptor-reg) :target result)
 271          (fdefn :scs (descriptor-reg)))
 272   (:temporary (:sc unsigned-reg) raw)
 273   (:temporary (:sc byte-reg) type)
 274   (:results (result :scs (descriptor-reg)))
 275   (:generator 38
 276     (load-type type function (- fun-pointer-lowtag))
 277     (inst lea raw
 278           (make-ea-for-object-slot function simple-fun-code-offset
 279                                    fun-pointer-lowtag))
 280     (inst cmp type simple-fun-header-widetag)
 281     (inst jmp :e normal-fn)
 282     (inst lea raw (make-fixup "closure_tramp" :foreign))
 283     NORMAL-FN
 284     (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
 285     (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
 286     (move result function)))
 287
 288 (define-vop (fdefn-makunbound)
 289   (:policy :fast-safe)
 290   (:translate fdefn-makunbound)
 291   (:args (fdefn :scs (descriptor-reg) :target result))
 292   (:results (result :scs (descriptor-reg)))
 293   (:generator 38
 294     (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
 295     (storew (make-fixup "undefined_tramp" :foreign)
 296             fdefn fdefn-raw-addr-slot other-pointer-lowtag)
 297     (move result fdefn)))
 298 \f
 299 ;;;; binding and unbinding
 300
 301 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
 302 ;;; the symbol on the binding stack and stuff the new value into the
 303 ;;; symbol.
 304
 305 #!+sb-thread
 306 (define-vop (bind)
 307   (:args (val :scs (any-reg descriptor-reg))
 308          (symbol :scs (descriptor-reg)))
 309   (:temporary (:sc descriptor-reg :offset eax-offset) eax)
 310   (:temporary (:sc unsigned-reg) tls-index bsp)
 311   (:generator 10
 312     (let ((tls-index-valid (gen-label))
 313           (get-tls-index-lock (gen-label))
 314           (release-tls-index-lock (gen-label)))
 315       (load-binding-stack-pointer bsp)
 316       (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 317       (inst add bsp (* binding-size n-word-bytes))
 318       (store-binding-stack-pointer bsp)
 319       (inst or tls-index tls-index)
 320       (inst jmp :ne tls-index-valid)
 321
 322       ;; FIXME:
 323       ;; * We should ensure the existence of TLS index for LET-bound specials
 324       ;;   at compile/load time, and use write a FAST-BIND for use with those.
 325       ;; * PROGV will need to do this, but even there this should not be inline.
 326       ;;   This is probably best moved to C, since dynbind.c also needs to do this.
 327       (pseudo-atomic
 328        (emit-label get-tls-index-lock)
 329        (inst mov tls-index 1)
 330        (inst xor eax eax)
 331        (inst lock)
 332        (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) tls-index)
 333        (inst jmp :ne get-tls-index-lock)
 334        ;; now with the lock held, see if the symbol's tls index has
 335        ;; been set in the meantime
 336        (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 337        (inst or tls-index tls-index)
 338        (inst jmp :ne release-tls-index-lock)
 339        ;; allocate a new tls-index
 340        (load-symbol-value tls-index *free-tls-index*)
 341        (inst add (make-ea-for-symbol-value *free-tls-index*) 4) ; fixnum + 1
 342        (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 343        (emit-label release-tls-index-lock)
 344        (store-symbol-value 0 *tls-index-lock*))
 345
 346       (emit-label tls-index-valid)
 347       (inst fs-segment-prefix)
 348       (inst mov eax (make-ea :dword :base tls-index))
 349       (storew eax bsp (- binding-value-slot binding-size))
 350       (storew symbol bsp (- binding-symbol-slot binding-size))
 351       (inst fs-segment-prefix)
 352       (inst mov (make-ea :dword :base tls-index) val))))
 353
 354 #!-sb-thread
 355 (define-vop (bind)
 356   (:args (val :scs (any-reg descriptor-reg))
 357          (symbol :scs (descriptor-reg)))
 358   (:temporary (:sc unsigned-reg) temp bsp)
 359   (:generator 5
 360     (load-symbol-value bsp *binding-stack-pointer*)
 361     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
 362     (inst add bsp (* binding-size n-word-bytes))
 363     (store-symbol-value bsp *binding-stack-pointer*)
 364     (storew temp bsp (- binding-value-slot binding-size))
 365     (storew symbol bsp (- binding-symbol-slot binding-size))
 366     (storew val symbol symbol-value-slot other-pointer-lowtag)))
 367
 368
 369 #!+sb-thread
 370 (define-vop (unbind)
 371     ;; four temporaries?
 372   (:temporary (:sc unsigned-reg) symbol value bsp tls-index)
 373   (:generator 0
 374     (load-binding-stack-pointer bsp)
 375     (loadw symbol bsp (- binding-symbol-slot binding-size))
 376     (loadw value bsp (- binding-value-slot binding-size))
 377
 378     (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 379     (inst fs-segment-prefix)
 380     (inst mov (make-ea :dword :base tls-index) value)
 381
 382     (storew 0 bsp (- binding-symbol-slot binding-size))
 383     (storew 0 bsp (- binding-value-slot binding-size))
 384     (inst sub bsp (* binding-size n-word-bytes))
 385     (store-binding-stack-pointer bsp)))
 386
 387 #!-sb-thread
 388 (define-vop (unbind)
 389   (:temporary (:sc unsigned-reg) symbol value bsp)
 390   (:generator 0
 391     (load-symbol-value bsp *binding-stack-pointer*)
 392     (loadw symbol bsp (- binding-symbol-slot binding-size))
 393     (loadw value bsp (- binding-value-slot binding-size))
 394     (storew value symbol symbol-value-slot other-pointer-lowtag)
 395     (storew 0 bsp (- binding-symbol-slot binding-size))
 396     (storew 0 bsp (- binding-value-slot binding-size))
 397     (inst sub bsp (* binding-size n-word-bytes))
 398     (store-symbol-value bsp *binding-stack-pointer*)))
 399
 400
 401 (define-vop (unbind-to-here)
 402   (:args (where :scs (descriptor-reg any-reg)))
 403   (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index)
 404   (:generator 0
 405     (load-binding-stack-pointer bsp)
 406     (inst cmp where bsp)
 407     (inst jmp :e done)
 408
 409     LOOP
 410     (loadw symbol bsp (- binding-symbol-slot binding-size))
 411     (inst or symbol symbol)
 412     (inst jmp :z skip)
 413     ;; Bind stack debug sentinels have the unbound marker in the symbol slot
 414     (inst cmp symbol unbound-marker-widetag)
 415     (inst jmp :eq skip)
 416     (loadw value bsp (- binding-value-slot binding-size))
 417     #!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag)
 418
 419     #!+sb-thread (loadw
 420                   tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 421     #!+sb-thread (inst fs-segment-prefix)
 422     #!+sb-thread (inst mov (make-ea :dword :base tls-index) value)
 423     (storew 0 bsp (- binding-symbol-slot binding-size))
 424
 425     SKIP
 426     (storew 0 bsp (- binding-value-slot binding-size))
 427     (inst sub bsp (* binding-size n-word-bytes))
 428     (inst cmp where bsp)
 429     (inst jmp :ne loop)
 430     (store-binding-stack-pointer bsp)
 431
 432     DONE))
 433
 434 (define-vop (bind-sentinel)
 435   (:temporary (:sc unsigned-reg) bsp)
 436   (:generator 1
 437      (load-binding-stack-pointer bsp)
 438      (inst add bsp (* binding-size n-word-bytes))
 439      (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
 440      (storew ebp-tn bsp (- binding-value-slot binding-size))
 441      (store-binding-stack-pointer bsp)))
 442
 443 (define-vop (unbind-sentinel)
 444   (:temporary (:sc unsigned-reg) bsp)
 445   (:generator 1
 446      (load-binding-stack-pointer bsp)
 447      (storew 0 bsp (- binding-value-slot binding-size))
 448      (storew 0 bsp (- binding-symbol-slot binding-size))
 449      (inst sub bsp (* binding-size n-word-bytes))
 450      (store-binding-stack-pointer bsp)))
 451 \f
 452
 453 \f
 454 ;;;; closure indexing
 455
 456 (define-full-reffer closure-index-ref *
 457   closure-info-offset fun-pointer-lowtag
 458   (any-reg descriptor-reg) * %closure-index-ref)
 459
 460 (define-full-setter set-funcallable-instance-info *
 461   funcallable-instance-info-offset fun-pointer-lowtag
 462   (any-reg descriptor-reg) * %set-funcallable-instance-info)
 463
 464 (define-full-reffer funcallable-instance-info *
 465   funcallable-instance-info-offset fun-pointer-lowtag
 466   (descriptor-reg any-reg) * %funcallable-instance-info)
 467
 468 (define-vop (closure-ref slot-ref)
 469   (:variant closure-info-offset fun-pointer-lowtag))
 470
 471 (define-vop (closure-init slot-set)
 472   (:variant closure-info-offset fun-pointer-lowtag))
 473 \f
 474 ;;;; value cell hackery
 475
 476 (define-vop (value-cell-ref cell-ref)
 477   (:variant value-cell-value-slot other-pointer-lowtag))
 478
 479 (define-vop (value-cell-set cell-set)
 480   (:variant value-cell-value-slot other-pointer-lowtag))
 481 \f
 482 ;;;; structure hackery
 483
 484 (define-vop (instance-length)
 485   (:policy :fast-safe)
 486   (:translate %instance-length)
 487   (:args (struct :scs (descriptor-reg)))
 488   (:results (res :scs (unsigned-reg)))
 489   (:result-types positive-fixnum)
 490   (:generator 4
 491     (loadw res struct 0 instance-pointer-lowtag)
 492     (inst shr res n-widetag-bits)))
 493
 494 (define-full-reffer instance-index-ref *
 495   instance-slots-offset instance-pointer-lowtag
 496   (any-reg descriptor-reg) *
 497   %instance-ref)
 498
 499 (define-full-setter instance-index-set *
 500   instance-slots-offset instance-pointer-lowtag
 501   (any-reg descriptor-reg) *
 502   %instance-set)
 503
 504 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
 505   instance-slots-offset instance-pointer-lowtag
 506   (any-reg descriptor-reg) *
 507   %compare-and-swap-instance-ref)
 508 \f
 509 ;;;; code object frobbing
 510
 511 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
 512   (any-reg descriptor-reg) * code-header-ref)
 513
 514 (define-full-setter code-header-set * 0 other-pointer-lowtag
 515   (any-reg descriptor-reg) * code-header-set)
 516 \f
 517 ;;;; raw instance slot accessors
 518
 519 (defun make-ea-for-raw-slot (object index instance-length n-words)
 520   (sc-case index
 521     (any-reg (make-ea :dword
 522                       :base object
 523                       :index instance-length
 524                       :disp (- (* (- instance-slots-offset n-words)
 525                                   n-word-bytes)
 526                                instance-pointer-lowtag)))
 527     (immediate (make-ea :dword :base object
 528                         :index instance-length
 529                         :scale 4
 530                         :disp (- (* (- instance-slots-offset n-words)
 531                                     n-word-bytes)
 532                                  instance-pointer-lowtag
 533                                  (fixnumize (tn-value index)))))))
 534
 535 (define-vop (raw-instance-ref/word)
 536   (:translate %raw-instance-ref/word)
 537   (:policy :fast-safe)
 538   (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)))
 539   (:arg-types * tagged-num)
 540   (:temporary (:sc unsigned-reg) tmp)
 541   (:results (value :scs (unsigned-reg)))
 542   (:result-types unsigned-num)
 543   (:generator 5
 544     (loadw tmp object 0 instance-pointer-lowtag)
 545     (inst shr tmp n-widetag-bits)
 546     (when (sc-is index any-reg)
 547       (inst shl tmp 2)
 548       (inst sub tmp index))
 549     (inst mov value (make-ea-for-raw-slot object index tmp 1))))
 550
 551 (define-vop (raw-instance-set/word)
 552   (:translate %raw-instance-set/word)
 553   (:policy :fast-safe)
 554   (:args (object :scs (descriptor-reg))
 555          (index :scs (any-reg immediate))
 556          (value :scs (unsigned-reg) :target result))
 557   (:arg-types * tagged-num unsigned-num)
 558   (:temporary (:sc unsigned-reg) tmp)
 559   (:results (result :scs (unsigned-reg)))
 560   (:result-types unsigned-num)
 561   (:generator 5
 562     (loadw tmp object 0 instance-pointer-lowtag)
 563     (inst shr tmp n-widetag-bits)
 564     (when (sc-is index any-reg)
 565       (inst shl tmp 2)
 566       (inst sub tmp index))
 567     (inst mov (make-ea-for-raw-slot object index tmp 1) value)
 568     (move result value)))
 569
 570 (define-vop (raw-instance-ref/single)
 571   (:translate %raw-instance-ref/single)
 572   (:policy :fast-safe)
 573   (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)))
 574   (:arg-types * tagged-num)
 575   (:temporary (:sc unsigned-reg) tmp)
 576   (:results (value :scs (single-reg)))
 577   (:result-types single-float)
 578   (:generator 5
 579     (loadw tmp object 0 instance-pointer-lowtag)
 580     (inst shr tmp n-widetag-bits)
 581     (when (sc-is index any-reg)
 582       (inst shl tmp 2)
 583       (inst sub tmp index))
 584     (with-empty-tn@fp-top(value)
 585       (inst fld (make-ea-for-raw-slot object index tmp 1)))))
 586
 587 (define-vop (raw-instance-set/single)
 588   (:translate %raw-instance-set/single)
 589   (:policy :fast-safe)
 590   (:args (object :scs (descriptor-reg))
 591          (index :scs (any-reg immediate))
 592          (value :scs (single-reg) :target result))
 593   (:arg-types * tagged-num single-float)
 594   (:temporary (:sc unsigned-reg) tmp)
 595   (:results (result :scs (single-reg)))
 596   (:result-types single-float)
 597   (:generator 5
 598     (loadw tmp object 0 instance-pointer-lowtag)
 599     (inst shr tmp n-widetag-bits)
 600     (when (sc-is index any-reg)
 601       (inst shl tmp 2)
 602       (inst sub tmp index))
 603     (unless (zerop (tn-offset value))
 604       (inst fxch value))
 605     (inst fst (make-ea-for-raw-slot object index tmp 1))
 606     (cond
 607       ((zerop (tn-offset value))
 608         (unless (zerop (tn-offset result))
 609           (inst fst result)))
 610       ((zerop (tn-offset result))
 611         (inst fst value))
 612       (t
 613         (unless (location= value result)
 614           (inst fst result))
 615         (inst fxch value)))))
 616
 617 (define-vop (raw-instance-ref/double)
 618   (:translate %raw-instance-ref/double)
 619   (:policy :fast-safe)
 620   (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)))
 621   (:arg-types * tagged-num)
 622   (:temporary (:sc unsigned-reg) tmp)
 623   (:results (value :scs (double-reg)))
 624   (:result-types double-float)
 625   (:generator 5
 626     (loadw tmp object 0 instance-pointer-lowtag)
 627     (inst shr tmp n-widetag-bits)
 628     (when (sc-is index any-reg)
 629       (inst shl tmp 2)
 630       (inst sub tmp index))
 631     (with-empty-tn@fp-top(value)
 632       (inst fldd (make-ea-for-raw-slot object index tmp 2)))))
 633
 634 (define-vop (raw-instance-set/double)
 635   (:translate %raw-instance-set/double)
 636   (:policy :fast-safe)
 637   (:args (object :scs (descriptor-reg))
 638          (index :scs (any-reg immediate))
 639          (value :scs (double-reg) :target result))
 640   (:arg-types * tagged-num double-float)
 641   (:temporary (:sc unsigned-reg) tmp)
 642   (:results (result :scs (double-reg)))
 643   (:result-types double-float)
 644   (:generator 5
 645     (loadw tmp object 0 instance-pointer-lowtag)
 646     (inst shr tmp n-widetag-bits)
 647     (when (sc-is index any-reg)
 648       (inst shl tmp 2)
 649       (inst sub tmp index))
 650     (unless (zerop (tn-offset value))
 651       (inst fxch value))
 652     (inst fstd (make-ea-for-raw-slot object index tmp 2))
 653     (cond
 654       ((zerop (tn-offset value))
 655         (unless (zerop (tn-offset result))
 656           (inst fstd result)))
 657       ((zerop (tn-offset result))
 658         (inst fstd value))
 659       (t
 660         (unless (location= value result)
 661           (inst fstd result))
 662         (inst fxch value)))))
 663
 664 (define-vop (raw-instance-ref/complex-single)
 665   (:translate %raw-instance-ref/complex-single)
 666   (:policy :fast-safe)
 667   (:args (object :scs (descriptor-reg))
 668          (index :scs (any-reg immediate)))
 669   (:arg-types * positive-fixnum)
 670   (:temporary (:sc unsigned-reg) tmp)
 671   (:results (value :scs (complex-single-reg)))
 672   (:result-types complex-single-float)
 673   (:generator 5
 674     (loadw tmp object 0 instance-pointer-lowtag)
 675     (inst shr tmp n-widetag-bits)
 676     (when (sc-is index any-reg)
 677       (inst shl tmp 2)
 678       (inst sub tmp index))
 679     (let ((real-tn (complex-single-reg-real-tn value)))
 680       (with-empty-tn@fp-top (real-tn)
 681         (inst fld (make-ea-for-raw-slot object index tmp 2))))
 682     (let ((imag-tn (complex-single-reg-imag-tn value)))
 683       (with-empty-tn@fp-top (imag-tn)
 684         (inst fld (make-ea-for-raw-slot object index tmp 1))))))
 685
 686 (define-vop (raw-instance-set/complex-single)
 687   (:translate %raw-instance-set/complex-single)
 688   (:policy :fast-safe)
 689   (:args (object :scs (descriptor-reg))
 690          (index :scs (any-reg immediate))
 691          (value :scs (complex-single-reg) :target result))
 692   (:arg-types * positive-fixnum complex-single-float)
 693   (:temporary (:sc unsigned-reg) tmp)
 694   (:results (result :scs (complex-single-reg)))
 695   (:result-types complex-single-float)
 696   (:generator 5
 697     (loadw tmp object 0 instance-pointer-lowtag)
 698     (inst shr tmp n-widetag-bits)
 699     (when (sc-is index any-reg)
 700       (inst shl tmp 2)
 701       (inst sub tmp index))
 702     (let ((value-real (complex-single-reg-real-tn value))
 703           (result-real (complex-single-reg-real-tn result)))
 704       (cond ((zerop (tn-offset value-real))
 705              ;; Value is in ST0.
 706              (inst fst (make-ea-for-raw-slot object index tmp 2))
 707              (unless (zerop (tn-offset result-real))
 708                ;; Value is in ST0 but not result.
 709                (inst fst result-real)))
 710             (t
 711              ;; Value is not in ST0.
 712              (inst fxch value-real)
 713              (inst fst (make-ea-for-raw-slot object index tmp 2))
 714              (cond ((zerop (tn-offset result-real))
 715                     ;; The result is in ST0.
 716                     (inst fst value-real))
 717                    (t
 718                     ;; Neither value or result are in ST0
 719                     (unless (location= value-real result-real)
 720                       (inst fst result-real))
 721                     (inst fxch value-real))))))
 722     (let ((value-imag (complex-single-reg-imag-tn value))
 723           (result-imag (complex-single-reg-imag-tn result)))
 724       (inst fxch value-imag)
 725       (inst fst (make-ea-for-raw-slot object index tmp 1))
 726       (unless (location= value-imag result-imag)
 727         (inst fst result-imag))
 728       (inst fxch value-imag))))
 729
 730 (define-vop (raw-instance-ref/complex-double)
 731   (:translate %raw-instance-ref/complex-double)
 732   (:policy :fast-safe)
 733   (:args (object :scs (descriptor-reg))
 734          (index :scs (any-reg immediate)))
 735   (:arg-types * positive-fixnum)
 736   (:temporary (:sc unsigned-reg) tmp)
 737   (:results (value :scs (complex-double-reg)))
 738   (:result-types complex-double-float)
 739   (:generator 7
 740     (loadw tmp object 0 instance-pointer-lowtag)
 741     (inst shr tmp n-widetag-bits)
 742     (when (sc-is index any-reg)
 743       (inst shl tmp 2)
 744       (inst sub tmp index))
 745     (let ((real-tn (complex-double-reg-real-tn value)))
 746       (with-empty-tn@fp-top (real-tn)
 747         (inst fldd (make-ea-for-raw-slot object index tmp 4))))
 748     (let ((imag-tn (complex-double-reg-imag-tn value)))
 749       (with-empty-tn@fp-top (imag-tn)
 750         (inst fldd (make-ea-for-raw-slot object index tmp 2))))))
 751
 752 (define-vop (raw-instance-set/complex-double)
 753   (:translate %raw-instance-set/complex-double)
 754   (:policy :fast-safe)
 755   (:args (object :scs (descriptor-reg))
 756          (index :scs (any-reg immediate))
 757          (value :scs (complex-double-reg) :target result))
 758   (:arg-types * positive-fixnum complex-double-float)
 759   (:temporary (:sc unsigned-reg) tmp)
 760   (:results (result :scs (complex-double-reg)))
 761   (:result-types complex-double-float)
 762   (:generator 20
 763     (loadw tmp object 0 instance-pointer-lowtag)
 764     (inst shr tmp n-widetag-bits)
 765     (when (sc-is index any-reg)
 766       (inst shl tmp 2)
 767       (inst sub tmp index))
 768     (let ((value-real (complex-double-reg-real-tn value))
 769           (result-real (complex-double-reg-real-tn result)))
 770       (cond ((zerop (tn-offset value-real))
 771              ;; Value is in ST0.
 772              (inst fstd (make-ea-for-raw-slot object index tmp 4))
 773              (unless (zerop (tn-offset result-real))
 774                ;; Value is in ST0 but not result.
 775                (inst fstd result-real)))
 776             (t
 777              ;; Value is not in ST0.
 778              (inst fxch value-real)
 779              (inst fstd (make-ea-for-raw-slot object index tmp 4))
 780              (cond ((zerop (tn-offset result-real))
 781                     ;; The result is in ST0.
 782                     (inst fstd value-real))
 783                    (t
 784                     ;; Neither value or result are in ST0
 785                     (unless (location= value-real result-real)
 786                       (inst fstd result-real))
 787                     (inst fxch value-real))))))
 788     (let ((value-imag (complex-double-reg-imag-tn value))
 789           (result-imag (complex-double-reg-imag-tn result)))
 790       (inst fxch value-imag)
 791       (inst fstd (make-ea-for-raw-slot object index tmp 2))
 792       (unless (location= value-imag result-imag)
 793         (inst fstd result-imag))
 794       (inst fxch value-imag))))