[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: Implement "Fixing Letrec (reloaded)"
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/02: Implement "Fixing Letrec (reloaded)" |
|
Date: |
Tue, 13 Aug 2019 06:54:56 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 615430874f9f229556010c80d605e07115bdb6f4
Author: Andy Wingo <address@hidden>
Date: Sun Aug 11 11:30:05 2019 +0200
Implement "Fixing Letrec (reloaded)"
* module/language/tree-il/fix-letrec.scm: Update algorithm to use
approach from "Fixing Letrec (reloaded)", which sorts mutually
recursive bindings by using Tarjan's algorithm to partition the
bindings into strongly-connected components. The result is that users
can use letrec* or internal definitions and get a result that is as
efficient as manual placement of let / letrec.
---
module/language/tree-il/fix-letrec.scm | 486 ++++++++++++++++-----------------
1 file changed, 229 insertions(+), 257 deletions(-)
diff --git a/module/language/tree-il/fix-letrec.scm
b/module/language/tree-il/fix-letrec.scm
index 5d6ad91..55d6705 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms
-;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2016 Free Software Foundation,
Inc.
+;; Copyright (C) 2009-2013,2016,2019 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -20,175 +20,38 @@
#:use-module (system base syntax)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (ice-9 match)
#:use-module (language tree-il)
#:use-module (language tree-il effects)
+ #:use-module (language cps graphs)
+ #:use-module (language cps intmap)
+ #:use-module (language cps intset)
#: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.
+;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig, as well as
+;; "Fixing Letrec (reloaded)", by Abdulaziz Ghuloum and R. Kent Dybvig.
-(define fix-fold
- (make-tree-il-folder unref ref set simple lambda complex))
-
-(define (simple-expression? x bound-vars simple-primcall?)
- (record-case x
- ((<void>) #t)
- ((<const>) #t)
- ((<lexical-ref> gensym)
- (not (memq gensym bound-vars)))
- ((<conditional> test consequent alternate)
- (and (simple-expression? test bound-vars simple-primcall?)
- (simple-expression? consequent bound-vars simple-primcall?)
- (simple-expression? alternate bound-vars simple-primcall?)))
- ((<seq> head tail)
- (and (simple-expression? head bound-vars simple-primcall?)
- (simple-expression? tail bound-vars simple-primcall?)))
- ((<primcall> name args)
- (and (simple-primcall? x)
- (and-map (lambda (x)
- (simple-expression? x bound-vars simple-primcall?))
- 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> gensyms)
- (values (append gensyms unref)
- ref
- set
- simple
- lambda*
- complex))
- ((<let> gensyms)
- (values (append gensyms 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> in-order? (orig-gensyms gensyms) vals)
- (define compute-effects
- (make-effects-analyzer (lambda (x) (memq x set))))
- (define (effect-free-primcall? x)
- (let ((effects (compute-effects x)))
- (effect-free?
- (exclude-effects effects (logior &allocation
- &type-check)))))
- (define (effect+exception-free-primcall? x)
- (let ((effects (compute-effects x)))
- (effect-free?
- (exclude-effects effects &allocation))))
- (let lp ((gensyms orig-gensyms) (vals vals)
- (s '()) (l '()) (c '()))
- (cond
- ((null? gensyms)
- ;; Unreferenced complex vars are still
- ;; complex for letrec*. We need to update
- ;; our algorithm to "Fixing letrec reloaded"
- ;; to fix this.
- (values (if in-order?
- (lset-difference eq? unref c)
- unref)
- ref
- set
- (append s simple)
- (append l lambda*)
- (append c complex)))
- ((memq (car gensyms) unref)
- ;; See above note about unref and letrec*.
- (if (and in-order?
- (not (lambda? (car vals)))
- (not (simple-expression?
- (car vals) orig-gensyms
- effect+exception-free-primcall?)))
- (lp (cdr gensyms) (cdr vals)
- s l (cons (car gensyms) c))
- (lp (cdr gensyms) (cdr vals)
- s l c)))
- ((memq (car gensyms) set)
- (lp (cdr gensyms) (cdr vals)
- s l (cons (car gensyms) c)))
- ((lambda? (car vals))
- (lp (cdr gensyms) (cdr vals)
- s (cons (car gensyms) l) c))
- ((simple-expression?
- (car vals) orig-gensyms
- (if in-order?
- effect+exception-free-primcall?
- effect-free-primcall?))
- ;; For letrec*, we can't consider e.g. `car' to be
- ;; "simple", as it could raise an exception. Hence
- ;; effect+exception-free-primitive? above.
- (lp (cdr gensyms) (cdr vals)
- (cons (car gensyms) s) l c))
- (else
- (lp (cdr gensyms) (cdr vals)
- s l (cons (car gensyms) c))))))
- ((<let> (orig-gensyms gensyms) vals)
- ;; The point is to compile let-bound lambdas as
- ;; efficiently as we do letrec-bound lambdas, so
- ;; we use the same algorithm for analyzing the
- ;; gensyms. There is no problem recursing into the
- ;; bindings after the let, because all variables
- ;; have been renamed.
- (let lp ((gensyms orig-gensyms) (vals vals)
- (s '()) (l '()) (c '()))
- (cond
- ((null? gensyms)
- (values unref
- ref
- set
- (append s simple)
- (append l lambda*)
- (append c complex)))
- ((memq (car gensyms) unref)
- (lp (cdr gensyms) (cdr vals)
- s l c))
- ((memq (car gensyms) set)
- (lp (cdr gensyms) (cdr vals)
- s l (cons (car gensyms) c)))
- ((and (lambda? (car vals))
- (not (memq (car gensyms) set)))
- (lp (cdr gensyms) (cdr vals)
- s (cons (car gensyms) l) c))
- ;; There is no difference between simple and
- ;; complex, for the purposes of let. Just lump
- ;; them all into complex.
- (else
- (lp (cdr gensyms) (cdr vals)
- s l (cons (car gensyms) c))))))
- (else
- (values unref ref set simple lambda* complex))))
- '()
- '()
- '()
- '()
- '()
- '())))
- (values unref simple lambda* complex)))
+(define fix-fold (make-tree-il-folder))
+(define (analyze-lexicals x)
+ (define referenced (make-hash-table))
+ (define assigned (make-hash-table))
+ ;; Functional hash sets would be nice.
+ (fix-fold x
+ (lambda (x)
+ (record-case x
+ ((<lexical-ref> gensym)
+ (hashq-set! referenced gensym #t)
+ (values))
+ ((<lexical-set> gensym)
+ (hashq-set! assigned gensym #t)
+ (values))
+ (else
+ (values))))
+ (lambda (x)
+ (values)))
+ (values referenced assigned))
(define (make-seq* src head tail)
(record-case head
@@ -198,20 +61,201 @@
((<void>) tail)
(else (make-seq src head tail))))
-(define (list->seq* loc exps)
- (if (null? (cdr exps))
- (car exps)
- (let lp ((exps (cdr exps)) (effects (list (car exps))))
- (if (null? (cdr exps))
- (make-seq* loc
- (fold (lambda (exp tail) (make-seq* #f exp tail))
- (car effects)
- (cdr effects))
- (car exps))
- (lp (cdr exps) (cons (car exps) effects))))))
+(define (free-variables expr cache)
+ (define (adjoin elt set)
+ (lset-adjoin eq? set elt))
+ (define (union set1 set2)
+ (lset-union eq? set1 set2))
+ (define (difference set1 set2)
+ (lset-difference eq? set1 set2))
+ (define fix-fold (make-tree-il-folder))
+ (define (recurse expr)
+ (free-variables expr cache))
+ (define (recurse* exprs)
+ (fold (lambda (expr free)
+ (union (recurse expr) free))
+ '()
+ exprs))
+ (define (visit expr)
+ (match expr
+ ((or ($ <void>) ($ <const>) ($ <primitive-ref>)
+ ($ <module-ref>) ($ <toplevel-ref>))
+ '())
+ (($ <lexical-ref> src name gensym)
+ (list gensym))
+ (($ <lexical-set> src name gensym exp)
+ (adjoin gensym (recurse exp)))
+ (($ <module-set> src mod name public? exp)
+ (recurse exp))
+ (($ <toplevel-set> src name exp)
+ (recurse exp))
+ (($ <toplevel-define> src name exp)
+ (recurse exp))
+ (($ <conditional> src test consequent alternate)
+ (union (recurse test)
+ (union (recurse consequent)
+ (recurse alternate))))
+ (($ <call> src proc args)
+ (recurse* (cons proc args)))
+ (($ <primcall> src name args)
+ (recurse* args))
+ (($ <seq> src head tail)
+ (union (recurse head)
+ (recurse tail)))
+ (($ <lambda> src meta body)
+ (recurse body))
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (union (difference (union (recurse* inits)
+ (recurse body))
+ gensyms)
+ (if alternate
+ (recurse alternate)
+ '())))
+ (($ <let> src names gensyms vals body)
+ (union (recurse* vals)
+ (difference (recurse body)
+ gensyms)))
+ (($ <letrec> src in-order? names gensyms vals body)
+ (difference (union (recurse* vals)
+ (recurse body))
+ gensyms))
+ (($ <fix> src names gensyms vals body)
+ (difference (union (recurse* vals)
+ (recurse body))
+ gensyms))
+ (($ <let-values> src exp body)
+ (union (recurse exp)
+ (recurse body)))
+ (($ <prompt> src escape-only? tag body handler)
+ (union (recurse tag)
+ (union (recurse body)
+ (recurse handler))))
+ (($ <abort> src tag args tail)
+ (union (recurse tag)
+ (union (recurse* args)
+ (recurse tail))))))
+ (or (hashq-ref cache expr)
+ (let ((res (visit expr)))
+ (hashq-set! cache expr res)
+ res)))
+
+(define (enumerate elts)
+ (fold2 (lambda (x out id)
+ (values (intmap-add out id x) (1+ id)))
+ elts empty-intmap 0))
+
+(define (compute-complex id->sym id->init assigned)
+ (define compute-effects
+ (make-effects-analyzer (lambda (x) (hashq-ref assigned x))))
+ (intmap-fold
+ (lambda (id sym complex)
+ (if (or (hashq-ref assigned sym)
+ (let ((effects (compute-effects (intmap-ref id->init id))))
+ (not (constant? (exclude-effects effects &allocation)))))
+ (intset-add complex id)
+ complex))
+ id->sym empty-intset))
+
+(define (compute-sccs names syms inits in-order? fv-cache assigned)
+ (define id->name (enumerate names))
+ (define id->sym (enumerate syms))
+ (define id->init (enumerate inits))
+ (define sym->id (intmap-fold (lambda (id sym out) (acons sym id out))
+ id->sym '()))
+ (define (var-list->intset vars)
+ (fold1 (lambda (sym out)
+ (intset-add out (assq-ref sym->id sym)))
+ vars empty-intset))
+ (define (free-in-init init)
+ (var-list->intset
+ (lset-intersection eq? syms (free-variables init fv-cache))))
+ (define fv-edges
+ (fold2 (lambda (init fv i)
+ (values
+ (intmap-add fv i (free-in-init init))
+ (1+ i)))
+ inits empty-intmap 0))
+ (define order-edges
+ (if in-order?
+ (let ((complex (compute-complex id->sym id->init assigned)))
+ (intmap-fold (lambda (id sym out prev)
+ (values
+ (intmap-add out id (intset-intersect complex prev))
+ (intset-add prev id)))
+ id->sym empty-intmap empty-intset))
+ empty-intmap))
+ (define sccs
+ (reverse
+ (compute-sorted-strongly-connected-components
+ (invert-graph (intmap-union fv-edges order-edges intset-union)))))
+ (map (lambda (ids)
+ (intset-fold-right (lambda (id out)
+ (cons (list (intmap-ref id->name id)
+ (intmap-ref id->sym id)
+ (intmap-ref id->init id))
+ out))
+ ids '()))
+ sccs))
+
+(define (fix-scc src binds body fv-cache referenced assigned)
+ (match binds
+ (((name sym init))
+ ;; Case of an SCC containing just a single binding.
+ (cond
+ ((not (hashq-ref referenced sym))
+ (make-seq* src init body))
+ ((and (lambda? init) (not (hashq-ref assigned sym)))
+ (make-fix src (list name) (list sym) (list init) body))
+ ((memq sym (free-variables init fv-cache))
+ (make-let src (list name) (list sym) (list (make-const src #f))
+ (make-seq src
+ (make-lexical-set src name sym init)
+ body)))
+ (else
+ (make-let src (list name) (list sym) (list init)
+ body))))
+ (_
+ (call-with-values (lambda ()
+ (partition
+ (lambda (bind)
+ (match bind
+ ((name sym init)
+ (and (lambda? init)
+ (not (hashq-ref assigned sym))))))
+ binds))
+ (lambda (l c)
+ (define (bind-complex-vars body)
+ (if (null? c)
+ body
+ (let ((inits (map (lambda (x) (make-void #f)) c)))
+ (make-let src (map car c) (map cadr c) inits body))))
+ (define (bind-lambdas body)
+ (if (null? l)
+ body
+ (make-fix src (map car l) (map cadr l) (map caddr l) body)))
+ (define (initialize-complex body)
+ (fold-right (lambda (bind body)
+ (match bind
+ ((name sym init)
+ (make-seq src
+ (make-lexical-set src name sym init)
+ body))))
+ body c))
+ (bind-complex-vars
+ (bind-lambdas
+ (initialize-complex body))))))))
+
+(define (fix-term src in-order? names gensyms vals body
+ fv-cache referenced assigned)
+ (fold-right (lambda (binds body)
+ (fix-scc src binds body fv-cache referenced assigned))
+ body
+ (compute-sccs names gensyms vals in-order? fv-cache
+ assigned)))
(define (fix-letrec x)
- (let-values (((unref simple lambda* complex) (partition-vars x)))
+ (let-values (((referenced assigned) (analyze-lexicals x)))
+ (define fv-cache (make-hash-table))
(post-order
(lambda (x)
(record-case x
@@ -219,92 +263,20 @@
;; Sets to unreferenced variables may be replaced by their
;; expression, called for effect.
((<lexical-set> gensym exp)
- (if (memq gensym unref)
- (make-seq* #f exp (make-void #f))
- x))
+ (if (hashq-ref referenced gensym)
+ x
+ (make-seq* #f exp (make-void #f))))
((<letrec> src in-order? names gensyms vals body)
- (let ((binds (map list gensyms names vals)))
- ;; The bindings returned by this function need to appear in the
same
- ;; order that they appear in the letrec.
- (define (lookup set)
- (let lp ((binds binds))
- (cond
- ((null? binds) '())
- ((memq (caar binds) set)
- (cons (car binds) (lp (cdr binds))))
- (else (lp (cdr binds))))))
- (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)
- (list->seq*
- src
- (append
- ;; The right-hand-sides of the unreferenced
- ;; bindings, for effect.
- (map caddr u)
- (cond
- ((null? c)
- ;; No complex bindings, just emit the body.
- (list body))
- (in-order?
- ;; For letrec*, assign complex bindings in order, then the
- ;; body.
- (append
- (map (lambda (c)
- (make-lexical-set #f (cadr c) (car c)
- (caddr c)))
- c)
- (list body)))
- (else
- ;; Otherwise for plain letrec, evaluate the "complex"
- ;; bindings, in a `let' to indicate that order doesn't
- ;; matter, and bind to their variables.
- (list
- (let ((tmps (map (lambda (x)
- (module-gensym "fixlr"))
- c)))
- (make-let
- #f (map cadr c) tmps (map caddr c)
- (list->seq
- #f
- (map (lambda (x tmp)
- (make-lexical-set
- #f (cadr x) (car x)
- (make-lexical-ref #f (cadr x) tmp)))
- c tmps))))
- body))))))))))
+ (fix-term src in-order? names gensyms vals body
+ fv-cache referenced assigned))
((<let> src names gensyms vals body)
- (let ((binds (map list gensyms names vals)))
- (define (lookup set)
- (map (lambda (v) (assq v binds))
- (lset-intersection eq? gensyms set)))
- (let ((u (lookup unref))
- (l (lookup lambda*))
- (c (lookup complex)))
- (list->seq*
- src
- (append
- ;; unreferenced bindings, called for effect.
- (map caddr u)
- (list
- ;; unassigned lambdas use fix.
- (make-fix src (map cadr l) (map car l) (map caddr l)
- ;; and the "complex" bindings.
- (make-let src (map cadr c) (map car c) (map caddr c)
- body))))))))
+ ;; Apply the same algorithm to <let> that binds <lambda>
+ (if (or-map lambda? vals)
+ (fix-term src #f names gensyms vals body
+ fv-cache referenced assigned)
+ x))
(else x)))
x)))