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 #!+sb-thread
 232 (define-vop (bind)
 233   (:args (val :scs (any-reg descriptor-reg))
 234          (symbol :scs (descriptor-reg)))
 235   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
 236   (:temporary (:scs (descriptor-reg)) temp tls-index)
 237   (:generator 5
 238      (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 239      (inst cmpwi tls-index 0)
 240      (inst bne TLS-VALID)
 241
 242      ;; No TLS slot allocated, so allocate one.
 243      (pseudo-atomic (pa-flag)
 244        (without-scheduling ()
 245          (assemble ()
 246            (inst li temp (+ (static-symbol-offset '*tls-index-lock*)
 247                             (ash symbol-value-slot word-shift)
 248                             (- other-pointer-lowtag)))
 249            OBTAIN-LOCK
 250            (inst lwarx tls-index null-tn temp)
 251            (inst cmpwi tls-index 0)
 252            (inst bne OBTAIN-LOCK)
 253            (inst stwcx. thread-base-tn null-tn temp)
 254            (inst bne OBTAIN-LOCK)
 255            (inst isync)
 256
 257            ;; Check to see if the TLS index was set while we were waiting.
 258            (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 259            (inst cmpwi tls-index 0)
 260            (inst bne RELEASE-LOCK)
 261
 262            (load-symbol-value tls-index *free-tls-index*)
 263            ;; FIXME: Check for TLS index overflow.
 264            (inst addi tls-index tls-index n-word-bytes)
 265            (store-symbol-value tls-index *free-tls-index*)
 266            (inst addi tls-index tls-index (- n-word-bytes))
 267            (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
 268
 269            ;; The sync instruction doesn't need to happen if we branch
 270            ;; directly to RELEASE-LOCK as we didn't do any stores in that
 271            ;; case.
 272            (inst sync)
 273            RELEASE-LOCK
 274            (inst stwx zero-tn null-tn temp)
 275
 276            ;; temp is a boxed register, but we've been storing crap in it.
 277            ;; fix it before we leave pseudo-atomic.
 278            (inst li temp 0))))
 279
 280      TLS-VALID
 281      (inst lwzx temp thread-base-tn tls-index)
 282      (inst addi bsp-tn bsp-tn (* 2 n-word-bytes))
 283      (storew temp bsp-tn (- binding-value-slot binding-size))
 284      (storew symbol bsp-tn (- binding-symbol-slot binding-size))
 285      (inst stwx val thread-base-tn tls-index)))
 286
 287 #!-sb-thread
 288 (define-vop (bind)
 289   (:args (val :scs (any-reg descriptor-reg))
 290          (symbol :scs (descriptor-reg)))
 291   (:temporary (:scs (descriptor-reg)) temp)
 292   (:generator 5
 293     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
 294     (inst addi bsp-tn bsp-tn (* 2 n-word-bytes))
 295     (storew temp bsp-tn (- binding-value-slot binding-size))
 296     (storew symbol bsp-tn (- binding-symbol-slot binding-size))
 297     (storew val symbol symbol-value-slot other-pointer-lowtag)))
 298
 299 #!+sb-thread
 300 (define-vop (unbind)
 301   (:temporary (:scs (descriptor-reg)) tls-index value)
 302   (:generator 0
 303     (loadw tls-index bsp-tn (- binding-symbol-slot binding-size))
 304     (loadw tls-index tls-index symbol-tls-index-slot other-pointer-lowtag)
 305     (loadw value bsp-tn (- binding-value-slot binding-size))
 306     (inst stwx value thread-base-tn tls-index)
 307     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 308     (storew zero-tn bsp-tn (- binding-value-slot binding-size))
 309     (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))))
 310
 311 #!-sb-thread
 312 (define-vop (unbind)
 313   (:temporary (:scs (descriptor-reg)) symbol value)
 314   (:generator 0
 315     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
 316     (loadw value bsp-tn (- binding-value-slot binding-size))
 317     (storew value symbol symbol-value-slot other-pointer-lowtag)
 318     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 319     (storew zero-tn bsp-tn (- binding-value-slot binding-size))
 320     (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))))
 321
 322
 323 (define-vop (unbind-to-here)
 324   (:args (arg :scs (descriptor-reg any-reg) :target where))
 325   (:temporary (:scs (any-reg) :from (:argument 0)) where)
 326   (:temporary (:scs (descriptor-reg)) symbol value)
 327   (:generator 0
 328     (let ((loop (gen-label))
 329           (skip (gen-label))
 330           (done (gen-label)))
 331       (move where arg)
 332       (inst cmpw where bsp-tn)
 333       (inst beq done)
 334
 335       (emit-label loop)
 336       (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
 337       (inst cmpwi symbol 0)
 338       (inst beq skip)
 339       (loadw value bsp-tn (- binding-value-slot binding-size))
 340       #!+sb-thread
 341       (loadw symbol symbol symbol-tls-index-slot other-pointer-lowtag)
 342       #!+sb-thread
 343       (inst stwx value thread-base-tn symbol)
 344       #!-sb-thread
 345       (storew value symbol symbol-value-slot other-pointer-lowtag)
 346       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 347
 348       (emit-label skip)
 349       (storew zero-tn bsp-tn (- binding-value-slot binding-size))
 350       (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))
 351       (inst cmpw where bsp-tn)
 352       (inst bne loop)
 353
 354       (emit-label done))))
 355
 356
 357 \f
 358 ;;;; Closure indexing.
 359
 360 (define-vop (closure-index-ref word-index-ref)
 361   (:variant closure-info-offset fun-pointer-lowtag)
 362   (:translate %closure-index-ref))
 363
 364 (define-vop (funcallable-instance-info word-index-ref)
 365   (:variant funcallable-instance-info-offset fun-pointer-lowtag)
 366   (:translate %funcallable-instance-info))
 367
 368 (define-vop (set-funcallable-instance-info word-index-set)
 369   (:variant funcallable-instance-info-offset fun-pointer-lowtag)
 370   (:translate %set-funcallable-instance-info))
 371
 372 (define-vop (closure-ref slot-ref)
 373   (:variant closure-info-offset fun-pointer-lowtag))
 374
 375 (define-vop (closure-init slot-set)
 376   (:variant closure-info-offset fun-pointer-lowtag))
 377
 378 \f
 379 ;;;; Value Cell hackery.
 380
 381 (define-vop (value-cell-ref cell-ref)
 382   (:variant value-cell-value-slot other-pointer-lowtag))
 383
 384 (define-vop (value-cell-set cell-set)
 385   (:variant value-cell-value-slot other-pointer-lowtag))
 386
 387
 388 \f
 389 ;;;; Instance hackery:
 390
 391 (define-vop (instance-length)
 392   (:policy :fast-safe)
 393   (:translate %instance-length)
 394   (:args (struct :scs (descriptor-reg)))
 395   (:temporary (:scs (non-descriptor-reg)) temp)
 396   (:results (res :scs (unsigned-reg)))
 397   (:result-types positive-fixnum)
 398   (:generator 4
 399     (loadw temp struct 0 instance-pointer-lowtag)
 400     (inst srwi res temp n-widetag-bits)))
 401
 402 (define-vop (instance-index-ref word-index-ref)
 403   (:policy :fast-safe)
 404   (:translate %instance-ref)
 405   (:variant instance-slots-offset instance-pointer-lowtag)
 406   (:arg-types instance positive-fixnum))
 407
 408 (define-vop (instance-index-set word-index-set)
 409   (:policy :fast-safe)
 410   (:translate %instance-set)
 411   (:variant instance-slots-offset instance-pointer-lowtag)
 412   (:arg-types instance positive-fixnum *))
 413
 414
 415
 416 \f
 417 ;;;; Code object frobbing.
 418
 419 (define-vop (code-header-ref word-index-ref)
 420   (:translate code-header-ref)
 421   (:policy :fast-safe)
 422   (:variant 0 other-pointer-lowtag))
 423
 424 (define-vop (code-header-set word-index-set)
 425   (:translate code-header-set)
 426   (:policy :fast-safe)
 427   (:variant 0 other-pointer-lowtag))
 428
 429
 430 \f
 431 ;;;; raw instance slot accessors
 432
 433 (defun offset-for-raw-slot (instance-length index n-words)
 434   (+ (* (- instance-length instance-slots-offset index (1- n-words))
 435         n-word-bytes)
 436      (- instance-pointer-lowtag)))
 437
 438 (define-vop (raw-instance-init/word)
 439   (:args (object :scs (descriptor-reg))
 440          (value :scs (unsigned-reg)))
 441   (:arg-types * unsigned-num)
 442   (:info instance-length index)
 443   (:generator 4
 444     (inst stw value object (offset-for-raw-slot instance-length index 1))))
 445
 446 (define-vop (raw-instance-ref/word)
 447   (:translate %raw-instance-ref/word)
 448   (:policy :fast-safe)
 449   (:args (object :scs (descriptor-reg))
 450          (index :scs (any-reg)))
 451   (:arg-types * positive-fixnum)
 452   (:results (value :scs (unsigned-reg)))
 453   (:temporary (:scs (non-descriptor-reg)) offset)
 454   (:result-types unsigned-num)
 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 lwzx value object offset)))
 466
 467 (define-vop (raw-instance-set/word)
 468   (:translate %raw-instance-set/word)
 469   (:policy :fast-safe)
 470   (:args (object :scs (descriptor-reg))
 471          (index :scs (any-reg))
 472          (value :scs (unsigned-reg)))
 473   (:arg-types * positive-fixnum unsigned-num)
 474   (:results (result :scs (unsigned-reg)))
 475   (:temporary (:scs (non-descriptor-reg)) offset)
 476   (:result-types unsigned-num)
 477   (:generator 5
 478     (loadw offset object 0 instance-pointer-lowtag)
 479     ;; offset = (offset >> n-widetag-bits) << 2
 480     (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
 481     (inst subf offset index offset)
 482     (inst addi
 483           offset
 484           offset
 485           (- (* (1- instance-slots-offset) n-word-bytes)
 486              instance-pointer-lowtag))
 487     (inst stwx value object offset)
 488     (move result value)))
 489
 490 (define-vop (raw-instance-init/single)
 491   (:args (object :scs (descriptor-reg))
 492          (value :scs (single-reg)))
 493   (:arg-types * single-float)
 494   (:info instance-length index)
 495   (:generator 4
 496     (inst stfs value object (offset-for-raw-slot instance-length index 1))))
 497
 498 (define-vop (raw-instance-ref/single)
 499   (:translate %raw-instance-ref/single)
 500   (:policy :fast-safe)
 501   (:args (object :scs (descriptor-reg))
 502          (index :scs (any-reg)))
 503   (:arg-types * positive-fixnum)
 504   (:results (value :scs (single-reg)))
 505   (:temporary (:scs (non-descriptor-reg)) offset)
 506   (:result-types single-float)
 507   (:generator 5
 508     (loadw offset object 0 instance-pointer-lowtag)
 509     ;; offset = (offset >> n-widetag-bits) << 2
 510     (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
 511     (inst subf offset index offset)
 512     (inst addi
 513           offset
 514           offset
 515           (- (* (1- instance-slots-offset) n-word-bytes)
 516              instance-pointer-lowtag))
 517     (inst lfsx value object offset)))
 518
 519 (define-vop (raw-instance-set/single)
 520   (:translate %raw-instance-set/single)
 521   (:policy :fast-safe)
 522   (:args (object :scs (descriptor-reg))
 523          (index :scs (any-reg))
 524          (value :scs (single-reg) :target result))
 525   (:arg-types * positive-fixnum single-float)
 526   (:results (result :scs (single-reg)))
 527   (:result-types single-float)
 528   (:temporary (:scs (non-descriptor-reg)) offset)
 529   (:generator 5
 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     (inst stfsx value object offset)
 540     (unless (location= result value)
 541       (inst frsp result value))))
 542
 543 (define-vop (raw-instance-init/double)
 544   (:args (object :scs (descriptor-reg))
 545          (value :scs (double-reg)))
 546   (:arg-types * double-float)
 547   (:info instance-length index)
 548   (:generator 4
 549     (inst stfd value object (offset-for-raw-slot instance-length index 2))))
 550
 551 (define-vop (raw-instance-ref/double)
 552   (:translate %raw-instance-ref/double)
 553   (:policy :fast-safe)
 554   (:args (object :scs (descriptor-reg))
 555          (index :scs (any-reg)))
 556   (:arg-types * positive-fixnum)
 557   (:results (value :scs (double-reg)))
 558   (:temporary (:scs (non-descriptor-reg)) offset)
 559   (:result-types double-float)
 560   (:generator 5
 561     (loadw offset object 0 instance-pointer-lowtag)
 562     ;; offset = (offset >> n-widetag-bits) << 2
 563     (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
 564     (inst subf offset index offset)
 565     (inst addi
 566           offset
 567           offset
 568           (- (* (- instance-slots-offset 2) n-word-bytes)
 569              instance-pointer-lowtag))
 570     (inst lfdx value object offset)))
 571
 572 (define-vop (raw-instance-set/double)
 573   (:translate %raw-instance-set/double)
 574   (:policy :fast-safe)
 575   (:args (object :scs (descriptor-reg))
 576          (index :scs (any-reg))
 577          (value :scs (double-reg) :target result))
 578   (:arg-types * positive-fixnum double-float)
 579   (:results (result :scs (double-reg)))
 580   (:result-types double-float)
 581   (:temporary (:scs (non-descriptor-reg)) offset)
 582   (:generator 5
 583     (loadw offset object 0 instance-pointer-lowtag)
 584     ;; offset = (offset >> n-widetag-bits) << 2
 585     (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
 586     (inst subf offset index offset)
 587     (inst addi
 588           offset
 589           offset
 590           (- (* (- instance-slots-offset 2) n-word-bytes)
 591              instance-pointer-lowtag))
 592     (inst stfdx value object offset)
 593     (unless (location= result value)
 594       (inst fmr result value))))
 595
 596 (define-vop (raw-instance-init/complex-single)
 597   (:args (object :scs (descriptor-reg))
 598          (value :scs (complex-single-reg)))
 599   (:arg-types * complex-single-float)
 600   (:info instance-length index)
 601   (:generator 4
 602     (inst stfs (complex-single-reg-real-tn value)
 603           object (offset-for-raw-slot instance-length index 2))
 604     (inst stfs (complex-single-reg-imag-tn value)
 605           object (offset-for-raw-slot instance-length index 1))))
 606
 607 (define-vop (raw-instance-ref/complex-single)
 608   (:translate %raw-instance-ref/complex-single)
 609   (:policy :fast-safe)
 610   (:args (object :scs (descriptor-reg))
 611          (index :scs (any-reg)))
 612   (:arg-types * positive-fixnum)
 613   (:results (value :scs (complex-single-reg)))
 614   (:temporary (:scs (non-descriptor-reg)) offset)
 615   (:result-types complex-single-float)
 616   (:generator 5
 617     (loadw offset object 0 instance-pointer-lowtag)
 618     ;; offset = (offset >> n-widetag-bits) << 2
 619     (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
 620     (inst subf offset index offset)
 621     (inst addi
 622           offset
 623           offset
 624           (- (* (- instance-slots-offset 2) n-word-bytes)
 625              instance-pointer-lowtag))
 626     (inst lfsx (complex-single-reg-real-tn value) object offset)
 627     (inst addi offset offset n-word-bytes)
 628     (inst lfsx (complex-single-reg-imag-tn value) object offset)))
 629
 630 (define-vop (raw-instance-set/complex-single)
 631   (:translate %raw-instance-set/complex-single)
 632   (:policy :fast-safe)
 633   (:args (object :scs (descriptor-reg))
 634          (index :scs (any-reg))
 635          (value :scs (complex-single-reg) :target result))
 636   (:arg-types * positive-fixnum complex-single-float)
 637   (:results (result :scs (complex-single-reg)))
 638   (:result-types complex-single-float)
 639   (:temporary (:scs (non-descriptor-reg)) offset)
 640   (:generator 5
 641     (loadw offset object 0 instance-pointer-lowtag)
 642     ;; offset = (offset >> n-widetag-bits) << 2
 643     (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
 644     (inst subf offset index offset)
 645     (inst addi
 646           offset
 647           offset
 648           (- (* (- instance-slots-offset 2) n-word-bytes)
 649              instance-pointer-lowtag))
 650     (let ((value-real (complex-single-reg-real-tn value))
 651           (result-real (complex-single-reg-real-tn result)))
 652       (inst stfsx value-real object offset)
 653       (unless (location= result-real value-real)
 654         (inst frsp result-real value-real)))
 655     (inst addi offset offset n-word-bytes)
 656     (let ((value-imag (complex-single-reg-imag-tn value))
 657           (result-imag (complex-single-reg-imag-tn result)))
 658       (inst stfsx value-imag object offset)
 659       (unless (location= result-imag value-imag)
 660         (inst frsp result-imag value-imag)))))
 661
 662 (define-vop (raw-instance-init/complex-double)
 663   (:args (object :scs (descriptor-reg))
 664          (value :scs (complex-double-reg)))
 665   (:arg-types * complex-double-float)
 666   (:info instance-length index)
 667   (:generator 4
 668     (inst stfd (complex-single-reg-real-tn value)
 669           object (offset-for-raw-slot instance-length index 4))
 670     (inst stfd (complex-double-reg-imag-tn value)
 671           object (offset-for-raw-slot instance-length index 2))))
 672
 673 (define-vop (raw-instance-ref/complex-double)
 674   (:translate %raw-instance-ref/complex-double)
 675   (:policy :fast-safe)
 676   (:args (object :scs (descriptor-reg))
 677          (index :scs (any-reg)))
 678   (:arg-types * positive-fixnum)
 679   (:results (value :scs (complex-double-reg)))
 680   (:temporary (:scs (non-descriptor-reg)) offset)
 681   (:result-types complex-double-float)
 682   (:generator 5
 683     (loadw offset object 0 instance-pointer-lowtag)
 684     ;; offset = (offset >> n-widetag-bits) << 2
 685     (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
 686     (inst subf offset index offset)
 687     (inst addi
 688           offset
 689           offset
 690           (- (* (- instance-slots-offset 4) n-word-bytes)
 691              instance-pointer-lowtag))
 692     (inst lfdx (complex-double-reg-real-tn value) object offset)
 693     (inst addi offset offset (* 2 n-word-bytes))
 694     (inst lfdx (complex-double-reg-imag-tn value) object offset)))
 695
 696 (define-vop (raw-instance-set/complex-double)
 697   (:translate %raw-instance-set/complex-double)
 698   (:policy :fast-safe)
 699   (:args (object :scs (descriptor-reg))
 700          (index :scs (any-reg))
 701          (value :scs (complex-double-reg) :target result))
 702   (:arg-types * positive-fixnum complex-double-float)
 703   (:results (result :scs (complex-double-reg)))
 704   (:result-types complex-double-float)
 705   (:temporary (:scs (non-descriptor-reg)) offset)
 706   (:generator 5
 707     (loadw offset object 0 instance-pointer-lowtag)
 708     ;; offset = (offset >> n-widetag-bits) << 2
 709     (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
 710     (inst subf offset index offset)
 711     (inst addi
 712           offset
 713           offset
 714           (- (* (- instance-slots-offset 4) n-word-bytes)
 715              instance-pointer-lowtag))
 716     (let ((value-real (complex-double-reg-real-tn value))
 717           (result-real (complex-double-reg-real-tn result)))
 718       (inst stfdx value-real object offset)
 719       (unless (location= result-real value-real)
 720         (inst fmr result-real value-real)))
 721     (inst addi offset offset (* 2 n-word-bytes))
 722     (let ((value-imag (complex-double-reg-imag-tn value))
 723           (result-imag (complex-double-reg-imag-tn result)))
 724       (inst stfdx value-imag object offset)
 725       (unless (location= result-imag value-imag)
 726         (inst fmr result-imag value-imag)))))