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
291 (load-binding-stack-pointer bsp
)
292 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
293 (inst add bsp
(* binding-size n-word-bytes
))
294 (store-binding-stack-pointer bsp
)
295 (inst test tls-index tls-index
)
296 (inst jmp
:ne tls-index-valid
)
297 (inst mov tls-index symbol
)
298 (inst call
(make-fixup
299 (ecase (tn-offset tls-index
)
300 (#.eax-offset
'alloc-tls-index-in-eax
)
301 (#.ebx-offset
'alloc-tls-index-in-ebx
)
302 (#.ecx-offset
'alloc-tls-index-in-ecx
)
303 (#.edx-offset
'alloc-tls-index-in-edx
)
304 (#.edi-offset
'alloc-tls-index-in-edi
)
305 (#.esi-offset
'alloc-tls-index-in-esi
))
308 ;; with-tls-ea on win32 causes tls-index to be an absolute address
309 ;; which is problematic when UNBIND uses with-tls-ea too.
310 #!+win32
(move temp tls-index
)
311 (with-tls-ea (EA :base tls-index
:base-already-live-p t
)
312 (inst push EA
:maybe-fs
)
313 (popw bsp
(- binding-value-slot binding-size
))
314 (storew #!-win32 tls-index
316 bsp
(- binding-symbol-slot binding-size
))
317 (inst mov EA val
:maybe-fs
))))
321 (:args
(val :scs
(any-reg descriptor-reg
))
322 (symbol :scs
(descriptor-reg)))
323 (:temporary
(:sc unsigned-reg
) temp bsp
)
325 (load-symbol-value bsp
*binding-stack-pointer
*)
326 (loadw temp symbol symbol-value-slot other-pointer-lowtag
)
327 (inst add bsp
(* binding-size n-word-bytes
))
328 (store-symbol-value bsp
*binding-stack-pointer
*)
329 (storew temp bsp
(- binding-value-slot binding-size
))
330 (storew symbol bsp
(- binding-symbol-slot binding-size
))
331 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
335 (:temporary
(:sc unsigned-reg
) temp bsp tls-index
)
337 (load-binding-stack-pointer bsp
)
338 ;; Load SYMBOL from stack, and get the TLS-INDEX.
339 (loadw tls-index bsp
(- binding-symbol-slot binding-size
))
340 ;; Load VALUE from stack, then restore it to the TLS area.
341 (loadw temp bsp
(- binding-value-slot binding-size
))
342 (with-tls-ea (EA :base tls-index
:base-already-live-p t
)
343 (inst mov EA temp
:maybe-fs
))
344 ;; Zero out the stack.
345 (inst sub bsp
(* binding-size n-word-bytes
))
346 (storew 0 bsp binding-symbol-slot
)
347 (storew 0 bsp binding-value-slot
)
348 (store-binding-stack-pointer bsp
)))
352 (:temporary
(:sc unsigned-reg
) symbol value bsp
)
354 (load-symbol-value bsp
*binding-stack-pointer
*)
355 (loadw symbol bsp
(- binding-symbol-slot binding-size
))
356 (loadw value bsp
(- binding-value-slot binding-size
))
357 (storew value symbol symbol-value-slot other-pointer-lowtag
)
358 (storew 0 bsp
(- binding-symbol-slot binding-size
))
359 (storew 0 bsp
(- binding-value-slot binding-size
))
360 (inst sub bsp
(* binding-size n-word-bytes
))
361 (store-symbol-value bsp
*binding-stack-pointer
*)))
364 (define-vop (unbind-to-here)
365 (:args
(where :scs
(descriptor-reg any-reg
)))
366 (:temporary
(:sc unsigned-reg
) symbol value bsp
)
368 (load-binding-stack-pointer bsp
)
373 (inst sub bsp
(* binding-size n-word-bytes
))
374 (loadw symbol bsp binding-symbol-slot
)
375 (inst test symbol symbol
)
377 ;; Bind stack debug sentinels have the unbound marker in the symbol slot
378 (inst cmp symbol unbound-marker-widetag
)
380 (loadw value bsp binding-value-slot
)
381 #!-sb-thread
(storew value symbol symbol-value-slot other-pointer-lowtag
)
382 #!+sb-thread
(with-tls-ea (EA :base symbol
:base-already-live-p t
)
383 (inst mov EA value
:maybe-fs
))
384 (storew 0 bsp binding-symbol-slot
)
387 (storew 0 bsp binding-value-slot
)
390 (store-binding-stack-pointer bsp
)
394 (define-vop (bind-sentinel)
395 (:temporary
(:sc unsigned-reg
) bsp
)
397 (load-binding-stack-pointer bsp
)
398 (inst add bsp
(* binding-size n-word-bytes
))
399 (storew unbound-marker-widetag bsp
(- binding-symbol-slot binding-size
))
400 (storew ebp-tn bsp
(- binding-value-slot binding-size
))
401 (store-binding-stack-pointer bsp
)))
403 (define-vop (unbind-sentinel)
404 (:temporary
(:sc unsigned-reg
) bsp
)
406 (load-binding-stack-pointer bsp
)
407 (storew 0 bsp
(- binding-value-slot binding-size
))
408 (storew 0 bsp
(- binding-symbol-slot binding-size
))
409 (inst sub bsp
(* binding-size n-word-bytes
))
410 (store-binding-stack-pointer bsp
)))
414 ;;;; closure indexing
416 (define-full-reffer closure-index-ref
*
417 closure-info-offset fun-pointer-lowtag
418 (any-reg descriptor-reg
) * %closure-index-ref
)
420 (define-full-setter set-funcallable-instance-info
*
421 funcallable-instance-info-offset fun-pointer-lowtag
422 (any-reg descriptor-reg
) * %set-funcallable-instance-info
)
424 (define-full-reffer funcallable-instance-info
*
425 funcallable-instance-info-offset fun-pointer-lowtag
426 (descriptor-reg any-reg
) * %funcallable-instance-info
)
428 (define-vop (closure-ref slot-ref
)
429 (:variant closure-info-offset fun-pointer-lowtag
))
431 (define-vop (closure-init slot-set
)
432 (:variant closure-info-offset fun-pointer-lowtag
))
434 (define-vop (closure-init-from-fp)
435 (:args
(object :scs
(descriptor-reg)))
438 (storew ebp-tn object
(+ closure-info-offset offset
) fun-pointer-lowtag
)))
440 ;;;; value cell hackery
442 (define-vop (value-cell-ref cell-ref
)
443 (:variant value-cell-value-slot other-pointer-lowtag
))
445 (define-vop (value-cell-set cell-set
)
446 (:variant value-cell-value-slot other-pointer-lowtag
))
448 ;;;; structure hackery
450 (define-vop (instance-length)
452 (:translate %instance-length
)
453 (:args
(struct :scs
(descriptor-reg)))
454 (:results
(res :scs
(unsigned-reg)))
455 (:result-types positive-fixnum
)
457 (loadw res struct
0 instance-pointer-lowtag
)
458 (inst shr res n-widetag-bits
)))
460 (define-full-reffer instance-index-ref
*
461 instance-slots-offset instance-pointer-lowtag
462 (any-reg descriptor-reg
) *
465 (define-full-setter instance-index-set
*
466 instance-slots-offset instance-pointer-lowtag
467 (any-reg descriptor-reg
) *
470 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
471 instance-slots-offset instance-pointer-lowtag
472 (any-reg descriptor-reg
) *
473 %compare-and-swap-instance-ref
)
475 ;;;; code object frobbing
477 (define-full-reffer code-header-ref
* 0 other-pointer-lowtag
478 (any-reg descriptor-reg
) * code-header-ref
)
480 (define-full-setter code-header-set
* 0 other-pointer-lowtag
481 (any-reg descriptor-reg
) * code-header-set
)
483 ;;;; raw instance slot accessors
485 (defun make-ea-for-raw-slot (object index instance-length n-words
)
486 (if (integerp instance-length
)
487 ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
491 :disp
(- (* (- instance-length instance-slots-offset index
(1- n-words
))
493 instance-pointer-lowtag
))
494 (flet ((make-ea-using-value (value)
495 (make-ea :dword
:base object
496 :index instance-length
498 :disp
(- (* (- instance-slots-offset n-words
)
500 instance-pointer-lowtag
501 (* value n-word-bytes
)))))
502 (if (typep index
'tn
)
504 (any-reg (make-ea :dword
506 :index instance-length
507 :disp
(- (* (- instance-slots-offset n-words
)
509 instance-pointer-lowtag
)))
510 (immediate (make-ea-using-value (tn-value index
))))
511 (make-ea-using-value index
)))))
513 (define-vop (raw-instance-ref/word
)
514 (:translate %raw-instance-ref
/word
)
516 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
517 (:arg-types
* tagged-num
)
518 (:temporary
(:sc unsigned-reg
) tmp
)
519 (:results
(value :scs
(unsigned-reg)))
520 (:result-types unsigned-num
)
522 (loadw tmp object
0 instance-pointer-lowtag
)
523 (inst shr tmp n-widetag-bits
)
524 (when (sc-is index any-reg
)
525 (inst shl tmp n-fixnum-tag-bits
)
526 (inst sub tmp index
))
527 (inst mov value
(make-ea-for-raw-slot object index tmp
1))))
529 (define-vop (raw-instance-set/word
)
530 (:translate %raw-instance-set
/word
)
532 (:args
(object :scs
(descriptor-reg))
533 (index :scs
(any-reg immediate
))
534 (value :scs
(unsigned-reg) :target result
))
535 (:arg-types
* tagged-num unsigned-num
)
536 (:temporary
(:sc unsigned-reg
) tmp
)
537 (:results
(result :scs
(unsigned-reg)))
538 (:result-types unsigned-num
)
540 (loadw tmp object
0 instance-pointer-lowtag
)
541 (inst shr tmp n-widetag-bits
)
542 (when (sc-is index any-reg
)
543 (inst shl tmp n-fixnum-tag-bits
)
544 (inst sub tmp index
))
545 (inst mov
(make-ea-for-raw-slot object index tmp
1) value
)
546 (move result value
)))
548 (define-vop (raw-instance-init/word
)
549 (:args
(object :scs
(descriptor-reg))
550 (value :scs
(unsigned-reg)))
551 (:arg-types
* unsigned-num
)
552 (:info instance-length index
)
554 (inst mov
(make-ea-for-raw-slot object index instance-length
1) value
)))
556 (define-vop (raw-instance-atomic-incf/word
)
557 (:translate %raw-instance-atomic-incf
/word
)
559 (:args
(object :scs
(descriptor-reg))
560 (index :scs
(any-reg immediate
))
561 (diff :scs
(unsigned-reg) :target result
))
562 (:arg-types
* tagged-num unsigned-num
)
563 (:temporary
(:sc unsigned-reg
) tmp
)
564 (:results
(result :scs
(unsigned-reg)))
565 (:result-types unsigned-num
)
567 (loadw tmp object
0 instance-pointer-lowtag
)
568 (inst shr tmp n-widetag-bits
)
569 (when (sc-is index any-reg
)
570 (inst shl tmp n-fixnum-tag-bits
)
571 (inst sub tmp index
))
572 (inst xadd
(make-ea-for-raw-slot object index tmp
1) diff
:lock
)
575 (define-vop (raw-instance-ref/single
)
576 (:translate %raw-instance-ref
/single
)
578 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
579 (:arg-types
* tagged-num
)
580 (:temporary
(:sc unsigned-reg
) tmp
)
581 (:results
(value :scs
(single-reg)))
582 (:result-types single-float
)
584 (loadw tmp object
0 instance-pointer-lowtag
)
585 (inst shr tmp n-widetag-bits
)
586 (when (sc-is index any-reg
)
587 (inst shl tmp n-fixnum-tag-bits
)
588 (inst sub tmp index
))
589 (with-empty-tn@fp-top
(value)
590 (inst fld
(make-ea-for-raw-slot object index tmp
1)))))
592 (define-vop (raw-instance-set/single
)
593 (:translate %raw-instance-set
/single
)
595 (:args
(object :scs
(descriptor-reg))
596 (index :scs
(any-reg immediate
))
597 (value :scs
(single-reg) :target result
))
598 (:arg-types
* tagged-num single-float
)
599 (:temporary
(:sc unsigned-reg
) tmp
)
600 (:results
(result :scs
(single-reg)))
601 (:result-types single-float
)
603 (loadw tmp object
0 instance-pointer-lowtag
)
604 (inst shr tmp n-widetag-bits
)
605 (when (sc-is index any-reg
)
606 (inst shl tmp n-fixnum-tag-bits
)
607 (inst sub tmp index
))
608 (unless (zerop (tn-offset value
))
610 (inst fst
(make-ea-for-raw-slot object index tmp
1))
612 ((zerop (tn-offset value
))
613 (unless (zerop (tn-offset result
))
615 ((zerop (tn-offset result
))
618 (unless (location= value result
)
620 (inst fxch value
)))))
622 (define-vop (raw-instance-init/single
)
623 (:args
(object :scs
(descriptor-reg))
624 (value :scs
(single-reg)))
625 (:arg-types
* single-float
)
626 (:info instance-length index
)
628 (with-tn@fp-top
(value)
629 (inst fst
(make-ea-for-raw-slot object index instance-length
1)))))
631 (define-vop (raw-instance-ref/double
)
632 (:translate %raw-instance-ref
/double
)
634 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
635 (:arg-types
* tagged-num
)
636 (:temporary
(:sc unsigned-reg
) tmp
)
637 (:results
(value :scs
(double-reg)))
638 (:result-types double-float
)
640 (loadw tmp object
0 instance-pointer-lowtag
)
641 (inst shr tmp n-widetag-bits
)
642 (when (sc-is index any-reg
)
643 (inst shl tmp n-fixnum-tag-bits
)
644 (inst sub tmp index
))
645 (with-empty-tn@fp-top
(value)
646 (inst fldd
(make-ea-for-raw-slot object index tmp
2)))))
648 (define-vop (raw-instance-set/double
)
649 (:translate %raw-instance-set
/double
)
651 (:args
(object :scs
(descriptor-reg))
652 (index :scs
(any-reg immediate
))
653 (value :scs
(double-reg) :target result
))
654 (:arg-types
* tagged-num double-float
)
655 (:temporary
(:sc unsigned-reg
) tmp
)
656 (:results
(result :scs
(double-reg)))
657 (:result-types double-float
)
659 (loadw tmp object
0 instance-pointer-lowtag
)
660 (inst shr tmp n-widetag-bits
)
661 (when (sc-is index any-reg
)
662 (inst shl tmp n-fixnum-tag-bits
)
663 (inst sub tmp index
))
664 (unless (zerop (tn-offset value
))
666 (inst fstd
(make-ea-for-raw-slot object index tmp
2))
668 ((zerop (tn-offset value
))
669 (unless (zerop (tn-offset result
))
671 ((zerop (tn-offset result
))
674 (unless (location= value result
)
676 (inst fxch value
)))))
678 (define-vop (raw-instance-init/double
)
679 (:args
(object :scs
(descriptor-reg))
680 (value :scs
(double-reg)))
681 (:arg-types
* double-float
)
682 (:info instance-length index
)
684 (with-tn@fp-top
(value)
685 (inst fstd
(make-ea-for-raw-slot object index instance-length
2)))))
687 (define-vop (raw-instance-ref/complex-single
)
688 (:translate %raw-instance-ref
/complex-single
)
690 (:args
(object :scs
(descriptor-reg))
691 (index :scs
(any-reg immediate
)))
692 (:arg-types
* positive-fixnum
)
693 (:temporary
(:sc unsigned-reg
) tmp
)
694 (:results
(value :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
)
700 (inst shl tmp n-fixnum-tag-bits
)
701 (inst sub tmp index
))
702 (let ((real-tn (complex-single-reg-real-tn value
)))
703 (with-empty-tn@fp-top
(real-tn)
704 (inst fld
(make-ea-for-raw-slot object index tmp
2))))
705 (let ((imag-tn (complex-single-reg-imag-tn value
)))
706 (with-empty-tn@fp-top
(imag-tn)
707 (inst fld
(make-ea-for-raw-slot object index tmp
1))))))
709 (define-vop (raw-instance-set/complex-single
)
710 (:translate %raw-instance-set
/complex-single
)
712 (:args
(object :scs
(descriptor-reg))
713 (index :scs
(any-reg immediate
))
714 (value :scs
(complex-single-reg) :target result
))
715 (:arg-types
* positive-fixnum complex-single-float
)
716 (:temporary
(:sc unsigned-reg
) tmp
)
717 (:results
(result :scs
(complex-single-reg)))
718 (:result-types complex-single-float
)
720 (loadw tmp object
0 instance-pointer-lowtag
)
721 (inst shr tmp n-widetag-bits
)
722 (when (sc-is index any-reg
)
723 (inst shl tmp n-fixnum-tag-bits
)
724 (inst sub tmp index
))
725 (let ((value-real (complex-single-reg-real-tn value
))
726 (result-real (complex-single-reg-real-tn result
)))
727 (cond ((zerop (tn-offset value-real
))
729 (inst fst
(make-ea-for-raw-slot object index tmp
2))
730 (unless (zerop (tn-offset result-real
))
731 ;; Value is in ST0 but not result.
732 (inst fst result-real
)))
734 ;; Value is not in ST0.
735 (inst fxch value-real
)
736 (inst fst
(make-ea-for-raw-slot object index tmp
2))
737 (cond ((zerop (tn-offset result-real
))
738 ;; The result is in ST0.
739 (inst fst value-real
))
741 ;; Neither value or result are in ST0
742 (unless (location= value-real result-real
)
743 (inst fst result-real
))
744 (inst fxch value-real
))))))
745 (let ((value-imag (complex-single-reg-imag-tn value
))
746 (result-imag (complex-single-reg-imag-tn result
)))
747 (inst fxch value-imag
)
748 (inst fst
(make-ea-for-raw-slot object index tmp
1))
749 (unless (location= value-imag result-imag
)
750 (inst fst result-imag
))
751 (inst fxch value-imag
))))
753 (define-vop (raw-instance-init/complex-single
)
754 (:args
(object :scs
(descriptor-reg))
755 (value :scs
(complex-single-reg)))
756 (:arg-types
* complex-single-float
)
757 (:info instance-length index
)
759 (let ((value-real (complex-single-reg-real-tn value
)))
760 (with-tn@fp-top
(value-real)
761 (inst fst
(make-ea-for-raw-slot object index instance-length
2))))
762 (let ((value-imag (complex-single-reg-imag-tn value
)))
763 (with-tn@fp-top
(value-imag)
764 (inst fst
(make-ea-for-raw-slot object index instance-length
1))))))
766 (define-vop (raw-instance-ref/complex-double
)
767 (:translate %raw-instance-ref
/complex-double
)
769 (:args
(object :scs
(descriptor-reg))
770 (index :scs
(any-reg immediate
)))
771 (:arg-types
* positive-fixnum
)
772 (:temporary
(:sc unsigned-reg
) tmp
)
773 (:results
(value :scs
(complex-double-reg)))
774 (:result-types complex-double-float
)
776 (loadw tmp object
0 instance-pointer-lowtag
)
777 (inst shr tmp n-widetag-bits
)
778 (when (sc-is index any-reg
)
779 (inst shl tmp n-fixnum-tag-bits
)
780 (inst sub tmp index
))
781 (let ((real-tn (complex-double-reg-real-tn value
)))
782 (with-empty-tn@fp-top
(real-tn)
783 (inst fldd
(make-ea-for-raw-slot object index tmp
4))))
784 (let ((imag-tn (complex-double-reg-imag-tn value
)))
785 (with-empty-tn@fp-top
(imag-tn)
786 (inst fldd
(make-ea-for-raw-slot object index tmp
2))))))
788 (define-vop (raw-instance-set/complex-double
)
789 (:translate %raw-instance-set
/complex-double
)
791 (:args
(object :scs
(descriptor-reg))
792 (index :scs
(any-reg immediate
))
793 (value :scs
(complex-double-reg) :target result
))
794 (:arg-types
* positive-fixnum complex-double-float
)
795 (:temporary
(:sc unsigned-reg
) tmp
)
796 (:results
(result :scs
(complex-double-reg)))
797 (:result-types complex-double-float
)
799 (loadw tmp object
0 instance-pointer-lowtag
)
800 (inst shr tmp n-widetag-bits
)
801 (when (sc-is index any-reg
)
802 (inst shl tmp n-fixnum-tag-bits
)
803 (inst sub tmp index
))
804 (let ((value-real (complex-double-reg-real-tn value
))
805 (result-real (complex-double-reg-real-tn result
)))
806 (cond ((zerop (tn-offset value-real
))
808 (inst fstd
(make-ea-for-raw-slot object index tmp
4))
809 (unless (zerop (tn-offset result-real
))
810 ;; Value is in ST0 but not result.
811 (inst fstd result-real
)))
813 ;; Value is not in ST0.
814 (inst fxch value-real
)
815 (inst fstd
(make-ea-for-raw-slot object index tmp
4))
816 (cond ((zerop (tn-offset result-real
))
817 ;; The result is in ST0.
818 (inst fstd value-real
))
820 ;; Neither value or result are in ST0
821 (unless (location= value-real result-real
)
822 (inst fstd result-real
))
823 (inst fxch value-real
))))))
824 (let ((value-imag (complex-double-reg-imag-tn value
))
825 (result-imag (complex-double-reg-imag-tn result
)))
826 (inst fxch value-imag
)
827 (inst fstd
(make-ea-for-raw-slot object index tmp
2))
828 (unless (location= value-imag result-imag
)
829 (inst fstd result-imag
))
830 (inst fxch value-imag
))))
832 (define-vop (raw-instance-init/complex-double
)
833 (:args
(object :scs
(descriptor-reg))
834 (value :scs
(complex-double-reg)))
835 (:arg-types
* complex-double-float
)
836 (:info instance-length index
)
838 (let ((value-real (complex-double-reg-real-tn value
)))
839 (with-tn@fp-top
(value-real)
840 (inst fstd
(make-ea-for-raw-slot object index instance-length
4))))
841 (let ((value-imag (complex-double-reg-imag-tn value
)))
842 (with-tn@fp-top
(value-imag)
843 (inst fstd
(make-ea-for-raw-slot object index instance-length
2))))))