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 (extern-alien-name "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 (extern-alien-name "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 (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))))
173 (define-vop (unbind-to-here)
174 (:args (arg :scs (descriptor-reg any-reg) :target where))
175 (:temporary (:scs (any-reg) :from (:argument 0)) where)
176 (:temporary (:scs (descriptor-reg)) symbol value)
178 (let ((loop (gen-label))
182 (inst cmp where bsp-tn)
187 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
190 (loadw value bsp-tn (- binding-value-slot binding-size))
191 (storew value symbol symbol-value-slot other-pointer-lowtag)
192 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
195 (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))
196 (inst cmp where bsp-tn)
202 ;;;; closure indexing.
204 (define-vop (closure-index-ref word-index-ref)
205 (:variant closure-info-offset fun-pointer-lowtag)
206 (:translate %closure-index-ref))
208 (define-vop (funcallable-instance-info word-index-ref)
209 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
210 (:translate %funcallable-instance-info))
212 (define-vop (set-funcallable-instance-info word-index-set)
213 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
214 (:translate %set-funcallable-instance-info))
216 (define-vop (funcallable-instance-lexenv cell-ref)
217 (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
220 (define-vop (closure-ref slot-ref)
221 (:variant closure-info-offset fun-pointer-lowtag))
223 (define-vop (closure-init slot-set)
224 (:variant closure-info-offset fun-pointer-lowtag))
226 ;;;; value cell hackery.
228 (define-vop (value-cell-ref cell-ref)
229 (:variant value-cell-value-slot other-pointer-lowtag))
231 (define-vop (value-cell-set cell-set)
232 (:variant value-cell-value-slot other-pointer-lowtag))
234 ;;;; instance hackery:
236 (define-vop (instance-length)
238 (:translate %instance-length)
239 (:args (struct :scs (descriptor-reg)))
240 (:temporary (:scs (non-descriptor-reg)) temp)
241 (:results (res :scs (unsigned-reg)))
242 (:result-types positive-fixnum)
244 (loadw temp struct 0 instance-pointer-lowtag)
245 (inst srl res temp n-widetag-bits)))
247 (define-vop (instance-ref slot-ref)
248 (:variant instance-slots-offset instance-pointer-lowtag)
250 (:translate %instance-ref)
251 (:arg-types * (:constant index)))
253 ;;; This VOP has no :results; however, %instance-set must return a
254 ;;; value. This caused, in the forward port to 0.7.x, an error in
255 ;;; !fdefn-cold-init: "argument X is not a REAL: NIL". This VOP is
256 ;;; commented out for now, pending the addition of checking code to
257 ;;; the define-vop machinery to ascertain that this was indeed the
258 ;;; problem. -- CSR, 2002-02-12
260 (define-vop (instance-set slot-set)
262 (:translate %instance-set)
263 (:variant instance-slots-offset instance-pointer-lowtag)
264 (:arg-types * (:constant index) *))
266 (define-vop (instance-index-ref word-index-ref)
268 (:translate %instance-ref)
269 (:variant instance-slots-offset instance-pointer-lowtag)
270 (:arg-types * positive-fixnum))
272 (define-vop (instance-index-set word-index-set)
274 (:translate %instance-set)
275 (:variant instance-slots-offset instance-pointer-lowtag)
276 (:arg-types * positive-fixnum *))
278 ;;;; Code object frobbing.
280 (define-vop (code-header-ref word-index-ref)
281 (:translate code-header-ref)
283 (:variant 0 other-pointer-lowtag))
285 (define-vop (code-header-set word-index-set)
286 (:translate code-header-set)
288 (:variant 0 other-pointer-lowtag))