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