Newer
Older
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; This file contains the implementation independent code for the
;;; representation selection phase in the compiler. Representation selection
;;; decides whether to use non-descriptor representations for objects and emits
;;; the appropriate representation-specific move and coerce vops.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
;;; Problems in the VM definition often show up here, so we try to be as
;;; implementor-friendly as possible.
;;;
;;; GET-OPERAND-INFO -- Interface
;;;
;;; Given a TN ref for a VOP argument or result, return these values:
;;; 1] True if the operand is an argument, false otherwise.
;;; 2] The ordinal position of the operand.
;;; 3] True if the operand is a more operand, false otherwise.
;;; 4] The costs for this operand.
;;; 5] The load-scs vector for this operand (NIL if more-p.)
;;;
(defun get-operand-info (ref)
(declare (type tn-ref ref))
(let* ((arg-p (not (tn-ref-write-p ref)))
(vop (tn-ref-vop ref))
(info (vop-info vop)))
(flet ((frob (refs costs restr load more-cost)
(do ((refs refs (tn-ref-across refs))
(costs costs (cdr costs))
(load load (cdr load))
(n 0 (1+ i)))
((null costs)
(assert more-cost)
(values arg-p
(+ n (position-in #'tn-ref-across ref refs))
t
more-cost
nil))
(when (eq refs ref)
(return
(values arg-p
n
nil
(car costs)
(car load)))))))
(if arg-p
(frob (vop-args vop) (vop-info-arg-costs info)
(vop-info-arg-load-scs info)
(vop-info-more-arg-costs info))
(frob (vop-results vop) (vop-info-result-costs info)
(vop-info-result-load-scs info)
(vop-info-more-result-costs info))))))
;;; LISTIFY-RESTRICTIONS -- Interface
;;;
;;; Convert a load-costs vector to the list of SCs allowed by the operand
;;; restriction.
;;;
(defun listify-restrictions (restr)
(declare (type sc-vector restr))
(collect ((res))
(dotimes (i sc-number-limit)
(when (eql (svref restr i) i)
(res (svref *sc-numbers* i))))
(res)))
;;; BAD-COSTS-ERROR -- Internal
;;;
;;; Try to give a helpful error message when Ref has no cost specified for
;;; some SC allowed by the TN's primitive-type.
;;;
(defun bad-costs-error (ref)
(declare (type tn-ref ref))
(let* ((tn (tn-ref-tn ref))
(vop (tn-ref-vop ref))
(ptype (tn-primitive-type tn)))
(multiple-value-bind (arg-p pos more-p costs load-scs)
(get-operand-info ref)
(collect ((losers))
(dolist (sc (primitive-type-scs ptype))
(unless (svref costs (sc-number sc))
(losers sc)))
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
(unless (losers)
(error "Representation selection flamed out for no obvious reason.~@
Try again after recompiling the VM definition."))
(error "~S is not valid as the ~:R ~:[result~;argument~] to the~@
~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@
~:[which cannot be coerced or loaded into the allowed SCs:~
~% ~S~;~]"
tn pos arg-p
(template-name info)
(primitive-type-name ptype)
(mapcar #'sc-name losers)
more-p
(mapcar #'sc-name (listify-restrictions load-scs)))))))
;;; BAD-MOVE-ARG-ERROR -- Internal
;;;
(defun bad-move-arg-error (val pass)
(declare (type tn val pass))
(error "No :MOVE-ARGUMENT VOP defined to move ~S (SC ~S) to
~S (SC ~S.)"
val (sc-name (tn-sc val))
pass (sc-name (tn-sc pass))))
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
;;; Return the best representation for a normal TN. SCs is a list of the SC
;;; numbers of the SCs to select from. Costs is a scratch vector.
;;;
(defun select-tn-representation (tn scs costs)
(declare (type tn tn) (type sc-vector costs))
(dolist (scn scs)
(setf (svref costs scn) 0))
(macrolet ((scan-refs (refs ops-slot costs-slot more-costs-slot)
`(do ((ref ,refs (tn-ref-next ref)))
((null ref))
(let* ((vop (tn-ref-vop ref))
(info (vop-info vop)))
(do ((cost (,costs-slot info) (cdr cost))
(op (,ops-slot vop) (tn-ref-across op)))
((null cost)
(add-costs (,more-costs-slot info)))
(when (eq op ref)
(add-costs (car cost))
(return))))))
(add-costs (cost)
`(let ((cost ,cost))
(dolist (scn scs)
(let ((res (svref cost scn)))
(unless res
(bad-costs-error ref))
(incf (svref costs scn) res))))))
(scan-refs (tn-reads tn) vop-args vop-info-arg-costs
vop-info-more-arg-costs)
(scan-refs (tn-writes tn) vop-results vop-info-result-costs
vop-info-more-result-costs))
(let ((min most-positive-fixnum)
(min-scn nil))
(dolist (scn scs)
(let ((cost (svref costs scn)))
(when (< cost min)
(setq min cost)
(setq min-scs scn))))
(svref *sc-numbers* min-scn)))
;;; NOTE-NUMBER-STACK-TN -- Internal
;;;
;;; Prepare for the possibility of a TN being allocated on the number stack
;;; by allocating a number-FP in all functions that TN is referenced in and in
;;; all the functions in their tail sets. Refs is a TN-Refs list of references
;;; to the TN.
;;;
(defun note-number-stack-tn (refs)
(declare (type (or tn-ref null) refs))
(do ((ref refs (tn-ref-next refs)))
((null ref))
(let* ((lambda (block-lambda
(ir2-block-block
(vop-block (tn-ref-fop ref)))))
(tails (lambda-tail-set lambda)))
(flet ((frob (fun)
(let ((env (lambda-environment lambda))
(2env (environment-info env)))
(unless (ir2-environment-number-fp 2env)
(setf (ir2-environment-number-fp 2env)
(make-number-fp-tn env))))))
(frob lambda)
(when tails
(dolist (fun (tail-set-functions tails))
(frob fun))))))
(undefined-value))
;;; ALLOCATE-OLD-NUMBER-FP-TNS -- Internal
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
;;; Allocate Old-Number-FP and Old-Number-FP-Pass TNs for all functions in
;;; tail sets that have locations which might be allocated on the number stack.
;;;
(defun allocate-old-number-fp-tns (component)
(dolist (fun (component-lambdas component))
(let* ((env (lambda-environment fun))
(2env (environment-info env)))
(unless (ir2-environment-old-number-fp 2env)
(let ((tails (lambda-tail-set fun)))
(when tails
(let ((info (tail-set-info tails)))
(when (eq (return-info-kind info) :fixed)
(dolist (loc (return-info-locations ))
(when (sc-number-stack-p (tn-sc loc))
(setf (ir2-environment-old-number-fp 2env)
(make-normal-tn *any-primitive-type*))
(setf (ir2-environment-old-number-fp-pass 2env)
(make-normal-tn *any-primitive-type*))
(return))))))))))
(undefined-value))
;;; EMIT-COERCE-VOP -- Internal
;;;
;;; Emit a coercion VOP for Op or die trying. SCS is the operand's LOAD-SCS
;;; vector, which we use to determine what SCs the VOP will accept. We pick
;;; any acceptable coerce VOP, since it practice it seems uninteresting to have
;;; more than one applicable.
;;;
;;; What we do is look at each SC allowed by the operand restriction, and
;;; see if there is a move VOP which moves between the operand's SC and load
;;; SC. If we find such a VOP, then we make a TN having the load SC as the
;;; representation.
;;;
(defun emit-coerce-vop (op scs)
(declare (type tn-ref op) (type sc-vector scs))
(let* ((op-tn (tn-ref-tn op))
(op-sc (tn-sc op-tn))
(op-scn (sc-number op-sc))
(write-p (tn-ref-write-p op))
(vop (tn-ref-vop op))
(node (vop-node vop))
(block (vop-block vop)))
(dotimes (i sc-number-limit (bad-costs-error op))
(when (eql (svref scs i) i)
(let ((res (if write-p
(svref (sc-move-vops op-sc) i)
(svref (sc-move-vops (svref *sc-numbers* i))
op-scn))))
(when res
(let ((temp (make-representation-tn i)))
(change-tn-ref-tn op temp)
(if write-p
(emit-move-template node block res temp op-tn vop)
(emit-move-template node block res op-tn temp vop)))
(return)))))))
;;; COERCE-VOP-OPERANDS -- Internal
;;;
;;; Scan the operands to VOP and call EMIT-COERCE-VOP on any for which we
;;; can't load the operand.
;;;
(defun coerce-vop-operands (vop)
(declare (type vop vop))
(let ((info (vop-info vop)))
(macrolet ((scan (ops load-scs)
`(do ((op ,ops (tn-ref-across op))
(scs ,load-scs (cdr scs)))
((null scs))
(unless (svref (car scs)
(sc-number (tn-sc (tn-ref-tn op))))
(emit-coerce-vop op (car scs))))))
(scan (vop-args vop) (vop-info-arg-load-scs info))
(scan (vop-results vop) (vop-info-result-load-scs info)))))
;;; EMIT-MOVES-AND-COERCIONS -- Internal
;;;
;;; Scan the IR2 looking for move operations that need to be replaced with
;;; special-case VOPs and emitting coercion VOPs for operands of normal VOPs.
;;;
(defun emit-moves-and-coercions (block)
(declare (type ir2-block block))
(do ((vop (ir2-block-start-vop block)
(vop-next vop)))
((null vop))
(let ((info (vop-info vop))
(node (vop-node vop))
(block (vop-block vop)))
(case (vop-info-name info)
(move-arguments
(let* ((info-args (vop-codegen-info vop))
(fp-tn (first info-args))
(nfp-tn (second info-args))
(pass-locs (third (info-args))))
(do ((val (vop-args vop) (tn-ref-across val))
(pass pass-locs (cdr pass-loc)))
((null val))
(let* ((val-tn (tn-ref-tn val))
(pass-tn (first pass))
(pass-sc (tn-sc pass-tn))
(res (svref (sc-move-arg-vops pass-sc)
(sc-number (tn-sc val-tn)))))
(unless res
(bad-move-arg-error val-tn pass-tn))
(emit-move-arg-template node block res val-tn
(if (sc-number-stack-p pass-sc)
nfp-tn fp-tn)
pass-tn
vop)))))
(move
(let ((x (tn-ref-tn (vop-args op)))
(y (tn-ref-tn (vop-results vop)))
(res (svref (sc-move-vops (tn-sc y))
(sc-number (tn-sc x)))))
(cond (res
(emit-move-template node block res x y vop)
(delete-vop vop))
(t
(coerce-vop-operands vop)))))
(t
(coerce-vop-operands vop))))))
;;; SELECT-REPRESENTATIONS -- Interface
;;;
;;; Entry to representation selection. First we select the representation
;;; for all normal TNs, setting the TN-SC. If we select a representation that
;;; allows the number stack, then we note this so that the number-FP can be
;;; allocated. Next we allocate old-NFP passing TNs for functions that may
;;; return values on the number stack. Finally, we scan the IR2 looking for
;;; places that we need to insert coercions and representation-specific moves.
;;;
(defun select-representations (component)
(let ((costs (make-array sc-number-limit)))
(do ((tn (ir2-component-normal-tns (component-info component))
(tn-next tn)))
((null tn))
(let* ((scs (primitive-type-scs (tn-primitive-type tn)))
(sc (if (rest scs)
(select-tn-representation tn scs costs)
(svref *sc-numbers* (first scs)))))
(setf (tn-sc tn) sc)
(when (sc-number-stack-p tn)
(note-number-stack-tn tn)))))
(allocate-old-number-fp-tns component)
(do-ir2-blocks (block component)
(emit-moves-and-coercions block))
(undefined-value))