1 ;;;; the x86 definitions of some general purpose memory reference VOPs
2 ;;;; inherited by basic memory reference operations
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 (defun symbol-slot-ea (symbol slot
&optional
(size :qword
))
17 (let ((offset (- (* slot n-word-bytes
) other-pointer-lowtag
)))
18 (if (static-symbol-p symbol
)
19 (+ nil-value
(static-symbol-offset symbol
) offset
)
20 (make-fixup symbol
:immobile-object offset
)))))
22 ;;; CELL-REF and CELL-SET are used to define VOPs like CAR, where the
23 ;;; offset to be read or written is a property of the VOP used.
24 (define-vop (cell-ref)
25 (:args
(object :scs
(descriptor-reg)
26 :load-if
(not (and (sc-is object immediate
)
27 (symbolp (tn-value object
))))))
28 (:results
(value :scs
(descriptor-reg any-reg
)))
29 (:variant-vars offset lowtag
)
32 (cond ((sc-is object immediate
)
33 ;; This is a hack so that FAST-SYMBOL-GLOBAL-VALUE
34 ;; and %SET-SYMBOL-GLOBAL-VALUE can inherit CELL-REF.
35 ;; (Not sure it's the prettiest way)
36 ;; this sanity-check is meta-compile-time statically assertable
37 (aver (eq offset symbol-value-slot
))
38 (inst mov value
(symbol-slot-ea (tn-value object
) offset
)))
40 (loadw value object offset lowtag
)))))
41 (define-vop (cell-set)
42 (:args
(object :scs
(descriptor-reg)
43 :load-if
(not (and (sc-is object immediate
)
44 (symbolp (tn-value object
)))))
45 (value :scs
(descriptor-reg any-reg
)
46 :load-if
(not (and (sc-is value immediate
)
47 (typep (tn-value value
)
50 (signed-byte 32)))))))
51 (:variant-vars offset lowtag
)
54 (let ((value (encode-value-if-immediate value
)))
55 (cond ((sc-is object immediate
)
56 ;; this sanity-check is meta-compile-time statically assertable
57 (aver (eq offset symbol-value-slot
))
58 (inst mov
(symbol-slot-ea (tn-value object
) offset
) value
))
60 (storew value object offset lowtag
))))))
63 (define-vop (cell-xadd)
64 (:args
(object :scs
(descriptor-reg) :to
:result
)
65 (value :scs
(any-reg) :target result
))
66 (:results
(result :scs
(any-reg) :from
(:argument
1)))
67 (:result-types tagged-num
)
68 (:variant-vars offset lowtag
)
72 (inst xadd
(make-ea-for-object-slot object offset lowtag
) result
:lock
)))
74 (define-vop (cell-xsub cell-xadd
)
76 (value :scs
(any-reg immediate
) :target result
))
78 ;; For constant delta we can avoid a mov followed by neg
79 ;; but if 'delta' is most-negative-fixnum, don't negate it.
80 ;; Decrementing by most-negative-fixnum is the same as incrementing.
83 (let ((k (tn-value value
)))
84 (inst mov result
(fixnumize (if (= k most-negative-fixnum
) k
(- k
))))))
88 (inst xadd
(make-ea-for-object-slot object offset lowtag
) result
:lock
)))
90 (define-vop (atomic-inc-symbol-global-value cell-xadd
)
91 (:translate %atomic-inc-symbol-global-value
)
92 ;; The function which this vop translates will not
93 ;; be used unless the variable is proclaimed as fixnum.
94 ;; All stores are checked in a safe policy, so this
95 ;; vop is safe because it increments a known fixnum.
97 (:arg-types
* tagged-num
)
98 (:variant symbol-value-slot other-pointer-lowtag
))
100 (define-vop (atomic-dec-symbol-global-value cell-xsub
)
101 (:translate %atomic-dec-symbol-global-value
)
103 (:arg-types
* tagged-num
)
104 (:variant symbol-value-slot other-pointer-lowtag
))
107 ((def-atomic (fun-name inherit slot
)
109 (define-vop (,(symbolicate fun-name
"/FAST") ,inherit
)
110 (:translate
,fun-name
)
112 (:arg-types
* tagged-num
)
113 (:variant
,slot list-pointer-lowtag
))
114 (define-vop (,(symbolicate fun-name
"/SAFE"))
115 (:translate
,fun-name
)
117 (:args
(cell :scs
(descriptor-reg))
118 (delta :scs
(any-reg immediate
)))
119 (:results
(result :scs
(any-reg)))
120 (:temporary
(:sc descriptor-reg
:offset rax-offset
) rax
)
121 (:temporary
(:sc any-reg
) newval
)
122 (:arg-types
* tagged-num
)
123 (:result-types tagged-num
)
126 (let ((err (generate-error-code vop
'object-not-fixnum-error rax
))
127 (const (if (sc-is delta immediate
)
128 (fixnumize ,(if (eq inherit
'cell-xsub
)
129 `(let ((x (tn-value delta
)))
130 (if (= x most-negative-fixnum
)
132 `(tn-value delta
)))))
134 (loadw rax cell
,slot list-pointer-lowtag
)
136 (inst test rax fixnum-tag-mask
)
139 (cond ((typep const
'(signed-byte 32))
141 (make-ea :qword
:base rax
:disp const
)))
143 (inst mov newval const
)
144 (inst add newval rax
)))
145 ,(if (eq inherit
'cell-xsub
)
146 `(progn (move newval rax
)
147 (inst sub newval delta
))
149 (make-ea :qword
:base rax
:index delta
))))
151 (make-ea-for-object-slot cell
,slot list-pointer-lowtag
)
154 (inst mov result rax
)))))))
155 (def-atomic %atomic-inc-car cell-xadd cons-car-slot
)
156 (def-atomic %atomic-inc-cdr cell-xadd cons-cdr-slot
)
157 (def-atomic %atomic-dec-car cell-xsub cons-car-slot
)
158 (def-atomic %atomic-dec-cdr cell-xsub cons-cdr-slot
))
160 ;;; SLOT-REF and SLOT-SET are used to define VOPs like CLOSURE-REF,
161 ;;; where the offset is constant at compile time, but varies for
163 (define-vop (slot-ref)
164 (:args
(object :scs
(descriptor-reg)))
165 (:results
(value :scs
(descriptor-reg any-reg
)))
166 (:variant-vars base lowtag
)
169 (loadw value object
(+ base offset
) lowtag
)))
170 (define-vop (slot-set)
171 (:args
(object :scs
(descriptor-reg))
172 (value :scs
(descriptor-reg any-reg immediate
)))
173 (:temporary
(:sc unsigned-reg
) temp
)
174 (:variant-vars base lowtag
)
177 (if (sc-is value immediate
)
178 (move-immediate (make-ea :qword
:base object
179 :disp
(- (* (+ base offset
) n-word-bytes
)
181 (encode-value-if-immediate value
)
183 ;; Else, value not immediate.
184 (storew value object
(+ base offset
) lowtag
))))
186 (define-vop (slot-set-conditional)
187 (:args
(object :scs
(descriptor-reg) :to
:eval
)
188 (old-value :scs
(descriptor-reg any-reg
) :target eax
)
189 (new-value :scs
(descriptor-reg any-reg
) :target temp
))
190 (:temporary
(:sc descriptor-reg
:offset eax-offset
191 :from
(:argument
1) :to
:result
:target result
) eax
)
192 (:temporary
(:sc descriptor-reg
:from
(:argument
2) :to
:result
) temp
)
193 (:variant-vars base lowtag
)
194 (:results
(result :scs
(descriptor-reg)))
198 (move temp new-value
)
199 (inst cmpxchg
(make-ea :dword
:base object
200 :disp
(- (* (+ base offset
) n-word-bytes
) lowtag
))
205 ;;; FIXME: Figure out whether we should delete this.
206 ;;; It looks just like 'cell-xadd' and is buggy in the same ways:
207 ;;; - modifies 'value' operand which *should* be in the same physical reg
208 ;;; as 'result' operand, but would cause harm if not.
209 ;;; - operand width needs to be :qword
210 ;;; - :LOCK is missing
211 (define-vop (slot-xadd)
212 (:args
(object :scs
(descriptor-reg) :to
:result
)
213 (value :scs
(any-reg) :target result
))
214 (:results
(result :scs
(any-reg) :from
(:argument
1)))
215 (:result-types tagged-num
)
216 (:variant-vars base lowtag
)
220 (inst xadd
(make-ea :dword
:base object
221 :disp
(- (* (+ base offset
) n-word-bytes
) lowtag
))