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 dnl GMP tests
AC_LIB_LINKFLAGS(gmp) AC_LIB_HAVE_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_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. dnl GNU libunistring tests.
if test "x$LTLIBUNISTRING" != "x"; then AC_LIB_HAVE_LINKFLAGS(unistring,
LIBS="$LTLIBUNISTRING $LIBS" [],
else [#include <unistr.h>],
AC_MSG_ERROR([GNU libunistring is required, please install it.]) [u8_check ("foo", 3)]
fi AC_MSG_ERROR([GNU libunistring not found, see README]))
dnl i18n tests dnl i18n tests
#AC_CHECK_HEADERS([libintl.h]) #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 noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
libguile_la_DEPENDENCIES = @LIBLOBJS@ 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 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> # These are headers visible as <guile/mumble.h>

17
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 'l': case 'L':
case 's': case 'S': case 's': case 'S':
idx++; idx++;
if (idx == len)
return SCM_BOOL_F;
start = idx; start = idx;
c = mem[idx]; c = mem[idx];
if (c == '-') if (c == '-')
{ {
idx++; idx++;
if (idx == len)
return SCM_BOOL_F;
sign = -1; sign = -1;
c = mem[idx]; c = mem[idx];
} }
else if (c == '+') else if (c == '+')
{ {
idx++; idx++;
if (idx == len)
return SCM_BOOL_F;
sign = 1; sign = 1;
c = mem[idx]; c = mem[idx];
} }
@ -2783,8 +2792,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
SCM divisor; SCM divisor;
idx++; 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)) if (scm_is_false (divisor))
return SCM_BOOL_F; return SCM_BOOL_F;
@ -2905,11 +2916,15 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
if (c == '+') if (c == '+')
{ {
idx++; idx++;
if (idx == len)
return SCM_BOOL_F;
sign = 1; sign = 1;
} }
else if (c == '-') else if (c == '-')
{ {
idx++; idx++;
if (idx == len)
return SCM_BOOL_F;
sign = -1; sign = -1;
} }
else else

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

