1 ;;;; the VM definition of various primitive memory access VOPs for
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)))
34 ;;;; Symbol hacking VOPs:
36 ;;; The compiler likes to be able to directly SET symbols.
37 (define-vop (set cell-set)
38 (:variant symbol-value-slot other-pointer-lowtag))
40 ;;; Do a cell ref with an error check for being unbound.
41 (define-vop (checked-cell-ref)
42 (:args (object :scs (descriptor-reg) :target obj-temp))
43 (:results (value :scs (descriptor-reg any-reg)))
46 (:save-p :compute-only)
47 (:temporary (:type random :scs (non-descriptor-reg)) temp)
48 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
50 ;;; With Symbol-Value, we check that the value isn't the trap object. So
51 ;;; Symbol-Value of NIL is NIL.
52 (define-vop (symbol-value checked-cell-ref)
53 (:translate symbol-value)
55 (move object obj-temp)
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 li unbound-marker-widetag temp)
59 (inst bc := nil value temp err-lab))))
61 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
62 (define-vop (boundp-frob)
63 (:args (object :scs (descriptor-reg)))
67 (:temporary (:scs (descriptor-reg)) value)
68 (:temporary (:type random :scs (non-descriptor-reg)) temp))
70 (define-vop (boundp boundp-frob)
73 (loadw value object symbol-value-slot other-pointer-lowtag)
74 (inst li unbound-marker-widetag temp)
75 (inst bc :<> not-p value temp 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 andcm res #b11 res)))
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 (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
111 (inst bc := nil value null-tn err-lab))))
113 (define-vop (set-fdefn-fun)
115 (:translate (setf fdefn-fun))
116 (:args (function :scs (descriptor-reg) :target result)
117 (fdefn :scs (descriptor-reg)))
118 (:temporary (:scs (interior-reg)) lip)
119 (:temporary (:scs (non-descriptor-reg)) type)
120 (:results (result :scs (descriptor-reg)))
122 (load-type type function (- fun-pointer-lowtag))
123 (inst addi (- simple-fun-header-widetag) type type)
124 (inst comb := type zero-tn normal-fn)
125 (inst addi (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
127 (inst li (make-fixup "closure_tramp" :foreign) lip)
129 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
130 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
131 (move function result)))
133 (define-vop (fdefn-makunbound)
135 (:translate fdefn-makunbound)
136 (:args (fdefn :scs (descriptor-reg) :target result))
137 (:temporary (:scs (non-descriptor-reg)) temp)
138 (:results (result :scs (descriptor-reg)))
140 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
141 (inst li (make-fixup "undefined_tramp" :foreign) temp)
142 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
143 (move fdefn result)))
147 ;;;; Binding and Unbinding.
149 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
150 ;;; the 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 addi (* binding-size n-word-bytes) bsp-tn bsp-tn)
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 addi (- (* binding-size n-word-bytes)) bsp-tn bsp-tn)))
174 (define-vop (unbind-to-here)
175 (:args (where :scs (descriptor-reg any-reg)))
176 (:temporary (:scs (descriptor-reg)) symbol value)
178 (inst comb := where bsp-tn done :nullify t)
179 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
182 (inst comb := symbol zero-tn skip)
183 (loadw value bsp-tn (- binding-value-slot binding-size))
184 (storew value symbol symbol-value-slot other-pointer-lowtag)
185 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
188 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
189 (inst addi (* -2 n-word-bytes) bsp-tn bsp-tn)
190 (inst comb :<> where bsp-tn loop :nullify t)
191 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
197 ;;;; Closure indexing.
199 (define-full-reffer closure-index-ref *
200 closure-info-offset fun-pointer-lowtag
201 (descriptor-reg any-reg) * %closure-index-ref)
203 (define-full-setter set-funcallable-instance-info *
204 funcallable-instance-info-offset fun-pointer-lowtag
205 (descriptor-reg any-reg) * %set-funcallable-instance-info)
207 (define-full-reffer funcallable-instance-info *
208 funcallable-instance-info-offset fun-pointer-lowtag
209 (descriptor-reg any-reg) * %funcallable-instance-info)
211 (define-vop (closure-ref slot-ref)
212 (:variant closure-info-offset fun-pointer-lowtag))
214 (define-vop (closure-init slot-set)
215 (:variant closure-info-offset fun-pointer-lowtag))
217 ;;;; Value Cell hackery.
219 (define-vop (value-cell-ref cell-ref)
220 (:variant value-cell-value-slot other-pointer-lowtag))
222 (define-vop (value-cell-set cell-set)
223 (:variant value-cell-value-slot other-pointer-lowtag))
227 ;;;; Instance hackery:
229 (define-vop (instance-length)
231 (:translate %instance-length)
232 (:args (struct :scs (descriptor-reg)))
233 (:results (res :scs (unsigned-reg)))
234 (:result-types positive-fixnum)
236 (loadw res struct 0 instance-pointer-lowtag)
237 (inst srl res n-widetag-bits res)))
239 (define-full-reffer instance-index-ref * instance-slots-offset
240 instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref)
242 (define-full-setter instance-index-set * instance-slots-offset
243 instance-pointer-lowtag (descriptor-reg any-reg) * %instance-set)
247 ;;;; Code object frobbing.
249 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
250 (descriptor-reg any-reg) * code-header-ref)
252 (define-full-setter code-header-set * 0 other-pointer-lowtag
253 (descriptor-reg any-reg) * code-header-set)
255 ;;;; raw instance slot accessors
257 (macrolet ((fix-storage (inc-offset-by)
259 (loadw offset object 0 instance-pointer-lowtag)
260 (inst srl offset n-widetag-bits offset)
261 (inst sll offset 2 offset)
262 (inst sub offset index offset)
263 (inst addi ,inc-offset-by offset offset)
264 (inst add offset object lip)))
265 (raw-instance ((type inc-offset-by set &optional complex)
267 (let ((name (symbolicate "RAW-INSTANCE-"
268 (if set "SET/" "REF/")
269 (if (eq type 'unsigned)
274 (if complex 'complex-single-float
277 (if complex 'complex-double-float
279 (t (symbolicate type "-NUM"))))
280 (type-reg (symbolicate (or complex type) "-REG")))
282 (:translate ,(symbolicate "%" name))
284 (:args (object :scs (descriptor-reg))
285 (index :scs (any-reg))
287 `((value :scs (,type-reg) :target result))))
288 (:arg-types * positive-fixnum ,@(if set `(,type-num)))
289 (:results (,(if set 'result 'value) :scs (,type-reg)))
290 (:temporary (:scs (non-descriptor-reg)) offset)
291 (:temporary (:scs (interior-reg)) lip)
292 (:result-types ,type-num)
294 (loadw offset object 0 instance-pointer-lowtag)
295 (inst srl offset n-widetag-bits offset)
296 (inst sll offset 2 offset)
297 (inst sub offset index offset)
298 (inst addi ,(* inc-offset-by n-word-bytes)
300 (inst add offset object lip)
302 (raw-instance (unsigned -1 nil)
303 (inst ldw (- (* instance-slots-offset n-word-bytes)
304 instance-pointer-lowtag) lip value))
306 (raw-instance (unsigned -1 t)
307 (inst stw value (- (* instance-slots-offset n-word-bytes)
308 instance-pointer-lowtag) lip)
311 (raw-instance (single -1 nil)
312 (inst li (- (* instance-slots-offset n-word-bytes)
313 instance-pointer-lowtag) offset)
314 (inst fldx offset lip value))
316 (raw-instance (single -1 t)
317 (inst li (- (* instance-slots-offset n-word-bytes)
318 instance-pointer-lowtag) offset)
319 (inst fstx value offset lip)
320 (unless (location= result value)
321 (inst funop :copy value result)))
323 (raw-instance (double -2 nil)
324 (inst fldx object index value)
325 (inst fldx offset lip value))
327 (raw-instance (double -2 t)
328 (inst fldx offset lip value)
329 (inst fldx index object value)
330 (inst funop :copy value result))
332 (raw-instance (single -2 nil complex-single)
333 (inst li (- (* instance-slots-offset n-word-bytes)
334 instance-pointer-lowtag) offset)
335 (inst fldx offset lip (complex-single-reg-real-tn value))
336 (inst li (- (* (1+ instance-slots-offset) n-word-bytes)
337 instance-pointer-lowtag) offset)
338 (inst fldx offset lip (complex-single-reg-imag-tn value)))
340 (raw-instance (single -2 t complex-single)
341 (let ((value-real (complex-single-reg-real-tn value))
342 (result-real (complex-single-reg-real-tn result)))
343 (inst li (- (* instance-slots-offset n-word-bytes)
344 instance-pointer-lowtag) offset)
345 (inst fstx value-real offset lip)
346 (unless (location= result-real value-real)
347 (inst funop :copy value-real result-real)))
348 (let ((value-imag (complex-single-reg-imag-tn value))
349 (result-imag (complex-single-reg-imag-tn result)))
350 (inst li (- (* (1+ instance-slots-offset) n-word-bytes)
351 instance-pointer-lowtag) offset)
352 (inst fstx value-imag offset lip)
353 (unless (location= result-imag value-imag)
354 (inst funop :copy value-imag result-imag))))
356 (raw-instance (double -4 nil complex-double)
357 (let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
358 instance-pointer-lowtag)))
359 (inst li immediate-offset offset)
360 (inst fldx offset lip (complex-double-reg-real-tn value)))
361 (let ((immediate-offset (+ 4 (- (* (1+ instance-slots-offset)
362 n-word-bytes) instance-pointer-lowtag))))
363 (inst li immediate-offset offset)
364 (inst fldx offset lip (complex-double-reg-real-tn value)))
365 (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes)
366 instance-pointer-lowtag)))
367 (inst li immediate-offset offset)
368 (inst fldx offset lip (complex-double-reg-imag-tn value)))
369 (let ((immediate-offset (+ 4 (- (* (+ instance-slots-offset 3)
370 n-word-bytes) instance-pointer-lowtag))))
371 (inst li immediate-offset offset)
372 (inst fldx offset lip (complex-double-reg-imag-tn value))))
374 (raw-instance (double -4 t complex-double)
375 (let ((value-real (complex-double-reg-real-tn value))
376 (result-real (complex-double-reg-real-tn result)))
377 (let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
378 instance-pointer-lowtag)))
379 (inst li immediate-offset offset)
380 (inst fldx offset lip value-real))
381 (let ((immediate-offset (+ 4 (- (* (1+ instance-slots-offset)
382 n-word-bytes) instance-pointer-lowtag))))
383 (inst li immediate-offset offset)
384 (inst fldx offset lip value-real))
386 (unless (location= result-real value-real)
387 (inst funop :copy value-real result-real)))
388 (let ((value-imag (complex-double-reg-imag-tn value))
389 (result-imag (complex-double-reg-imag-tn result)))
390 (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes)
391 instance-pointer-lowtag)))
392 (inst li immediate-offset offset)
393 (inst fldx offset lip value-imag))
395 (let ((immediate-offset (+ 4 (- (* (+ instance-slots-offset 3)
396 n-word-bytes) instance-pointer-lowtag))))
397 (inst li immediate-offset offset)
398 (inst fldx offset lip value-imag))
399 (unless (location= result-imag value-imag)
400 (inst funop :copy value-imag result-imag)))))