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 (define-vop (init-slot set-slot
)
34 (:info name dx-p offset lowtag
)
37 ;;;; Symbol hacking VOPs:
39 ;;; The compiler likes to be able to directly SET symbols.
40 (define-vop (set cell-set
)
41 (:variant symbol-value-slot other-pointer-lowtag
))
43 ;;; Do a cell ref with an error check for being unbound.
44 (define-vop (checked-cell-ref)
45 (:args
(object :scs
(descriptor-reg) :target obj-temp
))
46 (:results
(value :scs
(descriptor-reg any-reg
)))
49 (:save-p
:compute-only
)
50 (:temporary
(:scs
(descriptor-reg) :from
(:argument
0)) obj-temp
))
52 ;;; With Symbol-Value, we check that the value isn't the trap object.
53 ;;; So Symbol-Value of NIL is NIL.
54 (define-vop (symbol-value checked-cell-ref
)
57 (move obj-temp object
)
58 (loadw value obj-temp symbol-value-slot other-pointer-lowtag
)
59 (let ((err-lab (generate-error-code vop
'unbound-symbol-error obj-temp
)))
60 (inst cmp value unbound-marker-widetag
)
64 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
66 (define-vop (boundp-frob)
67 (:args
(object :scs
(descriptor-reg)))
71 (:temporary
(:scs
(descriptor-reg)) value
))
73 (define-vop (boundp boundp-frob
)
76 (loadw value object symbol-value-slot other-pointer-lowtag
)
77 (inst cmp value unbound-marker-widetag
)
78 (inst b
(if not-p
:eq
:ne
) target
)
81 (define-vop (fast-symbol-value cell-ref
)
82 (:variant symbol-value-slot other-pointer-lowtag
)
86 (define-vop (symbol-hash)
88 (:translate symbol-hash
)
89 (:args
(symbol :scs
(descriptor-reg)))
90 (:results
(res :scs
(any-reg)))
91 (:result-types positive-fixnum
)
93 ;; The symbol-hash slot of NIL holds NIL because it is also the
94 ;; cdr slot, so we have to strip off the two low bits to make sure
95 ;; it is a fixnum. The lowtag selection magic that is required to
96 ;; ensure this is explained in the comment in objdef.lisp
97 (loadw res symbol symbol-hash-slot other-pointer-lowtag
)
98 (inst andn res res fixnum-tag-mask
)))
100 ;;; On unithreaded builds these are just copies of the non-global versions.
101 (define-vop (%set-symbol-global-value set
))
102 (define-vop (symbol-global-value symbol-value
)
103 (:translate sym-global-val
))
104 (define-vop (fast-symbol-global-value fast-symbol-value
)
105 (:translate sym-global-val
))
107 ;;;; FDEFINITION (fdefn) objects.
108 (define-vop (fdefn-fun cell-ref
)
109 (:variant fdefn-fun-slot other-pointer-lowtag
))
111 (define-vop (safe-fdefn-fun)
112 (:translate safe-fdefn-fun
)
114 (:args
(object :scs
(descriptor-reg) :target obj-temp
))
115 (:results
(value :scs
(descriptor-reg any-reg
)))
117 (:save-p
:compute-only
)
118 (:temporary
(:scs
(descriptor-reg) :from
(:argument
0)) obj-temp
)
120 (move obj-temp object
)
121 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag
)
122 (inst cmp value null-tn
)
123 (let ((err-lab (generate-error-code vop
'undefined-fun-error obj-temp
)))
124 (inst b
:eq err-lab
))
127 (define-vop (set-fdefn-fun)
129 (:translate
(setf fdefn-fun
))
130 (:args
(function :scs
(descriptor-reg) :target result
)
131 (fdefn :scs
(descriptor-reg)))
132 (:temporary
(:scs
(interior-reg)) lip
)
133 (:temporary
(:scs
(non-descriptor-reg)) type
)
134 (:results
(result :scs
(descriptor-reg)))
136 (let ((normal-fn (gen-label)))
137 (load-type type function
(- fun-pointer-lowtag
))
138 (inst cmp type simple-fun-widetag
)
139 (inst b
:eq normal-fn
)
140 (inst move lip function
)
141 (inst li lip
(make-fixup 'closure-tramp
:assembly-routine
))
142 (emit-label normal-fn
)
143 (storew function fdefn fdefn-fun-slot other-pointer-lowtag
)
144 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
145 (move result function
))))
147 (define-vop (fdefn-makunbound)
149 (:translate fdefn-makunbound
)
150 (:args
(fdefn :scs
(descriptor-reg) :target result
))
151 (:temporary
(:scs
(non-descriptor-reg)) temp
)
152 (:results
(result :scs
(descriptor-reg)))
154 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag
)
155 (inst li temp
(make-fixup 'undefined-tramp
:assembly-routine
))
156 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
157 (move result fdefn
)))
161 ;;;; Binding and Unbinding.
163 ;;; Establish VAL as a binding for SYMBOL. Save the old value and the
164 ;;; symbol on the binding stack and stuff the new value into the
167 ;;; See the "Chapter 9: Specials" of the SBCL Internals Manual.
169 (define-vop (dynbind)
170 (:args
(val :scs
(any-reg descriptor-reg
))
171 (symbol :scs
(descriptor-reg)))
172 (:temporary
(:scs
(descriptor-reg)) temp
)
174 (loadw temp symbol symbol-value-slot other-pointer-lowtag
)
175 (inst add bsp-tn bsp-tn
(* 2 n-word-bytes
))
176 (storew temp bsp-tn
(- binding-value-slot binding-size
))
177 (storew symbol bsp-tn
(- binding-symbol-slot binding-size
))
178 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
181 (:temporary
(:scs
(descriptor-reg)) symbol value
)
183 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
184 (loadw value bsp-tn
(- binding-value-slot binding-size
))
185 (storew value symbol symbol-value-slot other-pointer-lowtag
)
186 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
187 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
188 (inst sub bsp-tn bsp-tn
(* 2 n-word-bytes
))))
190 (define-vop (unbind-to-here)
191 (:args
(arg :scs
(descriptor-reg any-reg
) :target where
))
192 (:temporary
(:scs
(any-reg) :from
(:argument
0)) where
)
193 (:temporary
(:scs
(descriptor-reg)) symbol value
)
195 (let ((loop (gen-label))
199 (inst cmp where bsp-tn
)
204 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
207 (loadw value bsp-tn
(- binding-value-slot binding-size
))
208 (storew value symbol symbol-value-slot other-pointer-lowtag
)
209 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
212 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
213 (inst sub bsp-tn bsp-tn
(* 2 n-word-bytes
))
214 (inst cmp where bsp-tn
)
220 ;;;; closure indexing.
222 (define-vop (closure-index-ref word-index-ref
)
223 (:variant closure-info-offset fun-pointer-lowtag
)
224 (:translate %closure-index-ref
))
226 (define-vop (funcallable-instance-info word-index-ref
)
227 (:variant funcallable-instance-info-offset fun-pointer-lowtag
)
228 (:translate %funcallable-instance-info
))
230 (define-vop (set-funcallable-instance-info word-index-set
)
231 (:variant funcallable-instance-info-offset fun-pointer-lowtag
)
232 (:translate %set-funcallable-instance-info
))
234 (define-vop (closure-ref slot-ref
)
235 (:variant closure-info-offset fun-pointer-lowtag
))
237 (define-vop (closure-init slot-set
)
238 (:variant closure-info-offset fun-pointer-lowtag
))
240 (define-vop (closure-init-from-fp)
241 (:args
(object :scs
(descriptor-reg)))
244 (storew cfp-tn object
(+ closure-info-offset offset
) fun-pointer-lowtag
)))
246 ;;;; value cell hackery.
248 (define-vop (value-cell-ref cell-ref
)
249 (:variant value-cell-value-slot other-pointer-lowtag
))
251 (define-vop (value-cell-set cell-set
)
252 (:variant value-cell-value-slot other-pointer-lowtag
))
254 ;;;; instance hackery:
256 (define-vop (instance-length)
258 (:translate %instance-length
)
259 (:args
(struct :scs
(descriptor-reg)))
260 (:temporary
(:scs
(non-descriptor-reg)) temp
)
261 (:results
(res :scs
(unsigned-reg)))
262 (:result-types positive-fixnum
)
264 (loadw temp struct
0 instance-pointer-lowtag
)
265 (inst srl res temp n-widetag-bits
)))
267 (define-vop (instance-index-ref word-index-ref
)
269 (:translate %instance-ref
)
270 (:variant instance-slots-offset instance-pointer-lowtag
)
271 (:arg-types
* positive-fixnum
))
273 (define-vop (instance-index-set word-index-set
)
275 (:translate %instance-set
)
276 (:variant instance-slots-offset instance-pointer-lowtag
)
277 (:arg-types
* positive-fixnum
*))
279 ;;;; Code object frobbing.
281 (define-vop (code-header-ref word-index-ref
)
282 (:translate code-header-ref
)
284 (:variant
0 other-pointer-lowtag
))
286 (define-vop (code-header-set word-index-set
)
287 (:translate code-header-set
)
289 (:variant
0 other-pointer-lowtag
))
293 ;;;; raw instance slot accessors
295 (define-vop (raw-instance-ref/word
)
296 (:translate %raw-instance-ref
/word
)
298 (:args
(object :scs
(descriptor-reg))
299 (index :scs
(any-reg)))
300 (:arg-types
* positive-fixnum
)
301 (:results
(value :scs
(unsigned-reg)))
302 (:temporary
(:scs
(non-descriptor-reg)) offset
)
303 (:result-types unsigned-num
)
305 (inst add offset index
(- (ash instance-slots-offset word-shift
)
306 instance-pointer-lowtag
))
307 (inst ld value object offset
)))
309 (define-vop (raw-instance-set/word
)
310 (:translate %raw-instance-set
/word
)
312 (:args
(object :scs
(descriptor-reg))
313 (index :scs
(any-reg))
314 (value :scs
(unsigned-reg)))
315 (:arg-types
* positive-fixnum unsigned-num
)
316 (:results
(result :scs
(unsigned-reg)))
317 (:temporary
(:scs
(non-descriptor-reg)) offset
)
318 (:result-types unsigned-num
)
320 (inst add offset index
(- (ash instance-slots-offset word-shift
)
321 instance-pointer-lowtag
))
322 (inst st value object offset
)
323 (move result value
)))
325 (define-vop (raw-instance-ref/single
)
326 (:translate %raw-instance-ref
/single
)
328 (:args
(object :scs
(descriptor-reg))
329 (index :scs
(any-reg)))
330 (:arg-types
* positive-fixnum
)
331 (:results
(value :scs
(single-reg)))
332 (:temporary
(:scs
(non-descriptor-reg)) offset
)
333 (:result-types single-float
)
335 (inst add offset index
(- (ash instance-slots-offset word-shift
)
336 instance-pointer-lowtag
))
337 (inst ldf value object offset
)))
339 (define-vop (raw-instance-set/single
)
340 (:translate %raw-instance-set
/single
)
342 (:args
(object :scs
(descriptor-reg))
343 (index :scs
(any-reg))
344 (value :scs
(single-reg) :target result
))
345 (:arg-types
* positive-fixnum single-float
)
346 (:results
(result :scs
(single-reg)))
347 (:result-types single-float
)
348 (:temporary
(:scs
(non-descriptor-reg)) offset
)
350 (inst add offset index
(- (ash instance-slots-offset word-shift
)
351 instance-pointer-lowtag
))
352 (inst stf value object offset
)
353 (unless (location= result value
)
354 (inst fmovs result value
))))
356 (define-vop (raw-instance-ref/double
)
357 (:translate %raw-instance-ref
/double
)
359 (:args
(object :scs
(descriptor-reg))
360 (index :scs
(any-reg)))
361 (:arg-types
* positive-fixnum
)
362 (:results
(value :scs
(double-reg)))
363 (:temporary
(:scs
(non-descriptor-reg)) offset
)
364 (:result-types double-float
)
366 (inst add offset index
(- (ash instance-slots-offset word-shift
)
367 instance-pointer-lowtag
))
368 (inst lddf value object offset
)))
370 (define-vop (raw-instance-set/double
)
371 (:translate %raw-instance-set
/double
)
373 (:args
(object :scs
(descriptor-reg))
374 (index :scs
(any-reg))
375 (value :scs
(double-reg) :target result
))
376 (:arg-types
* positive-fixnum double-float
)
377 (:results
(result :scs
(double-reg)))
378 (:result-types double-float
)
379 (:temporary
(:scs
(non-descriptor-reg)) offset
)
381 (inst add offset index
(- (ash instance-slots-offset word-shift
)
382 instance-pointer-lowtag
))
383 (inst stdf value object offset
)
384 (unless (location= result value
)
385 (move-double-reg result value
))))
387 (define-vop (raw-instance-ref/complex-single
)
388 (:translate %raw-instance-ref
/complex-single
)
390 (:args
(object :scs
(descriptor-reg))
391 (index :scs
(any-reg)))
392 (:arg-types
* positive-fixnum
)
393 (:results
(value :scs
(complex-single-reg)))
394 (:temporary
(:scs
(non-descriptor-reg)) offset
)
395 (:result-types complex-single-float
)
397 (inst add offset index
(- (ash instance-slots-offset word-shift
)
398 instance-pointer-lowtag
))
399 (inst ldf
(complex-single-reg-real-tn value
) object offset
)
400 (inst add offset offset n-word-bytes
)
401 (inst ldf
(complex-single-reg-imag-tn value
) object offset
)))
403 (define-vop (raw-instance-set/complex-single
)
404 (:translate %raw-instance-set
/complex-single
)
406 (:args
(object :scs
(descriptor-reg))
407 (index :scs
(any-reg))
408 (value :scs
(complex-single-reg) :target result
))
409 (:arg-types
* positive-fixnum complex-single-float
)
410 (:results
(result :scs
(complex-single-reg)))
411 (:result-types complex-single-float
)
412 (:temporary
(:scs
(non-descriptor-reg)) offset
)
414 (inst add offset index
(- (ash instance-slots-offset word-shift
)
415 instance-pointer-lowtag
))
416 (let ((value-real (complex-single-reg-real-tn value
))
417 (result-real (complex-single-reg-real-tn result
)))
418 (inst stf value-real object offset
)
419 (unless (location= result-real value-real
)
420 (inst fmovs result-real value-real
)))
421 (inst add offset offset n-word-bytes
)
422 (let ((value-imag (complex-single-reg-imag-tn value
))
423 (result-imag (complex-single-reg-imag-tn result
)))
424 (inst stf value-imag object offset
)
425 (unless (location= result-imag value-imag
)
426 (inst fmovs result-imag value-imag
)))))
428 (define-vop (raw-instance-ref/complex-double
)
429 (:translate %raw-instance-ref
/complex-double
)
431 (:args
(object :scs
(descriptor-reg))
432 (index :scs
(any-reg)))
433 (:arg-types
* positive-fixnum
)
434 (:results
(value :scs
(complex-double-reg)))
435 (:temporary
(:scs
(non-descriptor-reg)) offset
)
436 (:result-types complex-double-float
)
438 (inst add offset index
(- (ash instance-slots-offset word-shift
)
439 instance-pointer-lowtag
))
440 (inst lddf
(complex-double-reg-real-tn value
) object offset
)
441 (inst add offset offset
(* 2 n-word-bytes
))
442 (inst lddf
(complex-double-reg-imag-tn value
) object offset
)))
444 (define-vop (raw-instance-set/complex-double
)
445 (:translate %raw-instance-set
/complex-double
)
447 (:args
(object :scs
(descriptor-reg))
448 (index :scs
(any-reg))
449 (value :scs
(complex-double-reg) :target result
))
450 (:arg-types
* positive-fixnum complex-double-float
)
451 (:results
(result :scs
(complex-double-reg)))
452 (:result-types complex-double-float
)
453 (:temporary
(:scs
(non-descriptor-reg)) offset
)
455 (inst add offset index
(- (ash instance-slots-offset word-shift
)
456 instance-pointer-lowtag
))
457 (let ((value-real (complex-double-reg-real-tn value
))
458 (result-real (complex-double-reg-real-tn result
)))
459 (inst stdf value-real object offset
)
460 (unless (location= result-real value-real
)
461 (move-double-reg result-real value-real
)))
462 (inst add offset offset
(* 2 n-word-bytes
))
463 (let ((value-imag (complex-double-reg-imag-tn value
))
464 (result-imag (complex-double-reg-imag-tn result
)))
465 (inst stdf value-imag object offset
)
466 (unless (location= result-imag value-imag
)
467 (move-double-reg result-imag value-imag
)))))