The c1form-parents field is now a list of the nodes above the current one. We provide functions to rewrite the list when moving the node and speed up FIND-NODE-IN-LIST using this list.

src/cmp/cmpct.lsp

@@ -23,7 +23,7 @@
        (setf x (cdr x))
        (if (listp x)
            (c1expr x)
-           (copy-structure x)))))
+           x))))
    ((eq val nil) (c1nil))
    ((eq val t) (c1t))
    ((sys::fixnump val)

src/cmp/cmpeval.lsp

@@ -42,9 +42,9 @@
       form))
 
 (defvar *c1nil* (make-c1form* 'LOCATION :type (object-type nil) :args nil))
-(defun c1nil () (copy-structure *c1nil*))
+(defun c1nil () *c1nil*)
 (defvar *c1t* (make-c1form* 'LOCATION :type (object-type t) :args t))
-(defun c1t () (copy-structure *c1t*))
+(defun c1t () *c1t*)
 
 (defun c1call-symbol (fname args &aux fd)
   (cond ((setq fd (get-sysprop fname 'c1special)) (funcall fd args))

src/cmp/cmpform.lsp

@@ -129,32 +129,67 @@
       (c1form-add-info form form-args)
       form)))
 
+(defun c1form-add-info-loop (form dependents)
+  (loop for subform in dependents
+     when (c1form-p subform)
+     do (progn
+          (when (c1form-sp-change subform)
+            (setf (c1form-sp-change form) t
+                  (c1form-side-effects form) t))
+          (when (c1form-side-effects subform)
+            (setf (c1form-side-effects form) t))
+          (unless (eq (c1form-name subform) 'LOCATION)
+            (when (rest (c1form-parents subform))
+              (error "Running twice through same form"))
+            (setf (c1form-parents subform)
+                  (nconc (c1form-parents subform)
+                         (c1form-parents form)))))
+     when (consp subform)
+     do (c1form-add-info-loop form subform)))
+
 (defun c1form-add-info (form dependents)
-  (labels ((add-info-loop (form dependents)
-             (loop for subform in dependents
-                when (c1form-p subform)
-                do (progn
-                     (when (c1form-sp-change subform)
-                       (setf (c1form-sp-change form) t
-                             (c1form-side-effects form) t))
-                     (when (c1form-side-effects subform)
-                       (setf (c1form-side-effects form) t))
-                     (setf (c1form-parent subform) form))
-                when (consp subform)
-                do (add-info-loop form subform))))
-    (let ((record (gethash (c1form-name form) +c1-form-hash+)))
-      (unless record
-        (error "Internal error: unknown C1FORM name ~A"
-               (c1form-name form)))
-      (let ((length (first record))
-            (sp-change (c1form-sp-change form))
-            (side-effects (second record)))
-        (setf (c1form-side-effects form) (or (c1form-side-effects form)
-                                             sp-change
-                                             side-effects))
-        (unless (or (null length) (= length (length (c1form-args form))))
-          (error "Internal error: illegal number of arguments in ~A" form))))
-    (add-info-loop form dependents)))
+  (let ((record (gethash (c1form-name form) +c1-form-hash+)))
+    (unless record
+      (error "Internal error: unknown C1FORM name ~A"
+             (c1form-name form)))
+    (let ((length (first record))
+          (sp-change (c1form-sp-change form))
+          (side-effects (second record)))
+      (setf (c1form-side-effects form)
+            (or (c1form-side-effects form) sp-change side-effects)
+            (c1form-parents form)
+            (list form))
+      (unless (or (null length) (= length (length (c1form-args form))))
+        (error "Internal error: illegal number of arguments in ~A" form))))
+  (c1form-add-info-loop form dependents))
+
+(defun c1form-replace-with (dest new-fields)
+  (let* (new-parents)
+    ;; 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).
+    (if (eq (c1form-name new-fields) 'LOCATION)
+        (setf new-parents (c1form-parents dest))
+        (setf new-parents (c1form-parents new-fields)
+              (car new-parents) dest
+              (cdr new-parents) (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 fields are just copied
+    (setf (c1form-type dest) (c1form-type 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-name dest) (c1form-name new-fields)
+          (c1form-args dest) (c1form-args new-fields)
+          (c1form-parents dest) new-parents
+          (c1form-env dest) (c1form-env new-fields)
+          (c1form-form dest) (c1form-form new-fields)
+          (c1form-toplevel-form dest) (c1form-toplevel-form new-fields)
+          (c1form-file dest) (c1form-file new-fields)
+          (c1form-file-position dest) (c1form-file-position new-fields))))
 
 (defun copy-c1form (form)
   (copy-structure form))
@@ -177,8 +212,5 @@
 
 (defun find-node-in-list (home-node list)
   (flet ((parent-node-p (node presumed-child)
-	   (loop
-	    (cond ((null presumed-child) (return nil))
-		  ((eq node presumed-child) (return t))
-		  (t (setf presumed-child (c1form-parent presumed-child)))))))
+           (member node (c1form-parents presumed-child))))
     (member home-node list :test #'parent-node-p)))

src/cmp/cmplet.lsp

@@ -501,18 +501,11 @@
   ;; Only take the first value out of the form
   #+nil
   (setf form (make-c1form* 'VALUES :args (list form)))
-  (dolist (where (var-read-nodes var))
-    (cond ((and (eql (c1form-name where) 'VAR)
-		(eql (c1form-arg 0 where) var))
-	   (setf (c1form-type where) (c1form-type form)
-		 (c1form-sp-change where) (c1form-sp-change form)
-		 (c1form-volatile where) (c1form-volatile form)
-		 (c1form-name where) (c1form-name form)
-		 (c1form-args where) (c1form-args form))
-	   (c1form-add-info where (c1form-args where))
-	   )
-	  (t
-	   (baboon "VAR-SET-NODES are only C1FORMS of type VAR")))))
+  (let ((where (first (var-read-nodes var))))
+    (unless (and (eql (c1form-name where) 'VAR)
+                 (eql (c1form-arg 0 where) var))
+      (baboon "VAR-READ-NODES are only C1FORMS of type VAR"))
+    (c1form-replace-with where form)))
 
 (defun member-var (var list)
   (let ((kind (var-kind var)))

src/cmp/cmptypes.lsp

@@ -238,7 +238,7 @@
 		   (:print-object print-c1form)
 		   (:constructor do-make-c1form))
   (name nil)
-  (parent nil)
+  (parents nil)
   #+new-cmp
   (env (c-env:cmp-env-copy)) ;; Environment in which this form was compiled
   #-new-cmp

src/cmp/cmputil.lsp

@@ -289,7 +289,8 @@
 (defun undefined-variable (sym)
   (do-cmpwarn 'compiler-undefined-variable :name sym))
   
-(defun baboon (&aux (*print-case* :upcase))
+(defun baboon (&key (format-control "A bug was found in the compiler")
+               format-arguments)
   (signal 'compiler-internal-error
 	  :format-control "A bug was found in the compiler."
 	  :format-arguments nil))