diff --git a/module/Makefile.am b/module/Makefile.am index f3b7e62d5..5eec063c2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -37,11 +37,11 @@ SOURCES = \ 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) \ \ @@ -50,9 +50,10 @@ 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 @@ -83,8 +84,8 @@ TREE_IL_LANG_SOURCES = \ 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 \ diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index 21aa023a5..df618581f 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -20,7 +20,6 @@ (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)) @@ -39,8 +38,7 @@ #: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 diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 8ad7065c6..ad8b73176 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -327,73 +327,51 @@ This is an implementation of `foldts' as described by Andy Wingo in (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 - (( exp) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts exp seed ...))) - (up tree seed ...))) - (( exp) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts exp seed ...))) - (up tree seed ...))) - (( exp) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts exp seed ...))) - (up tree seed ...))) - (( exp) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts exp seed ...))) - (up tree seed ...))) - (( test then else) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts test seed ...)) - ((seed ...) (foldts then seed ...)) - ((seed ...) (foldts else seed ...))) - (up tree seed ...))) - (( proc args) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts proc seed ...)) - ((seed ...) (fold-values foldts args seed ...))) - (up tree seed ...))) - (( exps) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (fold-values foldts exps seed ...))) - (up tree seed ...))) - (( body) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts body seed ...))) - (up tree seed ...))) - (( vals body) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (fold-values foldts vals seed ...)) - ((seed ...) (foldts body seed ...))) - (up tree seed ...))) - (( vals body) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (fold-values foldts vals seed ...)) - ((seed ...) (foldts body seed ...))) - (up tree seed ...))) - - (( vals body) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (fold-values foldts vals seed ...)) - ((seed ...) (foldts body seed ...))) - (up tree seed ...))) - (( 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 + (( exp) + (foldts exp seed ...)) + (( exp) + (foldts exp seed ...)) + (( exp) + (foldts exp seed ...)) + (( exp) + (foldts exp seed ...)) + (( test then else) + (let*-values (((seed ...) (foldts test seed ...)) + ((seed ...) (foldts then seed ...))) + (foldts else seed ...))) + (( proc args) + (let-values (((seed ...) (foldts proc seed ...))) + (fold-values foldts args seed ...))) + (( exps) + (fold-values foldts exps seed ...)) + (( body) + (foldts body seed ...)) + (( vals body) + (let*-values (((seed ...) (fold-values foldts vals seed ...))) + (foldts body seed ...))) + (( vals body) + (let*-values (((seed ...) (fold-values foldts vals seed ...))) + (foldts body seed ...))) + (( vals body) + (let*-values (((seed ...) (fold-values foldts vals seed ...))) + (foldts body seed ...))) + (( 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)) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 73ef8ba21..49633aa28 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -319,13 +319,12 @@ ;; 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))) diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index 61504f6f1..0ed7b6bab 100644 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@ -18,12 +18,163 @@ (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 + (() #t) + (() #t) + (( gensym) + (not (memq gensym bound-vars))) + (( test then else) + (and (simple-expression? test bound-vars) + (simple-expression? then bound-vars) + (simple-expression? else bound-vars))) + (( exps) + (and-map (lambda (x) (simple-expression? x bound-vars)) + exps)) + (( 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 + (( gensym) + (values (delq gensym unref) + (lset-adjoin eq? ref gensym) + set + simple + lambda* + complex)) + (( gensym) + (values unref + ref + (lset-adjoin eq? set gensym) + simple + lambda* + complex)) + (( 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 + (( (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. + (( gensym exp) + (if (memq gensym unref) + (make-sequence #f (list (make-void #f) exp)) + x)) + + (( 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))) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index fd3fbc921..adc3f18bd 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -41,7 +41,8 @@ (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)) @@ -66,6 +67,15 @@ (lambda-body consumer)))) (else #f))) - + + (( vars body) + (if (null? vars) body x)) + + (( vars body) + (if (null? vars) body x)) + + (( vars body) + (if (null? vars) body x)) + (else #f))) x)) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 0f58e22fb..24900c64d 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -25,7 +25,7 @@ #: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 @@ -85,6 +85,39 @@ (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)