wingo pushed a commit to branch wip-tailify in repository guile. commit 525a69a063b12e53c59703ad1bc660cc03b21e68 Author: Andy Wingo <wi...@pobox.com> AuthorDate: Sat Jun 19 15:32:38 2021 +0200
More tailify bugsquashing --- module/language/cps/tailify.scm | 149 +++++++++++++++++++++++++--------------- 1 file changed, 92 insertions(+), 57 deletions(-) diff --git a/module/language/cps/tailify.scm b/module/language/cps/tailify.scm index 66dc24c..f9ebb63 100644 --- a/module/language/cps/tailify.scm +++ b/module/language/cps/tailify.scm @@ -74,6 +74,7 @@ (define-module (language cps tailify) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (ice-9 match) #:use-module (language cps) #:use-module (language cps intmap) @@ -129,23 +130,26 @@ be rewritten to continue to the tail's ktail." ;; HEAD will have been given a corresponding entry $kfun by ;; tailify-tails. Here we find the tail-label for the current tail. (define local-ktail - (match (intmap-ref cps (intmap-ref entries head)) + (match (intmap-ref cps head) (($ $kfun src meta self ktail kentry) ktail))) + (pk 'tailify-tail head body fresh-names original-ktail local-ktail) + (define (rename-var var) (rename-var* fresh-names var)) (define (rename-vars vars) (rename-vars* fresh-names vars)) (define (rename-exp exp) - (rewrite-exp exp - ((or ($ $const) ($ $prim) ($ $const-fun) ($ $code)) ,exp) - (($ $call proc args) - ($call (rename-var proc) ,(rename-vars args))) - (($ $callk k proc args) - ($callk k (and proc (rename-var proc)) ,(rename-vars args))) - (($ $primcall name param args) - ($primcall name param ,(rename-vars args))) - (($ $values args) - ($values ,(rename-vars args))))) + (pk 'rename exp + (rewrite-exp exp + ((or ($ $const) ($ $prim) ($ $const-fun) ($ $code)) ,exp) + (($ $call proc args) + ($call (rename-var proc) ,(rename-vars args))) + (($ $callk k proc args) + ($callk k (and proc (rename-var proc)) ,(rename-vars args))) + (($ $primcall name param args) + ($primcall name param ,(rename-vars args))) + (($ $values args) + ($values ,(rename-vars args)))))) (define (compute-saved-vars fresh-names k) (compute-saved-vars* fresh-names live-in constants reprs k)) @@ -197,6 +201,7 @@ be rewritten to continue to the tail's ktail." (let ((exp (rename-exp exp))) (cond ((eqv? k original-ktail) + (pk 'original-tail-call k exp) (match exp (($ $values args) ;; The original term is a $values in tail position. @@ -222,11 +227,13 @@ be rewritten to continue to the tail's ktail." (($ $kreceive) ;; A non-tail-call: push the pending continuation and tail ;; call instead. + (pk 'non-tail-call head k exp) (match exp ((or ($ $call) ($ $callk) ($ $calli)) (call-with-values (lambda () (compute-saved-vars fresh-names k)) (lambda (reprs vars) + (pk 'saved-vars reprs vars) (with-cps cps (letk kexp ($kargs () () ($continue local-ktail src ,exp))) @@ -307,14 +314,13 @@ be rewritten to continue to the tail's ktail." ;; we just rewrite all the body conts. (intset-fold (lambda (label cps) - (match (intmap-ref cps label) + (match (pk 'tailify-tail1 head label (intmap-ref cps label)) ((or ($ $kfun) ($ $kclause) ($ $ktail)) cps) ;; Unchanged. - (($ $kreceive) cps) ;; Dead. (($ $kargs names vals term) (with-cps cps (let$ term (rewrite-term term)) (let$ term (maybe-unwind-prompt label term)) - (setk label ($kargs names vals ,term)))))) + (setk label ($kargs names vals ,(pk 'setting label term))))))) body cps)) (define (tailify-tails cps winds live-in constants reprs tails) @@ -348,7 +354,8 @@ REPRS holds the representation of each var." (define fresh-names-per-tail (intmap-map (lambda (head body) (intset-fold (lambda (var fresh) - (intmap-add fresh var (fresh-var))) + (intmap-add fresh var (pk 'live-in head var + (fresh-var)))) (intmap-ref live-in head) empty-intmap)) tails)) @@ -364,48 +371,61 @@ REPRS holds the representation of each var." ;; the live vars are restored from the stack. In all cases, adjoin a ;; HEAD->ENTRY mapping to ENTRIES, where ENTRY is the $kfun label for ;; the tail. - (define (add-entry head cps entries) + (define (add-entry head body cps entries tails) (define fresh-names (intmap-ref fresh-names-per-tail head)) ;; Constants don't need to be passed from tail to tail; rather they ;; are rebound locally. - (define (restore-constants cps term) - (intmap-fold (lambda (var exp cps term) + (define (restore-constants cps body term) + (intmap-fold (lambda (var exp cps body term) (define var' (intmap-ref fresh-names var)) (with-cps cps (letk k ($kargs ('const) (var') ,term)) - (build-term ($continue k #f ,exp)))) + ($ (values (intset-add body k) + (build-term ($continue k #f ,exp)))))) (live-constants live-in constants head) - cps term)) - (define (restore-saved cps term) + cps body term)) + (define (restore-saved cps body term) (call-with-values (lambda () (compute-saved-vars head)) (lambda (reprs vars) + (pk 'restoring head reprs vars) (define names (map (lambda (_) 'restored) vars)) (if (null? names) - (with-cps cps term) + (with-cps cps ($ (values body term))) (with-cps cps (letk krestore ($kargs names vars ,term)) - (build-term ($continue krestore #f - ($primcall 'restore reprs ())))))))) + ($ (values (intset-add body krestore) + (build-term ($continue krestore #f + ($primcall 'restore reprs ())))))))))) (match (intmap-ref cps head) (($ $kfun) ;; The main entry. - (values cps (intmap-add entries head head))) + (values cps (intmap-add entries head head) tails)) (($ $kreceive ($ $arity req () rest () #f) kargs) ;; The continuation of a non-tail call, or a prompt handler. (match (intmap-ref cps kargs) (($ $kargs names vars) (let ((vars' (map (lambda (_) (fresh-var)) vars)) (src (cont-source kargs))) - (with-cps cps - (letk ktail ($ktail)) - (let$ term (restore-constants - (build-term - ($continue kargs src ($values vars'))))) - (let$ term (restore-saved term)) - (letk krestore ($kargs names vars' ,term)) - (letk kclause ($kclause (req '() rest '() #f) krestore #f)) - (letk kfun ($kfun src '() #f ktail kclause)) - (intmap-add entries head kfun)))))) + (let*-values (((cps body term) + (restore-constants + cps + body + (build-term + ($continue kargs src ($values vars'))))) + ((cps body term) (restore-saved cps body term))) + (with-cps cps + (letk ktail ($ktail)) + (letk krestore ($kargs names vars' ,term)) + (letk kclause ($kclause (req '() rest '() #f) krestore #f)) + (letk kfun ($kfun src '() #f ktail kclause)) + ($ (values + (intmap-add entries head kfun) + (let ((added (intset kfun kclause krestore ktail)) + (removed (intset head))) + (intmap-add (intmap-remove tails head) + kfun + (intset-subtract (intset-union body added) + removed))))))))))) (($ $kargs names vars term) ;; A join point. (call-with-values (lambda () (compute-saved-vars head)) @@ -415,28 +435,37 @@ REPRS holds the representation of each var." (map (lambda (var) (assq-ref names var)) vars'))) (define meta `((arg-representations . ,reprs))) - (with-cps cps - (letk ktail ($ktail)) - (let$ term (restore-constants term)) - (letk kargs ($kargs names' vars' ,term)) - (letk kfun ($kfun (cont-source head) meta #f ktail kargs)) - (intmap-add entries head kfun))))))) + (let*-values (((cps body term) + (restore-constants cps body term))) + (with-cps cps + (letk ktail ($ktail)) + (letk kargs ($kargs names' vars' ,term)) + (letk kfun ($kfun (cont-source head) meta #f ktail kargs)) + ($ (values + (intmap-add entries head kfun) + (let ((added (intset kfun kargs ktail)) + (removed (intset head))) + (intmap-add (intmap-remove tails head) + kfun + (intset-subtract (intset-union body added) + removed)))))))))))) (define original-ktail (match (intmap-ref cps (intmap-next tails)) (($ $kfun src meta self ktail kentry) ktail))) (call-with-values (lambda () - (intmap-fold (lambda (head body cps entries) - (add-entry head cps entries)) - tails cps empty-intmap)) - (lambda (cps entries) + (intmap-fold (lambda (head body cps entries tails) + (add-entry head body cps entries tails)) + tails cps empty-intmap tails)) + (lambda (cps entries tails) (intmap-fold - (lambda (head body cps) - (define fresh-names (intmap-ref fresh-names-per-tail head)) + (lambda (old-head head cps) + (define fresh-names (intmap-ref fresh-names-per-tail old-head)) + (define body (intmap-ref tails head)) (tailify-tail cps head body fresh-names winds live-in constants reprs entries original-ktail)) - tails cps)))) + entries cps)))) (define (compute-tails kfun body preds cps) "Compute the set of tails in the function with entry KFUN and body @@ -469,21 +498,22 @@ body, as an intset." (else (match (intset-fold (lambda (pred pred-splits) - (define pred-split + (define split (intmap-ref splits pred (lambda (_) #f))) - (match pred-split - (#f pred-splits) - (split (cons split pred-splits)))) + (if (and split (not (memv split pred-splits))) + (cons split pred-splits) + pred-splits)) (intmap-ref preds label) '()) ((split) ;; If all predecessors in same split, label is too. (intmap-add splits label split (lambda (old new) new))) ((_ _ . _) ;; Otherwise this is a new split. + (pk 'join-split label) (intmap-add splits label label (lambda (old new) new))))))) ;; label -> split head (define initial-splits - (intset-fold initial-split body empty-intmap)) + (pk (intset-fold initial-split body empty-intmap))) (cond ((trivial-intmap initial-splits) ;; There's only one split head, so only one tail. @@ -493,6 +523,7 @@ body, as an intset." ;; head, then collect the tails by split head. (let ((splits (fixpoint (lambda (splits) + (pk 'fixpoint splits) (intset-fold compute-split body splits)) initial-splits))) (intmap-fold @@ -616,7 +647,7 @@ tails in such a way that they enter via a $kfun and leave only via tail calls." (define succs (compute-successors cps kfun)) (define preds (invert-graph succs)) - (define tails (compute-tails kfun body preds cps)) + (define tails (pk 'tails (compute-tails kfun body preds cps))) (cond ((trivial-intmap tails) (tailify-trivial-tail body cps)) @@ -628,10 +659,14 @@ calls." (reprs (compute-var-representations cps))) (tailify-tails cps winds live-in constants reprs tails))))) +(define (dump* map) + (intmap-fold (lambda (label cont) (pk label cont) (values)) map) + map) + (define (tailify cps) ;; Renumber so that label order is topological order. (let ((cps (renumber cps))) (with-fresh-name-state cps - (intmap-fold tailify-function - (compute-reachable-functions cps) - cps)))) + (dump* (intmap-fold tailify-function + (compute-reachable-functions cps) + cps)))))