1 ;;;; allocation VOPs for the x86-64
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.
14 ;;;; CONS, LIST and LIST*
15 (define-vop (list-or-list*)
16 (:args
(things :more t
))
17 (:temporary
(:sc unsigned-reg
) ptr temp
)
18 (:temporary
(:sc unsigned-reg
:to
(:result
0) :target result
) res
)
20 (:results
(result :scs
(descriptor-reg)))
26 ;; (move result nil-value)
27 (inst mov result nil-value
))
29 (move result
(tn-ref-tn things
)))
32 ((store-car (tn list
&optional
(slot cons-car-slot
))
35 ((any-reg descriptor-reg
) ,tn
)
39 (storew reg
,list
,slot list-pointer-lowtag
))))
40 (let ((cons-cells (if star
(1- num
) num
))
41 (stack-allocate-p (node-stack-allocate-p node
)))
42 (maybe-pseudo-atomic stack-allocate-p
43 (allocation res
(* (pad-data-block cons-size
) cons-cells
) node
44 stack-allocate-p list-pointer-lowtag
)
46 (dotimes (i (1- cons-cells
))
47 (store-car (tn-ref-tn things
) ptr
)
48 (setf things
(tn-ref-across things
))
49 (inst add ptr
(pad-data-block cons-size
))
50 (storew ptr ptr
(- cons-cdr-slot cons-size
)
52 (store-car (tn-ref-tn things
) ptr
)
54 (setf things
(tn-ref-across things
))
55 (store-car (tn-ref-tn things
) ptr cons-cdr-slot
))
57 (storew nil-value ptr cons-cdr-slot
58 list-pointer-lowtag
)))
59 (aver (null (tn-ref-across things
)))))
60 (move result res
))))))
62 (define-vop (list list-or-list
*)
65 (define-vop (list* list-or-list
*)
68 ;;;; special-purpose inline allocators
70 ;;; Special variant of 'storew' which might have a shorter encoding
71 ;;; when storing to the heap (which starts out zero-filled).
72 (defun storew* (word object slot lowtag zeroed
)
73 (if (or (not zeroed
) (not (typep word
'(signed-byte 32))))
74 (storew word object slot lowtag
) ; Possibly use temp-reg-tn
76 (make-ea (cond ((typep word
'(unsigned-byte 8)) :byte
)
77 ((and (not (logtest word
#xff
))
78 (typep (ash word -
8) '(unsigned-byte 8)))
79 ;; Array lengths 128 to 16384 which are multiples of 128
80 (setq word
(ash word -
8))
81 (decf lowtag
1) ; increment address by 1
83 ((and (not (logtest word
#xffff
))
84 (typep (ash word -
16) '(unsigned-byte 8)))
86 (setq word
(ash word -
16))
87 (decf lowtag
2) ; increment address by 2
89 ((typep word
'(unsigned-byte 16)) :word
)
90 ;; Definitely a (signed-byte 32) due to pre-test.
93 :disp
(- (* slot n-word-bytes
) lowtag
))
97 (macrolet ((calc-size-in-bytes (n-words result-tn
)
98 `(cond ((sc-is ,n-words immediate
)
99 (pad-data-block (+ (tn-value ,n-words
) vector-data-offset
)))
102 (make-ea :byte
:index
,n-words
103 :scale
(ash 1 (- word-shift n-fixnum-tag-bits
))
105 (* vector-data-offset n-word-bytes
))))
106 (inst and
,result-tn
(lognot lowtag-mask
))
108 (put-header (vector-tn type length zeroed
)
109 `(progn (storew* (if (sc-is ,type immediate
) (tn-value ,type
) ,type
)
110 ,vector-tn
0 other-pointer-lowtag
,zeroed
)
111 (storew* (if (sc-is ,length immediate
)
112 (fixnumize (tn-value ,length
))
114 ,vector-tn vector-length-slot other-pointer-lowtag
117 (define-vop (allocate-vector-on-heap)
118 (:args
(type :scs
(unsigned-reg immediate
))
119 (length :scs
(any-reg immediate
))
120 (words :scs
(any-reg immediate
)))
121 (:results
(result :scs
(descriptor-reg) :from
:load
))
122 (:arg-types positive-fixnum positive-fixnum positive-fixnum
)
125 ;; The LET generates instructions that needn't be pseudoatomic
126 ;; so don't move it inside.
127 (let ((size (calc-size-in-bytes words result
)))
129 (allocation result size nil nil other-pointer-lowtag
)
130 (put-header result type length t
)))))
132 (define-vop (allocate-vector-on-stack)
133 (:args
(type :scs
(unsigned-reg immediate
) :to
:save
)
134 (length :scs
(any-reg immediate
) :to
:eval
:target rax
)
135 (words :scs
(any-reg immediate
) :target rcx
))
136 (:temporary
(:sc any-reg
:offset ecx-offset
:from
(:argument
2)) rcx
)
137 (:temporary
(:sc any-reg
:offset eax-offset
:from
:eval
) rax
)
138 (:temporary
(:sc any-reg
:offset edi-offset
) rdi
)
139 (:temporary
(:sc complex-double-reg
) zero
)
140 (:results
(result :scs
(descriptor-reg) :from
:load
))
141 (:arg-types positive-fixnum positive-fixnum positive-fixnum
)
142 (:translate allocate-vector
)
146 (let ((size (calc-size-in-bytes words result
)))
147 (allocation result size node t other-pointer-lowtag
)
148 (put-header result type length nil
)
149 ;; FIXME: It would be good to check for stack overflow here.
150 ;; It would also be good to skip zero-fill of specialized vectors
151 ;; perhaps in a policy-dependent way. At worst you'd see random
152 ;; bits, and CLHS says consequences are undefined.
154 (make-ea :qword
:base result
155 :disp
(- (* vector-data-offset n-word-bytes
)
156 other-pointer-lowtag
))))
158 (cond ((sc-is words immediate
)
159 (let ((n (tn-value words
)))
161 (inst mov rcx
(tn-value words
)))
164 (inst mov data-addr rax
)
165 (return-from zero-fill
))
167 (multiple-value-bind (double single
) (truncate n
2)
168 (inst xorpd zero zero
)
170 (inst movapd data-addr zero
)
171 (setf data-addr
(copy-structure data-addr
))
172 (incf (ea-disp data-addr
) (* n-word-bytes
2)))
173 (unless (zerop single
)
174 (inst movaps data-addr zero
))
175 (return-from zero-fill
))))))
178 (inst shr rcx n-fixnum-tag-bits
)))
179 (inst lea rdi data-addr
)
182 (inst stos rax
)))))))
185 (macrolet ((calc-size-in-bytes (length answer
)
186 `(cond ((sc-is ,length immediate
)
187 (aver (/= (tn-value ,length
) 0))
188 (* (tn-value ,length
) n-word-bytes
2))
190 (inst mov result nil-value
)
191 (inst test
,length
,length
)
194 (make-ea :byte
:base nil
:index
,length
195 :scale
(ash 1 (1+ (- word-shift
196 n-fixnum-tag-bits
)))))
199 `(let ((size (cond ((or (not (fixnump size
))
200 (immediate32-p size
))
203 (inst mov limit size
)
206 (make-ea :qword
:base result
207 :index
(if (fixnump size
) nil size
)
208 :disp
(if (fixnump size
) size
0))))))
210 (define-vop (allocate-list-on-stack)
211 (:args
(length :scs
(any-reg immediate
))
212 (element :scs
(any-reg descriptor-reg
)))
213 (:results
(result :scs
(descriptor-reg) :from
:load
))
214 (:arg-types positive-fixnum
*)
217 (:temporary
(:sc descriptor-reg
) tail next limit
)
220 (let ((size (calc-size-in-bytes length next
))
222 (allocation result size node t list-pointer-lowtag
)
224 (inst mov next result
)
227 (inst add next
(* 2 n-word-bytes
))
228 (storew element tail cons-car-slot list-pointer-lowtag
)
229 ;; Store the CDR even if it will be smashed to nil.
230 (storew next tail cons-cdr-slot list-pointer-lowtag
)
231 (inst cmp next limit
)
233 (storew nil-value tail cons-cdr-slot list-pointer-lowtag
))
236 (define-vop (allocate-list-on-heap)
237 (:args
(length :scs
(any-reg immediate
))
238 (element :scs
(any-reg descriptor-reg
)
239 :load-if
(not (and (sc-is element immediate
)
240 (eql (tn-value element
) 0)))))
241 (:results
(result :scs
(descriptor-reg) :from
:load
))
242 (:arg-types positive-fixnum
*)
245 (:temporary
(:sc descriptor-reg
) tail next limit
)
247 (let ((size (calc-size-in-bytes length next
))
251 (and (sc-is element immediate
) (eql (tn-value element
) 0))))
253 (allocation result size node nil list-pointer-lowtag
)
255 (inst mov next result
)
258 (storew next tail cons-cdr-slot list-pointer-lowtag
)
261 (inst add next
(* 2 n-word-bytes
))
262 (unless no-init
; don't bother writing zeros in the CARs
263 (storew element tail cons-car-slot list-pointer-lowtag
))
264 (inst cmp next limit
)
266 (storew nil-value tail cons-cdr-slot list-pointer-lowtag
))
270 (define-vop (make-fdefn)
272 (:translate make-fdefn
)
273 (:args
(name :scs
(descriptor-reg) :to
:eval
))
274 (:results
(result :scs
(descriptor-reg) :from
:argument
))
277 (with-fixed-allocation (result fdefn-widetag fdefn-size node
)
278 (storew name result fdefn-name-slot other-pointer-lowtag
)
279 (storew nil-value result fdefn-fun-slot other-pointer-lowtag
)
280 (storew (make-fixup 'undefined-tramp
:assembly-routine
)
281 result fdefn-raw-addr-slot other-pointer-lowtag
))))
283 (define-vop (make-closure)
284 (:args
(function :to
:save
:scs
(descriptor-reg)))
285 (:info length stack-allocate-p
)
286 (:temporary
(:sc any-reg
) temp
)
287 (:results
(result :scs
(descriptor-reg)))
290 (maybe-pseudo-atomic stack-allocate-p
291 (let* ((size (+ length closure-info-offset
))
292 (header (logior (ash (1- size
) n-widetag-bits
) closure-widetag
)))
293 (allocation result
(pad-data-block size
) node stack-allocate-p
295 (storew* #!-immobile-space header
; write the widetag and size
296 #!+immobile-space
; ... plus the layout pointer
297 (progn (inst mov temp
(logior (ash function-layout
32) header
))
299 result
0 fun-pointer-lowtag
(not stack-allocate-p
)))
300 ;; These two instructions are within the scope of PSEUDO-ATOMIC.
301 ;; This is due to scav_closure() assuming that it can always subtract
302 ;; FUN_RAW_ADDR_OFFSET from closure->fun to obtain a Lisp object,
303 ;; without any precheck for whether that word is currently 0.
304 (inst lea temp
(make-ea-for-object-slot function simple-fun-code-offset
306 (storew temp result closure-fun-slot fun-pointer-lowtag
))))
308 ;;; The compiler likes to be able to directly make value cells.
309 (define-vop (make-value-cell)
310 (:args
(value :scs
(descriptor-reg any-reg
) :to
:result
))
311 (:results
(result :scs
(descriptor-reg) :from
:eval
))
312 (:info stack-allocate-p
)
315 (with-fixed-allocation
316 (result value-cell-widetag value-cell-size node stack-allocate-p
)
317 (storew value result value-cell-value-slot other-pointer-lowtag
))))
319 ;;;; automatic allocators for primitive objects
321 (define-vop (make-unbound-marker)
323 (:results
(result :scs
(descriptor-reg any-reg
)))
325 (inst mov result unbound-marker-widetag
)))
327 (define-vop (make-funcallable-instance-tramp)
329 (:results
(result :scs
(any-reg)))
331 (inst mov result
(make-fixup 'funcallable-instance-tramp
:assembly-routine
))))
333 (define-vop (fixed-alloc)
335 (:info name words type lowtag stack-allocate-p
)
337 (:results
(result :scs
(descriptor-reg)))
340 (maybe-pseudo-atomic stack-allocate-p
341 (allocation result
(pad-data-block words
) node stack-allocate-p lowtag
)
343 (storew* (logior (ash (1- words
) n-widetag-bits
) type
)
344 result
0 lowtag
(not stack-allocate-p
))))))
346 (define-vop (var-alloc)
347 (:args
(extra :scs
(any-reg)))
348 (:arg-types positive-fixnum
)
349 (:info name words type lowtag
)
351 (:results
(result :scs
(descriptor-reg) :from
(:eval
1)))
352 (:temporary
(:sc any-reg
:from
:eval
:to
(:eval
1)) bytes
)
353 (:temporary
(:sc any-reg
:from
:eval
:to
:result
) header
)
357 (make-ea :qword
:disp
(* (1+ words
) n-word-bytes
) :index extra
358 :scale
(ash 1 (- word-shift n-fixnum-tag-bits
))))
359 (inst mov header bytes
)
360 (inst shl header
(- n-widetag-bits word-shift
)) ; w+1 to length field
361 (inst lea header
; (w-1 << 8) | type
362 (make-ea :qword
:base header
363 :disp
(+ (ash -
2 n-widetag-bits
) type
)))
364 (inst and bytes
(lognot lowtag-mask
))
366 (allocation result bytes node
)
367 (inst lea result
(make-ea :byte
:base result
:disp lowtag
))
368 (storew header result
0 lowtag
))))
371 (macrolet ((def (lisp-name c-name arg-scs
&body stuff
372 &aux
(argc (length arg-scs
)))
373 `(define-vop (,lisp-name
)
374 (:args
,@(if (>= argc
1) `((arg1 :scs
,(first arg-scs
) :target c-arg1
)))
375 ,@(if (>= argc
2) `((arg2 :scs
,(second arg-scs
) :target c-arg2
))))
377 '((:temporary
(:sc unsigned-reg
:from
(:argument
0)
378 :to
:eval
:offset rdi-offset
) c-arg1
)))
380 '((:temporary
(:sc unsigned-reg
:from
(:argument
1)
381 :to
:eval
:offset rsi-offset
) c-arg2
)))
382 (:temporary
(:sc unsigned-reg
:from
:eval
:to
(:result
0)
383 :offset rax-offset
) c-result
)
384 (:results
(result :scs
(descriptor-reg)))
387 ,@(if (>= argc
1) '((move c-arg1 arg1
)))
388 ,@(if (>= argc
2) '((move c-arg2 arg2
)))
389 (inst and rsp-tn -
16)
390 (inst mov temp-reg-tn
(make-fixup ,c-name
:foreign
))
391 (inst call temp-reg-tn
)
393 (move result c-result
))))))
394 ;; These VOPs are each used in one place only, and deliberately not
395 ;; specified as transforming the function after which they are named.
396 (def alloc-immobile-layout
"alloc_layout" ; MAKE-LAYOUT
398 (def alloc-immobile-symbol
"alloc_sym" ; MAKE-SYMBOL
400 (def alloc-immobile-fdefn
"alloc_fdefn" ; MAKE-FDEFN
402 #!+(and immobile-code compact-instance-header
)
403 (def alloc-generic-function
"alloc_generic_function"