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