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