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