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
)))
45 (inst cmpxchg
(make-ea :dword
:base object
46 :disp
(- (* offset n-word-bytes
) lowtag
))
50 ;;;; symbol hacking VOPs
52 (define-vop (%compare-and-swap-symbol-value
)
53 (:translate %compare-and-swap-symbol-value
)
54 (:args
(symbol :scs
(descriptor-reg) :to
(:result
1))
55 (old :scs
(descriptor-reg any-reg
) :target eax
)
56 (new :scs
(descriptor-reg any-reg
)))
57 (:temporary
(:sc descriptor-reg
:offset eax-offset
) eax
)
59 (:temporary
(:sc descriptor-reg
) tls
)
60 (:results
(result :scs
(descriptor-reg any-reg
)))
64 ;; This code has to pathological cases: NO-TLS-VALUE-MARKER
65 ;; or UNBOUND-MARKER as NEW: in either case we would end up
66 ;; doing possible damage with CMPXCHG -- so don't do that!
67 (let ((unbound (generate-error-code vop
'unbound-symbol-error symbol
))
72 (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag
)
73 ;; Thread-local area, no LOCK needed.
74 (inst cmpxchg
(make-ea :dword
:base tls
) new
:fs
)
75 (inst cmp eax no-tls-value-marker-widetag
)
78 (inst cmpxchg
(make-ea :dword
:base symbol
79 :disp
(- (* symbol-value-slot n-word-bytes
)
80 other-pointer-lowtag
))
84 (inst cmp result unbound-marker-widetag
)
85 (inst jmp
:e unbound
))))
87 (define-vop (%set-symbol-global-value cell-set
)
88 (:variant symbol-value-slot other-pointer-lowtag
))
90 (define-vop (fast-symbol-global-value cell-ref
)
91 (:variant symbol-value-slot other-pointer-lowtag
)
93 (:translate symbol-global-value
))
95 (define-vop (symbol-global-value)
97 (:translate symbol-global-value
)
98 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
99 (:results
(value :scs
(descriptor-reg any-reg
)))
101 (:save-p
:compute-only
)
103 (let ((err-lab (generate-error-code vop
'unbound-symbol-error object
)))
104 (loadw value object symbol-value-slot other-pointer-lowtag
)
105 (inst cmp value unbound-marker-widetag
)
106 (inst jmp
:e err-lab
))))
111 (:args
(symbol :scs
(descriptor-reg))
112 (value :scs
(descriptor-reg any-reg
)))
113 (:temporary
(:sc descriptor-reg
) tls
)
115 (let ((global-val (gen-label))
117 (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag
)
118 (inst cmp
(make-ea :dword
:base tls
) no-tls-value-marker-widetag
:fs
)
119 (inst jmp
:z global-val
)
120 (inst mov
(make-ea :dword
:base tls
) value
:fs
)
122 (emit-label global-val
)
123 (storew value symbol symbol-value-slot other-pointer-lowtag
)
126 ;; With Symbol-Value, we check that the value isn't the trap object. So
127 ;; Symbol-Value of NIL is NIL.
128 (define-vop (symbol-value)
129 (:translate symbol-value
)
131 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
132 (:results
(value :scs
(descriptor-reg any-reg
)))
134 (:save-p
:compute-only
)
136 (let* ((check-unbound-label (gen-label))
137 (err-lab (generate-error-code vop
'unbound-symbol-error object
))
138 (ret-lab (gen-label)))
139 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
140 (inst mov value
(make-ea :dword
:base value
) :fs
)
141 (inst cmp value no-tls-value-marker-widetag
)
142 (inst jmp
:ne check-unbound-label
)
143 (loadw value object symbol-value-slot other-pointer-lowtag
)
144 (emit-label check-unbound-label
)
145 (inst cmp value unbound-marker-widetag
)
146 (inst jmp
:e err-lab
)
147 (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 mov value
(make-ea :dword
:base value
) :fs
)
161 (inst cmp value no-tls-value-marker-widetag
)
162 (inst jmp
:ne ret-lab
)
163 (loadw value object symbol-value-slot other-pointer-lowtag
)
164 (emit-label ret-lab
)))))
168 (define-vop (symbol-value symbol-global-value
)
169 (:translate symbol-value
))
170 (define-vop (fast-symbol-value fast-symbol-global-value
)
171 (:translate symbol-value
))
172 (define-vop (set %set-symbol-global-value
)))
178 (:args
(object :scs
(descriptor-reg)))
180 (:temporary
(:sc descriptor-reg
#+nil
(:from
(:argument
0))) value
)
182 (let ((check-unbound-label (gen-label)))
183 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
184 (inst mov value
(make-ea :dword
:base value
) :fs
)
185 (inst cmp value no-tls-value-marker-widetag
)
186 (inst jmp
:ne check-unbound-label
)
187 (loadw value object symbol-value-slot other-pointer-lowtag
)
188 (emit-label check-unbound-label
)
189 (inst cmp value unbound-marker-widetag
))))
195 (:args
(object :scs
(descriptor-reg)))
198 (inst cmp
(make-ea-for-object-slot object symbol-value-slot
199 other-pointer-lowtag
)
200 unbound-marker-widetag
)))
203 (define-vop (symbol-hash)
205 (:translate symbol-hash
)
206 (:args
(symbol :scs
(descriptor-reg)))
207 (:results
(res :scs
(any-reg)))
208 (:result-types positive-fixnum
)
210 ;; The symbol-hash slot of NIL holds NIL because it is also the
211 ;; cdr slot, so we have to strip off the two low bits to make sure
212 ;; it is a fixnum. The lowtag selection magic that is required to
213 ;; ensure this is explained in the comment in objdef.lisp
214 (loadw res symbol symbol-hash-slot other-pointer-lowtag
)
215 (inst and res
(lognot #b11
))))
217 ;;;; fdefinition (FDEFN) objects
219 (define-vop (fdefn-fun cell-ref
) ; /pfw - alpha
220 (:variant fdefn-fun-slot other-pointer-lowtag
))
222 (define-vop (safe-fdefn-fun)
223 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
224 (:results
(value :scs
(descriptor-reg any-reg
)))
226 (:save-p
:compute-only
)
228 (loadw value object fdefn-fun-slot other-pointer-lowtag
)
229 (inst cmp value nil-value
)
230 (let ((err-lab (generate-error-code vop
'undefined-fun-error object
)))
231 (inst jmp
:e err-lab
))))
233 (define-vop (set-fdefn-fun)
235 (:translate
(setf fdefn-fun
))
236 (:args
(function :scs
(descriptor-reg) :target result
)
237 (fdefn :scs
(descriptor-reg)))
238 (:temporary
(:sc unsigned-reg
) raw
)
239 (:temporary
(:sc byte-reg
) type
)
240 (:results
(result :scs
(descriptor-reg)))
242 (load-type type function
(- fun-pointer-lowtag
))
244 (make-ea-for-object-slot function simple-fun-code-offset
246 (inst cmp type simple-fun-header-widetag
)
247 (inst jmp
:e normal-fn
)
248 (inst lea raw
(make-fixup "closure_tramp" :foreign
))
250 (storew function fdefn fdefn-fun-slot other-pointer-lowtag
)
251 (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
252 (move result function
)))
254 (define-vop (fdefn-makunbound)
256 (:translate fdefn-makunbound
)
257 (:args
(fdefn :scs
(descriptor-reg) :target result
))
258 (:results
(result :scs
(descriptor-reg)))
260 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag
)
261 (storew (make-fixup "undefined_tramp" :foreign
)
262 fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
263 (move result fdefn
)))
265 ;;;; binding and unbinding
267 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
268 ;;; the symbol on the binding stack and stuff the new value into the
271 ;;; FIXME: Split into DYNBIND and BIND: DYNBIND needs to ensure
272 ;;; TLS-INDEX, whereas BIND should assume it is already in place. Make
273 ;;; LET &co compile into BIND, and PROGV into DYNBIND, plus ensure
274 ;;; TLS-INDEX at compile-time, and make loader and dumper preserve
275 ;;; the existence of a TLS-INDEX.
278 (:args
(val :scs
(any-reg descriptor-reg
))
279 (symbol :scs
(descriptor-reg)))
280 (:temporary
(:sc unsigned-reg
) tls-index bsp
)
282 (let ((tls-index-valid (gen-label)))
283 (load-binding-stack-pointer bsp
)
284 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
285 (inst add bsp
(* binding-size n-word-bytes
))
286 (store-binding-stack-pointer bsp
)
287 (inst or tls-index tls-index
)
288 (inst jmp
:ne tls-index-valid
)
289 (inst mov tls-index symbol
)
290 (inst call
(make-fixup
291 (ecase (tn-offset tls-index
)
292 (#.eax-offset
'alloc-tls-index-in-eax
)
293 (#.ebx-offset
'alloc-tls-index-in-ebx
)
294 (#.ecx-offset
'alloc-tls-index-in-ecx
)
295 (#.edx-offset
'alloc-tls-index-in-edx
)
296 (#.edi-offset
'alloc-tls-index-in-edi
)
297 (#.esi-offset
'alloc-tls-index-in-esi
))
299 (emit-label tls-index-valid
)
300 (inst push
(make-ea :dword
:base tls-index
) :fs
)
301 (popw bsp
(- binding-value-slot binding-size
))
302 (storew symbol bsp
(- binding-symbol-slot binding-size
))
303 (inst mov
(make-ea :dword
:base tls-index
) val
:fs
))))
307 (:args
(val :scs
(any-reg descriptor-reg
))
308 (symbol :scs
(descriptor-reg)))
309 (:temporary
(:sc unsigned-reg
) temp bsp
)
311 (load-symbol-value bsp
*binding-stack-pointer
*)
312 (loadw temp symbol symbol-value-slot other-pointer-lowtag
)
313 (inst add bsp
(* binding-size n-word-bytes
))
314 (store-symbol-value bsp
*binding-stack-pointer
*)
315 (storew temp bsp
(- binding-value-slot binding-size
))
316 (storew symbol bsp
(- binding-symbol-slot binding-size
))
317 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
321 (:temporary
(:sc unsigned-reg
) temp bsp tls-index
)
323 (load-binding-stack-pointer bsp
)
324 ;; Load SYMBOL from stack, and get the TLS-INDEX.
325 (loadw temp bsp
(- binding-symbol-slot binding-size
))
326 (loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag
)
327 ;; Load VALUE from stack, then restore it to the TLS area.
328 (loadw temp bsp
(- binding-value-slot binding-size
))
329 (inst mov
(make-ea :dword
:base tls-index
) temp
:fs
)
330 ;; Zero out the stack.
331 (storew 0 bsp
(- binding-symbol-slot binding-size
))
332 (storew 0 bsp
(- binding-value-slot binding-size
))
333 (inst sub bsp
(* binding-size n-word-bytes
))
334 (store-binding-stack-pointer bsp
)))
338 (:temporary
(:sc unsigned-reg
) symbol value bsp
)
340 (load-symbol-value bsp
*binding-stack-pointer
*)
341 (loadw symbol bsp
(- binding-symbol-slot binding-size
))
342 (loadw value bsp
(- binding-value-slot binding-size
))
343 (storew value symbol symbol-value-slot other-pointer-lowtag
)
344 (storew 0 bsp
(- binding-symbol-slot binding-size
))
345 (storew 0 bsp
(- binding-value-slot binding-size
))
346 (inst sub bsp
(* binding-size n-word-bytes
))
347 (store-symbol-value bsp
*binding-stack-pointer
*)))
350 (define-vop (unbind-to-here)
351 (:args
(where :scs
(descriptor-reg any-reg
)))
352 (:temporary
(:sc unsigned-reg
) symbol value bsp
#!+sb-thread tls-index
)
354 (load-binding-stack-pointer bsp
)
359 (loadw symbol bsp
(- binding-symbol-slot binding-size
))
360 (inst or symbol symbol
)
362 ;; Bind stack debug sentinels have the unbound marker in the symbol slot
363 (inst cmp symbol unbound-marker-widetag
)
365 (loadw value bsp
(- binding-value-slot binding-size
))
366 #!-sb-thread
(storew value symbol symbol-value-slot other-pointer-lowtag
)
369 tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
370 #!+sb-thread
(inst mov
(make-ea :dword
:base tls-index
) value
:fs
)
371 (storew 0 bsp
(- binding-symbol-slot binding-size
))
374 (storew 0 bsp
(- binding-value-slot binding-size
))
375 (inst sub bsp
(* binding-size n-word-bytes
))
378 (store-binding-stack-pointer bsp
)
382 (define-vop (bind-sentinel)
383 (:temporary
(:sc unsigned-reg
) bsp
)
385 (load-binding-stack-pointer bsp
)
386 (inst add bsp
(* binding-size n-word-bytes
))
387 (storew unbound-marker-widetag bsp
(- binding-symbol-slot binding-size
))
388 (storew ebp-tn bsp
(- binding-value-slot binding-size
))
389 (store-binding-stack-pointer bsp
)))
391 (define-vop (unbind-sentinel)
392 (:temporary
(:sc unsigned-reg
) bsp
)
394 (load-binding-stack-pointer bsp
)
395 (storew 0 bsp
(- binding-value-slot binding-size
))
396 (storew 0 bsp
(- binding-symbol-slot binding-size
))
397 (inst sub bsp
(* binding-size n-word-bytes
))
398 (store-binding-stack-pointer bsp
)))
402 ;;;; closure indexing
404 (define-full-reffer closure-index-ref
*
405 closure-info-offset fun-pointer-lowtag
406 (any-reg descriptor-reg
) * %closure-index-ref
)
408 (define-full-setter set-funcallable-instance-info
*
409 funcallable-instance-info-offset fun-pointer-lowtag
410 (any-reg descriptor-reg
) * %set-funcallable-instance-info
)
412 (define-full-reffer funcallable-instance-info
*
413 funcallable-instance-info-offset fun-pointer-lowtag
414 (descriptor-reg any-reg
) * %funcallable-instance-info
)
416 (define-vop (closure-ref slot-ref
)
417 (:variant closure-info-offset fun-pointer-lowtag
))
419 (define-vop (closure-init slot-set
)
420 (:variant closure-info-offset fun-pointer-lowtag
))
422 ;;;; value cell hackery
424 (define-vop (value-cell-ref cell-ref
)
425 (:variant value-cell-value-slot other-pointer-lowtag
))
427 (define-vop (value-cell-set cell-set
)
428 (:variant value-cell-value-slot other-pointer-lowtag
))
430 ;;;; structure hackery
432 (define-vop (instance-length)
434 (:translate %instance-length
)
435 (:args
(struct :scs
(descriptor-reg)))
436 (:results
(res :scs
(unsigned-reg)))
437 (:result-types positive-fixnum
)
439 (loadw res struct
0 instance-pointer-lowtag
)
440 (inst shr res n-widetag-bits
)))
442 (define-full-reffer instance-index-ref
*
443 instance-slots-offset instance-pointer-lowtag
444 (any-reg descriptor-reg
) *
447 (define-full-setter instance-index-set
*
448 instance-slots-offset instance-pointer-lowtag
449 (any-reg descriptor-reg
) *
452 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
453 instance-slots-offset instance-pointer-lowtag
454 (any-reg descriptor-reg
) *
455 %compare-and-swap-instance-ref
)
457 ;;;; code object frobbing
459 (define-full-reffer code-header-ref
* 0 other-pointer-lowtag
460 (any-reg descriptor-reg
) * code-header-ref
)
462 (define-full-setter code-header-set
* 0 other-pointer-lowtag
463 (any-reg descriptor-reg
) * code-header-set
)
465 ;;;; raw instance slot accessors
467 (defun make-ea-for-raw-slot (object index instance-length n-words
)
468 (if (integerp instance-length
)
469 ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
473 :disp
(- (* (- instance-length instance-slots-offset index
(1- n-words
))
475 instance-pointer-lowtag
))
476 (flet ((make-ea-using-value (value)
477 (make-ea :dword
:base object
478 :index instance-length
480 :disp
(- (* (- instance-slots-offset n-words
)
482 instance-pointer-lowtag
483 (* value n-word-bytes
)))))
484 (if (typep index
'tn
)
486 (any-reg (make-ea :dword
488 :index instance-length
489 :disp
(- (* (- instance-slots-offset n-words
)
491 instance-pointer-lowtag
)))
492 (immediate (make-ea-using-value (tn-value index
))))
493 (make-ea-using-value index
)))))
495 (define-vop (raw-instance-ref/word
)
496 (:translate %raw-instance-ref
/word
)
498 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
499 (:arg-types
* tagged-num
)
500 (:temporary
(:sc unsigned-reg
) tmp
)
501 (:results
(value :scs
(unsigned-reg)))
502 (:result-types unsigned-num
)
504 (loadw tmp object
0 instance-pointer-lowtag
)
505 (inst shr tmp n-widetag-bits
)
506 (when (sc-is index any-reg
)
507 (inst shl tmp n-fixnum-tag-bits
)
508 (inst sub tmp index
))
509 (inst mov value
(make-ea-for-raw-slot object index tmp
1))))
511 (define-vop (raw-instance-set/word
)
512 (:translate %raw-instance-set
/word
)
514 (:args
(object :scs
(descriptor-reg))
515 (index :scs
(any-reg immediate
))
516 (value :scs
(unsigned-reg) :target result
))
517 (:arg-types
* tagged-num unsigned-num
)
518 (:temporary
(:sc unsigned-reg
) tmp
)
519 (:results
(result :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
(make-ea-for-raw-slot object index tmp
1) value
)
528 (move result value
)))
530 (define-vop (raw-instance-init/word
)
531 (:args
(object :scs
(descriptor-reg))
532 (value :scs
(unsigned-reg)))
533 (:arg-types
* unsigned-num
)
534 (:info instance-length index
)
536 (inst mov
(make-ea-for-raw-slot object index instance-length
1) value
)))
538 (define-vop (raw-instance-atomic-incf/word
)
539 (:translate %raw-instance-atomic-incf
/word
)
541 (:args
(object :scs
(descriptor-reg))
542 (index :scs
(any-reg immediate
))
543 (diff :scs
(unsigned-reg) :target result
))
544 (:arg-types
* tagged-num unsigned-num
)
545 (:temporary
(:sc unsigned-reg
) tmp
)
546 (:results
(result :scs
(unsigned-reg)))
547 (:result-types unsigned-num
)
549 (loadw tmp object
0 instance-pointer-lowtag
)
550 (inst shr tmp n-widetag-bits
)
551 (when (sc-is index any-reg
)
552 (inst shl tmp n-fixnum-tag-bits
)
553 (inst sub tmp index
))
554 (inst xadd
(make-ea-for-raw-slot object index tmp
1) diff
:lock
)
557 (define-vop (raw-instance-ref/single
)
558 (:translate %raw-instance-ref
/single
)
560 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
561 (:arg-types
* tagged-num
)
562 (:temporary
(:sc unsigned-reg
) tmp
)
563 (:results
(value :scs
(single-reg)))
564 (:result-types single-float
)
566 (loadw tmp object
0 instance-pointer-lowtag
)
567 (inst shr tmp n-widetag-bits
)
568 (when (sc-is index any-reg
)
569 (inst shl tmp n-fixnum-tag-bits
)
570 (inst sub tmp index
))
571 (with-empty-tn@fp-top
(value)
572 (inst fld
(make-ea-for-raw-slot object index tmp
1)))))
574 (define-vop (raw-instance-set/single
)
575 (:translate %raw-instance-set
/single
)
577 (:args
(object :scs
(descriptor-reg))
578 (index :scs
(any-reg immediate
))
579 (value :scs
(single-reg) :target result
))
580 (:arg-types
* tagged-num single-float
)
581 (:temporary
(:sc unsigned-reg
) tmp
)
582 (:results
(result :scs
(single-reg)))
583 (:result-types single-float
)
585 (loadw tmp object
0 instance-pointer-lowtag
)
586 (inst shr tmp n-widetag-bits
)
587 (when (sc-is index any-reg
)
588 (inst shl tmp n-fixnum-tag-bits
)
589 (inst sub tmp index
))
590 (unless (zerop (tn-offset value
))
592 (inst fst
(make-ea-for-raw-slot object index tmp
1))
594 ((zerop (tn-offset value
))
595 (unless (zerop (tn-offset result
))
597 ((zerop (tn-offset result
))
600 (unless (location= value result
)
602 (inst fxch value
)))))
604 (define-vop (raw-instance-init/single
)
605 (:args
(object :scs
(descriptor-reg))
606 (value :scs
(single-reg)))
607 (:arg-types
* single-float
)
608 (:info instance-length index
)
610 (with-tn@fp-top
(value)
611 (inst fst
(make-ea-for-raw-slot object index instance-length
1)))))
613 (define-vop (raw-instance-ref/double
)
614 (:translate %raw-instance-ref
/double
)
616 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg immediate
)))
617 (:arg-types
* tagged-num
)
618 (:temporary
(:sc unsigned-reg
) tmp
)
619 (:results
(value :scs
(double-reg)))
620 (:result-types double-float
)
622 (loadw tmp object
0 instance-pointer-lowtag
)
623 (inst shr tmp n-widetag-bits
)
624 (when (sc-is index any-reg
)
625 (inst shl tmp n-fixnum-tag-bits
)
626 (inst sub tmp index
))
627 (with-empty-tn@fp-top
(value)
628 (inst fldd
(make-ea-for-raw-slot object index tmp
2)))))
630 (define-vop (raw-instance-set/double
)
631 (:translate %raw-instance-set
/double
)
633 (:args
(object :scs
(descriptor-reg))
634 (index :scs
(any-reg immediate
))
635 (value :scs
(double-reg) :target result
))
636 (:arg-types
* tagged-num double-float
)
637 (:temporary
(:sc unsigned-reg
) tmp
)
638 (:results
(result :scs
(double-reg)))
639 (:result-types double-float
)
641 (loadw tmp object
0 instance-pointer-lowtag
)
642 (inst shr tmp n-widetag-bits
)
643 (when (sc-is index any-reg
)
644 (inst shl tmp n-fixnum-tag-bits
)
645 (inst sub tmp index
))
646 (unless (zerop (tn-offset value
))
648 (inst fstd
(make-ea-for-raw-slot object index tmp
2))
650 ((zerop (tn-offset value
))
651 (unless (zerop (tn-offset result
))
653 ((zerop (tn-offset result
))
656 (unless (location= value result
)
658 (inst fxch value
)))))
660 (define-vop (raw-instance-init/double
)
661 (:args
(object :scs
(descriptor-reg))
662 (value :scs
(double-reg)))
663 (:arg-types
* double-float
)
664 (:info instance-length index
)
666 (with-tn@fp-top
(value)
667 (inst fstd
(make-ea-for-raw-slot object index instance-length
2)))))
669 (define-vop (raw-instance-ref/complex-single
)
670 (:translate %raw-instance-ref
/complex-single
)
672 (:args
(object :scs
(descriptor-reg))
673 (index :scs
(any-reg immediate
)))
674 (:arg-types
* positive-fixnum
)
675 (:temporary
(:sc unsigned-reg
) tmp
)
676 (:results
(value :scs
(complex-single-reg)))
677 (:result-types complex-single-float
)
679 (loadw tmp object
0 instance-pointer-lowtag
)
680 (inst shr tmp n-widetag-bits
)
681 (when (sc-is index any-reg
)
682 (inst shl tmp n-fixnum-tag-bits
)
683 (inst sub tmp index
))
684 (let ((real-tn (complex-single-reg-real-tn value
)))
685 (with-empty-tn@fp-top
(real-tn)
686 (inst fld
(make-ea-for-raw-slot object index tmp
2))))
687 (let ((imag-tn (complex-single-reg-imag-tn value
)))
688 (with-empty-tn@fp-top
(imag-tn)
689 (inst fld
(make-ea-for-raw-slot object index tmp
1))))))
691 (define-vop (raw-instance-set/complex-single
)
692 (:translate %raw-instance-set
/complex-single
)
694 (:args
(object :scs
(descriptor-reg))
695 (index :scs
(any-reg immediate
))
696 (value :scs
(complex-single-reg) :target result
))
697 (:arg-types
* positive-fixnum complex-single-float
)
698 (:temporary
(:sc unsigned-reg
) tmp
)
699 (:results
(result :scs
(complex-single-reg)))
700 (:result-types complex-single-float
)
702 (loadw tmp object
0 instance-pointer-lowtag
)
703 (inst shr tmp n-widetag-bits
)
704 (when (sc-is index any-reg
)
705 (inst shl tmp n-fixnum-tag-bits
)
706 (inst sub tmp index
))
707 (let ((value-real (complex-single-reg-real-tn value
))
708 (result-real (complex-single-reg-real-tn result
)))
709 (cond ((zerop (tn-offset value-real
))
711 (inst fst
(make-ea-for-raw-slot object index tmp
2))
712 (unless (zerop (tn-offset result-real
))
713 ;; Value is in ST0 but not result.
714 (inst fst result-real
)))
716 ;; Value is not in ST0.
717 (inst fxch value-real
)
718 (inst fst
(make-ea-for-raw-slot object index tmp
2))
719 (cond ((zerop (tn-offset result-real
))
720 ;; The result is in ST0.
721 (inst fst value-real
))
723 ;; Neither value or result are in ST0
724 (unless (location= value-real result-real
)
725 (inst fst result-real
))
726 (inst fxch value-real
))))))
727 (let ((value-imag (complex-single-reg-imag-tn value
))
728 (result-imag (complex-single-reg-imag-tn result
)))
729 (inst fxch value-imag
)
730 (inst fst
(make-ea-for-raw-slot object index tmp
1))
731 (unless (location= value-imag result-imag
)
732 (inst fst result-imag
))
733 (inst fxch value-imag
))))
735 (define-vop (raw-instance-init/complex-single
)
736 (:args
(object :scs
(descriptor-reg))
737 (value :scs
(complex-single-reg)))
738 (:arg-types
* complex-single-float
)
739 (:info instance-length index
)
741 (let ((value-real (complex-single-reg-real-tn value
)))
742 (with-tn@fp-top
(value-real)
743 (inst fst
(make-ea-for-raw-slot object index instance-length
2))))
744 (let ((value-imag (complex-single-reg-imag-tn value
)))
745 (with-tn@fp-top
(value-imag)
746 (inst fst
(make-ea-for-raw-slot object index instance-length
1))))))
748 (define-vop (raw-instance-ref/complex-double
)
749 (:translate %raw-instance-ref
/complex-double
)
751 (:args
(object :scs
(descriptor-reg))
752 (index :scs
(any-reg immediate
)))
753 (:arg-types
* positive-fixnum
)
754 (:temporary
(:sc unsigned-reg
) tmp
)
755 (:results
(value :scs
(complex-double-reg)))
756 (:result-types complex-double-float
)
758 (loadw tmp object
0 instance-pointer-lowtag
)
759 (inst shr tmp n-widetag-bits
)
760 (when (sc-is index any-reg
)
761 (inst shl tmp n-fixnum-tag-bits
)
762 (inst sub tmp index
))
763 (let ((real-tn (complex-double-reg-real-tn value
)))
764 (with-empty-tn@fp-top
(real-tn)
765 (inst fldd
(make-ea-for-raw-slot object index tmp
4))))
766 (let ((imag-tn (complex-double-reg-imag-tn value
)))
767 (with-empty-tn@fp-top
(imag-tn)
768 (inst fldd
(make-ea-for-raw-slot object index tmp
2))))))
770 (define-vop (raw-instance-set/complex-double
)
771 (:translate %raw-instance-set
/complex-double
)
773 (:args
(object :scs
(descriptor-reg))
774 (index :scs
(any-reg immediate
))
775 (value :scs
(complex-double-reg) :target result
))
776 (:arg-types
* positive-fixnum complex-double-float
)
777 (:temporary
(:sc unsigned-reg
) tmp
)
778 (:results
(result :scs
(complex-double-reg)))
779 (:result-types complex-double-float
)
781 (loadw tmp object
0 instance-pointer-lowtag
)
782 (inst shr tmp n-widetag-bits
)
783 (when (sc-is index any-reg
)
784 (inst shl tmp n-fixnum-tag-bits
)
785 (inst sub tmp index
))
786 (let ((value-real (complex-double-reg-real-tn value
))
787 (result-real (complex-double-reg-real-tn result
)))
788 (cond ((zerop (tn-offset value-real
))
790 (inst fstd
(make-ea-for-raw-slot object index tmp
4))
791 (unless (zerop (tn-offset result-real
))
792 ;; Value is in ST0 but not result.
793 (inst fstd result-real
)))
795 ;; Value is not in ST0.
796 (inst fxch value-real
)
797 (inst fstd
(make-ea-for-raw-slot object index tmp
4))
798 (cond ((zerop (tn-offset result-real
))
799 ;; The result is in ST0.
800 (inst fstd value-real
))
802 ;; Neither value or result are in ST0
803 (unless (location= value-real result-real
)
804 (inst fstd result-real
))
805 (inst fxch value-real
))))))
806 (let ((value-imag (complex-double-reg-imag-tn value
))
807 (result-imag (complex-double-reg-imag-tn result
)))
808 (inst fxch value-imag
)
809 (inst fstd
(make-ea-for-raw-slot object index tmp
2))
810 (unless (location= value-imag result-imag
)
811 (inst fstd result-imag
))
812 (inst fxch value-imag
))))
814 (define-vop (raw-instance-init/complex-double
)
815 (:args
(object :scs
(descriptor-reg))
816 (value :scs
(complex-double-reg)))
817 (:arg-types
* complex-double-float
)
818 (:info instance-length index
)
820 (let ((value-real (complex-double-reg-real-tn value
)))
821 (with-tn@fp-top
(value-real)
822 (inst fstd
(make-ea-for-raw-slot object index instance-length
4))))
823 (let ((value-imag (complex-double-reg-imag-tn value
)))
824 (with-tn@fp-top
(value-imag)
825 (inst fstd
(make-ea-for-raw-slot object index instance-length
2))))))