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)) header)
165 (:temporary (:scs (non-descriptor-reg)) bytes)
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))))