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))
528 (if (integerp instance-length)
529 ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
533 :disp (+ (* (- instance-length instance-slots-offset index)
535 (- instance-pointer-lowtag)
539 (make-ea :qword :base object :index instance-length
540 :disp (+ (* (1- instance-slots-offset) n-word-bytes)
541 (- instance-pointer-lowtag)
544 (make-ea :qword :base object :index instance-length
546 :disp (+ (* (1- instance-slots-offset) n-word-bytes)
547 (- instance-pointer-lowtag)
549 (* index (- n-word-bytes))))))))
551 (define-vop (raw-instance-ref/word)
552 (:translate %raw-instance-ref/word)
554 (:args (object :scs (descriptor-reg)) (index :scs (any-reg)))
555 (:arg-types * tagged-num)
556 (:temporary (:sc unsigned-reg) tmp)
557 (:results (value :scs (unsigned-reg)))
558 (:result-types unsigned-num)
560 (loadw tmp object 0 instance-pointer-lowtag)
561 (inst shr tmp n-widetag-bits)
564 (inst mov value (make-ea-for-raw-slot object index tmp))))
566 (define-vop (raw-instance-ref-c/word)
567 (:translate %raw-instance-ref/word)
569 (:args (object :scs (descriptor-reg)))
570 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
571 #.instance-pointer-lowtag
572 #.instance-slots-offset)))
574 (:temporary (:sc unsigned-reg) tmp)
575 (:results (value :scs (unsigned-reg)))
576 (:result-types unsigned-num)
578 (loadw tmp object 0 instance-pointer-lowtag)
579 (inst shr tmp n-widetag-bits)
580 (inst mov value (make-ea-for-raw-slot object index tmp))))
582 (define-vop (raw-instance-set/word)
583 (:translate %raw-instance-set/word)
585 (:args (object :scs (descriptor-reg))
586 (index :scs (any-reg))
587 (value :scs (unsigned-reg) :target result))
588 (:arg-types * tagged-num unsigned-num)
589 (:temporary (:sc unsigned-reg) tmp)
590 (:results (result :scs (unsigned-reg)))
591 (:result-types unsigned-num)
593 (loadw tmp object 0 instance-pointer-lowtag)
594 (inst shr tmp n-widetag-bits)
597 (inst mov (make-ea-for-raw-slot object index tmp) value)
598 (move result value)))
600 (define-vop (raw-instance-set-c/word)
601 (:translate %raw-instance-set/word)
603 (:args (object :scs (descriptor-reg))
604 (value :scs (unsigned-reg) :target result))
605 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
606 #.instance-pointer-lowtag
607 #.instance-slots-offset))
610 (:temporary (:sc unsigned-reg) tmp)
611 (:results (result :scs (unsigned-reg)))
612 (:result-types unsigned-num)
614 (loadw tmp object 0 instance-pointer-lowtag)
615 (inst shr tmp n-widetag-bits)
616 (inst mov (make-ea-for-raw-slot object index tmp) value)
617 (move result value)))
619 (define-vop (raw-instance-init/word)
620 (:args (object :scs (descriptor-reg))
621 (value :scs (unsigned-reg)))
622 (:arg-types * unsigned-num)
623 (:info instance-length index)
625 (inst mov (make-ea-for-raw-slot object index instance-length) value)))
627 (define-vop (raw-instance-ref/single)
628 (:translate %raw-instance-ref/single)
630 (:args (object :scs (descriptor-reg))
631 (index :scs (any-reg)))
632 (:arg-types * positive-fixnum)
633 (:temporary (:sc unsigned-reg) tmp)
634 (:results (value :scs (single-reg)))
635 (:result-types single-float)
637 (loadw tmp object 0 instance-pointer-lowtag)
638 (inst shr tmp n-widetag-bits)
641 (inst movss value (make-ea-for-raw-slot object index tmp))))
643 (define-vop (raw-instance-ref-c/single)
644 (:translate %raw-instance-ref/single)
646 (:args (object :scs (descriptor-reg)))
647 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
648 #.instance-pointer-lowtag
649 #.instance-slots-offset)))
651 (:temporary (:sc unsigned-reg) tmp)
652 (:results (value :scs (single-reg)))
653 (:result-types single-float)
655 (loadw tmp object 0 instance-pointer-lowtag)
656 (inst shr tmp n-widetag-bits)
657 (inst movss value (make-ea-for-raw-slot object index tmp))))
659 (define-vop (raw-instance-set/single)
660 (:translate %raw-instance-set/single)
662 (:args (object :scs (descriptor-reg))
663 (index :scs (any-reg))
664 (value :scs (single-reg) :target result))
665 (:arg-types * positive-fixnum single-float)
666 (:temporary (:sc unsigned-reg) tmp)
667 (:results (result :scs (single-reg)))
668 (:result-types single-float)
670 (loadw tmp object 0 instance-pointer-lowtag)
671 (inst shr tmp n-widetag-bits)
674 (inst movss (make-ea-for-raw-slot object index tmp) value)
675 (unless (location= result value)
676 (inst movss result value))))
678 (define-vop (raw-instance-set-c/single)
679 (:translate %raw-instance-set/single)
681 (:args (object :scs (descriptor-reg))
682 (value :scs (single-reg) :target result))
683 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
684 #.instance-pointer-lowtag
685 #.instance-slots-offset))
688 (:temporary (:sc unsigned-reg) tmp)
689 (:results (result :scs (single-reg)))
690 (:result-types single-float)
692 (loadw tmp object 0 instance-pointer-lowtag)
693 (inst shr tmp n-widetag-bits)
694 (inst movss (make-ea-for-raw-slot object index tmp) value)
695 (unless (location= result value)
696 (inst movss result value))))
698 (define-vop (raw-instance-init/single)
699 (:args (object :scs (descriptor-reg))
700 (value :scs (single-reg)))
701 (:arg-types * single-float)
702 (:info instance-length index)
704 (inst movss (make-ea-for-raw-slot object index instance-length) value)))
706 (define-vop (raw-instance-ref/double)
707 (:translate %raw-instance-ref/double)
709 (:args (object :scs (descriptor-reg))
710 (index :scs (any-reg)))
711 (:arg-types * positive-fixnum)
712 (:temporary (:sc unsigned-reg) tmp)
713 (:results (value :scs (double-reg)))
714 (:result-types double-float)
716 (loadw tmp object 0 instance-pointer-lowtag)
717 (inst shr tmp n-widetag-bits)
720 (inst movsd value (make-ea-for-raw-slot object index tmp))))
722 (define-vop (raw-instance-ref-c/double)
723 (:translate %raw-instance-ref/double)
725 (:args (object :scs (descriptor-reg)))
726 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
727 #.instance-pointer-lowtag
728 #.instance-slots-offset)))
730 (:temporary (:sc unsigned-reg) tmp)
731 (:results (value :scs (double-reg)))
732 (:result-types double-float)
734 (loadw tmp object 0 instance-pointer-lowtag)
735 (inst shr tmp n-widetag-bits)
736 (inst movsd value (make-ea-for-raw-slot object index tmp))))
738 (define-vop (raw-instance-set/double)
739 (:translate %raw-instance-set/double)
741 (:args (object :scs (descriptor-reg))
742 (index :scs (any-reg))
743 (value :scs (double-reg) :target result))
744 (:arg-types * positive-fixnum double-float)
745 (:temporary (:sc unsigned-reg) tmp)
746 (:results (result :scs (double-reg)))
747 (:result-types double-float)
749 (loadw tmp object 0 instance-pointer-lowtag)
750 (inst shr tmp n-widetag-bits)
753 (inst movsd (make-ea-for-raw-slot object index tmp) value)
754 (unless (location= result value)
755 (inst movsd result value))))
757 (define-vop (raw-instance-set-c/double)
758 (:translate %raw-instance-set/double)
760 (:args (object :scs (descriptor-reg))
761 (value :scs (double-reg) :target result))
762 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
763 #.instance-pointer-lowtag
764 #.instance-slots-offset))
767 (:temporary (:sc unsigned-reg) tmp)
768 (:results (result :scs (double-reg)))
769 (:result-types double-float)
771 (loadw tmp object 0 instance-pointer-lowtag)
772 (inst shr tmp n-widetag-bits)
773 (inst movsd (make-ea-for-raw-slot object index tmp) value)
774 (unless (location= result value)
775 (inst movsd result value))))
777 (define-vop (raw-instance-init/double)
778 (:args (object :scs (descriptor-reg))
779 (value :scs (double-reg)))
780 (:arg-types * double-float)
781 (:info instance-length index)
783 (inst movsd (make-ea-for-raw-slot object index instance-length) value)))
785 (define-vop (raw-instance-ref/complex-single)
786 (:translate %raw-instance-ref/complex-single)
788 (:args (object :scs (descriptor-reg))
789 (index :scs (any-reg)))
790 (:arg-types * positive-fixnum)
791 (:temporary (:sc unsigned-reg) tmp)
792 (:results (value :scs (complex-single-reg)))
793 (:result-types complex-single-float)
795 (loadw tmp object 0 instance-pointer-lowtag)
796 (inst shr tmp n-widetag-bits)
799 (let ((real-tn (complex-single-reg-real-tn value)))
800 (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
801 (let ((imag-tn (complex-single-reg-imag-tn value)))
802 (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
804 (define-vop (raw-instance-ref-c/complex-single)
805 (:translate %raw-instance-ref/complex-single)
807 (:args (object :scs (descriptor-reg)))
808 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
809 #.instance-pointer-lowtag
810 #.instance-slots-offset)))
812 (:temporary (:sc unsigned-reg) tmp)
813 (:results (value :scs (complex-single-reg)))
814 (:result-types complex-single-float)
816 (loadw tmp object 0 instance-pointer-lowtag)
817 (inst shr tmp n-widetag-bits)
818 (let ((real-tn (complex-single-reg-real-tn value)))
819 (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
820 (let ((imag-tn (complex-single-reg-imag-tn value)))
821 (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
823 (define-vop (raw-instance-set/complex-single)
824 (:translate %raw-instance-set/complex-single)
826 (:args (object :scs (descriptor-reg))
827 (index :scs (any-reg))
828 (value :scs (complex-single-reg) :target result))
829 (:arg-types * positive-fixnum complex-single-float)
830 (:temporary (:sc unsigned-reg) tmp)
831 (:results (result :scs (complex-single-reg)))
832 (:result-types complex-single-float)
834 (loadw tmp object 0 instance-pointer-lowtag)
835 (inst shr tmp n-widetag-bits)
838 (let ((value-real (complex-single-reg-real-tn value))
839 (result-real (complex-single-reg-real-tn result)))
840 (inst movss (make-ea-for-raw-slot object index tmp) value-real)
841 (unless (location= value-real result-real)
842 (inst movss result-real value-real)))
843 (let ((value-imag (complex-single-reg-imag-tn value))
844 (result-imag (complex-single-reg-imag-tn result)))
845 (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
846 (unless (location= value-imag result-imag)
847 (inst movss result-imag value-imag)))))
849 (define-vop (raw-instance-set-c/complex-single)
850 (:translate %raw-instance-set/complex-single)
852 (:args (object :scs (descriptor-reg))
853 (value :scs (complex-single-reg) :target result))
854 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
855 #.instance-pointer-lowtag
856 #.instance-slots-offset))
857 complex-single-float)
859 (:temporary (:sc unsigned-reg) tmp)
860 (:results (result :scs (complex-single-reg)))
861 (:result-types complex-single-float)
863 (loadw tmp object 0 instance-pointer-lowtag)
864 (inst shr tmp n-widetag-bits)
865 (let ((value-real (complex-single-reg-real-tn value))
866 (result-real (complex-single-reg-real-tn result)))
867 (inst movss (make-ea-for-raw-slot object index tmp) value-real)
868 (unless (location= value-real result-real)
869 (inst movss result-real value-real)))
870 (let ((value-imag (complex-single-reg-imag-tn value))
871 (result-imag (complex-single-reg-imag-tn result)))
872 (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
873 (unless (location= value-imag result-imag)
874 (inst movss result-imag value-imag)))))
876 (define-vop (raw-instance-init/complex-single)
877 (:args (object :scs (descriptor-reg))
878 (value :scs (complex-single-reg)))
879 (:arg-types * complex-single-float)
880 (:info instance-length index)
882 (let ((value-real (complex-single-reg-real-tn value)))
883 (inst movss (make-ea-for-raw-slot object index instance-length) value-real))
884 (let ((value-imag (complex-single-reg-imag-tn value)))
885 (inst movss (make-ea-for-raw-slot object index instance-length 4) value-imag))))
887 (define-vop (raw-instance-ref/complex-double)
888 (:translate %raw-instance-ref/complex-double)
890 (:args (object :scs (descriptor-reg))
891 (index :scs (any-reg)))
892 (:arg-types * positive-fixnum)
893 (:temporary (:sc unsigned-reg) tmp)
894 (:results (value :scs (complex-double-reg)))
895 (:result-types complex-double-float)
897 (loadw tmp object 0 instance-pointer-lowtag)
898 (inst shr tmp n-widetag-bits)
901 (let ((real-tn (complex-double-reg-real-tn value)))
902 (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
903 (let ((imag-tn (complex-double-reg-imag-tn value)))
904 (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
906 (define-vop (raw-instance-ref-c/complex-double)
907 (:translate %raw-instance-ref/complex-double)
909 (:args (object :scs (descriptor-reg)))
910 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
911 #.instance-pointer-lowtag
912 #.instance-slots-offset)))
914 (:temporary (:sc unsigned-reg) tmp)
915 (:results (value :scs (complex-double-reg)))
916 (:result-types complex-double-float)
918 (loadw tmp object 0 instance-pointer-lowtag)
919 (inst shr tmp n-widetag-bits)
920 (let ((real-tn (complex-double-reg-real-tn value)))
921 (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
922 (let ((imag-tn (complex-double-reg-imag-tn value)))
923 (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
925 (define-vop (raw-instance-set/complex-double)
926 (:translate %raw-instance-set/complex-double)
928 (:args (object :scs (descriptor-reg))
929 (index :scs (any-reg))
930 (value :scs (complex-double-reg) :target result))
931 (:arg-types * positive-fixnum complex-double-float)
932 (:temporary (:sc unsigned-reg) tmp)
933 (:results (result :scs (complex-double-reg)))
934 (:result-types complex-double-float)
936 (loadw tmp object 0 instance-pointer-lowtag)
937 (inst shr tmp n-widetag-bits)
940 (let ((value-real (complex-double-reg-real-tn value))
941 (result-real (complex-double-reg-real-tn result)))
942 (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
943 (unless (location= value-real result-real)
944 (inst movsd result-real value-real)))
945 (let ((value-imag (complex-double-reg-imag-tn value))
946 (result-imag (complex-double-reg-imag-tn result)))
947 (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
948 (unless (location= value-imag result-imag)
949 (inst movsd result-imag value-imag)))))
951 (define-vop (raw-instance-set-c/complex-double)
952 (:translate %raw-instance-set/complex-double)
954 (:args (object :scs (descriptor-reg))
955 (value :scs (complex-double-reg) :target result))
956 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
957 #.instance-pointer-lowtag
958 #.instance-slots-offset))
959 complex-double-float)
961 (:temporary (:sc unsigned-reg) tmp)
962 (:results (result :scs (complex-double-reg)))
963 (:result-types complex-double-float)
965 (loadw tmp object 0 instance-pointer-lowtag)
966 (inst shr tmp n-widetag-bits)
967 (let ((value-real (complex-double-reg-real-tn value))
968 (result-real (complex-double-reg-real-tn result)))
969 (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
970 (unless (location= value-real result-real)
971 (inst movsd result-real value-real)))
972 (let ((value-imag (complex-double-reg-imag-tn value))
973 (result-imag (complex-double-reg-imag-tn result)))
974 (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
975 (unless (location= value-imag result-imag)
976 (inst movsd result-imag value-imag)))))
978 (define-vop (raw-instance-init/complex-double)
979 (:args (object :scs (descriptor-reg))
980 (value :scs (complex-double-reg)))
981 (:arg-types * complex-double-float)
982 (:info instance-length index)
984 (let ((value-real (complex-double-reg-real-tn value)))
985 (inst movsd (make-ea-for-raw-slot object index instance-length -8) value-real))
986 (let ((value-imag (complex-double-reg-imag-tn value)))
987 (inst movsd (make-ea-for-raw-slot object index instance-length) value-imag))))