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*))
38 ;;; Setting this causes the stack operations to dump a trace.
40 (defvar *eval-stack-trace* nil)
42 ;;; Push value on *EVAL-STACK*, growing the stack if necessary. This
43 ;;; returns value. We save *EVAL-STACK-TOP* in a local and increment
44 ;;; the global before storing value on the stack to prevent a GC
45 ;;; timing problem. If we stored value on the stack using
46 ;;; *EVAL-STACK-TOP* as an index, and we GC'ed before incrementing
47 ;;; *EVAL-STACK-TOP*, then INTERPRETER-GC-HOOK would clear the
49 (defun eval-stack-push (value)
50 (let ((len (length (the simple-vector *eval-stack*))))
51 (when (= len *eval-stack-top*)
52 #!+sb-show (when *eval-stack-trace*
53 (format t "[PUSH: growing stack.]~%"))
54 (let ((new-stack (make-array (ash len 1))))
55 (replace new-stack *eval-stack* :end1 len :end2 len)
56 (setf *eval-stack* new-stack))))
57 (let ((top *eval-stack-top*))
58 #!+sb-show (when *eval-stack-trace* (format t "pushing ~D.~%" top))
59 (incf *eval-stack-top*)
60 (setf (svref *eval-stack* top) value)))
62 ;;; Return the last value pushed on *EVAL-STACK* and decrement the top
63 ;;; pointer. We forego setting elements off the end of the stack to
64 ;;; nil for GC purposes because there is a *BEFORE-GC-HOOK* to take
65 ;;; care of this for us. However, because of the GC hook, we must be
66 ;;; careful to grab the value before decrementing *EVAL-STACK-TOP*
67 ;;; since we could GC between the decrement and the reference, and the
68 ;;; hook would clear the stack slot.
69 (defun eval-stack-pop ()
70 (when (zerop *eval-stack-top*)
71 (error "attempt to pop empty eval stack"))
72 (let* ((new-top (1- *eval-stack-top*))
73 (value (svref *eval-stack* new-top)))
74 #!+sb-show (when *eval-stack-trace*
75 (format t "popping ~D --> ~S.~%" new-top value))
76 (setf *eval-stack-top* new-top)
79 ;;; Allocate N locations on the stack, bumping the top pointer and
80 ;;; growing the stack if necessary. We set new slots to nil in case we
81 ;;; GC before having set them; we don't want to hold on to potential
82 ;;; garbage from old stack fluctuations.
83 (defun eval-stack-extend (n)
84 (let ((len (length (the simple-vector *eval-stack*))))
85 (when (> (+ n *eval-stack-top*) len)
86 #!+sb-show (when *eval-stack-trace*
87 (format t "[EXTEND: growing stack.]~%"))
88 (let ((new-stack (make-array (+ n (ash len 1)))))
89 (replace new-stack *eval-stack* :end1 len :end2 len)
90 (setf *eval-stack* new-stack))))
91 (let ((new-top (+ *eval-stack-top* n)))
92 #!+sb-show (when *eval-stack-trace*
93 (format t "extending to ~D.~%" new-top))
94 (do ((i *eval-stack-top* (1+ i)))
96 (setf (svref *eval-stack* i) nil))
97 (setf *eval-stack-top* new-top)))
99 ;;; the antithesis of EVAL-STACK-EXTEND
100 (defun eval-stack-shrink (n)
101 #!+sb-show (when *eval-stack-trace*
102 (format t "shrinking to ~D.~%" (- *eval-stack-top* n)))
103 (decf *eval-stack-top* n))
105 ;;; This is used to shrink the stack back to a previous frame pointer.
106 (defun eval-stack-reset-top (ptr)
107 #!+sb-show (when *eval-stack-trace*
108 (format t "setting top to ~D.~%" ptr))
109 (setf *eval-stack-top* ptr))
111 ;;; Return a local variable from the current stack frame. This is used
112 ;;; for references the compiler represents as a lambda-var leaf. It is
113 ;;; a macro as a quick and dirty way of making it SETFable.
115 ;;; FIXME: used only in this file, needn't be in runtime
116 (defmacro eval-stack-local (fp offset)
117 `(svref *eval-stack* (+ ,fp ,offset)))
119 ;;;; interpreted functions
121 ;;; the list of INTERPRETED-FUNCTIONs that have translated definitions
122 (defvar *interpreted-function-cache* nil)
123 (declaim (type list *interpreted-function-cache*))
125 ;;; Return a function that will lazily convert LAMBDA when called, and
126 ;;; will cache translations.
127 (defun make-interpreted-function (lambda)
128 (let ((res (%make-interpreted-function :lambda lambda
129 :arglist (second lambda))))
130 (setf (funcallable-instance-function res)
131 #'(instance-lambda (&rest args)
132 (let ((fun (interpreted-function-definition res))
133 (args (cons (length args) args)))
134 (setf (interpreted-function-gcs res) 0)
135 (internal-apply (or fun (convert-interpreted-fun res))
139 ;;; Eval a FUNCTION form, grab the definition and stick it in.
140 (defun convert-interpreted-fun (fun)
141 (declare (type interpreted-function fun))
142 (let* ((new (interpreted-function-definition
143 (internal-eval `#',(interpreted-function-lambda fun)))))
144 (setf (interpreted-function-definition fun) new)
145 (setf (interpreted-function-converted-once fun) t)
146 (let ((name (interpreted-function-%name fun)))
147 (setf (sb!c::leaf-name new) name)
148 (setf (sb!c::leaf-name (sb!c::main-entry
149 (sb!c::functional-entry-function new)))
151 (push fun *interpreted-function-cache*)
154 ;;; Get the CLAMBDA for the XEP, then look at the inline expansion info in
155 ;;; the real function.
156 (defun interpreted-function-lambda-expression (x)
157 (let ((lambda (interpreted-function-lambda x)))
159 (values lambda nil (interpreted-function-%name x))
160 (let ((fun (sb!c::functional-entry-function
161 (interpreted-function-definition x))))
162 (values (sb!c::functional-inline-expansion fun)
163 (if (let ((env (sb!c::functional-lexenv fun)))
164 (or (sb!c::lexenv-functions env)
165 (sb!c::lexenv-variables env)
166 (sb!c::lexenv-blocks env)
167 (sb!c::lexenv-tags env)))
169 (or (interpreted-function-%name x)
170 (sb!c::component-name
171 (sb!c::block-component
173 (sb!c::lambda-bind (sb!c::main-entry fun)))))))))))
175 ;;; Return a FUNCTION-TYPE describing an eval function. We just grab the
176 ;;; LEAF-TYPE of the definition, converting the definition if not currently
178 (defvar *already-looking-for-type-of* nil)
179 (defun interpreted-function-type (fun)
180 (if (member fun *already-looking-for-type-of*)
181 (specifier-type 'function)
182 (let* ((*already-looking-for-type-of*
183 (cons fun *already-looking-for-type-of*))
184 (def (or (interpreted-function-definition fun)
185 (sb!sys:without-gcing
186 (convert-interpreted-fun fun)
187 (interpreted-function-definition fun)))))
188 (sb!c::leaf-type (sb!c::functional-entry-function def)))))
190 (defun interpreted-function-name (x)
191 (multiple-value-bind (ig1 ig2 res) (interpreted-function-lambda-expression x)
192 (declare (ignore ig1 ig2))
194 (defun (setf interpreted-function-name) (val x)
195 (let ((def (interpreted-function-definition x)))
197 (setf (sb!c::leaf-name def) val)
198 (setf (sb!c::leaf-name (sb!c::main-entry (sb!c::functional-entry-function
201 (setf (interpreted-function-%name x) val)))
203 (defun interpreter-gc-hook ()
204 ;; Clear the unused portion of the eval stack.
205 (let ((len (length (the simple-vector *eval-stack*))))
206 (do ((i *eval-stack-top* (1+ i)))
208 (setf (svref *eval-stack* i) nil)))
210 ;; KLUDGE: I'd like to get rid of this, since it adds complexity and causes
211 ;; confusion. (It's not just academic that it causes confusion. When working
212 ;; on the original cross-compiler, I ran across what looked
213 ;; as though it might be a subtle writing-to-the-host-SBCL-compiler-data bug
214 ;; in my cross-compiler code, which turned out to be just a case of compiler
215 ;; warnings coming from recompilation of a flushed-from-the-cache interpreted
216 ;; function. Since it took me a long while to realize how many things the
217 ;; problem depended on (since it was tied up with magic numbers of GC cycles,
218 ;; egads!) I blew over a day trying to isolate the problem in a small test
221 ;; The cache-flushing seems to be motivated by efficiency concerns, which
222 ;; seem misplaced when the user chooses to use the interpreter. However, it
223 ;; also interacts with SAVE, and I veered off from deleting it wholesale when
224 ;; I noticed that. After the whole system is working, though, I'd like to
225 ;; revisit this decision. -- WHN 19990713
226 (let ((num (- (length *interpreted-function-cache*)
227 *interpreted-function-cache-minimum-size*)))
229 (setq *interpreted-function-cache*
230 (delete-if #'(lambda (x)
231 (when (>= (interpreted-function-gcs x)
232 *interpreted-function-cache-threshold*)
233 (setf (interpreted-function-definition x) nil)
235 *interpreted-function-cache*
237 (dolist (fun *interpreted-function-cache*)
238 (incf (interpreted-function-gcs fun))))
239 (pushnew 'interpreter-gc-hook sb!ext:*before-gc-hooks*)
241 ;;; Clear all entries in the eval function cache. This allows the internal
242 ;;; representation of the functions to be reclaimed, and also lazily forces
243 ;;; macroexpansions to be recomputed.
244 (defun flush-interpreted-function-cache ()
245 (dolist (fun *interpreted-function-cache*)
246 (setf (interpreted-function-definition fun) nil))
247 (setq *interpreted-function-cache* ()))
249 ;;;; INTERNAL-APPLY-LOOP macros
251 ;;;; These macros are intimately related to INTERNAL-APPLY-LOOP. They assume
252 ;;;; variables established by this function, and they assume they can return
253 ;;;; from a block by that name. This is sleazy, but we justify it as follows:
254 ;;;; They are so specialized in use, and their invocation became lengthy, that
255 ;;;; we allowed them to slime some access to things in their expanding
256 ;;;; environment. These macros don't really extend our Lisp syntax, but they do
257 ;;;; provide some template expansion service; it is these cleaner circumstance
258 ;;;; that require a more rigid programming style.
260 ;;;; Since these are macros expanded almost solely for COMBINATION nodes,
261 ;;;; they cascade from the end of this logical page to the beginning here.
262 ;;;; Therefore, it is best you start looking at them from the end of this
263 ;;;; section, backwards from normal scanning mode for Lisp code.
265 ;;; This runs a function on some arguments from the stack. If the combination
266 ;;; occurs in a tail recursive position, then we do the call such that we
267 ;;; return from tail-p-function with whatever values the call produces. With a
268 ;;; :local call, we have to restore the stack to its previous frame before
269 ;;; doing the call. The :full call mechanism does this for us. If it is NOT a
270 ;;; tail recursive call, and we're in a multiple value context, then then push
271 ;;; a list of the returned values. Do the same thing if we're in a :return
272 ;;; context. Push a single value, without listifying it, for a :single value
273 ;;; context. Otherwise, just call for side effect.
275 ;;; Node is the combination node, and cont is its continuation. Frame-ptr
276 ;;; is the current frame pointer, and closure is the current environment for
277 ;;; closure variables. Call-type is either :full or :local, and when it is
278 ;;; local, lambda is the IR1 lambda to apply.
280 ;;; This assumes the following variables are present: node, cont, frame-ptr,
281 ;;; and closure. It also assumes a block named internal-apply-loop.
283 ;;; FIXME: used only in this file, needn't be in runtime
284 ;;; FIXME: down with DO-FOO names for non-iteration constructs!
285 (defmacro do-combination (call-type lambda mv-or-normal)
286 (let* ((args (gensym))
287 (calling-closure (gensym))
288 (invoke-fun (ecase mv-or-normal
289 (:mv-call 'mv-internal-invoke)
290 (:normal 'internal-invoke)))
291 (args-form (ecase mv-or-normal
294 (length (sb!c::mv-combination-args node))))
296 `(eval-stack-args (sb!c:lambda-eval-info-args-passed
297 (sb!c::lambda-info ,lambda))))))
298 (call-form (ecase call-type
300 (length (sb!c::basic-combination-args node))))
301 (:local `(internal-apply
303 (compute-closure node ,lambda frame-ptr
310 ;; INVOKE-FUN takes care of the stack itself.
311 (,invoke-fun (length (sb!c::basic-combination-args node))
313 (:local `(let ((,args ,args-form)
315 (compute-closure node ,lambda frame-ptr closure)))
316 ;; No need to clean up stack slots for GC due to
317 ;; SB!EXT:*BEFORE-GC-HOOK*.
318 (eval-stack-reset-top frame-ptr)
321 (internal-apply ,lambda ,args ,calling-closure
323 `(cond ((sb!c::node-tail-p node)
326 (ecase (sb!c::continuation-info cont)
328 (eval-stack-push (multiple-value-list ,call-form)))
330 (eval-stack-push ,call-form))
331 (:unused ,call-form))))))
333 ;;; This sets the variable block in INTERNAL-APPLY-LOOP, and it announces this
334 ;;; by setting set-block-p for later loop iteration maintenance.
336 ;;; FIXME: used only in this file, needn't be in runtime
337 (defmacro set-block (exp)
340 (setf set-block-p t)))
342 ;;; This sets all the iteration variables in INTERNAL-APPLY-LOOP to iterate
343 ;;; over a new block's nodes. Block-exp is optional because sometimes we have
344 ;;; already set block, and we only need to bring the others into agreement.
345 ;;; If we already set block, then clear the variable that announces this,
348 ;;; FIXME: used only in this file, needn't be in runtime
349 (defmacro change-blocks (&optional block-exp)
352 `(setf block ,block-exp)
353 `(setf set-block-p nil))
354 (setf node (sb!c::continuation-next (sb!c::block-start block)))
355 (setf last-cont (sb!c::node-cont (sb!c::block-last block)))))
357 ;;; This controls printing visited nodes in INTERNAL-APPLY-LOOP. We use it
358 ;;; here, and INTERNAL-INVOKE uses it to print function call looking output
359 ;;; to further describe sb!c::combination nodes.
360 #!+sb-show (defvar *internal-apply-node-trace* nil)
362 (defun maybe-trace-funny-fun (node name &rest args)
363 (when *internal-apply-node-trace*
364 (format t "(~S ~{ ~S~}) c~S~%"
365 name args (sb!c::cont-num (sb!c::node-cont node)))))
367 ;;; This implements the intention of the virtual function name. This is a
368 ;;; macro because some of these actions must occur without a function call.
369 ;;; For example, calling a dispatch function to implement special binding would
370 ;;; be a no-op because returning from that function would cause the system to
371 ;;; undo any special bindings it established.
373 ;;; NOTE: update SB!C:ANNOTATE-COMPONENT-FOR-EVAL and/or
374 ;;; sb!c::undefined-funny-funs if you add or remove branches in this routine.
376 ;;; This assumes the following variables are present: node, cont, frame-ptr,
377 ;;; args, closure, block, and last-cont. It also assumes a block named
378 ;;; internal-apply-loop.
380 ;;; FIXME: used only in this file, needn't be in runtime
381 ;;; FIXME: down with DO-FOO names for non-iteration constructs!
382 (defmacro do-funny-function (funny-fun-name)
383 (let ((name (gensym)))
384 `(let ((,name ,funny-fun-name))
387 (let ((value (eval-stack-pop))
388 (global-var (eval-stack-pop)))
389 #!+sb-show (maybe-trace-funny-fun node ,name global-var value)
390 (sb!sys:%primitive sb!c:bind
392 (sb!c::global-var-name global-var))))
393 (sb!c::%special-unbind
394 ;; Throw away arg telling me which special, and tell the dynamic
395 ;; binding mechanism to unbind one variable.
397 #!+sb-show (maybe-trace-funny-fun node ,name)
398 (sb!sys:%primitive sb!c:unbind))
400 (let* ((tag (eval-stack-pop))
401 (nlx-info (eval-stack-pop))
403 ;; Ultimately THROW and CATCH will fix the interpreter's stack
404 ;; since this is necessary for compiled CATCH's and those in
405 ;; the initial top level function.
406 (stack-top *eval-stack-top*)
410 #!+sb-show (maybe-trace-funny-fun node ,name tag)
411 (multiple-value-setq (block node cont last-cont)
412 (internal-apply-loop (sb!c::continuation-next cont)
413 frame-ptr lambda args closure))
414 (setf fell-through-p t)))))
415 (cond (fell-through-p
416 ;; We got here because we just saw the SB!C::%CATCH-BREAKUP
417 ;; funny function inside the above recursive call to
418 ;; INTERNAL-APPLY-LOOP. Therefore, we just received and
419 ;; stored the current state of evaluation for falling
423 ;; Fix up the interpreter's stack after having thrown here.
424 ;; We won't need to do this in the final implementation.
425 (eval-stack-reset-top stack-top)
426 ;; Take the values received in the list bound above, and
427 ;; massage them into the form expected by the continuation
428 ;; of the non-local-exit info.
429 (ecase (sb!c::continuation-info
430 (sb!c::nlx-info-continuation nlx-info))
432 (eval-stack-push (car values)))
434 (eval-stack-push values))
436 ;; We want to continue with the code after the CATCH body.
437 ;; The non-local-exit info tells us where this is, but we
438 ;; know that block only contains a call to the funny
439 ;; function SB!C::%NLX-ENTRY, which simply is a place holder
440 ;; for the compiler IR1. We want to skip the target block
441 ;; entirely, so we say it is the block we're in now and say
442 ;; the current cont is the last-cont. This makes the COND
443 ;; at the end of INTERNAL-APPLY-LOOP do the right thing.
444 (setf block (sb!c::nlx-info-target nlx-info))
445 (setf cont last-cont)))))
446 (sb!c::%unwind-protect
447 ;; Cleanup function not pushed due to special-case :UNUSED
448 ;; annotation in ANNOTATE-COMPONENT-FOR-EVAL.
449 (let* ((nlx-info (eval-stack-pop))
451 (stack-top *eval-stack-top*))
454 #!+sb-show (maybe-trace-funny-fun node ,name)
455 (multiple-value-setq (block node cont last-cont)
456 (internal-apply-loop (sb!c::continuation-next cont)
457 frame-ptr lambda args closure))
458 (setf fell-through-p t))
459 (cond (fell-through-p
460 ;; We got here because we just saw the
461 ;; SB!C::%UNWIND-PROTECT-BREAKUP funny function inside the
462 ;; above recursive call to INTERNAL-APPLY-LOOP.
463 ;; Therefore, we just received and stored the current
464 ;; state of evaluation for falling through.
467 ;; Fix up the interpreter's stack after having thrown
468 ;; here. We won't need to do this in the final
470 (eval-stack-reset-top stack-top)
471 ;; Push some bogus values for exit context to keep the
472 ;; MV-BIND in the UNWIND-PROTECT translation happy.
473 (eval-stack-push '(nil nil 0))
474 (let ((node (sb!c::continuation-next
476 (car (sb!c::block-succ
477 (sb!c::nlx-info-target nlx-info)))))))
478 (internal-apply-loop node frame-ptr lambda args
480 ((sb!c::%catch-breakup
481 sb!c::%unwind-protect-breakup
482 sb!c::%continue-unwind)
483 ;; This shows up when we locally exit a CATCH body -- fell through.
484 ;; Return the current state of evaluation to the previous invocation
485 ;; of INTERNAL-APPLY-LOOP which happens to be running in the
486 ;; SB!C::%CATCH branch of this code.
487 #!+sb-show (maybe-trace-funny-fun node ,name)
488 (return-from internal-apply-loop
489 (values block node cont last-cont)))
491 #!+sb-show (maybe-trace-funny-fun node ,name)
492 ;; This just marks a spot in the code for CATCH, UNWIND-PROTECT, and
493 ;; non-local lexical exits (GO or RETURN-FROM).
494 ;; Do nothing since sb!c::%catch does it all when it catches a THROW.
495 ;; Do nothing since sb!c::%unwind-protect does it all when
496 ;; it catches a THROW.
498 (sb!c::%more-arg-context
499 (let* ((fixed-arg-count (1+ (eval-stack-pop)))
500 ;; Add 1 to actual fixed count for extra arg expected by
501 ;; external entry points (XEP) which some IR1 lambdas have.
502 ;; The extra arg is the number of arguments for arg count
503 ;; consistency checking. SB!C::%MORE-ARG-CONTEXT always runs
504 ;; within an XEP, so the lambda has an extra arg.
505 (more-args (nthcdr fixed-arg-count args)))
506 #!+sb-show (maybe-trace-funny-fun node ,name fixed-arg-count)
507 (aver (eq (sb!c::continuation-info cont) :multiple))
508 (eval-stack-push (list more-args (length more-args)))))
509 (sb!c::%unknown-values
510 (error "SB!C::%UNKNOWN-VALUES should never be in interpreter's IR1."))
511 (sb!c::%lexical-exit-breakup
512 ;; We see this whenever we locally exit the extent of a lexical
513 ;; target. That is, we are truly locally exiting an extent we could
514 ;; have non-locally lexically exited. Return the :fell-through flag
515 ;; and the current state of evaluation to the previous invocation
516 ;; of INTERNAL-APPLY-LOOP which happens to be running in the
517 ;; SB!C::ENTRY branch of INTERNAL-APPLY-LOOP.
518 #!+sb-show (maybe-trace-funny-fun node ,name)
519 ;; Discard the NLX-INFO arg...
521 (return-from internal-apply-loop
522 (values :fell-through block node cont last-cont)))))))
524 ;;; This expands for the two types of combination nodes INTERNAL-APPLY-LOOP
525 ;;; sees. Type is either :mv-call or :normal. Node is the combination node,
526 ;;; and cont is its continuation. Frame-ptr is the current frame pointer, and
527 ;;; closure is the current environment for closure variables.
529 ;;; Most of the real work is done by DO-COMBINATION. This first determines if
530 ;;; the combination node describes a :full call which DO-COMBINATION directly
531 ;;; handles. If the call is :local, then we either invoke an IR1 lambda, or we
532 ;;; just bind some LET variables. If the call is :local, and type is :mv-call,
533 ;;; then we can only be binding multiple values. Otherwise, the combination
534 ;;; node describes a function known to the compiler, but this may be a funny
535 ;;; function that actually isn't ever defined. We either take some action for
536 ;;; the funny function or do a :full call on the known true function, but the
537 ;;; interpreter doesn't do optimizing stuff for functions known to the
540 ;;; This assumes the following variables are present: node, cont, frame-ptr,
541 ;;; and closure. It also assumes a block named internal-apply-loop.
543 ;;; FIXME: used only in this file, needn't be in runtime
544 (defmacro combination-node (type)
545 (let* ((kind (gensym))
549 (letp-bind (ecase type
552 `((,letp (eq (sb!c::functional-kind ,lambda) :let))))))
556 `(store-mv-let-vars ,lambda frame-ptr
557 (length (sb!c::mv-combination-args node))))
560 (store-let-vars ,lambda frame-ptr)
561 (do-combination :local ,lambda ,type))))))
562 `(let ((,kind (sb!c::basic-combination-kind node))
563 (,fun (sb!c::basic-combination-fun node)))
564 (cond ((member ,kind '(:full :error))
565 (do-combination :full nil ,type))
567 (let* ((,lambda (sb!c::ref-leaf (sb!c::continuation-use ,fun)))
570 ((eq (sb!c::continuation-info ,fun) :unused)
571 (aver (typep ,kind 'sb!c::function-info))
572 (do-funny-function (sb!c::continuation-function-name ,fun)))
574 (aver (typep ,kind 'sb!c::function-info))
575 (do-combination :full nil ,type))))))
579 ;;; Evaluate an arbitary form. We convert the form, then call internal
580 ;;; APPLY on it. If *ALREADY-EVALED-THIS* is true, then we bind it to
581 ;;; NIL around the apply to limit the inhibition to the lexical scope
582 ;;; of the EVAL-WHEN.
584 (defun sb!eval:internal-eval (form)
585 (let ((res (sb!c:compile-for-eval form)))
586 (if *already-evaled-this*
587 (let ((*already-evaled-this* nil))
588 (internal-apply res nil '#()))
589 (internal-apply res nil '#()))))
591 ;;; This passes on a node's value appropriately, possibly returning from
592 ;;; function to do so. When we are tail-p, don't push the value, return it on
593 ;;; the system's actual call stack; when we blow out of function this way, we
594 ;;; must return the interpreter's stack to the its state before this call to
595 ;;; function. When we're in a multiple value context or heading for a return
596 ;;; node, we push a list of the value for easier handling later. Otherwise,
597 ;;; just push the value on the interpreter's stack.
599 ;;; FIXME: maybe used only in this file, if so, needn't be in runtime
600 (defmacro value (node info value frame-ptr function)
601 `(cond ((sb!c::node-tail-p ,node)
602 (eval-stack-reset-top ,frame-ptr)
603 (return-from ,function ,value))
604 ((member ,info '(:multiple :return) :test #'eq)
605 (eval-stack-push (list ,value)))
606 (t (aver (eq ,info :single))
607 (eval-stack-push ,value))))
610 (defun maybe-trace-nodes (node)
611 (when *internal-apply-node-trace*
612 (format t "<~A-node> c~S~%"
614 (sb!c::cont-num (sb!c::node-cont node)))))
616 ;;; Interpret LAMBDA, a compiler IR1 data structure representing a
617 ;;; function, applying it to ARGS. CLOSURE is the environment in which
618 ;;; to run LAMBDA, the variables and such closed over to form LAMBDA.
619 ;;; The call occurs on the interpreter's stack, so save the current
620 ;;; top and extend the stack for this lambda's call frame. Then store
621 ;;; the args into locals on the stack.
623 ;;; ARGS is the list of arguments to apply to. If IGNORE-UNUSED is
624 ;;; true, then values for un-read variables are present in the
625 ;;; argument list, and must be discarded (always true except in a
626 ;;; local call.) ARGS may run out of values before VARS runs out of
627 ;;; variables (in the case of an XEP with optionals); we just do CAR
628 ;;; of NIL and store NIL. This is not the proper defaulting (which is
629 ;;; done by explicit code in the XEP.)
630 (defun internal-apply (lambda args closure &optional (ignore-unused t))
631 (let ((frame-ptr *eval-stack-top*))
632 (eval-stack-extend (sb!c:lambda-eval-info-frame-size (sb!c::lambda-info lambda)))
633 (do ((vars (sb!c::lambda-vars lambda) (cdr vars))
636 (let ((var (car vars)))
637 (cond ((sb!c::leaf-refs var)
638 (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var))
639 (if (sb!c::lambda-var-indirect var)
640 (sb!c::make-value-cell (pop args))
642 (ignore-unused (pop args)))))
643 (internal-apply-loop (sb!c::lambda-bind lambda) frame-ptr lambda args
646 ;;; This does the work of INTERNAL-APPLY. This also calls itself
647 ;;; recursively for certain language features, such as CATCH. First is
648 ;;; the node at which to start interpreting. FRAME-PTR is the current
649 ;;; frame pointer for accessing local variables. LAMBDA is the IR1
650 ;;; lambda from which comes the nodes a given call to this function
651 ;;; processes, and CLOSURE is the environment for interpreting LAMBDA.
652 ;;; ARGS is the argument list for the lambda given to INTERNAL-APPLY,
653 ;;; and we have to carry it around with us in case of &more-arg or
654 ;;; &rest-arg processing which is represented explicitly in the
657 ;;; KLUDGE: Due to having a truly tail recursive interpreter, some of
658 ;;; the branches handling a given node need to RETURN-FROM this
659 ;;; routine. Also, some calls this makes to do work for it must occur
660 ;;; in tail recursive positions. Because of this required access to
661 ;;; this function lexical environment and calling positions, we often
662 ;;; are unable to break off logical chunks of code into functions. We
663 ;;; have written macros intended solely for use in this routine, and
664 ;;; due to all the local stuff they need to access and length complex
665 ;;; calls, we have written them to sleazily access locals from this
666 ;;; routine. In addition to assuming a block named internal-apply-loop
667 ;;; exists, they set and reference the following variables: NODE,
668 ;;; CONT, FRAME-PTR, CLOSURE, BLOCK, LAST-CONT, and SET-BLOCK-P.
669 ;;; FIXME: Perhaps this kludge could go away if we convert to a
670 ;;; compiler-only implementation?
671 (defun internal-apply-loop (first frame-ptr lambda args closure)
672 ;; FIXME: This will cause source code location information to be compiled
673 ;; into the executable, which will probably cause problems for users running
674 ;; without the sources and/or without the build-the-system readtable.
675 (declare (optimize (debug 2)))
676 (let* ((block (sb!c::node-block first))
677 (last-cont (sb!c::node-cont (sb!c::block-last block)))
681 (let ((cont (sb!c::node-cont node)))
684 #!+sb-show (maybe-trace-nodes node)
685 (let ((info (sb!c::continuation-info cont)))
686 (unless (eq info :unused)
687 (value node info (leaf-value node frame-ptr closure)
688 frame-ptr internal-apply-loop))))
690 #!+sb-show (maybe-trace-nodes node)
691 (combination-node :normal))
693 #!+sb-show (maybe-trace-nodes node)
694 ;; IF nodes always occur at the end of a block, so pick another.
695 (set-block (if (eval-stack-pop)
696 (sb!c::if-consequent node)
697 (sb!c::if-alternative node))))
699 #!+sb-show (maybe-trace-nodes node)
700 ;; Ignore bind nodes since INTERNAL-APPLY extends the
701 ;; stack for all of a lambda's locals, and the
702 ;; SB!C::COMBINATION branch handles LET binds (moving
703 ;; values off stack top into locals).
706 #!+sb-show (maybe-trace-nodes node)
707 (let ((info (sb!c::continuation-info cont))
708 (res (set-leaf-value node frame-ptr closure
710 (unless (eq info :unused)
711 (value node info res frame-ptr internal-apply-loop))))
713 #!+sb-show (maybe-trace-nodes node)
714 (let ((info (cdr (assoc node (sb!c:lambda-eval-info-entries
715 (sb!c::lambda-info lambda))))))
716 ;; No info means no-op entry for CATCH or UNWIND-PROTECT.
718 ;; Store stack top for restoration in local exit
719 ;; situation in SB!C::EXIT branch.
720 (setf (eval-stack-local frame-ptr
721 (sb!c:entry-node-info-st-top info))
723 (let ((tag (sb!c:entry-node-info-nlx-tag info)))
725 ;; Non-local lexical exit (someone closed over a
726 ;; GO tag or BLOCK name).
727 (let ((unique-tag (cons nil nil))
729 (setf (eval-stack-local frame-ptr tag) unique-tag)
730 (if (eq cont last-cont)
731 (change-blocks (car (sb!c::block-succ block)))
732 (setf node (sb!c::continuation-next cont)))
734 (multiple-value-setq (values block node cont last-cont)
736 (internal-apply-loop node frame-ptr
737 lambda args closure)))
739 (when (eq values :fell-through)
740 ;; We hit a %LEXICAL-EXIT-BREAKUP.
741 ;; Interpreting state is set with MV-SETQ above.
742 ;; Just get out of this branch and go on.
745 (unless (eq values :non-local-go)
746 ;; We know we're non-locally exiting from a
747 ;; BLOCK with values (saw a RETURN-FROM).
748 (ecase (sb!c::continuation-info cont)
750 (eval-stack-push (car values)))
752 (eval-stack-push values))
754 ;; Start interpreting again at the target, skipping
755 ;; the %NLX-ENTRY block.
757 (sb!c::continuation-next
759 (car (sb!c::block-succ block))))))))))))
761 #!+sb-show (maybe-trace-nodes node)
762 (let* ((incoming-values (sb!c::exit-value node))
763 (values (if incoming-values (eval-stack-pop))))
765 ((eq (sb!c::lambda-environment lambda)
766 (sb!c::block-environment
767 (sb!c::node-block (sb!c::exit-entry node))))
769 ;; Fixup stack top and massage values for destination.
770 (eval-stack-reset-top
771 (eval-stack-local frame-ptr
772 (sb!c:entry-node-info-st-top
773 (cdr (assoc (sb!c::exit-entry node)
774 (sb!c:lambda-eval-info-entries
775 (sb!c::lambda-info lambda)))))))
776 (ecase (sb!c::continuation-info cont)
778 (aver incoming-values)
779 (eval-stack-push (car values)))
781 (aver incoming-values)
782 (eval-stack-push values))
785 (let ((info (sb!c::find-nlx-info (sb!c::exit-entry node)
790 (sb!c::environment-closure
791 (sb!c::node-environment node))
794 (values values (sb!c::nlx-info-target info) nil cont)
795 (values :non-local-go (sb!c::nlx-info-target info)))))))))
797 #!+sb-show (maybe-trace-nodes node)
798 (let ((values (eval-stack-pop)))
799 (eval-stack-reset-top frame-ptr)
800 (return-from internal-apply-loop (values-list values))))
801 (sb!c::mv-combination
802 #!+sb-show (maybe-trace-nodes node)
803 (combination-node :mv-call)))
804 ;; See function doc below.
805 (reference-this-var-to-keep-it-alive node)
806 (reference-this-var-to-keep-it-alive frame-ptr)
807 (reference-this-var-to-keep-it-alive closure)
808 (cond ((not (eq cont last-cont))
809 (setf node (sb!c::continuation-next cont)))
810 ;; Currently only the last node in a block causes this loop to
811 ;; change blocks, so we never just go to the next node when
812 ;; the current node's branch tried to change blocks.
816 ;; CIF nodes set the block for us, but other last
818 (change-blocks (car (sb!c::block-succ block)))))))))
820 ;;; This function allows a reference to a variable that the compiler cannot
821 ;;; easily eliminate as unnecessary. We use this at the end of the node
822 ;;; dispatch in INTERNAL-APPLY-LOOP to make sure the node variable has a
823 ;;; valid value. Each node branch tends to reference it at the beginning,
824 ;;; and then there is no reference but a set at the end; the compiler then
825 ;;; kills the variable between the reference in the dispatch branch and when
826 ;;; we set it at the end. The problem is that most error will occur in the
827 ;;; interpreter within one of these node dispatch branches.
828 (defun reference-this-var-to-keep-it-alive (node)
831 ;;; This sets a SB!C::CSET node's var to value, returning value. When
832 ;;; var is local, we have to compare its home environment to the
833 ;;; current one, node's environment. If they're the same, we check to
834 ;;; see whether the var is indirect, and store the value on the stack
835 ;;; or in the value cell as appropriate. Otherwise, var is a closure
836 ;;; variable, and since we're setting it, we know its location
837 ;;; contains an indirect value object.
838 (defun set-leaf-value (node frame-ptr closure value)
839 (let ((var (sb!c::set-var node)))
842 (set-leaf-value-lambda-var node var frame-ptr closure value))
844 (setf (symbol-value (sb!c::global-var-name var)) value)))))
846 ;;; This does SET-LEAF-VALUE for a LAMBDA-VAR leaf. The debugger tools'
847 ;;; internals use this also to set interpreted local variables.
848 (defun set-leaf-value-lambda-var (node var frame-ptr closure value)
849 ;; Note: We avoid trying to set a lexical variable with no refs
850 ;; because the compiler deletes such variables.
851 (when (sb!c::leaf-refs var)
852 (let ((env (sb!c::node-environment node)))
853 (cond ((not (eq (sb!c::lambda-environment (sb!c::lambda-var-home var))
855 (sb!c::value-cell-set
857 (position var (sb!c::environment-closure env)
860 ((sb!c::lambda-var-indirect var)
861 (sb!c::value-cell-set
862 (eval-stack-local frame-ptr (sb!c::lambda-var-info var))
865 (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var))
868 ;;; This figures out how to return a value for a ref node. LEAF is the
869 ;;; ref's structure that tells us about the value, and it is one of
870 ;;; the following types:
871 ;;; constant -- It knows its own value.
872 ;;; global-var -- It's either a value or function reference. Get it right.
873 ;;; local-var -- This may on the stack or in the current closure, the
874 ;;; environment for the lambda INTERNAL-APPLY is currently
875 ;;; executing. If the leaf's home environment is the same
876 ;;; as the node's home environment, then the value is on the
877 ;;; stack, else it's in the closure since it came from another
878 ;;; environment. Whether the var comes from the stack or the
879 ;;; closure, it could have come from a closure, and it could
880 ;;; have been closed over for setting. When this happens, the
881 ;;; actual value is stored in an indirection object, so
882 ;;; indirect. See COMPUTE-CLOSURE for the description of
883 ;;; the structure of the closure argument to this function.
884 ;;; functional -- This is a reference to an interpreted function that may
885 ;;; be passed or called anywhere. We return a real function
886 ;;; that calls INTERNAL-APPLY, closing over the leaf. We also
887 ;;; have to compute a closure, running environment, for the
888 ;;; lambda in case it references stuff in the current
889 ;;; environment. If the closure is empty and there is no
890 ;;; functional environment, then we use
891 ;;; MAKE-INTERPRETED-FUNCTION to make a cached translation.
892 ;;; Since it is too late to lazily convert, we set up the
893 ;;; INTERPRETED-FUNCTION to be already converted.
894 (defun leaf-value (node frame-ptr closure)
895 (let ((leaf (sb!c::ref-leaf node)))
898 (sb!c::constant-value leaf))
900 (locally (declare (optimize (safety 1)))
901 (if (eq (sb!c::global-var-kind leaf) :global-function)
902 (let ((name (sb!c::global-var-name leaf)))
904 (symbol-function name)
906 (symbol-value (sb!c::global-var-name leaf)))))
908 (leaf-value-lambda-var node leaf frame-ptr closure))
910 (let* ((calling-closure (compute-closure node leaf frame-ptr closure))
911 (real-fun (sb!c::functional-entry-function leaf))
912 (arg-doc (sb!c::functional-arg-documentation real-fun)))
913 (cond ((sb!c:lambda-eval-info-function (sb!c::leaf-info leaf)))
914 ((and (zerop (length calling-closure))
915 (null (sb!c::lexenv-functions
916 (sb!c::functional-lexenv real-fun))))
917 (let ((res (make-interpreted-function
918 (sb!c::functional-inline-expansion real-fun))))
919 (push res *interpreted-function-cache*)
920 (setf (interpreted-function-definition res) leaf)
921 (setf (interpreted-function-converted-once res) t)
922 (setf (interpreted-function-arglist res) arg-doc)
923 (setf (interpreted-function-%name res)
924 (sb!c::leaf-name real-fun))
925 (setf (sb!c:lambda-eval-info-function
926 (sb!c::leaf-info leaf)) res)
929 (let ((res (%make-interpreted-function
931 :%name (sb!c::leaf-name real-fun)
933 :closure calling-closure)))
934 (setf (funcallable-instance-function res)
935 #'(instance-lambda (&rest args)
936 (declare (list args))
938 (interpreted-function-definition res)
939 (cons (length args) args)
940 (interpreted-function-closure res))))
943 ;;; This does LEAF-VALUE for a lambda-var leaf. The debugger tools' internals
944 ;;; uses this also to reference interpreted local variables.
945 (defun leaf-value-lambda-var (node leaf frame-ptr closure)
946 (let* ((env (sb!c::node-environment node))
948 (if (eq (sb!c::lambda-environment (sb!c::lambda-var-home leaf))
950 (eval-stack-local frame-ptr (sb!c::lambda-var-info leaf))
952 (position leaf (sb!c::environment-closure env)
954 (if (sb!c::lambda-var-indirect leaf)
955 (sb!c::value-cell-ref temp)
958 ;;; Compute a closure for a local call and for returned call'able
959 ;;; closure objects. Sometimes the closure is a SIMPLE-VECTOR of no
960 ;;; elements. NODE is either a reference node or a combination node.
961 ;;; LEAF is either the leaf of the reference node or the lambda to
962 ;;; internally apply for the combination node. FRAME-PTR is the
963 ;;; current frame pointer for fetching current values to store in the
964 ;;; closure. CLOSURE is the current closure, the closed-over
965 ;;; environment of the currently interpreting LAMBDA.
967 ;;; A computed closure is a vector corresponding to the list of
968 ;;; closure variables described in an environment. The position of a
969 ;;; lambda-var in this closure list is the index into the closure
970 ;;; vector of values.
971 (defun compute-closure (node leaf frame-ptr closure)
972 (let* ((current-env (sb!c::node-environment node))
973 (current-closure-vars (sb!c::environment-closure current-env))
974 ;; FUNCTIONAL-ENV is the environment description for leaf,
975 ;; the lambda for which we're computing a closure. This
976 ;; environment describes which of lambda's vars we find in
977 ;; lambda's closure when it's running, versus finding them on
979 (functional-env (sb!c::lambda-environment leaf))
980 (functional-closure-vars (sb!c::environment-closure functional-env))
981 (functional-closure (make-array (length functional-closure-vars))))
982 ;; For each lambda-var VAR in the functional environment's closure
983 ;; list, if the VAR's home environment is the current environment,
984 ;; then get a value off the stack and store it in the closure
985 ;; we're computing. Otherwise VAR's value comes from somewhere
986 ;; else, but we have it in our current closure, the environment
987 ;; we're running in as we compute this new closure. Find this
988 ;; value the same way we do in LEAF-VALUE, by finding VAR's
989 ;; position in the current environment's description of the
991 (do ((vars functional-closure-vars (cdr vars))
994 (let ((ele (car vars)))
995 (setf (svref functional-closure i)
998 (if (eq (sb!c::lambda-environment (sb!c::lambda-var-home ele))
1000 (eval-stack-local frame-ptr (sb!c::lambda-var-info ele))
1002 (position ele current-closure-vars
1005 (if (eq (sb!c::block-environment (sb!c::nlx-info-target ele))
1009 (sb!c:entry-node-info-nlx-tag
1010 (cdr (assoc ;; entry node for non-local extent
1011 (sb!c::cleanup-mess-up
1012 (sb!c::nlx-info-cleanup ele))
1013 (sb!c::lambda-eval-info-entries
1015 ;; the lambda INTERNAL-APPLY-LOOP tosses around
1016 (sb!c::environment-function
1017 (sb!c::node-environment node))))))))
1019 (position ele current-closure-vars
1021 functional-closure))
1023 ;;; INTERNAL-APPLY uses this to invoke a function from the
1024 ;;; interpreter's stack on some arguments also taken from the stack.
1025 ;;; When tail-p is non-nil, control does not return to INTERNAL-APPLY
1026 ;;; to further interpret the current IR1 lambda, so INTERNAL-INVOKE
1027 ;;; must clean up the current interpreter's stack frame.
1028 (defun internal-invoke (arg-count &optional tailp)
1029 (let ((args (eval-stack-args arg-count)) ;LET says this init form runs first.
1030 (fun (eval-stack-pop)))
1031 (when tailp (eval-stack-reset-top tailp))
1032 #!+sb-show (when *internal-apply-node-trace*
1033 (format t "(~S~{ ~S~})~%" fun args))
1036 ;;; This is almost just like INTERNAL-INVOKE. We call
1037 ;;; MV-EVAL-STACK-ARGS, and our function is in a list on the stack
1038 ;;; instead of simply on the stack.
1039 (defun mv-internal-invoke (arg-count &optional tailp)
1040 (let ((args (mv-eval-stack-args arg-count)) ; LET runs this init form first.
1041 (fun (car (eval-stack-pop))))
1042 (when tailp (eval-stack-reset-top tailp))
1043 #!+sb-show (when *internal-apply-node-trace*
1044 (format t "(~S~{ ~S~})~%" fun args))
1047 ;;; Return a list of the top arg-count elements on the interpreter's
1048 ;;; stack. This removes them from the stack.
1049 (defun eval-stack-args (arg-count)
1051 (dotimes (i arg-count args)
1052 (push (eval-stack-pop) args))))
1054 ;;; This assumes the top count elements on interpreter's stack are
1055 ;;; lists. This returns a single list with all the elements from these
1057 (defun mv-eval-stack-args (count)
1060 (let ((last (eval-stack-pop)))
1061 (dotimes (i (1- count))
1062 (let ((next (eval-stack-pop)))
1064 (if next (nconc next last) last))))
1067 ;;; This stores lambda's vars, stack locals, from values popped off the stack.
1068 ;;; When a var has no references, the compiler computes IR1 such that the
1069 ;;; continuation delivering the value for the unreference var appears unused.
1070 ;;; Because of this, the interpreter drops the value on the floor instead of
1071 ;;; saving it on the stack for binding, so we only pop a value when the var has
1072 ;;; some reference. INTERNAL-APPLY uses this for sb!c::combination nodes
1073 ;;; representing LET's.
1075 ;;; When storing the local, if it is indirect, then someone closes over it for
1076 ;;; setting instead of just for referencing. We then store an indirection cell
1077 ;;; with the value, and the referencing code for locals knows how to get the
1079 (defun store-let-vars (lambda frame-ptr)
1080 (let* ((vars (sb!c::lambda-vars lambda))
1081 (args (eval-stack-args (count-if #'sb!c::leaf-refs vars))))
1082 (declare (list vars args))
1084 (when (sb!c::leaf-refs v)
1085 (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v))
1086 (if (sb!c::lambda-var-indirect v)
1087 (sb!c::make-value-cell (pop args))
1090 ;;; This is similar to STORE-LET-VARS, but the values for the locals
1091 ;;; appear on the stack in a list due to forms that delivered multiple
1092 ;;; values to this lambda/let. Unlike STORE-LET-VARS, there is no
1093 ;;; control over the delivery of a value for an unreferenced var, so
1094 ;;; we drop the corresponding value on the floor when no one
1095 ;;; references it. INTERNAL-APPLY uses this for sb!c::mv-combination
1096 ;;; nodes representing LET's.
1097 (defun store-mv-let-vars (lambda frame-ptr count)
1099 (let ((args (eval-stack-pop)))
1100 (dolist (v (sb!c::lambda-vars lambda))
1101 (if (sb!c::leaf-refs v)
1102 (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v))
1103 (if (sb!c::lambda-var-indirect v)
1104 (sb!c::make-value-cell (pop args))
1109 ;;; This stores lambda's vars, stack locals, from multiple values stored on the
1110 ;;; top of the stack in a list. Since these values arrived multiply, there is
1111 ;;; no control over the delivery of each value for an unreferenced var, so
1112 ;;; unlike STORE-LET-VARS, we have values for variables never used. We drop
1113 ;;; the value corresponding to an unreferenced var on the floor.
1114 ;;; INTERNAL-APPLY uses this for sb!c::mv-combination nodes representing LET's.
1116 ;;; IR1 represents variables bound from multiple values in a list in the
1117 ;;; opposite order of the values list. We use STORE-MV-LET-VARS-AUX to recurse
1118 ;;; down the vars list until we bottom out, storing values on the way back up
1119 ;;; the recursion. You must do this instead of NREVERSE'ing the args list, so
1120 ;;; when we run out of values, we store nil's in the correct lambda-vars.
1121 (defun store-mv-let-vars (lambda frame-ptr count)
1123 (print (sb!c::lambda-vars lambda))
1124 (store-mv-let-vars-aux frame-ptr (sb!c::lambda-vars lambda) (eval-stack-pop)))
1125 (defun store-mv-let-vars-aux (frame-ptr vars args)
1127 (let ((remaining-args (store-mv-let-vars-aux frame-ptr (cdr vars) args))
1129 (when (sb!c::leaf-refs v)
1130 (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v))
1131 (if (sb!c::lambda-var-indirect v)
1132 (sb!c::make-value-cell (car remaining-args))
1133 (car remaining-args))))
1134 (cdr remaining-args))