1 ;;;; various primitive memory access VOPs for the x86 VM
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
17 ;;;; data object ref/set stuff
20 (:args (object :scs (descriptor-reg)))
21 (:info name offset lowtag)
23 (:results (result :scs (descriptor-reg any-reg)))
25 (loadw result object offset lowtag)))
27 (define-vop (set-slot)
28 (:args (object :scs (descriptor-reg))
29 (value :scs (descriptor-reg any-reg immediate)))
30 (:info name offset lowtag)
34 (if (sc-is value immediate)
35 (let ((val (tn-value value)))
39 (make-ea :dword :base object
40 :disp (- (* offset word-bytes) lowtag))
44 (make-ea :dword :base object
45 :disp (- (* offset word-bytes) lowtag))
46 (+ nil-value (static-symbol-offset val))))
49 (make-ea :dword :base object
50 :disp (- (* offset word-bytes) lowtag))
51 (logior (ash (char-code val) type-bits)
53 ;; Else, value not immediate.
54 (storew value object offset lowtag))))
56 ;;;; symbol hacking VOPs
58 ;;; these next two cf the sparc version, by jrd.
59 ;;; FIXME: Deref this ^ reference.
61 ;;; The compiler likes to be able to directly SET symbols.
62 (define-vop (set cell-set)
63 (:variant symbol-value-slot other-pointer-type))
65 ;;; Do a cell ref with an error check for being unbound.
66 (define-vop (checked-cell-ref)
67 (:args (object :scs (descriptor-reg) :target obj-temp))
68 (:results (value :scs (descriptor-reg any-reg)))
71 (:save-p :compute-only)
72 (:temporary (:sc descriptor-reg :from (:argument 0)) obj-temp))
74 ;;; With Symbol-Value, we check that the value isn't the trap object. So
75 ;;; Symbol-Value of NIL is NIL.
76 (define-vop (symbol-value)
77 (:translate symbol-value)
79 (:args (object :scs (descriptor-reg) :to (:result 1)))
80 (:results (value :scs (descriptor-reg any-reg)))
82 (:save-p :compute-only)
84 (let ((err-lab (generate-error-code vop unbound-symbol-error object)))
85 (loadw value object symbol-value-slot other-pointer-type)
86 (inst cmp value unbound-marker-type)
87 (inst jmp :e err-lab))))
89 (define-vop (fast-symbol-value cell-ref)
90 (:variant symbol-value-slot other-pointer-type)
92 (:translate symbol-value))
94 (defknown fast-symbol-value-xadd (symbol fixnum) fixnum ())
95 (define-vop (fast-symbol-value-xadd cell-xadd)
96 (:variant symbol-value-slot other-pointer-type)
98 (:translate fast-symbol-value-xadd)
99 (:arg-types * tagged-num))
104 (:args (object :scs (descriptor-reg)))
107 (:temporary (:sc descriptor-reg :from (:argument 0)) value)
109 (loadw value object symbol-value-slot other-pointer-type)
110 (inst cmp value unbound-marker-type)
111 (inst jmp (if not-p :e :ne) target)))
113 (define-vop (symbol-hash)
115 (:translate symbol-hash)
116 (:args (symbol :scs (descriptor-reg)))
117 (:results (res :scs (any-reg)))
118 (:result-types positive-fixnum)
120 ;; The symbol-hash slot of NIL holds NIL because it is also the cdr slot,
121 ;; so we have to strip off the two low bits to make sure it is a fixnum.
123 ;; FIXME: Is this still true? It seems to me from my reading of
124 ;; the DEFINE-PRIMITIVE-OBJECT in objdef.lisp that the symbol-hash
125 ;; is the second slot, and offset 0 = tags and stuff (and CAR slot in
126 ;; a CONS), offset 1 = value slot (and CDR slot in a CONS), and
127 ;; offset 2 = hash slot.
128 (loadw res symbol symbol-hash-slot other-pointer-type)
129 (inst and res (lognot #b11))))
131 ;;;; fdefinition (fdefn) objects
133 (define-vop (fdefn-function cell-ref) ; /pfw - alpha
134 (:variant fdefn-function-slot other-pointer-type))
136 (define-vop (safe-fdefn-function)
137 (:args (object :scs (descriptor-reg) :to (:result 1)))
138 (:results (value :scs (descriptor-reg any-reg)))
140 (:save-p :compute-only)
142 (loadw value object fdefn-function-slot other-pointer-type)
143 (inst cmp value nil-value)
144 ;; FIXME: UNDEFINED-SYMBOL-ERROR seems to actually be for symbols with no
145 ;; function value, not, as the name might suggest, symbols with no ordinary
146 ;; value. Perhaps the name could be made more mnemonic?
147 (let ((err-lab (generate-error-code vop undefined-symbol-error object)))
148 (inst jmp :e err-lab))))
150 (define-vop (set-fdefn-function)
152 (:translate (setf fdefn-function))
153 (:args (function :scs (descriptor-reg) :target result)
154 (fdefn :scs (descriptor-reg)))
155 (:temporary (:sc unsigned-reg) raw)
156 (:temporary (:sc byte-reg) type)
157 (:results (result :scs (descriptor-reg)))
159 (load-type type function (- function-pointer-type))
161 (make-ea :byte :base function
162 :disp (- (* function-code-offset word-bytes)
163 function-pointer-type)))
164 (inst cmp type function-header-type)
165 (inst jmp :e normal-fn)
166 (inst lea raw (make-fixup (extern-alien-name "closure_tramp") :foreign))
168 (storew function fdefn fdefn-function-slot other-pointer-type)
169 (storew raw fdefn fdefn-raw-addr-slot other-pointer-type)
170 (move result function)))
172 (define-vop (fdefn-makunbound)
174 (:translate fdefn-makunbound)
175 (:args (fdefn :scs (descriptor-reg) :target result))
176 (:results (result :scs (descriptor-reg)))
178 (storew nil-value fdefn fdefn-function-slot other-pointer-type)
179 (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
180 fdefn fdefn-raw-addr-slot other-pointer-type)
181 (move result fdefn)))
183 ;;;; binding and unbinding
185 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
186 ;;; the symbol on the binding stack and stuff the new value into the
190 (:args (val :scs (any-reg descriptor-reg))
191 (symbol :scs (descriptor-reg)))
192 (:temporary (:sc unsigned-reg) temp bsp)
194 (load-symbol-value bsp *binding-stack-pointer*)
195 (loadw temp symbol symbol-value-slot other-pointer-type)
196 (inst add bsp (* binding-size word-bytes))
197 (store-symbol-value bsp *binding-stack-pointer*)
198 (storew temp bsp (- binding-value-slot binding-size))
199 (storew symbol bsp (- binding-symbol-slot binding-size))
200 (storew val symbol symbol-value-slot other-pointer-type)))
203 (:temporary (:sc unsigned-reg) symbol value bsp)
205 (load-symbol-value bsp *binding-stack-pointer*)
206 (loadw symbol bsp (- binding-symbol-slot binding-size))
207 (loadw value bsp (- binding-value-slot binding-size))
208 (storew value symbol symbol-value-slot other-pointer-type)
209 (storew 0 bsp (- binding-symbol-slot binding-size))
210 (inst sub bsp (* binding-size word-bytes))
211 (store-symbol-value bsp *binding-stack-pointer*)))
213 (define-vop (unbind-to-here)
214 (:args (where :scs (descriptor-reg any-reg)))
215 (:temporary (:sc unsigned-reg) symbol value bsp)
217 (load-symbol-value bsp *binding-stack-pointer*)
222 (loadw symbol bsp (- binding-symbol-slot binding-size))
223 (inst or symbol symbol)
225 (loadw value bsp (- binding-value-slot binding-size))
226 (storew value symbol symbol-value-slot other-pointer-type)
227 (storew 0 bsp (- binding-symbol-slot binding-size))
230 (inst sub bsp (* binding-size word-bytes))
233 (store-symbol-value bsp *binding-stack-pointer*)
237 ;;;; closure indexing
239 (define-full-reffer closure-index-ref *
240 closure-info-offset function-pointer-type
241 (any-reg descriptor-reg) * %closure-index-ref)
243 (define-full-setter set-funcallable-instance-info *
244 funcallable-instance-info-offset function-pointer-type
245 (any-reg descriptor-reg) * %set-funcallable-instance-info)
247 (define-full-reffer funcallable-instance-info *
248 funcallable-instance-info-offset function-pointer-type
249 (descriptor-reg any-reg) * %funcallable-instance-info)
251 (define-vop (funcallable-instance-lexenv cell-ref)
252 (:variant funcallable-instance-lexenv-slot function-pointer-type))
254 (define-vop (closure-ref slot-ref)
255 (:variant closure-info-offset function-pointer-type))
257 (define-vop (closure-init slot-set)
258 (:variant closure-info-offset function-pointer-type))
260 ;;;; value cell hackery
262 (define-vop (value-cell-ref cell-ref)
263 (:variant value-cell-value-slot other-pointer-type))
265 (define-vop (value-cell-set cell-set)
266 (:variant value-cell-value-slot other-pointer-type))
268 ;;;; structure hackery
270 (define-vop (instance-length)
272 (:translate %instance-length)
273 (:args (struct :scs (descriptor-reg)))
274 (:results (res :scs (unsigned-reg)))
275 (:result-types positive-fixnum)
277 (loadw res struct 0 instance-pointer-type)
278 (inst shr res type-bits)))
280 (define-vop (instance-ref slot-ref)
281 (:variant instance-slots-offset instance-pointer-type)
283 (:translate %instance-ref)
284 (:arg-types instance (:constant index)))
286 (define-vop (instance-set slot-set)
288 (:translate %instance-set)
289 (:variant instance-slots-offset instance-pointer-type)
290 (:arg-types instance (:constant index) *))
292 (define-full-reffer instance-index-ref * instance-slots-offset
293 instance-pointer-type (any-reg descriptor-reg) * %instance-ref)
295 (define-full-setter instance-index-set * instance-slots-offset
296 instance-pointer-type (any-reg descriptor-reg) * %instance-set)
298 (defknown sb!kernel::%instance-set-conditional (instance index t t) t
301 (define-vop (instance-set-conditional-c slot-set-conditional)
303 (:translate sb!kernel::%instance-set-conditional)
304 (:variant instance-slots-offset instance-pointer-type)
305 (:arg-types instance (:constant index) * *))
307 (define-vop (instance-set-conditional)
308 (:translate sb!kernel::%instance-set-conditional)
309 (:args (object :scs (descriptor-reg) :to :eval)
310 (slot :scs (any-reg) :to :result)
311 (old-value :scs (descriptor-reg any-reg) :target eax)
312 (new-value :scs (descriptor-reg any-reg) :target temp))
313 (:arg-types instance positive-fixnum * *)
314 (:temporary (:sc descriptor-reg :offset eax-offset
315 :from (:argument 1) :to :result :target result) eax)
316 (:temporary (:sc descriptor-reg :from (:argument 2) :to :result) temp)
317 (:results (result :scs (descriptor-reg)))
321 (move temp new-value)
322 (inst cmpxchg (make-ea :dword :base object :index slot :scale 1
323 :disp (- (* instance-slots-offset word-bytes)
324 instance-pointer-type))
328 (defknown %instance-xadd (instance index fixnum) fixnum ())
329 (define-vop (instance-xadd-c slot-xadd)
331 (:translate %instance-xadd)
332 (:variant instance-slots-offset instance-pointer-type)
333 (:arg-types instance (:constant index) tagged-num))
335 ;;;; code object frobbing
337 (define-full-reffer code-header-ref * 0 other-pointer-type
338 (any-reg descriptor-reg) * code-header-ref)
340 (define-full-setter code-header-set * 0 other-pointer-type
341 (any-reg descriptor-reg) * code-header-set)