[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-912-g32e62c2
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-912-g32e62c2 |
|
Date: |
Sun, 13 Apr 2014 10:06:54 +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=32e62c2daefb67e9e2ccd90069eb9322de97e95b
The branch, master has been updated
via 32e62c2daefb67e9e2ccd90069eb9322de97e95b (commit)
via cd130361b81414491104c13c91a1229de6f8ecef (commit)
via a2acec7c7f075bd12b690e4c42461e1a9bca7abf (commit)
via 6dc886faf1da4a2f263118fd6d397e8d611bed70 (commit)
from 983413a1d9164501cd6c76aa10bf7e7f5b5c3319 (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 32e62c2daefb67e9e2ccd90069eb9322de97e95b
Author: Andy Wingo <address@hidden>
Date: Sun Apr 13 11:47:17 2014 +0200
Optimize closures with one free variable
* module/language/cps/closure-conversion.scm (convert-free-var)
(allocate-closure, init-closure, prune-free-vars, convert-one)
(convert-closures): Optimize closures with one free variable.
commit cd130361b81414491104c13c91a1229de6f8ecef
Author: Andy Wingo <address@hidden>
Date: Sat Apr 12 23:31:08 2014 +0200
Well-known closures represented using pairs or vectors
* module/language/cps/closure-conversion.scm (convert-free-var):
(convert-free-vars): Take self-known? param, to do the right thing for
well-known closures.
(allocate-closure): New helper. Well-known closures are represented
using pairs or vectors.
(init-closure): Adapt tpo DTRT for well-known closures.
(prune-free-vars): Move up.
(convert-one): Adapt to new well-known closure representation.
commit a2acec7c7f075bd12b690e4c42461e1a9bca7abf
Author: Andy Wingo <address@hidden>
Date: Sat Apr 12 22:42:23 2014 +0200
Update verify-cps
* module/language/cps/verify.scm (verify-cps): Update for recent CPS
changes.
commit 6dc886faf1da4a2f263118fd6d397e8d611bed70
Author: Andy Wingo <address@hidden>
Date: Sat Apr 12 19:46:23 2014 +0200
Avoid creating closures with no free variables
* module/language/cps/closure-conversion.scm (init-closure): Return just
one value.
(analyze-closures): Rewrite the well-known set to key off the label
instead of the closure identifiers before returning.
(convert-one): Avoid creating closure objects at runtime or load-time
when "instantiating" or calling well-known closures with no free
variables.
(prune-free-vars): New pass.
(convert-closures): Adapt.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps/closure-conversion.scm | 486 +++++++++++++++++++++-------
module/language/cps/verify.scm | 21 +-
2 files changed, 376 insertions(+), 131 deletions(-)
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 3c30649..9aeeb65 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -42,7 +42,7 @@
;; free := var ...
-(define (convert-free-var var self free k)
+(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
@@ -52,59 +52,166 @@ called with @var{var}."
(cond
((list-index (cut eq? <> var) free)
=> (lambda (free-idx)
- (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 'free-ref (self idx)))))))
- ($continue kidx #f ($const 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 free k)
+(define (convert-free-vars vars self self-known? free k)
"Convert a number of possibly free references to bound references.
@var{k} is called with the bound references, and should return the
term."
(match vars
(() (k '()))
((var . vars)
- (convert-free-var var self free
+ (convert-free-var var self self-known? free
(lambda (var)
- (convert-free-vars vars self free
+ (convert-free-vars vars self self-known? free
(lambda (vars)
(k (cons var vars)))))))))
-(define (init-closure src v free outer-self outer-free body)
+(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
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."
- (fold (lambda (free idx body)
- (let-fresh (k) (idxvar)
- (build-cps-term
- ($letk ((k ($kargs () () ,body)))
- ,(convert-free-var
- free outer-self outer-free
- (lambda (free)
- (values (build-cps-term
- ($letconst (('idx idxvar idx))
- ($continue k src
- ($primcall 'free-set! (v idxvar free)))))
- '())))))))
- body
- free
- (iota (length free))))
+ (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))
(named-funs (make-hash-table))
- (well-known (make-bitvector (var-counter) #t)))
+ (well-known-vars (make-bitvector (var-counter) #t)))
(define (add-named-fun! var cont)
(hashq-set! named-funs var cont))
(define (clear-well-known! var)
- (bitvector-set! well-known var #f))
+ (bitvector-set! well-known-vars var #f))
+ (define (compute-well-known-labels)
+ (let ((bv (make-bitvector (label-counter) #f)))
+ (hash-for-each
+ (lambda (var cont)
+ (match cont
+ (($ $cont label ($ $kfun src meta self))
+ (unless (equal? var self)
+ (bitvector-set! bv label
+ (and (bitvector-ref well-known-vars var)
+ (bitvector-ref well-known-vars self)))))))
+ named-funs)
+ bv))
(define (union a b)
(lset-union eq? a b))
(define (difference a b)
@@ -118,7 +225,7 @@ performed, and @var{outer-free} is the list of free
variables there."
(let ((free (if clause
(visit-cont clause (list self))
'())))
- (hashq-set! free-vars label (cons free cont))
+ (hashq-set! free-vars label free)
(difference free bound)))
(($ $cont label ($ $kclause arity body alternate))
(let ((free (visit-cont body bound)))
@@ -172,107 +279,234 @@ 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 well-known))))
+ (values free-vars named-funs (compute-well-known-labels)))))
-(define (convert-one label free-vars named-funs well-known)
- (match (hashq-ref free-vars label)
- ((free . (and fun ($ $cont _ ($ $kfun _ _ self))))
- (define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont label ($ $kargs names vars body))
- (label ($kargs names vars ,(visit-term body))))
- (($ $cont label ($ $kfun src meta self tail clause))
- (label ($kfun src meta self ,tail
- ,(and clause (visit-cont clause)))))
- (($ $cont label ($ $kclause arity body alternate))
- (label ($kclause ,arity ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- (($ $cont) ,cont)))
- (define (visit-term term)
- (match term
- (($ $letk conts body)
- (build-cps-term
- ($letk ,(map visit-cont conts) ,(visit-term body))))
+(define (prune-free-vars free-vars named-funs well-known var-aliases)
+ (define (well-known? label)
+ (bitvector-ref well-known label))
+ (let ((eliminated (make-bitvector (label-counter) #f))
+ (label-aliases (make-vector (label-counter) #f)))
+ (let lp ((label 0))
+ (let ((label (bit-position #t well-known label)))
+ (when label
+ (match (hashq-ref free-vars label)
+ ;; Mark all well-known closures that have no free variables
+ ;; for elimination.
+ (() (bitvector-set! eliminated label #t))
+ ;; Replace well-known closures that have just one free
+ ;; variable by references to that free variable.
+ ((var)
+ (vector-set! label-aliases label var))
+ (_ #f))
+ (lp (1+ label)))))
+ ;; Iterative free variable elimination.
+ (let lp ()
+ (let ((recurse? #f))
+ (define (adjoin elt list)
+ ;; 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)
+ (match free
+ (() '())
+ ((var . free)
+ (let lp ((var var) (alias-stack '()))
+ (match (hashq-ref named-funs var)
+ (($ $cont label)
+ (cond
+ ((bitvector-ref eliminated label)
+ (filter-out-eliminated free))
+ ((vector-ref label-aliases label)
+ => (lambda (var)
+ (cond
+ ((memq label alias-stack)
+ ;; We have found a set of mutually recursive
+ ;; well-known procedures, each of which only
+ ;; closes over one of the others. Mark them
+ ;; all for elimination.
+ (for-each (lambda (label)
+ (bitvector-set! eliminated label #t)
+ (set! recurse? #t))
+ alias-stack)
+ (filter-out-eliminated free))
+ (else
+ (lp var (cons label alias-stack))))))
+ (else
+ (adjoin var (filter-out-eliminated free)))))
+ (_ (adjoin var (filter-out-eliminated free))))))))
+ (hash-for-each-handle
+ (lambda (pair)
+ (match pair
+ ((label . ()) #t)
+ ((label . free)
+ (let ((orig-nfree (length free))
+ (free (filter-out-eliminated 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
+ ;; eliminate or alias this function as well.
+ (when (and (well-known? label)
+ (< (length free) orig-nfree))
+ (match free
+ (()
+ (bitvector-set! eliminated label #t)
+ (set! recurse? #t))
+ ((var)
+ (vector-set! label-aliases label var)
+ (set! recurse? #t))
+ (_ #t)))))))
+ free-vars)
+ ;; Iterate to fixed point.
+ (when recurse? (lp))))
+ ;; Populate var-aliases from label-aliases.
+ (hash-for-each (lambda (var cont)
+ (match cont
+ (($ $cont label)
+ (let ((alias (vector-ref label-aliases label)))
+ (when alias
+ (vector-set! var-aliases var alias))))))
+ named-funs)))
- ;; Remove letrec.
- (($ $letrec names vars funs body)
- (let lp ((in (map list names vars funs))
- (bindings (lambda (body) body))
- (body (visit-term body)))
- (match in
- (() (bindings body))
- (((name var ($ $fun ()
- (and fun-body
- ($ $cont kfun ($ $kfun src))))) . in)
- (match (hashq-ref free-vars kfun)
- ((fun-free . _)
- (lp in
- (lambda (body)
- (let-fresh (k) ()
- (build-cps-term
- ($letk ((k ($kargs (name) (var) ,(bindings body))))
- ($continue k src
- ($closure kfun (length fun-free)))))))
- (init-closure src var fun-free self free body))))))))
+(define (convert-one label fun free-vars named-funs well-known aliases)
+ (define (well-known? label)
+ (bitvector-ref well-known label))
- (($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
- term)
+ ;; 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))))
- (($ $continue k src ($ $fun () ($ $cont kfun)))
- (match (hashq-ref free-vars kfun)
- ((() . _)
- (build-cps-term ($continue k src ($closure kfun 0))))
- ((fun-free . _)
- (let-fresh (kinit) (v)
- (build-cps-term
- ($letk ((kinit ($kargs (v) (v)
- ,(init-closure
- src v fun-free self free
- (build-cps-term
- ($continue k src ($values (v))))))))
- ($continue kinit src
- ($closure kfun (length fun-free)))))))))
+ (let ((free (hashq-ref free-vars label))
+ (self-known? (well-known? label))
+ (self (match fun (($ $kfun _ _ self) self))))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kargs names vars body))
+ (label ($kargs names vars ,(visit-term body))))
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail
+ ,(and clause (visit-cont clause)))))
+ (($ $cont label ($ $kclause arity body alternate))
+ (label ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (($ $cont) ,cont)))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ (build-cps-term
+ ($letk ,(map visit-cont conts) ,(visit-term body))))
- (($ $continue k src ($ $call proc args))
- (let ((def (hashq-ref named-funs proc))
- (known? (bitvector-ref well-known proc)))
- (convert-free-vars (cons proc args) self free
- (match-lambda
- ((proc . args)
- (rewrite-cps-term def
- (($ $cont label)
- ($continue k src
- ($callk label proc args)))
- (#f
- ($continue k src
- ($call proc args)))))))))
+ ;; Remove letrec.
+ (($ $letrec names vars funs body)
+ (let lp ((in (map list names vars funs))
+ (bindings (lambda (body) body))
+ (body (visit-term body)))
+ (match in
+ (() (bindings body))
+ (((name var ($ $fun ()
+ (and fun-body
+ ($ $cont kfun ($ $kfun src))))) . in)
+ (let ((fun-free (hashq-ref free-vars kfun)))
+ (lp in
+ (lambda (body)
+ (allocate-closure
+ src name var kfun (well-known? kfun) fun-free
+ (bindings body)))
+ (init-closure
+ src var
+ (well-known? kfun) fun-free self self-known? free
+ body)))))))
+
+ (($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
+ term)
- (($ $continue k src ($ $callk k* proc args))
- (convert-free-vars (cons proc args) self free
- (match-lambda
- ((proc . args)
- (build-cps-term
- ($continue k src ($callk k* proc args)))))))
+ (($ $continue k src ($ $fun () ($ $cont kfun)))
+ (let ((fun-free (hashq-ref free-vars kfun)))
+ (match (cons (well-known? kfun) fun-free)
+ ((known?)
+ (build-cps-term
+ ($continue k src ,(if known?
+ (build-cps-exp ($const #f))
+ (build-cps-exp ($closure kfun 0))))))
+ ((#t _)
+ ;; A well-known closure of one free variable is replaced
+ ;; at each use with the free variable itself, so we don't
+ ;; need a binding at all; and yet, the continuation
+ ;; expects one value, so give it something. DCE should
+ ;; clean up later.
+ (build-cps-term
+ ($continue k src ,(build-cps-exp ($const #f)))))
+ (_
+ (let-fresh () (var)
+ (allocate-closure
+ src #f var kfun (well-known? kfun) fun-free
+ (init-closure
+ src var
+ (well-known? kfun) fun-free self self-known? free
+ (build-cps-term ($continue k src ($values (var)))))))))))
- (($ $continue k src ($ $primcall name args))
- (convert-free-vars args self free
- (lambda (args)
- (build-cps-term
- ($continue k src ($primcall name args))))))
+ (($ $continue k src ($ $call proc args))
+ (match (hashq-ref named-funs proc)
+ (($ $cont kfun)
+ (convert-known-proc-call
+ proc kfun self self-known? free
+ (lambda (proc)
+ (convert-free-vars args self self-known? free
+ (lambda (args)
+ (build-cps-term
+ ($continue k src
+ ($callk kfun proc args))))))))
+ (#f
+ (convert-free-vars (cons proc args) self self-known? free
+ (match-lambda
+ ((proc . args)
+ (build-cps-term
+ ($continue k src
+ ($call proc args)))))))))
- (($ $continue k src ($ $values args))
- (convert-free-vars args self free
- (lambda (args)
- (build-cps-term
- ($continue k src ($values args))))))
+ (($ $continue k src ($ $primcall name args))
+ (convert-free-vars args self self-known? free
+ (lambda (args)
+ (build-cps-term
+ ($continue k src ($primcall name args))))))
- (($ $continue k src ($ $prompt escape? tag handler))
- (convert-free-var tag self free
- (lambda (tag)
+ (($ $continue k src ($ $values args))
+ (convert-free-vars args self self-known? free
+ (lambda (args)
(build-cps-term
- ($continue k src
- ($prompt escape? tag handler))))))))
- (visit-cont fun))))
+ ($continue k src ($values args))))))
+
+ (($ $continue k src ($ $prompt escape? tag handler))
+ (convert-free-var tag self self-known? free
+ (lambda (tag)
+ (build-cps-term
+ ($continue k src
+ ($prompt escape? tag handler))))))))
+ (visit-cont (build-cps-cont (label ,fun)))))
(define (convert-closures fun)
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
@@ -281,8 +515,12 @@ and allocate and initialize flat closures."
(with-fresh-name-state-from-dfg dfg
(call-with-values (lambda () (analyze-closures fun dfg))
(lambda (free-vars named-funs well-known)
- (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <)))
+ (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 (cut convert-one <> free-vars named-funs well-known)
+ ,(map (lambda (label)
+ (convert-one label (lookup-cont label dfg)
+ free-vars named-funs well-known aliases))
labels)))))))))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 4352f20..b965427 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -113,14 +113,12 @@
(_
(error "unexpected clause" clause))))
- (define (visit-fun fun k-env v-env)
- (match fun
- (($ $fun (free ...)
- ($ $cont kbody
- ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause)))
+ (define (visit-entry entry k-env v-env)
+ (match entry
+ (($ $cont kbody
+ ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
(when (and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta))
- (for-each (cut check-var <> v-env) free)
(check-src src)
;; Reset the continuation environment, because Guile's
;; continuations are local.
@@ -128,6 +126,13 @@
(k-env (add-labels (list ktail) '())))
(when clause
(visit-clause clause k-env v-env))))
+ (_ (error "unexpected $kfun" entry))))
+
+ (define (visit-fun fun k-env v-env)
+ (match fun
+ (($ $fun (free ...) entry)
+ (for-each (cut check-var <> v-env) free)
+ (visit-entry '() v-env))
(_
(error "unexpected $fun" fun))))
@@ -139,6 +144,8 @@
#t)
(($ $prim (? symbol? name))
#t)
+ (($ $closure kfun n)
+ #t)
(($ $fun)
(visit-fun exp k-env v-env))
(($ $call proc (arg ...))
@@ -184,5 +191,5 @@
(_
(error "unexpected term" term))))
- (visit-fun fun '() '())
+ (visit-entry fun '() '())
fun)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-912-g32e62c2,
Andy Wingo <=