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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5