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, no 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
)
106 (inst fs-segment-prefix
)
107 (inst cmp
(make-ea :dword
:base tls
) no-tls-value-marker-widetag
)
108 (inst jmp
:z global-val
)
109 (inst fs-segment-prefix
)
110 (inst mov
(make-ea :dword
:base tls
) value
)
112 (emit-label global-val
)
113 (storew value symbol symbol-value-slot other-pointer-lowtag
)
116 ;; unithreaded it's a lot simpler ...
118 (define-vop (set cell-set
)
119 (:variant symbol-value-slot other-pointer-lowtag
))
121 ;;; With Symbol-Value, we check that the value isn't the trap object. So
122 ;;; Symbol-Value of NIL is NIL.
124 (define-vop (symbol-value)
125 (:translate symbol-value
)
127 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
128 (:results
(value :scs
(descriptor-reg any-reg
)))
130 (:save-p
:compute-only
)
132 (let* ((check-unbound-label (gen-label))
133 (err-lab (generate-error-code vop unbound-symbol-error object
))
134 (ret-lab (gen-label)))
135 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
136 (inst fs-segment-prefix
)
137 (inst mov value
(make-ea :dword
:base value
))
138 (inst cmp value no-tls-value-marker-widetag
)
139 (inst jmp
:ne check-unbound-label
)
140 (loadw value object symbol-value-slot other-pointer-lowtag
)
141 (emit-label check-unbound-label
)
142 (inst cmp value unbound-marker-widetag
)
143 (inst jmp
:e err-lab
)
144 (emit-label ret-lab
))))
147 (define-vop (fast-symbol-value symbol-value
)
148 ;; KLUDGE: not really fast, in fact, because we're going to have to
149 ;; do a full lookup of the thread-local area anyway. But half of
150 ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
151 ;; unbound", which is used in the implementation of COPY-SYMBOL. --
154 (:translate symbol-value
)
156 (let ((ret-lab (gen-label)))
157 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
158 (inst fs-segment-prefix
)
159 (inst mov value
(make-ea :dword
:base value
))
160 (inst cmp value no-tls-value-marker-widetag
)
161 (inst jmp
:ne ret-lab
)
162 (loadw value object symbol-value-slot other-pointer-lowtag
)
163 (emit-label ret-lab
))))
166 (define-vop (symbol-value)
167 (:translate symbol-value
)
169 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
170 (:results
(value :scs
(descriptor-reg any-reg
)))
172 (:save-p
:compute-only
)
174 (let ((err-lab (generate-error-code vop unbound-symbol-error object
)))
175 (loadw value object symbol-value-slot other-pointer-lowtag
)
176 (inst cmp value unbound-marker-widetag
)
177 (inst jmp
:e err-lab
))))
180 (define-vop (fast-symbol-value cell-ref
)
181 (:variant symbol-value-slot other-pointer-lowtag
)
183 (:translate symbol-value
))
185 (defknown locked-symbol-global-value-add
(symbol fixnum
) fixnum
())
187 (define-vop (locked-symbol-global-value-add)
188 (:args
(object :scs
(descriptor-reg) :to
:result
)
189 (value :scs
(any-reg) :target result
))
190 (:arg-types
* tagged-num
)
191 (:results
(result :scs
(any-reg) :from
(:argument
1)))
193 (:translate locked-symbol-global-value-add
)
194 (:result-types tagged-num
)
199 (inst add
(make-ea-for-object-slot object symbol-value-slot
200 other-pointer-lowtag
)
207 (:args
(object :scs
(descriptor-reg)))
210 (:temporary
(:sc descriptor-reg
#+nil
(:from
(:argument
0))) value
)
212 (let ((check-unbound-label (gen-label)))
213 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
214 (inst fs-segment-prefix
)
215 (inst mov value
(make-ea :dword
:base value
))
216 (inst cmp value no-tls-value-marker-widetag
)
217 (inst jmp
:ne check-unbound-label
)
218 (loadw value object symbol-value-slot other-pointer-lowtag
)
219 (emit-label check-unbound-label
)
220 (inst cmp value unbound-marker-widetag
)
221 (inst jmp
(if not-p
:e
:ne
) target
))))
227 (:args
(object :scs
(descriptor-reg)))
231 (inst cmp
(make-ea-for-object-slot object symbol-value-slot
232 other-pointer-lowtag
)
233 unbound-marker-widetag
)
234 (inst jmp
(if not-p
:e
:ne
) target
)))
237 (define-vop (symbol-hash)
239 (:translate symbol-hash
)
240 (:args
(symbol :scs
(descriptor-reg)))
241 (:results
(res :scs
(any-reg)))
242 (:result-types positive-fixnum
)
244 ;; The symbol-hash slot of NIL holds NIL because it is also the
245 ;; cdr slot, so we have to strip off the two low bits to make sure
246 ;; it is a fixnum. The lowtag selection magic that is required to
247 ;; ensure this is explained in the comment in objdef.lisp
248 (loadw res symbol symbol-hash-slot other-pointer-lowtag
)
249 (inst and res
(lognot #b11
))))
251 ;;;; fdefinition (FDEFN) objects
253 (define-vop (fdefn-fun cell-ref
) ; /pfw - alpha
254 (:variant fdefn-fun-slot other-pointer-lowtag
))
256 (define-vop (safe-fdefn-fun)
257 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
258 (:results
(value :scs
(descriptor-reg any-reg
)))
260 (:save-p
:compute-only
)
262 (loadw value object fdefn-fun-slot other-pointer-lowtag
)
263 (inst cmp value nil-value
)
264 (let ((err-lab (generate-error-code vop undefined-fun-error object
)))
265 (inst jmp
:e err-lab
))))
267 (define-vop (set-fdefn-fun)
269 (:translate
(setf fdefn-fun
))
270 (:args
(function :scs
(descriptor-reg) :target result
)
271 (fdefn :scs
(descriptor-reg)))
272 (:temporary
(:sc unsigned-reg
) raw
)
273 (:temporary
(:sc byte-reg
) type
)
274 (:results
(result :scs
(descriptor-reg)))
276 (load-type type function
(- fun-pointer-lowtag
))
278 (make-ea-for-object-slot function simple-fun-code-offset
280 (inst cmp type simple-fun-header-widetag
)
281 (inst jmp
:e normal-fn
)
282 (inst lea raw
(make-fixup "closure_tramp" :foreign
))
284 (storew function fdefn fdefn-fun-slot other-pointer-lowtag
)
285 (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
286 (move result function
)))
288 (define-vop (fdefn-makunbound)
290 (:translate fdefn-makunbound
)
291 (:args
(fdefn :scs
(descriptor-reg) :target result
))
292 (:results
(result :scs
(descriptor-reg)))
294 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag
)
295 (storew (make-fixup "undefined_tramp" :foreign
)
296 fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
297 (move result fdefn
)))
299 ;;;; binding and unbinding
301 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
302 ;;; the symbol on the binding stack and stuff the new value into the
307 (:args
(val :scs
(any-reg descriptor-reg
))
308 (symbol :scs
(descriptor-reg)))
309 (:temporary
(:sc descriptor-reg
:offset eax-offset
) eax
)
310 (:temporary
(:sc unsigned-reg
) tls-index bsp
)
312 (let ((tls-index-valid (gen-label))
313 (get-tls-index-lock (gen-label))
314 (release-tls-index-lock (gen-label)))
315 (load-binding-stack-pointer bsp
)
316 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
317 (inst add bsp
(* binding-size n-word-bytes
))
318 (store-binding-stack-pointer bsp
)
319 (inst or tls-index tls-index
)
320 (inst jmp
:ne tls-index-valid
)
323 ;; * We should ensure the existence of TLS index for LET-bound specials
324 ;; at compile/load time, and use write a FAST-BIND for use with those.
325 ;; * PROGV will need to do this, but even there this should not be inline.
326 ;; This is probably best moved to C, since dynbind.c also needs to do this.
328 (emit-label get-tls-index-lock
)
329 (inst mov tls-index
1)
332 (inst cmpxchg
(make-ea-for-symbol-value *tls-index-lock
*) tls-index
)
333 (inst jmp
:ne get-tls-index-lock
)
334 ;; now with the lock held, see if the symbol's tls index has
335 ;; been set in the meantime
336 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
337 (inst or tls-index tls-index
)
338 (inst jmp
:ne release-tls-index-lock
)
339 ;; allocate a new tls-index
340 (load-symbol-value tls-index
*free-tls-index
*)
341 (inst add
(make-ea-for-symbol-value *free-tls-index
*) 4) ; fixnum + 1
342 (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
343 (emit-label release-tls-index-lock
)
344 (store-symbol-value 0 *tls-index-lock
*))
346 (emit-label tls-index-valid
)
347 (inst fs-segment-prefix
)
348 (inst mov eax
(make-ea :dword
:base tls-index
))
349 (storew eax bsp
(- binding-value-slot binding-size
))
350 (storew symbol bsp
(- binding-symbol-slot binding-size
))
351 (inst fs-segment-prefix
)
352 (inst mov
(make-ea :dword
:base tls-index
) val
))))
356 (:args
(val :scs
(any-reg descriptor-reg
))
357 (symbol :scs
(descriptor-reg)))
358 (:temporary
(:sc unsigned-reg
) temp bsp
)
360 (load-symbol-value bsp
*binding-stack-pointer
*)
361 (loadw temp symbol symbol-value-slot other-pointer-lowtag
)
362 (inst add bsp
(* binding-size n-word-bytes
))
363 (store-symbol-value bsp
*binding-stack-pointer
*)
364 (storew temp bsp
(- binding-value-slot binding-size
))
365 (storew symbol bsp
(- binding-symbol-slot binding-size
))
366 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
372 (:temporary
(:sc unsigned-reg
) symbol value bsp tls-index
)
374 (load-binding-stack-pointer bsp
)
375 (loadw symbol bsp
(- binding-symbol-slot binding-size
))
376 (loadw value bsp
(- binding-value-slot binding-size
))
378 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
379 (inst fs-segment-prefix
)
380 (inst mov
(make-ea :dword
:base tls-index
) value
)
382 (storew 0 bsp
(- binding-symbol-slot binding-size
))
383 (storew 0 bsp
(- binding-value-slot binding-size
))
384 (inst sub bsp
(* binding-size n-word-bytes
))
385 (store-binding-stack-pointer bsp
)))
389 (:temporary
(:sc unsigned-reg
) symbol value bsp
)
391 (load-symbol-value bsp
*binding-stack-pointer
*)
392 (loadw symbol bsp
(- binding-symbol-slot binding-size
))
393 (loadw value bsp
(- binding-value-slot binding-size
))
394 (storew value symbol symbol-value-slot other-pointer-lowtag
)
395 (storew 0 bsp
(- binding-symbol-slot binding-size
))
396 (storew 0 bsp
(- binding-value-slot binding-size
))
397 (inst sub bsp
(* binding-size n-word-bytes
))
398 (store-symbol-value bsp
*binding-stack-pointer
*)))
401 (define-vop (unbind-to-here)
402 (:args
(where :scs
(descriptor-reg any-reg
)))
403 (:temporary
(:sc unsigned-reg
) symbol value bsp
#!+sb-thread tls-index
)
405 (load-binding-stack-pointer bsp
)
410 (loadw symbol bsp
(- binding-symbol-slot binding-size
))
411 (inst or symbol symbol
)
413 ;; Bind stack debug sentinels have the unbound marker in the symbol slot
414 (inst cmp symbol unbound-marker-widetag
)
416 (loadw value bsp
(- binding-value-slot binding-size
))
417 #!-sb-thread
(storew value symbol symbol-value-slot other-pointer-lowtag
)
420 tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
421 #!+sb-thread
(inst fs-segment-prefix
)
422 #!+sb-thread
(inst mov
(make-ea :dword
:base tls-index
) value
)
423 (storew 0 bsp
(- binding-symbol-slot binding-size
))
426 (storew 0 bsp
(- binding-value-slot binding-size
))
427 (inst sub bsp
(* binding-size n-word-bytes
))
430 (store-binding-stack-pointer bsp
)
434 (define-vop (bind-sentinel)
435 (:temporary
(:sc unsigned-reg
) bsp
)
437 (load-binding-stack-pointer bsp
)
438 (inst add bsp
(* binding-size n-word-bytes
))
439 (storew unbound-marker-widetag bsp
(- binding-symbol-slot binding-size
))
440 (storew ebp-tn bsp
(- binding-value-slot binding-size
))
441 (store-binding-stack-pointer bsp
)))
443 (define-vop (unbind-sentinel)
444 (:temporary
(:sc unsigned-reg
) bsp
)
446 (load-binding-stack-pointer bsp
)
447 (storew 0 bsp
(- binding-value-slot binding-size
))
448 (storew 0 bsp
(- binding-symbol-slot binding-size
))
449 (inst sub bsp
(* binding-size n-word-bytes
))
450 (store-binding-stack-pointer bsp
)))
454 ;;;; closure indexing
456 (define-full-reffer closure-index-ref
*
457 closure-info-offset fun-pointer-lowtag
458 (any-reg descriptor-reg
) * %closure-index-ref
)
460 (define-full-setter set-funcallable-instance-info
*
461 funcallable-instance-info-offset fun-pointer-lowtag
462 (any-reg descriptor-reg
) * %set-funcallable-instance-info
)
464 (define-full-reffer funcallable-instance-info
*
465 funcallable-instance-info-offset fun-pointer-lowtag
466 (descriptor-reg any-reg
) * %funcallable-instance-info
)
468 (define-vop (closure-ref slot-ref
)
469 (:variant closure-info-offset fun-pointer-lowtag
))
471 (define-vop (closure-init slot-set
)
472 (:variant closure-info-offset fun-pointer-lowtag
))
474 ;;;; value cell hackery
476 (define-vop (value-cell-ref cell-ref
)
477 (:variant value-cell-value-slot other-pointer-lowtag
))
479 (define-vop (value-cell-set cell-set
)
480 (:variant value-cell-value-slot other-pointer-lowtag
))
482 ;;;; structure hackery
484 (define-vop (instance-length)
486 (:translate %instance-length
)
487 (:args
(struct :scs
(descriptor-reg)))
488 (:results
(res :scs
(unsigned-reg)))
489 (:result-types positive-fixnum
)
491 (loadw res struct
0 instance-pointer-lowtag
)
492 (inst shr res n-widetag-bits
)))
494 (define-full-reffer instance-index-ref
*
495 instance-slots-offset instance-pointer-lowtag
496 (any-reg descriptor-reg
) *
499 (define-full-setter instance-index-set
*
500 instance-slots-offset instance-pointer-lowtag
501 (any-reg descriptor-reg
) *
504 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
505 instance-slots-offset instance-pointer-lowtag
506 (any-reg descriptor-reg
) *
507 %compare-and-swap-instance-ref
)
509 ;;;; code object frobbing
511 (define-full-reffer code-header-ref
* 0 other-pointer-lowtag
512 (any-reg descriptor-reg
) * code-header-ref
)
514 (define-full-setter code-header-set
* 0 other-pointer-lowtag
515 (any-reg descriptor-reg
) * code-header-set
)
517 ;;;; raw instance slot accessors
519 (defun make-ea-for-raw-slot (object index instance-length n-words
)
521 (any-reg (make-ea :dword
523 :index instance-length
524 :disp
(- (* (- instance-slots-offset n-words
)
526 instance-pointer-lowtag
)))
527 (immediate (make-ea :dword
:base object
528 :index instance-length
530 :disp
(- (* (- instance-slots-offset n-words
)
532 instance-pointer-lowtag
533 (fixnumize (tn-value index
)))))))
535 (define-vop (raw-instance-ref/word
)
536 (:translate %raw-instance-ref
/word
)
538 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
539 (:arg-types
* tagged-num
)
540 (:temporary
(:sc unsigned-reg
) tmp
)
541 (:results
(value :scs
(unsigned-reg)))
542 (:result-types unsigned-num
)
544 (loadw tmp object
0 instance-pointer-lowtag
)
545 (inst shr tmp n-widetag-bits
)
546 (when (sc-is index any-reg
)
548 (inst sub tmp index
))
549 (inst mov value
(make-ea-for-raw-slot object index tmp
1))))
551 (define-vop (raw-instance-set/word
)
552 (:translate %raw-instance-set
/word
)
554 (:args
(object :scs
(descriptor-reg))
555 (index :scs
(any-reg immediate
))
556 (value :scs
(unsigned-reg) :target result
))
557 (:arg-types
* tagged-num unsigned-num
)
558 (:temporary
(:sc unsigned-reg
) tmp
)
559 (:results
(result :scs
(unsigned-reg)))
560 (:result-types unsigned-num
)
562 (loadw tmp object
0 instance-pointer-lowtag
)
563 (inst shr tmp n-widetag-bits
)
564 (when (sc-is index any-reg
)
566 (inst sub tmp index
))
567 (inst mov
(make-ea-for-raw-slot object index tmp
1) value
)
568 (move result value
)))
570 (define-vop (raw-instance-ref/single
)
571 (:translate %raw-instance-ref
/single
)
573 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
574 (:arg-types
* tagged-num
)
575 (:temporary
(:sc unsigned-reg
) tmp
)
576 (:results
(value :scs
(single-reg)))
577 (:result-types single-float
)
579 (loadw tmp object
0 instance-pointer-lowtag
)
580 (inst shr tmp n-widetag-bits
)
581 (when (sc-is index any-reg
)
583 (inst sub tmp index
))
584 (with-empty-tn@fp-top
(value)
585 (inst fld
(make-ea-for-raw-slot object index tmp
1)))))
587 (define-vop (raw-instance-set/single
)
588 (:translate %raw-instance-set
/single
)
590 (:args
(object :scs
(descriptor-reg))
591 (index :scs
(any-reg immediate
))
592 (value :scs
(single-reg) :target result
))
593 (:arg-types
* tagged-num single-float
)
594 (:temporary
(:sc unsigned-reg
) tmp
)
595 (:results
(result :scs
(single-reg)))
596 (:result-types single-float
)
598 (loadw tmp object
0 instance-pointer-lowtag
)
599 (inst shr tmp n-widetag-bits
)
600 (when (sc-is index any-reg
)
602 (inst sub tmp index
))
603 (unless (zerop (tn-offset value
))
605 (inst fst
(make-ea-for-raw-slot object index tmp
1))
607 ((zerop (tn-offset value
))
608 (unless (zerop (tn-offset result
))
610 ((zerop (tn-offset result
))
613 (unless (location= value result
)
615 (inst fxch value
)))))
617 (define-vop (raw-instance-ref/double
)
618 (:translate %raw-instance-ref
/double
)
620 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
621 (:arg-types
* tagged-num
)
622 (:temporary
(:sc unsigned-reg
) tmp
)
623 (:results
(value :scs
(double-reg)))
624 (:result-types double-float
)
626 (loadw tmp object
0 instance-pointer-lowtag
)
627 (inst shr tmp n-widetag-bits
)
628 (when (sc-is index any-reg
)
630 (inst sub tmp index
))
631 (with-empty-tn@fp-top
(value)
632 (inst fldd
(make-ea-for-raw-slot object index tmp
2)))))
634 (define-vop (raw-instance-set/double
)
635 (:translate %raw-instance-set
/double
)
637 (:args
(object :scs
(descriptor-reg))
638 (index :scs
(any-reg immediate
))
639 (value :scs
(double-reg) :target result
))
640 (:arg-types
* tagged-num double-float
)
641 (:temporary
(:sc unsigned-reg
) tmp
)
642 (:results
(result :scs
(double-reg)))
643 (:result-types double-float
)
645 (loadw tmp object
0 instance-pointer-lowtag
)
646 (inst shr tmp n-widetag-bits
)
647 (when (sc-is index any-reg
)
649 (inst sub tmp index
))
650 (unless (zerop (tn-offset value
))
652 (inst fstd
(make-ea-for-raw-slot object index tmp
2))
654 ((zerop (tn-offset value
))
655 (unless (zerop (tn-offset result
))
657 ((zerop (tn-offset result
))
660 (unless (location= value result
)
662 (inst fxch value
)))))
664 (define-vop (raw-instance-ref/complex-single
)
665 (:translate %raw-instance-ref
/complex-single
)
667 (:args
(object :scs
(descriptor-reg))
668 (index :scs
(any-reg immediate
)))
669 (:arg-types
* positive-fixnum
)
670 (:temporary
(:sc unsigned-reg
) tmp
)
671 (:results
(value :scs
(complex-single-reg)))
672 (:result-types complex-single-float
)
674 (loadw tmp object
0 instance-pointer-lowtag
)
675 (inst shr tmp n-widetag-bits
)
676 (when (sc-is index any-reg
)
678 (inst sub tmp index
))
679 (let ((real-tn (complex-single-reg-real-tn value
)))
680 (with-empty-tn@fp-top
(real-tn)
681 (inst fld
(make-ea-for-raw-slot object index tmp
2))))
682 (let ((imag-tn (complex-single-reg-imag-tn value
)))
683 (with-empty-tn@fp-top
(imag-tn)
684 (inst fld
(make-ea-for-raw-slot object index tmp
1))))))
686 (define-vop (raw-instance-set/complex-single
)
687 (:translate %raw-instance-set
/complex-single
)
689 (:args
(object :scs
(descriptor-reg))
690 (index :scs
(any-reg immediate
))
691 (value :scs
(complex-single-reg) :target result
))
692 (:arg-types
* positive-fixnum complex-single-float
)
693 (:temporary
(:sc unsigned-reg
) tmp
)
694 (:results
(result :scs
(complex-single-reg)))
695 (:result-types complex-single-float
)
697 (loadw tmp object
0 instance-pointer-lowtag
)
698 (inst shr tmp n-widetag-bits
)
699 (when (sc-is index any-reg
)
701 (inst sub tmp index
))
702 (let ((value-real (complex-single-reg-real-tn value
))
703 (result-real (complex-single-reg-real-tn result
)))
704 (cond ((zerop (tn-offset value-real
))
706 (inst fst
(make-ea-for-raw-slot object index tmp
2))
707 (unless (zerop (tn-offset result-real
))
708 ;; Value is in ST0 but not result.
709 (inst fst result-real
)))
711 ;; Value is not in ST0.
712 (inst fxch value-real
)
713 (inst fst
(make-ea-for-raw-slot object index tmp
2))
714 (cond ((zerop (tn-offset result-real
))
715 ;; The result is in ST0.
716 (inst fst value-real
))
718 ;; Neither value or result are in ST0
719 (unless (location= value-real result-real
)
720 (inst fst result-real
))
721 (inst fxch value-real
))))))
722 (let ((value-imag (complex-single-reg-imag-tn value
))
723 (result-imag (complex-single-reg-imag-tn result
)))
724 (inst fxch value-imag
)
725 (inst fst
(make-ea-for-raw-slot object index tmp
1))
726 (unless (location= value-imag result-imag
)
727 (inst fst result-imag
))
728 (inst fxch value-imag
))))
730 (define-vop (raw-instance-ref/complex-double
)
731 (:translate %raw-instance-ref
/complex-double
)
733 (:args
(object :scs
(descriptor-reg))
734 (index :scs
(any-reg immediate
)))
735 (:arg-types
* positive-fixnum
)
736 (:temporary
(:sc unsigned-reg
) tmp
)
737 (:results
(value :scs
(complex-double-reg)))
738 (:result-types complex-double-float
)
740 (loadw tmp object
0 instance-pointer-lowtag
)
741 (inst shr tmp n-widetag-bits
)
742 (when (sc-is index any-reg
)
744 (inst sub tmp index
))
745 (let ((real-tn (complex-double-reg-real-tn value
)))
746 (with-empty-tn@fp-top
(real-tn)
747 (inst fldd
(make-ea-for-raw-slot object index tmp
4))))
748 (let ((imag-tn (complex-double-reg-imag-tn value
)))
749 (with-empty-tn@fp-top
(imag-tn)
750 (inst fldd
(make-ea-for-raw-slot object index tmp
2))))))
752 (define-vop (raw-instance-set/complex-double
)
753 (:translate %raw-instance-set
/complex-double
)
755 (:args
(object :scs
(descriptor-reg))
756 (index :scs
(any-reg immediate
))
757 (value :scs
(complex-double-reg) :target result
))
758 (:arg-types
* positive-fixnum complex-double-float
)
759 (:temporary
(:sc unsigned-reg
) tmp
)
760 (:results
(result :scs
(complex-double-reg)))
761 (:result-types complex-double-float
)
763 (loadw tmp object
0 instance-pointer-lowtag
)
764 (inst shr tmp n-widetag-bits
)
765 (when (sc-is index any-reg
)
767 (inst sub tmp index
))
768 (let ((value-real (complex-double-reg-real-tn value
))
769 (result-real (complex-double-reg-real-tn result
)))
770 (cond ((zerop (tn-offset value-real
))
772 (inst fstd
(make-ea-for-raw-slot object index tmp
4))
773 (unless (zerop (tn-offset result-real
))
774 ;; Value is in ST0 but not result.
775 (inst fstd result-real
)))
777 ;; Value is not in ST0.
778 (inst fxch value-real
)
779 (inst fstd
(make-ea-for-raw-slot object index tmp
4))
780 (cond ((zerop (tn-offset result-real
))
781 ;; The result is in ST0.
782 (inst fstd value-real
))
784 ;; Neither value or result are in ST0
785 (unless (location= value-real result-real
)
786 (inst fstd result-real
))
787 (inst fxch value-real
))))))
788 (let ((value-imag (complex-double-reg-imag-tn value
))
789 (result-imag (complex-double-reg-imag-tn result
)))
790 (inst fxch value-imag
)
791 (inst fstd
(make-ea-for-raw-slot object index tmp
2))
792 (unless (location= value-imag result-imag
)
793 (inst fstd result-imag
))
794 (inst fxch value-imag
))))