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

Diff of /src/compiler/eval.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.11.3.2 by wlott, Wed Aug 15 17:58:04 1990 UTC revision 1.39 by rtoy, Tue Apr 20 17:57:46 2010 UTC
# Line 1  Line 1 
1  ;;; -*- Package: eval; Log: C.Log -*-  ;;; -*- Package: eval; Log: C.Log -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the Spice Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
5  ;;; Carnegie-Mellon University, and has been placed in the public domain.  ;;; Carnegie Mellon University, and has been placed in the public domain.
6  ;;; If you want to use this code or any part of Spice Lisp, please contact  ;;;
7  ;;; Scott Fahlman (FAHLMAN@CMUC).  (ext:file-comment
8      "$Header$")
9    ;;;
10  ;;; **********************************************************************  ;;; **********************************************************************
11  ;;;  ;;;
 ;;; $Header$  
 ;;;  
12  ;;; This file contains the interpreter.  We first convert to the compiler's  ;;; This file contains the interpreter.  We first convert to the compiler's
13  ;;; IR1 and interpret that.  ;;; IR1 and interpret that.
14  ;;;  ;;;
15  ;;; Written by Bill Chiles.  ;;; Written by Rob MacLachlan and Bill Chiles.
16  ;;;  ;;;
17    
18  (in-package "EVAL")  (in-package "EVAL")
19    (intl:textdomain "cmucl")
20    
21  (export '(internal-eval *eval-stack-trace* *internal-apply-node-trace*  (export '(internal-eval *eval-stack-trace* *internal-apply-node-trace*
22                          *interpreted-function-cache-minimum-size*                          *interpreted-function-cache-minimum-size*
23                          *interpreted-function-cache-threshold*                          *interpreted-function-cache-threshold*
24                            flush-interpreted-function-cache
25                          trace-eval interpreted-function-p                          trace-eval interpreted-function-p
26                          interpreted-function-lambda-expression                          interpreted-function-lambda-expression
27                          interpreted-function-closure                          interpreted-function-closure
28                          interpreted-function-name                          interpreted-function-name
29                          interpreted-function-arglist                          interpreted-function-arglist
30                            interpreted-function-type
31                          make-interpreted-function))                          make-interpreted-function))
32    
33    
34  ;;;; Interpreter stack.  ;;;; Interpreter stack.
35    
 (defvar *eval-stack* (make-array 100)  
   "This is the interpreter's evaluation stack.")  
 (defvar *eval-stack-top* 0  
   "This is the next free element of the interpreter's evaluation stack.")  
   