@ -215,11 +215,37 @@ VM_DEFINE_FUNCTION (120, add, "add", 2)
FUNC2 (+, scm_sum); 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) VM_DEFINE_FUNCTION (121, sub, "sub", 2)
{ {
FUNC2 (-, scm_difference); 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) VM_DEFINE_FUNCTION (122, mul, "mul", 2)
{ {
ARGS2 (x, y); ARGS2 (x, y);
@ -289,7 +315,10 @@ VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
&& i < SCM_I_VECTOR_LENGTH (vect))) && i < SCM_I_VECTOR_LENGTH (vect)))
RETURN (SCM_I_VECTOR_ELTS (vect)[i]); RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
else 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) 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))) && i < SCM_I_VECTOR_LENGTH (vect)))
SCM_I_VECTOR_WELTS (vect)[i] = val; SCM_I_VECTOR_WELTS (vect)[i] = val;
else else
scm_vector_set_x (vect, idx, val); {
SYNC_REGISTER ();
scm_vector_set_x (vect, idx, val);
}
NEXT; 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; 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 () (defun renumber-ops ()

15
module/Makefile.am
View file

@ -37,11 +37,11 @@ SOURCES = \
system/base/message.scm \ system/base/message.scm \
\ \
language/tree-il.scm \ language/tree-il.scm \
language/ghil.scm language/glil.scm language/assembly.scm \ language/glil.scm language/assembly.scm \
\ \
$(SCHEME_LANG_SOURCES) \ $(SCHEME_LANG_SOURCES) \
$(TREE_IL_LANG_SOURCES) \ $(TREE_IL_LANG_SOURCES) \
$(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \ $(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \ $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \
\ \
@ -50,9 +50,10 @@ SOURCES = \
$(RNRS_SOURCES) \ $(RNRS_SOURCES) \
$(OOP_SOURCES) \ $(OOP_SOURCES) \
$(SYSTEM_SOURCES) \ $(SYSTEM_SOURCES) \
$(SCRIPTS_SOURCES) \
$(GHIL_LANG_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \ $(ECMASCRIPT_LANG_SOURCES) \
$(BRAINFUCK_LANG_SOURCES) \ $(BRAINFUCK_LANG_SOURCES)
$(SCRIPTS_SOURCES)
## test.scm is not currently installed. ## test.scm is not currently installed.
EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008 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 = \ TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \ language/tree-il/primitives.scm \
language/tree-il/optimize.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/analyze.scm \
language/tree-il/compile-glil.scm \ language/tree-il/compile-glil.scm \
language/tree-il/spec.scm language/tree-il/spec.scm
GHIL_LANG_SOURCES = \ 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 = \ GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm \ language/glil/spec.scm language/glil/compile-assembly.scm \

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

@ -251,35 +251,41 @@
(emit-code (emit-code
(if local? (if local?
(if (< index 256) (if (< index 256)
`((,(case op (case op
((ref) (if boxed? 'local-boxed-ref 'local-ref)) ((ref) (if boxed?
((set) (if boxed? 'local-boxed-set 'local-set)) `((local-boxed-ref ,index))
((box) 'box) `((local-ref ,index))))
((empty-box) 'empty-box) ((set) (if boxed?
(else (error "what" op))) `((local-boxed-set ,index))
,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)) (let ((a (quotient i 256))
(b (modulo i 256))) (b (modulo i 256)))
`((,(case op `((,(case op
((ref) ((ref)
(if boxed? (if boxed?
`((long-local-ref ,a ,b) `((long-local-ref ,a ,b)
(variable-ref)) (variable-ref))
`((long-local-ref ,a ,b)))) `((long-local-ref ,a ,b))))
((set) ((set)
(if boxed? (if boxed?
`((long-local-ref ,a ,b) `((long-local-ref ,a ,b)
(variable-set)) (variable-set))
`((long-local-set ,a ,b)))) `((long-local-set ,a ,b))))
((box) ((box)
`((make-variable) `((make-variable)
(variable-set) (variable-set)
(long-local-set ,a ,b))) (long-local-set ,a ,b)))
((empty-box) ((empty-box)
`((make-variable) `((make-variable)
(long-local-set ,a ,b))) (long-local-set ,a ,b)))
(else (error "what" op))) ((fix)
,index)))) `((fix-closure ,a ,b)))
(else (error "what" op)))
,index))))
`((,(case op `((,(case op
((ref) (if boxed? 'free-boxed-ref 'free-ref)) ((ref) (if boxed? 'free-boxed-ref 'free-ref))
((set) (if boxed? 'free-boxed-set (error "what." glil))) ((set) (if boxed? 'free-boxed-set (error "what." glil)))

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

@ -1,6 +1,6 @@
;;; Guile Scheme specification ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -20,7 +20,6 @@
(define-module (language scheme spec) (define-module (language scheme spec)
#:use-module (system base language) #:use-module (system base language)
#:use-module (language scheme compile-ghil)
#:use-module (language scheme compile-tree-il) #:use-module (language scheme compile-tree-il)
#:use-module (language scheme decompile-tree-il) #:use-module (language scheme decompile-tree-il)
#:export (scheme)) #:export (scheme))
@ -39,8 +38,7 @@
#:title "Guile Scheme" #:title "Guile Scheme"
#:version "0.5" #:version "0.5"
#:reader read #:reader read
#:compilers `((tree-il . ,compile-tree-il) #:compilers `((tree-il . ,compile-tree-il))
(ghil . ,compile-ghil))
#:decompilers `((tree-il . ,decompile-tree-il)) #:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x)) #:evaluator (lambda (x module) (primitive-eval x))
#:printer write #:printer write

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

@ -18,6 +18,7 @@
(define-module (language tree-il) (define-module (language tree-il)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (system base pmatch) #:use-module (system base pmatch)
#:use-module (system base syntax) #:use-module (system base syntax)
#:export (tree-il-src #:export (tree-il-src
@ -38,6 +39,7 @@
<lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body <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 <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 <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 <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 parse-tree-il
@ -45,6 +47,7 @@
tree-il->scheme tree-il->scheme
tree-il-fold tree-il-fold
make-tree-il-folder
post-order! post-order!
pre-order!)) pre-order!))
@ -65,6 +68,7 @@
(<lambda> names vars meta body) (<lambda> names vars meta body)
(<let> names vars vals body) (<let> names vars vals body)
(<letrec> names vars vals body) (<letrec> names vars vals body)
(<fix> names vars vals body)
(<let-values> names vars exp body)) (<let-values> names vars exp body))
@ -141,6 +145,9 @@
((letrec ,names ,vars ,vals ,body) ((letrec ,names ,vars ,vals ,body)
(make-letrec loc names vars (map retrans vals) (retrans 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) ((let-values ,names ,vars ,exp ,body)
(make-let-values loc names vars (retrans exp) (retrans body))) (make-let-values loc names vars (retrans exp) (retrans body)))
@ -197,6 +204,9 @@
((<letrec> names vars vals body) ((<letrec> names vars vals body)
`(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il 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 exp body)
`(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body))))) `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
@ -256,6 +266,10 @@
((<letrec> vars vals body) ((<letrec> vars vals body)
`(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme 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) ((<let-values> vars exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp)) `(call-with-values (lambda () ,(tree-il->scheme exp))
(lambda ,vars ,(tree-il->scheme body)))))) (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 (up tree (loop body
(loop vals (loop vals
(down tree result))))) (down tree result)))))
((<let-values> body) ((<fix> vals body)
(up tree (loop body (down tree result)))) (up tree (loop body
(loop vals
(down tree result)))))
((<let-values> exp body)
(up tree (loop body (loop exp (down tree result)))))
(else (else
(leaf tree result)))))) (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) (define (post-order! f x)
(let lp ((x x)) (let lp ((x x))
(record-case 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-vals x) (map lp vals))
(set! (letrec-body x) (lp body))) (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) ((<let-values> vars exp body)
(set! (let-values-exp x) (lp exp)) (set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body))) (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-vals x) (map lp vals))
(set! (letrec-body x) (lp body))) (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) ((<let-values> vars exp body)
(set! (let-values-exp x) (lp exp)) (set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body))) (set! (let-values-body x) (lp body)))

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

@ -78,6 +78,25 @@
;; in a vector. Each closure variable has a unique index into that ;; in a vector. Each closure variable has a unique index into that
;; vector. ;; 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 ;; The return value of `analyze-lexicals' is a hash table, the
;; "allocation". ;; "allocation".
@ -88,15 +107,17 @@
;; in many procedures, it is a two-level map. ;; in many procedures, it is a two-level map.
;; ;;
;; The allocation also stored information on how many local variables ;; The allocation also stored information on how many local variables
;; need to be allocated for each procedure, and information on what free ;; need to be allocated for each procedure, lexicals that have been
;; variables to capture from its lexical parent procedure. ;; translated into labels, and information on what free variables to
;; capture from its lexical parent procedure.
;; ;;
;; That is: ;; That is:
;; ;;
;; sym -> {lambda -> address} ;; 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-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc. ;; free variable addresses are relative to parent proc.
@ -108,32 +129,52 @@
(define (analyze-lexicals x) (define (analyze-lexicals x)
;; bound-vars: lambda -> (sym ...) ;; bound-vars: lambda -> (sym ...)
;; all identifiers bound within a lambda ;; all identifiers bound within a lambda
(define bound-vars (make-hash-table))
;; free-vars: lambda -> (sym ...) ;; free-vars: lambda -> (sym ...)
;; all identifiers referenced in a lambda, but not bound ;; all identifiers referenced in a lambda, but not bound
;; NB, this includes identifiers referenced by contained lambdas ;; NB, this includes identifiers referenced by contained lambdas
(define free-vars (make-hash-table))
;; assigned: sym -> #t ;; assigned: sym -> #t
;; variables that are assigned ;; variables that are assigned
(define assigned (make-hash-table))
;; refcounts: sym -> count ;; refcounts: sym -> count
;; allows us to detect the or-expansion in O(1) time ;; 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 ;; returns variables referenced in expr
(define (analyze! x proc) (define (analyze! x proc labels-in-proc tail? tail-call-args)
(define (step y) (analyze! y proc)) (define (step y) (analyze! y proc labels-in-proc #f #f))
(define (recur x new-proc) (analyze! x new-proc)) (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 (record-case x
((<application> proc args) ((<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) ((<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) ((<lexical-ref> name gensym)
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) (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)) (list gensym))
((<lexical-set> name gensym exp) ((<lexical-set> name gensym exp)
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
(hashq-set! assigned gensym #t) (hashq-set! assigned gensym #t)
(hashq-set! labels gensym #f)
(lset-adjoin eq? (step exp) gensym)) (lset-adjoin eq? (step exp) gensym))
((<module-set> mod name public? exp) ((<module-set> mod name public? exp)
@ -146,7 +187,12 @@
(step exp)) (step exp))
((<sequence> exps) ((<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) ((<lambda> vars meta body)
(let ((locally-bound (let rev* ((vars vars) (out '())) (let ((locally-bound (let rev* ((vars vars) (out '()))
@ -166,7 +212,7 @@
(hashq-set! bound-vars proc (hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc))) (append (reverse vars) (hashq-ref bound-vars proc)))
(lset-difference eq? (lset-difference eq?
(apply lset-union eq? (step body) (map step vals)) (apply lset-union eq? (step-tail body) (map step vals))
vars)) vars))
((<letrec> vars vals body) ((<letrec> vars vals body)
@ -174,21 +220,103 @@
(append (reverse vars) (hashq-ref bound-vars proc))) (append (reverse vars) (hashq-ref bound-vars proc)))
(for-each (lambda (sym) (hashq-set! assigned sym #t)) vars) (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
(lset-difference eq? (lset-difference eq?
(apply lset-union eq? (step body) (map step vals)) (apply lset-union eq? (step-tail body) (map step vals))
vars)) 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) ((<let-values> vars exp body)
(hashq-set! bound-vars proc (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
(let lp ((out (hashq-ref bound-vars proc)) (in vars)) (if (pair? in)
(if (pair? in) (lp (cons (car in) out) (cdr 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-difference eq?
(lset-union eq? (step exp) (step body)) (lset-union eq? (step exp) (step-tail body))
vars)) bound)))
(else '()))) (else '())))
;; allocation: sym -> {lambda -> address}
;; lambda -> (nlocs labels . free-locs)
(define allocation (make-hash-table))
(define (allocate! x proc n) (define (allocate! x proc n)
(define (recur y) (allocate! y proc n)) (define (recur y) (allocate! y proc n))
(record-case x (record-case x
@ -237,9 +365,13 @@
(free-addresses (free-addresses
(map (lambda (v) (map (lambda (v)
(hashq-ref (hashq-ref allocation v) proc)) (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 ;; set procedure allocations
(hashq-set! allocation x (cons nlocs free-addresses))) (hashq-set! allocation x (cons* nlocs labels free-addresses)))
n) n)
((<let> vars vals body) ((<let> vars vals body)
@ -285,29 +417,71 @@
`(#t ,(hashq-ref assigned v) . ,n))) `(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ 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-values> vars exp body)
(let ((nmax (recur exp))) (let ((nmax (recur exp)))
(let lp ((vars vars) (n n)) (let lp ((vars vars) (n n))
(if (null? vars) (cond
(max nmax (allocate! body proc n)) ((null? vars)
(let ((v (if (pair? vars) (car vars) vars))) (max nmax (allocate! body proc n)))
(let ((v (car vars))) ((not (pair? vars))
(hashq-set! (hashq-set! allocation vars
allocation v (make-hashq proc
(make-hashq proc `(#t ,(hashq-ref assigned vars) . ,n)))
`(#t ,(hashq-ref assigned v) . ,n))) ;; the 1+ for this var
(lp (cdr vars) (1+ n)))))))) (max nmax (allocate! body proc (1+ n))))
(else
(let ((v (car vars)))
(hashq-set!
allocation v
(make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n))))))))
(else n))) (else n)))
(define bound-vars (make-hash-table)) (analyze! x #f '() #t #f)
(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) (allocate! x #f 0)
allocation) allocation)
@ -381,6 +555,9 @@
((<letrec> vars names) ((<letrec> vars names)
(make-binding-info (extend vars names) refs (make-binding-info (extend vars names) refs
(cons src locs))) (cons src locs)))
((<fix> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
((<let-values> vars names) ((<let-values> vars names)
(make-binding-info (extend vars names) refs (make-binding-info (extend vars names) refs
(cons src locs))) (cons src locs)))
@ -428,6 +605,9 @@
((<letrec> vars) ((<letrec> vars)
(make-binding-info (shrink vars refs) refs (make-binding-info (shrink vars refs) refs
(cdr locs))) (cdr locs)))
((<fix> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
((<let-values> vars) ((<let-values> vars)
(make-binding-info (shrink vars refs) refs (make-binding-info (shrink vars refs) refs
(cdr locs))) (cdr locs)))

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

@ -37,7 +37,7 @@
;; allocation: ;; allocation:
;; sym -> {lambda -> address} ;; sym -> {lambda -> address}
;; lambda -> (nlocs . closure-vars) ;; lambda -> (nlocs labels . free-locs)
;; ;;
;; address := (local? boxed? . index) ;; address := (local? boxed? . index)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
@ -66,7 +66,7 @@
(with-fluid* *comp-module* (or (and e (car e)) (current-module)) (with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda () (lambda ()
(values (flatten-lambda x allocation) (values (flatten-lambda x #f allocation)
(and e (cons (car e) (cddr e))) (and e (cons (car e) (cddr e)))
e))))) e)))))
@ -85,6 +85,8 @@
((>= . 2) . ge?) ((>= . 2) . ge?)
((+ . 2) . add) ((+ . 2) . add)
((- . 2) . sub) ((- . 2) . sub)
((1+ . 1) . add1)
((1- . 1) . sub1)
((* . 2) . mul) ((* . 2) . mul)
((/ . 2) . div) ((/ . 2) . div)
((quotient . 2) . quo) ((quotient . 2) . quo)
@ -161,10 +163,10 @@
ids ids
vars)) vars))
;; FIXME: always emit? otherwise it's hard to pair bind with unbind
(define (emit-bindings src ids vars allocation proc emit-code) (define (emit-bindings src ids vars allocation proc emit-code)
(if (pair? vars) (emit-code src (make-glil-bind
(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) (define (with-output-to-code proc)
(let ((out '())) (let ((out '()))
@ -175,7 +177,7 @@
(proc emit-code) (proc emit-code)
(reverse out))) (reverse out)))
(define (flatten-lambda x allocation) (define (flatten-lambda x self-label allocation)
(receive (ids vars nargs nrest) (receive (ids vars nargs nrest)
(let lp ((ids (lambda-names x)) (vars (lambda-vars x)) (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
(oids '()) (ovars '()) (n 0)) (oids '()) (ovars '()) (n 0))
@ -186,53 +188,67 @@
(else (values (reverse (cons ids oids)) (else (values (reverse (cons ids oids))
(reverse (cons vars ovars)) (reverse (cons vars ovars))
(1+ n) 1)))) (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 (make-glil-program
nargs nrest nlocs (lambda-meta x) nargs nrest nlocs (lambda-meta x)
(with-output-to-code (with-output-to-code
(lambda (emit-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 ;; 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) (if (lambda-src x)
(emit-code #f (make-glil-source (lambda-src x)))) (emit-code #f (make-glil-source (lambda-src x))))
;; box args if necessary ;; box args if necessary
(for-each (for-each
(lambda (v) (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) x) (pmatch (hashq-ref (hashq-ref allocation v) x)
((#t #t . ,n) ((#t #t . ,n)
(emit-code #f (make-glil-lexical #t #f 'ref n)) (emit-code #f (make-glil-lexical #t #f 'ref n))
(emit-code #f (make-glil-lexical #t #t 'box n))))) (emit-code #f (make-glil-lexical #t #t 'box n)))))
vars) vars)
;; and here, here, dear reader: we compile. ;; 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) (define (emit-label label)
(emit-code #f (make-glil-label label))) (emit-code #f (make-glil-label label)))
(define (emit-branch src inst label) (define (emit-branch src inst label)
(emit-code src (make-glil-branch inst label))) (emit-code src (make-glil-branch inst label)))
;; LMVRA == "let-values MV return address" ;; RA: "return address"; #f unless we're in a non-tail fix with labels
(let comp ((x x) (context 'tail) (LMVRA #f)) ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
(define (comp-tail tree) (comp tree context LMVRA)) (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
(define (comp-push tree) (comp tree 'push #f)) (define (comp-tail tree) (comp tree context RA MVRA))
(define (comp-drop tree) (comp tree 'drop #f)) (define (comp-push tree) (comp tree 'push #f #f))
(define (comp-vals tree LMVRA) (comp tree 'vals LMVRA)) (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 (record-case x
((<void>) ((<void>)
(case context (case context
((push vals) (emit-code #f (make-glil-void))) ((push vals tail)
((tail) (emit-code #f (make-glil-void))))
(emit-code #f (make-glil-void)) (maybe-emit-return))
(emit-code #f (make-glil-call 'return 1)))))
((<const> src exp) ((<const> src exp)
(case context (case context
((push vals) (emit-code src (make-glil-const exp))) ((push vals tail)
((tail) (emit-code src (make-glil-const exp))))
(emit-code src (make-glil-const exp)) (maybe-emit-return))
(emit-code #f (make-glil-call 'return 1)))))
;; FIXME: should represent sequence as exps tail ;; FIXME: should represent sequence as exps tail
((<sequence> src exps) ((<sequence> src exps)
@ -258,7 +274,7 @@
;; drop: (lambda () (apply values '(1 2)) 3) ;; drop: (lambda () (apply values '(1 2)) 3)
;; push: (lambda () (list (apply values '(10 12)) 1)) ;; push: (lambda () (list (apply values '(10 12)) 1))
(case context (case context
((drop) (for-each comp-drop args)) ((drop) (for-each comp-drop args) (maybe-emit-return))
((tail) ((tail)
(for-each comp-push args) (for-each comp-push args)
(emit-code src (make-glil-call 'return/values* (length args)))))) (emit-code src (make-glil-call 'return/values* (length args))))))
@ -272,12 +288,14 @@
((push) ((push)
(comp-push proc) (comp-push proc)
(for-each comp-push args) (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) ((vals)
(comp-vals (comp-vals
(make-application src (make-primitive-ref #f 'apply) (make-application src (make-primitive-ref #f 'apply)
(cons proc args)) (cons proc args))
LMVRA)) MVRA)
(maybe-emit-return))
((drop) ((drop)
;; Well, shit. The proc might return any number of ;; Well, shit. The proc might return any number of
;; values (including 0), since it's in a drop context, ;; values (including 0), since it's in a drop context,
@ -285,8 +303,9 @@
;; mv-call out to our trampoline instead. ;; mv-call out to our trampoline instead.
(comp-drop (comp-drop
(make-application src (make-primitive-ref #f 'apply) (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) ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
(not (eq? context 'push))) (not (eq? context 'push)))
;; tail: (lambda () (values '(1 2))) ;; tail: (lambda () (values '(1 2)))
@ -294,11 +313,11 @@
;; push: (lambda () (list (values '(10 12)) 1)) ;; push: (lambda () (list (values '(10 12)) 1))
;; vals: (let-values (((a b ...) (values 1 2 ...))) ...) ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
(case context (case context
((drop) (for-each comp-drop args)) ((drop) (for-each comp-drop args) (maybe-emit-return))
((vals) ((vals)
(for-each comp-push args) (for-each comp-push args)
(emit-code #f (make-glil-const (length args))) (emit-code #f (make-glil-const (length args)))
(emit-branch src 'br LMVRA)) (emit-branch src 'br MVRA))
((tail) ((tail)
(for-each comp-push args) (for-each comp-push args)
(emit-code src (make-glil-call 'return/values (length args)))))) (emit-code src (make-glil-call 'return/values (length args))))))
@ -319,7 +338,8 @@
(comp-vals (comp-vals
(make-application src (make-primitive-ref #f 'call-with-values) (make-application src (make-primitive-ref #f 'call-with-values)
args) args)
LMVRA)) MVRA)
(maybe-emit-return))
(else (else
(let ((MV (make-label)) (POST (make-label)) (let ((MV (make-label)) (POST (make-label))
(producer (car args)) (consumer (cadr args))) (producer (car args)) (consumer (cadr args)))
@ -336,7 +356,8 @@
(else (emit-code src (make-glil-call 'call/nargs 0)) (else (emit-code src (make-glil-call 'call/nargs 0))
(emit-label POST) (emit-label POST)
(if (eq? context 'drop) (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) ((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-current-continuation) (eq? (primitive-ref-name proc) '@call-with-current-continuation)
@ -350,16 +371,19 @@
(make-application (make-application
src (make-primitive-ref #f 'call-with-current-continuation) src (make-primitive-ref #f 'call-with-current-continuation)
args) args)
LMVRA)) MVRA)
(maybe-emit-return))
((push) ((push)
(comp-push (car args)) (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) ((drop)
;; Crap. Just like `apply' in drop context. ;; Crap. Just like `apply' in drop context.
(comp-drop (comp-drop
(make-application (make-application
src (make-primitive-ref #f 'call-with-current-continuation) src (make-primitive-ref #f 'call-with-current-continuation)
args))))) args))
(maybe-emit-return))))
((and (primitive-ref? proc) ((and (primitive-ref? proc)
(or (hash-ref *primcall-ops* (or (hash-ref *primcall-ops*
@ -371,34 +395,74 @@
(case (instruction-pushes op) (case (instruction-pushes op)
((0) ((0)
(case context (case context
((tail) (emit-code #f (make-glil-void)) ((tail push vals) (emit-code #f (make-glil-void))))
(emit-code #f (make-glil-call 'return 1))) (maybe-emit-return))
((push vals) (emit-code #f (make-glil-void)))))
((1) ((1)
(case context (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 (else
(error "bad primitive op: too many pushes" (error "bad primitive op: too many pushes"
op (instruction-pushes op)))))) 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 (else
(comp-push proc) (comp-push proc)
(for-each comp-push args) (for-each comp-push args)
(let ((len (length args))) (let ((len (length args)))
(case context (case context
((tail) (emit-code src (make-glil-call 'goto/args len))) ((tail) (emit-code src (make-glil-call 'goto/args len)))
((push) (emit-code src (make-glil-call 'call len))) ((push) (emit-code src (make-glil-call 'call len))
((vals) (emit-code src (make-glil-call 'mv-call len LMVRA))) (maybe-emit-return))
((drop) ((vals) (emit-code src (make-glil-mv-call len MVRA))
(let ((MV (make-label)) (POST (make-label))) (maybe-emit-return))
(emit-code src (make-glil-mv-call len MV)) ((drop) (let ((MV (make-label)) (POST (make-label)))
(emit-code #f (make-glil-call 'drop 1)) (emit-code src (make-glil-mv-call len MV))
(emit-branch #f 'br POST) (emit-code #f (make-glil-call 'drop 1))
(emit-label MV) (emit-branch #f 'br (or RA POST))
(emit-code #f (make-glil-mv-bind '() #f)) (emit-label MV)
(emit-code #f (make-glil-unbind)) (emit-code #f (make-glil-mv-bind '() #f))
(emit-label POST)))))))) (emit-code #f (make-glil-unbind))
(if RA
(emit-branch #f 'br RA)
(emit-label POST)))))))))
((<conditional> src test then else) ((<conditional> src test then else)
;; TEST ;; TEST
@ -411,104 +475,93 @@
(comp-push test) (comp-push test)
(emit-branch src 'br-if-not L1) (emit-branch src 'br-if-not L1)
(comp-tail then) (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-branch #f 'br L2))
(emit-label L1) (emit-label L1)
(comp-tail else) (comp-tail else)
(if (not (eq? context 'tail)) (if (and (not RA) (not (eq? context 'tail)))
(emit-label L2)))) (emit-label L2))))
((<primitive-ref> src name) ((<primitive-ref> src name)
(cond (cond
((eq? (module-variable (fluid-ref *comp-module*) name) ((eq? (module-variable (fluid-ref *comp-module*) name)
(module-variable the-root-module name)) (module-variable the-root-module name))
(case context (case context
((push vals) ((tail push vals)
(emit-code src (make-glil-toplevel 'ref name))) (emit-code src (make-glil-toplevel 'ref name))))
((tail) (maybe-emit-return))
(emit-code src (make-glil-toplevel 'ref name))
(emit-code #f (make-glil-call 'return 1)))))
(else (else
(pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*)) (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
(case context (case context
((push vals) ((tail push vals)
(emit-code src (make-glil-module 'ref '(guile) name #f))) (emit-code src (make-glil-module 'ref '(guile) name #f))))
((tail) (maybe-emit-return))))
(emit-code src (make-glil-module 'ref '(guile) name #f))
(emit-code #f (make-glil-call 'return 1)))))))
((<lexical-ref> src name gensym) ((<lexical-ref> src name gensym)
(case context (case context
((push vals tail) ((push vals tail)
(pmatch (hashq-ref (hashq-ref allocation gensym) proc) (pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index) ((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'ref index))) (emit-code src (make-glil-lexical local? boxed? 'ref index)))
(,loc (,loc
(error "badness" x loc))))) (error "badness" x loc)))))
(case context (maybe-emit-return))
((tail) (emit-code #f (make-glil-call 'return 1)))))
((<lexical-set> src name gensym exp) ((<lexical-set> src name gensym exp)
(comp-push exp) (comp-push exp)
(pmatch (hashq-ref (hashq-ref allocation gensym) proc) (pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index) ((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'set index))) (emit-code src (make-glil-lexical local? boxed? 'set index)))
(,loc (,loc
(error "badness" x loc))) (error "badness" x loc)))
(case context (case context
((push vals) ((tail push vals)
(emit-code #f (make-glil-void))) (emit-code #f (make-glil-void))))
((tail) (maybe-emit-return))
(emit-code #f (make-glil-void))
(emit-code #f (make-glil-call 'return 1)))))
((<module-ref> src mod name public?) ((<module-ref> src mod name public?)
(emit-code src (make-glil-module 'ref mod name public?)) (emit-code src (make-glil-module 'ref mod name public?))
(case context (case context
((drop) (emit-code #f (make-glil-call 'drop 1))) ((drop) (emit-code #f (make-glil-call 'drop 1))))
((tail) (emit-code #f (make-glil-call 'return 1))))) (maybe-emit-return))
((<module-set> src mod name public? exp) ((<module-set> src mod name public? exp)
(comp-push exp) (comp-push exp)
(emit-code src (make-glil-module 'set mod name public?)) (emit-code src (make-glil-module 'set mod name public?))
(case context (case context
((push vals) ((tail push vals)
(emit-code #f (make-glil-void))) (emit-code #f (make-glil-void))))
((tail) (maybe-emit-return))
(emit-code #f (make-glil-void))
(emit-code #f (make-glil-call 'return 1)))))
((<toplevel-ref> src name) ((<toplevel-ref> src name)
(emit-code src (make-glil-toplevel 'ref name)) (emit-code src (make-glil-toplevel 'ref name))
(case context (case context
((drop) (emit-code #f (make-glil-call 'drop 1))) ((drop) (emit-code #f (make-glil-call 'drop 1))))
((tail) (emit-code #f (make-glil-call 'return 1))))) (maybe-emit-return))
((<toplevel-set> src name exp) ((<toplevel-set> src name exp)
(comp-push exp) (comp-push exp)
(emit-code src (make-glil-toplevel 'set name)) (emit-code src (make-glil-toplevel 'set name))
(case context (case context
((push vals) ((tail push vals)
(emit-code #f (make-glil-void))) (emit-code #f (make-glil-void))))
((tail) (maybe-emit-return))
(emit-code #f (make-glil-void))
(emit-code #f (make-glil-call 'return 1)))))
((<toplevel-define> src name exp) ((<toplevel-define> src name exp)
(comp-push exp) (comp-push exp)
(emit-code src (make-glil-toplevel 'define name)) (emit-code src (make-glil-toplevel 'define name))
(case context (case context
((push vals) ((tail push vals)
(emit-code #f (make-glil-void))) (emit-code #f (make-glil-void))))
((tail) (maybe-emit-return))
(emit-code #f (make-glil-void))
(emit-code #f (make-glil-call 'return 1)))))
((<lambda>) ((<lambda>)
(let ((free-locs (cdr (hashq-ref allocation x)))) (let ((free-locs (cddr (hashq-ref allocation x))))
(case context (case context
((push vals tail) ((push vals tail)
(emit-code #f (flatten-lambda x allocation)) (emit-code #f (flatten-lambda x #f allocation))
(if (not (null? free-locs)) (if (not (null? free-locs))
(begin (begin
(for-each (for-each
@ -519,15 +572,14 @@
(else (error "what" x loc)))) (else (error "what" x loc))))
free-locs) free-locs)
(emit-code #f (make-glil-call 'vector (length free-locs))) (emit-code #f (make-glil-call 'vector (length free-locs)))
(emit-code #f (make-glil-call 'make-closure 2)))) (emit-code #f (make-glil-call 'make-closure 2)))))))
(if (eq? context 'tail) (maybe-emit-return))
(emit-code #f (make-glil-call 'return 1)))))))
((<let> src names vars vals body) ((<let> src names vars vals body)
(for-each comp-push vals) (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) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n) ((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n))) (emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n) ((#t #t . ,n)
@ -539,15 +591,15 @@
((<letrec> src names vars vals body) ((<letrec> src names vars vals body)
(for-each (lambda (v) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n) ((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n))) (emit-code src (make-glil-lexical #t #t 'empty-box n)))
(,loc (error "badness" x loc)))) (,loc (error "badness" x loc))))
vars) vars)
(for-each comp-push vals) (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) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n) ((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n))) (emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc)))) (,loc (error "badness" x loc))))
@ -555,6 +607,87 @@
(comp-tail body) (comp-tail body)
(emit-code #f (make-glil-unbind))) (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-values> src names vars exp body)
(let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
(cond (cond
@ -571,10 +704,10 @@
(emit-code #f (make-glil-const 1)) (emit-code #f (make-glil-const 1))
(emit-label MV) (emit-label MV)
(emit-code src (make-glil-mv-bind (emit-code src (make-glil-mv-bind
(vars->bind-list names vars allocation proc) (vars->bind-list names vars allocation self)
rest?)) rest?))
(for-each (lambda (v) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) proc) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n) ((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n))) (emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,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) (define-module (language tree-il optimize)
#:use-module (language tree-il) #:use-module (language tree-il)
#:use-module (language tree-il primitives) #:use-module (language tree-il primitives)
#:use-module (language tree-il inline)
#:use-module (language tree-il fix-letrec)
#:export (optimize!)) #:export (optimize!))
(define (env-module e) (define (env-module e)
(if e (car e) (current-module))) (if e (car e) (current-module)))
(define (optimize! x env opts) (define (optimize! x env opts)
(expand-primitives! (resolve-primitives! x (env-module env)))) (inline!
(fix-letrec!
;; Possible optimizations: (expand-primitives!
;; * constant folding, propagation (resolve-primitives! x (env-module env))))))
;; * procedure inlining
;; * always when single call site
;; * always for "trivial" procs
;; * otherwise who knows
;; * dead code elimination
;; * degenerate case optimizations
;; * "fixing letrec"

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

@ -19,12 +19,13 @@
;;; Code: ;;; Code:
(define-module (language tree-il primitives) (define-module (language tree-il primitives)
#:use-module (system base pmatch)
#:use-module (rnrs bytevector) #:use-module (rnrs bytevector)
#:use-module (system base syntax) #:use-module (system base syntax)
#:use-module (language tree-il) #:use-module (language tree-il)
#:use-module (srfi srfi-16) #:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive! #:export (resolve-primitives! add-interesting-primitive!
expand-primitives!)) expand-primitives! effect-free-primitive?))
(define *interesting-primitive-names* (define *interesting-primitive-names*
'(apply @apply '(apply @apply
@ -84,6 +85,39 @@
(for-each add-interesting-primitive! *interesting-primitive-names*) (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) (define (resolve-primitives! x mod)
(post-order! (post-order!
(lambda (x) (lambda (x)
@ -142,8 +176,14 @@
(define (consequent exp) (define (consequent exp)
(cond (cond
((pair? exp) ((pair? exp)
`(make-application src (make-primitive-ref src ',(car exp)) (pmatch exp
,(inline-args (cdr 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) ((symbol? exp)
;; assume locally bound ;; assume locally bound
exp) exp)
@ -160,9 +200,21 @@
(cons `((src . ,(car in)) (cons `((src . ,(car in))
,(consequent (cadr in))) out))))))) ,(consequent (cadr in))) out)))))))
(define-primitive-expander zero? (x)
(= x 0))
(define-primitive-expander + (define-primitive-expander +
() 0 () 0
(x) x (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))) (x y z . rest) (+ x (+ y z . rest)))
(define-primitive-expander * (define-primitive-expander *
@ -172,11 +224,13 @@
(define-primitive-expander - (define-primitive-expander -
(x) (- 0 x) (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))) (x y z . rest) (- x (+ y z . rest)))
(define-primitive-expander 1-
(x) (- x 1))
(define-primitive-expander / (define-primitive-expander /
(x) (/ 1 x) (x) (/ 1 x)
(x y z . rest) (/ x (* y z . rest))) (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 ;;; 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 ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -63,148 +63,58 @@
;; (q <tmp-q>)) ;; (q <tmp-q>))
;; (baz x y z p q)))))) ;; (baz x y z p q))))))
;; I originally wrote this as a define-macro, but then I found out ;; We could really use quasisyntax here...
;; that guile's gensym/gentemp was broken, so I tried rewriting it as (define-syntax let-values
;; a syntax-rules statement. (lambda (x)
;; [make-symbol now fixes gensym/gentemp problems.] (syntax-case x ()
;; ((_ ((binds exp)) b0 b1 ...)
;; Since syntax-rules didn't seem powerful enough to implement (syntax (call-with-values (lambda () exp)
;; let-values in one definition without exposing illegal syntax (or (lambda binds b0 b1 ...))))
;; perhaps my brain's just not powerful enough :>). I tried writing ((_ (clause ...) b0 b1 ...)
;; it using a private helper, but that didn't work because the (let lp ((clauses (syntax (clause ...)))
;; let-values expands outside the scope of this module. I wonder why (ids '())
;; syntax-rules wasn't designed to allow "private" patterns or (tmps '()))
;; similar... (if (null? clauses)
;; (with-syntax (((id ...) ids)
;; So in the end, I dumped the syntax-rules implementation, reproduced ((tmp ...) tmps))
;; here for posterity, and went with the define-macro one below -- (syntax (let ((id tmp) ...)
;; gensym/gentemp's got to be fixed anyhow... b0 b1 ...)))
; (syntax-case (car clauses) ()
; (define-syntax let-values-helper (((var ...) exp)
; (syntax-rules () (with-syntax (((new-tmp ...) (generate-temporaries
; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y (syntax (var ...))))
; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda ((id ...) ids)
; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the ((tmp ...) tmps))
; ;; temps you create so you can use them later... (with-syntax ((inner (lp (cdr clauses)
; ;; (syntax (var ... id ...))
; ;; I really don't fully understand why the (var-1 var-1) trick (syntax (new-tmp ... tmp ...)))))
; ;; works below, but basically, when all those (x x) bindings show (syntax (call-with-values (lambda () exp)
; ;; up in the final "let", syntax-rules forces a renaming. (lambda (new-tmp ...) inner))))))
((vars exp)
; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings (with-syntax ((((new-tmp . new-var) ...)
; body ...) (let lp ((vars (syntax vars)))
; (lambda lambda-tmps (syntax-case vars ()
; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) ((id . rest)
(acons (syntax id)
; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings (car
; body ...) (generate-temporaries (syntax (id))))
; (let-values-helper "consumer" (lp (syntax rest))))
; (var-2 ...) (id (acons (syntax id)
; (lambda-tmp ... var-1) (car
; ((var-1 var-1) . final-let-bindings) (generate-temporaries (syntax (id))))
; lv-bindings '())))))
; body ...)) ((id ...) ids)
((tmp ...) tmps))
; ((_ "cwv" () final-let-bindings body ...) (with-syntax ((inner (lp (cdr clauses)
; (let final-let-bindings (syntax (new-var ... id ...))
; body ...)) (syntax (new-tmp ... tmp ...))))
(args (let lp ((tmps (syntax (new-tmp ...))))
; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings (syntax-case tmps ()
; body ...) ((id) (syntax id))
; (call-with-values (lambda () binding-1) ((id . rest) (cons (syntax id)
; (let-values-helper "consumer" (lp (syntax rest))))))))
; vars-1 (syntax (call-with-values (lambda () exp)
; () (lambda args inner)))))))))))))
; 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 '())))
;;;;;;;;;;;;;; ;;;;;;;;;;;;;;
;; let*-values ;; let*-values
@ -226,28 +136,11 @@
(define-syntax let*-values (define-syntax let*-values
(syntax-rules () (syntax-rules ()
((let*-values () body ...) ((let*-values () body ...)
(begin body ...)) (let () body ...))
((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
(call-with-values (lambda () binding-1) (call-with-values (lambda () binding-1)
(lambda vars-1 (lambda vars-1
(let*-values ((vars-2 binding-2) ...) (let*-values ((vars-2 binding-2) ...)
body ...)))))) 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 ;;; srfi-11.scm ends here

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

@ -1,6 +1,6 @@
;;; Guile VM specific syntaxes and utilities ;;; 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 ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -174,29 +174,70 @@
;; 5.88 0.01 0.01 list-index ;; 5.88 0.01 0.01 list-index
(define-macro (record-case record . clauses) ;;; So ugly... but I am too ignorant to know how to make it better.
(let ((r (gensym)) (define-syntax record-case
(rtd (gensym))) (lambda (x)
(define (process-clause clause) (syntax-case x ()
(if (eq? (car clause) 'else) ((_ record clause ...)
clause (let ((r (syntax r))
(let ((record-type (caar clause)) (rtd (syntax rtd)))
(slots (cdar clause)) (define (process-clause tag fields exprs)
(body (cdr clause))) (let ((infix (trim-brackets (syntax->datum tag))))
(let ((stem (trim-brackets record-type))) (with-syntax ((tag tag)
`((eq? ,rtd ,record-type) (((f . accessor) ...)
(let ,(map (lambda (slot) (let lp ((fields fields))
(if (pair? slot) (syntax-case fields ()
`(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r)) (() (syntax ()))
`(,slot (,(symbol-append stem '- slot) ,r)))) (((v0 f0) f1 ...)
slots) (acons (syntax v0)
,@(if (pair? body) body '((if #f #f))))))))) (datum->syntax x
`(let* ((,r ,record) (symbol-append infix '- (syntax->datum
(,rtd (struct-vtable ,r))) (syntax f0))))
(cond ,@(let ((clauses (map process-clause clauses))) (lp (syntax (f1 ...)))))
(if (assq 'else clauses) ((f0 f1 ...)
clauses (acons (syntax f0)
(append clauses `((else (error "unhandled record" ,r)))))))))) (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 ;; Here we take the terrorism to another level. Nasty, but the client
;; code looks good. ;; 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))) (program 0 0 0 () (const 1) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive +) (void) (const 1)) (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" (with-test-prefix "application"
(assert-tree-il->glil (assert-tree-il->glil