Commit d8dac21c authored by Juan Jose Garcia Ripoll's avatar Juan Jose Garcia Ripoll
Browse files

The c1form-parents field is now a list of the nodes above the current one. We...

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.
parent 85434943
......@@ -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)
......
......@@ -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))
......
......@@ -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)))
......@@ -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)))
......
......@@ -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
......
......@@ -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))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment