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