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
)
18 ((defstruct-description &rest args
) node dx
)
19 (declare (ignore args dx
))
20 (aver (constant-lvar-p defstruct-description
))
21 ;; A structure instance can be stack-allocated if it has no raw
22 ;; slots, or if we're on a target with a conservatively-scavenged
23 ;; stack. We have no reader conditional for stack conservation, but
24 ;; it turns out that the only time stack conservation is in play is
25 ;; when we're on GENCGC (since CHENEYGC doesn't have conservation)
26 ;; and C-STACK-IS-CONTROL-STACK (otherwise, the C stack is the
27 ;; number stack, and we precisely-scavenge the control stack).
28 #!-
(and :gencgc
:c-stack-is-control-stack
)
29 (every (lambda (x) (eq (dsd-raw-type x
) t
))
30 (dd-slots (lvar-value defstruct-description
)))
31 #!+(and :gencgc
:c-stack-is-control-stack
)
34 (defoptimizer ir2-convert-reffer
((object) node block name offset lowtag
)
35 (let* ((lvar (node-lvar node
))
36 (locs (lvar-result-tns lvar
37 (list *backend-t-primitive-type
*)))
39 (vop slot node block
(lvar-tn node block object
)
40 name offset lowtag res
)
41 (move-lvar-result node block locs lvar
)))
43 (defoptimizer ir2-convert-setter
((object value
) node block name offset lowtag
)
44 (let ((value-tn (lvar-tn node block value
)))
45 (vop set-slot node block
(lvar-tn node block object
) value-tn
47 (move-lvar-result node block
(list value-tn
) (node-lvar node
))))
49 ;;; FIXME: Isn't there a name for this which looks less like a typo?
50 ;;; (The name IR2-CONVERT-SETTER is used for something else, just above.)
51 (defoptimizer ir2-convert-setfer
((value object
) node block name offset lowtag
)
52 (let ((value-tn (lvar-tn node block value
)))
53 (vop set-slot node block
(lvar-tn node block object
) value-tn
55 (move-lvar-result node block
(list value-tn
) (node-lvar node
))))
57 #!+compare-and-swap-vops
58 (defoptimizer ir2-convert-casser
59 ((object old new
) node block name offset lowtag
)
60 (let* ((lvar (node-lvar node
))
61 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
63 (vop compare-and-swap-slot node block
64 (lvar-tn node block object
)
65 (lvar-tn node block old
)
66 (lvar-tn node block new
)
69 (move-lvar-result node block locs lvar
)))
71 (defun emit-inits (node block name object lowtag inits args
)
72 (let ((unbound-marker-tn nil
)
73 (funcallable-instance-tramp-tn nil
)
74 (lvar (node-lvar node
)))
75 (flet ((zero-init-p (x)
76 ;; dynamic-space is already zeroed
78 (not (lvar-dynamic-extent lvar
)))
79 ;; KLUDGE: can't ignore type-derived
80 ;; constants since they can be closed over
81 ;; and not using them confuses the register
83 ;; See compiler.pure/cons-zero-initialization
84 (strictly-constant-lvar-p x
)
85 (eql (lvar-value x
) 0))))
87 (let ((kind (car init
))
91 ;; FIXME: the only reason INIT-SLOT raw variants exist is to avoid
92 ;; an extra MOVE - setters return a value, but INITers don't.
93 ;; It would probably produce better code by not assuming that
94 ;; setters return a value, because as things are, if you call
95 ;; 8 setters in a row, then you probably produce 7 extraneous moves,
96 ;; because not all of them can deliver a value to the final result.
97 (let ((raw-type (pop slot
))
99 (unless (and (or (eq raw-type t
)
100 (eq raw-type
'word
)) ;; can be made to handle floats
102 (let ((arg-tn (lvar-tn node block arg
)))
104 ((make-case (&optional rsd-list
)
107 (vop init-slot node block object arg-tn
108 name
(+ sb
!vm
:instance-slots-offset slot
) lowtag
))
111 `(,(sb!kernel
::raw-slot-data-raw-type rsd
)
112 (vop ,(sb!kernel
::raw-slot-data-init-vop rsd
)
113 node block object arg-tn slot
)))
114 (symbol-value rsd-list
)))))
115 (make-case #!+raw-instance-init-vops
116 sb
!kernel
::*raw-slot-data
*))))))
118 (vop init-slot node block object
119 (emit-constant (sb!kernel
::dd-layout-or-lose slot
))
120 name sb
!vm
:instance-slots-offset lowtag
))
122 (if (and (eq kind
:arg
)
123 (zero-init-p (car args
)))
125 (vop init-slot node block object
129 (lvar-tn node block
(pop args
)))
131 (or unbound-marker-tn
132 (setf unbound-marker-tn
133 (let ((tn (make-restricted-tn
135 (sc-number-or-lose 'sb
!vm
::any-reg
))))
136 (vop make-unbound-marker node block tn
)
140 (:funcallable-instance-tramp
141 (or funcallable-instance-tramp-tn
142 (setf funcallable-instance-tramp-tn
143 (let ((tn (make-restricted-tn
145 (sc-number-or-lose 'sb
!vm
::any-reg
))))
146 (vop make-funcallable-instance-tramp node block tn
)
148 name slot lowtag
))))))))
150 (bug "Leftover args: ~S" args
)))
152 (defun emit-fixed-alloc (node block name words type lowtag result lvar
)
153 (let ((stack-allocate-p (and lvar
(lvar-dynamic-extent lvar
))))
154 (when stack-allocate-p
155 (vop current-stack-pointer node block
156 (ir2-lvar-stack-pointer (lvar-info lvar
))))
157 (vop fixed-alloc node block name words type lowtag stack-allocate-p result
)))
159 (defoptimizer ir2-convert-fixed-allocation
160 ((&rest args
) node block name words type lowtag inits
)
161 (let* ((lvar (node-lvar node
))
162 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
163 (result (first locs
)))
164 (emit-fixed-alloc node block name words type lowtag result lvar
)
165 (emit-inits node block name result lowtag inits args
)
166 (move-lvar-result node block locs lvar
)))
168 (defoptimizer ir2-convert-variable-allocation
169 ((extra &rest args
) node block name words type lowtag inits
)
170 (let* ((lvar (node-lvar node
))
171 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
172 (result (first locs
)))
173 (if (constant-lvar-p extra
)
174 (let ((words (+ (lvar-value extra
) words
)))
175 (emit-fixed-alloc node block name words type lowtag result lvar
))
176 (vop var-alloc node block
(lvar-tn node block extra
) name words
178 (emit-inits node block name result lowtag inits args
)
179 (move-lvar-result node block locs lvar
)))
181 (defoptimizer ir2-convert-structure-allocation
182 ((dd slot-specs
&rest args
) node block name words type lowtag inits
)
183 (declare (ignore inits
))
184 (let* ((lvar (node-lvar node
))
185 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
186 (result (first locs
)))
187 (aver (and (constant-lvar-p dd
) (constant-lvar-p slot-specs
) (= words
1)))
188 (let* ((c-dd (lvar-value dd
))
189 (c-slot-specs (lvar-value slot-specs
))
190 (words (+ (dd-length c-dd
) words
)))
191 (emit-fixed-alloc node block name words type lowtag result lvar
)
192 (emit-inits node block name result lowtag
`((:dd .
,c-dd
) ,@c-slot-specs
) args
)
193 (move-lvar-result node block locs lvar
))))
195 (defoptimizer (initialize-vector ir2-convert
)
196 ((vector &rest initial-contents
) node block
)
197 (let* ((vector-ctype (lvar-type vector
))
198 (elt-ctype (if (array-type-p vector-ctype
)
199 (array-type-specialized-element-type vector-ctype
)
200 (bug "Unknow vector type in IR2 conversion for ~S."
201 'initialize-vector
)))
202 (saetp (find-saetp-by-ctype elt-ctype
))
203 (lvar (node-lvar node
))
204 (locs (lvar-result-tns lvar
(list (primitive-type vector-ctype
))))
205 (result (first locs
))
206 (elt-ptype (primitive-type elt-ctype
))
207 (tmp (make-normal-tn elt-ptype
)))
208 (emit-move node block
(lvar-tn node block vector
) result
)
209 (flet ((compute-setter ()
212 (let ((*package
* (find-package :sb
!vm
))
215 (when (sb!vm
:saetp-specifier s
)
217 `(,(sb!vm
:saetp-typecode s
)
220 (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
221 (sb!vm
:saetp-primitive-type-name s
)
223 node block result tn index
0 tn
)
225 (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
226 (sb!vm
:saetp-primitive-type-name s
))
227 node block result index tn
0 tn
)
229 (vop ,(symbolicate "DATA-VECTOR-SET/"
230 (sb!vm
:saetp-primitive-type-name s
))
231 node block result index tn tn
)))
233 sb
!vm
:*specialized-array-element-type-properties
*)
234 `(ecase (sb!vm
:saetp-typecode saetp
)
235 ,@(nreverse clauses
)))))
239 (emit-constant index
)
242 (let ((setter (compute-setter))
243 (length (length initial-contents
))
245 (lvar-dynamic-extent lvar
)))
246 (character (eq (primitive-type-name elt-ptype
)
249 (let ((value (pop initial-contents
)))
250 ;; dynamic-space is already zeroed
251 (unless (and (not dx-p
)
252 ;; KLUDGE: can't ignore type-derived
253 ;; constants since they can be closed over
254 ;; and not using them confuses the register
256 ;; See compiler.pure/vector-zero-initialization
257 (strictly-constant-lvar-p value
)
259 (eql (char-code (lvar-value value
)) 0)
260 (eql (lvar-value value
) 0)))
261 (emit-move node block
(lvar-tn node block value
) tmp
)
262 (funcall setter
(tnify i
) tmp
))))))
263 (move-lvar-result node block locs lvar
)))
265 ;;; :SET-TRANS (in objdef.lisp !DEFINE-PRIMITIVE-OBJECT) doesn't quite
266 ;;; cut it for symbols, where under certain compilation options
267 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
268 ;;; than simply set the slot. So we build the IR2 converting function
269 ;;; by hand. -- CSR, 2003-05-08
270 (let ((fun-info (fun-info-or-lose '%set-symbol-value
)))
271 (setf (fun-info-ir2-convert fun-info
)
273 (let ((args (basic-combination-args node
)))
274 (destructuring-bind (symbol value
) args
275 (let ((value-tn (lvar-tn node block value
)))
277 (lvar-tn node block symbol
) value-tn
)
279 node block
(list value-tn
) (node-lvar node
))))))))
281 ;;; Stack allocation optimizers per platform support
282 #!+stack-allocatable-vectors
284 (defoptimizer (allocate-vector stack-allocate-result
)
285 ((type length words
) node dx
)
286 (declare (ignorable type
) (ignore length
))
288 ;; Can't put unboxed data on the stack unless we scavenge it
290 #!-c-stack-is-control-stack
291 (constant-lvar-p type
)
292 #!-c-stack-is-control-stack
293 (member (lvar-value type
)
294 '#.
(list (sb!vm
:saetp-typecode
(find-saetp 't
))
295 (sb!vm
:saetp-typecode
(find-saetp 'fixnum
))))
296 (or (eq dx
:always-dynamic
)
297 (zerop (policy node safety
))
298 ;; a vector object should fit in one page -- otherwise it might go past
299 ;; stack guard pages.
300 (values-subtypep (lvar-derived-type words
)
302 (specifier-type `(integer 0 ,(- (/ sb
!vm
::*backend-page-bytes
*
304 sb
!vm
:vector-data-offset
))))))))
306 (defoptimizer (allocate-vector ltn-annotate
) ((type length words
) call ltn-policy
)
307 (declare (ignore type length words
))
308 (vectorish-ltn-annotate-helper call ltn-policy
309 'sb
!vm
::allocate-vector-on-stack
310 'sb
!vm
::allocate-vector-on-heap
))
312 (defun vectorish-ltn-annotate-helper (call ltn-policy dx-template
&optional not-dx-template
)
313 (let* ((args (basic-combination-args call
))
314 (template-name (if (awhen (node-lvar call
)
315 (lvar-dynamic-extent it
))
318 (template (and template-name
319 (template-or-lose template-name
))))
321 (setf (lvar-info arg
)
322 (make-ir2-lvar (primitive-type (lvar-type arg
)))))
323 (unless (and template
324 (is-ok-template-use template call
(ltn-policy-safe-p ltn-policy
)))
325 (ltn-default-call call
)
326 (return-from vectorish-ltn-annotate-helper
(values)))
327 (setf (basic-combination-info call
) template
)
328 (setf (node-tail-p call
) nil
)
331 (annotate-1-value-lvar arg
)))))
334 #!+stack-allocatable-lists
336 (defoptimizer (list stack-allocate-result
) ((&rest args
) node dx
)
337 (declare (ignore dx
))
339 (defoptimizer (list* stack-allocate-result
) ((&rest args
) node dx
)
340 (declare (ignore dx
))
341 (not (null (rest args
))))
342 (defoptimizer (%listify-rest-args stack-allocate-result
) ((&rest args
) node dx
)
343 (declare (ignore args dx
))
347 #!+stack-allocatable-fixed-objects
349 (defoptimizer (cons stack-allocate-result
) ((&rest args
) node dx
)
350 (declare (ignore args dx
))
352 (defoptimizer (%make-complex stack-allocate-result
) ((&rest args
) node dx
)
353 (declare (ignore args dx
))
356 ;;; MAKE-LIST optimizations
359 (defoptimizer (%make-list stack-allocate-result
) ((length element
) node dx
)
360 (declare (ignore element
))
361 (or (eq dx
:always-dynamic
)
362 (zerop (policy node safety
))
363 ;; At most one page (this is more paranoid than %listify-rest-args).
364 ;; Really what you want to do is decrement the stack pointer by one page
365 ;; at a time, filling in CDR pointers downward. Then this restriction
366 ;; could be removed, because allocation would never miss the guard page
367 ;; if it tries to consume too much stack space.
368 (values-subtypep (lvar-derived-type length
)
370 (specifier-type `(integer 0 ,(/ sb
!vm
::*backend-page-bytes
*
371 sb
!vm
:n-word-bytes
2)))))))
372 (defoptimizer (%make-list ltn-annotate
) ((length element
) call ltn-policy
)
373 (declare (ignore length element
))
374 (vectorish-ltn-annotate-helper call ltn-policy
375 'sb
!vm
::allocate-list-on-stack
)))