src/compiler/ppc/cell.lisp

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