Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18611

Modified Files: compiler.lisp Log Message: Changed the compilation protocol for computing bindings "lended" status. Now, unused local functions should not impact bindings (previously even an unused local function would cause a binding to become "lended", ie. referenced indirectly).

Date: Wed Aug 18 17:22:03 2004 Author: ffjeld

Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.96 movitz/compiler.lisp:1.97 --- movitz/compiler.lisp:1.96 Wed Aug 18 15:30:51 2004 +++ movitz/compiler.lisp Wed Aug 18 17:22:02 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.96 2004/08/18 22:30:51 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.97 2004/08/19 00:22:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -561,8 +561,8 @@ ;;; (warn "binding ~S of ~S is not local to ~S, replacing with ~S of ~S." ;;; binding (binding-env binding) funobj ;;; borrowing-binding (binding-env borrowing-binding)) - (pushnew borrowing-binding - (getf (binding-lended-p binding) :lended-to)) +;;; (pushnew borrowing-binding +;;; (getf (binding-lended-p binding) :lended-to)) (dolist (usage usages) (pushnew usage (borrowed-binding-usage borrowing-binding))) borrowing-binding) @@ -650,6 +650,10 @@ (list :anonymous-lambda (movitz-funobj-name toplevel-funobj) (post-incf sub-funobj-index))))) + (loop for borrowed-binding in (borrowed-bindings sub-funobj) + do (pushnew borrowed-binding + (getf (binding-lending (borrowed-binding-target borrowed-binding)) + :lended-to))) (cond ((or (null usage) (null (borrowed-bindings sub-funobj))) @@ -788,7 +792,7 @@ optp-location req-location opt-location))) (make-stack-setup-code (- stack-frame-size stack-setup-pre)) (when (binding-lended-p req-binding) - (let ((lended-cons-position (getf (binding-lended-p req-binding) + (let ((lended-cons-position (getf (binding-lending req-binding) :stack-cons-location))) (etypecase req-location (integer @@ -2297,14 +2301,18 @@ :accessor macro-binding-expander)))

(defclass variable-binding (binding) - ((lended-p ; a property-list + ((lending ; a property-list :initform nil - :accessor binding-lended-p) + :accessor binding-lending) (store-type ; union of all types ever stored here :initform nil ;; :initarg :store-type :accessor binding-store-type)))

+(defmethod binding-lended-p ((binding variable-binding)) + (and (getf (binding-lending binding) :lended-to) + (not (eq :unused (getf (binding-lending binding) :lended-to))))) + (defclass lexical-binding (variable-binding) ()) (defclass located-binding (lexical-binding) ())

@@ -2807,7 +2815,7 @@ (pushnew lended-binding (potentially-lended-bindings function-env)) (take-note-of-binding lended-binding) - (symbol-macrolet ((p (binding-lended-p lended-binding))) + (symbol-macrolet ((p (binding-lending lended-binding))) (incf (getf p :lended-count 0)) (setf (getf p :dynamic-extent-p) (and (getf p :dynamic-extent-p t) dynamic-extent-p)))))) @@ -2962,7 +2970,7 @@ (dolist (binding bindings-register-goodness-sort) (unless (and (binding-lended-p binding) (not (typep binding 'borrowed-binding)) - (not (getf (binding-lended-p binding) :stack-cons-location))) + (not (getf (binding-lending binding) :stack-cons-location))) (unless (new-binding-located-p binding frame-map) (check-type binding located-binding) (multiple-value-bind (register status) @@ -3011,12 +3019,12 @@ (dolist (binding bindings-register-goodness-sort) (when (and (binding-lended-p binding) (not (typep binding 'borrowed-binding)) - (not (getf (binding-lended-p binding) :stack-cons-location))) + (not (getf (binding-lending binding) :stack-cons-location))) ;; (warn "assigning lending-cons for ~W at ~D" binding stack-frame-position) (let ((cons-pos (post-incf stack-frame-position 2))) (setf (new-binding-location (cons :lended-cons binding) frame-map) (1+ cons-pos)) - (setf (getf (binding-lended-p binding) :stack-cons-location) + (setf (getf (binding-lending binding) :stack-cons-location) cons-pos))) (unless (new-binding-located-p binding frame-map) (etypecase binding @@ -3551,18 +3559,18 @@ funobj lended-binding borrowing-binding) (assert (eq funobj (binding-funobj lended-binding))) - (assert (plusp (getf (binding-lended-p (actual-binding lended-binding)) + (assert (plusp (getf (binding-lending (actual-binding lended-binding)) :lended-count 0)) () "Asked to lend ~S of ~S to ~S of ~S with no lended-count." lended-binding (binding-env lended-binding) borrowing-binding (binding-env borrowing-binding)) (assert (eq funobj-register :edx)) - (when (getf (binding-lended-p lended-binding) :dynamic-extent-p) + (when (getf (binding-lending lended-binding) :dynamic-extent-p) (assert dynamic-extent-p)) ;; (warn "lending: ~W" lended-binding) (append (make-load-lexical lended-binding :eax funobj t frame-map) (unless (or (typep lended-binding 'borrowed-binding) - (getf (binding-lended-p lended-binding) :dynamic-extent-p)) + (getf (binding-lending lended-binding) :dynamic-extent-p)) (append `((:pushl :edx) (:globally (:call (:edi (:edi-offset ensure-heap-cons-variable)))) (:popl :edx)) @@ -4176,7 +4184,7 @@ `((:movl :edx (:ebp ,(stack-frame-offset (new-binding-location (edx-var env) frame-map)))))) eax-ebx-code-post-stackframe (loop for binding in (potentially-lended-bindings env) - as lended-cons-position = (getf (binding-lended-p binding) :stack-cons-location) + as lended-cons-position = (getf (binding-lending binding) :stack-cons-location) as location = (new-binding-location binding frame-map :default nil) when (and (not (typep binding 'borrowed-binding)) lended-cons-position @@ -6040,7 +6048,7 @@ )))) (cond ((binding-lended-p binding) - (let* ((cons-position (getf (binding-lended-p binding) + (let* ((cons-position (getf (binding-lending binding) :stack-cons-location)) (init-register (etypecase init-with-register (lexical-binding