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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5