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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11.1.2 - (show annotations) (vendor branch)
Wed Jun 6 14:04:30 1990 UTC (23 years, 10 months ago) by ram
Branch: eval_debug
Changes since 1.11.1.1: +7 -5 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 (push eval-fun *interpreted-function-cache*)
216 new))
217
218
219 ;;; INTERPRETED-FUNCTION-LAMDBA-EXPRESSION -- Interface
220 ;;;
221 ;;; Get the CLAMBDA for the XEP, then look at the inline expansion info in
222 ;;; the real function.
223 ;;;
224 (defun interpreted-function-lambda-expression (x)
225 (let* ((eval-fun (get-eval-function x))
226 (lambda (eval-function-lambda eval-fun)))
227 (if lambda
228 (values lambda nil (eval-function-name eval-fun))
229 (let ((fun (c::functional-entry-function
230 (eval-function-definition eval-fun))))
231 (values (c::functional-inline-expansion fun)
232 (if (let ((env (c::functional-lexenv fun)))
233 (or (c::lexenv-functions env)
234 (c::lexenv-variables env)
235 (c::lexenv-blocks env)
236 (c::lexenv-tags env)))
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 (setf (eval-function-name (get-eval-function x)) val))
254 ;;;
255 (defun interpreted-function-arglist (x)
256 (eval-function-arglist (get-eval-function x)))
257 ;;;
258 (defun (setf interpreted-function-arglist) (x val)
259 (setf (eval-function-arglist (get-eval-function x)) val))
260
261
262 ;;; INTERPRETED-FUNCTION-ENVIRONMENT -- Interface
263 ;;;
264 ;;; The environment should be the only SIMPLE-VECTOR in the closure. We
265 ;;; have to throw in the EVAL-FUNCTION-P test, since structure are currently
266 ;;; also SIMPLE-VECTORs.
267 ;;;
268 (defun interpreted-function-closure (x)
269 (system:find-if-in-closure #'(lambda (x)
270 (and (simple-vector-p x)
271 (not (eval-function-p x))))
272 x))
273
274
275 ;;; INTERPRETER-GC-HOOK -- Internal
276 ;;;
277 ;;; Clear the unused portion of the eval stack, and flush the definitions of
278 ;;; all functions in the cache that haven't been used enough.
279 ;;;
280 (defun interpreter-gc-hook ()
281 (let ((len (length (the simple-vector *eval-stack*))))
282 (do ((i *eval-stack-top* (1+ i)))
283 ((= i len))
284 (setf (svref *eval-stack* i) nil)))
285
286 (let ((num (- (length *interpreted-function-cache*)
287 *interpreted-function-cache-minimum-size*)))
288 (when (plusp num)
289 (setq *interpreted-function-cache*
290 (delete-if #'(lambda (x)
291 (when (>= (eval-function-gcs x)
292 *interpreted-function-cache-threshold*)
293 (setf (eval-function-definition x) nil)
294 t))
295 *interpreted-function-cache*
296 :count num))))
297
298 (dolist (fun *interpreted-function-cache*)
299 (incf (eval-function-gcs fun))))
300 ;;;
301 (pushnew 'interpreter-gc-hook ext:*before-gc-hooks*)
302
303
304
305 ;;;; INTERNAL-APPLY-LOOP macros.
306
307 ;;; These macros are intimately related to INTERNAL-APPLY-LOOP. They assume
308 ;;; variables established by this function, and they assume they can return
309 ;;; from a block by that name. This is sleazy, but we justify it as follows:
310 ;;; They are so specialized in use, and their invocation became lengthy, that
311 ;;; we allowed them to slime some access to things in their expanding
312 ;;; environment. These macros don't really extend our Lisp syntax, but they do
313 ;;; provide some template expansion service; it is these cleaner circumstance
314 ;;; that require a more rigid programming style.
315 ;;;
316 ;;; Since these are macros expanded almost solely for c::combination nodes,
317 ;;; they cascade from the end of this logical page to the beginning here.
318 ;;; Therefore, it is best you start looking at them from the end of this
319 ;;; section, backwards from normal scanning mode for Lisp code.
320 ;;;
321
322 ;;; DO-COMBINATION -- Internal.
323 ;;;
324 ;;; This runs a function on some arguments from the stack. If the combination
325 ;;; occurs in a tail recursive position, then we do the call such that we
326 ;;; return from tail-p-function with whatever values the call produces. With a
327 ;;; :local call, we have to restore the stack to its previous frame before
328 ;;; doing the call. The :full call mechanism does this for us. If it is NOT a
329 ;;; tail recursive call, and we're in a multiple value context, then then push
330 ;;; a list of the returned values. Do the same thing if we're in a :return
331 ;;; context. Push a single value, without listifying it, for a :single value
332 ;;; context. Otherwise, just call for side effect.
333 ;;;
334 ;;; Node is the combination node, and cont is its continuation. Frame-ptr
335 ;;; is the current frame pointer, and closure is the current environment for
336 ;;; closure variables. Call-type is either :full or :local, and when it is
337 ;;; local, lambda is the IR1 lambda to apply.
338 ;;;
339 ;;; This assumes the following variables are present: node, cont, frame-ptr,
340 ;;; and closure. It also assumes a block named internal-apply-loop.
341 ;;;
342 (defmacro do-combination (call-type lambda mv-or-normal)
343 (let* ((args (gensym))
344 (calling-closure (gensym))
345 (invoke-fun (ecase mv-or-normal
346 (:mv-call 'mv-internal-invoke)
347 (:normal 'internal-invoke)))
348 (args-form (ecase mv-or-normal
349 (:mv-call
350 `(mv-eval-stack-args
351 (length (c::mv-combination-args node))))
352 (:normal
353 `(eval-stack-args (c:lambda-eval-info-args-passed
354 (c::lambda-info ,lambda))))))
355 (call-form (ecase call-type
356 (:full `(,invoke-fun
357 (length (c::basic-combination-args node))))
358 (:local `(internal-apply
359 ,lambda ,args-form
360 (compute-closure node ,lambda frame-ptr
361 closure)))))
362 (tailp-call-form
363 (ecase call-type
364 (:full `(return-from
365 internal-apply-loop
366 ;; INVOKE-FUN takes care of the stack itself.
367 (,invoke-fun (length (c::basic-combination-args node))
368 frame-ptr)))
369 (:local `(let ((,args ,args-form)
370 (,calling-closure
371 (compute-closure node ,lambda frame-ptr closure)))
372 ;; No need to clean up stack slots for GC due to
373 ;; ext:*before-gc-hook*.
374 (eval-stack-set-top frame-ptr)
375 (return-from
376 internal-apply-loop
377 (internal-apply ,lambda ,args ,calling-closure)))))))
378 `(cond ((c::node-tail-p node)
379 ,tailp-call-form)
380 (t
381 (ecase (c::continuation-info cont)
382 ((:multiple :return)
383 (eval-stack-push (multiple-value-list ,call-form)))
384 (:single
385 (eval-stack-push ,call-form))
386 (:unused ,call-form))))))
387
388 ;;; SET-BLOCK -- Internal.
389 ;;;
390 ;;; This sets the variable block in INTERNAL-APPLY-LOOP, and it announces this
391 ;;; by setting set-block-p for later loop iteration maintenance.
392 ;;;
393 (defmacro set-block (exp)
394 `(progn
395 (setf block ,exp)
396 (setf set-block-p t)))
397
398 ;;; CHANGE-BLOCKS -- Internal.
399 ;;;
400 ;;; This sets all the iteration variables in INTERNAL-APPLY-LOOP to iterate
401 ;;; over a new block's nodes. Block-exp is optional because sometimes we have
402 ;;; already set block, and we only need to bring the others into agreement.
403 ;;; If we already set block, then clear the variable that announces this,
404 ;;; set-block-p.
405 ;;;
406 (defmacro change-blocks (&optional block-exp)
407 `(progn
408 ,(if block-exp
409 `(setf block ,block-exp)
410 `(setf set-block-p nil))
411 (setf node (c::continuation-next (c::block-start block)))
412 (setf last-cont (c::node-cont (c::block-last block)))))
413
414
415 ;;; This controls printing visited nodes in INTERNAL-APPLY-LOOP. We use it
416 ;;; here, and INTERNAL-INVOKE uses it to print function call looking output
417 ;;; to further describe c::combination nodes.
418 ;;;
419 (defvar *internal-apply-node-trace* nil)
420 ;;;
421 (defun maybe-trace-funny-fun (node name &rest args)
422 (when *internal-apply-node-trace*
423 (format t "(~S ~{ ~S~}) c~S~%"
424 name args (c::cont-num (c::node-cont node)))))
425
426
427 ;;; DO-FUNNY-FUNCTION -- Internal.
428 ;;;
429 ;;; This implements the intention of the virtual function name. This is a
430 ;;; macro because some of these actions must occur without a function call.
431 ;;; For example, calling a dispatch function to implement special binding would
432 ;;; be a no-op because returning from that function would cause the system to
433 ;;; undo any special bindings it established.
434 ;;;
435 ;;; NOTE: update C:ANNOTATE-COMPONENT-FOR-EVAL and/or c::undefined-funny-funs
436 ;;; if you add or remove branches in this routine.
437 ;;;
438 ;;; This assumes the following variables are present: node, cont, frame-ptr,
439 ;;; args, closure, block, and last-cont. It also assumes a block named
440 ;;; internal-apply-loop.
441 ;;;
442 (defmacro do-funny-function (funny-fun-name)
443 (let ((name (gensym)))
444 `(let ((,name ,funny-fun-name))
445 (ecase ,name
446 (c::%special-bind
447 (let ((value (eval-stack-pop))
448 (global-var (eval-stack-pop)))
449 (maybe-trace-funny-fun node ,name global-var value)
450 (system:%primitive bind value (c::global-var-name global-var))))
451 (c::%special-unbind
452 ;; Throw away arg telling me which special, and tell the dynamic
453 ;; binding mechanism to unbind one variable.
454 (eval-stack-pop)
455 (maybe-trace-funny-fun node ,name)
456 (system:%primitive unbind 1))
457 (c::%catch
458 (let* ((tag (eval-stack-pop))
459 (nlx-info (eval-stack-pop))
460 (fell-through-p nil)
461 ;; Ultimately THROW and CATCH will fix the interpreter's stack
462 ;; since this is necessary for compiled CATCH's and those in
463 ;; the initial top level function.
464 (stack-top *eval-stack-top*)
465 (values
466 (multiple-value-list
467 (catch tag
468 (maybe-trace-funny-fun node ,name tag)
469 (multiple-value-setq (block node cont last-cont)
470 (internal-apply-loop (c::continuation-next cont)
471 frame-ptr lambda args closure))
472 (setf fell-through-p t)))))
473 (cond (fell-through-p
474 ;; We got here because we just saw the C::%CATCH-BREAKUP
475 ;; funny function inside the above recursive call to
476 ;; INTERNAL-APPLY-LOOP. Therefore, we just received and
477 ;; stored the current state of evaluation for falling
478 ;; through.
479 )
480 (t
481 ;; Fix up the interpreter's stack after having thrown here.
482 ;; We won't need to do this in the final implementation.
483 (eval-stack-set-top stack-top)
484 ;; Take the values received in the list bound above, and
485 ;; massage them into the form expected by the continuation
486 ;; of the non-local-exit info.
487 (ecase (c::continuation-info
488 (c::nlx-info-continuation nlx-info))
489 (:single
490 (eval-stack-push (car values)))
491 ((:multiple :return)
492 (eval-stack-push values))
493 (:unused))
494 ;; We want to continue with the code after the CATCH body.
495 ;; The non-local-exit info tells us where this is, but we
496 ;; know that block only contains a call to the funny
497 ;; function C::%NLX-ENTRY, which simply is a place holder
498 ;; for the compiler IR1. We want to skip the target block
499 ;; entirely, so we say it is the block we're in now and say
500 ;; the current cont is the last-cont. This makes the COND
501 ;; at the end of INTERNAL-APPLY-LOOP do the right thing.
502 (setf block (c::nlx-info-target nlx-info))
503 (setf cont last-cont)))))
504 (c::%unwind-protect
505 ;; Cleanup function not pushed due to special-case :UNUSED
506 ;; annotation in ANNOTATE-COMPONENT-FOR-EVAL.
507 (let* ((nlx-info (eval-stack-pop))
508 (fell-through-p nil)
509 (stack-top *eval-stack-top*))
510 (unwind-protect
511 (progn
512 (maybe-trace-funny-fun node ,name)
513 (multiple-value-setq (block node cont last-cont)
514 (internal-apply-loop (c::continuation-next cont)
515 frame-ptr lambda args closure))
516 (setf fell-through-p t))
517 (cond (fell-through-p
518 ;; We got here because we just saw the
519 ;; C::%UNWIND-PROTECT-BREAKUP funny function inside the
520 ;; above recursive call to INTERNAL-APPLY-LOOP.
521 ;; Therefore, we just received and stored the current
522 ;; state of evaluation for falling through.
523 )
524 (t
525 ;; Fix up the interpreter's stack after having thrown here.
526 ;; We won't need to do this in the final implementation.
527 (eval-stack-set-top stack-top)
528 ;;
529 ;; Push some bogus values for exit context to keep the
530 ;; MV-BIND in the UNWIND-PROTECT translation happy.
531 (eval-stack-push '(nil nil 0))
532 (let ((node (c::continuation-next
533 (c::block-start
534 (car (c::block-succ
535 (c::nlx-info-target nlx-info)))))))
536 (internal-apply-loop node frame-ptr lambda args
537 closure)))))))
538 ((c::%catch-breakup c::%unwind-protect-breakup c::%continue-unwind)
539 ;; This shows up when we locally exit a CATCH body -- fell through.
540 ;; Return the current state of evaluation to the previous invocation
541 ;; of INTERNAL-APPLY-LOOP which happens to be running in the
542 ;; c::%catch branch of this code.
543 (maybe-trace-funny-fun node ,name)
544 (return-from internal-apply-loop
545 (values block node cont last-cont)))
546 (c::%nlx-entry
547 (maybe-trace-funny-fun node ,name)
548 ;; This just marks a spot in the code for CATCH, UNWIND-PROTECT, and
549 ;; non-local lexical exits (GO or RETURN-FROM).
550 ;; Do nothing since c::%catch does it all when it catches a THROW.
551 ;; Do nothing since c::%unwind-protect does it all when
552 ;; it catches a THROW.
553 )
554 (c::%more-arg-context
555 (let* ((fixed-arg-count (1+ (eval-stack-pop)))
556 ;; Add 1 to actual fixed count for extra arg expected by
557 ;; external entry points (XEP) which some IR1 lambdas have.
558 ;; The extra arg is the number of arguments for arg count
559 ;; consistency checking. C::%MORE-ARG-CONTEXT always runs
560 ;; within an XEP, so the lambda has an extra arg.
561 (more-args (nthcdr fixed-arg-count args)))
562 (maybe-trace-funny-fun node ,name fixed-arg-count)
563 (assert (eq (c::continuation-info cont) :multiple))
564 (eval-stack-push (list more-args (length more-args)))))
565 (c::%unknown-values
566 (error "C::%UNKNOWN-VALUES should never be in interpreter's IR1."))
567 (c::%lexical-exit-breakup
568 ;; We see this whenever we locally exit the extent of a lexical
569 ;; target. That is, we are truly locally exiting an extent we could
570 ;; have non-locally lexically exited. Return the :fell-through flag
571 ;; and the current state of evaluation to the previous invocation
572 ;; of INTERNAL-APPLY-LOOP which happens to be running in the
573 ;; c::entry branch of INTERNAL-APPLY-LOOP.
574 (maybe-trace-funny-fun node ,name)
575 (return-from internal-apply-loop
576 (values :fell-through block node cont last-cont)))))))
577
578
579 ;;; COMBINATION-NODE -- Internal.
580 ;;;
581 ;;; This expands for the two types of combination nodes INTERNAL-APPLY-LOOP
582 ;;; sees. Type is either :mv-call or :normal. Node is the combination node,
583 ;;; and cont is its continuation. Frame-ptr is the current frame pointer, and
584 ;;; closure is the current environment for closure variables.
585 ;;;
586 ;;; Most of the real work is done by DO-COMBINATION. This first determines if
587 ;;; the combination node describes a :full call which DO-COMBINATION directly
588 ;;; handles. If the call is :local, then we either invoke an IR1 lambda, or we
589 ;;; just bind some LET variables. If the call is :local, and type is :mv-call,
590 ;;; then we can only be binding multiple values. Otherwise, the combination
591 ;;; node describes a function known to the compiler, but this may be a funny
592 ;;; function that actually isn't ever defined. We either take some action for
593 ;;; the funny function or do a :full call on the known true function, but the
594 ;;; interpreter doesn't do optimizing stuff for functions known to the
595 ;;; compiler.
596 ;;;
597 ;;; This assumes the following variables are present: node, cont, frame-ptr,
598 ;;; and closure. It also assumes a block named internal-apply-loop.
599 ;;;
600 (defmacro combination-node (type)
601 (let* ((kind (gensym))
602 (fun (gensym))
603 (lambda (gensym))
604 (letp (gensym))
605 (letp-bind (ecase type
606 (:mv-call nil)
607 (:normal
608 `((,letp (eq (c::functional-kind ,lambda) :let))))))
609 (local-branch
610 (ecase type
611 (:mv-call
612 `(store-mv-let-vars ,lambda frame-ptr
613 (length (c::mv-combination-args node))))
614 (:normal
615 `(if ,letp
616 (store-let-vars ,lambda frame-ptr)
617 (do-combination :local ,lambda ,type))))))
618 `(let ((,kind (c::basic-combination-kind node))
619 (,fun (c::basic-combination-fun node)))
620 (cond ((eq ,kind :full)
621 (do-combination :full nil ,type))
622 ((eq ,kind :local)
623 (let* ((,lambda (c::ref-leaf (c::continuation-use ,fun)))
624 ,@letp-bind)
625 ,local-branch))
626 ((eq (c::continuation-info ,fun) :unused)
627 (assert (typep ,kind 'c::function-info))
628 (do-funny-function (c::continuation-function-name ,fun)))
629 (t
630 (assert (typep ,kind 'c::function-info))
631 (do-combination :full nil ,type))))))
632
633
634 (defun trace-eval (on)
635 (setf *eval-stack-trace* on)
636 (setf *internal-apply-node-trace* on))
637
638
639 ;;;; INTERNAL-EVAL:
640
641 (proclaim '(special lisp::*already-evaled-this*))
642
643 ;;; INTERNAL-EVAL -- Interface
644 ;;;
645 ;;; Evaluate an arbitary form. We convert the form, then call internal
646 ;;; apply on it. If *ALREADY-EVALED-THIS* is true, then we bind it to NIL
647 ;;; around the apply to limit the inhibition to the lexical scope of the
648 ;;; EVAL-WHEN.
649 ;;;
650 (defun internal-eval (form &optional quietly)
651 (let ((res (c:compile-for-eval form quietly)))
652 (if lisp::*already-evaled-this*
653 (let ((lisp::*already-evaled-this* nil))
654 (internal-apply res nil nil))
655 (internal-apply res nil nil))))
656
657
658 ;;; MAKE-INDIRECT-VALUE-CELL -- Internal.
659 ;;;
660 ;;; Later this will probably be the same weird internal thing the compiler
661 ;;; makes to represent these things.
662 ;;;
663 (defun make-indirect-value-cell (value)
664 (list value))
665 ;;;
666 (defmacro indirect-value (value-cell)
667 `(car ,value-cell))
668
669
670 ;;; VALUE -- Internal.
671 ;;;
672 ;;; This passes on a node's value appropriately, possibly returning from
673 ;;; function to do so. When we are tail-p, don't push the value, return it on
674 ;;; the system's actual call stack; when we blow out of function this way, we
675 ;;; must return the interpreter's stack to the its state before this call to
676 ;;; function. When we're in a multiple value context or heading for a return
677 ;;; node, we push a list of the value for easier handling later. Otherwise,
678 ;;; just push the value on the interpreter's stack.
679 ;;;
680 (defmacro value (node info value frame-ptr function)
681 `(cond ((c::node-tail-p ,node)
682 (eval-stack-set-top ,frame-ptr)
683 (return-from ,function ,value))
684 ((member ,info '(:multiple :return) :test #'eq)
685 (eval-stack-push (list ,value)))
686 (t (assert (eq ,info :single))
687 (eval-stack-push ,value))))))
688
689
690 (defun maybe-trace-nodes (node)
691 (when *internal-apply-node-trace*
692 (format t "<~A-node> c~S~%"
693 (type-of node)
694 (c::cont-num (c::node-cont node)))))
695
696 ;;; INTERNAL-APPLY -- Internal.
697 ;;;
698 ;;; This interprets lambda, a compiler IR1 data structure representing a
699 ;;; function, applying it to args. Closure is the environment in which to run
700 ;;; lambda, the variables and such closed over to form lambda. The call occurs
701 ;;; on the interpreter's stack, so save the current top and extend the stack
702 ;;; for this lambda's call frame. Then store the args into locals on the
703 ;;; stack.
704 ;;;
705 (defun internal-apply (lambda args closure)
706 (let ((frame-ptr *eval-stack-top*))
707 (eval-stack-extend (c:lambda-eval-info-frame-size (c::lambda-info lambda)))
708 (do ((vars (c::lambda-vars lambda) (cdr vars))
709 (args args (cdr args)))
710 ((null vars))
711 ;; Args may run out of values before vars runs out of variables, so
712 ;; just do CAR of nil and store nil.
713 (let ((var (car vars)))
714 (when (c::leaf-refs var)
715 (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
716 (if (c::lambda-var-indirect var)
717 (make-indirect-value-cell (car args))
718 (car args))))))
719 (internal-apply-loop (c::lambda-bind lambda) frame-ptr lambda args closure)))
720
721 ;;; INTERNAL-APPLY-LOOP -- Internal.
722 ;;;
723 ;;; This does the work of INTERNAL-APPLY. This also calls itself recursively
724 ;;; for certain language features, such as CATCH. First is the node at which
725 ;;; to start interpreting. Frame-ptr is the current frame pointer for
726 ;;; accessing local variables. Lambda is the IR1 lambda from which comes the
727 ;;; nodes a given call to this function processes, and closure is the
728 ;;; environment for interpreting lambda. Args is the argument list for the
729 ;;; lambda given to INTERNAL-APPLY, and we have to carry it around with us
730 ;;; in case of more-arg or rest-arg processing which is represented explicitly
731 ;;; in the compiler's IR1.
732 ;;;
733 ;;; Due to having a truly tail recursive interpreter, some of the branches
734 ;;; handling a given node need to RETURN-FROM this routine. Also, some calls
735 ;;; this makes to do work for it must occur in tail recursive positions.
736 ;;; Because of this required access to this function lexical environment and
737 ;;; calling positions, we often are unable to break off logical chunks of code
738 ;;; into functions. We have written macros intended solely for use in this
739 ;;; routine, and due to all the local stuff they need to access and length
740 ;;; complex calls, we have written them to sleazily access locals from this
741 ;;; routine. In addition to assuming a block named internal-apply-loop exists,
742 ;;; they set and reference the following variables: node, cont, frame-ptr,
743 ;;; closure, block, last-cont, and set-block-p.
744 ;;;
745 (defun internal-apply-loop (first frame-ptr lambda args closure)
746 (let* ((block (c::node-block first))
747 (last-cont (c::node-cont (c::block-last block)))
748 (node first)
749 (set-block-p nil))
750 (loop
751 (let ((cont (c::node-cont node)))
752 (etypecase node
753 (c::ref
754 (maybe-trace-nodes node)
755 (let ((info (c::continuation-info cont)))
756 (unless (eq info :unused)
757 (value node info (leaf-value node frame-ptr closure)
758 frame-ptr internal-apply-loop))))
759 (c::combination
760 (maybe-trace-nodes node)
761 (combination-node :normal))
762 (c::cif
763 (maybe-trace-nodes node)
764 ;; IF nodes always occur at the end of a block, so pick another.
765 (set-block (if (eval-stack-pop)
766 (c::if-consequent node)
767 (c::if-alternative node))))
768 (c::bind
769 (maybe-trace-nodes node)
770 ;; Ignore bind nodes since INTERNAL-APPLY extends the stack for
771 ;; all of a lambda's locals, and the c::combination branch
772 ;; handles LET binds (moving values off stack top into locals).
773 )
774 (c::cset
775 (maybe-trace-nodes node)
776 (let ((info (c::continuation-info cont))
777 (res (set-leaf-value node frame-ptr closure
778 (eval-stack-pop))))
779 (unless (eq info :unused)
780 (value node info res frame-ptr internal-apply-loop))))
781 (c::entry
782 (maybe-trace-nodes node)
783 (let ((info (cdr (assoc node (c:lambda-eval-info-entries
784 (c::lambda-info lambda))))))
785 ;; No info means no-op entry for CATCH or UNWIND-PROTECT.
786 (when info
787 ;; Store stack top for restoration in local exit situation
788 ;; in c::exit branch.
789 (setf (eval-stack-local frame-ptr
790 (c:entry-node-info-st-top info))
791 *eval-stack-top*)
792 (let ((tag (c:entry-node-info-nlx-tag info)))
793 (when tag
794 ;; Non-local lexical exit (someone closed over a
795 ;; GO tag or BLOCK name).
796 (let ((unique-tag (cons nil nil))
797 ;; Ultimately CATCH will handle the stack top
798 ;; cleanup.
799 (stack-top *eval-stack-top*)
800 values)
801 (setf (eval-stack-local frame-ptr tag) unique-tag)
802 (if (eq cont last-cont)
803 (change-blocks (car (c::block-succ block)))
804 (setf node (c::continuation-next cont)))
805 (loop
806 (multiple-value-setq (values block node cont last-cont)
807 (catch unique-tag
808 (internal-apply-loop node frame-ptr
809 lambda args closure)))
810 (cond ((eq values :fell-through)
811 ;; Interpreting state is set with MV-SETQ above.
812 ;; Just get out of this branch and go on.
813 (return))
814 ((eq values :non-local-go)
815 ;; Ultimately do nothing here since CATCH would
816 ;; have cleaned up the stack for us.
817 (eval-stack-set-top stack-top)
818 (setf node (c::continuation-next
819 (car (c::block-succ block)))))
820 (t
821 ;; We know we're non-locally exiting from a
822 ;; BLOCK with values (saw a RETURN-FROM).
823 ;;
824 ;; Ultimately do nothing here since CATCH would
825 ;; have cleaned up the stack for us.
826 (eval-stack-set-top stack-top)
827 (ecase (c::continuation-info cont)
828 (:single
829 (eval-stack-push (car values)))
830 ((:multiple :return)
831 (eval-stack-push values))
832 (:unused))
833 (setf cont last-cont)
834 (return))))))))))
835 (c::exit
836 (maybe-trace-nodes node)
837 (let* ((incoming-values (c::exit-value node))
838 (values (if incoming-values (eval-stack-pop))))
839 (cond
840 ((eq (c::lambda-environment lambda)
841 (c::lambda-environment
842 (c::block-lambda
843 (c::continuation-block cont))))
844 ;; Local exit.
845 ;; Fixup stack top and massage values for destination.
846 (eval-stack-set-top
847 (eval-stack-local frame-ptr
848 (c:entry-node-info-st-top
849 (cdr (assoc (c::exit-entry node)
850 (c:lambda-eval-info-entries
851 (c::lambda-info lambda)))))))
852 (ecase (c::continuation-info cont)
853 (:single
854 (assert incoming-values)
855 (eval-stack-push (car values)))
856 ((:multiple :return)
857 (assert incoming-values)
858 (eval-stack-push values))
859 (:unused)))
860 (t
861 (let ((info (c::find-nlx-info (c::exit-entry node) cont)))
862 (throw
863 (svref closure
864 (position info
865 (c::environment-closure
866 (c::node-environment node))
867 :test #'eq))
868 (if incoming-values
869 (values values (c::nlx-info-target info) nil cont)
870 (values :non-local-go (c::nlx-info-target info)))))))))
871 (c::creturn
872 (maybe-trace-nodes node)
873 (let ((values (eval-stack-pop)))
874 (eval-stack-set-top frame-ptr)
875 (return-from internal-apply-loop (values-list values))))
876 (c::mv-combination
877 (maybe-trace-nodes node)
878 (combination-node :mv-call)))
879 (cond ((not (eq cont last-cont))
880 (setf node (c::continuation-next cont)))
881 ;; Currently only the last node in a block causes this loop to
882 ;; change blocks, so we never just go to the next node when
883 ;; the current node's branch tried to change blocks.
884 (set-block-p
885 (change-blocks))
886 (t
887 ;; Cif nodes set the block for us, but other last nodes do not.
888 (change-blocks (car (c::block-succ block)))))))
889 (eval-stack-set-top frame-ptr)))
890
891
892 ;;; SET-LEAF-VALUE -- Internal.
893 ;;;
894 ;;; This sets a c::cset node's var to value, returning value. When var is
895 ;;; local, we have to compare its home environment to the current one, node's
896 ;;; environment. If they're the same, we check to see if the var is indirect,
897 ;;; and store the value on the stack or in the value cell as appropriate.
898 ;;; Otherwise, var is a closure variable, and since we're setting it, we know
899 ;;; it's location contains an indirect value object.
900 ;;;
901 (defun set-leaf-value (node frame-ptr closure value)
902 (let ((var (c::set-var node)))
903 (typecase var
904 (c::global-var
905 (setf (symbol-value (c::global-var-name var)) value))
906 (c::lambda-var
907 (let ((env (c::node-environment node)))
908 (cond
909 ((not (eq (c::lambda-environment (c::lambda-var-home var))
910 env))
911 (setf (indirect-value
912 (svref closure
913 (position var (c::environment-closure env)
914 :test #'eq)))
915 value))
916 ((c::lambda-var-indirect var)
917 (setf (indirect-value
918 (eval-stack-local frame-ptr (c::lambda-var-info var)))
919 value))
920 (t
921 (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
922 value))))))))
923
924
925 ;;; LEAF-VALUE -- Internal.
926 ;;;
927 ;;; This figures out how to return a value for a ref node. Leaf is the ref's
928 ;;; structure that tells us about the value, and it is one of the following
929 ;;; types:
930 ;;; constant -- It knows its own value.
931 ;;; global-var -- It's either a value or function reference. Get it right.
932 ;;; local-var -- This may on the stack or in the current closure, the
933 ;;; environment for the lambda INTERNAL-APPLY is currently
934 ;;; executing. If the leaf's home environment is the same
935 ;;; as the node's home environment, then the value is on the
936 ;;; stack, else it's in the closure since it came from another
937 ;;; environment. Whether the var comes from the stack or the
938 ;;; closure, it could have come from a closure, and it could
939 ;;; have been closed over for setting. When this happens, the
940 ;;; actual value is stored in an indirection object, so
941 ;;; indirect. See COMPUTE-CLOSURE for the description of
942 ;;; the structure of the closure argument to this function.
943 ;;; functional -- This is a reference to an interpreted function that may
944 ;;; be passed or called anywhere. We return a real function
945 ;;; that calls INTERNAL-APPLY, closing over the leaf. We also
946 ;;; have to compute a closure, running environment, for the
947 ;;; lambda in case it references stuff in the current
948 ;;; environment. If the closure is empty and there is no
949 ;;; functional environment, then we use
950 ;;; MAKE-INTERPRETED-FUNCTION to make a cached translation.
951 ;;; Since it is too late to lazily convert, we set up the
952 ;;; EVAL-FUNCTION to be already converted.
953 ;;;
954 (defun leaf-value (node frame-ptr closure)
955 (let ((leaf (c::ref-leaf node)))
956 (typecase leaf
957 (c::constant
958 (c::constant-value leaf))
959 (c::global-var
960 (if (eq (c::global-var-kind leaf) :global-function)
961 (let ((name (c::global-var-name leaf)))
962 (if (symbolp name)
963 (symbol-function name)
964 (fdefinition name)))
965 (symbol-value (c::global-var-name leaf))))
966 (c::lambda-var
967 (let* ((env (c::node-environment node))
968 (temp
969 (if (eq (c::lambda-environment (c::lambda-var-home leaf))
970 env)
971 (eval-stack-local frame-ptr (c::lambda-var-info leaf))
972 (svref closure
973 (position leaf (c::environment-closure env)
974 :test #'eq)))))
975 (if (c::lambda-var-indirect leaf)
976 (indirect-value temp)
977 temp)))
978 (c::functional
979 (let* ((calling-closure (compute-closure node leaf frame-ptr closure))
980 (real-fun (c::functional-entry-function leaf))
981 (arg-doc (c::functional-arg-documentation real-fun)))
982 (cond ((c:lambda-eval-info-function (c::leaf-info leaf)))
983 ((and (zerop (length calling-closure))
984 (null (c::lexenv-functions
985 (c::functional-lexenv 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