From 92805e219789654115f741b7d621bc9947833379 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 27 May 2014 11:49:42 -0400 Subject: [PATCH] Add $branch expression type * module/language/cps.scm ($branch): New expression type; will replace $kif. * module/language/cps/arities.scm: * module/language/cps/closure-conversion.scm: * 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/primitives.scm: * module/language/cps/renumber.scm: * module/language/cps/self-references.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 to $branch expression type. --- module/language/cps.scm | 11 +++- module/language/cps/arities.scm | 3 ++ module/language/cps/closure-conversion.scm | 16 ++++++ module/language/cps/compile-bytecode.scm | 8 ++- module/language/cps/cse.scm | 46 +++++++++++------ module/language/cps/dce.scm | 25 +++++++--- module/language/cps/dfg.scm | 11 ++++ module/language/cps/effects-analysis.scm | 2 + module/language/cps/primitives.scm | 3 +- module/language/cps/renumber.scm | 2 + module/language/cps/self-references.scm | 2 + module/language/cps/simplify.scm | 40 ++++++++------- module/language/cps/slot-allocation.scm | 6 ++- module/language/cps/type-fold.scm | 17 +++++++ module/language/cps/types.scm | 58 +++++++++++++++++++++- module/language/cps/verify.scm | 6 +++ 16 files changed, 207 insertions(+), 49 deletions(-) diff --git a/module/language/cps.scm b/module/language/cps.scm index 2867a4ad7..608397547 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -122,7 +122,7 @@ $kif $kreceive $kargs $kfun $ktail $kclause ;; Expressions. - $void $const $prim $fun $closure + $void $const $prim $fun $closure $branch $call $callk $primcall $values $prompt ;; First-order CPS root. @@ -194,6 +194,7 @@ (define-cps-type $prim name) (define-cps-type $fun free body) ; Higher-order. (define-cps-type $closure label nfree) ; First-order. +(define-cps-type $branch k exp) (define-cps-type $call proc args) (define-cps-type $callk k proc args) ; First-order. (define-cps-type $primcall name args) @@ -266,7 +267,7 @@ (define-syntax build-cps-exp (syntax-rules (unquote - $void $const $prim $fun $closure + $void $const $prim $fun $closure $branch $call $callk $primcall $values $prompt) ((_ (unquote exp)) exp) ((_ ($void)) (make-$void)) @@ -286,6 +287,7 @@ ((_ ($values (unquote args))) (make-$values args)) ((_ ($values (arg ...))) (make-$values (list arg ...))) ((_ ($values args)) (make-$values args)) + ((_ ($branch k exp)) (make-$branch k (build-cps-exp exp))) ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler)))) @@ -404,6 +406,8 @@ (build-cps-exp ($callk k proc arg))) (('primcall name arg ...) (build-cps-exp ($primcall name arg))) + (('branch k exp) + (build-cps-exp ($branch k ,(parse-cps exp)))) (('values arg ...) (build-cps-exp ($values arg))) (('prompt escape? tag handler) @@ -467,6 +471,8 @@ `(callk ,k ,proc ,@args)) (($ $primcall name args) `(primcall ,name ,@args)) + (($ $branch k exp) + `(branch ,k ,(unparse-cps exp))) (($ $values args) `(values ,@args)) (($ $prompt escape? tag handler) @@ -623,6 +629,7 @@ (($ $continue k src exp) (match exp (($ $prompt escape? tag handler) (proc k handler)) + (($ $branch kt) (proc k kt)) (_ (proc k))))))) (($ $kif kt kf) (proc kt kf)) diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm index c18955809..c8a9728bb 100644 --- a/module/language/cps/arities.scm +++ b/module/language/cps/arities.scm @@ -148,6 +148,9 @@ ;; adapt the return to the target continuation, and we don't ;; need to do any adapting here. ($continue k src ,exp)) + (($ $branch) + ;; Assume branching primcalls have the correct arity. + ($continue k src ,exp)) (($ $primcall 'return (arg)) ;; Primcalls to return are in tail position. ($continue ktail src ,exp)) diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 26737e924..89e209052 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -126,6 +126,8 @@ (($ $primcall name args) (for-each clear-well-known! args) (fold adjoin '() args)) + (($ $branch kt exp) + (visit-exp exp bound)) (($ $values args) (for-each clear-well-known! args) (fold adjoin '() args)) @@ -498,6 +500,20 @@ bound to @var{var}, and continue with @var{body}." (build-cps-term ($continue k src ($primcall name args)))))) + (($ $continue k src ($ $branch kt ($ $primcall name args))) + (convert-free-vars args + (lambda (args) + (build-cps-term + ($continue k src + ($branch kt ($primcall name args))))))) + + (($ $continue k src ($ $branch kt ($ $values (arg)))) + (convert-free-var arg + (lambda (arg) + (build-cps-term + ($continue k src + ($branch kt ($values (arg)))))))) + (($ $continue k src ($ $values args)) (convert-free-vars args (lambda (args) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index af5e1cc0b..4ee9b4503 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -189,8 +189,12 @@ (compile-value label exp dst nlocals))) (maybe-emit-jump)) (($ $kargs () ()) - (compile-effect label exp k nlocals) - (maybe-emit-jump)) + (match exp + (($ $branch kt exp) + (compile-test label exp kt k (1+ label))) + (_ + (compile-effect label exp k nlocals) + (maybe-emit-jump)))) (($ $kargs names syms) (compile-values label exp syms) (maybe-emit-jump)) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 52516227e..91d142018 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -351,6 +351,9 @@ be that both true and false proofs are available." (($ $callk k proc args) #f) (($ $primcall name args) (cons* 'primcall name (map subst-var args))) + (($ $branch _ ($ $primcall name args)) + (cons* 'primcall name (map subst-var args))) + (($ $branch) #f) (($ $values args) #f) (($ $prompt escape? tag handler) #f))) @@ -514,6 +517,8 @@ be that both true and false proofs are available." ($callk k (subst-var proc) ,(map subst-var args))) (($ $primcall name args) ($primcall name ,(map subst-var args))) + (($ $branch k exp) + ($branch k ,(visit-exp exp))) (($ $values args) ($values ,(map subst-var args))) (($ $prompt escape? tag handler) @@ -531,23 +536,32 @@ be that both true and false proofs are available." => (match-lambda ((equiv . vars) (let* ((eidx (label->idx equiv))) - (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))) - ;; There is no point in adding a case for $ktail, as - ;; only $values, $call, or $callk can continue to - ;; $ktail. + (match exp + (($ $branch kt exp) + (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 + ($branch kt ,(visit-exp exp)))) + (build-cps-term + ($continue (if t kt k) src ($values ())))))) (_ - ($continue k src ,(visit-exp exp)))))))) + (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))) + (_ + ($continue k src ,(visit-exp exp)))))))))) (else (build-cps-term ($continue k src ,(visit-exp exp)))))))) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index 5f5e58ca9..1318a811f 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -66,7 +66,10 @@ (match (lookup-cont (idx->label n) dfg) (($ $kargs _ _ body) (match (find-call body) - (($ $continue k) (cont-defs k)))) + (($ $continue k src exp) + (match exp + (($ $branch) #f) + (_ (cont-defs k)))))) (($ $kreceive arity kargs) (cont-defs kargs)) (($ $kclause arity ($ $cont kargs ($ $kargs names syms))) @@ -84,6 +87,13 @@ (let ((typev (infer-types fun dfg))) (define (idx->label idx) (+ idx min-label)) (define (var->idx var) (- var min-var)) + (define (visit-primcall lidx fx name args) + (let ((args (map var->idx args))) + ;; Negative args are closure variables. + (unless (or-map negative? args) + (when (primcall-types-check? lidx typev name args) + (vector-set! effects lidx + (logand fx (lognot &type-check))))))) (let lp ((lidx 0)) (when (< lidx label-count) (let ((fx (vector-ref effects lidx))) @@ -93,12 +103,9 @@ (($ $kargs _ _ term) (match (find-call term) (($ $continue k src ($ $primcall name args)) - (let ((args (map var->idx args))) - ;; Negative args are closure variables. - (unless (or-map negative? args) - (when (primcall-types-check? lidx typev name args) - (vector-set! effects lidx - (logand fx (lognot &type-check))))))) + (visit-primcall lidx fx name args)) + (($ $continue k src ($ $branch _ ($primcall name args))) + (visit-primcall lidx fx name args)) (_ #f))) (_ #f))))) (lp (1+ lidx))))))))) @@ -217,6 +224,10 @@ (for-each mark-live! args)) (($ $primcall name args) (for-each mark-live! args)) + (($ $branch k ($ $primcall name args)) + (for-each mark-live! args)) + (($ $branch k ($ $values (arg))) + (mark-live! arg)) (($ $values args) (match (vector-ref defs n) (#f (for-each mark-live! args)) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm index 460843c25..8425c5400 100644 --- a/module/language/cps/dfg.scm +++ b/module/language/cps/dfg.scm @@ -858,6 +858,9 @@ body continuation in the prompt." (for-each use! args)) (($ $primcall name args) (for-each use! args)) + (($ $branch kt exp) + (link-blocks! label kt) + (visit-exp exp label)) (($ $values args) (for-each use! args)) (($ $prompt escape? tag handler) @@ -933,6 +936,14 @@ body continuation in the prompt." (format port "v~a[~a]~:{ v~a[~a]~}: " (car vars) (car names) (map list (cdr vars) (cdr names)))) (match (find-call term) + (($ $continue kf src ($ $branch kt exp)) + (format port "if ") + (match exp + (($ $primcall name args) + (format port "(~a~{ v~a~})" name args)) + (($ $values (arg)) + (format port "v~a" arg))) + (format port " k~a k~a\n" kt kf)) (($ $continue k src exp) (match exp (($ $void) (format port "void")) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 98b575718..0e6587588 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -445,6 +445,8 @@ is or might be a read or a write to the same location as A." (&write-object &prompt)) ((or ($ $call) ($ $callk)) &all-effects) + (($ $branch k exp) + (expression-effects exp dfg)) (($ $primcall name args) (primitive-effects dfg name args)))) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 873600c42..4c6287a91 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -18,7 +18,8 @@ ;;; Commentary: ;;; -;;; Information about named primitives, as they appear in $prim and $primcall. +;;; Information about named primitives, as they appear in $prim and +;;; $primcall. ;;; ;;; Code: diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm index ab27653f6..7bab9e281 100644 --- a/module/language/cps/renumber.scm +++ b/module/language/cps/renumber.scm @@ -256,6 +256,8 @@ (($ $callk k proc args) (let ((args (map rename args))) (build-cps-exp ($callk (relabel k) (rename proc) args)))) + (($ $branch kt exp) + (build-cps-exp ($branch (relabel kt) ,(visit-exp exp)))) (($ $primcall name args) (let ((args (map rename args))) (build-cps-exp ($primcall name args)))) diff --git a/module/language/cps/self-references.scm b/module/language/cps/self-references.scm index 69113208f..be4f2d9df 100644 --- a/module/language/cps/self-references.scm +++ b/module/language/cps/self-references.scm @@ -65,6 +65,8 @@ ($callk k (subst proc) ,(map subst args))) (($ $primcall name args) ($primcall name ,(map subst args))) + (($ $branch k exp) + ($branch k ,(visit-exp exp))) (($ $values args) ($values ,(map subst args))) (($ $prompt escape? tag handler) diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index 0dd98e24f..22410cbef 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -209,25 +209,27 @@ (cond ((hashq-ref k-table k) => visit-term) (else - (build-cps-term - ($continue k src - ,(match exp - ((or ($ $void) ($ $const) ($ $prim)) exp) - (($ $fun) (visit-fun exp)) - (($ $call proc args) - (let ((args (map subst args))) - (build-cps-exp ($call (subst proc) args)))) - (($ $callk k proc args) - (let ((args (map subst args))) - (build-cps-exp ($callk k (subst proc) args)))) - (($ $primcall name args) - (let ((args (map subst args))) - (build-cps-exp ($primcall name args)))) - (($ $values args) - (let ((args (map subst args))) - (build-cps-exp ($values args)))) - (($ $prompt escape? tag handler) - (build-cps-exp ($prompt escape? (subst tag) handler))))))))))) + (build-cps-term ($continue k src ,(visit-exp exp)))))))) + (define (visit-exp exp) + (match exp + ((or ($ $void) ($ $const) ($ $prim)) exp) + (($ $fun) (visit-fun exp)) + (($ $call proc args) + (let ((args (map subst args))) + (build-cps-exp ($call (subst proc) args)))) + (($ $callk k proc args) + (let ((args (map subst args))) + (build-cps-exp ($callk k (subst proc) args)))) + (($ $primcall name args) + (let ((args (map subst args))) + (build-cps-exp ($primcall name args)))) + (($ $values args) + (let ((args (map subst args))) + (build-cps-exp ($values args)))) + (($ $branch kt exp) + (build-cps-exp ($branch kt ,(visit-exp exp)))) + (($ $prompt escape? tag handler) + (build-cps-exp ($prompt escape? (subst tag) handler))))) (define (visit-fun fun) (rewrite-cps-exp fun (($ $fun free body) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 53d6cee5e..74dafd736 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -362,6 +362,10 @@ are comparable with eqv?. A tmp slot may be used." (cons proc args)) (($ $primcall name args) args) + (($ $branch kt ($ $primcall name args)) + args) + (($ $branch kt ($ $values args)) + args) (($ $values args) args) (($ $prompt escape? tag handler) @@ -461,7 +465,7 @@ are comparable with eqv?. A tmp slot may be used." (if (bit-position #t dead 0) (finish-hints n (live-before n) args) (scan-for-hints (1- n) args)))) - ((or ($ $call) ($ $callk) ($ $values)) + ((or ($ $call) ($ $callk) ($ $values) ($ $branch)) (finish-hints n (live-before n) args)))) ;; Otherwise we kill uses of the block entry. (_ (finish-hints n (live-before (1+ n)) args)))) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index 91f23df33..20abc36f3 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -202,6 +202,15 @@ (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. + (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))) (when typev (match fun @@ -254,6 +263,14 @@ (build-cps-term ($continue (if val kt kf) src ($values ())))))) term)) + (($ $continue kf src ($ $branch kt ($ $primcall))) + ,(if (and folded? + (bitvector-ref folded? (label->idx label))) + ;; Folded branch. + (let ((val (vector-ref folded-values (label->idx label)))) + (build-cps-term + ($continue (if val kt kf) src ($values ())))) + term)) (_ ,term))) (define (visit-fun fun) (rewrite-cps-exp fun diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 22335f7d0..c868728b1 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -470,6 +470,7 @@ minimum, and maximum." (max (min (&max a) (&max b)))) (restrict! a type min max) (restrict! b type min max)))) +;; FIXME!!!!! (define-type-inferrer-aliases eq? eqv? equal?) (define-syntax-rule (define-simple-predicate-inferrer predicate type) @@ -730,6 +731,7 @@ minimum, and maximum." (when (zero? (logand (logior (&type a) (&type b)) (lognot &number))) (restrict! a &real -inf.0 +inf.0) (restrict! b &real -inf.0 +inf.0))) +;; FIXME!!! (define-type-aliases < <= > >=) ;; Arithmetic. @@ -1198,7 +1200,6 @@ mapping symbols to types." ;; Add types for new definitions, and restrict types of ;; existing variables due to side effects. (match (lookup-cont label dfg) - ;; fixme: letrec (($ $kargs names vars term) (let visit-term ((term term)) (match term @@ -1215,6 +1216,61 @@ mapping symbols to types." (visit-term term)) (($ $continue k src exp) (match exp + (($ $branch kt exp) + ;; The "normal" continuation is the #f branch. + ;; For the #t branch we need to roll our own + ;; "changed" logic. This will be refactored + ;; in the future. + (let ((kt-out tmp2)) + (bytevector-copy! pre 0 kt-out 0 (bytevector-length pre)) + (match exp + (($ $values (arg)) + (let ((arg (var->idx arg))) + (unless (< arg 0) + (bitvector-set! changed arg #t) + (restrict! post arg (logior &boolean &nil) 0 0)) + ;; No additional information on the #t branch, + ;; as there's no way currently to remove #f + ;; from the typeset (because it would remove + ;; #t as well: they are both &boolean). + )) + (($ $primcall name args) + (let ((args (map var->idx args))) + ;; For the #t branch we need to roll our own + ;; "changed" logic. This will be refactored + ;; in the future. + (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)))) + ;; The "normal" continuation is the #f branch. + (infer-predicate! post name args #f) + (infer-predicate! kt-out name args #t) + (let lp ((args args)) + (match args + ((arg . args) + ;; Primcall operands can originate + ;; outside the function. + (when (<= 0 arg) + ;; `out' will be scanned below. + (bitvector-set! changed arg #t) + ;; But we need to manually scan + ;; kt-out. + (update-changelist! kt kt-out arg)) + (lp args)) + (_ #f)))))) + ;; Manually propagate the kt branch. + (propagate-types! kt kt-out))) (($ $primcall name args) (match (lookup-cont k dfg) (($ $kargs (_) (var)) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index b965427f5..4745032bd 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -158,6 +158,12 @@ ;; the reference. (check-var proc v-env) (for-each (cut check-var <> v-env) arg)) + (($ $branch kt ($ $primcall (? symbol? name) (arg ...))) + (check-var kt k-env) + (for-each (cut check-var <> v-env) arg)) + (($ $branch kt ($ $values (arg ...))) + (check-var kt k-env) + (for-each (cut check-var <> v-env) arg)) (($ $primcall (? symbol? name) (arg ...)) (for-each (cut check-var <> v-env) arg)) (($ $values (arg ...)) -- 2.20.1