1.0.28.26: Mr. ATOMIC-INCF/SYMBOL, meet Mr. AX
[sbcl.git] / src / compiler / x86 / cell.lisp
1 ;;;; various primitive memory access VOPs for the x86 VM
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; data object ref/set stuff
15
16 (define-vop (slot)
17   (:args (object :scs (descriptor-reg)))
18   (:info name offset lowtag)
19   (:ignore name)
20   (:results (result :scs (descriptor-reg any-reg)))
21   (:generator 1
22     (loadw result object offset lowtag)))
23
24 (define-vop (set-slot)
25   (:args (object :scs (descriptor-reg))
26          (value :scs (descriptor-reg any-reg immediate)))
27   (:info name offset lowtag)
28   (:ignore name)
29   (:results)
30   (:generator 1
31      (storew (encode-value-if-immediate value) object offset lowtag)))
32
33 (define-vop (compare-and-swap-slot)
34   (:args (object :scs (descriptor-reg) :to :eval)
35          (old :scs (descriptor-reg any-reg) :target eax)
36          (new :scs (descriptor-reg any-reg)))
37   (:temporary (:sc descriptor-reg :offset eax-offset
38                    :from (:argument 1) :to :result :target result)
39               eax)
40   (:info name offset lowtag)
41   (:ignore name)
42   (:results (result :scs (descriptor-reg any-reg)))
43   (:generator 5
44      (move eax old)
45      (inst cmpxchg (make-ea :dword :base object
46                             :disp (- (* offset n-word-bytes) lowtag))
47            new :lock)
48      (move result eax)))
49 \f
50 ;;;; symbol hacking VOPs
51
52 (define-vop (%compare-and-swap-symbol-value)
53   (:translate %compare-and-swap-symbol-value)
54   (:args (symbol :scs (descriptor-reg) :to (:result 1))
55          (old :scs (descriptor-reg any-reg) :target eax)
56          (new :scs (descriptor-reg any-reg)))
57   (:temporary (:sc descriptor-reg :offset eax-offset) eax)
58   #!+sb-thread
59   (:temporary (:sc descriptor-reg) tls)
60   (:results (result :scs (descriptor-reg any-reg)))
61   (:policy :fast-safe)
62   (:vop-var vop)
63   (:generator 15
64     ;; This code has to pathological cases: NO-TLS-VALUE-MARKER
65     ;; or UNBOUND-MARKER as NEW: in either case we would end up
66     ;; doing possible damage with CMPXCHG -- so don't do that!
67     (let ((unbound (generate-error-code vop 'unbound-symbol-error symbol))
68           (check (gen-label)))
69       (move eax old)
70       #!+sb-thread
71       (progn
72         (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
73         ;; Thread-local area, no LOCK needed.
74         (inst cmpxchg (make-ea :dword :base tls) new :fs)
75         (inst cmp eax no-tls-value-marker-widetag)
76         (inst jmp :ne check)
77         (move eax old))
78       (inst cmpxchg (make-ea :dword :base symbol
79                              :disp (- (* symbol-value-slot n-word-bytes)
80                                       other-pointer-lowtag))
81             new :lock)
82       (emit-label check)
83       (move result eax)
84       (inst cmp result unbound-marker-widetag)
85       (inst jmp :e unbound))))
86
87 ;;; these next two cf the sparc version, by jrd.
88 ;;; FIXME: Deref this ^ reference.
89
90
91 ;;; The compiler likes to be able to directly SET symbols.
92 #!+sb-thread
93 (define-vop (set)
94   (:args (symbol :scs (descriptor-reg))
95          (value :scs (descriptor-reg any-reg)))
96   (:temporary (:sc descriptor-reg) tls)
97   ;;(:policy :fast-safe)
98   (:generator 4
99     (let ((global-val (gen-label))
100           (done (gen-label)))
101       (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
102       (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag :fs)
103       (inst jmp :z global-val)
104       (inst mov (make-ea :dword :base tls) value :fs)
105       (inst jmp done)
106       (emit-label global-val)
107       (storew value symbol symbol-value-slot other-pointer-lowtag)
108       (emit-label done))))
109
110 ;; unithreaded it's a lot simpler ...
111 #!-sb-thread
112 (define-vop (set cell-set)
113   (:variant symbol-value-slot other-pointer-lowtag))
114
115 ;;; With Symbol-Value, we check that the value isn't the trap object. So
116 ;;; Symbol-Value of NIL is NIL.
117 #!+sb-thread
118 (define-vop (symbol-value)
119   (:translate symbol-value)
120   (:policy :fast-safe)
121   (:args (object :scs (descriptor-reg) :to (:result 1)))
122   (:results (value :scs (descriptor-reg any-reg)))
123   (:vop-var vop)
124   (:save-p :compute-only)
125   (:generator 9
126     (let* ((check-unbound-label (gen-label))
127            (err-lab (generate-error-code vop 'unbound-symbol-error object))
128            (ret-lab (gen-label)))
129       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
130       (inst mov value (make-ea :dword :base value) :fs)
131       (inst cmp value no-tls-value-marker-widetag)
132       (inst jmp :ne check-unbound-label)
133       (loadw value object symbol-value-slot other-pointer-lowtag)
134       (emit-label check-unbound-label)
135       (inst cmp value unbound-marker-widetag)
136       (inst jmp :e err-lab)
137       (emit-label ret-lab))))
138
139 #!+sb-thread
140 (define-vop (fast-symbol-value symbol-value)
141   ;; KLUDGE: not really fast, in fact, because we're going to have to
142   ;; do a full lookup of the thread-local area anyway.  But half of
143   ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
144   ;; unbound", which is used in the implementation of COPY-SYMBOL.  --
145   ;; CSR, 2003-04-22
146   (:policy :fast)
147   (:translate symbol-value)
148   (:generator 8
149     (let ((ret-lab (gen-label)))
150       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
151       (inst mov value (make-ea :dword :base value) :fs)
152       (inst cmp value no-tls-value-marker-widetag)
153       (inst jmp :ne ret-lab)
154       (loadw value object symbol-value-slot other-pointer-lowtag)
155       (emit-label ret-lab))))
156
157 #!-sb-thread
158 (define-vop (symbol-value)
159   (:translate symbol-value)
160   (:policy :fast-safe)
161   (:args (object :scs (descriptor-reg) :to (:result 1)))
162   (:results (value :scs (descriptor-reg any-reg)))
163   (:vop-var vop)
164   (:save-p :compute-only)
165   (:generator 9
166     (let ((err-lab (generate-error-code vop 'unbound-symbol-error object)))
167       (loadw value object symbol-value-slot other-pointer-lowtag)
168       (inst cmp value unbound-marker-widetag)
169       (inst jmp :e err-lab))))
170
171 #!-sb-thread
172 (define-vop (fast-symbol-value cell-ref)
173   (:variant symbol-value-slot other-pointer-lowtag)
174   (:policy :fast)
175   (:translate symbol-value))
176
177 #!+sb-thread
178 (define-vop (boundp)
179   (:translate boundp)
180   (:policy :fast-safe)
181   (:args (object :scs (descriptor-reg)))
182   (:conditional :ne)
183   (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
184   (:generator 9
185     (let ((check-unbound-label (gen-label)))
186       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
187       (inst mov value (make-ea :dword :base value) :fs)
188       (inst cmp value no-tls-value-marker-widetag)
189       (inst jmp :ne check-unbound-label)
190       (loadw value object symbol-value-slot other-pointer-lowtag)
191       (emit-label check-unbound-label)
192       (inst cmp value unbound-marker-widetag))))
193
194 #!-sb-thread
195 (define-vop (boundp)
196   (:translate boundp)
197   (:policy :fast-safe)
198   (:args (object :scs (descriptor-reg)))
199   (:conditional :ne)
200   (:generator 9
201     (inst cmp (make-ea-for-object-slot object symbol-value-slot
202                                        other-pointer-lowtag)
203           unbound-marker-widetag)))
204
205
206 (define-vop (symbol-hash)
207   (:policy :fast-safe)
208   (:translate symbol-hash)
209   (:args (symbol :scs (descriptor-reg)))
210   (:results (res :scs (any-reg)))
211   (:result-types positive-fixnum)
212   (:generator 2
213     ;; The symbol-hash slot of NIL holds NIL because it is also the
214     ;; cdr slot, so we have to strip off the two low bits to make sure
215     ;; it is a fixnum.  The lowtag selection magic that is required to
216     ;; ensure this is explained in the comment in objdef.lisp
217     (loadw res symbol symbol-hash-slot other-pointer-lowtag)
218     (inst and res (lognot #b11))))
219 \f
220 ;;;; fdefinition (FDEFN) objects
221
222 (define-vop (fdefn-fun cell-ref)        ; /pfw - alpha
223   (:variant fdefn-fun-slot other-pointer-lowtag))
224
225 (define-vop (safe-fdefn-fun)
226   (:args (object :scs (descriptor-reg) :to (:result 1)))
227   (:results (value :scs (descriptor-reg any-reg)))
228   (:vop-var vop)
229   (:save-p :compute-only)
230   (:generator 10
231     (loadw value object fdefn-fun-slot other-pointer-lowtag)
232     (inst cmp value nil-value)
233     (let ((err-lab (generate-error-code vop 'undefined-fun-error object)))
234       (inst jmp :e err-lab))))
235
236 (define-vop (set-fdefn-fun)
237   (:policy :fast-safe)
238   (:translate (setf fdefn-fun))
239   (:args (function :scs (descriptor-reg) :target result)
240          (fdefn :scs (descriptor-reg)))
241   (:temporary (:sc unsigned-reg) raw)
242   (:temporary (:sc byte-reg) type)
243   (:results (result :scs (descriptor-reg)))
244   (:generator 38
245     (load-type type function (- fun-pointer-lowtag))
246     (inst lea raw
247           (make-ea-for-object-slot function simple-fun-code-offset
248                                    fun-pointer-lowtag))
249     (inst cmp type simple-fun-header-widetag)
250     (inst jmp :e normal-fn)
251     (inst lea raw (make-fixup "closure_tramp" :foreign))
252     NORMAL-FN
253     (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
254     (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
255     (move result function)))
256
257 (define-vop (fdefn-makunbound)
258   (:policy :fast-safe)
259   (:translate fdefn-makunbound)
260   (:args (fdefn :scs (descriptor-reg) :target result))
261   (:results (result :scs (descriptor-reg)))
262   (:generator 38
263     (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
264     (storew (make-fixup "undefined_tramp" :foreign)
265             fdefn fdefn-raw-addr-slot other-pointer-lowtag)
266     (move result fdefn)))
267 \f
268 ;;;; binding and unbinding
269
270 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
271 ;;; the symbol on the binding stack and stuff the new value into the
272 ;;; symbol.
273
274 ;;; FIXME: Split into DYNBIND and BIND: DYNBIND needs to ensure
275 ;;; TLS-INDEX, whereas BIND should assume it is already in place. Make
276 ;;; LET &co compile into BIND, and PROGV into DYNBIND, plus ensure
277 ;;; TLS-INDEX at compile-time, and make loader and dumper preserve
278 ;;; the existence of a TLS-INDEX.
279 #!+sb-thread
280 (define-vop (bind)
281   (:args (val :scs (any-reg descriptor-reg))
282          (symbol :scs (descriptor-reg)))
283   (:temporary (:sc unsigned-reg) tls-index bsp)
284   (:generator 10
285     (let ((tls-index-valid (gen-label)))
286       (load-binding-stack-pointer bsp)
287       (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
288       (inst add bsp (* binding-size n-word-bytes))
289       (store-binding-stack-pointer bsp)
290       (inst or tls-index tls-index)
291       (inst jmp :ne tls-index-valid)
292       (inst mov tls-index symbol)
293       (inst call (make-fixup
294                   (ecase (tn-offset tls-index)
295                     (#.eax-offset 'alloc-tls-index-in-eax)
296                     (#.ebx-offset 'alloc-tls-index-in-ebx)
297                     (#.ecx-offset 'alloc-tls-index-in-ecx)
298                     (#.edx-offset 'alloc-tls-index-in-edx)
299                     (#.edi-offset 'alloc-tls-index-in-edi)
300                     (#.esi-offset 'alloc-tls-index-in-esi))
301                   :assembly-routine))
302       (emit-label tls-index-valid)
303       (inst push (make-ea :dword :base tls-index) :fs)
304       (popw bsp (- binding-value-slot binding-size))
305       (storew symbol bsp (- binding-symbol-slot binding-size))
306       (inst mov (make-ea :dword :base tls-index) val :fs))))
307
308 #!-sb-thread
309 (define-vop (bind)
310   (:args (val :scs (any-reg descriptor-reg))
311          (symbol :scs (descriptor-reg)))
312   (:temporary (:sc unsigned-reg) temp bsp)
313   (:generator 5
314     (load-symbol-value bsp *binding-stack-pointer*)
315     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
316     (inst add bsp (* binding-size n-word-bytes))
317     (store-symbol-value bsp *binding-stack-pointer*)
318     (storew temp bsp (- binding-value-slot binding-size))
319     (storew symbol bsp (- binding-symbol-slot binding-size))
320     (storew val symbol symbol-value-slot other-pointer-lowtag)))
321
322 #!+sb-thread
323 (define-vop (unbind)
324   (:temporary (:sc unsigned-reg) temp bsp tls-index)
325   (:generator 0
326     (load-binding-stack-pointer bsp)
327     ;; Load SYMBOL from stack, and get the TLS-INDEX.
328     (loadw temp bsp (- binding-symbol-slot binding-size))
329     (loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag)
330     ;; Load VALUE from stack, then restore it to the TLS area.
331     (loadw temp bsp (- binding-value-slot binding-size))
332     (inst mov (make-ea :dword :base tls-index) temp :fs)
333     ;; Zero out the stack.
334     (storew 0 bsp (- binding-symbol-slot binding-size))
335     (storew 0 bsp (- binding-value-slot binding-size))
336     (inst sub bsp (* binding-size n-word-bytes))
337     (store-binding-stack-pointer bsp)))
338
339 #!-sb-thread
340 (define-vop (unbind)
341   (:temporary (:sc unsigned-reg) symbol value bsp)
342   (:generator 0
343     (load-symbol-value bsp *binding-stack-pointer*)
344     (loadw symbol bsp (- binding-symbol-slot binding-size))
345     (loadw value bsp (- binding-value-slot binding-size))
346     (storew value symbol symbol-value-slot other-pointer-lowtag)
347     (storew 0 bsp (- binding-symbol-slot binding-size))
348     (storew 0 bsp (- binding-value-slot binding-size))
349     (inst sub bsp (* binding-size n-word-bytes))
350     (store-symbol-value bsp *binding-stack-pointer*)))
351
352
353 (define-vop (unbind-to-here)
354   (:args (where :scs (descriptor-reg any-reg)))
355   (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index)
356   (:generator 0
357     (load-binding-stack-pointer bsp)
358     (inst cmp where bsp)
359     (inst jmp :e done)
360
361     LOOP
362     (loadw symbol bsp (- binding-symbol-slot binding-size))
363     (inst or symbol symbol)
364     (inst jmp :z skip)
365     ;; Bind stack debug sentinels have the unbound marker in the symbol slot
366     (inst cmp symbol unbound-marker-widetag)
367     (inst jmp :eq skip)
368     (loadw value bsp (- binding-value-slot binding-size))
369     #!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag)
370
371     #!+sb-thread (loadw
372                   tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
373     #!+sb-thread (inst mov (make-ea :dword :base tls-index) value :fs)
374     (storew 0 bsp (- binding-symbol-slot binding-size))
375
376     SKIP
377     (storew 0 bsp (- binding-value-slot binding-size))
378     (inst sub bsp (* binding-size n-word-bytes))
379     (inst cmp where bsp)
380     (inst jmp :ne loop)
381     (store-binding-stack-pointer bsp)
382
383     DONE))
384
385 (define-vop (bind-sentinel)
386   (:temporary (:sc unsigned-reg) bsp)
387   (:generator 1
388      (load-binding-stack-pointer bsp)
389      (inst add bsp (* binding-size n-word-bytes))
390      (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
391      (storew ebp-tn bsp (- binding-value-slot binding-size))
392      (store-binding-stack-pointer bsp)))
393
394 (define-vop (unbind-sentinel)
395   (:temporary (:sc unsigned-reg) bsp)
396   (:generator 1
397      (load-binding-stack-pointer bsp)
398      (storew 0 bsp (- binding-value-slot binding-size))
399      (storew 0 bsp (- binding-symbol-slot binding-size))
400      (inst sub bsp (* binding-size n-word-bytes))
401      (store-binding-stack-pointer bsp)))
402 \f
403
404 \f
405 ;;;; closure indexing
406
407 (define-full-reffer closure-index-ref *
408   closure-info-offset fun-pointer-lowtag
409   (any-reg descriptor-reg) * %closure-index-ref)
410
411 (define-full-setter set-funcallable-instance-info *
412   funcallable-instance-info-offset fun-pointer-lowtag
413   (any-reg descriptor-reg) * %set-funcallable-instance-info)
414
415 (define-full-reffer funcallable-instance-info *
416   funcallable-instance-info-offset fun-pointer-lowtag
417   (descriptor-reg any-reg) * %funcallable-instance-info)
418
419 (define-vop (closure-ref slot-ref)
420   (:variant closure-info-offset fun-pointer-lowtag))
421
422 (define-vop (closure-init slot-set)
423   (:variant closure-info-offset fun-pointer-lowtag))
424 \f
425 ;;;; value cell hackery
426
427 (define-vop (value-cell-ref cell-ref)
428   (:variant value-cell-value-slot other-pointer-lowtag))
429
430 (define-vop (value-cell-set cell-set)
431   (:variant value-cell-value-slot other-pointer-lowtag))
432 \f
433 ;;;; structure hackery
434
435 (define-vop (instance-length)
436   (:policy :fast-safe)
437   (:translate %instance-length)
438   (:args (struct :scs (descriptor-reg)))
439   (:results (res :scs (unsigned-reg)))
440   (:result-types positive-fixnum)
441   (:generator 4
442     (loadw res struct 0 instance-pointer-lowtag)
443     (inst shr res n-widetag-bits)))
444
445 (define-full-reffer instance-index-ref *
446   instance-slots-offset instance-pointer-lowtag
447   (any-reg descriptor-reg) *
448   %instance-ref)
449
450 (define-full-setter instance-index-set *
451   instance-slots-offset instance-pointer-lowtag
452   (any-reg descriptor-reg) *
453   %instance-set)
454
455 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
456   instance-slots-offset instance-pointer-lowtag
457   (any-reg descriptor-reg) *
458   %compare-and-swap-instance-ref)
459 \f
460 ;;;; code object frobbing
461
462 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
463   (any-reg descriptor-reg) * code-header-ref)
464
465 (define-full-setter code-header-set * 0 other-pointer-lowtag
466   (any-reg descriptor-reg) * code-header-set)
467 \f
468 ;;;; raw instance slot accessors
469
470 (defun make-ea-for-raw-slot (object index instance-length n-words)
471   (if (integerp instance-length)
472       ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
473       ;; at compile time.
474       (make-ea :dword
475                :base object
476                :disp (- (* (- instance-length instance-slots-offset index (1- n-words))
477                            n-word-bytes)
478                         instance-pointer-lowtag))
479       (flet ((make-ea-using-value (value)
480                (make-ea :dword :base object
481                         :index instance-length
482                         :scale 4
483                         :disp (- (* (- instance-slots-offset n-words)
484                                     n-word-bytes)
485                                  instance-pointer-lowtag
486                                  (* value n-word-bytes)))))
487         (if (typep index 'tn)
488             (sc-case index
489               (any-reg (make-ea :dword
490                                 :base object
491                                 :index instance-length
492                                 :disp (- (* (- instance-slots-offset n-words)
493                                             n-word-bytes)
494                                          instance-pointer-lowtag)))
495               (immediate (make-ea-using-value (tn-value index))))
496             (make-ea-using-value index)))))
497
498 (define-vop (raw-instance-ref/word)
499   (:translate %raw-instance-ref/word)
500   (:policy :fast-safe)
501   (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)))
502   (:arg-types * tagged-num)
503   (:temporary (:sc unsigned-reg) tmp)
504   (:results (value :scs (unsigned-reg)))
505   (:result-types unsigned-num)
506   (:generator 5
507     (loadw tmp object 0 instance-pointer-lowtag)
508     (inst shr tmp n-widetag-bits)
509     (when (sc-is index any-reg)
510       (inst shl tmp 2)
511       (inst sub tmp index))
512     (inst mov value (make-ea-for-raw-slot object index tmp 1))))
513
514 (define-vop (raw-instance-set/word)
515   (:translate %raw-instance-set/word)
516   (:policy :fast-safe)
517   (:args (object :scs (descriptor-reg))
518          (index :scs (any-reg immediate))
519          (value :scs (unsigned-reg) :target result))
520   (:arg-types * tagged-num unsigned-num)
521   (:temporary (:sc unsigned-reg) tmp)
522   (:results (result :scs (unsigned-reg)))
523   (:result-types unsigned-num)
524   (:generator 5
525     (loadw tmp object 0 instance-pointer-lowtag)
526     (inst shr tmp n-widetag-bits)
527     (when (sc-is index any-reg)
528       (inst shl tmp 2)
529       (inst sub tmp index))
530     (inst mov (make-ea-for-raw-slot object index tmp 1) value)
531     (move result value)))
532
533 (define-vop (raw-instance-init/word)
534   (:args (object :scs (descriptor-reg))
535          (value :scs (unsigned-reg)))
536   (:arg-types * unsigned-num)
537   (:info instance-length index)
538   (:generator 5
539     (inst mov (make-ea-for-raw-slot object index instance-length 1) value)))
540
541 (define-vop (raw-instance-atomic-incf/word)
542   (:translate %raw-instance-atomic-incf/word)
543   (:policy :fast-safe)
544   (:args (object :scs (descriptor-reg))
545          (index :scs (any-reg immediate))
546          (diff :scs (signed-reg) :target result))
547   (:arg-types * tagged-num signed-num)
548   (:temporary (:sc unsigned-reg) tmp)
549   (:results (result :scs (unsigned-reg)))
550   (:result-types unsigned-num)
551   (:generator 5
552     (loadw tmp object 0 instance-pointer-lowtag)
553     (inst shr tmp n-widetag-bits)
554     (when (sc-is index any-reg)
555       (inst shl tmp 2)
556       (inst sub tmp index))
557     (inst xadd (make-ea-for-raw-slot object index tmp 1) diff :lock)
558     (move result diff)))
559
560 (define-vop (raw-instance-ref/single)
561   (:translate %raw-instance-ref/single)
562   (:policy :fast-safe)
563   (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)))
564   (:arg-types * tagged-num)
565   (:temporary (:sc unsigned-reg) tmp)
566   (:results (value :scs (single-reg)))
567   (:result-types single-float)
568   (:generator 5
569     (loadw tmp object 0 instance-pointer-lowtag)
570     (inst shr tmp n-widetag-bits)
571     (when (sc-is index any-reg)
572       (inst shl tmp 2)
573       (inst sub tmp index))
574     (with-empty-tn@fp-top(value)
575       (inst fld (make-ea-for-raw-slot object index tmp 1)))))
576
577 (define-vop (raw-instance-set/single)
578   (:translate %raw-instance-set/single)
579   (:policy :fast-safe)
580   (:args (object :scs (descriptor-reg))
581          (index :scs (any-reg immediate))
582          (value :scs (single-reg) :target result))
583   (:arg-types * tagged-num single-float)
584   (:temporary (:sc unsigned-reg) tmp)
585   (:results (result :scs (single-reg)))
586   (:result-types single-float)
587   (:generator 5
588     (loadw tmp object 0 instance-pointer-lowtag)
589     (inst shr tmp n-widetag-bits)
590     (when (sc-is index any-reg)
591       (inst shl tmp 2)
592       (inst sub tmp index))
593     (unless (zerop (tn-offset value))
594       (inst fxch value))
595     (inst fst (make-ea-for-raw-slot object index tmp 1))
596     (cond
597       ((zerop (tn-offset value))
598         (unless (zerop (tn-offset result))
599           (inst fst result)))
600       ((zerop (tn-offset result))
601         (inst fst value))
602       (t
603         (unless (location= value result)
604           (inst fst result))
605         (inst fxch value)))))
606
607 (define-vop (raw-instance-init/single)
608   (:args (object :scs (descriptor-reg))
609          (value :scs (single-reg)))
610   (:arg-types * single-float)
611   (:info instance-length index)
612   (:generator 5
613     (with-tn@fp-top (value)
614       (inst fst (make-ea-for-raw-slot object index instance-length 1)))))
615
616 (define-vop (raw-instance-ref/double)
617   (:translate %raw-instance-ref/double)
618   (:policy :fast-safe)
619   (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)))
620   (:arg-types * tagged-num)
621   (:temporary (:sc unsigned-reg) tmp)
622   (:results (value :scs (double-reg)))
623   (:result-types double-float)
624   (:generator 5
625     (loadw tmp object 0 instance-pointer-lowtag)
626     (inst shr tmp n-widetag-bits)
627     (when (sc-is index any-reg)
628       (inst shl tmp 2)
629       (inst sub tmp index))
630     (with-empty-tn@fp-top(value)
631       (inst fldd (make-ea-for-raw-slot object index tmp 2)))))
632
633 (define-vop (raw-instance-set/double)
634   (:translate %raw-instance-set/double)
635   (:policy :fast-safe)
636   (:args (object :scs (descriptor-reg))
637          (index :scs (any-reg immediate))
638          (value :scs (double-reg) :target result))
639   (:arg-types * tagged-num double-float)
640   (:temporary (:sc unsigned-reg) tmp)
641   (:results (result :scs (double-reg)))
642   (:result-types double-float)
643   (:generator 5
644     (loadw tmp object 0 instance-pointer-lowtag)
645     (inst shr tmp n-widetag-bits)
646     (when (sc-is index any-reg)
647       (inst shl tmp 2)
648       (inst sub tmp index))
649     (unless (zerop (tn-offset value))
650       (inst fxch value))
651     (inst fstd (make-ea-for-raw-slot object index tmp 2))
652     (cond
653       ((zerop (tn-offset value))
654         (unless (zerop (tn-offset result))
655           (inst fstd result)))
656       ((zerop (tn-offset result))
657         (inst fstd value))
658       (t
659         (unless (location= value result)
660           (inst fstd result))
661         (inst fxch value)))))
662
663 (define-vop (raw-instance-init/double)
664   (:args (object :scs (descriptor-reg))
665          (value :scs (double-reg)))
666   (:arg-types * double-float)
667   (:info instance-length index)
668   (:generator 5
669     (with-tn@fp-top (value)
670       (inst fstd (make-ea-for-raw-slot object index instance-length 2)))))
671
672 (define-vop (raw-instance-ref/complex-single)
673   (:translate %raw-instance-ref/complex-single)
674   (:policy :fast-safe)
675   (:args (object :scs (descriptor-reg))
676          (index :scs (any-reg immediate)))
677   (:arg-types * positive-fixnum)
678   (:temporary (:sc unsigned-reg) tmp)
679   (:results (value :scs (complex-single-reg)))
680   (:result-types complex-single-float)
681   (:generator 5
682     (loadw tmp object 0 instance-pointer-lowtag)
683     (inst shr tmp n-widetag-bits)
684     (when (sc-is index any-reg)
685       (inst shl tmp 2)
686       (inst sub tmp index))
687     (let ((real-tn (complex-single-reg-real-tn value)))
688       (with-empty-tn@fp-top (real-tn)
689         (inst fld (make-ea-for-raw-slot object index tmp 2))))
690     (let ((imag-tn (complex-single-reg-imag-tn value)))
691       (with-empty-tn@fp-top (imag-tn)
692         (inst fld (make-ea-for-raw-slot object index tmp 1))))))
693
694 (define-vop (raw-instance-set/complex-single)
695   (:translate %raw-instance-set/complex-single)
696   (:policy :fast-safe)
697   (:args (object :scs (descriptor-reg))
698          (index :scs (any-reg immediate))
699          (value :scs (complex-single-reg) :target result))
700   (:arg-types * positive-fixnum complex-single-float)
701   (:temporary (:sc unsigned-reg) tmp)
702   (:results (result :scs (complex-single-reg)))
703   (:result-types complex-single-float)
704   (:generator 5
705     (loadw tmp object 0 instance-pointer-lowtag)
706     (inst shr tmp n-widetag-bits)
707     (when (sc-is index any-reg)
708       (inst shl tmp 2)
709       (inst sub tmp index))
710     (let ((value-real (complex-single-reg-real-tn value))
711           (result-real (complex-single-reg-real-tn result)))
712       (cond ((zerop (tn-offset value-real))
713              ;; Value is in ST0.
714              (inst fst (make-ea-for-raw-slot object index tmp 2))
715              (unless (zerop (tn-offset result-real))
716                ;; Value is in ST0 but not result.
717                (inst fst result-real)))
718             (t
719              ;; Value is not in ST0.
720              (inst fxch value-real)
721              (inst fst (make-ea-for-raw-slot object index tmp 2))
722              (cond ((zerop (tn-offset result-real))
723                     ;; The result is in ST0.
724                     (inst fst value-real))
725                    (t
726                     ;; Neither value or result are in ST0
727                     (unless (location= value-real result-real)
728                       (inst fst result-real))
729                     (inst fxch value-real))))))
730     (let ((value-imag (complex-single-reg-imag-tn value))
731           (result-imag (complex-single-reg-imag-tn result)))
732       (inst fxch value-imag)
733       (inst fst (make-ea-for-raw-slot object index tmp 1))
734       (unless (location= value-imag result-imag)
735         (inst fst result-imag))
736       (inst fxch value-imag))))
737
738 (define-vop (raw-instance-init/complex-single)
739   (:args (object :scs (descriptor-reg))
740          (value :scs (complex-single-reg)))
741   (:arg-types * complex-single-float)
742   (:info instance-length index)
743   (:generator 5
744     (let ((value-real (complex-single-reg-real-tn value)))
745       (with-tn@fp-top (value-real)
746         (inst fst (make-ea-for-raw-slot object index instance-length 2))))
747     (let ((value-imag (complex-single-reg-imag-tn value)))
748       (with-tn@fp-top (value-imag)
749         (inst fst (make-ea-for-raw-slot object index instance-length 1))))))
750
751 (define-vop (raw-instance-ref/complex-double)
752   (:translate %raw-instance-ref/complex-double)
753   (:policy :fast-safe)
754   (:args (object :scs (descriptor-reg))
755          (index :scs (any-reg immediate)))
756   (:arg-types * positive-fixnum)
757   (:temporary (:sc unsigned-reg) tmp)
758   (:results (value :scs (complex-double-reg)))
759   (:result-types complex-double-float)
760   (:generator 7
761     (loadw tmp object 0 instance-pointer-lowtag)
762     (inst shr tmp n-widetag-bits)
763     (when (sc-is index any-reg)
764       (inst shl tmp 2)
765       (inst sub tmp index))
766     (let ((real-tn (complex-double-reg-real-tn value)))
767       (with-empty-tn@fp-top (real-tn)
768         (inst fldd (make-ea-for-raw-slot object index tmp 4))))
769     (let ((imag-tn (complex-double-reg-imag-tn value)))
770       (with-empty-tn@fp-top (imag-tn)
771         (inst fldd (make-ea-for-raw-slot object index tmp 2))))))
772
773 (define-vop (raw-instance-set/complex-double)
774   (:translate %raw-instance-set/complex-double)
775   (:policy :fast-safe)
776   (:args (object :scs (descriptor-reg))
777          (index :scs (any-reg immediate))
778          (value :scs (complex-double-reg) :target result))
779   (:arg-types * positive-fixnum complex-double-float)
780   (:temporary (:sc unsigned-reg) tmp)
781   (:results (result :scs (complex-double-reg)))
782   (:result-types complex-double-float)
783   (:generator 20
784     (loadw tmp object 0 instance-pointer-lowtag)
785     (inst shr tmp n-widetag-bits)
786     (when (sc-is index any-reg)
787       (inst shl tmp 2)
788       (inst sub tmp index))
789     (let ((value-real (complex-double-reg-real-tn value))
790           (result-real (complex-double-reg-real-tn result)))
791       (cond ((zerop (tn-offset value-real))
792              ;; Value is in ST0.
793              (inst fstd (make-ea-for-raw-slot object index tmp 4))
794              (unless (zerop (tn-offset result-real))
795                ;; Value is in ST0 but not result.
796                (inst fstd result-real)))
797             (t
798              ;; Value is not in ST0.
799              (inst fxch value-real)
800              (inst fstd (make-ea-for-raw-slot object index tmp 4))
801              (cond ((zerop (tn-offset result-real))
802                     ;; The result is in ST0.
803                     (inst fstd value-real))
804                    (t
805                     ;; Neither value or result are in ST0
806                     (unless (location= value-real result-real)
807                       (inst fstd result-real))
808                     (inst fxch value-real))))))
809     (let ((value-imag (complex-double-reg-imag-tn value))
810           (result-imag (complex-double-reg-imag-tn result)))
811       (inst fxch value-imag)
812       (inst fstd (make-ea-for-raw-slot object index tmp 2))
813       (unless (location= value-imag result-imag)
814         (inst fstd result-imag))
815       (inst fxch value-imag))))
816
817 (define-vop (raw-instance-init/complex-double)
818   (:args (object :scs (descriptor-reg))
819          (value :scs (complex-double-reg)))
820   (:arg-types * complex-double-float)
821   (:info instance-length index)
822   (:generator 20
823     (let ((value-real (complex-double-reg-real-tn value)))
824       (with-tn@fp-top (value-real)
825         (inst fstd (make-ea-for-raw-slot object index instance-length 4))))
826     (let ((value-imag (complex-double-reg-imag-tn value)))
827       (with-tn@fp-top (value-imag)
828         (inst fstd (make-ea-for-raw-slot object index instance-length 2))))))