mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 04:40:29 +02:00
cb28c08537
* module/Makefile.am: Add inline.scm. * module/language/tree-il.scm (pre-order!, post-order!): pre-order! is new. post-order! existed but was not public. They do destructive tree traversals of tree-il, and need more documentation. Also, add predicates to tree-il's export list. * module/language/tree-il/inline.scm: New file, which expands primitives into more primitive primitives. In the future perhaps it will not be necessary, as the general inlining infrastructure will handle these cases, but for now it's useful. * module/language/tree-il/optimize.scm: Move post-order! out to better pastures.
356 lines
11 KiB
Scheme
356 lines
11 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 2.1 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 (system base pmatch)
|
||
#:use-module (system base syntax)
|
||
#:export (tree-il-src
|
||
|
||
<lexical> make-lexical
|
||
lexical-name lexical-gensym
|
||
|
||
<application> application? make-application application-src application-proc application-args
|
||
<conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
|
||
<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
|
||
<lambda> lambda? make-lambda lambda-src lambda-vars lambda-meta lambda-body
|
||
<const> const? make-const const-src const-exp
|
||
<sequence> sequence? make-sequence sequence-src sequence-exps
|
||
<let> let? make-let let-src let-vars let-vals let-exp
|
||
<letrec> letrec? make-letrec letrec-src letrec-vars letrec-vals letrec-exp
|
||
|
||
parse-tree-il
|
||
unparse-tree-il
|
||
tree-il->scheme
|
||
|
||
post-order!
|
||
pre-order!))
|
||
|
||
(define-type (<tree-il> #:common-slots (src))
|
||
(<application> proc args)
|
||
(<conditional> test then else)
|
||
(<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)
|
||
(<lambda> vars meta body)
|
||
(<const> exp)
|
||
(<sequence> exps)
|
||
(<let> vars vals exp)
|
||
(<letrec> vars vals exp))
|
||
|
||
(define <lexical> <lexical-ref>)
|
||
(define lexical? lexical-ref?)
|
||
(define make-lexical make-lexical-ref)
|
||
(define lexical-name lexical-ref-name)
|
||
(define lexical-gensym lexical-ref-gensym)
|
||
|
||
|
||
|
||
;; FIXME: use this in psyntax
|
||
(define (location x)
|
||
(and (pair? x)
|
||
(let ((props (source-properties x)))
|
||
(and (not (null? props))
|
||
(vector (assq-ref props 'line)
|
||
(assq-ref props 'column)
|
||
(assq-ref props 'filename))))))
|
||
|
||
(define (parse-tree-il env exp)
|
||
(let ((loc (location exp))
|
||
(retrans (lambda (x) (parse-ghil env x))))
|
||
(pmatch exp
|
||
((apply ,proc ,args)
|
||
(make-application loc (retrans proc) (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 ,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 ,vars ,exp)
|
||
(make-lambda loc vars '() (retrans exp)))
|
||
|
||
((lambda ,vars ,meta ,exp)
|
||
(make-lambda loc vars meta (retrans exp)))
|
||
|
||
((const ,exp)
|
||
(make-const loc exp))
|
||
|
||
((begin . ,exps)
|
||
(make-sequence loc (map retrans exps)))
|
||
|
||
((let ,vars ,vals ,exp)
|
||
(make-let loc vars vals (retrans exp)))
|
||
|
||
((letrec ,vars ,vals ,exp)
|
||
(make-letrec loc vars vals (retrans exp)))
|
||
|
||
(else
|
||
(error "unrecognized tree-il" exp)))))
|
||
|
||
(define (unparse-tree-il tree-il)
|
||
(record-case tree-il
|
||
((<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> vars meta body)
|
||
`(lambda ,vars ,meta ,(unparse-tree-il body)))
|
||
|
||
((<const> exp)
|
||
`(const ,exp))
|
||
|
||
((<sequence> exps)
|
||
`(begin ,@(map unparse-tree-il exps)))
|
||
|
||
((<let> vars vals exp)
|
||
`(let ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
|
||
|
||
((<letrec> vars vals exp)
|
||
`(letrec ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))))
|
||
|
||
(define (tree-il->scheme e)
|
||
(cond ((list? e)
|
||
(map tree-il->scheme e))
|
||
((pair? e)
|
||
(cons (tree-il->scheme (car e))
|
||
(tree-il->scheme (cdr e))))
|
||
((record? e)
|
||
(record-case e
|
||
((<application> proc args)
|
||
`(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
|
||
|
||
((<conditional> test then else)
|
||
`(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 exp)
|
||
`(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))
|
||
|
||
((<letrec> vars vals exp)
|
||
`(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))))
|
||
(else e)))
|
||
|
||
(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))
|
||
(or (f x) x))
|
||
|
||
((<conditional> test then else)
|
||
(set! (conditional-test x) (lp test))
|
||
(set! (conditional-then x) (lp then))
|
||
(set! (conditional-else x) (lp else))
|
||
(or (f x) x))
|
||
|
||
((<primitive-ref> name)
|
||
(or (f x) x))
|
||
|
||
((<lexical-ref> name gensym)
|
||
(or (f x) x))
|
||
|
||
((<lexical-set> name gensym exp)
|
||
(set! (lexical-set-exp x) (lp exp))
|
||
(or (f x) x))
|
||
|
||
((<module-ref> mod name public?)
|
||
(or (f x) x))
|
||
|
||
((<module-set> mod name public? exp)
|
||
(set! (module-set-exp x) (lp exp))
|
||
(or (f x) x))
|
||
|
||
((<toplevel-ref> name)
|
||
(or (f x) x))
|
||
|
||
((<toplevel-set> name exp)
|
||
(set! (toplevel-set-exp x) (lp exp))
|
||
(or (f x) x))
|
||
|
||
((<toplevel-define> name exp)
|
||
(set! (toplevel-define-exp x) (lp exp))
|
||
(or (f x) x))
|
||
|
||
((<lambda> vars meta body)
|
||
(set! (lambda-body x) (lp body))
|
||
(or (f x) x))
|
||
|
||
((<const> exp)
|
||
(or (f x) x))
|
||
|
||
((<sequence> exps)
|
||
(set! (sequence-exps x) (map lp exps))
|
||
(or (f x) x))
|
||
|
||
((<let> vars vals exp)
|
||
(set! (let-vals x) (map lp vals))
|
||
(set! (let-exp x) (lp exp))
|
||
(or (f x) x))
|
||
|
||
((<letrec> vars vals exp)
|
||
(set! (letrec-vals x) (map lp vals))
|
||
(set! (letrec-exp x) (lp exp))
|
||
(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 exp)
|
||
(set! (let-vals x) (map lp vals))
|
||
(set! (let-exp x) (lp exp)))
|
||
|
||
((<letrec> vars vals exp)
|
||
(set! (letrec-vals x) (map lp vals))
|
||
(set! (letrec-exp x) (lp exp)))
|
||
|
||
(else #f))
|
||
x)))
|