summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-05-28 10:56:05 -0400
committerAndy Wingo <wingo@pobox.com>2013-06-10 22:46:08 +0200
commit403d78f915552a6eaaf2ecd7a93b2a7dc2983585 (patch)
tree515ac3b9d08d70437256c22be56e978c3ebe4258
parent64fc50c294df9b6644fd40bec90eb8f4dfbc3907 (diff)
downloadguile-403d78f915552a6eaaf2ecd7a93b2a7dc2983585.tar.gz
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.
-rw-r--r--module/ice-9/compile-psyntax.scm22
-rw-r--r--module/language/tree-il.scm155
-rw-r--r--module/language/tree-il/canonicalize.scm10
-rw-r--r--module/language/tree-il/compile-glil.scm2
-rw-r--r--module/language/tree-il/fix-letrec.scm8
-rw-r--r--module/language/tree-il/optimize.scm6
-rw-r--r--module/language/tree-il/primitives.scm54
-rw-r--r--test-suite/tests/cse.test8
-rw-r--r--test-suite/tests/peval.test4
-rw-r--r--test-suite/tests/tree-il.test8
10 files changed, 139 insertions, 138 deletions
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 201ae395e..21d639fa1 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/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)
- (post-order! (lambda (x)
- (if (const? x)
- (set! (const-exp x)
- (squeeze-constant! (const-exp x))))
- #f)
- x))
+(define (squeeze-tree-il x)
+ (post-order (lambda (x)
+ (if (const? x)
+ (make-const (const-src x)
+ (squeeze-constant! (const-exp 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!
- (canonicalize!
- (resolve-primitives!
+ (squeeze-tree-il
+ (canonicalize
+ (resolve-primitives
(macroexpand x 'c '(compile load eval))
(current-module))))
(current-module)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index ddcba9938..b5b7807bd 100644
--- a/module/language/tree-il.scm
+++ b/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
- ((<call> proc args)
- (set! (call-proc x) (lp proc))
- (set! (call-args x) (map lp args)))
+ (post
+ (record-case (pre x)
+ ((<void> src)
+ (make-void src))
- ((<primcall> name args)
- (set! (primcall-args x) (map lp args)))
+ ((<const> src exp)
+ (make-const src exp))
- ((<conditional> test consequent alternate)
- (set! (conditional-test x) (lp test))
- (set! (conditional-consequent x) (lp consequent))
- (set! (conditional-alternate x) (lp alternate)))
+ ((<primitive-ref> src name)
+ (make-primitive-ref src name))
- ((<lexical-set> name gensym exp)
- (set! (lexical-set-exp x) (lp exp)))
+ ((<lexical-ref> src name gensym)
+ (make-lexical-ref src name gensym))
- ((<module-set> mod name public? exp)
- (set! (module-set-exp x) (lp exp)))
+ ((<lexical-set> src name gensym exp)
+ (make-lexical-set src name gensym (lp exp)))
- ((<toplevel-set> name exp)
- (set! (toplevel-set-exp x) (lp exp)))
+ ((<module-ref> src mod name public?)
+ (make-module-ref src mod name public?))
- ((<toplevel-define> name exp)
- (set! (toplevel-define-exp x) (lp exp)))
+ ((<module-set> src mod name public? exp)
+ (make-module-set src mod name public? (lp exp)))
- ((<lambda> body)
- (if body
- (set! (lambda-body x) (lp body))))
+ ((<toplevel-ref> src name)
+ (make-toplevel-ref src name))
- ((<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))))
+ ((<toplevel-set> src name exp)
+ (make-toplevel-set src name (lp exp)))
- ((<seq> head tail)
- (set! (seq-head x) (lp head))
- (set! (seq-tail x) (lp tail)))
+ ((<toplevel-define> src name exp)
+ (make-toplevel-define src name (lp exp)))
+
+ ((<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)
- (set! (let-vals x) (map lp vals))
- (set! (let-body x) (lp body)))
-
- ((<letrec> gensyms vals body)
- (set! (letrec-vals x) (map lp vals))
- (set! (letrec-body x) (lp body)))
-
- ((<fix> gensyms 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))
-
- (or (f x) x)))
+ ((<lambda> src meta body)
+ (make-lambda src meta (and body (lp body))))
+
+ ((<lambda-case> src req opt rest kw inits gensyms body alternate)
+ (make-lambda-case src req opt rest kw (map lp inits) gensyms (lp body)
+ (and alternate (lp alternate))))
+
+ ((<let> src names gensyms vals body)
+ (make-let src names gensyms (map lp vals) (lp body)))
+
+ ((<letrec> src in-order? names gensyms vals body)
+ (make-letrec src in-order? names gensyms (map lp vals) (lp body)))
+
+ ((<fix> src names gensyms vals body)
+ (make-fix src names gensyms (map lp vals) (lp body)))
+
+ ((<let-values> src exp body)
+ (make-let-values src (lp exp) (lp body)))
+
+ ((<dynwind> src winder pre body post unwinder)
+ (make-dynwind src
+ (lp winder) (lp pre) (lp body) (lp post) (lp unwinder)))
+
+ ((<dynlet> src fluids vals body)
+ (make-dynlet src (map lp fluids) (map lp vals) (lp body)))
+
+ ((<dynref> src fluid)
+ (make-dynref src (lp fluid)))
+
+ ((<dynset> src fluid exp)
+ (make-dynset src (lp fluid) (lp exp)))
+
+ ((<prompt> src tag body handler)
+ (make-prompt src (lp tag) (lp body) (lp handler)))
+
+ ((<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))
diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm
index 1db842022..4f2eb5262 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/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)
- (post-order!
+(define (canonicalize x)
+ (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))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 1b6fea69c..db154cda9 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/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))
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index b5722fe09..d8f127afa 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/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
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index c6e4fec07..b95f1ae67 100644
--- a/module/language/tree-il/optimize.scm
+++ b/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)))))))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index e3f6a9071..32e172289 100644
--- a/module/language/tree-il/primitives.scm
+++ b/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
- ((<toplevel-ref> src name)
- (and=> (and (not (hashq-ref local-definitions name))
- (hashq-ref *interesting-primitive-vars*
- (module-variable mod name)))
- (lambda (name) (make-primitive-ref src name))))
- ((<module-ref> src mod name public?)
- ;; for the moment, we're disabling primitive resolution for
- ;; public refs because resolve-interface can raise errors.
- (and=> (and=> (resolve-module mod)
- (if public?
- module-public-interface
- identity))
- (lambda (m)
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable m name))
- (lambda (name)
- (make-primitive-ref src name))))))
- ((<call> src proc args)
- (and (primitive-ref? proc)
- (make-primcall src (primitive-ref-name proc) args)))
- (else #f)))
+ (or
+ (record-case x
+ ((<toplevel-ref> src name)
+ (and=> (and (not (hashq-ref local-definitions name))
+ (hashq-ref *interesting-primitive-vars*
+ (module-variable mod name)))
+ (lambda (name) (make-primitive-ref src name))))
+ ((<module-ref> src mod name public?)
+ ;; for the moment, we're disabling primitive resolution for
+ ;; public refs because resolve-interface can raise errors.
+ (and=> (and=> (resolve-module mod)
+ (if public?
+ module-public-interface
+ identity))
+ (lambda (m)
+ (and=> (hashq-ref *interesting-primitive-vars*
+ (module-variable m name))
+ (lambda (name)
+ (make-primitive-ref src name))))))
+ ((<call> src proc args)
+ (and (primitive-ref? proc)
+ (make-primcall src (primitive-ref-name proc) args)))
+ (else #f))
+ x))
x))
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index f9b85d495..e29bac92c 100644
--- a/test-suite/tests/cse.test
+++ b/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!
- (fix-letrec!
+ (canonicalize
+ (fix-letrec
(cse
(peval
(expand-primitives!
- (resolve-primitives!
+ (resolve-primitives
(compile 'in #:from 'scheme #:to 'tree-il)
(current-module))))))))))
(pmatch evaled
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index f409e943a..abc995c22 100644
--- a/test-suite/tests/peval.test
+++ b/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)))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 2ed15c7a9..62052770c 100644
--- a/test-suite/tests/tree-il.test
+++ b/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))
- x))
+ (post-order (lambda (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)