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
)
17 (declare (ignore node dx
))
20 (defoptimizer ir2-convert-reffer
((object) node block name offset lowtag
)
21 (let* ((lvar (node-lvar node
))
22 (locs (lvar-result-tns lvar
23 (list *backend-t-primitive-type
*)))
25 (vop slot node block
(lvar-tn node block object
)
26 name offset lowtag res
)
27 (move-lvar-result node block locs lvar
)))
29 (defoptimizer ir2-convert-setter
((object value
) node block name offset lowtag
)
30 (let ((value-tn (lvar-tn node block value
)))
31 (vop set-slot node block
(lvar-tn node block object
) value-tn
33 (move-lvar-result node block
(list value-tn
) (node-lvar node
))))
35 ;;; FIXME: Isn't there a name for this which looks less like a typo?
36 ;;; (The name IR2-CONVERT-SETTER is used for something else, just above.)
37 (defoptimizer ir2-convert-setfer
((value object
) node block name offset lowtag
)
38 (let ((value-tn (lvar-tn node block value
)))
39 (vop set-slot node block
(lvar-tn node block object
) value-tn
41 (move-lvar-result node block
(list value-tn
) (node-lvar node
))))
43 #!+compare-and-swap-vops
44 (defoptimizer ir2-convert-casser
45 ((object old new
) node block name offset lowtag
)
46 (let* ((lvar (node-lvar node
))
47 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
49 (vop compare-and-swap-slot node block
50 (lvar-tn node block object
)
51 (lvar-tn node block old
)
52 (lvar-tn node block new
)
55 (move-lvar-result node block locs lvar
)))
57 (defun emit-inits (node block name object lowtag instance-length inits args
)
58 #!-raw-instance-init-vops
59 (declare (ignore instance-length
))
60 (let ((unbound-marker-tn nil
)
61 (funcallable-instance-tramp-tn nil
))
63 (let ((kind (car init
))
67 (let ((raw-type (pop slot
))
68 (arg-tn (lvar-tn node block
(pop args
))))
69 (macrolet ((make-case ()
72 (vop set-slot node block object arg-tn
73 name
(+ sb
!vm
:instance-slots-offset slot
) lowtag
))
74 ,@(mapcar (lambda (rsd)
75 `(,(sb!kernel
::raw-slot-data-raw-type rsd
)
76 (vop ,(sb!kernel
::raw-slot-data-init-vop rsd
)
78 object arg-tn instance-length slot
)))
79 #!+raw-instance-init-vops
80 sb
!kernel
::*raw-slot-data-list
*
81 #!-raw-instance-init-vops
85 (vop set-slot node block object
86 (emit-constant (sb!kernel
::dd-layout-or-lose slot
))
87 name sb
!vm
:instance-slots-offset lowtag
))
89 (vop set-slot node block object
93 (lvar-tn node block
(pop args
)))
96 (setf unbound-marker-tn
97 (let ((tn (make-restricted-tn
99 (sc-number-or-lose 'sb
!vm
::any-reg
))))
100 (vop make-unbound-marker node block tn
)
104 (:funcallable-instance-tramp
105 (or funcallable-instance-tramp-tn
106 (setf funcallable-instance-tramp-tn
107 (let ((tn (make-restricted-tn
109 (sc-number-or-lose 'sb
!vm
::any-reg
))))
110 (vop make-funcallable-instance-tramp node block tn
)
112 name slot lowtag
))))))
114 (bug "Leftover args: ~S" args
)))
116 (defun emit-fixed-alloc (node block name words type lowtag result lvar
)
117 (let ((stack-allocate-p (and lvar
(lvar-dynamic-extent lvar
))))
118 (when stack-allocate-p
119 (vop current-stack-pointer node block
120 (ir2-lvar-stack-pointer (lvar-info lvar
))))
121 (vop fixed-alloc node block name words type lowtag stack-allocate-p result
)))
123 (defoptimizer ir2-convert-fixed-allocation
124 ((&rest args
) node block name words type lowtag inits
)
125 (let* ((lvar (node-lvar node
))
126 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
127 (result (first locs
)))
128 (emit-fixed-alloc node block name words type lowtag result lvar
)
129 (emit-inits node block name result lowtag words inits args
)
130 (move-lvar-result node block locs lvar
)))
132 (defoptimizer ir2-convert-variable-allocation
133 ((extra &rest args
) node block name words type lowtag inits
)
134 (let* ((lvar (node-lvar node
))
135 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
136 (result (first locs
)))
137 (if (constant-lvar-p extra
)
138 (let ((words (+ (lvar-value extra
) words
)))
139 (emit-fixed-alloc node block name words type lowtag result lvar
))
140 (vop var-alloc node block
(lvar-tn node block extra
) name words
142 (emit-inits node block name result lowtag nil inits args
)
143 (move-lvar-result node block locs lvar
)))
145 (defoptimizer ir2-convert-structure-allocation
146 ((dd slot-specs
&rest args
) node block name words type lowtag inits
)
147 (let* ((lvar (node-lvar node
))
148 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
149 (result (first locs
)))
150 (aver (constant-lvar-p dd
))
151 (aver (constant-lvar-p slot-specs
))
152 (let* ((c-dd (lvar-value dd
))
153 (c-slot-specs (lvar-value slot-specs
))
154 (words (+ (sb!kernel
::dd-instance-length c-dd
) words
)))
155 (emit-fixed-alloc node block name words type lowtag result lvar
)
156 (emit-inits node block name result lowtag words
`((:dd .
,c-dd
) ,@c-slot-specs
) args
)
157 (move-lvar-result node block locs lvar
))))
159 ;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite
160 ;;; cut it for symbols, where under certain compilation options
161 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
162 ;;; than simply set the slot. So we build the IR2 converting function
163 ;;; by hand. -- CSR, 2003-05-08
164 (let ((fun-info (fun-info-or-lose '%set-symbol-value
)))
165 (setf (fun-info-ir2-convert fun-info
)
167 (let ((args (basic-combination-args node
)))
168 (destructuring-bind (symbol value
) args
169 (let ((value-tn (lvar-tn node block value
)))
171 (lvar-tn node block symbol
) value-tn
)
173 node block
(list value-tn
) (node-lvar node
))))))))
175 ;;; Stack allocation optimizers per platform support
177 ;;; Platforms with stack-allocatable vectors
180 (defoptimizer (allocate-vector stack-allocate-result
)
181 ((type length words
) node dx
)
183 (zerop (policy node safety
))
184 ;; a vector object should fit in one page -- otherwise it might go past
185 ;; stack guard pages.
186 (values-subtypep (lvar-derived-type words
)
188 (specifier-type `(integer 0 ,(- (/ sb
!vm
::*backend-page-size
*
190 sb
!vm
:vector-data-offset
)))))))
192 (defoptimizer (allocate-vector ltn-annotate
) ((type length words
) call ltn-policy
)
193 (let ((args (basic-combination-args call
))
194 (template (template-or-lose (if (awhen (node-lvar call
)
195 (lvar-dynamic-extent it
))
196 'sb
!vm
::allocate-vector-on-stack
197 'sb
!vm
::allocate-vector-on-heap
))))
199 (setf (lvar-info arg
)
200 (make-ir2-lvar (primitive-type (lvar-type arg
)))))
201 (unless (is-ok-template-use template call
(ltn-policy-safe-p ltn-policy
))
202 (ltn-default-call call
)
203 (return-from allocate-vector-ltn-annotate-optimizer
(values)))
204 (setf (basic-combination-info call
) template
)
205 (setf (node-tail-p call
) nil
)
208 (annotate-1-value-lvar arg
)))))
211 #!+(or alpha mips ppc sparc x86 x86-64
)
213 (defoptimizer (list stack-allocate-result
) ((&rest args
) node dx
)
214 (declare (ignore node dx
))
216 (defoptimizer (list* stack-allocate-result
) ((&rest args
) node dx
)
217 (declare (ignore node dx
))
218 (not (null (rest args
))))
219 (defoptimizer (%listify-rest-args stack-allocate-result
) ((&rest args
) node dx
)
220 (declare (ignore node dx
))
225 (defoptimizer (cons stack-allocate-result
) ((&rest args
) node dx
)
226 (declare (ignore node dx
))