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 (compare-and-swap-slot)
34 (:args (object :scs (descriptor-reg) :to :eval)
35 (old :scs (descriptor-reg any-reg) :target eax)
36 (new :scs (descriptor-reg any-reg)))
37 (:temporary (:sc descriptor-reg :offset eax-offset
38 :from (:argument 1) :to :result :target result)
40 (:info name offset lowtag)
42 (: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, not LOCK needed.
76 (inst fs-segment-prefix)
77 (inst cmpxchg (make-ea :dword :base tls) new)
78 (inst cmp eax no-tls-value-marker-widetag)
82 (inst cmpxchg (make-ea :dword :base symbol
83 :disp (- (* symbol-value-slot n-word-bytes)
84 other-pointer-lowtag))
88 (inst cmp result unbound-marker-widetag)
89 (inst jmp :e unbound))))
91 ;;; these next two cf the sparc version, by jrd.
92 ;;; FIXME: Deref this ^ reference.
95 ;;; The compiler likes to be able to directly SET symbols.
98 (:args (symbol :scs (descriptor-reg))
99 (value :scs (descriptor-reg any-reg)))
100 (:temporary (:sc descriptor-reg) tls)
101 ;;(:policy :fast-safe)
103 (let ((global-val (gen-label))
105 (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
107 (inst jmp :z global-val)
108 (inst fs-segment-prefix)
109 (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag)
110 (inst jmp :z global-val)
111 (inst fs-segment-prefix)
112 (inst mov (make-ea :dword :base tls) value)
114 (emit-label global-val)
115 (storew value symbol symbol-value-slot other-pointer-lowtag)
118 ;; unithreaded it's a lot simpler ...
120 (define-vop (set cell-set)
121 (:variant symbol-value-slot other-pointer-lowtag))
123 ;;; With Symbol-Value, we check that the value isn't the trap object. So
124 ;;; Symbol-Value of NIL is NIL.
126 (define-vop (symbol-value)
127 (:translate symbol-value)
129 (:args (object :scs (descriptor-reg) :to (:result 1)))
130 (:results (value :scs (descriptor-reg any-reg)))
132 (:save-p :compute-only)
134 (let* ((check-unbound-label (gen-label))
135 (err-lab (generate-error-code vop unbound-symbol-error object))
136 (ret-lab (gen-label)))
137 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
138 (inst fs-segment-prefix)
139 (inst mov value (make-ea :dword :base value))
140 (inst cmp value no-tls-value-marker-widetag)
141 (inst jmp :ne check-unbound-label)
142 (loadw value object symbol-value-slot other-pointer-lowtag)
143 (emit-label check-unbound-label)
144 (inst cmp value unbound-marker-widetag)
145 (inst jmp :e err-lab)
146 (emit-label ret-lab))))
149 (define-vop (fast-symbol-value symbol-value)
150 ;; KLUDGE: not really fast, in fact, because we're going to have to
151 ;; do a full lookup of the thread-local area anyway. But half of
152 ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
153 ;; unbound", which is used in the implementation of COPY-SYMBOL. --
156 (:translate symbol-value)
158 (let ((ret-lab (gen-label)))
159 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
160 (inst fs-segment-prefix)
161 (inst mov value (make-ea :dword :base value))
162 (inst cmp value no-tls-value-marker-widetag)
163 (inst jmp :ne ret-lab)
164 (loadw value object symbol-value-slot other-pointer-lowtag)
165 (emit-label ret-lab))))
168 (define-vop (symbol-value)
169 (:translate symbol-value)
171 (:args (object :scs (descriptor-reg) :to (:result 1)))
172 (:results (value :scs (descriptor-reg any-reg)))
174 (:save-p :compute-only)
176 (let ((err-lab (generate-error-code vop unbound-symbol-error object)))
177 (loadw value object symbol-value-slot other-pointer-lowtag)
178 (inst cmp value unbound-marker-widetag)
179 (inst jmp :e err-lab))))
182 (define-vop (fast-symbol-value cell-ref)
183 (:variant symbol-value-slot other-pointer-lowtag)
185 (:translate symbol-value))
187 (defknown locked-symbol-global-value-add (symbol fixnum) fixnum ())
189 (define-vop (locked-symbol-global-value-add)
190 (:args (object :scs (descriptor-reg) :to :result)
191 (value :scs (any-reg) :target result))
192 (:arg-types * tagged-num)
193 (:results (result :scs (any-reg) :from (:argument 1)))
195 (:translate locked-symbol-global-value-add)
196 (:result-types tagged-num)
201 (inst add (make-ea-for-object-slot object symbol-value-slot
202 other-pointer-lowtag)
209 (:args (object :scs (descriptor-reg)))
212 (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
214 (let ((check-unbound-label (gen-label)))
215 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
216 (inst fs-segment-prefix)
217 (inst mov value (make-ea :dword :base value))
218 (inst cmp value no-tls-value-marker-widetag)
219 (inst jmp :ne check-unbound-label)
220 (loadw value object symbol-value-slot other-pointer-lowtag)
221 (emit-label check-unbound-label)
222 (inst cmp value unbound-marker-widetag)
223 (inst jmp (if not-p :e :ne) target))))
229 (:args (object :scs (descriptor-reg)))
233 (inst cmp (make-ea-for-object-slot object symbol-value-slot
234 other-pointer-lowtag)
235 unbound-marker-widetag)
236 (inst jmp (if not-p :e :ne) target)))
239 (define-vop (symbol-hash)
241 (:translate symbol-hash)
242 (:args (symbol :scs (descriptor-reg)))
243 (:results (res :scs (any-reg)))
244 (:result-types positive-fixnum)
246 ;; The symbol-hash slot of NIL holds NIL because it is also the
247 ;; cdr slot, so we have to strip off the two low bits to make sure
248 ;; it is a fixnum. The lowtag selection magic that is required to
249 ;; ensure this is explained in the comment in objdef.lisp
250 (loadw res symbol symbol-hash-slot other-pointer-lowtag)
251 (inst and res (lognot #b11))))
253 ;;;; fdefinition (FDEFN) objects
255 (define-vop (fdefn-fun cell-ref) ; /pfw - alpha
256 (:variant fdefn-fun-slot other-pointer-lowtag))
258 (define-vop (safe-fdefn-fun)
259 (:args (object :scs (descriptor-reg) :to (:result 1)))
260 (:results (value :scs (descriptor-reg any-reg)))
262 (:save-p :compute-only)
264 (loadw value object fdefn-fun-slot other-pointer-lowtag)
265 (inst cmp value nil-value)
266 (let ((err-lab (generate-error-code vop undefined-fun-error object)))
267 (inst jmp :e err-lab))))
269 (define-vop (set-fdefn-fun)
271 (:translate (setf fdefn-fun))
272 (:args (function :scs (descriptor-reg) :target result)
273 (fdefn :scs (descriptor-reg)))
274 (:temporary (:sc unsigned-reg) raw)
275 (:temporary (:sc byte-reg) type)
276 (:results (result :scs (descriptor-reg)))
278 (load-type type function (- fun-pointer-lowtag))
280 (make-ea-for-object-slot function simple-fun-code-offset
282 (inst cmp type simple-fun-header-widetag)
283 (inst jmp :e normal-fn)
284 (inst lea raw (make-fixup "closure_tramp" :foreign))
286 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
287 (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
288 (move result function)))
290 (define-vop (fdefn-makunbound)
292 (:translate fdefn-makunbound)
293 (:args (fdefn :scs (descriptor-reg) :target result))
294 (:results (result :scs (descriptor-reg)))
296 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
297 (storew (make-fixup "undefined_tramp" :foreign)
298 fdefn fdefn-raw-addr-slot other-pointer-lowtag)
299 (move result fdefn)))
301 ;;;; binding and unbinding
303 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
304 ;;; the symbol on the binding stack and stuff the new value into the
309 (:args (val :scs (any-reg descriptor-reg))
310 (symbol :scs (descriptor-reg)))
311 (:temporary (:sc descriptor-reg :offset eax-offset) eax)
312 (:temporary (:sc unsigned-reg) tls-index temp bsp)
314 (let ((tls-index-valid (gen-label))
315 (get-tls-index-lock (gen-label))
316 (release-tls-index-lock (gen-label)))
317 (load-binding-stack-pointer bsp)
318 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
319 (inst add bsp (* binding-size n-word-bytes))
320 (store-binding-stack-pointer bsp)
321 (inst or tls-index tls-index)
322 (inst jmp :ne tls-index-valid)
325 (emit-label get-tls-index-lock)
329 (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) temp)
330 (inst jmp :ne get-tls-index-lock)
331 ;; now with the lock held, see if the symbol's tls index has
332 ;; been set in the meantime
333 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
334 (inst or tls-index tls-index)
335 (inst jmp :ne release-tls-index-lock)
336 ;; allocate a new tls-index
337 (load-symbol-value tls-index *free-tls-index*)
338 (inst add tls-index 4) ;XXX surely we can do this more
339 (store-symbol-value tls-index *free-tls-index*) ;succintly
340 (inst sub tls-index 4)
341 (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
342 (emit-label release-tls-index-lock)
343 (store-symbol-value 0 *tls-index-lock*))
345 (emit-label tls-index-valid)
346 (inst fs-segment-prefix)
347 (inst mov temp (make-ea :dword :base tls-index))
348 (storew temp bsp (- binding-value-slot binding-size))
349 (storew symbol bsp (- binding-symbol-slot binding-size))
350 (inst fs-segment-prefix)
351 (inst mov (make-ea :dword :base tls-index) val))))
355 (:args (val :scs (any-reg descriptor-reg))
356 (symbol :scs (descriptor-reg)))
357 (:temporary (:sc unsigned-reg) temp bsp)
359 (load-symbol-value bsp *binding-stack-pointer*)
360 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
361 (inst add bsp (* binding-size n-word-bytes))
362 (store-symbol-value bsp *binding-stack-pointer*)
363 (storew temp bsp (- binding-value-slot binding-size))
364 (storew symbol bsp (- binding-symbol-slot binding-size))
365 (storew val symbol symbol-value-slot other-pointer-lowtag)))
371 (:temporary (:sc unsigned-reg) symbol value bsp tls-index)
373 (load-binding-stack-pointer bsp)
374 (loadw symbol bsp (- binding-symbol-slot binding-size))
375 (loadw value bsp (- binding-value-slot binding-size))
377 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
378 (inst fs-segment-prefix)
379 (inst mov (make-ea :dword :base tls-index) value)
381 (storew 0 bsp (- binding-symbol-slot binding-size))
382 (storew 0 bsp (- binding-value-slot binding-size))
383 (inst sub bsp (* binding-size n-word-bytes))
384 (store-binding-stack-pointer bsp)))
388 (:temporary (:sc unsigned-reg) symbol value bsp)
390 (load-symbol-value bsp *binding-stack-pointer*)
391 (loadw symbol bsp (- binding-symbol-slot binding-size))
392 (loadw value bsp (- binding-value-slot binding-size))
393 (storew value symbol symbol-value-slot other-pointer-lowtag)
394 (storew 0 bsp (- binding-symbol-slot binding-size))
395 (storew 0 bsp (- binding-value-slot binding-size))
396 (inst sub bsp (* binding-size n-word-bytes))
397 (store-symbol-value bsp *binding-stack-pointer*)))
400 (define-vop (unbind-to-here)
401 (:args (where :scs (descriptor-reg any-reg)))
402 (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index)
404 (load-binding-stack-pointer bsp)
409 (loadw symbol bsp (- binding-symbol-slot binding-size))
410 (inst or symbol symbol)
412 ;; Bind stack debug sentinels have the unbound marker in the symbol slot
413 (inst cmp symbol unbound-marker-widetag)
415 (loadw value bsp (- binding-value-slot binding-size))
416 #!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag)
419 tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
420 #!+sb-thread (inst fs-segment-prefix)
421 #!+sb-thread (inst mov (make-ea :dword :base tls-index) value)
422 (storew 0 bsp (- binding-symbol-slot binding-size))
425 (storew 0 bsp (- binding-value-slot binding-size))
426 (inst sub bsp (* binding-size n-word-bytes))
429 (store-binding-stack-pointer bsp)
433 (define-vop (bind-sentinel)
434 (:temporary (:sc unsigned-reg) bsp)
436 (load-binding-stack-pointer bsp)
437 (inst add bsp (* binding-size n-word-bytes))
438 (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
439 (storew ebp-tn bsp (- binding-value-slot binding-size))
440 (store-binding-stack-pointer bsp)))
442 (define-vop (unbind-sentinel)
443 (:temporary (:sc unsigned-reg) bsp)
445 (load-binding-stack-pointer bsp)
446 (storew 0 bsp (- binding-value-slot binding-size))
447 (storew 0 bsp (- binding-symbol-slot binding-size))
448 (inst sub bsp (* binding-size n-word-bytes))
449 (store-binding-stack-pointer bsp)))
453 ;;;; closure indexing
455 (define-full-reffer closure-index-ref *
456 closure-info-offset fun-pointer-lowtag
457 (any-reg descriptor-reg) * %closure-index-ref)
459 (define-full-setter set-funcallable-instance-info *
460 funcallable-instance-info-offset fun-pointer-lowtag
461 (any-reg descriptor-reg) * %set-funcallable-instance-info)
463 (define-full-reffer funcallable-instance-info *
464 funcallable-instance-info-offset fun-pointer-lowtag
465 (descriptor-reg any-reg) * %funcallable-instance-info)
467 (define-vop (closure-ref slot-ref)
468 (:variant closure-info-offset fun-pointer-lowtag))
470 (define-vop (closure-init slot-set)
471 (:variant closure-info-offset fun-pointer-lowtag))
473 ;;;; value cell hackery
475 (define-vop (value-cell-ref cell-ref)
476 (:variant value-cell-value-slot other-pointer-lowtag))
478 (define-vop (value-cell-set cell-set)
479 (:variant value-cell-value-slot other-pointer-lowtag))
481 ;;;; structure hackery
483 (define-vop (instance-length)
485 (:translate %instance-length)
486 (:args (struct :scs (descriptor-reg)))
487 (:results (res :scs (unsigned-reg)))
488 (:result-types positive-fixnum)
490 (loadw res struct 0 instance-pointer-lowtag)
491 (inst shr res n-widetag-bits)))
493 (define-full-reffer instance-index-ref *
494 instance-slots-offset instance-pointer-lowtag
495 (any-reg descriptor-reg) *
498 (define-full-setter instance-index-set *
499 instance-slots-offset instance-pointer-lowtag
500 (any-reg descriptor-reg) *
503 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
504 instance-slots-offset instance-pointer-lowtag
505 (any-reg descriptor-reg) *
506 %compare-and-swap-instance-ref)
508 ;;;; code object frobbing
510 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
511 (any-reg descriptor-reg) * code-header-ref)
513 (define-full-setter code-header-set * 0 other-pointer-lowtag
514 (any-reg descriptor-reg) * code-header-set)
516 ;;;; raw instance slot accessors
518 (defun make-ea-for-raw-slot (object index instance-length n-words)
520 (any-reg (make-ea :dword
522 :index instance-length
523 :disp (- (* (- instance-slots-offset n-words)
525 instance-pointer-lowtag)))
526 (immediate (make-ea :dword :base object
527 :index instance-length
529 :disp (- (* (- instance-slots-offset n-words)
531 instance-pointer-lowtag
532 (fixnumize (tn-value index)))))))
534 (define-vop (raw-instance-ref/word)
535 (:translate %raw-instance-ref/word)
537 (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)))
538 (:arg-types * tagged-num)
539 (:temporary (:sc unsigned-reg) tmp)
540 (:results (value :scs (unsigned-reg)))
541 (:result-types unsigned-num)
543 (loadw tmp object 0 instance-pointer-lowtag)
544 (inst shr tmp n-widetag-bits)
545 (when (sc-is index any-reg)
547 (inst sub tmp index))
548 (inst mov value (make-ea-for-raw-slot object index tmp 1))))
550 (define-vop (raw-instance-set/word)
551 (:translate %raw-instance-set/word)
553 (:args (object :scs (descriptor-reg))
554 (index :scs (any-reg immediate))
555 (value :scs (unsigned-reg) :target result))
556 (:arg-types * tagged-num unsigned-num)
557 (:temporary (:sc unsigned-reg) tmp)
558 (:results (result :scs (unsigned-reg)))
559 (:result-types unsigned-num)
561 (loadw tmp object 0 instance-pointer-lowtag)
562 (inst shr tmp n-widetag-bits)
563 (when (sc-is index any-reg)
565 (inst sub tmp index))
566 (inst mov (make-ea-for-raw-slot object index tmp 1) value)
567 (move result value)))
569 (define-vop (raw-instance-ref/single)
570 (:translate %raw-instance-ref/single)
572 (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)))
573 (:arg-types * tagged-num)
574 (:temporary (:sc unsigned-reg) tmp)
575 (:results (value :scs (single-reg)))
576 (:result-types single-float)
578 (loadw tmp object 0 instance-pointer-lowtag)
579 (inst shr tmp n-widetag-bits)
580 (when (sc-is index any-reg)
582 (inst sub tmp index))
583 (with-empty-tn@fp-top(value)
584 (inst fld (make-ea-for-raw-slot object index tmp 1)))))
586 (define-vop (raw-instance-set/single)
587 (:translate %raw-instance-set/single)
589 (:args (object :scs (descriptor-reg))
590 (index :scs (any-reg immediate))
591 (value :scs (single-reg) :target result))
592 (:arg-types * tagged-num single-float)
593 (:temporary (:sc unsigned-reg) tmp)
594 (:results (result :scs (single-reg)))
595 (:result-types single-float)
597 (loadw tmp object 0 instance-pointer-lowtag)
598 (inst shr tmp n-widetag-bits)
599 (when (sc-is index any-reg)
601 (inst sub tmp index))
602 (unless (zerop (tn-offset value))
604 (inst fst (make-ea-for-raw-slot object index tmp 1))
606 ((zerop (tn-offset value))
607 (unless (zerop (tn-offset result))
609 ((zerop (tn-offset result))
612 (unless (location= value result)
614 (inst fxch value)))))
616 (define-vop (raw-instance-ref/double)
617 (:translate %raw-instance-ref/double)
619 (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)))
620 (:arg-types * tagged-num)
621 (:temporary (:sc unsigned-reg) tmp)
622 (:results (value :scs (double-reg)))
623 (:result-types double-float)
625 (loadw tmp object 0 instance-pointer-lowtag)
626 (inst shr tmp n-widetag-bits)
627 (when (sc-is index any-reg)
629 (inst sub tmp index))
630 (with-empty-tn@fp-top(value)
631 (inst fldd (make-ea-for-raw-slot object index tmp 2)))))
633 (define-vop (raw-instance-set/double)
634 (:translate %raw-instance-set/double)
636 (:args (object :scs (descriptor-reg))
637 (index :scs (any-reg immediate))
638 (value :scs (double-reg) :target result))
639 (:arg-types * tagged-num double-float)
640 (:temporary (:sc unsigned-reg) tmp)
641 (:results (result :scs (double-reg)))
642 (:result-types double-float)
644 (loadw tmp object 0 instance-pointer-lowtag)
645 (inst shr tmp n-widetag-bits)
646 (when (sc-is index any-reg)
648 (inst sub tmp index))
649 (unless (zerop (tn-offset value))
651 (inst fstd (make-ea-for-raw-slot object index tmp 2))
653 ((zerop (tn-offset value))
654 (unless (zerop (tn-offset result))
656 ((zerop (tn-offset result))
659 (unless (location= value result)
661 (inst fxch value)))))
663 (define-vop (raw-instance-ref/complex-single)
664 (:translate %raw-instance-ref/complex-single)
666 (:args (object :scs (descriptor-reg))
667 (index :scs (any-reg immediate)))
668 (:arg-types * positive-fixnum)
669 (:temporary (:sc unsigned-reg) tmp)
670 (:results (value :scs (complex-single-reg)))
671 (:result-types complex-single-float)
673 (loadw tmp object 0 instance-pointer-lowtag)
674 (inst shr tmp n-widetag-bits)
675 (when (sc-is index any-reg)
677 (inst sub tmp index))
678 (let ((real-tn (complex-single-reg-real-tn value)))
679 (with-empty-tn@fp-top (real-tn)
680 (inst fld (make-ea-for-raw-slot object index tmp 2))))
681 (let ((imag-tn (complex-single-reg-imag-tn value)))
682 (with-empty-tn@fp-top (imag-tn)
683 (inst fld (make-ea-for-raw-slot object index tmp 1))))))
685 (define-vop (raw-instance-set/complex-single)
686 (:translate %raw-instance-set/complex-single)
688 (:args (object :scs (descriptor-reg))
689 (index :scs (any-reg immediate))
690 (value :scs (complex-single-reg) :target result))
691 (:arg-types * positive-fixnum complex-single-float)
692 (:temporary (:sc unsigned-reg) tmp)
693 (:results (result :scs (complex-single-reg)))
694 (:result-types complex-single-float)
696 (loadw tmp object 0 instance-pointer-lowtag)
697 (inst shr tmp n-widetag-bits)
698 (when (sc-is index any-reg)
700 (inst sub tmp index))
701 (let ((value-real (complex-single-reg-real-tn value))
702 (result-real (complex-single-reg-real-tn result)))
703 (cond ((zerop (tn-offset value-real))
705 (inst fst (make-ea-for-raw-slot object index tmp 2))
706 (unless (zerop (tn-offset result-real))
707 ;; Value is in ST0 but not result.
708 (inst fst result-real)))
710 ;; Value is not in ST0.
711 (inst fxch value-real)
712 (inst fst (make-ea-for-raw-slot object index tmp 2))
713 (cond ((zerop (tn-offset result-real))
714 ;; The result is in ST0.
715 (inst fst value-real))
717 ;; Neither value or result are in ST0
718 (unless (location= value-real result-real)
719 (inst fst result-real))
720 (inst fxch value-real))))))
721 (let ((value-imag (complex-single-reg-imag-tn value))
722 (result-imag (complex-single-reg-imag-tn result)))
723 (inst fxch value-imag)
724 (inst fst (make-ea-for-raw-slot object index tmp 1))
725 (unless (location= value-imag result-imag)
726 (inst fst result-imag))
727 (inst fxch value-imag))))
729 (define-vop (raw-instance-ref/complex-double)
730 (:translate %raw-instance-ref/complex-double)
732 (:args (object :scs (descriptor-reg))
733 (index :scs (any-reg immediate)))
734 (:arg-types * positive-fixnum)
735 (:temporary (:sc unsigned-reg) tmp)
736 (:results (value :scs (complex-double-reg)))
737 (:result-types complex-double-float)
739 (loadw tmp object 0 instance-pointer-lowtag)
740 (inst shr tmp n-widetag-bits)
741 (when (sc-is index any-reg)
743 (inst sub tmp index))
744 (let ((real-tn (complex-double-reg-real-tn value)))
745 (with-empty-tn@fp-top (real-tn)
746 (inst fldd (make-ea-for-raw-slot object index tmp 4))))
747 (let ((imag-tn (complex-double-reg-imag-tn value)))
748 (with-empty-tn@fp-top (imag-tn)
749 (inst fldd (make-ea-for-raw-slot object index tmp 2))))))
751 (define-vop (raw-instance-set/complex-double)
752 (:translate %raw-instance-set/complex-double)
754 (:args (object :scs (descriptor-reg))
755 (index :scs (any-reg immediate))
756 (value :scs (complex-double-reg) :target result))
757 (:arg-types * positive-fixnum complex-double-float)
758 (:temporary (:sc unsigned-reg) tmp)
759 (:results (result :scs (complex-double-reg)))
760 (:result-types complex-double-float)
762 (loadw tmp object 0 instance-pointer-lowtag)
763 (inst shr tmp n-widetag-bits)
764 (when (sc-is index any-reg)
766 (inst sub tmp index))
767 (let ((value-real (complex-double-reg-real-tn value))
768 (result-real (complex-double-reg-real-tn result)))
769 (cond ((zerop (tn-offset value-real))
771 (inst fstd (make-ea-for-raw-slot object index tmp 4))
772 (unless (zerop (tn-offset result-real))
773 ;; Value is in ST0 but not result.
774 (inst fstd result-real)))
776 ;; Value is not in ST0.
777 (inst fxch value-real)
778 (inst fstd (make-ea-for-raw-slot object index tmp 4))
779 (cond ((zerop (tn-offset result-real))
780 ;; The result is in ST0.
781 (inst fstd value-real))
783 ;; Neither value or result are in ST0
784 (unless (location= value-real result-real)
785 (inst fstd result-real))
786 (inst fxch value-real))))))
787 (let ((value-imag (complex-double-reg-imag-tn value))
788 (result-imag (complex-double-reg-imag-tn result)))
789 (inst fxch value-imag)
790 (inst fstd (make-ea-for-raw-slot object index tmp 2))
791 (unless (location= value-imag result-imag)
792 (inst fstd result-imag))
793 (inst fxch value-imag))))