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

Contents of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5