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 #!+compact-instance-header
195 (progn (aver (= type sb
!vm
:instance-widetag
))
196 (emit-constant (setq type
(sb!kernel
::dd-layout-or-lose c-dd
))))
197 (emit-fixed-alloc node block name words type lowtag result lvar
)
198 (emit-inits node block name result lowtag
199 `(#!-compact-instance-header
(: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 (constant-lvar-p value
)
261 (eql (char-code (lvar-value value
)) 0)
262 (eql (lvar-value value
) 0)))
263 (emit-move node block
(lvar-tn node block value
) tmp
)
264 (funcall setter
(tnify i
) tmp
))))))
265 (move-lvar-result node block locs lvar
)))
267 ;;; An array header for simple non-unidimensional arrays is a fixed alloc,
268 ;;; because the rank has to be known.
269 ;;; (There are no compile-time optimizations for unknown rank arrays)
270 (defoptimizer (make-array-header* ir2-convert
) ((&rest args
) node block
)
271 (let ((n-args (length args
)))
272 (ir2-convert-fixed-allocation
273 node block
'make-array
274 ;; Each argument fills in one slot of the array header.
275 ;; Add one word for the primitive object's header word.
277 ;; MAKE-ARRAY optimizations will not kick in for complex arrays.
278 sb
!vm
:simple-array-widetag
279 sb
!vm
:other-pointer-lowtag
280 (loop for i from
1 to n-args collect
`(:arg .
,i
)))))
282 ;;; :SET-TRANS (in objdef.lisp !DEFINE-PRIMITIVE-OBJECT) doesn't quite
283 ;;; cut it for symbols, where under certain compilation options
284 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
285 ;;; than simply set the slot. So we build the IR2 converting function
286 ;;; by hand. -- CSR, 2003-05-08
287 (let ((fun-info (fun-info-or-lose '%set-symbol-value
)))
288 (setf (fun-info-ir2-convert fun-info
)
290 (let ((args (basic-combination-args node
)))
291 (destructuring-bind (symbol value
) args
292 (let ((value-tn (lvar-tn node block value
)))
294 (lvar-tn node block symbol
) value-tn
)
296 node block
(list value-tn
) (node-lvar node
))))))))
298 ;;; Stack allocation optimizers per platform support
299 #!+stack-allocatable-vectors
301 (defoptimizer (make-array-header* stack-allocate-result
) ((&rest args
) node dx
)
304 (defoptimizer (allocate-vector stack-allocate-result
)
305 ((type length words
) node dx
)
306 (declare (ignorable type
) (ignore length
))
308 ;; Can't put unboxed data on the stack unless we scavenge it
310 #!-c-stack-is-control-stack
311 (constant-lvar-p type
)
312 #!-c-stack-is-control-stack
313 (member (lvar-value type
)
314 '#.
(list (sb!vm
:saetp-typecode
(find-saetp 't
))
315 (sb!vm
:saetp-typecode
(find-saetp 'fixnum
))))
316 (or (eq dx
:always-dynamic
)
317 (zerop (policy node safety
))
318 ;; a vector object should fit in one page -- otherwise it might go past
319 ;; stack guard pages.
320 (values-subtypep (lvar-derived-type words
)
322 (specifier-type `(integer 0 ,(- (/ sb
!vm
::*backend-page-bytes
*
324 sb
!vm
:vector-data-offset
))))))))
326 (defoptimizer (allocate-vector ltn-annotate
) ((type length words
) call ltn-policy
)
327 (declare (ignore type length words
))
328 (vectorish-ltn-annotate-helper call ltn-policy
329 'sb
!vm
::allocate-vector-on-stack
330 'sb
!vm
::allocate-vector-on-heap
))
332 (defun vectorish-ltn-annotate-helper (call ltn-policy dx-template
&optional not-dx-template
)
333 (let* ((args (basic-combination-args call
))
334 (template-name (if (node-stack-allocate-p call
)
337 (template (and template-name
338 (template-or-lose template-name
))))
340 (setf (lvar-info arg
)
341 (make-ir2-lvar (primitive-type (lvar-type arg
)))))
342 (unless (and template
343 (is-ok-template-use template call
(ltn-policy-safe-p ltn-policy
)))
344 (ltn-default-call call
)
345 (return-from vectorish-ltn-annotate-helper
(values)))
346 (setf (basic-combination-info call
) template
)
347 (setf (node-tail-p call
) nil
)
350 (annotate-1-value-lvar arg
)))))
353 #!+stack-allocatable-lists
355 (defoptimizer (list stack-allocate-result
) ((&rest args
) node dx
)
356 (declare (ignore dx
))
358 (defoptimizer (list* stack-allocate-result
) ((&rest args
) node dx
)
359 (declare (ignore dx
))
360 (not (null (rest args
))))
361 (defoptimizer (%listify-rest-args stack-allocate-result
) ((&rest args
) node dx
)
362 (declare (ignore args dx
))
366 #!+stack-allocatable-fixed-objects
368 (defoptimizer (cons stack-allocate-result
) ((&rest args
) node dx
)
369 (declare (ignore args dx
))
371 (defoptimizer (%make-complex stack-allocate-result
) ((&rest args
) node dx
)
372 (declare (ignore args dx
))
375 ;;; MAKE-LIST optimizations
378 (defoptimizer (%make-list stack-allocate-result
) ((length element
) node dx
)
379 (declare (ignore element
))
380 (or (eq dx
:always-dynamic
)
381 (zerop (policy node safety
))
382 ;; At most one page (this is more paranoid than %listify-rest-args).
383 ;; Really what you want to do is decrement the stack pointer by one page
384 ;; at a time, filling in CDR pointers downward. Then this restriction
385 ;; could be removed, because allocation would never miss the guard page
386 ;; if it tries to consume too much stack space.
387 (values-subtypep (lvar-derived-type length
)
389 (specifier-type `(integer 0 ,(/ sb
!vm
::*backend-page-bytes
*
390 sb
!vm
:n-word-bytes
2)))))))
391 (defoptimizer (%make-list ltn-annotate
) ((length element
) call ltn-policy
)
392 (declare (ignore length element
))
393 (vectorish-ltn-annotate-helper call ltn-policy
394 'sb
!vm
::allocate-list-on-stack
)))
398 ;;; Return a list of parameters with which to call MAKE-ARRAY-HEADER*
399 ;;; given the mandatory slots for a simple array of rank 0 or > 1.
400 (defun make-array-header-inits (storage n-elements dimensions
)
401 (macrolet ((expand ()
402 `(list* ,@(mapcar (lambda (slot)
403 (ecase (slot-name slot
)
405 (fill-pointer 'n-elements
)
406 (elements 'n-elements
)
410 (displaced-from nil
)))
411 (butlast (primitive-object-slots
412 (find 'array
*primitive-objects
*
413 :key
'primitive-object-name
))))