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