/[cmucl]/src/compiler/eval-comp.lisp
ViewVC logotype

Contents of /src/compiler/eval-comp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.38 - (show annotations)
Tue Apr 20 17:57:46 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.37: +6 -6 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/eval-comp.lisp,v 1.38 2010/04/20 17:57:46 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file represents the current state of on-going development on compiler
13 ;;; hooks for an interpreter that takes the compiler's IR1 of a program.
14 ;;;
15 ;;; Written by Bill Chiles.
16 ;;;
17
18 (in-package "C")
19 (intl:textdomain "cmucl")
20
21 (declaim (special *constants* *free-variables* *compile-component*
22 *code-vector* *next-location* *result-fixups*
23 *free-functions* *source-paths* *failed-optimizations*
24 *continuation-number* *continuation-numbers*
25 *number-continuations* *tn-id* *tn-ids* *id-tns*
26 *label-ids* *label-id* *id-labels*
27 *compiler-error-count*
28 *compiler-warning-count* *compiler-note-count*
29 *compiler-error-output* *compiler-error-bailout*
30 *compiler-trace-output*
31 *last-source-context* *last-original-source*
32 *last-source-form* *last-format-string* *last-format-args*
33 *last-message-count* *check-consistency*
34 *all-components* *converting-for-interpreter*
35 *source-info* *block-compile* *current-path*
36 *current-component* *lexical-environment*))
37
38 (export '(compile-for-eval lambda-eval-info-frame-size
39 lambda-eval-info-args-passed lambda-eval-info-entries
40 lambda-eval-info-function entry-node-info-st-top
41 entry-node-info-nlx-tag))
42
43
44 ;;; COMPILE-FOR-EVAL -- Public.
45 ;;;
46 ;;; This translates form into the compiler's IR1 and performs environment
47 ;;; analysis. It is sort of a combination of NCOMPILE-FILE, SUB-COMPILE-FILE,
48 ;;; COMPILE-TOP-LEVEL, and COMPILE-COMPONENT.
49 ;;;
50 (defun compile-for-eval (form quietly &optional env)
51 (with-ir1-namespace
52 (let* ((*block-compile* nil)
53 (*coalesce-constants* nil)
54 (*lexical-environment* (or env (make-null-environment)))
55 ;;
56 (*compiler-error-output*
57 (if quietly
58 (make-broadcast-stream)
59 *error-output*))
60 (*compiler-trace-output* nil)
61 (*compiler-error-bailout*
62 #'(lambda () (error (intl:gettext "Fatal error, aborting evaluation."))))
63 ;;
64 (*current-path* nil)
65 (*last-source-context* nil)
66 (*last-original-source* nil)
67 (*last-source-form* nil)
68 (*last-format-string* nil)
69 (*last-format-args* nil)
70 (*last-message-count* 0)
71 ;;
72 (*compiler-error-count* 0)
73 (*compiler-warning-count* 0)
74 (*compiler-note-count* 0)
75 (*source-info* (make-lisp-source-info form))
76 (*converting-for-interpreter* t)
77 (*gensym-counter* 0))
78
79 (clear-stuff nil)
80 (find-source-paths form 0)
81 ;;
82 ;; This LET comes from COMPILE-TOP-LEVEL.
83 ;; The noted DOLIST is a splice from a call that COMPILE-TOP-LEVEL makes.
84 (with-compilation-unit ()
85 (let ((lambdas (list (ir1-top-level form '(original-source-start 0 0)
86 t))))
87 (declare (list lambdas))
88 (dolist (lambda lambdas)
89 (let* ((component
90 (block-component (node-block (lambda-bind lambda))))
91 (*all-components* (list component)))
92 (local-call-analyze component)))
93 (multiple-value-bind (components top-components)
94 (find-initial-dfo lambdas)
95 (let ((*all-components* (append components top-components)))
96 (when *check-consistency*
97 (check-ir1-consistency *all-components*))
98 ;;
99 ;; This DOLIST body comes from the beginning of
100 ;; COMPILE-COMPONENT.
101 (dolist (component *all-components*)
102 ;;
103 ;; Since we don't call IR1-OPTIMIZE, delete
104 ;; unreachable blocks here.
105 (do-blocks (block component)
106 (when (block-unreachable-p block)
107 (delete-block block)))
108
109 (ir1-finalize component)
110 (let ((*compile-component* component))
111 (environment-analyze component))
112 (annotate-component-for-eval component))
113 (when *check-consistency*
114 (check-ir1-consistency *all-components*))))
115 (car lambdas))))))
116
117
118 ;;;; Annotating IR1 for interpretation.
119
120 (defstruct (lambda-eval-info (:print-function print-lambda-eval-info)
121 (:constructor make-lambda-eval-info
122 (frame-size args-passed entries)))
123 frame-size ;Number of stack locations needed to hold locals.
124 args-passed ;Number of referenced arguments passed to lambda.
125 entries ;A-list mapping entry nodes to stack locations.
126 (function nil)) ;A function object corresponding to this lambda.
127
128 (defun print-lambda-eval-info (obj str n)
129 (declare (ignore n obj))
130 (format str "#<Lambda-eval-info>"))
131
132 (defstruct (entry-node-info (:print-function print-entry-node-info)
133 (:constructor make-entry-node-info
134 (st-top nlx-tag)))
135 st-top ;Stack top when we encounter the entry node.
136 nlx-tag) ;Tag to which to throw to get back entry node's context.
137
138 (defun print-entry-node-info (obj str n)
139 (declare (ignore n obj))
140 (format str "#<Entry-node-info>"))
141
142
143 ;;; Some compiler funny functions have definitions, so the interpreter can
144 ;;; call them. These require special action to coordinate the interpreter,
145 ;;; system call stack, and the environment. The annotation prepass marks the
146 ;;; references to these as :unused, so the interpreter doesn't try to fetch
147 ;;; function's through these undefined symbols.
148 ;;;
149 (defconstant undefined-funny-funs
150 '(%special-bind %special-unbind %more-arg-context %unknown-values %catch
151 %unwind-protect %catch-breakup %unwind-protect-breakup %lexical-exit-breakup
152 %continue-unwind %nlx-entry))
153
154 ;;; Some kinds of functions are only passed as arguments to funny functions,
155 ;;; and are never actually evaluated at run time.
156 ;;;
157 (defconstant non-closed-function-kinds '(:cleanup :escape))
158
159 ;;; ANNOTATE-COMPONENT-FOR-EVAL -- Internal.
160 ;;;
161 ;;; This annotates continuations, lambda-vars, and lambdas. For each
162 ;;; continuation, we cache how its destination uses its value. This only buys
163 ;;; efficiency when the code executes more than once, but the overhead of this
164 ;;; part of the prepass for code executed only once should be negligible.
165 ;;;
166 ;;; As a special case to aid interpreting local function calls, we sometimes
167 ;;; note the continuation as :unused. This occurs when there is a local call,
168 ;;; and there is no actual function object to call; we mark the continuation as
169 ;;; :unused since there is nothing to push on the interpreter's stack.
170 ;;; Normally we would see a reference to a function that we would push on the
171 ;;; stack to later pop and apply to the arguments on the stack. To determine
172 ;;; when we have a local call with no real function object, we look at the node
173 ;;; to see if it is a reference with a destination that is a :local combination
174 ;;; whose function is the reference node's continuation.
175 ;;;
176 ;;; After checking for virtual local calls, we check for funny functions the
177 ;;; compiler refers to for calling to note certain operations. These functions
178 ;;; are undefined, and if the interpreter tried to reference the function cells
179 ;;; of these symbols, it would get an error. We mark the continuations
180 ;;; delivering the values of these references as :unused, so the reference
181 ;;; never takes place.
182 ;;;
183 ;;; For each lambda-var, including a lambda's vars and its let's vars, we note
184 ;;; the stack offset used to access and store that variable. Then we note the
185 ;;; lambda with the total number of variables, so we know how big its stack
186 ;;; frame is. Also in the lambda's info is the number of its arguments that it
187 ;;; actually references; the interpreter never pushes or pops an unreferenced
188 ;;; argument, so we can't just use LENGTH on LAMBDA-VARS to know how many args
189 ;;; the caller passed.
190 ;;;
191 ;;; For each entry node in a lambda, we associate in the lambda-eval-info the
192 ;;; entry node with a stack offset. Evaluation code stores the frame pointer
193 ;;; in this slot upon processing the entry node to aid stack cleanup and
194 ;;; correct frame manipulation when processing exit nodes.
195 ;;;
196 (defun annotate-component-for-eval (component)
197 (do-blocks (b component)
198 (do-nodes (node cont b)
199 (let* ((dest (continuation-dest cont))
200 (refp (typep node 'ref))
201 (leaf (if refp (ref-leaf node))))
202 (setf (continuation-info cont)
203 (cond ((and refp dest (typep dest 'basic-combination)
204 (eq (basic-combination-kind dest) :local)
205 (eq (basic-combination-fun dest) cont))
206 :unused)
207 ((and leaf (typep leaf 'global-var)
208 (eq (global-var-kind leaf) :global-function)
209 (member (c::global-var-name leaf) undefined-funny-funs
210 :test #'eq))
211 :unused)
212 ((and leaf (typep leaf 'clambda)
213 (member (functional-kind leaf)
214 non-closed-function-kinds))
215 (assert (not (eq (functional-kind leaf) :escape)))
216 :unused)
217 (t
218 (typecase dest
219 ;; Change locations in eval.lisp that think :return could
220 ;; occur.
221 ((or mv-combination creturn exit) :multiple)
222 (null :unused)
223 (t :single))))))))
224 (dolist (lambda (component-lambdas component))
225 (let ((locals-count 0)
226 (args-passed-count 0))
227 (dolist (var (lambda-vars lambda))
228 (setf (leaf-info var) locals-count)
229 (incf locals-count)
230 (when (leaf-refs var) (incf args-passed-count)))
231 (dolist (let (lambda-lets lambda))
232 (dolist (var (lambda-vars let))
233 (setf (leaf-info var) locals-count)
234 (incf locals-count)))
235 (let ((entries nil))
236 (dolist (e (lambda-entries lambda))
237 (ecase (process-entry-node-p e)
238 (:blow-it-off)
239 (:local-lexical-exit
240 (push (cons e (make-entry-node-info locals-count nil))
241 entries)
242 (incf locals-count))
243 (:non-local-lexical-exit
244 (push (cons e
245 (make-entry-node-info locals-count (incf locals-count)))
246 entries)
247 (incf locals-count))))
248 (setf (lambda-info lambda)
249 (make-lambda-eval-info locals-count args-passed-count
250 entries))))))
251
252 ;;; PROCESS-ENTRY-NODE-P -- Internal.
253 ;;;
254 (defun process-entry-node-p (entry)
255 (let ((entry-cleanup (entry-cleanup entry)))
256 (dolist (nlx (environment-nlx-info (node-environment entry))
257 :local-lexical-exit)
258 (let ((cleanup (nlx-info-cleanup nlx)))
259 (when (eq entry-cleanup cleanup)
260 (ecase (cleanup-kind cleanup)
261 ((:block :tagbody)
262 (return :non-local-lexical-exit))
263 ((:catch :unwind-protect)
264 (return :blow-it-off))))))))
265
266
267 ;;; Sometime consider annotations to exclude processign of exit nodes when
268 ;;; we want to do a tail-p thing.
269 ;;;
270
271
272 ;;;; Defining funny functions for interpreter.
273
274 #|
275 %listify-rest-args %more-arg %verify-argument-count %argument-count-error
276 %odd-keyword-arguments-error %unknown-keyword-argument-error
277 |#
278
279 (defun %verify-argument-count (supplied-args defined-args)
280 (unless (= supplied-args defined-args)
281 (simple-program-error (intl:gettext "Wrong argument count, wanted ~D and got ~D.")
282 defined-args supplied-args))
283 (values))
284
285 ;;; Use (SETF SYMBOL-FUNCTION) insetad of DEFUN so that the compiler
286 ;;; doesn't try to compile the hidden %THROW MV-CALL in the throw below as
287 ;;; a local recursive call.
288 ;;;
289 (setf (symbol-function '%throw)
290 #'(lambda (tag &rest args)
291 (throw tag (values-list args))))
292
293 (defun %more-arg (args index)
294 (nth index args))
295
296 (defun %listify-rest-args (ptr count dynamic-extent)
297 (declare (ignore count dynamic-extent))
298 ptr)
299
300 (defun %more-arg-values (args start count)
301 (values-list (subseq args start count)))
302
303 (defun %argument-count-error (args-passed-count)
304 (error 'simple-program-error
305 :format-control (intl:gettext "Wrong number of arguments passed -- ~S.")
306 :format-arguments (list args-passed-count)))
307
308 (defun %odd-keyword-arguments-error ()
309 (error 'simple-program-error
310 :format-control
311 (intl:gettext "Function called with odd number of keyword arguments.")))
312
313 (defun %unknown-keyword-argument-error (keyword)
314 (error 'simple-program-error
315 :format-control (intl:gettext "Unknown keyword argument -- ~S.")
316 :format-arguments (list keyword)))
317
318 (defun %cleanup-point ())
319
320 (defun value-cell-ref (x) (value-cell-ref x))

  ViewVC Help
Powered by ViewVC 1.1.5