mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Merge commit 'origin/master'

Browse source
This commit is contained in:
Michael Gran 2009-08-08 02:35:08 -07:00
commit aa131e9e67
19 changed files with 1106 additions and 409 deletions
Download patch file Download diff file Expand all files Collapse all files

23
configure.in → configure.ac
View file

@ -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 <gmp.h>
AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <gmp.h>]],
[[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 <gmp.h>],
[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 <unistr.h>],
[u8_check ("foo", 3)]
AC_MSG_ERROR([GNU libunistring not found, see README]))
dnl i18n tests
#AC_CHECK_HEADERS([libintl.h])

0
guile-readline/configure.in → guile-readline/configure.ac
View file

2
libguile/Makefile.am
View file

@ -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 <guile/mumble.h>

15
libguile/numbers.c
View file

@ -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,6 +2792,8 @@ 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);
if (scm_is_false (divisor))
@ -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

32
libguile/vm-i-scheme.c
View file

@ -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);
@ -289,8 +315,11 @@ VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
&& i < SCM_I_VECTOR_LENGTH (vect)))
RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
else
{
SYNC_REGISTER ();
RETURN (scm_vector_ref (vect, idx));
}
}
VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
{
@ -303,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
{
SYNC_REGISTER ();
scm_vector_set_x (vect, idx, val);
}
NEXT;
}

14
libguile/vm-i-system.c
View file

@ -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 ()

13
module/Makefile.am
View file

@ -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
@ -77,12 +78,14 @@ 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/fix-letrec.scm \
language/tree-il/analyze.scm \
language/tree-il/compile-glil.scm \
language/tree-il/spec.scm
GHIL_LANG_SOURCES = \
language/ghil/spec.scm language/ghil/compile-glil.scm
language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm \

18
module/language/glil/compile-assembly.scm
View file

