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 null zero)))
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 (: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 (: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 (:temporary (:scs (non-descriptor-reg)) temp)
87 (:results (res :scs (any-reg)))
88 (:result-types positive-fixnum)
90 (loadw temp symbol symbol-hash-slot other-pointer-lowtag)
91 (inst dep 0 31 n-fixnum-tag-bits temp)
92 ;; we must go through an temporary to avoid gc
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 (let ((normal-fn (gen-label)))
123 (load-type type function (- fun-pointer-lowtag))
124 (inst addi (- simple-fun-header-widetag) type type)
125 (inst comb := type zero-tn normal-fn)
126 (inst addi (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
128 (inst li (make-fixup 'closure-tramp :assembly-routine) lip)
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 function result))))
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 (make-fixup "undefined_tramp" :foreign) temp)
143 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
144 (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 (* 2 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 (- (* 2 n-word-bytes)) bsp-tn bsp-tn)))
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 comb := where bsp-tn done :nullify t)
186 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
187 (inst comb := symbol zero-tn skip)
188 (loadw value bsp-tn (- binding-value-slot binding-size))
189 (storew value symbol symbol-value-slot other-pointer-lowtag)
190 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
193 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
194 (inst addi (* -2 n-word-bytes) bsp-tn bsp-tn)
195 (inst comb :<> where bsp-tn loop)
200 ;;;; Closure indexing.
202 (define-full-reffer closure-index-ref *
203 closure-info-offset fun-pointer-lowtag
204 (descriptor-reg any-reg) * %closure-index-ref)
206 (define-full-setter set-funcallable-instance-info *
207 funcallable-instance-info-offset fun-pointer-lowtag
208 (descriptor-reg any-reg null zero) * %set-funcallable-instance-info)
210 (define-full-reffer funcallable-instance-info *
211 funcallable-instance-info-offset fun-pointer-lowtag
212 (descriptor-reg any-reg) * %funcallable-instance-info)
214 (define-vop (closure-ref slot-ref)
215 (:variant closure-info-offset fun-pointer-lowtag))
217 (define-vop (closure-init slot-set)
218 (:variant closure-info-offset fun-pointer-lowtag))
220 ;;;; Value Cell hackery.
222 (define-vop (value-cell-ref cell-ref)
223 (:variant value-cell-value-slot other-pointer-lowtag))
225 (define-vop (value-cell-set cell-set)
226 (:variant value-cell-value-slot other-pointer-lowtag))
230 ;;;; Instance hackery:
232 (define-vop (instance-length)
234 (:translate %instance-length)
235 (:args (struct :scs (descriptor-reg)))
236 (:results (res :scs (unsigned-reg)))
237 (:result-types positive-fixnum)
239 (loadw res struct 0 instance-pointer-lowtag)
240 (inst srl res n-widetag-bits res)))
242 (define-full-reffer instance-index-ref * instance-slots-offset
243 instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref)
245 (define-full-setter instance-index-set * instance-slots-offset
246 instance-pointer-lowtag (descriptor-reg any-reg null zero) * %instance-set)
250 ;;;; Code object frobbing.
252 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
253 (descriptor-reg any-reg) * code-header-ref)
255 (define-full-setter code-header-set * 0 other-pointer-lowtag
256 (descriptor-reg any-reg null zero) * code-header-set)
259 ;;;; raw instance slot accessors
261 (macrolet ((fix-storage (inc-offset-by)
263 (loadw offset object 0 instance-pointer-lowtag)
264 (inst srl offset n-widetag-bits offset)
265 (inst sll offset 2 offset)
266 (inst sub offset index offset)
267 (inst addi ,inc-offset-by offset offset)
268 (inst add offset object lip)))
269 (raw-instance ((type inc-offset-by set &optional complex)
271 (let ((name (symbolicate "RAW-INSTANCE-"
272 (if set "SET/" "REF/")
273 (if (eq type 'unsigned)
278 (if complex 'complex-single-float
281 (if complex 'complex-double-float
283 (t (symbolicate type "-NUM"))))
284 (type-reg (symbolicate (or complex type) "-REG")))
286 (:translate ,(symbolicate "%" name))
288 (:args (object :scs (descriptor-reg))
289 (index :scs (any-reg))
291 `((value :scs (,type-reg) :target result))))
292 (:arg-types * positive-fixnum ,@(if set `(,type-num)))
293 (:results (,(if set 'result 'value) :scs (,type-reg)))
294 (:temporary (:scs (non-descriptor-reg)) offset)
295 (:temporary (:scs (interior-reg)) lip)
296 (:result-types ,type-num)
298 (loadw offset object 0 instance-pointer-lowtag)
299 (inst srl offset n-widetag-bits offset)
300 (inst sll offset 2 offset)
301 (inst sub offset index offset)
302 (inst addi ,(* inc-offset-by n-word-bytes)
304 (inst add offset object lip)
306 (raw-instance (unsigned -1 nil)
307 (inst ldw (- (* instance-slots-offset n-word-bytes)
308 instance-pointer-lowtag) lip value))
310 (raw-instance (unsigned -1 t)
311 (inst stw value (- (* instance-slots-offset n-word-bytes)
312 instance-pointer-lowtag) lip)
315 (raw-instance (single -1 nil)
316 (inst li (- (* instance-slots-offset n-word-bytes)
317 instance-pointer-lowtag) offset)
318 (inst fldx offset lip value))
320 (raw-instance (single -1 t)
321 (inst li (- (* instance-slots-offset n-word-bytes)
322 instance-pointer-lowtag) offset)
323 (inst fstx value offset lip)
324 (unless (location= result value)
325 (inst funop :copy value result)))
327 (raw-instance (double -2 nil)
328 (inst fldx object index value)
329 (inst fldx offset lip value))
331 (raw-instance (double -2 t)
332 (inst fldx offset lip value)
333 (inst fldx index object value)
334 (inst funop :copy value result))
336 (raw-instance (single -2 nil complex-single)
337 (inst li (- (* instance-slots-offset n-word-bytes)
338 instance-pointer-lowtag) offset)
339 (inst fldx offset lip (complex-single-reg-real-tn value))
340 (inst li (- (* (1+ instance-slots-offset) n-word-bytes)
341 instance-pointer-lowtag) offset)
342 (inst fldx offset lip (complex-single-reg-imag-tn value)))
344 (raw-instance (single -2 t complex-single)
345 (let ((value-real (complex-single-reg-real-tn value))
346 (result-real (complex-single-reg-real-tn result)))
347 (inst li (- (* instance-slots-offset n-word-bytes)
348 instance-pointer-lowtag) offset)
349 (inst fstx value-real offset lip)
350 (unless (location= result-real value-real)
351 (inst funop :copy value-real result-real)))
352 (let ((value-imag (complex-single-reg-imag-tn value))
353 (result-imag (complex-single-reg-imag-tn result)))
354 (inst li (- (* (1+ instance-slots-offset) n-word-bytes)
355 instance-pointer-lowtag) offset)
356 (inst fstx value-imag offset lip)
357 (unless (location= result-imag value-imag)
358 (inst funop :copy value-imag result-imag))))
360 (raw-instance (double -4 nil complex-double)
361 (let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
362 instance-pointer-lowtag)))
363 (inst li immediate-offset offset)
364 (inst fldx offset lip (complex-double-reg-real-tn value)))
365 (let ((immediate-offset (+ 4 (- (* (1+ instance-slots-offset)
366 n-word-bytes) instance-pointer-lowtag))))
367 (inst li immediate-offset offset)
368 (inst fldx offset lip (complex-double-reg-real-tn value)))
369 (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes)
370 instance-pointer-lowtag)))
371 (inst li immediate-offset offset)
372 (inst fldx offset lip (complex-double-reg-imag-tn value)))
373 (let ((immediate-offset (+ 4 (- (* (+ instance-slots-offset 3)
374 n-word-bytes) instance-pointer-lowtag))))
375 (inst li immediate-offset offset)
376 (inst fldx offset lip (complex-double-reg-imag-tn value))))
378 (raw-instance (double -4 t complex-double)
379 (let ((value-real (complex-double-reg-real-tn value))
380 (result-real (complex-double-reg-real-tn result)))
381 (let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
382 instance-pointer-lowtag)))
383 (inst li immediate-offset offset)
384 (inst fldx offset lip value-real))
385 (let ((immediate-offset (+ 4 (- (* (1+ instance-slots-offset)
386 n-word-bytes) instance-pointer-lowtag))))
387 (inst li immediate-offset offset)
388 (inst fldx offset lip value-real))
390 (unless (location= result-real value-real)
391 (inst funop :copy value-real result-real)))
392 (let ((value-imag (complex-double-reg-imag-tn value))
393 (result-imag (complex-double-reg-imag-tn result)))
394 (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes)
395 instance-pointer-lowtag)))
396 (inst li immediate-offset offset)
397 (inst fldx offset lip value-imag))
399 (let ((immediate-offset (+ 4 (- (* (+ instance-slots-offset 3)
400 n-word-bytes) instance-pointer-lowtag))))
401 (inst li immediate-offset offset)
402 (inst fldx offset lip value-imag))
403 (unless (location= result-imag value-imag)
404 (inst funop :copy value-imag result-imag)))))