Declare types of END and TEST in N{LIST,VECTOR}-SUBSTITUTE-IF[-NOT]*
[sbcl.git] / src / compiler / sparc / alloc.lisp
1 ;;;; allocation VOPs for the Sparc port
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; LIST and LIST*
15 (define-vop (list-or-list*)
16   (:args (things :more t))
17   (:temporary (:scs (descriptor-reg) :type list) ptr)
18   (:temporary (:scs (descriptor-reg)) temp)
19   (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
20               res)
21   (:temporary (:scs (non-descriptor-reg)) alloc-temp)
22   (:info num)
23   (:results (result :scs (descriptor-reg)))
24   (:variant-vars star)
25   (:policy :safe)
26   (:node-var node)
27   (:generator 0
28     (cond ((zerop num)
29            (move result null-tn))
30           ((and star (= num 1))
31            (move result (tn-ref-tn things)))
32           (t
33            (macrolet
34                ((maybe-load (tn)
35                   (once-only ((tn tn))
36                     `(sc-case ,tn
37                        ((any-reg descriptor-reg zero null)
38                         ,tn)
39                        (control-stack
40                         (load-stack-tn temp ,tn)
41                         temp)))))
42              (let* ((dx-p (node-stack-allocate-p node))
43                     (cons-cells (if star (1- num) num))
44                     (alloc (* (pad-data-block cons-size) cons-cells)))
45                (pseudo-atomic ()
46                  (allocation res alloc list-pointer-lowtag
47                              :stack-p dx-p
48                              :temp-tn alloc-temp)
49                  (move ptr res)
50                  (dotimes (i (1- cons-cells))
51                    (storew (maybe-load (tn-ref-tn things)) ptr
52                            cons-car-slot list-pointer-lowtag)
53                    (setf things (tn-ref-across things))
54                    (inst add ptr ptr (pad-data-block cons-size))
55                    (storew ptr ptr
56                            (- cons-cdr-slot cons-size)
57                            list-pointer-lowtag))
58                  (storew (maybe-load (tn-ref-tn things)) ptr
59                          cons-car-slot list-pointer-lowtag)
60                  (storew (if star
61                              (maybe-load (tn-ref-tn (tn-ref-across things)))
62                              null-tn)
63                          ptr cons-cdr-slot list-pointer-lowtag))
64                (move result res)))))))
65
66 (define-vop (list list-or-list*)
67   (:variant nil))
68
69 (define-vop (list* list-or-list*)
70   (:variant t))
71
72 \f
73 ;;;; Special purpose inline allocators.
74
75 (define-vop (allocate-code-object)
76   (:args (boxed-arg :scs (any-reg))
77          (unboxed-arg :scs (any-reg)))
78   (:results (result :scs (descriptor-reg)))
79   (:temporary (:scs (non-descriptor-reg)) ndescr)
80   (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
81   (:temporary (:scs (non-descriptor-reg)) size)
82   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
83   (:generator 100
84     (inst add boxed boxed-arg (fixnumize (1+ code-trace-table-offset-slot)))
85     (inst and boxed (lognot lowtag-mask))
86     (inst srl unboxed unboxed-arg word-shift)
87     (inst add unboxed lowtag-mask)
88     (inst and unboxed (lognot lowtag-mask))
89     (pseudo-atomic ()
90       ;;
91       ;; This looks like another dreadful type pun. CSR - 2002-02-06
92       ;;
93       ;; Not any more, or not in that sense at least, because the
94       ;; "p/a bit is also the highest lowtag bit" assumption is now hidden
95       ;; in the allocation macro.  DFL - 2012-10-01
96       ;;
97       ;; Figure out how much space we really need and allocate it.
98       (inst add size boxed unboxed)
99       (allocation result size other-pointer-lowtag :temp-tn ndescr)
100       (inst sll ndescr boxed (- n-widetag-bits word-shift))
101       (inst or ndescr code-header-widetag)
102       (storew ndescr result 0 other-pointer-lowtag)
103       (storew unboxed result code-code-size-slot other-pointer-lowtag)
104       (storew null-tn result code-entry-points-slot other-pointer-lowtag)
105       (storew null-tn result code-debug-info-slot other-pointer-lowtag))))
106
107 (define-vop (make-fdefn)
108   (:args (name :scs (descriptor-reg) :to :eval))
109   (:temporary (:scs (non-descriptor-reg)) temp)
110   (:results (result :scs (descriptor-reg) :from :argument))
111   (:policy :fast-safe)
112   (:translate make-fdefn)
113   (:generator 37
114     (with-fixed-allocation (result temp fdefn-widetag fdefn-size)
115       (inst li temp (make-fixup "undefined_tramp" :foreign))
116       (storew name result fdefn-name-slot other-pointer-lowtag)
117       (storew null-tn result fdefn-fun-slot other-pointer-lowtag)
118       (storew temp result fdefn-raw-addr-slot other-pointer-lowtag))))
119
120
121 (define-vop (make-closure)
122   (:args (function :to :save :scs (descriptor-reg)))
123   (:info length stack-allocate-p)
124   (:temporary (:scs (non-descriptor-reg)) temp)
125   (:results (result :scs (descriptor-reg)))
126   (:generator 10
127     (let* ((size (+ length closure-info-offset))
128            (alloc-size (pad-data-block size)))
129       (pseudo-atomic ()
130         (allocation result alloc-size fun-pointer-lowtag
131                     :stack-p stack-allocate-p
132                     :temp-tn temp)
133         (inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
134         (storew temp result 0 fun-pointer-lowtag)
135         (storew function result closure-fun-slot fun-pointer-lowtag)))))
136
137 ;;; The compiler likes to be able to directly make value cells.
138 (define-vop (make-value-cell)
139   (:args (value :to :save :scs (descriptor-reg any-reg)))
140   (:temporary (:scs (non-descriptor-reg)) temp)
141   (:info stack-allocate-p)
142   (:ignore stack-allocate-p)
143   (:results (result :scs (descriptor-reg)))
144   (:generator 10
145     (with-fixed-allocation
146         (result temp value-cell-header-widetag value-cell-size)
147       (storew value result value-cell-value-slot other-pointer-lowtag))))
148 \f
149 ;;;; Automatic allocators for primitive objects.
150
151 (define-vop (make-unbound-marker)
152   (:args)
153   (:results (result :scs (descriptor-reg any-reg)))
154   (:generator 1
155     (inst li result unbound-marker-widetag)))
156
157 (define-vop (make-funcallable-instance-tramp)
158   (:args)
159   (:results (result :scs (any-reg)))
160   (:generator 1
161     (inst li result (make-fixup "funcallable_instance_tramp" :foreign))))
162
163 (define-vop (fixed-alloc)
164   (:args)
165   (:info name words type lowtag stack-allocate-p)
166   (:ignore name stack-allocate-p)
167   (:results (result :scs (descriptor-reg)))
168   (:temporary (:scs (non-descriptor-reg)) temp)
169   (:generator 4
170     (pseudo-atomic ()
171       (allocation result (pad-data-block words) lowtag :temp-tn temp)
172       (when type
173         (inst li temp (logior (ash (1- words) n-widetag-bits) type))
174         (storew temp result 0 lowtag)))))
175
176 (define-vop (var-alloc)
177   (:args (extra :scs (any-reg)))
178   (:arg-types positive-fixnum)
179   (:info name words type lowtag)
180   (:ignore name)
181   (:results (result :scs (descriptor-reg)))
182   (:temporary (:scs (any-reg)) bytes)
183   (:temporary (:scs (non-descriptor-reg)) header)
184   (:temporary (:scs (non-descriptor-reg)) temp)
185   (:generator 6
186     (inst add bytes extra (* (1+ words) n-word-bytes))
187     (inst sll header bytes (- n-widetag-bits 2))
188     (inst add header header (+ (ash -2 n-widetag-bits) type))
189     (inst and bytes (lognot lowtag-mask))
190     (pseudo-atomic ()
191       (allocation result bytes lowtag :temp-tn temp)
192       (storew header result 0 lowtag))))