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