1 ;;;; This file represents the current state of on-going development on
2 ;;;; compiler hooks for an interpreter that takes the compiler's IR1 of
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
16 ;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp?
17 (declaim (special *constants* *free-variables* *component-being-compiled*
18 *code-vector* *next-location* *result-fixups*
19 *free-functions* *source-paths* *failed-optimizations*
20 *seen-blocks* *seen-functions* *list-conflicts-table*
21 *continuation-number* *continuation-numbers*
22 *number-continuations* *tn-id* *tn-ids* *id-tns*
23 *label-ids* *label-id* *id-labels*
24 *compiler-error-count* *compiler-warning-count*
25 *compiler-style-warning-count* *compiler-note-count*
26 *compiler-error-bailout*
27 #!+sb-show *compiler-trace-output*
28 *last-source-context* *last-original-source*
29 *last-source-form* *last-format-string* *last-format-args*
30 *last-message-count* *check-consistency*
31 *all-components* *converting-for-interpreter*
32 *source-info* *block-compile* *current-path*
33 *current-component* *lexenv*))
35 ;;; Translate form into the compiler's IR1 and perform environment
36 ;;; analysis. This is sort of a combination of COMPILE-FILE,
37 ;;; SUB-COMPILE-FILE, COMPILE-TOP-LEVEL, and COMPILE-COMPONENT.
38 (defun compile-for-eval (form)
40 (let* ((*block-compile* nil)
41 (*lexenv* (make-null-lexenv))
42 (*compiler-error-bailout*
43 #'(lambda () (error "fatal error, aborting evaluation")))
45 (*last-source-context* nil)
46 (*last-original-source* nil)
47 (*last-source-form* nil)
48 (*last-format-string* nil)
49 (*last-format-args* nil)
50 (*last-message-count* 0)
51 ;; These are now bound by WITH-COMPILATION-UNIT. -- WHN 20000308
52 #+nil (*compiler-error-count* 0)
53 #+nil (*compiler-warning-count* 0)
54 #+nil (*compiler-style-warning-count* 0)
55 #+nil (*compiler-note-count* 0)
56 (*source-info* (make-lisp-source-info form))
57 (*converting-for-interpreter* t)
63 (find-source-paths form 0)
64 ;; This LET comes from COMPILE-TOP-LEVEL.
65 ;; The noted DOLIST is a splice from a call that COMPILE-TOP-LEVEL makes.
66 (sb!xc:with-compilation-unit ()
67 (let ((lambdas (list (ir1-top-level form
68 '(original-source-start 0 0)
70 (declare (list lambdas))
71 (dolist (lambda lambdas)
73 (block-component (node-block (lambda-bind lambda))))
74 (*all-components* (list component)))
75 (local-call-analyze component)))
76 (multiple-value-bind (components top-components)
77 (find-initial-dfo lambdas)
78 (let ((*all-components* (append components top-components)))
79 (when *check-consistency*
80 (check-ir1-consistency *all-components*))
81 ;; This DOLIST body comes from the beginning of
83 (dolist (component *all-components*)
84 (ir1-finalize component)
85 (let ((*component-being-compiled* component))
86 (environment-analyze component))
87 (annotate-component-for-eval component))
88 (when *check-consistency*
89 (check-ir1-consistency *all-components*))))
92 ;;;; annotating IR1 for interpretation
94 (defstruct (lambda-eval-info (:constructor make-lambda-eval-info
95 (frame-size args-passed entries))
97 frame-size ; number of stack locations needed to hold locals
98 args-passed ; number of referenced arguments passed to lambda
99 entries ; a-list mapping entry nodes to stack locations
100 (function nil)) ; a function object corresponding to this lambda
101 (def!method print-object ((obj lambda-eval-info) str)
102 (print-unreadable-object (obj str :type t)))
104 (defstruct (entry-node-info (:constructor make-entry-node-info
107 st-top ; stack top when we encounter the entry node
108 nlx-tag) ; tag to which to throw to get back entry node's context
109 (def!method print-object ((obj entry-node-info) str)
110 (print-unreadable-object (obj str :type t)))
112 ;;; Some compiler funny functions have definitions, so the interpreter
113 ;;; can call them. These require special action to coordinate the
114 ;;; interpreter, system call stack, and the environment. The
115 ;;; annotation prepass marks the references to these as :UNUSED, so
116 ;;; the interpreter doesn't try to fetch functions through these
117 ;;; undefined symbols.
118 (defconstant undefined-funny-funs
119 '(%special-bind %special-unbind %more-arg-context %unknown-values %catch
120 %unwind-protect %catch-breakup %unwind-protect-breakup
121 %lexical-exit-breakup %continue-unwind %nlx-entry))
123 ;;; Some kinds of functions are only passed as arguments to funny
124 ;;; functions, and are never actually evaluated at run time.
125 (defconstant non-closed-function-kinds '(:cleanup :escape))
127 ;;; This annotates continuations, lambda-vars, and lambdas. For each
128 ;;; continuation, we cache how its destination uses its value. This
129 ;;; only buys efficiency when the code executes more than once, but
130 ;;; the overhead of this part of the prepass for code executed only
131 ;;; once should be negligible.
133 ;;; As a special case to aid interpreting local function calls, we
134 ;;; sometimes note the continuation as :unused. This occurs when there
135 ;;; is a local call, and there is no actual function object to call;
136 ;;; we mark the continuation as :unused since there is nothing to push
137 ;;; on the interpreter's stack. Normally we would see a reference to a
138 ;;; function that we would push on the stack to later pop and apply to
139 ;;; the arguments on the stack. To determine when we have a local call
140 ;;; with no real function object, we look at the node to see whether
141 ;;; it is a reference with a destination that is a :local combination
142 ;;; whose function is the reference node's continuation.
144 ;;; After checking for virtual local calls, we check for funny
145 ;;; functions the compiler refers to for calling to note certain
146 ;;; operations. These functions are undefined, and if the interpreter
147 ;;; tried to reference the function cells of these symbols, it would
148 ;;; get an error. We mark the continuations delivering the values of
149 ;;; these references as :unused, so the reference never takes place.
151 ;;; For each lambda-var, including a LAMBDA's vars and its LET's vars,
152 ;;; we note the stack offset used to access and store that variable.
153 ;;; Then we note the lambda with the total number of variables, so we
154 ;;; know how big its stack frame is. Also in the lambda's info is the
155 ;;; number of its arguments that it actually references; the
156 ;;; interpreter never pushes or pops an unreferenced argument, so we
157 ;;; can't just use LENGTH on LAMBDA-VARS to know how many args the
160 ;;; For each entry node in a lambda, we associate in the
161 ;;; lambda-eval-info the entry node with a stack offset. Evaluation
162 ;;; code stores the frame pointer in this slot upon processing the
163 ;;; entry node to aid stack cleanup and correct frame manipulation
164 ;;; when processing exit nodes.
165 (defun annotate-component-for-eval (component)
166 (do-blocks (b component)
167 (do-nodes (node cont b)
168 (let* ((dest (continuation-dest cont))
169 (refp (typep node 'ref))
170 (leaf (if refp (ref-leaf node))))
171 (setf (continuation-info cont)
172 (cond ((and refp dest (typep dest 'basic-combination)
173 (eq (basic-combination-kind dest) :local)
174 (eq (basic-combination-fun dest) cont))
176 ((and leaf (typep leaf 'global-var)
177 (eq (global-var-kind leaf) :global-function)
178 (member (sb!c::global-var-name leaf)
182 ((and leaf (typep leaf 'clambda)
183 (member (functional-kind leaf)
184 non-closed-function-kinds))
185 (aver (not (eq (functional-kind leaf) :escape)))
189 ;; Change locations in eval.lisp that think
190 ;; :RETURN could occur.
191 ((or mv-combination creturn exit) :multiple)
194 (dolist (lambda (component-lambdas component))
195 (let ((locals-count 0)
196 (args-passed-count 0))
197 (dolist (var (lambda-vars lambda))
198 (setf (leaf-info var) locals-count)
200 (when (leaf-refs var) (incf args-passed-count)))
201 (dolist (let (lambda-lets lambda))
202 (dolist (var (lambda-vars let))
203 (setf (leaf-info var) locals-count)
204 (incf locals-count)))
206 (dolist (e (lambda-entries lambda))
207 (ecase (process-entry-node-p e)
210 (push (cons e (make-entry-node-info locals-count nil))
213 (:non-local-lexical-exit
215 (make-entry-node-info locals-count
216 (incf locals-count)))
218 (incf locals-count))))
219 (setf (lambda-info lambda)
220 (make-lambda-eval-info locals-count
224 (defun process-entry-node-p (entry)
225 (let ((entry-cleanup (entry-cleanup entry)))
226 (dolist (nlx (environment-nlx-info (node-environment entry))
228 (let ((cleanup (nlx-info-cleanup nlx)))
229 (when (eq entry-cleanup cleanup)
230 (ecase (cleanup-kind cleanup)
232 (return :non-local-lexical-exit))
233 ((:catch :unwind-protect)
234 (return :blow-it-off))))))))
236 ;;; Sometime consider annotations to exclude processing of exit nodes
237 ;;; when we want to do a tail-p thing.
239 ;;;; defining funny functions for interpreter
242 %listify-rest-args %more-arg %verify-argument-count %argument-count-error
243 %odd-key-arguments-error %unknown-key-argument-error
246 (defun %verify-argument-count (supplied-args defined-args)
247 (unless (= supplied-args defined-args)
248 (error "Wrong argument count, wanted ~D and got ~D."
249 defined-args supplied-args))
252 ;;; Use (SETF SYMBOL-FUNCTION) instead of DEFUN so that the compiler
253 ;;; doesn't try to compile the hidden %THROW MV-CALL in the throw below as
254 ;;; a local recursive call.
255 (setf (symbol-function '%throw)
256 #'(lambda (tag &rest args)
257 (throw tag (values-list args))))
259 (defun %more-arg (args index)
262 (defun %listify-rest-args (ptr count)
263 (declare (ignore count))
266 (defun %more-arg-values (args start count)
267 (values-list (subseq args start count)))
269 (defun %argument-count-error (args-passed-count)
270 (error 'simple-program-error
271 :format-control "wrong number of arguments passed: ~S"
272 :format-arguments (list args-passed-count)))
274 (defun %odd-key-arguments-error ()
275 (error 'simple-program-error
276 :format-control "function called with odd number of &KEY arguments"
277 :format-arguments nil))
279 (defun %unknown-key-argument-error (key-arg-name)
280 (error 'simple-program-error
281 :format-control "unknown &KEY argument: ~S"
282 :format-arguments (list key-arg-name)))
284 (defun %cleanup-point ())
286 (defun value-cell-ref (x) (value-cell-ref x))