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