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 ;;;; FDEFINITION (fdefn) objects.
97 (define-vop (fdefn-fun cell-ref
)
98 (:variant fdefn-fun-slot other-pointer-lowtag
))
100 (define-vop (safe-fdefn-fun)
101 (:args
(object :scs
(descriptor-reg) :target obj-temp
))
102 (:results
(value :scs
(descriptor-reg any-reg
)))
104 (:save-p
:compute-only
)
105 (:temporary
(:scs
(descriptor-reg) :from
(:argument
0)) obj-temp
)
107 (move obj-temp object
)
108 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag
)
109 (inst cmp value null-tn
)
110 (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp
)))
111 (inst b
:eq err-lab
))
114 (define-vop (set-fdefn-fun)
116 (:translate
(setf fdefn-fun
))
117 (:args
(function :scs
(descriptor-reg) :target result
)
118 (fdefn :scs
(descriptor-reg)))
119 (:temporary
(:scs
(interior-reg)) lip
)
120 (:temporary
(:scs
(non-descriptor-reg)) type
)
121 (:results
(result :scs
(descriptor-reg)))
123 (let ((normal-fn (gen-label)))
124 (load-type type function
(- fun-pointer-lowtag
))
125 (inst cmp type simple-fun-header-widetag
)
126 (inst b
:eq normal-fn
)
127 (inst move lip function
)
128 (inst li lip
(make-fixup "closure_tramp" :foreign
))
129 (emit-label normal-fn
)
130 (storew function fdefn fdefn-fun-slot other-pointer-lowtag
)
131 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
132 (move result function
))))
134 (define-vop (fdefn-makunbound)
136 (:translate fdefn-makunbound
)
137 (:args
(fdefn :scs
(descriptor-reg) :target result
))
138 (:temporary
(:scs
(non-descriptor-reg)) temp
)
139 (:results
(result :scs
(descriptor-reg)))
141 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag
)
142 (inst li temp
(make-fixup "undefined_tramp" :foreign
))
143 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
144 (move result fdefn
)))
148 ;;;; Binding and Unbinding.
150 ;;; Establish VAL as a binding for SYMBOL. Save the old value and the
151 ;;; symbol on the binding stack and stuff the new value into the
154 (:args
(val :scs
(any-reg descriptor-reg
))
155 (symbol :scs
(descriptor-reg)))
156 (:temporary
(:scs
(descriptor-reg)) temp
)
158 (loadw temp symbol symbol-value-slot other-pointer-lowtag
)
159 (inst add bsp-tn bsp-tn
(* 2 n-word-bytes
))
160 (storew temp bsp-tn
(- binding-value-slot binding-size
))
161 (storew symbol bsp-tn
(- binding-symbol-slot binding-size
))
162 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
165 (:temporary
(:scs
(descriptor-reg)) symbol value
)
167 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
168 (loadw value bsp-tn
(- binding-value-slot binding-size
))
169 (storew value symbol symbol-value-slot other-pointer-lowtag
)
170 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
171 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
172 (inst sub bsp-tn bsp-tn
(* 2 n-word-bytes
))))
174 (define-vop (unbind-to-here)
175 (:args
(arg :scs
(descriptor-reg any-reg
) :target where
))
176 (:temporary
(:scs
(any-reg) :from
(:argument
0)) where
)
177 (:temporary
(:scs
(descriptor-reg)) symbol value
)
179 (let ((loop (gen-label))
183 (inst cmp where bsp-tn
)
188 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
191 (loadw value bsp-tn
(- binding-value-slot binding-size
))
192 (storew value symbol symbol-value-slot other-pointer-lowtag
)
193 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
196 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
197 (inst sub bsp-tn bsp-tn
(* 2 n-word-bytes
))
198 (inst cmp where bsp-tn
)
204 ;;;; closure indexing.
206 (define-vop (closure-index-ref word-index-ref
)
207 (:variant closure-info-offset fun-pointer-lowtag
)
208 (:translate %closure-index-ref
))
210 (define-vop (funcallable-instance-info word-index-ref
)
211 (:variant funcallable-instance-info-offset fun-pointer-lowtag
)
212 (:translate %funcallable-instance-info
))
214 (define-vop (set-funcallable-instance-info word-index-set
)
215 (:variant funcallable-instance-info-offset fun-pointer-lowtag
)
216 (:translate %set-funcallable-instance-info
))
218 (define-vop (closure-ref slot-ref
)
219 (:variant closure-info-offset fun-pointer-lowtag
))
221 (define-vop (closure-init slot-set
)
222 (:variant closure-info-offset fun-pointer-lowtag
))
224 ;;;; value cell hackery.
226 (define-vop (value-cell-ref cell-ref
)
227 (:variant value-cell-value-slot other-pointer-lowtag
))
229 (define-vop (value-cell-set cell-set
)
230 (:variant value-cell-value-slot other-pointer-lowtag
))
232 ;;;; instance hackery:
234 (define-vop (instance-length)
236 (:translate %instance-length
)
237 (:args
(struct :scs
(descriptor-reg)))
238 (:temporary
(:scs
(non-descriptor-reg)) temp
)
239 (:results
(res :scs
(unsigned-reg)))
240 (:result-types positive-fixnum
)
242 (loadw temp struct
0 instance-pointer-lowtag
)
243 (inst srl res temp n-widetag-bits
)))
245 (define-vop (instance-index-ref word-index-ref
)
247 (:translate %instance-ref
)
248 (:variant instance-slots-offset instance-pointer-lowtag
)
249 (:arg-types
* positive-fixnum
))
251 (define-vop (instance-index-set word-index-set
)
253 (:translate %instance-set
)
254 (:variant instance-slots-offset instance-pointer-lowtag
)
255 (:arg-types
* positive-fixnum
*))
257 ;;;; Code object frobbing.
259 (define-vop (code-header-ref word-index-ref
)
260 (:translate code-header-ref
)
262 (:variant
0 other-pointer-lowtag
))
264 (define-vop (code-header-set word-index-set
)
265 (:translate code-header-set
)
267 (:variant
0 other-pointer-lowtag
))
271 ;;;; raw instance slot accessors
273 (define-vop (raw-instance-ref/word
)
274 (:translate %raw-instance-ref
/word
)
276 (:args
(object :scs
(descriptor-reg))
277 (index :scs
(any-reg)))
278 (:arg-types
* positive-fixnum
)
279 (:results
(value :scs
(unsigned-reg)))
280 (:temporary
(:scs
(non-descriptor-reg)) offset
)
281 (:result-types unsigned-num
)
283 (loadw offset object
0 instance-pointer-lowtag
)
284 (inst srl offset offset n-widetag-bits
)
285 (inst sll offset offset
2)
286 (inst sub offset offset index
)
290 (- (* (1- instance-slots-offset
) n-word-bytes
)
291 instance-pointer-lowtag
))
292 (inst ld value object offset
)))
294 (define-vop (raw-instance-set/word
)
295 (:translate %raw-instance-set
/word
)
297 (:args
(object :scs
(descriptor-reg))
298 (index :scs
(any-reg))
299 (value :scs
(unsigned-reg)))
300 (:arg-types
* positive-fixnum unsigned-num
)
301 (:results
(result :scs
(unsigned-reg)))
302 (:temporary
(:scs
(non-descriptor-reg)) offset
)
303 (:result-types unsigned-num
)
305 (loadw offset object
0 instance-pointer-lowtag
)
306 (inst srl offset offset n-widetag-bits
)
307 (inst sll offset offset
2)
308 (inst sub offset offset index
)
312 (- (* (1- instance-slots-offset
) n-word-bytes
)
313 instance-pointer-lowtag
))
314 (inst st value object offset
)
315 (move result value
)))
317 (define-vop (raw-instance-ref/single
)
318 (:translate %raw-instance-ref
/single
)
320 (:args
(object :scs
(descriptor-reg))
321 (index :scs
(any-reg)))
322 (:arg-types
* positive-fixnum
)
323 (:results
(value :scs
(single-reg)))
324 (:temporary
(:scs
(non-descriptor-reg)) offset
)
325 (:result-types single-float
)
327 (loadw offset object
0 instance-pointer-lowtag
)
328 (inst srl offset offset n-widetag-bits
)
329 (inst sll offset offset
2)
330 (inst sub offset offset index
)
334 (- (* (1- instance-slots-offset
) n-word-bytes
)
335 instance-pointer-lowtag
))
336 (inst ldf value object offset
)))
338 (define-vop (raw-instance-set/single
)
339 (:translate %raw-instance-set
/single
)
341 (:args
(object :scs
(descriptor-reg))
342 (index :scs
(any-reg))
343 (value :scs
(single-reg) :target result
))
344 (:arg-types
* positive-fixnum single-float
)
345 (:results
(result :scs
(single-reg)))
346 (:result-types single-float
)
347 (:temporary
(:scs
(non-descriptor-reg)) offset
)
349 (loadw offset object
0 instance-pointer-lowtag
)
350 (inst srl offset offset n-widetag-bits
)
351 (inst sll offset offset
2)
352 (inst sub offset offset index
)
356 (- (* (1- instance-slots-offset
) n-word-bytes
)
357 instance-pointer-lowtag
))
358 (inst stf value object offset
)
359 (unless (location= result value
)
360 (inst fmovs result value
))))
362 (define-vop (raw-instance-ref/double
)
363 (:translate %raw-instance-ref
/double
)
365 (:args
(object :scs
(descriptor-reg))
366 (index :scs
(any-reg)))
367 (:arg-types
* positive-fixnum
)
368 (:results
(value :scs
(double-reg)))
369 (:temporary
(:scs
(non-descriptor-reg)) offset
)
370 (:result-types double-float
)
372 (loadw offset object
0 instance-pointer-lowtag
)
373 (inst srl offset offset n-widetag-bits
)
374 (inst sll offset offset
2)
375 (inst sub offset offset index
)
379 (- (* (- instance-slots-offset
2) n-word-bytes
)
380 instance-pointer-lowtag
))
381 (inst lddf value object offset
)))
383 (define-vop (raw-instance-set/double
)
384 (:translate %raw-instance-set
/double
)
386 (:args
(object :scs
(descriptor-reg))
387 (index :scs
(any-reg))
388 (value :scs
(double-reg) :target result
))
389 (:arg-types
* positive-fixnum double-float
)
390 (:results
(result :scs
(double-reg)))
391 (:result-types double-float
)
392 (:temporary
(:scs
(non-descriptor-reg)) offset
)
394 (loadw offset object
0 instance-pointer-lowtag
)
395 (inst srl offset offset n-widetag-bits
)
396 (inst sll offset offset
2)
397 (inst sub offset offset index
)
401 (- (* (- instance-slots-offset
2) n-word-bytes
)
402 instance-pointer-lowtag
))
403 (inst stdf value object offset
)
404 (unless (location= result value
)
405 (move-double-reg result value
))))
407 (define-vop (raw-instance-ref/complex-single
)
408 (:translate %raw-instance-ref
/complex-single
)
410 (:args
(object :scs
(descriptor-reg))
411 (index :scs
(any-reg)))
412 (:arg-types
* positive-fixnum
)
413 (:results
(value :scs
(complex-single-reg)))
414 (:temporary
(:scs
(non-descriptor-reg)) offset
)
415 (:result-types complex-single-float
)
417 (loadw offset object
0 instance-pointer-lowtag
)
418 (inst srl offset offset n-widetag-bits
)
419 (inst sll offset offset
2)
420 (inst sub offset offset index
)
424 (- (* (- instance-slots-offset
2) n-word-bytes
)
425 instance-pointer-lowtag
))
426 (inst ldf
(complex-single-reg-real-tn value
) object offset
)
427 (inst add offset offset n-word-bytes
)
428 (inst ldf
(complex-single-reg-imag-tn value
) object offset
)))
430 (define-vop (raw-instance-set/complex-single
)
431 (:translate %raw-instance-set
/complex-single
)
433 (:args
(object :scs
(descriptor-reg))
434 (index :scs
(any-reg))
435 (value :scs
(complex-single-reg) :target result
))
436 (:arg-types
* positive-fixnum complex-single-float
)
437 (:results
(result :scs
(complex-single-reg)))
438 (:result-types complex-single-float
)
439 (:temporary
(:scs
(non-descriptor-reg)) offset
)
441 (loadw offset object
0 instance-pointer-lowtag
)
442 (inst srl offset offset n-widetag-bits
)
443 (inst sll offset offset
2)
444 (inst sub offset offset index
)
448 (- (* (- instance-slots-offset
2) n-word-bytes
)
449 instance-pointer-lowtag
))
450 (let ((value-real (complex-single-reg-real-tn value
))
451 (result-real (complex-single-reg-real-tn result
)))
452 (inst stf value-real object offset
)
453 (unless (location= result-real value-real
)
454 (inst fmovs result-real value-real
)))
455 (inst add offset offset n-word-bytes
)
456 (let ((value-imag (complex-single-reg-imag-tn value
))
457 (result-imag (complex-single-reg-imag-tn result
)))
458 (inst stf value-imag object offset
)
459 (unless (location= result-imag value-imag
)
460 (inst fmovs result-imag value-imag
)))))
462 (define-vop (raw-instance-ref/complex-double
)
463 (:translate %raw-instance-ref
/complex-double
)
465 (:args
(object :scs
(descriptor-reg))
466 (index :scs
(any-reg)))
467 (:arg-types
* positive-fixnum
)
468 (:results
(value :scs
(complex-double-reg)))
469 (:temporary
(:scs
(non-descriptor-reg)) offset
)
470 (:result-types complex-double-float
)
472 (loadw offset object
0 instance-pointer-lowtag
)
473 (inst srl offset offset n-widetag-bits
)
474 (inst sll offset offset
2)
475 (inst sub offset offset index
)
479 (- (* (- instance-slots-offset
4) n-word-bytes
)
480 instance-pointer-lowtag
))
481 (inst lddf
(complex-double-reg-real-tn value
) object offset
)
482 (inst add offset offset
(* 2 n-word-bytes
))
483 (inst lddf
(complex-double-reg-imag-tn value
) object offset
)))
485 (define-vop (raw-instance-set/complex-double
)
486 (:translate %raw-instance-set
/complex-double
)
488 (:args
(object :scs
(descriptor-reg))
489 (index :scs
(any-reg))
490 (value :scs
(complex-double-reg) :target result
))
491 (:arg-types
* positive-fixnum complex-double-float
)
492 (:results
(result :scs
(complex-double-reg)))
493 (:result-types complex-double-float
)
494 (:temporary
(:scs
(non-descriptor-reg)) offset
)
496 (loadw offset object
0 instance-pointer-lowtag
)
497 (inst srl offset offset n-widetag-bits
)
498 (inst sll offset offset
2)
499 (inst sub offset offset index
)
503 (- (* (- instance-slots-offset
4) n-word-bytes
)
504 instance-pointer-lowtag
))
505 (let ((value-real (complex-double-reg-real-tn value
))
506 (result-real (complex-double-reg-real-tn result
)))
507 (inst stdf value-real object offset
)
508 (unless (location= result-real value-real
)
509 (move-double-reg result-real value-real
)))
510 (inst add offset offset
(* 2 n-word-bytes
))
511 (let ((value-imag (complex-double-reg-imag-tn value
))
512 (result-imag (complex-double-reg-imag-tn result
)))
513 (inst stdf value-imag object offset
)
514 (unless (location= result-imag value-imag
)
515 (move-double-reg result-imag value-imag
)))))