From ef797cb513b225a30a52c33989619b06de6e4cde Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Wed, 19 May 2010 14:20:17 +0200 Subject: [PATCH] Management of variable references, read and set nodes, and type updates is now done through the functions in cmpvar.lsp. --- src/cmp/cmpblock.lsp | 22 ++++++----- src/cmp/cmpform.lsp | 54 ++++++++++++++++++++----- src/cmp/cmplet.lsp | 42 ++++++-------------- src/cmp/cmpspecial.lsp | 1 - src/cmp/cmptag.lsp | 3 +- src/cmp/cmpvar.lsp | 89 ++++++++++++++++++++++++++++++------------ 6 files changed, 134 insertions(+), 77 deletions(-) diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index 1ac1755a2..4bf352aae 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -84,24 +84,26 @@ (unless blk (cmperr "The block ~s is undefined." name)) (let* ((val (c1expr (second args))) - (var (blk-var blk)) + (var nil) (type T)) (cond (ccb (setf (blk-ref-ccb blk) t type 'CCB + var (blk-var blk) (var-kind var) 'CLOSURE - (var-ref-ccb var) T) - (incf (var-ref var))) + (var-ref-ccb var) T)) (clb (setf (blk-ref-clb blk) t - type 'CLB) - (incf (var-ref var))) - (unw (setf type 'UNWIND-PROTECT) - (incf (var-ref var)))) + type 'CLB + var (blk-var blk))) + (unw (setf type 'UNWIND-PROTECT + var (blk-var blk)))) (incf (blk-ref blk)) (setf (blk-type blk) (type-or (blk-type blk) (c1form-primary-type val))) - (add-to-read-nodes var (make-c1form* 'RETURN-FROM :type 'T - :args blk type val)))))) + (let ((output (make-c1form* 'RETURN-FROM :type 'T + :args blk type val var))) + (when var (add-to-read-nodes var output)) + output))))) -(defun c2return-from (blk type val) +(defun c2return-from (blk type val var) (case type (CCB (let ((*destination* 'VALUES)) (c2expr* val)) diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index 3434a97f3..a37baedc4 100644 --- a/src/cmp/cmpform.lsp +++ b/src/cmp/cmpform.lsp @@ -34,7 +34,7 @@ (PROGN body :pure) (PROGV symbols values form :side-effects) (TAGBODY tag-var tag-body :pure) - (RETURN-FROM blk-var return-type value :side-effects) + (RETURN-FROM blk-var return-type value variable-or-nil :side-effects) (FUNCALL fun-value (arg-value*) :side-effects) (CALL-LOCAL obj-fun (arg-value*) :side-effects) (CALL-GLOBAL fun-name (arg-value*)) @@ -167,16 +167,16 @@ (c1form-add-info-loop form dependents)) (defun c1form-replace-with (dest new-fields) + ;; Side effects might have to be propagated to the parents + ;; but currently we do not allow moving forms with side effects + (when (c1form-side-effects new-fields) + (baboon "Attempted to move a form with side-effects")) ;; We have to relocate the children nodes of NEW-FIELDS in ;; the new branch. This implies rewriting the parents chain, ;; but only for non-location nodes (these are reused). (unless (eq (c1form-name new-fields) 'LOCATION) (rplacd (c1form-parents new-fields) (c1form-parents dest))) - ;; Side effects might have to be propagated to the parents - ;; but currently we do not allow moving forms with side effects - (when (c1form-side-effects new-fields) - (baboon "Attempted to move a form with side-effects")) ;; Remaining flags are just copied (setf (c1form-type dest) (c1form-type new-fields) (c1form-sp-change dest) (c1form-sp-change new-fields) @@ -185,6 +185,27 @@ (c1form-name dest) 'VALUES (c1form-args dest) (list (list new-fields)))) +(defun c1form-replace-entirely (dest new-fields) + ;; Similar to the previous one, but we can really overwrite + ;; all fields instead of enclosing into a different form + (when (c1form-side-effects new-fields) + (baboon "Attempted to move a form with side-effects")) + ;; Replacing the inheritance chain is a bit more complicated + ;; because we want to preserve the "CAR" of the new-fields, + ;; which is used by its children + (let* ((new (car (c1form-parents new-fields))) + (old (cdr (c1form-parents dest)))) + ;; Remaining flags are just copied + (setf (c1form-name dest) (c1form-name new-fields) + (c1form-parents dest) (nconc (rplaca new dest) old) + (c1form-type dest) (c1form-type new-fields) + (c1form-local-vars dest) (c1form-local-vars new-fields) + (c1form-sp-change dest) (c1form-sp-change new-fields) + (c1form-side-effects dest) (c1form-side-effects new-fields) + (c1form-volatile dest) (c1form-volatile new-fields) + (c1form-args dest) (c1form-args new-fields) + (c1form-env dest) (c1form-env new-fields)))) + (defun copy-c1form (form) (copy-structure form)) @@ -204,10 +225,25 @@ (defun location-primary-type (form) (c1form-primary-type form)) -(defun find-node-in-list (home-node list) - (flet ((parent-node-p (node presumed-child) - (member node (c1form-parents presumed-child)))) - (member home-node list :test #'parent-node-p))) +(defun find-form-in-node-list (form list) + (let ((v1 (loop with form-parents = (c1form-parents form) + for presumed-child-parents in list + thereis (tailp form-parents presumed-child-parents))) + (v2 (loop for presumed-child-parents in list + thereis (member form presumed-child-parents :test #'eq)))) + (unless (eq (and v1 t) (and v2 t)) + (baboon :format-control "Mismatch between FIND-FORM-IN-NODE-LISTs")) + v1)) + +(defun add-form-to-node-list (form list) + (list* (c1form-parents form) list)) + +(defun delete-form-from-node-list (form list) + (let ((parents (c1form-parents form))) + (unless (member parents list) + (baboon :format-control "Unable to find C1FORM~%~4I~A~%in node list~%~4I~A" + :format-arguments (list form list))) + (delete parents list))) (defun traverse-c1form-tree (tree function) (cond ((consp tree) diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index 30a1d07b9..77d924a0d 100644 --- a/src/cmp/cmplet.lsp +++ b/src/cmp/cmplet.lsp @@ -120,7 +120,7 @@ (and-form-type (var-type var) form (var-name var) :unsafe "In LET body") (let ((form-type (c1form-primary-type form))) (setf (var-type var) form-type) - (update-var-type var form-type rest-forms))) + (update-variable-type var form-type))) (defun c1let-unused-variable-p (var form) ;; * (let ((v2 e2)) e3 e4) => (let () e3 e4) @@ -164,28 +164,16 @@ (nsubst-var var form) t)) -(defun update-var-type (var type x) - (cond ((consp x) - (dolist (e x) - (update-var-type var type e))) - ((not (c1form-p x))) - ((eq (c1form-name x) 'VAR) - (when (eq var (c1form-arg 0 x)) - (setf (c1form-type x) (type-and (c1form-primary-type x) type)))) - (t - (update-var-type var type (c1form-args x))))) - (defun read-only-variable-p (v other-decls) (dolist (i other-decls nil) (when (and (eq (car i) :READ-ONLY) (member v (rest i))) (return t)))) -(defun update-variable-type (var form) +(defun c2let-update-variable-type (var form) (unless (or (var-set-nodes var) (unboxed var)) - (setf (var-type var) - (type-and (var-type var) (c1form-primary-type form))))) + (update-variable-type var (c1form-type form)))) (defun c2let (vars forms body &aux (block-p nil) (bindings nil) @@ -197,7 +185,7 @@ ;; FIXME! Until we switch on the type propagation phase we do ;; this little optimization here - (mapc 'update-variable-type vars forms) + (mapc 'c2let-update-variable-type vars forms) ;; Allocation is needed for: ;; 1. each variable which is LOCAL and which is not REPLACED @@ -333,7 +321,7 @@ ;; FIXME! Until we switch on the type propagation phase we do ;; this little optimization here - (mapc 'update-variable-type vars forms) + (mapc 'c2let-update-variable-type vars forms) (do ((vl vars (cdr vl)) (fl forms (cdr fl)) @@ -440,28 +428,24 @@ ;; exactly one occurrence of var is present in forms (defun delete-c1forms (form) (flet ((eliminate-references (form) - (if (eq (c1form-name form) 'VAR) - (let ((var (c1form-arg 0 form))) - (when var - (decf (var-ref var)) - (setf (var-ref var) (1- (var-ref var)) - (var-read-nodes var) - (delete form (var-read-nodes var)))))))) + (when (eq (c1form-name form) 'VAR) + (let ((var (c1form-arg 0 form))) + (when var + (delete-from-read-nodes var form)))))) (traverse-c1form-tree form #'eliminate-references))) (defun nsubst-var (var form) (when (var-set-nodes var) (baboon :format-control "Cannot replace a variable that is to be changed")) (when (var-functions-reading var) - (baboon :format-control "Cannot replace a variable that is closed over")) - (dolist (where (var-read-nodes var)) + (baboon :format-control "Cannot replace a variable that forms part of a closure")) + (dolist (where (var-read-forms var)) (unless (and (eql (c1form-name where) 'VAR) (eql (c1form-arg 0 where) var)) (baboon :format-control "VAR-READ-NODES are only C1FORMS of type VAR")) + (delete-from-read-nodes var where) (c1form-replace-with where form)) - (setf (var-read-nodes var) nil - (var-ref var) 0 - (var-ignorable var) t)) + (setf (var-ignorable var) 0)) (defun member-var (var list) (let ((kind (var-kind var))) diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index 72ed5e53c..050e17acd 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -61,7 +61,6 @@ (let ((funob (local-function-ref fun t))) (if funob (let* ((var (fun-var funob))) - (incf (var-ref var)) (add-to-read-nodes var (make-c1form* 'VAR :args var))) (make-c1form* 'FUNCTION :type 'FUNCTION diff --git a/src/cmp/cmptag.lsp b/src/cmp/cmptag.lsp index 8abe5843d..04164a293 100644 --- a/src/cmp/cmptag.lsp +++ b/src/cmp/cmptag.lsp @@ -42,7 +42,7 @@ (dolist (v form) (add-reg1 v))) ((var-p form) - (incf (var-ref form) (the fixnum *reg-amount*))))) + (setf (var-ref form) most-positive-fixnum)))) (jumps-to-p (clause tag-name) ;; Does CLAUSE have a go TAG-NAME in it? (cond ((c1form-p clause) @@ -206,7 +206,6 @@ (var-kind var) 'LEXICAL)) (unw (unless (var-kind var) (setf (var-kind var) :OBJECT)))) - (incf (var-ref var)) (incf (tag-ref tag)) (add-to-read-nodes var (make-c1form* 'GO :args tag (or ccb clb unw)))))) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index dfe40a85e..e8790dfbf 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -22,14 +22,14 @@ var)) (defun var-referenced-in-form-list (var form-list) - (dolist (f form-list nil) - (when (var-referenced-in-form var f) - (return t)))) + (and (var-read-nodes var) + (loop for f in form-list + thereis (var-referenced-in-form var f)))) (defun var-changed-in-form-list (var form-list) - (dolist (f form-list nil) - (when (var-changed-in-form var f) - (return t)))) + (and (var-set-nodes var) + (loop for f in form-list + thereis (var-changed-in-form var f)))) ;;; FIXME! VAR-REFERENCED-IN-FORM and VAR-CHANGED-IN-FORM are too ;;; pessimistic. One should check whether the functions reading/setting the @@ -47,7 +47,7 @@ (let ((loc (var-loc var))) (when (var-p loc) (var-referenced-in-forms loc form))) - (or (find-node-in-list form (var-read-nodes var)) + (or (find-form-in-node-list form (var-read-nodes var)) (var-functions-reading var)))) (defun var-changed-in-form (var form) @@ -57,13 +57,54 @@ (let ((loc (var-loc var))) (when (var-p loc) (var-changed-in-form loc form))) - (or (find-node-in-list form (var-set-nodes var)) + (or (find-form-in-node-list form (var-set-nodes var)) (if (or (eq kind 'SPECIAL) (eq kind 'GLOBAL)) (c1form-sp-change form) (var-functions-setting var)))))) +(defun update-variable-type (var orig-type) + ;; FIXME! Refuse to update type of variables that are modified + (when (var-set-nodes var) + (return-from update-variable-type)) + (let ((type (type-and (var-type var) orig-type))) + (if (null type) + (cmpwarn "Variable assigned a value incompatible with its type declaration.~%Variable: ~A~%Expected type: ~A~%Value type: ~A" + (var-name var) + (var-type var) + orig-type) + (loop for form in (var-read-forms var) + when (and (eq (c1form-name form) 'VAR) + (eq var (c1form-arg 0 form))) + do (setf (c1form-type form) type) + finally (setf (var-type var) type))))) + +(defun var-read-forms (var) + (mapcar #'first (var-read-nodes var))) + +(defun assert-var-ref-value (var) + (unless (let ((ref (var-ref var))) + (or (> ref (/ most-positive-fixnum 2)) + (= (var-ref var) (+ (length (var-read-nodes var)) + (length (var-set-nodes var)))))) + (baboon :format-control "Number of references in VAR ~A unequal to references list" + :format-arguments (list var)))) + +(defun assert-var-not-ignored (var) + (when (let ((x (var-ignorable var))) (and x (minusp x))) + (cmpwarn "Variable ~A, declared as IGNORE, found in a lisp form." + (var-name var)) + (setf (var-ignorable var) nil))) + +(defun delete-from-read-nodes (var form) + (assert-var-ref-value var) + (setf (var-ref var) (1- (var-ref var)) + (var-read-nodes var) (delete-form-from-node-list form (var-read-nodes var)))) + (defun add-to-read-nodes (var form) - (push form (var-read-nodes var)) + (assert-var-ref-value var) + (assert-var-not-ignored var) + (setf (var-ref var) (1+ (var-ref var)) + (var-read-nodes var) (add-form-to-node-list form (var-read-nodes var))) (when *current-function* (unless (eq *current-function* (var-function var)) (pushnew *current-function* (var-functions-reading var)) @@ -71,7 +112,10 @@ form) (defun add-to-set-nodes (var form) - (push form (var-set-nodes var)) + (assert-var-ref-value var) + (assert-var-not-ignored var) + (setf (var-ref var) (1+ (var-ref var)) + (var-set-nodes var) (add-form-to-node-list form (var-set-nodes var))) ;;(push form (var-read-nodes var)) (when *current-function* (unless (eq *current-function* (var-function var)) @@ -139,7 +183,7 @@ (make-var :name name :type type :loc 'OBJECT :kind 'LEXICAL ; we rely on check-vref to fix it :ignorable ignorable - :ref (or ignorable 0)))))) + :ref 0))))) (defun check-vref (var) (when (eq (var-kind var) 'LEXICAL) @@ -154,17 +198,12 @@ :OBJECT))))) (defun c1var (name) - (let ((vref (c1vref name))) - (unless (var-p vref) - ;; This might be the case if there is a symbol macrolet - (return-from c1var vref)) - (let ((output (make-c1form* 'VAR :type (var-type vref) - :args vref))) - (add-to-read-nodes vref output) - output) - #+nil - (add-to-read-nodes vref (make-c1form* 'VAR :type (var-type vref) - :args vref)))) + (let* ((var (c1vref name)) + (output (make-c1form* 'VAR + :type (var-type var) + :args var))) + (add-to-read-nodes var output) + output)) (defun make-lcl-var (&key rep-type (type 'T)) (unless rep-type @@ -189,9 +228,8 @@ ;; symbol-macrolet (baboon)) (t - (when (minusp (var-ref var)) ; IGNORE. - (cmpwarn "The ignored variable ~s is used." name) - (setf (var-ref var) 0)) + (assert-var-ref-value var) + (assert-var-not-ignored var) (when (eq (var-kind var) 'LEXICAL) (cond (ccb (setf (var-ref-clb var) nil ; replace a previous 'CLB (var-ref-ccb var) t @@ -199,7 +237,6 @@ (var-loc var) 'OBJECT)) (clb (setf (var-ref-clb var) t (var-loc var) 'OBJECT)))) - (incf (var-ref var)) var)))) (defun push-vars (v)