1 ;;;; allocation VOPs for the Alpha port
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.
15 (defoptimizer (list stack-allocate-result) ((&rest args))
17 (defoptimizer (list* stack-allocate-result) ((&rest args))
18 (not (null (rest args))))
20 (define-vop (list-or-list*)
21 (:args (things :more t))
22 (:temporary (:scs (descriptor-reg) :type list) ptr)
23 (:temporary (:scs (descriptor-reg)) temp)
24 (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
27 (:results (result :scs (descriptor-reg)))
33 (move null-tn result))
35 (move (tn-ref-tn things) result))
38 ((store-car (tn list &optional (slot cons-car-slot))
41 ((any-reg descriptor-reg) ,tn)
45 (load-stack-tn temp ,tn)
47 (storew reg ,list ,slot list-pointer-lowtag))))
48 (let* ((dx-p (awhen (sb!c::node-lvar node) (sb!c::lvar-dynamic-extent it)))
49 (cons-cells (if star (1- num) num))
50 (space (* (pad-data-block cons-size) cons-cells)))
51 (pseudo-atomic (:extra (if dx-p 0 space))
54 (inst bis csp-tn list-pointer-lowtag res)
55 (inst lda csp-tn space csp-tn))
57 (inst bis alloc-tn list-pointer-lowtag res)))
59 (dotimes (i (1- cons-cells))
60 (store-car (tn-ref-tn things) ptr)
61 (setf things (tn-ref-across things))
62 (inst lda ptr (pad-data-block cons-size) ptr)
64 (- cons-cdr-slot cons-size)
66 (store-car (tn-ref-tn things) ptr)
68 (setf things (tn-ref-across things))
69 (store-car (tn-ref-tn things) ptr cons-cdr-slot))
72 cons-cdr-slot list-pointer-lowtag)))
73 (aver (null (tn-ref-across things)))
74 (move res result))))))))
76 (define-vop (list list-or-list*)
79 (define-vop (list* list-or-list*)
82 ;;;; special purpose inline allocators
84 (define-vop (allocate-code-object)
85 (:args (boxed-arg :scs (any-reg))
86 (unboxed-arg :scs (any-reg)))
87 (:results (result :scs (descriptor-reg)))
88 (:temporary (:scs (non-descriptor-reg)) ndescr)
89 (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
90 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
92 (inst li (lognot lowtag-mask) ndescr)
93 (inst lda boxed (fixnumize (1+ code-trace-table-offset-slot))
95 (inst and boxed ndescr boxed)
96 (inst srl unboxed-arg word-shift unboxed)
97 (inst lda unboxed lowtag-mask unboxed)
98 (inst and unboxed ndescr unboxed)
99 (inst sll boxed (- n-widetag-bits word-shift) ndescr)
100 (inst bis ndescr code-header-widetag ndescr)
103 (inst bis alloc-tn other-pointer-lowtag result)
104 (storew ndescr result 0 other-pointer-lowtag)
105 (storew unboxed result code-code-size-slot other-pointer-lowtag)
106 (storew null-tn result code-entry-points-slot other-pointer-lowtag)
107 (inst addq alloc-tn boxed alloc-tn)
108 (inst addq alloc-tn unboxed alloc-tn))
110 (storew null-tn result code-debug-info-slot other-pointer-lowtag)))
112 (define-vop (make-fdefn)
114 (:translate make-fdefn)
115 (:args (name :scs (descriptor-reg) :to :eval))
116 (:temporary (:scs (non-descriptor-reg)) temp)
117 (:results (result :scs (descriptor-reg) :from :argument))
119 (with-fixed-allocation (result temp fdefn-widetag fdefn-size)
120 (storew name result fdefn-name-slot other-pointer-lowtag)
121 (storew null-tn result fdefn-fun-slot other-pointer-lowtag)
122 (inst li (make-fixup "undefined_tramp" :foreign) temp)
123 (storew temp result fdefn-raw-addr-slot other-pointer-lowtag))))
125 (define-vop (make-closure)
126 (:args (function :to :save :scs (descriptor-reg)))
127 (:info length stack-allocate-p)
128 (:ignore stack-allocate-p)
129 (:temporary (:scs (non-descriptor-reg)) temp)
130 (:results (result :scs (descriptor-reg)))
133 (let* ((size (+ length closure-info-offset))
134 (alloc-size (pad-data-block size))
135 (dx-p (node-stack-allocate-p node)))
137 (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
139 (pseudo-atomic (:extra (if dx-p 0 alloc-size))
141 ;; no need to align CSP: FUN-POINTER-LOWTAG already has
142 ;; the corresponding bit set
143 (inst bis csp-tn fun-pointer-lowtag result)
144 (inst lda csp-tn alloc-size csp-tn))
146 (inst bis alloc-tn fun-pointer-lowtag result)))
147 (storew temp result 0 fun-pointer-lowtag))
148 (storew function result closure-fun-slot fun-pointer-lowtag))))
150 ;;; The compiler likes to be able to directly make value cells.
151 (define-vop (make-value-cell)
152 (:args (value :to :save :scs (descriptor-reg any-reg null zero)))
153 (:temporary (:scs (non-descriptor-reg)) temp)
154 (:results (result :scs (descriptor-reg)))
156 (with-fixed-allocation
157 (result temp value-cell-header-widetag value-cell-size)
158 (storew value result value-cell-value-slot other-pointer-lowtag))))
160 ;;;; automatic allocators for primitive objects
162 (define-vop (make-unbound-marker)
164 (:results (result :scs (any-reg)))
166 (inst li unbound-marker-widetag result)))
168 (define-vop (fixed-alloc)
170 (:info name words type lowtag)
172 (:results (result :scs (descriptor-reg)))
173 (:temporary (:scs (non-descriptor-reg)) temp)
175 (pseudo-atomic (:extra (pad-data-block words))
176 (inst bis alloc-tn lowtag result)
178 (inst li (logior (ash (1- words) n-widetag-bits) type) temp)
179 (storew temp result 0 lowtag)))))
181 (define-vop (var-alloc)
182 (:args (extra :scs (any-reg)))
183 (:arg-types positive-fixnum)
184 (:info name words type lowtag)
186 (:results (result :scs (descriptor-reg)))
187 (:temporary (:scs (non-descriptor-reg)) header)
188 (:temporary (:scs (non-descriptor-reg)) bytes)
190 (inst lda bytes (* (1+ words) n-word-bytes) extra)
191 (inst sll bytes (- n-widetag-bits 2) header)
192 (inst lda header (+ (ash -2 n-widetag-bits) type) header)
193 (inst srl bytes n-lowtag-bits bytes)
194 (inst sll bytes n-lowtag-bits bytes)
196 (inst bis alloc-tn lowtag result)
197 (storew header result 0 lowtag)
198 (inst addq alloc-tn bytes alloc-tn))))