src/compiler/x86-64/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   (:temporary (:sc descriptor-reg) temp)
  28   (:info name offset lowtag)
  29   (:ignore name)
  30   (:results)
  31   (:generator 1
  32     (if (sc-is value immediate)
  33         (let ((val (tn-value value)))
  34           (move-immediate (make-ea :qword
  35                                    :base object
  36                                    :disp (- (* offset n-word-bytes)
  37                                             lowtag))
  38                           (etypecase val
  39                             (integer
  40                              (fixnumize val))
  41                             (symbol
  42                              (+ nil-value (static-symbol-offset val)))
  43                             (character
  44                              (logior (ash (char-code val) n-widetag-bits)
  45                                      character-widetag)))
  46                           temp))
  47         ;; Else, value not immediate.
  48         (storew value object offset lowtag))))
  49
  50 (define-vop (compare-and-swap-slot)
  51   (:args (object :scs (descriptor-reg) :to :eval)
  52          (old :scs (descriptor-reg any-reg) :target rax)
  53          (new :scs (descriptor-reg any-reg)))
  54   (:temporary (:sc descriptor-reg :offset rax-offset
  55                    :from (:argument 1) :to :result :target result)
  56               rax)
  57   (:info name offset lowtag)
  58   (:ignore name)
  59   (:results (result :scs (descriptor-reg any-reg)))
  60   (:generator 5
  61      (move rax old)
  62      (inst cmpxchg (make-ea :qword :base object
  63                             :disp (- (* offset n-word-bytes) lowtag))
  64            new :lock)
  65      (move result rax)))
  66 \f
  67 ;;;; symbol hacking VOPs
  68
  69 (define-vop (%compare-and-swap-symbol-value)
  70   (:translate %compare-and-swap-symbol-value)
  71   (:args (symbol :scs (descriptor-reg) :to (:result 1))
  72          (old :scs (descriptor-reg any-reg) :target rax)
  73          (new :scs (descriptor-reg any-reg)))
  74   (:temporary (:sc descriptor-reg :offset rax-offset) rax)
  75   #!+sb-thread
  76   (:temporary (:sc descriptor-reg) tls)
  77   (:results (result :scs (descriptor-reg any-reg)))
  78   (:policy :fast-safe)
  79   (:vop-var vop)
  80   (:generator 15
  81     ;; This code has two pathological cases: NO-TLS-VALUE-MARKER
  82     ;; or UNBOUND-MARKER as NEW: in either case we would end up
  83     ;; doing possible damage with CMPXCHG -- so don't do that!
  84     (let ((unbound (generate-error-code vop 'unbound-symbol-error symbol))
  85           (check (gen-label)))
  86       (move rax old)
  87       #!+sb-thread
  88       (progn
  89         (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
  90         ;; Thread-local area, no LOCK needed.
  91         (inst cmpxchg (make-ea :qword :base thread-base-tn
  92                                :index tls :scale 1)
  93               new)
  94         (inst cmp rax no-tls-value-marker-widetag)
  95         (inst jmp :ne check)
  96         (move rax old))
  97       (inst cmpxchg (make-ea :qword :base symbol
  98                              :disp (- (* symbol-value-slot n-word-bytes)
  99                                       other-pointer-lowtag)
 100                              :scale 1)
 101             new :lock)
 102       (emit-label check)
 103       (move result rax)
 104       (inst cmp result unbound-marker-widetag)
 105       (inst jmp :e unbound))))
 106
 107 ;;; these next two cf the sparc version, by jrd.
 108 ;;; FIXME: Deref this ^ reference.
 109
 110
 111 ;;; The compiler likes to be able to directly SET symbols.
 112 #!+sb-thread
 113 (define-vop (set)
 114   (:args (symbol :scs (descriptor-reg))
 115          (value :scs (descriptor-reg any-reg)))
 116   (:temporary (:sc descriptor-reg) tls)
 117   ;;(:policy :fast-safe)
 118   (:generator 4
 119     (let ((global-val (gen-label))
 120           (done (gen-label)))
 121       (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
 122       (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls)
 123             no-tls-value-marker-widetag)
 124       (inst jmp :z global-val)
 125       (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls)
 126             value)
 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 ;; unithreaded it's a lot simpler ...
 133 #!-sb-thread
 134 (define-vop (set cell-set)
 135   (:variant symbol-value-slot other-pointer-lowtag))
 136
 137 ;;; With Symbol-Value, we check that the value isn't the trap object. So
 138 ;;; Symbol-Value of NIL is NIL.
 139 #!+sb-thread
 140 (define-vop (symbol-value)
 141   (:translate symbol-value)
 142   (:policy :fast-safe)
 143   (:args (object :scs (descriptor-reg) :to (:result 1)))
 144   (:results (value :scs (descriptor-reg any-reg)))
 145   (:vop-var vop)
 146   (:save-p :compute-only)
 147   (:generator 9
 148     (let* ((check-unbound-label (gen-label))
 149            (err-lab (generate-error-code vop 'unbound-symbol-error object))
 150            (ret-lab (gen-label)))
 151       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
 152       (inst mov value (make-ea :qword :base thread-base-tn
 153                                :index value :scale 1))
 154       (inst cmp value no-tls-value-marker-widetag)
 155       (inst jmp :ne check-unbound-label)
 156       (loadw value object symbol-value-slot other-pointer-lowtag)
 157       (emit-label check-unbound-label)
 158       (inst cmp value unbound-marker-widetag)
 159       (inst jmp :e err-lab)
 160       (emit-label ret-lab))))
 161
 162 #!+sb-thread
 163 (define-vop (fast-symbol-value symbol-value)
 164   ;; KLUDGE: not really fast, in fact, because we're going to have to
 165   ;; do a full lookup of the thread-local area anyway.  But half of
 166   ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
 167   ;; unbound", which is used in the implementation of COPY-SYMBOL.  --
 168   ;; CSR, 2003-04-22
 169   (:policy :fast)
 170   (:translate symbol-value)
 171   (:generator 8
 172     (let ((ret-lab (gen-label)))
 173       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
 174       (inst mov value
 175             (make-ea :qword :base thread-base-tn :index value :scale 1))
 176       (inst cmp value no-tls-value-marker-widetag)
 177       (inst jmp :ne ret-lab)
 178       (loadw value object symbol-value-slot other-pointer-lowtag)
 179       (emit-label ret-lab))))
 180
 181 #!-sb-thread
 182 (define-vop (symbol-value)
 183   (:translate symbol-value)
 184   (:policy :fast-safe)
 185   (:args (object :scs (descriptor-reg) :to (:result 1)))
 186   (:results (value :scs (descriptor-reg any-reg)))
 187   (:vop-var vop)
 188   (:save-p :compute-only)
 189   (:generator 9
 190     (let ((err-lab (generate-error-code vop 'unbound-symbol-error object)))
 191       (loadw value object symbol-value-slot other-pointer-lowtag)
 192       (inst cmp value unbound-marker-widetag)
 193       (inst jmp :e err-lab))))
 194
 195 #!-sb-thread
 196 (define-vop (fast-symbol-value cell-ref)
 197   (:variant symbol-value-slot other-pointer-lowtag)
 198   (:policy :fast)
 199   (:translate symbol-value))
 200
 201 (defknown locked-symbol-global-value-add (symbol fixnum) fixnum ())
 202
 203 (define-vop (locked-symbol-global-value-add)
 204     (:args (object :scs (descriptor-reg) :to :result)
 205            (value :scs (any-reg) :target result))
 206   (:arg-types * tagged-num)
 207   (:results (result :scs (any-reg) :from (:argument 1)))
 208   (:policy :fast)
 209   (:translate locked-symbol-global-value-add)
 210   (:result-types tagged-num)
 211   (:policy :fast-safe)
 212   (:generator 4
 213     (move result value)
 214     (inst add (make-ea :qword :base object
 215                        :disp (- (* symbol-value-slot n-word-bytes)
 216                                 other-pointer-lowtag))
 217           value :lock)))
 218
 219 #!+sb-thread
 220 (define-vop (boundp)
 221   (:translate boundp)
 222   (:policy :fast-safe)
 223   (:args (object :scs (descriptor-reg)))
 224   (:conditional :ne)
 225   (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
 226   (:generator 9
 227     (let ((check-unbound-label (gen-label)))
 228       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
 229       (inst mov value
 230             (make-ea :qword :base thread-base-tn :index value :scale 1))
 231       (inst cmp value no-tls-value-marker-widetag)
 232       (inst jmp :ne check-unbound-label)
 233       (loadw value object symbol-value-slot other-pointer-lowtag)
 234       (emit-label check-unbound-label)
 235       (inst cmp value unbound-marker-widetag))))
 236
 237 #!-sb-thread
 238 (define-vop (boundp)
 239   (:translate boundp)
 240   (:policy :fast-safe)
 241   (:args (object :scs (descriptor-reg)))
 242   (:conditional :ne)
 243   (:generator 9
 244     (inst cmp (make-ea-for-object-slot object symbol-value-slot
 245                                        other-pointer-lowtag)
 246           unbound-marker-widetag)))
 247
 248
 249 (define-vop (symbol-hash)
 250   (:policy :fast-safe)
 251   (:translate symbol-hash)
 252   (:args (symbol :scs (descriptor-reg)))
 253   (:results (res :scs (any-reg)))
 254   (:result-types positive-fixnum)
 255   (:generator 2
 256     ;; The symbol-hash slot of NIL holds NIL because it is also the
 257     ;; cdr slot, so we have to strip off the three low bits to make sure
 258     ;; it is a fixnum.  The lowtag selection magic that is required to
 259     ;; ensure this is explained in the comment in objdef.lisp
 260     (loadw res symbol symbol-hash-slot other-pointer-lowtag)
 261     (inst and res (lognot #b111))))
 262 \f
 263 ;;;; fdefinition (FDEFN) objects
 264
 265 (define-vop (fdefn-fun cell-ref)        ; /pfw - alpha
 266   (:variant fdefn-fun-slot other-pointer-lowtag))
 267
 268 (define-vop (safe-fdefn-fun)
 269   (:args (object :scs (descriptor-reg) :to (:result 1)))
 270   (:results (value :scs (descriptor-reg any-reg)))
 271   (:vop-var vop)
 272   (:save-p :compute-only)
 273   (:generator 10
 274     (loadw value object fdefn-fun-slot other-pointer-lowtag)
 275     (inst cmp value nil-value)
 276     (let ((err-lab (generate-error-code vop 'undefined-fun-error object)))
 277       (inst jmp :e err-lab))))
 278
 279 (define-vop (set-fdefn-fun)
 280   (:policy :fast-safe)
 281   (:translate (setf fdefn-fun))
 282   (:args (function :scs (descriptor-reg) :target result)
 283          (fdefn :scs (descriptor-reg)))
 284   (:temporary (:sc unsigned-reg) raw)
 285   (:temporary (:sc byte-reg) type)
 286   (:results (result :scs (descriptor-reg)))
 287   (:generator 38
 288     (load-type type function (- fun-pointer-lowtag))
 289     (inst lea raw
 290           (make-ea :byte :base function
 291                    :disp (- (* simple-fun-code-offset n-word-bytes)
 292                             fun-pointer-lowtag)))
 293     (inst cmp type simple-fun-header-widetag)
 294     (inst jmp :e NORMAL-FUN)
 295     (inst lea raw (make-fixup "closure_tramp" :foreign))
 296     NORMAL-FUN
 297     (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
 298     (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
 299     (move result function)))
 300
 301 (define-vop (fdefn-makunbound)
 302   (:policy :fast-safe)
 303   (:translate fdefn-makunbound)
 304   (:args (fdefn :scs (descriptor-reg) :target result))
 305   (:results (result :scs (descriptor-reg)))
 306   (:generator 38
 307     (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
 308     (storew (make-fixup "undefined_tramp" :foreign)
 309             fdefn fdefn-raw-addr-slot other-pointer-lowtag)
 310     (move result fdefn)))
 311 \f
 312 ;;;; binding and unbinding
 313
 314 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
 315 ;;; the symbol on the binding stack and stuff the new value into the
 316 ;;; symbol.
 317
 318 #!+sb-thread
 319 (define-vop (bind)
 320   (:args (val :scs (any-reg descriptor-reg))
 321          (symbol :scs (descriptor-reg)))
 322   (:temporary (:sc unsigned-reg) tls-index bsp)
 323   (:generator 10
 324     (let ((tls-index-valid (gen-label)))
 325       (load-binding-stack-pointer bsp)
 326       (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 327       (inst add bsp (* binding-size n-word-bytes))
 328       (store-binding-stack-pointer bsp)
 329       (inst or tls-index tls-index)
 330       (inst jmp :ne tls-index-valid)
 331       (inst mov tls-index symbol)
 332       (inst lea temp-reg-tn
 333             (make-ea :qword :disp
 334                      (make-fixup (ecase (tn-offset tls-index)
 335                                    (#.rax-offset 'alloc-tls-index-in-rax)
 336                                    (#.rcx-offset 'alloc-tls-index-in-rcx)
 337                                    (#.rdx-offset 'alloc-tls-index-in-rdx)
 338                                    (#.rbx-offset 'alloc-tls-index-in-rbx)
 339                                    (#.rsi-offset 'alloc-tls-index-in-rsi)
 340                                    (#.rdi-offset 'alloc-tls-index-in-rdi)
 341                                    (#.r8-offset  'alloc-tls-index-in-r8)
 342                                    (#.r9-offset  'alloc-tls-index-in-r9)
 343                                    (#.r10-offset 'alloc-tls-index-in-r10)
 344                                    (#.r12-offset 'alloc-tls-index-in-r12)
 345                                    (#.r13-offset 'alloc-tls-index-in-r13)
 346                                    (#.r14-offset 'alloc-tls-index-in-r14)
 347                                    (#.r15-offset 'alloc-tls-index-in-r15))
 348                                  :assembly-routine)))
 349       (inst call temp-reg-tn)
 350       (emit-label tls-index-valid)
 351       (inst push (make-ea :qword :base thread-base-tn :scale 1 :index tls-index))
 352       (popw bsp (- binding-value-slot binding-size))
 353       (storew symbol bsp (- binding-symbol-slot binding-size))
 354       (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
 355             val))))
 356
 357 #!-sb-thread
 358 (define-vop (bind)
 359   (:args (val :scs (any-reg descriptor-reg))
 360          (symbol :scs (descriptor-reg)))
 361   (:temporary (:sc unsigned-reg) temp bsp)
 362   (:generator 5
 363     (load-symbol-value bsp *binding-stack-pointer*)
 364     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
 365     (inst add bsp (* binding-size n-word-bytes))
 366     (store-symbol-value bsp *binding-stack-pointer*)
 367     (storew temp bsp (- binding-value-slot binding-size))
 368     (storew symbol bsp (- binding-symbol-slot binding-size))
 369     (storew val symbol symbol-value-slot other-pointer-lowtag)))
 370
 371 #!+sb-thread
 372 (define-vop (unbind)
 373   (:temporary (:sc unsigned-reg) temp bsp tls-index)
 374   (:generator 0
 375     (load-binding-stack-pointer bsp)
 376     ;; Load SYMBOL from stack, and get the TLS-INDEX
 377     (loadw temp bsp (- binding-symbol-slot binding-size))
 378     (loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag)
 379     ;; Load VALUE from stack, the restore it to the TLS area.
 380     (loadw temp bsp (- binding-value-slot binding-size))
 381     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
 382           temp)
 383     ;; Zero out the stack.
 384     (storew 0 bsp (- binding-symbol-slot binding-size))
 385     (storew 0 bsp (- binding-value-slot binding-size))
 386     (inst sub bsp (* binding-size n-word-bytes))
 387     (store-binding-stack-pointer bsp)))
 388
 389 #!-sb-thread
 390 (define-vop (unbind)
 391   (:temporary (:sc unsigned-reg) symbol value bsp)
 392   (:generator 0
 393     (load-symbol-value bsp *binding-stack-pointer*)
 394     (loadw symbol bsp (- binding-symbol-slot binding-size))
 395     (loadw value bsp (- binding-value-slot binding-size))
 396     (storew value symbol symbol-value-slot other-pointer-lowtag)
 397     (storew 0 bsp (- binding-symbol-slot binding-size))
 398     (storew 0 bsp (- binding-value-slot binding-size))
 399     (inst sub bsp (* binding-size n-word-bytes))
 400     (store-symbol-value bsp *binding-stack-pointer*)))
 401
 402 (define-vop (unbind-to-here)
 403   (:args (where :scs (descriptor-reg any-reg)))
 404   (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index)
 405   (:generator 0
 406     (load-binding-stack-pointer bsp)
 407     (inst cmp where bsp)
 408     (inst jmp :e DONE)
 409
 410     LOOP
 411     (loadw symbol bsp (- binding-symbol-slot binding-size))
 412     (inst or symbol symbol)
 413     (inst jmp :z SKIP)
 414     ;; Bind stack debug sentinels have the unbound marker in the symbol slot
 415     (inst cmp symbol unbound-marker-widetag)
 416     (inst jmp :eq SKIP)
 417     (loadw value bsp (- binding-value-slot binding-size))
 418     #!-sb-thread
 419     (storew value symbol symbol-value-slot other-pointer-lowtag)
 420     #!+sb-thread
 421     (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 422     #!+sb-thread
 423     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
 424           value)
 425     (storew 0 bsp (- binding-symbol-slot binding-size))
 426
 427     SKIP
 428     (storew 0 bsp (- binding-value-slot binding-size))
 429     (inst sub bsp (* binding-size n-word-bytes))
 430     (inst cmp where bsp)
 431     (inst jmp :ne LOOP)
 432     (store-binding-stack-pointer bsp)
 433
 434     DONE))
 435
 436 (define-vop (bind-sentinel)
 437   (:temporary (:sc unsigned-reg) bsp)
 438   (:generator 1
 439      (load-binding-stack-pointer bsp)
 440      (inst add bsp (* binding-size n-word-bytes))
 441      (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
 442      (storew rbp-tn bsp (- binding-value-slot binding-size))
 443      (store-binding-stack-pointer bsp)))
 444
 445 (define-vop (unbind-sentinel)
 446   (:temporary (:sc unsigned-reg) bsp)
 447   (:generator 1
 448      (load-binding-stack-pointer bsp)
 449      (storew 0 bsp (- binding-value-slot binding-size))
 450      (storew 0 bsp (- binding-symbol-slot binding-size))
 451      (inst sub bsp (* binding-size n-word-bytes))
 452      (store-binding-stack-pointer bsp)))
 453
 454 \f
 455
 456 \f
 457 ;;;; closure indexing
 458
 459 (define-full-reffer closure-index-ref *
 460   closure-info-offset fun-pointer-lowtag
 461   (any-reg descriptor-reg) * %closure-index-ref)
 462
 463 (define-full-setter set-funcallable-instance-info *
 464   funcallable-instance-info-offset fun-pointer-lowtag
 465   (any-reg descriptor-reg) * %set-funcallable-instance-info)
 466
 467 (define-full-reffer funcallable-instance-info *
 468   funcallable-instance-info-offset fun-pointer-lowtag
 469   (descriptor-reg any-reg) * %funcallable-instance-info)
 470
 471 (define-vop (closure-ref slot-ref)
 472   (:variant closure-info-offset fun-pointer-lowtag))
 473
 474 (define-vop (closure-init slot-set)
 475   (:variant closure-info-offset fun-pointer-lowtag))
 476 \f
 477 ;;;; value cell hackery
 478
 479 (define-vop (value-cell-ref cell-ref)
 480   (:variant value-cell-value-slot other-pointer-lowtag))
 481
 482 (define-vop (value-cell-set cell-set)
 483   (:variant value-cell-value-slot other-pointer-lowtag))
 484 \f
 485 ;;;; structure hackery
 486
 487 (define-vop (instance-length)
 488   (:policy :fast-safe)
 489   (:translate %instance-length)
 490   (:args (struct :scs (descriptor-reg)))
 491   (:results (res :scs (unsigned-reg)))
 492   (:result-types positive-fixnum)
 493   (:generator 4
 494     (loadw res struct 0 instance-pointer-lowtag)
 495     (inst shr res n-widetag-bits)))
 496
 497 (define-full-reffer instance-index-ref * instance-slots-offset
 498   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
 499
 500 (define-full-setter instance-index-set * instance-slots-offset
 501   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
 502
 503 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
 504   instance-slots-offset instance-pointer-lowtag
 505   (any-reg descriptor-reg) *
 506   %compare-and-swap-instance-ref)
 507 \f
 508 ;;;; code object frobbing
 509
 510 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
 511   (any-reg descriptor-reg) * code-header-ref)
 512
 513 (define-full-setter code-header-set * 0 other-pointer-lowtag
 514   (any-reg descriptor-reg) * code-header-set)
 515 \f
 516 ;;;; raw instance slot accessors
 517
 518 (defun make-ea-for-raw-slot (object index instance-length
 519                              &optional (adjustment 0))
 520   (if (integerp instance-length)
 521       ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
 522       ;; at compile time.
 523       (make-ea :qword
 524                :base object
 525                :disp (+ (* (- instance-length instance-slots-offset index)
 526                            n-word-bytes)
 527                         (- instance-pointer-lowtag)
 528                         adjustment))
 529       (etypecase index
 530         (tn
 531          (make-ea :qword :base object :index instance-length
 532                   :disp (+ (* (1- instance-slots-offset) n-word-bytes)
 533                            (- instance-pointer-lowtag)
 534                            adjustment)))
 535         (integer
 536          (make-ea :qword :base object :index instance-length
 537                   :scale 8
 538                   :disp (+ (* (1- instance-slots-offset) n-word-bytes)
 539                            (- instance-pointer-lowtag)
 540                            adjustment
 541                            (* index (- n-word-bytes))))))))
 542
 543 (define-vop (raw-instance-ref/word)
 544   (:translate %raw-instance-ref/word)
 545   (:policy :fast-safe)
 546   (:args (object :scs (descriptor-reg)) (index :scs (any-reg)))
 547   (:arg-types * tagged-num)
 548   (:temporary (:sc unsigned-reg) tmp)
 549   (:results (value :scs (unsigned-reg)))
 550   (:result-types unsigned-num)
 551   (:generator 5
 552     (loadw tmp object 0 instance-pointer-lowtag)
 553     (inst shr tmp n-widetag-bits)
 554     (inst shl tmp 3)
 555     (inst sub tmp index)
 556     (inst mov value (make-ea-for-raw-slot object index tmp))))
 557
 558 (define-vop (raw-instance-ref-c/word)
 559   (:translate %raw-instance-ref/word)
 560   (:policy :fast-safe)
 561   (:args (object :scs (descriptor-reg)))
 562   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 563                                              #.instance-pointer-lowtag
 564                                              #.instance-slots-offset)))
 565   (:info index)
 566   (:temporary (:sc unsigned-reg) tmp)
 567   (:results (value :scs (unsigned-reg)))
 568   (:result-types unsigned-num)
 569   (:generator 4
 570     (loadw tmp object 0 instance-pointer-lowtag)
 571     (inst shr tmp n-widetag-bits)
 572     (inst mov value (make-ea-for-raw-slot object index tmp))))
 573
 574 (define-vop (raw-instance-set/word)
 575   (:translate %raw-instance-set/word)
 576   (:policy :fast-safe)
 577   (:args (object :scs (descriptor-reg))
 578          (index :scs (any-reg))
 579          (value :scs (unsigned-reg) :target result))
 580   (:arg-types * tagged-num unsigned-num)
 581   (:temporary (:sc unsigned-reg) tmp)
 582   (:results (result :scs (unsigned-reg)))
 583   (:result-types unsigned-num)
 584   (:generator 5
 585     (loadw tmp object 0 instance-pointer-lowtag)
 586     (inst shr tmp n-widetag-bits)
 587     (inst shl tmp 3)
 588     (inst sub tmp index)
 589     (inst mov (make-ea-for-raw-slot object index tmp) value)
 590     (move result value)))
 591
 592 (define-vop (raw-instance-set-c/word)
 593   (:translate %raw-instance-set/word)
 594   (:policy :fast-safe)
 595   (:args (object :scs (descriptor-reg))
 596          (value :scs (unsigned-reg) :target result))
 597   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 598                                              #.instance-pointer-lowtag
 599                                              #.instance-slots-offset))
 600               unsigned-num)
 601   (:info index)
 602   (:temporary (:sc unsigned-reg) tmp)
 603   (:results (result :scs (unsigned-reg)))
 604   (:result-types unsigned-num)
 605   (:generator 4
 606     (loadw tmp object 0 instance-pointer-lowtag)
 607     (inst shr tmp n-widetag-bits)
 608     (inst mov (make-ea-for-raw-slot object index tmp) value)
 609     (move result value)))
 610
 611 (define-vop (raw-instance-init/word)
 612   (:args (object :scs (descriptor-reg))
 613          (value :scs (unsigned-reg)))
 614   (:arg-types * unsigned-num)
 615   (:info instance-length index)
 616   (:generator 4
 617     (inst mov (make-ea-for-raw-slot object index instance-length) value)))
 618
 619 (define-vop (raw-instance-atomic-incf-c/word)
 620   (:translate %raw-instance-atomic-incf/word)
 621   (:policy :fast-safe)
 622   (:args (object :scs (descriptor-reg))
 623          (diff :scs (signed-reg) :target result))
 624   (:arg-types * (:constant (load/store-index #.n-word-bytes
 625                                              #.instance-pointer-lowtag
 626                                              #.instance-slots-offset))
 627               signed-num)
 628   (:info index)
 629   (:temporary (:sc unsigned-reg) tmp)
 630   (:results (result :scs (unsigned-reg)))
 631   (:result-types unsigned-num)
 632   (:generator 4
 633     (loadw tmp object 0 instance-pointer-lowtag)
 634     (inst shr tmp n-widetag-bits)
 635     (inst xadd (make-ea-for-raw-slot object index tmp) diff :lock)
 636     (move result diff)))
 637
 638 (define-vop (raw-instance-ref/single)
 639   (:translate %raw-instance-ref/single)
 640   (:policy :fast-safe)
 641   (:args (object :scs (descriptor-reg))
 642          (index :scs (any-reg)))
 643   (:arg-types * positive-fixnum)
 644   (:temporary (:sc unsigned-reg) tmp)
 645   (:results (value :scs (single-reg)))
 646   (:result-types single-float)
 647   (:generator 5
 648     (loadw tmp object 0 instance-pointer-lowtag)
 649     (inst shr tmp n-widetag-bits)
 650     (inst shl tmp 3)
 651     (inst sub tmp index)
 652     (inst movss value (make-ea-for-raw-slot object index tmp))))
 653
 654 (define-vop (raw-instance-ref-c/single)
 655   (:translate %raw-instance-ref/single)
 656   (:policy :fast-safe)
 657   (:args (object :scs (descriptor-reg)))
 658   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 659                                              #.instance-pointer-lowtag
 660                                              #.instance-slots-offset)))
 661   (:info index)
 662   (:temporary (:sc unsigned-reg) tmp)
 663   (:results (value :scs (single-reg)))
 664   (:result-types single-float)
 665   (:generator 4
 666     (loadw tmp object 0 instance-pointer-lowtag)
 667     (inst shr tmp n-widetag-bits)
 668     (inst movss value (make-ea-for-raw-slot object index tmp))))
 669
 670 (define-vop (raw-instance-set/single)
 671   (:translate %raw-instance-set/single)
 672   (:policy :fast-safe)
 673   (:args (object :scs (descriptor-reg))
 674          (index :scs (any-reg))
 675          (value :scs (single-reg) :target result))
 676   (:arg-types * positive-fixnum single-float)
 677   (:temporary (:sc unsigned-reg) tmp)
 678   (:results (result :scs (single-reg)))
 679   (:result-types single-float)
 680   (:generator 5
 681     (loadw tmp object 0 instance-pointer-lowtag)
 682     (inst shr tmp n-widetag-bits)
 683     (inst shl tmp 3)
 684     (inst sub tmp index)
 685     (inst movss (make-ea-for-raw-slot object index tmp) value)
 686    (unless (location= result value)
 687      (inst movss result value))))
 688
 689 (define-vop (raw-instance-set-c/single)
 690   (:translate %raw-instance-set/single)
 691   (:policy :fast-safe)
 692   (:args (object :scs (descriptor-reg))
 693          (value :scs (single-reg) :target result))
 694   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 695                                              #.instance-pointer-lowtag
 696                                              #.instance-slots-offset))
 697               single-float)
 698   (:info index)
 699   (:temporary (:sc unsigned-reg) tmp)
 700   (:results (result :scs (single-reg)))
 701   (:result-types single-float)
 702   (:generator 4
 703     (loadw tmp object 0 instance-pointer-lowtag)
 704     (inst shr tmp n-widetag-bits)
 705     (inst movss (make-ea-for-raw-slot object index tmp) value)
 706    (unless (location= result value)
 707      (inst movss result value))))
 708
 709 (define-vop (raw-instance-init/single)
 710   (:args (object :scs (descriptor-reg))
 711          (value :scs (single-reg)))
 712   (:arg-types * single-float)
 713   (:info instance-length index)
 714   (:generator 4
 715     (inst movss (make-ea-for-raw-slot object index instance-length) value)))
 716
 717 (define-vop (raw-instance-ref/double)
 718   (:translate %raw-instance-ref/double)
 719   (:policy :fast-safe)
 720   (:args (object :scs (descriptor-reg))
 721          (index :scs (any-reg)))
 722   (:arg-types * positive-fixnum)
 723   (:temporary (:sc unsigned-reg) tmp)
 724   (:results (value :scs (double-reg)))
 725   (:result-types double-float)
 726   (:generator 5
 727     (loadw tmp object 0 instance-pointer-lowtag)
 728     (inst shr tmp n-widetag-bits)
 729     (inst shl tmp 3)
 730     (inst sub tmp index)
 731     (inst movsd value (make-ea-for-raw-slot object index tmp))))
 732
 733 (define-vop (raw-instance-ref-c/double)
 734   (:translate %raw-instance-ref/double)
 735   (:policy :fast-safe)
 736   (:args (object :scs (descriptor-reg)))
 737   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 738                                              #.instance-pointer-lowtag
 739                                              #.instance-slots-offset)))
 740   (:info index)
 741   (:temporary (:sc unsigned-reg) tmp)
 742   (:results (value :scs (double-reg)))
 743   (:result-types double-float)
 744   (:generator 4
 745     (loadw tmp object 0 instance-pointer-lowtag)
 746     (inst shr tmp n-widetag-bits)
 747     (inst movsd value (make-ea-for-raw-slot object index tmp))))
 748
 749 (define-vop (raw-instance-set/double)
 750   (:translate %raw-instance-set/double)
 751   (:policy :fast-safe)
 752   (:args (object :scs (descriptor-reg))
 753          (index :scs (any-reg))
 754          (value :scs (double-reg) :target result))
 755   (:arg-types * positive-fixnum double-float)
 756   (:temporary (:sc unsigned-reg) tmp)
 757   (:results (result :scs (double-reg)))
 758   (:result-types double-float)
 759   (:generator 5
 760     (loadw tmp object 0 instance-pointer-lowtag)
 761     (inst shr tmp n-widetag-bits)
 762     (inst shl tmp 3)
 763     (inst sub tmp index)
 764     (inst movsd (make-ea-for-raw-slot object index tmp) value)
 765    (unless (location= result value)
 766      (inst movsd result value))))
 767
 768 (define-vop (raw-instance-set-c/double)
 769   (:translate %raw-instance-set/double)
 770   (:policy :fast-safe)
 771   (:args (object :scs (descriptor-reg))
 772          (value :scs (double-reg) :target result))
 773   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 774                                              #.instance-pointer-lowtag
 775                                              #.instance-slots-offset))
 776               double-float)
 777   (:info index)
 778   (:temporary (:sc unsigned-reg) tmp)
 779   (:results (result :scs (double-reg)))
 780   (:result-types double-float)
 781   (:generator 4
 782     (loadw tmp object 0 instance-pointer-lowtag)
 783     (inst shr tmp n-widetag-bits)
 784     (inst movsd (make-ea-for-raw-slot object index tmp) value)
 785    (unless (location= result value)
 786      (inst movsd result value))))
 787
 788 (define-vop (raw-instance-init/double)
 789   (:args (object :scs (descriptor-reg))
 790          (value :scs (double-reg)))
 791   (:arg-types * double-float)
 792   (:info instance-length index)
 793   (:generator 4
 794     (inst movsd (make-ea-for-raw-slot object index instance-length) value)))
 795
 796 (define-vop (raw-instance-ref/complex-single)
 797   (:translate %raw-instance-ref/complex-single)
 798   (:policy :fast-safe)
 799   (:args (object :scs (descriptor-reg))
 800          (index :scs (any-reg)))
 801   (:arg-types * positive-fixnum)
 802   (:temporary (:sc unsigned-reg) tmp)
 803   (:results (value :scs (complex-single-reg)))
 804   (:result-types complex-single-float)
 805   (:generator 5
 806     (loadw tmp object 0 instance-pointer-lowtag)
 807     (inst shr tmp n-widetag-bits)
 808     (inst shl tmp 3)
 809     (inst sub tmp index)
 810     (let ((real-tn (complex-single-reg-real-tn value)))
 811       (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
 812     (let ((imag-tn (complex-single-reg-imag-tn value)))
 813       (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
 814
 815 (define-vop (raw-instance-ref-c/complex-single)
 816   (:translate %raw-instance-ref/complex-single)
 817   (:policy :fast-safe)
 818   (:args (object :scs (descriptor-reg)))
 819   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 820                                              #.instance-pointer-lowtag
 821                                              #.instance-slots-offset)))
 822   (:info index)
 823   (:temporary (:sc unsigned-reg) tmp)
 824   (:results (value :scs (complex-single-reg)))
 825   (:result-types complex-single-float)
 826   (:generator 4
 827     (loadw tmp object 0 instance-pointer-lowtag)
 828     (inst shr tmp n-widetag-bits)
 829     (let ((real-tn (complex-single-reg-real-tn value)))
 830       (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
 831     (let ((imag-tn (complex-single-reg-imag-tn value)))
 832       (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
 833
 834 (define-vop (raw-instance-set/complex-single)
 835   (:translate %raw-instance-set/complex-single)
 836   (:policy :fast-safe)
 837   (:args (object :scs (descriptor-reg))
 838          (index :scs (any-reg))
 839          (value :scs (complex-single-reg) :target result))
 840   (:arg-types * positive-fixnum complex-single-float)
 841   (:temporary (:sc unsigned-reg) tmp)
 842   (:results (result :scs (complex-single-reg)))
 843   (:result-types complex-single-float)
 844   (:generator 5
 845     (loadw tmp object 0 instance-pointer-lowtag)
 846     (inst shr tmp n-widetag-bits)
 847     (inst shl tmp 3)
 848     (inst sub tmp index)
 849     (let ((value-real (complex-single-reg-real-tn value))
 850           (result-real (complex-single-reg-real-tn result)))
 851       (inst movss (make-ea-for-raw-slot object index tmp) value-real)
 852       (unless (location= value-real result-real)
 853         (inst movss result-real value-real)))
 854     (let ((value-imag (complex-single-reg-imag-tn value))
 855           (result-imag (complex-single-reg-imag-tn result)))
 856       (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
 857       (unless (location= value-imag result-imag)
 858         (inst movss result-imag value-imag)))))
 859
 860 (define-vop (raw-instance-set-c/complex-single)
 861   (:translate %raw-instance-set/complex-single)
 862   (:policy :fast-safe)
 863   (:args (object :scs (descriptor-reg))
 864          (value :scs (complex-single-reg) :target result))
 865   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 866                                              #.instance-pointer-lowtag
 867                                              #.instance-slots-offset))
 868               complex-single-float)
 869   (:info index)
 870   (:temporary (:sc unsigned-reg) tmp)
 871   (:results (result :scs (complex-single-reg)))
 872   (:result-types complex-single-float)
 873   (:generator 4
 874     (loadw tmp object 0 instance-pointer-lowtag)
 875     (inst shr tmp n-widetag-bits)
 876     (let ((value-real (complex-single-reg-real-tn value))
 877           (result-real (complex-single-reg-real-tn result)))
 878       (inst movss (make-ea-for-raw-slot object index tmp) value-real)
 879       (unless (location= value-real result-real)
 880         (inst movss result-real value-real)))
 881     (let ((value-imag (complex-single-reg-imag-tn value))
 882           (result-imag (complex-single-reg-imag-tn result)))
 883       (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
 884       (unless (location= value-imag result-imag)
 885         (inst movss result-imag value-imag)))))
 886
 887 (define-vop (raw-instance-init/complex-single)
 888   (:args (object :scs (descriptor-reg))
 889          (value :scs (complex-single-reg)))
 890   (:arg-types * complex-single-float)
 891   (:info instance-length index)
 892   (:generator 4
 893     (let ((value-real (complex-single-reg-real-tn value)))
 894       (inst movss (make-ea-for-raw-slot object index instance-length) value-real))
 895     (let ((value-imag (complex-single-reg-imag-tn value)))
 896       (inst movss (make-ea-for-raw-slot object index instance-length 4) value-imag))))
 897
 898 (define-vop (raw-instance-ref/complex-double)
 899   (:translate %raw-instance-ref/complex-double)
 900   (:policy :fast-safe)
 901   (:args (object :scs (descriptor-reg))
 902          (index :scs (any-reg)))
 903   (:arg-types * positive-fixnum)
 904   (:temporary (:sc unsigned-reg) tmp)
 905   (:results (value :scs (complex-double-reg)))
 906   (:result-types complex-double-float)
 907   (:generator 5
 908     (loadw tmp object 0 instance-pointer-lowtag)
 909     (inst shr tmp n-widetag-bits)
 910     (inst shl tmp 3)
 911     (inst sub tmp index)
 912     (let ((real-tn (complex-double-reg-real-tn value)))
 913       (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
 914     (let ((imag-tn (complex-double-reg-imag-tn value)))
 915       (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
 916
 917 (define-vop (raw-instance-ref-c/complex-double)
 918   (:translate %raw-instance-ref/complex-double)
 919   (:policy :fast-safe)
 920   (:args (object :scs (descriptor-reg)))
 921   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 922                                              #.instance-pointer-lowtag
 923                                              #.instance-slots-offset)))
 924   (:info index)
 925   (:temporary (:sc unsigned-reg) tmp)
 926   (:results (value :scs (complex-double-reg)))
 927   (:result-types complex-double-float)
 928   (:generator 4
 929     (loadw tmp object 0 instance-pointer-lowtag)
 930     (inst shr tmp n-widetag-bits)
 931     (let ((real-tn (complex-double-reg-real-tn value)))
 932       (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
 933     (let ((imag-tn (complex-double-reg-imag-tn value)))
 934       (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
 935
 936 (define-vop (raw-instance-set/complex-double)
 937   (:translate %raw-instance-set/complex-double)
 938   (:policy :fast-safe)
 939   (:args (object :scs (descriptor-reg))
 940          (index :scs (any-reg))
 941          (value :scs (complex-double-reg) :target result))
 942   (:arg-types * positive-fixnum complex-double-float)
 943   (:temporary (:sc unsigned-reg) tmp)
 944   (:results (result :scs (complex-double-reg)))
 945   (:result-types complex-double-float)
 946   (:generator 5
 947     (loadw tmp object 0 instance-pointer-lowtag)
 948     (inst shr tmp n-widetag-bits)
 949     (inst shl tmp 3)
 950     (inst sub tmp index)
 951     (let ((value-real (complex-double-reg-real-tn value))
 952           (result-real (complex-double-reg-real-tn result)))
 953       (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
 954       (unless (location= value-real result-real)
 955         (inst movsd result-real value-real)))
 956     (let ((value-imag (complex-double-reg-imag-tn value))
 957           (result-imag (complex-double-reg-imag-tn result)))
 958       (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
 959       (unless (location= value-imag result-imag)
 960         (inst movsd result-imag value-imag)))))
 961
 962 (define-vop (raw-instance-set-c/complex-double)
 963   (:translate %raw-instance-set/complex-double)
 964   (:policy :fast-safe)
 965   (:args (object :scs (descriptor-reg))
 966          (value :scs (complex-double-reg) :target result))
 967   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 968                                              #.instance-pointer-lowtag
 969                                              #.instance-slots-offset))
 970               complex-double-float)
 971   (:info index)
 972   (:temporary (:sc unsigned-reg) tmp)
 973   (:results (result :scs (complex-double-reg)))
 974   (:result-types complex-double-float)
 975   (:generator 4
 976     (loadw tmp object 0 instance-pointer-lowtag)
 977     (inst shr tmp n-widetag-bits)
 978     (let ((value-real (complex-double-reg-real-tn value))
 979           (result-real (complex-double-reg-real-tn result)))
 980       (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
 981       (unless (location= value-real result-real)
 982         (inst movsd result-real value-real)))
 983     (let ((value-imag (complex-double-reg-imag-tn value))
 984           (result-imag (complex-double-reg-imag-tn result)))
 985       (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
 986       (unless (location= value-imag result-imag)
 987         (inst movsd result-imag value-imag)))))
 988
 989 (define-vop (raw-instance-init/complex-double)
 990   (:args (object :scs (descriptor-reg))
 991          (value :scs (complex-double-reg)))
 992   (:arg-types * complex-double-float)
 993   (:info instance-length index)
 994   (:generator 4
 995     (let ((value-real (complex-double-reg-real-tn value)))
 996       (inst movsd (make-ea-for-raw-slot object index instance-length -8) value-real))
 997     (let ((value-imag (complex-double-reg-imag-tn value)))
 998       (inst movsd (make-ea-for-raw-slot object index instance-length) value-imag))))