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.
18 (:args
(object :scs
(descriptor-reg)))
19 (:info name offset lowtag
)
21 (:results
(result :scs
(descriptor-reg any-reg
)))
23 (loadw result object offset lowtag
)))
25 (define-vop (set-slot)
26 (:args
(object :scs
(descriptor-reg))
27 (value :scs
(descriptor-reg any-reg
)))
28 (:info name offset lowtag
)
32 (storew value object offset lowtag
)))
35 ;;;; Symbol hacking VOPs:
37 ;;; The compiler likes to be able to directly SET symbols.
38 (define-vop (set cell-set
)
39 (:variant symbol-value-slot other-pointer-lowtag
))
41 ;;; Do a cell ref with an error check for being unbound.
42 (define-vop (checked-cell-ref)
43 (:args
(object :scs
(descriptor-reg) :target obj-temp
))
44 (:results
(value :scs
(descriptor-reg any-reg
)))
47 (:save-p
:compute-only
)
48 (:temporary
(:scs
(descriptor-reg) :from
(:argument
0)) obj-temp
))
50 ;;; With SYMBOL-VALUE, we check that the value isn't the trap object.
51 ;;; So SYMBOL-VALUE of NIL is NIL.
52 (define-vop (symbol-value checked-cell-ref
)
53 (:translate symbol-value
)
55 (move obj-temp object
)
56 (loadw value obj-temp symbol-value-slot other-pointer-lowtag
)
57 (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp
)))
58 (inst cmpwi value unbound-marker-widetag
)
61 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
63 (define-vop (boundp-frob)
64 (:args
(object :scs
(descriptor-reg)))
68 (:temporary
(:scs
(descriptor-reg)) value
))
70 (define-vop (boundp boundp-frob
)
73 (loadw value object symbol-value-slot other-pointer-lowtag
)
74 (inst cmpwi value unbound-marker-widetag
)
75 (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 clrrwi res res
(1- n-lowtag-bits
))))
96 ;;;; Fdefinition (fdefn) objects.
98 (define-vop (fdefn-fun cell-ref
)
99 (:variant fdefn-fun-slot other-pointer-lowtag
))
101 (define-vop (safe-fdefn-fun)
102 (:args
(object :scs
(descriptor-reg) :target obj-temp
))
103 (:results
(value :scs
(descriptor-reg any-reg
)))
105 (:save-p
:compute-only
)
106 (:temporary
(:scs
(descriptor-reg) :from
(:argument
0)) obj-temp
)
108 (move obj-temp object
)
109 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag
)
110 (inst cmpw value null-tn
)
111 (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp
)))
112 (inst beq 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 cmpwi type simple-fun-header-widetag
)
126 ;;(inst mr lip function)
127 (inst addi lip function
128 (- (ash simple-fun-code-offset word-shift
) fun-pointer-lowtag
))
130 (inst lr lip
(make-fixup "closure_tramp" :foreign
))
131 (emit-label normal-fn
)
132 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
133 (storew function fdefn fdefn-fun-slot other-pointer-lowtag
)
134 (move result function
))))
136 (define-vop (fdefn-makunbound)
138 (:translate fdefn-makunbound
)
139 (:args
(fdefn :scs
(descriptor-reg) :target result
))
140 (:temporary
(:scs
(non-descriptor-reg)) temp
)
141 (:results
(result :scs
(descriptor-reg)))
143 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag
)
144 (inst lr temp
(make-fixup "undefined_tramp" :foreign
))
145 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
146 (move result fdefn
)))
150 ;;;; Binding and Unbinding.
152 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
153 ;;; the symbol on the binding stack and stuff the new value into the
157 (:args
(val :scs
(any-reg descriptor-reg
))
158 (symbol :scs
(descriptor-reg)))
159 (:temporary
(:scs
(descriptor-reg)) temp
)
161 (loadw temp symbol symbol-value-slot other-pointer-lowtag
)
162 (inst addi bsp-tn bsp-tn
(* 2 n-word-bytes
))
163 (storew temp bsp-tn
(- binding-value-slot binding-size
))
164 (storew symbol bsp-tn
(- binding-symbol-slot binding-size
))
165 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
169 (:temporary
(:scs
(descriptor-reg)) symbol value
)
171 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
172 (loadw value bsp-tn
(- binding-value-slot binding-size
))
173 (storew value symbol symbol-value-slot other-pointer-lowtag
)
174 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
175 (inst subi bsp-tn bsp-tn
(* 2 n-word-bytes
))))
178 (define-vop (unbind-to-here)
179 (:args
(arg :scs
(descriptor-reg any-reg
) :target where
))
180 (:temporary
(:scs
(any-reg) :from
(:argument
0)) where
)
181 (:temporary
(:scs
(descriptor-reg)) symbol value
)
183 (let ((loop (gen-label))
187 (inst cmpw where bsp-tn
)
191 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
192 (inst cmpwi symbol
0)
194 (loadw value bsp-tn
(- binding-value-slot binding-size
))
195 (storew value symbol symbol-value-slot other-pointer-lowtag
)
196 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
199 (inst subi bsp-tn bsp-tn
(* 2 n-word-bytes
))
200 (inst cmpw where bsp-tn
)
207 ;;;; Closure indexing.
209 (define-vop (closure-index-ref word-index-ref
)
210 (:variant closure-info-offset fun-pointer-lowtag
)
211 (:translate %closure-index-ref
))
213 (define-vop (funcallable-instance-info word-index-ref
)
214 (:variant funcallable-instance-info-offset fun-pointer-lowtag
)
215 (:translate %funcallable-instance-info
))
217 (define-vop (set-funcallable-instance-info word-index-set
)
218 (:variant funcallable-instance-info-offset fun-pointer-lowtag
)
219 (:translate %set-funcallable-instance-info
))
221 (define-vop (funcallable-instance-lexenv cell-ref
)
222 (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag
))
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
))
232 ;;;; Value Cell hackery.
234 (define-vop (value-cell-ref cell-ref
)
235 (:variant value-cell-value-slot other-pointer-lowtag
))
237 (define-vop (value-cell-set cell-set
)
238 (:variant value-cell-value-slot other-pointer-lowtag
))
242 ;;;; Instance hackery:
244 (define-vop (instance-length)
246 (:translate %instance-length
)
247 (:args
(struct :scs
(descriptor-reg)))
248 (:temporary
(:scs
(non-descriptor-reg)) temp
)
249 (:results
(res :scs
(unsigned-reg)))
250 (:result-types positive-fixnum
)
252 (loadw temp struct
0 instance-pointer-lowtag
)
253 (inst srwi res temp n-widetag-bits
)))
255 (define-vop (instance-ref slot-ref
)
256 (:variant instance-slots-offset instance-pointer-lowtag
)
258 (:translate %instance-ref
)
259 (:arg-types
* (:constant index
)))
262 (define-vop (instance-set slot-set
)
264 (:translate %instance-set
)
265 (:variant instance-slots-offset instance-pointer-lowtag
)
266 (:arg-types instance
(:constant index
) *))
268 (define-vop (instance-index-ref word-index-ref
)
270 (:translate %instance-ref
)
271 (:variant instance-slots-offset instance-pointer-lowtag
)
272 (:arg-types instance positive-fixnum
))
274 (define-vop (instance-index-set word-index-set
)
276 (:translate %instance-set
)
277 (:variant instance-slots-offset instance-pointer-lowtag
)
278 (:arg-types instance positive-fixnum
*))
283 ;;;; Code object frobbing.
285 (define-vop (code-header-ref word-index-ref
)
286 (:translate code-header-ref
)
288 (:variant
0 other-pointer-lowtag
))
290 (define-vop (code-header-set word-index-set
)
291 (:translate code-header-set
)
293 (:variant
0 other-pointer-lowtag
))
297 ;;;; raw instance slot accessors
299 (define-vop (raw-instance-ref/word
)
300 (:translate %raw-instance-ref
/word
)
302 (:args
(object :scs
(descriptor-reg))
303 (index :scs
(any-reg)))
304 (:arg-types
* positive-fixnum
)
305 (:results
(value :scs
(unsigned-reg)))
306 (:temporary
(:scs
(non-descriptor-reg)) offset
)
307 (:result-types unsigned-num
)
309 (loadw offset object
0 instance-pointer-lowtag
)
310 (inst srwi offset offset n-widetag-bits
)
311 (inst slwi offset offset
2)
312 (inst subf offset index offset
)
316 (- (* (1- instance-slots-offset
) n-word-bytes
)
317 instance-pointer-lowtag
))
318 (inst lwzx value object offset
)))
320 (define-vop (raw-instance-set/word
)
321 (:translate %raw-instance-set
/word
)
323 (:args
(object :scs
(descriptor-reg))
324 (index :scs
(any-reg))
325 (value :scs
(unsigned-reg)))
326 (:arg-types
* positive-fixnum unsigned-num
)
327 (:results
(result :scs
(unsigned-reg)))
328 (:temporary
(:scs
(non-descriptor-reg)) offset
)
329 (:result-types unsigned-num
)
331 (loadw offset object
0 instance-pointer-lowtag
)
332 (inst srwi offset offset n-widetag-bits
)
333 (inst slwi offset offset
2)
334 (inst subf offset index offset
)
338 (- (* (1- instance-slots-offset
) n-word-bytes
)
339 instance-pointer-lowtag
))
340 (inst stwx value object offset
)
341 (move result value
)))
343 (define-vop (raw-instance-ref/single
)
344 (:translate %raw-instance-ref
/single
)
346 (:args
(object :scs
(descriptor-reg))
347 (index :scs
(any-reg)))
348 (:arg-types
* positive-fixnum
)
349 (:results
(value :scs
(single-reg)))
350 (:temporary
(:scs
(non-descriptor-reg)) offset
)
351 (:result-types single-float
)
353 (loadw offset object
0 instance-pointer-lowtag
)
354 (inst srwi offset offset n-widetag-bits
)
355 (inst slwi offset offset
2)
356 (inst subf offset index offset
)
360 (- (* (1- instance-slots-offset
) n-word-bytes
)
361 instance-pointer-lowtag
))
362 (inst lfsx value object offset
)))
364 (define-vop (raw-instance-set/single
)
365 (:translate %raw-instance-set
/single
)
367 (:args
(object :scs
(descriptor-reg))
368 (index :scs
(any-reg))
369 (value :scs
(single-reg) :target result
))
370 (:arg-types
* positive-fixnum single-float
)
371 (:results
(result :scs
(single-reg)))
372 (:result-types single-float
)
373 (:temporary
(:scs
(non-descriptor-reg)) offset
)
375 (loadw offset object
0 instance-pointer-lowtag
)
376 (inst srwi offset offset n-widetag-bits
)
377 (inst slwi offset offset
2)
378 (inst subf offset index offset
)
382 (- (* (1- instance-slots-offset
) n-word-bytes
)
383 instance-pointer-lowtag
))
384 (inst stfsx value object offset
)
385 (unless (location= result value
)
386 (inst frsp result value
))))
388 (define-vop (raw-instance-ref/double
)
389 (:translate %raw-instance-ref
/double
)
391 (:args
(object :scs
(descriptor-reg))
392 (index :scs
(any-reg)))
393 (:arg-types
* positive-fixnum
)
394 (:results
(value :scs
(double-reg)))
395 (:temporary
(:scs
(non-descriptor-reg)) offset
)
396 (:result-types double-float
)
398 (loadw offset object
0 instance-pointer-lowtag
)
399 (inst srwi offset offset n-widetag-bits
)
400 (inst slwi offset offset
2)
401 (inst subf offset index offset
)
405 (- (* (- instance-slots-offset
2) n-word-bytes
)
406 instance-pointer-lowtag
))
407 (inst lfdx value object offset
)))
409 (define-vop (raw-instance-set/double
)
410 (:translate %raw-instance-set
/double
)
412 (:args
(object :scs
(descriptor-reg))
413 (index :scs
(any-reg))
414 (value :scs
(double-reg) :target result
))
415 (:arg-types
* positive-fixnum double-float
)
416 (:results
(result :scs
(double-reg)))
417 (:result-types double-float
)
418 (:temporary
(:scs
(non-descriptor-reg)) offset
)
420 (loadw offset object
0 instance-pointer-lowtag
)
421 (inst srwi offset offset n-widetag-bits
)
422 (inst slwi offset offset
2)
423 (inst subf offset index offset
)
427 (- (* (- instance-slots-offset
2) n-word-bytes
)
428 instance-pointer-lowtag
))
429 (inst stfdx value object offset
)
430 (unless (location= result value
)
431 (inst fmr result value
))))
433 (define-vop (raw-instance-ref/complex-single
)
434 (:translate %raw-instance-ref
/complex-single
)
436 (:args
(object :scs
(descriptor-reg))
437 (index :scs
(any-reg)))
438 (:arg-types
* positive-fixnum
)
439 (:results
(value :scs
(complex-single-reg)))
440 (:temporary
(:scs
(non-descriptor-reg)) offset
)
441 (:result-types complex-single-float
)
443 (loadw offset object
0 instance-pointer-lowtag
)
444 (inst srwi offset offset n-widetag-bits
)
445 (inst slwi offset offset
2)
446 (inst subf offset index offset
)
450 (- (* (- instance-slots-offset
2) n-word-bytes
)
451 instance-pointer-lowtag
))
452 (inst lfsx
(complex-single-reg-real-tn value
) object offset
)
453 (inst addi offset offset n-word-bytes
)
454 (inst lfsx
(complex-single-reg-imag-tn value
) object offset
)))
456 (define-vop (raw-instance-set/complex-single
)
457 (:translate %raw-instance-set
/complex-single
)
459 (:args
(object :scs
(descriptor-reg))
460 (index :scs
(any-reg))
461 (value :scs
(complex-single-reg) :target result
))
462 (:arg-types
* positive-fixnum complex-single-float
)
463 (:results
(result :scs
(complex-single-reg)))
464 (:result-types complex-single-float
)
465 (:temporary
(:scs
(non-descriptor-reg)) offset
)
467 (loadw offset object
0 instance-pointer-lowtag
)
468 (inst srwi offset offset n-widetag-bits
)
469 (inst slwi offset offset
2)
470 (inst subf offset index offset
)
474 (- (* (- instance-slots-offset
2) n-word-bytes
)
475 instance-pointer-lowtag
))
476 (let ((value-real (complex-single-reg-real-tn value
))
477 (result-real (complex-single-reg-real-tn result
)))
478 (inst stfsx value-real object offset
)
479 (unless (location= result-real value-real
)
480 (inst frsp result-real value-real
)))
481 (inst addi offset offset n-word-bytes
)
482 (let ((value-imag (complex-single-reg-imag-tn value
))
483 (result-imag (complex-single-reg-imag-tn result
)))
484 (inst stfsx value-imag object offset
)
485 (unless (location= result-imag value-imag
)
486 (inst frsp result-imag value-imag
)))))
488 (define-vop (raw-instance-ref/complex-double
)
489 (:translate %raw-instance-ref
/complex-double
)
491 (:args
(object :scs
(descriptor-reg))
492 (index :scs
(any-reg)))
493 (:arg-types
* positive-fixnum
)
494 (:results
(value :scs
(complex-double-reg)))
495 (:temporary
(:scs
(non-descriptor-reg)) offset
)
496 (:result-types complex-double-float
)
498 (loadw offset object
0 instance-pointer-lowtag
)
499 (inst srwi offset offset n-widetag-bits
)
500 (inst slwi offset offset
2)
501 (inst subf offset index offset
)
505 (- (* (- instance-slots-offset
4) n-word-bytes
)
506 instance-pointer-lowtag
))
507 (inst lfdx
(complex-double-reg-real-tn value
) object offset
)
508 (inst addi offset offset
(* 2 n-word-bytes
))
509 (inst lfdx
(complex-double-reg-imag-tn value
) object offset
)))
511 (define-vop (raw-instance-set/complex-double
)
512 (:translate %raw-instance-set
/complex-double
)
514 (:args
(object :scs
(descriptor-reg))
515 (index :scs
(any-reg))
516 (value :scs
(complex-double-reg) :target result
))
517 (:arg-types
* positive-fixnum complex-double-float
)
518 (:results
(result :scs
(complex-double-reg)))
519 (:result-types complex-double-float
)
520 (:temporary
(:scs
(non-descriptor-reg)) offset
)
522 (loadw offset object
0 instance-pointer-lowtag
)
523 (inst srwi offset offset n-widetag-bits
)
524 (inst slwi offset offset
2)
525 (inst subf offset index offset
)
529 (- (* (- instance-slots-offset
4) n-word-bytes
)
530 instance-pointer-lowtag
))
531 (let ((value-real (complex-double-reg-real-tn value
))
532 (result-real (complex-double-reg-real-tn result
)))
533 (inst stfdx value-real object offset
)
534 (unless (location= result-real value-real
)
535 (inst fmr result-real value-real
)))
536 (inst addi offset offset
(* 2 n-word-bytes
))
537 (let ((value-imag (complex-double-reg-imag-tn value
))
538 (result-imag (complex-double-reg-imag-tn result
)))
539 (inst stfdx value-imag object offset
)
540 (unless (location= result-imag value-imag
)
541 (inst fmr result-imag value-imag
)))))