mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
80af116875
* module/Makefile.am (SOURCES): Reorganize so GHIL is compiled last, along with ecmascript. * module/language/scheme/spec.scm: Remove references to GHIL, as it's bitrotten and obsolete.. * module/language/tree-il.scm (make-tree-il-folder): Rework so that we only have down and up procs, and call down and up on each element. * module/language/tree-il/analyze.scm (analyze-lexicals): Fix a thinko handling let-values. * module/language/tree-il/fix-letrec.scm: Actually implement fixing letrec. The resulting code will perform better, but violations of the letrec restriction are not detected. This behavior is allowed by the spec, but it is undesirable. Perhaps that will be fixed later. * module/language/tree-il/inline.scm (inline!): Fix a case in which ((lambda args foo)) would be erroneously inlined to foo. Remove empty let, letrec, and fix statements. * module/language/tree-il/primitives.scm (effect-free-primitive?): New public predicate.
474 lines
16 KiB
Scheme
474 lines
16 KiB
Scheme
;;;; Copyright (C) 2009 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
|
||
;;;; License as published by the Free Software Foundation; either
|
||
;;;; version 3 of the License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This library is distributed in the hope that it will be useful,
|
||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;;;; Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU Lesser General Public
|
||
;;;; License along with this library; if not, write to the Free Software
|
||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
;;;;
|
||
|
||
|
||
(define-module (language tree-il)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-11)
|
||
#:use-module (system base pmatch)
|
||
#:use-module (system base syntax)
|
||
#:export (tree-il-src
|
||
|
||
<void> void? make-void void-src
|
||
<const> const? make-const const-src const-exp
|
||
<primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
|
||
<lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym
|
||
<lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp
|
||
<module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public?
|
||
<module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp
|
||
<toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name
|
||
<toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
|
||
<toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
|
||
<conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
|
||
<application> application? make-application application-src application-proc application-args
|
||
<sequence> sequence? make-sequence sequence-src sequence-exps
|
||
<lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
|
||
<let> let? make-let let-src let-names let-vars let-vals let-body
|
||
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
|
||
<fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
|
||
<let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
|
||
|
||
parse-tree-il
|
||
unparse-tree-il
|
||
tree-il->scheme
|
||
|
||
tree-il-fold
|
||
make-tree-il-folder
|
||
post-order!
|
||
pre-order!))
|
||
|
||
(define-type (<tree-il> #:common-slots (src))
|
||
(<void>)
|
||
(<const> exp)
|
||
(<primitive-ref> name)
|
||
(<lexical-ref> name gensym)
|
||
(<lexical-set> name gensym exp)
|
||
(<module-ref> mod name public?)
|
||
(<module-set> mod name public? exp)
|
||
(<toplevel-ref> name)
|
||
(<toplevel-set> name exp)
|
||
(<toplevel-define> name exp)
|
||
(<conditional> test then else)
|
||
(<application> proc args)
|
||
(<sequence> exps)
|
||
(<lambda> names vars meta body)
|
||
(<let> names vars vals body)
|
||
(<letrec> names vars vals body)
|
||
(<fix> names vars vals body)
|
||
(<let-values> names vars exp body))
|
||
|
||
|
||
|
||
(define (location x)
|
||
(and (pair? x)
|
||
(let ((props (source-properties x)))
|
||
(and (pair? props) props))))
|
||
|
||
(define (parse-tree-il exp)
|
||
(let ((loc (location exp))
|
||
(retrans (lambda (x) (parse-tree-il x))))
|
||
(pmatch exp
|
||
((void)
|
||
(make-void loc))
|
||
|
||
((apply ,proc . ,args)
|
||
(make-application loc (retrans proc) (map retrans args)))
|
||
|
||
((if ,test ,then ,else)
|
||
(make-conditional loc (retrans test) (retrans then) (retrans else)))
|
||
|
||
((primitive ,name) (guard (symbol? name))
|
||
(make-primitive-ref loc name))
|
||
|
||
((lexical ,name) (guard (symbol? name))
|
||
(make-lexical-ref loc name name))
|
||
|
||
((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
|
||
(make-lexical-ref loc name sym))
|
||
|
||
((set! (lexical ,name) ,exp) (guard (symbol? name))
|
||
(make-lexical-set loc name name (retrans exp)))
|
||
|
||
((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
|
||
(make-lexical-set loc name sym (retrans exp)))
|
||
|
||
((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
|
||
(make-module-ref loc mod name #t))
|
||
|
||
((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
|
||
(make-module-set loc mod name #t (retrans exp)))
|
||
|
||
((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
|
||
(make-module-ref loc mod name #f))
|
||
|
||
((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
|
||
(make-module-set loc mod name #f (retrans exp)))
|
||
|
||
((toplevel ,name) (guard (symbol? name))
|
||
(make-toplevel-ref loc name))
|
||
|
||
((set! (toplevel ,name) ,exp) (guard (symbol? name))
|
||
(make-toplevel-set loc name (retrans exp)))
|
||
|
||
((define ,name ,exp) (guard (symbol? name))
|
||
(make-toplevel-define loc name (retrans exp)))
|
||
|
||
((lambda ,names ,vars ,exp)
|
||
(make-lambda loc names vars '() (retrans exp)))
|
||
|
||
((lambda ,names ,vars ,meta ,exp)
|
||
(make-lambda loc names vars meta (retrans exp)))
|
||
|
||
((const ,exp)
|
||
(make-const loc exp))
|
||
|
||
((begin . ,exps)
|
||
(make-sequence loc (map retrans exps)))
|
||
|
||
((let ,names ,vars ,vals ,body)
|
||
(make-let loc names vars (map retrans vals) (retrans body)))
|
||
|
||
((letrec ,names ,vars ,vals ,body)
|
||
(make-letrec loc names vars (map retrans vals) (retrans body)))
|
||
|
||
((fix ,names ,vars ,vals ,body)
|
||
(make-fix loc names vars (map retrans vals) (retrans body)))
|
||
|
||
((let-values ,names ,vars ,exp ,body)
|
||
(make-let-values loc names vars (retrans exp) (retrans body)))
|
||
|
||
(else
|
||
(error "unrecognized tree-il" exp)))))
|
||
|
||
(define (unparse-tree-il tree-il)
|
||
(record-case tree-il
|
||
((<void>)
|
||
'(void))
|
||
|
||
((<application> proc args)
|
||
`(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
|
||
|
||
((<conditional> test then else)
|
||
`(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else)))
|
||
|
||
((<primitive-ref> name)
|
||
`(primitive ,name))
|
||
|
||
((<lexical-ref> name gensym)
|
||
`(lexical ,name ,gensym))
|
||
|
||
((<lexical-set> name gensym exp)
|
||
`(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
|
||
|
||
((<module-ref> mod name public?)
|
||
`(,(if public? '@ '@@) ,mod ,name))
|
||
|
||
((<module-set> mod name public? exp)
|
||
`(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
|
||
|
||
((<toplevel-ref> name)
|
||
`(toplevel ,name))
|
||
|
||
((<toplevel-set> name exp)
|
||
`(set! (toplevel ,name) ,(unparse-tree-il exp)))
|
||
|
||
((<toplevel-define> name exp)
|
||
`(define ,name ,(unparse-tree-il exp)))
|
||
|
||
((<lambda> names vars meta body)
|
||
`(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
|
||
|
||
((<const> exp)
|
||
`(const ,exp))
|
||
|
||
((<sequence> exps)
|
||
`(begin ,@(map unparse-tree-il exps)))
|
||
|
||
((<let> names vars vals body)
|
||
`(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
|
||
|
||
((<letrec> names vars vals body)
|
||
`(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
|
||
|
||
((<fix> names vars vals body)
|
||
`(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
|
||
|
||
((<let-values> names vars exp body)
|
||
`(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
|
||
|
||
(define (tree-il->scheme e)
|
||
(record-case e
|
||
((<void>)
|
||
'(if #f #f))
|
||
|
||
((<application> proc args)
|
||
`(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
|
||
|
||
((<conditional> test then else)
|
||
(if (void? else)
|
||
`(if ,(tree-il->scheme test) ,(tree-il->scheme then))
|
||
`(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else))))
|
||
|
||
((<primitive-ref> name)
|
||
name)
|
||
|
||
((<lexical-ref> name gensym)
|
||
gensym)
|
||
|
||
((<lexical-set> name gensym exp)
|
||
`(set! ,gensym ,(tree-il->scheme exp)))
|
||
|
||
((<module-ref> mod name public?)
|
||
`(,(if public? '@ '@@) ,mod ,name))
|
||
|
||
((<module-set> mod name public? exp)
|
||
`(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
|
||
|
||
((<toplevel-ref> name)
|
||
name)
|
||
|
||
((<toplevel-set> name exp)
|
||
`(set! ,name ,(tree-il->scheme exp)))
|
||
|
||
((<toplevel-define> name exp)
|
||
`(define ,name ,(tree-il->scheme exp)))
|
||
|
||
((<lambda> vars meta body)
|
||
`(lambda ,vars
|
||
,@(cond ((assq-ref meta 'documentation) => list) (else '()))
|
||
,(tree-il->scheme body)))
|
||
|
||
((<const> exp)
|
||
(if (and (self-evaluating? exp) (not (vector? exp)))
|
||
exp
|
||
(list 'quote exp)))
|
||
|
||
((<sequence> exps)
|
||
`(begin ,@(map tree-il->scheme exps)))
|
||
|
||
((<let> vars vals body)
|
||
`(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
|
||
|
||
((<letrec> vars vals body)
|
||
`(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
|
||
|
||
((<fix> vars vals body)
|
||
;; not a typo, we really do translate back to letrec
|
||
`(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
|
||
|
||
((<let-values> vars exp body)
|
||
`(call-with-values (lambda () ,(tree-il->scheme exp))
|
||
(lambda ,vars ,(tree-il->scheme body))))))
|
||
|
||
|
||
(define (tree-il-fold leaf down up seed tree)
|
||
"Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
|
||
into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is
|
||
invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
|
||
and SEED is the current result, intially seeded with SEED.
|
||
|
||
This is an implementation of `foldts' as described by Andy Wingo in
|
||
``Applications of fold to XML transformation''."
|
||
(let loop ((tree tree)
|
||
(result seed))
|
||
(if (or (null? tree) (pair? tree))
|
||
(fold loop result tree)
|
||
(record-case tree
|
||
((<lexical-set> exp)
|
||
(up tree (loop exp (down tree result))))
|
||
((<module-set> exp)
|
||
(up tree (loop exp (down tree result))))
|
||
((<toplevel-set> exp)
|
||
(up tree (loop exp (down tree result))))
|
||
((<toplevel-define> exp)
|
||
(up tree (loop exp (down tree result))))
|
||
((<conditional> test then else)
|
||
(up tree (loop else
|
||
(loop then
|
||
(loop test (down tree result))))))
|
||
((<application> proc args)
|
||
(up tree (loop (cons proc args) (down tree result))))
|
||
((<sequence> exps)
|
||
(up tree (loop exps (down tree result))))
|
||
((<lambda> body)
|
||
(up tree (loop body (down tree result))))
|
||
((<let> vals body)
|
||
(up tree (loop body
|
||
(loop vals
|
||
(down tree result)))))
|
||
((<letrec> vals body)
|
||
(up tree (loop body
|
||
(loop vals
|
||
(down tree result)))))
|
||
((<fix> vals body)
|
||
(up tree (loop body
|
||
(loop vals
|
||
(down tree result)))))
|
||
((<let-values> exp body)
|
||
(up tree (loop body (loop exp (down tree result)))))
|
||
(else
|
||
(leaf tree result))))))
|
||
|
||
|
||
(define-syntax make-tree-il-folder
|
||
(syntax-rules ()
|
||
((_ seed ...)
|
||
(lambda (tree down up seed ...)
|
||
(define (fold-values proc exps seed ...)
|
||
(if (null? exps)
|
||
(values seed ...)
|
||
(let-values (((seed ...) (proc (car exps) seed ...)))
|
||
(fold-values proc (cdr exps) seed ...))))
|
||
(let foldts ((tree tree) (seed seed) ...)
|
||
(let*-values
|
||
(((seed ...) (down tree seed ...))
|
||
((seed ...)
|
||
(record-case tree
|
||
((<lexical-set> exp)
|
||
(foldts exp seed ...))
|
||
((<module-set> exp)
|
||
(foldts exp seed ...))
|
||
((<toplevel-set> exp)
|
||
(foldts exp seed ...))
|
||
((<toplevel-define> exp)
|
||
(foldts exp seed ...))
|
||
((<conditional> test then else)
|
||
(let*-values (((seed ...) (foldts test seed ...))
|
||
((seed ...) (foldts then seed ...)))
|
||
(foldts else seed ...)))
|
||
((<application> proc args)
|
||
(let-values (((seed ...) (foldts proc seed ...)))
|
||
(fold-values foldts args seed ...)))
|
||
((<sequence> exps)
|
||
(fold-values foldts exps seed ...))
|
||
((<lambda> body)
|
||
(foldts body seed ...))
|
||
((<let> vals body)
|
||
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
|
||
(foldts body seed ...)))
|
||
((<letrec> vals body)
|
||
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
|
||
(foldts body seed ...)))
|
||
((<fix> vals body)
|
||
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
|
||
(foldts body seed ...)))
|
||
((<let-values> exp body)
|
||
(let*-values (((seed ...) (foldts exp seed ...)))
|
||
(foldts body seed ...)))
|
||
(else
|
||
(values seed ...)))))
|
||
(up tree seed ...)))))))
|
||
|
||
(define (post-order! f x)
|
||
(let lp ((x x))
|
||
(record-case x
|
||
((<application> proc args)
|
||
(set! (application-proc x) (lp proc))
|
||
(set! (application-args x) (map lp args)))
|
||
|
||
((<conditional> test then else)
|
||
(set! (conditional-test x) (lp test))
|
||
(set! (conditional-then x) (lp then))
|
||
(set! (conditional-else x) (lp else)))
|
||
|
||
((<lexical-set> name gensym exp)
|
||
(set! (lexical-set-exp x) (lp exp)))
|
||
|
||
((<module-set> mod name public? exp)
|
||
(set! (module-set-exp x) (lp exp)))
|
||
|
||
((<toplevel-set> name exp)
|
||
(set! (toplevel-set-exp x) (lp exp)))
|
||
|
||
((<toplevel-define> name exp)
|
||
(set! (toplevel-define-exp x) (lp exp)))
|
||
|
||
((<lambda> vars meta body)
|
||
(set! (lambda-body x) (lp body)))
|
||
|
||
((<sequence> exps)
|
||
(set! (sequence-exps x) (map lp exps)))
|
||
|
||
((<let> vars vals body)
|
||
(set! (let-vals x) (map lp vals))
|
||
(set! (let-body x) (lp body)))
|
||
|
||
((<letrec> vars vals body)
|
||
(set! (letrec-vals x) (map lp vals))
|
||
(set! (letrec-body x) (lp body)))
|
||
|
||
((<fix> vars vals body)
|
||
(set! (fix-vals x) (map lp vals))
|
||
(set! (fix-body x) (lp body)))
|
||
|
||
((<let-values> vars exp body)
|
||
(set! (let-values-exp x) (lp exp))
|
||
(set! (let-values-body x) (lp body)))
|
||
|
||
(else #f))
|
||
|
||
(or (f x) x)))
|
||
|
||
(define (pre-order! f x)
|
||
(let lp ((x x))
|
||
(let ((x (or (f x) x)))
|
||
(record-case x
|
||
((<application> proc args)
|
||
(set! (application-proc x) (lp proc))
|
||
(set! (application-args x) (map lp args)))
|
||
|
||
((<conditional> test then else)
|
||
(set! (conditional-test x) (lp test))
|
||
(set! (conditional-then x) (lp then))
|
||
(set! (conditional-else x) (lp else)))
|
||
|
||
((<lexical-set> name gensym exp)
|
||
(set! (lexical-set-exp x) (lp exp)))
|
||
|
||
((<module-set> mod name public? exp)
|
||
(set! (module-set-exp x) (lp exp)))
|
||
|
||
((<toplevel-set> name exp)
|
||
(set! (toplevel-set-exp x) (lp exp)))
|
||
|
||
((<toplevel-define> name exp)
|
||
(set! (toplevel-define-exp x) (lp exp)))
|
||
|
||
((<lambda> vars meta body)
|
||
(set! (lambda-body x) (lp body)))
|
||
|
||
((<sequence> exps)
|
||
(set! (sequence-exps x) (map lp exps)))
|
||
|
||
((<let> vars vals body)
|
||
(set! (let-vals x) (map lp vals))
|
||
(set! (let-body x) (lp body)))
|
||
|
||
((<letrec> vars vals body)
|
||
(set! (letrec-vals x) (map lp vals))
|
||
(set! (letrec-body x) (lp body)))
|
||
|
||
((<fix> vars vals body)
|
||
(set! (fix-vals x) (map lp vals))
|
||
(set! (fix-body x) (lp body)))
|
||
|
||
((<let-values> vars exp body)
|
||
(set! (let-values-exp x) (lp exp))
|
||
(set! (let-values-body x) (lp body)))
|
||
|
||
(else #f))
|
||
x)))
|