;;; -*- 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
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.
(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)
tree-il-fold
make-tree-il-folder
- post-order!
+ post-order
pre-order!
tree-il=?
(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))
#: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)
(lambda (exp res) res)
#f exp))
-(define (canonicalize! x)
- (post-order!
+(define (canonicalize x)
+ (post-order
(lambda (x)
(match x
(($ <let> src () () () body)
;; 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))
(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))
;;; 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
#: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
(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
;;; 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
;; 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)))))))
;;; 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
#: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?
(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))
(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))
\f
;;;; 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
((_ 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
((_ 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)
;; <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)))))
;; 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
(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)
HCoop / bpt / guile.git / commitdiff