1 ;;;; allocation VOPs for the x86
3 ;;;; This software is part of the SBCL system. See the README file for
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.
19 (define-vop (list-or-list*)
20 (:args (things :more t))
21 (:temporary (:sc unsigned-reg) ptr temp)
22 (:temporary (:sc unsigned-reg :to (:result 0) :target result) res)
24 (:results (result :scs (descriptor-reg)))
30 ;; (move result nil-value)
31 (inst mov result nil-value))
33 (move result (tn-ref-tn things)))
36 ((store-car (tn list &optional (slot sb!vm:cons-car-slot))
39 ((any-reg descriptor-reg) ,tn)
43 (storew reg ,list ,slot sb!vm:list-pointer-type))))
44 (let ((cons-cells (if star (1- num) num)))
46 (allocation res (* (pad-data-block cons-size) cons-cells) node)
48 (make-ea :byte :base res :disp list-pointer-type))
50 (dotimes (i (1- cons-cells))
51 (store-car (tn-ref-tn things) ptr)
52 (setf things (tn-ref-across things))
53 (inst add ptr (pad-data-block cons-size))
54 (storew ptr ptr (- cons-cdr-slot cons-size)
56 (store-car (tn-ref-tn things) ptr)
58 (setf things (tn-ref-across things))
59 (store-car (tn-ref-tn things) ptr cons-cdr-slot))
61 (storew nil-value ptr cons-cdr-slot
63 (assert (null (tn-ref-across things)))))
64 (move result res))))))
66 (define-vop (list list-or-list*)
69 (define-vop (list* list-or-list*)
72 ;;;; special-purpose inline allocators
74 (define-vop (allocate-code-object)
75 (:args (boxed-arg :scs (any-reg) :target boxed)
76 (unboxed-arg :scs (any-reg) :target unboxed))
77 (:results (result :scs (descriptor-reg)))
78 (:temporary (:sc unsigned-reg :from :eval) temp)
79 (:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
80 (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
82 (move boxed boxed-arg)
83 (inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
84 (inst and boxed (lognot lowtag-mask))
85 (move unboxed unboxed-arg)
86 (inst shr unboxed word-shift)
87 (inst add unboxed lowtag-mask)
88 (inst and unboxed (lognot lowtag-mask))
90 ;; comment from CMU CL code:
91 ;; now loading code into static space cause it can't move
93 ;; KLUDGE: What? What's all the cruft about saving fixups for then?
94 ;; I think what's happened is that ALLOCATE-CODE-OBJECT is the basic
95 ;; CMU CL primitive; this ALLOCATE-CODE-OBJECT was hacked for
96 ;; static space only in a simple-minded port to the X86; and then
97 ;; in an attempt to improve the port to the X86,
98 ;; ALLOCATE-DYNAMIC-CODE-OBJECT was defined. If that's right, I'd like
99 ;; to know why not just go back to the basic CMU CL behavior of
100 ;; ALLOCATE-CODE-OBJECT, where it makes a relocatable code object.
103 ;; FIXME: should have a check for overflow of static space
104 (load-symbol-value temp sb!vm:*static-space-free-pointer*)
105 (inst lea result (make-ea :byte :base temp :disp other-pointer-type))
106 (inst add temp boxed)
107 (inst add temp unboxed)
108 (store-symbol-value temp sb!vm:*static-space-free-pointer*)
109 (inst shl boxed (- type-bits word-shift))
110 (inst or boxed code-header-type)
111 (storew boxed result 0 other-pointer-type)
112 (storew unboxed result code-code-size-slot other-pointer-type)
113 (inst mov temp nil-value)
114 (storew temp result code-entry-points-slot other-pointer-type))
115 (storew temp result code-debug-info-slot other-pointer-type)))
117 (define-vop (allocate-dynamic-code-object)
118 (:args (boxed-arg :scs (any-reg) :target boxed)
119 (unboxed-arg :scs (any-reg) :target unboxed))
120 (:results (result :scs (descriptor-reg) :from :eval))
121 (:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
122 (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
125 (move boxed boxed-arg)
126 (inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
127 (inst and boxed (lognot lowtag-mask))
128 (move unboxed unboxed-arg)
129 (inst shr unboxed word-shift)
130 (inst add unboxed lowtag-mask)
131 (inst and unboxed (lognot lowtag-mask))
132 (inst mov result boxed)
133 (inst add result unboxed)
135 (allocation result result node)
136 (inst lea result (make-ea :byte :base result :disp other-pointer-type))
137 (inst shl boxed (- type-bits word-shift))
138 (inst or boxed code-header-type)
139 (storew boxed result 0 other-pointer-type)
140 (storew unboxed result code-code-size-slot other-pointer-type)
141 (storew nil-value result code-entry-points-slot other-pointer-type))
142 (storew nil-value result code-debug-info-slot other-pointer-type)))
144 (define-vop (make-fdefn)
146 (:translate make-fdefn)
147 (:args (name :scs (descriptor-reg) :to :eval))
148 (:results (result :scs (descriptor-reg) :from :argument))
151 (with-fixed-allocation (result fdefn-type fdefn-size node)
152 (storew name result fdefn-name-slot other-pointer-type)
153 (storew nil-value result fdefn-function-slot other-pointer-type)
154 (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
155 result fdefn-raw-addr-slot other-pointer-type))))
157 (define-vop (make-closure)
158 (:args (function :to :save :scs (descriptor-reg)))
160 (:temporary (:sc any-reg) temp)
161 (:results (result :scs (descriptor-reg)))
165 (let ((size (+ length closure-info-offset)))
166 (allocation result (pad-data-block size) node)
168 (make-ea :byte :base result :disp function-pointer-type))
169 (storew (logior (ash (1- size) type-bits) closure-header-type)
170 result 0 function-pointer-type))
171 (loadw temp function closure-function-slot function-pointer-type)
172 (storew temp result closure-function-slot function-pointer-type))))
174 ;;; The compiler likes to be able to directly make value cells.
175 (define-vop (make-value-cell)
176 (:args (value :scs (descriptor-reg any-reg) :to :result))
177 (:results (result :scs (descriptor-reg) :from :eval))
180 (with-fixed-allocation
181 (result value-cell-header-type value-cell-size node))
182 (storew value result value-cell-value-slot other-pointer-type)))
184 ;;;; automatic allocators for primitive objects
186 (define-vop (make-unbound-marker)
188 (:results (result :scs (any-reg)))
190 (inst mov result unbound-marker-type)))
192 (define-vop (fixed-alloc)
194 (:info name words type lowtag)
196 (:results (result :scs (descriptor-reg)))
200 (allocation result (pad-data-block words) node)
201 (inst lea result (make-ea :byte :base result :disp lowtag))
203 (storew (logior (ash (1- words) type-bits) type) result 0 lowtag)))))
205 (define-vop (var-alloc)
206 (:args (extra :scs (any-reg)))
207 (:arg-types positive-fixnum)
208 (:info name words type lowtag)
210 (:results (result :scs (descriptor-reg) :from (:eval 1)))
211 (:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes)
212 (:temporary (:sc any-reg :from :eval :to :result) header)
216 (make-ea :dword :base extra :disp (* (1+ words) word-bytes)))
217 (inst mov header bytes)
218 (inst shl header (- type-bits 2)) ; w+1 to length field
220 (inst lea header ; (w-1 << 8) | type
221 (make-ea :dword :base header :disp (+ (ash -2 type-bits) type)))
222 (inst and bytes (lognot lowtag-mask))
224 (allocation result bytes node)
225 (inst lea result (make-ea :byte :base result :disp lowtag))
226 (storew header result 0 lowtag))))
228 (define-vop (make-symbol)
230 (:translate make-symbol)
231 (:args (name :scs (descriptor-reg) :to :eval))
232 (:temporary (:sc unsigned-reg :from :eval) temp)
233 (:results (result :scs (descriptor-reg) :from :argument))
236 (with-fixed-allocation (result symbol-header-type symbol-size node)
237 (storew name result symbol-name-slot other-pointer-type)
238 (storew unbound-marker-type result symbol-value-slot other-pointer-type)
239 ;; Set up a random hash value for the symbol. Perhaps the object
240 ;; address could be used for even faster and smaller code!
241 ;; FIXME: We don't mind the symbol hash not being repeatable, so
242 ;; we might as well add in the object address here, too. (Adding entropy
243 ;; is good, even if ANSI doesn't understand that.)
245 (make-fixup (extern-alien-name "fast_random_state") :foreign)
247 (inst add temp 12345)
248 (inst mov (make-fixup (extern-alien-name "fast_random_state") :foreign)
250 ;; We want a positive fixnum for the hash value, so discard the LS bits.
252 (inst and temp #xfffffffc)
253 (storew temp result symbol-hash-slot other-pointer-type)
254 (storew nil-value result symbol-plist-slot other-pointer-type)
255 (storew nil-value result symbol-package-slot other-pointer-type))))