Tree-il post-order rewriter no longer destructive

* module/language/tree-il.scm (pre-post-order): New helper, like
  pre-order! and post-order! but not destructive.
  (post-order): Implement in terms of pre-post-order, and rename from
  post-order!.

* module/ice-9/compile-psyntax.scm (squeeze-tree-il):
* module/language/tree-il/canonicalize.scm (canonicalize):
* module/language/tree-il/fix-letrec.scm (fix-letrec):
* module/language/tree-il/primitives.scm (resolve-primitives): Use
  post-order, and rename from the destructive
  variants (squeeze-tree-il!, canonicalize!, etc).  Adapt callers.

* test-suite/tests/tree-il.test (strip-source): Adapt to post-order.

* test-suite/tests/cse.test:
* test-suite/tests/peval.test:
* module/language/tree-il/optimize.scm: Adapt callers.

module/ice-9/compile-psyntax.scm

@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 ;;;
-;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -73,13 +73,13 @@
          x)
         (else x)))
 
-(define (squeeze-tree-il! x)
+(define (squeeze-tree-il x)
-  (post-order! (lambda (x)
+  (post-order (lambda (x)
-                 (if (const? x)
+                (if (const? x)
-                     (set! (const-exp x)
+                    (make-const (const-src x)
-                           (squeeze-constant! (const-exp x))))
+                                (squeeze-constant! (const-exp x)))
-                 #f)
+                    x))
-               x))
+              x))
 
 ;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
 ;; changing session identifiers.
@@ -99,9 +99,9 @@
             (close-port in))
           (begin
             (pretty-print (tree-il->scheme
-                           (squeeze-tree-il!
+                           (squeeze-tree-il
-                            (canonicalize!
+                            (canonicalize
-                             (resolve-primitives!
+                             (resolve-primitives
                               (macroexpand x 'c '(compile load eval))
                               (current-module))))
                            (current-module)

module/language/tree-il.scm

@@ -61,7 +61,7 @@
 
             tree-il-fold
             make-tree-il-folder
-            post-order!
+            post-order
             pre-order!
 
             tree-il=?
@@ -529,95 +529,92 @@ This is an implementation of `foldts' as described by Andy Wingo in
                (values seed ...)))))
         (up tree seed ...)))))
 
-(define (post-order! f x)
+(define (pre-post-order pre post x)
   (let lp ((x x))
-    (record-case x
+    (post
-      ((<call> proc args)
+     (record-case (pre x)
-       (set! (call-proc x) (lp proc))
+       ((<void> src)
-       (set! (call-args x) (map lp args)))
+        (make-void src))
 
-      ((<primcall> name args)
+       ((<const> src exp)
-       (set! (primcall-args x) (map lp args)))
+        (make-const src exp))
 
-      ((<conditional> test consequent alternate)
+       ((<primitive-ref> src name)
-       (set! (conditional-test x) (lp test))
+        (make-primitive-ref src name))
-       (set! (conditional-consequent x) (lp consequent))
-       (set! (conditional-alternate x) (lp alternate)))
 
-      ((<lexical-set> name gensym exp)
+       ((<lexical-ref> src name gensym)
-       (set! (lexical-set-exp x) (lp exp)))
+        (make-lexical-ref src name gensym))
 
-      ((<module-set> mod name public? exp)
+       ((<lexical-set> src name gensym exp)
-       (set! (module-set-exp x) (lp exp)))
+        (make-lexical-set src name gensym (lp exp)))
 
-      ((<toplevel-set> name exp)
+       ((<module-ref> src mod name public?)
-       (set! (toplevel-set-exp x) (lp exp)))
+        (make-module-ref src mod name public?))
 
-      ((<toplevel-define> name exp)
+       ((<module-set> src mod name public? exp)
-       (set! (toplevel-define-exp x) (lp exp)))
+        (make-module-set src mod name public? (lp exp)))
 
-      ((<lambda> body)
+       ((<toplevel-ref> src name)
-       (if body
+        (make-toplevel-ref src name))
-           (set! (lambda-body x) (lp body))))
 
-      ((<lambda-case> inits body alternate)
+       ((<toplevel-set> src name exp)
-       (set! inits (map lp inits))
+        (make-toplevel-set src name (lp exp)))
-       (set! (lambda-case-body x) (lp body))
-       (if alternate
-           (set! (lambda-case-alternate x) (lp alternate))))
 
-      ((<seq> head tail)
+       ((<toplevel-define> src name exp)
-       (set! (seq-head x) (lp head))
+        (make-toplevel-define src name (lp exp)))
-       (set! (seq-tail x) (lp tail)))
+
+       ((<conditional> src test consequent alternate)
+        (make-conditional src (lp test) (lp consequent) (lp alternate)))
+
+       ((<call> src proc args)
+        (make-call src (lp proc) (map lp args)))
+
+       ((<primcall> src name args)
+        (make-primcall src name (map lp args)))
+
+       ((<seq> src head tail)
+        (make-seq src (lp head) (lp tail)))
       
-      ((<let> gensyms vals body)
+       ((<lambda> src meta body)
-       (set! (let-vals x) (map lp vals))
+        (make-lambda src meta (and body (lp body))))
-       (set! (let-body x) (lp body)))
 
-      ((<letrec> gensyms vals body)
+       ((<lambda-case> src req opt rest kw inits gensyms body alternate)
-       (set! (letrec-vals x) (map lp vals))
+        (make-lambda-case src req opt rest kw (map lp inits) gensyms (lp body)
-       (set! (letrec-body x) (lp body)))
+                          (and alternate (lp alternate))))
 
-      ((<fix> gensyms vals body)
+       ((<let> src names gensyms vals body)
-       (set! (fix-vals x) (map lp vals))
+        (make-let src names gensyms (map lp vals) (lp body)))
-       (set! (fix-body x) (lp body)))
 
-      ((<let-values> exp body)
+       ((<letrec> src in-order? names gensyms vals body)
-       (set! (let-values-exp x) (lp exp))
+        (make-letrec src in-order? names gensyms (map lp vals) (lp body)))
-       (set! (let-values-body x) (lp body)))
 
-      ((<dynwind> winder pre body post unwinder)
+       ((<fix> src names gensyms vals body)
-       (set! (dynwind-winder x) (lp winder))
+        (make-fix src names gensyms (map lp vals) (lp body)))
-       (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)
+       ((<let-values> src exp body)
-       (set! (dynlet-fluids x) (map lp fluids))
+        (make-let-values src (lp exp) (lp body)))
-       (set! (dynlet-vals x) (map lp vals))
-       (set! (dynlet-body x) (lp body)))
 
-      ((<dynref> fluid)
+       ((<dynwind> src winder pre body post unwinder)
-       (set! (dynref-fluid x) (lp fluid)))
+        (make-dynwind src
+                      (lp winder) (lp pre) (lp body) (lp post) (lp unwinder)))
 
-      ((<dynset> fluid exp)
+       ((<dynlet> src fluids vals body)
-       (set! (dynset-fluid x) (lp fluid))
+        (make-dynlet src (map lp fluids) (map lp vals) (lp body)))
-       (set! (dynset-exp x) (lp exp)))
 
-      ((<prompt> tag body handler)
+       ((<dynref> src fluid)
-       (set! (prompt-tag x) (lp tag))
+        (make-dynref src (lp fluid)))
-       (set! (prompt-body x) (lp body))
-       (set! (prompt-handler x) (lp handler)))
 
-      ((<abort> tag args tail)
+       ((<dynset> src fluid exp)
-       (set! (abort-tag x) (lp tag))
+        (make-dynset src (lp fluid) (lp exp)))
-       (set! (abort-args x) (map lp args))
-       (set! (abort-tail x) (lp tail)))
 
-      (else #f))
+       ((<prompt> src tag body handler)
+        (make-prompt src (lp tag) (lp body) (lp handler)))
 
-    (or (f x) x)))
+       ((<abort> src tag args tail)
+        (make-abort src (lp tag) (map lp args) (lp tail)))))))
+
+(define (post-order f x)
+  (pre-post-order (lambda (x) x) f x))
 
 (define (pre-order! f x)
   (let lp ((x x))

module/language/tree-il/canonicalize.scm

@@ -22,7 +22,7 @@
   #:use-module (language tree-il)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-  #:export (canonicalize!))
+  #:export (canonicalize))
 
 (define (tree-il-any proc exp)
   (tree-il-fold (lambda (exp res)
@@ -32,8 +32,8 @@
                 (lambda (exp res) res)
                 #f exp))
 
-(define (canonicalize! x)
+(define (canonicalize x)
-  (post-order!
+  (post-order
    (lambda (x)
      (match x
        (($ <let> src () () () body)
@@ -85,7 +85,7 @@
         ;; thunk.  Sad but true.
         (if (or (escape-only? handler)
                 (thunk-application? body))
-            #f
+            x
             (make-prompt src tag (make-thunk-application body) handler)))
-       (_ #f)))
+       (_ x)))
    x))

module/language/tree-il/compile-glil.scm

@@ -65,7 +65,7 @@
   (let* ((x (make-lambda (tree-il-src x) '()
                          (make-lambda-case #f '() #f #f #f '() '() x #f)))
          (x (optimize! x e opts))
-         (x (canonicalize! x))
+         (x (canonicalize x))
          (allocation (analyze-lexicals x)))
 
     (with-fluids ((*comp-module* e))

module/language/tree-il/fix-letrec.scm

@@ -1,6 +1,6 @@
 ;;; transformation of letrec into simpler forms
 
-;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -22,7 +22,7 @@
   #:use-module (srfi srfi-11)
   #:use-module (language tree-il)
   #:use-module (language tree-il effects)
-  #:export (fix-letrec!))
+  #:export (fix-letrec))
 
 ;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
 ;; Efficient Implementation of Scheme's Recursive Binding Construct", by
@@ -210,9 +210,9 @@
                        (car exps))
             (lp (cdr exps) (cons (car exps) effects))))))
 
-(define (fix-letrec! x)
+(define (fix-letrec x)
   (let-values (((unref simple lambda* complex) (partition-vars x)))
-    (post-order!
+    (post-order
      (lambda (x)
        (record-case x
 

module/language/tree-il/optimize.scm

@@ -1,6 +1,6 @@
 ;;; Tree-il optimizer
 
-;; Copyright (C) 2009, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011, 2012, 2013 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -39,9 +39,9 @@
                 ;; Disable CSE.
                 (lambda (x) x))
                (_ cse))))
-    (fix-letrec!
+    (fix-letrec
      (verify-tree-il
       (cse
        (verify-tree-il
-        (peval (expand-primitives! (resolve-primitives! x env))
+        (peval (expand-primitives! (resolve-primitives x env))
                env)))))))

module/language/tree-il/primitives.scm

@@ -1,6 +1,6 @@
 ;;; open-coding primitive procedures
 
-;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -25,7 +25,7 @@
   #:use-module (language tree-il)
   #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-16)
-  #:export (resolve-primitives! add-interesting-primitive!
+  #:export (resolve-primitives add-interesting-primitive!
             expand-primitives!
             effect-free-primitive? effect+exception-free-primitive?
             constructor-primitive? accessor-primitive?
@@ -248,7 +248,7 @@
 (define (negate-primitive prim)
   (hashq-ref *negatable-primitive-table* prim))
 
-(define (resolve-primitives! x mod)
+(define (resolve-primitives x mod)
   (define local-definitions
     (make-hash-table))
 
@@ -261,30 +261,32 @@
        (collect-local-definitions tail))
       (else #f)))
   
-  (post-order!
+  (post-order
    (lambda (x)
-     (record-case x
+     (or
-       ((<toplevel-ref> src name)
+      (record-case x
-        (and=> (and (not (hashq-ref local-definitions name))
+        ((<toplevel-ref> src name)
-                    (hashq-ref *interesting-primitive-vars*
+         (and=> (and (not (hashq-ref local-definitions name))
-                               (module-variable mod name)))
+                     (hashq-ref *interesting-primitive-vars*
-               (lambda (name) (make-primitive-ref src name))))
+                                (module-variable mod name)))
-       ((<module-ref> src mod name public?)
+                (lambda (name) (make-primitive-ref src name))))
-        ;; for the moment, we're disabling primitive resolution for
+        ((<module-ref> src mod name public?)
-        ;; public refs because resolve-interface can raise errors.
+         ;; for the moment, we're disabling primitive resolution for
-        (and=> (and=> (resolve-module mod)
+         ;; public refs because resolve-interface can raise errors.
-                      (if public?
+         (and=> (and=> (resolve-module mod)
-                          module-public-interface
+                       (if public?
-                          identity))
+                           module-public-interface
-               (lambda (m)
+                           identity))
-                 (and=> (hashq-ref *interesting-primitive-vars*
+                (lambda (m)
-                                   (module-variable m name))
+                  (and=> (hashq-ref *interesting-primitive-vars*
-                        (lambda (name)
+                                    (module-variable m name))
-                          (make-primitive-ref src name))))))
+                         (lambda (name)
-       ((<call> src proc args)
+                           (make-primitive-ref src name))))))
-        (and (primitive-ref? proc)
+        ((<call> src proc args)
-             (make-primcall src (primitive-ref-name proc) args)))
+         (and (primitive-ref? proc)
-       (else #f)))
+              (make-primcall src (primitive-ref-name proc) args)))
+        (else #f))
+      x))
    x))
 
 

test-suite/tests/cse.test

@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
 ;;;;
-;;;; 	Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -36,12 +36,12 @@
     ((_ in pat)
      (pass-if 'in
        (let ((evaled (unparse-tree-il
-                      (canonicalize!
+                      (canonicalize
-                       (fix-letrec!
+                       (fix-letrec
                         (cse
                          (peval
                           (expand-primitives!
-                           (resolve-primitives!
+                           (resolve-primitives
                             (compile 'in #:from 'scheme #:to 'tree-il)
                             (current-module))))))))))
          (pmatch evaled

test-suite/tests/peval.test

@@ -37,7 +37,7 @@
     ((_ in pat)
      (pass-if-peval in pat
                     (expand-primitives!
-                     (resolve-primitives!
+                     (resolve-primitives
                       (compile 'in #:from 'scheme #:to 'tree-il)
                       (current-module)))))
     ((_ in pat code)
@@ -489,7 +489,7 @@
     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
     (pmatch (unparse-tree-il
              (peval (expand-primitives!
-                     (resolve-primitives!
+                     (resolve-primitives
                       (compile
                        '(let ((make-adder
                                (lambda (x) (lambda (y) (+ x y)))))

test-suite/tests/tree-il.test

@@ -32,8 +32,10 @@
 ;; information from the incoming tree-il.
 
 (define (strip-source x)
-  (post-order! (lambda (x) (set! (tree-il-src x) #f))
+  (post-order (lambda (x)
-               x))
+                (set! (tree-il-src x) #f)
+                x)
+              x))
 
 (define-syntax assert-tree-il->glil
   (syntax-rules (with-partial-evaluation without-partial-evaluation
@@ -64,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)