[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-916-gd0d8a55
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-916-gd0d8a55 |
|
Date: |
Sun, 13 Apr 2014 12:24:57 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d0d8a552b414569b0f8d84f0a4f75bec38da693c
The branch, master has been updated
via d0d8a552b414569b0f8d84f0a4f75bec38da693c (commit)
via fcb31f29532b541b27e96df31c60a16902db8707 (commit)
via 2920554a1e45ccdfa3b1d6ea60d59a61a4bb430f (commit)
via 1487367e21b1d14b0c99c7704684e1354e07063f (commit)
from 32e62c2daefb67e9e2ccd90069eb9322de97e95b (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d0d8a552b414569b0f8d84f0a4f75bec38da693c
Author: Andy Wingo <address@hidden>
Date: Sun Apr 13 14:22:22 2014 +0200
Eval has no more free variables
* module/ice-9/eval.scm (primitive-eval): Expand out the call to
make-general-closure, so that make-general-closure becomes
well-known. Now eval has no more free variables!
commit fcb31f29532b541b27e96df31c60a16902db8707
Author: Andy Wingo <address@hidden>
Date: Sun Apr 13 14:21:25 2014 +0200
Closure conversion eliminates self-references introduced by fixpoint
* module/language/cps/closure-conversion.scm (analyze-closures): Build a
bound-vars set as well, to resolve introduced self-references.
(prune-free-vars, convert-one): Arrange to eliminate self-references.
commit 2920554a1e45ccdfa3b1d6ea60d59a61a4bb430f
Author: Andy Wingo <address@hidden>
Date: Sun Apr 13 13:52:56 2014 +0200
Refactor to closure-conversion
* module/language/cps/closure-conversion.scm (convert-one): Refactor to
pull in helpers locally, as they will need more state.
commit 1487367e21b1d14b0c99c7704684e1354e07063f
Author: Andy Wingo <address@hidden>
Date: Sun Apr 13 12:21:36 2014 +0200
Avoid consing an unbound-arg marker in the evaluator
* module/ice-9/eval.scm (primitive-eval): Turns out we don't need to
cons to make the unbound-arg marker.
-----------------------------------------------------------------------
Summary of changes:
module/ice-9/eval.scm | 21 +-
module/language/cps/closure-conversion.scm | 402 ++++++++++++++--------------
2 files changed, 219 insertions(+), 204 deletions(-)
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index f95bbe9..89d17cd 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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
@@ -329,8 +329,12 @@
;; of arguments, and some rest arities; see make-fixed-closure and
;; make-rest-closure above.
- ;; A unique marker for unbound keywords.
- (define unbound-arg (list 'unbound-arg))
+ ;; A unique marker for unbound keywords. NB: There should be no
+ ;; other instance of '(unbound-arg) in this compilation unit, so
+ ;; that this marker is indeed unique. It's a hack, but it allows
+ ;; the constant to propagate to inner closures, reducing free
+ ;; variable counts all around, so it is important for perf.
+ (define unbound-arg '(unbound-arg))
;; Procedures with rest, optional, or keyword arguments, potentially with
;; multiple arities, as with case-lambda.
@@ -504,9 +508,14 @@
(let ((proc
(if (null? tail)
(make-fixed-closure eval nreq body env)
- (if (null? (cdr tail))
- (make-rest-closure eval nreq body env)
- (apply make-general-closure env body nreq tail)))))
+ (mx-bind
+ tail (rest? . tail)
+ (if (null? tail)
+ (make-rest-closure eval nreq body env)
+ (mx-bind
+ tail (nopt kw inits alt)
+ (make-general-closure env body nreq rest?
+ nopt kw inits alt)))))))
(let lp ((meta meta))
(unless (null? meta)
(set-procedure-property! proc (caar meta) (cdar meta))
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 9aeeb65..6a1127d 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -42,162 +42,19 @@
;; free := var ...
-(define (convert-free-var var self self-known? free k)
- "Convert one possibly free variable reference to a bound reference.
-
-If @var{var} is free (i.e., present in @var{free},), it is replaced
-by a closure reference via a @code{free-ref} primcall, and @var{k} is
-called with the new var. Otherwise @var{var} is bound, so @var{k} is
-called with @var{var}."
- (cond
- ((list-index (cut eq? <> var) free)
- => (lambda (free-idx)
- (match (cons self-known? free)
- ;; A reference to the one free var of a well-known function.
- ((#t _) (k self))
- ;; A reference to one of the two free vars in a well-known
- ;; function.
- ((#t _ _)
- (let-fresh (k*) (var*)
- (build-cps-term
- ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
- ($continue k* #f
- ($primcall (match free-idx (0 'car) (1 'cdr)) (self)))))))
- (_
- (let-fresh (k* kidx) (idx var*)
- (build-cps-term
- ($letk ((kidx ($kargs ('idx) (idx)
- ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
- ($continue k* #f
- ($primcall
- (cond
- ((not self-known?) 'free-ref)
- ((<= free-idx #xff)
'vector-ref/immediate)
- (else 'vector-ref))
- (self idx)))))))
- ($continue kidx #f ($const free-idx)))))))))
- (else (k var))))
-
-(define (convert-free-vars vars self self-known? free k)
- "Convert a number of possibly free references to bound references.
address@hidden is called with the bound references, and should return the
-term."
- (match vars
- (() (k '()))
- ((var . vars)
- (convert-free-var var self self-known? free
- (lambda (var)
- (convert-free-vars vars self self-known? free
- (lambda (vars)
- (k (cons var vars)))))))))
-
-(define (allocate-closure src name var label known? free body)
- "Allocate a new closure."
- (match (cons known? free)
- ((#f . _)
- (let-fresh (k*) ()
- (build-cps-term
- ($letk ((k* ($kargs (name) (var) ,body)))
- ($continue k* src
- ($closure label (length free)))))))
- ((#t)
- ;; Well-known closure with no free variables; elide the
- ;; binding entirely.
- body)
- ((#t _)
- ;; Well-known closure with one free variable; the free var is the
- ;; closure, and no new binding need be made.
- body)
- ((#t _ _)
- ;; Well-known closure with two free variables; the closure is a
- ;; pair.
- (let-fresh (kinit kfalse) (false)
- (build-cps-term
- ($letk ((kinit ($kargs (name) (var)
- ,body))
- (kfalse ($kargs ('false) (false)
- ($continue kinit src
- ($primcall 'cons (false false))))))
- ($continue kfalse src ($const #f))))))
- ;; Well-known callee with more than two free variables; the closure
- ;; is a vector.
- ((#t . _)
- (let ((nfree (length free)))
- (let-fresh (kinit klen kfalse) (false len-var)
- (build-cps-term
- ($letk ((kinit ($kargs (name) (var) ,body))
- (kfalse ($kargs ('false) (false)
- ($letk ((klen
- ($kargs ('len) (len-var)
- ($continue kinit src
- ($primcall (if (<= nfree #xff)
- 'make-vector/immediate
- 'make-vector)
- (len-var false))))))
- ($continue klen src ($const nfree))))))
- ($continue kfalse src ($const #f)))))))))
-
-(define (init-closure src var known? free
- outer-self outer-known? outer-free body)
- "Initialize the free variables @var{free} in a closure bound to
address@hidden, and continue with @var{body}. @var{outer-self} must be the
-label of the outer procedure, where the initialization will be
-performed, and @var{outer-free} is the list of free variables there."
- (match (cons known? free)
- ;; Well-known callee with no free variables; no initialization
- ;; necessary.
- ((#t) body)
- ;; Well-known callee with one free variable; no initialization
- ;; necessary.
- ((#t _) body)
- ;; Well-known callee with two free variables; do a set-car! and
- ;; set-cdr!.
- ((#t v0 v1)
- (let-fresh (kcar kcdr) ()
- (convert-free-var
- v0 outer-self outer-known? outer-free
- (lambda (v0)
- (build-cps-term
- ($letk ((kcar ($kargs () ()
- ,(convert-free-var
- v1 outer-self outer-known? outer-free
- (lambda (v1)
- (build-cps-term
- ($letk ((kcdr ($kargs () () ,body)))
- ($continue kcdr src
- ($primcall 'set-cdr! (var v1))))))))))
- ($continue kcar src
- ($primcall 'set-car! (var v0)))))))))
- ;; Otherwise residualize a sequence of vector-set! or free-set!,
- ;; depending on whether the callee is well-known or not.
- (_
- (fold (lambda (free idx body)
- (let-fresh (k) (idxvar)
- (build-cps-term
- ($letk ((k ($kargs () () ,body)))
- ,(convert-free-var
- free outer-self outer-known? outer-free
- (lambda (free)
- (build-cps-term
- ($letconst (('idx idxvar idx))
- ($continue k src
- ($primcall (cond
- ((not known?) 'free-set!)
- ((<= idx #xff) 'vector-set!/immediate)
- (else 'vector-set!))
- (var idxvar free)))))))))))
- body
- free
- (iota (length free))))))
-
(define (analyze-closures exp dfg)
"Compute the set of free variables for all $fun instances in
@var{exp}."
- (let ((free-vars (make-hash-table))
+ (let ((bound-vars (make-hash-table))
+ (free-vars (make-hash-table))
(named-funs (make-hash-table))
(well-known-vars (make-bitvector (var-counter) #t)))
(define (add-named-fun! var cont)
- (hashq-set! named-funs var cont))
+ (hashq-set! named-funs var cont)
+ (match cont
+ (($ $cont label ($ $kfun src meta self))
+ (unless (eq? var self)
+ (hashq-set! bound-vars label var)))))
(define (clear-well-known! var)
(bitvector-set! well-known-vars var #f))
(define (compute-well-known-labels)
@@ -279,7 +136,7 @@ performed, and @var{outer-free} is the list of free
variables there."
(let ((free (visit-cont exp '())))
(unless (null? free)
(error "Expected no free vars in toplevel thunk" free exp))
- (values free-vars named-funs (compute-well-known-labels)))))
+ (values bound-vars free-vars named-funs (compute-well-known-labels)))))
(define (prune-free-vars free-vars named-funs well-known var-aliases)
(define (well-known? label)
@@ -306,7 +163,7 @@ performed, and @var{outer-free} is the list of free
variables there."
;; Normally you wouldn't see duplicates in a free variable
;; list, but with aliases that is possible.
(if (memq elt list) list (cons elt list)))
- (define (filter-out-eliminated free)
+ (define (prune-free closure-label free)
(match free
(() '())
((var . free)
@@ -315,7 +172,7 @@ performed, and @var{outer-free} is the list of free
variables there."
(($ $cont label)
(cond
((bitvector-ref eliminated label)
- (filter-out-eliminated free))
+ (prune-free closure-label free))
((vector-ref label-aliases label)
=> (lambda (var)
(cond
@@ -328,19 +185,23 @@ performed, and @var{outer-free} is the list of free
variables there."
(bitvector-set! eliminated label #t)
(set! recurse? #t))
alias-stack)
- (filter-out-eliminated free))
+ (prune-free closure-label free))
(else
(lp var (cons label alias-stack))))))
+ ((eq? closure-label label)
+ ;; Eliminate self-reference.
+ (pk 'hi)
+ (prune-free closure-label free))
(else
- (adjoin var (filter-out-eliminated free)))))
- (_ (adjoin var (filter-out-eliminated free))))))))
+ (adjoin var (prune-free closure-label free)))))
+ (_ (adjoin var (prune-free closure-label free))))))))
(hash-for-each-handle
(lambda (pair)
(match pair
((label . ()) #t)
((label . free)
(let ((orig-nfree (length free))
- (free (filter-out-eliminated free)))
+ (free (prune-free label free)))
(set-cdr! pair free)
;; If we managed to eliminate one or more free variables
;; from a well-known function, it could be that we can
@@ -367,42 +228,188 @@ performed, and @var{outer-free} is the list of free
variables there."
(vector-set! var-aliases var alias))))))
named-funs)))
-(define (convert-one label fun free-vars named-funs well-known aliases)
+(define (convert-one bound label fun free-vars named-funs well-known aliases)
(define (well-known? label)
(bitvector-ref well-known label))
- ;; Load the closure for a known call. The callee may or may not be
- ;; known at all call sites.
- (define (convert-known-proc-call var label self self-known? free k)
- ;; Well-known closures with one free variable are replaced at their
- ;; use sites by uses of the one free variable. The use sites of a
- ;; well-known closures are only in well-known proc calls, and in
- ;; free lists of other closures. Here we handle the call case; the
- ;; free list case is handled by prune-free-vars.
- (define (rename var)
- (let ((var* (vector-ref aliases var)))
- (if var*
- (rename var*)
- var)))
- (match (cons (well-known? label)
- (hashq-ref free-vars label))
- ((#t)
- ;; Calling a well-known procedure with no free variables; pass #f
- ;; as the closure.
- (let-fresh (k*) (v*)
- (build-cps-term
- ($letk ((k* ($kargs (v*) (v*) ,(k v*))))
- ($continue k* #f ($const #f))))))
- ((#t _)
- ;; Calling a well-known procedure with one free variable; pass
- ;; the free variable as the closure.
- (convert-free-var (rename var) self self-known? free k))
- (_
- (convert-free-var var self self-known? free k))))
-
(let ((free (hashq-ref free-vars label))
(self-known? (well-known? label))
(self (match fun (($ $kfun _ _ self) self))))
+ (define (convert-free-var var k)
+ "Convert one possibly free variable reference to a bound reference.
+
+If @var{var} is free, it is replaced by a closure reference via a
address@hidden primcall, and @var{k} is called with the new var.
+Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
+ (cond
+ ((list-index (cut eq? <> var) free)
+ => (lambda (free-idx)
+ (match (cons self-known? free)
+ ;; A reference to the one free var of a well-known function.
+ ((#t _) (k self))
+ ;; A reference to one of the two free vars in a well-known
+ ;; function.
+ ((#t _ _)
+ (let-fresh (k*) (var*)
+ (build-cps-term
+ ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
+ ($continue k* #f
+ ($primcall (match free-idx (0 'car) (1 'cdr))
(self)))))))
+ (_
+ (let-fresh (k* kidx) (idx var*)
+ (build-cps-term
+ ($letk ((kidx ($kargs ('idx) (idx)
+ ($letk ((k* ($kargs (var*) (var*) ,(k
var*))))
+ ($continue k* #f
+ ($primcall
+ (cond
+ ((not self-known?) 'free-ref)
+ ((<= free-idx #xff)
'vector-ref/immediate)
+ (else 'vector-ref))
+ (self idx)))))))
+ ($continue kidx #f ($const free-idx)))))))))
+ ((eq? var bound) (k self))
+ (else (k var))))
+
+ (define (convert-free-vars vars k)
+ "Convert a number of possibly free references to bound references.
address@hidden is called with the bound references, and should return the
+term."
+ (match vars
+ (() (k '()))
+ ((var . vars)
+ (convert-free-var var
+ (lambda (var)
+ (convert-free-vars vars
+ (lambda (vars)
+ (k (cons var vars)))))))))
+
+ (define (allocate-closure src name var label known? free body)
+ "Allocate a new closure."
+ (match (cons known? free)
+ ((#f . _)
+ (let-fresh (k*) ()
+ (build-cps-term
+ ($letk ((k* ($kargs (name) (var) ,body)))
+ ($continue k* src
+ ($closure label (length free)))))))
+ ((#t)
+ ;; Well-known closure with no free variables; elide the
+ ;; binding entirely.
+ body)
+ ((#t _)
+ ;; Well-known closure with one free variable; the free var is the
+ ;; closure, and no new binding need be made.
+ body)
+ ((#t _ _)
+ ;; Well-known closure with two free variables; the closure is a
+ ;; pair.
+ (let-fresh (kinit kfalse) (false)
+ (build-cps-term
+ ($letk ((kinit ($kargs (name) (var)
+ ,body))
+ (kfalse ($kargs ('false) (false)
+ ($continue kinit src
+ ($primcall 'cons (false false))))))
+ ($continue kfalse src ($const #f))))))
+ ;; Well-known callee with more than two free variables; the closure
+ ;; is a vector.
+ ((#t . _)
+ (let ((nfree (length free)))
+ (let-fresh (kinit klen kfalse) (false len-var)
+ (build-cps-term
+ ($letk ((kinit ($kargs (name) (var) ,body))
+ (kfalse
+ ($kargs ('false) (false)
+ ($letk ((klen
+ ($kargs ('len) (len-var)
+ ($continue kinit src
+ ($primcall (if (<= nfree #xff)
+ 'make-vector/immediate
+ 'make-vector)
+ (len-var false))))))
+ ($continue klen src ($const nfree))))))
+ ($continue kfalse src ($const #f)))))))))
+
+ (define (init-closure src var known? closure-free body)
+ "Initialize the free variables @var{closure-free} in a closure
+bound to @var{var}, and continue with @var{body}."
+ (match (cons known? closure-free)
+ ;; Well-known callee with no free variables; no initialization
+ ;; necessary.
+ ((#t) body)
+ ;; Well-known callee with one free variable; no initialization
+ ;; necessary.
+ ((#t _) body)
+ ;; Well-known callee with two free variables; do a set-car! and
+ ;; set-cdr!.
+ ((#t v0 v1)
+ (let-fresh (kcar kcdr) ()
+ (convert-free-var
+ v0
+ (lambda (v0)
+ (build-cps-term
+ ($letk ((kcar ($kargs () ()
+ ,(convert-free-var
+ v1
+ (lambda (v1)
+ (build-cps-term
+ ($letk ((kcdr ($kargs () () ,body)))
+ ($continue kcdr src
+ ($primcall 'set-cdr! (var
v1))))))))))
+ ($continue kcar src
+ ($primcall 'set-car! (var v0)))))))))
+ ;; Otherwise residualize a sequence of vector-set! or free-set!,
+ ;; depending on whether the callee is well-known or not.
+ (_
+ (fold (lambda (free idx body)
+ (let-fresh (k) (idxvar)
+ (build-cps-term
+ ($letk ((k ($kargs () () ,body)))
+ ,(convert-free-var
+ free
+ (lambda (free)
+ (build-cps-term
+ ($letconst (('idx idxvar idx))
+ ($continue k src
+ ($primcall (cond
+ ((not known?) 'free-set!)
+ ((<= idx #xff)
'vector-set!/immediate)
+ (else 'vector-set!))
+ (var idxvar free)))))))))))
+ body
+ closure-free
+ (iota (length closure-free))))))
+
+ ;; Load the closure for a known call. The callee may or may not be
+ ;; known at all call sites.
+ (define (convert-known-proc-call var label self self-known? free k)
+ ;; Well-known closures with one free variable are replaced at their
+ ;; use sites by uses of the one free variable. The use sites of a
+ ;; well-known closures are only in well-known proc calls, and in
+ ;; free lists of other closures. Here we handle the call case; the
+ ;; free list case is handled by prune-free-vars.
+ (define (rename var)
+ (let ((var* (vector-ref aliases var)))
+ (if var*
+ (rename var*)
+ var)))
+ (match (cons (well-known? label)
+ (hashq-ref free-vars label))
+ ((#t)
+ ;; Calling a well-known procedure with no free variables; pass #f
+ ;; as the closure.
+ (let-fresh (k*) (v*)
+ (build-cps-term
+ ($letk ((k* ($kargs (v*) (v*) ,(k v*))))
+ ($continue k* #f ($const #f))))))
+ ((#t _)
+ ;; Calling a well-known procedure with one free variable; pass
+ ;; the free variable as the closure.
+ (convert-free-var (rename var) k))
+ (_
+ (convert-free-var var k))))
+
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body))
@@ -437,8 +444,7 @@ performed, and @var{outer-free} is the list of free
variables there."
src name var kfun (well-known? kfun) fun-free
(bindings body)))
(init-closure
- src var
- (well-known? kfun) fun-free self self-known? free
+ src var (well-known? kfun) fun-free
body)))))))
(($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
@@ -465,8 +471,7 @@ performed, and @var{outer-free} is the list of free
variables there."
(allocate-closure
src #f var kfun (well-known? kfun) fun-free
(init-closure
- src var
- (well-known? kfun) fun-free self self-known? free
+ src var (well-known? kfun) fun-free
(build-cps-term ($continue k src ($values (var)))))))))))
(($ $continue k src ($ $call proc args))
@@ -475,13 +480,13 @@ performed, and @var{outer-free} is the list of free
variables there."
(convert-known-proc-call
proc kfun self self-known? free
(lambda (proc)
- (convert-free-vars args self self-known? free
+ (convert-free-vars args
(lambda (args)
(build-cps-term
($continue k src
($callk kfun proc args))))))))
(#f
- (convert-free-vars (cons proc args) self self-known? free
+ (convert-free-vars (cons proc args)
(match-lambda
((proc . args)
(build-cps-term
@@ -489,19 +494,19 @@ performed, and @var{outer-free} is the list of free
variables there."
($call proc args)))))))))
(($ $continue k src ($ $primcall name args))
- (convert-free-vars args self self-known? free
+ (convert-free-vars args
(lambda (args)
(build-cps-term
($continue k src ($primcall name args))))))
(($ $continue k src ($ $values args))
- (convert-free-vars args self self-known? free
+ (convert-free-vars args
(lambda (args)
(build-cps-term
($continue k src ($values args))))))
(($ $continue k src ($ $prompt escape? tag handler))
- (convert-free-var tag self self-known? free
+ (convert-free-var tag
(lambda (tag)
(build-cps-term
($continue k src
@@ -514,13 +519,14 @@ and allocate and initialize flat closures."
(let ((dfg (compute-dfg fun)))
(with-fresh-name-state-from-dfg dfg
(call-with-values (lambda () (analyze-closures fun dfg))
- (lambda (free-vars named-funs well-known)
+ (lambda (bound-vars free-vars named-funs well-known)
(let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <))
(aliases (make-vector (var-counter) #f)))
(prune-free-vars free-vars named-funs well-known aliases)
(build-cps-term
($program
,(map (lambda (label)
- (convert-one label (lookup-cont label dfg)
+ (convert-one (hashq-ref bound-vars label) label
+ (lookup-cont label dfg)
free-vars named-funs well-known aliases))
labels)))))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-916-gd0d8a55,
Andy Wingo <=