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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5