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)))
62 (inst cmpxchg (make-ea :qword :base object
63 :disp (- (* offset n-word-bytes) lowtag))
67 ;;;; symbol hacking VOPs
69 (define-vop (%compare-and-swap-symbol-value)
70 (:translate %compare-and-swap-symbol-value)
71 (:args (symbol :scs (descriptor-reg) :to (:result 1))
72 (old :scs (descriptor-reg any-reg) :target rax)
73 (new :scs (descriptor-reg any-reg)))
74 (:temporary (:sc descriptor-reg :offset rax-offset) rax)
76 (:temporary (:sc descriptor-reg) tls)
77 (:results (result :scs (descriptor-reg any-reg)))
81 ;; This code has two pathological cases: NO-TLS-VALUE-MARKER
82 ;; or UNBOUND-MARKER as NEW: in either case we would end up
83 ;; doing possible damage with CMPXCHG -- so don't do that!
84 (let ((unbound (generate-error-code vop 'unbound-symbol-error symbol))
89 (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
90 ;; Thread-local area, no LOCK needed.
91 (inst cmpxchg (make-ea :qword :base thread-base-tn
94 (inst cmp rax no-tls-value-marker-widetag)
97 (inst cmpxchg (make-ea :qword :base symbol
98 :disp (- (* symbol-value-slot n-word-bytes)
104 (inst cmp result unbound-marker-widetag)
105 (inst jmp :e unbound))))
107 ;;; these next two cf the sparc version, by jrd.
108 ;;; FIXME: Deref this ^ reference.
111 ;;; The compiler likes to be able to directly SET symbols.
114 (:args (symbol :scs (descriptor-reg))
115 (value :scs (descriptor-reg any-reg)))
116 (:temporary (:sc descriptor-reg) tls)
117 ;;(:policy :fast-safe)
119 (let ((global-val (gen-label))
121 (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
122 (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls)
123 no-tls-value-marker-widetag)
124 (inst jmp :z global-val)
125 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls)
128 (emit-label global-val)
129 (storew value symbol symbol-value-slot other-pointer-lowtag)
132 ;; unithreaded it's a lot simpler ...
134 (define-vop (set cell-set)
135 (:variant symbol-value-slot other-pointer-lowtag))
137 ;;; With Symbol-Value, we check that the value isn't the trap object. So
138 ;;; Symbol-Value of NIL is NIL.
140 (define-vop (symbol-value)
141 (:translate symbol-value)
143 (:args (object :scs (descriptor-reg) :to (:result 1)))
144 (:results (value :scs (descriptor-reg any-reg)))
146 (:save-p :compute-only)
148 (let* ((check-unbound-label (gen-label))
149 (err-lab (generate-error-code vop 'unbound-symbol-error object))
150 (ret-lab (gen-label)))
151 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
152 (inst mov value (make-ea :qword :base thread-base-tn
153 :index value :scale 1))
154 (inst cmp value no-tls-value-marker-widetag)
155 (inst jmp :ne check-unbound-label)
156 (loadw value object symbol-value-slot other-pointer-lowtag)
157 (emit-label check-unbound-label)
158 (inst cmp value unbound-marker-widetag)
159 (inst jmp :e err-lab)
160 (emit-label ret-lab))))
163 (define-vop (fast-symbol-value symbol-value)
164 ;; KLUDGE: not really fast, in fact, because we're going to have to
165 ;; do a full lookup of the thread-local area anyway. But half of
166 ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
167 ;; unbound", which is used in the implementation of COPY-SYMBOL. --
170 (:translate symbol-value)
172 (let ((ret-lab (gen-label)))
173 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
175 (make-ea :qword :base thread-base-tn :index value :scale 1))
176 (inst cmp value no-tls-value-marker-widetag)
177 (inst jmp :ne ret-lab)
178 (loadw value object symbol-value-slot other-pointer-lowtag)
179 (emit-label ret-lab))))
182 (define-vop (symbol-value)
183 (:translate symbol-value)
185 (:args (object :scs (descriptor-reg) :to (:result 1)))
186 (:results (value :scs (descriptor-reg any-reg)))
188 (:save-p :compute-only)
190 (let ((err-lab (generate-error-code vop 'unbound-symbol-error object)))
191 (loadw value object symbol-value-slot other-pointer-lowtag)
192 (inst cmp value unbound-marker-widetag)
193 (inst jmp :e err-lab))))
196 (define-vop (fast-symbol-value cell-ref)
197 (:variant symbol-value-slot other-pointer-lowtag)
199 (:translate symbol-value))
201 (defknown locked-symbol-global-value-add (symbol fixnum) fixnum ())
203 (define-vop (locked-symbol-global-value-add)
204 (:args (object :scs (descriptor-reg) :to :result)
205 (value :scs (any-reg) :target result))
206 (:arg-types * tagged-num)
207 (:results (result :scs (any-reg) :from (:argument 1)))
209 (:translate locked-symbol-global-value-add)
210 (:result-types tagged-num)
214 (inst add (make-ea :qword :base object
215 :disp (- (* symbol-value-slot n-word-bytes)
216 other-pointer-lowtag))
223 (:args (object :scs (descriptor-reg)))
226 (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
228 (let ((check-unbound-label (gen-label)))
229 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
231 (make-ea :qword :base thread-base-tn :index value :scale 1))
232 (inst cmp value no-tls-value-marker-widetag)
233 (inst jmp :ne check-unbound-label)
234 (loadw value object symbol-value-slot other-pointer-lowtag)
235 (emit-label check-unbound-label)
236 (inst cmp value unbound-marker-widetag)
237 (inst jmp (if not-p :e :ne) target))))
243 (:args (object :scs (descriptor-reg)))
247 (inst cmp (make-ea-for-object-slot object symbol-value-slot
248 other-pointer-lowtag)
249 unbound-marker-widetag)
250 (inst jmp (if not-p :e :ne) target)))
253 (define-vop (symbol-hash)
255 (:translate symbol-hash)
256 (:args (symbol :scs (descriptor-reg)))
257 (:results (res :scs (any-reg)))
258 (:result-types positive-fixnum)
260 ;; The symbol-hash slot of NIL holds NIL because it is also the
261 ;; cdr slot, so we have to strip off the three low bits to make sure
262 ;; it is a fixnum. The lowtag selection magic that is required to
263 ;; ensure this is explained in the comment in objdef.lisp
264 (loadw res symbol symbol-hash-slot other-pointer-lowtag)
265 (inst and res (lognot #b111))))
267 ;;;; fdefinition (FDEFN) objects
269 (define-vop (fdefn-fun cell-ref) ; /pfw - alpha
270 (:variant fdefn-fun-slot other-pointer-lowtag))
272 (define-vop (safe-fdefn-fun)
273 (:args (object :scs (descriptor-reg) :to (:result 1)))
274 (:results (value :scs (descriptor-reg any-reg)))
276 (:save-p :compute-only)
278 (loadw value object fdefn-fun-slot other-pointer-lowtag)
279 (inst cmp value nil-value)
280 (let ((err-lab (generate-error-code vop 'undefined-fun-error object)))
281 (inst jmp :e err-lab))))
283 (define-vop (set-fdefn-fun)
285 (:translate (setf fdefn-fun))
286 (:args (function :scs (descriptor-reg) :target result)
287 (fdefn :scs (descriptor-reg)))
288 (:temporary (:sc unsigned-reg) raw)
289 (:temporary (:sc byte-reg) type)
290 (:results (result :scs (descriptor-reg)))
292 (load-type type function (- fun-pointer-lowtag))
294 (make-ea :byte :base function
295 :disp (- (* simple-fun-code-offset n-word-bytes)
296 fun-pointer-lowtag)))
297 (inst cmp type simple-fun-header-widetag)
298 (inst jmp :e NORMAL-FUN)
299 (inst lea raw (make-fixup "closure_tramp" :foreign))
301 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
302 (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
303 (move result function)))
305 (define-vop (fdefn-makunbound)
307 (:translate fdefn-makunbound)
308 (:args (fdefn :scs (descriptor-reg) :target result))
309 (:results (result :scs (descriptor-reg)))
311 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
312 (storew (make-fixup "undefined_tramp" :foreign)
313 fdefn fdefn-raw-addr-slot other-pointer-lowtag)
314 (move result fdefn)))
316 ;;;; binding and unbinding
318 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
319 ;;; the symbol on the binding stack and stuff the new value into the
324 (:args (val :scs (any-reg descriptor-reg))
325 (symbol :scs (descriptor-reg)))
326 (:temporary (:sc unsigned-reg) tls-index bsp)
328 (let ((tls-index-valid (gen-label)))
329 (load-binding-stack-pointer bsp)
330 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
331 (inst add bsp (* binding-size n-word-bytes))
332 (store-binding-stack-pointer bsp)
333 (inst or tls-index tls-index)
334 (inst jmp :ne tls-index-valid)
335 (inst mov tls-index symbol)
336 (inst lea temp-reg-tn
337 (make-ea :qword :disp
338 (make-fixup (ecase (tn-offset tls-index)
339 (#.rax-offset 'alloc-tls-index-in-rax)
340 (#.rcx-offset 'alloc-tls-index-in-rcx)
341 (#.rdx-offset 'alloc-tls-index-in-rdx)
342 (#.rbx-offset 'alloc-tls-index-in-rbx)
343 (#.rsi-offset 'alloc-tls-index-in-rsi)
344 (#.rdi-offset 'alloc-tls-index-in-rdi)
345 (#.r8-offset 'alloc-tls-index-in-r8)
346 (#.r9-offset 'alloc-tls-index-in-r9)
347 (#.r10-offset 'alloc-tls-index-in-r10)
348 (#.r12-offset 'alloc-tls-index-in-r12)
349 (#.r13-offset 'alloc-tls-index-in-r13)
350 (#.r14-offset 'alloc-tls-index-in-r14)
351 (#.r15-offset 'alloc-tls-index-in-r15))
353 (inst call temp-reg-tn)
354 (emit-label tls-index-valid)
355 (inst push (make-ea :qword :base thread-base-tn :scale 1 :index tls-index))
356 (popw bsp (- binding-value-slot binding-size))
357 (storew symbol bsp (- binding-symbol-slot binding-size))
358 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
363 (:args (val :scs (any-reg descriptor-reg))
364 (symbol :scs (descriptor-reg)))
365 (:temporary (:sc unsigned-reg) temp bsp)
367 (load-symbol-value bsp *binding-stack-pointer*)
368 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
369 (inst add bsp (* binding-size n-word-bytes))
370 (store-symbol-value bsp *binding-stack-pointer*)
371 (storew temp bsp (- binding-value-slot binding-size))
372 (storew symbol bsp (- binding-symbol-slot binding-size))
373 (storew val symbol symbol-value-slot other-pointer-lowtag)))
377 (:temporary (:sc unsigned-reg) temp bsp tls-index)
379 (load-binding-stack-pointer bsp)
380 ;; Load SYMBOL from stack, and get the TLS-INDEX
381 (loadw temp bsp (- binding-symbol-slot binding-size))
382 (loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag)
383 ;; Load VALUE from stack, the restore it to the TLS area.
384 (loadw temp bsp (- binding-value-slot binding-size))
385 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
387 ;; Zero out the stack.
388 (storew 0 bsp (- binding-symbol-slot binding-size))
389 (storew 0 bsp (- binding-value-slot binding-size))
390 (inst sub bsp (* binding-size n-word-bytes))
391 (store-binding-stack-pointer bsp)))
395 (:temporary (:sc unsigned-reg) symbol value bsp)
397 (load-symbol-value bsp *binding-stack-pointer*)
398 (loadw symbol bsp (- binding-symbol-slot binding-size))
399 (loadw value bsp (- binding-value-slot binding-size))
400 (storew value symbol symbol-value-slot other-pointer-lowtag)
401 (storew 0 bsp (- binding-symbol-slot binding-size))
402 (storew 0 bsp (- binding-value-slot binding-size))
403 (inst sub bsp (* binding-size n-word-bytes))
404 (store-symbol-value bsp *binding-stack-pointer*)))
406 (define-vop (unbind-to-here)
407 (:args (where :scs (descriptor-reg any-reg)))
408 (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index)
410 (load-binding-stack-pointer bsp)
415 (loadw symbol bsp (- binding-symbol-slot binding-size))
416 (inst or symbol symbol)
418 ;; Bind stack debug sentinels have the unbound marker in the symbol slot
419 (inst cmp symbol unbound-marker-widetag)
421 (loadw value bsp (- binding-value-slot binding-size))
423 (storew value symbol symbol-value-slot other-pointer-lowtag)
425 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
427 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
429 (storew 0 bsp (- binding-symbol-slot binding-size))
432 (storew 0 bsp (- binding-value-slot binding-size))
433 (inst sub bsp (* binding-size n-word-bytes))
436 (store-binding-stack-pointer bsp)
440 (define-vop (bind-sentinel)
441 (:temporary (:sc unsigned-reg) bsp)
443 (load-binding-stack-pointer bsp)
444 (inst add bsp (* binding-size n-word-bytes))
445 (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
446 (storew rbp-tn bsp (- binding-value-slot binding-size))
447 (store-binding-stack-pointer bsp)))
449 (define-vop (unbind-sentinel)
450 (:temporary (:sc unsigned-reg) bsp)
452 (load-binding-stack-pointer bsp)
453 (storew 0 bsp (- binding-value-slot binding-size))
454 (storew 0 bsp (- binding-symbol-slot binding-size))
455 (inst sub bsp (* binding-size n-word-bytes))
456 (store-binding-stack-pointer bsp)))
461 ;;;; closure indexing
463 (define-full-reffer closure-index-ref *
464 closure-info-offset fun-pointer-lowtag
465 (any-reg descriptor-reg) * %closure-index-ref)
467 (define-full-setter set-funcallable-instance-info *
468 funcallable-instance-info-offset fun-pointer-lowtag
469 (any-reg descriptor-reg) * %set-funcallable-instance-info)
471 (define-full-reffer funcallable-instance-info *
472 funcallable-instance-info-offset fun-pointer-lowtag
473 (descriptor-reg any-reg) * %funcallable-instance-info)
475 (define-vop (closure-ref slot-ref)
476 (:variant closure-info-offset fun-pointer-lowtag))
478 (define-vop (closure-init slot-set)
479 (:variant closure-info-offset fun-pointer-lowtag))
481 ;;;; value cell hackery
483 (define-vop (value-cell-ref cell-ref)
484 (:variant value-cell-value-slot other-pointer-lowtag))
486 (define-vop (value-cell-set cell-set)
487 (:variant value-cell-value-slot other-pointer-lowtag))
489 ;;;; structure hackery
491 (define-vop (instance-length)
493 (:translate %instance-length)
494 (:args (struct :scs (descriptor-reg)))
495 (:results (res :scs (unsigned-reg)))
496 (:result-types positive-fixnum)
498 (loadw res struct 0 instance-pointer-lowtag)
499 (inst shr res n-widetag-bits)))
501 (define-full-reffer instance-index-ref * instance-slots-offset
502 instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
504 (define-full-setter instance-index-set * instance-slots-offset
505 instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
507 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
508 instance-slots-offset instance-pointer-lowtag
509 (any-reg descriptor-reg) *
510 %compare-and-swap-instance-ref)
512 ;;;; code object frobbing
514 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
515 (any-reg descriptor-reg) * code-header-ref)
517 (define-full-setter code-header-set * 0 other-pointer-lowtag
518 (any-reg descriptor-reg) * code-header-set)
520 ;;;; raw instance slot accessors
522 (defun make-ea-for-raw-slot (object index instance-length
523 &optional (adjustment 0))
524 (if (integerp instance-length)
525 ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
529 :disp (+ (* (- instance-length instance-slots-offset index)
531 (- instance-pointer-lowtag)
535 (make-ea :qword :base object :index instance-length
536 :disp (+ (* (1- instance-slots-offset) n-word-bytes)
537 (- instance-pointer-lowtag)
540 (make-ea :qword :base object :index instance-length
542 :disp (+ (* (1- instance-slots-offset) n-word-bytes)
543 (- instance-pointer-lowtag)
545 (* index (- n-word-bytes))))))))
547 (define-vop (raw-instance-ref/word)
548 (:translate %raw-instance-ref/word)
550 (:args (object :scs (descriptor-reg)) (index :scs (any-reg)))
551 (:arg-types * tagged-num)
552 (:temporary (:sc unsigned-reg) tmp)
553 (:results (value :scs (unsigned-reg)))
554 (:result-types unsigned-num)
556 (loadw tmp object 0 instance-pointer-lowtag)
557 (inst shr tmp n-widetag-bits)
560 (inst mov value (make-ea-for-raw-slot object index tmp))))
562 (define-vop (raw-instance-ref-c/word)
563 (:translate %raw-instance-ref/word)
565 (:args (object :scs (descriptor-reg)))
566 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
567 #.instance-pointer-lowtag
568 #.instance-slots-offset)))
570 (:temporary (:sc unsigned-reg) tmp)
571 (:results (value :scs (unsigned-reg)))
572 (:result-types unsigned-num)
574 (loadw tmp object 0 instance-pointer-lowtag)
575 (inst shr tmp n-widetag-bits)
576 (inst mov value (make-ea-for-raw-slot object index tmp))))
578 (define-vop (raw-instance-set/word)
579 (:translate %raw-instance-set/word)
581 (:args (object :scs (descriptor-reg))
582 (index :scs (any-reg))
583 (value :scs (unsigned-reg) :target result))
584 (:arg-types * tagged-num unsigned-num)
585 (:temporary (:sc unsigned-reg) tmp)
586 (:results (result :scs (unsigned-reg)))
587 (:result-types unsigned-num)
589 (loadw tmp object 0 instance-pointer-lowtag)
590 (inst shr tmp n-widetag-bits)
593 (inst mov (make-ea-for-raw-slot object index tmp) value)
594 (move result value)))
596 (define-vop (raw-instance-set-c/word)
597 (:translate %raw-instance-set/word)
599 (:args (object :scs (descriptor-reg))
600 (value :scs (unsigned-reg) :target result))
601 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
602 #.instance-pointer-lowtag
603 #.instance-slots-offset))
606 (:temporary (:sc unsigned-reg) tmp)
607 (:results (result :scs (unsigned-reg)))
608 (:result-types unsigned-num)
610 (loadw tmp object 0 instance-pointer-lowtag)
611 (inst shr tmp n-widetag-bits)
612 (inst mov (make-ea-for-raw-slot object index tmp) value)
613 (move result value)))
615 (define-vop (raw-instance-init/word)
616 (:args (object :scs (descriptor-reg))
617 (value :scs (unsigned-reg)))
618 (:arg-types * unsigned-num)
619 (:info instance-length index)
621 (inst mov (make-ea-for-raw-slot object index instance-length) value)))
623 (define-vop (raw-instance-atomic-incf-c/word)
624 (:translate %raw-instance-atomic-incf/word)
626 (:args (object :scs (descriptor-reg))
627 (diff :scs (signed-reg) :target result))
628 (:arg-types * (:constant (load/store-index #.n-word-bytes
629 #.instance-pointer-lowtag
630 #.instance-slots-offset))
633 (:temporary (:sc unsigned-reg) tmp)
634 (:results (result :scs (unsigned-reg)))
635 (:result-types unsigned-num)
637 (loadw tmp object 0 instance-pointer-lowtag)
638 (inst shr tmp n-widetag-bits)
639 (inst xadd (make-ea-for-raw-slot object index tmp) diff :lock)
642 (define-vop (raw-instance-ref/single)
643 (:translate %raw-instance-ref/single)
645 (:args (object :scs (descriptor-reg))
646 (index :scs (any-reg)))
647 (:arg-types * positive-fixnum)
648 (:temporary (:sc unsigned-reg) tmp)
649 (:results (value :scs (single-reg)))
650 (:result-types single-float)
652 (loadw tmp object 0 instance-pointer-lowtag)
653 (inst shr tmp n-widetag-bits)
656 (inst movss value (make-ea-for-raw-slot object index tmp))))
658 (define-vop (raw-instance-ref-c/single)
659 (:translate %raw-instance-ref/single)
661 (:args (object :scs (descriptor-reg)))
662 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
663 #.instance-pointer-lowtag
664 #.instance-slots-offset)))
666 (:temporary (:sc unsigned-reg) tmp)
667 (:results (value :scs (single-reg)))
668 (:result-types single-float)
670 (loadw tmp object 0 instance-pointer-lowtag)
671 (inst shr tmp n-widetag-bits)
672 (inst movss value (make-ea-for-raw-slot object index tmp))))
674 (define-vop (raw-instance-set/single)
675 (:translate %raw-instance-set/single)
677 (:args (object :scs (descriptor-reg))
678 (index :scs (any-reg))
679 (value :scs (single-reg) :target result))
680 (:arg-types * positive-fixnum single-float)
681 (:temporary (:sc unsigned-reg) tmp)
682 (:results (result :scs (single-reg)))
683 (:result-types single-float)
685 (loadw tmp object 0 instance-pointer-lowtag)
686 (inst shr tmp n-widetag-bits)
689 (inst movss (make-ea-for-raw-slot object index tmp) value)
690 (unless (location= result value)
691 (inst movss result value))))
693 (define-vop (raw-instance-set-c/single)
694 (:translate %raw-instance-set/single)
696 (:args (object :scs (descriptor-reg))
697 (value :scs (single-reg) :target result))
698 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
699 #.instance-pointer-lowtag
700 #.instance-slots-offset))
703 (:temporary (:sc unsigned-reg) tmp)
704 (:results (result :scs (single-reg)))
705 (:result-types single-float)
707 (loadw tmp object 0 instance-pointer-lowtag)
708 (inst shr tmp n-widetag-bits)
709 (inst movss (make-ea-for-raw-slot object index tmp) value)
710 (unless (location= result value)
711 (inst movss result value))))
713 (define-vop (raw-instance-init/single)
714 (:args (object :scs (descriptor-reg))
715 (value :scs (single-reg)))
716 (:arg-types * single-float)
717 (:info instance-length index)
719 (inst movss (make-ea-for-raw-slot object index instance-length) value)))
721 (define-vop (raw-instance-ref/double)
722 (:translate %raw-instance-ref/double)
724 (:args (object :scs (descriptor-reg))
725 (index :scs (any-reg)))
726 (:arg-types * positive-fixnum)
727 (:temporary (:sc unsigned-reg) tmp)
728 (:results (value :scs (double-reg)))
729 (:result-types double-float)
731 (loadw tmp object 0 instance-pointer-lowtag)
732 (inst shr tmp n-widetag-bits)
735 (inst movsd value (make-ea-for-raw-slot object index tmp))))
737 (define-vop (raw-instance-ref-c/double)
738 (:translate %raw-instance-ref/double)
740 (:args (object :scs (descriptor-reg)))
741 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
742 #.instance-pointer-lowtag
743 #.instance-slots-offset)))
745 (:temporary (:sc unsigned-reg) tmp)
746 (:results (value :scs (double-reg)))
747 (:result-types double-float)
749 (loadw tmp object 0 instance-pointer-lowtag)
750 (inst shr tmp n-widetag-bits)
751 (inst movsd value (make-ea-for-raw-slot object index tmp))))
753 (define-vop (raw-instance-set/double)
754 (:translate %raw-instance-set/double)
756 (:args (object :scs (descriptor-reg))
757 (index :scs (any-reg))
758 (value :scs (double-reg) :target result))
759 (:arg-types * positive-fixnum double-float)
760 (:temporary (:sc unsigned-reg) tmp)
761 (:results (result :scs (double-reg)))
762 (:result-types double-float)
764 (loadw tmp object 0 instance-pointer-lowtag)
765 (inst shr tmp n-widetag-bits)
768 (inst movsd (make-ea-for-raw-slot object index tmp) value)
769 (unless (location= result value)
770 (inst movsd result value))))
772 (define-vop (raw-instance-set-c/double)
773 (:translate %raw-instance-set/double)
775 (:args (object :scs (descriptor-reg))
776 (value :scs (double-reg) :target result))
777 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
778 #.instance-pointer-lowtag
779 #.instance-slots-offset))
782 (:temporary (:sc unsigned-reg) tmp)
783 (:results (result :scs (double-reg)))
784 (:result-types double-float)
786 (loadw tmp object 0 instance-pointer-lowtag)
787 (inst shr tmp n-widetag-bits)
788 (inst movsd (make-ea-for-raw-slot object index tmp) value)
789 (unless (location= result value)
790 (inst movsd result value))))
792 (define-vop (raw-instance-init/double)
793 (:args (object :scs (descriptor-reg))
794 (value :scs (double-reg)))
795 (:arg-types * double-float)
796 (:info instance-length index)
798 (inst movsd (make-ea-for-raw-slot object index instance-length) value)))
800 (define-vop (raw-instance-ref/complex-single)
801 (:translate %raw-instance-ref/complex-single)
803 (:args (object :scs (descriptor-reg))
804 (index :scs (any-reg)))
805 (:arg-types * positive-fixnum)
806 (:temporary (:sc unsigned-reg) tmp)
807 (:results (value :scs (complex-single-reg)))
808 (:result-types complex-single-float)
810 (loadw tmp object 0 instance-pointer-lowtag)
811 (inst shr tmp n-widetag-bits)
814 (let ((real-tn (complex-single-reg-real-tn value)))
815 (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
816 (let ((imag-tn (complex-single-reg-imag-tn value)))
817 (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
819 (define-vop (raw-instance-ref-c/complex-single)
820 (:translate %raw-instance-ref/complex-single)
822 (:args (object :scs (descriptor-reg)))
823 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
824 #.instance-pointer-lowtag
825 #.instance-slots-offset)))
827 (:temporary (:sc unsigned-reg) tmp)
828 (:results (value :scs (complex-single-reg)))
829 (:result-types complex-single-float)
831 (loadw tmp object 0 instance-pointer-lowtag)
832 (inst shr tmp n-widetag-bits)
833 (let ((real-tn (complex-single-reg-real-tn value)))
834 (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
835 (let ((imag-tn (complex-single-reg-imag-tn value)))
836 (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
838 (define-vop (raw-instance-set/complex-single)
839 (:translate %raw-instance-set/complex-single)
841 (:args (object :scs (descriptor-reg))
842 (index :scs (any-reg))
843 (value :scs (complex-single-reg) :target result))
844 (:arg-types * positive-fixnum complex-single-float)
845 (:temporary (:sc unsigned-reg) tmp)
846 (:results (result :scs (complex-single-reg)))
847 (:result-types complex-single-float)
849 (loadw tmp object 0 instance-pointer-lowtag)
850 (inst shr tmp n-widetag-bits)
853 (let ((value-real (complex-single-reg-real-tn value))
854 (result-real (complex-single-reg-real-tn result)))
855 (inst movss (make-ea-for-raw-slot object index tmp) value-real)
856 (unless (location= value-real result-real)
857 (inst movss result-real value-real)))
858 (let ((value-imag (complex-single-reg-imag-tn value))
859 (result-imag (complex-single-reg-imag-tn result)))
860 (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
861 (unless (location= value-imag result-imag)
862 (inst movss result-imag value-imag)))))
864 (define-vop (raw-instance-set-c/complex-single)
865 (:translate %raw-instance-set/complex-single)
867 (:args (object :scs (descriptor-reg))
868 (value :scs (complex-single-reg) :target result))
869 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
870 #.instance-pointer-lowtag
871 #.instance-slots-offset))
872 complex-single-float)
874 (:temporary (:sc unsigned-reg) tmp)
875 (:results (result :scs (complex-single-reg)))
876 (:result-types complex-single-float)
878 (loadw tmp object 0 instance-pointer-lowtag)
879 (inst shr tmp n-widetag-bits)
880 (let ((value-real (complex-single-reg-real-tn value))
881 (result-real (complex-single-reg-real-tn result)))
882 (inst movss (make-ea-for-raw-slot object index tmp) value-real)
883 (unless (location= value-real result-real)
884 (inst movss result-real value-real)))
885 (let ((value-imag (complex-single-reg-imag-tn value))
886 (result-imag (complex-single-reg-imag-tn result)))
887 (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
888 (unless (location= value-imag result-imag)
889 (inst movss result-imag value-imag)))))
891 (define-vop (raw-instance-init/complex-single)
892 (:args (object :scs (descriptor-reg))
893 (value :scs (complex-single-reg)))
894 (:arg-types * complex-single-float)
895 (:info instance-length index)
897 (let ((value-real (complex-single-reg-real-tn value)))
898 (inst movss (make-ea-for-raw-slot object index instance-length) value-real))
899 (let ((value-imag (complex-single-reg-imag-tn value)))
900 (inst movss (make-ea-for-raw-slot object index instance-length 4) value-imag))))
902 (define-vop (raw-instance-ref/complex-double)
903 (:translate %raw-instance-ref/complex-double)
905 (:args (object :scs (descriptor-reg))
906 (index :scs (any-reg)))
907 (:arg-types * positive-fixnum)
908 (:temporary (:sc unsigned-reg) tmp)
909 (:results (value :scs (complex-double-reg)))
910 (:result-types complex-double-float)
912 (loadw tmp object 0 instance-pointer-lowtag)
913 (inst shr tmp n-widetag-bits)
916 (let ((real-tn (complex-double-reg-real-tn value)))
917 (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
918 (let ((imag-tn (complex-double-reg-imag-tn value)))
919 (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
921 (define-vop (raw-instance-ref-c/complex-double)
922 (:translate %raw-instance-ref/complex-double)
924 (:args (object :scs (descriptor-reg)))
925 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
926 #.instance-pointer-lowtag
927 #.instance-slots-offset)))
929 (:temporary (:sc unsigned-reg) tmp)
930 (:results (value :scs (complex-double-reg)))
931 (:result-types complex-double-float)
933 (loadw tmp object 0 instance-pointer-lowtag)
934 (inst shr tmp n-widetag-bits)
935 (let ((real-tn (complex-double-reg-real-tn value)))
936 (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
937 (let ((imag-tn (complex-double-reg-imag-tn value)))
938 (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
940 (define-vop (raw-instance-set/complex-double)
941 (:translate %raw-instance-set/complex-double)
943 (:args (object :scs (descriptor-reg))
944 (index :scs (any-reg))
945 (value :scs (complex-double-reg) :target result))
946 (:arg-types * positive-fixnum complex-double-float)
947 (:temporary (:sc unsigned-reg) tmp)
948 (:results (result :scs (complex-double-reg)))
949 (:result-types complex-double-float)
951 (loadw tmp object 0 instance-pointer-lowtag)
952 (inst shr tmp n-widetag-bits)
955 (let ((value-real (complex-double-reg-real-tn value))
956 (result-real (complex-double-reg-real-tn result)))
957 (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
958 (unless (location= value-real result-real)
959 (inst movsd result-real value-real)))
960 (let ((value-imag (complex-double-reg-imag-tn value))
961 (result-imag (complex-double-reg-imag-tn result)))
962 (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
963 (unless (location= value-imag result-imag)
964 (inst movsd result-imag value-imag)))))
966 (define-vop (raw-instance-set-c/complex-double)
967 (:translate %raw-instance-set/complex-double)
969 (:args (object :scs (descriptor-reg))
970 (value :scs (complex-double-reg) :target result))
971 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
972 #.instance-pointer-lowtag
973 #.instance-slots-offset))
974 complex-double-float)
976 (:temporary (:sc unsigned-reg) tmp)
977 (:results (result :scs (complex-double-reg)))
978 (:result-types complex-double-float)
980 (loadw tmp object 0 instance-pointer-lowtag)
981 (inst shr tmp n-widetag-bits)
982 (let ((value-real (complex-double-reg-real-tn value))
983 (result-real (complex-double-reg-real-tn result)))
984 (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
985 (unless (location= value-real result-real)
986 (inst movsd result-real value-real)))
987 (let ((value-imag (complex-double-reg-imag-tn value))
988 (result-imag (complex-double-reg-imag-tn result)))
989 (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
990 (unless (location= value-imag result-imag)
991 (inst movsd result-imag value-imag)))))
993 (define-vop (raw-instance-init/complex-double)
994 (:args (object :scs (descriptor-reg))
995 (value :scs (complex-double-reg)))
996 (:arg-types * complex-double-float)
997 (:info instance-length index)
999 (let ((value-real (complex-double-reg-real-tn value)))
1000 (inst movsd (make-ea-for-raw-slot object index instance-length -8) value-real))
1001 (let ((value-imag (complex-double-reg-imag-tn value)))
1002 (inst movsd (make-ea-for-raw-slot object index instance-length) value-imag))))