Management of variable references, read and set nodes, and type updates is now done through the functions in cmpvar.lsp.

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))

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)

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)))

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

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))))))
 

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)