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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Tue Apr 9 14:40:43 1991 UTC (23 years ago) by ram
Branch: MAIN
Changes since 1.16: +13 -2 lines
Added FLUSH-INTERPRETED-FUNCTION-CACHE so that we can prevent interpreted stuff
from being unnecessarily retained in saved cores.
1 ;;; -*- Package: eval; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/eval.lisp,v 1.17 1991/04/09 14:40:43 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/eval.lisp,v 1.17 1991/04/09 14:40:43 ram Exp $
15 ;;;
16 ;;; This file contains the interpreter. We first convert to the compiler's
17 ;;; IR1 and interpret that.
18 ;;;
19 ;;; Written by Rob MacLachlan and Bill Chiles.
20 ;;;
21
22 (in-package "EVAL")
23
24 (export '(internal-eval *eval-stack-trace* *internal-apply-node-trace*
25 *interpreted-function-cache-minimum-size*
26 *interpreted-function-cache-threshold*
27 flush-interpreted-function-cache
28 trace-eval interpreted-function-p
29 interpreted-function-lambda-expression
30 interpreted-function-closure
31 interpreted-function-name
32 interpreted-function-arglist
33 interpreted-function-type
34 make-interpreted-function))
35
36
37 ;;;; Interpreter stack.
38
39 (defvar *eval-stack* (make-array 100)
40 "This is the interpreter's evaluation stack.")
41 (defvar *eval-stack-top* 0
42 "This is the next free element of the interpreter's evaluation stack.")
43
44 ;;; Setting this causes the stack operations to dump a trace.
45 ;;;
46 (defvar *eval-stack-trace* nil)
47
48
49 ;;; EVAL-STACK-PUSH -- Internal.
50 ;;;
51 ;;; Push value on *eval-stack*, growing the stack if necessary. This returns
52 ;;; value. We save *eval-stack-top* in a local and increment the global before
53 ;;; storing value on the stack to prevent a GC timing problem. If we stored
54 ;;; value on the stack using *eval-stack-top* as an index, and we GC'ed before
55 ;;; incrementing *eval-stack-top*, then INTERPRETER-GC-HOOK would clear the
56 ;;; location.
57 ;;;
58 (defun eval-stack-push (value)
59 (let ((len (length (the simple-vector *eval-stack*))))
60 (when (= len *eval-stack-top*)
61 (when *eval-stack-trace* (format t "[PUSH: growing stack.]~%"))
62 (let ((new-stack (make-array (ash len 1))))
63 (replace new-stack *eval-stack* :end1 len :end2 len)
64 (setf *eval-stack* new-stack))))
65 (let ((top *eval-stack-top*))
66 (when *eval-stack-trace* (format t "pushing ~D.~%" top))
67 (incf *eval-stack-top*)
68 (setf (svref *eval-stack* top) value)))
69
70 ;;; EVAL-STACK-POP -- Internal.
71 ;;;
72 ;;; This returns the last value pushed on *eval-stack* and decrements the top
73 ;;; pointer. We forego setting elements off the end of the stack to nil for GC
74 ;;; purposes because there is a *before-gc-hook* to take care of this for us.
75 ;;; However, because of the GC hook, we must be careful to grab the value
76 ;;; before decrementing *eval-stack-top* since we could GC between the
77 ;;; decrement and the reference, and the hook would clear the stack slot.
78 ;;;
79 (defun eval-stack-pop ()
80 (when (zerop *eval-stack-top*)
81 (error "Attempt to pop empty eval stack."))
82 (let* ((new-top (1- *eval-stack-top*))
83 (value (svref *eval-stack* new-top)))
84 (when *eval-stack-trace* (format t "popping ~D --> ~S.~%" new-top value))
85 (setf *eval-stack-top* new-top)
86 value))
87
88 ;;; EVAL-STACK-EXTEND -- Internal.
89 ;;;
90 ;;; This allocates n locations on the stack, bumping the top pointer and
91 ;;; growing the stack if necessary. We set new slots to nil in case we GC
92 ;;; before having set them; we don't want to hold on to potential garbage
93 ;;; from old stack fluctuations.
94 ;;;
95 (defun eval-stack-extend (n)
96 (let ((len (length (the simple-vector *eval-stack*))))
97 (when (> (+ n *eval-stack-top*) len)
98 (when *eval-stack-trace* (format t "[EXTEND: growing stack.]~%"))
99 (let ((new-stack (make-array (+ n (ash len 1)))))
100 (replace new-stack *eval-stack* :end1 len :end2 len)
101 (setf *eval-stack* new-stack))))
102 (let ((new-top (+ *eval-stack-top* n)))
103 (when *eval-stack-trace* (format t "extending to ~D.~%" new-top))
104 (do ((i *eval-stack-top* (1+ i)))
105 ((= i new-top))
106 (setf (svref *eval-stack* i) nil))
107 (setf *eval-stack-top* new-top)))
108
109 ;;; EVAL-STACK-SHRINK -- Internal.
110 ;;;
111 ;;; The anthesis of EVAL-STACK-EXTEND.
112 ;;;
113 (defun eval-stack-shrink (n)
114 (when *eval-stack-trace*
115 (format t "shrinking to ~D.~%" (- *eval-stack-top* n)))
116 (decf *eval-stack-top* n))
117
118 ;;; EVAL-STACK-SET-TOP -- Internal.
119 ;;;
120 ;;; This is used to shrink the stack back to a previous frame pointer.
121 ;;;
122 (defun eval-stack-set-top (ptr)
123 (when *eval-stack-trace* (format t "setting top to ~D.~%" ptr))
124 (setf *eval-stack-top* ptr))
125
126
127 ;;; EVAL-STACK-LOCAL -- Internal.
128 ;;;
129 ;;; This returns a local variable from the current stack frame. This is used
130 ;;; for references the compiler represents as a lambda-var leaf. This is a
131 ;;; macro for SETF purposes.
132 ;;;
133 (defmacro eval-stack-local (fp offset)
134 `(svref *eval-stack* (+ ,fp ,offset)))
135
136
137 ;;;; Interpreted functions:
138
139 (defstruct (eval-function
140 (:print-function
141 (lambda (s stream d)
142 (declare (ignore d))
143 (format stream "#<EVAL-FUNCTION ~S>"
144 (eval-function-name s)))))
145 ;;
146 ;; The name of this interpreted function, or NIL if none specified.
147 (name nil)
148 ;;
149 ;; This function's debug arglist.
150 (arglist nil)
151 ;;
152 ;; A lambda that can be converted to get the definition.
153 (lambda nil)
154 ;;
155 ;; If this function has been converted, then this is the XEP. If this is
156 ;; false, then the function is not in the cache (or is in the process of
157 ;; being removed.)
158 (definition nil :type (or c::clambda null))
159 ;;
160 ;; The number of consequtive GCs that this function has been unused. This is
161 ;; used to control cache replacement.
162 (gcs 0 :type c::index)
163 ;;
164 ;; True if Lambda has been converted at least once, and thus warnings should
165 ;; be suppressed on additional conversions.
166 (converted-once nil))
167
168
169 (defvar *interpreted-function-cache-minimum-size* 25
170 "If the interpreted function cache has more functions than this come GC time,
171 then attempt to prune it according to
172 *INTERPRETED-FUNCTION-CACHE-THRESHOLD*.")
173
174 (defvar *interpreted-function-cache-threshold* 3
175 "If an interpreted function goes uncalled for more than this many GCs, then
176 it is eligible for flushing from the cache.")
177
178 (proclaim '(type c::index
179 *interpreted-function-cache-minimum-size*
180 *interpreted-function-cache-threshold*))
181
182
183 ;;; The list of EVAL-FUNCTIONS that have translated definitions.
184 ;;;
185 (defvar *interpreted-function-cache* nil)
186 (proclaim '(type list *interpreted-function-cache*))
187
188
189 ;;; MAKE-INTERPRETED-FUNCTION -- Interface
190 ;;;
191 ;;; Return a function that will lazily convert Lambda when called, and will
192 ;;; cache translations.
193 ;;;
194 (defun make-interpreted-function (lambda)
195 (let ((eval-fun (make-eval-function :lambda lambda)))
196 #'(lambda (&rest args)
197 (let ((fun (eval-function-definition eval-fun))
198 (args (cons (length args) args)))
199 (setf (eval-function-gcs eval-fun) 0)
200 (internal-apply (or fun (convert-eval-fun eval-fun))
201 args '#())))))
202
203
204 ;;; GET-EVAL-FUNCTION -- Internal
205 ;;;
206 (defun get-eval-function (x)
207 (let ((res (system:find-if-in-closure #'eval-function-p x)))
208 (assert res)
209 res))
210
211
212 ;;; CONVERT-EVAL-FUN -- Internal
213 ;;;
214 ;;; Eval a FUNCTION form, grab the definition and stick it in.
215 ;;;
216 (defun convert-eval-fun (eval-fun)
217 (declare (type eval-function eval-fun))
218 (let* ((new (eval-function-definition
219 (get-eval-function
220 (internal-eval `#',(eval-function-lambda eval-fun)
221 (eval-function-converted-once eval-fun))))))
222 (setf (eval-function-definition eval-fun) new)
223 (setf (eval-function-converted-once eval-fun) t)
224 (let ((name (eval-function-name eval-fun)))
225 (setf (c::leaf-name new) name)
226 (setf (c::leaf-name (c::main-entry (c::functional-entry-function new)))
227 name))
228 (push eval-fun *interpreted-function-cache*)
229 new))
230
231
232 ;;; INTERPRETED-FUNCTION-LAMDBA-EXPRESSION -- Interface
233 ;;;
234 ;;; Get the CLAMBDA for the XEP, then look at the inline expansion info in
235 ;;; the real function.
236 ;;;
237 (defun interpreted-function-lambda-expression (x)
238 (let* ((eval-fun (get-eval-function x))
239 (lambda (eval-function-lambda eval-fun)))
240 (if lambda
241 (values lambda nil (eval-function-name eval-fun))
242 (let ((fun (c::functional-entry-function
243 (eval-function-definition eval-fun))))
244 (values (c::functional-inline-expansion fun)
245 (if (let ((env (c::functional-lexenv fun)))
246 (or (c::lexenv-functions env)
247 (c::lexenv-variables env)
248 (c::lexenv-blocks env)
249 (c::lexenv-tags env)))
250 t nil)
251 (or (eval-function-name eval-fun)
252 (c::component-name
253 (c::block-component
254 (c::node-block (c::lambda-bind fun))))))))))
255
256
257 ;;; INTERPRETED-FUNCTION-TYPE -- Interface
258 ;;;
259 ;;; Return a FUNCTION-TYPE describing an eval function. We just grab the
260 ;;; LEAF-TYPE of the definition, converting the definition if not currently
261 ;;; cached.
262 ;;;
263 (defvar *already-looking-for-type-of* nil)
264 ;;;
265 (defun interpreted-function-type (fun)
266 (if (member fun *already-looking-for-type-of*)
267 (specifier-type 'function)
268 (let* ((*already-looking-for-type-of*
269 (cons fun *already-looking-for-type-of*))
270 (eval-fun (get-eval-function fun))
271 (def (or (eval-function-definition eval-fun)
272 (system:without-gcing
273 (convert-eval-fun eval-fun)
274 (eval-function-definition eval-fun)))))
275 (c::leaf-type (c::functional-entry-function def)))))
276
277
278 ;;;
279 ;;; INTERPRETED-FUNCTION-{NAME,ARGLIST} -- Interface
280 ;;;
281 (defun interpreted-function-name (x)
282 (multiple-value-bind (ig1 ig2 res)
283 (interpreted-function-lambda-expression x)
284 (declare (ignore ig1 ig2))
285 res))
286 ;;;
287 (defun (setf interpreted-function-name) (val x)
288 (let* ((eval-fun (get-eval-function x))
289 (def (eval-function-definition eval-fun)))
290 (when def
291 (setf (c::leaf-name def) val)
292 (setf (c::leaf-name (c::main-entry (c::functional-entry-function def)))
293 val))
294 (setf (eval-function-name eval-fun) val)))
295 ;;;
296 (defun interpreted-function-arglist (x)
297 (eval-function-arglist (get-eval-function x)))
298 ;;;
299 (defun (setf interpreted-function-arglist) (val x)
300 (setf (eval-function-arglist (get-eval-function x)) val))
301
302
303 ;;; INTERPRETED-FUNCTION-ENVIRONMENT -- Interface
304 ;;;
305 ;;; The environment should be the only SIMPLE-VECTOR in the closure. We
306 ;;; have to throw in the EVAL-FUNCTION-P test, since structure are currently
307 ;;; also SIMPLE-VECTORs.
308 ;;;
309 (defun interpreted-function-closure (x)
310 (system:find-if-in-closure #'(lambda (x)
311 (and (simple-vector-p x)
312 (not (eval-function-p x))))
313 x))
314
315
316 ;;; INTERPRETER-GC-HOOK -- Internal
317 ;;;
318 ;;; Clear the unused portion of the eval stack, and flush the definitions of
319 ;;; all functions in the cache that haven't been used enough.
320 ;;;
321 (defun interpreter-gc-hook ()
322 (let ((len (length (the simple-vector *eval-stack*))))
323 (do ((i *eval-stack-top* (1+ i)))
324 ((= i len))
325 (setf (svref *eval-stack* i) nil)))
326
327 (let ((num (- (length *interpreted-function-cache*)
328 *interpreted-function-cache-minimum-size*)))
329 (when (plusp num)
330 (setq *interpreted-function-cache*
331 (delete-if #'(lambda (x)
332 (when (>= (eval-function-gcs x)
333 *interpreted-function-cache-threshold*)
334 (setf (eval-function-definition x) nil)
335 t))
336 *interpreted-function-cache*
337 :count num))))
338
339 (dolist (fun *interpreted-function-cache*)
340 (incf (eval-function-gcs fun))))
341 ;;;
342 (pushnew 'interpreter-gc-hook ext:*before-gc-hooks*)
343
344
345 ;;; FLUSH-INTERPRETED-FUNCTION-CACHE -- Interface
346 ;;;
347 (defun flush-interpreted-function-cache ()
348 "Clear all entries in the eval function cache. This allows the internal
349 representation of the functions to be reclaimed, and also lazily forces
350 macroexpansions to be recomputed."
351 (dolist (fun *interpreted-function-cache*)
352 (setf (eval-function-definition fun) nil))
353 (setq *interpreted-function-cache* ()))
354
355
356 ;;;; INTERNAL-APPLY-LOOP macros.
357
358 ;;; These macros are intimately related to INTERNAL-APPLY-LOOP. They assume
359 ;;; variables established by this function, and they assume they can return
360 ;;; from a block by that name. This is sleazy, but we justify it as follows:
361 ;;; They are so specialized in use, and their invocation became lengthy, that
362 ;;; we allowed them to slime some access to things in their expanding
363 ;;; environment. These macros don't really extend our Lisp syntax, but they do
364 ;;; provide some template expansion service; it is these cleaner circumstance
365 ;;; that require a more rigid programming style.
366 ;;;
367 ;;; Since these are macros expanded almost solely for c::combination nodes,
368 ;;; they cascade from the end of this logical page to the beginning here.
369 ;;; Therefore, it is best you start looking at them from the end of this
370 ;;; section, backwards from normal scanning mode for Lisp code.
371 ;;;
372
373 ;;; DO-COMBINATION -- Internal.
374 ;;;
375 ;;; This runs a function on some arguments from the stack. If the combination
376 ;;; occurs in a tail recursive position, then we do the call such that we
377 ;;; return from tail-p-function with whatever values the call produces. With a
378 ;;; :local call, we have to restore the stack to its previous frame before
379 ;;; doing the call. The :full call mechanism does this for us. If it is NOT a
380 ;;; tail recursive call, and we're in a multiple value context, then then push
381 ;;; a list of the returned values. Do the same thing if we're in a :return
382 ;;; context. Push a single value, without listifying it, for a :single value
383 ;;; context. Otherwise, just call for side effect.
384 ;;;
385 ;;; Node is the combination node, and cont is its continuation. Frame-ptr
386 ;;; is the current frame pointer, and closure is the current environment for
387 ;;; closure variables. Call-type is either :full or :local, and when it is
388 ;;; local, lambda is the IR1 lambda to apply.
389 ;;;
390 ;;; This assumes the following variables are present: node, cont, frame-ptr,
391 ;;; and closure. It also assumes a block named internal-apply-loop.
392 ;;;
393 (defmacro do-combination (call-type lambda mv-or-normal)
394 (let* ((args (gensym))
395 (calling-closure (gensym))
396 (invoke-fun (ecase mv-or-normal
397 (:mv-call 'mv-internal-invoke)
398 (:normal 'internal-invoke)))
399 (args-form (ecase mv-or-normal
400 (:mv-call
401 `(mv-eval-stack-args
402 (length (c::mv-combination-args node))))
403 (:normal
404 `(eval-stack-args (c:lambda-eval-info-args-passed
405 (c::lambda-info ,lambda))))))
406 (call-form (ecase call-type
407 (:full `(,invoke-fun
408 (length (c::basic-combination-args node))))
409 (:local `(internal-apply
410 ,lambda ,args-form
411 (compute-closure node ,lambda frame-ptr
412 closure)))))
413 (tailp-call-form
414 (ecase call-type
415 (:full `(return-from
416 internal-apply-loop
417 ;; INVOKE-FUN takes care of the stack itself.
418 (,invoke-fun (length (c::basic-combination-args node))
419 frame-ptr)))
420 (:local `(let ((,args ,args-form)
421 (,calling-closure
422 (compute-closure node ,lambda frame-ptr closure)))
423 ;; No need to clean up stack slots for GC due to
424 ;; ext:*before-gc-hook*.
425 (eval-stack-set-top frame-ptr)
426 (return-from
427 internal-apply-loop
428 (internal-apply ,lambda ,args ,calling-closure)))))))
429 `(cond ((c::node-tail-p node)
430 ,tailp-call-form)
431 (t
432 (ecase (c::continuation-info cont)
433 ((:multiple :return)
434 (eval-stack-push (multiple-value-list ,call-form)))
435 (:single
436 (eval-stack-push ,call-form))
437 (:unused ,call-form))))))
438
439 ;;; SET-BLOCK -- Internal.
440 ;;;
441 ;;; This sets the variable block in INTERNAL-APPLY-LOOP, and it announces this
442 ;;; by setting set-block-p for later loop iteration maintenance.
443 ;;;
444 (defmacro set-block (exp)
445 `(progn
446 (setf block ,exp)
447 (setf set-block-p t)))
448
449 ;;; CHANGE-BLOCKS -- Internal.
450 ;;;
451 ;;; This sets all the iteration variables in INTERNAL-APPLY-LOOP to iterate
452 ;;; over a new block's nodes. Block-exp is optional because sometimes we have
453 ;;; already set block, and we only need to bring the others into agreement.
454 ;;; If we already set block, then clear the variable that announces this,
455 ;;; set-block-p.
456 ;;;
457 (defmacro change-blocks (&optional block-exp)
458 `(progn
459 ,(if block-exp
460 `(setf block ,block-exp)
461 `(setf set-block-p nil))
462 (setf node (c::continuation-next (c::block-start block)))
463 (setf last-cont (c::node-cont (c::block-last block)))))
464
465
466 ;;; This controls printing visited nodes in INTERNAL-APPLY-LOOP. We use it
467 ;;; here, and INTERNAL-INVOKE uses it to print function call looking output
468 ;;; to further describe c::combination nodes.
469 ;;;
470 (defvar *internal-apply-node-trace* nil)
471 ;;;
472 (defun maybe-trace-funny-fun (node name &rest args)
473 (when *internal-apply-node-trace*
474 (format t "(~S ~{ ~S~}) c~S~%"
475 name args (c::cont-num (c::node-cont node)))))
476
477
478 ;;; DO-FUNNY-FUNCTION -- Internal.
479 ;;;
480 ;;; This implements the intention of the virtual function name. This is a
481 ;;; macro because some of these actions must occur without a function call.
482 ;;; For example, calling a dispatch function to implement special binding would
483 ;;; be a no-op because returning from that function would cause the system to
484 ;;; undo any special bindings it established.
485 ;;;
486 ;;; NOTE: update C:ANNOTATE-COMPONENT-FOR-EVAL and/or c::undefined-funny-funs
487 ;;; if you add or remove branches in this routine.
488 ;;;
489 ;;; This assumes the following variables are present: node, cont, frame-ptr,
490 ;;; args, closure, block, and last-cont. It also assumes a block named
491 ;;; internal-apply-loop.
492 ;;;
493 (defmacro do-funny-function (funny-fun-name)
494 (let ((name (gensym)))
495 `(let ((,name ,funny-fun-name))
496 (ecase ,name
497 (c::%special-bind
498 (let ((value (eval-stack-pop))
499 (global-var (eval-stack-pop)))
500 (maybe-trace-funny-fun node ,name global-var value)
501 (system:%primitive bind value (c::global-var-name global-var))))
502 (c::%special-unbind
503 ;; Throw away arg telling me which special, and tell the dynamic
504 ;; binding mechanism to unbind one variable.
505 (eval-stack-pop)
506 (maybe-trace-funny-fun node ,name)
507 (system:%primitive unbind))
508 (c::%catch
509 (let* ((tag (eval-stack-pop))
510 (nlx-info (eval-stack-pop))
511 (fell-through-p nil)
512 ;; Ultimately THROW and CATCH will fix the interpreter's stack
513 ;; since this is necessary for compiled CATCH's and those in
514 ;; the initial top level function.
515 (stack-top *eval-stack-top*)
516 (values
517 (multiple-value-list
518 (catch tag
519 (maybe-trace-funny-fun node ,name tag)
520 (multiple-value-setq (block node cont last-cont)
521 (internal-apply-loop (c::continuation-next cont)
522 frame-ptr lambda args closure))
523 (setf fell-through-p t)))))
524 (cond (fell-through-p
525 ;; We got here because we just saw the C::%CATCH-BREAKUP
526 ;; funny function inside the above recursive call to
527 ;; INTERNAL-APPLY-LOOP. Therefore, we just received and
528 ;; stored the current state of evaluation for falling
529 ;; through.
530 )
531 (t
532 ;; Fix up the interpreter's stack after having thrown here.
533 ;; We won't need to do this in the final implementation.
534 (eval-stack-set-top stack-top)
535 ;; Take the values received in the list bound above, and
536 ;; massage them into the form expected by the continuation
537 ;; of the non-local-exit info.
538 (ecase (c::continuation-info
539 (c::nlx-info-continuation nlx-info))
540 (:single
541 (eval-stack-push (car values)))
542 ((:multiple :return)
543 (eval-stack-push values))
544 (:unused))
545 ;; We want to continue with the code after the CATCH body.
546 ;; The non-local-exit info tells us where this is, but we
547 ;; know that block only contains a call to the funny
548 ;; function C::%NLX-ENTRY, which simply is a place holder
549 ;; for the compiler IR1. We want to skip the target block
550 ;; entirely, so we say it is the block we're in now and say
551 ;; the current cont is the last-cont. This makes the COND
552 ;; at the end of INTERNAL-APPLY-LOOP do the right thing.
553 (setf block (c::nlx-info-target nlx-info))
554 (setf cont last-cont)))))
555 (c::%unwind-protect
556 ;; Cleanup function not pushed due to special-case :UNUSED
557 ;; annotation in ANNOTATE-COMPONENT-FOR-EVAL.
558 (let* ((nlx-info (eval-stack-pop))
559 (fell-through-p nil)
560 (stack-top *eval-stack-top*))
561 (unwind-protect
562 (progn
563 (maybe-trace-funny-fun node ,name)
564 (multiple-value-setq (block node cont last-cont)
565 (internal-apply-loop (c::continuation-next cont)
566 frame-ptr lambda args closure))
567 (setf fell-through-p t))
568 (cond (fell-through-p
569 ;; We got here because we just saw the
570 ;; C::%UNWIND-PROTECT-BREAKUP funny function inside the
571 ;; above recursive call to INTERNAL-APPLY-LOOP.
572 ;; Therefore, we just received and stored the current
573 ;; state of evaluation for falling through.
574 )
575 (t
576 ;; Fix up the interpreter's stack after having thrown here.
577 ;; We won't need to do this in the final implementation.
578 (eval-stack-set-top stack-top)
579 ;;
580 ;; Push some bogus values for exit context to keep the
581 ;; MV-BIND in the UNWIND-PROTECT translation happy.
582 (eval-stack-push '(nil nil 0))
583 (let ((node (c::continuation-next
584 (c::block-start
585 (car (c::block-succ
586 (c::nlx-info-target nlx-info)))))))
587 (internal-apply-loop node frame-ptr lambda args
588 closure)))))))
589 ((c::%catch-breakup c::%unwind-protect-breakup c::%continue-unwind)
590 ;; This shows up when we locally exit a CATCH body -- fell through.
591 ;; Return the current state of evaluation to the previous invocation
592 ;; of INTERNAL-APPLY-LOOP which happens to be running in the
593 ;; c::%catch branch of this code.
594 (maybe-trace-funny-fun node ,name)
595 (return-from internal-apply-loop
596 (values block node cont last-cont)))
597 (c::%nlx-entry
598 (maybe-trace-funny-fun node ,name)
599 ;; This just marks a spot in the code for CATCH, UNWIND-PROTECT, and
600 ;; non-local lexical exits (GO or RETURN-FROM).
601 ;; Do nothing since c::%catch does it all when it catches a THROW.
602 ;; Do nothing since c::%unwind-protect does it all when
603 ;; it catches a THROW.
604 )
605 (c::%more-arg-context
606 (let* ((fixed-arg-count (1+ (eval-stack-pop)))
607 ;; Add 1 to actual fixed count for extra arg expected by
608 ;; external entry points (XEP) which some IR1 lambdas have.
609 ;; The extra arg is the number of arguments for arg count
610 ;; consistency checking. C::%MORE-ARG-CONTEXT always runs
611 ;; within an XEP, so the lambda has an extra arg.
612 (more-args (nthcdr fixed-arg-count args)))
613 (maybe-trace-funny-fun node ,name fixed-arg-count)
614 (assert (eq (c::continuation-info cont) :multiple))
615 (eval-stack-push (list more-args (length more-args)))))
616 (c::%unknown-values
617 (error "C::%UNKNOWN-VALUES should never be in interpreter's IR1."))
618 (c::%lexical-exit-breakup
619 ;; We see this whenever we locally exit the extent of a lexical
620 ;; target. That is, we are truly locally exiting an extent we could
621 ;; have non-locally lexically exited. Return the :fell-through flag
622 ;; and the current state of evaluation to the previous invocation
623 ;; of INTERNAL-APPLY-LOOP which happens to be running in the
624 ;; c::entry branch of INTERNAL-APPLY-LOOP.
625 (maybe-trace-funny-fun node ,name)
626 ;;
627 ;; Discard the NLX-INFO arg...
628 (eval-stack-pop)
629 (return-from internal-apply-loop
630 (values :fell-through block node cont last-cont)))))))
631
632
633 ;;; COMBINATION-NODE -- Internal.
634 ;;;
635 ;;; This expands for the two types of combination nodes INTERNAL-APPLY-LOOP
636 ;;; sees. Type is either :mv-call or :normal. Node is the combination node,
637 ;;; and cont is its continuation. Frame-ptr is the current frame pointer, and
638 ;;; closure is the current environment for closure variables.
639 ;;;
640 ;;; Most of the real work is done by DO-COMBINATION. This first determines if
641 ;;; the combination node describes a :full call which DO-COMBINATION directly
642 ;;; handles. If the call is :local, then we either invoke an IR1 lambda, or we
643 ;;; just bind some LET variables. If the call is :local, and type is :mv-call,
644 ;;; then we can only be binding multiple values. Otherwise, the combination
645 ;;; node describes a function known to the compiler, but this may be a funny
646 ;;; function that actually isn't ever defined. We either take some action for
647 ;;; the funny function or do a :full call on the known true function, but the
648 ;;; interpreter doesn't do optimizing stuff for functions known to the
649 ;;; compiler.
650 ;;;
651 ;;; This assumes the following variables are present: node, cont, frame-ptr,
652 ;;; and closure. It also assumes a block named internal-apply-loop.
653 ;;;
654 (defmacro combination-node (type)
655 (let* ((kind (gensym))
656 (fun (gensym))
657 (lambda (gensym))
658 (letp (gensym))
659 (letp-bind (ecase type
660 (:mv-call nil)
661 (:normal
662 `((,letp (eq (c::functional-kind ,lambda) :let))))))
663 (local-branch
664 (ecase type
665 (:mv-call
666 `(store-mv-let-vars ,lambda frame-ptr
667 (length (c::mv-combination-args node))))
668 (:normal
669 `(if ,letp
670 (store-let-vars ,lambda frame-ptr)
671 (do-combination :local ,lambda ,type))))))
672 `(let ((,kind (c::basic-combination-kind node))
673 (,fun (c::basic-combination-fun node)))
674 (cond ((eq ,kind :full)
675 (do-combination :full nil ,type))
676 ((eq ,kind :local)
677 (let* ((,lambda (c::ref-leaf (c::continuation-use ,fun)))
678 ,@letp-bind)
679 ,local-branch))
680 ((eq (c::continuation-info ,fun) :unused)
681 (assert (typep ,kind 'c::function-info))
682 (do-funny-function (c::continuation-function-name ,fun)))
683 (t
684 (assert (typep ,kind 'c::function-info))
685 (do-combination :full nil ,type))))))
686
687
688 (defun trace-eval (on)
689 (setf *eval-stack-trace* on)
690 (setf *internal-apply-node-trace* on))
691
692
693 ;;;; INTERNAL-EVAL:
694
695 (proclaim '(special lisp::*already-evaled-this*))
696
697 ;;; INTERNAL-EVAL -- Interface
698 ;;;
699 ;;; Evaluate an arbitary form. We convert the form, then call internal
700 ;;; apply on it. If *ALREADY-EVALED-THIS* is true, then we bind it to NIL
701 ;;; around the apply to limit the inhibition to the lexical scope of the
702 ;;; EVAL-WHEN.
703 ;;;
704 (defun internal-eval (form &optional quietly)
705 (let ((res (c:compile-for-eval form quietly)))
706 (if lisp::*already-evaled-this*
707 (let ((lisp::*already-evaled-this* nil))
708 (internal-apply res nil '#()))
709 (internal-apply res nil '#()))))
710
711
712 ;;; MAKE-INDIRECT-VALUE-CELL -- Internal.
713 ;;;
714 ;;; Later this will probably be the same weird internal thing the compiler
715 ;;; makes to represent these things.
716 ;;;
717 (defun make-indirect-value-cell (value)
718 (list value))
719 ;;;
720 (defmacro indirect-value (value-cell)
721 `(car ,value-cell))
722
723
724 ;;; VALUE -- Internal.
725 ;;;
726 ;;; This passes on a node's value appropriately, possibly returning from
727 ;;; function to do so. When we are tail-p, don't push the value, return it on
728 ;;; the system's actual call stack; when we blow out of function this way, we
729 ;;; must return the interpreter's stack to the its state before this call to
730 ;;; function. When we're in a multiple value context or heading for a return
731 ;;; node, we push a list of the value for easier handling later. Otherwise,
732 ;;; just push the value on the interpreter's stack.
733 ;;;
734 (defmacro value (node info value frame-ptr function)
735 `(cond ((c::node-tail-p ,node)
736 (eval-stack-set-top ,frame-ptr)
737 (return-from ,function ,value))
738 ((member ,info '(:multiple :return) :test #'eq)
739 (eval-stack-push (list ,value)))
740 (t (assert (eq ,info :single))
741 (eval-stack-push ,value))))))
742
743
744 (defun maybe-trace-nodes (node)
745 (when *internal-apply-node-trace*
746 (format t "<~A-node> c~S~%"
747 (type-of node)
748 (c::cont-num (c::node-cont node)))))
749
750 ;;; INTERNAL-APPLY -- Internal.
751 ;;;
752 ;;; This interprets lambda, a compiler IR1 data structure representing a
753 ;;; function, applying it to args. Closure is the environment in which to run
754 ;;; lambda, the variables and such closed over to form lambda. The call occurs
755 ;;; on the interpreter's stack, so save the current top and extend the stack
756 ;;; for this lambda's call frame. Then store the args into locals on the
757 ;;; stack.
758 ;;;
759 (defun internal-apply (lambda args closure)
760 (let ((frame-ptr *eval-stack-top*))
761 (eval-stack-extend (c:lambda-eval-info-frame-size (c::lambda-info lambda)))
762 (do ((vars (c::lambda-vars lambda) (cdr vars))
763 (args args (cdr args)))
764 ((null vars))
765 ;; Args may run out of values before vars runs out of variables, so
766 ;; just do CAR of nil and store nil.
767 (let ((var (car vars)))
768 (when (c::leaf-refs var)
769 (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
770 (if (c::lambda-var-indirect var)
771 (make-indirect-value-cell (car args))
772 (car args))))))
773 (internal-apply-loop (c::lambda-bind lambda) frame-ptr lambda args closure)))
774
775 ;;; INTERNAL-APPLY-LOOP -- Internal.
776 ;;;
777 ;;; This does the work of INTERNAL-APPLY. This also calls itself recursively
778 ;;; for certain language features, such as CATCH. First is the node at which
779 ;;; to start interpreting. Frame-ptr is the current frame pointer for
780 ;;; accessing local variables. Lambda is the IR1 lambda from which comes the
781 ;;; nodes a given call to this function processes, and closure is the
782 ;;; environment for interpreting lambda. Args is the argument list for the
783 ;;; lambda given to INTERNAL-APPLY, and we have to carry it around with us
784 ;;; in case of more-arg or rest-arg processing which is represented explicitly
785 ;;; in the compiler's IR1.
786 ;;;
787 ;;; Due to having a truly tail recursive interpreter, some of the branches
788 ;;; handling a given node need to RETURN-FROM this routine. Also, some calls
789 ;;; this makes to do work for it must occur in tail recursive positions.
790 ;;; Because of this required access to this function lexical environment and
791 ;;; calling positions, we often are unable to break off logical chunks of code
792 ;;; into functions. We have written macros intended solely for use in this
793 ;;; routine, and due to all the local stuff they need to access and length
794 ;;; complex calls, we have written them to sleazily access locals from this
795 ;;; routine. In addition to assuming a block named internal-apply-loop exists,
796 ;;; they set and reference the following variables: node, cont, frame-ptr,
797 ;;; closure, block, last-cont, and set-block-p.
798 ;;;
799 (defun internal-apply-loop (first frame-ptr lambda args closure)
800 (declare (optimize (debug-info 2)))
801 (let* ((block (c::node-block first))
802 (last-cont (c::node-cont (c::block-last block)))
803 (node first)
804 (set-block-p nil))
805 (loop
806 (let ((cont (c::node-cont node)))
807 (etypecase node
808 (c::ref
809 (maybe-trace-nodes node)
810 (let ((info (c::continuation-info cont)))
811 (unless (eq info :unused)
812 (value node info (leaf-value node frame-ptr closure)
813 frame-ptr internal-apply-loop))))
814 (c::combination
815 (maybe-trace-nodes node)
816 (combination-node :normal))
817 (c::cif
818 (maybe-trace-nodes node)
819 ;; IF nodes always occur at the end of a block, so pick another.
820 (set-block (if (eval-stack-pop)
821 (c::if-consequent node)
822 (c::if-alternative node))))
823 (c::bind
824 (maybe-trace-nodes node)
825 ;; Ignore bind nodes since INTERNAL-APPLY extends the stack for
826 ;; all of a lambda's locals, and the c::combination branch
827 ;; handles LET binds (moving values off stack top into locals).
828 )
829 (c::cset
830 (maybe-trace-nodes node)
831 (let ((info (c::continuation-info cont))
832 (res (set-leaf-value node frame-ptr closure
833 (eval-stack-pop))))
834 (unless (eq info :unused)
835 (value node info res frame-ptr internal-apply-loop))))
836 (c::entry
837 (maybe-trace-nodes node)
838 (let ((info (cdr (assoc node (c:lambda-eval-info-entries
839 (c::lambda-info lambda))))))
840 ;; No info means no-op entry for CATCH or UNWIND-PROTECT.
841 (when info
842 ;; Store stack top for restoration in local exit situation
843 ;; in c::exit branch.
844 (setf (eval-stack-local frame-ptr
845 (c:entry-node-info-st-top info))
846 *eval-stack-top*)
847 (let ((tag (c:entry-node-info-nlx-tag info)))
848 (when tag
849 ;; Non-local lexical exit (someone closed over a
850 ;; GO tag or BLOCK name).
851 (let ((unique-tag (cons nil nil))
852 values)
853 (setf (eval-stack-local frame-ptr tag) unique-tag)
854 (if (eq cont last-cont)
855 (change-blocks (car (c::block-succ block)))
856 (setf node (c::continuation-next cont)))
857 (loop
858 (multiple-value-setq (values block node cont last-cont)
859 (catch unique-tag
860 (internal-apply-loop node frame-ptr
861 lambda args closure)))
862
863 (when (eq values :fell-through)
864 ;; We hit a %LEXICAL-EXIT-BREAKUP.
865 ;; Interpreting state is set with MV-SETQ above.
866 ;; Just get out of this branch and go on.
867 (return))
868
869 (unless (eq values :non-local-go)
870 ;; We know we're non-locally exiting from a
871 ;; BLOCK with values (saw a RETURN-FROM).
872 (ecase (c::continuation-info cont)
873 (:single
874 (eval-stack-push (car values)))
875 ((:multiple :return)
876 (eval-stack-push values))
877 (:unused)))
878 ;;
879 ;; Start interpreting again at the target, skipping
880 ;; the %NLX-ENTRY block.
881 (setf node
882 (c::continuation-next
883 (c::block-start
884 (car (c::block-succ block))))))))))))
885 (c::exit
886 (maybe-trace-nodes node)
887 (let* ((incoming-values (c::exit-value node))
888 (values (if incoming-values (eval-stack-pop))))
889 (cond
890 ((eq (c::lambda-environment lambda)
891 (c::block-environment (c::continuation-block cont)))
892 ;; Local exit.
893 ;; Fixup stack top and massage values for destination.
894 (eval-stack-set-top
895 (eval-stack-local frame-ptr
896 (c:entry-node-info-st-top
897 (cdr (assoc (c::exit-entry node)
898 (c:lambda-eval-info-entries
899 (c::lambda-info lambda)))))))
900 (ecase (c::continuation-info cont)
901 (:single
902 (assert incoming-values)
903 (eval-stack-push (car values)))
904 ((:multiple :return)
905 (assert incoming-values)
906 (eval-stack-push values))
907 (:unused)))
908 (t
909 (let ((info (c::find-nlx-info (c::exit-entry node) cont)))
910 (throw
911 (svref closure
912 (position info
913 (c::environment-closure
914 (c::node-environment node))
915 :test #'eq))
916 (if incoming-values
917 (values values (c::nlx-info-target info) nil cont)
918 (values :non-local-go (c::nlx-info-target info)))))))))
919 (c::creturn
920 (maybe-trace-nodes node)
921 (let ((values (eval-stack-pop)))
922 (eval-stack-set-top frame-ptr)
923 (return-from internal-apply-loop (values-list values))))
924 (c::mv-combination
925 (maybe-trace-nodes node)
926 (combination-node :mv-call)))
927 ;; See function doc below.
928 (reference-this-var-to-keep-it-alive node)
929 (reference-this-var-to-keep-it-alive frame-ptr)
930 (reference-this-var-to-keep-it-alive closure)
931 (cond ((not (eq cont last-cont))
932 (setf node (c::continuation-next cont)))
933 ;; Currently only the last node in a block causes this loop to
934 ;; change blocks, so we never just go to the next node when
935 ;; the current node's branch tried to change blocks.
936 (set-block-p
937 (change-blocks))
938 (t
939 ;; Cif nodes set the block for us, but other last nodes do not.
940 (change-blocks (car (c::block-succ block)))))))
941 (eval-stack-set-top frame-ptr)))
942
943 ;;; REFERENCE-THIS-VAR-TO-KEEP-IT-ALIVE -- Internal.
944 ;;;
945 ;;; This function allows a reference to a variable that the compiler cannot
946 ;;; easily eliminate as unnecessary. We use this at the end of the node
947 ;;; dispatch in INTERNAL-APPLY-LOOP to make sure the node variable has a
948 ;;; valid value. Each node branch tends to reference it at the beginning,
949 ;;; and then there is no reference but a set at the end; the compiler then
950 ;;; kills the variable between the reference in the dispatch branch and when
951 ;;; we set it at the end. The problem is that most error will occur in the
952 ;;; interpreter within one of these node dispatch branches.
953 ;;;
954 (defun reference-this-var-to-keep-it-alive (node)
955 node)
956
957
958 ;;; SET-LEAF-VALUE -- Internal.
959 ;;;
960 ;;; This sets a c::cset node's var to value, returning value. When var is
961 ;;; local, we have to compare its home environment to the current one, node's
962 ;;; environment. If they're the same, we check to see if the var is indirect,
963 ;;; and store the value on the stack or in the value cell as appropriate.
964 ;;; Otherwise, var is a closure variable, and since we're setting it, we know
965 ;;; it's location contains an indirect value object.
966 ;;;
967 (defun set-leaf-value (node frame-ptr closure value)
968 (let ((var (c::set-var node)))
969 (typecase var
970 (c::global-var
971 (setf (symbol-value (c::global-var-name var)) value))
972 (c::lambda-var
973 (set-leaf-value-lambda-var node var frame-ptr closure value)))))
974
975 ;;; SET-LEAF-VALUE-LAMBDA-VAR -- Internal Interface.
976 ;;;
977 ;;; This does SET-LEAF-VALUE for a lambda-var leaf. The debugger tools'
978 ;;; internals uses this also to set interpreted local variables.
979 ;;;
980 (defun set-leaf-value-lambda-var (node var frame-ptr closure value)
981 (let ((env (c::node-environment node)))
982 (cond ((not (eq (c::lambda-environment (c::lambda-var-home var))
983 env))
984 (setf (indirect-value
985 (svref closure
986 (position var (c::environment-closure env)
987 :test #'eq)))
988 value))
989 ((c::lambda-var-indirect var)
990 (setf (indirect-value
991 (eval-stack-local frame-ptr (c::lambda-var-info var)))
992 value))
993 (t
994 (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
995 value)))))
996
997 ;;; LEAF-VALUE -- Internal.
998 ;;;
999 ;;; This figures out how to return a value for a ref node. Leaf is the ref's
1000 ;;; structure that tells us about the value, and it is one of the following
1001 ;;; types:
1002 ;;; constant -- It knows its own value.
1003 ;;; global-var -- It's either a value or function reference. Get it right.
1004 ;;; local-var -- This may on the stack or in the current closure, the
1005 ;;; environment for the lambda INTERNAL-APPLY is currently
1006 ;;; executing. If the leaf's home environment is the same
1007 ;;; as the node's home environment, then the value is on the
1008 ;;; stack, else it's in the closure since it came from another
1009 ;;; environment. Whether the var comes from the stack or the
1010 ;;; closure, it could have come from a closure, and it could
1011 ;;; have been closed over for setting. When this happens, the
1012 ;;; actual value is stored in an indirection object, so
1013 ;;; indirect. See COMPUTE-CLOSURE for the description of
1014 ;;; the structure of the closure argument to this function.
1015 ;;; functional -- This is a reference to an interpreted function that may
1016 ;;; be passed or called anywhere. We return a real function
1017 ;;; that calls INTERNAL-APPLY, closing over the leaf. We also
1018 ;;; have to compute a closure, running environment, for the
1019 ;;; lambda in case it references stuff in the current
1020 ;;; environment. If the closure is empty and there is no
1021 ;;; functional environment, then we use
1022 ;;; MAKE-INTERPRETED-FUNCTION to make a cached translation.
1023 ;;; Since it is too late to lazily convert, we set up the
1024 ;;; EVAL-FUNCTION to be already converted.
1025 ;;;
1026 (defun leaf-value (node frame-ptr closure)
1027 (let ((leaf (c::ref-leaf node)))
1028 (typecase leaf
1029 (c::constant
1030 (c::constant-value leaf))
1031 (c::global-var
1032 (if (eq (c::global-var-kind leaf) :global-function)
1033 (let ((name (c::global-var-name leaf)))
1034 (if (symbolp name)
1035 (symbol-function name)
1036 (fdefinition name)))
1037 (symbol-value (c::global-var-name leaf))))
1038 (c::lambda-var
1039 (leaf-value-lambda-var node leaf frame-ptr closure))
1040 (c::functional
1041 (let* ((calling-closure (compute-closure node leaf frame-ptr closure))
1042 (real-fun (c::functional-entry-function leaf))
1043 (arg-doc (c::functional-arg-documentation real-fun)))
1044 (cond ((c:lambda-eval-info-function (c::leaf-info leaf)))
1045 ((and (zerop (length calling-closure))
1046 (null (c::lexenv-functions
1047 (c::functional-lexenv real-fun))))
1048 (let* ((res (make-interpreted-function
1049 (c::functional-inline-expansion real-fun)))
1050 (eval-fun (get-eval-function res)))
1051 (push eval-fun *interpreted-function-cache*)
1052 (setf (eval-function-definition eval-fun) leaf)
1053 (setf (eval-function-converted-once eval-fun) t)
1054 (setf (eval-function-arglist eval-fun) arg-doc)
1055 (setf (eval-function-name eval-fun) (c::leaf-name real-fun))
1056 (setf (c:lambda-eval-info-function (c::leaf-info leaf)) res)
1057 res))
1058 (t
1059 (let ((eval-fun (make-eval-function
1060 :definition leaf
1061 :name (c::leaf-name real-fun)
1062 :arglist arg-doc)))
1063 #'(lambda (&rest args)
1064 (declare (list args))
1065 (internal-apply (eval-function-definition eval-fun)
1066 (cons (length args) args)
1067 calling-closure))))))))))
1068
1069 ;;; LEAF-VALUE-LAMBDA-VAR -- Internal Interface.
1070 ;;;
1071 ;;; This does LEAF-VALUE for a lambda-var leaf. The debugger tools' internals
1072 ;;; uses this also to reference interpreted local variables.
1073 ;;;
1074 (defun leaf-value-lambda-var (node leaf frame-ptr closure)
1075 (let* ((env (c::node-environment node))
1076 (temp
1077 (if (eq (c::lambda-environment (c::lambda-var-home leaf))
1078 env)
1079 (eval-stack-local frame-ptr (c::lambda-var-info leaf))
1080 (svref closure
1081 (position leaf (c::environment-closure env)
1082 :test #'eq)))))
1083 (if (c::lambda-var-indirect leaf)
1084 (indirect-value temp)
1085 temp)))
1086
1087 ;;; COMPUTE-CLOSURE -- Internal.
1088 ;;;
1089 ;;; This computes a closure for a local call and for returned call'able closure
1090 ;;; objects. Sometimes the closure is a simple-vector of no elements. Node
1091 ;;; is either a reference node or a combination node. Leaf is either the leaf
1092 ;;; of the reference node or the lambda to internally apply for the combination
1093 ;;; node. Frame-ptr is the current frame pointer for fetching current values
1094 ;;; to store in the closure. Closure is the current closure, the currently
1095 ;;; interpreting lambda's closed over environment.
1096 ;;;
1097 ;;; A computed closure is a vector corresponding to the list of closure
1098 ;;; variables described in an environment. The position of a lambda-var in
1099 ;;; this closure list is the index into the closure vector of values.
1100 ;;;
1101 ;;; Functional-env is the environment description for leaf, the lambda for which
1102 ;;; we're computing a closure. This environment describes which of lambda's
1103 ;;; vars we find in lambda's closure when it's running, versus finding them
1104 ;;; on the stack. For each lambda-var in the functional environment's closure
1105 ;;; list, if the lambda-var's home environment is the current environment, then
1106 ;;; get a value off the stack and store it in the closure we're computing.
1107 ;;; Otherwise that lambda-var's value comes from somewhere else, but we have it
1108 ;;; in our current closure, the environment we're running in as we compute this
1109 ;;; new closure. Find this value the same way we do in LEAF-VALUE, by finding
1110 ;;; the lambda-var's position in the current environment's description of the
1111 ;;; current closure.
1112 ;;;
1113 (defun compute-closure (node leaf frame-ptr closure)
1114 (let* ((current-env (c::node-environment node))
1115 (current-closure-vars (c::environment-closure current-env))
1116 (functional-env (c::lambda-environment leaf))
1117 (functional-closure-vars (c::environment-closure functional-env))
1118 (functional-closure (make-array (length functional-closure-vars))))
1119 (do ((vars functional-closure-vars (cdr vars))
1120 (i 0 (1+ i)))
1121 ((null vars))
1122 (let ((ele (car vars)))
1123 (setf (svref functional-closure i)
1124 (etypecase ele
1125 (c::lambda-var
1126 (if (eq (c::lambda-environment (c::lambda-var-home ele))
1127 current-env)
1128 (eval-stack-local frame-ptr (c::lambda-var-info ele))
1129 (svref closure
1130 (position ele current-closure-vars
1131 :test #'eq))))
1132 (c::nlx-info
1133 (if (eq (c::block-environment (c::nlx-info-target ele))
1134 current-env)
1135 (eval-stack-local
1136 frame-ptr
1137 (c:entry-node-info-nlx-tag
1138 (cdr (assoc ;; entry node for non-local extent
1139 (c::cleanup-mess-up (c::nlx-info-cleanup ele))
1140 (c::lambda-eval-info-entries
1141 (c::lambda-info
1142 ;; lambda INTERNAL-APPLY-LOOP tosses around.
1143 (c::environment-function
1144 (c::node-environment node))))))))
1145 (svref closure
1146 (position ele current-closure-vars
1147 :test #'eq))))))))
1148 functional-closure))
1149
1150 ;;; INTERNAL-INVOKE -- Internal.
1151 ;;;
1152 ;;; INTERNAL-APPLY uses this to invoke a function from the interpreter's stack
1153 ;;; on some arguments also taken from the stack. When tail-p is non-nil,
1154 ;;; control does not return to INTERNAL-APPLY to further interpret the current
1155 ;;; IR1 lambda, so INTERNAL-INVOKE must clean up the current interpreter's
1156 ;;; stack frame.
1157 ;;;
1158 (defun internal-invoke (arg-count &optional tailp)
1159 (let ((args (eval-stack-args arg-count)) ;LET says this init form runs first.
1160 (fun (eval-stack-pop)))
1161 (when tailp (eval-stack-set-top tailp))
1162 (when *internal-apply-node-trace*
1163 (format t "(~S~{ ~S~})~%" fun args))
1164 (apply fun args)))
1165
1166 ;;; MV-INTERNAL-INVOKE -- Internal.
1167 ;;;
1168 ;;; Almost just like INTERNAL-INVOKE. We call MV-EVAL-STACK-ARGS, and our
1169 ;;; function is in a list on the stack instead of simply on the stack.
1170 ;;;
1171 (defun mv-internal-invoke (arg-count &optional tailp)
1172 (let ((args (mv-eval-stack-args arg-count)) ;LET runs this init form first.
1173 (fun (car (eval-stack-pop))))
1174 (when tailp (eval-stack-set-top tailp))
1175 (when *internal-apply-node-trace*
1176 (format t "(~S~{ ~S~})~%" fun args))
1177 (apply fun args)))
1178
1179
1180 ;;; EVAL-STACK-ARGS -- Internal.
1181 ;;;
1182 ;;; This returns a list of the top arg-count elements on the interpreter's
1183 ;;; stack. This removes them from the stack.
1184 ;;;
1185 (defun eval-stack-args (arg-count)
1186 (let ((args nil))
1187 (dotimes (i arg-count args)
1188 (push (eval-stack-pop) args))))
1189
1190 ;;; MV-EVAL-STACK-ARGS -- Internal.
1191 ;;;
1192 ;;; This assumes the top count elements on interpreter's stack are lists. This
1193 ;;; returns a single list with all the elements from these lists.
1194 ;;;
1195 (defun mv-eval-stack-args (count)
1196 (if (= count 1)
1197 (eval-stack-pop)
1198 (let ((last (eval-stack-pop)))
1199 (dotimes (i (1- count))
1200 (let ((next (eval-stack-pop)))
1201 (setf last
1202 (if next (nconc next last) last))))
1203 last)))
1204
1205 ;;; STORE-LET-VARS -- Internal.
1206 ;;;
1207 ;;; This stores lambda's vars, stack locals, from values popped off the stack.
1208 ;;; When a var has no references, the compiler computes IR1 such that the
1209 ;;; continuation delivering the value for the unreference var appears unused.
1210 ;;; Because of this, the interpreter drops the value on the floor instead of
1211 ;;; saving it on the stack for binding, so we only pop a value when the var has
1212 ;;; some reference. INTERNAL-APPLY uses this for c::combination nodes
1213 ;;; representing LET's.
1214 ;;;
1215 ;;; When storing the local, if it is indirect, then someone closes over it for
1216 ;;; setting instead of just for referencing. We then store an indirection cell
1217 ;;; with the value, and the referencing code for locals knows how to get the
1218 ;;; actual value.
1219 ;;;
1220 (defun store-let-vars (lambda frame-ptr)
1221 (let* ((vars (c::lambda-vars lambda))
1222 (args (eval-stack-args (count-if #'c::leaf-refs vars))))
1223 (declare (list vars args))
1224 (dolist (v vars)
1225 (when (c::leaf-refs v)
1226 (setf (eval-stack-local frame-ptr (c::lambda-var-info v))
1227 (if (c::lambda-var-indirect v)
1228 (make-indirect-value-cell (pop args))
1229 (pop args)))))))
1230
1231 ;;; STORE-MV-LET-VARS -- Internal.
1232 ;;;
1233 ;;; This is similar to STORE-LET-VARS, but the values for the locals appear on
1234 ;;; the stack in a list due to forms that delivered multiple values to this
1235 ;;; lambda/let. Unlike STORE-LET-VARS, there is no control over the delivery
1236 ;;; of a value for an unreferenced var, so we drop the corresponding value on
1237 ;;; the floor when no one references it. INTERNAL-APPLY uses this for
1238 ;;; c::mv-combination nodes representing LET's.
1239 ;;;
1240 (defun store-mv-let-vars (lambda frame-ptr count)
1241 (assert (= count 1))
1242 (let ((args (eval-stack-pop)))
1243 (dolist (v (c::lambda-vars lambda))
1244 (if (c::leaf-refs v)
1245 (setf (eval-stack-local frame-ptr (c::lambda-var-info v))
1246 (if (c::lambda-var-indirect v)
1247 (make-indirect-value-cell (pop args))
1248 (pop args)))
1249 (pop args)))))
1250
1251 #|
1252 ;;; STORE-MV-LET-VARS -- Internal.
1253 ;;;
1254 ;;; This stores lambda's vars, stack locals, from multiple values stored on the
1255 ;;; top of the stack in a list. Since these values arrived multiply, there is
1256 ;;; no control over the delivery of each value for an unreferenced var, so
1257 ;;; unlike STORE-LET-VARS, we have values for variables never used. We drop
1258 ;;; the value corresponding to an unreferenced var on the floor.
1259 ;;; INTERNAL-APPLY uses this for c::mv-combination nodes representing LET's.
1260 ;;;
1261 ;;; IR1 represents variables bound from multiple values in a list in the
1262 ;;; opposite order of the values list. We use STORE-MV-LET-VARS-AUX to recurse
1263 ;;; down the vars list until we bottom out, storing values on the way back up
1264 ;;; the recursion. You must do this instead of NREVERSE'ing the args list, so
1265 ;;; when we run out of values, we store nil's in the correct lambda-vars.
1266 ;;;
1267 (defun store-mv-let-vars (lambda frame-ptr count)
1268 (assert (= count 1))
1269 (print (c::lambda-vars lambda))
1270 (store-mv-let-vars-aux frame-ptr (c::lambda-vars lambda) (eval-stack-pop)))
1271 ;;;
1272 (defun store-mv-let-vars-aux (frame-ptr vars args)
1273 (if vars
1274 (let ((remaining-args (store-mv-let-vars-aux frame-ptr (cdr vars) args))
1275 (v (car vars)))
1276 (when (c::leaf-refs v)
1277 (setf (eval-stack-local frame-ptr (c::lambda-var-info v))
1278 (if (c::lambda-var-indirect v)
1279 (make-indirect-value-cell (car remaining-args))
1280 (car remaining-args))))
1281 (cdr remaining-args))
1282 args))
1283 |#

  ViewVC Help
Powered by ViewVC 1.1.5