e82cdd472778714c18d0de2e8e11a1d99c421a0e
[sbcl.git] / src / compiler / x86-64 / cell.lisp
1 ;;;; various primitive memory access VOPs for the x86 VM
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; data object ref/set stuff
15
16 (define-vop (slot)
17   (:args (object :scs (descriptor-reg)))
18   (:info name offset lowtag)
19   (:ignore name)
20   (:results (result :scs (descriptor-reg any-reg)))
21   (:generator 1
22    (loadw result object offset lowtag)))
23
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)
29   (:ignore name)
30   (:results)
31   (:generator 1
32     (if (sc-is value immediate)
33         (let ((val (tn-value value)))
34           (move-immediate (make-ea :qword
35                                    :base object
36                                    :disp (- (* offset n-word-bytes)
37                                             lowtag))
38                           (etypecase val
39                             (integer
40                              (fixnumize val))
41                             (symbol
42                              (+ nil-value (static-symbol-offset val)))
43                             (character
44                              (logior (ash (char-code val) n-widetag-bits)
45                                      character-widetag)))
46                           temp))
47         ;; Else, value not immediate.
48         (storew value object offset lowtag))))
49
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)
56               rax)
57   (:info name offset lowtag)
58   (:ignore name)
59   (:results (result :scs (descriptor-reg any-reg)))
60   (:generator 5
61      (move rax old)
62      (inst cmpxchg (make-ea :qword :base object
63                             :disp (- (* offset n-word-bytes) lowtag))
64            new :lock)
65      (move result rax)))
66 \f
67 ;;;; symbol hacking VOPs
68
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)
75   #!+sb-thread
76   (:temporary (:sc descriptor-reg) tls)
77   (:results (result :scs (descriptor-reg any-reg)))
78   (:policy :fast-safe)
79   (:vop-var vop)
80   (:generator 15
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))
85           (check (gen-label)))
86       (move rax old)
87       #!+sb-thread
88       (progn
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
92                                :index tls :scale 1)
93               new)
94         (inst cmp rax no-tls-value-marker-widetag)
95         (inst jmp :ne check)
96         (move rax old))
97       (inst cmpxchg (make-ea :qword :base symbol
98                              :disp (- (* symbol-value-slot n-word-bytes)
99                                       other-pointer-lowtag)
100                              :scale 1)
101             new :lock)
102       (emit-label check)
103       (move result rax)
104       (inst cmp result unbound-marker-widetag)
105       (inst jmp :e unbound))))
106
107 ;;; these next two cf the sparc version, by jrd.
108 ;;; FIXME: Deref this ^ reference.
109
110
111 ;;; The compiler likes to be able to directly SET symbols.
112 #!+sb-thread
113 (define-vop (set)
114   (:args (symbol :scs (descriptor-reg))
115          (value :scs (descriptor-reg any-reg)))
116   (:temporary (:sc descriptor-reg) tls)
117   ;;(:policy :fast-safe)
118   (:generator 4
119     (let ((global-val (gen-label))
120           (done (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)
126             value)
127       (inst jmp done)
128       (emit-label global-val)
129       (storew value symbol symbol-value-slot other-pointer-lowtag)
130       (emit-label done))))
131
132 ;; unithreaded it's a lot simpler ...
133 #!-sb-thread
134 (define-vop (set cell-set)
135   (:variant symbol-value-slot other-pointer-lowtag))
136
137 ;;; With Symbol-Value, we check that the value isn't the trap object. So
138 ;;; Symbol-Value of NIL is NIL.
139 #!+sb-thread
140 (define-vop (symbol-value)
141   (:translate symbol-value)
142   (:policy :fast-safe)
143   (:args (object :scs (descriptor-reg) :to (:result 1)))
144   (:results (value :scs (descriptor-reg any-reg)))
145   (:vop-var vop)
146   (:save-p :compute-only)
147   (:generator 9
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))))
161
162 #!+sb-thread
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.  --
168   ;; CSR, 2003-04-22
169   (:policy :fast)
170   (:translate symbol-value)
171   (:generator 8
172     (let ((ret-lab (gen-label)))
173       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
174       (inst mov value
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))))
180
181 #!-sb-thread
182 (define-vop (symbol-value)
183   (:translate symbol-value)
184   (:policy :fast-safe)
185   (:args (object :scs (descriptor-reg) :to (:result 1)))
186   (:results (value :scs (descriptor-reg any-reg)))
187   (:vop-var vop)
188   (:save-p :compute-only)
189   (:generator 9
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))))
194
195 #!-sb-thread
196 (define-vop (fast-symbol-value cell-ref)
197   (:variant symbol-value-slot other-pointer-lowtag)
198   (:policy :fast)
199   (:translate symbol-value))
200
201 (defknown locked-symbol-global-value-add (symbol fixnum) fixnum ())
202
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)))
208   (:policy :fast)
209   (:translate locked-symbol-global-value-add)
210   (:result-types tagged-num)
211   (:policy :fast-safe)
212   (:generator 4
213     (move result value)
214     (inst add (make-ea :qword :base object
215                        :disp (- (* symbol-value-slot n-word-bytes)
216                                 other-pointer-lowtag))
217           value :lock)))
218
219 #!+sb-thread
220 (define-vop (boundp)
221   (:translate boundp)
222   (:policy :fast-safe)
223   (:args (object :scs (descriptor-reg)))
224   (:conditional :ne)
225   (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
226   (:generator 9
227     (let ((check-unbound-label (gen-label)))
228       (loadw value object symbol-tls-index-slot other-pointer-lowtag)
229       (inst mov value
230             (make-ea :qword :base thread-base-tn :index value :scale 1))
231       (inst cmp value no-tls-value-marker-widetag)
232       (inst jmp :ne check-unbound-label)
233       (loadw value object symbol-value-slot other-pointer-lowtag)
234       (emit-label check-unbound-label)
235       (inst cmp value unbound-marker-widetag))))
236
237 #!-sb-thread
238 (define-vop (boundp)
239   (:translate boundp)
240   (:policy :fast-safe)
241   (:args (object :scs (descriptor-reg)))
242   (:conditional :ne)
243   (:generator 9
244     (inst cmp (make-ea-for-object-slot object symbol-value-slot
245                                        other-pointer-lowtag)
246           unbound-marker-widetag)))
247
248
249 (define-vop (symbol-hash)
250   (:policy :fast-safe)
251   (:translate symbol-hash)
252   (:args (symbol :scs (descriptor-reg)))
253   (:results (res :scs (any-reg)))
254   (:result-types positive-fixnum)
255   (:generator 2
256     ;; The symbol-hash slot of NIL holds NIL because it is also the
257     ;; cdr slot, so we have to strip off the three low bits to make sure
258     ;; it is a fixnum.  The lowtag selection magic that is required to
259     ;; ensure this is explained in the comment in objdef.lisp
260     (loadw res symbol symbol-hash-slot other-pointer-lowtag)
261     (inst and res (lognot #b111))))
262 \f
263 ;;;; fdefinition (FDEFN) objects
264
265 (define-vop (fdefn-fun cell-ref)        ; /pfw - alpha
266   (:variant fdefn-fun-slot other-pointer-lowtag))
267
268 (define-vop (safe-fdefn-fun)
269   (:args (object :scs (descriptor-reg) :to (:result 1)))
270   (:results (value :scs (descriptor-reg any-reg)))
271   (:vop-var vop)
272   (:save-p :compute-only)
273   (:generator 10
274     (loadw value object fdefn-fun-slot other-pointer-lowtag)
275     (inst cmp value nil-value)
276     (let ((err-lab (generate-error-code vop 'undefined-fun-error object)))
277       (inst jmp :e err-lab))))
278
279 (define-vop (set-fdefn-fun)
280   (:policy :fast-safe)
281   (:translate (setf fdefn-fun))
282   (:args (function :scs (descriptor-reg) :target result)
283          (fdefn :scs (descriptor-reg)))
284   (:temporary (:sc unsigned-reg) raw)
285   (:temporary (:sc byte-reg) type)
286   (:results (result :scs (descriptor-reg)))
287   (:generator 38
288     (load-type type function (- fun-pointer-lowtag))
289     (inst lea raw
290           (make-ea :byte :base function
291                    :disp (- (* simple-fun-code-offset n-word-bytes)
292                             fun-pointer-lowtag)))
293     (inst cmp type simple-fun-header-widetag)
294     (inst jmp :e NORMAL-FUN)
295     (inst lea raw (make-fixup "closure_tramp" :foreign))
296     NORMAL-FUN
297     (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
298     (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
299     (move result function)))
300
301 (define-vop (fdefn-makunbound)
302   (:policy :fast-safe)
303   (:translate fdefn-makunbound)
304   (:args (fdefn :scs (descriptor-reg) :target result))
305   (:results (result :scs (descriptor-reg)))
306   (:generator 38
307     (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
308     (storew (make-fixup "undefined_tramp" :foreign)
309             fdefn fdefn-raw-addr-slot other-pointer-lowtag)
310     (move result fdefn)))
311 \f
312 ;;;; binding and unbinding
313
314 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
315 ;;; the symbol on the binding stack and stuff the new value into the
316 ;;; symbol.
317
318 #!+sb-thread
319 (define-vop (bind)
320   (:args (val :scs (any-reg descriptor-reg))
321          (symbol :scs (descriptor-reg)))
322   (:temporary (:sc unsigned-reg) tls-index bsp)
323   (:generator 10
324     (let ((tls-index-valid (gen-label)))
325       (load-binding-stack-pointer bsp)
326       (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
327       (inst add bsp (* binding-size n-word-bytes))
328       (store-binding-stack-pointer bsp)
329       (inst or tls-index tls-index)
330       (inst jmp :ne tls-index-valid)
331       (inst mov tls-index symbol)
332       (inst lea temp-reg-tn
333             (make-ea :qword :disp
334                      (make-fixup (ecase (tn-offset tls-index)
335                                    (#.rax-offset 'alloc-tls-index-in-rax)
336                                    (#.rcx-offset 'alloc-tls-index-in-rcx)
337                                    (#.rdx-offset 'alloc-tls-index-in-rdx)
338                                    (#.rbx-offset 'alloc-tls-index-in-rbx)
339                                    (#.rsi-offset 'alloc-tls-index-in-rsi)
340                                    (#.rdi-offset 'alloc-tls-index-in-rdi)
341                                    (#.r8-offset  'alloc-tls-index-in-r8)
342                                    (#.r9-offset  'alloc-tls-index-in-r9)
343                                    (#.r10-offset 'alloc-tls-index-in-r10)
344                                    (#.r12-offset 'alloc-tls-index-in-r12)
345                                    (#.r13-offset 'alloc-tls-index-in-r13)
346                                    (#.r14-offset 'alloc-tls-index-in-r14)
347                                    (#.r15-offset 'alloc-tls-index-in-r15))
348                                  :assembly-routine)))
349       (inst call temp-reg-tn)
350       (emit-label tls-index-valid)
351       (inst push (make-ea :qword :base thread-base-tn :scale 1 :index tls-index))
352       (popw bsp (- binding-value-slot binding-size))
353       (storew symbol bsp (- binding-symbol-slot binding-size))
354       (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
355             val))))
356
357 #!-sb-thread
358 (define-vop (bind)
359   (:args (val :scs (any-reg descriptor-reg))
360          (symbol :scs (descriptor-reg)))
361   (:temporary (:sc unsigned-reg) temp bsp)
362   (:generator 5
363     (load-symbol-value bsp *binding-stack-pointer*)
364     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
365     (inst add bsp (* binding-size n-word-bytes))
366     (store-symbol-value bsp *binding-stack-pointer*)
367     (storew temp bsp (- binding-value-slot binding-size))
368     (storew symbol bsp (- binding-symbol-slot binding-size))
369     (storew val symbol symbol-value-slot other-pointer-lowtag)))
370
371 #!+sb-thread
372 (define-vop (unbind)
373   (:temporary (:sc unsigned-reg) temp bsp tls-index)
374   (:generator 0
375     (load-binding-stack-pointer bsp)
376     ;; Load SYMBOL from stack, and get the TLS-INDEX
377     (loadw temp bsp (- binding-symbol-slot binding-size))
378     (loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag)
379     ;; Load VALUE from stack, the restore it to the TLS area.
380     (loadw temp bsp (- binding-value-slot binding-size))
381     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
382           temp)
383     ;; Zero out the stack.
384     (storew 0 bsp (- binding-symbol-slot binding-size))
385     (storew 0 bsp (- binding-value-slot binding-size))
386     (inst sub bsp (* binding-size n-word-bytes))
387     (store-binding-stack-pointer bsp)))
388
389 #!-sb-thread
390 (define-vop (unbind)
391   (:temporary (:sc unsigned-reg) symbol value bsp)
392   (:generator 0
393     (load-symbol-value bsp *binding-stack-pointer*)
394     (loadw symbol bsp (- binding-symbol-slot binding-size))
395     (loadw value bsp (- binding-value-slot binding-size))
396     (storew value symbol symbol-value-slot other-pointer-lowtag)
397     (storew 0 bsp (- binding-symbol-slot binding-size))
398     (storew 0 bsp (- binding-value-slot binding-size))
399     (inst sub bsp (* binding-size n-word-bytes))
400     (store-symbol-value bsp *binding-stack-pointer*)))
401
402 (define-vop (unbind-to-here)
403   (:args (where :scs (descriptor-reg any-reg)))
404   (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index)
405   (:generator 0
406     (load-binding-stack-pointer bsp)
407     (inst cmp where bsp)
408     (inst jmp :e DONE)
409
410     LOOP
411     (loadw symbol bsp (- binding-symbol-slot binding-size))
412     (inst or symbol symbol)
413     (inst jmp :z SKIP)
414     ;; Bind stack debug sentinels have the unbound marker in the symbol slot
415     (inst cmp symbol unbound-marker-widetag)
416     (inst jmp :eq SKIP)
417     (loadw value bsp (- binding-value-slot binding-size))
418     #!-sb-thread
419     (storew value symbol symbol-value-slot other-pointer-lowtag)
420     #!+sb-thread
421     (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
422     #!+sb-thread
423     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
424           value)
425     (storew 0 bsp (- binding-symbol-slot binding-size))
426
427     SKIP
428     (storew 0 bsp (- binding-value-slot binding-size))
429     (inst sub bsp (* binding-size n-word-bytes))
430     (inst cmp where bsp)
431     (inst jmp :ne LOOP)
432     (store-binding-stack-pointer bsp)
433
434     DONE))
435
436 (define-vop (bind-sentinel)
437   (:temporary (:sc unsigned-reg) bsp)
438   (:generator 1
439      (load-binding-stack-pointer bsp)
440      (inst add bsp (* binding-size n-word-bytes))
441      (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
442      (storew rbp-tn bsp (- binding-value-slot binding-size))
443      (store-binding-stack-pointer bsp)))
444
445 (define-vop (unbind-sentinel)
446   (:temporary (:sc unsigned-reg) bsp)
447   (:generator 1
448      (load-binding-stack-pointer bsp)
449      (storew 0 bsp (- binding-value-slot binding-size))
450      (storew 0 bsp (- binding-symbol-slot binding-size))
451      (inst sub bsp (* binding-size n-word-bytes))
452      (store-binding-stack-pointer bsp)))
453
454 \f
455
456 \f
457 ;;;; closure indexing
458
459 (define-full-reffer closure-index-ref *
460   closure-info-offset fun-pointer-lowtag
461   (any-reg descriptor-reg) * %closure-index-ref)
462
463 (define-full-setter set-funcallable-instance-info *
464   funcallable-instance-info-offset fun-pointer-lowtag
465   (any-reg descriptor-reg) * %set-funcallable-instance-info)
466
467 (define-full-reffer funcallable-instance-info *
468   funcallable-instance-info-offset fun-pointer-lowtag
469   (descriptor-reg any-reg) * %funcallable-instance-info)
470
471 (define-vop (closure-ref slot-ref)
472   (:variant closure-info-offset fun-pointer-lowtag))
473
474 (define-vop (closure-init slot-set)
475   (:variant closure-info-offset fun-pointer-lowtag))
476 \f
477 ;;;; value cell hackery
478
479 (define-vop (value-cell-ref cell-ref)
480   (:variant value-cell-value-slot other-pointer-lowtag))
481
482 (define-vop (value-cell-set cell-set)
483   (:variant value-cell-value-slot other-pointer-lowtag))
484 \f
485 ;;;; structure hackery
486
487 (define-vop (instance-length)
488   (:policy :fast-safe)
489   (:translate %instance-length)
490   (:args (struct :scs (descriptor-reg)))
491   (:results (res :scs (unsigned-reg)))
492   (:result-types positive-fixnum)
493   (:generator 4
494     (loadw res struct 0 instance-pointer-lowtag)
495     (inst shr res n-widetag-bits)))
496
497 (define-full-reffer instance-index-ref * instance-slots-offset
498   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
499
500 (define-full-setter instance-index-set * instance-slots-offset
501   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
502
503 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
504   instance-slots-offset instance-pointer-lowtag
505   (any-reg descriptor-reg) *
506   %compare-and-swap-instance-ref)
507 \f
508 ;;;; code object frobbing
509
510 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
511   (any-reg descriptor-reg) * code-header-ref)
512
513 (define-full-setter code-header-set * 0 other-pointer-lowtag
514   (any-reg descriptor-reg) * code-header-set)
515 \f
516 ;;;; raw instance slot accessors
517
518 (defun make-ea-for-raw-slot (object index instance-length
519                              &optional (adjustment 0))
520   (if (integerp instance-length)
521       ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
522       ;; at compile time.
523       (make-ea :qword
524                :base object
525                :disp (+ (* (- instance-length instance-slots-offset index)
526                            n-word-bytes)
527                         (- instance-pointer-lowtag)
528                         adjustment))
529       (etypecase index
530         (tn
531          (make-ea :qword :base object :index instance-length
532                   :disp (+ (* (1- instance-slots-offset) n-word-bytes)
533                            (- instance-pointer-lowtag)
534                            adjustment)))
535         (integer
536          (make-ea :qword :base object :index instance-length
537                   :scale 8
538                   :disp (+ (* (1- instance-slots-offset) n-word-bytes)
539                            (- instance-pointer-lowtag)
540                            adjustment
541                            (* index (- n-word-bytes))))))))
542
543 (define-vop (raw-instance-ref/word)
544   (:translate %raw-instance-ref/word)
545   (:policy :fast-safe)
546   (:args (object :scs (descriptor-reg)) (index :scs (any-reg)))
547   (:arg-types * tagged-num)
548   (:temporary (:sc unsigned-reg) tmp)
549   (:results (value :scs (unsigned-reg)))
550   (:result-types unsigned-num)
551   (:generator 5
552     (loadw tmp object 0 instance-pointer-lowtag)
553     (inst shr tmp n-widetag-bits)
554     (inst shl tmp 3)
555     (inst sub tmp index)
556     (inst mov value (make-ea-for-raw-slot object index tmp))))
557
558 (define-vop (raw-instance-ref-c/word)
559   (:translate %raw-instance-ref/word)
560   (:policy :fast-safe)
561   (:args (object :scs (descriptor-reg)))
562   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
563                                              #.instance-pointer-lowtag
564                                              #.instance-slots-offset)))
565   (:info index)
566   (:temporary (:sc unsigned-reg) tmp)
567   (:results (value :scs (unsigned-reg)))
568   (:result-types unsigned-num)
569   (:generator 4
570     (loadw tmp object 0 instance-pointer-lowtag)
571     (inst shr tmp n-widetag-bits)
572     (inst mov value (make-ea-for-raw-slot object index tmp))))
573
574 (define-vop (raw-instance-set/word)
575   (:translate %raw-instance-set/word)
576   (:policy :fast-safe)
577   (:args (object :scs (descriptor-reg))
578          (index :scs (any-reg))
579          (value :scs (unsigned-reg) :target result))
580   (:arg-types * tagged-num unsigned-num)
581   (:temporary (:sc unsigned-reg) tmp)
582   (:results (result :scs (unsigned-reg)))
583   (:result-types unsigned-num)
584   (:generator 5
585     (loadw tmp object 0 instance-pointer-lowtag)
586     (inst shr tmp n-widetag-bits)
587     (inst shl tmp 3)
588     (inst sub tmp index)
589     (inst mov (make-ea-for-raw-slot object index tmp) value)
590     (move result value)))
591
592 (define-vop (raw-instance-set-c/word)
593   (:translate %raw-instance-set/word)
594   (:policy :fast-safe)
595   (:args (object :scs (descriptor-reg))
596          (value :scs (unsigned-reg) :target result))
597   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
598                                              #.instance-pointer-lowtag
599                                              #.instance-slots-offset))
600               unsigned-num)
601   (:info index)
602   (:temporary (:sc unsigned-reg) tmp)
603   (:results (result :scs (unsigned-reg)))
604   (:result-types unsigned-num)
605   (:generator 4
606     (loadw tmp object 0 instance-pointer-lowtag)
607     (inst shr tmp n-widetag-bits)
608     (inst mov (make-ea-for-raw-slot object index tmp) value)
609     (move result value)))
610
611 (define-vop (raw-instance-init/word)
612   (:args (object :scs (descriptor-reg))
613          (value :scs (unsigned-reg)))
614   (:arg-types * unsigned-num)
615   (:info instance-length index)
616   (:generator 4
617     (inst mov (make-ea-for-raw-slot object index instance-length) value)))
618
619 (define-vop (raw-instance-atomic-incf-c/word)
620   (:translate %raw-instance-atomic-incf/word)
621   (:policy :fast-safe)
622   (:args (object :scs (descriptor-reg))
623          (diff :scs (signed-reg) :target result))
624   (:arg-types * (:constant (load/store-index #.n-word-bytes
625                                              #.instance-pointer-lowtag
626                                              #.instance-slots-offset))
627               signed-num)
628   (:info index)
629   (:temporary (:sc unsigned-reg) tmp)
630   (:results (result :scs (unsigned-reg)))
631   (:result-types unsigned-num)
632   (:generator 4
633     (loadw tmp object 0 instance-pointer-lowtag)
634     (inst shr tmp n-widetag-bits)
635     (inst xadd (make-ea-for-raw-slot object index tmp) diff :lock)
636     (move result diff)))
637
638 (define-vop (raw-instance-ref/single)
639   (:translate %raw-instance-ref/single)
640   (:policy :fast-safe)
641   (:args (object :scs (descriptor-reg))
642          (index :scs (any-reg)))
643   (:arg-types * positive-fixnum)
644   (:temporary (:sc unsigned-reg) tmp)
645   (:results (value :scs (single-reg)))
646   (:result-types single-float)
647   (:generator 5
648     (loadw tmp object 0 instance-pointer-lowtag)
649     (inst shr tmp n-widetag-bits)
650     (inst shl tmp 3)
651     (inst sub tmp index)
652     (inst movss value (make-ea-for-raw-slot object index tmp))))
653
654 (define-vop (raw-instance-ref-c/single)
655   (:translate %raw-instance-ref/single)
656   (:policy :fast-safe)
657   (:args (object :scs (descriptor-reg)))
658   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
659                                              #.instance-pointer-lowtag
660                                              #.instance-slots-offset)))
661   (:info index)
662   (:temporary (:sc unsigned-reg) tmp)
663   (:results (value :scs (single-reg)))
664   (:result-types single-float)
665   (:generator 4
666     (loadw tmp object 0 instance-pointer-lowtag)
667     (inst shr tmp n-widetag-bits)
668     (inst movss value (make-ea-for-raw-slot object index tmp))))
669
670 (define-vop (raw-instance-set/single)
671   (:translate %raw-instance-set/single)
672   (:policy :fast-safe)
673   (:args (object :scs (descriptor-reg))
674          (index :scs (any-reg))
675          (value :scs (single-reg) :target result))
676   (:arg-types * positive-fixnum single-float)
677   (:temporary (:sc unsigned-reg) tmp)
678   (:results (result :scs (single-reg)))
679   (:result-types single-float)
680   (:generator 5
681     (loadw tmp object 0 instance-pointer-lowtag)
682     (inst shr tmp n-widetag-bits)
683     (inst shl tmp 3)
684     (inst sub tmp index)
685     (inst movss (make-ea-for-raw-slot object index tmp) value)
686    (unless (location= result value)
687      (inst movss result value))))
688
689 (define-vop (raw-instance-set-c/single)
690   (:translate %raw-instance-set/single)
691   (:policy :fast-safe)
692   (:args (object :scs (descriptor-reg))
693          (value :scs (single-reg) :target result))
694   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
695                                              #.instance-pointer-lowtag
696                                              #.instance-slots-offset))
697               single-float)
698   (:info index)
699   (:temporary (:sc unsigned-reg) tmp)
700   (:results (result :scs (single-reg)))
701   (:result-types single-float)
702   (:generator 4
703     (loadw tmp object 0 instance-pointer-lowtag)
704     (inst shr tmp n-widetag-bits)
705     (inst movss (make-ea-for-raw-slot object index tmp) value)
706    (unless (location= result value)
707      (inst movss result value))))
708
709 (define-vop (raw-instance-init/single)
710   (:args (object :scs (descriptor-reg))
711          (value :scs (single-reg)))
712   (:arg-types * single-float)
713   (:info instance-length index)
714   (:generator 4
715     (inst movss (make-ea-for-raw-slot object index instance-length) value)))
716
717 (define-vop (raw-instance-ref/double)
718   (:translate %raw-instance-ref/double)
719   (:policy :fast-safe)
720   (:args (object :scs (descriptor-reg))
721          (index :scs (any-reg)))
722   (:arg-types * positive-fixnum)
723   (:temporary (:sc unsigned-reg) tmp)
724   (:results (value :scs (double-reg)))
725   (:result-types double-float)
726   (:generator 5
727     (loadw tmp object 0 instance-pointer-lowtag)
728     (inst shr tmp n-widetag-bits)
729     (inst shl tmp 3)
730     (inst sub tmp index)
731     (inst movsd value (make-ea-for-raw-slot object index tmp))))
732
733 (define-vop (raw-instance-ref-c/double)
734   (:translate %raw-instance-ref/double)
735   (:policy :fast-safe)
736   (:args (object :scs (descriptor-reg)))
737   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
738                                              #.instance-pointer-lowtag
739                                              #.instance-slots-offset)))
740   (:info index)
741   (:temporary (:sc unsigned-reg) tmp)
742   (:results (value :scs (double-reg)))
743   (:result-types double-float)
744   (:generator 4
745     (loadw tmp object 0 instance-pointer-lowtag)
746     (inst shr tmp n-widetag-bits)
747     (inst movsd value (make-ea-for-raw-slot object index tmp))))
748
749 (define-vop (raw-instance-set/double)
750   (:translate %raw-instance-set/double)
751   (:policy :fast-safe)
752   (:args (object :scs (descriptor-reg))
753          (index :scs (any-reg))
754          (value :scs (double-reg) :target result))
755   (:arg-types * positive-fixnum double-float)
756   (:temporary (:sc unsigned-reg) tmp)
757   (:results (result :scs (double-reg)))
758   (:result-types double-float)
759   (:generator 5
760     (loadw tmp object 0 instance-pointer-lowtag)
761     (inst shr tmp n-widetag-bits)
762     (inst shl tmp 3)
763     (inst sub tmp index)
764     (inst movsd (make-ea-for-raw-slot object index tmp) value)
765    (unless (location= result value)
766      (inst movsd result value))))
767
768 (define-vop (raw-instance-set-c/double)
769   (:translate %raw-instance-set/double)
770   (:policy :fast-safe)
771   (:args (object :scs (descriptor-reg))
772          (value :scs (double-reg) :target result))
773   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
774                                              #.instance-pointer-lowtag
775                                              #.instance-slots-offset))
776               double-float)
777   (:info index)
778   (:temporary (:sc unsigned-reg) tmp)
779   (:results (result :scs (double-reg)))
780   (:result-types double-float)
781   (:generator 4
782     (loadw tmp object 0 instance-pointer-lowtag)
783     (inst shr tmp n-widetag-bits)
784     (inst movsd (make-ea-for-raw-slot object index tmp) value)
785    (unless (location= result value)
786      (inst movsd result value))))
787
788 (define-vop (raw-instance-init/double)
789   (:args (object :scs (descriptor-reg))
790          (value :scs (double-reg)))
791   (:arg-types * double-float)
792   (:info instance-length index)
793   (:generator 4
794     (inst movsd (make-ea-for-raw-slot object index instance-length) value)))
795
796 (define-vop (raw-instance-ref/complex-single)
797   (:translate %raw-instance-ref/complex-single)
798   (:policy :fast-safe)
799   (:args (object :scs (descriptor-reg))
800          (index :scs (any-reg)))
801   (:arg-types * positive-fixnum)
802   (:temporary (:sc unsigned-reg) tmp)
803   (:results (value :scs (complex-single-reg)))
804   (:result-types complex-single-float)
805   (:generator 5
806     (loadw tmp object 0 instance-pointer-lowtag)
807     (inst shr tmp n-widetag-bits)
808     (inst shl tmp 3)
809     (inst sub tmp index)
810     (let ((real-tn (complex-single-reg-real-tn value)))
811       (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
812     (let ((imag-tn (complex-single-reg-imag-tn value)))
813       (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
814
815 (define-vop (raw-instance-ref-c/complex-single)
816   (:translate %raw-instance-ref/complex-single)
817   (:policy :fast-safe)
818   (:args (object :scs (descriptor-reg)))
819   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
820                                              #.instance-pointer-lowtag
821                                              #.instance-slots-offset)))
822   (:info index)
823   (:temporary (:sc unsigned-reg) tmp)
824   (:results (value :scs (complex-single-reg)))
825   (:result-types complex-single-float)
826   (:generator 4
827     (loadw tmp object 0 instance-pointer-lowtag)
828     (inst shr tmp n-widetag-bits)
829     (let ((real-tn (complex-single-reg-real-tn value)))
830       (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
831     (let ((imag-tn (complex-single-reg-imag-tn value)))
832       (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
833
834 (define-vop (raw-instance-set/complex-single)
835   (:translate %raw-instance-set/complex-single)
836   (:policy :fast-safe)
837   (:args (object :scs (descriptor-reg))
838          (index :scs (any-reg))
839          (value :scs (complex-single-reg) :target result))
840   (:arg-types * positive-fixnum complex-single-float)
841   (:temporary (:sc unsigned-reg) tmp)
842   (:results (result :scs (complex-single-reg)))
843   (:result-types complex-single-float)
844   (:generator 5
845     (loadw tmp object 0 instance-pointer-lowtag)
846     (inst shr tmp n-widetag-bits)
847     (inst shl tmp 3)
848     (inst sub tmp index)
849     (let ((value-real (complex-single-reg-real-tn value))
850           (result-real (complex-single-reg-real-tn result)))
851       (inst movss (make-ea-for-raw-slot object index tmp) value-real)
852       (unless (location= value-real result-real)
853         (inst movss result-real value-real)))
854     (let ((value-imag (complex-single-reg-imag-tn value))
855           (result-imag (complex-single-reg-imag-tn result)))
856       (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
857       (unless (location= value-imag result-imag)
858         (inst movss result-imag value-imag)))))
859
860 (define-vop (raw-instance-set-c/complex-single)
861   (:translate %raw-instance-set/complex-single)
862   (:policy :fast-safe)
863   (:args (object :scs (descriptor-reg))
864          (value :scs (complex-single-reg) :target result))
865   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
866                                              #.instance-pointer-lowtag
867                                              #.instance-slots-offset))
868               complex-single-float)
869   (:info index)
870   (:temporary (:sc unsigned-reg) tmp)
871   (:results (result :scs (complex-single-reg)))
872   (:result-types complex-single-float)
873   (:generator 4
874     (loadw tmp object 0 instance-pointer-lowtag)
875     (inst shr tmp n-widetag-bits)
876     (let ((value-real (complex-single-reg-real-tn value))
877           (result-real (complex-single-reg-real-tn result)))
878       (inst movss (make-ea-for-raw-slot object index tmp) value-real)
879       (unless (location= value-real result-real)
880         (inst movss result-real value-real)))
881     (let ((value-imag (complex-single-reg-imag-tn value))
882           (result-imag (complex-single-reg-imag-tn result)))
883       (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
884       (unless (location= value-imag result-imag)
885         (inst movss result-imag value-imag)))))
886
887 (define-vop (raw-instance-init/complex-single)
888   (:args (object :scs (descriptor-reg))
889          (value :scs (complex-single-reg)))
890   (:arg-types * complex-single-float)
891   (:info instance-length index)
892   (:generator 4
893     (let ((value-real (complex-single-reg-real-tn value)))
894       (inst movss (make-ea-for-raw-slot object index instance-length) value-real))
895     (let ((value-imag (complex-single-reg-imag-tn value)))
896       (inst movss (make-ea-for-raw-slot object index instance-length 4) value-imag))))
897
898 (define-vop (raw-instance-ref/complex-double)
899   (:translate %raw-instance-ref/complex-double)
900   (:policy :fast-safe)
901   (:args (object :scs (descriptor-reg))
902          (index :scs (any-reg)))
903   (:arg-types * positive-fixnum)
904   (:temporary (:sc unsigned-reg) tmp)
905   (:results (value :scs (complex-double-reg)))
906   (:result-types complex-double-float)
907   (:generator 5
908     (loadw tmp object 0 instance-pointer-lowtag)
909     (inst shr tmp n-widetag-bits)
910     (inst shl tmp 3)
911     (inst sub tmp index)
912     (let ((real-tn (complex-double-reg-real-tn value)))
913       (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
914     (let ((imag-tn (complex-double-reg-imag-tn value)))
915       (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
916
917 (define-vop (raw-instance-ref-c/complex-double)
918   (:translate %raw-instance-ref/complex-double)
919   (:policy :fast-safe)
920   (:args (object :scs (descriptor-reg)))
921   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
922                                              #.instance-pointer-lowtag
923                                              #.instance-slots-offset)))
924   (:info index)
925   (:temporary (:sc unsigned-reg) tmp)
926   (:results (value :scs (complex-double-reg)))
927   (:result-types complex-double-float)
928   (:generator 4
929     (loadw tmp object 0 instance-pointer-lowtag)
930     (inst shr tmp n-widetag-bits)
931     (let ((real-tn (complex-double-reg-real-tn value)))
932       (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
933     (let ((imag-tn (complex-double-reg-imag-tn value)))
934       (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
935
936 (define-vop (raw-instance-set/complex-double)
937   (:translate %raw-instance-set/complex-double)
938   (:policy :fast-safe)
939   (:args (object :scs (descriptor-reg))
940          (index :scs (any-reg))
941          (value :scs (complex-double-reg) :target result))
942   (:arg-types * positive-fixnum complex-double-float)
943   (:temporary (:sc unsigned-reg) tmp)
944   (:results (result :scs (complex-double-reg)))
945   (:result-types complex-double-float)
946   (:generator 5
947     (loadw tmp object 0 instance-pointer-lowtag)
948     (inst shr tmp n-widetag-bits)
949     (inst shl tmp 3)
950     (inst sub tmp index)
951     (let ((value-real (complex-double-reg-real-tn value))
952           (result-real (complex-double-reg-real-tn result)))
953       (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
954       (unless (location= value-real result-real)
955         (inst movsd result-real value-real)))
956     (let ((value-imag (complex-double-reg-imag-tn value))
957           (result-imag (complex-double-reg-imag-tn result)))
958       (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
959       (unless (location= value-imag result-imag)
960         (inst movsd result-imag value-imag)))))
961
962 (define-vop (raw-instance-set-c/complex-double)
963   (:translate %raw-instance-set/complex-double)
964   (:policy :fast-safe)
965   (:args (object :scs (descriptor-reg))
966          (value :scs (complex-double-reg) :target result))
967   (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
968                                              #.instance-pointer-lowtag
969                                              #.instance-slots-offset))
970               complex-double-float)
971   (:info index)
972   (:temporary (:sc unsigned-reg) tmp)
973   (:results (result :scs (complex-double-reg)))
974   (:result-types complex-double-float)
975   (:generator 4
976     (loadw tmp object 0 instance-pointer-lowtag)
977     (inst shr tmp n-widetag-bits)
978     (let ((value-real (complex-double-reg-real-tn value))
979           (result-real (complex-double-reg-real-tn result)))
980       (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
981       (unless (location= value-real result-real)
982         (inst movsd result-real value-real)))
983     (let ((value-imag (complex-double-reg-imag-tn value))
984           (result-imag (complex-double-reg-imag-tn result)))
985       (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
986       (unless (location= value-imag result-imag)
987         (inst movsd result-imag value-imag)))))
988
989 (define-vop (raw-instance-init/complex-double)
990   (:args (object :scs (descriptor-reg))
991          (value :scs (complex-double-reg)))
992   (:arg-types * complex-double-float)
993   (:info instance-length index)
994   (:generator 4
995     (let ((value-real (complex-double-reg-real-tn value)))
996       (inst movsd (make-ea-for-raw-slot object index instance-length -8) value-real))
997     (let ((value-imag (complex-double-reg-imag-tn value)))
998       (inst movsd (make-ea-for-raw-slot object index instance-length) value-imag))))