1 ;;;; the VM definition of various primitive memory access VOPs for the
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;;;; 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)))
27 (:info name offset lowtag)
31 (storew value object offset lowtag)))
33 ;;;; Symbol hacking VOPs:
35 ;;; The compiler likes to be able to directly SET symbols.
36 (define-vop (set cell-set)
37 (:variant symbol-value-slot other-pointer-lowtag))
39 ;;; Do a cell ref with an error check for being unbound.
40 (define-vop (checked-cell-ref)
41 (:args (object :scs (descriptor-reg) :target obj-temp))
42 (:results (value :scs (descriptor-reg any-reg)))
45 (:save-p :compute-only)
46 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
48 ;;; With Symbol-Value, we check that the value isn't the trap object.
49 ;;; So Symbol-Value of NIL is NIL.
50 (define-vop (symbol-value checked-cell-ref)
51 (:translate symbol-value)
53 (move obj-temp object)
54 (loadw value obj-temp symbol-value-slot other-pointer-lowtag)
55 (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
56 (inst cmp value unbound-marker-widetag)
60 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
62 (define-vop (boundp-frob)
63 (:args (object :scs (descriptor-reg)))
67 (:temporary (:scs (descriptor-reg)) value))
69 (define-vop (boundp boundp-frob)
72 (loadw value object symbol-value-slot other-pointer-lowtag)
73 (inst cmp value unbound-marker-widetag)
74 (inst b (if not-p :eq :ne) target)
77 (define-vop (fast-symbol-value cell-ref)
78 (:variant symbol-value-slot other-pointer-lowtag)
80 (:translate symbol-value))
82 (define-vop (symbol-hash)
84 (:translate symbol-hash)
85 (:args (symbol :scs (descriptor-reg)))
86 (:results (res :scs (any-reg)))
87 (:result-types positive-fixnum)
89 ;; The symbol-hash slot of NIL holds NIL because it is also the
90 ;; cdr slot, so we have to strip off the two low bits to make sure
91 ;; it is a fixnum. The lowtag selection magic that is required to
92 ;; ensure this is explained in the comment in objdef.lisp
93 (loadw res symbol symbol-hash-slot other-pointer-lowtag)
94 (inst andn res res fixnum-tag-mask)))
96 ;;; On unithreaded builds these are just copies of the non-global versions.
97 (define-vop (%set-symbol-global-value set))
98 (define-vop (symbol-global-value symbol-value)
99 (:translate symbol-global-value))
100 (define-vop (fast-symbol-global-value fast-symbol-value)
101 (:translate symbol-global-value))
103 ;;;; FDEFINITION (fdefn) objects.
104 (define-vop (fdefn-fun cell-ref)
105 (:variant fdefn-fun-slot other-pointer-lowtag))
107 (define-vop (safe-fdefn-fun)
108 (:args (object :scs (descriptor-reg) :target obj-temp))
109 (:results (value :scs (descriptor-reg any-reg)))
111 (:save-p :compute-only)
112 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
114 (move obj-temp object)
115 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
116 (inst cmp value null-tn)
117 (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
118 (inst b :eq err-lab))
121 (define-vop (set-fdefn-fun)
123 (:translate (setf fdefn-fun))
124 (:args (function :scs (descriptor-reg) :target result)
125 (fdefn :scs (descriptor-reg)))
126 (:temporary (:scs (interior-reg)) lip)
127 (:temporary (:scs (non-descriptor-reg)) type)
128 (:results (result :scs (descriptor-reg)))
130 (let ((normal-fn (gen-label)))
131 (load-type type function (- fun-pointer-lowtag))
132 (inst cmp type simple-fun-header-widetag)
133 (inst b :eq normal-fn)
134 (inst move lip function)
135 (inst li lip (make-fixup "closure_tramp" :foreign))
136 (emit-label normal-fn)
137 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
138 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
139 (move result function))))
141 (define-vop (fdefn-makunbound)
143 (:translate fdefn-makunbound)
144 (:args (fdefn :scs (descriptor-reg) :target result))
145 (:temporary (:scs (non-descriptor-reg)) temp)
146 (:results (result :scs (descriptor-reg)))
148 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
149 (inst li temp (make-fixup "undefined_tramp" :foreign))
150 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
151 (move result fdefn)))
155 ;;;; Binding and Unbinding.
157 ;;; Establish VAL as a binding for SYMBOL. Save the old value and the
158 ;;; symbol on the binding stack and stuff the new value into the
161 (:args (val :scs (any-reg descriptor-reg))
162 (symbol :scs (descriptor-reg)))
163 (:temporary (:scs (descriptor-reg)) temp)
165 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
166 (inst add bsp-tn bsp-tn (* 2 n-word-bytes))
167 (storew temp bsp-tn (- binding-value-slot binding-size))
168 (storew symbol bsp-tn (- binding-symbol-slot binding-size))
169 (storew val symbol symbol-value-slot other-pointer-lowtag)))
172 (:temporary (:scs (descriptor-reg)) symbol value)
174 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
175 (loadw value bsp-tn (- binding-value-slot binding-size))
176 (storew value symbol symbol-value-slot other-pointer-lowtag)
177 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
178 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
179 (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))))
181 (define-vop (unbind-to-here)
182 (:args (arg :scs (descriptor-reg any-reg) :target where))
183 (:temporary (:scs (any-reg) :from (:argument 0)) where)
184 (:temporary (:scs (descriptor-reg)) symbol value)
186 (let ((loop (gen-label))
190 (inst cmp where bsp-tn)
195 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
198 (loadw value bsp-tn (- binding-value-slot binding-size))
199 (storew value symbol symbol-value-slot other-pointer-lowtag)
200 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
203 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
204 (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))
205 (inst cmp where bsp-tn)
211 ;;;; closure indexing.
213 (define-vop (closure-index-ref word-index-ref)
214 (:variant closure-info-offset fun-pointer-lowtag)
215 (:translate %closure-index-ref))
217 (define-vop (funcallable-instance-info word-index-ref)
218 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
219 (:translate %funcallable-instance-info))
221 (define-vop (set-funcallable-instance-info word-index-set)
222 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
223 (:translate %set-funcallable-instance-info))
225 (define-vop (closure-ref slot-ref)
226 (:variant closure-info-offset fun-pointer-lowtag))
228 (define-vop (closure-init slot-set)
229 (:variant closure-info-offset fun-pointer-lowtag))
231 ;;;; value cell hackery.
233 (define-vop (value-cell-ref cell-ref)
234 (:variant value-cell-value-slot other-pointer-lowtag))
236 (define-vop (value-cell-set cell-set)
237 (:variant value-cell-value-slot other-pointer-lowtag))
239 ;;;; instance hackery:
241 (define-vop (instance-length)
243 (:translate %instance-length)
244 (:args (struct :scs (descriptor-reg)))
245 (:temporary (:scs (non-descriptor-reg)) temp)
246 (:results (res :scs (unsigned-reg)))
247 (:result-types positive-fixnum)
249 (loadw temp struct 0 instance-pointer-lowtag)
250 (inst srl res temp n-widetag-bits)))
252 (define-vop (instance-index-ref word-index-ref)
254 (:translate %instance-ref)
255 (:variant instance-slots-offset instance-pointer-lowtag)
256 (:arg-types * positive-fixnum))
258 (define-vop (instance-index-set word-index-set)
260 (:translate %instance-set)
261 (:variant instance-slots-offset instance-pointer-lowtag)
262 (:arg-types * positive-fixnum *))
264 ;;;; Code object frobbing.
266 (define-vop (code-header-ref word-index-ref)
267 (:translate code-header-ref)
269 (:variant 0 other-pointer-lowtag))
271 (define-vop (code-header-set word-index-set)
272 (:translate code-header-set)
274 (:variant 0 other-pointer-lowtag))
278 ;;;; raw instance slot accessors
280 (define-vop (raw-instance-ref/word)
281 (:translate %raw-instance-ref/word)
283 (:args (object :scs (descriptor-reg))
284 (index :scs (any-reg)))
285 (:arg-types * positive-fixnum)
286 (:results (value :scs (unsigned-reg)))
287 (:temporary (:scs (non-descriptor-reg)) offset)
288 (:result-types unsigned-num)
290 (loadw offset object 0 instance-pointer-lowtag)
291 (inst srl offset offset n-widetag-bits)
292 (inst sll offset offset n-fixnum-tag-bits)
293 (inst sub offset offset index)
297 (- (* (1- instance-slots-offset) n-word-bytes)
298 instance-pointer-lowtag))
299 (inst ld value object offset)))
301 (define-vop (raw-instance-set/word)
302 (:translate %raw-instance-set/word)
304 (:args (object :scs (descriptor-reg))
305 (index :scs (any-reg))
306 (value :scs (unsigned-reg)))
307 (:arg-types * positive-fixnum unsigned-num)
308 (:results (result :scs (unsigned-reg)))
309 (:temporary (:scs (non-descriptor-reg)) offset)
310 (:result-types unsigned-num)
312 (loadw offset object 0 instance-pointer-lowtag)
313 (inst srl offset offset n-widetag-bits)
314 (inst sll offset offset n-fixnum-tag-bits)
315 (inst sub offset offset index)
319 (- (* (1- instance-slots-offset) n-word-bytes)
320 instance-pointer-lowtag))
321 (inst st value object offset)
322 (move result value)))
324 (define-vop (raw-instance-ref/single)
325 (:translate %raw-instance-ref/single)
327 (:args (object :scs (descriptor-reg))
328 (index :scs (any-reg)))
329 (:arg-types * positive-fixnum)
330 (:results (value :scs (single-reg)))
331 (:temporary (:scs (non-descriptor-reg)) offset)
332 (:result-types single-float)
334 (loadw offset object 0 instance-pointer-lowtag)
335 (inst srl offset offset n-widetag-bits)
336 (inst sll offset offset n-fixnum-tag-bits)
337 (inst sub offset offset index)
341 (- (* (1- instance-slots-offset) n-word-bytes)
342 instance-pointer-lowtag))
343 (inst ldf value object offset)))
345 (define-vop (raw-instance-set/single)
346 (:translate %raw-instance-set/single)
348 (:args (object :scs (descriptor-reg))
349 (index :scs (any-reg))
350 (value :scs (single-reg) :target result))
351 (:arg-types * positive-fixnum single-float)
352 (:results (result :scs (single-reg)))
353 (:result-types single-float)
354 (:temporary (:scs (non-descriptor-reg)) offset)
356 (loadw offset object 0 instance-pointer-lowtag)
357 (inst srl offset offset n-widetag-bits)
358 (inst sll offset offset n-fixnum-tag-bits)
359 (inst sub offset offset index)
363 (- (* (1- instance-slots-offset) n-word-bytes)
364 instance-pointer-lowtag))
365 (inst stf value object offset)
366 (unless (location= result value)
367 (inst fmovs result value))))
369 (define-vop (raw-instance-ref/double)
370 (:translate %raw-instance-ref/double)
372 (:args (object :scs (descriptor-reg))
373 (index :scs (any-reg)))
374 (:arg-types * positive-fixnum)
375 (:results (value :scs (double-reg)))
376 (:temporary (:scs (non-descriptor-reg)) offset)
377 (:result-types double-float)
379 (loadw offset object 0 instance-pointer-lowtag)
380 (inst srl offset offset n-widetag-bits)
381 (inst sll offset offset n-fixnum-tag-bits)
382 (inst sub offset offset index)
386 (- (* (- instance-slots-offset 2) n-word-bytes)
387 instance-pointer-lowtag))
388 (inst lddf value object offset)))
390 (define-vop (raw-instance-set/double)
391 (:translate %raw-instance-set/double)
393 (:args (object :scs (descriptor-reg))
394 (index :scs (any-reg))
395 (value :scs (double-reg) :target result))
396 (:arg-types * positive-fixnum double-float)
397 (:results (result :scs (double-reg)))
398 (:result-types double-float)
399 (:temporary (:scs (non-descriptor-reg)) offset)
401 (loadw offset object 0 instance-pointer-lowtag)
402 (inst srl offset offset n-widetag-bits)
403 (inst sll offset offset n-fixnum-tag-bits)
404 (inst sub offset offset index)
408 (- (* (- instance-slots-offset 2) n-word-bytes)
409 instance-pointer-lowtag))
410 (inst stdf value object offset)
411 (unless (location= result value)
412 (move-double-reg result value))))
414 (define-vop (raw-instance-ref/complex-single)
415 (:translate %raw-instance-ref/complex-single)
417 (:args (object :scs (descriptor-reg))
418 (index :scs (any-reg)))
419 (:arg-types * positive-fixnum)
420 (:results (value :scs (complex-single-reg)))
421 (:temporary (:scs (non-descriptor-reg)) offset)
422 (:result-types complex-single-float)
424 (loadw offset object 0 instance-pointer-lowtag)
425 (inst srl offset offset n-widetag-bits)
426 (inst sll offset offset n-fixnum-tag-bits)
427 (inst sub offset offset index)
431 (- (* (- instance-slots-offset 2) n-word-bytes)
432 instance-pointer-lowtag))
433 (inst ldf (complex-single-reg-real-tn value) object offset)
434 (inst add offset offset n-word-bytes)
435 (inst ldf (complex-single-reg-imag-tn value) object offset)))
437 (define-vop (raw-instance-set/complex-single)
438 (:translate %raw-instance-set/complex-single)
440 (:args (object :scs (descriptor-reg))
441 (index :scs (any-reg))
442 (value :scs (complex-single-reg) :target result))
443 (:arg-types * positive-fixnum complex-single-float)
444 (:results (result :scs (complex-single-reg)))
445 (:result-types complex-single-float)
446 (:temporary (:scs (non-descriptor-reg)) offset)
448 (loadw offset object 0 instance-pointer-lowtag)
449 (inst srl offset offset n-widetag-bits)
450 (inst sll offset offset n-fixnum-tag-bits)
451 (inst sub offset offset index)
455 (- (* (- instance-slots-offset 2) n-word-bytes)
456 instance-pointer-lowtag))
457 (let ((value-real (complex-single-reg-real-tn value))
458 (result-real (complex-single-reg-real-tn result)))
459 (inst stf value-real object offset)
460 (unless (location= result-real value-real)
461 (inst fmovs result-real value-real)))
462 (inst add offset offset n-word-bytes)
463 (let ((value-imag (complex-single-reg-imag-tn value))
464 (result-imag (complex-single-reg-imag-tn result)))
465 (inst stf value-imag object offset)
466 (unless (location= result-imag value-imag)
467 (inst fmovs result-imag value-imag)))))
469 (define-vop (raw-instance-ref/complex-double)
470 (:translate %raw-instance-ref/complex-double)
472 (:args (object :scs (descriptor-reg))
473 (index :scs (any-reg)))
474 (:arg-types * positive-fixnum)
475 (:results (value :scs (complex-double-reg)))
476 (:temporary (:scs (non-descriptor-reg)) offset)
477 (:result-types complex-double-float)
479 (loadw offset object 0 instance-pointer-lowtag)
480 (inst srl offset offset n-widetag-bits)
481 (inst sll offset offset n-fixnum-tag-bits)
482 (inst sub offset offset index)
486 (- (* (- instance-slots-offset 4) n-word-bytes)
487 instance-pointer-lowtag))
488 (inst lddf (complex-double-reg-real-tn value) object offset)
489 (inst add offset offset (* 2 n-word-bytes))
490 (inst lddf (complex-double-reg-imag-tn value) object offset)))
492 (define-vop (raw-instance-set/complex-double)
493 (:translate %raw-instance-set/complex-double)
495 (:args (object :scs (descriptor-reg))
496 (index :scs (any-reg))
497 (value :scs (complex-double-reg) :target result))
498 (:arg-types * positive-fixnum complex-double-float)
499 (:results (result :scs (complex-double-reg)))
500 (:result-types complex-double-float)
501 (:temporary (:scs (non-descriptor-reg)) offset)
503 (loadw offset object 0 instance-pointer-lowtag)
504 (inst srl offset offset n-widetag-bits)
505 (inst sll offset offset n-fixnum-tag-bits)
506 (inst sub offset offset index)
510 (- (* (- instance-slots-offset 4) n-word-bytes)
511 instance-pointer-lowtag))
512 (let ((value-real (complex-double-reg-real-tn value))
513 (result-real (complex-double-reg-real-tn result)))
514 (inst stdf value-real object offset)
515 (unless (location= result-real value-real)
516 (move-double-reg result-real value-real)))
517 (inst add offset offset (* 2 n-word-bytes))
518 (let ((value-imag (complex-double-reg-imag-tn value))
519 (result-imag (complex-double-reg-imag-tn result)))
520 (inst stdf value-imag object offset)
521 (unless (location= result-imag value-imag)
522 (move-double-reg result-imag value-imag)))))