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/ir1util.lisp,v 1.32 1991/03/11 16:05:25 ram Exp $")
;;; **********************************************************************
;;;
;;; This file contains random utilities used for manipulating the IR1
;;; representation.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package "C")
(export '(*compiler-notification-function*))
(in-package "EXTENSIONS")
(export '(*error-print-level* *error-print-length*
*source-context-take-car-forms* *undefined-warning-limit*
*enclosing-source-cutoff*))
(in-package "C")
;;; Node-Enclosing-Cleanup -- Interface
;;; Return the innermost cleanup enclosing Node, or NIL if there is none in
;;; its function. If Node has no cleanup, but is in a let, then we must still
;;; check the environment that the call is in.
(defun node-enclosing-cleanup (node)
(declare (type node node))
(do ((lexenv (node-lexenv node)
(lambda-call-lexenv (lexenv-lambda lexenv))))
((null lexenv) nil)
(let ((cup (lexenv-cleanup lexenv)))
(when cup (return cup)))))
;;; Insert-Cleanup-Code -- Interface
;;;
;;; Convert the Form in a block inserted between Block1 and Block2 as an
;;; implicit MV-Prog1. The inserted block is returned. Node is used for IR1
;;; context when converting the form. Note that the block is not assigned a
;;; number, and is linked into the DFO at the beginning. We indicate that we
;;; have trashed the DFO by setting Component-Reanalyze. If Cleanup is
;;; supplied, then convert with that cleanup.
(defun insert-cleanup-code (block1 block2 node form &optional cleanup)
(declare (type cblock block1 block2) (type node node)
(type (or cleanup null) cleanup))
(with-ir1-environment node
(let* ((start (make-continuation))
(block (continuation-starts-block start))
(cont (make-continuation))
(*lexical-environment*
(if cleanup
(make-lexenv :cleanup cleanup)
*lexical-environment*)))
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
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
(change-block-successor block1 block2 block)
(link-blocks block block2)
(ir1-convert start cont form)
(setf (block-last block) (continuation-use cont))
block)))
;;;; Continuation use hacking:
;;; Find-Uses -- Interface
;;;
;;; Return a list of all the nodes which use Cont.
;;;
(proclaim '(function find-uses (continuation) list))
(defun find-uses (cont)
(ecase (continuation-kind cont)
((:block-start :deleted-block-start)
(block-start-uses (continuation-block cont)))
(:inside-block (list (continuation-use cont)))
(:unused nil)))
;;; Delete-Continuation-Use -- Interface
;;;
;;; Update continuation use information so that Node is no longer a use of
;;; its Cont. If the old continuation doesn't start its block, then we don't
;;; update the Block-Start-Uses, since it will be deleted when we are done.
;;;
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something has
;;; changed.
;;;
(proclaim '(function delete-continuation-use (node) void))
(defun delete-continuation-use (node)
(let* ((cont (node-cont node))
(block (continuation-block cont)))
(ecase (continuation-kind cont)
(:deleted)
((:block-start :deleted-block-start)
(let ((uses (delete node (block-start-uses block))))
(setf (block-start-uses block) uses)
(setf (continuation-use cont)
(if (cdr uses) nil (car uses)))))
(:inside-block
(setf (continuation-kind cont) :unused)
(setf (continuation-block cont) nil)
(setf (continuation-use cont) nil)
(setf (continuation-next cont) nil)))
(setf (node-cont node) nil)))
;;; Add-Continuation-Use -- Interface
;;;
;;; Update continuation use information so that Node uses Cont. If Cont is
;;; :Unused, then we set its block to Node's Node-Block (which must be set.)
;;;
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something has
;;; changed.
;;;
(proclaim '(function add-continuation-use (node continuation) void))
(defun add-continuation-use (node cont)
(assert (not (node-cont node)))
(let ((block (continuation-block cont)))
(ecase (continuation-kind cont)
(:deleted)
(:unused
(assert (not block))
(let ((block (node-block node)))
(assert block)
(setf (continuation-block cont) block))
(setf (continuation-kind cont) :inside-block)
(setf (continuation-use cont) node))
((:block-start :deleted-block-start)
(let ((uses (cons node (block-start-uses block))))
(setf (block-start-uses block) uses)
(setf (continuation-use cont)
(if (cdr uses) nil (car uses)))))))
(setf (node-cont node) cont))
;;; Immediately-Used-P -- Interface
;;;
;;; Return true if Cont is the Node-Cont for Node and Cont is transferred to
;;; immediately after the evaluation of Node.
;;;
(defun immediately-used-p (cont node)
(declare (type continuation cont) (type node node))
(and (eq (node-cont node) cont)
(not (eq (continuation-kind cont) :deleted))
(let ((cblock (continuation-block cont))
(nblock (node-block node)))
(or (eq cblock nblock)
(let ((succ (block-succ nblock)))
(and (= (length succ) 1)
(eq (first succ) cblock)))))))
;;;; Continuation substitution:
;;; Substitute-Continuation -- Interface
;;;
;;; In Old's Dest, replace Old with New. New's Dest must initially be NIL.
;;; When we are done, we call Flush-Dest on Old to clear its Dest and to note
;;; potential optimization opportunities.
;;;
(defun substitute-continuation (new old)
(declare (type continuation old new))
(assert (not (continuation-dest new)))
(let ((dest (continuation-dest old)))
(etypecase dest
((or ref bind))
(cif (setf (if-test dest) new))
(cset (setf (set-value dest) new))
(creturn (setf (return-result dest) new))
(exit (setf (exit-value dest) new))
(basic-combination
(if (eq old (basic-combination-fun dest))
(setf (basic-combination-fun dest) new)
(setf (basic-combination-args dest)
(nsubst new old (basic-combination-args dest))))))
(flush-dest old)
(setf (continuation-dest new) dest))
(undefined-value))
;;; Ensure-Block-Start -- Interface
;;;
;;; Ensure that Cont is the start of a block (or deleted) so that the use
;;; set can be freely manipulated.
;;; -- If the continuation is :Unused or is :Inside-Block and the Cont of Last
;;; in its block, then we make it the start of a new deleted block.
;;; -- If the continuation is :Inside-Block inside a block, then we split the
;;; block using Node-Ends-Block, which makes the continuation be a
;;; :Block-Start.
;;;
(defun ensure-block-start (cont)
(declare (type continuation cont))
(let ((kind (continuation-kind cont)))
(ecase kind
((:deleted :block-start :deleted-block-start))
((:unused :inside-block)
(let ((block (continuation-block cont)))
(cond ((or (eq kind :unused)
(eq (node-cont (block-last block)) cont))
(setf (continuation-block cont)
(make-block-key :start cont :component nil))
(setf (continuation-kind cont) :deleted-block-start))
(t
(node-ends-block (continuation-use cont))))))))
(undefined-value))
;;; Substitute-Continuation-Uses -- Interface
;;;
;;; Replace all uses of Old with uses of New, where New has an arbitary
;;; number of uses. If New will end up with more than one use, then we must
;;; arrange for it to start a block if it doesn't already.
;;;
(defun substitute-continuation-uses (new old)
(declare (type continuation old new))
(unless (and (eq (continuation-kind new) :unused)
(eq (continuation-kind old) :inside-block))
(ensure-block-start new))
(do-uses (node old)
(delete-continuation-use node)
(add-continuation-use node new))
(reoptimize-continuation new)
(undefined-value))
;;;; Misc shortand functions:
;;; NODE-HOME-LAMBDA -- Interface
;;;
;;; Return the home (i.e. enclosing non-let) lambda for Node. Since the
;;; LEXENV-LAMBDA may be deleted, we must chain up the LAMBDA-CALL-LEXENV
;;; thread until we find a lambda that isn't deleted, and then return its home.
;;;
(declaim (maybe-inline node-home-lambda))
(defun node-home-lambda (node)
(declare (type node node))
(do ((fun (lexenv-lambda (node-lexenv node))
(lexenv-lambda (lambda-call-lexenv fun))))
((not (eq (functional-kind fun) :deleted))
(lambda-home fun))
(when (eq (lambda-home fun) fun)
(return fun))))
;;; NODE-xxx -- Interface
(declaim (inline node-block node-tlf-number))
(declaim (maybe-inline node-environment))
(defun node-block (node)
(declare (type node node))
(the cblock (continuation-block (node-prev node))))
;;;
(defun node-environment (node)
(declare (type node node) (inline node-home-lambda))
(the environment (lambda-environment (node-home-lambda node))))
;;; BLOCK-xxx-CLEANUP -- Interface
;;;
;;; Return the enclosing cleanup for environment of the first or last node
;;; in Block.
;;;
(defun block-start-cleanup (block)
(declare (type cblock block))
(node-enclosing-cleanup (continuation-next (block-start block))))
;;;
(defun block-end-cleanup (block)
(declare (type cblock block))
(node-enclosing-cleanup (block-last block)))
;;; BLOCK-HOME-LAMBDA -- Interface
;;;
;;; Return the non-let lambda that holds Block's code.
;;;
(defun block-home-lambda (block)
(declare (type cblock block) (inline node-home-lambda))
(node-home-lambda (block-last block)))
;;; BLOCK-ENVIRONMENT -- Interface
;;;
;;; Return the IR1 environment for Block.
;;;
(defun block-environment (block)
(declare (type cblock block) (inline node-home-lambda))
(lambda-environment (node-home-lambda (block-last block))))
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
;;; SOURCE-PATH-TLF-NUMBER -- Interface
;;;
;;; Return the Top Level Form number of path, i.e. the ordinal number of
;;; its orignal source's top-level form in its compilation unit.
;;;
(defun source-path-tlf-number (path)
(declare (list path))
(car (last path)))
;;; SOURCE-PATH-ORIGINAL-SOURCE -- Interface
;;;
;;; Return the (reversed) list for the path in the orignal source (with the
;;; TLF number last.)
;;;
(defun source-path-original-source (path)
(declare (list path))
(cddr (member 'original-source-start path)))
;;; SOURCE-PATH-FORM-NUMBER -- Interface
;;;
;;; Return the Form Number of Path's orignal source inside the Top Level
;;; Form that contains it. This is determined by the order that we walk the
;;; subforms of the top level source form.
;;;
(defun source-path-form-number (path)
(declare (list path))
(cadr (member 'original-source-start path)))
;;; SOURCE-PATH-FORMS -- Interface
;;;
;;; Return a list of all the enclosing forms not in the original source that
;;; converted to get to this form, with the immediate source for node at the
;;; start of the list.
;;;
(defun source-path-forms (path)
(subseq path 0 (position 'original-source-start path)))
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
;;; MAKE-LEXENV -- Interface
;;;
;;; Return a new LEXENV just like Default except for the specified slot
;;; values. Values for the alist slots are NCONC'ed to the beginning of the
;;; current value, rather than replacing it entirely.
;;;
(defun make-lexenv (&key (default *lexical-environment*)
functions variables blocks tags type-restrictions
inlines
(lambda (lexenv-lambda default))
(cleanup (lexenv-cleanup default))
(cookie (lexenv-cookie default)))
(macrolet ((frob (var slot)
`(let ((old (,slot default)))
(if ,var
(nconc ,var old)
old))))
(internal-make-lexenv
(frob functions lexenv-functions)
(frob variables lexenv-variables)
(frob blocks lexenv-blocks)
(frob tags lexenv-tags)
(frob type-restrictions lexenv-type-restrictions)
(frob inlines lexenv-inlines)
lambda cleanup cookie)))
#|
functions
variables
blocks
tags
type-restrictions
inlines
|#
;;; Link-Blocks -- Interface
;;; Join Block1 and Block2.
(declare (type cblock block1 block2))
(assert (not (member block2 (block-succ block1))))
(push block2 (block-succ block1))
(push block1 (block-pred block2))
(undefined-value))
;;; UNLINK-BLOCKS -- Interface
;;;
;;; Like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If this leaves a
;;; successor with a single predecessor that ends in an IF, then set
;;; BLOCK-TEST-MODIFIED so that any test constraint will now be able to be
;;; propagated to the successor.
(declare (type cblock block1 block2))
Loading
Loading full blame...