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-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 (dx-p (node-stack-allocate-p node
)))
75 (flet ((zero-init-p (x)
76 ;; dynamic-space is already zeroed
79 (eql (lvar-value x
) 0))))
81 (let ((kind (car init
))
85 ;; FIXME: the only reason INIT-SLOT raw variants exist is to avoid
86 ;; an extra MOVE - setters return a value, but INITers don't.
87 ;; It would probably produce better code by not assuming that
88 ;; setters return a value, because as things are, if you call
89 ;; 8 setters in a row, then you probably produce 7 extraneous moves,
90 ;; because not all of them can deliver a value to the final result.
91 (let ((raw-type (pop slot
))
93 (unless (and (or (eq raw-type t
)
94 (eq raw-type
'word
)) ;; can be made to handle floats
96 (let ((arg-tn (lvar-tn node block arg
)))
98 ((make-case (&optional rsd-list
)
101 (vop init-slot node block object arg-tn
102 name dx-p
(+ sb
!vm
:instance-slots-offset slot
) lowtag
))
105 `(,(sb!kernel
::raw-slot-data-raw-type rsd
)
106 (vop ,(sb!kernel
::raw-slot-data-init-vop rsd
)
107 node block object arg-tn slot
)))
108 (symbol-value rsd-list
)))))
109 (make-case #!+raw-instance-init-vops
110 sb
!kernel
::*raw-slot-data
*))))))
112 (vop init-slot node block object
113 (emit-constant (sb!kernel
::dd-layout-or-lose slot
))
115 ;; Layout has no index if compact headers.
116 (or #!+compact-instance-header
:layout sb
!vm
:instance-slots-offset
)
119 (if (and (eq kind
:arg
)
120 (zero-init-p (car args
)))
122 (vop init-slot node block object
126 (lvar-tn node block
(pop args
)))
128 ;; SLOT should be the word index to alter, but with structure
129 ;; instances, SLOT is a cons whose car is the raw-slot-type
130 ;; since BOXED-COMBINATION-REF-P expects that #'cddr is the
133 (setq slot
(+ (cdr slot
) sb
!vm
:instance-slots-offset
)))
134 (or unbound-marker-tn
135 (setf unbound-marker-tn
136 (let ((tn (make-restricted-tn
138 (sc-number-or-lose 'sb
!vm
::any-reg
))))
139 (vop make-unbound-marker node block tn
)
143 (:funcallable-instance-tramp
144 (or funcallable-instance-tramp-tn
145 (setf funcallable-instance-tramp-tn
146 (let ((tn (make-restricted-tn
148 (sc-number-or-lose 'sb
!vm
::any-reg
))))
149 (vop make-funcallable-instance-tramp node block tn
)
151 name dx-p slot lowtag
))))))))
153 (bug "Leftover args: ~S" args
)))
155 (defun emit-fixed-alloc (node block name words type lowtag result lvar
)
156 (let ((stack-allocate-p (and lvar
(lvar-dynamic-extent lvar
))))
157 (when stack-allocate-p
158 (vop current-stack-pointer node block
159 (ir2-lvar-stack-pointer (lvar-info lvar
))))
160 (vop fixed-alloc node block name words type lowtag stack-allocate-p result
)))
162 (defoptimizer ir2-convert-fixed-allocation
163 ((&rest args
) node block name words type lowtag inits
)
164 (let* ((lvar (node-lvar node
))
165 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
166 (result (first locs
)))
167 (emit-fixed-alloc node block name words type lowtag result lvar
)
168 (emit-inits node block name result lowtag inits args
)
169 (move-lvar-result node block locs lvar
)))
171 (defoptimizer ir2-convert-variable-allocation
172 ((extra &rest args
) node block name words type lowtag inits
)
173 (let* ((lvar (node-lvar node
))
174 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
175 (result (first locs
)))
176 (if (constant-lvar-p extra
)
177 (let ((words (+ (lvar-value extra
) words
)))
178 (emit-fixed-alloc node block name words type lowtag result lvar
))
179 (vop var-alloc node block
(lvar-tn node block extra
) name words
181 (emit-inits node block name result lowtag inits args
)
182 (move-lvar-result node block locs lvar
)))
184 (defoptimizer ir2-convert-structure-allocation
185 ((dd slot-specs
&rest args
) node block name words type lowtag inits
)
186 (declare (ignore inits
))
187 (let* ((lvar (node-lvar node
))
188 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
189 (result (first locs
)))
190 (aver (and (constant-lvar-p dd
) (constant-lvar-p slot-specs
) (= words
1)))
191 (let* ((c-dd (lvar-value dd
))
192 (c-slot-specs (lvar-value slot-specs
))
193 (words (+ (dd-length c-dd
) words
)))
194 (emit-fixed-alloc node block name words type lowtag result lvar
)
195 (emit-inits node block name result lowtag
`((:dd .
,c-dd
) ,@c-slot-specs
) args
)
196 (move-lvar-result node block locs lvar
))))
198 (defoptimizer (initialize-vector ir2-convert
)
199 ((vector &rest initial-contents
) node block
)
200 (let* ((vector-ctype (lvar-type vector
))
201 (elt-ctype (if (array-type-p vector-ctype
)
202 (array-type-specialized-element-type vector-ctype
)
203 (bug "Unknow vector type in IR2 conversion for ~S."
204 'initialize-vector
)))
205 (saetp (find-saetp-by-ctype elt-ctype
))
206 (lvar (node-lvar node
))
207 (locs (lvar-result-tns lvar
(list (primitive-type vector-ctype
))))
208 (result (first locs
))
209 (elt-ptype (primitive-type elt-ctype
))
210 (tmp (make-normal-tn elt-ptype
)))
211 (emit-move node block
(lvar-tn node block vector
) result
)
212 (flet ((compute-setter ()
215 (let ((*package
* (find-package :sb
!vm
))
218 (when (sb!vm
:saetp-specifier s
)
220 `(,(sb!vm
:saetp-typecode s
)
223 (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
224 (sb!vm
:saetp-primitive-type-name s
)
226 node block result tn index
0 tn
)
228 (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
229 (sb!vm
:saetp-primitive-type-name s
))
230 node block result index tn
0 tn
)
232 (vop ,(symbolicate "DATA-VECTOR-SET/"
233 (sb!vm
:saetp-primitive-type-name s
))
234 node block result index tn tn
)))
236 sb
!vm
:*specialized-array-element-type-properties
*)
237 `(ecase (sb!vm
:saetp-typecode saetp
)
238 ,@(nreverse clauses
)))))
242 (emit-constant index
)
245 (let ((setter (compute-setter))
246 (length (length initial-contents
))
248 (lvar-dynamic-extent lvar
)))
249 (character (eq (primitive-type-name elt-ptype
)
252 (let ((value (pop initial-contents
)))
253 ;; dynamic-space is already zeroed
254 (unless (and (not dx-p
)
255 (constant-lvar-p value
)
257 (eql (char-code (lvar-value value
)) 0)
258 (eql (lvar-value value
) 0)))
259 (emit-move node block
(lvar-tn node block value
) tmp
)
260 (funcall setter
(tnify i
) tmp
))))))
261 (move-lvar-result node block locs lvar
)))
263 ;;; An array header for simple non-unidimensional arrays is a fixed alloc,
264 ;;; because the rank has to be known.
265 ;;; (There are no compile-time optimizations for unknown rank arrays)
266 (defoptimizer (make-array-header* ir2-convert
) ((&rest args
) node block
)
267 (let ((n-args (length args
)))
268 (ir2-convert-fixed-allocation
269 node block
'make-array
270 ;; Each argument fills in one slot of the array header.
271 ;; Add one word for the primitive object's header word.
273 ;; MAKE-ARRAY optimizations will not kick in for complex arrays.
274 sb
!vm
:simple-array-widetag
275 sb
!vm
:other-pointer-lowtag
276 (loop for i from
1 to n-args collect
`(:arg .
,i
)))))
278 ;;; :SET-TRANS (in objdef.lisp !DEFINE-PRIMITIVE-OBJECT) doesn't quite
279 ;;; cut it for symbols, where under certain compilation options
280 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
281 ;;; than simply set the slot. So we build the IR2 converting function
282 ;;; by hand. -- CSR, 2003-05-08
283 (let ((fun-info (fun-info-or-lose '%set-symbol-value
)))
284 (setf (fun-info-ir2-convert fun-info
)
286 (let ((args (basic-combination-args node
)))
287 (destructuring-bind (symbol value
) args
288 (let ((value-tn (lvar-tn node block value
)))
290 (lvar-tn node block symbol
) value-tn
)
292 node block
(list value-tn
) (node-lvar node
))))))))
294 ;;; Stack allocation optimizers per platform support
295 #!+stack-allocatable-vectors
297 (defoptimizer (make-array-header* stack-allocate-result
) ((&rest args
) node dx
)
300 (defoptimizer (allocate-vector stack-allocate-result
)
301 ((type length words
) node dx
)
302 (declare (ignorable type
) (ignore length
))
304 ;; Can't put unboxed data on the stack unless we scavenge it
306 #!-c-stack-is-control-stack
307 (constant-lvar-p type
)
308 #!-c-stack-is-control-stack
309 (member (lvar-value type
)
310 '#.
(list (sb!vm
:saetp-typecode
(find-saetp 't
))
311 (sb!vm
:saetp-typecode
(find-saetp 'fixnum
))))
312 (or (eq dx
:always-dynamic
)
313 (zerop (policy node safety
))
314 ;; a vector object should fit in one page -- otherwise it might go past
315 ;; stack guard pages.
316 (values-subtypep (lvar-derived-type words
)
318 (specifier-type `(integer 0 ,(- (/ sb
!vm
::*backend-page-bytes
*
320 sb
!vm
:vector-data-offset
))))))))
322 (defoptimizer (allocate-vector ltn-annotate
) ((type length words
) call ltn-policy
)
323 (declare (ignore type length words
))
324 (vectorish-ltn-annotate-helper call ltn-policy
325 'sb
!vm
::allocate-vector-on-stack
326 'sb
!vm
::allocate-vector-on-heap
))
328 (defun vectorish-ltn-annotate-helper (call ltn-policy dx-template
&optional not-dx-template
)
329 (let* ((args (basic-combination-args call
))
330 (template-name (if (node-stack-allocate-p call
)
333 (template (and template-name
334 (template-or-lose template-name
))))
336 (setf (lvar-info arg
)
337 (make-ir2-lvar (primitive-type (lvar-type arg
)))))
338 (unless (and template
339 (is-ok-template-use template call
(ltn-policy-safe-p ltn-policy
)))
340 (ltn-default-call call
)
341 (return-from vectorish-ltn-annotate-helper
(values)))
342 (setf (basic-combination-info call
) template
)
343 (setf (node-tail-p call
) nil
)
346 (annotate-1-value-lvar arg
)))))
349 #!+stack-allocatable-lists
351 (defoptimizer (list stack-allocate-result
) ((&rest args
) node dx
)
352 (declare (ignore dx
))
354 (defoptimizer (list* stack-allocate-result
) ((&rest args
) node dx
)
355 (declare (ignore dx
))
356 (not (null (rest args
))))
357 (defoptimizer (%listify-rest-args stack-allocate-result
) ((&rest args
) node dx
)
358 (declare (ignore args dx
))
362 #!+stack-allocatable-fixed-objects
364 (defoptimizer (cons stack-allocate-result
) ((&rest args
) node dx
)
365 (declare (ignore args dx
))
367 (defoptimizer (%make-complex stack-allocate-result
) ((&rest args
) node dx
)
368 (declare (ignore args dx
))
371 ;;; MAKE-LIST optimizations
374 (defoptimizer (%make-list stack-allocate-result
) ((length element
) node dx
)
375 (declare (ignore element
))
376 (or (eq dx
:always-dynamic
)
377 (zerop (policy node safety
))
378 ;; At most one page (this is more paranoid than %listify-rest-args).
379 ;; Really what you want to do is decrement the stack pointer by one page
380 ;; at a time, filling in CDR pointers downward. Then this restriction
381 ;; could be removed, because allocation would never miss the guard page
382 ;; if it tries to consume too much stack space.
383 (values-subtypep (lvar-derived-type length
)
385 (specifier-type `(integer 0 ,(/ sb
!vm
::*backend-page-bytes
*
386 sb
!vm
:n-word-bytes
2)))))))
387 (defoptimizer (%make-list ltn-annotate
) ((length element
) call ltn-policy
)
388 (declare (ignore length element
))
389 (vectorish-ltn-annotate-helper call ltn-policy
390 'sb
!vm
::allocate-list-on-stack
)))
394 ;;; Return a list of parameters with which to call MAKE-ARRAY-HEADER*
395 ;;; given the mandatory slots for a simple array of rank 0 or > 1.
396 (defun make-array-header-inits (storage n-elements dimensions
)
397 (macrolet ((expand ()
398 `(list* ,@(mapcar (lambda (slot)
399 (ecase (slot-name slot
)
401 (fill-pointer 'n-elements
)
402 (elements 'n-elements
)
406 (displaced-from nil
)))
407 (butlast (primitive-object-slots
408 (find 'array
*primitive-objects
*
409 :key
'primitive-object-name
))))