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 ir2-convert-reffer ((object) node block name offset lowtag)
20 (let* ((lvar (node-lvar node))
21 (locs (lvar-result-tns lvar
22 (list *backend-t-primitive-type*)))
24 (vop slot node block (lvar-tn node block object)
25 name offset lowtag res)
26 (move-lvar-result node block locs lvar)))
28 (defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
29 (let ((value-tn (lvar-tn node block value)))
30 (vop set-slot node block (lvar-tn node block object) value-tn
32 (move-lvar-result node block (list value-tn) (node-lvar node))))
34 ;;; FIXME: Isn't there a name for this which looks less like a typo?
35 ;;; (The name IR2-CONVERT-SETTER is used for something else, just above.)
36 (defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag)
37 (let ((value-tn (lvar-tn node block value)))
38 (vop set-slot node block (lvar-tn node block object) value-tn
40 (move-lvar-result node block (list value-tn) (node-lvar node))))
42 #!+compare-and-swap-vops
43 (defoptimizer ir2-convert-casser
44 ((object old new) node block name offset lowtag)
45 (let* ((lvar (node-lvar node))
46 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
48 (vop compare-and-swap-slot node block
49 (lvar-tn node block object)
50 (lvar-tn node block old)
51 (lvar-tn node block new)
54 (move-lvar-result node block locs lvar)))
56 (defun emit-inits (node block name object lowtag instance-length inits args)
57 #!-raw-instance-init-vops
58 (declare (ignore instance-length))
59 (let ((unbound-marker-tn nil)
60 (funcallable-instance-tramp-tn nil))
62 (let ((kind (car init))
66 (let ((raw-type (pop slot))
67 (arg-tn (lvar-tn node block (pop args))))
68 (macrolet ((make-case ()
71 (vop set-slot node block object arg-tn
72 name (+ sb!vm:instance-slots-offset slot) lowtag))
73 ,@(mapcar (lambda (rsd)
74 `(,(sb!kernel::raw-slot-data-raw-type rsd)
75 (vop ,(sb!kernel::raw-slot-data-init-vop rsd)
77 object arg-tn instance-length slot)))
78 #!+raw-instance-init-vops
79 sb!kernel::*raw-slot-data-list*
80 #!-raw-instance-init-vops
84 (vop set-slot node block object
85 (emit-constant (sb!kernel::dd-layout-or-lose slot))
86 name sb!vm:instance-slots-offset lowtag))
88 (vop set-slot node block object
92 (lvar-tn node block (pop args)))
95 (setf unbound-marker-tn
96 (let ((tn (make-restricted-tn
98 (sc-number-or-lose 'sb!vm::any-reg))))
99 (vop make-unbound-marker node block tn)
103 (:funcallable-instance-tramp
104 (or funcallable-instance-tramp-tn
105 (setf funcallable-instance-tramp-tn
106 (let ((tn (make-restricted-tn
108 (sc-number-or-lose 'sb!vm::any-reg))))
109 (vop make-funcallable-instance-tramp node block tn)
111 name slot lowtag))))))
113 (bug "Leftover args: ~S" args)))
115 (defun emit-fixed-alloc (node block name words type lowtag result lvar)
116 (let ((stack-allocate-p (and lvar (lvar-dynamic-extent lvar))))
117 (when stack-allocate-p
118 (vop current-stack-pointer node block
119 (ir2-lvar-stack-pointer (lvar-info lvar))))
120 (vop fixed-alloc node block name words type lowtag stack-allocate-p result)))
122 (defoptimizer ir2-convert-fixed-allocation
123 ((&rest args) node block name words type lowtag inits)
124 (let* ((lvar (node-lvar node))
125 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
126 (result (first locs)))
127 (emit-fixed-alloc node block name words type lowtag result lvar)
128 (emit-inits node block name result lowtag words inits args)
129 (move-lvar-result node block locs lvar)))
131 (defoptimizer ir2-convert-variable-allocation
132 ((extra &rest args) node block name words type lowtag inits)
133 (let* ((lvar (node-lvar node))
134 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
135 (result (first locs)))
136 (if (constant-lvar-p extra)
137 (let ((words (+ (lvar-value extra) words)))
138 (emit-fixed-alloc node block name words type lowtag result lvar))
139 (vop var-alloc node block (lvar-tn node block extra) name words
141 (emit-inits node block name result lowtag nil inits args)
142 (move-lvar-result node block locs lvar)))
144 (defoptimizer ir2-convert-structure-allocation
145 ((dd slot-specs &rest args) node block name words type lowtag inits)
146 (let* ((lvar (node-lvar node))
147 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
148 (result (first locs)))
149 (aver (constant-lvar-p dd))
150 (aver (constant-lvar-p slot-specs))
151 (let* ((c-dd (lvar-value dd))
152 (c-slot-specs (lvar-value slot-specs))
153 (words (+ (sb!kernel::dd-instance-length c-dd) words)))
154 (emit-fixed-alloc node block name words type lowtag result lvar)
155 (emit-inits node block name result lowtag words `((:dd . ,c-dd) ,@c-slot-specs) args)
156 (move-lvar-result node block locs lvar))))
158 (defoptimizer (initialize-vector ir2-convert)
159 ((vector &rest initial-contents) node block)
160 (let* ((vector-ctype (lvar-type vector))
161 (elt-ctype (if (array-type-p vector-ctype)
162 (array-type-specialized-element-type vector-ctype)
163 (bug "Unknow vector type in IR2 conversion for ~S."
164 'initialize-vector)))
165 (saetp (find-saetp-by-ctype elt-ctype))
166 (lvar (node-lvar node))
167 (locs (lvar-result-tns lvar (list (primitive-type vector-ctype))))
168 (result (first locs))
169 (elt-ptype (primitive-type elt-ctype))
170 (tmp (make-normal-tn elt-ptype)))
171 (emit-move node block (lvar-tn node block vector) result)
172 (flet ((compute-setter ()
175 (let ((*package* (find-package :sb!vm))
178 (when (sb!vm:saetp-specifier s)
180 `(,(sb!vm:saetp-typecode s)
183 (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
184 (sb!vm:saetp-primitive-type-name s))
185 node block result index tn 0 tn)
187 (vop ,(symbolicate "DATA-VECTOR-SET/"
188 (sb!vm:saetp-primitive-type-name s))
189 node block result index tn tn)))
191 sb!vm:*specialized-array-element-type-properties*)
192 `(ecase (sb!vm:saetp-typecode saetp)
193 ,@(nreverse clauses)))))
196 (constant-tn (find-constant index))))
197 (let ((setter (compute-setter))
198 (length (length initial-contents)))
200 (emit-move node block (lvar-tn node block (pop initial-contents)) tmp)
201 (funcall setter (tnify i) tmp))))
202 (move-lvar-result node block locs lvar)))
204 ;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite
205 ;;; cut it for symbols, where under certain compilation options
206 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
207 ;;; than simply set the slot. So we build the IR2 converting function
208 ;;; by hand. -- CSR, 2003-05-08
209 (let ((fun-info (fun-info-or-lose '%set-symbol-value)))
210 (setf (fun-info-ir2-convert fun-info)
212 (let ((args (basic-combination-args node)))
213 (destructuring-bind (symbol value) args
214 (let ((value-tn (lvar-tn node block value)))
216 (lvar-tn node block symbol) value-tn)
218 node block (list value-tn) (node-lvar node))))))))
220 ;;; Stack allocation optimizers per platform support
222 ;;; Platforms with stack-allocatable vectors
223 #!+(or hppa mips x86 x86-64)
225 (defoptimizer (allocate-vector stack-allocate-result)
226 ((type length words) node dx)
228 (zerop (policy node safety))
229 ;; a vector object should fit in one page -- otherwise it might go past
230 ;; stack guard pages.
231 (values-subtypep (lvar-derived-type words)
233 (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-bytes*
235 sb!vm:vector-data-offset)))))))
237 (defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy)
238 (let ((args (basic-combination-args call))
239 (template (template-or-lose (if (awhen (node-lvar call)
240 (lvar-dynamic-extent it))
241 'sb!vm::allocate-vector-on-stack
242 'sb!vm::allocate-vector-on-heap))))
244 (setf (lvar-info arg)
245 (make-ir2-lvar (primitive-type (lvar-type arg)))))
246 (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
247 (ltn-default-call call)
248 (return-from allocate-vector-ltn-annotate-optimizer (values)))
249 (setf (basic-combination-info call) template)
250 (setf (node-tail-p call) nil)
253 (annotate-1-value-lvar arg)))))
256 #!+(or alpha hppa mips ppc sparc x86 x86-64)
258 (defoptimizer (list stack-allocate-result) ((&rest args) node dx)
259 (declare (ignore node dx))
261 (defoptimizer (list* stack-allocate-result) ((&rest args) node dx)
262 (declare (ignore node dx))
263 (not (null (rest args))))
264 (defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args) node dx)
265 (declare (ignore node dx))
269 #!+(or hppa mips x86 x86-64)
270 (defoptimizer (cons stack-allocate-result) ((&rest args) node dx)
271 (declare (ignore node dx))