mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Implement "Fixing Letrec (reloaded)"

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2019-08-11 11:30:05 +02:00
parent bba4ce222d
commit 615430874f
1 changed files with 229 additions and 257 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms ;;; 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 ;;;; 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,175 +20,38 @@
#:use-module (system base syntax) #:use-module (system base syntax)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (ice-9 match)
#:use-module (language tree-il) #:use-module (language tree-il)
#:use-module (language tree-il effects) #:use-module (language tree-il effects)
#:use-module (language cps graphs)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (fix-letrec)) #:export (fix-letrec))
;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet ;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
;; Efficient Implementation of Scheme's Recursive Binding Construct", by ;; 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 (define fix-fold (make-tree-il-folder))
(make-tree-il-folder unref ref set simple lambda complex)) (define (analyze-lexicals x)
(define referenced (make-hash-table))
(define (simple-expression? x bound-vars simple-primcall?) (define assigned (make-hash-table))
(record-case x ;; Functional hash sets would be nice.
((<void>) #t) (fix-fold x
((<const>) #t) (lambda (x)
((<lexical-ref> gensym) (record-case x
(not (memq gensym bound-vars))) ((<lexical-ref> gensym)
((<conditional> test consequent alternate) (hashq-set! referenced gensym #t)
(and (simple-expression? test bound-vars simple-primcall?) (values))
(simple-expression? consequent bound-vars simple-primcall?) ((<lexical-set> gensym)
(simple-expression? alternate bound-vars simple-primcall?))) (hashq-set! assigned gensym #t)
((<seq> head tail) (values))
(and (simple-expression? head bound-vars simple-primcall?) (else
(simple-expression? tail bound-vars simple-primcall?))) (values))))
((<primcall> name args) (lambda (x)
(and (simple-primcall? x) (values)))
(and-map (lambda (x) (values referenced assigned))
(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 (make-seq* src head tail) (define (make-seq* src head tail)
(record-case head (record-case head
@ -198,20 +61,201 @@
((<void>) tail) ((<void>) tail)
(else (make-seq src head tail)))) (else (make-seq src head tail))))
(define (list->seq* loc exps) (define (free-variables expr cache)
(if (null? (cdr exps)) (define (adjoin elt set)
(car exps) (lset-adjoin eq? set elt))
(let lp ((exps (cdr exps)) (effects (list (car exps)))) (define (union set1 set2)
(if (null? (cdr exps)) (lset-union eq? set1 set2))
(make-seq* loc (define (difference set1 set2)
(fold (lambda (exp tail) (make-seq* #f exp tail)) (lset-difference eq? set1 set2))
(car effects) (define fix-fold (make-tree-il-folder))
(cdr effects)) (define (recurse expr)
(car exps)) (free-variables expr cache))
(lp (cdr exps) (cons (car exps) effects)))))) (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) (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 (post-order
(lambda (x) (lambda (x)
(record-case x (record-case x
@ -219,92 +263,20 @@
;; Sets to unreferenced variables may be replaced by their ;; Sets to unreferenced variables may be replaced by their
;; expression, called for effect. ;; expression, called for effect.
((<lexical-set> gensym exp) ((<lexical-set> gensym exp)
(if (memq gensym unref) (if (hashq-ref referenced gensym)
(make-seq* #f exp (make-void #f)) x
x)) (make-seq* #f exp (make-void #f))))
((<letrec> src in-order? names gensyms vals body) ((<letrec> src in-order? names gensyms vals body)
(let ((binds (map list gensyms names vals))) (fix-term src in-order? names gensyms vals body
;; The bindings returned by this function need to appear in the same fv-cache referenced assigned))
;; 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))))))))))
((<let> src names gensyms vals body) ((<let> src names gensyms vals body)
(let ((binds (map list gensyms names vals))) ;; Apply the same algorithm to <let> that binds <lambda>
(define (lookup set) (if (or-map lambda? vals)
(map (lambda (v) (assq v binds)) (fix-term src #f names gensyms vals body
(lset-intersection eq? gensyms set))) fv-cache referenced assigned)
(let ((u (lookup unref)) x))
(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))))))))
(else x))) (else x)))
x))) x)))