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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5