diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index 5d6ad91f6..55d67054f 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 - (() #t) - (() #t) - (( gensym) - (not (memq gensym bound-vars))) - (( 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?))) - (( head tail) - (and (simple-expression? head bound-vars simple-primcall?) - (simple-expression? tail bound-vars simple-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 - (( gensym) - (values (delq gensym unref) - (lset-adjoin eq? ref gensym) - set - simple - lambda* - complex)) - (( gensym) - (values unref - ref - (lset-adjoin eq? set gensym) - simple - lambda* - complex)) - (( gensyms) - (values (append gensyms unref) - ref - set - simple - lambda* - complex)) - (( 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 - (( 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)))))) - (( (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 + (( gensym) + (hashq-set! referenced gensym #t) + (values)) + (( 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 @@ (() 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 ($ ) ($ ) ($ ) + ($ ) ($ )) + '()) + (($ src name gensym) + (list gensym)) + (($ src name gensym exp) + (adjoin gensym (recurse exp))) + (($ src mod name public? exp) + (recurse exp)) + (($ src name exp) + (recurse exp)) + (($ src name exp) + (recurse exp)) + (($ src test consequent alternate) + (union (recurse test) + (union (recurse consequent) + (recurse alternate)))) + (($ src proc args) + (recurse* (cons proc args))) + (($ src name args) + (recurse* args)) + (($ src head tail) + (union (recurse head) + (recurse tail))) + (($ src meta body) + (recurse body)) + (($ src req opt rest kw inits gensyms body alternate) + (union (difference (union (recurse* inits) + (recurse body)) + gensyms) + (if alternate + (recurse alternate) + '()))) + (($ src names gensyms vals body) + (union (recurse* vals) + (difference (recurse body) + gensyms))) + (($ src in-order? names gensyms vals body) + (difference (union (recurse* vals) + (recurse body)) + gensyms)) + (($ src names gensyms vals body) + (difference (union (recurse* vals) + (recurse body)) + gensyms)) + (($ src exp body) + (union (recurse exp) + (recurse body))) + (($ src escape-only? tag body handler) + (union (recurse tag) + (union (recurse body) + (recurse handler)))) + (($ 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. (( 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)))) (( 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)) (( 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 that binds + (if (or-map lambda? vals) + (fix-term src #f names gensyms vals body + fv-cache referenced assigned) + x)) (else x))) x)))