Pre-order tree-il rewrites are now non-destructive

* module/language/tree-il.scm (pre-order): Re-implement in terms of
  pre-post-order, and rename from pre-order!.

* module/language/tree-il/primitives.scm (expand-primitives): Adapt to
  pre-order change, and rename from expand-primitives!.

* module/language/tree-il/optimize.scm (optimize): Adapt to
  expand-primitives! change, and rename from optimize!.

* module/language/tree-il/compile-glil.scm:
* module/system/repl/common.scm:
* test-suite/tests/cse.test:
* test-suite/tests/peval.test:
* test-suite/tests/tree-il.test: Adapt to expand-primitives and optimize
  changes.

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index b5b7807..0a5b72a 100644 (file)
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -62,7 +62,7 @@
             tree-il-fold
             make-tree-il-folder
             post-order
-            pre-order!
+            pre-order
 
             tree-il=?
             tree-il-hash))
@@ -616,94 +616,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
 (define (post-order f x)
   (pre-post-order (lambda (x) x) f x))
 
-(define (pre-order! f x)
-  (let lp ((x x))
-    (let ((x (or (f x) x)))
-      (record-case x
-        ((<call> proc args)
-         (set! (call-proc x) (lp proc))
-         (set! (call-args x) (map lp args)))
-
-        ((<primcall> name args)
-         (set! (primcall-args x) (map lp args)))
-
-        ((<conditional> test consequent alternate)
-         (set! (conditional-test x) (lp test))
-         (set! (conditional-consequent x) (lp consequent))
-         (set! (conditional-alternate x) (lp alternate)))
-
-        ((<lexical-set> exp)
-         (set! (lexical-set-exp x) (lp exp)))
-
-        ((<module-set> exp)
-         (set! (module-set-exp x) (lp exp)))
-
-        ((<toplevel-set> exp)
-         (set! (toplevel-set-exp x) (lp exp)))
-
-        ((<toplevel-define> exp)
-         (set! (toplevel-define-exp x) (lp exp)))
-
-        ((<lambda> body)
-         (if body
-             (set! (lambda-body x) (lp body))))
-
-        ((<lambda-case> inits body alternate)
-         (set! inits (map lp inits))
-         (set! (lambda-case-body x) (lp body))
-         (if alternate (set! (lambda-case-alternate x) (lp alternate))))
-
-        ((<seq> head tail)
-         (set! (seq-head x) (lp head))
-         (set! (seq-tail x) (lp tail)))
-        
-        ((<let> vals body)
-         (set! (let-vals x) (map lp vals))
-         (set! (let-body x) (lp body)))
-
-        ((<letrec> vals body)
-         (set! (letrec-vals x) (map lp vals))
-         (set! (letrec-body x) (lp body)))
-
-        ((<fix> vals body)
-         (set! (fix-vals x) (map lp vals))
-         (set! (fix-body x) (lp body)))
-
-        ((<let-values> exp body)
-         (set! (let-values-exp x) (lp exp))
-         (set! (let-values-body x) (lp body)))
-
-        ((<dynwind> winder pre body post unwinder)
-         (set! (dynwind-winder x) (lp winder))
-         (set! (dynwind-pre x) (lp pre))
-         (set! (dynwind-body x) (lp body))
-         (set! (dynwind-post x) (lp post))
-         (set! (dynwind-unwinder x) (lp unwinder)))
-
-        ((<dynlet> fluids vals body)
-         (set! (dynlet-fluids x) (map lp fluids))
-         (set! (dynlet-vals x) (map lp vals))
-         (set! (dynlet-body x) (lp body)))
-
-        ((<dynref> fluid)
-         (set! (dynref-fluid x) (lp fluid)))
-
-        ((<dynset> fluid exp)
-         (set! (dynset-fluid x) (lp fluid))
-         (set! (dynset-exp x) (lp exp)))
-
-        ((<prompt> tag body handler)
-         (set! (prompt-tag x) (lp tag))
-         (set! (prompt-body x) (lp body))
-         (set! (prompt-handler x) (lp handler)))
-
-        ((<abort> tag args tail)
-         (set! (abort-tag x) (lp tag))
-         (set! (abort-args x) (map lp args))
-         (set! (abort-tail x) (lp tail)))
-
-        (else #f))
-      x)))
+(define (pre-order f x)
+  (pre-post-order f (lambda (x) x) x))
 
 ;; FIXME: We should have a better primitive than this.
 (define (struct-nfields x)

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index db154cd..353bd03 100644 (file)
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -64,7 +64,7 @@
 
   (let* ((x (make-lambda (tree-il-src x) '()
                          (make-lambda-case #f '() #f #f #f '() '() x #f)))
-         (x (optimize! x e opts))
+         (x (optimize x e opts))
          (x (canonicalize x))
          (allocation (analyze-lexicals x)))
 

diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index b95f1ae..4fb8f59 100644 (file)
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -26,9 +26,9 @@
   #:use-module (language tree-il fix-letrec)
   #:use-module (language tree-il debug)
   #:use-module (ice-9 match)
-  #:export (optimize!))
+  #:export (optimize))
 
-(define (optimize! x env opts)
+(define (optimize x env opts)
   (let ((peval (match (memq #:partial-eval? opts)
                  ((#:partial-eval? #f _ ...)
                   ;; Disable partial evaluation.
@@ -43,5 +43,5 @@
      (verify-tree-il
       (cse
        (verify-tree-il
-        (peval (expand-primitives! (resolve-primitives x env))
+        (peval (expand-primitives (resolve-primitives x env))
                env)))))))

diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 32e1722..cbda2db 100644 (file)
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -26,7 +26,7 @@
   #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-16)
   #:export (resolve-primitives add-interesting-primitive!
-            expand-primitives!
+            expand-primitives
             effect-free-primitive? effect+exception-free-primitive?
             constructor-primitive? accessor-primitive?
             singly-valued-primitive? equality-primitive?
@@ -160,7 +160,7 @@
     integer->char char->integer number->string string->number
     struct-vtable
     string-length vector-length
-    ;; These all should get expanded out by expand-primitives!.
+    ;; These all should get expanded out by expand-primitives.
     caar cadr cdar cddr
     caaar caadr cadar caddr cdaar cdadr cddar cdddr
     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
@@ -293,14 +293,15 @@
 
 (define *primitive-expand-table* (make-hash-table))
 
-(define (expand-primitives! x)
-  (pre-order!
+(define (expand-primitives x)
+  (pre-order
    (lambda (x)
      (record-case x
        ((<primcall> src name args)
         (let ((expand (hashq-ref *primitive-expand-table* name)))
-          (and expand (apply expand src args))))
-       (else #f)))
+          (or (and expand (apply expand src args))
+              x)))
+       (else x)))
    x))
 
 ;;; I actually did spend about 10 minutes trying to redo this with

diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 5da7c48..94b41ea 100644 (file)
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -25,7 +25,7 @@
   #:use-module (system base language)
   #:use-module (system base message)
   #:use-module (system vm program)
-  #:autoload (language tree-il optimize) (optimize!)
+  #:autoload (language tree-il optimize) (optimize)
   #:use-module (ice-9 control)
   #:use-module (ice-9 history)
   #:export (<repl> make-repl repl-language repl-options
@@ -189,10 +189,10 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
 (define (repl-optimize repl form)
   (let ((from (repl-language repl))
         (opts (repl-compile-options repl)))
-    (decompile (optimize! (compile form #:from from #:to 'tree-il #:opts opts
-                                   #:env (current-module))
-                          (current-module)
-                          opts)
+    (decompile (optimize (compile form #:from from #:to 'tree-il #:opts opts
+                                  #:env (current-module))
+                         (current-module)
+                         opts)
                #:from 'tree-il #:to from)))
 
 (define (repl-parse repl form)

diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index e29bac9..e60fdf3 100644 (file)
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -40,7 +40,7 @@
                        (fix-letrec
                         (cse
                          (peval
-                          (expand-primitives!
+                          (expand-primitives
                            (resolve-primitives
                             (compile 'in #:from 'scheme #:to 'tree-il)
                             (current-module))))))))))

diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index abc995c..8f237b8 100644 (file)
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -36,7 +36,7 @@
   (syntax-rules ()
     ((_ in pat)
      (pass-if-peval in pat
-                    (expand-primitives!
+                    (expand-primitives
                      (resolve-primitives
                       (compile 'in #:from 'scheme #:to 'tree-il)
                       (current-module)))))
@@ -488,7 +488,7 @@
     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
     (pmatch (unparse-tree-il
-             (peval (expand-primitives!
+             (peval (expand-primitives
                      (resolve-primitives
                       (compile
                        '(let ((make-adder

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 6205277..a98921b 100644 (file)
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -66,7 +66,7 @@
                        (beautify-user-module! m)
                        m))
            (orig     (parse-tree-il 'in))
-           (resolved (expand-primitives! (resolve-primitives orig module))))
+           (resolved (expand-primitives (resolve-primitives orig module))))
       (or (equal? (unparse-tree-il resolved) 'expected)
           (begin
             (format (current-error-port)