src/compiler/eval.lisp

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