/[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.36 by toy, Fri Dec 13 19:25:50 2002 UTC revision 1.37 by rtoy, Fri Mar 19 15:19:00 2010 UTC
# Line 16  Line 16 
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*
# Line 49  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 _"[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 _"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 69  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 _"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 _"popping ~D --> ~S.~%" new-top value))
77      (setf *eval-stack-top* new-top)      (setf *eval-stack-top* new-top)
78      value))      value))
79    
# Line 86  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 _"[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 _"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 103  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 _"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 111  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 _"setting top to ~D.~%" ptr))
116    (setf *eval-stack-top* ptr))    (setf *eval-stack-top* ptr))
117    
118    
# Line 128  Line 129 
129  ;;;; Interpreted functions:  ;;;; Interpreted functions:
130    
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,    _N"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
134    *INTERPRETED-FUNCTION-CACHE-THRESHOLD*.")    *INTERPRETED-FUNCTION-CACHE-THRESHOLD*.")
135    
136  (defvar *interpreted-function-cache-threshold* 3  (defvar *interpreted-function-cache-threshold* 3
137    "If an interpreted function goes uncalled for more than this many GCs, then    _N"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  (declaim (type c::index  (declaim (type c::index
# Line 278  Line 279 
279  ;;; FLUSH-INTERPRETED-FUNCTION-CACHE  --  Interface  ;;; FLUSH-INTERPRETED-FUNCTION-CACHE  --  Interface
280  ;;;  ;;;
281  (defun flush-interpreted-function-cache ()  (defun flush-interpreted-function-cache ()
282    "Clear all entries in the eval function cache.  This allows the internal    _N"Clear all entries in the eval function cache.  This allows the internal
283    representation of the functions to be reclaimed, and also lazily forces    representation of the functions to be reclaimed, and also lazily forces
284    macroexpansions to be recomputed."    macroexpansions to be recomputed."
285    (dolist (fun *interpreted-function-cache*)    (dolist (fun *interpreted-function-cache*)
# Line 549  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 _"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

Legend:
Removed from v.1.36  
changed lines
  Added in v.1.37

  ViewVC Help
Powered by ViewVC 1.1.5