1 ;;;; various primitive memory access VOPs for the x86 VM
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 ;;;; data object ref/set stuff
17 (:args
(object :scs
(descriptor-reg)))
18 (:info name offset lowtag
)
20 (:results
(result :scs
(descriptor-reg any-reg
)))
22 (loadw result object offset lowtag
)))
24 (define-vop (set-slot)
25 (:args
(object :scs
(descriptor-reg))
26 (value :scs
(descriptor-reg any-reg immediate
)))
27 (:info name offset lowtag
)
31 (storew (encode-value-if-immediate value
) object offset lowtag
)))
33 (define-vop (init-slot set-slot
))
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
)
42 (:info name offset lowtag
)
44 (:results
(result :scs
(descriptor-reg any-reg
)))
47 (inst cmpxchg
(make-ea :dword
:base object
48 :disp
(- (* offset n-word-bytes
) lowtag
))
52 ;;;; symbol hacking VOPs
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
)
61 (:temporary
(:sc descriptor-reg
) tls
)
62 (:results
(result :scs
(descriptor-reg any-reg
)))
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
))
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
)
81 (inst cmpxchg
(make-ea :dword
:base symbol
82 :disp
(- (* symbol-value-slot n-word-bytes
)
83 other-pointer-lowtag
))
87 (inst cmp result unbound-marker-widetag
)
88 (inst jmp
:e unbound
))))
90 (define-vop (%set-symbol-global-value cell-set
)
91 (:variant symbol-value-slot other-pointer-lowtag
))
93 (define-vop (fast-symbol-global-value cell-ref
)
94 (:variant symbol-value-slot other-pointer-lowtag
)
96 (:translate sym-global-val
))
98 (define-vop (symbol-global-value)
100 (:translate sym-global-val
)
101 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
102 (:results
(value :scs
(descriptor-reg any-reg
)))
104 (:save-p
:compute-only
)
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
))))
114 (:args
(symbol :scs
(descriptor-reg))
115 (value :scs
(descriptor-reg any-reg
)))
116 (:temporary
(:sc descriptor-reg
) tls
)
118 (let ((global-val (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
))
126 (emit-label global-val
)
127 (storew value symbol symbol-value-slot other-pointer-lowtag
)
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)
135 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
136 (:results
(value :scs
(descriptor-reg any-reg
)))
138 (:save-p
:compute-only
)
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
))))
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. --
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
)))))
174 (define-vop (symbol-value symbol-global-value
)
175 (:translate symeval
))
176 (define-vop (fast-symbol-value fast-symbol-global-value
)
177 (:translate symeval
))
178 (define-vop (set %set-symbol-global-value
)))
184 (:args
(object :scs
(descriptor-reg)))
186 (:temporary
(:sc descriptor-reg
#+nil
(:from
(:argument
0))) value
)
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
))))
202 (:args
(object :scs
(descriptor-reg)))
205 (inst cmp
(make-ea-for-object-slot object symbol-value-slot
206 other-pointer-lowtag
)
207 unbound-marker-widetag
)))
210 (define-vop (symbol-hash)
212 (:translate symbol-hash
)
213 (:args
(symbol :scs
(descriptor-reg)))
214 (:results
(res :scs
(any-reg)))
215 (:result-types positive-fixnum
)
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
))))
224 ;;;; fdefinition (FDEFN) objects
226 (define-vop (fdefn-fun cell-ref
) ; /pfw - alpha
227 (:variant fdefn-fun-slot other-pointer-lowtag
))
229 (define-vop (safe-fdefn-fun)
230 (:translate safe-fdefn-fun
)
232 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
233 (:results
(value :scs
(descriptor-reg any-reg
)))
235 (:save-p
:compute-only
)
237 (loadw value object fdefn-fun-slot other-pointer-lowtag
)
238 (inst cmp value nil-value
)
239 (let ((err-lab (generate-error-code vop
'undefined-fun-error object
)))
240 (inst jmp
:e err-lab
))))
242 (define-vop (set-fdefn-fun)
244 (:translate
(setf fdefn-fun
))
245 (:args
(function :scs
(descriptor-reg) :target result
)
246 (fdefn :scs
(descriptor-reg)))
247 (:temporary
(:sc unsigned-reg
) raw
)
248 (:temporary
(:sc byte-reg
) type
)
249 (:results
(result :scs
(descriptor-reg)))
251 (load-type type function
(- fun-pointer-lowtag
))
253 (make-ea-for-object-slot function simple-fun-code-offset
255 (inst cmp type simple-fun-widetag
)
256 (inst jmp
:e normal-fn
)
257 (inst lea raw
(make-fixup 'closure-tramp
:assembly-routine
))
259 (storew function fdefn fdefn-fun-slot other-pointer-lowtag
)
260 (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
261 (move result function
)))
263 (define-vop (fdefn-makunbound)
265 (:translate fdefn-makunbound
)
266 (:args
(fdefn :scs
(descriptor-reg) :target result
))
267 (:results
(result :scs
(descriptor-reg)))
269 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag
)
270 (storew (make-fixup 'undefined-tramp
:assembly-routine
)
271 fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
272 (move result fdefn
)))
274 ;;;; binding and unbinding
276 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
277 ;;; the symbol on the binding stack and stuff the new value into the
279 ;;; See the "Chapter 9: Specials" of the SBCL Internals Manual.
283 ((def (vopname symbol-arg info sc-offset load-tls-index
)
284 `(define-vop (,vopname
)
285 (:args
(val :scs
(any-reg descriptor-reg
)) ,@symbol-arg
)
287 (:temporary
(:sc unsigned-reg
,@sc-offset
) tls-index
)
288 (:temporary
(:sc unsigned-reg
) bsp
#!+win32 temp
)
289 (:generator
10 ; cost is irrelevant. we explicitly pick a vop
290 (load-binding-stack-pointer bsp
)
292 (inst add bsp
(* binding-size n-word-bytes
))
293 (store-binding-stack-pointer bsp
)
294 ;; with-tls-ea on win32 causes tls-index to be an absolute address
295 ;; which is problematic when UNBIND uses with-tls-ea too.
296 #!+win32
(move temp tls-index
)
297 (with-tls-ea (EA :base tls-index
:base-already-live-p t
)
298 (inst push EA
:maybe-fs
)
299 (popw bsp
(- binding-value-slot binding-size
))
300 (storew #!-win32 tls-index
302 bsp
(- binding-symbol-slot binding-size
))
303 (inst mov EA val
:maybe-fs
))))))
304 (def bind
; bind a known symbol
305 nil
((:info symbol
)) nil
306 ((inst mov tls-index
(make-fixup symbol
:symbol-tls-index
))))
307 (def dynbind
; bind a symbol in a PROGV form
308 ((symbol :scs
(descriptor-reg))) nil
(:offset eax-offset
)
309 ((inst mov tls-index
(tls-index-of symbol
))
310 (inst test tls-index tls-index
)
311 (inst jmp
:ne tls-index-valid
)
312 (inst mov tls-index symbol
)
313 (inst call
(make-fixup 'alloc-tls-index
:assembly-routine
))
317 (define-vop (dynbind)
318 (:args
(val :scs
(any-reg descriptor-reg
))
319 (symbol :scs
(descriptor-reg)))
320 (:temporary
(:sc unsigned-reg
) temp bsp
)
322 (load-symbol-value bsp
*binding-stack-pointer
*)
323 (loadw temp symbol symbol-value-slot other-pointer-lowtag
)
324 (inst add bsp
(* binding-size n-word-bytes
))
325 (store-symbol-value bsp
*binding-stack-pointer
*)
326 (storew temp bsp
(- binding-value-slot binding-size
))
327 (storew symbol bsp
(- binding-symbol-slot binding-size
))
328 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
332 (:temporary
(:sc unsigned-reg
) temp bsp tls-index
)
334 (load-binding-stack-pointer bsp
)
335 ;; Load SYMBOL from stack, and get the TLS-INDEX.
336 (loadw tls-index bsp
(- binding-symbol-slot binding-size
))
337 ;; Load VALUE from stack, then restore it to the TLS area.
338 (loadw temp bsp
(- binding-value-slot binding-size
))
339 (with-tls-ea (EA :base tls-index
:base-already-live-p t
)
340 (inst mov EA temp
:maybe-fs
))
341 ;; Zero out the stack.
342 (inst sub bsp
(* binding-size n-word-bytes
))
343 (storew 0 bsp binding-symbol-slot
)
344 (storew 0 bsp binding-value-slot
)
345 (store-binding-stack-pointer bsp
)))
349 (:temporary
(:sc unsigned-reg
) symbol value bsp
)
351 (load-symbol-value bsp
*binding-stack-pointer
*)
352 (loadw symbol bsp
(- binding-symbol-slot binding-size
))
353 (loadw value bsp
(- binding-value-slot binding-size
))
354 (storew value symbol symbol-value-slot other-pointer-lowtag
)
355 (storew 0 bsp
(- binding-symbol-slot binding-size
))
356 (storew 0 bsp
(- binding-value-slot binding-size
))
357 (inst sub bsp
(* binding-size n-word-bytes
))
358 (store-symbol-value bsp
*binding-stack-pointer
*)))
361 (define-vop (unbind-to-here)
362 (:args
(where :scs
(descriptor-reg any-reg
)))
363 (:temporary
(:sc unsigned-reg
) symbol value bsp
)
365 (load-binding-stack-pointer bsp
)
370 (inst sub bsp
(* binding-size n-word-bytes
))
371 (loadw symbol bsp binding-symbol-slot
)
372 (inst test symbol symbol
)
374 ;; Bind stack debug sentinels have the unbound marker in the symbol slot
375 (inst cmp symbol unbound-marker-widetag
)
377 (loadw value bsp binding-value-slot
)
378 #!-sb-thread
(storew value symbol symbol-value-slot other-pointer-lowtag
)
379 #!+sb-thread
(with-tls-ea (EA :base symbol
:base-already-live-p t
)
380 (inst mov EA value
:maybe-fs
))
381 (storew 0 bsp binding-symbol-slot
)
384 (storew 0 bsp binding-value-slot
)
387 (store-binding-stack-pointer bsp
)
391 ;;;; closure indexing
393 (define-full-reffer closure-index-ref
*
394 closure-info-offset fun-pointer-lowtag
395 (any-reg descriptor-reg
) * %closure-index-ref
)
397 (define-full-setter set-funcallable-instance-info
*
398 funcallable-instance-info-offset fun-pointer-lowtag
399 (any-reg descriptor-reg
) * %set-funcallable-instance-info
)
401 (define-full-reffer funcallable-instance-info
*
402 funcallable-instance-info-offset fun-pointer-lowtag
403 (descriptor-reg any-reg
) * %funcallable-instance-info
)
405 (define-vop (closure-ref slot-ref
)
406 (:variant closure-info-offset fun-pointer-lowtag
))
408 (define-vop (closure-init slot-set
)
409 (:variant closure-info-offset fun-pointer-lowtag
))
411 (define-vop (closure-init-from-fp)
412 (:args
(object :scs
(descriptor-reg)))
415 (storew ebp-tn object
(+ closure-info-offset offset
) fun-pointer-lowtag
)))
417 ;;;; value cell hackery
419 (define-vop (value-cell-ref cell-ref
)
420 (:variant value-cell-value-slot other-pointer-lowtag
))
422 (define-vop (value-cell-set cell-set
)
423 (:variant value-cell-value-slot other-pointer-lowtag
))
425 ;;;; structure hackery
427 (define-vop (instance-length)
429 (:translate %instance-length
)
430 (:args
(struct :scs
(descriptor-reg)))
431 (:results
(res :scs
(unsigned-reg)))
432 (:result-types positive-fixnum
)
434 (loadw res struct
0 instance-pointer-lowtag
)
435 (inst shr res n-widetag-bits
)))
437 (define-full-reffer instance-index-ref
*
438 instance-slots-offset instance-pointer-lowtag
439 (any-reg descriptor-reg
) *
442 (define-full-setter instance-index-set
*
443 instance-slots-offset instance-pointer-lowtag
444 (any-reg descriptor-reg
) *
447 (define-full-compare-and-swap %instance-cas instance
448 instance-slots-offset instance-pointer-lowtag
449 (any-reg descriptor-reg
) *
451 (define-full-compare-and-swap %raw-instance-cas
/word instance
452 instance-slots-offset instance-pointer-lowtag
453 (unsigned-reg) unsigned-num %raw-instance-cas
/word
)
455 ;;;; code object frobbing
457 (define-full-reffer code-header-ref
* 0 other-pointer-lowtag
458 (any-reg descriptor-reg
) * code-header-ref
)
460 (define-full-setter code-header-set
* 0 other-pointer-lowtag
461 (any-reg descriptor-reg
) * code-header-set
)
463 ;;;; raw instance slot accessors
465 (defun make-ea-for-raw-slot (object index
&optional
(displacement 0))
466 ;; instance-init vops pass a literal integer, ref/set can use an immediate tn
467 (let ((imm-index (cond ((integerp index
) index
)
468 ((sc-is index immediate
) (tn-value index
)))))
469 (make-ea :dword
:base object
470 ;; If index is a register, it needs no scaling - it has tag bits.
471 :index
(unless imm-index index
) :scale
1
472 :disp
(- (ash (+ (or imm-index
0) displacement instance-slots-offset
)
473 word-shift
) instance-pointer-lowtag
))))
475 (define-vop (raw-instance-ref/word
)
476 (:translate %raw-instance-ref
/word
)
478 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
479 (:arg-types
* tagged-num
)
480 (:results
(value :scs
(unsigned-reg)))
481 (:result-types unsigned-num
)
483 (inst mov value
(make-ea-for-raw-slot object index
))))
485 (define-vop (raw-instance-set/word
)
486 (:translate %raw-instance-set
/word
)
488 (:args
(object :scs
(descriptor-reg))
489 (index :scs
(any-reg immediate
))
490 (value :scs
(unsigned-reg) :target result
))
491 (:arg-types
* tagged-num unsigned-num
)
492 (:results
(result :scs
(unsigned-reg)))
493 (:result-types unsigned-num
)
495 (inst mov
(make-ea-for-raw-slot object index
) value
)
496 (move result value
)))
498 (define-vop (raw-instance-init/word
)
499 (:args
(object :scs
(descriptor-reg))
500 (value :scs
(unsigned-reg)))
501 (:arg-types
* unsigned-num
)
504 (inst mov
(make-ea-for-raw-slot object index
) value
)))
506 (define-vop (raw-instance-ref/signed-word
)
507 (:translate %raw-instance-ref
/signed-word
)
509 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
510 (:arg-types
* tagged-num
)
511 (:results
(value :scs
(signed-reg)))
512 (:result-types signed-num
)
514 (inst mov value
(make-ea-for-raw-slot object index
))))
516 (define-vop (raw-instance-set/signed-word
)
517 (:translate %raw-instance-set
/signed-word
)
519 (:args
(object :scs
(descriptor-reg))
520 (index :scs
(any-reg immediate
))
521 (value :scs
(signed-reg) :target result
))
522 (:arg-types
* tagged-num signed-num
)
523 (:results
(result :scs
(signed-reg)))
524 (:result-types signed-num
)
526 (inst mov
(make-ea-for-raw-slot object index
) value
)
527 (move result value
)))
529 (define-vop (raw-instance-init/signed-word
)
530 (:args
(object :scs
(descriptor-reg))
531 (value :scs
(signed-reg)))
532 (:arg-types
* signed-num
)
535 (inst mov
(make-ea-for-raw-slot object index
) value
)))
537 (define-vop (raw-instance-atomic-incf/word
)
538 (:translate %raw-instance-atomic-incf
/word
)
540 (:args
(object :scs
(descriptor-reg))
541 (index :scs
(any-reg immediate
))
542 (diff :scs
(unsigned-reg) :target result
))
543 (:arg-types
* tagged-num unsigned-num
)
544 (:results
(result :scs
(unsigned-reg)))
545 (:result-types unsigned-num
)
547 (inst xadd
(make-ea-for-raw-slot object index
) diff
:lock
)
550 (define-vop (raw-instance-ref/single
)
551 (:translate %raw-instance-ref
/single
)
553 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
554 (:arg-types
* tagged-num
)
555 (:results
(value :scs
(single-reg)))
556 (:result-types single-float
)
558 (with-empty-tn@fp-top
(value)
559 (inst fld
(make-ea-for-raw-slot object index
)))))
561 (define-vop (raw-instance-set/single
)
562 (:translate %raw-instance-set
/single
)
564 (:args
(object :scs
(descriptor-reg))
565 (index :scs
(any-reg immediate
))
566 (value :scs
(single-reg) :target result
))
567 (:arg-types
* tagged-num single-float
)
568 (:results
(result :scs
(single-reg)))
569 (:result-types single-float
)
571 (unless (zerop (tn-offset value
))
573 (inst fst
(make-ea-for-raw-slot object index
))
575 ((zerop (tn-offset value
))
576 (unless (zerop (tn-offset result
))
578 ((zerop (tn-offset result
))
581 (unless (location= value result
)
583 (inst fxch value
)))))
585 (define-vop (raw-instance-init/single
)
586 (:args
(object :scs
(descriptor-reg))
587 (value :scs
(single-reg)))
588 (:arg-types
* single-float
)
591 (with-tn@fp-top
(value)
592 (inst fst
(make-ea-for-raw-slot object index
)))))
594 (define-vop (raw-instance-ref/double
)
595 (:translate %raw-instance-ref
/double
)
597 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
598 (:arg-types
* tagged-num
)
599 (:results
(value :scs
(double-reg)))
600 (:result-types double-float
)
602 (with-empty-tn@fp-top
(value)
603 (inst fldd
(make-ea-for-raw-slot object index
)))))
605 (define-vop (raw-instance-set/double
)
606 (:translate %raw-instance-set
/double
)
608 (:args
(object :scs
(descriptor-reg))
609 (index :scs
(any-reg immediate
))
610 (value :scs
(double-reg) :target result
))
611 (:arg-types
* tagged-num double-float
)
612 (:results
(result :scs
(double-reg)))
613 (:result-types double-float
)
615 (unless (zerop (tn-offset value
))
617 (inst fstd
(make-ea-for-raw-slot object index
))
619 ((zerop (tn-offset value
))
620 (unless (zerop (tn-offset result
))
622 ((zerop (tn-offset result
))
625 (unless (location= value result
)
627 (inst fxch value
)))))
629 (define-vop (raw-instance-init/double
)
630 (:args
(object :scs
(descriptor-reg))
631 (value :scs
(double-reg)))
632 (:arg-types
* double-float
)
635 (with-tn@fp-top
(value)
636 (inst fstd
(make-ea-for-raw-slot object index
)))))
638 (define-vop (raw-instance-ref/complex-single
)
639 (:translate %raw-instance-ref
/complex-single
)
641 (:args
(object :scs
(descriptor-reg))
642 (index :scs
(any-reg immediate
)))
643 (:arg-types
* positive-fixnum
)
644 (:results
(value :scs
(complex-single-reg)))
645 (:result-types complex-single-float
)
647 (let ((real-tn (complex-single-reg-real-tn value
)))
648 (with-empty-tn@fp-top
(real-tn)
649 (inst fld
(make-ea-for-raw-slot object index
))))
650 (let ((imag-tn (complex-single-reg-imag-tn value
)))
651 (with-empty-tn@fp-top
(imag-tn)
652 (inst fld
(make-ea-for-raw-slot object index
1))))))
654 (define-vop (raw-instance-set/complex-single
)
655 (:translate %raw-instance-set
/complex-single
)
657 (:args
(object :scs
(descriptor-reg))
658 (index :scs
(any-reg immediate
))
659 (value :scs
(complex-single-reg) :target result
))
660 (:arg-types
* positive-fixnum complex-single-float
)
661 (:results
(result :scs
(complex-single-reg)))
662 (:result-types complex-single-float
)
664 (let ((value-real (complex-single-reg-real-tn value
))
665 (result-real (complex-single-reg-real-tn result
)))
666 (cond ((zerop (tn-offset value-real
))
668 (inst fst
(make-ea-for-raw-slot object index
))
669 (unless (zerop (tn-offset result-real
))
670 ;; Value is in ST0 but not result.
671 (inst fst result-real
)))
673 ;; Value is not in ST0.
674 (inst fxch value-real
)
675 (inst fst
(make-ea-for-raw-slot object index
))
676 (cond ((zerop (tn-offset result-real
))
677 ;; The result is in ST0.
678 (inst fst value-real
))
680 ;; Neither value or result are in ST0
681 (unless (location= value-real result-real
)
682 (inst fst result-real
))
683 (inst fxch value-real
))))))
684 (let ((value-imag (complex-single-reg-imag-tn value
))
685 (result-imag (complex-single-reg-imag-tn result
)))
686 (inst fxch value-imag
)
687 (inst fst
(make-ea-for-raw-slot object index
1))
688 (unless (location= value-imag result-imag
)
689 (inst fst result-imag
))
690 (inst fxch value-imag
))))
692 (define-vop (raw-instance-init/complex-single
)
693 (:args
(object :scs
(descriptor-reg))
694 (value :scs
(complex-single-reg)))
695 (:arg-types
* complex-single-float
)
698 (let ((value-real (complex-single-reg-real-tn value
)))
699 (with-tn@fp-top
(value-real)
700 (inst fst
(make-ea-for-raw-slot object index
))))
701 (let ((value-imag (complex-single-reg-imag-tn value
)))
702 (with-tn@fp-top
(value-imag)
703 (inst fst
(make-ea-for-raw-slot object index
1))))))
705 (define-vop (raw-instance-ref/complex-double
)
706 (:translate %raw-instance-ref
/complex-double
)
708 (:args
(object :scs
(descriptor-reg))
709 (index :scs
(any-reg immediate
)))
710 (:arg-types
* positive-fixnum
)
711 (:results
(value :scs
(complex-double-reg)))
712 (:result-types complex-double-float
)
714 (let ((real-tn (complex-double-reg-real-tn value
)))
715 (with-empty-tn@fp-top
(real-tn)
716 (inst fldd
(make-ea-for-raw-slot object index
))))
717 (let ((imag-tn (complex-double-reg-imag-tn value
)))
718 (with-empty-tn@fp-top
(imag-tn)
719 (inst fldd
(make-ea-for-raw-slot object index
2))))))
721 (define-vop (raw-instance-set/complex-double
)
722 (:translate %raw-instance-set
/complex-double
)
724 (:args
(object :scs
(descriptor-reg))
725 (index :scs
(any-reg immediate
))
726 (value :scs
(complex-double-reg) :target result
))
727 (:arg-types
* positive-fixnum complex-double-float
)
728 (:results
(result :scs
(complex-double-reg)))
729 (:result-types complex-double-float
)
731 (let ((value-real (complex-double-reg-real-tn value
))
732 (result-real (complex-double-reg-real-tn result
)))
733 (cond ((zerop (tn-offset value-real
))
735 (inst fstd
(make-ea-for-raw-slot object index
))
736 (unless (zerop (tn-offset result-real
))
737 ;; Value is in ST0 but not result.
738 (inst fstd result-real
)))
740 ;; Value is not in ST0.
741 (inst fxch value-real
)
742 (inst fstd
(make-ea-for-raw-slot object index
))
743 (cond ((zerop (tn-offset result-real
))
744 ;; The result is in ST0.
745 (inst fstd value-real
))
747 ;; Neither value or result are in ST0
748 (unless (location= value-real result-real
)
749 (inst fstd result-real
))
750 (inst fxch value-real
))))))
751 (let ((value-imag (complex-double-reg-imag-tn value
))
752 (result-imag (complex-double-reg-imag-tn result
)))
753 (inst fxch value-imag
)
754 (inst fstd
(make-ea-for-raw-slot object index
2))
755 (unless (location= value-imag result-imag
)
756 (inst fstd result-imag
))
757 (inst fxch value-imag
))))
759 (define-vop (raw-instance-init/complex-double
)
760 (:args
(object :scs
(descriptor-reg))
761 (value :scs
(complex-double-reg)))
762 (:arg-types
* complex-double-float
)
765 (let ((value-real (complex-double-reg-real-tn value
)))
766 (with-tn@fp-top
(value-real)
767 (inst fstd
(make-ea-for-raw-slot object index
))))
768 (let ((value-imag (complex-double-reg-imag-tn value
)))
769 (with-tn@fp-top
(value-imag)
770 (inst fstd
(make-ea-for-raw-slot object index
2))))))