diff --git a/src/cmp/cmpct.lsp b/src/cmp/cmpct.lsp index a43234b42..ac256e2a0 100644 --- a/src/cmp/cmpct.lsp +++ b/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) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 2f80f5eb6..54f0b133b 100644 --- a/src/cmp/cmpeval.lsp +++ b/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)) diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index d06b757c6..d2cfdbb7d 100644 --- a/src/cmp/cmpform.lsp +++ b/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))) diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index 124c3f4ee..b85050b7e 100644 --- a/src/cmp/cmplet.lsp +++ b/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))) diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp index 58a1e2095..9e7031d1d 100644 --- a/src/cmp/cmptypes.lsp +++ b/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 diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index e211ba215..6b57e57ae 100644 --- a/src/cmp/cmputil.lsp +++ b/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))