6 (define-vop (list-or-list*)
7 (:args (things :more t))
8 (:temporary (:scs (descriptor-reg) :type list) ptr)
9 (:temporary (:scs (descriptor-reg)) temp)
10 (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
12 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
14 (:results (result :scs (descriptor-reg)))
19 (move result null-tn))
21 (move result (tn-ref-tn things)))
24 ((store-car (tn list &optional (slot cons-car-slot))
27 ((any-reg descriptor-reg) ,tn)
31 (load-stack-tn temp ,tn)
33 (storew reg ,list ,slot list-pointer-lowtag))))
34 (let ((cons-cells (if star (1- num) num)))
35 (pseudo-atomic (pa-flag
36 :extra (* (pad-data-block cons-size)
38 (inst or res alloc-tn list-pointer-lowtag)
40 (dotimes (i (1- cons-cells))
41 (store-car (tn-ref-tn things) ptr)
42 (setf things (tn-ref-across things))
43 (inst addu ptr ptr (pad-data-block cons-size))
45 (- cons-cdr-slot cons-size)
47 (store-car (tn-ref-tn things) ptr)
49 (setf things (tn-ref-across things))
50 (store-car (tn-ref-tn things) ptr cons-cdr-slot))
53 cons-cdr-slot list-pointer-lowtag)))
54 (assert (null (tn-ref-across things)))
55 (move result res))))))))
57 (define-vop (list list-or-list*)
60 (define-vop (list* list-or-list*)
64 ;;;; Special purpose inline allocators.
66 (define-vop (allocate-code-object)
67 (:args (boxed-arg :scs (any-reg))
68 (unboxed-arg :scs (any-reg)))
69 (:results (result :scs (descriptor-reg)))
70 (:temporary (:scs (non-descriptor-reg)) ndescr)
71 (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
72 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
73 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
75 (inst li ndescr (lognot lowtag-mask))
76 (inst addu boxed boxed-arg
77 (fixnumize (1+ code-trace-table-offset-slot)))
78 (inst and boxed ndescr)
79 (inst srl unboxed unboxed-arg word-shift)
80 (inst addu unboxed unboxed lowtag-mask)
81 (inst and unboxed ndescr)
82 (inst sll ndescr boxed (- n-widetag-bits word-shift))
83 (inst or ndescr code-header-widetag)
85 (pseudo-atomic (pa-flag)
86 (inst or result alloc-tn other-pointer-lowtag)
87 (storew ndescr result 0 other-pointer-lowtag)
88 (storew unboxed result code-code-size-slot other-pointer-lowtag)
89 (storew null-tn result code-entry-points-slot other-pointer-lowtag)
90 (inst addu alloc-tn boxed)
91 (inst addu alloc-tn unboxed))
93 (storew null-tn result code-debug-info-slot other-pointer-lowtag)))
95 (define-vop (make-fdefn)
97 (:translate make-fdefn)
98 (:args (name :scs (descriptor-reg) :to :eval))
99 (:temporary (:scs (non-descriptor-reg)) temp)
100 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
101 (:results (result :scs (descriptor-reg) :from :argument))
103 (with-fixed-allocation (result pa-flag temp fdefn-widetag fdefn-size)
104 (storew name result fdefn-name-slot other-pointer-lowtag)
105 (storew null-tn result fdefn-fun-slot other-pointer-lowtag)
106 (inst li temp (make-fixup "undefined_tramp" :foreign))
107 (storew temp result fdefn-raw-addr-slot other-pointer-lowtag))))
109 (define-vop (make-closure)
110 (:args (function :to :save :scs (descriptor-reg)))
111 (:info length stack-allocate-p)
112 (:ignore stack-allocate-p)
113 (:temporary (:scs (non-descriptor-reg)) temp)
114 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
115 (:results (result :scs (descriptor-reg)))
117 (let ((size (+ length closure-info-offset)))
118 (inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
119 (pseudo-atomic (pa-flag :extra (pad-data-block size))
120 (inst or result alloc-tn fun-pointer-lowtag)
121 (storew temp result 0 fun-pointer-lowtag))
122 (storew function result closure-fun-slot fun-pointer-lowtag))))
124 ;;; The compiler likes to be able to directly make value cells.
126 (define-vop (make-value-cell)
127 (:args (value :to :save :scs (descriptor-reg any-reg null zero)))
128 (:temporary (:scs (non-descriptor-reg)) temp)
129 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
130 (:results (result :scs (descriptor-reg)))
132 (with-fixed-allocation
133 (result pa-flag temp value-cell-header-widetag value-cell-size))
134 (storew value result value-cell-value-slot other-pointer-lowtag)))
137 ;;;; Automatic allocators for primitive objects.
139 (define-vop (make-unbound-marker)
141 (:results (result :scs (any-reg)))
143 (inst li result unbound-marker-widetag)))
145 (define-vop (fixed-alloc)
147 (:info name words type lowtag)
149 (:results (result :scs (descriptor-reg)))
150 (:temporary (:scs (non-descriptor-reg)) temp)
151 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
153 (pseudo-atomic (pa-flag :extra (pad-data-block words))
154 (inst or result alloc-tn lowtag)
156 (inst li temp (logior (ash (1- words) n-widetag-bits) type))
157 (storew temp result 0 lowtag)))))
159 (define-vop (var-alloc)
160 (:args (extra :scs (any-reg)))
161 (:arg-types positive-fixnum)
162 (:info name words type lowtag)
164 (:results (result :scs (descriptor-reg)))
165 (:temporary (:scs (any-reg)) bytes)
166 (:temporary (:scs (non-descriptor-reg)) header)
167 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
169 (inst addu bytes extra (* (1+ words) n-word-bytes))
170 (inst sll header bytes (- n-widetag-bits 2))
171 (inst addu header header (+ (ash -2 n-widetag-bits) type))
172 (inst srl bytes bytes n-lowtag-bits)
173 (inst sll bytes bytes n-lowtag-bits)
174 (pseudo-atomic (pa-flag)
175 (inst or result alloc-tn lowtag)
176 (storew header result 0 lowtag)
177 (inst addu alloc-tn alloc-tn bytes))))