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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5