system/base/message.scm \
\
language/tree-il.scm \
- language/ghil.scm language/glil.scm language/assembly.scm \
+ language/glil.scm language/assembly.scm \
\
$(SCHEME_LANG_SOURCES) \
$(TREE_IL_LANG_SOURCES) \
- $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \
+ $(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \
\
$(RNRS_SOURCES) \
$(OOP_SOURCES) \
$(SYSTEM_SOURCES) \
+ $(SCRIPTS_SOURCES) \
+ $(GHIL_LANG_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
- $(BRAINFUCK_LANG_SOURCES) \
- $(SCRIPTS_SOURCES)
+ $(BRAINFUCK_LANG_SOURCES)
## test.scm is not currently installed.
EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008
language/tree-il/compile-glil.scm \
language/tree-il/spec.scm
-GHIL_LANG_SOURCES = \
- language/ghil/spec.scm language/ghil/compile-glil.scm
+GHIL_LANG_SOURCES = \
+ language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm \
;;; Guile Scheme specification
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
(define-module (language scheme spec)
#:use-module (system base language)
- #:use-module (language scheme compile-ghil)
#:use-module (language scheme compile-tree-il)
#:use-module (language scheme decompile-tree-il)
#:export (scheme))
#:title "Guile Scheme"
#:version "0.5"
#:reader read
- #:compilers `((tree-il . ,compile-tree-il)
- (ghil . ,compile-ghil))
+ #:compilers `((tree-il . ,compile-tree-il))
#:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
(define-syntax make-tree-il-folder
(syntax-rules ()
((_ seed ...)
- (lambda (tree down up leaf 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) ...)
- (record-case tree
- ((<lexical-set> exp)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (foldts exp seed ...)))
- (up tree seed ...)))
- ((<module-set> exp)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (foldts exp seed ...)))
- (up tree seed ...)))
- ((<toplevel-set> exp)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (foldts exp seed ...)))
- (up tree seed ...)))
- ((<toplevel-define> exp)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (foldts exp seed ...)))
- (up tree seed ...)))
- ((<conditional> test then else)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (foldts test seed ...))
- ((seed ...) (foldts then seed ...))
- ((seed ...) (foldts else seed ...)))
- (up tree seed ...)))
- ((<application> proc args)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (foldts proc seed ...))
- ((seed ...) (fold-values foldts args seed ...)))
- (up tree seed ...)))
- ((<sequence> exps)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (fold-values foldts exps seed ...)))
- (up tree seed ...)))
- ((<lambda> body)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (foldts body seed ...)))
- (up tree seed ...)))
- ((<let> vals body)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (fold-values foldts vals seed ...))
- ((seed ...) (foldts body seed ...)))
- (up tree seed ...)))
- ((<letrec> vals body)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (fold-values foldts vals seed ...))
- ((seed ...) (foldts body seed ...)))
- (up tree seed ...)))
-
- ((<fix> vals body)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (fold-values foldts vals seed ...))
- ((seed ...) (foldts body seed ...)))
- (up tree seed ...)))
- ((<let-values> exp body)
- (let*-values (((seed ...) (down tree seed ...))
- ((seed ...) (fold-values foldts vals seed ...))
- ((seed ...) (foldts body seed ...)))
- (up tree seed ...)))
- (else
- (leaf tree 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))
;; the 1+ for this var
(max nmax (allocate! body proc (1+ n))))
(else
- (let ((v (if (pair? vars) (car vars) vars)))
- (let ((v (car vars)))
- (hashq-set!
- allocation v
- (make-hashq proc
- `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (cdr vars) (1+ n)))))))))
+ (let ((v (car vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (cdr vars) (1+ n))))))))
(else n)))
(define-module (language tree-il fix-letrec)
#:use-module (system base syntax)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
#:export (fix-letrec!))
;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
;; Efficient Implementation of Scheme’s Recursive Binding Construct", by
;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.
+(define fix-fold
+ (make-tree-il-folder unref ref set simple lambda complex))
+
+(define (simple-expression? x bound-vars)
+ (record-case x
+ ((<void>) #t)
+ ((<const>) #t)
+ ((<lexical-ref> gensym)
+ (not (memq gensym bound-vars)))
+ ((<conditional> test then else)
+ (and (simple-expression? test bound-vars)
+ (simple-expression? then bound-vars)
+ (simple-expression? else bound-vars)))
+ ((<sequence> exps)
+ (and-map (lambda (x) (simple-expression? x bound-vars))
+ exps))
+ ((<application> proc args)
+ (and (primitive-ref? proc)
+ (effect-free-primitive? (primitive-ref-name proc))
+ (and-map (lambda (x) (simple-expression? x bound-vars))
+ args)))
+ (else #f)))
+
+(define (partition-vars x)
+ (let-values
+ (((unref ref set simple lambda* complex)
+ (fix-fold x
+ (lambda (x unref ref set simple lambda* complex)
+ (record-case x
+ ((<lexical-ref> gensym)
+ (values (delq gensym unref)
+ (lset-adjoin eq? ref gensym)
+ set
+ simple
+ lambda*
+ complex))
+ ((<lexical-set> gensym)
+ (values unref
+ ref
+ (lset-adjoin eq? set gensym)
+ simple
+ lambda*
+ complex))
+ ((<letrec> vars)
+ (values (append vars unref)
+ ref
+ set
+ simple
+ lambda*
+ complex))
+ (else
+ (values unref ref set simple lambda* complex))))
+ (lambda (x unref ref set simple lambda* complex)
+ (record-case x
+ ((<letrec> (orig-vars vars) vals)
+ (let lp ((vars orig-vars) (vals vals)
+ (s '()) (l '()) (c '()))
+ (cond
+ ((null? vars)
+ (values unref
+ ref
+ set
+ (append s simple)
+ (append l lambda*)
+ (append c complex)))
+ ((memq (car vars) unref)
+ (lp (cdr vars) (cdr vals)
+ s l c))
+ ((memq (car vars) set)
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c)))
+ ((lambda? (car vals))
+ (lp (cdr vars) (cdr vals)
+ s (cons (car vars) l) c))
+ ((simple-expression? (car vals) orig-vars)
+ (lp (cdr vars) (cdr vals)
+ (cons (car vars) s) l c))
+ (else
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c))))))
+ (else
+ (values unref ref set simple lambda* complex))))
+ '()
+ '()
+ '()
+ '()
+ '()
+ '())))
+ (values unref simple lambda* complex)))
+
(define (fix-letrec! x)
- x)
+ (let-values (((unref simple lambda* complex) (partition-vars x)))
+ (post-order!
+ (lambda (x)
+ (record-case x
+
+ ;; Sets to unreferenced variables may be replaced by their
+ ;; expression, called for effect.
+ ((<lexical-set> gensym exp)
+ (if (memq gensym unref)
+ (make-sequence #f (list (make-void #f) exp))
+ x))
+
+ ((<letrec> src names vars vals body)
+ (let ((binds (map list vars names vals)))
+ (define (lookup set)
+ (map (lambda (v) (assq v binds))
+ (lset-intersection eq? vars set)))
+ (let ((u (lookup unref))
+ (s (lookup simple))
+ (l (lookup lambda*))
+ (c (lookup complex)))
+ ;; Bind "simple" bindings, and locations for complex
+ ;; bindings.
+ (make-let
+ src
+ (append (map cadr s) (map cadr c))
+ (append (map car s) (map car c))
+ (append (map caddr s) (map (lambda (x) (make-void #f)) c))
+ ;; Bind lambdas using the fixpoint operator.
+ (make-fix
+ src (map cadr l) (map car l) (map caddr l)
+ (make-sequence
+ src
+ (append
+ ;; The right-hand-sides of the unreferenced
+ ;; bindings, for effect.
+ (map caddr u)
+ (if (null? c)
+ ;; No complex bindings, just emit the body.
+ (list body)
+ (list
+ ;; Evaluate the the "complex" bindings, in a `let' to
+ ;; indicate that order doesn't matter, and bind to
+ ;; their variables.
+ (let ((tmps (map (lambda (x) (gensym)) c)))
+ (make-let
+ #f (map cadr c) tmps (map caddr c)
+ (make-sequence
+ #f
+ (map (lambda (x tmp)
+ (make-lexical-set
+ #f (cadr x) (car x)
+ (make-lexical-ref #f (cadr x) tmp)))
+ c tmps))))
+ ;; Finally, the body.
+ body)))))))))
+
+ (else x)))
+ x)))
(cond
;; ((lambda () x)) => x
- ((and (lambda? proc) (null? args))
+ ((and (lambda? proc) (null? (lambda-vars proc))
+ (null? args))
(lambda-body proc))
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
(lambda-body consumer))))
(else #f)))
-
+
+ ((<let> vars body)
+ (if (null? vars) body x))
+
+ ((<letrec> vars body)
+ (if (null? vars) body x))
+
+ ((<fix> vars body)
+ (if (null? vars) body x))
+
(else #f)))
x))
#:use-module (language tree-il)
#:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive!
- expand-primitives!))
+ expand-primitives! effect-free-primitive?))
(define *interesting-primitive-names*
'(apply @apply
(for-each add-interesting-primitive! *interesting-primitive-names*)
+(define *effect-free-primitives*
+ '(values
+ eq? eqv? equal?
+ = < > <= >= zero?
+ + * - / 1- 1+ quotient remainder modulo
+ not
+ pair? null? list? acons cons cons*
+ list vector
+ car cdr
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ vector-ref
+ bytevector-u8-ref bytevector-s8-ref
+ bytevector-u16-ref bytevector-u16-native-ref
+ bytevector-s16-ref bytevector-s16-native-ref
+ bytevector-u32-ref bytevector-u32-native-ref
+ bytevector-s32-ref bytevector-s32-native-ref
+ bytevector-u64-ref bytevector-u64-native-ref
+ bytevector-s64-ref bytevector-s64-native-ref
+ bytevector-ieee-single-ref bytevector-ieee-single-native-ref
+ bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+
+
+(define *effect-free-primitive-table* (make-hash-table))
+
+(for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t))
+ *effect-free-primitives*)
+
+(define (effect-free-primitive? prim)
+ (hashq-ref *effect-free-primitive-table* prim))
+
(define (resolve-primitives! x mod)
(post-order!
(lambda (x)
HCoop / bpt / guile.git / commitdiff