diff options
author | Andy Wingo <wingo@pobox.com> | 2013-05-28 10:56:05 -0400 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-06-10 22:46:08 +0200 |
commit | 403d78f915552a6eaaf2ecd7a93b2a7dc2983585 (patch) | |
tree | 515ac3b9d08d70437256c22be56e978c3ebe4258 | |
parent | 64fc50c294df9b6644fd40bec90eb8f4dfbc3907 (diff) | |
download | guile-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.scm | 22 | ||||
-rw-r--r-- | module/language/tree-il.scm | 155 | ||||
-rw-r--r-- | module/language/tree-il/canonicalize.scm | 10 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 2 | ||||
-rw-r--r-- | module/language/tree-il/fix-letrec.scm | 8 | ||||
-rw-r--r-- | module/language/tree-il/optimize.scm | 6 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 54 | ||||
-rw-r--r-- | test-suite/tests/cse.test | 8 | ||||
-rw-r--r-- | test-suite/tests/peval.test | 4 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 8 |
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) |