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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (show annotations)
Sat Feb 8 17:24:47 1997 UTC (17 years, 2 months ago) by pw
Branch: MAIN
Changes since 1.29: +57 -113 lines
From: Douglas Thomas Crosher  <dtc@scrooge.ee.swin.oz.au>
Message-Id: <199702041630.DAA06602@scrooge.ee.swin.oz.au>
Subject: Re: making eval-functions FINs
To: cmucl-imp@cons.org
Date: Wed, 5 Feb 1997 03:30:55 +1100 (EST)
In-Reply-To: <199702040300.EAA16744@knight.cons.org> from "Rob MacLachlan" at Feb 3, 97 09:59:02 pm
X-Mailer: ELM [version 2.4 PL24]
Content-Type: text


> I seem to have lost the most recent message about fixing compiler/eval to
> use FINs instead of closures.  But yes, I would think that the current
> EVAL-FUNCTION  slots should become slots in the interpreted function FIN.
> GET-EVAL-FUN when would then become IDENTITY, so it should probably be
> flushed entirely.

Done; moved eval-function data into the interpreted-function FIN, also
added a closure slot so describe can access it easily. Revised patches
below.

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

  ViewVC Help
Powered by ViewVC 1.1.5