@ -251,13 +251,17 @@
(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)
(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)))
,index))
(let ((a (quotient i 256))
(b (modulo i 256)))
`((,(case op
@ -278,6 +282,8 @@
((empty-box)
`((make-variable)
(long-local-set ,a ,b)))
((fix)
`((fix-closure ,a ,b)))
(else (error "what" op)))
,index))))
`((,(case op

6
module/language/scheme/spec.scm
View file

@ -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

80
module/language/tree-il.scm
View file

@ -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
@ -38,6 +39,7 @@
<lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
<let> let? make-let let-src let-names let-vars let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
parse-tree-il
@ -45,6 +47,7 @@
tree-il->scheme
tree-il-fold
make-tree-il-folder
post-order!
pre-order!))
@ -65,6 +68,7 @@
(<lambda> names vars meta body)
(<let> names vars vals body)
(<letrec> names vars vals body)
(<fix> names vars vals body)
(<let-values> names vars exp body))
@ -141,6 +145,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 +204,9 @@
((<letrec> names vars vals body)
`(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
((<fix> names vars vals body)
`(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
((<let-values> names vars exp body)
`(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
@ -256,6 +266,10 @@
((<letrec> vars vals body)
`(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
((<fix> vars vals body)
;; not a typo, we really do translate back to letrec
`(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
((<let-values> vars exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp))
(lambda ,vars ,(tree-il->scheme body))))))
@ -300,11 +314,65 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop body
(loop vals
(down tree result)))))
((<let-values> body)
(up tree (loop body (down tree result))))
((<fix> vals body)
(up tree (loop body
(loop vals
(down tree result)))))
((<let-values> exp body)
(up tree (loop body (loop exp (down tree result)))))
(else
(leaf tree result))))))
(define-syntax make-tree-il-folder
(syntax-rules ()
((_ seed ...)
(lambda (tree down up seed ...)
(define (fold-values proc exps seed ...)
(if (null? exps)
(values seed ...)
(let-values (((seed ...) (proc (car exps) seed ...)))
(fold-values proc (cdr exps) seed ...))))
(let foldts ((tree tree) (seed seed) ...)
(let*-values
(((seed ...) (down tree seed ...))
((seed ...)
(record-case tree
((<lexical-set> exp)
(foldts exp seed ...))
((<module-set> exp)
(foldts exp seed ...))
((<toplevel-set> exp)
(foldts exp seed ...))
((<toplevel-define> exp)
(foldts exp seed ...))
((<conditional> test then else)
(let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts then seed ...)))
(foldts else seed ...)))
((<application> proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
((<sequence> exps)
(fold-values foldts exps seed ...))
((<lambda> body)
(foldts body seed ...))
((<let> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<letrec> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<fix> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<let-values> exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
(else
(values seed ...)))))
(up tree seed ...)))))))
(define (post-order! f x)
(let lp ((x x))
(record-case x
@ -343,6 +411,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)))
((<fix> vars vals body)
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
((<let-values> vars exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
@ -390,6 +462,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)))
((<fix> vars vals body)
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
((<let-values> vars exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))

242
module/language/tree-il/analyze.scm
View file

@ -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 <fix> 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,32 +129,52 @@
(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
;; 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))
;; 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))
(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
((<application> proc args)
(apply lset-union eq? (step proc) (map step args)))
(apply lset-union eq? (step-tail-call proc args)
(map step args)))
((<conditional> test then else)
(lset-union eq? (step test) (step then) (step else)))
(lset-union eq? (step test) (step-tail then) (step-tail else)))
((<lexical-ref> 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))
((<lexical-set> 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))
((<module-set> mod name public? exp)
@ -146,7 +187,12 @@
(step exp))
((<sequence> 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))))))))
((<lambda> vars meta body)
(let ((locally-bound (let rev* ((vars vars) (out '()))
@ -166,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))
((<letrec> vars vals body)
@ -174,21 +220,103 @@
(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))
((<fix> 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)))
;; 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
((<lambda> (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)))
((<let-values> vars exp body)
(hashq-set! bound-vars proc
(let lp ((out (hashq-ref bound-vars proc)) (in 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)))))
(if (null? in) out (cons in out))))))
(hashq-set! bound-vars proc bound)
(lset-difference eq?
(lset-union eq? (step exp) (step body))
vars))
(lset-union eq? (step exp) (step-tail body))
bound)))
(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
@ -237,9 +365,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)
((<let> vars vals body)
@ -285,12 +417,61 @@
`(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n))))))
((<fix> vars vals body)
(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)
((<lambda> 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))))))))
((<let-values> 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)))
(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 (car vars)))
(hashq-set!
allocation v
@ -300,14 +481,7 @@
(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)
(analyze! x #f '() #t #f)
(allocate! x #f 0)
allocation)
@ -381,6 +555,9 @@
((<letrec> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
((<fix> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
((<let-values> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
@ -428,6 +605,9 @@
((<letrec> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
((<fix> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
((<let-values> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))

327
module/language/tree-il/compile-glil.scm
View file

@ -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) ...)
@ -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)))))
@ -85,6 +85,8 @@
((>= . 2) . ge?)
((+ . 2) . add)
((- . 2) . sub)
((1+ . 1) . add1)
((1- . 1) . sub1)
((* . 2) . mul)
((/ . 2) . div)
((quotient . 2) . quo)
@ -161,10 +163,10 @@
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
(vars->bind-list ids vars allocation proc)))))
(vars->bind-list ids vars allocation proc))))
(define (with-output-to-code proc)
(let ((out '()))
@ -175,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))
@ -186,13 +188,18 @@
(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
(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 (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
@ -204,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 emit-code)))))))
(flatten (lambda-body x) allocation x self-label
labels emit-code)))))))
(define (flatten x allocation proc 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
((<void>)
(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))
((<const> 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
((<sequence> src exps)
@ -258,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))))))
@ -272,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,
@ -285,7 +303,8 @@
;; 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)))
@ -294,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))))))
@ -319,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)))
@ -336,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)
@ -350,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*
@ -371,34 +395,74 @@
(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))))))
;; 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)
;; 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-call 'mv-call len LMVRA)))
((drop)
(let ((MV (make-label)) (POST (make-label)))
((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 POST)
(emit-branch #f 'br (or RA POST))
(emit-label MV)
(emit-code #f (make-glil-mv-bind '() #f))
(emit-code #f (make-glil-unbind))
(emit-label POST))))))))
(if RA
(emit-branch #f 'br RA)
(emit-label POST)))))))))
((<conditional> src test then else)
;; TEST
@ -411,11 +475,13 @@
(comp-push test)
(emit-branch src 'br-if-not L1)
(comp-tail then)
(if (not (eq? context 'tail))
;; 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 (and (not RA) (not (eq? context 'tail)))
(emit-label L2))))
((<primitive-ref> src name)
@ -423,92 +489,79 @@
((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))))
((<lexical-ref> 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
(error "badness" x loc)))))
(case context
((tail) (emit-code #f (make-glil-call 'return 1)))))
(maybe-emit-return))
((<lexical-set> 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
(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))
((<module-ref> 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))
((<module-set> 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))
((<toplevel-ref> 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))
((<toplevel-set> 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))
((<toplevel-define> 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))
((<lambda>)
(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 allocation))
(emit-code #f (flatten-lambda x #f allocation))
(if (not (null? free-locs))
(begin
(for-each
@ -519,15 +572,14 @@
(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))
((<let> 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)
@ -539,15 +591,15 @@
((<letrec> 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))))
@ -555,6 +607,87 @@
(comp-tail body)
(emit-code #f (make-glil-unbind)))
((<fix> src names vars vals body)
;; 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))
((assq (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))))
((<let-values> src names vars exp body)
(let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
(cond
@ -571,10 +704,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)

180
module/language/tree-il/fix-letrec.scm Normal file
View file

@ -0,0 +1,180 @@
;;; 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 (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
#:export (fix-letrec!))
;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
;; Efficient Implementation of Scheme’s Recursive Binding Construct", by
;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.
(define fix-fold
(make-tree-il-folder unref ref set simple lambda complex))
(define (simple-expression? x bound-vars)
(record-case x
((<void>) #t)
((<const>) #t)
((<lexical-ref> gensym)
(not (memq gensym bound-vars)))
((<conditional> test then else)
(and (simple-expression? test bound-vars)
(simple-expression? then bound-vars)
(simple-expression? else bound-vars)))
((<sequence> exps)
(and-map (lambda (x) (simple-expression? x bound-vars))
exps))
((<application> proc args)
(and (primitive-ref? proc)
(effect-free-primitive? (primitive-ref-name proc))
(and-map (lambda (x) (simple-expression? x bound-vars))
args)))
(else #f)))
(define (partition-vars x)
(let-values
(((unref ref set simple lambda* complex)
(fix-fold x
(lambda (x unref ref set simple lambda* complex)
(record-case x
((<lexical-ref> gensym)
(values (delq gensym unref)
(lset-adjoin eq? ref gensym)
set
simple
lambda*
complex))
((<lexical-set> gensym)
(values unref
ref
(lset-adjoin eq? set gensym)
simple
lambda*
complex))
((<letrec> vars)
(values (append vars unref)
ref
set
simple
lambda*
complex))
(else
(values unref ref set simple lambda* complex))))
(lambda (x unref ref set simple lambda* complex)
(record-case x
((<letrec> (orig-vars vars) vals)
(let lp ((vars orig-vars) (vals vals)
(s '()) (l '()) (c '()))
(cond
((null? vars)
(values unref
ref
set
(append s simple)
(append l lambda*)
(append c complex)))
((memq (car vars) unref)
(lp (cdr vars) (cdr vals)
s l c))
((memq (car vars) set)
(lp (cdr vars) (cdr vals)
s l (cons (car vars) c)))
((lambda? (car vals))
(lp (cdr vars) (cdr vals)
s (cons (car vars) l) c))
((simple-expression? (car vals) orig-vars)
(lp (cdr vars) (cdr vals)
(cons (car vars) s) l c))
(else
(lp (cdr vars) (cdr vals)
s l (cons (car vars) c))))))
(else
(values unref ref set simple lambda* complex))))
'()
'()
'()
'()
'()
'())))
(values unref simple lambda* complex)))
(define (fix-letrec! x)
(let-values (((unref simple lambda* complex) (partition-vars x)))
(post-order!
(lambda (x)
(record-case x
;; Sets to unreferenced variables may be replaced by their
;; expression, called for effect.
((<lexical-set> gensym exp)
(if (memq gensym unref)
(make-sequence #f (list (make-void #f) exp))
x))
((<letrec> src names vars vals body)
(let ((binds (map list vars names vals)))
(define (lookup set)
(map (lambda (v) (assq v binds))
(lset-intersection eq? vars set)))
(let ((u (lookup unref))
(s (lookup simple))
(l (lookup lambda*))
(c (lookup complex)))
;; Bind "simple" bindings, and locations for complex
;; bindings.
(make-let
src
(append (map cadr s) (map cadr c))
(append (map car s) (map car c))
(append (map caddr s) (map (lambda (x) (make-void #f)) c))
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
(make-sequence
src
(append
;; The right-hand-sides of the unreferenced
;; bindings, for effect.
(map caddr u)
(if (null? c)
;; No complex bindings, just emit the body.
(list body)
(list
;; Evaluate the the "complex" bindings, in a `let' to
;; indicate that order doesn't matter, and bind to
;; their variables.
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
(make-sequence
#f
(map (lambda (x tmp)
(make-lexical-set
#f (cadr x) (car x)
(make-lexical-ref #f (cadr x) tmp)))
c tmps))))
;; Finally, the body.
body)))))))))
(else x)))
x)))

81
module/language/tree-il/inline.scm Normal file
View file

@ -0,0 +1,81 @@
;;; 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 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)
#: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
((<application> src proc args)
(cond
;; ((lambda () x)) => x
((and (lambda? proc) (null? (lambda-vars 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)))
((<let> vars body)
(if (null? vars) body x))
((<letrec> vars body)
(if (null? vars) body x))
((<fix> vars body)
(if (null? vars) body x))
(else #f)))
x))

18
module/language/tree-il/optimize.scm
View file

@ -21,21 +21,15 @@
(define-module (language tree-il optimize)
#: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)
(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!
(fix-letrec!
(expand-primitives!
(resolve-primitives! x (env-module env))))))

64
module/language/tree-il/primitives.scm
View file

@ -19,12 +19,13 @@
;;; 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)
#:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive!
expand-primitives!))
expand-primitives! effect-free-primitive?))
(define *interesting-primitive-names*
'(apply @apply
@ -84,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)
@ -142,8 +176,14 @@
(define (consequent exp)
(cond
((pair? 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))))
,(inline-args (cdr exp))))))
((symbol? exp)
;; assume locally bound
exp)
@ -160,9 +200,21 @@
(cons `((src . ,(car in))
,(consequent (cadr in))) out)))))))
(define-primitive-expander zero? (x)
(= x 0))
(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 +224,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)))

215
module/srfi/srfi-11.scm
View file

@ -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,58 @@
;; (q <tmp-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
; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) 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 (<tmp-x> <tmp-y>
; ;; <tmp-z>) ...) 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 ()
((_ ((binds exp)) b0 b1 ...)
(syntax (call-with-values (lambda () exp)
(lambda binds b0 b1 ...))))
((_ (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 +136,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

89
module/system/base/syntax.scm
View file

@ -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 ...))))
((((<foo> f0 ...) e0 ...) . rest)
(lp (syntax rest)
(cons (process-clause (syntax <foo>)
(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.

2
test-suite/tests/tree-il.test
View file

@ -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