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)))
112 (:temporary
(:scs
(non-descriptor-reg)) temp
)
113 (:temporary
(:sc non-descriptor-reg
:offset nl4-offset
) pa-flag
)
114 (:results
(result :scs
(descriptor-reg)))
116 (let ((size (+ length closure-info-offset
)))
117 (inst li temp
(logior (ash (1- size
) n-widetag-bits
) closure-header-widetag
))
118 (pseudo-atomic (pa-flag :extra
(pad-data-block size
))
119 (inst or result alloc-tn fun-pointer-lowtag
)
120 (storew temp result
0 fun-pointer-lowtag
))
121 (storew function result closure-fun-slot fun-pointer-lowtag
))))
123 ;;; The compiler likes to be able to directly make value cells.
125 (define-vop (make-value-cell)
126 (:args
(value :to
:save
:scs
(descriptor-reg any-reg null zero
)))
127 (:temporary
(:scs
(non-descriptor-reg)) temp
)
128 (:temporary
(:sc non-descriptor-reg
:offset nl4-offset
) pa-flag
)
129 (:results
(result :scs
(descriptor-reg)))
131 (with-fixed-allocation
132 (result pa-flag temp value-cell-header-widetag value-cell-size
))
133 (storew value result value-cell-value-slot other-pointer-lowtag
)))
136 ;;;; Automatic allocators for primitive objects.
138 (define-vop (make-unbound-marker)
140 (:results
(result :scs
(any-reg)))
142 (inst li result unbound-marker-widetag
)))
144 (define-vop (fixed-alloc)
146 (:info name words type lowtag
)
148 (:results
(result :scs
(descriptor-reg)))
149 (:temporary
(:scs
(non-descriptor-reg)) temp
)
150 (:temporary
(:sc non-descriptor-reg
:offset nl4-offset
) pa-flag
)
152 (pseudo-atomic (pa-flag :extra
(pad-data-block words
))
153 (inst or result alloc-tn lowtag
)
155 (inst li temp
(logior (ash (1- words
) n-widetag-bits
) type
))
156 (storew temp result
0 lowtag
)))))
158 (define-vop (var-alloc)
159 (:args
(extra :scs
(any-reg)))
160 (:arg-types positive-fixnum
)
161 (:info name words type lowtag
)
163 (:results
(result :scs
(descriptor-reg)))
164 (:temporary
(:scs
(any-reg)) bytes
)
165 (:temporary
(:scs
(non-descriptor-reg)) header
)
166 (:temporary
(:sc non-descriptor-reg
:offset nl4-offset
) pa-flag
)
168 (inst addu bytes extra
(* (1+ words
) n-word-bytes
))
169 (inst sll header bytes
(- n-widetag-bits
2))
170 (inst addu header header
(+ (ash -
2 n-widetag-bits
) type
))
171 (inst srl bytes bytes n-lowtag-bits
)
172 (inst sll bytes bytes n-lowtag-bits
)
173 (pseudo-atomic (pa-flag)
174 (inst or result alloc-tn lowtag
)
175 (storew header result
0 lowtag
)
176 (inst addu alloc-tn alloc-tn bytes
))))