From afb0a92d501af0c2ffa5428a35171ba40782f8ca Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 3 Jan 2018 14:15:35 +0100 Subject: [PATCH] $branch is now a distinct CPS term type * module/language/cps.scm ($branch): Refactor to be its own CPS term type, not relying on $continue to specify a continuation (which before was only for the false case) or a source location. Update allllllll callers. --- .dir-locals.el | 1 + module/language/cps.scm | 35 ++-- module/language/cps/closure-conversion.scm | 159 ++++++++--------- module/language/cps/compile-bytecode.scm | 156 +++++++++-------- module/language/cps/contification.scm | 22 ++- module/language/cps/cse.scm | 147 ++++++++-------- module/language/cps/dce.scm | 61 ++++--- module/language/cps/devirtualize-integers.scm | 158 +++++++++-------- module/language/cps/effects-analysis.scm | 6 +- module/language/cps/handle-interrupts.scm | 20 ++- module/language/cps/licm.scm | 164 +++++++++--------- module/language/cps/peel-loops.scm | 16 +- module/language/cps/reify-primitives.scm | 8 +- module/language/cps/renumber.scm | 57 +++--- module/language/cps/rotate-loops.scm | 135 +++++++------- module/language/cps/self-references.scm | 64 +++---- module/language/cps/simplify.scm | 72 ++++---- module/language/cps/slot-allocation.scm | 36 ++-- module/language/cps/specialize-numbers.scm | 120 ++++++------- module/language/cps/split-rec.scm | 46 ++--- module/language/cps/type-checks.scm | 16 +- module/language/cps/type-fold.scm | 49 +++--- module/language/cps/types.scm | 14 +- module/language/cps/utils.scm | 44 +++-- module/language/cps/verify.scm | 86 +++++++-- module/language/tree-il/compile-cps.scm | 19 +- 26 files changed, 907 insertions(+), 804 deletions(-) diff --git a/.dir-locals.el b/.dir-locals.el index 5e213c57f..3fdf7894f 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -33,6 +33,7 @@ (eval . (put '$letk* 'scheme-indent-function 1)) (eval . (put '$letconst 'scheme-indent-function 1)) (eval . (put '$continue 'scheme-indent-function 2)) + (eval . (put '$branch 'scheme-indent-function 3)) (eval . (put '$kargs 'scheme-indent-function 2)) (eval . (put '$kfun 'scheme-indent-function 4)) (eval . (put '$letrec 'scheme-indent-function 3)) diff --git a/module/language/cps.scm b/module/language/cps.scm index eae5fdc88..ddd4102ab 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -127,10 +127,10 @@ $kreceive $kargs $kfun $ktail $kclause ;; Terms. - $continue + $continue $branch ;; Expressions. - $const $prim $fun $rec $closure $branch + $const $prim $fun $rec $closure $call $callk $primcall $values $prompt ;; Building macros. @@ -179,6 +179,7 @@ ;; Terms. (define-cps-type $continue k src exp) +(define-cps-type $branch kf kt src op param args) ;; Expressions. (define-cps-type $const val) @@ -186,7 +187,6 @@ (define-cps-type $fun body) ; Higher-order. (define-cps-type $rec names syms funs) ; Higher-order. (define-cps-type $closure label nfree) ; First-order. -(define-cps-type $branch kt exp) (define-cps-type $call proc args) (define-cps-type $callk k proc args) ; First-order. (define-cps-type $primcall name param args) @@ -223,11 +223,17 @@ ((_ (unquote exp)) exp) ((_ ($continue k src exp)) - (make-$continue k src (build-exp exp))))) + (make-$continue k src (build-exp exp))) + ((_ ($branch kf kt src op param (unquote args))) + (make-$branch kf kt src op param args)) + ((_ ($branch kf kt src op param (arg ...))) + (make-$branch kf kt src op param (list arg ...))) + ((_ ($branch kf kt src op param args)) + (make-$branch kf kt src op param args)))) (define-syntax build-exp (syntax-rules (unquote - $const $prim $fun $rec $closure $branch + $const $prim $fun $rec $closure $call $callk $primcall $values $prompt) ((_ (unquote exp)) exp) ((_ ($const val)) (make-$const val)) @@ -247,7 +253,6 @@ ((_ ($values (unquote args))) (make-$values args)) ((_ ($values (arg ...))) (make-$values (list arg ...))) ((_ ($values args)) (make-$values args)) - ((_ ($branch kt exp)) (make-$branch kt (build-exp exp))) ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler)))) @@ -280,9 +285,13 @@ (('kclause (req opt rest kw allow-other-keys?) kbody kalt) (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt))) - ;; Calls. + ;; Terms. (('continue k exp) (build-term ($continue k (src exp) ,(parse-cps exp)))) + (('branch kf kt op param arg ...) + (build-term ($branch kf kt (src exp) op param arg))) + + ;; Expressions. (('unspecified) (build-exp ($const *unspecified*))) (('const exp) @@ -301,8 +310,6 @@ (build-exp ($callk k proc arg))) (('primcall name param arg ...) (build-exp ($primcall name param arg))) - (('branch k exp) - (build-exp ($branch k ,(parse-cps exp)))) (('values arg ...) (build-exp ($values arg))) (('prompt escape? tag handler) @@ -325,9 +332,13 @@ `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody . ,(if kalternate (list kalternate) '()))) - ;; Calls. + ;; Terms. (($ $continue k src exp) `(continue ,k ,(unparse-cps exp))) + (($ $branch kf kt src op param args) + `(branch ,kf ,kt ,op ,param ,@args)) + + ;; Expressions. (($ $const val) (if (unspecified? val) '(unspecified) @@ -348,8 +359,6 @@ `(callk ,k ,proc ,@args)) (($ $primcall name param args) `(primcall ,name ,param ,@args)) - (($ $branch k exp) - `(branch ,k ,(unparse-cps exp))) (($ $values args) `(values ,@args)) (($ $prompt escape? tag handler) diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 58f0020e4..b15bb632a 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -89,12 +89,12 @@ conts." (add-uses args uses)) (($ $call proc args) (add-uses args uses)) - (($ $branch kt ($ $primcall name param args)) - (add-uses args uses)) (($ $primcall name param args) (add-uses args uses)) (($ $prompt escape? tag handler) (add-use tag uses)))) + (($ $kargs _ _ ($ $branch kf kt src op param args)) + (add-uses args uses)) (_ uses))) conts empty-intset))) @@ -117,8 +117,9 @@ conts." (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) (($ $ktail) (ref0)) (($ $kclause arity kbody kalt) (ref2 kbody kalt)) - (($ $kargs names syms ($ $continue k src exp)) - (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) + (($ $kargs _ _ ($ $continue k _ ($ $prompt _ _ h))) (ref2 k h)) + (($ $kargs _ _ ($ $continue k)) (ref1 k)) + (($ $kargs _ _ ($ $branch kf kt)) (ref2 kf kt)))) (let*-values (((single multiple) (values empty-intset empty-intset)) ((single multiple) (intset-fold add-ref body single multiple))) (intset-subtract (persistent-intset single) @@ -226,35 +227,35 @@ proc argument. For recursive calls, use the appropriate 'self' variable, if possible. Also rewrite uses of the non-well-known but shared closures to use the appropriate 'self' variable, if possible." ;; env := var -> (var . label) - (define (rewrite-fun kfun cps env) + (define (visit-fun kfun cps env) (define (subst var) (match (intmap-ref env var (lambda (_) #f)) (#f var) ((var . label) var))) - (define (rename-exp label cps names vars k src exp) - (intmap-replace! - cps label - (build-cont - ($kargs names vars - ($continue k src - ,(rewrite-exp exp - ((or ($ $const) ($ $prim)) ,exp) - (($ $call proc args) - ,(let ((args (map subst args))) - (rewrite-exp (intmap-ref env proc (lambda (_) #f)) - (#f ($call proc ,args)) - ((closure . label) ($callk label closure ,args))))) - (($ $primcall name param args) - ($primcall name param ,(map subst args))) - (($ $branch k ($ $primcall name param args)) - ($branch k ($primcall name param ,(map subst args)))) - (($ $values args) - ($values ,(map subst args))) - (($ $prompt escape? tag handler) - ($prompt escape? (subst tag) handler)))))))) + (define (visit-exp exp) + (rewrite-exp exp + ((or ($ $const) ($ $prim)) ,exp) + (($ $call proc args) + ,(let ((args (map subst args))) + (rewrite-exp (intmap-ref env proc (lambda (_) #f)) + (#f ($call proc ,args)) + ((closure . label) ($callk label closure ,args))))) + (($ $primcall name param args) + ($primcall name param ,(map subst args))) + (($ $values args) + ($values ,(map subst args))) + (($ $prompt escape? tag handler) + ($prompt escape? (subst tag) handler)))) - (define (visit-exp label cps names vars k src exp) + (define (visit-term term) + (rewrite-term term + (($ $continue k src exp) + ($continue k src ,(visit-exp exp))) + (($ $branch kf kt src op param args) + ($branch kf kt src op param ,(map subst args))))) + + (define (visit-rec labels vars cps) (define (compute-env label bound self rec-bound rec-labels env) (define (add-bound-var bound label env) (intmap-add env bound (cons self label) (lambda (old new) new))) @@ -265,26 +266,27 @@ shared closures to use the appropriate 'self' variable, if possible." ;; Otherwise be sure to use "self" references in any ;; closure. (add-bound-var bound label env))) - (match exp - (($ $fun label) - (rewrite-fun label cps env)) - (($ $rec names vars (($ $fun labels) ...)) - (fold (lambda (label var cps) - (match (intmap-ref cps label) - (($ $kfun src meta self) - (rewrite-fun label cps - (compute-env label var self vars labels - env))))) - cps labels vars)) - (_ (rename-exp label cps names vars k src exp)))) - - (define (rewrite-cont label cps) + (fold (lambda (label var cps) + (match (intmap-ref cps label) + (($ $kfun src meta self) + (visit-fun label cps + (compute-env label var self vars labels env))))) + cps labels vars)) + + (define (visit-cont label cps) (match (intmap-ref cps label) - (($ $kargs names vars ($ $continue k src exp)) - (visit-exp label cps names vars k src exp)) + (($ $kargs names vars + ($ $continue k src ($ $fun label))) + (visit-fun label cps env)) + (($ $kargs _ _ + ($ $continue k src ($ $rec names vars (($ $fun labels) ...)))) + (visit-rec labels vars cps)) + (($ $kargs names vars term) + (with-cps cps + (setk label ($kargs names vars ,(visit-term term))))) (_ cps))) - (intset-fold rewrite-cont (intmap-ref functions kfun) cps)) + (intset-fold visit-cont (intmap-ref functions kfun) cps)) ;; Initial environment is bound-var -> (shared-var . label) map for ;; functions with shared closures. @@ -299,7 +301,7 @@ shared closures to use the appropriate 'self' variable, if possible." env)) shared empty-intmap))) - (persistent-intmap (rewrite-fun kfun cps env)))) + (persistent-intmap (visit-fun kfun cps env)))) (define (compute-free-vars conts kfun shared) "Compute a FUN-LABEL->FREE-VAR... map describing all free variable @@ -350,31 +352,33 @@ references." (intset-fold (lambda (label defs uses) (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) + (($ $kargs names vars term) (values (add-defs vars defs) - (match exp - ((or ($ $const) ($ $prim)) uses) - (($ $fun kfun) - (intset-union (persistent-intset uses) - (intmap-ref free kfun))) - (($ $rec names vars (($ $fun kfun) ...)) - (fold (lambda (kfun uses) - (intset-union (persistent-intset uses) - (intmap-ref free kfun))) - uses kfun)) - (($ $values args) - (add-uses args uses)) - (($ $call proc args) - (add-use proc (add-uses args uses))) - (($ $callk label proc args) - (add-use proc (add-uses args uses))) - (($ $branch kt ($ $primcall name param args)) - (add-uses args uses)) - (($ $primcall name param args) - (add-uses args uses)) - (($ $prompt escape? tag handler) - (add-use tag uses))))) + (match term + (($ $continue k src exp) + (match exp + ((or ($ $const) ($ $prim)) uses) + (($ $fun kfun) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + (($ $rec names vars (($ $fun kfun) ...)) + (fold (lambda (kfun uses) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + uses kfun)) + (($ $values args) + (add-uses args uses)) + (($ $call proc args) + (add-use proc (add-uses args uses))) + (($ $callk label proc args) + (add-use proc (add-uses args uses))) + (($ $primcall name param args) + (add-uses args uses)) + (($ $prompt escape? tag handler) + (add-use tag uses)))) + (($ $branch kf kt src op param args) + (add-uses args uses))))) (($ $kfun src meta self) (values (add-def self defs) uses)) (_ (values defs uses)))) @@ -715,14 +719,6 @@ bound to @var{var}, and continue to @var{k}." (build-term ($continue k src ($primcall name param args))))))) - (($ $continue k src ($ $branch kt ($ $primcall name param args))) - (convert-args cps args - (lambda (cps args) - (with-cps cps - (build-term - ($continue k src - ($branch kt ($primcall name param args)))))))) - (($ $continue k src ($ $values args)) (convert-args cps args (lambda (cps args) @@ -736,7 +732,14 @@ bound to @var{var}, and continue to @var{k}." (with-cps cps (build-term ($continue k src - ($prompt escape? tag handler))))))))) + ($prompt escape? tag handler))))))) + + (($ $branch kf kt src op param args) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($branch kf kt src op param args)))))))) (intset-fold (lambda (label cps) (match (intmap-ref cps label (lambda (_) #f)) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 2b3b23fef..0bef330f5 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -435,7 +435,7 @@ ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation))))) - (define (compile-test label exp kt kf next-label) + (define (compile-test label next-label kf kt op param args) (define (prefer-true?) (if (< (max kt kf) label) ;; Two backwards branches. Prefer @@ -474,71 +474,71 @@ (define (binary- (intmap-ref defs label) (lambda (defs) (subst-vars var-substs defs))))) (define (add-def! aux-key var) @@ -229,7 +237,7 @@ false. It could be that both true and false proofs are available." ((add-definitions ((def <- op arg ...) (aux <- op* arg* ...) ...) . clauses) - (match exp-key + (match term-key (('op arg ...) (match defs ((def) (add-def! (list 'op* arg* ...) aux) ...))) @@ -237,7 +245,7 @@ false. It could be that both true and false proofs are available." ((add-definitions ((op arg ...) (aux <- op* arg* ...) ...) . clauses) - (match exp-key + (match term-key (('op arg ...) (add-def! (list 'op* arg* ...) aux) ...) (_ (add-definitions . clauses)))))) @@ -282,12 +290,18 @@ false. It could be that both true and false proofs are available." ((u <- s64->u64 #f s) (s <- u64->s64 #f u))))) (define (visit-label label equiv-labels var-substs) + (define (term-defs term) + (match term + (($ $continue k) + (and (intset-ref singly-referenced k) + (intmap-ref defs label))) + (($ $branch) '()))) (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (match (compute-exp-key var-substs exp) + (($ $kargs names vars term) + (match (compute-term-key var-substs term) (#f (values equiv-labels var-substs)) - (exp-key - (let* ((equiv (hash-ref equiv-set exp-key '())) + (term-key + (let* ((equiv (hash-ref equiv-set term-key '())) (fx (intmap-ref effects label)) (avail (intmap-ref avail label))) (define (finish equiv-labels var-substs) @@ -296,7 +310,7 @@ false. It could be that both true and false proofs are available." ;; define those. Do so after finding equivalent ;; expressions, so that we can take advantage of ;; subst'd output vars. - (add-auxiliary-definitions! label var-substs exp-key) + (add-auxiliary-definitions! label var-substs term-key) (values equiv-labels var-substs)) (let lp ((candidates equiv)) (match candidates @@ -310,10 +324,9 @@ false. It could be that both true and false proofs are available." ;; allocation case). (when (and (not (causes-effect? fx &allocation)) (not (effect-clobbers? fx (&read-object &fluid)))) - (let ((defs (and (intset-ref singly-referenced k) - (intmap-ref defs label)))) + (let ((defs (term-defs term))) (when defs - (hash-set! equiv-set exp-key + (hash-set! equiv-set term-key (acons label defs equiv))))) (finish equiv-labels var-substs)) (((and head (candidate . vars)) . candidates) @@ -327,8 +340,7 @@ false. It could be that both true and false proofs are available." ;; we provide the definitions for the successor, mark ;; the vars for substitution. (finish (intmap-add equiv-labels label head) - (let ((defs (and (intset-ref singly-referenced k) - (intmap-ref defs label)))) + (let ((defs (term-defs term))) (if defs (fold (lambda (def var var-substs) (intmap-add var-substs def var)) @@ -364,44 +376,41 @@ false. It could be that both true and false proofs are available." ($callk k (subst-var proc) ,(map subst-var args))) (($ $primcall name param args) ($primcall name param ,(map subst-var args))) - (($ $branch k exp) - ($branch k ,(visit-exp exp))) (($ $values args) ($values ,(map subst-var args))) (($ $prompt escape? tag handler) ($prompt escape? (subst-var tag) handler)))) + (define (visit-term label term) + (match term + (($ $branch kf kt src op param args) + (match (intmap-ref equiv-labels label (lambda (_) #f)) + ((equiv) ; A branch defines no values. + (let* ((bool (intmap-ref truthy-labels label)) + (t (intset-ref bool (true-idx equiv))) + (f (intset-ref bool (false-idx equiv)))) + (if (eqv? t f) + (build-term + ($branch kf kt src op param ,(map subst-var args))) + (build-term + ($continue (if t kt kf) src ($values ())))))) + (#f + (build-term + ($branch kf kt src op param ,(map subst-var args)))))) + (($ $continue k src exp) + (match (intmap-ref equiv-labels label (lambda (_) #f)) + ((equiv . vars) + (build-term ($continue k src ($values vars)))) + (#f + (build-term + ($continue k src ,(visit-exp exp)))))))) + (intmap-map (lambda (label cont) - (match cont - (($ $kargs names vars ($ $continue k src exp)) - (build-cont - ($kargs names vars - ,(match (intmap-ref equiv-labels label (lambda (_) #f)) - ((equiv . vars) - (match exp - (($ $branch kt exp) - (let* ((bool (intmap-ref truthy-labels label)) - (t (intset-ref bool (true-idx equiv))) - (f (intset-ref bool (false-idx equiv)))) - (if (eqv? t f) - (build-term - ($continue k src - ($branch kt ,(visit-exp exp)))) - (build-term - ($continue (if t kt k) src ($values ())))))) - (_ - ;; For better or for worse, we only replace primcalls - ;; if they have an associated VM op, which allows - ;; them to continue to $kargs and thus we know their - ;; defs and can use a $values expression instead of a - ;; values primcall. - (build-term - ($continue k src ($values vars)))))) - (#f - (build-term - ($continue k src ,(visit-exp exp)))))))) - (_ cont))) + (rewrite-cont cont + (($ $kargs names vars term) + ($kargs names vars ,(visit-term label term))) + (_ ,cont))) conts)) (define (eliminate-common-subexpressions conts) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index d896b3664..829ab3613 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -80,6 +80,10 @@ sites." (causes-effect? fx &allocation)) (values (intset-add! known k) unknown) (values known (intset-add! unknown k))))) + (($ $kargs _ _ ($ $branch)) + ;; Branches pass no values to their + ;; continuations. + (values known unknown)) (($ $kreceive arity kargs) (values known (intset-add! unknown kargs))) (($ $kfun src meta self tail clause) @@ -151,8 +155,6 @@ sites." (adjoin-vars args (adjoin-var proc live-vars)))) (($ $primcall name param args) (values live-labels (adjoin-vars args live-vars))) - (($ $branch k ($ $primcall name param args)) - (values live-labels (adjoin-vars args live-vars))) (($ $values args) (values live-labels (match (cont-defs k) @@ -164,17 +166,6 @@ sites." live-vars args defs))))))) (define (visit-exp label k exp live-labels live-vars) - (define (next-live-term k) - ;; FIXME: For a chain of dead branches, this is quadratic. - (let lp ((seen empty-intset) (k k)) - (cond - ((intset-ref live-labels k) k) - ((intset-ref seen k) k) - (else - (match (intmap-ref conts k) - (($ $kargs _ _ ($ $continue k*)) - (lp (intset-add seen k) k*)) - (_ k)))))) (cond ((intset-ref live-labels label) ;; Expression live already. @@ -192,12 +183,6 @@ sites." ;; Does it cause a type check, but we weren't able to prove ;; that the types check? (causes-effect? fx &type-check) - ;; We only remove branches if both continuations are the - ;; same. - (match exp - (($ $branch kt) - (not (eqv? (next-live-term k) (next-live-term kt)))) - (_ #f)) ;; We might have a setter. If the object being assigned to ;; is live or was not created by us, then this expression is ;; live. Otherwise the value is still dead. @@ -219,6 +204,32 @@ sites." ;; Still dead. (values live-labels live-vars)))) + (define (visit-branch label kf kt args live-labels live-vars) + (define (next-live-term k) + ;; FIXME: For a chain of dead branches, this is quadratic. + (let lp ((seen empty-intset) (k k)) + (cond + ((intset-ref live-labels k) k) + ((intset-ref seen k) k) + (else + (match (intmap-ref conts k) + (($ $kargs _ _ ($ $continue k*)) + (lp (intset-add seen k) k*)) + (_ k)))))) + (cond + ((intset-ref live-labels label) + ;; Branch live already. + (values live-labels (adjoin-vars args live-vars))) + ((or (causes-effect? (intmap-ref effects label) &type-check) + (not (eqv? (next-live-term kf) (next-live-term kt)))) + ;; The branch is live if its continuations are not the same, or + ;; if the branch itself causes type checks. + (values (intset-add live-labels label) + (adjoin-vars args live-vars))) + (else + ;; Still dead. + (values live-labels live-vars)))) + (define (visit-fun label live-labels live-vars) ;; Visit uses before definitions. (postorder-fold-local-conts2 @@ -226,6 +237,8 @@ sites." (match cont (($ $kargs _ _ ($ $continue k src exp)) (visit-exp label k exp live-labels live-vars)) + (($ $kargs _ _ ($ $branch kf kt src op param args)) + (visit-branch label kf kt args live-labels live-vars)) (($ $kreceive arity kargs) (values live-labels live-vars)) (($ $kclause arity kargs kalt) @@ -327,7 +340,13 @@ sites." (values cps term))))) (values cps (build-term - ($continue k src ($values ())))))))) + ($continue k src ($values ())))))) + (($ $branch kf kt src op param args) + (if (label-live? label) + (values cps term) + ;; Dead branches continue to the same continuation + ;; (eventually). + (values cps (build-term ($continue kf src ($values ())))))))) (define (visit-cont label cont cps) (match cont (($ $kargs names vars term) diff --git a/module/language/cps/devirtualize-integers.scm b/module/language/cps/devirtualize-integers.scm index 1cedaeae7..9ebe6fc84 100644 --- a/module/language/cps/devirtualize-integers.scm +++ b/module/language/cps/devirtualize-integers.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017, 2018 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 @@ -59,22 +59,24 @@ (intmap-fold (lambda (label cont use-counts) (match cont - (($ $kargs names vars ($ $continue k src exp)) - (match exp - ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec)) - use-counts) - (($ $values args) - (add-uses use-counts args)) - (($ $call proc args) - (add-uses (add-use use-counts proc) args)) - (($ $callk kfun proc args) - (add-uses (add-use use-counts proc) args)) - (($ $branch kt ($ $primcall name param args)) - (add-uses use-counts args)) - (($ $primcall name param args) - (add-uses use-counts args)) - (($ $prompt escape? tag handler) - (add-use use-counts tag)))) + (($ $kargs names vars term) + (match term + (($ $continue k src exp) + (match exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec)) + use-counts) + (($ $values args) + (add-uses use-counts args)) + (($ $call proc args) + (add-uses (add-use use-counts proc) args)) + (($ $callk kfun proc args) + (add-uses (add-use use-counts proc) args)) + (($ $primcall name param args) + (add-uses use-counts args)) + (($ $prompt escape? tag handler) + (add-use use-counts tag)))) + (($ $branch kf kt src op param args) + (add-uses use-counts args)))) (_ use-counts))) cps (transient-intmap)))) @@ -124,7 +126,7 @@ the trace should be referenced outside of it." ;; graph to get to $kreceive etc, so we can stop with these two ;; continuation kinds. (($ $ktail) (fail)) - (($ $kargs names vars ($ $continue k src exp)) + (($ $kargs names vars term) (let* ((vars-of-interest (if defs-of-interest? (fold1 (lambda (var set) (intset-add set var)) @@ -134,7 +136,8 @@ the trace should be referenced outside of it." (fresh-vars (fold (lambda (var fresh-vars) (intmap-add fresh-vars var (fresh-var))) fresh-vars vars)) - (vars (map (lambda (var) (intmap-ref fresh-vars var)) vars))) + (peeled-vars (map (lambda (var) (intmap-ref fresh-vars var)) + vars))) (define (rename-uses args) (map (lambda (arg) (intmap-ref fresh-vars arg (lambda (arg) arg))) args)) @@ -142,10 +145,10 @@ the trace should be referenced outside of it." (or-map (lambda (arg) (intset-ref vars-of-interest arg)) args)) (define (continue k live-vars defs-of-interest? can-terminate-trace? - exp) + make-term) (define (stitch cps k) (with-cps cps - (letk label* ($kargs names vars ($continue k src ,exp))) + (letk label* ($kargs names peeled-vars ,(make-term k))) label*)) (define (terminate) (stitch cps k)) @@ -158,73 +161,71 @@ the trace should be referenced outside of it." ((and can-terminate-trace? (eq? live-vars empty-intmap)) (terminate)) (else (fail)))))))) - (match exp - (($ $const) - ;; fine. - (continue k live-vars #f #f exp)) - (($ $values args) - (let ((live-vars (subtract-uses live-vars args))) - (continue k live-vars - (any-use-of-interest? args) #f - (build-exp ($values ,(rename-uses args)))))) - (($ $primcall name param args) - ;; exp is effect-free or var of interest in args - (let* ((fx (expression-effects exp)) - (uses-of-interest? (any-use-of-interest? args)) - (live-vars (subtract-uses live-vars args))) - ;; If the primcall uses a value of interest, - ;; consider it for peeling even if it would cause a - ;; type check; perhaps the peeling causes the type - ;; check to go away. - (if (or (eqv? fx &no-effects) - (and uses-of-interest? (eqv? fx &type-check))) - (continue k (subtract-uses live-vars args) - ;; Primcalls that use values of interest - ;; define values of interest. - uses-of-interest? #t - (build-exp - ($primcall name param ,(rename-uses args)))) - (fail)))) - (($ $branch kt ($ $primcall name param args)) + (match term + (($ $branch kf kt src op param args) ;; kt or k is kf; var of interest is in args (let* ((live-vars (subtract-uses live-vars args)) (uses-of-interest? (any-use-of-interest? args)) (defs-of-interest? #f) ;; Branches don't define values. (can-terminate-trace? uses-of-interest?) - (exp (build-exp - ($primcall name param ,(rename-uses args))))) + (peeled-args (rename-uses args))) (cond ((not (any-use-of-interest? args)) (fail)) ((bailout? kt) - (continue k live-vars defs-of-interest? can-terminate-trace? - (build-exp ($branch kt ,exp)))) - ((bailout? k) - (let () - (define (stitch cps kt) - (with-cps cps - (letk label* - ($kargs names vars - ($continue k src ($branch kt ,exp)))) - label*)) - (define (terminate) - (stitch cps kt)) - (with-cps cps - (let$ kt* (peel-cont kt live-vars fresh-vars - vars-of-interest defs-of-interest?)) - ($ ((lambda (cps) - (cond - (kt* (stitch cps kt*)) - ((and can-terminate-trace? (eq? live-vars empty-intmap)) - (terminate)) - (else (fail))))))))) + (continue kf live-vars defs-of-interest? can-terminate-trace? + (lambda (kf) + (build-term + ($branch kf kt src op param peeled-args))))) + ((bailout? kf) + (continue kt live-vars defs-of-interest? can-terminate-trace? + (lambda (kt) + (build-term + ($branch kf kt src op param peeled-args))))) (else (with-cps cps (letk label* - ($kargs names vars - ($continue k src ($branch kt ,exp)))) + ($kargs names peeled-vars + ($branch kf kt src op param peeled-args))) label*))))) - (_ (fail)))))))) + (($ $continue k src exp) + (match exp + (($ $const) + ;; fine. + (continue k live-vars #f #f + (lambda (k) + (build-term ($continue k src ,exp))))) + (($ $values args) + (let ((uses-of-interest? (any-use-of-interest? args)) + (live-vars (subtract-uses live-vars args)) + (peeled-args (rename-uses args))) + (continue k live-vars + uses-of-interest? #f + (lambda (k) + (build-term + ($continue k src ($values peeled-args))))))) + (($ $primcall name param args) + ;; exp is effect-free or var of interest in args + (let* ((fx (expression-effects exp)) + (uses-of-interest? (any-use-of-interest? args)) + (live-vars (subtract-uses live-vars args)) + (peeled-args (rename-uses args))) + ;; If the primcall uses a value of interest, + ;; consider it for peeling even if it would cause a + ;; type check; perhaps the peeling causes the type + ;; check to go away. + (if (or (eqv? fx &no-effects) + (and uses-of-interest? (eqv? fx &type-check))) + (continue k live-vars + ;; Primcalls that use values of interest + ;; define values of interest. + uses-of-interest? #t + (lambda (k) + (build-term + ($continue k src + ($primcall name param ,peeled-args))))) + (fail)))) + (_ (fail)))))))))) (define (peel-traces-in-function cps body use-counts) (intset-fold @@ -232,9 +233,7 @@ the trace should be referenced outside of it." (match (intmap-ref cps label) ;; Traces start with a fixnum? predicate. We could expand this ;; in the future if we wanted to. - (($ $kargs names vars - ($ $continue kf src - ($ $branch kt ($ $primcall 'fixnum? #f (x))))) + (($ $kargs names vars ($ $branch kf kt src 'fixnum? #f (x))) (with-cps cps (let$ kt (peel-trace kt x kf use-counts)) ($ ((lambda (cps) @@ -242,8 +241,7 @@ the trace should be referenced outside of it." (with-cps cps (setk label ($kargs names vars - ($continue kf src - ($branch kt ($primcall 'fixnum? #f (x))))))) + ($branch kf kt src 'fixnum? #f (x))))) cps)))))) (_ cps))) body diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index b49ef15e4..854bd11b8 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -1,6 +1,6 @@ ;;; Effects analysis on CPS -;; Copyright (C) 2011-2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2011-2015, 2017, 2018 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 @@ -603,8 +603,6 @@ the LABELS that are clobbered by the effects of LABEL." &all-effects) ((or ($ $call) ($ $callk)) &all-effects) - (($ $branch k exp) - (expression-effects exp)) (($ $primcall name param args) (primitive-effects param name args)))) @@ -614,6 +612,8 @@ the LABELS that are clobbered by the effects of LABEL." (match cont (($ $kargs names syms ($ $continue k src exp)) (expression-effects exp)) + (($ $kargs names syms ($ $branch kf kt src op param args)) + (primitive-effects param op args)) (($ $kreceive arity kargs) (match arity (($ $arity _ () #f () #f) &type-check) diff --git a/module/language/cps/handle-interrupts.scm b/module/language/cps/handle-interrupts.scm index 758637c18..614b7a44a 100644 --- a/module/language/cps/handle-interrupts.scm +++ b/module/language/cps/handle-interrupts.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2016, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2016, 2017, 2018 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 @@ -34,12 +34,15 @@ #:export (add-handle-interrupts)) (define (compute-safepoints cps) + (define (maybe-add-safepoint label k safepoints) + "Add K to safepoints if it is a target of a backward branch." + (if (<= k label) + (intset-add! safepoints k) + safepoints)) (define (visit-cont label cont safepoints) (match cont (($ $kargs names vars ($ $continue k src exp)) - (let ((safepoints (if (<= k label) - (intset-add! safepoints k) - safepoints))) + (let ((safepoints (maybe-add-safepoint label k safepoints))) (if (match exp (($ $call) #t) (($ $callk) #t) @@ -50,18 +53,21 @@ (_ #f)) (intset-add! safepoints label) safepoints))) + (($ $kargs names vars ($ $branch kf kt)) + (maybe-add-safepoint label kf + (maybe-add-safepoint label kt safepoints))) (_ safepoints))) (persistent-intset (intmap-fold visit-cont cps empty-intset))) (define (add-handle-interrupts cps) (define (add-safepoint label cps) (match (intmap-ref cps label) - (($ $kargs names vars ($ $continue k src exp)) + (($ $kargs names vars term) (with-cps cps - (letk k* ($kargs () () ($continue k src ,exp))) + (letk k ($kargs () () ,term)) (setk label ($kargs names vars - ($continue k* src + ($continue k #f ($primcall 'handle-interrupts #f ())))))))) (let* ((cps (renumber cps)) (safepoints (compute-safepoints cps))) diff --git a/module/language/cps/licm.scm b/module/language/cps/licm.scm index 3e612a228..b016b3b41 100644 --- a/module/language/cps/licm.scm +++ b/module/language/cps/licm.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -69,7 +69,6 @@ (match exp ((or ($ $const) ($ $prim) ($ $closure)) #t) (($ $prompt) #f) ;; ? - (($ $branch) #f) (($ $primcall name param args) (and-map (lambda (arg) (not (intset-ref loop-vars arg))) args)) @@ -127,93 +126,98 @@ pre-header-label pre-header-cont) pre-header-label))) (match cont - (($ $kargs names vars ($ $continue k src exp)) - ;; If k is a loop exit, it will be nullary. + (($ $kargs names vars term) (let-values (((names vars) (filter-loop-vars names vars))) - (match (intmap-ref cps k) - (($ $kargs def-names def-vars) - (cond - ((not (loop-invariant? label exp loop-vars loop-effects - always-reached?)) - (let* ((loop-vars (adjoin-loop-vars loop-vars def-vars)) - (loop-vars (match exp - (($ $prompt escape? tag handler) - (match (intmap-ref cps handler) - (($ $kreceive arity kargs) - (match (intmap-ref cps kargs) - (($ $kargs names vars) - (adjoin-loop-vars loop-vars vars)))))) - (_ loop-vars))) - (cont (build-cont - ($kargs names vars - ($continue k src ,exp)))) - (always-reached? - (and always-reached? - (match exp - (($ $branch) #f) - (_ (not (causes-effect? (intmap-ref loop-effects label) - &type-check))))))) - (values cps cont loop-vars loop-effects - pre-header-label always-reached?))) - ((trivial-intset (intmap-ref preds k)) - (let-values - (((cps pre-header-label) - (hoist-exp src exp def-names def-vars pre-header-label)) - ((cont) (build-cont - ($kargs names vars - ($continue k src ($values ())))))) - (values cps cont loop-vars (intmap-remove loop-effects label) - pre-header-label always-reached?))) - (else - (let*-values - (((def-names def-vars) - (match (intmap-ref cps k) - (($ $kargs names vars) (values names vars)))) - ((loop-vars) (adjoin-loop-vars loop-vars def-vars)) - ((fresh-vars) (map (lambda (_) (fresh-var)) def-vars)) - ((cps pre-header-label) - (hoist-exp src exp def-names fresh-vars pre-header-label)) - ((cont) (build-cont - ($kargs names vars - ($continue k src ($values fresh-vars)))))) - (values cps cont loop-vars (intmap-remove loop-effects label) - pre-header-label always-reached?))))) - (($ $kreceive ($ $arity req () rest) kargs) - (match (intmap-ref cps kargs) + (match term + (($ $continue k src exp) + ;; If k is a loop exit, it will be nullary. + (match (intmap-ref cps k) (($ $kargs def-names def-vars) (cond ((not (loop-invariant? label exp loop-vars loop-effects always-reached?)) (let* ((loop-vars (adjoin-loop-vars loop-vars def-vars)) + (loop-vars (match exp + (($ $prompt escape? tag handler) + (match (intmap-ref cps handler) + (($ $kreceive arity kargs) + (match (intmap-ref cps kargs) + (($ $kargs names vars) + (adjoin-loop-vars loop-vars vars)))))) + (_ loop-vars))) (cont (build-cont ($kargs names vars - ($continue k src ,exp))))) - (values cps cont loop-vars loop-effects pre-header-label #f))) + ($continue k src ,exp)))) + (always-reached? + (and always-reached? + (not (causes-effect? (intmap-ref loop-effects label) + &type-check))))) + (values cps cont loop-vars loop-effects + pre-header-label always-reached?))) ((trivial-intset (intmap-ref preds k)) - (let ((loop-effects - (intmap-remove (intmap-remove loop-effects label) k))) - (let-values - (((cps pre-header-label) - (hoist-call src exp req rest def-names def-vars - pre-header-label)) - ((cont) (build-cont - ($kargs names vars - ($continue kargs src ($values ())))))) - (values cps cont loop-vars loop-effects - pre-header-label always-reached?)))) - (else - (let*-values - (((loop-vars) (adjoin-loop-vars loop-vars def-vars)) - ((fresh-vars) (map (lambda (_) (fresh-var)) def-vars)) - ((cps pre-header-label) - (hoist-call src exp req rest def-names fresh-vars - pre-header-label)) + (let-values + (((cps pre-header-label) + (hoist-exp src exp def-names def-vars pre-header-label)) ((cont) (build-cont ($kargs names vars - ($continue kargs src - ($values fresh-vars)))))) - (values cps cont loop-vars loop-effects - pre-header-label always-reached?)))))))))) + ($continue k src ($values ())))))) + (values cps cont loop-vars (intmap-remove loop-effects label) + pre-header-label always-reached?))) + (else + (let*-values + (((def-names def-vars) + (match (intmap-ref cps k) + (($ $kargs names vars) (values names vars)))) + ((loop-vars) (adjoin-loop-vars loop-vars def-vars)) + ((fresh-vars) (map (lambda (_) (fresh-var)) def-vars)) + ((cps pre-header-label) + (hoist-exp src exp def-names fresh-vars pre-header-label)) + ((cont) (build-cont + ($kargs names vars + ($continue k src ($values fresh-vars)))))) + (values cps cont loop-vars (intmap-remove loop-effects label) + pre-header-label always-reached?))))) + (($ $kreceive ($ $arity req () rest) kargs) + (match (intmap-ref cps kargs) + (($ $kargs def-names def-vars) + (cond + ((not (loop-invariant? label exp loop-vars loop-effects + always-reached?)) + (let* ((loop-vars (adjoin-loop-vars loop-vars def-vars)) + (cont (build-cont + ($kargs names vars + ($continue k src ,exp))))) + (values cps cont loop-vars loop-effects pre-header-label #f))) + ((trivial-intset (intmap-ref preds k)) + (let ((loop-effects + (intmap-remove (intmap-remove loop-effects label) k))) + (let-values + (((cps pre-header-label) + (hoist-call src exp req rest def-names def-vars + pre-header-label)) + ((cont) (build-cont + ($kargs names vars + ($continue kargs src ($values ())))))) + (values cps cont loop-vars loop-effects + pre-header-label always-reached?)))) + (else + (let*-values + (((loop-vars) (adjoin-loop-vars loop-vars def-vars)) + ((fresh-vars) (map (lambda (_) (fresh-var)) def-vars)) + ((cps pre-header-label) + (hoist-call src exp req rest def-names fresh-vars + pre-header-label)) + ((cont) (build-cont + ($kargs names vars + ($continue kargs src + ($values fresh-vars)))))) + (values cps cont loop-vars loop-effects + pre-header-label always-reached?))))))))) + (($ $branch) + (let* ((cont (build-cont ($kargs names vars ,term))) + (always-reached? #f)) + (values cps cont loop-vars loop-effects + pre-header-label always-reached?)))))) (($ $kreceive ($ $arity req () rest) kargs) (values cps cont loop-vars loop-effects pre-header-label always-reached?)))) @@ -252,9 +256,9 @@ (define (rename-back-edges cont) (define (rename label) (if (eqv? label entry) header-label label)) (rewrite-cont cont - (($ $kargs names vars ($ $continue kf src ($ $branch kt exp))) + (($ $kargs names vars ($ $branch kf kt src op param args)) ($kargs names vars - ($continue (rename kf) src ($branch (rename kt) ,exp)))) + ($branch (rename kf) (rename kt) src op param args))) (($ $kargs names vars ($ $continue k src exp)) ($kargs names vars ($continue (rename k) src ,exp))) diff --git a/module/language/cps/peel-loops.scm b/module/language/cps/peel-loops.scm index c93bbc8c6..0f2345130 100644 --- a/module/language/cps/peel-loops.scm +++ b/module/language/cps/peel-loops.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -141,16 +141,20 @@ ($call (rename-var proc) ,(map rename-var args))) (($ $callk k proc args) ($callk k (rename-var proc) ,(map rename-var args))) - (($ $branch kt ($ $primcall name param args)) - ($branch (rename-label kt) ($primcall name param ,(map rename-var args)))) (($ $primcall name param args) ($primcall name param ,(map rename-var args))) (($ $prompt escape? tag handler) ($prompt escape? (rename-var tag) (rename-label handler))))) + (define (rename-term term) + (rewrite-term term + (($ $continue k src exp) + ($continue (rename-label k) src ,(rename-exp exp))) + (($ $branch kf kt src op param args) + ($branch (rename-label kf) (rename-label kt) src + op param ,(map rename-var args))))) (rewrite-cont cont - (($ $kargs names vars ($ $continue k src exp)) - ($kargs names (map rename-var vars) - ($continue (rename-label k) src ,(rename-exp exp)))) + (($ $kargs names vars term) + ($kargs names (map rename-var vars) ,(rename-term term))) (($ $kreceive ($ $arity req () rest) kargs) ($kreceive req rest (rename-label kargs))))) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 8765ee207..afd6f71a3 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -384,8 +384,7 @@ ($continue krecv src ($call proc args)))) (let$ body (resolve-prim name kproc src)) (setk label ($kargs names vars ,body)))))) - (($ $kargs names vars - ($ $continue kf src ($ $branch kt ($ $primcall name param args)))) + (($ $kargs names vars ($ $branch kf kt src name param args)) (let () (define (u11? val) (<= 0 val #x7ff)) (define (u12? val) (<= 0 val #xfff)) @@ -404,8 +403,7 @@ (letv c) (letk kconst ($kargs ('c) (c) - ($continue kf src - ($branch kt ($primcall 'op* #f (out ...)))))) + ($branch kf kt src 'op* #f (out ...)))) (setk label ($kargs names vars ($continue kconst src diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm index fdd12717e..ba565c1c1 100644 --- a/module/language/cps/renumber.scm +++ b/module/language/cps/renumber.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -85,16 +85,18 @@ (call-with-values (lambda () (match (intmap-ref conts k) - (($ $kargs names syms ($ $continue k src exp)) - (match exp - (($ $prompt escape? tag handler) - (visit2 k handler order visited)) - (($ $branch kt) - (if (visit-kf-first? k kt) - (visit2 k kt order visited) - (visit2 kt k order visited))) - (_ - (visit k order visited)))) + (($ $kargs names syms term) + (match term + (($ $continue k src exp) + (match exp + (($ $prompt escape? tag handler) + (visit2 k handler order visited)) + (_ + (visit k order visited)))) + (($ $branch kf kt) + (if (visit-kf-first? kf kt) + (visit2 kf kt order visited) + (visit2 kt kf order visited))))) (($ $kreceive arity k) (visit k order visited)) (($ $kclause arity kbody kalt) (if kalt @@ -177,8 +179,6 @@ ($call (rename-var proc) ,(map rename-var args))) (($ $callk k proc args) ($callk (rename-label k) (rename-var proc) ,(map rename-var args))) - (($ $branch kt exp) - ($branch (rename-label kt) ,(rename-exp exp))) (($ $primcall name param args) ($primcall name param ,(map rename-var args))) (($ $prompt escape? tag handler) @@ -200,18 +200,23 @@ out new-k (rewrite-cont (intmap-ref conts old-k) - (($ $kargs names syms ($ $continue k src exp)) - ($kargs names (map rename-var syms) - ($continue (rename-label k) src ,(rename-exp exp)))) - (($ $kreceive ($ $arity req () rest () #f) k) - ($kreceive req rest (rename-label k))) - (($ $ktail) - ($ktail)) - (($ $kfun src meta self tail clause) - ($kfun src meta (rename-var self) (rename-label tail) - (and clause (rename-label clause)))) - (($ $kclause arity body alternate) - ($kclause ,(rename-arity arity) (rename-label body) - (and alternate (rename-label alternate))))))) + (($ $kargs names syms term) + ($kargs names (map rename-var syms) + ,(rewrite-term term + (($ $continue k src exp) + ($continue (rename-label k) src ,(rename-exp exp))) + (($ $branch kf kt src op param args) + ($branch (rename-label kf) (rename-label kt) src + op param ,(map rename-var args)))))) + (($ $kreceive ($ $arity req () rest () #f) k) + ($kreceive req rest (rename-label k))) + (($ $ktail) + ($ktail)) + (($ $kfun src meta self tail clause) + ($kfun src meta (rename-var self) (rename-label tail) + (and clause (rename-label clause)))) + (($ $kclause arity body alternate) + ($kclause ,(rename-arity arity) (rename-label body) + (and alternate (rename-label alternate))))))) label-map empty-intmap)))) diff --git a/module/language/cps/rotate-loops.scm b/module/language/cps/rotate-loops.scm index 93ac0b3cc..dbc2f9e5e 100644 --- a/module/language/cps/rotate-loops.scm +++ b/module/language/cps/rotate-loops.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -55,6 +55,7 @@ #:use-module (language cps utils) #:use-module (language cps intmap) #:use-module (language cps intset) + #:use-module (language cps with-cps) #:export (rotate-loops)) (define (loop-successors scc succs) @@ -79,7 +80,8 @@ (match (intmap-ref cps entry-label) ((and entry-cont ($ $kargs entry-names entry-vars - ($ $continue entry-kf entry-src ($ $branch entry-kt entry-exp)))) + ($ $branch entry-kf entry-kt entry-src + entry-op entry-param entry-args))) (let* ((exit-if-true? (intset-ref body-labels entry-kf)) (loop-exits (find-exits body-labels succs)) (exit (if exit-if-true? entry-kt entry-kf)) @@ -93,49 +95,50 @@ (map (lambda (_) (fresh-var)) entry-vars)) (define (make-trampoline k src values) (build-cont ($kargs () () ($continue k src ($values values))))) - (define (replace-exit k trampoline) - (if (eqv? k exit) trampoline k)) - (define (rename-exp exp vars) - (define (rename-var var) - (match (list-index entry-vars var) - (#f var) - (idx (list-ref vars idx)))) - (rewrite-exp exp - ((or ($ $const) ($ $prim) ($ $closure)) ,exp) - (($ $values args) - ($values ,(map rename-var args))) - (($ $call proc args) - ($call (rename-var proc) ,(map rename-var args))) - (($ $callk k proc args) - ($callk k (rename-var proc) ,(map rename-var args))) - (($ $branch kt ($ $primcall name param args)) - ($branch kt ($primcall name param ,(map rename-var args)))) - (($ $primcall name param args) - ($primcall name param ,(map rename-var args))) - (($ $prompt escape? tag handler) - ($prompt escape? (rename-var tag) handler)))) - (define (attach-trampoline label src names vars args) - (let* ((trampoline-out-label (fresh-label)) - (trampoline-out-cont - (make-trampoline join-label src args)) - (trampoline-in-label (fresh-label)) - (trampoline-in-cont - (make-trampoline new-entry-label src args)) - (kf (if exit-if-true? trampoline-in-label trampoline-out-label)) - (kt (if exit-if-true? trampoline-out-label trampoline-in-label)) - (cont (build-cont - ($kargs names vars - ($continue kf entry-src - ($branch kt ,(rename-exp entry-exp args)))))) - (cps (intmap-replace! cps label cont)) - (cps (intmap-add! cps trampoline-in-label trampoline-in-cont))) - (intmap-add! cps trampoline-out-label trampoline-out-cont))) + (define (rename-var var replacements) + "If VAR refers to a member of ENTRY-VARS, replace with a +corresponding var from REPLACEMENTS; otherwise return VAR." + (match (list-index entry-vars var) + (#f var) + (idx (list-ref replacements idx)))) + (define (rename-vars vars replacements) + (map (lambda (var) (rename-var var replacements)) vars)) + (define (rename-term term replacements) + (define (rename arg) (rename-var arg replacements)) + (define (rename* arg) (rename-vars arg replacements)) + (rewrite-term term + (($ $continue k src exp) + ($continue k src + ,(rewrite-exp exp + ((or ($ $const) ($ $prim) ($ $closure)) ,exp) + (($ $values args) + ($values ,(rename* args))) + (($ $call proc args) + ($call (rename proc) ,(rename* args))) + (($ $callk k proc args) + ($callk k (rename proc) ,(rename* args))) + (($ $primcall name param args) + ($primcall name param ,(rename* args))) + (($ $prompt escape? tag handler) + ($prompt escape? (rename tag) handler))))) + (($ $branch kf kt src op param args) + ($branch kf kt src op param ,(rename* args))))) + (define (attach-trampoline cps label src names vars args) + (with-cps cps + (letk ktramp-out ,(make-trampoline join-label src args)) + (letk ktramp-in ,(make-trampoline new-entry-label src args)) + (setk label + ($kargs names vars + ($branch (if exit-if-true? ktramp-in ktramp-out) + (if exit-if-true? ktramp-out ktramp-in) + entry-src + entry-op entry-param ,(rename-vars entry-args args)))))) ;; Rewrite the targets of the entry branch to go to ;; trampolines. One will pass values out of the loop, and ;; one will pass values into the loop. (let* ((pre-header-vars (make-fresh-vars)) (body-vars (make-fresh-vars)) - (cps (attach-trampoline entry-label entry-src + (cps (attach-trampoline cps entry-label entry-src entry-names pre-header-vars pre-header-vars)) (new-entry-cont (build-cont @@ -148,44 +151,38 @@ (cond ((intset-ref back-edges label) (match (intmap-ref cps label) - (($ $kargs names vars ($ $continue _ src exp)) - (match (rename-exp exp body-vars) - (($ $values args) - (attach-trampoline label src names vars args)) - (exp + (($ $kargs names vars term) + (match (rename-term term body-vars) + (($ $continue _ src ($ $values args)) + (attach-trampoline cps label src names vars args)) + (($ $continue _ src exp) (let* ((args (make-fresh-vars)) (bind-label (fresh-label)) (edge* (build-cont ($kargs names vars ($continue bind-label src ,exp)))) (cps (intmap-replace! cps label edge*)) - ;; attach-trampoline uses intmap-replace!. + ;; attach-trampoline uses setk. (cps (intmap-add! cps bind-label #f))) - (attach-trampoline bind-label src + (attach-trampoline cps bind-label src entry-names args args))))))) ((intset-ref loop-exits label) (match (intmap-ref cps label) - (($ $kargs names vars - ($ $continue kf src ($ $branch kt exp))) - (let* ((trampoline-out-label (fresh-label)) - (trampoline-out-cont - (make-trampoline join-label src body-vars)) - (kf (if (eqv? kf exit) trampoline-out-label kf)) - (kt (if (eqv? kt exit) trampoline-out-label kt)) - (cont (build-cont - ($kargs names vars - ($continue kf src - ($branch kt ,(rename-exp exp body-vars)))))) - (cps (intmap-replace! cps label cont))) - (intmap-add! cps trampoline-out-label trampoline-out-cont))))) + (($ $kargs names vars ($ $branch kf kt src op param args)) + (with-cps cps + (letk ktramp-out ,(make-trampoline join-label src body-vars)) + (setk label + ($kargs names vars + ($branch (if (eqv? kf exit) ktramp-out kf) + (if (eqv? kt exit) ktramp-out kt) + src + op param ,(rename-vars args body-vars)))))))) (else (match (intmap-ref cps label) - (($ $kargs names vars ($ $continue k src exp)) - (let ((cont (build-cont - ($kargs names vars - ($continue k src - ,(rename-exp exp body-vars)))))) - (intmap-replace! cps label cont))) + (($ $kargs names vars term) + (with-cps cps + (setk label ($kargs names vars + ,(rename-term term body-vars))))) (($ $kreceive) cps))))) (intset-remove body-labels entry-label) cps)))))) @@ -195,10 +192,8 @@ (intset-fold (lambda (label rotate?) (match (intmap-ref cps label) (($ $kreceive) #f) - (($ $kargs _ _ ($ $continue _ _ exp)) - (match exp - (($ $branch) #f) - (_ rotate?))))) + (($ $kargs _ _ ($ $branch)) #f) + (($ $kargs _ _ ($ $continue)) rotate?))) edges #t)) (let* ((succs (compute-successors cps kfun)) (preds (invert-graph succs))) diff --git a/module/language/cps/self-references.scm b/module/language/cps/self-references.scm index e874f0e62..f1ffc4afd 100644 --- a/module/language/cps/self-references.scm +++ b/module/language/cps/self-references.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -36,42 +36,42 @@ (define (subst var) (intmap-ref env var (lambda (var) var))) - (define (rename-exp label cps names vars k src exp) - (let ((exp (rewrite-exp exp - ((or ($ $const) ($ $prim)) ,exp) - (($ $call proc args) - ($call (subst proc) ,(map subst args))) - (($ $callk k proc args) - ($callk k (subst proc) ,(map subst args))) - (($ $primcall name param args) - ($primcall name param ,(map subst args))) - (($ $branch k ($ $primcall name param args)) - ($branch k ($primcall name param ,(map subst args)))) - (($ $values args) - ($values ,(map subst args))) - (($ $prompt escape? tag handler) - ($prompt escape? (subst tag) handler))))) - (intmap-replace! cps label - (build-cont - ($kargs names vars ($continue k src ,exp)))))) + (define (rename-exp exp) + (rewrite-exp exp + ((or ($ $const) ($ $prim)) ,exp) + (($ $call proc args) + ($call (subst proc) ,(map subst args))) + (($ $callk k proc args) + ($callk k (subst proc) ,(map subst args))) + (($ $primcall name param args) + ($primcall name param ,(map subst args))) + (($ $values args) + ($values ,(map subst args))) + (($ $prompt escape? tag handler) + ($prompt escape? (subst tag) handler)))) - (define (visit-exp cps label names vars k src exp) - (match exp - (($ $fun label) + (define (rename-term term) + (rewrite-term term + (($ $continue k src exp) + ($continue k src ,(rename-exp exp))) + (($ $branch kf kt src op param args) + ($branch kf kt src op param ,(map subst args))))) + + (define (visit-label label cps) + (match (intmap-ref cps label) + (($ $kargs _ _ ($ $continue k src ($ $fun label))) (resolve-self-references cps label env)) - (($ $rec names vars (($ $fun labels) ...)) + (($ $kargs _ _ ($ $continue k src + ($ $rec names vars (($ $fun labels) ...)))) (fold (lambda (label var cps) (match (intmap-ref cps label) (($ $kfun src meta self) (resolve-self-references cps label (intmap-add env var self))))) cps labels vars)) - (_ (rename-exp label cps names vars k src exp)))) - - (intset-fold (lambda (label cps) - (match (intmap-ref cps label) - (($ $kargs names vars ($ $continue k src exp)) - (visit-exp cps label names vars k src exp)) - (_ cps))) - (compute-function-body cps label) - cps)) + (($ $kargs names vars term) + (intmap-replace! cps label + (build-cont ($kargs names vars ,(rename-term term))))) + (_ cps))) + + (intset-fold visit-label (compute-function-body cps label) cps)) diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index 46255692f..f546583d4 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -78,10 +78,10 @@ (ref* args)) (($ $values args) (ref* args)) - (($ $branch kt ($ $primcall name param args)) - (ref* args)) (($ $prompt escape? tag handler) (ref tag)))) + (($ $kargs _ _ ($ $branch kf kt src op param args)) + (ref* args)) (_ (values single multiple)))) (let*-values (((single multiple) (values empty-intset empty-intset)) @@ -144,15 +144,15 @@ (lambda (label cont) (and (not (intset-ref label-set label)) (rewrite-cont cont - (($ $kargs names syms ($ $continue kf src ($ $branch kt exp))) + (($ $kargs names syms ($ $branch kf kt src op param args)) ($kargs names syms - ($continue (subst kf) src ($branch (subst kt) ,exp)))) + ($branch (subst kf) (subst kt) src op param args))) (($ $kargs names syms ($ $continue k src ($ $const val))) ,(match (intmap-ref conts k) (($ $kargs (_) ((? (lambda (var) (intset-ref singly-used var)) var)) - ($ $continue kf _ ($ $branch kt ($ $primcall 'false? #f (var))))) + ($ $branch kf kt _ 'false? #f (var))) (build-cont ($kargs names syms ($continue (subst (if val kf kt)) src ($values ()))))) @@ -189,7 +189,11 @@ (($ $ktail) (ref0)) (($ $kclause arity kbody kalt) (ref2 kbody kalt)) (($ $kargs names syms ($ $continue k src exp)) - (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) + (match exp + (($ $prompt _ _ handler) (ref2 k handler)) + (_ (ref1 k)))) + (($ $kargs names syms ($ $branch kf kt)) + (ref2 kf kt)))) (let*-values (((single multiple) (values empty-intset empty-intset)) ((single multiple) (intset-fold add-ref body single multiple))) (intset-subtract (persistent-intset single) @@ -235,35 +239,37 @@ (match (intmap-ref var-map var (lambda (_) #f)) (#f var) (val (subst val)))) - (define (transform-exp label k src exp) + (define (transform-term label term) (if (intset-ref label-set label) - (match (intmap-ref conts k) - (($ $kargs _ _ ($ $continue k* src* exp*)) - (transform-exp k k* src* exp*))) - (build-term - ($continue k src - ,(rewrite-exp exp - ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) - ,exp) - (($ $call proc args) - ($call (subst proc) ,(map subst args))) - (($ $callk k proc args) - ($callk k (subst proc) ,(map subst args))) - (($ $primcall name param args) - ($primcall name param ,(map subst args))) - (($ $values args) - ($values ,(map subst args))) - (($ $branch kt ($ $primcall name param args)) - ($branch kt ($primcall name param ,(map subst args)))) - (($ $prompt escape? tag handler) - ($prompt escape? (subst tag) handler))))))) + (match term + (($ $continue k) + (match (intmap-ref conts k) + (($ $kargs _ _ term) + (transform-term k term))))) + (rewrite-term term + (($ $continue k src exp) + ($continue k src + ,(rewrite-exp exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) + ,exp) + (($ $call proc args) + ($call (subst proc) ,(map subst args))) + (($ $callk k proc args) + ($callk k (subst proc) ,(map subst args))) + (($ $primcall name param args) + ($primcall name param ,(map subst args))) + (($ $values args) + ($values ,(map subst args))) + (($ $prompt escape? tag handler) + ($prompt escape? (subst tag) handler))))) + (($ $branch kf kt src op param args) + ($branch kf kt src op param ,(map subst args)))))) (transform-conts (lambda (label cont) - (match cont - (($ $kargs names syms ($ $continue k src exp)) - (build-cont - ($kargs names syms ,(transform-exp label k src exp)))) - (_ cont))) + (rewrite-cont cont + (($ $kargs names syms term) + ($kargs names syms ,(transform-term label term))) + (_ ,cont))) conts))) (define (simplify conts) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index d9963e3f8..8abb0eafb 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -1,6 +1,6 @@ ;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -154,12 +154,12 @@ by a label, respectively." (return (get-defs k) (intset-add (vars->intset args) proc))) (($ $primcall name param args) (return (get-defs k) (vars->intset args))) - (($ $branch kt ($ $primcall name param args)) - (return empty-intset (vars->intset args))) (($ $values args) (return (get-defs k) (vars->intset args))) (($ $prompt escape? tag handler) (return empty-intset (intset tag))))) + (($ $kargs _ _ ($ $branch kf kt src op param args)) + (return empty-intset (vars->intset args))) (($ $kclause arity body alt) (return (get-defs body) empty-intset)) (($ $kreceive arity kargs) @@ -238,10 +238,10 @@ body continuation in the prompt." (visit-cont handler level (visit-cont k (1+ level) labels))) (($ $kargs names syms ($ $continue k src ($ $primcall 'unwind))) (visit-cont k (1- level) labels)) - (($ $kargs names syms ($ $continue k src ($ $branch kt))) - (visit-cont k level (visit-cont kt level labels))) (($ $kargs names syms ($ $continue k src exp)) - (visit-cont k level labels))))))))))) + (visit-cont k level labels)) + (($ $kargs names syms ($ $branch kf kt)) + (visit-cont kf level (visit-cont kt level labels)))))))))))) (define (visit-prompt label handler succs) (let ((body (compute-prompt-body label))) (define (out-or-back-edge? label) @@ -629,14 +629,14 @@ are comparable with eqv?. A tmp slot may be used." (max (+ (get-proc-slot label) nargs) size))) (define (measure-cont label cont size) (match cont - (($ $kargs names vars ($ $continue k src exp)) + (($ $kargs names vars term) (let ((size (max-size* vars size))) - (match exp - (($ $call proc args) + (match term + (($ $continue _ _ ($ $call proc args)) (call-size label (1+ (length args)) size)) - (($ $callk _ proc args) + (($ $continue _ _ ($ $callk _ proc args)) (call-size label (1+ (length args)) size)) - (($ $values args) + (($ $continue _ _ ($ $values args)) (shuffle-size (get-shuffles label) size)) (_ size)))) (($ $kreceive) @@ -744,6 +744,8 @@ are comparable with eqv?. A tmp slot may be used." (intmap-fold (lambda (label cont representations) (match cont + (($ $kargs _ _ ($ $branch)) + representations) (($ $kargs _ _ ($ $continue k _ exp)) (match (get-defs k) (() representations) @@ -970,16 +972,16 @@ are comparable with eqv?. A tmp slot may be used." (define (allocate-cont label cont slots call-allocs) (match cont - (($ $kargs names vars ($ $continue k src exp)) + (($ $kargs names vars term) (let-values (((slots live) (allocate-defs label vars slots))) - (match exp - (($ $call proc args) + (match term + (($ $continue k src ($ $call proc args)) (allocate-call label k (cons proc args) slots call-allocs live)) - (($ $callk _ proc args) + (($ $continue k src ($ $callk _ proc args)) (allocate-call label k (cons proc args) slots call-allocs live)) - (($ $values args) + (($ $continue k src ($ $values args)) (allocate-values label k args slots call-allocs)) - (($ $prompt escape? tag handler) + (($ $continue k src ($ $prompt escape? tag handler)) (allocate-prompt label k handler slots call-allocs)) (_ (values slots call-allocs))))) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index d8ec5e6b4..73fd00427 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2015, 2016, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2015, 2016, 2017, 2018 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 @@ -146,9 +146,7 @@ (define (specialize-comparison cps kf kt src op a b unbox-a unbox-b) (with-cps cps (letv a* b*) - (letk kop ($kargs ('b) (b*) - ($continue kf src - ($branch kt ($primcall op #f (a* b*)))))) + (letk kop ($kargs ('b) (b*) ($branch kf kt src op #f (a* b*)))) (let$ unbox-b-body (unbox-b kop src b)) (letk kunbox-b ($kargs ('a) (a*) ,unbox-b-body)) ($ (unbox-a kunbox-b src a)))) @@ -157,9 +155,7 @@ unbox-a) (with-cps cps (letv ia) - (letk kop ($kargs ('ia) (ia) - ($continue kf src - ($branch kt ($primcall op imm (ia)))))) + (letk kop ($kargs ('ia) (ia) ($branch kf kt src op imm (ia)))) ($ (unbox-a kop src a)))) (define (specialize-comparison/s64-integer cps kf kt src op a-s64 b-int @@ -168,23 +164,19 @@ (with-cps cps (letv a b sunk) (letk kheap ($kargs ('sunk) (sunk) - ($continue kf src - ($branch kt ($primcall op #f (sunk b-int)))))) + ($branch kf kt src op #f (sunk b-int)))) ;; Re-box the variable. FIXME: currently we use a specially ;; marked s64->scm to avoid CSE from hoisting the allocation ;; again. Instead we should just use a-s64 directly and implement ;; an allocation sinking pass that should handle this.. (let$ rebox-a-body (rebox-a kheap src a)) (letk kretag ($kargs () () ,rebox-a-body)) - (letk kb ($kargs ('b) (b) - ($continue kf src - ($branch kt ($primcall s64-op #f (a b)))))) + (letk kb ($kargs ('b) (b) ($branch kf kt src s64-op #f (a b)))) (letk kfix ($kargs () () ($continue kb src ($primcall 'untag-fixnum #f (b-int))))) (letk ka ($kargs ('a) (a) - ($continue kretag src - ($branch kfix ($primcall 'fixnum? #f (b-int)))))) + ($branch kretag kfix src 'fixnum? #f (b-int)))) ($ (unbox-a ka src a-s64))))) (define (specialize-comparison/integer-s64 cps kf kt src op a-int b-s64 @@ -196,8 +188,7 @@ (with-cps cps (letv a b sunk) (letk kheap ($kargs ('sunk) (sunk) - ($continue kf src - ($branch kt ($primcall '< #f (a-int sunk)))))) + ($branch kf kt src '< #f (a-int sunk)))) ;; FIXME: We should just use b-s64 directly and implement an ;; allocation sinking pass so that the box op that creates b-64 ;; should float down here. Instead, for now we just rebox the @@ -205,25 +196,19 @@ ;; CSE. (let$ rebox-b-body (rebox-b kheap src b)) (letk kretag ($kargs () () ,rebox-b-body)) - (letk ka ($kargs ('a) (a) - ($continue kf src - ($branch kt ($primcall 's64-< #f (a b)))))) + (letk ka ($kargs ('a) (a) ($branch kf kt src 's64-< #f (a b)))) (letk kfix ($kargs () () ($continue ka src ($primcall 'untag-fixnum #f (a-int))))) (letk kb ($kargs ('b) (b) - ($continue kretag src - ($branch kfix ($primcall 'fixnum? #f (a-int)))))) + ($branch kretag kfix src 'fixnum? #f (a-int)))) ($ (unbox-b kb src b-s64)))))) (define (specialize-comparison/immediate-s64-integer cps kf kt src op a b-int compare-integers) (with-cps cps (letv b sunk) - (let$ sunk-compare-exp (compare-integers sunk)) - (letk kheap ($kargs ('sunk) (sunk) - ($continue kf src - ($branch kt ,sunk-compare-exp)))) + (letk kheap ($kargs ('sunk) (sunk) ,(compare-integers kf kt src sunk))) ;; Re-box the variable. FIXME: currently we use a specially marked ;; load-const to avoid CSE from hoisting the constant. Instead we ;; should just use a $const directly and implement an allocation @@ -232,14 +217,11 @@ ($continue kheap src ($primcall 'load-const/unlikely a ())))) (letk kb ($kargs ('b) (b) - ($continue kf src - ($branch kt ($primcall op a (b)))))) + ($branch kf kt src op a (b)))) (letk kfix ($kargs () () ($continue kb src ($primcall 'untag-fixnum #f (b-int))))) - (build-term - ($continue kretag src - ($branch kfix ($primcall 'fixnum? #f (b-int))))))) + (build-term ($branch kretag kfix src 'fixnum? #f (b-int))))) (define (sigbits-union x y) (and x y (logior x y))) @@ -324,38 +306,40 @@ BITS indicating the significant bits needed for a variable. BITS may be (match (intmap-ref cps label) (($ $kfun src meta self) (add-def out self)) - (($ $kargs names vars ($ $continue k src exp)) + (($ $kargs names vars term) (let ((out (add-defs out vars))) - (match exp - ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec)) - ;; No uses, so no info added to sigbits. - out) - (($ $values args) - (match (intmap-ref cps k) - (($ $kargs _ vars) - (if (intset-ref visited k) - (fold (lambda (arg var out) - (intmap-add out arg (intmap-ref out var) - sigbits-union)) - out args vars) - out)) - (($ $ktail) - (add-unknown-uses out args)))) - (($ $call proc args) - (add-unknown-use (add-unknown-uses out args) proc)) - (($ $callk label proc args) - (add-unknown-use (add-unknown-uses out args) proc)) - (($ $branch kt ($ $primcall name param args)) - (add-unknown-uses out args)) - (($ $primcall name param args) - (let ((h (significant-bits-handler name))) - (if h - (match (intmap-ref cps k) - (($ $kargs _ defs) - (h label types out param args defs))) + (match term + (($ $continue k src exp) + (match exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec)) + ;; No uses, so no info added to sigbits. + out) + (($ $values args) + (match (intmap-ref cps k) + (($ $kargs _ vars) + (if (intset-ref visited k) + (fold (lambda (arg var out) + (intmap-add out arg (intmap-ref out var) + sigbits-union)) + out args vars) + out)) + (($ $ktail) (add-unknown-uses out args)))) - (($ $prompt escape? tag handler) - (add-unknown-use out tag))))) + (($ $call proc args) + (add-unknown-use (add-unknown-uses out args) proc)) + (($ $callk label proc args) + (add-unknown-use (add-unknown-uses out args) proc)) + (($ $primcall name param args) + (let ((h (significant-bits-handler name))) + (if h + (match (intmap-ref cps k) + (($ $kargs _ defs) + (h label types out param args defs))) + (add-unknown-uses out args)))) + (($ $prompt escape? tag handler) + (add-unknown-use out tag)))) + (($ $branch kf kt src op param args) + (add-unknown-uses out args))))) (_ out))))))))) (define (specialize-operations cps) @@ -623,9 +607,8 @@ BITS indicating the significant bits needed for a variable. BITS may be (let ((imm-op (match op ('= 's64-imm-=) ('< 'imm-s64-<)))) (specialize-comparison/immediate-s64-integer cps kf kt src imm-op a b - (lambda (cps a) - (with-cps cps - (build-exp ($primcall op #f (a b))))))))) + (lambda (kf kt src a) + (build-term ($branch kf kt src op #f (a b)))))))) (else (specialize-comparison/s64-integer cps kf kt src op a b (unbox-s64 a) @@ -637,9 +620,8 @@ BITS indicating the significant bits needed for a variable. BITS may be (let ((imm-op (match op ('= 's64-imm-=) ('< 's64-imm-<)))) (specialize-comparison/immediate-s64-integer cps kf kt src imm-op b a - (lambda (cps b) - (with-cps cps - (build-exp ($primcall op #f (a b))))))))) + (lambda (kf kt src b) + (build-term ($branch kf kt src op #f (a b)))))))) (else (specialize-comparison/integer-s64 cps kf kt src op a b (unbox-s64 b) @@ -654,8 +636,7 @@ BITS indicating the significant bits needed for a variable. BITS may be (sigbits (compute-significant-bits cps types label))) (values cps types sigbits))) - (($ $kargs names vars - ($ $continue k src ($ $primcall op param args))) + (($ $kargs names vars ($ $continue k src ($ $primcall op param args))) (call-with-values (lambda () (specialize-primcall cps k src op param args)) (lambda (cps term) @@ -665,8 +646,7 @@ BITS indicating the significant bits needed for a variable. BITS may be cps) types sigbits)))) - (($ $kargs names vars - ($ $continue kf src ($ $branch kt ($ $primcall op param args)))) + (($ $kargs names vars ($ $branch kf kt src op param args)) (call-with-values (lambda () (specialize-branch cps kf kt src op param args)) (lambda (cps term) diff --git a/module/language/cps/split-rec.scm b/module/language/cps/split-rec.scm index c733c38c0..2f60b9948 100644 --- a/module/language/cps/split-rec.scm +++ b/module/language/cps/split-rec.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -70,29 +70,31 @@ references." (intset-fold (lambda (label defs uses) (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) + (($ $kargs names vars term) (values (add-defs vars defs) - (match exp - ((or ($ $const) ($ $prim)) uses) - (($ $fun kfun) - (intset-union (persistent-intset uses) - (intmap-ref free kfun))) - (($ $rec names vars (($ $fun kfun) ...)) - (fold (lambda (kfun uses) - (intset-union (persistent-intset uses) - (intmap-ref free kfun))) - uses kfun)) - (($ $values args) - (add-uses args uses)) - (($ $call proc args) - (add-use proc (add-uses args uses))) - (($ $branch kt ($ $primcall name param args)) - (add-uses args uses)) - (($ $primcall name param args) - (add-uses args uses)) - (($ $prompt escape? tag handler) - (add-use tag uses))))) + (match term + (($ $continue k src exp) + (match exp + ((or ($ $const) ($ $prim)) uses) + (($ $fun kfun) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + (($ $rec names vars (($ $fun kfun) ...)) + (fold (lambda (kfun uses) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + uses kfun)) + (($ $values args) + (add-uses args uses)) + (($ $call proc args) + (add-use proc (add-uses args uses))) + (($ $primcall name param args) + (add-uses args uses)) + (($ $prompt escape? tag handler) + (add-use tag uses)))) + (($ $branch kf kt src op param args) + (add-uses args uses))))) (($ $kfun src meta self) (values (add-def self defs) uses)) (_ (values defs uses)))) diff --git a/module/language/cps/type-checks.scm b/module/language/cps/type-checks.scm index d7503c954..029acdfcd 100644 --- a/module/language/cps/type-checks.scm +++ b/module/language/cps/type-checks.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -50,14 +50,12 @@ KFUN where we can prove that no assertion will be raised at run-time." ((causes-all-effects? fx) effects) ((causes-effect? fx &type-check) (match (intmap-ref conts label) - (($ $kargs _ _ exp) - (match exp - (($ $continue k src ($ $primcall name param args)) - (visit-primcall effects fx label name param args)) - (($ $continue k src - ($ $branch _ ($ $primcall name param args))) - (visit-primcall effects fx label name param args)) - (_ effects))) + (($ $kargs names vars + ($ $continue k src ($ $primcall name param args))) + (visit-primcall effects fx label name param args)) + (($ $kargs names vars + ($ $branch kf kt src name param args)) + (visit-primcall effects fx label name param args)) (_ effects))) (else effects)))) types diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index f76c82e2a..3ac1eae26 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -1,5 +1,5 @@ ;;; Abstract constant folding on CPS -;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015, 2017, 2018 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 License as @@ -355,8 +355,7 @@ (letk kt ($kargs () () ($continue k src ($const #t)))) (letk kf ($kargs () () ($continue k src ($const #f)))) (letk ku64 ($kargs (#f) (u64) - ($continue kt src - ($branch kf ($primcall 's64-imm-= 0 (u64)))))) + ($branch kt kf src 's64-imm-= 0 (u64)))) (letk kand ($kargs (#f) (res) ($continue ku64 src ($primcall 'untag-fixnum #f (res))))) (letk kmask ($kargs (#f) (mask) @@ -527,32 +526,32 @@ ($kargs names vars ($continue (if v kt kf) src ($values ()))))))))))))))) - (define (visit-expression cps label names vars k src exp) - (match exp - (($ $primcall name param args) - ;; We might be able to fold primcalls that define a value. - (match (intmap-ref cps k) - (($ $kargs (_) (def)) - (or (fold-primcall cps label names vars k src name param args def) - (reduce-primcall cps label names vars k src name param args))) - (_ - (reduce-primcall cps label names vars k src name param args)))) - (($ $branch kt ($ $primcall name param args)) - ;; We might be able to fold primcalls that branch. - (match args - ((x) - (or (fold-unary-branch cps label names vars k kt src name param x) - cps)) - ((x y) - (or (fold-binary-branch cps label names vars k kt src name param x y) - cps)))) - (_ cps))) + (define (visit-primcall cps label names vars k src name param args) + ;; We might be able to fold primcalls that define a value. + (match (intmap-ref cps k) + (($ $kargs (_) (def)) + (or (fold-primcall cps label names vars k src name param args def) + (reduce-primcall cps label names vars k src name param args))) + (_ + (reduce-primcall cps label names vars k src name param args)))) + (define (visit-branch cps label names vars kf kt src name param args) + ;; We might be able to fold primcalls that branch. + (match args + ((x) + (or (fold-unary-branch cps label names vars kf kt src name param x) + cps)) + ((x y) + (or (fold-binary-branch cps label names vars kf kt src name param x y) + cps)))) (let lp ((label start) (cps cps)) (if (<= label end) (lp (1+ label) (match (intmap-ref cps label) - (($ $kargs names vars ($ $continue k src exp)) - (visit-expression cps label names vars k src exp)) + (($ $kargs names vars ($ $continue k src + ($ $primcall op param args))) + (visit-primcall cps label names vars k src op param args)) + (($ $kargs names vars ($ $branch kf kt src op param args)) + (visit-branch cps label names vars kf kt src op param args)) (_ cps))) cps)))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 278c4e1d7..bb3462463 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1,5 +1,5 @@ ;;; Type analysis on CPS -;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015, 2017, 2018 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 License as @@ -1777,8 +1777,9 @@ minimum, and maximum." (match cont (($ $kargs _ _ ($ $continue k src exp)) (match exp - ((or ($ $branch) ($ $prompt)) 2) + (($ $prompt) 2) (_ 1))) + (($ $kargs _ _ ($ $branch)) 2) (($ $kfun src meta self tail clause) (if clause 1 0)) (($ $kclause arity body alt) (if alt 2 1)) (($ $kreceive) 1) @@ -1915,11 +1916,6 @@ maximum, where type is a bitset as a fixnum." (values (append changed0 changed1) typev))) ;; Each of these branches must propagate to its successors. (match exp - (($ $branch kt ($ $primcall name param args)) - ;; The "normal" continuation is the #f branch. - (let ((kf-types (infer-primcall types 0 name param args #f)) - (kt-types (infer-primcall types 1 name param args #f))) - (propagate2 k kf-types kt kt-types))) (($ $prompt escape? tag handler) ;; The "normal" continuation enters the prompt. (propagate2 k types handler types)) @@ -1979,6 +1975,10 @@ maximum, where type is a bitset as a fixnum." (match (intmap-ref conts label) (($ $kargs names vars ($ $continue k src exp)) (visit-exp label typev k types exp)) + (($ $kargs names vars ($ $branch kf kt src op param args)) + ;; The "normal" continuation is the #f branch. + (propagate2 kf (infer-primcall types 0 op param args #f) + kt (infer-primcall types 1 op param args #f))) (($ $kreceive arity k) (match (intmap-ref conts k) (($ $kargs names vars) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index 3d7ac9c1a..cc153c2b9 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 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -198,13 +198,14 @@ disjoint, an error will be signalled." (if kalt (visit-cont kalt (visit-cont kbody labels)) (visit-cont kbody labels))) - (($ $kargs names syms ($ $continue k src exp)) - (visit-cont k (match exp - (($ $branch k) - (visit-cont k labels)) - (($ $prompt escape? tag k) - (visit-cont k labels)) - (_ labels))))))))))) + (($ $kargs names syms term) + (match term + (($ $continue k src ($ $prompt escape? tag handler)) + (visit-cont k (visit-cont handler labels))) + (($ $continue k) + (visit-cont k labels)) + (($ $branch kf kt) + (visit-cont kf (visit-cont kt labels)))))))))))) (define* (compute-reachable-functions conts #:optional (kfun 0)) "Compute a mapping LABEL->LABEL..., where each key is a reachable @@ -257,11 +258,13 @@ intset." (if (intmap-ref succs label (lambda (_) #f)) succs (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (match exp - (($ $branch kt) (propagate2 k kt)) - (($ $prompt escape? tag handler) (propagate2 k handler)) - (_ (propagate1 k)))) + (($ $kargs names vars term) + (match term + (($ $continue k src exp) + (match exp + (($ $prompt escape? tag handler) (propagate2 k handler)) + (_ (propagate1 k)))) + (($ $branch kf kt) (propagate2 kf kt)))) (($ $kreceive arity k) (propagate1 k)) (($ $kfun src meta self tail clause) @@ -291,12 +294,15 @@ intset." preds) (($ $kclause arity kbody kalt) (add-pred kbody (if kalt (add-pred kalt preds) preds))) - (($ $kargs names syms ($ $continue k src exp)) - (add-pred k - (match exp - (($ $branch k) (add-pred k preds)) - (($ $prompt _ _ k) (add-pred k preds)) - (_ preds)))))) + (($ $kargs names syms term) + (match term + (($ $continue k src exp) + (add-pred k + (match exp + (($ $prompt _ _ k) (add-pred k preds)) + (_ preds)))) + (($ $branch kf kt) + (add-pred kf (add-pred kt preds))))))) (persistent-intmap (intset-fold add-preds labels (intset->intmap (lambda (label) '()) labels)))) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index 5dc4b84b7..1e0537046 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -1,5 +1,5 @@ ;;; Diagnostic checker for CPS -;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015, 2017, 2018 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 License as @@ -62,7 +62,7 @@ (intmap-fold (lambda (label cont seen) (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) + (($ $kargs names vars term) (fold1 adjoin-def vars seen)) (($ $kfun src meta self tail clause) (adjoin-def self seen)) @@ -99,12 +99,15 @@ definitions that are available at LABEL." (values (append changed0 changed1) defs))) (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) + (($ $kargs names vars term) (let ((out (fold1 adjoin-def vars in))) - (match exp - (($ $branch kt) (propagate2 k kt out)) - (($ $prompt escape? tag handler) (propagate2 k handler out)) - (_ (propagate1 k out))))) + (match term + (($ $continue k src exp) + (match exp + (($ $prompt escape? tag handler) (propagate2 k handler out)) + (_ (propagate1 k out)))) + (($ $branch kf kt) + (propagate2 kf kt out))))) (($ $kreceive arity k) (propagate1 k in)) (($ $kfun src meta self tail clause) @@ -159,21 +162,60 @@ definitions that are available at LABEL." (check-use proc) (for-each check-use args) (visit-first-order kfun)) - (($ $branch kt ($ $primcall name param args)) - (for-each check-use args) - first-order) (($ $primcall name param args) (for-each check-use args) first-order) (($ $prompt escape? tag handler) (check-use tag) first-order))) + (define (visit-term term bound first-order) + (define (check-use var) + (unless (intset-ref bound var) + (error "unbound var" var))) + (define (visit-first-order kfun) + (if (intset-ref first-order kfun) + first-order + (visit-fun kfun empty-intset (intset-add first-order kfun)))) + (match term + (($ $continue k src exp) + (match exp + ((or ($ $const) ($ $prim)) first-order) + ;; todo: $closure + (($ $fun kfun) + (visit-fun kfun bound first-order)) + (($ $closure kfun) + (visit-first-order kfun)) + (($ $rec names vars (($ $fun kfuns) ...)) + (let ((bound (fold1 adjoin-def vars bound))) + (fold1 (lambda (kfun first-order) + (visit-fun kfun bound first-order)) + kfuns first-order))) + (($ $values args) + (for-each check-use args) + first-order) + (($ $call proc args) + (check-use proc) + (for-each check-use args) + first-order) + (($ $callk kfun proc args) + (check-use proc) + (for-each check-use args) + (visit-first-order kfun)) + (($ $primcall name param args) + (for-each check-use args) + first-order) + (($ $prompt escape? tag handler) + (check-use tag) + first-order))) + (($ $branch kf kt src name param args) + (for-each check-use args) + first-order))) (intmap-fold (lambda (label bound first-order) (let ((bound (intset-union free bound))) (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (visit-exp exp (fold1 adjoin-def vars bound) first-order)) + (($ $kargs names vars term) + (visit-term term (fold1 adjoin-def vars bound) first-order)) (_ first-order)))) (compute-available-definitions conts kfun) first-order))) @@ -236,11 +278,6 @@ definitions that are available at LABEL." (assert-kreceive-or-ktail)) (($ $callk k proc args) (assert-kreceive-or-ktail)) - (($ $branch kt exp) - (assert-nullary) - (match (intmap-ref conts kt) - (($ $kargs () ()) #t) - (cont (error "bad kt" cont)))) (($ $primcall name param args) (match cont (($ $kargs) #t) @@ -254,15 +291,26 @@ definitions that are available at LABEL." (match (intmap-ref conts handler) (($ $kreceive) #t) (cont (error "bad handler" cont)))))) + (define (check-term term) + (match term + (($ $continue k src exp) + (check-arity exp (intmap-ref conts k))) + (($ $branch kf kt src op param args) + (match (intmap-ref conts kf) + (($ $kargs () ()) #t) + (cont (error "bad kf" cont))) + (match (intmap-ref conts kt) + (($ $kargs () ()) #t) + (cont (error "bad kt" cont)))))) (let ((reachable (compute-reachable-labels conts kfun))) (intmap-for-each (lambda (label cont) (when (intset-ref reachable label) (match cont - (($ $kargs names vars ($ $continue k src exp)) + (($ $kargs names vars term) (unless (= (length names) (length vars)) (error "broken $kargs" label names vars)) - (check-arity exp (intmap-ref conts k))) + (check-term term)) (_ #t)))) conts))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index e66b09bdd..ae02113f2 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -310,9 +310,8 @@ (let$ init (convert init kreceive subst)) (letk kunbound ($kargs () () ,init)) (build-term - ($continue kbound src - ($branch kunbound - ($primcall 'undefined? #f (orig-var)))))))))))))) + ($branch kbound kunbound src + 'undefined? #f (orig-var)))))))))))) (define (build-list cps k src vals) (match vals @@ -914,14 +913,11 @@ (if (heap-type-predicate? name) (with-cps cps (letk kt* ($kargs () () - ($continue kf src - ($branch kt ($primcall name #f args))))) + ($branch kf kt src name #f args))) (build-term - ($continue kf src - ($branch kt* ($primcall 'heap-object? #f args))))) + ($branch kf kt* src 'heap-object? #f args))) (with-cps cps - (build-term ($continue kf src - ($branch kt ($primcall name #f args))))))))) + (build-term ($branch kf kt src name #f args))))))) (($ src test consequent alternate) (with-cps cps (let$ t (convert-test consequent kt kf)) @@ -935,8 +931,7 @@ (_ (convert-arg cps test (lambda (cps test) (with-cps cps - (build-term ($continue kt src - ($branch kf ($primcall 'false? #f (test))))))))))) + (build-term ($branch kt kf src 'false? #f (test))))))))) (with-cps cps (let$ t (convert consequent k subst)) (let$ f (convert alternate k subst))