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.
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)
21 (:results (result :scs (descriptor-reg)))
27 ;; (move result nil-value)
28 (inst mov result nil-value))
30 (move result (tn-ref-tn things)))
33 ((store-car (tn list &optional (slot cons-car-slot))
36 ((any-reg descriptor-reg) ,tn)
40 (storew reg ,list ,slot list-pointer-lowtag))))
41 (let ((cons-cells (if star (1- num) num)))
43 (allocation res (* (pad-data-block cons-size) cons-cells) node)
45 (make-ea :byte :base res :disp list-pointer-lowtag))
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)
53 (store-car (tn-ref-tn things) ptr)
55 (setf things (tn-ref-across things))
56 (store-car (tn-ref-tn things) ptr cons-cdr-slot))
58 (storew nil-value ptr cons-cdr-slot
59 list-pointer-lowtag)))
60 (aver (null (tn-ref-across things)))))
61 (move result res))))))
63 (define-vop (list list-or-list*)
66 (define-vop (list* list-or-list*)
69 ;;;; special-purpose inline allocators
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) :from :eval))
75 (:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
76 (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
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 (inst mov result boxed)
87 (inst add result unboxed)
89 (allocation result result node)
90 (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
91 (inst shl boxed (- n-widetag-bits word-shift))
92 (inst or boxed code-header-widetag)
93 (storew boxed result 0 other-pointer-lowtag)
94 (storew unboxed result code-code-size-slot other-pointer-lowtag)
95 (storew nil-value result code-entry-points-slot other-pointer-lowtag))
96 (storew nil-value result code-debug-info-slot other-pointer-lowtag)))
98 (define-vop (make-fdefn)
100 (:translate make-fdefn)
101 (:args (name :scs (descriptor-reg) :to :eval))
102 (:results (result :scs (descriptor-reg) :from :argument))
105 (with-fixed-allocation (result fdefn-widetag fdefn-size node)
106 (storew name result fdefn-name-slot other-pointer-lowtag)
107 (storew nil-value result fdefn-fun-slot other-pointer-lowtag)
108 (storew (make-fixup "undefined_tramp" :foreign)
109 result fdefn-raw-addr-slot other-pointer-lowtag))))
111 (define-vop (make-closure)
112 (:args (function :to :save :scs (descriptor-reg)))
113 (:info length stack-allocate-p)
114 (:ignore stack-allocate-p)
115 (:temporary (:sc any-reg) temp)
116 (:results (result :scs (descriptor-reg)))
120 (let ((size (+ length closure-info-offset)))
121 (allocation result (pad-data-block size) node)
123 (make-ea :byte :base result :disp fun-pointer-lowtag))
124 (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
125 result 0 fun-pointer-lowtag))
126 (loadw temp function closure-fun-slot fun-pointer-lowtag)
127 (storew temp result closure-fun-slot fun-pointer-lowtag))))
129 ;;; The compiler likes to be able to directly make value cells.
130 (define-vop (make-value-cell)
131 (:args (value :scs (descriptor-reg any-reg) :to :result))
132 (:results (result :scs (descriptor-reg) :from :eval))
135 (with-fixed-allocation
136 (result value-cell-header-widetag value-cell-size node))
137 (storew value result value-cell-value-slot other-pointer-lowtag)))
139 ;;;; automatic allocators for primitive objects
141 (define-vop (make-unbound-marker)
143 (:results (result :scs (any-reg)))
145 (inst mov result unbound-marker-widetag)))
147 (define-vop (fixed-alloc)
149 (:info name words type lowtag)
151 (:results (result :scs (descriptor-reg)))
155 (allocation result (pad-data-block words) node)
156 (inst lea result (make-ea :byte :base result :disp lowtag))
158 (storew (logior (ash (1- words) n-widetag-bits) type)
163 (define-vop (var-alloc)
164 (:args (extra :scs (any-reg)))
165 (:arg-types positive-fixnum)
166 (:info name words type lowtag)
168 (:results (result :scs (descriptor-reg) :from (:eval 1)))
169 (:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes)
170 (:temporary (:sc any-reg :from :eval :to :result) header)
174 (make-ea :qword :base extra :disp (* (1+ words) n-word-bytes)))
175 (inst mov header bytes)
176 (inst shl header (- n-widetag-bits 3)) ; w+1 to length field
177 (inst lea header ; (w-1 << 8) | type
178 (make-ea :qword :base header :disp (+ (ash -2 n-widetag-bits) type)))
179 (inst and bytes (lognot lowtag-mask))
181 (allocation result bytes node)
182 (inst lea result (make-ea :byte :base result :disp lowtag))
183 (storew header result 0 lowtag))))
185 (define-vop (make-symbol)
187 (:translate make-symbol)
188 (:args (name :scs (descriptor-reg) :to :eval))
189 (:temporary (:sc unsigned-reg :from :eval) temp)
190 (:results (result :scs (descriptor-reg) :from :argument))
193 (with-fixed-allocation (result symbol-header-widetag symbol-size node)
194 (storew name result symbol-name-slot other-pointer-lowtag)
195 (storew unbound-marker-widetag
198 other-pointer-lowtag)
199 ;; Set up a random hash value for the symbol. Perhaps the object
200 ;; address could be used for even faster and smaller code!
201 ;; FIXME: We don't mind the symbol hash not being repeatable, so
202 ;; we might as well add in the object address here, too. (Adding entropy
203 ;; is good, even if ANSI doesn't understand that.)
205 (make-fixup "fast_random_state" :foreign)
207 (inst add temp 12345)
208 (inst mov (make-fixup "fast_random_state" :foreign)
210 ;; We want a positive fixnum for the hash value, so discard the LS bits.
212 ;; FIXME: OK, who wants to tell me (CSR) why these two
213 ;; instructions aren't replaced by (INST AND TEMP #x8FFFFFFC)?
214 ;; Are the following two instructions actually faster? Does the
215 ;; difference in behaviour really matter?
217 (inst and temp #xfffffffc)
218 (storew temp result symbol-hash-slot other-pointer-lowtag)
219 (storew nil-value result symbol-plist-slot other-pointer-lowtag)
220 (storew nil-value result symbol-package-slot other-pointer-lowtag))))