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)
13 (:results (result :scs (descriptor-reg)))
19 (move null-tn result))
21 (move (tn-ref-tn things) result))
27 ((any-reg descriptor-reg zero null)
30 (load-stack-tn temp ,tn)
32 (let* ((cons-cells (if star (1- num) num))
33 (alloc (* (pad-data-block cons-size) cons-cells)))
34 (pseudo-atomic (:extra alloc)
36 (inst dep list-pointer-lowtag 31 3 res)
38 (dotimes (i (1- cons-cells))
39 (storew (maybe-load (tn-ref-tn things)) ptr
40 cons-car-slot list-pointer-lowtag)
41 (setf things (tn-ref-across things))
42 (inst addi (pad-data-block cons-size) ptr ptr)
44 (- cons-cdr-slot cons-size)
46 (storew (maybe-load (tn-ref-tn things)) ptr
47 cons-car-slot list-pointer-lowtag)
49 (maybe-load (tn-ref-tn (tn-ref-across things)))
51 ptr cons-cdr-slot list-pointer-lowtag))
52 (move res result)))))))
55 (define-vop (list list-or-list*)
58 (define-vop (list* list-or-list*)
62 ;;;; Special purpose inline allocators.
64 (define-vop (allocate-code-object)
65 (:args (boxed-arg :scs (any-reg))
66 (unboxed-arg :scs (any-reg)))
67 (:results (result :scs (descriptor-reg)))
68 (:temporary (:scs (non-descriptor-reg)) ndescr)
69 (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
70 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
72 (inst addi (fixnumize (1+ code-trace-table-offset-slot)) boxed-arg boxed)
73 (inst dep 0 31 3 boxed)
74 (inst srl unboxed-arg word-shift unboxed)
75 (inst addi lowtag-mask unboxed unboxed)
76 (inst dep 0 31 3 unboxed)
78 ;; Note: we don't have to subtract off the 4 that was added by
79 ;; pseudo-atomic, because depositing other-pointer-lowtag just adds
81 (inst move alloc-tn result)
82 (inst dep other-pointer-lowtag 31 3 result)
83 (inst add alloc-tn boxed alloc-tn)
84 (inst add alloc-tn unboxed alloc-tn)
85 (inst sll boxed (- n-widetag-bits word-shift) ndescr)
86 (inst addi code-header-widetag ndescr ndescr)
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 (storew null-tn result code-debug-info-slot other-pointer-lowtag))))
92 (define-vop (make-fdefn)
93 (:args (name :scs (descriptor-reg) :to :eval))
94 (:temporary (:scs (non-descriptor-reg)) temp)
95 (:results (result :scs (descriptor-reg) :from :argument))
97 (:translate make-fdefn)
99 (with-fixed-allocation (result temp fdefn-widetag fdefn-size)
100 (inst li (make-fixup "undefined_tramp" :foreign) temp)
101 (storew name result fdefn-name-slot other-pointer-lowtag)
102 (storew null-tn result fdefn-fun-slot other-pointer-lowtag)
103 (storew temp result fdefn-raw-addr-slot other-pointer-lowtag))))
105 (define-vop (make-closure)
106 (:args (function :to :save :scs (descriptor-reg)))
108 (:temporary (:scs (non-descriptor-reg)) temp)
109 (:results (result :scs (descriptor-reg)))
111 (let ((size (+ length closure-info-offset)))
112 (pseudo-atomic (:extra (pad-data-block size))
113 (inst move alloc-tn result)
114 (inst dep fun-pointer-lowtag 31 3 result)
115 (inst li (logior (ash (1- size) n-widetag-bits) closure-header-widetag) temp)
116 (storew temp result 0 fun-pointer-lowtag)))
117 (storew function result closure-fun-slot fun-pointer-lowtag)))
119 ;;; The compiler likes to be able to directly make value cells.
121 (define-vop (make-value-cell)
122 (:args (value :to :save :scs (descriptor-reg any-reg)))
123 (:temporary (:scs (non-descriptor-reg)) temp)
124 (:results (result :scs (descriptor-reg)))
126 (with-fixed-allocation
127 (result temp value-cell-header-widetag value-cell-size))
128 (storew value result value-cell-value-slot other-pointer-lowtag)))
132 ;;;; Automatic allocators for primitive objects.
134 (define-vop (make-unbound-marker)
136 (:results (result :scs (any-reg)))
138 (inst li unbound-marker-widetag result)))
140 (define-vop (fixed-alloc)
142 (:info name words type lowtag)
144 (:results (result :scs (descriptor-reg)))
145 (:temporary (:scs (non-descriptor-reg)) temp)
147 (pseudo-atomic (:extra (pad-data-block words))
148 (inst move alloc-tn result)
149 (inst dep lowtag 31 3 result)
151 (inst li (logior (ash (1- words) n-widetag-bits) type) temp)
152 (storew temp result 0 lowtag)))))
154 (define-vop (var-alloc)
155 (:args (extra :scs (any-reg)))
156 (:arg-types positive-fixnum)
157 (:info name words type lowtag)
159 (:results (result :scs (descriptor-reg)))
160 (:temporary (:scs (any-reg)) bytes header)
162 (inst addi (* (1+ words) n-word-bytes) extra bytes)
163 (inst sll bytes (- n-widetag-bits 2) header)
164 (inst addi (+ (ash -2 n-widetag-bits) type) header header)
165 (inst dep 0 31 3 bytes)
167 (inst move alloc-tn result)
168 (inst dep lowtag 31 3 result)
169 (storew header result 0 lowtag)
170 (inst add alloc-tn bytes alloc-tn))))