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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5