/[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.29 by pw, Wed Feb 5 16:01:21 1997 UTC revision 1.30 by pw, Sat Feb 8 17:24:47 1997 UTC
# Line 127  Line 127 
127    
128  ;;;; Interpreted functions:  ;;;; Interpreted functions:
129    
 (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))  
   
   
130  (defvar *interpreted-function-cache-minimum-size* 25  (defvar *interpreted-function-cache-minimum-size* 25
131    "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,
132    then attempt to prune it according to    then attempt to prune it according to
# Line 171  Line 141 
141                   *interpreted-function-cache-threshold*))                   *interpreted-function-cache-threshold*))
142    
143    
144  ;;; The list of EVAL-FUNCTIONS that have translated definitions.  ;;; The list of INTERPRETED-FUNCTIONS that have translated definitions.
145  ;;;  ;;;
146  (defvar *interpreted-function-cache* nil)  (defvar *interpreted-function-cache* nil)
147  (proclaim '(type list *interpreted-function-cache*))  (proclaim '(type list *interpreted-function-cache*))
# Line 183  Line 153 
153  ;;; cache translations.  ;;; cache translations.
154  ;;;  ;;;
155  (defun make-interpreted-function (lambda)  (defun make-interpreted-function (lambda)
156    (let ((eval-fun (make-eval-function :lambda lambda    (let ((res (%make-interpreted-function :lambda lambda
157                                        :arglist (second lambda))))                                           :arglist (second lambda))))
158      #'(lambda (&rest args)      (setf (funcallable-instance-function res)
159          (let ((fun (eval-function-definition eval-fun))            #'(instance-lambda (&rest args)
160                (args (cons (length args) args)))                 (let ((fun (interpreted-function-definition res))
161            (setf (eval-function-gcs eval-fun) 0)                       (args (cons (length args) args)))
162            (internal-apply (or fun (convert-eval-fun eval-fun))                   (setf (interpreted-function-gcs res) 0)
163                            args '#())))))                   (internal-apply (or fun (convert-interpreted-fun res))
164                                     args '#()))))
   
 ;;; GET-EVAL-FUNCTION  --  Internal  
 ;;;  
 (defun get-eval-function (x)  
   (let ((res (system:find-if-in-closure #'eval-function-p x)))  
     (assert res)  
165      res))      res))
166    
167    
168  ;;; CONVERT-EVAL-FUN  --  Internal  ;;; CONVERT-INTERPRETED-FUN  --  Internal
169  ;;;  ;;;
170  ;;;    Eval a FUNCTION form, grab the definition and stick it in.  ;;;    Eval a FUNCTION form, grab the definition and stick it in.
171  ;;;  ;;;
172  (defun convert-eval-fun (eval-fun)  (defun convert-interpreted-fun (fun)
173    (declare (type eval-function eval-fun))    (declare (type interpreted-function fun))
174    (let* ((new (eval-function-definition    (let* ((new (interpreted-function-definition
175                 (get-eval-function                 (internal-eval `#',(interpreted-function-lambda fun)
176                  (internal-eval `#',(eval-function-lambda eval-fun)                                (interpreted-function-converted-once fun)))))
177                                 (eval-function-converted-once eval-fun))))))      (setf (interpreted-function-definition fun) new)
178      (setf (eval-function-definition eval-fun) new)      (setf (interpreted-function-converted-once fun) t)
179      (setf (eval-function-converted-once eval-fun) t)      (let ((name (interpreted-function-%name fun)))
     (let ((name (eval-function-name eval-fun)))  
180        (setf (c::leaf-name new) name)        (setf (c::leaf-name new) name)
181        (setf (c::leaf-name (c::main-entry (c::functional-entry-function new)))        (setf (c::leaf-name (c::main-entry (c::functional-entry-function new)))
182              name))              name))
183      (push eval-fun *interpreted-function-cache*)      (push fun *interpreted-function-cache*)
184      new))      new))
185    
186    
# Line 227  Line 190 
190  ;;; the real function.  ;;; the real function.
191  ;;;  ;;;
192  (defun interpreted-function-lambda-expression (x)  (defun interpreted-function-lambda-expression (x)
193    (let* ((eval-fun (get-eval-function x))    (let ((lambda (interpreted-function-lambda x)))
          (lambda (eval-function-lambda eval-fun)))  
194      (if lambda      (if lambda
195          (values lambda nil (eval-function-name eval-fun))          (values lambda nil (interpreted-function-%name x))
196          (let ((fun (c::functional-entry-function          (let ((fun (c::functional-entry-function
197                      (eval-function-definition eval-fun))))                      (interpreted-function-definition x))))
198            (values (c::functional-inline-expansion fun)            (values (c::functional-inline-expansion fun)
199                    (if (let ((env (c::functional-lexenv fun)))                    (if (let ((env (c::functional-lexenv fun)))
200                          (or (c::lexenv-functions env)                          (or (c::lexenv-functions env)
# Line 240  Line 202 
202                              (c::lexenv-blocks env)                              (c::lexenv-blocks env)
203                              (c::lexenv-tags env)))                              (c::lexenv-tags env)))
204                        t nil)                        t nil)
205                    (or (eval-function-name eval-fun)                    (or (interpreted-function-%name x)
206                        (c::component-name                        (c::component-name
207                         (c::block-component                         (c::block-component
208                          (c::node-block (c::lambda-bind fun))))))))))                          (c::node-block (c::lambda-bind fun))))))))))
# Line 259  Line 221 
221        (specifier-type 'function)        (specifier-type 'function)
222        (let* ((*already-looking-for-type-of*        (let* ((*already-looking-for-type-of*
223                (cons fun *already-looking-for-type-of*))                (cons fun *already-looking-for-type-of*))
224               (eval-fun (get-eval-function fun))               (def (or (interpreted-function-definition fun)
              (def (or (eval-function-definition eval-fun)  
225                        (system:without-gcing                        (system:without-gcing
226                         (convert-eval-fun eval-fun)                         (convert-interpreted-fun fun)
227                         (eval-function-definition eval-fun)))))                         (interpreted-function-definition fun)))))
228          (c::leaf-type (c::functional-entry-function def)))))          (c::leaf-type (c::functional-entry-function def)))))
229    
230    
231  ;;;  ;;;
232  ;;; INTERPRETED-FUNCTION-{NAME,ARGLIST}  --  Interface  ;;; INTERPRETED-FUNCTION-NAME  --  Interface
233  ;;;  ;;;
234  (defun interpreted-function-name (x)  (defun interpreted-function-name (x)
235    (multiple-value-bind (ig1 ig2 res)    (multiple-value-bind (ig1 ig2 res)
# Line 277  Line 238 
238      res))      res))
239  ;;;  ;;;
240  (defun (setf interpreted-function-name) (val x)  (defun (setf interpreted-function-name) (val x)
241    (let* ((eval-fun (get-eval-function x))    (let ((def (interpreted-function-definition x)))
          (def (eval-function-definition eval-fun)))  
242      (when def      (when def
243        (setf (c::leaf-name def) val)        (setf (c::leaf-name def) val)
244        (setf (c::leaf-name (c::main-entry (c::functional-entry-function def)))        (setf (c::leaf-name (c::main-entry (c::functional-entry-function def)))
245              val))              val))
246      (setf (eval-function-name eval-fun) val)))      (setf (interpreted-function-%name x) val)))
 ;;;  
 (defun interpreted-function-arglist (x)  
   (eval-function-arglist (get-eval-function x)))  
 ;;;  
 (defun (setf interpreted-function-arglist) (val x)  
   (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))  
   
247    
248  ;;; INTERPRETER-GC-HOOK  --  Internal  ;;; INTERPRETER-GC-HOOK  --  Internal
249  ;;;  ;;;
# Line 321  Line 261 
261      (when (plusp num)      (when (plusp num)
262        (setq *interpreted-function-cache*        (setq *interpreted-function-cache*
263              (delete-if #'(lambda (x)              (delete-if #'(lambda (x)
264                             (when (>= (eval-function-gcs x)                             (when (>= (interpreted-function-gcs x)
265                                       *interpreted-function-cache-threshold*)                                       *interpreted-function-cache-threshold*)
266                               (setf (eval-function-definition x) nil)                               (setf (interpreted-function-definition x) nil)
267                               t))                               t))
268                         *interpreted-function-cache*                         *interpreted-function-cache*
269                         :count num))))                         :count num))))
270    
271    (dolist (fun *interpreted-function-cache*)    (dolist (fun *interpreted-function-cache*)
272      (incf (eval-function-gcs fun))))      (incf (interpreted-function-gcs fun))))
273  ;;;  ;;;
274  (pushnew 'interpreter-gc-hook ext:*before-gc-hooks*)  (pushnew 'interpreter-gc-hook ext:*before-gc-hooks*)
275    
# Line 341  Line 281 
281    representation of the functions to be reclaimed, and also lazily forces    representation of the functions to be reclaimed, and also lazily forces
282    macroexpansions to be recomputed."    macroexpansions to be recomputed."
283    (dolist (fun *interpreted-function-cache*)    (dolist (fun *interpreted-function-cache*)
284      (setf (eval-function-definition fun) nil))      (setf (interpreted-function-definition fun) nil))
285    (setq *interpreted-function-cache* ()))    (setq *interpreted-function-cache* ()))
286    
287    
# Line 1031  Line 971 
971  ;;;                  functional environment, then we use  ;;;                  functional environment, then we use
972  ;;;                  MAKE-INTERPRETED-FUNCTION to make a cached translation.  ;;;                  MAKE-INTERPRETED-FUNCTION to make a cached translation.
973  ;;;                  Since it is too late to lazily convert, we set up the  ;;;                  Since it is too late to lazily convert, we set up the
974  ;;;                  EVAL-FUNCTION to be already converted.  ;;;                  INTERPRETED-FUNCTION to be already converted.
975  ;;;  ;;;
976  (defun leaf-value (node frame-ptr closure)  (defun leaf-value (node frame-ptr closure)
977    (let ((leaf (c::ref-leaf node)))    (let ((leaf (c::ref-leaf node)))
# Line 1063  Line 1003 
1003                 ((and (zerop (length calling-closure))                 ((and (zerop (length calling-closure))
1004                       (null (c::lexenv-functions                       (null (c::lexenv-functions
1005                              (c::functional-lexenv real-fun))))                              (c::functional-lexenv real-fun))))
1006                  (let* ((res (make-interpreted-function                  (let ((res (make-interpreted-function
1007                               (c::functional-inline-expansion real-fun)))                              (c::functional-inline-expansion real-fun))))
1008                         (eval-fun (get-eval-function res)))                    (push res *interpreted-function-cache*)
1009                    (push eval-fun *interpreted-function-cache*)                    (setf (interpreted-function-definition res) leaf)
1010                    (setf (eval-function-definition eval-fun) leaf)                    (setf (interpreted-function-converted-once res) t)
1011                    (setf (eval-function-converted-once eval-fun) t)                    (setf (interpreted-function-arglist res) arg-doc)
1012                    (setf (eval-function-arglist eval-fun) arg-doc)                    (setf (interpreted-function-%name res)
1013                    (setf (eval-function-name eval-fun) (c::leaf-name real-fun))                          (c::leaf-name real-fun))
1014                    (setf (c:lambda-eval-info-function (c::leaf-info leaf)) res)                    (setf (c:lambda-eval-info-function (c::leaf-info leaf)) res)
1015                    res))                    res))
1016                 (t                 (t
1017                  (let ((eval-fun (make-eval-function                  (let ((res (%make-interpreted-function
1018                                   :definition leaf                              :definition leaf
1019                                   :name (c::leaf-name real-fun)                              :%name (c::leaf-name real-fun)
1020                                   :arglist arg-doc)))                              :arglist arg-doc
1021                    #'(lambda (&rest args)                              :closure calling-closure)))
1022                        (declare (list args))                    (setf (funcallable-instance-function res)
1023                        (internal-apply (eval-function-definition eval-fun)                          #'(instance-lambda (&rest args)
1024                                        (cons (length args) args)                              (declare (list args))
1025                                        calling-closure))))))))))                              (internal-apply
1026                                 (interpreted-function-definition res)
1027                                 (cons (length args) args)
1028                                 (interpreted-function-closure res))))
1029                      res))))))))
1030    
1031  ;;; LEAF-VALUE-LAMBDA-VAR -- Internal Interface.  ;;; LEAF-VALUE-LAMBDA-VAR -- Internal Interface.
1032  ;;;  ;;;

Legend:
Removed from v.1.29  
changed lines
  Added in v.1.30

  ViewVC Help
Powered by ViewVC 1.1.5