0.pre7.20:
[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
16 (define-vop (list-or-list*)
17   (:args (things :more t))
18   (:temporary (:sc unsigned-reg) ptr temp)
19   (:temporary (:sc unsigned-reg :to (:result 0) :target result) res)
20   (:info num)
21   (:results (result :scs (descriptor-reg)))
22   (:variant-vars star)
23   (:policy :safe)
24   (:node-var node)
25   (:generator 0
26     (cond ((zerop num)
27            ;; (move result nil-value)
28            (inst mov result nil-value))
29           ((and star (= num 1))
30            (move result (tn-ref-tn things)))
31           (t
32            (macrolet
33                ((store-car (tn list &optional (slot sb!vm:cons-car-slot))
34                   `(let ((reg
35                           (sc-case ,tn
36                             ((any-reg descriptor-reg) ,tn)
37                             ((control-stack)
38                              (move temp ,tn)
39                              temp))))
40                      (storew reg ,list ,slot sb!vm:list-pointer-type))))
41              (let ((cons-cells (if star (1- num) num)))
42                (pseudo-atomic
43                 (allocation res (* (pad-data-block cons-size) cons-cells) node)
44                 (inst lea res
45                       (make-ea :byte :base res :disp list-pointer-type))
46                 (move ptr res)
47                 (dotimes (i (1- cons-cells))
48                   (store-car (tn-ref-tn things) ptr)
49                   (setf things (tn-ref-across things))
50                   (inst add ptr (pad-data-block cons-size))
51                   (storew ptr ptr (- cons-cdr-slot cons-size)
52                           list-pointer-type))
53                 (store-car (tn-ref-tn things) ptr)
54                 (cond (star
55                        (setf things (tn-ref-across things))
56                        (store-car (tn-ref-tn things) ptr cons-cdr-slot))
57                       (t
58                        (storew nil-value ptr cons-cdr-slot
59                                list-pointer-type)))
60                 (aver (null (tn-ref-across things)))))
61              (move result res))))))
62
63 (define-vop (list list-or-list*)
64   (:variant nil))
65
66 (define-vop (list* list-or-list*)
67   (:variant t))
68 \f
69 ;;;; special-purpose inline allocators
70
71 (define-vop (allocate-code-object)
72   (:args (boxed-arg :scs (any-reg) :target boxed)
73          (unboxed-arg :scs (any-reg) :target unboxed))
74   (:results (result :scs (descriptor-reg)))
75   (:temporary (:sc unsigned-reg :from :eval) temp)
76   (:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
77   (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
78   (:generator 100
79     (move boxed boxed-arg)
80     (inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
81     (inst and boxed (lognot lowtag-mask))
82     (move unboxed unboxed-arg)
83     (inst shr unboxed word-shift)
84     (inst add unboxed lowtag-mask)
85     (inst and unboxed (lognot lowtag-mask))
86     (pseudo-atomic
87      ;; comment from CMU CL code:
88      ;;   now loading code into static space cause it can't move
89      ;;
90      ;; KLUDGE: What? What's all the cruft about saving fixups for then?
91      ;; I think what's happened is that ALLOCATE-CODE-OBJECT is the basic
92      ;; CMU CL primitive; this ALLOCATE-CODE-OBJECT was hacked for
93      ;; static space only in a simple-minded port to the X86; and then
94      ;; in an attempt to improve the port to the X86,
95      ;; ALLOCATE-DYNAMIC-CODE-OBJECT was defined. If that's right, I'd like
96      ;; to know why not just go back to the basic CMU CL behavior of
97      ;; ALLOCATE-CODE-OBJECT, where it makes a relocatable code object.
98      ;;   -- WHN 19990916
99      ;;
100      ;; FIXME: should have a check for overflow of static space
101      (load-symbol-value temp sb!vm:*static-space-free-pointer*)
102      (inst lea result (make-ea :byte :base temp :disp other-pointer-type))
103      (inst add temp boxed)
104      (inst add temp unboxed)
105      (store-symbol-value temp sb!vm:*static-space-free-pointer*)
106      (inst shl boxed (- type-bits word-shift))
107      (inst or boxed code-header-type)
108      (storew boxed result 0 other-pointer-type)
109      (storew unboxed result code-code-size-slot other-pointer-type)
110      (inst mov temp nil-value)
111      (storew temp result code-entry-points-slot other-pointer-type))
112     (storew temp result code-debug-info-slot other-pointer-type)))
113
114 (define-vop (allocate-dynamic-code-object)
115   (:args (boxed-arg :scs (any-reg) :target boxed)
116          (unboxed-arg :scs (any-reg) :target unboxed))
117   (:results (result :scs (descriptor-reg) :from :eval))
118   (:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
119   (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
120   (:node-var node)
121   (:generator 100
122     (move boxed boxed-arg)
123     (inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
124     (inst and boxed (lognot lowtag-mask))
125     (move unboxed unboxed-arg)
126     (inst shr unboxed word-shift)
127     (inst add unboxed lowtag-mask)
128     (inst and unboxed (lognot lowtag-mask))
129     (inst mov result boxed)
130     (inst add result unboxed)
131     (pseudo-atomic
132      (allocation result result node)
133      (inst lea result (make-ea :byte :base result :disp other-pointer-type))
134      (inst shl boxed (- type-bits word-shift))
135      (inst or boxed code-header-type)
136      (storew boxed result 0 other-pointer-type)
137      (storew unboxed result code-code-size-slot other-pointer-type)
138      (storew nil-value result code-entry-points-slot other-pointer-type))
139     (storew nil-value result code-debug-info-slot other-pointer-type)))
140 \f
141 (define-vop (make-fdefn)
142   (:policy :fast-safe)
143   (:translate make-fdefn)
144   (:args (name :scs (descriptor-reg) :to :eval))
145   (:results (result :scs (descriptor-reg) :from :argument))
146   (:node-var node)
147   (:generator 37
148     (with-fixed-allocation (result fdefn-type fdefn-size node)
149       (storew name result fdefn-name-slot other-pointer-type)
150       (storew nil-value result fdefn-function-slot other-pointer-type)
151       (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
152               result fdefn-raw-addr-slot other-pointer-type))))
153
154 (define-vop (make-closure)
155   (:args (function :to :save :scs (descriptor-reg)))
156   (:info length)
157   (:temporary (:sc any-reg) temp)
158   (:results (result :scs (descriptor-reg)))
159   (:node-var node)
160   (:generator 10
161    (pseudo-atomic
162     (let ((size (+ length closure-info-offset)))
163       (allocation result (pad-data-block size) node)
164       (inst lea result
165             (make-ea :byte :base result :disp function-pointer-type))
166       (storew (logior (ash (1- size) type-bits) closure-header-type)
167               result 0 function-pointer-type))
168     (loadw temp function closure-function-slot function-pointer-type)
169     (storew temp result closure-function-slot function-pointer-type))))
170
171 ;;; The compiler likes to be able to directly make value cells.
172 (define-vop (make-value-cell)
173   (:args (value :scs (descriptor-reg any-reg) :to :result))
174   (:results (result :scs (descriptor-reg) :from :eval))
175   (:node-var node)
176   (:generator 10
177     (with-fixed-allocation
178         (result value-cell-header-type value-cell-size node))
179     (storew value result value-cell-value-slot other-pointer-type)))
180 \f
181 ;;;; automatic allocators for primitive objects
182
183 (define-vop (make-unbound-marker)
184   (:args)
185   (:results (result :scs (any-reg)))
186   (:generator 1
187     (inst mov result unbound-marker-type)))
188
189 (define-vop (fixed-alloc)
190   (:args)
191   (:info name words type lowtag)
192   (:ignore name)
193   (:results (result :scs (descriptor-reg)))
194   (:node-var node)
195   (:generator 50
196     (pseudo-atomic
197      (allocation result (pad-data-block words) node)
198      (inst lea result (make-ea :byte :base result :disp lowtag))
199      (when type
200        (storew (logior (ash (1- words) type-bits) type) result 0 lowtag)))))
201
202 (define-vop (var-alloc)
203   (:args (extra :scs (any-reg)))
204   (:arg-types positive-fixnum)
205   (:info name words type lowtag)
206   (:ignore name)
207   (:results (result :scs (descriptor-reg) :from (:eval 1)))
208   (:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes)
209   (:temporary (:sc any-reg :from :eval :to :result) header)
210   (:node-var node)
211   (:generator 50
212     (inst lea bytes
213           (make-ea :dword :base extra :disp (* (1+ words) word-bytes)))
214     (inst mov header bytes)
215     (inst shl header (- type-bits 2))   ; w+1 to length field
216
217     (inst lea header                    ; (w-1 << 8) | type
218           (make-ea :dword :base header :disp (+ (ash -2 type-bits) type)))
219     (inst and bytes (lognot lowtag-mask))
220     (pseudo-atomic
221      (allocation result bytes node)
222      (inst lea result (make-ea :byte :base result :disp lowtag))
223      (storew header result 0 lowtag))))
224
225 (define-vop (make-symbol)
226   (:policy :fast-safe)
227   (:translate make-symbol)
228   (:args (name :scs (descriptor-reg) :to :eval))
229   (:temporary (:sc unsigned-reg :from :eval) temp)
230   (:results (result :scs (descriptor-reg) :from :argument))
231   (:node-var node)
232   (:generator 37
233     (with-fixed-allocation (result symbol-header-type symbol-size node)
234       (storew name result symbol-name-slot other-pointer-type)
235       (storew unbound-marker-type result symbol-value-slot other-pointer-type)
236       ;; Set up a random hash value for the symbol. Perhaps the object
237       ;; address could be used for even faster and smaller code!
238       ;; FIXME: We don't mind the symbol hash not being repeatable, so
239       ;; we might as well add in the object address here, too. (Adding entropy
240       ;; is good, even if ANSI doesn't understand that.)
241       (inst imul temp
242             (make-fixup (extern-alien-name "fast_random_state") :foreign)
243             1103515245)
244       (inst add temp 12345)
245       (inst mov (make-fixup (extern-alien-name "fast_random_state") :foreign)
246             temp)
247       ;; We want a positive fixnum for the hash value, so discard the LS bits.
248       (inst shr temp 1)
249       (inst and temp #xfffffffc)
250       (storew temp result symbol-hash-slot other-pointer-type)
251       (storew nil-value result symbol-plist-slot other-pointer-type)
252       (storew nil-value result symbol-package-slot other-pointer-type))))