From ee0ddd21211757664092eaec631c4c76f4aae74f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 4 Aug 2009 20:29:09 +0200 Subject: [PATCH 01/13] fix buffer overrun reading partial numbers: 1.0f, 1.0/, and 1.0+ * libguile/numbers.c (mem2decimal_from_point, mem2ureal, mem2complex): Fix a number of cases where, for invalid numbers, we could read past the end of the buffer. This happened in e.g. "1.0+", "1/" and "1.0f". But I couldn't figure out how to test for these, given that the behavior depended on the contents of uninitialized memory in the reader buffer. We'll just have to be happy with this. Thanks to Kjetil S. Matheussen for the report. --- libguile/numbers.c | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 5f56b7a29..b4bff8142 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2657,17 +2657,26 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, case 'l': case 'L': case 's': case 'S': idx++; + if (idx == len) + return SCM_BOOL_F; + start = idx; c = mem[idx]; if (c == '-') { idx++; + if (idx == len) + return SCM_BOOL_F; + sign = -1; c = mem[idx]; } else if (c == '+') { idx++; + if (idx == len) + return SCM_BOOL_F; + sign = 1; c = mem[idx]; } @@ -2783,8 +2792,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, SCM divisor; idx++; + if (idx == len) + return SCM_BOOL_F; - divisor = mem2uinteger (mem, len, &idx, radix, &x); + divisor = mem2uinteger (mem, len, &idx, radix, &x); if (scm_is_false (divisor)) return SCM_BOOL_F; @@ -2905,11 +2916,15 @@ mem2complex (const char* mem, size_t len, unsigned int idx, if (c == '+') { idx++; + if (idx == len) + return SCM_BOOL_F; sign = 1; } else if (c == '-') { idx++; + if (idx == len) + return SCM_BOOL_F; sign = -1; } else From 45cc8a38777c9f971b6aae4895311fcc9e15ce3e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 4 Aug 2009 20:46:20 +0200 Subject: [PATCH 02/13] rename configure.in to configure.ac * configure.ac: * guile-readline/configure.ac: Rename from configure.in, as recommended by the autoconf manual. --- configure.in => configure.ac | 0 guile-readline/{configure.in => configure.ac} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename configure.in => configure.ac (100%) rename guile-readline/{configure.in => configure.ac} (100%) diff --git a/configure.in b/configure.ac similarity index 100% rename from configure.in rename to configure.ac diff --git a/guile-readline/configure.in b/guile-readline/configure.ac similarity index 100% rename from guile-readline/configure.in rename to guile-readline/configure.ac From f4863880f5ef539cb545999c19b6b5c0eec9382d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 4 Aug 2009 21:16:32 +0200 Subject: [PATCH 03/13] perform gmp/unistring compile checks with AC_LIB_HAVE_LINKFLAGS * configure.ac: Rework gmp and unistring checks to use AC_LIB_HAVE_LINKFLAGS, so that the compilation checks run with the right -L/-l flags. * libguile/Makefile.am (libguile_la_LIBADD): Adapt to need to add $(LIBGMP) and $(LIBUNISTRING) here. Hopefully this solves http://article.gmane.org/gmane.lisp.guile.bugs/4288. --- configure.ac | 23 ++++++++++------------- libguile/Makefile.am | 2 +- 2 files changed, 11 insertions(+), 14 deletions(-) diff --git a/configure.ac b/configure.ac index 53049eb79..dae82954a 100644 --- a/configure.ac +++ b/configure.ac @@ -827,22 +827,19 @@ fi dnl GMP tests -AC_LIB_LINKFLAGS(gmp) -AC_CHECK_LIB([gmp], [__gmpz_init], , - [AC_MSG_ERROR([GNU MP not found, see README])]) - -# mpz_import is a macro so we need to include -AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], - [[mpz_import (0, 0, 0, 0, 0, 0, 0); ]])], +AC_LIB_HAVE_LINKFLAGS(gmp, [], - [AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])]) + [#include ], + [mpz_import (0, 0, 0, 0, 0, 0, 0);], + AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README])) dnl GNU libunistring tests. -if test "x$LTLIBUNISTRING" != "x"; then - LIBS="$LTLIBUNISTRING $LIBS" -else - AC_MSG_ERROR([GNU libunistring is required, please install it.]) -fi +AC_LIB_HAVE_LINKFLAGS(unistring, + [], + [#include ], + [u8_check ("foo", 3)] + AC_MSG_ERROR([GNU libunistring not found, see README])) + dnl i18n tests #AC_CHECK_HEADERS([libintl.h]) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 8c9c598bf..dfaa65a8f 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -220,7 +220,7 @@ noinst_HEADERS = convert.i.c \ noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c libguile_la_DEPENDENCIES = @LIBLOBJS@ -libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) +libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) $(LTLIBUNISTRING) libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined # These are headers visible as From 7382f23e58725eef2f7a374ec101a42c0192527e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 5 Aug 2009 11:55:42 +0200 Subject: [PATCH 04/13] add1 and sub1 instructions * libguile/vm-i-scheme.c: Add add1 and sub1 instructions. * module/language/tree-il/compile-glil.scm: Compile 1+ and 1- to add1 and sub1. * module/language/tree-il/primitives.scm (define-primitive-expander): Add support for `if' statements in the consequent. (+, -): Compile (- x 1), (+ x 1), and (+ 1 x) to 1- or 1+ as appropriate. (1-): Remove this one. Seems we forgot 1+ before, but we weren't compiling it nicely anyway. * test-suite/tests/tree-il.test ("void"): Fix expected compilation of (+ (void) 1) to allow for add1. --- libguile/vm-i-scheme.c | 26 ++++++++++++++++++++++ module/language/tree-il/compile-glil.scm | 2 ++ module/language/tree-il/primitives.scm | 28 +++++++++++++++++++----- test-suite/tests/tree-il.test | 2 +- 4 files changed, 52 insertions(+), 6 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index dce9b5fbc..675ec1a0a 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -215,11 +215,37 @@ VM_DEFINE_FUNCTION (120, add, "add", 2) FUNC2 (+, scm_sum); } +VM_DEFINE_FUNCTION (167, add1, "add1", 1) +{ + ARGS1 (x); + if (SCM_I_INUMP (x)) + { + scm_t_int64 n = SCM_I_INUM (x) + 1; + if (SCM_FIXABLE (n)) + RETURN (SCM_I_MAKINUM (n)); + } + SYNC_REGISTER (); + RETURN (scm_sum (x, SCM_I_MAKINUM (1))); +} + VM_DEFINE_FUNCTION (121, sub, "sub", 2) { FUNC2 (-, scm_difference); } +VM_DEFINE_FUNCTION (168, sub1, "sub1", 1) +{ + ARGS1 (x); + if (SCM_I_INUMP (x)) + { + scm_t_int64 n = SCM_I_INUM (x) - 1; + if (SCM_FIXABLE (n)) + RETURN (SCM_I_MAKINUM (n)); + } + SYNC_REGISTER (); + RETURN (scm_difference (x, SCM_I_MAKINUM (1))); +} + VM_DEFINE_FUNCTION (122, mul, "mul", 2) { ARGS2 (x, y); diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index bf4699797..975cbf02a 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -85,6 +85,8 @@ ((>= . 2) . ge?) ((+ . 2) . add) ((- . 2) . sub) + ((1+ . 1) . add1) + ((1- . 1) . sub1) ((* . 2) . mul) ((/ . 2) . div) ((quotient . 2) . quo) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 9ccd2720d..0f58e22fb 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -19,6 +19,7 @@ ;;; Code: (define-module (language tree-il primitives) + #:use-module (system base pmatch) #:use-module (rnrs bytevector) #:use-module (system base syntax) #:use-module (language tree-il) @@ -142,8 +143,14 @@ (define (consequent exp) (cond ((pair? exp) - `(make-application src (make-primitive-ref src ',(car exp)) - ,(inline-args (cdr exp)))) + (pmatch exp + ((if ,test ,then ,else) + `(if ,test + ,(consequent then) + ,(consequent else))) + (else + `(make-application src (make-primitive-ref src ',(car exp)) + ,(inline-args (cdr exp)))))) ((symbol? exp) ;; assume locally bound exp) @@ -163,6 +170,15 @@ (define-primitive-expander + () 0 (x) x + (x y) (if (and (const? y) + (let ((y (const-exp y))) + (and (exact? y) (= y 1)))) + (1+ x) + (if (and (const? x) + (let ((x (const-exp x))) + (and (exact? x) (= x 1)))) + (1+ y) + (+ x y))) (x y z . rest) (+ x (+ y z . rest))) (define-primitive-expander * @@ -172,11 +188,13 @@ (define-primitive-expander - (x) (- 0 x) + (x y) (if (and (const? y) + (let ((y (const-exp y))) + (and (exact? y) (= y 1)))) + (1- x) + (- x y)) (x y z . rest) (- x (+ y z . rest))) -(define-primitive-expander 1- - (x) (- x 1)) - (define-primitive-expander / (x) (/ 1 x) (x y z . rest) (/ x (* y z . rest))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 896206b1f..d993e4ff2 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -72,7 +72,7 @@ (program 0 0 0 () (const 1) (call return 1))) (assert-tree-il->glil (apply (primitive +) (void) (const 1)) - (program 0 0 0 () (void) (const 1) (call add 2) (call return 1)))) + (program 0 0 0 () (void) (call add1 1) (call return 1)))) (with-test-prefix "application" (assert-tree-il->glil From dab0f9d55db2e2f4251265443ab0599e424a02c9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 5 Aug 2009 16:17:20 +0200 Subject: [PATCH 05/13] add a brain-dead inliner * module/Makefile.am (TREE_IL_LANG_SOURCES): * module/language/tree-il/inline.scm: Add a brain-dead inliner, to inline ((lambda () x)) => x. * module/language/tree-il/optimize.scm (optimize!): Invoke the inliner. --- module/Makefile.am | 1 + module/language/tree-il/inline.scm | 44 ++++++++++++++++++++++++++++ module/language/tree-il/optimize.scm | 15 +++------- 3 files changed, 49 insertions(+), 11 deletions(-) create mode 100644 module/language/tree-il/inline.scm diff --git a/module/Makefile.am b/module/Makefile.am index 2971fc6b5..b6bd341d6 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -77,6 +77,7 @@ SCHEME_LANG_SOURCES = \ TREE_IL_LANG_SOURCES = \ language/tree-il/primitives.scm \ language/tree-il/optimize.scm \ + language/tree-il/inline.scm \ language/tree-il/analyze.scm \ language/tree-il/compile-glil.scm \ language/tree-il/spec.scm diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm new file mode 100644 index 000000000..10ec51c08 --- /dev/null +++ b/module/language/tree-il/inline.scm @@ -0,0 +1,44 @@ +;;; a simple inliner + +;; 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 inline) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:export (inline!)) + +;; Possible optimizations: +;; * constant folding, propagation +;; * procedure inlining +;; * always when single call site +;; * always for "trivial" procs +;; * otherwise who knows +;; * dead code elimination +;; * degenerate case optimizations +;; * "fixing letrec" + +;; This is a completely brain-dead optimization pass whose sole claim to +;; fame is ((lambda () x)) => x. +(define (inline! x) + (post-order! + (lambda (x) + (record-case x + (( proc args) + (and (lambda? proc) (null? args) + (lambda-body proc))) + (else #f))) + x)) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index ac16a9e39..9820f9417 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -21,21 +21,14 @@ (define-module (language tree-il optimize) #:use-module (language tree-il) #:use-module (language tree-il primitives) + #:use-module (language tree-il inline) #:export (optimize!)) (define (env-module e) (if e (car e) (current-module))) (define (optimize! x env opts) - (expand-primitives! (resolve-primitives! x (env-module env)))) - -;; Possible optimizations: -;; * constant folding, propagation -;; * procedure inlining -;; * always when single call site -;; * always for "trivial" procs -;; * otherwise who knows -;; * dead code elimination -;; * degenerate case optimizations -;; * "fixing letrec" + (inline! + (expand-primitives! + (resolve-primitives! x (env-module env))))) From c21c89b1384415313cd4bc03e76d6e1507e48d7a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 5 Aug 2009 17:51:40 +0200 Subject: [PATCH 06/13] add tree-il construct, and compile it * libguile/vm-i-system.c (fix-closure): New instruction, for wiring together fixpoint procedures. * module/Makefile.am (TREE_IL_LANG_SOURCES): Add fix-letrec.scm. * module/language/glil/compile-assembly.scm (glil->assembly): Reindent the case, and handle 'fix for locally-bound vars. * module/language/tree-il.scm (): Add the tree-il type and accessors, for fixed-point bindings. This IL construct is taken from the Waddell paper. (parse-tree-il, unparse-tree-il, tree-il->scheme, tree-il-fold) (pre-order!, post-order!): Update for . * module/language/tree-il/analyze.scm (analyze-lexicals): Update for . The difference here is that the bindings may not be assigned, and are not marked as such. They are not boxed. (report-unused-variables): Update for . * module/language/tree-il/compile-glil.scm (flatten): Compile to GLIL. * module/language/tree-il/fix-letrec.scm: A stub implementation of fixing letrec -- will flesh out in a separate commit. * module/language/tree-il/inline.scm: Fix license, it was mistakenly added with LGPL v2.1+. * module/language/tree-il/optimize.scm (optimize!): Run the fix-letrec! pass. --- libguile/vm-i-system.c | 14 ++++++ module/Makefile.am | 1 + module/language/glil/compile-assembly.scm | 60 +++++++++++++---------- module/language/tree-il.scm | 24 +++++++++ module/language/tree-il/analyze.scm | 27 ++++++++++ module/language/tree-il/compile-glil.scm | 43 ++++++++++++++++ module/language/tree-il/fix-letrec.scm | 29 +++++++++++ module/language/tree-il/inline.scm | 26 +++++----- module/language/tree-il/optimize.scm | 9 ++-- 9 files changed, 189 insertions(+), 44 deletions(-) create mode 100644 module/language/tree-il/fix-letrec.scm diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 4536b91da..9604ce55a 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1232,6 +1232,20 @@ VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1) NEXT; } +VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2, 0, 1) +{ + SCM x, vect; + unsigned int i = FETCH (); + i <<= 8; + i += FETCH (); + POP (vect); + /* FIXME CHECK_LOCAL (i) */ + x = LOCAL_REF (i); + /* FIXME ASSERT_PROGRAM (x); */ + SCM_SET_CELL_WORD_3 (x, vect); + NEXT; +} + /* (defun renumber-ops () diff --git a/module/Makefile.am b/module/Makefile.am index b6bd341d6..f3b7e62d5 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -78,6 +78,7 @@ TREE_IL_LANG_SOURCES = \ language/tree-il/primitives.scm \ language/tree-il/optimize.scm \ language/tree-il/inline.scm \ + language/tree-il/fix-letrec.scm \ language/tree-il/analyze.scm \ language/tree-il/compile-glil.scm \ language/tree-il/spec.scm diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index fa5805757..4bd6c4f04 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -251,35 +251,41 @@ (emit-code (if local? (if (< index 256) - `((,(case op - ((ref) (if boxed? 'local-boxed-ref 'local-ref)) - ((set) (if boxed? 'local-boxed-set 'local-set)) - ((box) 'box) - ((empty-box) 'empty-box) - (else (error "what" op))) - ,index)) + (case op + ((ref) (if boxed? + `((local-boxed-ref ,index)) + `((local-ref ,index)))) + ((set) (if boxed? + `((local-boxed-set ,index)) + `((local-set ,index)))) + ((box) `((box ,index))) + ((empty-box) `((empty-box ,index))) + ((fix) `((fix-closure 0 ,index))) + (else (error "what" op))) (let ((a (quotient i 256)) (b (modulo i 256))) - `((,(case op - ((ref) - (if boxed? - `((long-local-ref ,a ,b) - (variable-ref)) - `((long-local-ref ,a ,b)))) - ((set) - (if boxed? - `((long-local-ref ,a ,b) - (variable-set)) - `((long-local-set ,a ,b)))) - ((box) - `((make-variable) - (variable-set) - (long-local-set ,a ,b))) - ((empty-box) - `((make-variable) - (long-local-set ,a ,b))) - (else (error "what" op))) - ,index)))) + `((,(case op + ((ref) + (if boxed? + `((long-local-ref ,a ,b) + (variable-ref)) + `((long-local-ref ,a ,b)))) + ((set) + (if boxed? + `((long-local-ref ,a ,b) + (variable-set)) + `((long-local-set ,a ,b)))) + ((box) + `((make-variable) + (variable-set) + (long-local-set ,a ,b))) + ((empty-box) + `((make-variable) + (long-local-set ,a ,b))) + ((fix) + `((fix-closure ,a ,b))) + (else (error "what" op))) + ,index)))) `((,(case op ((ref) (if boxed? 'free-boxed-ref 'free-ref)) ((set) (if boxed? 'free-boxed-set (error "what." glil))) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index aec4eedb9..01d52f181 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -38,6 +38,7 @@ lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body let? make-let let-src let-names let-vars let-vals let-body letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body + fix? make-fix fix-src fix-names fix-vars fix-vals fix-body let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body parse-tree-il @@ -65,6 +66,7 @@ ( names vars meta body) ( names vars vals body) ( names vars vals body) + ( names vars vals body) ( names vars exp body)) @@ -141,6 +143,9 @@ ((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))) @@ -197,6 +202,9 @@ (( names vars vals body) `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + (( names vars vals body) + `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + (( names vars exp body) `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body))))) @@ -256,6 +264,10 @@ (( vars vals body) `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + (( 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))) + (( vars exp body) `(call-with-values (lambda () ,(tree-il->scheme exp)) (lambda ,vars ,(tree-il->scheme body)))))) @@ -300,6 +312,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (up tree (loop body (loop vals (down tree result))))) + (( vals body) + (up tree (loop body + (loop vals + (down tree result))))) (( body) (up tree (loop body (down tree result)))) (else @@ -343,6 +359,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (letrec-vals x) (map lp vals)) (set! (letrec-body x) (lp body))) + (( vars vals body) + (set! (fix-vals x) (map lp vals)) + (set! (fix-body x) (lp body))) + (( vars exp body) (set! (let-values-exp x) (lp exp)) (set! (let-values-body x) (lp body))) @@ -390,6 +410,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (letrec-vals x) (map lp vals)) (set! (letrec-body x) (lp body))) + (( vars vals body) + (set! (fix-vals x) (map lp vals)) + (set! (fix-body x) (lp body))) + (( vars exp body) (set! (let-values-exp x) (lp exp)) (set! (let-values-body x) (lp body))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 1b39b2dd4..35ddfaa3b 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -177,6 +177,13 @@ (apply lset-union eq? (step body) (map step vals)) vars)) + (( vars vals body) + (hashq-set! bound-vars proc + (append (reverse vars) (hashq-ref bound-vars proc))) + (lset-difference eq? + (apply lset-union eq? (step body) (map step vals)) + vars)) + (( vars exp body) (hashq-set! bound-vars proc (let lp ((out (hashq-ref bound-vars proc)) (in vars)) @@ -285,6 +292,20 @@ `(#t ,(hashq-ref assigned v) . ,n))) (lp (cdr vars) (1+ n)))))) + (( vars vals body) + (let lp ((vars vars) (n n)) + (if (null? vars) + (let ((nmax (apply max + (map (lambda (x) + (allocate! x proc n)) + vals)))) + (max nmax (allocate! body proc n))) + (let ((v (car vars))) + (if (hashq-ref assigned v) + (error "fixpoint procedures may not be assigned" x)) + (hashq-set! allocation v (make-hashq proc `(#t #f . ,n))) + (lp (cdr vars) (1+ n)))))) + (( vars exp body) (let ((nmax (recur exp))) (let lp ((vars vars) (n n)) @@ -381,6 +402,9 @@ (( vars names) (make-binding-info (extend vars names) refs (cons src locs))) + (( vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) (( vars names) (make-binding-info (extend vars names) refs (cons src locs))) @@ -428,6 +452,9 @@ (( vars) (make-binding-info (shrink vars refs) refs (cdr locs))) + (( vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) (( vars) (make-binding-info (shrink vars refs) refs (cdr locs))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 975cbf02a..e3e45f56c 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -557,6 +557,49 @@ (comp-tail body) (emit-code #f (make-glil-unbind))) + (( src names vars vals body) + ;; For fixpoint procedures, we can do some tricks to avoid + ;; heap-allocation. Since we know the vals are lambdas, we can + ;; set them to their local var slots first, then capture their + ;; bindings, mutating them in place. + (for-each (lambda (x v) + (emit-code #f (flatten-lambda x allocation)) + (if (not (null? (cdr (hashq-ref allocation x)))) + ;; But we do have to make-closure them first, so + ;; we are mutating fresh closures on the heap. + (begin + (emit-code #f (make-glil-const #f)) + (emit-code #f (make-glil-call 'make-closure 2)))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + (,loc (error "badness" x loc)))) + vals + vars) + (emit-bindings src names vars allocation proc emit-code) + ;; Now go back and fix up the bindings. + (for-each + (lambda (x v) + (let ((free-locs (cdr (hashq-ref allocation x)))) + (if (not (null? free-locs)) + (begin + (for-each + (lambda (loc) + (pmatch loc + ((,local? ,boxed? . ,n) + (emit-code #f (make-glil-lexical local? #f 'ref n))) + (else (error "what" x loc)))) + free-locs) + (emit-code #f (make-glil-call 'vector (length free-locs))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #f . ,n) + (emit-code #f (make-glil-lexical #t #f 'fix n))) + (,loc (error "badness" x loc))))))) + vals + vars) + (comp-tail body) + (emit-code #f (make-glil-unbind))) + (( src names vars exp body) (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) (cond diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm new file mode 100644 index 000000000..61504f6f1 --- /dev/null +++ b/module/language/tree-il/fix-letrec.scm @@ -0,0 +1,29 @@ +;;; transformation of letrec into simpler forms + +;; 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 fix-letrec) + #:use-module (system base syntax) + #:use-module (language tree-il) + #: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-letrec! x) + x) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index 10ec51c08..c534f195b 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -2,19 +2,19 @@ ;; 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 +;;;; 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 inline) #:use-module (system base syntax) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 9820f9417..23505201c 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -22,13 +22,14 @@ #:use-module (language tree-il) #:use-module (language tree-il primitives) #:use-module (language tree-il inline) + #:use-module (language tree-il fix-letrec) #:export (optimize!)) (define (env-module e) (if e (car e) (current-module))) (define (optimize! x env opts) - (inline! - (expand-primitives! - (resolve-primitives! x (env-module env))))) - + (fix-letrec! + (inline! + (expand-primitives! + (resolve-primitives! x (env-module env)))))) From 4dcd84998fc61e15920aea83c4420c7357b9be46 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 5 Aug 2009 21:25:35 +0200 Subject: [PATCH 07/13] let-values in terms of syntax-case, add make-tree-il-folder * module/language/tree-il.scm (tree-il-fold): Fix for let-values case. (make-tree-il-folder): New public macro, makes a multi-valued folder specific to the number of seeds that the user wants. * module/language/tree-il/optimize.scm (optimize!): Reverse the order of inline! and fix-letrec!, as the latter might expose opportunities for the former. * module/srfi/srfi-11.scm (let-values): Reimplement in terms of syntax-case, so that its expressions may reference hygienically bound variables. See the NEWS for the rationale. (let*-values): An empty let*-values still introduces a local `let' binding contour. * module/system/base/syntax.scm (record-case): Yukkkk. Reimplement in terms of syntax-case. Ug-ly, but see the NEWS again: "Lexical bindings introduced by hygienic macros may not be referenced by nonhygienic macros." --- module/language/tree-il.scm | 78 +++++++++- module/language/tree-il/optimize.scm | 4 +- module/srfi/srfi-11.scm | 212 +++++++-------------------- module/system/base/syntax.scm | 89 ++++++++--- 4 files changed, 194 insertions(+), 189 deletions(-) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 01d52f181..8ad7065c6 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -18,6 +18,7 @@ (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 @@ -46,6 +47,7 @@ tree-il->scheme tree-il-fold + make-tree-il-folder post-order! pre-order!)) @@ -316,11 +318,83 @@ This is an implementation of `foldts' as described by Andy Wingo in (up tree (loop body (loop vals (down tree result))))) - (( body) - (up tree (loop body (down tree result)))) + (( 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 leaf 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 ...)))))))) + + (define (post-order! f x) (let lp ((x x)) (record-case x diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 23505201c..0e490a636 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -29,7 +29,7 @@ (if e (car e) (current-module))) (define (optimize! x env opts) - (fix-letrec! - (inline! + (inline! + (fix-letrec! (expand-primitives! (resolve-primitives! x (env-module env)))))) diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm index c8422eeaf..8a41d00f7 100644 --- a/module/srfi/srfi-11.scm +++ b/module/srfi/srfi-11.scm @@ -1,6 +1,6 @@ ;;; srfi-11.scm --- let-values and let*-values -;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 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 @@ -63,148 +63,55 @@ ;; (q )) ;; (baz x y z p q)))))) -;; I originally wrote this as a define-macro, but then I found out -;; that guile's gensym/gentemp was broken, so I tried rewriting it as -;; a syntax-rules statement. -;; [make-symbol now fixes gensym/gentemp problems.] -;; -;; Since syntax-rules didn't seem powerful enough to implement -;; let-values in one definition without exposing illegal syntax (or -;; perhaps my brain's just not powerful enough :>). I tried writing -;; it using a private helper, but that didn't work because the -;; let-values expands outside the scope of this module. I wonder why -;; syntax-rules wasn't designed to allow "private" patterns or -;; similar... -;; -;; So in the end, I dumped the syntax-rules implementation, reproduced -;; here for posterity, and went with the define-macro one below -- -;; gensym/gentemp's got to be fixed anyhow... -; -; (define-syntax let-values-helper -; (syntax-rules () -; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y -; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda -; ;; ( ) ...) from above, keeping track of the -; ;; temps you create so you can use them later... -; ;; -; ;; I really don't fully understand why the (var-1 var-1) trick -; ;; works below, but basically, when all those (x x) bindings show -; ;; up in the final "let", syntax-rules forces a renaming. - -; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings -; body ...) -; (lambda lambda-tmps -; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) - -; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings -; body ...) -; (let-values-helper "consumer" -; (var-2 ...) -; (lambda-tmp ... var-1) -; ((var-1 var-1) . final-let-bindings) -; lv-bindings -; body ...)) - -; ((_ "cwv" () final-let-bindings body ...) -; (let final-let-bindings -; body ...)) - -; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings -; body ...) -; (call-with-values (lambda () binding-1) -; (let-values-helper "consumer" -; vars-1 -; () -; final-let-bindings -; (other-bindings ...) -; body ...))))) -; -; (define-syntax let-values -; (syntax-rules () -; ((let-values () body ...) -; (begin body ...)) -; ((let-values (binding ...) body ...) -; (let-values-helper "cwv" (binding ...) () body ...)))) -; -; -; (define-syntax let-values -; (letrec-syntax ((build-consumer -; ;; Take the vars from one let binding (i.e. the (x -; ;; y z) from ((x y z) (values 1 2 3)) and turn it -; ;; in to the corresponding (lambda ( -; ;; ) ...) from above. -; (syntax-rules () -; ((_ () new-tmps tmp-vars () body ...) -; (lambda new-tmps -; body ...)) -; ((_ () new-tmps tmp-vars vars body ...) -; (lambda new-tmps -; (lv-builder vars tmp-vars body ...))) -; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...) -; (build-consumer (var-2 ...) -; (tmp-1 . new-tmps) -; ((var-1 tmp-1) . tmp-vars) -; bindings -; body ...)))) -; (lv-builder -; (syntax-rules () -; ((_ () tmp-vars body ...) -; (let tmp-vars -; body ...)) -; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...) -; tmp-vars -; body ...) -; (call-with-values (lambda () binding-1) -; (build-consumer vars-1 -; () -; tmp-vars -; ((vars-2 binding-2) ...) -; body ...)))))) -; -; (syntax-rules () -; ((_ () body ...) -; (begin body ...)) -; ((_ ((vars binding) ...) body ...) -; (lv-builder ((vars binding) ...) () body ...))))) - -(define-macro (let-values vars . body) - - (define (map-1-dot proc elts) - ;; map over one optionally dotted (a b c . d) list, producing an - ;; optionally dotted result. - (cond - ((null? elts) '()) - ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts)))) - (else (proc elts)))) - - (define (undot-list lst) - ;; produce a non-dotted list from a possibly dotted list. - (cond - ((null? lst) '()) - ((pair? lst) (cons (car lst) (undot-list (cdr lst)))) - (else (list lst)))) - - (define (let-values-helper vars body prev-let-vars) - (let* ((var-binding (car vars)) - (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var")) - (car var-binding))) - (let-vars (map (lambda (sym tmp) (list sym tmp)) - (undot-list (car var-binding)) - (undot-list new-tmps)))) - - (if (null? (cdr vars)) - `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,new-tmps - (let ,(apply append let-vars prev-let-vars) - ,@body))) - `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,new-tmps - ,(let-values-helper (cdr vars) body - (cons let-vars prev-let-vars))))))) - - (if (null? vars) - `(begin ,@body) - (let-values-helper vars body '()))) +;; We could really use quasisyntax here... +(define-syntax let-values + (lambda (x) + (syntax-case x () + ((_ (clause ...) b0 b1 ...) + (let lp ((clauses (syntax (clause ...))) + (ids '()) + (tmps '())) + (if (null? clauses) + (with-syntax (((id ...) ids) + ((tmp ...) tmps)) + (syntax (let ((id tmp) ...) + b0 b1 ...))) + (syntax-case (car clauses) () + (((var ...) exp) + (with-syntax (((new-tmp ...) (generate-temporaries + (syntax (var ...)))) + ((id ...) ids) + ((tmp ...) tmps)) + (with-syntax ((inner (lp (cdr clauses) + (syntax (var ... id ...)) + (syntax (new-tmp ... tmp ...))))) + (syntax (call-with-values (lambda () exp) + (lambda (new-tmp ...) inner)))))) + ((vars exp) + (with-syntax ((((new-tmp . new-var) ...) + (let lp ((vars (syntax vars))) + (syntax-case vars () + ((id . rest) + (acons (syntax id) + (car + (generate-temporaries (syntax (id)))) + (lp (syntax rest)))) + (id (acons (syntax id) + (car + (generate-temporaries (syntax (id)))) + '()))))) + ((id ...) ids) + ((tmp ...) tmps)) + (with-syntax ((inner (lp (cdr clauses) + (syntax (new-var ... id ...)) + (syntax (new-tmp ... tmp ...)))) + (args (let lp ((tmps (syntax (new-tmp ...)))) + (syntax-case tmps () + ((id) (syntax id)) + ((id . rest) (cons (syntax id) + (lp (syntax rest)))))))) + (syntax (call-with-values (lambda () exp) + (lambda args inner))))))))))))) ;;;;;;;;;;;;;; ;; let*-values @@ -226,28 +133,11 @@ (define-syntax let*-values (syntax-rules () ((let*-values () body ...) - (begin body ...)) + (let () body ...)) ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) (call-with-values (lambda () binding-1) (lambda vars-1 (let*-values ((vars-2 binding-2) ...) body ...)))))) -; Alternate define-macro implementation... -; -; (define-macro (let*-values vars . body) -; (define (let-values-helper vars body) -; (let ((var-binding (car vars))) -; (if (null? (cdr vars)) -; `(call-with-values (lambda () ,(cadr var-binding)) -; (lambda ,(car var-binding) -; ,@body)) -; `(call-with-values (lambda () ,(cadr var-binding)) -; (lambda ,(car var-binding) -; ,(let-values-helper (cdr vars) body)))))) - -; (if (null? vars) -; `(begin ,@body) -; (let-values-helper vars body))) - ;;; srfi-11.scm ends here diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index cc73f38d1..249961d79 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -1,6 +1,6 @@ ;;; Guile VM specific syntaxes and utilities -;; 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 @@ -174,29 +174,70 @@ ;; 5.88 0.01 0.01 list-index -(define-macro (record-case record . clauses) - (let ((r (gensym)) - (rtd (gensym))) - (define (process-clause clause) - (if (eq? (car clause) 'else) - clause - (let ((record-type (caar clause)) - (slots (cdar clause)) - (body (cdr clause))) - (let ((stem (trim-brackets record-type))) - `((eq? ,rtd ,record-type) - (let ,(map (lambda (slot) - (if (pair? slot) - `(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r)) - `(,slot (,(symbol-append stem '- slot) ,r)))) - slots) - ,@(if (pair? body) body '((if #f #f))))))))) - `(let* ((,r ,record) - (,rtd (struct-vtable ,r))) - (cond ,@(let ((clauses (map process-clause clauses))) - (if (assq 'else clauses) - clauses - (append clauses `((else (error "unhandled record" ,r)))))))))) +;;; So ugly... but I am too ignorant to know how to make it better. +(define-syntax record-case + (lambda (x) + (syntax-case x () + ((_ record clause ...) + (let ((r (syntax r)) + (rtd (syntax rtd))) + (define (process-clause tag fields exprs) + (let ((infix (trim-brackets (syntax->datum tag)))) + (with-syntax ((tag tag) + (((f . accessor) ...) + (let lp ((fields fields)) + (syntax-case fields () + (() (syntax ())) + (((v0 f0) f1 ...) + (acons (syntax v0) + (datum->syntax x + (symbol-append infix '- (syntax->datum + (syntax f0)))) + (lp (syntax (f1 ...))))) + ((f0 f1 ...) + (acons (syntax f0) + (datum->syntax x + (symbol-append infix '- (syntax->datum + (syntax f0)))) + (lp (syntax (f1 ...)))))))) + ((e0 e1 ...) + (syntax-case exprs () + (() (syntax (#t))) + ((e0 e1 ...) (syntax (e0 e1 ...)))))) + (syntax + ((eq? rtd tag) + (let ((f (accessor r)) + ...) + e0 e1 ...)))))) + (with-syntax + ((r r) + (rtd rtd) + ((processed ...) + (let lp ((clauses (syntax (clause ...))) + (out '())) + (syntax-case clauses (else) + (() + (reverse! (cons (syntax + (else (error "unhandled record" r))) + out))) + (((else e0 e1 ...)) + (reverse! (cons (syntax (else e0 e1 ...)) out))) + (((else e0 e1 ...) . rest) + (syntax-violation 'record-case + "bad else clause placement" + (syntax x) + (syntax (else e0 e1 ...)))) + (((( f0 ...) e0 ...) . rest) + (lp (syntax rest) + (cons (process-clause (syntax ) + (syntax (f0 ...)) + (syntax (e0 ...))) + out))))))) + (syntax + (let* ((r record) + (rtd (struct-vtable r))) + (cond processed ...))))))))) + ;; Here we take the terrorism to another level. Nasty, but the client ;; code looks good. From bca488f186ce662e8c41b8ac1675fa2f03bb3fc2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 6 Aug 2009 11:48:16 +0200 Subject: [PATCH 08/13] actually inline call-with-values to tree-il's * module/srfi/srfi-11.scm (let-values): In the one-clause case, avoid going through temporary variables. * module/language/tree-il/inline.scm (inline!): Add another case: (call-with-values (lambda () ...) (lambda ... ...) -> let-values. * module/language/tree-il/compile-glil.scm (flatten): Fix a bug compiling applications in "vals" context. * module/language/tree-il/analyze.scm (analyze-lexicals): Fix a couple bugs with let-values and rest arguments. --- module/language/tree-il/analyze.scm | 42 ++++++++++++++---------- module/language/tree-il/compile-glil.scm | 2 +- module/language/tree-il/inline.scm | 33 +++++++++++++++++-- module/srfi/srfi-11.scm | 3 ++ 4 files changed, 59 insertions(+), 21 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 35ddfaa3b..73ef8ba21 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -185,14 +185,14 @@ vars)) (( vars exp body) - (hashq-set! bound-vars proc - (let lp ((out (hashq-ref bound-vars proc)) (in vars)) - (if (pair? in) - (lp (cons (car in) out) (cdr in)) - (if (null? in) out (cons in out))))) - (lset-difference eq? - (lset-union eq? (step exp) (step body)) - vars)) + (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars)) + (if (pair? in) + (lp (cons (car in) out) (cdr in)) + (if (null? in) out (cons in out)))))) + (hashq-set! bound-vars proc bound) + (lset-difference eq? + (lset-union eq? (step exp) (step body)) + bound))) (else '()))) @@ -309,15 +309,23 @@ (( vars exp body) (let ((nmax (recur exp))) (let lp ((vars vars) (n n)) - (if (null? vars) - (max nmax (allocate! body proc n)) - (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)))))))) + (cond + ((null? vars) + (max nmax (allocate! body proc n))) + ((not (pair? vars)) + (hashq-set! allocation vars + (make-hashq proc + `(#t ,(hashq-ref assigned vars) . ,n))) + ;; 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))))))))) (else n))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index e3e45f56c..3d25dd181 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -391,7 +391,7 @@ (case context ((tail) (emit-code src (make-glil-call 'goto/args len))) ((push) (emit-code src (make-glil-call 'call len))) - ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA))) + ((vals) (emit-code src (make-glil-mv-call len LMVRA))) ((drop) (let ((MV (make-label)) (POST (make-label))) (emit-code src (make-glil-mv-call len MV)) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index c534f195b..fd3fbc921 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -37,8 +37,35 @@ (post-order! (lambda (x) (record-case x - (( proc args) - (and (lambda? proc) (null? args) - (lambda-body proc))) + (( src proc args) + (cond + + ;; ((lambda () x)) => x + ((and (lambda? proc) (null? args)) + (lambda-body proc)) + + ;; (call-with-values (lambda () foo) (lambda (a b . c) bar)) + ;; => (let-values (((a b . c) foo)) bar) + ;; + ;; Note that this is a singly-binding form of let-values. Also + ;; note that Scheme's let-values expands into call-with-values, + ;; then here we reduce it to tree-il's let-values. + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-values) + (= (length args) 2) + (lambda? (cadr args))) + (let ((producer (car args)) + (consumer (cadr args))) + (make-let-values src + (lambda-names consumer) + (lambda-vars consumer) + (if (and (lambda? producer) + (null? (lambda-names producer))) + (lambda-body producer) + (make-application src producer '())) + (lambda-body consumer)))) + + (else #f))) + (else #f))) x)) diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm index 8a41d00f7..22bda21a2 100644 --- a/module/srfi/srfi-11.scm +++ b/module/srfi/srfi-11.scm @@ -67,6 +67,9 @@ (define-syntax let-values (lambda (x) (syntax-case x () + ((_ ((binds exp)) b0 b1 ...) + (syntax (call-with-values (lambda () exp) + (lambda binds b0 b1 ...)))) ((_ (clause ...) b0 b1 ...) (let lp ((clauses (syntax (clause ...))) (ids '()) From 80af1168751e59a3ee5c4a79febb2da23d36112d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 6 Aug 2009 16:01:24 +0200 Subject: [PATCH 09/13] actually implement "fixing letrec" * 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. --- module/Makefile.am | 13 ++- module/language/scheme/spec.scm | 6 +- module/language/tree-il.scm | 100 +++++++--------- module/language/tree-il/analyze.scm | 13 +-- module/language/tree-il/fix-letrec.scm | 153 ++++++++++++++++++++++++- module/language/tree-il/inline.scm | 14 ++- module/language/tree-il/primitives.scm | 35 +++++- 7 files changed, 252 insertions(+), 82 deletions(-) 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) From 9b29d6079184d2d92fef5a1b7eba79f39fa3ef82 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 6 Aug 2009 17:46:38 +0200 Subject: [PATCH 10/13] loop detection in the house * libguile/vm-i-scheme.c (vector-ref, vector-set): Sync registers if we call out to C. * module/language/tree-il/compile-glil.scm (flatten-lambda): Add an extra argument, the self-label, which should be the gensym under which the procedure is bound in a expression. (flatten): If we see a call to a lexical ref to the self-label in a tail position, rename and goto instead of goto/args, which will tear down the frame -- or will, in the future. It's a primitive form of loop detection. * module/language/tree-il/primitives.scm (zero?): Expand to (= x 0). --- libguile/vm-i-scheme.c | 10 +++- module/language/tree-il/compile-glil.scm | 64 ++++++++++++++++-------- module/language/tree-il/primitives.scm | 3 ++ 3 files changed, 54 insertions(+), 23 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 675ec1a0a..0cace147d 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -315,7 +315,10 @@ VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2) && i < SCM_I_VECTOR_LENGTH (vect))) RETURN (SCM_I_VECTOR_ELTS (vect)[i]); else - RETURN (scm_vector_ref (vect, idx)); + { + SYNC_REGISTER (); + RETURN (scm_vector_ref (vect, idx)); + } } VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0) @@ -329,7 +332,10 @@ VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0) && i < SCM_I_VECTOR_LENGTH (vect))) SCM_I_VECTOR_WELTS (vect)[i] = val; else - scm_vector_set_x (vect, idx, val); + { + SYNC_REGISTER (); + scm_vector_set_x (vect, idx, val); + } NEXT; } diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 3d25dd181..7c2764236 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -66,7 +66,7 @@ (with-fluid* *comp-module* (or (and e (car e)) (current-module)) (lambda () - (values (flatten-lambda x allocation) + (values (flatten-lambda x #f allocation) (and e (cons (car e) (cddr e))) e))))) @@ -177,7 +177,7 @@ (proc emit-code) (reverse out))) -(define (flatten-lambda x allocation) +(define (flatten-lambda x self-label allocation) (receive (ids vars nargs nrest) (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) (oids '()) (ovars '()) (n 0)) @@ -193,6 +193,9 @@ nargs nrest nlocs (lambda-meta x) (with-output-to-code (lambda (emit-code) + ;; emit label for self tail calls + (if self-label + (emit-code #f (make-glil-label self-label))) ;; write bindings and source debugging info (emit-bindings #f ids vars allocation x emit-code) (if (lambda-src x) @@ -201,14 +204,14 @@ (for-each (lambda (v) (pmatch (hashq-ref (hashq-ref allocation v) x) - ((#t #t . ,n) - (emit-code #f (make-glil-lexical #t #f 'ref n)) - (emit-code #f (make-glil-lexical #t #t 'box n))))) + ((#t #t . ,n) + (emit-code #f (make-glil-lexical #t #f 'ref n)) + (emit-code #f (make-glil-lexical #t #t 'box n))))) vars) ;; and here, here, dear reader: we compile. - (flatten (lambda-body x) allocation x emit-code))))))) + (flatten (lambda-body x) allocation x self-label emit-code))))))) -(define (flatten x allocation proc emit-code) +(define (flatten x allocation self self-label emit-code) (define (emit-label label) (emit-code #f (make-glil-label label))) (define (emit-branch src inst label) @@ -384,6 +387,25 @@ (error "bad primitive op: too many pushes" op (instruction-pushes op)))))) + ;; da capo al fine + ((and (lexical-ref? proc) + self-label (eq? (lexical-ref-gensym proc) self-label) + ;; self-call in tail position is a goto + (eq? context 'tail) + ;; make sure the arity is right + (list? (lambda-vars self)) + (= (length args) (length (lambda-vars self)))) + ;; evaluate new values + (for-each comp-push args) + ;; rename & goto + (for-each (lambda (sym) + (pmatch (hashq-ref (hashq-ref allocation sym) self) + ((#t ,boxed? . ,index) + (emit-code #f (make-glil-lexical #t #f 'set index))) + (,x (error "what" x)))) + (reverse (lambda-vars self))) + (emit-branch src 'br self-label)) + (else (comp-push proc) (for-each comp-push args) @@ -442,7 +464,7 @@ (( src name gensym) (case context ((push vals tail) - (pmatch (hashq-ref (hashq-ref allocation gensym) proc) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) ((,local? ,boxed? . ,index) (emit-code src (make-glil-lexical local? boxed? 'ref index))) (,loc @@ -452,7 +474,7 @@ (( src name gensym exp) (comp-push exp) - (pmatch (hashq-ref (hashq-ref allocation gensym) proc) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) ((,local? ,boxed? . ,index) (emit-code src (make-glil-lexical local? boxed? 'set index))) (,loc @@ -510,7 +532,7 @@ (let ((free-locs (cdr (hashq-ref allocation x)))) (case context ((push vals tail) - (emit-code #f (flatten-lambda x allocation)) + (emit-code #f (flatten-lambda x #f allocation)) (if (not (null? free-locs)) (begin (for-each @@ -527,9 +549,9 @@ (( src names vars vals body) (for-each comp-push vals) - (emit-bindings src names vars allocation proc emit-code) + (emit-bindings src names vars allocation self emit-code) (for-each (lambda (v) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #f . ,n) (emit-code src (make-glil-lexical #t #f 'set n))) ((#t #t . ,n) @@ -541,15 +563,15 @@ (( src names vars vals body) (for-each (lambda (v) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #t . ,n) (emit-code src (make-glil-lexical #t #t 'empty-box n))) (,loc (error "badness" x loc)))) vars) (for-each comp-push vals) - (emit-bindings src names vars allocation proc emit-code) + (emit-bindings src names vars allocation self emit-code) (for-each (lambda (v) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #t . ,n) (emit-code src (make-glil-lexical #t #t 'set n))) (,loc (error "badness" x loc)))) @@ -563,20 +585,20 @@ ;; set them to their local var slots first, then capture their ;; bindings, mutating them in place. (for-each (lambda (x v) - (emit-code #f (flatten-lambda x allocation)) + (emit-code #f (flatten-lambda x v allocation)) (if (not (null? (cdr (hashq-ref allocation x)))) ;; But we do have to make-closure them first, so ;; we are mutating fresh closures on the heap. (begin (emit-code #f (make-glil-const #f)) (emit-code #f (make-glil-call 'make-closure 2)))) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #f . ,n) (emit-code src (make-glil-lexical #t #f 'set n))) (,loc (error "badness" x loc)))) vals vars) - (emit-bindings src names vars allocation proc emit-code) + (emit-bindings src names vars allocation self emit-code) ;; Now go back and fix up the bindings. (for-each (lambda (x v) @@ -591,7 +613,7 @@ (else (error "what" x loc)))) free-locs) (emit-code #f (make-glil-call 'vector (length free-locs))) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #f . ,n) (emit-code #f (make-glil-lexical #t #f 'fix n))) (,loc (error "badness" x loc))))))) @@ -616,10 +638,10 @@ (emit-code #f (make-glil-const 1)) (emit-label MV) (emit-code src (make-glil-mv-bind - (vars->bind-list names vars allocation proc) + (vars->bind-list names vars allocation self) rest?)) (for-each (lambda (v) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #f . ,n) (emit-code src (make-glil-lexical #t #f 'set n))) ((#t #t . ,n) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 24900c64d..955c7bf25 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -200,6 +200,9 @@ (cons `((src . ,(car in)) ,(consequent (cadr in))) out))))))) +(define-primitive-expander zero? (x) + (= x 0)) + (define-primitive-expander + () 0 (x) x From 9059993fe0bf38045ae52552c68d985a3e3c5344 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 7 Aug 2009 15:35:53 +0200 Subject: [PATCH 11/13] add label alist to lambda allocations in tree-il->glil compiler * module/language/tree-il/analyze.scm: Add some more comments about something that will land in a future commit: compiling fixpoint lambdas as labels. (analyze-lexicals): Reorder a bit, and add a label alist to procedure allocations. Empty for now. * module/language/tree-il/compile-glil.scm (flatten): Adapt to the free variables being in the cddr of the allocation, not the cdr. --- module/language/tree-il/analyze.scm | 58 ++++++++++++++++++------ module/language/tree-il/compile-glil.scm | 6 +-- 2 files changed, 47 insertions(+), 17 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 49633aa28..70778f34d 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -78,6 +78,25 @@ ;; in a vector. Each closure variable has a unique index into that ;; vector. ;; +;; There is one more complication. Procedures bound by may, in +;; some cases, be rendered inline to their parent procedure. That is to +;; say, +;; +;; (letrec ((lp (lambda () (lp)))) (lp)) +;; => (fix ((lp (lambda () (lp)))) (lp)) +;; => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP; +;; ^ jump over the loop ^ the fixpoint lp ^ starting off the loop +;; +;; The upshot is that we don't have to allocate any space for the `lp' +;; closure at all, as it can be rendered inline as a loop. So there is +;; another kind of allocation, "label allocation", in which the +;; procedure is simply a label, placed at the start of the lambda body. +;; The label is the gensym under which the lambda expression is bound. +;; +;; The analyzer checks to see that the label is called with the correct +;; number of arguments. Calls to labels compile to rename + goto. +;; Lambda, the ultimate goto! +;; ;; ;; The return value of `analyze-lexicals' is a hash table, the ;; "allocation". @@ -88,15 +107,17 @@ ;; in many procedures, it is a two-level map. ;; ;; The allocation also stored information on how many local variables -;; need to be allocated for each procedure, and information on what free -;; variables to capture from its lexical parent procedure. +;; need to be allocated for each procedure, lexicals that have been +;; translated into labels, and information on what free variables to +;; capture from its lexical parent procedure. ;; ;; That is: ;; ;; sym -> {lambda -> address} -;; lambda -> (nlocs . free-locs) +;; lambda -> (nlocs labels . free-locs) ;; -;; address := (local? boxed? . index) +;; address ::= (local? boxed? . index) +;; labels ::= ((sym . lambda-vars) ...) ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) ;; free variable addresses are relative to parent proc. @@ -108,14 +129,22 @@ (define (analyze-lexicals x) ;; bound-vars: lambda -> (sym ...) ;; all identifiers bound within a lambda + (define bound-vars (make-hash-table)) ;; free-vars: lambda -> (sym ...) ;; all identifiers referenced in a lambda, but not bound ;; NB, this includes identifiers referenced by contained lambdas + (define free-vars (make-hash-table)) ;; assigned: sym -> #t + (define assigned (make-hash-table)) ;; variables that are assigned ;; refcounts: sym -> count ;; allows us to detect the or-expansion in O(1) time - + (define refcounts (make-hash-table)) + ;; labels: sym -> lambda-vars + ;; for determining if fixed-point procedures can be rendered as + ;; labels. lambda-vars may be an improper list. + (define labels (make-hash-table)) + ;; returns variables referenced in expr (define (analyze! x proc) (define (step y) (analyze! y proc)) @@ -196,6 +225,10 @@ (else '()))) + ;; allocation: sym -> {lambda -> address} + ;; lambda -> (nlocs labels . free-locs) + (define allocation (make-hash-table)) + (define (allocate! x proc n) (define (recur y) (allocate! y proc n)) (record-case x @@ -244,9 +277,13 @@ (free-addresses (map (lambda (v) (hashq-ref (hashq-ref allocation v) proc)) - (hashq-ref free-vars x)))) + (hashq-ref free-vars x))) + (labels (filter cdr + (map (lambda (sym) + (cons sym (hashq-ref labels sym))) + (hashq-ref bound-vars x))))) ;; set procedure allocations - (hashq-set! allocation x (cons nlocs free-addresses))) + (hashq-set! allocation x (cons* nlocs labels free-addresses))) n) (( vars vals body) @@ -328,13 +365,6 @@ (else n))) - (define bound-vars (make-hash-table)) - (define free-vars (make-hash-table)) - (define assigned (make-hash-table)) - (define refcounts (make-hash-table)) - - (define allocation (make-hash-table)) - (analyze! x #f) (allocate! x #f 0) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 7c2764236..3ee5c881d 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -529,7 +529,7 @@ (emit-code #f (make-glil-call 'return 1))))) (() - (let ((free-locs (cdr (hashq-ref allocation x)))) + (let ((free-locs (cddr (hashq-ref allocation x)))) (case context ((push vals tail) (emit-code #f (flatten-lambda x #f allocation)) @@ -586,7 +586,7 @@ ;; bindings, mutating them in place. (for-each (lambda (x v) (emit-code #f (flatten-lambda x v allocation)) - (if (not (null? (cdr (hashq-ref allocation x)))) + (if (not (null? (cddr (hashq-ref allocation x)))) ;; But we do have to make-closure them first, so ;; we are mutating fresh closures on the heap. (begin @@ -602,7 +602,7 @@ ;; Now go back and fix up the bindings. (for-each (lambda (x v) - (let ((free-locs (cdr (hashq-ref allocation x)))) + (let ((free-locs (cddr (hashq-ref allocation x)))) (if (not (null? free-locs)) (begin (for-each From 230cfcfb3e3558a6981487042cc5358d0da1f8bb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 7 Aug 2009 17:44:02 +0200 Subject: [PATCH 12/13] implement compilation of label-allocated lambda expressions * module/language/tree-il/compile-glil.scm (flatten-lambda, flatten): Implement compilation of label-allocated lambda expressions. Quite tricky, we'll see if this works when the new analyzer lands. --- module/language/tree-il/compile-glil.scm | 322 ++++++++++++++--------- 1 file changed, 194 insertions(+), 128 deletions(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 3ee5c881d..4880f4754 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -37,7 +37,7 @@ ;; allocation: ;; sym -> {lambda -> address} -;; lambda -> (nlocs . closure-vars) +;; lambda -> (nlocs labels . free-locs) ;; ;; address := (local? boxed? . index) ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) @@ -163,6 +163,7 @@ ids vars)) +;; FIXME: always emit? otherwise it's hard to pair bind with unbind (define (emit-bindings src ids vars allocation proc emit-code) (if (pair? vars) (emit-code src (make-glil-bind @@ -188,7 +189,8 @@ (else (values (reverse (cons ids oids)) (reverse (cons vars ovars)) (1+ n) 1)))) - (let ((nlocs (car (hashq-ref allocation x)))) + (let ((nlocs (car (hashq-ref allocation x))) + (labels (cadr (hashq-ref allocation x)))) (make-glil-program nargs nrest nlocs (lambda-meta x) (with-output-to-code @@ -209,35 +211,44 @@ (emit-code #f (make-glil-lexical #t #t 'box n))))) vars) ;; and here, here, dear reader: we compile. - (flatten (lambda-body x) allocation x self-label emit-code))))))) + (flatten (lambda-body x) allocation x self-label + labels emit-code))))))) -(define (flatten x allocation self self-label emit-code) +(define (flatten x allocation self self-label fix-labels emit-code) (define (emit-label label) (emit-code #f (make-glil-label label))) (define (emit-branch src inst label) (emit-code src (make-glil-branch inst label))) - ;; LMVRA == "let-values MV return address" - (let comp ((x x) (context 'tail) (LMVRA #f)) - (define (comp-tail tree) (comp tree context LMVRA)) - (define (comp-push tree) (comp tree 'push #f)) - (define (comp-drop tree) (comp tree 'drop #f)) - (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA)) + ;; RA: "return address"; #f unless we're in a non-tail fix with labels + ;; MVRA: "multiple-values return address"; #f unless we're in a let-values + (let comp ((x x) (context 'tail) (RA #f) (MVRA #f)) + (define (comp-tail tree) (comp tree context RA MVRA)) + (define (comp-push tree) (comp tree 'push #f #f)) + (define (comp-drop tree) (comp tree 'drop #f #f)) + (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA)) + (define (comp-fix tree RA) (comp tree context RA MVRA)) + ;; A couple of helpers. Note that if we are in tail context, we + ;; won't have an RA. + (define (maybe-emit-return) + (if RA + (emit-branch #f 'br RA) + (if (eq? context 'tail) + (emit-code #f (make-glil-call 'return 1))))) + (record-case x (() (case context - ((push vals) (emit-code #f (make-glil-void))) - ((tail) - (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))))) + ((push vals tail) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) (( src exp) (case context - ((push vals) (emit-code src (make-glil-const exp))) - ((tail) - (emit-code src (make-glil-const exp)) - (emit-code #f (make-glil-call 'return 1))))) + ((push vals tail) + (emit-code src (make-glil-const exp)))) + (maybe-emit-return)) ;; FIXME: should represent sequence as exps tail (( src exps) @@ -263,7 +274,7 @@ ;; drop: (lambda () (apply values '(1 2)) 3) ;; push: (lambda () (list (apply values '(10 12)) 1)) (case context - ((drop) (for-each comp-drop args)) + ((drop) (for-each comp-drop args) (maybe-emit-return)) ((tail) (for-each comp-push args) (emit-code src (make-glil-call 'return/values* (length args)))))) @@ -277,12 +288,14 @@ ((push) (comp-push proc) (for-each comp-push args) - (emit-code src (make-glil-call 'apply (1+ (length args))))) + (emit-code src (make-glil-call 'apply (1+ (length args)))) + (maybe-emit-return)) ((vals) (comp-vals (make-application src (make-primitive-ref #f 'apply) (cons proc args)) - LMVRA)) + MVRA) + (maybe-emit-return)) ((drop) ;; Well, shit. The proc might return any number of ;; values (including 0), since it's in a drop context, @@ -290,8 +303,9 @@ ;; mv-call out to our trampoline instead. (comp-drop (make-application src (make-primitive-ref #f 'apply) - (cons proc args))))))))) - + (cons proc args))) + (maybe-emit-return))))))) + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) (not (eq? context 'push))) ;; tail: (lambda () (values '(1 2))) @@ -299,11 +313,11 @@ ;; push: (lambda () (list (values '(10 12)) 1)) ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...) (case context - ((drop) (for-each comp-drop args)) + ((drop) (for-each comp-drop args) (maybe-emit-return)) ((vals) (for-each comp-push args) (emit-code #f (make-glil-const (length args))) - (emit-branch src 'br LMVRA)) + (emit-branch src 'br MVRA)) ((tail) (for-each comp-push args) (emit-code src (make-glil-call 'return/values (length args)))))) @@ -324,7 +338,8 @@ (comp-vals (make-application src (make-primitive-ref #f 'call-with-values) args) - LMVRA)) + MVRA) + (maybe-emit-return)) (else (let ((MV (make-label)) (POST (make-label)) (producer (car args)) (consumer (cadr args))) @@ -341,7 +356,8 @@ (else (emit-code src (make-glil-call 'call/nargs 0)) (emit-label POST) (if (eq? context 'drop) - (emit-code #f (make-glil-call 'drop 1))))))))) + (emit-code #f (make-glil-call 'drop 1))) + (maybe-emit-return))))))) ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) '@call-with-current-continuation) @@ -355,16 +371,19 @@ (make-application src (make-primitive-ref #f 'call-with-current-continuation) args) - LMVRA)) + MVRA) + (maybe-emit-return)) ((push) (comp-push (car args)) - (emit-code src (make-glil-call 'call/cc 1))) + (emit-code src (make-glil-call 'call/cc 1)) + (maybe-emit-return)) ((drop) ;; Crap. Just like `apply' in drop context. (comp-drop (make-application src (make-primitive-ref #f 'call-with-current-continuation) - args))))) + args)) + (maybe-emit-return)))) ((and (primitive-ref? proc) (or (hash-ref *primcall-ops* @@ -376,13 +395,12 @@ (case (instruction-pushes op) ((0) (case context - ((tail) (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))) - ((push vals) (emit-code #f (make-glil-void))))) + ((tail push vals) (emit-code #f (make-glil-void)))) + (maybe-emit-return)) ((1) (case context - ((tail) (emit-code #f (make-glil-call 'return 1))) - ((drop) (emit-code #f (make-glil-call 'drop 1))))) + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) (else (error "bad primitive op: too many pushes" op (instruction-pushes op)))))) @@ -401,28 +419,50 @@ (for-each (lambda (sym) (pmatch (hashq-ref (hashq-ref allocation sym) self) ((#t ,boxed? . ,index) + ;; set unboxed, as the proc prelude will box if needed (emit-code #f (make-glil-lexical #t #f 'set index))) (,x (error "what" x)))) (reverse (lambda-vars self))) (emit-branch src 'br self-label)) + ;; lambda, the ultimate goto + ((and (lexical-ref? proc) + (assq (lexical-ref-gensym proc) fix-labels)) + ;; evaluate new values, assuming that analyze-lexicals did its + ;; job, and that the arity was right + (for-each comp-push args) + ;; rename + (for-each (lambda (sym) + (pmatch (hashq-ref (hashq-ref allocation sym) self) + ((#t #f . ,index) + (emit-code #f (make-glil-lexical #t #f 'set index))) + ((#t #t . ,index) + (emit-code #f (make-glil-lexical #t #t 'box index))) + (,x (error "what" x)))) + (reverse (assq-ref fix-labels (lexical-ref-gensym proc)))) + ;; goto! + (emit-branch src 'br (lexical-ref-gensym proc))) + (else (comp-push proc) (for-each comp-push args) (let ((len (length args))) (case context ((tail) (emit-code src (make-glil-call 'goto/args len))) - ((push) (emit-code src (make-glil-call 'call len))) - ((vals) (emit-code src (make-glil-mv-call len LMVRA))) - ((drop) - (let ((MV (make-label)) (POST (make-label))) - (emit-code src (make-glil-mv-call len MV)) - (emit-code #f (make-glil-call 'drop 1)) - (emit-branch #f 'br POST) - (emit-label MV) - (emit-code #f (make-glil-mv-bind '() #f)) - (emit-code #f (make-glil-unbind)) - (emit-label POST)))))))) + ((push) (emit-code src (make-glil-call 'call len)) + (maybe-emit-return)) + ((vals) (emit-code src (make-glil-mv-call len MVRA)) + (maybe-emit-return)) + ((drop) (let ((MV (make-label)) (POST (make-label))) + (emit-code src (make-glil-mv-call len MV)) + (emit-code #f (make-glil-call 'drop 1)) + (emit-branch #f 'br (or RA POST)) + (emit-label MV) + (emit-code #f (make-glil-mv-bind '() #f)) + (emit-code #f (make-glil-unbind)) + (if RA + (emit-branch #f 'br RA) + (emit-label POST))))))))) (( src test then else) ;; TEST @@ -436,30 +476,28 @@ (emit-branch src 'br-if-not L1) (comp-tail then) (if (not (eq? context 'tail)) - (emit-branch #f 'br L2)) + (emit-branch #f 'br (or RA L2))) (emit-label L1) (comp-tail else) (if (not (eq? context 'tail)) - (emit-label L2)))) + (if RA + (emit-branch #f 'br RA) + (emit-label L2))))) (( src name) (cond ((eq? (module-variable (fluid-ref *comp-module*) name) (module-variable the-root-module name)) (case context - ((push vals) - (emit-code src (make-glil-toplevel 'ref name))) - ((tail) - (emit-code src (make-glil-toplevel 'ref name)) - (emit-code #f (make-glil-call 'return 1))))) + ((tail push vals) + (emit-code src (make-glil-toplevel 'ref name)))) + (maybe-emit-return)) (else (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*)) (case context - ((push vals) - (emit-code src (make-glil-module 'ref '(guile) name #f))) - ((tail) - (emit-code src (make-glil-module 'ref '(guile) name #f)) - (emit-code #f (make-glil-call 'return 1))))))) + ((tail push vals) + (emit-code src (make-glil-module 'ref '(guile) name #f)))) + (maybe-emit-return)))) (( src name gensym) (case context @@ -469,8 +507,7 @@ (emit-code src (make-glil-lexical local? boxed? 'ref index))) (,loc (error "badness" x loc))))) - (case context - ((tail) (emit-code #f (make-glil-call 'return 1))))) + (maybe-emit-return)) (( src name gensym exp) (comp-push exp) @@ -480,53 +517,45 @@ (,loc (error "badness" x loc))) (case context - ((push vals) - (emit-code #f (make-glil-void))) - ((tail) - (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))))) + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) (( src mod name public?) (emit-code src (make-glil-module 'ref mod name public?)) (case context - ((drop) (emit-code #f (make-glil-call 'drop 1))) - ((tail) (emit-code #f (make-glil-call 'return 1))))) + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) (( src mod name public? exp) (comp-push exp) (emit-code src (make-glil-module 'set mod name public?)) (case context - ((push vals) - (emit-code #f (make-glil-void))) - ((tail) - (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))))) + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) (( src name) (emit-code src (make-glil-toplevel 'ref name)) (case context - ((drop) (emit-code #f (make-glil-call 'drop 1))) - ((tail) (emit-code #f (make-glil-call 'return 1))))) + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) (( src name exp) (comp-push exp) (emit-code src (make-glil-toplevel 'set name)) (case context - ((push vals) - (emit-code #f (make-glil-void))) - ((tail) - (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))))) + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) (( src name exp) (comp-push exp) (emit-code src (make-glil-toplevel 'define name)) (case context - ((push vals) - (emit-code #f (make-glil-void))) - ((tail) - (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))))) + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) (() (let ((free-locs (cddr (hashq-ref allocation x)))) @@ -543,9 +572,8 @@ (else (error "what" x loc)))) free-locs) (emit-code #f (make-glil-call 'vector (length free-locs))) - (emit-code #f (make-glil-call 'make-closure 2)))) - (if (eq? context 'tail) - (emit-code #f (make-glil-call 'return 1))))))) + (emit-code #f (make-glil-call 'make-closure 2))))))) + (maybe-emit-return)) (( src names vars vals body) (for-each comp-push vals) @@ -580,47 +608,85 @@ (emit-code #f (make-glil-unbind))) (( src names vars vals body) - ;; For fixpoint procedures, we can do some tricks to avoid - ;; heap-allocation. Since we know the vals are lambdas, we can - ;; set them to their local var slots first, then capture their - ;; bindings, mutating them in place. - (for-each (lambda (x v) - (emit-code #f (flatten-lambda x v allocation)) - (if (not (null? (cddr (hashq-ref allocation x)))) - ;; But we do have to make-closure them first, so - ;; we are mutating fresh closures on the heap. - (begin - (emit-code #f (make-glil-const #f)) - (emit-code #f (make-glil-call 'make-closure 2)))) - (pmatch (hashq-ref (hashq-ref allocation v) self) - ((#t #f . ,n) - (emit-code src (make-glil-lexical #t #f 'set n))) - (,loc (error "badness" x loc)))) - vals - vars) - (emit-bindings src names vars allocation self emit-code) - ;; Now go back and fix up the bindings. - (for-each - (lambda (x v) - (let ((free-locs (cddr (hashq-ref allocation x)))) - (if (not (null? free-locs)) - (begin - (for-each - (lambda (loc) - (pmatch loc - ((,local? ,boxed? . ,n) - (emit-code #f (make-glil-lexical local? #f 'ref n))) - (else (error "what" x loc)))) - free-locs) - (emit-code #f (make-glil-call 'vector (length free-locs))) - (pmatch (hashq-ref (hashq-ref allocation v) self) - ((#t #f . ,n) - (emit-code #f (make-glil-lexical #t #f 'fix n))) - (,loc (error "badness" x loc))))))) - vals - vars) - (comp-tail body) - (emit-code #f (make-glil-unbind))) + ;; The ideal here is to just render the lambda bodies inline, and + ;; wire the code together with gotos. We can do that if + ;; analyze-lexicals has determined that a given var has "label" + ;; allocation -- which is the case if it is in `fix-labels'. + ;; + ;; But even for closures that we can't inline, we can do some + ;; tricks to avoid heap-allocation for the binding itself. Since + ;; we know the vals are lambdas, we can set them to their local + ;; var slots first, then capture their bindings, mutating them in + ;; place. + (let ((RA (if (eq? context 'tail) #f (make-label)))) + (for-each + (lambda (x v) + (cond + ((hashq-ref allocation x) + ;; allocating a closure + (emit-code #f (flatten-lambda x v allocation)) + (if (not (null? (cddr (hashq-ref allocation x)))) + ;; Need to make-closure first, but with a temporary #f + ;; free-variables vector, so we are mutating fresh + ;; closures on the heap. + (begin + (emit-code #f (make-glil-const #f)) + (emit-code #f (make-glil-call 'make-closure 2)))) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + (,loc (error "badness" x loc)))) + (else + ;; labels allocation: emit label & body, but jump over it + (let ((POST (make-label))) + (emit-branch #f 'br POST) + (emit-label v) + ;; we know the lambda vars are a list + (emit-bindings #f (lambda-names x) (lambda-vars x) + allocation self emit-code) + (if (lambda-src x) + (emit-code #f (make-glil-source (lambda-src x)))) + (comp-fix (lambda-body x) RA) + (emit-code #f (make-glil-unbind)) + (emit-label POST))))) + vals + vars) + ;; Emit bindings metadata for closures + (let ((binds (let lp ((out '()) (vars vars) (names names)) + (cond ((null? vars) (reverse! out)) + ((memq (car vars) fix-labels) + (lp out (cdr vars) (cdr names))) + (else + (lp (acons (car vars) (car names) out) + (cdr vars) (cdr names))))))) + (emit-bindings src (map cdr binds) (map car binds) + allocation self emit-code)) + ;; Now go back and fix up the bindings for closures. + (for-each + (lambda (x v) + (let ((free-locs (if (hashq-ref allocation x) + (cddr (hashq-ref allocation x)) + ;; can hit this latter case for labels allocation + '()))) + (if (not (null? free-locs)) + (begin + (for-each + (lambda (loc) + (pmatch loc + ((,local? ,boxed? . ,n) + (emit-code #f (make-glil-lexical local? #f 'ref n))) + (else (error "what" x loc)))) + free-locs) + (emit-code #f (make-glil-call 'vector (length free-locs))) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code #f (make-glil-lexical #t #f 'fix n))) + (,loc (error "badness" x loc))))))) + vals + vars) + (comp-tail body) + (emit-label RA) + (emit-code #f (make-glil-unbind)))) (( src names vars exp body) (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) From d97b69d9cd7207e947d22b2417defc58560e6457 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 7 Aug 2009 19:06:15 +0200 Subject: [PATCH 13/13] lambda, the ultimate goto * module/language/tree-il/analyze.scm (analyze-lexicals): Rework to actually determine when a fixed-point procedure may be allocated as a label. * module/language/tree-il/compile-glil.scm (emit-bindings): Always emit a . Otherwise it's too hard to pair with unbindings. (flatten-lambda): Consequently, here we only `bind' if there are any vars to bind. This doesn't make any difference, given that lambdas don't have trailing unbind instructions, but it does keep the GLIL output the same for thunks -- no extraneous (bind) instructions. Keeps tree-il.test happy. (flatten): Some bugfixes. Yaaay, it works!!! --- module/language/tree-il/analyze.scm | 170 +++++++++++++++++++---- module/language/tree-il/compile-glil.scm | 24 ++-- 2 files changed, 155 insertions(+), 39 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 70778f34d..b93a0bd7e 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -135,8 +135,8 @@ ;; NB, this includes identifiers referenced by contained lambdas (define free-vars (make-hash-table)) ;; assigned: sym -> #t - (define assigned (make-hash-table)) ;; variables that are assigned + (define assigned (make-hash-table)) ;; refcounts: sym -> count ;; allows us to detect the or-expansion in O(1) time (define refcounts (make-hash-table)) @@ -146,23 +146,35 @@ (define labels (make-hash-table)) ;; returns variables referenced in expr - (define (analyze! x proc) - (define (step y) (analyze! y proc)) - (define (recur x new-proc) (analyze! x new-proc)) + (define (analyze! x proc labels-in-proc tail? tail-call-args) + (define (step y) (analyze! y proc labels-in-proc #f #f)) + (define (step-tail y) (analyze! y proc labels-in-proc tail? #f)) + (define (step-tail-call y args) (analyze! y proc labels-in-proc #f + (and tail? args))) + (define (recur/labels x new-proc labels) + (analyze! x new-proc (append labels labels-in-proc) #t #f)) + (define (recur x new-proc) (analyze! x new-proc '() tail? #f)) (record-case x (( proc args) - (apply lset-union eq? (step proc) (map step args))) + (apply lset-union eq? (step-tail-call proc args) + (map step args))) (( test then else) - (lset-union eq? (step test) (step then) (step else))) + (lset-union eq? (step test) (step-tail then) (step-tail else))) (( name gensym) (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) + (if (not (and tail-call-args + (memq gensym labels-in-proc) + (let ((args (hashq-ref labels gensym))) + (and (list? args) + (= (length args) (length tail-call-args)))))) + (hashq-set! labels gensym #f)) (list gensym)) (( name gensym exp) - (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) (hashq-set! assigned gensym #t) + (hashq-set! labels gensym #f) (lset-adjoin eq? (step exp) gensym)) (( mod name public? exp) @@ -175,7 +187,12 @@ (step exp)) (( exps) - (apply lset-union eq? (map step exps))) + (let lp ((exps exps) (ret '())) + (cond ((null? exps) '()) + ((null? (cdr exps)) + (lset-union eq? ret (step-tail (car exps)))) + (else + (lp (cdr exps) (lset-union eq? ret (step (car exps)))))))) (( vars meta body) (let ((locally-bound (let rev* ((vars vars) (out '())) @@ -195,7 +212,7 @@ (hashq-set! bound-vars proc (append (reverse vars) (hashq-ref bound-vars proc))) (lset-difference eq? - (apply lset-union eq? (step body) (map step vals)) + (apply lset-union eq? (step-tail body) (map step vals)) vars)) (( vars vals body) @@ -203,15 +220,86 @@ (append (reverse vars) (hashq-ref bound-vars proc))) (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars) (lset-difference eq? - (apply lset-union eq? (step body) (map step vals)) + (apply lset-union eq? (step-tail body) (map step vals)) vars)) (( vars vals body) + ;; Try to allocate these procedures as labels. + (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val))) + vars vals) (hashq-set! bound-vars proc (append (reverse vars) (hashq-ref bound-vars proc))) - (lset-difference eq? - (apply lset-union eq? (step body) (map step vals)) - vars)) + ;; Step into subexpressions. + (let* ((var-refs + (map + ;; Since we're trying to label-allocate the lambda, + ;; pretend it's not a closure, and just recurse into its + ;; body directly. (Otherwise, recursing on a closure + ;; that references one of the fix's bound vars would + ;; prevent label allocation.) + (lambda (x) + (record-case x + (( (lvars vars) body) + (let ((locally-bound + (let rev* ((lvars lvars) (out '())) + (cond ((null? lvars) out) + ((pair? lvars) (rev* (cdr lvars) + (cons (car lvars) out))) + (else (cons lvars out)))))) + (hashq-set! bound-vars x locally-bound) + ;; recur/labels, the difference from the closure case + (let* ((referenced (recur/labels body x vars)) + (free (lset-difference eq? referenced locally-bound)) + (all-bound (reverse! (hashq-ref bound-vars x)))) + (hashq-set! bound-vars x all-bound) + (hashq-set! free-vars x free) + free))))) + vals)) + (vars-with-refs (map cons vars var-refs)) + (body-refs (recur/labels body proc vars))) + (define (delabel-dependents! sym) + (let ((refs (assq-ref vars-with-refs sym))) + (if refs + (for-each (lambda (sym) + (if (hashq-ref labels sym) + (begin + (hashq-set! labels sym #f) + (delabel-dependents! sym)))) + refs)))) + ;; Stepping into the lambdas and the body might have made some + ;; procedures not label-allocatable -- which might have + ;; knock-on effects. For example: + ;; (fix ((a (lambda () (b))) + ;; (b (lambda () a))) + ;; (a)) + ;; As far as `a' is concerned, both `a' and `b' are + ;; label-allocatable. But `b' references `a' not in a proc-tail + ;; position, which makes `a' not label-allocatable. The + ;; knock-on effect is that, when back-propagating this + ;; information to `a', `b' will also become not + ;; label-allocatable, as it is referenced within `a', which is + ;; allocated as a closure. This is a transitive relationship. + (for-each (lambda (sym) + (if (not (hashq-ref labels sym)) + (delabel-dependents! sym))) + vars) + ;; Now lift bound variables with label-allocated lambdas to the + ;; parent procedure. + (for-each + (lambda (sym val) + (if (hashq-ref labels sym) + ;; Remove traces of the label-bound lambda. The free + ;; vars will propagate up via the return val. + (begin + (hashq-set! bound-vars proc + (append (hashq-ref bound-vars val) + (hashq-ref bound-vars proc))) + (hashq-remove! bound-vars val) + (hashq-remove! free-vars val)))) + vars vals) + (lset-difference eq? + (apply lset-union eq? body-refs var-refs) + vars))) (( vars exp body) (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars)) @@ -220,7 +308,7 @@ (if (null? in) out (cons in out)))))) (hashq-set! bound-vars proc bound) (lset-difference eq? - (lset-union eq? (step exp) (step body)) + (lset-union eq? (step exp) (step-tail body)) bound))) (else '()))) @@ -330,18 +418,46 @@ (lp (cdr vars) (1+ n)))))) (( vars vals body) - (let lp ((vars vars) (n n)) - (if (null? vars) - (let ((nmax (apply max - (map (lambda (x) - (allocate! x proc n)) - vals)))) - (max nmax (allocate! body proc n))) - (let ((v (car vars))) - (if (hashq-ref assigned v) - (error "fixpoint procedures may not be assigned" x)) - (hashq-set! allocation v (make-hashq proc `(#t #f . ,n))) - (lp (cdr vars) (1+ n)))))) + (let lp ((in vars) (n n)) + (if (null? in) + (let lp ((vars vars) (vals vals) (nmax n)) + (cond + ((null? vars) + (max nmax (allocate! body proc n))) + ((hashq-ref labels (car vars)) + ;; allocate label bindings & body inline to proc + (lp (cdr vars) + (cdr vals) + (record-case (car vals) + (( vars body) + (let lp ((vars vars) (n n)) + (if (not (null? vars)) + ;; allocate bindings + (let ((v (if (pair? vars) (car vars) vars))) + (hashq-set! + allocation v + (make-hashq + proc `(#t ,(hashq-ref assigned v) . ,n))) + (lp (if (pair? vars) (cdr vars) '()) (1+ n))) + ;; allocate body + (max nmax (allocate! body proc n)))))))) + (else + ;; allocate closure + (lp (cdr vars) + (cdr vals) + (max nmax (allocate! (car vals) proc n)))))) + + (let ((v (car in))) + (cond + ((hashq-ref assigned v) + (error "fixpoint procedures may not be assigned" x)) + ((hashq-ref labels v) + ;; no binding, it's a label + (lp (cdr in) n)) + (else + ;; allocate closure binding + (hashq-set! allocation v (make-hashq proc `(#t #f . ,n))) + (lp (cdr in) (1+ n)))))))) (( vars exp body) (let ((nmax (recur exp))) @@ -365,7 +481,7 @@ (else n))) - (analyze! x #f) + (analyze! x #f '() #t #f) (allocate! x #f 0) allocation) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 4880f4754..48db6f6c4 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -165,9 +165,8 @@ ;; FIXME: always emit? otherwise it's hard to pair bind with unbind (define (emit-bindings src ids vars allocation proc emit-code) - (if (pair? vars) - (emit-code src (make-glil-bind - (vars->bind-list ids vars allocation proc))))) + (emit-code src (make-glil-bind + (vars->bind-list ids vars allocation proc)))) (define (with-output-to-code proc) (let ((out '())) @@ -199,7 +198,8 @@ (if self-label (emit-code #f (make-glil-label self-label))) ;; write bindings and source debugging info - (emit-bindings #f ids vars allocation x emit-code) + (if (not (null? ids)) + (emit-bindings #f ids vars allocation x emit-code)) (if (lambda-src x) (emit-code #f (make-glil-source (lambda-src x)))) ;; box args if necessary @@ -475,15 +475,15 @@ (comp-push test) (emit-branch src 'br-if-not L1) (comp-tail then) - (if (not (eq? context 'tail)) - (emit-branch #f 'br (or RA L2))) + ;; if there is an RA, comp-tail will cause a jump to it -- just + ;; have to clean up here if there is no RA. + (if (and (not RA) (not (eq? context 'tail))) + (emit-branch #f 'br L2)) (emit-label L1) (comp-tail else) - (if (not (eq? context 'tail)) - (if RA - (emit-branch #f 'br RA) - (emit-label L2))))) - + (if (and (not RA) (not (eq? context 'tail))) + (emit-label L2)))) + (( src name) (cond ((eq? (module-variable (fluid-ref *comp-module*) name) @@ -654,7 +654,7 @@ ;; Emit bindings metadata for closures (let ((binds (let lp ((out '()) (vars vars) (names names)) (cond ((null? vars) (reverse! out)) - ((memq (car vars) fix-labels) + ((assq (car vars) fix-labels) (lp out (cdr vars) (cdr names))) (else (lp (acons (car vars) (car names) out)