From 59258f7cad38327cb32278f64ec53eb6ba63a3df Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 31 May 2014 21:43:12 -0400 Subject: [PATCH] Remove $kif * module/language/cps.scm: Remove $kif. * module/language/cps/compile-bytecode.scm: * module/language/cps/cse.scm: * module/language/cps/dce.scm: * module/language/cps/dfg.scm: * module/language/cps/effects-analysis.scm: * module/language/cps/prune-top-level-scopes.scm: * module/language/cps/renumber.scm: * module/language/cps/simplify.scm: * module/language/cps/slot-allocation.scm: * module/language/cps/type-fold.scm: * module/language/cps/types.scm: * module/language/cps/verify.scm: Adapt. --- module/language/cps.scm | 19 ++----- module/language/cps/compile-bytecode.scm | 2 - module/language/cps/cse.scm | 31 ++++-------- module/language/cps/dce.scm | 2 - module/language/cps/dfg.scm | 7 +-- module/language/cps/effects-analysis.scm | 1 - .../language/cps/prune-top-level-scopes.scm | 4 +- module/language/cps/renumber.scm | 8 ++- module/language/cps/simplify.scm | 8 ++- module/language/cps/slot-allocation.scm | 5 +- module/language/cps/type-fold.scm | 31 +++--------- module/language/cps/types.scm | 50 +------------------ module/language/cps/verify.scm | 3 -- 13 files changed, 36 insertions(+), 135 deletions(-) diff --git a/module/language/cps.scm b/module/language/cps.scm index 608397547..f570921d8 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -27,8 +27,8 @@ ;;; $letk binds a set of mutually recursive continuations, each one an ;;; instance of $cont. A $cont declares the name of a continuation, and ;;; then contains as a subterm the particular continuation instance: -;;; $kif for test continuations, $kargs for continuations that bind -;;; values, etc. +;;; $kargs for continuations that bind values, $ktail for the tail +;;; continuation, etc. ;;; ;;; $continue nodes call continuations. The expression contained in the ;;; $continue node determines the value or values that are passed to the @@ -92,7 +92,7 @@ ;;; - $letk, $letrec, and $continue are terms. ;;; ;;; - $cont is a continuation, containing a continuation body ($kargs, -;;; $kif, etc). +;;; $ktail, etc). ;;; ;;; - $continue terms contain an expression ($call, $const, $fun, ;;; etc). @@ -119,7 +119,7 @@ $cont ;; Continuation bodies. - $kif $kreceive $kargs $kfun $ktail $kclause + $kreceive $kargs $kfun $ktail $kclause ;; Expressions. $void $const $prim $fun $closure $branch @@ -181,7 +181,6 @@ ;; Continuations (define-cps-type $cont k cont) -(define-cps-type $kif kt kf) (define-cps-type $kreceive arity k) (define-cps-type $kargs names syms body) (define-cps-type $kfun src meta self tail clause) @@ -239,11 +238,9 @@ (make-$arity req opt rest kw allow-other-keys?)))) (define-syntax build-cont-body - (syntax-rules (unquote $kif $kreceive $kargs $kfun $ktail $kclause) + (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause) ((_ (unquote exp)) exp) - ((_ ($kif kt kf)) - (make-$kif kt kf)) ((_ ($kreceive req rest kargs)) (make-$kreceive (make-$arity req '() rest '() #f) kargs)) ((_ ($kargs (name ...) (unquote syms) body)) @@ -356,8 +353,6 @@ (('k sym body) (build-cps-cont (sym ,(parse-cps body)))) - (('kif kt kf) - (build-cont-body ($kif kt kf))) (('kreceive req rest k) (build-cont-body ($kreceive req rest k))) (('kargs names syms body) @@ -429,8 +424,6 @@ `(letk ,(map unparse-cps conts) ,(unparse-cps body))) (($ $cont sym body) `(k ,sym ,(unparse-cps body))) - (($ $kif kt kf) - `(kif ,kt ,kf)) (($ $kreceive ($ $arity req () rest '() #f) k) `(kreceive ,req ,rest ,k)) (($ $kargs () () body) @@ -632,8 +625,6 @@ (($ $branch kt) (proc k kt)) (_ (proc k))))))) - (($ $kif kt kf) (proc kt kf)) - (($ $kreceive arity k) (proc k)) (($ $kclause arity ($ $cont kbody) #f) (proc kbody)) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 4ee9b4503..25626a372 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -198,8 +198,6 @@ (($ $kargs names syms) (compile-values label exp syms) (maybe-emit-jump)) - (($ $kif kt kf) - (compile-test label exp kt kf (and fallthrough? (1+ k)))) (($ $kreceive ($ $arity req () rest () #f) kargs) (compile-trunc label k exp (length req) (and rest diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 91d142018..64dab7f13 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -177,16 +177,15 @@ be that both true and false proofs are available." (if initialized? (intersect! bool (vector-ref boolv pidx)) (bitvector-copy! bool (vector-ref boolv pidx))) - (match (lookup-predecessors pred dfg) - ((test) - (let ((tidx (label->idx test))) - (match (lookup-cont pred dfg) - (($ $kif kt kf) - (when (eqv? kt label) - (bitvector-set! bool (true-idx tidx) #t)) - (when (eqv? kf label) - (bitvector-set! bool (false-idx tidx) #t))) - (_ #t)))) + (match (lookup-cont pred dfg) + (($ $kargs _ _ term) + (match (find-call term) + (($ $continue kf ($ $branch kt exp)) + (when (eqv? kt label) + (bitvector-set! bool (true-idx pidx) #t)) + (when (eqv? kf label) + (bitvector-set! bool (false-idx pidx) #t))) + (_ #t))) (_ #t)) (lp preds #t))))))) (lp (1+ n) first? @@ -219,7 +218,6 @@ be that both true and false proofs are available." (cont-defs kargs)) (($ $kclause arity ($ $cont kargs ($ $kargs names syms))) syms) - (($ $kif) '()) (($ $kfun src meta self) (list self)) (($ $ktail) '()))) (lp (1+ n)))) @@ -548,16 +546,9 @@ be that both true and false proofs are available." (build-cps-term ($continue (if t kt k) src ($values ())))))) (_ + ;; FIXME: can we always continue with $values? why + ;; or why not? (rewrite-cps-term (lookup-cont k dfg) - (($ $kif kt kf) - ,(let* ((bool (vector-ref boolv (label->idx label))) - (t (bitvector-ref bool (true-idx eidx))) - (f (bitvector-ref bool (false-idx eidx)))) - (if (eqv? t f) - (build-cps-term - ($continue k src ,(visit-exp exp))) - (build-cps-term - ($continue (if t kt kf) src ($values ())))))) (($ $kargs) ($continue k src ($values vars))) (_ diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index 1318a811f..fbfd2f386 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -74,7 +74,6 @@ (cont-defs kargs)) (($ $kclause arity ($ $cont kargs ($ $kargs names syms))) syms) - (($ $kif) #f) (($ $kfun src meta self) (list self)) (($ $ktail) #f))) (lp (1+ n)))) @@ -236,7 +235,6 @@ (mark-live! use))) args defs)))))))))) (($ $kreceive arity kargs) #f) - (($ $kif) #f) (($ $kclause arity ($ $cont kargs ($ $kargs names syms body))) (for-each mark-live! syms)) (($ $kfun src meta self) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm index 8425c5400..593d02c07 100644 --- a/module/language/cps/dfg.scm +++ b/module/language/cps/dfg.scm @@ -107,7 +107,7 @@ min-label max-label label-count min-var max-var var-count) dfg? - ;; vector of label -> $kif, $kargs, etc + ;; vector of label -> $kargs, etc (conts dfg-cont-table) ;; vector of label -> (pred-label ...) (preds dfg-preds) @@ -816,9 +816,6 @@ body continuation in the prompt." (($ $kargs names syms body) (for-each (cut add-def! <> label) syms) (visit-term body label)) - (($ $kif kt kf) - (link-blocks! label kt) - (link-blocks! label kf)) (($ $kreceive arity k) (link-blocks! label k)))) @@ -917,8 +914,6 @@ body continuation in the prompt." (newline port)) (format port "k~a:~8t" label) (match cont - (($ $kif kt kf) - (format port "$kif k~a k~a\n" kt kf)) (($ $kreceive arity k) (format port "$kreceive ~a k~a\n" arity k)) (($ $kfun src meta self tail clause) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 0e6587588..b1e2cc841 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -467,7 +467,6 @@ is or might be a read or a write to the same location as A." (($ $arity _ () #f () #f) &type-check) (($ $arity () () _ () #f) (&allocate &pair)) (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check)))) - (($ $kif) &no-effects) (($ $kfun) &type-check) (($ $kclause) &type-check) (($ $ktail) &no-effects))) diff --git a/module/language/cps/prune-top-level-scopes.scm b/module/language/cps/prune-top-level-scopes.scm index 2330d31c4..ed0907429 100644 --- a/module/language/cps/prune-top-level-scopes.scm +++ b/module/language/cps/prune-top-level-scopes.scm @@ -46,7 +46,7 @@ (($ $cont k ($ $kclause arity body alternate)) (visit-cont body) (when alternate (visit-cont alternate))) - (($ $cont k (or ($ $kreceive) ($ $kif))) + (($ $cont k ($ $kreceive)) #t))) (define (visit-term term) (match term @@ -99,7 +99,7 @@ (($ $cont sym ($ $kclause arity body alternate)) (sym ($kclause ,arity ,(visit-cont body) ,(and alternate (visit-cont alternate))))) - (($ $cont sym (or ($ $kreceive) ($ $kif))) + (($ $cont sym ($ $kreceive)) ,cont))) (define (visit-term term) (rewrite-cps-term term diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm index 7bab9e281..204d20982 100644 --- a/module/language/cps/renumber.scm +++ b/module/language/cps/renumber.scm @@ -100,7 +100,7 @@ (visit-cont body) (when alternate (visit-cont alternate))) - ((or ($ $ktail) ($ $kreceive) ($ $kif)) + ((or ($ $ktail) ($ $kreceive)) #f))))) (define (visit-term term) (match term @@ -147,7 +147,7 @@ ;; sure we mark as reachable. (vector-set! labels label next-label) (set! next-label (1+ next-label)))) - ((or ($ $kreceive) ($ $kif)) + (($ $kreceive) #f)))))) (define (visit-term term reachable?) (match term @@ -225,9 +225,7 @@ ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body) ,(and alternate (must-visit-cont alternate))))) (($ $kreceive ($ $arity req () rest () #f) kargs) - (label ($kreceive req rest (relabel kargs)))) - (($ $kif kt kf) - (label ($kif (relabel kt) (relabel kf)))))))))) + (label ($kreceive req rest (relabel kargs)))))))))) (define (visit-term term) (rewrite-cps-term term (($ $letk conts body) diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index 22410cbef..51858899a 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -96,9 +96,7 @@ (sym ($kclause ,arity ,(visit-cont body sym) ,(and alternate (visit-cont alternate sym))))) (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs)) - (sym ($kreceive req rest (reduce kargs scope)))) - (($ $cont sym ($ $kif kt kf)) - (sym ($kif (reduce kt scope) (reduce kf scope)))))) + (sym ($kreceive req rest (reduce kargs scope)))))) (define (visit-term term scope) (rewrite-cps-term term (($ $letk conts body) @@ -135,7 +133,7 @@ (($ $cont sym ($ $kclause arity body alternate)) (visit-cont body) (when alternate (visit-cont alternate))) - (($ $cont sym (or ($ $ktail) ($ $kreceive) ($ $kif))) + (($ $cont sym (or ($ $ktail) ($ $kreceive))) #f))) (define (visit-term term) (match term @@ -192,7 +190,7 @@ (($ $kclause arity body alternate) (sym ($kclause ,arity ,(must-visit-cont body) ,(and alternate (must-visit-cont alternate))))) - ((or ($ $kreceive) ($ $kif)) + (($ $kreceive) (sym ,cont))))))) (define (visit-term term) (match term diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 74dafd736..6ba30548d 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -581,8 +581,7 @@ are comparable with eqv?. A tmp slot may be used." (compute-tmp-slot (logior pre-live result-live) '())))) (hashq-set! call-allocations label - (make-call-allocation #f moves #f)))) - (($ $kif) #f))) + (make-call-allocation #f moves #f)))))) (define (allocate-prompt label k handler nargs) (match (lookup-cont handler dfg) @@ -652,7 +651,7 @@ are comparable with eqv?. A tmp slot may be used." (allocate-prompt label k handler nargs)) (_ #f))) (lp (1+ n) post-live)) - ((or ($ $kreceive) ($ $kif) ($ $ktail)) + ((or ($ $kreceive) ($ $ktail)) (lp (1+ n) post-live))))))) (define (visit-entry) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index 20abc36f3..b644fd0ec 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -187,20 +187,11 @@ (($ $letrec _ _ _ body) (visit-term body label)) (($ $continue k src ($ $primcall name args)) - ;; We might be able to fold primcalls that define a value or - ;; that branch. + ;; We might be able to fold primcalls that define a value. (match (lookup-cont k dfg) (($ $kargs (_) (def)) (maybe-fold-value! (label->idx label) name (label->idx k) (var->idx def))) - (($ $kif kt kf) - (match args - ((arg) - (maybe-fold-unary-branch! (label->idx label) name - (var->idx arg))) - ((arg0 arg1) - (maybe-fold-binary-branch! (label->idx label) name - (var->idx arg0) (var->idx arg1))))) (_ #f))) (($ $continue kf src ($ $branch kt ($ $primcall name args))) ;; We might be able to fold primcalls that branch. @@ -249,19 +240,13 @@ (let ((val (vector-ref folded-values (label->idx label)))) ;; Uncomment for debugging. ;; (pk 'folded src primcall val) - (match (lookup-cont k dfg) - (($ $kargs) - (let-fresh (k*) (v*) - ;; Rely on DCE to elide this expression, if - ;; possible. - (build-cps-term - ($letk ((k* ($kargs (#f) (v*) - ($continue k src ($const val))))) - ($continue k* src ,primcall))))) - (($ $kif kt kf) - ;; Folded branch. - (build-cps-term - ($continue (if val kt kf) src ($values ())))))) + (let-fresh (k*) (v*) + ;; Rely on DCE to elide this expression, if + ;; possible. + (build-cps-term + ($letk ((k* ($kargs (#f) (v*) + ($continue k src ($const val))))) + ($continue k* src ,primcall))))) term)) (($ $continue kf src ($ $branch kt ($ $primcall))) ,(if (and folded? diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index c868728b1..e6689d608 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1276,7 +1276,7 @@ mapping symbols to types." (($ $kargs (_) (var)) (let ((def (var->idx var))) (infer-primcall! post name (map var->idx args) def))) - ((or ($ $kargs ()) ($ $kif)) + (($ $kargs ()) (infer-primcall! post name (map var->idx args) #f)) (_ #f))) (($ $values args) @@ -1354,54 +1354,6 @@ mapping symbols to types." (match exp (($ $prompt escape? tag handler) (propagate-types! handler post)) - (_ #f)) - (match (lookup-cont k dfg) - ;; We propagate one step farther for conditionals. - ;; Unfortunately we have to duplicate the - ;; changed-types logic. This is unavoidable as a $kif - ;; node has two successors but only one post-types - ;; set. - (($ $kif kt kf) - (let ((kt-out tmp) - (kf-out tmp2)) - (define (update-changelist! k from var) - (let ((to (get-pre-types k))) - (unless (or (< var 0) - (bitvector-ref changed-types var) - (= (logior (var-type from var) - (var-type to var)) - (var-type to var))) - (bitvector-set! changed-types var #t)) - (unless (or (< var 0) - (bitvector-ref changed-ranges var) - (and - (<= (var-min to var) (var-min from var)) - (<= (var-max from var) (var-max to var)))) - (bitvector-set! changed-ranges var #t)))) - (bytevector-copy! post 0 kt-out 0 (bytevector-length post)) - (bytevector-copy! post 0 kf-out 0 (bytevector-length post)) - (let lp ((args (match exp - (($ $values (arg)) - (let* ((arg (var->idx arg))) - (restrict! kf-out arg - (logior &boolean &nil) 0 0) - (list arg))) - (($ $primcall name args) - (let ((args (map var->idx args))) - (infer-predicate! kt-out name args #t) - (infer-predicate! kf-out name args #f) - args))))) - (match args - ((arg . args) - (update-changelist! kt kt-out arg) - (update-changelist! kf kf-out arg) - (lp args)) - (_ #f))) - ;; Although "k" might dominate "kt", it's not - ;; necessarily the case that "label" dominates - ;; "kt". The perils of lookahead. - (propagate-types/slow! kt kt-out) - (propagate-types/slow! kf kf-out))) (_ #f))))) (($ $kreceive arity k*) (propagate-types! k* post)) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index 4745032bd..a39e99b8c 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -72,9 +72,6 @@ (define (visit-cont-body cont k-env v-env) (match cont - (($ $kif kt kf) - (check-label kt k-env) - (check-label kf k-env)) (($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k) (check-label k k-env)) (($ $kargs (name ...) (sym ...) body) -- 2.20.1