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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5