src/compiler/x86/cell.lisp

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