src/compiler/alpha/cell.lisp

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