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