1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
12 (def-alloc %make-structure-instance 1 :structure-alloc
13 sb!vm:instance-header-widetag sb!vm:instance-pointer-lowtag
16 #!+stack-allocatable-fixed-objects
17 (defoptimizer (%make-structure-instance stack-allocate-result) ((defstruct-description &rest args) node dx)
18 (aver (constant-lvar-p defstruct-description))
19 ;; A structure instance can be stack-allocated if it has no raw
20 ;; slots, or if we're on a target with a conservatively-scavenged
21 ;; stack. We have no reader conditional for stack conservation, but
22 ;; it turns out that the only time stack conservation is in play is
23 ;; when we're on GENCGC (since CHENEYGC doesn't have conservation)
24 ;; and C-STACK-IS-CONTROL-STACK (otherwise, the C stack is the
25 ;; number stack, and we precisely-scavenge the control stack).
26 #!-(and :gencgc :c-stack-is-control-stack)
27 (zerop (sb!kernel::dd-raw-length (lvar-value defstruct-description)))
28 #!+(and :gencgc :c-stack-is-control-stack)
31 (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
32 (let* ((lvar (node-lvar node))
33 (locs (lvar-result-tns lvar
34 (list *backend-t-primitive-type*)))
36 (vop slot node block (lvar-tn node block object)
37 name offset lowtag res)
38 (move-lvar-result node block locs lvar)))
40 (defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
41 (let ((value-tn (lvar-tn node block value)))
42 (vop set-slot node block (lvar-tn node block object) value-tn
44 (move-lvar-result node block (list value-tn) (node-lvar node))))
46 ;;; FIXME: Isn't there a name for this which looks less like a typo?
47 ;;; (The name IR2-CONVERT-SETTER is used for something else, just above.)
48 (defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag)
49 (let ((value-tn (lvar-tn node block value)))
50 (vop set-slot node block (lvar-tn node block object) value-tn
52 (move-lvar-result node block (list value-tn) (node-lvar node))))
54 #!+compare-and-swap-vops
55 (defoptimizer ir2-convert-casser
56 ((object old new) node block name offset lowtag)
57 (let* ((lvar (node-lvar node))
58 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
60 (vop compare-and-swap-slot node block
61 (lvar-tn node block object)
62 (lvar-tn node block old)
63 (lvar-tn node block new)
66 (move-lvar-result node block locs lvar)))
68 (defun emit-inits (node block name object lowtag instance-length inits args)
69 #!-raw-instance-init-vops
70 (declare (ignore instance-length))
71 (let ((unbound-marker-tn nil)
72 (funcallable-instance-tramp-tn nil))
74 (let ((kind (car init))
78 (let* ((raw-type (pop slot))
80 (arg-tn (lvar-tn node block arg)))
85 (vop init-slot node block object arg-tn
86 name (+ sb!vm:instance-slots-offset slot) lowtag))
89 (let ((specifier (sb!kernel::raw-slot-data-raw-type
92 (let ((type (specifier-type ',specifier))
94 (unless (csubtypep (lvar-type arg) type)
95 (let ((tmp (make-normal-tn
96 (primitive-type type))))
97 (emit-type-check node block arg-tn
100 (vop ,(sb!kernel::raw-slot-data-init-vop rsd)
102 object arg-tn instance-length slot)))))
103 #!+raw-instance-init-vops
104 sb!kernel::*raw-slot-data-list*
105 #!-raw-instance-init-vops
109 (vop init-slot node block object
110 (emit-constant (sb!kernel::dd-layout-or-lose slot))
111 name sb!vm:instance-slots-offset lowtag))
113 (vop init-slot node block object
117 (lvar-tn node block (pop args)))
119 (or unbound-marker-tn
120 (setf unbound-marker-tn
121 (let ((tn (make-restricted-tn
123 (sc-number-or-lose 'sb!vm::any-reg))))
124 (vop make-unbound-marker node block tn)
128 (:funcallable-instance-tramp
129 (or funcallable-instance-tramp-tn
130 (setf funcallable-instance-tramp-tn
131 (let ((tn (make-restricted-tn
133 (sc-number-or-lose 'sb!vm::any-reg))))
134 (vop make-funcallable-instance-tramp node block tn)
136 name slot lowtag))))))
138 (bug "Leftover args: ~S" args)))
140 (defun emit-fixed-alloc (node block name words type lowtag result lvar)
141 (let ((stack-allocate-p (and lvar (lvar-dynamic-extent lvar))))
142 (when stack-allocate-p
143 (vop current-stack-pointer node block
144 (ir2-lvar-stack-pointer (lvar-info lvar))))
145 (vop fixed-alloc node block name words type lowtag stack-allocate-p result)))
147 (defoptimizer ir2-convert-fixed-allocation
148 ((&rest args) node block name words type lowtag inits)
149 (let* ((lvar (node-lvar node))
150 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
151 (result (first locs)))
152 (emit-fixed-alloc node block name words type lowtag result lvar)
153 (emit-inits node block name result lowtag words inits args)
154 (move-lvar-result node block locs lvar)))
156 (defoptimizer ir2-convert-variable-allocation
157 ((extra &rest args) node block name words type lowtag inits)
158 (let* ((lvar (node-lvar node))
159 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
160 (result (first locs)))
161 (if (constant-lvar-p extra)
162 (let ((words (+ (lvar-value extra) words)))
163 (emit-fixed-alloc node block name words type lowtag result lvar))
164 (vop var-alloc node block (lvar-tn node block extra) name words
166 (emit-inits node block name result lowtag nil inits args)
167 (move-lvar-result node block locs lvar)))
169 (defoptimizer ir2-convert-structure-allocation
170 ((dd slot-specs &rest args) node block name words type lowtag inits)
171 (let* ((lvar (node-lvar node))
172 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
173 (result (first locs)))
174 (aver (constant-lvar-p dd))
175 (aver (constant-lvar-p slot-specs))
176 (let* ((c-dd (lvar-value dd))
177 (c-slot-specs (lvar-value slot-specs))
178 (words (+ (sb!kernel::dd-instance-length c-dd) words)))
179 (emit-fixed-alloc node block name words type lowtag result lvar)
180 (emit-inits node block name result lowtag words `((:dd . ,c-dd) ,@c-slot-specs) args)
181 (move-lvar-result node block locs lvar))))
183 (defoptimizer (initialize-vector ir2-convert)
184 ((vector &rest initial-contents) node block)
185 (let* ((vector-ctype (lvar-type vector))
186 (elt-ctype (if (array-type-p vector-ctype)
187 (array-type-specialized-element-type vector-ctype)
188 (bug "Unknow vector type in IR2 conversion for ~S."
189 'initialize-vector)))
190 (saetp (find-saetp-by-ctype elt-ctype))
191 (lvar (node-lvar node))
192 (locs (lvar-result-tns lvar (list (primitive-type vector-ctype))))
193 (result (first locs))
194 (elt-ptype (primitive-type elt-ctype))
195 (tmp (make-normal-tn elt-ptype)))
196 (emit-move node block (lvar-tn node block vector) result)
197 (flet ((compute-setter ()
200 (let ((*package* (find-package :sb!vm))
203 (when (sb!vm:saetp-specifier s)
205 `(,(sb!vm:saetp-typecode s)
208 (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
209 (sb!vm:saetp-primitive-type-name s))
210 node block result index tn 0 tn)
212 (vop ,(symbolicate "DATA-VECTOR-SET/"
213 (sb!vm:saetp-primitive-type-name s))
214 node block result index tn tn)))
216 sb!vm:*specialized-array-element-type-properties*)
217 `(ecase (sb!vm:saetp-typecode saetp)
218 ,@(nreverse clauses)))))
221 (emit-constant index)))
222 (let ((setter (compute-setter))
223 (length (length initial-contents)))
225 (emit-move node block (lvar-tn node block (pop initial-contents)) tmp)
226 (funcall setter (tnify i) tmp))))
227 (move-lvar-result node block locs lvar)))
229 ;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite
230 ;;; cut it for symbols, where under certain compilation options
231 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
232 ;;; than simply set the slot. So we build the IR2 converting function
233 ;;; by hand. -- CSR, 2003-05-08
234 (let ((fun-info (fun-info-or-lose '%set-symbol-value)))
235 (setf (fun-info-ir2-convert fun-info)
237 (let ((args (basic-combination-args node)))
238 (destructuring-bind (symbol value) args
239 (let ((value-tn (lvar-tn node block value)))
241 (lvar-tn node block symbol) value-tn)
243 node block (list value-tn) (node-lvar node))))))))
245 ;;; Stack allocation optimizers per platform support
246 #!+stack-allocatable-vectors
248 (defoptimizer (allocate-vector stack-allocate-result)
249 ((type length words) node dx)
251 ;; Can't put unboxed data on the stack unless we scavenge it
253 #!-c-stack-is-control-stack
254 (constant-lvar-p type)
255 #!-c-stack-is-control-stack
256 (member (lvar-value type)
257 '#.(list (sb!vm:saetp-typecode (find-saetp 't))
258 (sb!vm:saetp-typecode (find-saetp 'fixnum))))
259 (or (eq dx :always-dynamic)
260 (zerop (policy node safety))
261 ;; a vector object should fit in one page -- otherwise it might go past
262 ;; stack guard pages.
263 (values-subtypep (lvar-derived-type words)
265 (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-bytes*
267 sb!vm:vector-data-offset))))))))
269 (defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy)
270 (let ((args (basic-combination-args call))
271 (template (template-or-lose (if (awhen (node-lvar call)
272 (lvar-dynamic-extent it))
273 'sb!vm::allocate-vector-on-stack
274 'sb!vm::allocate-vector-on-heap))))
276 (setf (lvar-info arg)
277 (make-ir2-lvar (primitive-type (lvar-type arg)))))
278 (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
279 (ltn-default-call call)
280 (return-from allocate-vector-ltn-annotate-optimizer (values)))
281 (setf (basic-combination-info call) template)
282 (setf (node-tail-p call) nil)
285 (annotate-1-value-lvar arg)))))
288 #!+stack-allocatable-lists
290 (defoptimizer (list stack-allocate-result) ((&rest args) node dx)
292 (defoptimizer (list* stack-allocate-result) ((&rest args) node dx)
293 (not (null (rest args))))
294 (defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args) node dx)
298 #!+stack-allocatable-fixed-objects
300 (defoptimizer (cons stack-allocate-result) ((&rest args) node dx)
302 (defoptimizer (%make-complex stack-allocate-result) ((&rest args) node dx)