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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5