1 ;;;; This file contains the IR1 interpreter. We first convert to the
2 ;;;; compiler's IR1, then interpret that.
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!EVAL")
15 ;;;; interpreter stack
17 (defvar *interpreted-function-cache-minimum-size* 25
19 "If the interpreted function cache has more functions than this come GC time,
20 then attempt to prune it according to
21 *INTERPRETED-FUNCTION-CACHE-THRESHOLD*.")
23 (defvar *interpreted-function-cache-threshold* 3
25 "If an interpreted function goes uncalled for more than this many GCs, then
26 it is eligible for flushing from the cache.")
28 (declaim (type (and fixnum unsigned-byte)
29 *interpreted-function-cache-minimum-size*
30 *interpreted-function-cache-threshold*))
32 ;;; The list of INTERPRETED-FUNCTIONS that have translated definitions.
33 (defvar *interpreted-function-cache* nil)
34 (declaim (type list *interpreted-function-cache*))
36 ;;; Setting this causes the stack operations to dump a trace.
38 (defvar *eval-stack-trace* nil)
40 ;;; Push value on *EVAL-STACK*, growing the stack if necessary. This
41 ;;; returns value. We save *EVAL-STACK-TOP* in a local and increment
42 ;;; the global before storing value on the stack to prevent a GC
43 ;;; timing problem. If we stored value on the stack using
44 ;;; *EVAL-STACK-TOP* as an index, and we GC'ed before incrementing
45 ;;; *EVAL-STACK-TOP*, then INTERPRETER-GC-HOOK would clear the
47 (defun eval-stack-push (value)
48 (let ((len (length (the simple-vector *eval-stack*))))
49 (when (= len *eval-stack-top*)
50 #+!sb-show (when *eval-stack-trace*
51 (format t "[PUSH: growing stack.]~%"))
52 (let ((new-stack (make-array (ash len 1))))
53 (replace new-stack *eval-stack* :end1 len :end2 len)
54 (setf *eval-stack* new-stack))))
55 (let ((top *eval-stack-top*))
56 #+!sb-show (when *eval-stack-trace* (format t "pushing ~D.~%" top))
57 (incf *eval-stack-top*)
58 (setf (svref *eval-stack* top) value)))
60 ;;; Return the last value pushed on *EVAL-STACK* and decrement the top
61 ;;; pointer. We forego setting elements off the end of the stack to
62 ;;; nil for GC purposes because there is a *BEFORE-GC-HOOK* to take
63 ;;; care of this for us. However, because of the GC hook, we must be
64 ;;; careful to grab the value before decrementing *EVAL-STACK-TOP*
65 ;;; since we could GC between the decrement and the reference, and the
66 ;;; hook would clear the stack slot.
67 (defun eval-stack-pop ()
68 (when (zerop *eval-stack-top*)
69 (error "attempt to pop empty eval stack"))
70 (let* ((new-top (1- *eval-stack-top*))
71 (value (svref *eval-stack* new-top)))
72 #+!sb-show (when *eval-stack-trace*
73 (format t "popping ~D --> ~S.~%" new-top value))
74 (setf *eval-stack-top* new-top)
77 ;;; Allocate N locations on the stack, bumping the top pointer and
78 ;;; growing the stack if necessary. We set new slots to nil in case we
79 ;;; GC before having set them; we don't want to hold on to potential
80 ;;; garbage from old stack fluctuations.
81 (defun eval-stack-extend (n)
82 (let ((len (length (the simple-vector *eval-stack*))))
83 (when (> (+ n *eval-stack-top*) len)
84 #+!sb-show (when *eval-stack-trace*
85 (format t "[EXTEND: growing stack.]~%"))
86 (let ((new-stack (make-array (+ n (ash len 1)))))
87 (replace new-stack *eval-stack* :end1 len :end2 len)
88 (setf *eval-stack* new-stack))))
89 (let ((new-top (+ *eval-stack-top* n)))
90 #+!sb-show (when *eval-stack-trace*
91 (format t "extending to ~D.~%" new-top))
92 (do ((i *eval-stack-top* (1+ i)))
94 (setf (svref *eval-stack* i) nil))
95 (setf *eval-stack-top* new-top)))
97 ;;; the antithesis of EVAL-STACK-EXTEND
98 (defun eval-stack-shrink (n)
99 #+!sb-show (when *eval-stack-trace*
100 (format t "shrinking to ~D.~%" (- *eval-stack-top* n)))
101 (decf *eval-stack-top* n))
103 ;;; This is used to shrink the stack back to a previous frame pointer.
104 (defun eval-stack-reset-top (ptr)
105 #+!sb-show (when *eval-stack-trace*
106 (format t "setting top to ~D.~%" ptr))
107 (setf *eval-stack-top* ptr))
109 ;;; Return a local variable from the current stack frame. This is used
110 ;;; for references the compiler represents as a lambda-var leaf. It is
111 ;;; a macro as a quick and dirty way of making it SETFable.
113 ;;; FIXME: used only in this file, needn't be in runtime
114 (defmacro eval-stack-local (fp offset)
115 `(svref *eval-stack* (+ ,fp ,offset)))
117 ;;;; interpreted functions
119 ;;; the list of INTERPRETED-FUNCTIONS that have translated definitions
120 (defvar *interpreted-function-cache* nil)
121 (declaim (type list *interpreted-function-cache*))
123 ;;; Return a function that will lazily convert LAMBDA when called, and
124 ;;; will cache translations.
125 (defun make-interpreted-function (lambda)
126 (let ((res (%make-interpreted-function :lambda lambda
127 :arglist (second lambda))))
128 (setf (funcallable-instance-function res)
129 #'(instance-lambda (&rest args)
130 (let ((fun (interpreted-function-definition res))
131 (args (cons (length args) args)))
132 (setf (interpreted-function-gcs res) 0)
133 (internal-apply (or fun (convert-interpreted-fun res))
137 ;;; Eval a FUNCTION form, grab the definition and stick it in.
138 (defun convert-interpreted-fun (fun)
139 (declare (type interpreted-function fun))
140 (let* ((new (interpreted-function-definition
141 (internal-eval `#',(interpreted-function-lambda fun)))))
142 (setf (interpreted-function-definition fun) new)
143 (setf (interpreted-function-converted-once fun) t)
144 (let ((name (interpreted-function-%name fun)))
145 (setf (sb!c::leaf-name new) name)
146 (setf (sb!c::leaf-name (sb!c::main-entry
147 (sb!c::functional-entry-function new)))
149 (push fun *interpreted-function-cache*)
152 ;;; Get the CLAMBDA for the XEP, then look at the inline expansion info in
153 ;;; the real function.
154 (defun interpreted-function-lambda-expression (x)
155 (let ((lambda (interpreted-function-lambda x)))
157 (values lambda nil (interpreted-function-%name x))
158 (let ((fun (sb!c::functional-entry-function
159 (interpreted-function-definition x))))
160 (values (sb!c::functional-inline-expansion fun)
161 (if (let ((env (sb!c::functional-lexenv fun)))
162 (or (sb!c::lexenv-functions env)
163 (sb!c::lexenv-variables env)
164 (sb!c::lexenv-blocks env)
165 (sb!c::lexenv-tags env)))
167 (or (interpreted-function-%name x)
168 (sb!c::component-name
169 (sb!c::block-component
171 (sb!c::lambda-bind (sb!c::main-entry fun)))))))))))
173 ;;; Return a FUNCTION-TYPE describing an eval function. We just grab the
174 ;;; LEAF-TYPE of the definition, converting the definition if not currently
176 (defvar *already-looking-for-type-of* nil)
177 (defun interpreted-function-type (fun)
178 (if (member fun *already-looking-for-type-of*)
179 (specifier-type 'function)
180 (let* ((*already-looking-for-type-of*
181 (cons fun *already-looking-for-type-of*))
182 (def (or (interpreted-function-definition fun)
183 (sb!sys:without-gcing
184 (convert-interpreted-fun fun)
185 (interpreted-function-definition fun)))))
186 (sb!c::leaf-type (sb!c::functional-entry-function def)))))
188 (defun interpreted-function-name (x)
189 (multiple-value-bind (ig1 ig2 res) (interpreted-function-lambda-expression x)
190 (declare (ignore ig1 ig2))
192 (defun (setf interpreted-function-name) (val x)
193 (let ((def (interpreted-function-definition x)))
195 (setf (sb!c::leaf-name def) val)
196 (setf (sb!c::leaf-name (sb!c::main-entry (sb!c::functional-entry-function
199 (setf (interpreted-function-%name x) val)))
201 (defun interpreter-gc-hook ()
202 ;; Clear the unused portion of the eval stack.
203 (let ((len (length (the simple-vector *eval-stack*))))
204 (do ((i *eval-stack-top* (1+ i)))
206 (setf (svref *eval-stack* i) nil)))
208 ;; KLUDGE: I'd like to get rid of this, since it adds complexity and causes
209 ;; confusion. (It's not just academic that it causes confusion. When working
210 ;; on the original cross-compiler, I ran across what looked
211 ;; as though it might be a subtle writing-to-the-host-SBCL-compiler-data bug
212 ;; in my cross-compiler code, which turned out to be just a case of compiler
213 ;; warnings coming from recompilation of a flushed-from-the-cache interpreted
214 ;; function. Since it took me a long while to realize how many things the
215 ;; problem depended on (since it was tied up with magic numbers of GC cycles,
216 ;; egads!) I blew over a day trying to isolate the problem in a small test
219 ;; The cache-flushing seems to be motivated by efficiency concerns, which
220 ;; seem misplaced when the user chooses to use the interpreter. However, it
221 ;; also interacts with SAVE, and I veered off from deleting it wholesale when
222 ;; I noticed that. After the whole system is working, though, I'd like to
223 ;; revisit this decision. -- WHN 19990713
224 (let ((num (- (length *interpreted-function-cache*)
225 *interpreted-function-cache-minimum-size*)))
227 (setq *interpreted-function-cache*
228 (delete-if #'(lambda (x)
229 (when (>= (interpreted-function-gcs x)
230 *interpreted-function-cache-threshold*)
231 (setf (interpreted-function-definition x) nil)
233 *interpreted-function-cache*
235 (dolist (fun *interpreted-function-cache*)
236 (incf (interpreted-function-gcs fun))))
237 (pushnew 'interpreter-gc-hook sb!ext:*before-gc-hooks*)
239 ;;; Clear all entries in the eval function cache. This allows the internal
240 ;;; representation of the functions to be reclaimed, and also lazily forces
241 ;;; macroexpansions to be recomputed.
242 (defun flush-interpreted-function-cache ()
243 (dolist (fun *interpreted-function-cache*)
244 (setf (interpreted-function-definition fun) nil))
245 (setq *interpreted-function-cache* ()))
247 ;;;; INTERNAL-APPLY-LOOP macros
249 ;;;; These macros are intimately related to INTERNAL-APPLY-LOOP. They assume
250 ;;;; variables established by this function, and they assume they can return
251 ;;;; from a block by that name. This is sleazy, but we justify it as follows:
252 ;;;; They are so specialized in use, and their invocation became lengthy, that
253 ;;;; we allowed them to slime some access to things in their expanding
254 ;;;; environment. These macros don't really extend our Lisp syntax, but they do
255 ;;;; provide some template expansion service; it is these cleaner circumstance
256 ;;;; that require a more rigid programming style.
258 ;;;; Since these are macros expanded almost solely for COMBINATION nodes,
259 ;;;; they cascade from the end of this logical page to the beginning here.
260 ;;;; Therefore, it is best you start looking at them from the end of this
261 ;;;; section, backwards from normal scanning mode for Lisp code.
263 ;;; This runs a function on some arguments from the stack. If the combination
264 ;;; occurs in a tail recursive position, then we do the call such that we
265 ;;; return from tail-p-function with whatever values the call produces. With a
266 ;;; :local call, we have to restore the stack to its previous frame before
267 ;;; doing the call. The :full call mechanism does this for us. If it is NOT a
268 ;;; tail recursive call, and we're in a multiple value context, then then push
269 ;;; a list of the returned values. Do the same thing if we're in a :return
270 ;;; context. Push a single value, without listifying it, for a :single value
271 ;;; context. Otherwise, just call for side effect.
273 ;;; Node is the combination node, and cont is its continuation. Frame-ptr
274 ;;; is the current frame pointer, and closure is the current environment for
275 ;;; closure variables. Call-type is either :full or :local, and when it is
276 ;;; local, lambda is the IR1 lambda to apply.
278 ;;; This assumes the following variables are present: node, cont, frame-ptr,
279 ;;; and closure. It also assumes a block named internal-apply-loop.
281 ;;; FIXME: used only in this file, needn't be in runtime
282 ;;; FIXME: down with DO-FOO names for non-iteration constructs!
283 (defmacro do-combination (call-type lambda mv-or-normal)
284 (let* ((args (gensym))
285 (calling-closure (gensym))
286 (invoke-fun (ecase mv-or-normal
287 (:mv-call 'mv-internal-invoke)
288 (:normal 'internal-invoke)))
289 (args-form (ecase mv-or-normal
292 (length (sb!c::mv-combination-args node))))
294 `(eval-stack-args (sb!c:lambda-eval-info-args-passed
295 (sb!c::lambda-info ,lambda))))))
296 (call-form (ecase call-type
298 (length (sb!c::basic-combination-args node))))
299 (:local `(internal-apply
301 (compute-closure node ,lambda frame-ptr
308 ;; INVOKE-FUN takes care of the stack itself.
309 (,invoke-fun (length (sb!c::basic-combination-args node))
311 (:local `(let ((,args ,args-form)
313 (compute-closure node ,lambda frame-ptr closure)))
314 ;; No need to clean up stack slots for GC due to
315 ;; SB!EXT:*BEFORE-GC-HOOK*.
316 (eval-stack-reset-top frame-ptr)
319 (internal-apply ,lambda ,args ,calling-closure
321 `(cond ((sb!c::node-tail-p node)
324 (ecase (sb!c::continuation-info cont)
326 (eval-stack-push (multiple-value-list ,call-form)))
328 (eval-stack-push ,call-form))
329 (:unused ,call-form))))))
331 ;;; This sets the variable block in INTERNAL-APPLY-LOOP, and it announces this
332 ;;; by setting set-block-p for later loop iteration maintenance.
334 ;;; FIXME: used only in this file, needn't be in runtime
335 (defmacro set-block (exp)
338 (setf set-block-p t)))
340 ;;; This sets all the iteration variables in INTERNAL-APPLY-LOOP to iterate
341 ;;; over a new block's nodes. Block-exp is optional because sometimes we have
342 ;;; already set block, and we only need to bring the others into agreement.
343 ;;; If we already set block, then clear the variable that announces this,
346 ;;; FIXME: used only in this file, needn't be in runtime
347 (defmacro change-blocks (&optional block-exp)
350 `(setf block ,block-exp)
351 `(setf set-block-p nil))
352 (setf node (sb!c::continuation-next (sb!c::block-start block)))
353 (setf last-cont (sb!c::node-cont (sb!c::block-last block)))))
355 ;;; This controls printing visited nodes in INTERNAL-APPLY-LOOP. We use it
356 ;;; here, and INTERNAL-INVOKE uses it to print function call looking output
357 ;;; to further describe sb!c::combination nodes.
358 #!+sb-show (defvar *internal-apply-node-trace* nil)
360 (defun maybe-trace-funny-fun (node name &rest args)
361 (when *internal-apply-node-trace*
362 (format t "(~S ~{ ~S~}) c~S~%"
363 name args (sb!c::cont-num (sb!c::node-cont node)))))
365 ;;; This implements the intention of the virtual function name. This is a
366 ;;; macro because some of these actions must occur without a function call.
367 ;;; For example, calling a dispatch function to implement special binding would
368 ;;; be a no-op because returning from that function would cause the system to
369 ;;; undo any special bindings it established.
371 ;;; NOTE: update SB!C:ANNOTATE-COMPONENT-FOR-EVAL and/or
372 ;;; sb!c::undefined-funny-funs if you add or remove branches in this routine.
374 ;;; This assumes the following variables are present: node, cont, frame-ptr,
375 ;;; args, closure, block, and last-cont. It also assumes a block named
376 ;;; internal-apply-loop.
378 ;;; FIXME: used only in this file, needn't be in runtime
379 ;;; FIXME: down with DO-FOO names for non-iteration constructs!
380 (defmacro do-funny-function (funny-fun-name)
381 (let ((name (gensym)))
382 `(let ((,name ,funny-fun-name))
385 (let ((value (eval-stack-pop))
386 (global-var (eval-stack-pop)))
387 #!+sb-show (maybe-trace-funny-fun node ,name global-var value)
388 (sb!sys:%primitive sb!c:bind
390 (sb!c::global-var-name global-var))))
391 (sb!c::%special-unbind
392 ;; Throw away arg telling me which special, and tell the dynamic
393 ;; binding mechanism to unbind one variable.
395 #!+sb-show (maybe-trace-funny-fun node ,name)
396 (sb!sys:%primitive sb!c:unbind))
398 (let* ((tag (eval-stack-pop))
399 (nlx-info (eval-stack-pop))
401 ;; Ultimately THROW and CATCH will fix the interpreter's stack
402 ;; since this is necessary for compiled CATCH's and those in
403 ;; the initial top level function.
404 (stack-top *eval-stack-top*)
408 #!+sb-show (maybe-trace-funny-fun node ,name tag)
409 (multiple-value-setq (block node cont last-cont)
410 (internal-apply-loop (sb!c::continuation-next cont)
411 frame-ptr lambda args closure))
412 (setf fell-through-p t)))))
413 (cond (fell-through-p
414 ;; We got here because we just saw the SB!C::%CATCH-BREAKUP
415 ;; funny function inside the above recursive call to
416 ;; INTERNAL-APPLY-LOOP. Therefore, we just received and
417 ;; stored the current state of evaluation for falling
421 ;; Fix up the interpreter's stack after having thrown here.
422 ;; We won't need to do this in the final implementation.
423 (eval-stack-reset-top stack-top)
424 ;; Take the values received in the list bound above, and
425 ;; massage them into the form expected by the continuation
426 ;; of the non-local-exit info.
427 (ecase (sb!c::continuation-info
428 (sb!c::nlx-info-continuation nlx-info))
430 (eval-stack-push (car values)))
432 (eval-stack-push values))
434 ;; We want to continue with the code after the CATCH body.
435 ;; The non-local-exit info tells us where this is, but we
436 ;; know that block only contains a call to the funny
437 ;; function SB!C::%NLX-ENTRY, which simply is a place holder
438 ;; for the compiler IR1. We want to skip the target block
439 ;; entirely, so we say it is the block we're in now and say
440 ;; the current cont is the last-cont. This makes the COND
441 ;; at the end of INTERNAL-APPLY-LOOP do the right thing.
442 (setf block (sb!c::nlx-info-target nlx-info))
443 (setf cont last-cont)))))
444 (sb!c::%unwind-protect
445 ;; Cleanup function not pushed due to special-case :UNUSED
446 ;; annotation in ANNOTATE-COMPONENT-FOR-EVAL.
447 (let* ((nlx-info (eval-stack-pop))
449 (stack-top *eval-stack-top*))
452 #!+sb-show (maybe-trace-funny-fun node ,name)
453 (multiple-value-setq (block node cont last-cont)
454 (internal-apply-loop (sb!c::continuation-next cont)
455 frame-ptr lambda args closure))
456 (setf fell-through-p t))
457 (cond (fell-through-p
458 ;; We got here because we just saw the
459 ;; SB!C::%UNWIND-PROTECT-BREAKUP funny function inside the
460 ;; above recursive call to INTERNAL-APPLY-LOOP.
461 ;; Therefore, we just received and stored the current
462 ;; state of evaluation for falling through.
465 ;; Fix up the interpreter's stack after having thrown
466 ;; here. We won't need to do this in the final
468 (eval-stack-reset-top stack-top)
469 ;; Push some bogus values for exit context to keep the
470 ;; MV-BIND in the UNWIND-PROTECT translation happy.
471 (eval-stack-push '(nil nil 0))
472 (let ((node (sb!c::continuation-next
474 (car (sb!c::block-succ
475 (sb!c::nlx-info-target nlx-info)))))))
476 (internal-apply-loop node frame-ptr lambda args
478 ((sb!c::%catch-breakup
479 sb!c::%unwind-protect-breakup
480 sb!c::%continue-unwind)
481 ;; This shows up when we locally exit a CATCH body -- fell through.
482 ;; Return the current state of evaluation to the previous invocation
483 ;; of INTERNAL-APPLY-LOOP which happens to be running in the
484 ;; SB!C::%CATCH branch of this code.
485 #!+sb-show (maybe-trace-funny-fun node ,name)
486 (return-from internal-apply-loop
487 (values block node cont last-cont)))
489 #!+sb-show (maybe-trace-funny-fun node ,name)
490 ;; This just marks a spot in the code for CATCH, UNWIND-PROTECT, and
491 ;; non-local lexical exits (GO or RETURN-FROM).
492 ;; Do nothing since sb!c::%catch does it all when it catches a THROW.
493 ;; Do nothing since sb!c::%unwind-protect does it all when
494 ;; it catches a THROW.
496 (sb!c::%more-arg-context
497 (let* ((fixed-arg-count (1+ (eval-stack-pop)))
498 ;; Add 1 to actual fixed count for extra arg expected by
499 ;; external entry points (XEP) which some IR1 lambdas have.
500 ;; The extra arg is the number of arguments for arg count
501 ;; consistency checking. SB!C::%MORE-ARG-CONTEXT always runs
502 ;; within an XEP, so the lambda has an extra arg.
503 (more-args (nthcdr fixed-arg-count args)))
504 #!+sb-show (maybe-trace-funny-fun node ,name fixed-arg-count)
505 (aver (eq (sb!c::continuation-info cont) :multiple))
506 (eval-stack-push (list more-args (length more-args)))))
507 (sb!c::%unknown-values
508 (error "SB!C::%UNKNOWN-VALUES should never be in interpreter's IR1."))
509 (sb!c::%lexical-exit-breakup
510 ;; We see this whenever we locally exit the extent of a lexical
511 ;; target. That is, we are truly locally exiting an extent we could
512 ;; have non-locally lexically exited. Return the :fell-through flag
513 ;; and the current state of evaluation to the previous invocation
514 ;; of INTERNAL-APPLY-LOOP which happens to be running in the
515 ;; SB!C::ENTRY branch of INTERNAL-APPLY-LOOP.
516 #!+sb-show (maybe-trace-funny-fun node ,name)
517 ;; Discard the NLX-INFO arg...
519 (return-from internal-apply-loop
520 (values :fell-through block node cont last-cont)))))))
522 ;;; This expands for the two types of combination nodes INTERNAL-APPLY-LOOP
523 ;;; sees. Type is either :mv-call or :normal. Node is the combination node,
524 ;;; and cont is its continuation. Frame-ptr is the current frame pointer, and
525 ;;; closure is the current environment for closure variables.
527 ;;; Most of the real work is done by DO-COMBINATION. This first determines if
528 ;;; the combination node describes a :full call which DO-COMBINATION directly
529 ;;; handles. If the call is :local, then we either invoke an IR1 lambda, or we
530 ;;; just bind some LET variables. If the call is :local, and type is :mv-call,
531 ;;; then we can only be binding multiple values. Otherwise, the combination
532 ;;; node describes a function known to the compiler, but this may be a funny
533 ;;; function that actually isn't ever defined. We either take some action for
534 ;;; the funny function or do a :full call on the known true function, but the
535 ;;; interpreter doesn't do optimizing stuff for functions known to the
538 ;;; This assumes the following variables are present: node, cont, frame-ptr,
539 ;;; and closure. It also assumes a block named internal-apply-loop.
541 ;;; FIXME: used only in this file, needn't be in runtime
542 (defmacro combination-node (type)
543 (let* ((kind (gensym))
547 (letp-bind (ecase type
550 `((,letp (eq (sb!c::functional-kind ,lambda) :let))))))
554 `(store-mv-let-vars ,lambda frame-ptr
555 (length (sb!c::mv-combination-args node))))
558 (store-let-vars ,lambda frame-ptr)
559 (do-combination :local ,lambda ,type))))))
560 `(let ((,kind (sb!c::basic-combination-kind node))
561 (,fun (sb!c::basic-combination-fun node)))
562 (cond ((member ,kind '(:full :error))
563 (do-combination :full nil ,type))
565 (let* ((,lambda (sb!c::ref-leaf (sb!c::continuation-use ,fun)))
568 ((eq (sb!c::continuation-info ,fun) :unused)
569 (aver (typep ,kind 'sb!c::function-info))
570 (do-funny-function (sb!c::continuation-function-name ,fun)))
572 (aver (typep ,kind 'sb!c::function-info))
573 (do-combination :full nil ,type))))))
577 ;;; Evaluate an arbitary form. We convert the form, then call internal
578 ;;; APPLY on it. If *ALREADY-EVALED-THIS* is true, then we bind it to
579 ;;; NIL around the apply to limit the inhibition to the lexical scope
580 ;;; of the EVAL-WHEN.
581 (defun internal-eval (form)
582 (let ((res (sb!c:compile-for-eval form)))
583 (if *already-evaled-this*
584 (let ((*already-evaled-this* nil))
585 (internal-apply res nil '#()))
586 (internal-apply res nil '#()))))
588 ;;; This passes on a node's value appropriately, possibly returning from
589 ;;; function to do so. When we are tail-p, don't push the value, return it on
590 ;;; the system's actual call stack; when we blow out of function this way, we
591 ;;; must return the interpreter's stack to the its state before this call to
592 ;;; function. When we're in a multiple value context or heading for a return
593 ;;; node, we push a list of the value for easier handling later. Otherwise,
594 ;;; just push the value on the interpreter's stack.
596 ;;; FIXME: maybe used only in this file, if so, needn't be in runtime
597 (defmacro value (node info value frame-ptr function)
598 `(cond ((sb!c::node-tail-p ,node)
599 (eval-stack-reset-top ,frame-ptr)
600 (return-from ,function ,value))
601 ((member ,info '(:multiple :return) :test #'eq)
602 (eval-stack-push (list ,value)))
603 (t (aver (eq ,info :single))
604 (eval-stack-push ,value))))
607 (defun maybe-trace-nodes (node)
608 (when *internal-apply-node-trace*
609 (format t "<~A-node> c~S~%"
611 (sb!c::cont-num (sb!c::node-cont node)))))
613 ;;; Interpret LAMBDA, a compiler IR1 data structure representing a
614 ;;; function, applying it to ARGS. CLOSURE is the environment in which
615 ;;; to run LAMBDA, the variables and such closed over to form LAMBDA.
616 ;;; The call occurs on the interpreter's stack, so save the current
617 ;;; top and extend the stack for this lambda's call frame. Then store
618 ;;; the args into locals on the stack.
620 ;;; ARGS is the list of arguments to apply to. If IGNORE-UNUSED is
621 ;;; true, then values for un-read variables are present in the
622 ;;; argument list, and must be discarded (always true except in a
623 ;;; local call.) ARGS may run out of values before VARS runs out of
624 ;;; variables (in the case of an XEP with optionals); we just do CAR
625 ;;; of NIL and store NIL. This is not the proper defaulting (which is
626 ;;; done by explicit code in the XEP.)
627 (defun internal-apply (lambda args closure &optional (ignore-unused t))
628 (let ((frame-ptr *eval-stack-top*))
629 (eval-stack-extend (sb!c:lambda-eval-info-frame-size (sb!c::lambda-info lambda)))
630 (do ((vars (sb!c::lambda-vars lambda) (cdr vars))
633 (let ((var (car vars)))
634 (cond ((sb!c::leaf-refs var)
635 (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var))
636 (if (sb!c::lambda-var-indirect var)
637 (sb!c::make-value-cell (pop args))
639 (ignore-unused (pop args)))))
640 (internal-apply-loop (sb!c::lambda-bind lambda) frame-ptr lambda args
643 ;;; This does the work of INTERNAL-APPLY. This also calls itself
644 ;;; recursively for certain language features, such as CATCH. First is
645 ;;; the node at which to start interpreting. FRAME-PTR is the current
646 ;;; frame pointer for accessing local variables. LAMBDA is the IR1
647 ;;; lambda from which comes the nodes a given call to this function
648 ;;; processes, and CLOSURE is the environment for interpreting LAMBDA.
649 ;;; ARGS is the argument list for the lambda given to INTERNAL-APPLY,
650 ;;; and we have to carry it around with us in case of &more-arg or
651 ;;; &rest-arg processing which is represented explicitly in the
654 ;;; KLUDGE: Due to having a truly tail recursive interpreter, some of
655 ;;; the branches handling a given node need to RETURN-FROM this
656 ;;; routine. Also, some calls this makes to do work for it must occur
657 ;;; in tail recursive positions. Because of this required access to
658 ;;; this function lexical environment and calling positions, we often
659 ;;; are unable to break off logical chunks of code into functions. We
660 ;;; have written macros intended solely for use in this routine, and
661 ;;; due to all the local stuff they need to access and length complex
662 ;;; calls, we have written them to sleazily access locals from this
663 ;;; routine. In addition to assuming a block named internal-apply-loop
664 ;;; exists, they set and reference the following variables: NODE,
665 ;;; CONT, FRAME-PTR, CLOSURE, BLOCK, LAST-CONT, and SET-BLOCK-P.
666 ;;; FIXME: Perhaps this kludge could go away if we convert to a
667 ;;; compiler-only implementation?
668 (defun internal-apply-loop (first frame-ptr lambda args closure)
669 ;; FIXME: This will cause source code location information to be compiled
670 ;; into the executable, which will probably cause problems for users running
671 ;; without the sources and/or without the build-the-system readtable.
672 (declare (optimize (debug 2)))
673 (let* ((block (sb!c::node-block first))
674 (last-cont (sb!c::node-cont (sb!c::block-last block)))
678 (let ((cont (sb!c::node-cont node)))
681 #!+sb-show (maybe-trace-nodes node)
682 (let ((info (sb!c::continuation-info cont)))
683 (unless (eq info :unused)
684 (value node info (leaf-value node frame-ptr closure)
685 frame-ptr internal-apply-loop))))
687 #!+sb-show (maybe-trace-nodes node)
688 (combination-node :normal))
690 #!+sb-show (maybe-trace-nodes node)
691 ;; IF nodes always occur at the end of a block, so pick another.
692 (set-block (if (eval-stack-pop)
693 (sb!c::if-consequent node)
694 (sb!c::if-alternative node))))
696 #!+sb-show (maybe-trace-nodes node)
697 ;; Ignore bind nodes since INTERNAL-APPLY extends the
698 ;; stack for all of a lambda's locals, and the
699 ;; SB!C::COMBINATION branch handles LET binds (moving
700 ;; values off stack top into locals).
703 #!+sb-show (maybe-trace-nodes node)
704 (let ((info (sb!c::continuation-info cont))
705 (res (set-leaf-value node frame-ptr closure
707 (unless (eq info :unused)
708 (value node info res frame-ptr internal-apply-loop))))
710 #!+sb-show (maybe-trace-nodes node)
711 (let ((info (cdr (assoc node (sb!c:lambda-eval-info-entries
712 (sb!c::lambda-info lambda))))))
713 ;; No info means no-op entry for CATCH or UNWIND-PROTECT.
715 ;; Store stack top for restoration in local exit
716 ;; situation in SB!C::EXIT branch.
717 (setf (eval-stack-local frame-ptr
718 (sb!c:entry-node-info-st-top info))
720 (let ((tag (sb!c:entry-node-info-nlx-tag info)))
722 ;; Non-local lexical exit (someone closed over a
723 ;; GO tag or BLOCK name).
724 (let ((unique-tag (cons nil nil))
726 (setf (eval-stack-local frame-ptr tag) unique-tag)
727 (if (eq cont last-cont)
728 (change-blocks (car (sb!c::block-succ block)))
729 (setf node (sb!c::continuation-next cont)))
731 (multiple-value-setq (values block node cont last-cont)
733 (internal-apply-loop node frame-ptr
734 lambda args closure)))
736 (when (eq values :fell-through)
737 ;; We hit a %LEXICAL-EXIT-BREAKUP.
738 ;; Interpreting state is set with MV-SETQ above.
739 ;; Just get out of this branch and go on.
742 (unless (eq values :non-local-go)
743 ;; We know we're non-locally exiting from a
744 ;; BLOCK with values (saw a RETURN-FROM).
745 (ecase (sb!c::continuation-info cont)
747 (eval-stack-push (car values)))
749 (eval-stack-push values))
751 ;; Start interpreting again at the target, skipping
752 ;; the %NLX-ENTRY block.
754 (sb!c::continuation-next
756 (car (sb!c::block-succ block))))))))))))
758 #!+sb-show (maybe-trace-nodes node)
759 (let* ((incoming-values (sb!c::exit-value node))
760 (values (if incoming-values (eval-stack-pop))))
762 ((eq (sb!c::lambda-environment lambda)
763 (sb!c::block-environment
764 (sb!c::node-block (sb!c::exit-entry node))))
766 ;; Fixup stack top and massage values for destination.
767 (eval-stack-reset-top
768 (eval-stack-local frame-ptr
769 (sb!c:entry-node-info-st-top
770 (cdr (assoc (sb!c::exit-entry node)
771 (sb!c:lambda-eval-info-entries
772 (sb!c::lambda-info lambda)))))))
773 (ecase (sb!c::continuation-info cont)
775 (aver incoming-values)
776 (eval-stack-push (car values)))
778 (aver incoming-values)
779 (eval-stack-push values))
782 (let ((info (sb!c::find-nlx-info (sb!c::exit-entry node)
787 (sb!c::environment-closure
788 (sb!c::node-environment node))
791 (values values (sb!c::nlx-info-target info) nil cont)
792 (values :non-local-go (sb!c::nlx-info-target info)))))))))
794 #!+sb-show (maybe-trace-nodes node)
795 (let ((values (eval-stack-pop)))
796 (eval-stack-reset-top frame-ptr)
797 (return-from internal-apply-loop (values-list values))))
798 (sb!c::mv-combination
799 #!+sb-show (maybe-trace-nodes node)
800 (combination-node :mv-call)))
801 ;; See function doc below.
802 (reference-this-var-to-keep-it-alive node)
803 (reference-this-var-to-keep-it-alive frame-ptr)
804 (reference-this-var-to-keep-it-alive closure)
805 (cond ((not (eq cont last-cont))
806 (setf node (sb!c::continuation-next cont)))
807 ;; Currently only the last node in a block causes this loop to
808 ;; change blocks, so we never just go to the next node when
809 ;; the current node's branch tried to change blocks.
813 ;; CIF nodes set the block for us, but other last
815 (change-blocks (car (sb!c::block-succ block)))))))))
817 ;;; This function allows a reference to a variable that the compiler cannot
818 ;;; easily eliminate as unnecessary. We use this at the end of the node
819 ;;; dispatch in INTERNAL-APPLY-LOOP to make sure the node variable has a
820 ;;; valid value. Each node branch tends to reference it at the beginning,
821 ;;; and then there is no reference but a set at the end; the compiler then
822 ;;; kills the variable between the reference in the dispatch branch and when
823 ;;; we set it at the end. The problem is that most error will occur in the
824 ;;; interpreter within one of these node dispatch branches.
825 (defun reference-this-var-to-keep-it-alive (node)
828 ;;; This sets a SB!C::CSET node's var to value, returning value. When
829 ;;; var is local, we have to compare its home environment to the
830 ;;; current one, node's environment. If they're the same, we check to
831 ;;; see whether the var is indirect, and store the value on the stack
832 ;;; or in the value cell as appropriate. Otherwise, var is a closure
833 ;;; variable, and since we're setting it, we know its location
834 ;;; contains an indirect value object.
835 (defun set-leaf-value (node frame-ptr closure value)
836 (let ((var (sb!c::set-var node)))
839 (set-leaf-value-lambda-var node var frame-ptr closure value))
841 (setf (symbol-value (sb!c::global-var-name var)) value)))))
843 ;;; This does SET-LEAF-VALUE for a LAMBDA-VAR leaf. The debugger tools'
844 ;;; internals use this also to set interpreted local variables.
845 (defun set-leaf-value-lambda-var (node var frame-ptr closure value)
846 ;; Note: We avoid trying to set a lexical variable with no refs
847 ;; because the compiler deletes such variables.
848 (when (sb!c::leaf-refs var)
849 (let ((env (sb!c::node-environment node)))
850 (cond ((not (eq (sb!c::lambda-environment (sb!c::lambda-var-home var))
852 (sb!c::value-cell-set
854 (position var (sb!c::environment-closure env)
857 ((sb!c::lambda-var-indirect var)
858 (sb!c::value-cell-set
859 (eval-stack-local frame-ptr (sb!c::lambda-var-info var))
862 (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var))
865 ;;; This figures out how to return a value for a ref node. LEAF is the
866 ;;; ref's structure that tells us about the value, and it is one of
867 ;;; the following types:
868 ;;; constant -- It knows its own value.
869 ;;; global-var -- It's either a value or function reference. Get it right.
870 ;;; local-var -- This may on the stack or in the current closure, the
871 ;;; environment for the lambda INTERNAL-APPLY is currently
872 ;;; executing. If the leaf's home environment is the same
873 ;;; as the node's home environment, then the value is on the
874 ;;; stack, else it's in the closure since it came from another
875 ;;; environment. Whether the var comes from the stack or the
876 ;;; closure, it could have come from a closure, and it could
877 ;;; have been closed over for setting. When this happens, the
878 ;;; actual value is stored in an indirection object, so
879 ;;; indirect. See COMPUTE-CLOSURE for the description of
880 ;;; the structure of the closure argument to this function.
881 ;;; functional -- This is a reference to an interpreted function that may
882 ;;; be passed or called anywhere. We return a real function
883 ;;; that calls INTERNAL-APPLY, closing over the leaf. We also
884 ;;; have to compute a closure, running environment, for the
885 ;;; lambda in case it references stuff in the current
886 ;;; environment. If the closure is empty and there is no
887 ;;; functional environment, then we use
888 ;;; MAKE-INTERPRETED-FUNCTION to make a cached translation.
889 ;;; Since it is too late to lazily convert, we set up the
890 ;;; INTERPRETED-FUNCTION to be already converted.
891 (defun leaf-value (node frame-ptr closure)
892 (let ((leaf (sb!c::ref-leaf node)))
895 (sb!c::constant-value leaf))
897 (locally (declare (optimize (safety 1)))
898 (if (eq (sb!c::global-var-kind leaf) :global-function)
899 (let ((name (sb!c::global-var-name leaf)))
901 (symbol-function name)
903 (symbol-value (sb!c::global-var-name leaf)))))
905 (leaf-value-lambda-var node leaf frame-ptr closure))
907 (let* ((calling-closure (compute-closure node leaf frame-ptr closure))
908 (real-fun (sb!c::functional-entry-function leaf))
909 (arg-doc (sb!c::functional-arg-documentation real-fun)))
910 (cond ((sb!c:lambda-eval-info-function (sb!c::leaf-info leaf)))
911 ((and (zerop (length calling-closure))
912 (null (sb!c::lexenv-functions
913 (sb!c::functional-lexenv real-fun))))
914 (let ((res (make-interpreted-function
915 (sb!c::functional-inline-expansion real-fun))))
916 (push res *interpreted-function-cache*)
917 (setf (interpreted-function-definition res) leaf)
918 (setf (interpreted-function-converted-once res) t)
919 (setf (interpreted-function-arglist res) arg-doc)
920 (setf (interpreted-function-%name res)
921 (sb!c::leaf-name real-fun))
922 (setf (sb!c:lambda-eval-info-function
923 (sb!c::leaf-info leaf)) res)
926 (let ((res (%make-interpreted-function
928 :%name (sb!c::leaf-name real-fun)
930 :closure calling-closure)))
931 (setf (funcallable-instance-function res)
932 #'(instance-lambda (&rest args)
933 (declare (list args))
935 (interpreted-function-definition res)
936 (cons (length args) args)
937 (interpreted-function-closure res))))
940 ;;; This does LEAF-VALUE for a lambda-var leaf. The debugger tools' internals
941 ;;; uses this also to reference interpreted local variables.
942 (defun leaf-value-lambda-var (node leaf frame-ptr closure)
943 (let* ((env (sb!c::node-environment node))
945 (if (eq (sb!c::lambda-environment (sb!c::lambda-var-home leaf))
947 (eval-stack-local frame-ptr (sb!c::lambda-var-info leaf))
949 (position leaf (sb!c::environment-closure env)
951 (if (sb!c::lambda-var-indirect leaf)
952 (sb!c::value-cell-ref temp)
955 ;;; Compute a closure for a local call and for returned call'able
956 ;;; closure objects. Sometimes the closure is a SIMPLE-VECTOR of no
957 ;;; elements. NODE is either a reference node or a combination node.
958 ;;; LEAF is either the leaf of the reference node or the lambda to
959 ;;; internally apply for the combination node. FRAME-PTR is the
960 ;;; current frame pointer for fetching current values to store in the
961 ;;; closure. CLOSURE is the current closure, the closed-over
962 ;;; environment of the currently interpreting LAMBDA.
964 ;;; A computed closure is a vector corresponding to the list of
965 ;;; closure variables described in an environment. The position of a
966 ;;; lambda-var in this closure list is the index into the closure
967 ;;; vector of values.
968 (defun compute-closure (node leaf frame-ptr closure)
969 (let* ((current-env (sb!c::node-environment node))
970 (current-closure-vars (sb!c::environment-closure current-env))
971 ;; FUNCTIONAL-ENV is the environment description for leaf,
972 ;; the lambda for which we're computing a closure. This
973 ;; environment describes which of lambda's vars we find in
974 ;; lambda's closure when it's running, versus finding them on
976 (functional-env (sb!c::lambda-environment leaf))
977 (functional-closure-vars (sb!c::environment-closure functional-env))
978 (functional-closure (make-array (length functional-closure-vars))))
979 ;; For each lambda-var VAR in the functional environment's closure
980 ;; list, if the VAR's home environment is the current environment,
981 ;; then get a value off the stack and store it in the closure
982 ;; we're computing. Otherwise VAR's value comes from somewhere
983 ;; else, but we have it in our current closure, the environment
984 ;; we're running in as we compute this new closure. Find this
985 ;; value the same way we do in LEAF-VALUE, by finding VAR's
986 ;; position in the current environment's description of the
988 (do ((vars functional-closure-vars (cdr vars))
991 (let ((ele (car vars)))
992 (setf (svref functional-closure i)
995 (if (eq (sb!c::lambda-environment (sb!c::lambda-var-home ele))
997 (eval-stack-local frame-ptr (sb!c::lambda-var-info ele))
999 (position ele current-closure-vars
1002 (if (eq (sb!c::block-environment (sb!c::nlx-info-target ele))
1006 (sb!c:entry-node-info-nlx-tag
1007 (cdr (assoc ;; entry node for non-local extent
1008 (sb!c::cleanup-mess-up
1009 (sb!c::nlx-info-cleanup ele))
1010 (sb!c::lambda-eval-info-entries
1012 ;; the lambda INTERNAL-APPLY-LOOP tosses around
1013 (sb!c::environment-function
1014 (sb!c::node-environment node))))))))
1016 (position ele current-closure-vars
1018 functional-closure))
1020 ;;; INTERNAL-APPLY uses this to invoke a function from the
1021 ;;; interpreter's stack on some arguments also taken from the stack.
1022 ;;; When tail-p is non-nil, control does not return to INTERNAL-APPLY
1023 ;;; to further interpret the current IR1 lambda, so INTERNAL-INVOKE
1024 ;;; must clean up the current interpreter's stack frame.
1025 (defun internal-invoke (arg-count &optional tailp)
1026 (let ((args (eval-stack-args arg-count)) ;LET says this init form runs first.
1027 (fun (eval-stack-pop)))
1028 (when tailp (eval-stack-reset-top tailp))
1029 #!+sb-show (when *internal-apply-node-trace*
1030 (format t "(~S~{ ~S~})~%" fun args))
1033 ;;; This is almost just like INTERNAL-INVOKE. We call
1034 ;;; MV-EVAL-STACK-ARGS, and our function is in a list on the stack
1035 ;;; instead of simply on the stack.
1036 (defun mv-internal-invoke (arg-count &optional tailp)
1037 (let ((args (mv-eval-stack-args arg-count)) ; LET runs this init form first.
1038 (fun (car (eval-stack-pop))))
1039 (when tailp (eval-stack-reset-top tailp))
1040 #!+sb-show (when *internal-apply-node-trace*
1041 (format t "(~S~{ ~S~})~%" fun args))
1044 ;;; Return a list of the top arg-count elements on the interpreter's
1045 ;;; stack. This removes them from the stack.
1046 (defun eval-stack-args (arg-count)
1048 (dotimes (i arg-count args)
1049 (push (eval-stack-pop) args))))
1051 ;;; This assumes the top count elements on interpreter's stack are
1052 ;;; lists. This returns a single list with all the elements from these
1054 (defun mv-eval-stack-args (count)
1057 (let ((last (eval-stack-pop)))
1058 (dotimes (i (1- count))
1059 (let ((next (eval-stack-pop)))
1061 (if next (nconc next last) last))))
1064 ;;; This stores lambda's vars, stack locals, from values popped off the stack.
1065 ;;; When a var has no references, the compiler computes IR1 such that the
1066 ;;; continuation delivering the value for the unreference var appears unused.
1067 ;;; Because of this, the interpreter drops the value on the floor instead of
1068 ;;; saving it on the stack for binding, so we only pop a value when the var has
1069 ;;; some reference. INTERNAL-APPLY uses this for sb!c::combination nodes
1070 ;;; representing LET's.
1072 ;;; When storing the local, if it is indirect, then someone closes over it for
1073 ;;; setting instead of just for referencing. We then store an indirection cell
1074 ;;; with the value, and the referencing code for locals knows how to get the
1076 (defun store-let-vars (lambda frame-ptr)
1077 (let* ((vars (sb!c::lambda-vars lambda))
1078 (args (eval-stack-args (count-if #'sb!c::leaf-refs vars))))
1079 (declare (list vars args))
1081 (when (sb!c::leaf-refs v)
1082 (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v))
1083 (if (sb!c::lambda-var-indirect v)
1084 (sb!c::make-value-cell (pop args))
1087 ;;; This is similar to STORE-LET-VARS, but the values for the locals
1088 ;;; appear on the stack in a list due to forms that delivered multiple
1089 ;;; values to this lambda/let. Unlike STORE-LET-VARS, there is no
1090 ;;; control over the delivery of a value for an unreferenced var, so
1091 ;;; we drop the corresponding value on the floor when no one
1092 ;;; references it. INTERNAL-APPLY uses this for sb!c::mv-combination
1093 ;;; nodes representing LET's.
1094 (defun store-mv-let-vars (lambda frame-ptr count)
1096 (let ((args (eval-stack-pop)))
1097 (dolist (v (sb!c::lambda-vars lambda))
1098 (if (sb!c::leaf-refs v)
1099 (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v))
1100 (if (sb!c::lambda-var-indirect v)
1101 (sb!c::make-value-cell (pop args))
1106 ;;; This stores lambda's vars, stack locals, from multiple values stored on the
1107 ;;; top of the stack in a list. Since these values arrived multiply, there is
1108 ;;; no control over the delivery of each value for an unreferenced var, so
1109 ;;; unlike STORE-LET-VARS, we have values for variables never used. We drop
1110 ;;; the value corresponding to an unreferenced var on the floor.
1111 ;;; INTERNAL-APPLY uses this for sb!c::mv-combination nodes representing LET's.
1113 ;;; IR1 represents variables bound from multiple values in a list in the
1114 ;;; opposite order of the values list. We use STORE-MV-LET-VARS-AUX to recurse
1115 ;;; down the vars list until we bottom out, storing values on the way back up
1116 ;;; the recursion. You must do this instead of NREVERSE'ing the args list, so
1117 ;;; when we run out of values, we store nil's in the correct lambda-vars.
1118 (defun store-mv-let-vars (lambda frame-ptr count)
1120 (print (sb!c::lambda-vars lambda))
1121 (store-mv-let-vars-aux frame-ptr (sb!c::lambda-vars lambda) (eval-stack-pop)))
1122 (defun store-mv-let-vars-aux (frame-ptr vars args)
1124 (let ((remaining-args (store-mv-let-vars-aux frame-ptr (cdr vars) args))
1126 (when (sb!c::leaf-refs v)
1127 (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v))
1128 (if (sb!c::lambda-var-indirect v)
1129 (sb!c::make-value-cell (car remaining-args))
1130 (car remaining-args))))
1131 (cdr remaining-args))