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 instance-length inits args
)
72 #!+interleaved-raw-slots
(declare (ignore instance-length
))
73 #!-raw-instance-init-vops
74 (declare (ignore instance-length
))
75 (let ((unbound-marker-tn nil
)
76 (funcallable-instance-tramp-tn nil
))
78 (let ((kind (car init
))
82 ;; FIXME: with #!+interleaved-raw-slots the only reason INIT-SLOT
83 ;; and its raw variants exist is to avoid an extra MOVE -
84 ;; setters are expected to return something, but INITers don't.
85 ;; It would probably produce better code by not assuming that
86 ;; setters return a value, because as things are, if you call
87 ;; 8 setters in a row, then you probably produce 7 extraneous moves,
88 ;; because not all of them can deliver a value to the final result.
89 (let* ((raw-type (pop slot
))
91 (arg-tn (lvar-tn node block arg
)))
93 ((make-case (&optional rsd-list
)
96 (vop init-slot node block object arg-tn
97 name
(+ sb
!vm
:instance-slots-offset slot
) lowtag
))
100 `(,(sb!kernel
::raw-slot-data-raw-type rsd
)
101 (vop ,(sb!kernel
::raw-slot-data-init-vop rsd
)
102 node block object arg-tn
103 #!-interleaved-raw-slots instance-length
105 (symbol-value rsd-list
)))))
106 (make-case #!+raw-instance-init-vops
107 sb
!kernel
::*raw-slot-data-list
*))))
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 (declare (ignore inits
))
172 (let* ((lvar (node-lvar node
))
173 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
174 (result (first locs
)))
175 (aver (constant-lvar-p dd
))
176 (aver (constant-lvar-p slot-specs
))
177 (let* ((c-dd (lvar-value dd
))
178 (c-slot-specs (lvar-value slot-specs
))
179 (words (+ (sb!kernel
::dd-instance-length c-dd
) words
)))
180 (emit-fixed-alloc node block name words type lowtag result lvar
)
181 (emit-inits node block name result lowtag words
`((:dd .
,c-dd
) ,@c-slot-specs
) args
)
182 (move-lvar-result node block locs lvar
))))
184 (defoptimizer (initialize-vector ir2-convert
)
185 ((vector &rest initial-contents
) node block
)
186 (let* ((vector-ctype (lvar-type vector
))
187 (elt-ctype (if (array-type-p vector-ctype
)
188 (array-type-specialized-element-type vector-ctype
)
189 (bug "Unknow vector type in IR2 conversion for ~S."
190 'initialize-vector
)))
191 (saetp (find-saetp-by-ctype elt-ctype
))
192 (lvar (node-lvar node
))
193 (locs (lvar-result-tns lvar
(list (primitive-type vector-ctype
))))
194 (result (first locs
))
195 (elt-ptype (primitive-type elt-ctype
))
196 (tmp (make-normal-tn elt-ptype
)))
197 (emit-move node block
(lvar-tn node block vector
) result
)
198 (flet ((compute-setter ()
201 (let ((*package
* (find-package :sb
!vm
))
204 (when (sb!vm
:saetp-specifier s
)
206 `(,(sb!vm
:saetp-typecode s
)
209 (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
210 (sb!vm
:saetp-primitive-type-name s
)
212 node block result tn index
0 tn
)
214 (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
215 (sb!vm
:saetp-primitive-type-name s
))
216 node block result index tn
0 tn
)
218 (vop ,(symbolicate "DATA-VECTOR-SET/"
219 (sb!vm
:saetp-primitive-type-name s
))
220 node block result index tn tn
)))
222 sb
!vm
:*specialized-array-element-type-properties
*)
223 `(ecase (sb!vm
:saetp-typecode saetp
)
224 ,@(nreverse clauses
)))))
228 (emit-constant index
)
231 (let ((setter (compute-setter))
232 (length (length initial-contents
)))
234 (emit-move node block
(lvar-tn node block
(pop initial-contents
)) tmp
)
235 (funcall setter
(tnify i
) tmp
))))
236 (move-lvar-result node block locs lvar
)))
238 ;;; :SET-TRANS (in objdef.lisp !DEFINE-PRIMITIVE-OBJECT) doesn't quite
239 ;;; cut it for symbols, where under certain compilation options
240 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
241 ;;; than simply set the slot. So we build the IR2 converting function
242 ;;; by hand. -- CSR, 2003-05-08
243 (let ((fun-info (fun-info-or-lose '%set-symbol-value
)))
244 (setf (fun-info-ir2-convert fun-info
)
246 (let ((args (basic-combination-args node
)))
247 (destructuring-bind (symbol value
) args
248 (let ((value-tn (lvar-tn node block value
)))
250 (lvar-tn node block symbol
) value-tn
)
252 node block
(list value-tn
) (node-lvar node
))))))))
254 ;;; Stack allocation optimizers per platform support
255 #!+stack-allocatable-vectors
257 (defoptimizer (allocate-vector stack-allocate-result
)
258 ((type length words
) node dx
)
259 (declare (ignorable type
) (ignore length
))
261 ;; Can't put unboxed data on the stack unless we scavenge it
263 #!-c-stack-is-control-stack
264 (constant-lvar-p type
)
265 #!-c-stack-is-control-stack
266 (member (lvar-value type
)
267 '#.
(list (sb!vm
:saetp-typecode
(find-saetp 't
))
268 (sb!vm
:saetp-typecode
(find-saetp 'fixnum
))))
269 (or (eq dx
:always-dynamic
)
270 (zerop (policy node safety
))
271 ;; a vector object should fit in one page -- otherwise it might go past
272 ;; stack guard pages.
273 (values-subtypep (lvar-derived-type words
)
275 (specifier-type `(integer 0 ,(- (/ sb
!vm
::*backend-page-bytes
*
277 sb
!vm
:vector-data-offset
))))))))
279 (defoptimizer (allocate-vector ltn-annotate
) ((type length words
) call ltn-policy
)
280 (declare (ignore type length words
))
281 (vectorish-ltn-annotate-helper call ltn-policy
282 'sb
!vm
::allocate-vector-on-stack
283 'sb
!vm
::allocate-vector-on-heap
))
285 (defun vectorish-ltn-annotate-helper (call ltn-policy dx-template
&optional not-dx-template
)
286 (let* ((args (basic-combination-args call
))
287 (template-name (if (awhen (node-lvar call
)
288 (lvar-dynamic-extent it
))
291 (template (and template-name
292 (template-or-lose template-name
))))
294 (setf (lvar-info arg
)
295 (make-ir2-lvar (primitive-type (lvar-type arg
)))))
296 (unless (and template
297 (is-ok-template-use template call
(ltn-policy-safe-p ltn-policy
)))
298 (ltn-default-call call
)
299 (return-from vectorish-ltn-annotate-helper
(values)))
300 (setf (basic-combination-info call
) template
)
301 (setf (node-tail-p call
) nil
)
304 (annotate-1-value-lvar arg
)))))
307 #!+stack-allocatable-lists
309 (defoptimizer (list stack-allocate-result
) ((&rest args
) node dx
)
310 (declare (ignore dx
))
312 (defoptimizer (list* stack-allocate-result
) ((&rest args
) node dx
)
313 (declare (ignore dx
))
314 (not (null (rest args
))))
315 (defoptimizer (%listify-rest-args stack-allocate-result
) ((&rest args
) node dx
)
316 (declare (ignore args dx
))
320 #!+stack-allocatable-fixed-objects
322 (defoptimizer (cons stack-allocate-result
) ((&rest args
) node dx
)
323 (declare (ignore args dx
))
325 (defoptimizer (%make-complex stack-allocate-result
) ((&rest args
) node dx
)
326 (declare (ignore args dx
))
329 ;;; MAKE-LIST optimizations
332 (defoptimizer (%make-list stack-allocate-result
) ((length element
) node dx
)
333 (declare (ignore element
))
334 (or (eq dx
:always-dynamic
)
335 (zerop (policy node safety
))
336 ;; At most one page (this is more paranoid than %listify-rest-args).
337 ;; Really what you want to do is decrement the stack pointer by one page
338 ;; at a time, filling in CDR pointers downward. Then this restriction
339 ;; could be removed, because allocation would never miss the guard page
340 ;; if it tries to consume too much stack space.
341 (values-subtypep (lvar-derived-type length
)
343 (specifier-type `(integer 0 ,(/ sb
!vm
::*backend-page-bytes
*
344 sb
!vm
:n-word-bytes
2)))))))
345 (defoptimizer (%make-list ltn-annotate
) ((length element
) call ltn-policy
)
346 (declare (ignore length element
))
347 (vectorish-ltn-annotate-helper call ltn-policy
348 'sb
!vm
::allocate-list-on-stack
)))