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 (:temporary (:sc descriptor-reg) temp)
28 (:info name offset lowtag)
32 (if (sc-is value immediate)
33 (let ((val (tn-value value)))
34 (move-immediate (make-ea :qword
36 :disp (- (* offset n-word-bytes)
42 (+ nil-value (static-symbol-offset val)))
44 (logior (ash (char-code val) n-widetag-bits)
47 ;; Else, value not immediate.
48 (storew value object offset lowtag))))
50 (define-vop (compare-and-swap-slot)
51 (:args (object :scs (descriptor-reg) :to :eval)
52 (old :scs (descriptor-reg any-reg) :target rax)
53 (new :scs (descriptor-reg any-reg)))
54 (:temporary (:sc descriptor-reg :offset rax-offset
55 :from (:argument 1) :to :result :target result)
57 (:info name offset lowtag)
59 (:results (result :scs (descriptor-reg any-reg)))
64 (inst cmpxchg (make-ea :qword :base object
65 :disp (- (* offset n-word-bytes) lowtag))
69 ;;;; symbol hacking VOPs
71 (define-vop (%compare-and-swap-symbol-value)
72 (:translate %compare-and-swap-symbol-value)
73 (:args (symbol :scs (descriptor-reg) :to (:result 1))
74 (old :scs (descriptor-reg any-reg) :target rax)
75 (new :scs (descriptor-reg any-reg)))
76 (:temporary (:sc descriptor-reg :offset rax-offset) rax)
78 (:temporary (:sc descriptor-reg) tls)
79 (:results (result :scs (descriptor-reg any-reg)))
83 ;; This code has two pathological cases: NO-TLS-VALUE-MARKER
84 ;; or UNBOUND-MARKER as NEW: in either case we would end up
85 ;; doing possible damage with CMPXCHG -- so don't do that!
86 (let ((unbound (generate-error-code vop 'unbound-symbol-error symbol))
91 (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
92 ;; Thread-local area, no LOCK needed.
93 (inst cmpxchg (make-ea :qword :base thread-base-tn
96 (inst cmp rax no-tls-value-marker-widetag)
100 (inst cmpxchg (make-ea :qword :base symbol
101 :disp (- (* symbol-value-slot n-word-bytes)
102 other-pointer-lowtag)
107 (inst cmp result unbound-marker-widetag)
108 (inst jmp :e unbound))))
110 ;;; these next two cf the sparc version, by jrd.
111 ;;; FIXME: Deref this ^ reference.
114 ;;; The compiler likes to be able to directly SET symbols.
117 (:args (symbol :scs (descriptor-reg))
118 (value :scs (descriptor-reg any-reg)))
119 (:temporary (:sc descriptor-reg) tls)
120 ;;(:policy :fast-safe)
122 (let ((global-val (gen-label))
124 (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
125 (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls)
126 no-tls-value-marker-widetag)
127 (inst jmp :z global-val)
128 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls)
131 (emit-label global-val)
132 (storew value symbol symbol-value-slot other-pointer-lowtag)
135 ;; unithreaded it's a lot simpler ...
137 (define-vop (set cell-set)
138 (:variant symbol-value-slot other-pointer-lowtag))
140 ;;; With Symbol-Value, we check that the value isn't the trap object. So
141 ;;; Symbol-Value of NIL is NIL.
143 (define-vop (symbol-value)
144 (:translate symbol-value)
146 (:args (object :scs (descriptor-reg) :to (:result 1)))
147 (:results (value :scs (descriptor-reg any-reg)))
149 (:save-p :compute-only)
151 (let* ((check-unbound-label (gen-label))
152 (err-lab (generate-error-code vop 'unbound-symbol-error object))
153 (ret-lab (gen-label)))
154 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
155 (inst mov value (make-ea :qword :base thread-base-tn
156 :index value :scale 1))
157 (inst cmp value no-tls-value-marker-widetag)
158 (inst jmp :ne check-unbound-label)
159 (loadw value object symbol-value-slot other-pointer-lowtag)
160 (emit-label check-unbound-label)
161 (inst cmp value unbound-marker-widetag)
162 (inst jmp :e err-lab)
163 (emit-label ret-lab))))
166 (define-vop (fast-symbol-value symbol-value)
167 ;; KLUDGE: not really fast, in fact, because we're going to have to
168 ;; do a full lookup of the thread-local area anyway. But half of
169 ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
170 ;; unbound", which is used in the implementation of COPY-SYMBOL. --
173 (:translate symbol-value)
175 (let ((ret-lab (gen-label)))
176 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
178 (make-ea :qword :base thread-base-tn :index value :scale 1))
179 (inst cmp value no-tls-value-marker-widetag)
180 (inst jmp :ne ret-lab)
181 (loadw value object symbol-value-slot other-pointer-lowtag)
182 (emit-label ret-lab))))
185 (define-vop (symbol-value)
186 (:translate symbol-value)
188 (:args (object :scs (descriptor-reg) :to (:result 1)))
189 (:results (value :scs (descriptor-reg any-reg)))
191 (:save-p :compute-only)
193 (let ((err-lab (generate-error-code vop 'unbound-symbol-error object)))
194 (loadw value object symbol-value-slot other-pointer-lowtag)
195 (inst cmp value unbound-marker-widetag)
196 (inst jmp :e err-lab))))
199 (define-vop (fast-symbol-value cell-ref)
200 (:variant symbol-value-slot other-pointer-lowtag)
202 (:translate symbol-value))
204 (defknown locked-symbol-global-value-add (symbol fixnum) fixnum ())
206 (define-vop (locked-symbol-global-value-add)
207 (:args (object :scs (descriptor-reg) :to :result)
208 (value :scs (any-reg) :target result))
209 (:arg-types * tagged-num)
210 (:results (result :scs (any-reg) :from (:argument 1)))
212 (:translate locked-symbol-global-value-add)
213 (:result-types tagged-num)
218 (inst add (make-ea :qword :base object
219 :disp (- (* symbol-value-slot n-word-bytes)
220 other-pointer-lowtag))
227 (:args (object :scs (descriptor-reg)))
230 (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
232 (let ((check-unbound-label (gen-label)))
233 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
235 (make-ea :qword :base thread-base-tn :index value :scale 1))
236 (inst cmp value no-tls-value-marker-widetag)
237 (inst jmp :ne check-unbound-label)
238 (loadw value object symbol-value-slot other-pointer-lowtag)
239 (emit-label check-unbound-label)
240 (inst cmp value unbound-marker-widetag)
241 (inst jmp (if not-p :e :ne) target))))
247 (:args (object :scs (descriptor-reg)))
251 (inst cmp (make-ea-for-object-slot object symbol-value-slot
252 other-pointer-lowtag)
253 unbound-marker-widetag)
254 (inst jmp (if not-p :e :ne) target)))
257 (define-vop (symbol-hash)
259 (:translate symbol-hash)
260 (:args (symbol :scs (descriptor-reg)))
261 (:results (res :scs (any-reg)))
262 (:result-types positive-fixnum)
264 ;; The symbol-hash slot of NIL holds NIL because it is also the
265 ;; cdr slot, so we have to strip off the three low bits to make sure
266 ;; it is a fixnum. The lowtag selection magic that is required to
267 ;; ensure this is explained in the comment in objdef.lisp
268 (loadw res symbol symbol-hash-slot other-pointer-lowtag)
269 (inst and res (lognot #b111))))
271 ;;;; fdefinition (FDEFN) objects
273 (define-vop (fdefn-fun cell-ref) ; /pfw - alpha
274 (:variant fdefn-fun-slot other-pointer-lowtag))
276 (define-vop (safe-fdefn-fun)
277 (:args (object :scs (descriptor-reg) :to (:result 1)))
278 (:results (value :scs (descriptor-reg any-reg)))
280 (:save-p :compute-only)
282 (loadw value object fdefn-fun-slot other-pointer-lowtag)
283 (inst cmp value nil-value)
284 (let ((err-lab (generate-error-code vop 'undefined-fun-error object)))
285 (inst jmp :e err-lab))))
287 (define-vop (set-fdefn-fun)
289 (:translate (setf fdefn-fun))
290 (:args (function :scs (descriptor-reg) :target result)
291 (fdefn :scs (descriptor-reg)))
292 (:temporary (:sc unsigned-reg) raw)
293 (:temporary (:sc byte-reg) type)
294 (:results (result :scs (descriptor-reg)))
296 (load-type type function (- fun-pointer-lowtag))
298 (make-ea :byte :base function
299 :disp (- (* simple-fun-code-offset n-word-bytes)
300 fun-pointer-lowtag)))
301 (inst cmp type simple-fun-header-widetag)
302 (inst jmp :e NORMAL-FUN)
303 (inst lea raw (make-fixup "closure_tramp" :foreign))
305 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
306 (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
307 (move result function)))
309 (define-vop (fdefn-makunbound)
311 (:translate fdefn-makunbound)
312 (:args (fdefn :scs (descriptor-reg) :target result))
313 (:results (result :scs (descriptor-reg)))
315 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
316 (storew (make-fixup "undefined_tramp" :foreign)
317 fdefn fdefn-raw-addr-slot other-pointer-lowtag)
318 (move result fdefn)))
320 ;;;; binding and unbinding
322 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
323 ;;; the symbol on the binding stack and stuff the new value into the
328 (:args (val :scs (any-reg descriptor-reg))
329 (symbol :scs (descriptor-reg)))
330 (:temporary (:sc unsigned-reg) tls-index bsp)
332 (let ((tls-index-valid (gen-label)))
333 (load-binding-stack-pointer bsp)
334 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
335 (inst add bsp (* binding-size n-word-bytes))
336 (store-binding-stack-pointer bsp)
337 (inst or tls-index tls-index)
338 (inst jmp :ne tls-index-valid)
339 (inst mov tls-index symbol)
340 (inst lea temp-reg-tn
341 (make-ea :qword :disp
342 (make-fixup (ecase (tn-offset tls-index)
343 (#.rax-offset 'alloc-tls-index-in-rax)
344 (#.rcx-offset 'alloc-tls-index-in-rcx)
345 (#.rdx-offset 'alloc-tls-index-in-rdx)
346 (#.rbx-offset 'alloc-tls-index-in-rbx)
347 (#.rsi-offset 'alloc-tls-index-in-rsi)
348 (#.rdi-offset 'alloc-tls-index-in-rdi)
349 (#.r8-offset 'alloc-tls-index-in-r8)
350 (#.r9-offset 'alloc-tls-index-in-r9)
351 (#.r10-offset 'alloc-tls-index-in-r10)
352 (#.r12-offset 'alloc-tls-index-in-r12)
353 (#.r13-offset 'alloc-tls-index-in-r13)
354 (#.r14-offset 'alloc-tls-index-in-r14)
355 (#.r15-offset 'alloc-tls-index-in-r15))
357 (inst call temp-reg-tn)
358 (emit-label tls-index-valid)
359 (inst push (make-ea :qword :base thread-base-tn :scale 1 :index tls-index))
360 (popw bsp (- binding-value-slot binding-size))
361 (storew symbol bsp (- binding-symbol-slot binding-size))
362 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
367 (:args (val :scs (any-reg descriptor-reg))
368 (symbol :scs (descriptor-reg)))
369 (:temporary (:sc unsigned-reg) temp bsp)
371 (load-symbol-value bsp *binding-stack-pointer*)
372 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
373 (inst add bsp (* binding-size n-word-bytes))
374 (store-symbol-value bsp *binding-stack-pointer*)
375 (storew temp bsp (- binding-value-slot binding-size))
376 (storew symbol bsp (- binding-symbol-slot binding-size))
377 (storew val symbol symbol-value-slot other-pointer-lowtag)))
381 (:temporary (:sc unsigned-reg) temp bsp tls-index)
383 (load-binding-stack-pointer bsp)
384 ;; Load SYMBOL from stack, and get the TLS-INDEX
385 (loadw temp bsp (- binding-symbol-slot binding-size))
386 (loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag)
387 ;; Load VALUE from stack, the restore it to the TLS area.
388 (loadw temp bsp (- binding-value-slot binding-size))
389 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
391 ;; Zero out the stack.
392 (storew 0 bsp (- binding-symbol-slot binding-size))
393 (storew 0 bsp (- binding-value-slot binding-size))
394 (inst sub bsp (* binding-size n-word-bytes))
395 (store-binding-stack-pointer bsp)))
399 (:temporary (:sc unsigned-reg) symbol value bsp)
401 (load-symbol-value bsp *binding-stack-pointer*)
402 (loadw symbol bsp (- binding-symbol-slot binding-size))
403 (loadw value bsp (- binding-value-slot binding-size))
404 (storew value symbol symbol-value-slot other-pointer-lowtag)
405 (storew 0 bsp (- binding-symbol-slot binding-size))
406 (storew 0 bsp (- binding-value-slot binding-size))
407 (inst sub bsp (* binding-size n-word-bytes))
408 (store-symbol-value bsp *binding-stack-pointer*)))
410 (define-vop (unbind-to-here)
411 (:args (where :scs (descriptor-reg any-reg)))
412 (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index)
414 (load-binding-stack-pointer bsp)
419 (loadw symbol bsp (- binding-symbol-slot binding-size))
420 (inst or symbol symbol)
422 ;; Bind stack debug sentinels have the unbound marker in the symbol slot
423 (inst cmp symbol unbound-marker-widetag)
425 (loadw value bsp (- binding-value-slot binding-size))
427 (storew value symbol symbol-value-slot other-pointer-lowtag)
429 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
431 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
433 (storew 0 bsp (- binding-symbol-slot binding-size))
436 (storew 0 bsp (- binding-value-slot binding-size))
437 (inst sub bsp (* binding-size n-word-bytes))
440 (store-binding-stack-pointer bsp)
444 (define-vop (bind-sentinel)
445 (:temporary (:sc unsigned-reg) bsp)
447 (load-binding-stack-pointer bsp)
448 (inst add bsp (* binding-size n-word-bytes))
449 (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
450 (storew rbp-tn bsp (- binding-value-slot binding-size))
451 (store-binding-stack-pointer bsp)))
453 (define-vop (unbind-sentinel)
454 (:temporary (:sc unsigned-reg) bsp)
456 (load-binding-stack-pointer bsp)
457 (storew 0 bsp (- binding-value-slot binding-size))
458 (storew 0 bsp (- binding-symbol-slot binding-size))
459 (inst sub bsp (* binding-size n-word-bytes))
460 (store-binding-stack-pointer bsp)))
465 ;;;; closure indexing
467 (define-full-reffer closure-index-ref *
468 closure-info-offset fun-pointer-lowtag
469 (any-reg descriptor-reg) * %closure-index-ref)
471 (define-full-setter set-funcallable-instance-info *
472 funcallable-instance-info-offset fun-pointer-lowtag
473 (any-reg descriptor-reg) * %set-funcallable-instance-info)
475 (define-full-reffer funcallable-instance-info *
476 funcallable-instance-info-offset fun-pointer-lowtag
477 (descriptor-reg any-reg) * %funcallable-instance-info)
479 (define-vop (closure-ref slot-ref)
480 (:variant closure-info-offset fun-pointer-lowtag))
482 (define-vop (closure-init slot-set)
483 (:variant closure-info-offset fun-pointer-lowtag))
485 ;;;; value cell hackery
487 (define-vop (value-cell-ref cell-ref)
488 (:variant value-cell-value-slot other-pointer-lowtag))
490 (define-vop (value-cell-set cell-set)
491 (:variant value-cell-value-slot other-pointer-lowtag))
493 ;;;; structure hackery
495 (define-vop (instance-length)
497 (:translate %instance-length)
498 (:args (struct :scs (descriptor-reg)))
499 (:results (res :scs (unsigned-reg)))
500 (:result-types positive-fixnum)
502 (loadw res struct 0 instance-pointer-lowtag)
503 (inst shr res n-widetag-bits)))
505 (define-full-reffer instance-index-ref * instance-slots-offset
506 instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
508 (define-full-setter instance-index-set * instance-slots-offset
509 instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
511 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
512 instance-slots-offset instance-pointer-lowtag
513 (any-reg descriptor-reg) *
514 %compare-and-swap-instance-ref)
516 ;;;; code object frobbing
518 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
519 (any-reg descriptor-reg) * code-header-ref)
521 (define-full-setter code-header-set * 0 other-pointer-lowtag
522 (any-reg descriptor-reg) * code-header-set)
524 ;;;; raw instance slot accessors
526 (defun make-ea-for-raw-slot (object index instance-length
527 &optional (adjustment 0))
530 (make-ea :qword :base object :index instance-length
531 :disp (+ (* (1- instance-slots-offset) n-word-bytes)
532 (- instance-pointer-lowtag)
535 (make-ea :qword :base object :index instance-length
537 :disp (+ (* (1- instance-slots-offset) n-word-bytes)
538 (- instance-pointer-lowtag)
540 (- (fixnumize index)))))))
542 (define-vop (raw-instance-ref/word)
543 (:translate %raw-instance-ref/word)
545 (:args (object :scs (descriptor-reg)) (index :scs (any-reg)))
546 (:arg-types * tagged-num)
547 (:temporary (:sc unsigned-reg) tmp)
548 (:results (value :scs (unsigned-reg)))
549 (:result-types unsigned-num)
551 (loadw tmp object 0 instance-pointer-lowtag)
552 (inst shr tmp n-widetag-bits)
555 (inst mov value (make-ea-for-raw-slot object index tmp))))
557 (define-vop (raw-instance-ref-c/word)
558 (:translate %raw-instance-ref/word)
560 (:args (object :scs (descriptor-reg)))
561 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
562 #.instance-pointer-lowtag
563 #.instance-slots-offset)))
565 (:temporary (:sc unsigned-reg) tmp)
566 (:results (value :scs (unsigned-reg)))
567 (:result-types unsigned-num)
569 (loadw tmp object 0 instance-pointer-lowtag)
570 (inst shr tmp n-widetag-bits)
571 (inst mov value (make-ea-for-raw-slot object index tmp))))
573 (define-vop (raw-instance-set/word)
574 (:translate %raw-instance-set/word)
576 (:args (object :scs (descriptor-reg))
577 (index :scs (any-reg))
578 (value :scs (unsigned-reg) :target result))
579 (:arg-types * tagged-num unsigned-num)
580 (:temporary (:sc unsigned-reg) tmp)
581 (:results (result :scs (unsigned-reg)))
582 (:result-types unsigned-num)
584 (loadw tmp object 0 instance-pointer-lowtag)
585 (inst shr tmp n-widetag-bits)
588 (inst mov (make-ea-for-raw-slot object index tmp) value)
589 (move result value)))
591 (define-vop (raw-instance-set-c/word)
592 (:translate %raw-instance-set/word)
594 (:args (object :scs (descriptor-reg))
595 (value :scs (unsigned-reg) :target result))
596 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
597 #.instance-pointer-lowtag
598 #.instance-slots-offset))
601 (:temporary (:sc unsigned-reg) tmp)
602 (:results (result :scs (unsigned-reg)))
603 (:result-types unsigned-num)
605 (loadw tmp object 0 instance-pointer-lowtag)
606 (inst shr tmp n-widetag-bits)
607 (inst mov (make-ea-for-raw-slot object index tmp) value)
608 (move result value)))
610 (define-vop (raw-instance-ref/single)
611 (:translate %raw-instance-ref/single)
613 (:args (object :scs (descriptor-reg))
614 (index :scs (any-reg)))
615 (:arg-types * positive-fixnum)
616 (:temporary (:sc unsigned-reg) tmp)
617 (:results (value :scs (single-reg)))
618 (:result-types single-float)
620 (loadw tmp object 0 instance-pointer-lowtag)
621 (inst shr tmp n-widetag-bits)
624 (inst movss value (make-ea-for-raw-slot object index tmp))))
626 (define-vop (raw-instance-ref-c/single)
627 (:translate %raw-instance-ref/single)
629 (:args (object :scs (descriptor-reg)))
630 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
631 #.instance-pointer-lowtag
632 #.instance-slots-offset)))
634 (:temporary (:sc unsigned-reg) tmp)
635 (:results (value :scs (single-reg)))
636 (:result-types single-float)
638 (loadw tmp object 0 instance-pointer-lowtag)
639 (inst shr tmp n-widetag-bits)
640 (inst movss value (make-ea-for-raw-slot object index tmp))))
642 (define-vop (raw-instance-set/single)
643 (:translate %raw-instance-set/single)
645 (:args (object :scs (descriptor-reg))
646 (index :scs (any-reg))
647 (value :scs (single-reg) :target result))
648 (:arg-types * positive-fixnum single-float)
649 (:temporary (:sc unsigned-reg) tmp)
650 (:results (result :scs (single-reg)))
651 (:result-types single-float)
653 (loadw tmp object 0 instance-pointer-lowtag)
654 (inst shr tmp n-widetag-bits)
657 (inst movss (make-ea-for-raw-slot object index tmp) value)
658 (unless (location= result value)
659 (inst movss result value))))
661 (define-vop (raw-instance-set-c/single)
662 (:translate %raw-instance-set/single)
664 (:args (object :scs (descriptor-reg))
665 (value :scs (single-reg) :target result))
666 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
667 #.instance-pointer-lowtag
668 #.instance-slots-offset))
671 (:temporary (:sc unsigned-reg) tmp)
672 (:results (result :scs (single-reg)))
673 (:result-types single-float)
675 (loadw tmp object 0 instance-pointer-lowtag)
676 (inst shr tmp n-widetag-bits)
677 (inst movss (make-ea-for-raw-slot object index tmp) value)
678 (unless (location= result value)
679 (inst movss result value))))
681 (define-vop (raw-instance-ref/double)
682 (:translate %raw-instance-ref/double)
684 (:args (object :scs (descriptor-reg))
685 (index :scs (any-reg)))
686 (:arg-types * positive-fixnum)
687 (:temporary (:sc unsigned-reg) tmp)
688 (:results (value :scs (double-reg)))
689 (:result-types double-float)
691 (loadw tmp object 0 instance-pointer-lowtag)
692 (inst shr tmp n-widetag-bits)
695 (inst movsd value (make-ea-for-raw-slot object index tmp))))
697 (define-vop (raw-instance-ref-c/double)
698 (:translate %raw-instance-ref/double)
700 (:args (object :scs (descriptor-reg)))
701 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
702 #.instance-pointer-lowtag
703 #.instance-slots-offset)))
705 (:temporary (:sc unsigned-reg) tmp)
706 (:results (value :scs (double-reg)))
707 (:result-types double-float)
709 (loadw tmp object 0 instance-pointer-lowtag)
710 (inst shr tmp n-widetag-bits)
711 (inst movsd value (make-ea-for-raw-slot object index tmp))))
713 (define-vop (raw-instance-set/double)
714 (:translate %raw-instance-set/double)
716 (:args (object :scs (descriptor-reg))
717 (index :scs (any-reg))
718 (value :scs (double-reg) :target result))
719 (:arg-types * positive-fixnum double-float)
720 (:temporary (:sc unsigned-reg) tmp)
721 (:results (result :scs (double-reg)))
722 (:result-types double-float)
724 (loadw tmp object 0 instance-pointer-lowtag)
725 (inst shr tmp n-widetag-bits)
728 (inst movsd (make-ea-for-raw-slot object index tmp) value)
729 (unless (location= result value)
730 (inst movsd result value))))
732 (define-vop (raw-instance-set-c/double)
733 (:translate %raw-instance-set/double)
735 (:args (object :scs (descriptor-reg))
736 (value :scs (double-reg) :target result))
737 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
738 #.instance-pointer-lowtag
739 #.instance-slots-offset))
742 (:temporary (:sc unsigned-reg) tmp)
743 (:results (result :scs (double-reg)))
744 (:result-types double-float)
746 (loadw tmp object 0 instance-pointer-lowtag)
747 (inst shr tmp n-widetag-bits)
748 (inst movsd (make-ea-for-raw-slot object index tmp) value)
749 (unless (location= result value)
750 (inst movsd result value))))
752 (define-vop (raw-instance-ref/complex-single)
753 (:translate %raw-instance-ref/complex-single)
755 (:args (object :scs (descriptor-reg))
756 (index :scs (any-reg)))
757 (:arg-types * positive-fixnum)
758 (:temporary (:sc unsigned-reg) tmp)
759 (:results (value :scs (complex-single-reg)))
760 (:result-types complex-single-float)
762 (loadw tmp object 0 instance-pointer-lowtag)
763 (inst shr tmp n-widetag-bits)
766 (let ((real-tn (complex-single-reg-real-tn value)))
767 (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
768 (let ((imag-tn (complex-single-reg-imag-tn value)))
769 (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
771 (define-vop (raw-instance-ref-c/complex-single)
772 (:translate %raw-instance-ref/complex-single)
774 (:args (object :scs (descriptor-reg)))
775 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
776 #.instance-pointer-lowtag
777 #.instance-slots-offset)))
779 (:temporary (:sc unsigned-reg) tmp)
780 (:results (value :scs (complex-single-reg)))
781 (:result-types complex-single-float)
783 (loadw tmp object 0 instance-pointer-lowtag)
784 (inst shr tmp n-widetag-bits)
785 (let ((real-tn (complex-single-reg-real-tn value)))
786 (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
787 (let ((imag-tn (complex-single-reg-imag-tn value)))
788 (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
790 (define-vop (raw-instance-set/complex-single)
791 (:translate %raw-instance-set/complex-single)
793 (:args (object :scs (descriptor-reg))
794 (index :scs (any-reg))
795 (value :scs (complex-single-reg) :target result))
796 (:arg-types * positive-fixnum complex-single-float)
797 (:temporary (:sc unsigned-reg) tmp)
798 (:results (result :scs (complex-single-reg)))
799 (:result-types complex-single-float)
801 (loadw tmp object 0 instance-pointer-lowtag)
802 (inst shr tmp n-widetag-bits)
805 (let ((value-real (complex-single-reg-real-tn value))
806 (result-real (complex-single-reg-real-tn result)))
807 (inst movss (make-ea-for-raw-slot object index tmp) value-real)
808 (unless (location= value-real result-real)
809 (inst movss result-real value-real)))
810 (let ((value-imag (complex-single-reg-imag-tn value))
811 (result-imag (complex-single-reg-imag-tn result)))
812 (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
813 (unless (location= value-imag result-imag)
814 (inst movss result-imag value-imag)))))
816 (define-vop (raw-instance-set-c/complex-single)
817 (:translate %raw-instance-set/complex-single)
819 (:args (object :scs (descriptor-reg))
820 (value :scs (complex-single-reg) :target result))
821 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
822 #.instance-pointer-lowtag
823 #.instance-slots-offset))
824 complex-single-float)
826 (:temporary (:sc unsigned-reg) tmp)
827 (:results (result :scs (complex-single-reg)))
828 (:result-types complex-single-float)
830 (loadw tmp object 0 instance-pointer-lowtag)
831 (inst shr tmp n-widetag-bits)
832 (let ((value-real (complex-single-reg-real-tn value))
833 (result-real (complex-single-reg-real-tn result)))
834 (inst movss (make-ea-for-raw-slot object index tmp) value-real)
835 (unless (location= value-real result-real)
836 (inst movss result-real value-real)))
837 (let ((value-imag (complex-single-reg-imag-tn value))
838 (result-imag (complex-single-reg-imag-tn result)))
839 (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
840 (unless (location= value-imag result-imag)
841 (inst movss result-imag value-imag)))))
843 (define-vop (raw-instance-ref/complex-double)
844 (:translate %raw-instance-ref/complex-double)
846 (:args (object :scs (descriptor-reg))
847 (index :scs (any-reg)))
848 (:arg-types * positive-fixnum)
849 (:temporary (:sc unsigned-reg) tmp)
850 (:results (value :scs (complex-double-reg)))
851 (:result-types complex-double-float)
853 (loadw tmp object 0 instance-pointer-lowtag)
854 (inst shr tmp n-widetag-bits)
857 (let ((real-tn (complex-double-reg-real-tn value)))
858 (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
859 (let ((imag-tn (complex-double-reg-imag-tn value)))
860 (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
862 (define-vop (raw-instance-ref-c/complex-double)
863 (:translate %raw-instance-ref/complex-double)
865 (:args (object :scs (descriptor-reg)))
866 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
867 #.instance-pointer-lowtag
868 #.instance-slots-offset)))
870 (:temporary (:sc unsigned-reg) tmp)
871 (:results (value :scs (complex-double-reg)))
872 (:result-types complex-double-float)
874 (loadw tmp object 0 instance-pointer-lowtag)
875 (inst shr tmp n-widetag-bits)
876 (let ((real-tn (complex-double-reg-real-tn value)))
877 (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
878 (let ((imag-tn (complex-double-reg-imag-tn value)))
879 (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
881 (define-vop (raw-instance-set/complex-double)
882 (:translate %raw-instance-set/complex-double)
884 (:args (object :scs (descriptor-reg))
885 (index :scs (any-reg))
886 (value :scs (complex-double-reg) :target result))
887 (:arg-types * positive-fixnum complex-double-float)
888 (:temporary (:sc unsigned-reg) tmp)
889 (:results (result :scs (complex-double-reg)))
890 (:result-types complex-double-float)
892 (loadw tmp object 0 instance-pointer-lowtag)
893 (inst shr tmp n-widetag-bits)
896 (let ((value-real (complex-double-reg-real-tn value))
897 (result-real (complex-double-reg-real-tn result)))
898 (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
899 (unless (location= value-real result-real)
900 (inst movsd result-real value-real)))
901 (let ((value-imag (complex-double-reg-imag-tn value))
902 (result-imag (complex-double-reg-imag-tn result)))
903 (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
904 (unless (location= value-imag result-imag)
905 (inst movsd result-imag value-imag)))))
907 (define-vop (raw-instance-set-c/complex-double)
908 (:translate %raw-instance-set/complex-double)
910 (:args (object :scs (descriptor-reg))
911 (value :scs (complex-double-reg) :target result))
912 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
913 #.instance-pointer-lowtag
914 #.instance-slots-offset))
915 complex-double-float)
917 (:temporary (:sc unsigned-reg) tmp)
918 (:results (result :scs (complex-double-reg)))
919 (:result-types complex-double-float)
921 (loadw tmp object 0 instance-pointer-lowtag)
922 (inst shr tmp n-widetag-bits)
923 (let ((value-real (complex-double-reg-real-tn value))
924 (result-real (complex-double-reg-real-tn result)))
925 (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
926 (unless (location= value-real result-real)
927 (inst movsd result-real value-real)))
928 (let ((value-imag (complex-double-reg-imag-tn value))
929 (result-imag (complex-double-reg-imag-tn result)))
930 (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
931 (unless (location= value-imag result-imag)
932 (inst movsd result-imag value-imag)))))