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 (defoptimizer (%make-structure-instance stack-allocate-result) ((&rest args) node dx)
19 (defoptimizer (make-array stack-allocate-result) ((&rest args) node dx)
20 ;; The actual stack allocation decision will be made on the basis of what
21 ;; ALLOCATE-VECTOR, but this is needed so that (FILL (MAKE-ARRAY N) X) and
22 ;; (REPLACE (MAKE-ARRAY (LENGTH V)) V) can potentially stack allocate the
26 (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
27 (let* ((lvar (node-lvar node))
28 (locs (lvar-result-tns lvar
29 (list *backend-t-primitive-type*)))
31 (vop slot node block (lvar-tn node block object)
32 name offset lowtag res)
33 (move-lvar-result node block locs lvar)))
35 (defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
36 (let ((value-tn (lvar-tn node block value)))
37 (vop set-slot node block (lvar-tn node block object) value-tn
39 (move-lvar-result node block (list value-tn) (node-lvar node))))
41 ;;; FIXME: Isn't there a name for this which looks less like a typo?
42 ;;; (The name IR2-CONVERT-SETTER is used for something else, just above.)
43 (defoptimizer ir2-convert-setfer ((value object) 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 #!+compare-and-swap-vops
50 (defoptimizer ir2-convert-casser
51 ((object old new) node block name offset lowtag)
52 (let* ((lvar (node-lvar node))
53 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
55 (vop compare-and-swap-slot node block
56 (lvar-tn node block object)
57 (lvar-tn node block old)
58 (lvar-tn node block new)
61 (move-lvar-result node block locs lvar)))
63 (defun emit-inits (node block name object lowtag instance-length inits args)
64 #!-raw-instance-init-vops
65 (declare (ignore instance-length))
66 (let ((unbound-marker-tn nil)
67 (funcallable-instance-tramp-tn nil))
69 (let ((kind (car init))
73 (let ((raw-type (pop slot))
74 (arg-tn (lvar-tn node block (pop args))))
75 (macrolet ((make-case ()
78 (vop set-slot node block object arg-tn
79 name (+ sb!vm:instance-slots-offset slot) lowtag))
80 ,@(mapcar (lambda (rsd)
81 `(,(sb!kernel::raw-slot-data-raw-type rsd)
82 (vop ,(sb!kernel::raw-slot-data-init-vop rsd)
84 object arg-tn instance-length slot)))
85 #!+raw-instance-init-vops
86 sb!kernel::*raw-slot-data-list*
87 #!-raw-instance-init-vops
91 (vop set-slot node block object
92 (emit-constant (sb!kernel::dd-layout-or-lose slot))
93 name sb!vm:instance-slots-offset lowtag))
95 (vop set-slot node block object
99 (lvar-tn node block (pop args)))
101 (or unbound-marker-tn
102 (setf unbound-marker-tn
103 (let ((tn (make-restricted-tn
105 (sc-number-or-lose 'sb!vm::any-reg))))
106 (vop make-unbound-marker node block tn)
110 (:funcallable-instance-tramp
111 (or funcallable-instance-tramp-tn
112 (setf funcallable-instance-tramp-tn
113 (let ((tn (make-restricted-tn
115 (sc-number-or-lose 'sb!vm::any-reg))))
116 (vop make-funcallable-instance-tramp node block tn)
118 name slot lowtag))))))
120 (bug "Leftover args: ~S" args)))
122 (defun emit-fixed-alloc (node block name words type lowtag result lvar)
123 (let ((stack-allocate-p (and lvar (lvar-dynamic-extent lvar))))
124 (when stack-allocate-p
125 (vop current-stack-pointer node block
126 (ir2-lvar-stack-pointer (lvar-info lvar))))
127 (vop fixed-alloc node block name words type lowtag stack-allocate-p result)))
129 (defoptimizer ir2-convert-fixed-allocation
130 ((&rest args) node block name words type lowtag inits)
131 (let* ((lvar (node-lvar node))
132 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
133 (result (first locs)))
134 (emit-fixed-alloc node block name words type lowtag result lvar)
135 (emit-inits node block name result lowtag words inits args)
136 (move-lvar-result node block locs lvar)))
138 (defoptimizer ir2-convert-variable-allocation
139 ((extra &rest args) node block name words type lowtag inits)
140 (let* ((lvar (node-lvar node))
141 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
142 (result (first locs)))
143 (if (constant-lvar-p extra)
144 (let ((words (+ (lvar-value extra) words)))
145 (emit-fixed-alloc node block name words type lowtag result lvar))
146 (vop var-alloc node block (lvar-tn node block extra) name words
148 (emit-inits node block name result lowtag nil inits args)
149 (move-lvar-result node block locs lvar)))
151 (defoptimizer ir2-convert-structure-allocation
152 ((dd slot-specs &rest args) node block name words type lowtag inits)
153 (let* ((lvar (node-lvar node))
154 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
155 (result (first locs)))
156 (aver (constant-lvar-p dd))
157 (aver (constant-lvar-p slot-specs))
158 (let* ((c-dd (lvar-value dd))
159 (c-slot-specs (lvar-value slot-specs))
160 (words (+ (sb!kernel::dd-instance-length c-dd) words)))
161 (emit-fixed-alloc node block name words type lowtag result lvar)
162 (emit-inits node block name result lowtag words `((:dd . ,c-dd) ,@c-slot-specs) args)
163 (move-lvar-result node block locs lvar))))
165 ;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite
166 ;;; cut it for symbols, where under certain compilation options
167 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
168 ;;; than simply set the slot. So we build the IR2 converting function
169 ;;; by hand. -- CSR, 2003-05-08
170 (let ((fun-info (fun-info-or-lose '%set-symbol-value)))
171 (setf (fun-info-ir2-convert fun-info)
173 (let ((args (basic-combination-args node)))
174 (destructuring-bind (symbol value) args
175 (let ((value-tn (lvar-tn node block value)))
177 (lvar-tn node block symbol) value-tn)
179 node block (list value-tn) (node-lvar node))))))))
181 ;;; Stack allocation optimizers per platform support
183 ;;; Platforms with stack-allocatable vectors
184 #!+(or hppa mips x86 x86-64)
186 (defoptimizer (allocate-vector stack-allocate-result)
187 ((type length words) node dx)
189 (zerop (policy node safety))
190 ;; a vector object should fit in one page -- otherwise it might go past
191 ;; stack guard pages.
192 (values-subtypep (lvar-derived-type words)
194 (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-bytes*
196 sb!vm:vector-data-offset)))))))
198 (defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy)
199 (let ((args (basic-combination-args call))
200 (template (template-or-lose (if (awhen (node-lvar call)
201 (lvar-dynamic-extent it))
202 'sb!vm::allocate-vector-on-stack
203 'sb!vm::allocate-vector-on-heap))))
205 (setf (lvar-info arg)
206 (make-ir2-lvar (primitive-type (lvar-type arg)))))
207 (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
208 (ltn-default-call call)
209 (return-from allocate-vector-ltn-annotate-optimizer (values)))
210 (setf (basic-combination-info call) template)
211 (setf (node-tail-p call) nil)
214 (annotate-1-value-lvar arg)))))
217 #!+(or alpha hppa mips ppc sparc x86 x86-64)
219 (defoptimizer (list stack-allocate-result) ((&rest args) node dx)
220 (declare (ignore node dx))
222 (defoptimizer (list* stack-allocate-result) ((&rest args) node dx)
223 (declare (ignore node dx))
224 (not (null (rest args))))
225 (defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args) node dx)
226 (declare (ignore node dx))
230 #!+(or hppa mips x86 x86-64)
231 (defoptimizer (cons stack-allocate-result) ((&rest args) node dx)
232 (declare (ignore node dx))