/[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 - (hide 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 wlott 1.1 ;;; -*- Package: C; Log: C.Log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.17 ;;; 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 rtoy 1.38 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/eval-comp.lisp,v 1.38 2010/04/20 17:57:46 rtoy Rel $")
9 ram 1.17 ;;;
10 wlott 1.1 ;;; **********************************************************************
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 rtoy 1.37 (intl:textdomain "cmucl")
20 wlott 1.1
21 pw 1.29 (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 wlott 1.1
38     (export '(compile-for-eval lambda-eval-info-frame-size
39     lambda-eval-info-args-passed lambda-eval-info-entries
40 ram 1.7 lambda-eval-info-function entry-node-info-st-top
41     entry-node-info-nlx-tag))
42 wlott 1.1
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 toy 1.32 (defun compile-for-eval (form quietly &optional env)
51 wlott 1.1 (with-ir1-namespace
52     (let* ((*block-compile* nil)
53 toy 1.33 (*coalesce-constants* nil)
54 toy 1.32 (*lexical-environment* (or env (make-null-environment)))
55 wlott 1.1 ;;
56     (*compiler-error-output*
57     (if quietly
58     (make-broadcast-stream)
59     *error-output*))
60     (*compiler-trace-output* nil)
61     (*compiler-error-bailout*
62 rtoy 1.38 #'(lambda () (error (intl:gettext "Fatal error, aborting evaluation."))))
63 wlott 1.1 ;;
64 ram 1.11 (*current-path* nil)
65 wlott 1.1 (*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 ram 1.13 (*source-info* (make-lisp-source-info form))
76 wlott 1.22 (*converting-for-interpreter* t)
77     (*gensym-counter* 0))
78 ram 1.13
79 ram 1.12 (clear-stuff nil)
80 ram 1.8 (find-source-paths form 0)
81 wlott 1.1 ;;
82     ;; This LET comes from COMPILE-TOP-LEVEL.
83     ;; The noted DOLIST is a splice from a call that COMPILE-TOP-LEVEL makes.
84 ram 1.9 (with-compilation-unit ()
85 ram 1.13 (let ((lambdas (list (ir1-top-level form '(original-source-start 0 0)
86     t))))
87 ram 1.9 (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 ram 1.10 (multiple-value-bind (components top-components)
94 gerd 1.36 (find-initial-dfo lambdas)
95 ram 1.10 (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 gerd 1.36 ;;
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 ram 1.18 (ir1-finalize component)
110 ram 1.10 (let ((*compile-component* component))
111     (environment-analyze component))
112     (annotate-component-for-eval component))
113 ram 1.9 (when *check-consistency*
114 ram 1.10 (check-ir1-consistency *all-components*))))
115 ram 1.9 (car lambdas))))))
116 wlott 1.1
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 ram 1.7 entries ;A-list mapping entry nodes to stack locations.
126     (function nil)) ;A function object corresponding to this lambda.
127 wlott 1.1
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 ram 1.5 ;;; 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 wlott 1.1
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 ram 1.2 (cond ((and refp dest (typep dest 'basic-combination)
204 ram 1.3 (eq (basic-combination-kind dest) :local)
205     (eq (basic-combination-fun dest) cont))
206 wlott 1.1 :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 ram 1.5 :unused)
212     ((and leaf (typep leaf 'clambda)
213     (member (functional-kind leaf)
214     non-closed-function-kinds))
215 ram 1.6 (assert (not (eq (functional-kind leaf) :escape)))
216 wlott 1.1 :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 ram 1.13 (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 wlott 1.1
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 rtoy 1.38 (simple-program-error (intl:gettext "Wrong argument count, wanted ~D and got ~D.")
282 wlott 1.23 defined-args supplied-args))
283     (values))
284 wlott 1.1
285 wlott 1.14 ;;; 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 wlott 1.1
293     (defun %more-arg (args index)
294     (nth index args))
295    
296 toy 1.35 (defun %listify-rest-args (ptr count dynamic-extent)
297     (declare (ignore count dynamic-extent))
298 wlott 1.1 ptr)
299 wlott 1.25
300 wlott 1.26 (defun %more-arg-values (args start count)
301     (values-list (subseq args start count)))
302 wlott 1.1
303     (defun %argument-count-error (args-passed-count)
304 pw 1.30 (error 'simple-program-error
305 rtoy 1.38 :format-control (intl:gettext "Wrong number of arguments passed -- ~S.")
306 pw 1.30 :format-arguments (list args-passed-count)))
307 wlott 1.1
308     (defun %odd-keyword-arguments-error ()
309 pw 1.30 (error 'simple-program-error
310     :format-control
311 rtoy 1.38 (intl:gettext "Function called with odd number of keyword arguments.")))
312 wlott 1.1
313     (defun %unknown-keyword-argument-error (keyword)
314 pw 1.30 (error 'simple-program-error
315 rtoy 1.38 :format-control (intl:gettext "Unknown keyword argument -- ~S.")
316 pw 1.30 :format-arguments (list keyword)))
317 ram 1.20
318     (defun %cleanup-point ())
319 ram 1.21
320     (defun value-cell-ref (x) (value-cell-ref x))

  ViewVC Help
Powered by ViewVC 1.1.5