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 #!+sb-thread
 202 (define-vop (boundp)
 203   (:translate boundp)
 204   (:policy :fast-safe)
 205   (:args (object :scs (descriptor-reg)))
 206   (:conditional :ne)
 207   (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
 208   (:generator 9
 209     (let ((check-unbound-label (gen-label)))
 210       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
 211       (inst mov value
 212             (make-ea :qword :base thread-base-tn :index value :scale 1))
 213       (inst cmp value no-tls-value-marker-widetag)
 214       (inst jmp :ne check-unbound-label)
 215       (loadw value object symbol-value-slot other-pointer-lowtag)
 216       (emit-label check-unbound-label)
 217       (inst cmp value unbound-marker-widetag))))
 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   (:generator 9
 226     (inst cmp (make-ea-for-object-slot object symbol-value-slot
 227                                        other-pointer-lowtag)
 228           unbound-marker-widetag)))
 229
 230
 231 (define-vop (symbol-hash)
 232   (:policy :fast-safe)
 233   (:translate symbol-hash)
 234   (:args (symbol :scs (descriptor-reg)))
 235   (:results (res :scs (any-reg)))
 236   (:result-types positive-fixnum)
 237   (:generator 2
 238     ;; The symbol-hash slot of NIL holds NIL because it is also the
 239     ;; cdr slot, so we have to strip off the three low bits to make sure
 240     ;; it is a fixnum.  The lowtag selection magic that is required to
 241     ;; ensure this is explained in the comment in objdef.lisp
 242     (loadw res symbol symbol-hash-slot other-pointer-lowtag)
 243     (inst and res (lognot #b111))))
 244 \f
 245 ;;;; fdefinition (FDEFN) objects
 246
 247 (define-vop (fdefn-fun cell-ref)        ; /pfw - alpha
 248   (:variant fdefn-fun-slot other-pointer-lowtag))
 249
 250 (define-vop (safe-fdefn-fun)
 251   (:args (object :scs (descriptor-reg) :to (:result 1)))
 252   (:results (value :scs (descriptor-reg any-reg)))
 253   (:vop-var vop)
 254   (:save-p :compute-only)
 255   (:generator 10
 256     (loadw value object fdefn-fun-slot other-pointer-lowtag)
 257     (inst cmp value nil-value)
 258     (let ((err-lab (generate-error-code vop 'undefined-fun-error object)))
 259       (inst jmp :e err-lab))))
 260
 261 (define-vop (set-fdefn-fun)
 262   (:policy :fast-safe)
 263   (:translate (setf fdefn-fun))
 264   (:args (function :scs (descriptor-reg) :target result)
 265          (fdefn :scs (descriptor-reg)))
 266   (:temporary (:sc unsigned-reg) raw)
 267   (:temporary (:sc byte-reg) type)
 268   (:results (result :scs (descriptor-reg)))
 269   (:generator 38
 270     (load-type type function (- fun-pointer-lowtag))
 271     (inst lea raw
 272           (make-ea :byte :base function
 273                    :disp (- (* simple-fun-code-offset n-word-bytes)
 274                             fun-pointer-lowtag)))
 275     (inst cmp type simple-fun-header-widetag)
 276     (inst jmp :e NORMAL-FUN)
 277     (inst lea raw (make-fixup "closure_tramp" :foreign))
 278     NORMAL-FUN
 279     (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
 280     (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
 281     (move result function)))
 282
 283 (define-vop (fdefn-makunbound)
 284   (:policy :fast-safe)
 285   (:translate fdefn-makunbound)
 286   (:args (fdefn :scs (descriptor-reg) :target result))
 287   (:results (result :scs (descriptor-reg)))
 288   (:generator 38
 289     (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
 290     (storew (make-fixup "undefined_tramp" :foreign)
 291             fdefn fdefn-raw-addr-slot other-pointer-lowtag)
 292     (move result fdefn)))
 293 \f
 294 ;;;; binding and unbinding
 295
 296 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
 297 ;;; the symbol on the binding stack and stuff the new value into the
 298 ;;; symbol.
 299
 300 #!+sb-thread
 301 (define-vop (bind)
 302   (:args (val :scs (any-reg descriptor-reg))
 303          (symbol :scs (descriptor-reg)))
 304   (:temporary (:sc unsigned-reg) tls-index bsp)
 305   (:generator 10
 306     (let ((tls-index-valid (gen-label)))
 307       (load-binding-stack-pointer bsp)
 308       (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 309       (inst add bsp (* binding-size n-word-bytes))
 310       (store-binding-stack-pointer bsp)
 311       (inst or tls-index tls-index)
 312       (inst jmp :ne tls-index-valid)
 313       (inst mov tls-index symbol)
 314       (inst lea temp-reg-tn
 315             (make-ea :qword :disp
 316                      (make-fixup (ecase (tn-offset tls-index)
 317                                    (#.rax-offset 'alloc-tls-index-in-rax)
 318                                    (#.rcx-offset 'alloc-tls-index-in-rcx)
 319                                    (#.rdx-offset 'alloc-tls-index-in-rdx)
 320                                    (#.rbx-offset 'alloc-tls-index-in-rbx)
 321                                    (#.rsi-offset 'alloc-tls-index-in-rsi)
 322                                    (#.rdi-offset 'alloc-tls-index-in-rdi)
 323                                    (#.r8-offset  'alloc-tls-index-in-r8)
 324                                    (#.r9-offset  'alloc-tls-index-in-r9)
 325                                    (#.r10-offset 'alloc-tls-index-in-r10)
 326                                    (#.r12-offset 'alloc-tls-index-in-r12)
 327                                    (#.r13-offset 'alloc-tls-index-in-r13)
 328                                    (#.r14-offset 'alloc-tls-index-in-r14)
 329                                    (#.r15-offset 'alloc-tls-index-in-r15))
 330                                  :assembly-routine)))
 331       (inst call temp-reg-tn)
 332       (emit-label tls-index-valid)
 333       (inst push (make-ea :qword :base thread-base-tn :scale 1 :index tls-index))
 334       (popw bsp (- binding-value-slot binding-size))
 335       (storew symbol bsp (- binding-symbol-slot binding-size))
 336       (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
 337             val))))
 338
 339 #!-sb-thread
 340 (define-vop (bind)
 341   (:args (val :scs (any-reg descriptor-reg))
 342          (symbol :scs (descriptor-reg)))
 343   (:temporary (:sc unsigned-reg) temp bsp)
 344   (:generator 5
 345     (load-symbol-value bsp *binding-stack-pointer*)
 346     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
 347     (inst add bsp (* binding-size n-word-bytes))
 348     (store-symbol-value bsp *binding-stack-pointer*)
 349     (storew temp bsp (- binding-value-slot binding-size))
 350     (storew symbol bsp (- binding-symbol-slot binding-size))
 351     (storew val symbol symbol-value-slot other-pointer-lowtag)))
 352
 353 #!+sb-thread
 354 (define-vop (unbind)
 355   (:temporary (:sc unsigned-reg) temp bsp tls-index)
 356   (:generator 0
 357     (load-binding-stack-pointer bsp)
 358     ;; Load SYMBOL from stack, and get the TLS-INDEX
 359     (loadw temp bsp (- binding-symbol-slot binding-size))
 360     (loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag)
 361     ;; Load VALUE from stack, the restore it to the TLS area.
 362     (loadw temp bsp (- binding-value-slot binding-size))
 363     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
 364           temp)
 365     ;; Zero out the stack.
 366     (storew 0 bsp (- binding-symbol-slot binding-size))
 367     (storew 0 bsp (- binding-value-slot binding-size))
 368     (inst sub bsp (* binding-size n-word-bytes))
 369     (store-binding-stack-pointer bsp)))
 370
 371 #!-sb-thread
 372 (define-vop (unbind)
 373   (:temporary (:sc unsigned-reg) symbol value bsp)
 374   (:generator 0
 375     (load-symbol-value bsp *binding-stack-pointer*)
 376     (loadw symbol bsp (- binding-symbol-slot binding-size))
 377     (loadw value bsp (- binding-value-slot binding-size))
 378     (storew value symbol symbol-value-slot other-pointer-lowtag)
 379     (storew 0 bsp (- binding-symbol-slot binding-size))
 380     (storew 0 bsp (- binding-value-slot binding-size))
 381     (inst sub bsp (* binding-size n-word-bytes))
 382     (store-symbol-value bsp *binding-stack-pointer*)))
 383
 384 (define-vop (unbind-to-here)
 385   (:args (where :scs (descriptor-reg any-reg)))
 386   (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index)
 387   (:generator 0
 388     (load-binding-stack-pointer bsp)
 389     (inst cmp where bsp)
 390     (inst jmp :e DONE)
 391
 392     LOOP
 393     (loadw symbol bsp (- binding-symbol-slot binding-size))
 394     (inst or symbol symbol)
 395     (inst jmp :z SKIP)
 396     ;; Bind stack debug sentinels have the unbound marker in the symbol slot
 397     (inst cmp symbol unbound-marker-widetag)
 398     (inst jmp :eq SKIP)
 399     (loadw value bsp (- binding-value-slot binding-size))
 400     #!-sb-thread
 401     (storew value symbol symbol-value-slot other-pointer-lowtag)
 402     #!+sb-thread
 403     (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 404     #!+sb-thread
 405     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
 406           value)
 407     (storew 0 bsp (- binding-symbol-slot binding-size))
 408
 409     SKIP
 410     (storew 0 bsp (- binding-value-slot binding-size))
 411     (inst sub bsp (* binding-size n-word-bytes))
 412     (inst cmp where bsp)
 413     (inst jmp :ne LOOP)
 414     (store-binding-stack-pointer bsp)
 415
 416     DONE))
 417
 418 (define-vop (bind-sentinel)
 419   (:temporary (:sc unsigned-reg) bsp)
 420   (:generator 1
 421      (load-binding-stack-pointer bsp)
 422      (inst add bsp (* binding-size n-word-bytes))
 423      (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
 424      (storew rbp-tn bsp (- binding-value-slot binding-size))
 425      (store-binding-stack-pointer bsp)))
 426
 427 (define-vop (unbind-sentinel)
 428   (:temporary (:sc unsigned-reg) bsp)
 429   (:generator 1
 430      (load-binding-stack-pointer bsp)
 431      (storew 0 bsp (- binding-value-slot binding-size))
 432      (storew 0 bsp (- binding-symbol-slot binding-size))
 433      (inst sub bsp (* binding-size n-word-bytes))
 434      (store-binding-stack-pointer bsp)))
 435
 436 \f
 437
 438 \f
 439 ;;;; closure indexing
 440
 441 (define-full-reffer closure-index-ref *
 442   closure-info-offset fun-pointer-lowtag
 443   (any-reg descriptor-reg) * %closure-index-ref)
 444
 445 (define-full-setter set-funcallable-instance-info *
 446   funcallable-instance-info-offset fun-pointer-lowtag
 447   (any-reg descriptor-reg) * %set-funcallable-instance-info)
 448
 449 (define-full-reffer funcallable-instance-info *
 450   funcallable-instance-info-offset fun-pointer-lowtag
 451   (descriptor-reg any-reg) * %funcallable-instance-info)
 452
 453 (define-vop (closure-ref slot-ref)
 454   (:variant closure-info-offset fun-pointer-lowtag))
 455
 456 (define-vop (closure-init slot-set)
 457   (:variant closure-info-offset fun-pointer-lowtag))
 458 \f
 459 ;;;; value cell hackery
 460
 461 (define-vop (value-cell-ref cell-ref)
 462   (:variant value-cell-value-slot other-pointer-lowtag))
 463
 464 (define-vop (value-cell-set cell-set)
 465   (:variant value-cell-value-slot other-pointer-lowtag))
 466 \f
 467 ;;;; structure hackery
 468
 469 (define-vop (instance-length)
 470   (:policy :fast-safe)
 471   (:translate %instance-length)
 472   (:args (struct :scs (descriptor-reg)))
 473   (:results (res :scs (unsigned-reg)))
 474   (:result-types positive-fixnum)
 475   (:generator 4
 476     (loadw res struct 0 instance-pointer-lowtag)
 477     (inst shr res n-widetag-bits)))
 478
 479 (define-full-reffer instance-index-ref * instance-slots-offset
 480   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
 481
 482 (define-full-setter instance-index-set * instance-slots-offset
 483   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
 484
 485 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
 486   instance-slots-offset instance-pointer-lowtag
 487   (any-reg descriptor-reg) *
 488   %compare-and-swap-instance-ref)
 489 \f
 490 ;;;; code object frobbing
 491
 492 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
 493   (any-reg descriptor-reg) * code-header-ref)
 494
 495 (define-full-setter code-header-set * 0 other-pointer-lowtag
 496   (any-reg descriptor-reg) * code-header-set)
 497 \f
 498 ;;;; raw instance slot accessors
 499
 500 (defun make-ea-for-raw-slot (object index instance-length
 501                              &optional (adjustment 0))
 502   (if (integerp instance-length)
 503       ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
 504       ;; at compile time.
 505       (make-ea :qword
 506                :base object
 507                :disp (+ (* (- instance-length instance-slots-offset index)
 508                            n-word-bytes)
 509                         (- instance-pointer-lowtag)
 510                         adjustment))
 511       (etypecase index
 512         (tn
 513          (make-ea :qword :base object :index instance-length
 514                   :disp (+ (* (1- instance-slots-offset) n-word-bytes)
 515                            (- instance-pointer-lowtag)
 516                            adjustment)))
 517         (integer
 518          (make-ea :qword :base object :index instance-length
 519                   :scale 8
 520                   :disp (+ (* (1- instance-slots-offset) n-word-bytes)
 521                            (- instance-pointer-lowtag)
 522                            adjustment
 523                            (* index (- n-word-bytes))))))))
 524
 525 (define-vop (raw-instance-ref/word)
 526   (:translate %raw-instance-ref/word)
 527   (:policy :fast-safe)
 528   (:args (object :scs (descriptor-reg)) (index :scs (any-reg)))
 529   (:arg-types * tagged-num)
 530   (:temporary (:sc unsigned-reg) tmp)
 531   (:results (value :scs (unsigned-reg)))
 532   (:result-types unsigned-num)
 533   (:generator 5
 534     (loadw tmp object 0 instance-pointer-lowtag)
 535     (inst shr tmp n-widetag-bits)
 536     (inst shl tmp 3)
 537     (inst sub tmp index)
 538     (inst mov value (make-ea-for-raw-slot object index tmp))))
 539
 540 (define-vop (raw-instance-ref-c/word)
 541   (:translate %raw-instance-ref/word)
 542   (:policy :fast-safe)
 543   (:args (object :scs (descriptor-reg)))
 544   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 545                                              #.instance-pointer-lowtag
 546                                              #.instance-slots-offset)))
 547   (:info index)
 548   (:temporary (:sc unsigned-reg) tmp)
 549   (:results (value :scs (unsigned-reg)))
 550   (:result-types unsigned-num)
 551   (:generator 4
 552     (loadw tmp object 0 instance-pointer-lowtag)
 553     (inst shr tmp n-widetag-bits)
 554     (inst mov value (make-ea-for-raw-slot object index tmp))))
 555
 556 (define-vop (raw-instance-set/word)
 557   (:translate %raw-instance-set/word)
 558   (:policy :fast-safe)
 559   (:args (object :scs (descriptor-reg))
 560          (index :scs (any-reg))
 561          (value :scs (unsigned-reg) :target result))
 562   (:arg-types * tagged-num unsigned-num)
 563   (:temporary (:sc unsigned-reg) tmp)
 564   (:results (result :scs (unsigned-reg)))
 565   (:result-types unsigned-num)
 566   (:generator 5
 567     (loadw tmp object 0 instance-pointer-lowtag)
 568     (inst shr tmp n-widetag-bits)
 569     (inst shl tmp 3)
 570     (inst sub tmp index)
 571     (inst mov (make-ea-for-raw-slot object index tmp) value)
 572     (move result value)))
 573
 574 (define-vop (raw-instance-set-c/word)
 575   (:translate %raw-instance-set/word)
 576   (:policy :fast-safe)
 577   (:args (object :scs (descriptor-reg))
 578          (value :scs (unsigned-reg) :target result))
 579   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 580                                              #.instance-pointer-lowtag
 581                                              #.instance-slots-offset))
 582               unsigned-num)
 583   (:info index)
 584   (:temporary (:sc unsigned-reg) tmp)
 585   (:results (result :scs (unsigned-reg)))
 586   (:result-types unsigned-num)
 587   (:generator 4
 588     (loadw tmp object 0 instance-pointer-lowtag)
 589     (inst shr tmp n-widetag-bits)
 590     (inst mov (make-ea-for-raw-slot object index tmp) value)
 591     (move result value)))
 592
 593 (define-vop (raw-instance-init/word)
 594   (:args (object :scs (descriptor-reg))
 595          (value :scs (unsigned-reg)))
 596   (:arg-types * unsigned-num)
 597   (:info instance-length index)
 598   (:generator 4
 599     (inst mov (make-ea-for-raw-slot object index instance-length) value)))
 600
 601 (define-vop (raw-instance-atomic-incf-c/word)
 602   (:translate %raw-instance-atomic-incf/word)
 603   (:policy :fast-safe)
 604   (:args (object :scs (descriptor-reg))
 605          (diff :scs (signed-reg) :target result))
 606   (:arg-types * (:constant (load/store-index #.n-word-bytes
 607                                              #.instance-pointer-lowtag
 608                                              #.instance-slots-offset))
 609               signed-num)
 610   (:info index)
 611   (:temporary (:sc unsigned-reg) tmp)
 612   (:results (result :scs (unsigned-reg)))
 613   (:result-types unsigned-num)
 614   (:generator 4
 615     (loadw tmp object 0 instance-pointer-lowtag)
 616     (inst shr tmp n-widetag-bits)
 617     (inst xadd (make-ea-for-raw-slot object index tmp) diff :lock)
 618     (move result diff)))
 619
 620 (define-vop (raw-instance-ref/single)
 621   (:translate %raw-instance-ref/single)
 622   (:policy :fast-safe)
 623   (:args (object :scs (descriptor-reg))
 624          (index :scs (any-reg)))
 625   (:arg-types * positive-fixnum)
 626   (:temporary (:sc unsigned-reg) tmp)
 627   (:results (value :scs (single-reg)))
 628   (:result-types single-float)
 629   (:generator 5
 630     (loadw tmp object 0 instance-pointer-lowtag)
 631     (inst shr tmp n-widetag-bits)
 632     (inst shl tmp 3)
 633     (inst sub tmp index)
 634     (inst movss value (make-ea-for-raw-slot object index tmp))))
 635
 636 (define-vop (raw-instance-ref-c/single)
 637   (:translate %raw-instance-ref/single)
 638   (:policy :fast-safe)
 639   (:args (object :scs (descriptor-reg)))
 640   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 641                                              #.instance-pointer-lowtag
 642                                              #.instance-slots-offset)))
 643   (:info index)
 644   (:temporary (:sc unsigned-reg) tmp)
 645   (:results (value :scs (single-reg)))
 646   (:result-types single-float)
 647   (:generator 4
 648     (loadw tmp object 0 instance-pointer-lowtag)
 649     (inst shr tmp n-widetag-bits)
 650     (inst movss value (make-ea-for-raw-slot object index tmp))))
 651
 652 (define-vop (raw-instance-set/single)
 653   (:translate %raw-instance-set/single)
 654   (:policy :fast-safe)
 655   (:args (object :scs (descriptor-reg))
 656          (index :scs (any-reg))
 657          (value :scs (single-reg) :target result))
 658   (:arg-types * positive-fixnum single-float)
 659   (:temporary (:sc unsigned-reg) tmp)
 660   (:results (result :scs (single-reg)))
 661   (:result-types single-float)
 662   (:generator 5
 663     (loadw tmp object 0 instance-pointer-lowtag)
 664     (inst shr tmp n-widetag-bits)
 665     (inst shl tmp 3)
 666     (inst sub tmp index)
 667     (inst movss (make-ea-for-raw-slot object index tmp) value)
 668    (unless (location= result value)
 669      (inst movss result value))))
 670
 671 (define-vop (raw-instance-set-c/single)
 672   (:translate %raw-instance-set/single)
 673   (:policy :fast-safe)
 674   (:args (object :scs (descriptor-reg))
 675          (value :scs (single-reg) :target result))
 676   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 677                                              #.instance-pointer-lowtag
 678                                              #.instance-slots-offset))
 679               single-float)
 680   (:info index)
 681   (:temporary (:sc unsigned-reg) tmp)
 682   (:results (result :scs (single-reg)))
 683   (:result-types single-float)
 684   (:generator 4
 685     (loadw tmp object 0 instance-pointer-lowtag)
 686     (inst shr tmp n-widetag-bits)
 687     (inst movss (make-ea-for-raw-slot object index tmp) value)
 688    (unless (location= result value)
 689      (inst movss result value))))
 690
 691 (define-vop (raw-instance-init/single)
 692   (:args (object :scs (descriptor-reg))
 693          (value :scs (single-reg)))
 694   (:arg-types * single-float)
 695   (:info instance-length index)
 696   (:generator 4
 697     (inst movss (make-ea-for-raw-slot object index instance-length) value)))
 698
 699 (define-vop (raw-instance-ref/double)
 700   (:translate %raw-instance-ref/double)
 701   (:policy :fast-safe)
 702   (:args (object :scs (descriptor-reg))
 703          (index :scs (any-reg)))
 704   (:arg-types * positive-fixnum)
 705   (:temporary (:sc unsigned-reg) tmp)
 706   (:results (value :scs (double-reg)))
 707   (:result-types double-float)
 708   (:generator 5
 709     (loadw tmp object 0 instance-pointer-lowtag)
 710     (inst shr tmp n-widetag-bits)
 711     (inst shl tmp 3)
 712     (inst sub tmp index)
 713     (inst movsd value (make-ea-for-raw-slot object index tmp))))
 714
 715 (define-vop (raw-instance-ref-c/double)
 716   (:translate %raw-instance-ref/double)
 717   (:policy :fast-safe)
 718   (:args (object :scs (descriptor-reg)))
 719   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 720                                              #.instance-pointer-lowtag
 721                                              #.instance-slots-offset)))
 722   (:info index)
 723   (:temporary (:sc unsigned-reg) tmp)
 724   (:results (value :scs (double-reg)))
 725   (:result-types double-float)
 726   (:generator 4
 727     (loadw tmp object 0 instance-pointer-lowtag)
 728     (inst shr tmp n-widetag-bits)
 729     (inst movsd value (make-ea-for-raw-slot object index tmp))))
 730
 731 (define-vop (raw-instance-set/double)
 732   (:translate %raw-instance-set/double)
 733   (:policy :fast-safe)
 734   (:args (object :scs (descriptor-reg))
 735          (index :scs (any-reg))
 736          (value :scs (double-reg) :target result))
 737   (:arg-types * positive-fixnum double-float)
 738   (:temporary (:sc unsigned-reg) tmp)
 739   (:results (result :scs (double-reg)))
 740   (:result-types double-float)
 741   (:generator 5
 742     (loadw tmp object 0 instance-pointer-lowtag)
 743     (inst shr tmp n-widetag-bits)
 744     (inst shl tmp 3)
 745     (inst sub tmp index)
 746     (inst movsd (make-ea-for-raw-slot object index tmp) value)
 747    (unless (location= result value)
 748      (inst movsd result value))))
 749
 750 (define-vop (raw-instance-set-c/double)
 751   (:translate %raw-instance-set/double)
 752   (:policy :fast-safe)
 753   (:args (object :scs (descriptor-reg))
 754          (value :scs (double-reg) :target result))
 755   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 756                                              #.instance-pointer-lowtag
 757                                              #.instance-slots-offset))
 758               double-float)
 759   (:info index)
 760   (:temporary (:sc unsigned-reg) tmp)
 761   (:results (result :scs (double-reg)))
 762   (:result-types double-float)
 763   (:generator 4
 764     (loadw tmp object 0 instance-pointer-lowtag)
 765     (inst shr tmp n-widetag-bits)
 766     (inst movsd (make-ea-for-raw-slot object index tmp) value)
 767    (unless (location= result value)
 768      (inst movsd result value))))
 769
 770 (define-vop (raw-instance-init/double)
 771   (:args (object :scs (descriptor-reg))
 772          (value :scs (double-reg)))
 773   (:arg-types * double-float)
 774   (:info instance-length index)
 775   (:generator 4
 776     (inst movsd (make-ea-for-raw-slot object index instance-length) value)))
 777
 778 (define-vop (raw-instance-ref/complex-single)
 779   (:translate %raw-instance-ref/complex-single)
 780   (:policy :fast-safe)
 781   (:args (object :scs (descriptor-reg))
 782          (index :scs (any-reg)))
 783   (:arg-types * positive-fixnum)
 784   (:temporary (:sc unsigned-reg) tmp)
 785   (:results (value :scs (complex-single-reg)))
 786   (:result-types complex-single-float)
 787   (:generator 5
 788     (loadw tmp object 0 instance-pointer-lowtag)
 789     (inst shr tmp n-widetag-bits)
 790     (inst shl tmp 3)
 791     (inst sub tmp index)
 792     (let ((real-tn (complex-single-reg-real-tn value)))
 793       (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
 794     (let ((imag-tn (complex-single-reg-imag-tn value)))
 795       (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
 796
 797 (define-vop (raw-instance-ref-c/complex-single)
 798   (:translate %raw-instance-ref/complex-single)
 799   (:policy :fast-safe)
 800   (:args (object :scs (descriptor-reg)))
 801   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 802                                              #.instance-pointer-lowtag
 803                                              #.instance-slots-offset)))
 804   (:info index)
 805   (:temporary (:sc unsigned-reg) tmp)
 806   (:results (value :scs (complex-single-reg)))
 807   (:result-types complex-single-float)
 808   (:generator 4
 809     (loadw tmp object 0 instance-pointer-lowtag)
 810     (inst shr tmp n-widetag-bits)
 811     (let ((real-tn (complex-single-reg-real-tn value)))
 812       (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
 813     (let ((imag-tn (complex-single-reg-imag-tn value)))
 814       (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
 815
 816 (define-vop (raw-instance-set/complex-single)
 817   (:translate %raw-instance-set/complex-single)
 818   (:policy :fast-safe)
 819   (:args (object :scs (descriptor-reg))
 820          (index :scs (any-reg))
 821          (value :scs (complex-single-reg) :target result))
 822   (:arg-types * positive-fixnum complex-single-float)
 823   (:temporary (:sc unsigned-reg) tmp)
 824   (:results (result :scs (complex-single-reg)))
 825   (:result-types complex-single-float)
 826   (:generator 5
 827     (loadw tmp object 0 instance-pointer-lowtag)
 828     (inst shr tmp n-widetag-bits)
 829     (inst shl tmp 3)
 830     (inst sub tmp index)
 831     (let ((value-real (complex-single-reg-real-tn value))
 832           (result-real (complex-single-reg-real-tn result)))
 833       (inst movss (make-ea-for-raw-slot object index tmp) value-real)
 834       (unless (location= value-real result-real)
 835         (inst movss result-real value-real)))
 836     (let ((value-imag (complex-single-reg-imag-tn value))
 837           (result-imag (complex-single-reg-imag-tn result)))
 838       (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
 839       (unless (location= value-imag result-imag)
 840         (inst movss result-imag value-imag)))))
 841
 842 (define-vop (raw-instance-set-c/complex-single)
 843   (:translate %raw-instance-set/complex-single)
 844   (:policy :fast-safe)
 845   (:args (object :scs (descriptor-reg))
 846          (value :scs (complex-single-reg) :target result))
 847   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 848                                              #.instance-pointer-lowtag
 849                                              #.instance-slots-offset))
 850               complex-single-float)
 851   (:info index)
 852   (:temporary (:sc unsigned-reg) tmp)
 853   (:results (result :scs (complex-single-reg)))
 854   (:result-types complex-single-float)
 855   (:generator 4
 856     (loadw tmp object 0 instance-pointer-lowtag)
 857     (inst shr tmp n-widetag-bits)
 858     (let ((value-real (complex-single-reg-real-tn value))
 859           (result-real (complex-single-reg-real-tn result)))
 860       (inst movss (make-ea-for-raw-slot object index tmp) value-real)
 861       (unless (location= value-real result-real)
 862         (inst movss result-real value-real)))
 863     (let ((value-imag (complex-single-reg-imag-tn value))
 864           (result-imag (complex-single-reg-imag-tn result)))
 865       (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
 866       (unless (location= value-imag result-imag)
 867         (inst movss result-imag value-imag)))))
 868
 869 (define-vop (raw-instance-init/complex-single)
 870   (:args (object :scs (descriptor-reg))
 871          (value :scs (complex-single-reg)))
 872   (:arg-types * complex-single-float)
 873   (:info instance-length index)
 874   (:generator 4
 875     (let ((value-real (complex-single-reg-real-tn value)))
 876       (inst movss (make-ea-for-raw-slot object index instance-length) value-real))
 877     (let ((value-imag (complex-single-reg-imag-tn value)))
 878       (inst movss (make-ea-for-raw-slot object index instance-length 4) value-imag))))
 879
 880 (define-vop (raw-instance-ref/complex-double)
 881   (:translate %raw-instance-ref/complex-double)
 882   (:policy :fast-safe)
 883   (:args (object :scs (descriptor-reg))
 884          (index :scs (any-reg)))
 885   (:arg-types * positive-fixnum)
 886   (:temporary (:sc unsigned-reg) tmp)
 887   (:results (value :scs (complex-double-reg)))
 888   (:result-types complex-double-float)
 889   (:generator 5
 890     (loadw tmp object 0 instance-pointer-lowtag)
 891     (inst shr tmp n-widetag-bits)
 892     (inst shl tmp 3)
 893     (inst sub tmp index)
 894     (let ((real-tn (complex-double-reg-real-tn value)))
 895       (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
 896     (let ((imag-tn (complex-double-reg-imag-tn value)))
 897       (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
 898
 899 (define-vop (raw-instance-ref-c/complex-double)
 900   (:translate %raw-instance-ref/complex-double)
 901   (:policy :fast-safe)
 902   (:args (object :scs (descriptor-reg)))
 903   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 904                                              #.instance-pointer-lowtag
 905                                              #.instance-slots-offset)))
 906   (:info index)
 907   (:temporary (:sc unsigned-reg) tmp)
 908   (:results (value :scs (complex-double-reg)))
 909   (:result-types complex-double-float)
 910   (:generator 4
 911     (loadw tmp object 0 instance-pointer-lowtag)
 912     (inst shr tmp n-widetag-bits)
 913     (let ((real-tn (complex-double-reg-real-tn value)))
 914       (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
 915     (let ((imag-tn (complex-double-reg-imag-tn value)))
 916       (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
 917
 918 (define-vop (raw-instance-set/complex-double)
 919   (:translate %raw-instance-set/complex-double)
 920   (:policy :fast-safe)
 921   (:args (object :scs (descriptor-reg))
 922          (index :scs (any-reg))
 923          (value :scs (complex-double-reg) :target result))
 924   (:arg-types * positive-fixnum complex-double-float)
 925   (:temporary (:sc unsigned-reg) tmp)
 926   (:results (result :scs (complex-double-reg)))
 927   (:result-types complex-double-float)
 928   (:generator 5
 929     (loadw tmp object 0 instance-pointer-lowtag)
 930     (inst shr tmp n-widetag-bits)
 931     (inst shl tmp 3)
 932     (inst sub tmp index)
 933     (let ((value-real (complex-double-reg-real-tn value))
 934           (result-real (complex-double-reg-real-tn result)))
 935       (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
 936       (unless (location= value-real result-real)
 937         (inst movsd result-real value-real)))
 938     (let ((value-imag (complex-double-reg-imag-tn value))
 939           (result-imag (complex-double-reg-imag-tn result)))
 940       (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
 941       (unless (location= value-imag result-imag)
 942         (inst movsd result-imag value-imag)))))
 943
 944 (define-vop (raw-instance-set-c/complex-double)
 945   (:translate %raw-instance-set/complex-double)
 946   (:policy :fast-safe)
 947   (:args (object :scs (descriptor-reg))
 948          (value :scs (complex-double-reg) :target result))
 949   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
 950                                              #.instance-pointer-lowtag
 951                                              #.instance-slots-offset))
 952               complex-double-float)
 953   (:info index)
 954   (:temporary (:sc unsigned-reg) tmp)
 955   (:results (result :scs (complex-double-reg)))
 956   (:result-types complex-double-float)
 957   (:generator 4
 958     (loadw tmp object 0 instance-pointer-lowtag)
 959     (inst shr tmp n-widetag-bits)
 960     (let ((value-real (complex-double-reg-real-tn value))
 961           (result-real (complex-double-reg-real-tn result)))
 962       (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
 963       (unless (location= value-real result-real)
 964         (inst movsd result-real value-real)))
 965     (let ((value-imag (complex-double-reg-imag-tn value))
 966           (result-imag (complex-double-reg-imag-tn result)))
 967       (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
 968       (unless (location= value-imag result-imag)
 969         (inst movsd result-imag value-imag)))))
 970
 971 (define-vop (raw-instance-init/complex-double)
 972   (:args (object :scs (descriptor-reg))
 973          (value :scs (complex-double-reg)))
 974   (:arg-types * complex-double-float)
 975   (:info instance-length index)
 976   (:generator 4
 977     (let ((value-real (complex-double-reg-real-tn value)))
 978       (inst movsd (make-ea-for-raw-slot object index instance-length -8) value-real))
 979     (let ((value-imag (complex-double-reg-imag-tn value)))
 980       (inst movsd (make-ea-for-raw-slot object index instance-length) value-imag))))