0.8.21.50:
[sbcl.git] / src / compiler / x86 / alloc.lisp
1 ;;;; allocation VOPs for the x86
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; LIST and LIST*
15 (defoptimizer (list stack-allocate-result) ((&rest args))
16   (not (null args)))
17 (defoptimizer (list* stack-allocate-result) ((&rest args))
18   (not (null (rest args))))
19
20 (define-vop (list-or-list*)
21   (:args (things :more t))
22   (:temporary (:sc unsigned-reg) ptr temp)
23   (:temporary (:sc unsigned-reg :to (:result 0) :target result) res)
24   (:info num)
25   (:results (result :scs (descriptor-reg)))
26   (:variant-vars star)
27   (:policy :safe)
28   (:node-var node)
29   (:generator 0
30     (cond ((zerop num)
31            ;; (move result nil-value)
32            (inst mov result nil-value))
33           ((and star (= num 1))
34            (move result (tn-ref-tn things)))
35           (t
36            (macrolet
37                ((store-car (tn list &optional (slot cons-car-slot))
38                   `(let ((reg
39                           (sc-case ,tn
40                             ((any-reg descriptor-reg) ,tn)
41                             ((control-stack)
42                              (move temp ,tn)
43                              temp))))
44                      (storew reg ,list ,slot list-pointer-lowtag))))
45              (let ((cons-cells (if star (1- num) num)))
46                (pseudo-atomic
47                 (allocation res (* (pad-data-block cons-size) cons-cells) node
48                             (awhen (sb!c::node-lvar node) (sb!c::lvar-dynamic-extent it)))
49                 (inst lea res
50                       (make-ea :byte :base res :disp list-pointer-lowtag))
51                 (move ptr res)
52                 (dotimes (i (1- cons-cells))
53                   (store-car (tn-ref-tn things) ptr)
54                   (setf things (tn-ref-across things))
55                   (inst add ptr (pad-data-block cons-size))
56                   (storew ptr ptr (- cons-cdr-slot cons-size)
57                           list-pointer-lowtag))
58                 (store-car (tn-ref-tn things) ptr)
59                 (cond (star
60                        (setf things (tn-ref-across things))
61                        (store-car (tn-ref-tn things) ptr cons-cdr-slot))
62                       (t
63                        (storew nil-value ptr cons-cdr-slot
64                                list-pointer-lowtag)))
65                 (aver (null (tn-ref-across things)))))
66              (move result res))))))
67
68 (define-vop (list list-or-list*)
69   (:variant nil))
70
71 (define-vop (list* list-or-list*)
72   (:variant t))
73 \f
74 ;;;; special-purpose inline allocators
75
76 ;;; ALLOCATE-VECTOR
77 (define-vop (allocate-vector-on-heap)
78   (:args (type :scs (unsigned-reg))
79          (length :scs (any-reg))
80          (words :scs (any-reg)))
81   (:results (result :scs (descriptor-reg) :from :load))
82   (:arg-types positive-fixnum
83               positive-fixnum
84               positive-fixnum)
85   (:policy :fast-safe)
86   (:generator 100
87     (inst lea result (make-ea :byte :base words :disp
88                               (+ (1- (ash 1 n-lowtag-bits))
89                                  (* vector-data-offset n-word-bytes))))
90     (inst and result (lognot lowtag-mask))
91     (pseudo-atomic
92       (allocation result result)
93       (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
94       (storew type result 0 other-pointer-lowtag)
95       (storew length result vector-length-slot other-pointer-lowtag))))
96
97 (define-vop (allocate-vector-on-stack)
98   (:args (type :scs (unsigned-reg))
99          (length :scs (any-reg))
100          (words :scs (any-reg) :target ecx))
101   (:temporary (:sc any-reg :offset ecx-offset :from (:argument 2)) ecx)
102   (:temporary (:sc any-reg :offset eax-offset :from (:argument 2)) zero)
103   (:temporary (:sc any-reg :offset edi-offset :from (:argument 0)) res)
104   (:results (result :scs (descriptor-reg) :from :load))
105   (:arg-types positive-fixnum
106               positive-fixnum
107               positive-fixnum)
108   (:translate allocate-vector)
109   (:policy :fast-safe)
110   (:node-var node)
111   (:generator 100
112     (inst lea result (make-ea :byte :base words :disp
113                               (+ (1- (ash 1 n-lowtag-bits))
114                                  (* vector-data-offset n-word-bytes))))
115     (inst and result (lognot lowtag-mask))
116     ;; FIXME: It would be good to check for stack overflow here.
117     (move ecx words)
118     (inst shr ecx n-fixnum-tag-bits)
119     (allocation result result node t)
120     (inst cld)
121     (inst lea res
122           (make-ea :byte :base result :disp (* vector-data-offset n-word-bytes)))
123     (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
124     (storew type result 0 other-pointer-lowtag)
125     (storew length result vector-length-slot other-pointer-lowtag)
126     (inst xor zero zero)
127     (inst rep)
128     (inst stos zero)))
129
130 (in-package :sb!c)
131 (defoptimizer (allocate-vector stack-allocate-result)
132     ((type length words) node)
133   (ecase (policy node stack-allocate-vector)
134     (0 nil)
135     ((1 2)
136      ;; a vector object should fit in one page
137      (values-subtypep (lvar-derived-type words)
138                       (load-time-value
139                        (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-size*
140                                                           sb!vm:n-word-bytes)
141                                                        sb!vm:vector-data-offset))))))
142     (3 t)))
143
144 (defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy)
145   (let ((args (basic-combination-args call))
146         (template (template-or-lose (if (awhen (node-lvar call)
147                                           (lvar-dynamic-extent it))
148                                         'sb!vm::allocate-vector-on-stack
149                                         'sb!vm::allocate-vector-on-heap))))
150     (dolist (arg args)
151       (setf (lvar-info arg)
152             (make-ir2-lvar (primitive-type (lvar-type arg)))))
153     (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
154       (ltn-default-call call)
155       (return-from allocate-vector-ltn-annotate-optimizer (values)))
156     (setf (basic-combination-info call) template)
157     (setf (node-tail-p call) nil)
158
159     (dolist (arg args)
160       (annotate-1-value-lvar arg))))
161 (in-package :sb!vm)
162
163 ;;;
164 (define-vop (allocate-code-object)
165   (:args (boxed-arg :scs (any-reg) :target boxed)
166          (unboxed-arg :scs (any-reg) :target unboxed))
167   (:results (result :scs (descriptor-reg) :from :eval))
168   (:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
169   (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
170   (:node-var node)
171   (:generator 100
172     (move boxed boxed-arg)
173     (inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
174     (inst and boxed (lognot lowtag-mask))
175     (move unboxed unboxed-arg)
176     (inst shr unboxed word-shift)
177     (inst add unboxed lowtag-mask)
178     (inst and unboxed (lognot lowtag-mask))
179     (inst mov result boxed)
180     (inst add result unboxed)
181     (pseudo-atomic
182      (allocation result result node)
183      (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
184      (inst shl boxed (- n-widetag-bits word-shift))
185      (inst or boxed code-header-widetag)
186      (storew boxed result 0 other-pointer-lowtag)
187      (storew unboxed result code-code-size-slot other-pointer-lowtag)
188      (storew nil-value result code-entry-points-slot other-pointer-lowtag))
189     (storew nil-value result code-debug-info-slot other-pointer-lowtag)))
190 \f
191 (define-vop (make-fdefn)
192   (:policy :fast-safe)
193   (:translate make-fdefn)
194   (:args (name :scs (descriptor-reg) :to :eval))
195   (:results (result :scs (descriptor-reg) :from :argument))
196   (:node-var node)
197   (:generator 37
198     (with-fixed-allocation (result fdefn-widetag fdefn-size node)
199       (storew name result fdefn-name-slot other-pointer-lowtag)
200       (storew nil-value result fdefn-fun-slot other-pointer-lowtag)
201       (storew (make-fixup "undefined_tramp" :foreign)
202               result fdefn-raw-addr-slot other-pointer-lowtag))))
203
204 (define-vop (make-closure)
205   (:args (function :to :save :scs (descriptor-reg)))
206   (:info length stack-allocate-p)
207   (:temporary (:sc any-reg) temp)
208   (:results (result :scs (descriptor-reg)))
209   (:node-var node)
210   (:generator 10
211    (maybe-pseudo-atomic stack-allocate-p
212      (let ((size (+ length closure-info-offset)))
213        (allocation result (pad-data-block size) node
214                    stack-allocate-p)
215        (inst lea result
216              (make-ea :byte :base result :disp fun-pointer-lowtag))
217        (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
218                result 0 fun-pointer-lowtag))
219     (loadw temp function closure-fun-slot fun-pointer-lowtag)
220     (storew temp result closure-fun-slot fun-pointer-lowtag))))
221
222 ;;; The compiler likes to be able to directly make value cells.
223 (define-vop (make-value-cell)
224   (:args (value :scs (descriptor-reg any-reg) :to :result))
225   (:results (result :scs (descriptor-reg) :from :eval))
226   (:node-var node)
227   (:generator 10
228     (with-fixed-allocation
229         (result value-cell-header-widetag value-cell-size node))
230     (storew value result value-cell-value-slot other-pointer-lowtag)))
231 \f
232 ;;;; automatic allocators for primitive objects
233
234 (define-vop (make-unbound-marker)
235   (:args)
236   (:results (result :scs (any-reg)))
237   (:generator 1
238     (inst mov result unbound-marker-widetag)))
239
240 (define-vop (fixed-alloc)
241   (:args)
242   (:info name words type lowtag)
243   (:ignore name)
244   (:results (result :scs (descriptor-reg)))
245   (:node-var node)
246   (:generator 50
247     (pseudo-atomic
248      (allocation result (pad-data-block words) node)
249      (inst lea result (make-ea :byte :base result :disp lowtag))
250      (when type
251        (storew (logior (ash (1- words) n-widetag-bits) type)
252                result
253                0
254                lowtag)))))
255
256 (define-vop (var-alloc)
257   (:args (extra :scs (any-reg)))
258   (:arg-types positive-fixnum)
259   (:info name words type lowtag)
260   (:ignore name)
261   (:results (result :scs (descriptor-reg) :from (:eval 1)))
262   (:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes)
263   (:temporary (:sc any-reg :from :eval :to :result) header)
264   (:node-var node)
265   (:generator 50
266     (inst lea bytes
267           (make-ea :dword :base extra :disp (* (1+ words) n-word-bytes)))
268     (inst mov header bytes)
269     (inst shl header (- n-widetag-bits 2)) ; w+1 to length field
270     (inst lea header                    ; (w-1 << 8) | type
271           (make-ea :dword :base header :disp (+ (ash -2 n-widetag-bits) type)))
272     (inst and bytes (lognot lowtag-mask))
273     (pseudo-atomic
274      (allocation result bytes node)
275      (inst lea result (make-ea :byte :base result :disp lowtag))
276      (storew header result 0 lowtag))))
277
278