mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Tree-il post-order rewriter no longer destructive

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-05-28 10:56:05 -04:00
parent 64fc50c294
commit 403d78f915
10 changed files with 128 additions and 127 deletions
Download patch file Download diff file Expand all files Collapse all files

22
module/ice-9/compile-psyntax.scm
View file

@ -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)

133
module/language/tree-il.scm
View file

@ -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)))
((<lambda> src meta body)
(make-lambda src meta (and body (lp body))))
((<letrec> gensyms vals body)
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (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))))
((<fix> gensyms vals body)
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
((<let> src names gensyms vals body)
(make-let src names gensyms (map lp vals) (lp body)))
((<let-values> exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
((<letrec> src in-order? names gensyms vals body)
(make-letrec src in-order? names gensyms (map lp vals) (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)))
((<fix> src names gensyms vals body)
(make-fix src names gensyms (map lp vals) (lp body)))
((<dynlet> fluids vals body)
(set! (dynlet-fluids x) (map lp fluids))
(set! (dynlet-vals x) (map lp vals))
(set! (dynlet-body x) (lp body)))
((<let-values> src exp body)
(make-let-values src (lp exp) (lp body)))
((<dynref> fluid)
(set! (dynref-fluid x) (lp fluid)))
((<dynwind> src winder pre body post unwinder)
(make-dynwind src
(lp winder) (lp pre) (lp body) (lp post) (lp unwinder)))
((<dynset> fluid exp)
(set! (dynset-fluid x) (lp fluid))
(set! (dynset-exp x) (lp exp)))
((<dynlet> src fluids vals body)
(make-dynlet src (map lp fluids) (map lp vals) (lp body)))
((<prompt> tag body handler)
(set! (prompt-tag x) (lp tag))
(set! (prompt-body x) (lp body))
(set! (prompt-handler x) (lp handler)))
((<dynref> src fluid)
(make-dynref src (lp fluid)))
((<abort> tag args tail)
(set! (abort-tag x) (lp tag))
(set! (abort-args x) (map lp args))
(set! (abort-tail x) (lp tail)))
((<dynset> src fluid exp)
(make-dynset src (lp fluid) (lp exp)))
(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))

10
module/language/tree-il/canonicalize.scm
View file

@ -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))

2
module/language/tree-il/compile-glil.scm
View file

@ -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))

8
module/language/tree-il/fix-letrec.scm
View file

@ -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

6
module/language/tree-il/optimize.scm
View file

@ -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)))))))

54
module/language/tree-il/primitives.scm
View file

@ -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))

8
test-suite/tests/cse.test
View file

@ -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

4
test-suite/tests/peval.test
View file

@ -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)))))

8
test-suite/tests/tree-il.test
View file

@ -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)