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