diff options
author | Andy Wingo <wingo@pobox.com> | 2021-05-19 20:07:46 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2021-10-01 11:28:22 +0200 |
commit | 8fab68f8b1e50c6e429bc8053cfeeff26baae4c4 (patch) | |
tree | d128fc59fe6f0034d3aa48cdc653955ca81b0e50 | |
parent | 745b67c04aa327e3d261cf5aa5f3ff0ff6bfef5e (diff) | |
download | guile-8fab68f8b1e50c6e429bc8053cfeeff26baae4c4.tar.gz |
Move live variable computation routines to utils and graphs.
* module/language/cps/graphs.scm (rename-keys, rename-intset)
(rename-graph, compute-reverse-control-flow-order)
(compute-live-variables): Move here from slot-allocation.
* module/language/cps/utils.scm: Remove duplicate compute-idoms
definition.
(compute-defs-and-uses, compute-var-representations): Move here from
slot-allocation.
* module/language/cps/slot-allocation.scm: Move routines out to utils
and graphs.
-rw-r--r-- | module/language/cps/graphs.scm | 88 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 214 | ||||
-rw-r--r-- | module/language/cps/utils.scm | 171 |
3 files changed, 225 insertions, 248 deletions
diff --git a/module/language/cps/graphs.scm b/module/language/cps/graphs.scm index 8be36c84d..abdca76c9 100644 --- a/module/language/cps/graphs.scm +++ b/module/language/cps/graphs.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013-2015, 2017-2020 Free Software Foundation, Inc. +;; Copyright (C) 2013-2015, 2017-2021 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 @@ -23,6 +23,7 @@ ;;; Code: (define-module (language cps graphs) + #:use-module (ice-9 control) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (language cps intset) @@ -33,6 +34,7 @@ intmap-map intmap-keys invert-bijection invert-partition + rename-keys rename-intset rename-graph intset->intmap intmap-select worklist-fold @@ -43,7 +45,9 @@ compute-reverse-post-order compute-strongly-connected-components compute-sorted-strongly-connected-components - solve-flow-equations)) + compute-reverse-control-flow-order + solve-flow-equations + compute-live-variables)) (define-inlinable (fold1 f l s0) (let lp ((l l) (s0 s0)) @@ -162,6 +166,32 @@ intset of successors, return a graph SUCC->PRED...." succs (intmap-map (lambda (label _) empty-intset) succs))) +(define (rename-keys map old->new) + "Return a fresh intmap containing F(K) -> V for K and V in MAP, where +F is looking up K in the intmap OLD->NEW." + (persistent-intmap + (intmap-fold (lambda (k v out) + (intmap-add! out (intmap-ref old->new k) v)) + map + empty-intmap))) + +(define (rename-intset set old->new) + "Return a fresh intset of F(K) for K in SET, where F is looking up K +in the intmap OLD->NEW." + (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old))) + set empty-intset)) + +(define (rename-graph graph old->new) + "Return a fresh intmap containing F(K) -> intset(F(V)...) for K and +intset(V...) in GRAPH, where F is looking up K in the intmap OLD->NEW." + (persistent-intmap + (intmap-fold (lambda (pred succs out) + (intmap-add! out + (intmap-ref old->new pred) + (rename-intset succs old->new))) + graph + empty-intmap))) + (define (compute-strongly-connected-components succs start) "Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map partitioning the labels into strongly connected components (SCCs)." @@ -232,6 +262,37 @@ connected components in sorted order." (((? (lambda (id) (eqv? id start))) . ids) (map (lambda (id) (intmap-ref components id)) ids)))) +(define (compute-reverse-control-flow-order preds) + "Return a LABEL->ORDER bijection where ORDER is a contiguous set of +integers starting from 0 and incrementing in sort order. There is a +precondition that labels in PREDS are already renumbered in reverse post +order." + (define (has-back-edge? preds) + (let/ec return + (intmap-fold (lambda (label labels) + (intset-fold (lambda (pred) + (if (<= label pred) + (return #t) + (values))) + labels) + (values)) + preds) + #f)) + (if (has-back-edge? preds) + ;; This is more involved than forward control flow because not all + ;; live labels are reachable from the tail. + (persistent-intmap + (fold2 (lambda (component order n) + (intset-fold (lambda (label order n) + (values (intmap-add! order label n) + (1+ n))) + component order n)) + (reverse (compute-sorted-strongly-connected-components preds)) + empty-intmap 0)) + ;; Just reverse forward control flow. + (let ((max (intmap-prev preds))) + (intmap-map (lambda (label labels) (- max label)) preds)))) + (define (intset-pop set) (match (intset-next set) (#f (values set #f)) @@ -274,3 +335,26 @@ SUBTRACT, ADD, and MEET operates on that state." (run (intset-union worklist changed) in out))) (values (persistent-intmap in) (persistent-intmap out))))))) + +(define (compute-live-variables preds defs uses) + "Compute and return two values mapping LABEL->VAR..., where VAR... are +the definitions that are live before and after LABEL, as intsets." + (let* ((old->new (compute-reverse-control-flow-order preds)) + (init (persistent-intmap (intmap-fold + (lambda (old new init) + (intmap-add! init new empty-intset)) + old->new empty-intmap)))) + (call-with-values + (lambda () + (solve-flow-equations (rename-graph preds old->new) + init init + (rename-keys defs old->new) + (rename-keys uses old->new) + intset-subtract intset-union intset-union)) + (lambda (in out) + ;; As a reverse control-flow problem, the values flowing into a + ;; node are actually the live values after the node executes. + ;; Funny, innit? So we return them in the reverse order. + (let ((new->old (invert-bijection old->new))) + (values (rename-keys out new->old) + (rename-keys in new->old))))))) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index ff32e1ae1..253776769 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -30,6 +30,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (language cps) + #:use-module (language cps graphs) #:use-module (language cps utils) #:use-module (language cps intmap) #:use-module (language cps intset) @@ -121,94 +122,6 @@ (define (lookup-nlocals allocation) (allocation-frame-size allocation)) -(define-syntax-rule (persistent-intmap2 exp) - (call-with-values (lambda () exp) - (lambda (a b) - (values (persistent-intmap a) (persistent-intmap b))))) - -(define (compute-defs-and-uses cps) - "Return two LABEL->VAR... maps indicating values defined at and used -by a label, respectively." - (define (vars->intset vars) - (fold (lambda (var set) (intset-add set var)) empty-intset vars)) - (persistent-intmap2 - (intmap-fold - (lambda (label cont defs uses) - (define (get-defs k) - (match (intmap-ref cps k) - (($ $kargs names vars) (vars->intset vars)) - (_ empty-intset))) - (define (return d u) - (values (intmap-add! defs label d) - (intmap-add! uses label u))) - (match cont - (($ $kfun src meta self tail clause) - (return (intset-union - (if clause (get-defs clause) empty-intset) - (if self (intset self) empty-intset)) - empty-intset)) - (($ $kargs _ _ ($ $continue k src exp)) - (match exp - ((or ($ $const) ($ $const-fun) ($ $code)) - (return (get-defs k) empty-intset)) - (($ $call proc args) - (return (get-defs k) (intset-add (vars->intset args) proc))) - (($ $callk _ proc args) - (let ((args (vars->intset args))) - (return (get-defs k) (if proc (intset-add args proc) args)))) - (($ $primcall name param args) - (return (get-defs k) (vars->intset args))) - (($ $values args) - (return (get-defs k) (vars->intset args))))) - (($ $kargs _ _ ($ $branch kf kt src op param args)) - (return empty-intset (vars->intset args))) - (($ $kargs _ _ ($ $switch kf kt* src arg)) - (return empty-intset (intset arg))) - (($ $kargs _ _ ($ $prompt k kh src escape? tag)) - (return empty-intset (intset tag))) - (($ $kargs _ _ ($ $throw src op param args)) - (return empty-intset (vars->intset args))) - (($ $kclause arity body alt) - (return (get-defs body) empty-intset)) - (($ $kreceive arity kargs) - (return (get-defs kargs) empty-intset)) - (($ $ktail) - (return empty-intset empty-intset)))) - cps - empty-intmap - empty-intmap))) - -(define (compute-reverse-control-flow-order preds) - "Return a LABEL->ORDER bijection where ORDER is a contiguous set of -integers starting from 0 and incrementing in sort order. There is a -precondition that labels in PREDS are already renumbered in reverse post -order." - (define (has-back-edge? preds) - (let/ec return - (intmap-fold (lambda (label labels) - (intset-fold (lambda (pred) - (if (<= label pred) - (return #t) - (values))) - labels) - (values)) - preds) - #f)) - (if (has-back-edge? preds) - ;; This is more involved than forward control flow because not all - ;; live labels are reachable from the tail. - (persistent-intmap - (fold2 (lambda (component order n) - (intset-fold (lambda (label order n) - (values (intmap-add! order label n) - (1+ n))) - component order n)) - (reverse (compute-sorted-strongly-connected-components preds)) - empty-intmap 0)) - ;; Just reverse forward control flow. - (let ((max (intmap-prev preds))) - (intmap-map (lambda (label labels) (- max label)) preds)))) - (define* (add-prompt-control-flow-edges conts succs #:key complete?) "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL + LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each @@ -272,51 +185,6 @@ body continuation in the prompt." conts succs)) -(define (rename-keys map old->new) - (persistent-intmap - (intmap-fold (lambda (k v out) - (intmap-add! out (intmap-ref old->new k) v)) - map - empty-intmap))) - -(define (rename-intset set old->new) - (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old))) - set empty-intset)) - -(define (rename-graph graph old->new) - (persistent-intmap - (intmap-fold (lambda (pred succs out) - (intmap-add! out - (intmap-ref old->new pred) - (rename-intset succs old->new))) - graph - empty-intmap))) - -(define (compute-live-variables cps defs uses) - "Compute and return two values mapping LABEL->VAR..., where VAR... are -the definitions that are live before and after LABEL, as intsets." - (let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps))) - (preds (invert-graph succs)) - (old->new (compute-reverse-control-flow-order preds)) - (init (persistent-intmap (intmap-fold - (lambda (old new init) - (intmap-add! init new empty-intset)) - old->new empty-intmap)))) - (call-with-values - (lambda () - (solve-flow-equations (rename-graph preds old->new) - init init - (rename-keys defs old->new) - (rename-keys uses old->new) - intset-subtract intset-union intset-union)) - (lambda (in out) - ;; As a reverse control-flow problem, the values flowing into a - ;; node are actually the live values after the node executes. - ;; Funny, innit? So we return them in the reverse order. - (let ((new->old (invert-bijection old->new))) - (values (rename-keys out new->old) - (rename-keys in new->old))))))) - (define (compute-needs-slot cps defs uses) (define (get-defs k) (intmap-ref defs k)) (define (get-uses label) (intmap-ref uses label)) @@ -746,84 +614,14 @@ are comparable with eqv?. A tmp slot may be used." (persistent-intmap (intmap-fold-right allocate-lazy cps slots))) -(define (compute-var-representations cps) - (define (get-defs k) - (match (intmap-ref cps k) - (($ $kargs names vars) vars) - (_ '()))) - (intmap-fold - (lambda (label cont representations) - (match cont - (($ $kargs _ _ ($ $continue k _ exp)) - (match (get-defs k) - (() representations) - ((var) - (match exp - (($ $values (arg)) - (intmap-add representations var - (intmap-ref representations arg))) - (($ $primcall (or 'scm->f64 'load-f64 's64->f64 - 'f32-ref 'f64-ref - 'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs - 'ffloor 'fceiling - 'fsin 'fcos 'ftan 'fasin 'facos 'fatan 'fatan2)) - (intmap-add representations var 'f64)) - (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64 - 's64->u64 - 'assume-u64 - 'uadd 'usub 'umul - 'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh - 'uadd/immediate 'usub/immediate 'umul/immediate - 'ursh/immediate 'ulsh/immediate - 'u8-ref 'u16-ref 'u32-ref 'u64-ref - 'word-ref 'word-ref/immediate - 'untag-char)) - (intmap-add representations var 'u64)) - (($ $primcall (or 'untag-fixnum - 'assume-s64 - 'scm->s64 'load-s64 'u64->s64 - 'srsh 'srsh/immediate - 's8-ref 's16-ref 's32-ref 's64-ref)) - (intmap-add representations var 's64)) - (($ $primcall (or 'pointer-ref/immediate - 'tail-pointer-ref/immediate)) - (intmap-add representations var 'ptr)) - (($ $code) - (intmap-add representations var 'u64)) - (_ - (intmap-add representations var 'scm)))) - (vars - (match exp - (($ $values args) - (fold (lambda (arg var representations) - (intmap-add representations var - (intmap-ref representations arg))) - representations args vars)))))) - (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw))) - representations) - (($ $kfun src meta self tail entry) - (let ((representations (if self - (intmap-add representations self 'scm) - representations))) - (fold1 (lambda (var representations) - (intmap-add representations var 'scm)) - (get-defs entry) representations))) - (($ $kclause arity body alt) - (fold1 (lambda (var representations) - (intmap-add representations var 'scm)) - (get-defs body) representations)) - (($ $kreceive arity kargs) - (fold1 (lambda (var representations) - (intmap-add representations var 'scm)) - (get-defs kargs) representations)) - (($ $ktail) representations))) - cps - empty-intmap)) - (define* (allocate-slots cps #:key (precolor-calls? #t)) (let*-values (((defs uses) (compute-defs-and-uses cps)) ((representations) (compute-var-representations cps)) - ((live-in live-out) (compute-live-variables cps defs uses)) + ((live-in live-out) + (let* ((succs (compute-successors cps)) + (succs+ (add-prompt-control-flow-edges cps succs)) + (preds (invert-graph succs+))) + (compute-live-variables preds defs uses))) ((needs-slot) (compute-needs-slot cps defs uses)) ((lazy) (if precolor-calls? (compute-lazy-vars cps live-in live-out defs diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index c72c04434..8f36e4d53 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021 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 @@ -43,7 +43,9 @@ compute-successors compute-predecessors compute-idoms - compute-dom-edges) + compute-dom-edges + compute-defs-and-uses + compute-var-representations) #:re-export (fold1 fold2 trivial-intset intmap-map @@ -302,42 +304,6 @@ intset." (intmap-fold adjoin-idom preds-map idoms)) empty-intmap))) -;; Precondition: For each function in CONTS, the continuation names are -;; topologically sorted. -(define (compute-idoms conts kfun) - ;; This is the iterative O(n^2) fixpoint algorithm, originally from - ;; Allen and Cocke ("Graph-theoretic constructs for program flow - ;; analysis", 1972). See the discussion in Cooper, Harvey, and - ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001. - (let ((preds-map (compute-predecessors conts kfun))) - (define (compute-idom idoms preds) - (define (idom-ref label) - (intmap-ref idoms label (lambda (_) #f))) - (match preds - (() -1) - ((pred) pred) ; Shortcut. - ((pred . preds) - (define (common-idom d0 d1) - ;; We exploit the fact that a reverse post-order is a - ;; topological sort, and so the idom of a node is always - ;; numerically less than the node itself. - (let lp ((d0 d0) (d1 d1)) - (cond - ;; d0 or d1 can be false on the first iteration. - ((not d0) d1) - ((not d1) d0) - ((= d0 d1) d0) - ((< d0 d1) (lp d0 (idom-ref d1))) - (else (lp (idom-ref d0) d1))))) - (fold1 common-idom preds pred)))) - (define (adjoin-idom label preds idoms) - (let ((idom (compute-idom idoms preds))) - ;; Don't use intmap-add! here. - (intmap-add idoms label idom (lambda (old new) new)))) - (fixpoint (lambda (idoms) - (intmap-fold adjoin-idom preds-map idoms)) - empty-intmap))) - ;; Compute a vector containing, for each node, a list of the nodes that ;; it immediately dominates. These are the "D" edges in the DJ tree. (define (compute-dom-edges idoms) @@ -351,3 +317,132 @@ intset." idoms empty-intmap))) +(define (compute-defs-and-uses cps) + "Return two LABEL->VAR... maps indicating values defined at and used +by a label, respectively." + (define (vars->intset vars) + (fold (lambda (var set) (intset-add set var)) empty-intset vars)) + (define-syntax-rule (persistent-intmap2 exp) + (call-with-values (lambda () exp) + (lambda (a b) + (values (persistent-intmap a) (persistent-intmap b))))) + (persistent-intmap2 + (intmap-fold + (lambda (label cont defs uses) + (define (get-defs k) + (match (intmap-ref cps k) + (($ $kargs names vars) (vars->intset vars)) + (_ empty-intset))) + (define (return d u) + (values (intmap-add! defs label d) + (intmap-add! uses label u))) + (match cont + (($ $kfun src meta self tail clause) + (return (intset-union + (if clause (get-defs clause) empty-intset) + (if self (intset self) empty-intset)) + empty-intset)) + (($ $kargs _ _ ($ $continue k src exp)) + (match exp + ((or ($ $const) ($ $const-fun) ($ $code)) + (return (get-defs k) empty-intset)) + (($ $call proc args) + (return (get-defs k) (intset-add (vars->intset args) proc))) + (($ $callk _ proc args) + (let ((args (vars->intset args))) + (return (get-defs k) (if proc (intset-add args proc) args)))) + (($ $primcall name param args) + (return (get-defs k) (vars->intset args))) + (($ $values args) + (return (get-defs k) (vars->intset args))))) + (($ $kargs _ _ ($ $branch kf kt src op param args)) + (return empty-intset (vars->intset args))) + (($ $kargs _ _ ($ $switch kf kt* src arg)) + (return empty-intset (intset arg))) + (($ $kargs _ _ ($ $prompt k kh src escape? tag)) + (return empty-intset (intset tag))) + (($ $kargs _ _ ($ $throw src op param args)) + (return empty-intset (vars->intset args))) + (($ $kclause arity body alt) + (return (get-defs body) empty-intset)) + (($ $kreceive arity kargs) + (return (get-defs kargs) empty-intset)) + (($ $ktail) + (return empty-intset empty-intset)))) + cps + empty-intmap + empty-intmap))) + +(define (compute-var-representations cps) + (define (get-defs k) + (match (intmap-ref cps k) + (($ $kargs names vars) vars) + (_ '()))) + (intmap-fold + (lambda (label cont representations) + (match cont + (($ $kargs _ _ ($ $continue k _ exp)) + (match (get-defs k) + (() representations) + ((var) + (match exp + (($ $values (arg)) + (intmap-add representations var + (intmap-ref representations arg))) + (($ $primcall (or 'scm->f64 'load-f64 's64->f64 + 'f32-ref 'f64-ref + 'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs + 'ffloor 'fceiling + 'fsin 'fcos 'ftan 'fasin 'facos 'fatan 'fatan2)) + (intmap-add representations var 'f64)) + (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64 + 's64->u64 + 'assume-u64 + 'uadd 'usub 'umul + 'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh + 'uadd/immediate 'usub/immediate 'umul/immediate + 'ursh/immediate 'ulsh/immediate + 'u8-ref 'u16-ref 'u32-ref 'u64-ref + 'word-ref 'word-ref/immediate + 'untag-char)) + (intmap-add representations var 'u64)) + (($ $primcall (or 'untag-fixnum + 'assume-s64 + 'scm->s64 'load-s64 'u64->s64 + 'srsh 'srsh/immediate + 's8-ref 's16-ref 's32-ref 's64-ref)) + (intmap-add representations var 's64)) + (($ $primcall (or 'pointer-ref/immediate + 'tail-pointer-ref/immediate)) + (intmap-add representations var 'ptr)) + (($ $code) + (intmap-add representations var 'u64)) + (_ + (intmap-add representations var 'scm)))) + (vars + (match exp + (($ $values args) + (fold (lambda (arg var representations) + (intmap-add representations var + (intmap-ref representations arg))) + representations args vars)))))) + (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw))) + representations) + (($ $kfun src meta self tail entry) + (let ((representations (if self + (intmap-add representations self 'scm) + representations))) + (fold1 (lambda (var representations) + (intmap-add representations var 'scm)) + (get-defs entry) representations))) + (($ $kclause arity body alt) + (fold1 (lambda (var representations) + (intmap-add representations var 'scm)) + (get-defs body) representations)) + (($ $kreceive arity kargs) + (fold1 (lambda (var representations) + (intmap-add representations var 'scm)) + (get-defs kargs) representations)) + (($ $ktail) representations))) + cps + empty-intmap)) |