diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/language/tree-il/fix-letrec.scm | 369 |
1 files changed, 216 insertions, 153 deletions
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index c1e399d59..f7811f95e 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-2013,2016,2019,2021,2023 Free Software Foundation, Inc. +;; Copyright (C) 2009-2013,2016,2019,2021,2023,2025 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 @@ -17,7 +17,7 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (language tree-il fix-letrec) - #:use-module (srfi srfi-1) + #:use-module ((srfi srfi-1) #:select (fold fold-right partition)) #:use-module (srfi srfi-11) #:use-module (ice-9 match) #:use-module (language tree-il) @@ -32,52 +32,85 @@ ;; 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)) -(define (analyze-lexicals x) - (define referenced (make-hash-table)) - (define assigned (make-hash-table)) - ;; Functional hash sets would be nice. - (fix-fold x - (match-lambda - (($ <lexical-ref> src name gensym) - (hashq-set! referenced gensym #t) - (values)) - (($ <lexical-set> src name gensym) - (hashq-set! assigned gensym #t) - (values)) - (_ - (values))) - (lambda (x) - (values))) - (values referenced assigned)) +(define (compute-ids expr) + "For each lexical in @var{expr}, assign it an integer identifier. +Identifiers are assigned sequentially in pre-order, which allows later +code to sort letrec* bindings by identifier value." + (define counter 0) + (define sym->id (make-hash-table)) + (define (intern! sym) + (let ((id counter)) + (set! counter (1+ id)) + (hashq-set! sym->id sym id))) + (define (for-each/0 f l) + (for-each f l) + (values)) + (define tree-il-fold/0 (make-tree-il-folder)) + (tree-il-fold/0 expr + (match-lambda + (($ <lambda-case> src req opt rest kw inits syms body alt) + (for-each/0 intern! syms)) + (($ <let> src names syms inits body) + (for-each/0 intern! syms)) + (($ <letrec> src in-order? names syms inits body) + (for-each/0 intern! syms)) + (($ <fix> src names syms inits body) + (for-each/0 intern! syms)) + (_ (values))) + (lambda (_) (values))) + (lambda (sym) + (or (hashq-ref sym->id sym) + (error "unknown binding" sym)))) + +(define (compute-referenced-and-assigned expr sym->id) + (define tree-il-fold/2 (make-tree-il-folder referenced assigned)) + (tree-il-fold/2 + expr + (lambda (expr referenced assigned) + (match expr + (($ <lexical-ref> src name gensym) + (values (intset-add referenced (sym->id gensym)) + assigned)) + (($ <lexical-set> src name gensym val) + (values referenced + (intset-add assigned (sym->id gensym)))) + (_ + (values referenced assigned)))) + (lambda (term referenced assigned) + (values referenced assigned)) + empty-intset + empty-intset)) (define (make-seq* src head tail) (match head ((or ($ <lambda>) ($ <const>) ($ <lexical-ref>) ($ <void>)) tail) (else (make-seq src head tail)))) -(define (free-variables expr cache) +(define (make-compute-free-variables sym->id) + (define (empty) + empty-intset) (define (adjoin elt set) - (lset-adjoin eq? set elt)) + (intset-add set (sym->id elt))) + (define (list->set elts) + (fold adjoin (empty) elts)) (define (union set1 set2) - (lset-union eq? set1 set2)) + (intset-union set1 set2)) (define (difference set1 set2) - (lset-difference eq? set1 set2)) - (define fix-fold (make-tree-il-folder)) + (intset-subtract set1 set2)) (define (recurse expr) - (free-variables expr cache)) + (visit expr)) (define (recurse* exprs) (fold (lambda (expr free) (union (recurse expr) free)) - '() + (empty) exprs)) (define (visit expr) (match expr ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <module-ref>) ($ <toplevel-ref>)) - '()) + (empty)) (($ <lexical-ref> src name gensym) - (list gensym)) + (adjoin gensym (empty))) (($ <lexical-set> src name gensym exp) (adjoin gensym (recurse exp))) (($ <module-set> src mod name public? exp) @@ -102,22 +135,22 @@ (($ <lambda-case> src req opt rest kw inits gensyms body alternate) (union (difference (union (recurse* inits) (recurse body)) - gensyms) + (list->set gensyms)) (if alternate (recurse alternate) - '()))) + (empty)))) (($ <let> src names gensyms vals body) (union (recurse* vals) (difference (recurse body) - gensyms))) + (list->set gensyms)))) (($ <letrec> src in-order? names gensyms vals body) (difference (union (recurse* vals) (recurse body)) - gensyms)) + (list->set gensyms))) (($ <fix> src names gensyms vals body) (difference (union (recurse* vals) (recurse body)) - gensyms)) + (list->set gensyms))) (($ <let-values> src exp body) (union (recurse exp) (recurse body))) @@ -129,55 +162,68 @@ (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 cache (make-hash-table)) + (lambda (expr) + (or (hashq-ref cache expr) + (let ((res (visit expr))) + (hashq-set! cache expr res) + res)))) -(define (compute-complex id->sym id->init assigned) +(define (compute-complex expr assigned sym->id) + (define (assigned? id) + (intset-ref assigned id)) + (define (assigned-sym? sym) + (assigned? (sym->id sym))) (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)) + (make-effects-analyzer assigned-sym?)) + (define (compute-complex-bindings syms inits complex) + (fold (lambda (sym init complex) + (let ((id (sym->id sym))) + (if (or (assigned? id) + (let ((effects (compute-effects init))) + (not (constant? + (exclude-effects effects &allocation))))) + (intset-add complex id) + complex))) + complex syms inits)) + (define tree-il-fold/1 (make-tree-il-folder complex)) + (tree-il-fold/1 + expr + (lambda (expr complex) complex) + (lambda (expr complex) + ;; Complex variables are bound by let or letrec. + (match expr + (($ <letrec> src in-order? names syms inits body) + (compute-complex-bindings syms inits complex)) + (($ <let> src names syms inits body) + (compute-complex-bindings syms inits complex)) + (_ + complex))) + 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 (compute-sccs names syms inits in-order? + sym->id complex compute-free-variables) + (define nodes + (fold (lambda (name sym init nodes) + (intmap-add nodes (sym->id sym) (list name sym init))) + empty-intmap names syms inits)) + (define node-ids (intmap-keys nodes)) (define fv-edges - (fold2 (lambda (init fv i) - (values - (intmap-add fv i (free-in-init init)) - (1+ i))) - inits empty-intmap 0)) + (intmap-fold (lambda (id node edges) + (match node + ((name sym init) + (let ((fv (compute-free-variables init))) + (intmap-add edges id + (intset-intersect node-ids fv)))))) + nodes empty-intmap)) (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)) + ;; Rely on identifier ordering. + (intset-fold (lambda (id out prev) + (values + (intmap-add out id (intset-intersect complex prev)) + (intset-add prev id))) + node-ids empty-intmap empty-intset) empty-intmap)) (define sccs (reverse @@ -185,23 +231,20 @@ (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)) + (cons (intmap-ref nodes id) out)) ids '())) sccs)) -(define (fix-scc src binds body fv-cache referenced assigned) +(define (fix-scc src binds body unreferenced? unassigned? recursive?) (match binds (((name sym init)) ;; Case of an SCC containing just a single binding. (cond - ((not (hashq-ref referenced sym)) + ((unreferenced? sym) (make-seq* src init body)) - ((and (lambda? init) (not (hashq-ref assigned sym))) + ((and (lambda? init) (unassigned? sym)) (make-fix src (list name) (list sym) (list init) body)) - ((memq sym (free-variables init fv-cache)) + ((recursive? init sym) (make-let src (list name) (list sym) (list (make-void src)) (make-seq src (make-lexical-set src name sym init) @@ -215,19 +258,20 @@ (lambda (bind) (match bind ((name sym init) - (and (lambda? init) - (not (hashq-ref assigned sym)))))) + (and (lambda? init) (unassigned? 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)))) + (match c + (() body) + (((names syms inits) ...) + (let ((inits (map (lambda (x) (make-void #f)) inits))) + (make-let src names syms inits body))))) (define (bind-lambdas body) - (if (null? l) - body - (make-fix src (map car l) (map cadr l) (map caddr l) body))) + (match l + (() body) + (((names syms inits) ...) + (make-fix src names syms inits body)))) (define (initialize-complex body) (fold-right (lambda (bind body) (match bind @@ -241,74 +285,93 @@ (initialize-complex body)))))))) (define (fix-term src in-order? names gensyms vals body - fv-cache referenced assigned) + sym->id referenced assigned complex + compute-free-variables) + (define (unreferenced? sym) + (not (intset-ref referenced (sym->id sym)))) + (define (unassigned? sym) + (not (intset-ref assigned (sym->id sym)))) + (define (recursive? expr sym) + (intset-ref (compute-free-variables expr) (sym->id sym))) (fold-right (lambda (binds body) - (fix-scc src binds body fv-cache referenced assigned)) + (fix-scc src binds body + unreferenced? unassigned? recursive?)) body - (compute-sccs names gensyms vals in-order? fv-cache - assigned))) + (compute-sccs names gensyms vals in-order? + sym->id complex compute-free-variables))) ;; For letrec*, try to minimize false dependencies introduced by ;; ordering. -(define (reorder-bindings bindings) - (define (possibly-references? expr bindings) - (let visit ((expr expr)) - (match expr - ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <module-ref>)) #f) - (($ <lexical-ref> _ name var) - (or-map (match-lambda (#(name var' val) (eq? var' var))) - bindings)) - (($ <seq> _ head tail) - (or (visit head) (visit tail))) - (($ <primcall> _ name args) (or-map visit args)) - (($ <conditional> _ test consequent alternate) - (or (visit test) (visit consequent) (visit alternate))) - (_ #t)))) - (let visit ((bindings bindings) (sunk-lambdas '()) (sunk-exprs '())) +(define (reorder-bindings bindings sym->id compute-free-variables) + (define (possibly-references? expr remaining-ids) + (not (eq? empty-intset + (intset-intersect (compute-free-variables expr) + remaining-ids)))) + (define (binding-ids bindings) + (fold (lambda (binding ids) + (match binding + (#(name sym val) (intset-add ids (sym->id sym))))) + empty-intset bindings)) + (let visit ((bindings bindings) (remaining-ids (binding-ids bindings)) + (sunk-lambdas '()) (sunk-exprs '())) (match bindings (() (append sunk-lambdas (reverse sunk-exprs))) ((binding . bindings) (match binding - (#(_ _ ($ <lambda>)) - (visit bindings (cons binding sunk-lambdas) sunk-exprs)) - (#(_ _ expr) - (cond - ((possibly-references? expr bindings) - ;; Init expression might refer to later bindings. - ;; Serialize. - (append sunk-lambdas (reverse sunk-exprs) - (cons binding (visit bindings '() '())))) - (else - (visit bindings sunk-lambdas (cons binding sunk-exprs)))))))))) + (#(_ sym expr) + (let ((remaining-ids (intset-remove remaining-ids (sym->id sym)))) + (cond + ((lambda? expr) + (visit bindings remaining-ids + (cons binding sunk-lambdas) sunk-exprs)) + ((possibly-references? expr remaining-ids) + ;; Init expression might refer to later bindings. + ;; Serialize. + (append sunk-lambdas (reverse sunk-exprs) + (cons binding (visit bindings remaining-ids '() '())))) + (else + (visit bindings remaining-ids + sunk-lambdas (cons binding sunk-exprs))))))))))) (define (fix-letrec x) - (let-values (((referenced assigned) (analyze-lexicals x))) - (define fv-cache (make-hash-table)) - (post-order - (lambda (x) - (match x - ;; Sets to unreferenced variables may be replaced by their - ;; expression, called for effect. - (($ <lexical-set> src name gensym exp) - (if (hashq-ref referenced gensym) - x - (make-seq* #f exp (make-void #f)))) - - (($ <letrec> src in-order? names gensyms vals body) - (if in-order? - (match (reorder-bindings (map vector names gensyms vals)) - ((#(names gensyms vals) ...) - (fix-term src #t names gensyms vals body - fv-cache referenced assigned))) - (fix-term src #f names gensyms vals body - fv-cache referenced assigned))) + (define sym->id + (compute-ids x)) + (define-values (referenced assigned) + (compute-referenced-and-assigned x sym->id)) + (define complex + (compute-complex x assigned sym->id)) + (define compute-free-variables + (make-compute-free-variables sym->id)) + (define (unreferenced? sym) + (not (intset-ref referenced (sym->id sym)))) + + (post-order + (lambda (x) + (match x + ;; Sets to unreferenced variables may be replaced by their + ;; expression, called for effect. + (($ <lexical-set> src name (? unreferenced?) exp) + (make-seq* #f exp (make-void #f))) + + (($ <letrec> src in-order? names gensyms vals body) + (if in-order? + (match (reorder-bindings (map vector names gensyms vals) + sym->id compute-free-variables) + ((#(names gensyms vals) ...) + (fix-term src #t names gensyms vals body + sym->id referenced assigned complex + compute-free-variables))) + (fix-term src #f names gensyms vals body + sym->id referenced assigned complex + compute-free-variables))) + + (($ <let> src names gensyms vals body) + ;; Apply the same algorithm to <let> that binds <lambda> + (if (or-map lambda? vals) + (fix-term src #f names gensyms vals body + sym->id referenced assigned complex + compute-free-variables) + x)) - (($ <let> src names gensyms vals 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)) - - (_ x))) - x))) + (_ x))) + x)) |