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 symbol-global-value))
98 (define-vop (symbol-global-value)
100 (:translate symbol-global-value)
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)
133 (:translate 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. --
161 (:translate symbol-value)
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 symbol-value))
176 (define-vop (fast-symbol-value fast-symbol-global-value)
177 (:translate symbol-value))
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 (:args (object :scs (descriptor-reg) :to (:result 1)))
231 (:results (value :scs (descriptor-reg any-reg)))
233 (:save-p :compute-only)
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))))
240 (define-vop (set-fdefn-fun)
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)))
249 (load-type type function (- fun-pointer-lowtag))
251 (make-ea-for-object-slot function simple-fun-code-offset
253 (inst cmp type simple-fun-header-widetag)
254 (inst jmp :e normal-fn)
255 (inst lea raw (make-fixup "closure_tramp" :foreign))
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)))
261 (define-vop (fdefn-makunbound)
263 (:translate fdefn-makunbound)
264 (:args (fdefn :scs (descriptor-reg) :target result))
265 (:results (result :scs (descriptor-reg)))
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)))
272 ;;;; binding and unbinding
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
277 ;;; See the "Chapter 9: Specials" of the SBCL Internals Manual.
279 ;;; FIXME: Split into DYNBIND and BIND: DYNBIND needs to ensure
280 ;;; TLS-INDEX, whereas BIND should assume it is already in place. Make
281 ;;; LET &co compile into BIND, and PROGV into DYNBIND, plus ensure
282 ;;; TLS-INDEX at compile-time, and make loader and dumper preserve
283 ;;; the existence of a TLS-INDEX.
286 (:args (val :scs (any-reg descriptor-reg))
287 (symbol :scs (descriptor-reg)))
288 (:temporary (:sc unsigned-reg) tls-index bsp)
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))
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 tls-index bsp (- binding-symbol-slot binding-size))
311 (inst mov EA val :maybe-fs))))
315 (:args (val :scs (any-reg descriptor-reg))
316 (symbol :scs (descriptor-reg)))
317 (:temporary (:sc unsigned-reg) temp bsp)
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)))
329 (:temporary (:sc unsigned-reg) temp bsp tls-index)
331 (load-binding-stack-pointer bsp)
332 ;; Load SYMBOL from stack, and get the TLS-INDEX.
333 (loadw tls-index bsp (- binding-symbol-slot binding-size))
334 ;; Load VALUE from stack, then restore it to the TLS area.
335 (loadw temp bsp (- binding-value-slot binding-size))
336 (with-tls-ea (EA :base tls-index :base-already-live-p t)
337 (inst mov EA temp :maybe-fs))
338 ;; Zero out the stack.
339 (inst sub bsp (* binding-size n-word-bytes))
340 (storew 0 bsp binding-symbol-slot)
341 (storew 0 bsp binding-value-slot)
342 (store-binding-stack-pointer bsp)))
346 (:temporary (:sc unsigned-reg) symbol value bsp)
348 (load-symbol-value bsp *binding-stack-pointer*)
349 (loadw symbol bsp (- binding-symbol-slot binding-size))
350 (loadw value bsp (- binding-value-slot binding-size))
351 (storew value symbol symbol-value-slot other-pointer-lowtag)
352 (storew 0 bsp (- binding-symbol-slot binding-size))
353 (storew 0 bsp (- binding-value-slot binding-size))
354 (inst sub bsp (* binding-size n-word-bytes))
355 (store-symbol-value bsp *binding-stack-pointer*)))
358 (define-vop (unbind-to-here)
359 (:args (where :scs (descriptor-reg any-reg)))
360 (:temporary (:sc unsigned-reg) symbol value bsp)
362 (load-binding-stack-pointer bsp)
367 (inst sub bsp (* binding-size n-word-bytes))
368 (loadw symbol bsp binding-symbol-slot)
369 (inst test symbol symbol)
371 ;; Bind stack debug sentinels have the unbound marker in the symbol slot
372 (inst cmp symbol unbound-marker-widetag)
374 (loadw value bsp binding-value-slot)
375 #!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag)
376 #!+sb-thread (with-tls-ea (EA :base symbol :base-already-live-p t)
377 (inst mov EA value :maybe-fs))
378 (storew 0 bsp binding-symbol-slot)
381 (storew 0 bsp binding-value-slot)
384 (store-binding-stack-pointer bsp)
388 (define-vop (bind-sentinel)
389 (:temporary (:sc unsigned-reg) bsp)
391 (load-binding-stack-pointer bsp)
392 (inst add bsp (* binding-size n-word-bytes))
393 (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
394 (storew ebp-tn bsp (- binding-value-slot binding-size))
395 (store-binding-stack-pointer bsp)))
397 (define-vop (unbind-sentinel)
398 (:temporary (:sc unsigned-reg) bsp)
400 (load-binding-stack-pointer bsp)
401 (storew 0 bsp (- binding-value-slot binding-size))
402 (storew 0 bsp (- binding-symbol-slot binding-size))
403 (inst sub bsp (* binding-size n-word-bytes))
404 (store-binding-stack-pointer bsp)))
408 ;;;; closure indexing
410 (define-full-reffer closure-index-ref *
411 closure-info-offset fun-pointer-lowtag
412 (any-reg descriptor-reg) * %closure-index-ref)
414 (define-full-setter set-funcallable-instance-info *
415 funcallable-instance-info-offset fun-pointer-lowtag
416 (any-reg descriptor-reg) * %set-funcallable-instance-info)
418 (define-full-reffer funcallable-instance-info *
419 funcallable-instance-info-offset fun-pointer-lowtag
420 (descriptor-reg any-reg) * %funcallable-instance-info)
422 (define-vop (closure-ref slot-ref)
423 (:variant closure-info-offset fun-pointer-lowtag))
425 (define-vop (closure-init slot-set)
426 (:variant closure-info-offset fun-pointer-lowtag))
428 (define-vop (closure-init-from-fp)
429 (:args (object :scs (descriptor-reg)))
432 (storew ebp-tn object (+ closure-info-offset offset) fun-pointer-lowtag)))
434 ;;;; value cell hackery
436 (define-vop (value-cell-ref cell-ref)
437 (:variant value-cell-value-slot other-pointer-lowtag))
439 (define-vop (value-cell-set cell-set)
440 (:variant value-cell-value-slot other-pointer-lowtag))
442 ;;;; structure hackery
444 (define-vop (instance-length)
446 (:translate %instance-length)
447 (:args (struct :scs (descriptor-reg)))
448 (:results (res :scs (unsigned-reg)))
449 (:result-types positive-fixnum)
451 (loadw res struct 0 instance-pointer-lowtag)
452 (inst shr res n-widetag-bits)))
454 (define-full-reffer instance-index-ref *
455 instance-slots-offset instance-pointer-lowtag
456 (any-reg descriptor-reg) *
459 (define-full-setter instance-index-set *
460 instance-slots-offset instance-pointer-lowtag
461 (any-reg descriptor-reg) *
464 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
465 instance-slots-offset instance-pointer-lowtag
466 (any-reg descriptor-reg) *
467 %compare-and-swap-instance-ref)
469 ;;;; code object frobbing
471 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
472 (any-reg descriptor-reg) * code-header-ref)
474 (define-full-setter code-header-set * 0 other-pointer-lowtag
475 (any-reg descriptor-reg) * code-header-set)
477 ;;;; raw instance slot accessors
479 (defun make-ea-for-raw-slot (object index instance-length n-words)
480 (if (integerp instance-length)
481 ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
485 :disp (- (* (- instance-length instance-slots-offset index (1- n-words))
487 instance-pointer-lowtag))
488 (flet ((make-ea-using-value (value)
489 (make-ea :dword :base object
490 :index instance-length
492 :disp (- (* (- instance-slots-offset n-words)
494 instance-pointer-lowtag
495 (* value n-word-bytes)))))
496 (if (typep index 'tn)
498 (any-reg (make-ea :dword
500 :index instance-length
501 :disp (- (* (- instance-slots-offset n-words)
503 instance-pointer-lowtag)))
504 (immediate (make-ea-using-value (tn-value index))))
505 (make-ea-using-value index)))))
507 (define-vop (raw-instance-ref/word)
508 (:translate %raw-instance-ref/word)
510 (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)))
511 (:arg-types * tagged-num)
512 (:temporary (:sc unsigned-reg) tmp)
513 (:results (value :scs (unsigned-reg)))
514 (:result-types unsigned-num)
516 (loadw tmp object 0 instance-pointer-lowtag)
517 (inst shr tmp n-widetag-bits)
518 (when (sc-is index any-reg)
519 (inst shl tmp n-fixnum-tag-bits)
520 (inst sub tmp index))
521 (inst mov value (make-ea-for-raw-slot object index tmp 1))))
523 (define-vop (raw-instance-set/word)
524 (:translate %raw-instance-set/word)
526 (:args (object :scs (descriptor-reg))
527 (index :scs (any-reg immediate))
528 (value :scs (unsigned-reg) :target result))
529 (:arg-types * tagged-num unsigned-num)
530 (:temporary (:sc unsigned-reg) tmp)
531 (:results (result :scs (unsigned-reg)))
532 (:result-types unsigned-num)
534 (loadw tmp object 0 instance-pointer-lowtag)
535 (inst shr tmp n-widetag-bits)
536 (when (sc-is index any-reg)
537 (inst shl tmp n-fixnum-tag-bits)
538 (inst sub tmp index))
539 (inst mov (make-ea-for-raw-slot object index tmp 1) value)
540 (move result value)))
542 (define-vop (raw-instance-init/word)
543 (:args (object :scs (descriptor-reg))
544 (value :scs (unsigned-reg)))
545 (:arg-types * unsigned-num)
546 (:info instance-length index)
548 (inst mov (make-ea-for-raw-slot object index instance-length 1) value)))
550 (define-vop (raw-instance-atomic-incf/word)
551 (:translate %raw-instance-atomic-incf/word)
553 (:args (object :scs (descriptor-reg))
554 (index :scs (any-reg immediate))
555 (diff :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)
564 (inst shl tmp n-fixnum-tag-bits)
565 (inst sub tmp index))
566 (inst xadd (make-ea-for-raw-slot object index tmp 1) diff :lock)
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)
581 (inst shl tmp n-fixnum-tag-bits)
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)
600 (inst shl tmp n-fixnum-tag-bits)
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-init/single)
617 (:args (object :scs (descriptor-reg))
618 (value :scs (single-reg)))
619 (:arg-types * single-float)
620 (:info instance-length index)
622 (with-tn@fp-top (value)
623 (inst fst (make-ea-for-raw-slot object index instance-length 1)))))
625 (define-vop (raw-instance-ref/double)
626 (:translate %raw-instance-ref/double)
628 (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)))
629 (:arg-types * tagged-num)
630 (:temporary (:sc unsigned-reg) tmp)
631 (:results (value :scs (double-reg)))
632 (:result-types double-float)
634 (loadw tmp object 0 instance-pointer-lowtag)
635 (inst shr tmp n-widetag-bits)
636 (when (sc-is index any-reg)
637 (inst shl tmp n-fixnum-tag-bits)
638 (inst sub tmp index))
639 (with-empty-tn@fp-top(value)
640 (inst fldd (make-ea-for-raw-slot object index tmp 2)))))
642 (define-vop (raw-instance-set/double)
643 (:translate %raw-instance-set/double)
645 (:args (object :scs (descriptor-reg))
646 (index :scs (any-reg immediate))
647 (value :scs (double-reg) :target result))
648 (:arg-types * tagged-num double-float)
649 (:temporary (:sc unsigned-reg) tmp)
650 (:results (result :scs (double-reg)))
651 (:result-types double-float)
653 (loadw tmp object 0 instance-pointer-lowtag)
654 (inst shr tmp n-widetag-bits)
655 (when (sc-is index any-reg)
656 (inst shl tmp n-fixnum-tag-bits)
657 (inst sub tmp index))
658 (unless (zerop (tn-offset value))
660 (inst fstd (make-ea-for-raw-slot object index tmp 2))
662 ((zerop (tn-offset value))
663 (unless (zerop (tn-offset result))
665 ((zerop (tn-offset result))
668 (unless (location= value result)
670 (inst fxch value)))))
672 (define-vop (raw-instance-init/double)
673 (:args (object :scs (descriptor-reg))
674 (value :scs (double-reg)))
675 (:arg-types * double-float)
676 (:info instance-length index)
678 (with-tn@fp-top (value)
679 (inst fstd (make-ea-for-raw-slot object index instance-length 2)))))
681 (define-vop (raw-instance-ref/complex-single)
682 (:translate %raw-instance-ref/complex-single)
684 (:args (object :scs (descriptor-reg))
685 (index :scs (any-reg immediate)))
686 (:arg-types * positive-fixnum)
687 (:temporary (:sc unsigned-reg) tmp)
688 (:results (value :scs (complex-single-reg)))
689 (:result-types complex-single-float)
691 (loadw tmp object 0 instance-pointer-lowtag)
692 (inst shr tmp n-widetag-bits)
693 (when (sc-is index any-reg)
694 (inst shl tmp n-fixnum-tag-bits)
695 (inst sub tmp index))
696 (let ((real-tn (complex-single-reg-real-tn value)))
697 (with-empty-tn@fp-top (real-tn)
698 (inst fld (make-ea-for-raw-slot object index tmp 2))))
699 (let ((imag-tn (complex-single-reg-imag-tn value)))
700 (with-empty-tn@fp-top (imag-tn)
701 (inst fld (make-ea-for-raw-slot object index tmp 1))))))
703 (define-vop (raw-instance-set/complex-single)
704 (:translate %raw-instance-set/complex-single)
706 (:args (object :scs (descriptor-reg))
707 (index :scs (any-reg immediate))
708 (value :scs (complex-single-reg) :target result))
709 (:arg-types * positive-fixnum complex-single-float)
710 (:temporary (:sc unsigned-reg) tmp)
711 (:results (result :scs (complex-single-reg)))
712 (:result-types complex-single-float)
714 (loadw tmp object 0 instance-pointer-lowtag)
715 (inst shr tmp n-widetag-bits)
716 (when (sc-is index any-reg)
717 (inst shl tmp n-fixnum-tag-bits)
718 (inst sub tmp index))
719 (let ((value-real (complex-single-reg-real-tn value))
720 (result-real (complex-single-reg-real-tn result)))
721 (cond ((zerop (tn-offset value-real))
723 (inst fst (make-ea-for-raw-slot object index tmp 2))
724 (unless (zerop (tn-offset result-real))
725 ;; Value is in ST0 but not result.
726 (inst fst result-real)))
728 ;; Value is not in ST0.
729 (inst fxch value-real)
730 (inst fst (make-ea-for-raw-slot object index tmp 2))
731 (cond ((zerop (tn-offset result-real))
732 ;; The result is in ST0.
733 (inst fst value-real))
735 ;; Neither value or result are in ST0
736 (unless (location= value-real result-real)
737 (inst fst result-real))
738 (inst fxch value-real))))))
739 (let ((value-imag (complex-single-reg-imag-tn value))
740 (result-imag (complex-single-reg-imag-tn result)))
741 (inst fxch value-imag)
742 (inst fst (make-ea-for-raw-slot object index tmp 1))
743 (unless (location= value-imag result-imag)
744 (inst fst result-imag))
745 (inst fxch value-imag))))
747 (define-vop (raw-instance-init/complex-single)
748 (:args (object :scs (descriptor-reg))
749 (value :scs (complex-single-reg)))
750 (:arg-types * complex-single-float)
751 (:info instance-length index)
753 (let ((value-real (complex-single-reg-real-tn value)))
754 (with-tn@fp-top (value-real)
755 (inst fst (make-ea-for-raw-slot object index instance-length 2))))
756 (let ((value-imag (complex-single-reg-imag-tn value)))
757 (with-tn@fp-top (value-imag)
758 (inst fst (make-ea-for-raw-slot object index instance-length 1))))))
760 (define-vop (raw-instance-ref/complex-double)
761 (:translate %raw-instance-ref/complex-double)
763 (:args (object :scs (descriptor-reg))
764 (index :scs (any-reg immediate)))
765 (:arg-types * positive-fixnum)
766 (:temporary (:sc unsigned-reg) tmp)
767 (:results (value :scs (complex-double-reg)))
768 (:result-types complex-double-float)
770 (loadw tmp object 0 instance-pointer-lowtag)
771 (inst shr tmp n-widetag-bits)
772 (when (sc-is index any-reg)
773 (inst shl tmp n-fixnum-tag-bits)
774 (inst sub tmp index))
775 (let ((real-tn (complex-double-reg-real-tn value)))
776 (with-empty-tn@fp-top (real-tn)
777 (inst fldd (make-ea-for-raw-slot object index tmp 4))))
778 (let ((imag-tn (complex-double-reg-imag-tn value)))
779 (with-empty-tn@fp-top (imag-tn)
780 (inst fldd (make-ea-for-raw-slot object index tmp 2))))))
782 (define-vop (raw-instance-set/complex-double)
783 (:translate %raw-instance-set/complex-double)
785 (:args (object :scs (descriptor-reg))
786 (index :scs (any-reg immediate))
787 (value :scs (complex-double-reg) :target result))
788 (:arg-types * positive-fixnum complex-double-float)
789 (:temporary (:sc unsigned-reg) tmp)
790 (:results (result :scs (complex-double-reg)))
791 (:result-types complex-double-float)
793 (loadw tmp object 0 instance-pointer-lowtag)
794 (inst shr tmp n-widetag-bits)
795 (when (sc-is index any-reg)
796 (inst shl tmp n-fixnum-tag-bits)
797 (inst sub tmp index))
798 (let ((value-real (complex-double-reg-real-tn value))
799 (result-real (complex-double-reg-real-tn result)))
800 (cond ((zerop (tn-offset value-real))
802 (inst fstd (make-ea-for-raw-slot object index tmp 4))
803 (unless (zerop (tn-offset result-real))
804 ;; Value is in ST0 but not result.
805 (inst fstd result-real)))
807 ;; Value is not in ST0.
808 (inst fxch value-real)
809 (inst fstd (make-ea-for-raw-slot object index tmp 4))
810 (cond ((zerop (tn-offset result-real))
811 ;; The result is in ST0.
812 (inst fstd value-real))
814 ;; Neither value or result are in ST0
815 (unless (location= value-real result-real)
816 (inst fstd result-real))
817 (inst fxch value-real))))))
818 (let ((value-imag (complex-double-reg-imag-tn value))
819 (result-imag (complex-double-reg-imag-tn result)))
820 (inst fxch value-imag)
821 (inst fstd (make-ea-for-raw-slot object index tmp 2))
822 (unless (location= value-imag result-imag)
823 (inst fstd result-imag))
824 (inst fxch value-imag))))
826 (define-vop (raw-instance-init/complex-double)
827 (:args (object :scs (descriptor-reg))
828 (value :scs (complex-double-reg)))
829 (:arg-types * complex-double-float)
830 (:info instance-length index)
832 (let ((value-real (complex-double-reg-real-tn value)))
833 (with-tn@fp-top (value-real)
834 (inst fstd (make-ea-for-raw-slot object index instance-length 4))))
835 (let ((value-imag (complex-double-reg-imag-tn value)))
836 (with-tn@fp-top (value-imag)
837 (inst fstd (make-ea-for-raw-slot object index instance-length 2))))))