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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5