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