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
)
77 (lvar (node-lvar node
)))
78 (flet ((zero-init-p (x)
79 ;; dynamic-space is already zeroed
81 (not (lvar-dynamic-extent lvar
)))
82 ;; KLUDGE: can't ignore type-derived
83 ;; constants since they can be closed over
84 ;; and not using them confuses the register
86 ;; See compiler.pure/cons-zero-initialization
87 (strictly-constant-lvar-p x
)
88 (eql (lvar-value x
) 0))))
90 (let ((kind (car init
))
94 ;; FIXME: with #!+interleaved-raw-slots the only reason INIT-SLOT
95 ;; and its raw variants exist is to avoid an extra MOVE -
96 ;; setters are expected to return something, but INITers don't.
97 ;; It would probably produce better code by not assuming that
98 ;; setters return a value, because as things are, if you call
99 ;; 8 setters in a row, then you probably produce 7 extraneous moves,
100 ;; because not all of them can deliver a value to the final result.
101 (let ((raw-type (pop slot
))
103 (unless (and (or (eq raw-type t
)
104 (eq raw-type
'word
)) ;; can be made to handle floats
106 (let ((arg-tn (lvar-tn node block arg
)))
108 ((make-case (&optional rsd-list
)
111 (vop init-slot node block object arg-tn
112 name
(+ sb
!vm
:instance-slots-offset slot
) lowtag
))
115 `(,(sb!kernel
::raw-slot-data-raw-type rsd
)
116 (vop ,(sb!kernel
::raw-slot-data-init-vop rsd
)
117 node block object arg-tn
118 #!-interleaved-raw-slots instance-length
120 (symbol-value rsd-list
)))))
121 (make-case #!+raw-instance-init-vops
122 sb
!kernel
::*raw-slot-data
*))))))
124 (vop init-slot node block object
125 (emit-constant (sb!kernel
::dd-layout-or-lose slot
))
126 name sb
!vm
:instance-slots-offset lowtag
))
128 (if (and (eq kind
:arg
)
129 (zero-init-p (car args
)))
131 (vop init-slot node block object
135 (lvar-tn node block
(pop args
)))
137 (or unbound-marker-tn
138 (setf unbound-marker-tn
139 (let ((tn (make-restricted-tn
141 (sc-number-or-lose 'sb
!vm
::any-reg
))))
142 (vop make-unbound-marker node block tn
)
146 (:funcallable-instance-tramp
147 (or funcallable-instance-tramp-tn
148 (setf funcallable-instance-tramp-tn
149 (let ((tn (make-restricted-tn
151 (sc-number-or-lose 'sb
!vm
::any-reg
))))
152 (vop make-funcallable-instance-tramp node block tn
)
154 name slot lowtag
))))))))
156 (bug "Leftover args: ~S" args
)))
158 (defun emit-fixed-alloc (node block name words type lowtag result lvar
)
159 (let ((stack-allocate-p (and lvar
(lvar-dynamic-extent lvar
))))
160 (when stack-allocate-p
161 (vop current-stack-pointer node block
162 (ir2-lvar-stack-pointer (lvar-info lvar
))))
163 (vop fixed-alloc node block name words type lowtag stack-allocate-p result
)))
165 (defoptimizer ir2-convert-fixed-allocation
166 ((&rest args
) node block name words type lowtag inits
)
167 (let* ((lvar (node-lvar node
))
168 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
169 (result (first locs
)))
170 (emit-fixed-alloc node block name words type lowtag result lvar
)
171 (emit-inits node block name result lowtag words inits args
)
172 (move-lvar-result node block locs lvar
)))
174 (defoptimizer ir2-convert-variable-allocation
175 ((extra &rest args
) node block name words type lowtag inits
)
176 (let* ((lvar (node-lvar node
))
177 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
178 (result (first locs
)))
179 (if (constant-lvar-p extra
)
180 (let ((words (+ (lvar-value extra
) words
)))
181 (emit-fixed-alloc node block name words type lowtag result lvar
))
182 (vop var-alloc node block
(lvar-tn node block extra
) name words
184 (emit-inits node block name result lowtag nil inits args
)
185 (move-lvar-result node block locs lvar
)))
187 (defoptimizer ir2-convert-structure-allocation
188 ((dd slot-specs
&rest args
) node block name words type lowtag inits
)
189 (declare (ignore inits
))
190 (let* ((lvar (node-lvar node
))
191 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
192 (result (first locs
)))
193 (aver (constant-lvar-p dd
))
194 (aver (constant-lvar-p slot-specs
))
195 (let* ((c-dd (lvar-value dd
))
196 (c-slot-specs (lvar-value slot-specs
))
197 (words (+ (sb!kernel
::dd-instance-length c-dd
) words
)))
198 (emit-fixed-alloc node block name words type lowtag result lvar
)
199 (emit-inits node block name result lowtag words
`((:dd .
,c-dd
) ,@c-slot-specs
) args
)
200 (move-lvar-result node block locs lvar
))))
202 (defoptimizer (initialize-vector ir2-convert
)
203 ((vector &rest initial-contents
) node block
)
204 (let* ((vector-ctype (lvar-type vector
))
205 (elt-ctype (if (array-type-p vector-ctype
)
206 (array-type-specialized-element-type vector-ctype
)
207 (bug "Unknow vector type in IR2 conversion for ~S."
208 'initialize-vector
)))
209 (saetp (find-saetp-by-ctype elt-ctype
))
210 (lvar (node-lvar node
))
211 (locs (lvar-result-tns lvar
(list (primitive-type vector-ctype
))))
212 (result (first locs
))
213 (elt-ptype (primitive-type elt-ctype
))
214 (tmp (make-normal-tn elt-ptype
)))
215 (emit-move node block
(lvar-tn node block vector
) result
)
216 (flet ((compute-setter ()
219 (let ((*package
* (find-package :sb
!vm
))
222 (when (sb!vm
:saetp-specifier s
)
224 `(,(sb!vm
:saetp-typecode s
)
227 (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
228 (sb!vm
:saetp-primitive-type-name s
)
230 node block result tn index
0 tn
)
232 (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
233 (sb!vm
:saetp-primitive-type-name s
))
234 node block result index tn
0 tn
)
236 (vop ,(symbolicate "DATA-VECTOR-SET/"
237 (sb!vm
:saetp-primitive-type-name s
))
238 node block result index tn tn
)))
240 sb
!vm
:*specialized-array-element-type-properties
*)
241 `(ecase (sb!vm
:saetp-typecode saetp
)
242 ,@(nreverse clauses
)))))
246 (emit-constant index
)
249 (let ((setter (compute-setter))
250 (length (length initial-contents
))
252 (lvar-dynamic-extent lvar
)))
253 (character (eq (primitive-type-name elt-ptype
)
256 (let ((value (pop initial-contents
)))
257 ;; dynamic-space is already zeroed
258 (unless (and (not dx-p
)
259 ;; KLUDGE: can't ignore type-derived
260 ;; constants since they can be closed over
261 ;; and not using them confuses the register
263 ;; See compiler.pure/vector-zero-initialization
264 (strictly-constant-lvar-p value
)
266 (eql (char-code (lvar-value value
)) 0)
267 (eql (lvar-value value
) 0)))
268 (emit-move node block
(lvar-tn node block value
) tmp
)
269 (funcall setter
(tnify i
) tmp
))))))
270 (move-lvar-result node block locs lvar
)))
272 ;;; :SET-TRANS (in objdef.lisp !DEFINE-PRIMITIVE-OBJECT) doesn't quite
273 ;;; cut it for symbols, where under certain compilation options
274 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
275 ;;; than simply set the slot. So we build the IR2 converting function
276 ;;; by hand. -- CSR, 2003-05-08
277 (let ((fun-info (fun-info-or-lose '%set-symbol-value
)))
278 (setf (fun-info-ir2-convert fun-info
)
280 (let ((args (basic-combination-args node
)))
281 (destructuring-bind (symbol value
) args
282 (let ((value-tn (lvar-tn node block value
)))
284 (lvar-tn node block symbol
) value-tn
)
286 node block
(list value-tn
) (node-lvar node
))))))))
288 ;;; Stack allocation optimizers per platform support
289 #!+stack-allocatable-vectors
291 (defoptimizer (allocate-vector stack-allocate-result
)
292 ((type length words
) node dx
)
293 (declare (ignorable type
) (ignore length
))
295 ;; Can't put unboxed data on the stack unless we scavenge it
297 #!-c-stack-is-control-stack
298 (constant-lvar-p type
)
299 #!-c-stack-is-control-stack
300 (member (lvar-value type
)
301 '#.
(list (sb!vm
:saetp-typecode
(find-saetp 't
))
302 (sb!vm
:saetp-typecode
(find-saetp 'fixnum
))))
303 (or (eq dx
:always-dynamic
)
304 (zerop (policy node safety
))
305 ;; a vector object should fit in one page -- otherwise it might go past
306 ;; stack guard pages.
307 (values-subtypep (lvar-derived-type words
)
309 (specifier-type `(integer 0 ,(- (/ sb
!vm
::*backend-page-bytes
*
311 sb
!vm
:vector-data-offset
))))))))
313 (defoptimizer (allocate-vector ltn-annotate
) ((type length words
) call ltn-policy
)
314 (declare (ignore type length words
))
315 (vectorish-ltn-annotate-helper call ltn-policy
316 'sb
!vm
::allocate-vector-on-stack
317 'sb
!vm
::allocate-vector-on-heap
))
319 (defun vectorish-ltn-annotate-helper (call ltn-policy dx-template
&optional not-dx-template
)
320 (let* ((args (basic-combination-args call
))
321 (template-name (if (awhen (node-lvar call
)
322 (lvar-dynamic-extent it
))
325 (template (and template-name
326 (template-or-lose template-name
))))
328 (setf (lvar-info arg
)
329 (make-ir2-lvar (primitive-type (lvar-type arg
)))))
330 (unless (and template
331 (is-ok-template-use template call
(ltn-policy-safe-p ltn-policy
)))
332 (ltn-default-call call
)
333 (return-from vectorish-ltn-annotate-helper
(values)))
334 (setf (basic-combination-info call
) template
)
335 (setf (node-tail-p call
) nil
)
338 (annotate-1-value-lvar arg
)))))
341 #!+stack-allocatable-lists
343 (defoptimizer (list stack-allocate-result
) ((&rest args
) node dx
)
344 (declare (ignore dx
))
346 (defoptimizer (list* stack-allocate-result
) ((&rest args
) node dx
)
347 (declare (ignore dx
))
348 (not (null (rest args
))))
349 (defoptimizer (%listify-rest-args stack-allocate-result
) ((&rest args
) node dx
)
350 (declare (ignore args dx
))
354 #!+stack-allocatable-fixed-objects
356 (defoptimizer (cons stack-allocate-result
) ((&rest args
) node dx
)
357 (declare (ignore args dx
))
359 (defoptimizer (%make-complex stack-allocate-result
) ((&rest args
) node dx
)
360 (declare (ignore args dx
))
363 ;;; MAKE-LIST optimizations
366 (defoptimizer (%make-list stack-allocate-result
) ((length element
) node dx
)
367 (declare (ignore element
))
368 (or (eq dx
:always-dynamic
)
369 (zerop (policy node safety
))
370 ;; At most one page (this is more paranoid than %listify-rest-args).
371 ;; Really what you want to do is decrement the stack pointer by one page
372 ;; at a time, filling in CDR pointers downward. Then this restriction
373 ;; could be removed, because allocation would never miss the guard page
374 ;; if it tries to consume too much stack space.
375 (values-subtypep (lvar-derived-type length
)
377 (specifier-type `(integer 0 ,(/ sb
!vm
::*backend-page-bytes
*
378 sb
!vm
:n-word-bytes
2)))))))
379 (defoptimizer (%make-list ltn-annotate
) ((length element
) call ltn-policy
)
380 (declare (ignore length element
))
381 (vectorish-ltn-annotate-helper call ltn-policy
382 'sb
!vm
::allocate-list-on-stack
)))