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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5