Newer
Older
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common 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 CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.27 1991/05/16 00:25:56 ram Exp $")
;;; **********************************************************************
;;;
;;; This file implements the IR1 optimization phase of the compiler. IR1
;;; optimization is a grab-bag of optimizations that don't make major changes
;;; to the block-level control flow and don't use flow analysis. These
;;; optimizations can mostly be classified as "meta-evaluation", but there is a
;;; sizable top-down component as well.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)
;;;; Interface for obtaining results of constant folding:
;;; Constant-Continuation-P -- Interface
;;;
;;; Return true if the sole use of Cont is a reference to a constant leaf.
;;;
(proclaim '(function constant-continuation-p (continuation) boolean))
(defun constant-continuation-p (cont)
(let ((use (continuation-use cont)))
(and (ref-p use)
(constant-p (ref-leaf use)))))
;;; Continuation-Value -- Interface
;;;
;;; Return the constant value for a continuation whose only use is a
;;; constant node.
;;;
(proclaim '(function continuation-value (continuation) t))
(defun continuation-value (cont)
(assert (constant-continuation-p cont))
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
98
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
125
126
127
128
129
130
131
132
(constant-value (ref-leaf (continuation-use cont))))
;;;; Interface for obtaining results of type inference:
;;; CONTINUATION-PROVEN-TYPE -- Interface
;;;
;;; Return a (possibly values) type that describes what we have proven about
;;; the type of Cont without taking any type assertions into consideration.
;;; This is just the union of the NODE-DERIVED-TYPE of all the uses. Most
;;; often people use CONTINUATION-DERIVED-TYPE or CONTINUATION-TYPE instead of
;;; using this function directly.
;;;
(defun continuation-proven-type (cont)
(declare (type continuation cont))
(ecase (continuation-kind cont)
((:block-start :deleted-block-start)
(let ((uses (block-start-uses (continuation-block cont))))
(if uses
(do ((res (node-derived-type (first uses))
(values-type-union (node-derived-type (first current))
res))
(current (rest uses) (rest current)))
((null current) res))
*empty-type*)))
(:inside-block
(node-derived-type (continuation-use cont)))))
;;; Continuation-Derived-Type -- Interface
;;;
;;; Our best guess for the type of this continuation's value. Note that
;;; this may be Values or Function type, which cannot be passed as an argument
;;; to the normal type operations. See Continuation-Type. This may be called
;;; on deleted continuations, always returning *.
;;;
;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the result
;;; is a subtype of the assertion. If so, return the proven type and set
;;; TYPE-CHECK to nil. Otherwise, return the intersection of the asserted and
;;; proven types, and set TYPE-CHECK T. If TYPE-CHECK already has a non-null
;;; value, then preserve it. Only in the somewhat unusual circumstance of
;;; a newly discovered assertion will we change TYPE-CHECK from NIL to T.
;;;
;;; The result value is cached in the Continuation-%Derived-Type. If the
;;; slot is true, just return that value, otherwise recompute and stash the
;;; value there.
;;;
(proclaim '(inline continuation-derived-type))
(defun continuation-derived-type (cont)
(declare (type continuation cont))
(or (continuation-%derived-type cont)
(%continuation-derived-type cont)))
;;;
(defun %continuation-derived-type (cont)
(declare (type continuation cont))
(let ((proven (continuation-proven-type cont))
(asserted (continuation-asserted-type cont)))
(cond ((values-subtypep proven asserted)
(setf (continuation-%type-check cont) nil)
(setf (continuation-%derived-type cont) proven))
(t
(unless (or (continuation-%type-check cont)
(not (continuation-dest cont))
(eq asserted *universal-type*))
(setf (continuation-%type-check cont) t))
(setf (continuation-%derived-type cont)
(values-type-intersection asserted proven))))))
;;; CONTINUATION-TYPE-CHECK -- Interface
;;;
;;; Call CONTINUATION-DERIVED-TYPE to make sure the slot is up to date, then
;;; return it.
;;;
(proclaim '(inline continuation-type-check))
(defun continuation-type-check (cont)
(declare (type continuation cont))
(continuation-derived-type cont)
(continuation-%type-check cont))
;;; Continuation-Type -- Interface
;;;
;;; Return the derived type for Cont's first value. This is guaranteed not
;;; to be a Values or Function type.
;;;
(proclaim '(function continuation-type (continuation) ctype))
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
(defun continuation-type (cont)
(single-value-type (continuation-derived-type cont)))
;;;; Interface routines used by optimizers:
;;; Reoptimize-Continuation -- Interface
;;;
;;; This function is called by optimizers to indicate that something
;;; interesting has happened to the value of Cont. Optimizers must make sure
;;; that they don't call for reoptimization when nothing has happened, since
;;; optimization will fail to terminate.
;;;
;;; We clear any cached type for the continuation and set the reoptimize
;;; flags on everything in sight, unless the continuation is deleted (in which
;;; case we do nothing.)
;;;
;;; Since this can get called curing IR1 conversion, we have to be careful
;;; not to fly into space when the Dest's Prev is missing.
;;;
(defun reoptimize-continuation (cont)
(declare (type continuation cont))
(unless (eq (continuation-kind cont) :deleted)
(setf (continuation-%derived-type cont) nil)
(let ((dest (continuation-dest cont)))
(when dest
(setf (continuation-reoptimize cont) t)
(setf (node-reoptimize dest) t)
(let ((prev (node-prev dest)))
(when prev
(let* ((block (continuation-block prev))
(component (block-component block)))
(when (typep dest 'cif)
(setf (block-test-modified block) t))
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
(setf (block-reoptimize block) t)
(setf (component-reoptimize component) t))))))
(do-uses (node cont)
(setf (block-type-check (node-block node)) t)))
(undefined-value))
;;; Derive-Node-Type -- Interface
;;;
;;; Annotate Node to indicate that its result has been proven to be typep to
;;; RType. After IR1 conversion has happened, this is the only correct way to
;;; supply information discovered about a node's type. If you fuck with the
;;; Node-Derived-Type directly, then information may be lost and reoptimization
;;; may not happen.
;;;
;;; What we do is intersect Rtype with Node's Derived-Type. If the
;;; intersection is different from the old type, then we do a
;;; Reoptimize-Continuation on the Node-Cont.
;;;
(defun derive-node-type (node rtype)
(declare (type node node) (type ctype rtype))
(let ((node-type (node-derived-type node)))
(unless (eq node-type rtype)
(let ((int (values-type-intersection node-type rtype)))
(when (type/= node-type int)
(setf (node-derived-type node) int)
(reoptimize-continuation (node-cont node))))))
(undefined-value))
;;; Assert-Continuation-Type -- Interface
;;;
;;; Similar to Derive-Node-Type, but asserts that it is an error for Cont's
;;; value not to be typep to Type. If we improve the assertion, we set
;;; TYPE-CHECK and TYPE-ASSERTED to guarantee that the new assertion will be
;;; checked.
;;;
(defun assert-continuation-type (cont type)
(declare (type continuation cont) (type ctype type))
(let ((cont-type (continuation-asserted-type cont)))
(unless (eq cont-type type)
(let ((int (values-type-intersection cont-type type)))
(when (type/= cont-type int)
(setf (continuation-asserted-type cont) int)
(do-uses (node cont)
(setf (block-attributep (block-flags (node-block node))
type-check type-asserted)
t))
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
(reoptimize-continuation cont)))))
(undefined-value))
;;; Assert-Call-Type -- Interface
;;;
;;; Assert that Call is to a function of the specified Type. It is assumed
;;; that the call is legal and has only constants in the keyword positions.
;;;
(defun assert-call-type (call type)
(declare (type combination call) (type function-type type))
(derive-node-type call (function-type-returns type))
(let ((args (combination-args call)))
(dolist (req (function-type-required type))
(when (null args) (return-from assert-call-type))
(let ((arg (pop args)))
(assert-continuation-type arg req)))
(dolist (opt (function-type-optional type))
(when (null args) (return-from assert-call-type))
(let ((arg (pop args)))
(assert-continuation-type arg opt)))
(let ((rest (function-type-rest type)))
(when rest
(dolist (arg args)
(assert-continuation-type arg rest))))
(dolist (key (function-type-keywords type))
(let ((name (key-info-name key)))
(do ((arg args (cddr arg)))
((null arg))
(when (eq (continuation-value (first arg)) name)
(assert-continuation-type
(second arg) (key-info-type key)))))))
(undefined-value))
;;; IR1-Optimize -- Interface
;;;
;;; Do one forward pass over Component, deleting unreachable blocks and
;;; doing IR1 optimizations. We can ignore all blocks that don't have the
;;; Reoptimize flag set. If Component-Reoptimize is true when we are done,
;;; then another iteration would be beneficial.
;;;
;;; We delete blocks when there is either no predecessor or the block is in
;;; a lambda that has been deleted. These blocks would eventually be deleted
;;; by DFO recomputation, but doing it here immediately makes the effect
;;; avaliable to IR1 optimization.
;;;
(defun ir1-optimize (component)
(declare (type component component))
(setf (component-reoptimize component) nil)
(do-blocks (block component)
(cond
((or (block-delete-p block)
(null (block-pred block))
(eq (functional-kind (block-home-lambda block)) :deleted))
(delete-block block))
(t
(loop
(let ((succ (block-succ block)))
(unless (and succ (null (rest succ)))
(return)))
(let ((last (block-last block)))
(typecase last
(cif
(flush-dest (if-test last))
(when (unlink-node last) (return)))
(exit
(when (maybe-delete-exit last) (return)))))
(unless (join-successor-if-possible block)
(return)))
(when (and (block-reoptimize block) (block-component block))
(assert (not (block-delete-p block)))
(ir1-optimize-block block))
(when (and (block-flush-p block) (block-component block))
(assert (not (block-delete-p block)))
(flush-dead-code block)))))
(undefined-value))
;;; IR1-Optimize-Block -- Internal
;;;
;;; Loop over the nodes in Block, looking for stuff that needs to be
;;; optimized. We dispatch off of the type of each node with its reoptimize
;;; flag set:
;;; -- With a combination, we call Propagate-Function-Change whenever the
;;; function changes, and call IR1-Optimize-Combination if any argument
;;; changes.
;;; -- With an Exit, we derive the node's type from the Value's type. We don't
;;; propagate Cont's assertion to the Value, since if we did, this would
;;; move the checking of Cont's assertion to the exit. This wouldn't work
;;; with Catch and UWP, where the Exit node is just a placeholder for the
;;; actual unknown exit.
;;;
;;; Note that we clear the node & block reoptimize flags *before* doing the
;;; optimization. This ensures that the node or block will be reoptimized if
;;; IR1-OPTIMIZE-RETURN, since it wants to clear the flag itself.
;;;
(defun ir1-optimize-block (block)
(declare (type cblock block))
(setf (block-reoptimize block) nil)
(when (node-reoptimize node)
(setf (node-reoptimize node) nil)
(typecase node
(ref)
(combination
(when (continuation-reoptimize (basic-combination-fun node))
(propagate-function-change node))
(when (dolist (arg (basic-combination-args node) nil)
(when (and arg (continuation-reoptimize arg))
(return t)))
(ir1-optimize-combination node)))
(cif
(ir1-optimize-if node))
(creturn
(setf (node-reoptimize node) t)
(ir1-optimize-return node))
(mv-combination
(ir1-optimize-mv-combination node))
(exit
(let ((value (exit-value node)))
(when value
(derive-node-type node (continuation-derived-type value)))))
(cset
(ir1-optimize-set node)))))
(undefined-value))
;;; Join-Successor-If-Possible -- Internal
;;;
;;; We cannot combine with a successor block if:
;;; 1] The successor has more than one predecessor.
;;; 2] The last node's Cont is also used somewhere else.
;;; 3] The successor is the current block (infinite loop).
;;; 4] The next block has a different cleanup, and thus we may want to insert
;;; cleanup code between the two blocks at some point.
;;; 5] The next block has a different home lambda, and thus the control
;;; transfer is a non-local exit.
;;;
;;; If we succeed, we return true, otherwise false.
;;;
;;; Joining is easy when the successor's Start continuation is the same from
;;; our Last's Cont. If they differ, then we can still join when the last
;;; continuation has no next and the next continuation has no uses. In this
;;; case, we replace the next continuation with the last before joining the
;;; blocks.
;;;
(defun join-successor-if-possible (block)
(declare (type cblock block))
(let ((next (first (block-succ block))))
(when (block-start next)
Loading
Loading full blame...