36  ;;; Setting this causes the stack operations to dump a trace.  ;;; Setting this causes the stack operations to dump a trace.
37  ;;;  ;;;
38  (defvar *eval-stack-trace* nil)  (defvar *eval-stack-trace* nil)
# Line 51  Line 50 
50  (defun eval-stack-push (value)  (defun eval-stack-push (value)
51    (let ((len (length (the simple-vector *eval-stack*))))    (let ((len (length (the simple-vector *eval-stack*))))
52      (when (= len *eval-stack-top*)      (when (= len *eval-stack-top*)
53        (when *eval-stack-trace* (format t "[PUSH: growing stack.]~%"))        (when *eval-stack-trace* (format t (intl:gettext "[PUSH: growing stack.]~%")))
54        (let ((new-stack (make-array (ash len 1))))        (let ((new-stack (make-array (ash len 1))))
55          (replace new-stack *eval-stack* :end1 len :end2 len)          (replace new-stack *eval-stack* :end1 len :end2 len)
56          (setf *eval-stack* new-stack))))          (setf *eval-stack* new-stack))))
57    (let ((top *eval-stack-top*))    (let ((top *eval-stack-top*))
58      (when *eval-stack-trace* (format t "pushing ~D.~%" top))      (when *eval-stack-trace* (format t (intl:gettext "pushing ~D.~%") top))
59      (incf *eval-stack-top*)      (incf *eval-stack-top*)
60      (setf (svref *eval-stack* top) value)))      (setf (svref *eval-stack* top) value)))
61    
# Line 71  Line 70 
70  ;;;  ;;;
71  (defun eval-stack-pop ()  (defun eval-stack-pop ()
72    (when (zerop *eval-stack-top*)    (when (zerop *eval-stack-top*)
73      (error "Attempt to pop empty eval stack."))      (error (intl:gettext "Attempt to pop empty eval stack.")))
74    (let* ((new-top (1- *eval-stack-top*))    (let* ((new-top (1- *eval-stack-top*))
75           (value (svref *eval-stack* new-top)))           (value (svref *eval-stack* new-top)))
76      (when *eval-stack-trace* (format t "popping ~D --> ~S.~%" new-top value))      (when *eval-stack-trace* (format t (intl:gettext "popping ~D --> ~S.~%") new-top value))
77      (setf *eval-stack-top* new-top)      (setf *eval-stack-top* new-top)
78      value))      value))
79    
# Line 88  Line 87 
87  (defun eval-stack-extend (n)  (defun eval-stack-extend (n)
88    (let ((len (length (the simple-vector *eval-stack*))))    (let ((len (length (the simple-vector *eval-stack*))))
89      (when (> (+ n *eval-stack-top*) len)      (when (> (+ n *eval-stack-top*) len)
90        (when *eval-stack-trace* (format t "[EXTEND: growing stack.]~%"))        (when *eval-stack-trace* (format t (intl:gettext "[EXTEND: growing stack.]~%")))
91        (let ((new-stack (make-array (+ n (ash len 1)))))        (let ((new-stack (make-array (+ n (ash len 1)))))
92          (replace new-stack *eval-stack* :end1 len :end2 len)          (replace new-stack *eval-stack* :end1 len :end2 len)
93          (setf *eval-stack* new-stack))))          (setf *eval-stack* new-stack))))
94    (let ((new-top (+ *eval-stack-top* n)))    (let ((new-top (+ *eval-stack-top* n)))
95    (when *eval-stack-trace* (format t "extending to ~D.~%" new-top))    (when *eval-stack-trace* (format t (intl:gettext "extending to ~D.~%") new-top))
96      (do ((i *eval-stack-top* (1+ i)))      (do ((i *eval-stack-top* (1+ i)))
97          ((= i new-top))          ((= i new-top))
98        (setf (svref *eval-stack* i) nil))        (setf (svref *eval-stack* i) nil))
# Line 105  Line 104 
104  ;;;  ;;;
105  (defun eval-stack-shrink (n)  (defun eval-stack-shrink (n)
106    (when *eval-stack-trace*    (when *eval-stack-trace*
107      (format t "shrinking to ~D.~%" (- *eval-stack-top* n)))      (format t (intl:gettext "shrinking to ~D.~%") (- *eval-stack-top* n)))
108    (decf *eval-stack-top* n))    (decf *eval-stack-top* n))
109    
110  ;;; EVAL-STACK-SET-TOP -- Internal.  ;;; EVAL-STACK-SET-TOP -- Internal.
# Line 113  Line 112 
112  ;;; This is used to shrink the stack back to a previous frame pointer.  ;;; This is used to shrink the stack back to a previous frame pointer.
113  ;;;  ;;;
114  (defun eval-stack-set-top (ptr)  (defun eval-stack-set-top (ptr)
115    (when *eval-stack-trace* (format t "setting top to ~D.~%" ptr))    (when *eval-stack-trace* (format t (intl:gettext "setting top to ~D.~%") ptr))
116    (setf *eval-stack-top* ptr))    (setf *eval-stack-top* ptr))
117    
118    
# Line 129  Line 128 
128    
129  ;;;; Interpreted functions:  ;;;; Interpreted functions:
130    
 (defstruct (eval-function  
             (:print-function  
              (lambda (s stream d)  
                (declare (ignore d))  
                (format stream "#<EVAL-FUNCTION ~S>"  
                        (eval-function-name s)))))  
   ;;  
   ;; The name of this interpreted function, or NIL if none specified.  
   (name nil)  
   ;;  
   ;; This function's debug arglist.  
   (arglist nil)  
   ;;  
   ;; A lambda that can be converted to get the definition.  
   (lambda nil)  
   ;;  
   ;; If this function has been converted, then this is the XEP.  If this is  
   ;; false, then the function is not in the cache (or is in the process of  
   ;; being removed.)  
   (definition nil :type (or c::clambda null))  
   ;;  
   ;; The number of consequtive GCs that this function has been unused.  This is  
   ;; used to control cache replacement.  
   (gcs 0 :type c::index)  
   ;;  
   ;; True if Lambda has been converted at least once, and thus warnings should  
   ;; be suppressed on additional conversions.  
   (converted-once nil))  
   
   
131  (defvar *interpreted-function-cache-minimum-size* 25  (defvar *interpreted-function-cache-minimum-size* 25
132    "If the interpreted function cache has more functions than this come GC time,    "If the interpreted function cache has more functions than this come GC time,
133    then attempt to prune it according to    then attempt to prune it according to
# Line 168  Line 137 
137    "If an interpreted function goes uncalled for more than this many GCs, then    "If an interpreted function goes uncalled for more than this many GCs, then
138    it is eligible for flushing from the cache.")    it is eligible for flushing from the cache.")
139    
140  (proclaim '(type c::index  (declaim (type c::index
141                   *interpreted-function-cache-minimum-size*                 *interpreted-function-cache-minimum-size*
142                   *interpreted-function-cache-threshold*))                 *interpreted-function-cache-threshold*))
143    
144    
145  ;;; The list of EVAL-FUNCTIONS that have translated definitions.  ;;; The list of INTERPRETED-FUNCTIONS that have translated definitions.
146  ;;;  ;;;
147  (defvar *interpreted-function-cache* nil)  (defvar *interpreted-function-cache* nil)
148  (proclaim '(type list *interpreted-function-cache*))  (declaim (type list *interpreted-function-cache*))
149    
150    
151  ;;; MAKE-INTERPRETED-FUNCTION  --  Interface  ;;; MAKE-INTERPRETED-FUNCTION  --  Interface
# Line 185  Line 154 
154  ;;; cache translations.  ;;; cache translations.
155  ;;;  ;;;
156  (defun make-interpreted-function (lambda)  (defun make-interpreted-function (lambda)
157    (let ((eval-fun (make-eval-function :lambda lambda)))    (let ((res (%make-interpreted-function :lambda lambda
158      #'(lambda (&rest args)                                           :arglist (second lambda))))
159          (let ((fun (eval-function-definition eval-fun))      (setf (funcallable-instance-function res)
160                (args (cons (length args) args)))            #'(instance-lambda (&rest args)
161            (setf (eval-function-gcs eval-fun) 0)                 (let ((fun (interpreted-function-definition res))
162            (internal-apply (or fun (convert-eval-fun eval-fun))                       (args (cons (length args) args)))
163                            args '#())))))                   (setf (interpreted-function-gcs res) 0)
164                     (internal-apply (or fun (convert-interpreted-fun res))
165                                     args '#()))))
 ;;; GET-EVAL-FUNCTION  --  Internal  
 ;;;  
 (defun get-eval-function (x)  
   (let ((res (system:find-if-in-closure #'eval-function-p x)))  
     (assert res)  
166      res))      res))
167    
168    
169  ;;; CONVERT-EVAL-FUN  --  Internal  ;;; CONVERT-INTERPRETED-FUN  --  Internal
170  ;;;  ;;;
171  ;;;    Eval a FUNCTION form, grab the definition and stick it in.  ;;;    Eval a FUNCTION form, grab the definition and stick it in.
172  ;;;  ;;;
173  (defun convert-eval-fun (eval-fun)  (defun convert-interpreted-fun (fun)
174    (declare (type eval-function eval-fun))    (declare (type interpreted-function fun))
175    (let* ((new (eval-function-definition    (let* ((new (interpreted-function-definition
176                 (get-eval-function                 (internal-eval `#',(interpreted-function-lambda fun)
177                  (internal-eval `#',(eval-function-lambda eval-fun)                                (interpreted-function-converted-once fun)))))
178                                 (eval-function-converted-once eval-fun))))))      (setf (interpreted-function-definition fun) new)
179      (setf (eval-function-definition eval-fun) new)      (setf (interpreted-function-converted-once fun) t)
180      (setf (eval-function-converted-once eval-fun) t)      (let ((name (interpreted-function-%name fun)))
181      (push eval-fun *interpreted-function-cache*)        (setf (c::leaf-name new) name)
182          (setf (c::leaf-name (c::main-entry (c::functional-entry-function new)))
183                name))
184        (push fun *interpreted-function-cache*)
185      new))      new))
186    
187    
# Line 224  Line 191 
191  ;;; the real function.  ;;; the real function.
192  ;;;  ;;;
193  (defun interpreted-function-lambda-expression (x)  (defun interpreted-function-lambda-expression (x)
194    (let* ((eval-fun (get-eval-function x))    (let ((lambda (interpreted-function-lambda x)))
          (lambda (eval-function-lambda eval-fun)))  
195      (if lambda      (if lambda
196          (values lambda nil (eval-function-name eval-fun))          (values lambda nil (interpreted-function-%name x))
197          (let ((fun (c::functional-entry-function          (let ((fun (c::functional-entry-function
198                      (eval-function-definition eval-fun))))                      (interpreted-function-definition x))))
199            (values (c::functional-inline-expansion fun)            (values (c::functional-inline-expansion fun)
200                    (if (or (c::functional-fenv fun)                    (if (let ((env (c::functional-lexenv fun)))
201                            (c::functional-venv fun)                          (or (c::lexenv-functions env)
202                            (c::functional-benv fun)                              (c::lexenv-variables env)
203                            (c::functional-tenv fun))                              (c::lexenv-blocks env)
204                                (c::lexenv-tags env)))
205                        t nil)                        t nil)
206                    (or (eval-function-name eval-fun)                    (or (interpreted-function-%name x)
207                        (c::component-name                        (c::component-name
208                         (c::block-component                         (c::block-component
209                          (c::node-block (c::lambda-bind fun))))))))))                          (c::node-block
210                             (c::lambda-bind (c::main-entry fun)))))))))))
211    
212    
213    ;;; INTERPRETED-FUNCTION-TYPE  --  Interface
214    ;;;
215    ;;;    Return a FUNCTION-TYPE describing an eval function.  We just grab the
216    ;;; LEAF-TYPE of the definition, converting the definition if not currently
217    ;;; cached.
218    ;;;
219    (defvar *already-looking-for-type-of* nil)
220    ;;;
221    (defun interpreted-function-type (fun)
222      (if (member fun *already-looking-for-type-of*)
223          (specifier-type 'function)
224          (let* ((*already-looking-for-type-of*
225                  (cons fun *already-looking-for-type-of*))
226                 (def (or (interpreted-function-definition fun)
227                          (system:without-gcing
228                           (convert-interpreted-fun fun)
229                           (interpreted-function-definition fun)))))
230            (c::leaf-type (c::functional-entry-function def)))))
231    
232    
233  ;;; INTERPRETED-FUNCTION-{NAME,ARGLIST}  --  Interface  ;;;
234    ;;; INTERPRETED-FUNCTION-NAME  --  Interface
235  ;;;  ;;;
236  (defun interpreted-function-name (x)  (defun interpreted-function-name (x)
237    (multiple-value-bind (ig1 ig2 res)    (multiple-value-bind (ig1 ig2 res)
# Line 251  Line 240 
240      res))      res))
241  ;;;  ;;;
242  (defun (setf interpreted-function-name) (val x)  (defun (setf interpreted-function-name) (val x)
243    (setf (eval-function-name (get-eval-function x)) val))    (let ((def (interpreted-function-definition x)))
244  ;;;      (when def
245  (defun interpreted-function-arglist (x)        (setf (c::leaf-name def) val)
246    (eval-function-arglist (get-eval-function x)))        (setf (c::leaf-name (c::main-entry (c::functional-entry-function def)))
247  ;;;              val))
248  (defun (setf interpreted-function-arglist) (val x)      (setf (interpreted-function-%name x) val)))
   (setf (eval-function-arglist (get-eval-function x)) val))  
   
   
 ;;; INTERPRETED-FUNCTION-ENVIRONMENT  --  Interface  
 ;;;  
 ;;;    The environment should be the only SIMPLE-VECTOR in the closure.  We  
 ;;; have to throw in the EVAL-FUNCTION-P test, since structure are currently  
 ;;; also SIMPLE-VECTORs.  
 ;;;  
 (defun interpreted-function-closure (x)  
   (system:find-if-in-closure #'(lambda (x)  
                                  (and (simple-vector-p x)  
                                       (not (eval-function-p x))))  
                              x))  
   
249    
250  ;;; INTERPRETER-GC-HOOK  --  Internal  ;;; INTERPRETER-GC-HOOK  --  Internal
251  ;;;  ;;;
# Line 289  Line 263 
263      (when (plusp num)      (when (plusp num)
264        (setq *interpreted-function-cache*        (setq *interpreted-function-cache*
265              (delete-if #'(lambda (x)              (delete-if #'(lambda (x)
266                             (when (>= (eval-function-gcs x)                             (when (>= (interpreted-function-gcs x)
267                                       *interpreted-function-cache-threshold*)                                       *interpreted-function-cache-threshold*)
268                               (setf (eval-function-definition x) nil)                               (setf (interpreted-function-definition x) nil)
269                               t))                               t))
270                         *interpreted-function-cache*                         *interpreted-function-cache*
271                         :count num))))                         :count num))))
272    
273    (dolist (fun *interpreted-function-cache*)    (dolist (fun *interpreted-function-cache*)
274      (incf (eval-function-gcs fun))))      (incf (interpreted-function-gcs fun))))
275  ;;;  ;;;
276  (pushnew 'interpreter-gc-hook ext:*before-gc-hooks*)  (pushnew 'interpreter-gc-hook ext:*before-gc-hooks*)
277    
278    
279    ;;; FLUSH-INTERPRETED-FUNCTION-CACHE  --  Interface
280    ;;;
281    (defun flush-interpreted-function-cache ()
282      "Clear all entries in the eval function cache.  This allows the internal
283      representation of the functions to be reclaimed, and also lazily forces
284      macroexpansions to be recomputed."
285      (dolist (fun *interpreted-function-cache*)
286        (setf (interpreted-function-definition fun) nil))
287      (setq *interpreted-function-cache* ()))
288    
289    
290  ;;;; INTERNAL-APPLY-LOOP macros.  ;;;; INTERNAL-APPLY-LOOP macros.
291    
# Line 359  Line 343 
343                        (:local `(internal-apply                        (:local `(internal-apply
344                                  ,lambda ,args-form                                  ,lambda ,args-form
345                                  (compute-closure node ,lambda frame-ptr                                  (compute-closure node ,lambda frame-ptr
346                                                   closure)))))                                                   closure)
347                                    nil))))
348           (tailp-call-form           (tailp-call-form
349            (ecase call-type            (ecase call-type
350              (:full `(return-from              (:full `(return-from
# Line 375  Line 360 
360                         (eval-stack-set-top frame-ptr)                         (eval-stack-set-top frame-ptr)
361                         (return-from                         (return-from
362                          internal-apply-loop                          internal-apply-loop
363                          (internal-apply ,lambda ,args ,calling-closure)))))))                          (internal-apply ,lambda ,args ,calling-closure
364                                            nil)))))))
365      `(cond ((c::node-tail-p node)      `(cond ((c::node-tail-p node)
366              ,tailp-call-form)              ,tailp-call-form)
367             (t             (t
# Line 564  Line 550 
550              (assert (eq (c::continuation-info cont) :multiple))              (assert (eq (c::continuation-info cont) :multiple))
551              (eval-stack-push (list more-args (length more-args)))))              (eval-stack-push (list more-args (length more-args)))))
552           (c::%unknown-values           (c::%unknown-values
553            (error "C::%UNKNOWN-VALUES should never be in interpreter's IR1."))            (error (intl:gettext "C::%UNKNOWN-VALUES should never be in interpreter's IR1.")))
554           (c::%lexical-exit-breakup           (c::%lexical-exit-breakup
555            ;; We see this whenever we locally exit the extent of a lexical            ;; We see this whenever we locally exit the extent of a lexical
556            ;; target.  That is, we are truly locally exiting an extent we could            ;; target.  That is, we are truly locally exiting an extent we could
# Line 573  Line 559 
559            ;; of INTERNAL-APPLY-LOOP which happens to be running in the            ;; of INTERNAL-APPLY-LOOP which happens to be running in the
560            ;; c::entry branch of INTERNAL-APPLY-LOOP.            ;; c::entry branch of INTERNAL-APPLY-LOOP.
561            (maybe-trace-funny-fun node ,name)            (maybe-trace-funny-fun node ,name)
562              ;;
563              ;; Discard the NLX-INFO arg...
564              (eval-stack-pop)
565            (return-from internal-apply-loop            (return-from internal-apply-loop
566                         (values :fell-through block node cont last-cont)))))))                         (values :fell-through block node cont last-cont)))))))
567    
# Line 618  Line 607 
607                    (do-combination :local ,lambda ,type))))))                    (do-combination :local ,lambda ,type))))))
608      `(let ((,kind (c::basic-combination-kind node))      `(let ((,kind (c::basic-combination-kind node))
609             (,fun (c::basic-combination-fun node)))             (,fun (c::basic-combination-fun node)))
610         (cond ((eq ,kind :full)         (cond ((member ,kind '(:full :error))
611                (do-combination :full nil ,type))                (do-combination :full nil ,type))
612               ((eq ,kind :local)               ((eq ,kind :local)
613                (let* ((,lambda (c::ref-leaf (c::continuation-use ,fun)))                (let* ((,lambda (c::ref-leaf (c::continuation-use ,fun)))
# Line 637  Line 626 
626    (setf *internal-apply-node-trace* on))    (setf *internal-apply-node-trace* on))
627    
628    
 ;;;; INTERNAL-EVAL:  
   
 (proclaim '(special lisp::*already-evaled-this*))  
   
629  ;;; INTERNAL-EVAL  --  Interface  ;;; INTERNAL-EVAL  --  Interface
630  ;;;  ;;;
631  ;;;    Evaluate an arbitary form.  We convert the form, then call internal  ;;;    Evaluate an arbitary form.  We convert the form, then call internal
632  ;;; apply on it.  If *ALREADY-EVALED-THIS* is true, then we bind it to NIL  ;;; apply on it.
 ;;; around the apply to limit the inhibition to the lexical scope of the  
 ;;; EVAL-WHEN.  
 ;;;  
 (defun internal-eval (form &optional quietly)  
   (let ((res (c:compile-for-eval form quietly)))  
     (if lisp::*already-evaled-this*  
         (let ((lisp::*already-evaled-this* nil))  
           (internal-apply res nil nil))  
         (internal-apply res nil nil))))  
   
   
 ;;; MAKE-INDIRECT-VALUE-CELL -- Internal.  
 ;;;  
 ;;; Later this will probably be the same weird internal thing the compiler  
 ;;; makes to represent these things.  
633  ;;;  ;;;
634  (defun make-indirect-value-cell (value)  (defun internal-eval (form &optional quietly env)
635    (list value))    (let ((res (c:compile-for-eval form quietly env)))
636  ;;;      (internal-apply res nil '#())))
 (defmacro indirect-value (value-cell)  
   `(car ,value-cell))  
637    
638    
639  ;;; VALUE -- Internal.  ;;; VALUE -- Internal.
# Line 685  Line 653 
653           ((member ,info '(:multiple :return) :test #'eq)           ((member ,info '(:multiple :return) :test #'eq)
654            (eval-stack-push (list ,value)))            (eval-stack-push (list ,value)))
655           (t (assert (eq ,info :single))           (t (assert (eq ,info :single))
656              (eval-stack-push ,value))))))              (eval-stack-push ,value))))
657    
658    
659  (defun maybe-trace-nodes (node)  (defun maybe-trace-nodes (node)
# Line 703  Line 671 
671  ;;; for this lambda's call frame.  Then store the args into locals on the  ;;; for this lambda's call frame.  Then store the args into locals on the
672  ;;; stack.  ;;; stack.
673  ;;;  ;;;
674  (defun internal-apply (lambda args closure)  ;;; Args is the list of arguments to apply to.  If IGNORE-UNUSED is true, then
675    ;;; values for un-read variables are present in the argument list, and must be
676    ;;; discarded (always true except in a local call.)  Args may run out of values
677    ;;; before vars runs out of variables (in the case of an XEP with optionals);
678    ;;; we just do CAR of nil and store nil.  This is not the proper defaulting
679    ;;; (which is done by explicit code in the XEP.)
680    ;;;
681    (defun internal-apply (lambda args closure &optional (ignore-unused t))
682    (let ((frame-ptr *eval-stack-top*))    (let ((frame-ptr *eval-stack-top*))
683      (eval-stack-extend (c:lambda-eval-info-frame-size (c::lambda-info lambda)))      (eval-stack-extend (c:lambda-eval-info-frame-size (c::lambda-info lambda)))
684      (do ((vars (c::lambda-vars lambda) (cdr vars))      (do ((vars (c::lambda-vars lambda) (cdr vars))
685           (args args (cdr args)))           (args args))
686          ((null vars))          ((null vars))
       ;; Args may run out of values before vars runs out of variables, so  
       ;; just do CAR of nil and store nil.  
687        (let ((var (car vars)))        (let ((var (car vars)))
688          (when (c::leaf-refs var)          (cond ((c::leaf-refs var)
689            (setf (eval-stack-local frame-ptr (c::lambda-var-info var))                 (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
690                  (if (c::lambda-var-indirect var)                       (if (c::lambda-var-indirect var)
691                      (make-indirect-value-cell (car args))                           (c:make-value-cell (pop args))
692                      (car args))))))                           (pop args))))
693      (internal-apply-loop (c::lambda-bind lambda) frame-ptr lambda args closure)))                (ignore-unused (pop args)))))
694        (internal-apply-loop (c::lambda-bind lambda) frame-ptr lambda args
695                             closure)))
696    
697  ;;; INTERNAL-APPLY-LOOP -- Internal.  ;;; INTERNAL-APPLY-LOOP -- Internal.
698  ;;;  ;;;
# Line 744  Line 719 
719  ;;; closure, block, last-cont, and set-block-p.  ;;; closure, block, last-cont, and set-block-p.
720  ;;;  ;;;
721  (defun internal-apply-loop (first frame-ptr lambda args closure)  (defun internal-apply-loop (first frame-ptr lambda args closure)
722      (declare (optimize (debug 2)))
723    (let* ((block (c::node-block first))    (let* ((block (c::node-block first))
724           (last-cont (c::node-cont (c::block-last block)))           (last-cont (c::node-cont (c::block-last block)))
725           (node first)           (node first)
# Line 795  Line 771 
771                       ;; Non-local lexical exit (someone closed over a                       ;; Non-local lexical exit (someone closed over a
772                       ;; GO tag or BLOCK name).                       ;; GO tag or BLOCK name).
773                       (let ((unique-tag (cons nil nil))                       (let ((unique-tag (cons nil nil))
                            ;; Ultimately CATCH will handle the stack top  
                            ;; cleanup.  
                            (stack-top *eval-stack-top*)  
774                             values)                             values)
775                         (setf (eval-stack-local frame-ptr tag) unique-tag)                         (setf (eval-stack-local frame-ptr tag) unique-tag)
776                         (if (eq cont last-cont)                         (if (eq cont last-cont)
# Line 808  Line 781 
781                             (catch unique-tag                             (catch unique-tag
782                               (internal-apply-loop node frame-ptr                               (internal-apply-loop node frame-ptr
783                                                    lambda args closure)))                                                    lambda args closure)))
784                           (cond ((eq values :fell-through)  
785                                  ;; Interpreting state is set with MV-SETQ above.                           (when (eq values :fell-through)
786                                  ;; Just get out of this branch and go on.                             ;; We hit a %LEXICAL-EXIT-BREAKUP.
787                                  (return))                             ;; Interpreting state is set with MV-SETQ above.
788                                 ((eq values :non-local-go)                             ;; Just get out of this branch and go on.
789                                  ;; Ultimately do nothing here since CATCH would                             (return))
790                                  ;; have cleaned up the stack for us.  
791                                  (eval-stack-set-top stack-top)                           (unless (eq values :non-local-go)
792                                  (setf node (c::continuation-next                             ;; We know we're non-locally exiting from a
793                                              (car (c::block-succ block)))))                             ;; BLOCK with values (saw a RETURN-FROM).
794                                 (t                             (ecase (c::continuation-info cont)
795                                  ;; We know we're non-locally exiting from a                               (:single
796                                  ;; BLOCK with values (saw a RETURN-FROM).                                (eval-stack-push (car values)))
797                                  ;;                               ((:multiple :return)
798                                  ;; Ultimately do nothing here since CATCH would                                (eval-stack-push values))
799                                  ;; have cleaned up the stack for us.                               (:unused)))
800                                  (eval-stack-set-top stack-top)                           ;;
801                                  (ecase (c::continuation-info cont)                           ;; Start interpreting again at the target, skipping
802                                    (:single                           ;; the %NLX-ENTRY block.
803                                     (eval-stack-push (car values)))                           (setf node
804                                    ((:multiple :return)                                 (c::continuation-next
805                                     (eval-stack-push values))                                  (c::block-start
806                                    (:unused))                                   (car (c::block-succ block))))))))))))
                                 (setf cont last-cont)  
                                 (return))))))))))  
807              (c::exit              (c::exit
808               (maybe-trace-nodes node)               (maybe-trace-nodes node)
809               (let* ((incoming-values (c::exit-value node))               (let* ((incoming-values (c::exit-value node))
810                      (values (if incoming-values (eval-stack-pop))))                      (values (if incoming-values (eval-stack-pop))))
811                 (cond                 (cond
812                  ((eq (c::lambda-environment lambda)                  ((eq (c::lambda-environment lambda)
813                       (c::lambda-environment                       (c::block-environment
814                        (c::block-lambda                        (c::node-block (c::exit-entry node))))
                        (c::continuation-block cont))))  
815                   ;; Local exit.                   ;; Local exit.
816                   ;; Fixup stack top and massage values for destination.                   ;; Fixup stack top and massage values for destination.
817                   (eval-stack-set-top                   (eval-stack-set-top
# Line 877  Line 847 
847              (c::mv-combination              (c::mv-combination
848               (maybe-trace-nodes node)               (maybe-trace-nodes node)
849               (combination-node :mv-call)))               (combination-node :mv-call)))
850              ;; See function doc below.
851              (reference-this-var-to-keep-it-alive node)
852              (reference-this-var-to-keep-it-alive frame-ptr)
853              (reference-this-var-to-keep-it-alive closure)
854            (cond ((not (eq cont last-cont))            (cond ((not (eq cont last-cont))
855                   (setf node (c::continuation-next cont)))                   (setf node (c::continuation-next cont)))
856                  ;; Currently only the last node in a block causes this loop to                  ;; Currently only the last node in a block causes this loop to
# Line 886  Line 860 
860                   (change-blocks))                   (change-blocks))
861                  (t                  (t
862                   ;; Cif nodes set the block for us, but other last nodes do not.                   ;; Cif nodes set the block for us, but other last nodes do not.
863                   (change-blocks (car (c::block-succ block)))))))                   (change-blocks (car (c::block-succ block)))))))))
864      (eval-stack-set-top frame-ptr)))  
865    ;;; REFERENCE-THIS-VAR-TO-KEEP-IT-ALIVE -- Internal.
866    ;;;
867    ;;; This function allows a reference to a variable that the compiler cannot
868    ;;; easily eliminate as unnecessary.  We use this at the end of the node
869    ;;; dispatch in INTERNAL-APPLY-LOOP to make sure the node variable has a
870    ;;; valid value.  Each node branch tends to reference it at the beginning,
871    ;;; and then there is no reference but a set at the end; the compiler then
872    ;;; kills the variable between the reference in the dispatch branch and when
873    ;;; we set it at the end.  The problem is that most error will occur in the
874    ;;; interpreter within one of these node dispatch branches.
875    ;;;
876    (defun reference-this-var-to-keep-it-alive (node)
877      node)
878    
879    
880  ;;; SET-LEAF-VALUE -- Internal.  ;;; SET-LEAF-VALUE -- Internal.
881  ;;;  ;;;
# Line 901  Line 888 
888  ;;;  ;;;
889  (defun set-leaf-value (node frame-ptr closure value)  (defun set-leaf-value (node frame-ptr closure value)
890    (let ((var (c::set-var node)))    (let ((var (c::set-var node)))
891      (typecase var      (etypecase var
       (c::global-var  
        (setf (symbol-value (c::global-var-name var)) value))  
892        (c::lambda-var        (c::lambda-var
893         (let ((env (c::node-environment node)))         (set-leaf-value-lambda-var node var frame-ptr closure value))
894           (cond        (c::global-var
895            ((not (eq (c::lambda-environment (c::lambda-var-home var))         (setf (symbol-value (c::global-var-name var)) value)))))
                     env))  
            (setf (indirect-value  
                   (svref closure  
                          (position var (c::environment-closure env)  
                                    :test #'eq)))  
                  value))  
           ((c::lambda-var-indirect var)  
            (setf (indirect-value  
                   (eval-stack-local frame-ptr (c::lambda-var-info var)))  
                  value))  
           (t  
            (setf (eval-stack-local frame-ptr (c::lambda-var-info var))  
                  value))))))))  
896    
897    ;;; SET-LEAF-VALUE-LAMBDA-VAR -- Internal Interface.
898    ;;;
899    ;;; This does SET-LEAF-VALUE for a lambda-var leaf.  The debugger tools'
900    ;;; internals uses this also to set interpreted local variables. If the var
901    ;;; is a lexical variable with no refs, then we don't actually set anything,
902    ;;; since the variable has been deleted.
903    ;;;
904    (defun set-leaf-value-lambda-var (node var frame-ptr closure value)
905      (when (c::leaf-refs var)
906        (let ((env (c::node-environment node)))
907          (cond ((not (eq (c::lambda-environment (c::lambda-var-home var))
908                          env))
909                 (c:value-cell-set
910                  (svref closure (position var (c::environment-closure env)
911                                           :test #'eq))
912                  value))
913                ((c::lambda-var-indirect var)
914                 (c:value-cell-set
915                  (eval-stack-local frame-ptr (c::lambda-var-info var))
916                  value))
917                (t
918                 (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
919                       value)))))
920      value)
921    
922  ;;; LEAF-VALUE -- Internal.  ;;; LEAF-VALUE -- Internal.
923  ;;;  ;;;
# Line 950  Line 946 
946  ;;;                  functional environment, then we use  ;;;                  functional environment, then we use
947  ;;;                  MAKE-INTERPRETED-FUNCTION to make a cached translation.  ;;;                  MAKE-INTERPRETED-FUNCTION to make a cached translation.
948  ;;;                  Since it is too late to lazily convert, we set up the  ;;;                  Since it is too late to lazily convert, we set up the
949  ;;;                  EVAL-FUNCTION to be already converted.  ;;;                  INTERPRETED-FUNCTION to be already converted.
950  ;;;  ;;;
951  (defun leaf-value (node frame-ptr closure)  (defun leaf-value (node frame-ptr closure)
952    (let ((leaf (c::ref-leaf node)))    (let ((leaf (c::ref-leaf node)))
953      (typecase leaf      (etypecase leaf
954        (c::constant        (c::constant
955         (c::constant-value leaf))         (c::constant-value leaf))
956        (c::global-var        (c::global-var
957         (if (eq (c::global-var-kind leaf) :global-function)         (locally (declare (optimize (safety 1)))
958             (let ((name (c::global-var-name leaf)))           (if (eq (c::global-var-kind leaf) :global-function)
959               (if (symbolp name)               (let ((name (c::global-var-name leaf)))
960                   (symbol-function name)                 (if (symbolp name)
961                   (fdefinition name)))                     (symbol-function name)
962             (symbol-value (c::global-var-name leaf))))                     (fdefinition name)))
963                 (symbol-value (c::global-var-name leaf)))))
964        (c::lambda-var        (c::lambda-var
965         (let* ((env (c::node-environment node))         (leaf-value-lambda-var node leaf frame-ptr closure))
               (temp  
                (if (eq (c::lambda-environment (c::lambda-var-home leaf))  
                        env)  
                    (eval-stack-local frame-ptr (c::lambda-var-info leaf))  
                    (svref closure  
                           (position leaf (c::environment-closure env)  
                                     :test #'eq)))))  
          (if (c::lambda-var-indirect leaf)  
              (indirect-value temp)  
              temp)))  
966        (c::functional        (c::functional
967         (let* ((calling-closure (compute-closure node leaf frame-ptr closure))         (let* ((calling-closure (compute-closure node leaf frame-ptr closure))
968                (real-fun (c::functional-entry-function leaf))                (real-fun (c::functional-entry-function leaf))
969                (arg-doc (c::functional-arg-documentation real-fun)))                (arg-doc (c::functional-arg-documentation real-fun)))
970           (cond ((c:lambda-eval-info-function (c::leaf-info leaf)))           (cond ((c:lambda-eval-info-function (c::leaf-info leaf)))
971                 ((and (zerop (length calling-closure))                 ((and (zerop (length calling-closure))
972                       (null (c::functional-fenv real-fun)))                       (null (c::lexenv-functions
973                  (let* ((res (make-interpreted-function                              (c::functional-lexenv real-fun))))
974                               (c::functional-inline-expansion real-fun)))                  (let ((res (make-interpreted-function
975                         (eval-fun (get-eval-function res)))                              (c::functional-inline-expansion real-fun))))
976                    (push eval-fun *interpreted-function-cache*)                    (push res *interpreted-function-cache*)
977                    (setf (eval-function-definition eval-fun) leaf)                    (setf (interpreted-function-definition res) leaf)
978                    (setf (eval-function-converted-once eval-fun) t)                    (setf (interpreted-function-converted-once res) t)
979                    (setf (eval-function-arglist eval-fun) arg-doc)                    (setf (interpreted-function-arglist res) arg-doc)
980                    (setf (eval-function-name eval-fun) (c::leaf-name real-fun))                    (setf (interpreted-function-%name res)
981                            (c::leaf-name real-fun))
982                    (setf (c:lambda-eval-info-function (c::leaf-info leaf)) res)                    (setf (c:lambda-eval-info-function (c::leaf-info leaf)) res)
983                    res))                    res))
984                 (t                 (t
985                  (let ((eval-fun (make-eval-function                  (let ((res (%make-interpreted-function
986                                   :definition leaf                              :definition leaf
987                                   :name (c::leaf-name real-fun)                              :%name (c::leaf-name real-fun)
988                                   :arglist arg-doc)))                              :arglist arg-doc
989                    #'(lambda (&rest args)                              :closure calling-closure)))
990                        (declare (list args))                    (setf (funcallable-instance-function res)
991                        (internal-apply (eval-function-definition eval-fun)                          #'(instance-lambda (&rest args)
992                                        (cons (length args) args)                              (declare (list args))
993                                        calling-closure))))))))))                              (internal-apply
994                                 (interpreted-function-definition res)
995                                 (cons (length args) args)
996                                 (interpreted-function-closure res))))
997                      res))))))))
998    
999    ;;; LEAF-VALUE-LAMBDA-VAR -- Internal Interface.
1000    ;;;
1001    ;;; This does LEAF-VALUE for a lambda-var leaf.  The debugger tools' internals
1002    ;;; uses this also to reference interpreted local variables.
1003    ;;;
1004    (defun leaf-value-lambda-var (node leaf frame-ptr closure)
1005      (let* ((env (c::node-environment node))
1006             (temp
1007              (if (eq (c::lambda-environment (c::lambda-var-home leaf))
1008                      env)
1009                  (eval-stack-local frame-ptr (c::lambda-var-info leaf))
1010                  (svref closure
1011                         (position leaf (c::environment-closure env)
1012                                   :test #'eq)))))
1013        (if (c::lambda-var-indirect leaf)
1014            (c:value-cell-ref temp)
1015            temp)))
1016    
1017  ;;; COMPUTE-CLOSURE -- Internal.  ;;; COMPUTE-CLOSURE -- Internal.
1018  ;;;  ;;;
# Line 1051  Line 1060 
1060                              (position ele current-closure-vars                              (position ele current-closure-vars
1061                                        :test #'eq))))                                        :test #'eq))))
1062                  (c::nlx-info                  (c::nlx-info
1063                   (if (eq (c::lambda-environment                   (if (eq (c::block-environment (c::nlx-info-target ele))
                           (c::block-lambda (c::nlx-info-target ele)))  
1064                           current-env)                           current-env)
1065                       (eval-stack-local                       (eval-stack-local
1066                        frame-ptr                        frame-ptr
1067                        (c:entry-node-info-nlx-tag                        (c:entry-node-info-nlx-tag
1068                         (cdr (assoc ;; entry node for non-local extent                         (cdr (assoc ;; entry node for non-local extent
1069                               (c::continuation-use                               (c::cleanup-mess-up (c::nlx-info-cleanup ele))
                               (c::cleanup-start (c::nlx-info-cleanup ele)))  
1070                               (c::lambda-eval-info-entries                               (c::lambda-eval-info-entries
1071                                (c::lambda-info                                (c::lambda-info
1072                                 ;; lambda INTERNAL-APPLY-LOOP tosses around.                                 ;; lambda INTERNAL-APPLY-LOOP tosses around.
# Line 1108  Line 1115 
1115  (defun eval-stack-args (arg-count)  (defun eval-stack-args (arg-count)
1116    (let ((args nil))    (let ((args nil))
1117      (dotimes (i arg-count args)      (dotimes (i arg-count args)
       (declare (ignore i))  
1118        (push (eval-stack-pop) args))))        (push (eval-stack-pop) args))))
1119    
1120  ;;; MV-EVAL-STACK-ARGS -- Internal.  ;;; MV-EVAL-STACK-ARGS -- Internal.
# Line 1149  Line 1155 
1155        (when (c::leaf-refs v)        (when (c::leaf-refs v)
1156          (setf (eval-stack-local frame-ptr (c::lambda-var-info v))          (setf (eval-stack-local frame-ptr (c::lambda-var-info v))
1157                (if (c::lambda-var-indirect v)                (if (c::lambda-var-indirect v)
1158                    (make-indirect-value-cell (pop args))                    (c:make-value-cell (pop args))
1159                    (pop args)))))))                    (pop args)))))))
1160    
1161  ;;; STORE-MV-LET-VARS -- Internal.  ;;; STORE-MV-LET-VARS -- Internal.
# Line 1168  Line 1174 
1174        (if (c::leaf-refs v)        (if (c::leaf-refs v)
1175            (setf (eval-stack-local frame-ptr (c::lambda-var-info v))            (setf (eval-stack-local frame-ptr (c::lambda-var-info v))
1176                  (if (c::lambda-var-indirect v)                  (if (c::lambda-var-indirect v)
1177                      (make-indirect-value-cell (pop args))                      (c:make-value-cell (pop args))
1178                      (pop args)))                      (pop args)))
1179            (pop args)))))            (pop args)))))
1180    
# Line 1200  Line 1206 
1206          (when (c::leaf-refs v)          (when (c::leaf-refs v)
1207            (setf (eval-stack-local frame-ptr (c::lambda-var-info v))            (setf (eval-stack-local frame-ptr (c::lambda-var-info v))
1208                  (if (c::lambda-var-indirect v)                  (if (c::lambda-var-indirect v)
1209                      (make-indirect-value-cell (car remaining-args))                      (c:make-value-cell (car remaining-args))
1210                      (car remaining-args))))                      (car remaining-args))))
1211          (cdr remaining-args))          (cdr remaining-args))
1212        args))        args))

Legend:
Removed from v.1.11.3.2  
changed lines
  Added in v.1.39

  ViewVC Help
Powered by ViewVC 1.1.5