From fe16de52e030c47f074498743d365e504e5dc9dd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Aug 2008 22:22:26 -0500 Subject: [PATCH] Inference transforms can now give up; remove elaboration phase since we'll do that while building CFG --- .../compiler/tree/builder/builder.factor | 5 + .../tree/elaboration/elaboration.factor | 5 - .../tree/intrinsics/intrinsics.factor | 24 +++- .../tree/loop/detection/detection.factor | 10 +- .../compiler/tree/optimizer/optimizer.factor | 10 +- .../tree/propagation/inlining/inlining.factor | 5 +- .../known-words/known-words.factor | 9 +- .../transforms/transforms.factor | 114 +++++++++++++++--- 8 files changed, 138 insertions(+), 44 deletions(-) delete mode 100644 unfinished/compiler/tree/elaboration/elaboration.factor diff --git a/unfinished/compiler/tree/builder/builder.factor b/unfinished/compiler/tree/builder/builder.factor index afa57556ca..e2315dbdf7 100644 --- a/unfinished/compiler/tree/builder/builder.factor +++ b/unfinished/compiler/tree/builder/builder.factor @@ -22,6 +22,11 @@ IN: compiler.tree.builder ] with-tree-builder nip unclip-last in-d>> ; +: build-sub-tree ( #call quot -- nodes ) + [ [ out-d>> ] [ in-d>> ] bi ] dip + build-tree-with + rot #copy suffix ; + : (make-specializer) ( class picker -- quot ) swap "predicate" word-prop append ; diff --git a/unfinished/compiler/tree/elaboration/elaboration.factor b/unfinished/compiler/tree/elaboration/elaboration.factor deleted file mode 100644 index b0f4306964..0000000000 --- a/unfinished/compiler/tree/elaboration/elaboration.factor +++ /dev/null @@ -1,5 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: compiler.tree.elaboration - -: elaborate ( nodes -- nodes' ) ; diff --git a/unfinished/compiler/tree/intrinsics/intrinsics.factor b/unfinished/compiler/tree/intrinsics/intrinsics.factor index a3328114bd..322e0dabe1 100644 --- a/unfinished/compiler/tree/intrinsics/intrinsics.factor +++ b/unfinished/compiler/tree/intrinsics/intrinsics.factor @@ -1,6 +1,26 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ; +USING: kernel classes.tuple classes.tuple.private math arrays +byte-arrays words stack-checker.known-words ; IN: compiler.tree.intrinsics -: ( ... class -- tuple ) "Intrinsic" throw ; +: ( ... class -- tuple ) + "BUG: missing intrinsic" throw ; + +: (tuple) ( layout -- tuple ) + "BUG: missing (tuple) intrinsic" throw ; + +\ (tuple) { tuple-layout } { tuple } define-primitive +\ (tuple) make-flushable + +: (array) ( n -- array ) + "BUG: missing (array) intrinsic" throw ; + +\ (array) { integer } { array } define-primitive +\ (array) make-flushable + +: (byte-array) ( n -- byte-array ) + "BUG: missing (byte-array) intrinsic" throw ; + +\ (byte-array) { integer } { byte-array } define-primitive +\ (byte-array) make-flushable diff --git a/unfinished/compiler/tree/loop/detection/detection.factor b/unfinished/compiler/tree/loop/detection/detection.factor index 5c21e8c237..21d7e2a694 100644 --- a/unfinished/compiler/tree/loop/detection/detection.factor +++ b/unfinished/compiler/tree/loop/detection/detection.factor @@ -22,7 +22,7 @@ IN: compiler.tree.loop.detection SYMBOL: loop-heights SYMBOL: loop-calls -SYMBOL: label-stack +SYMBOL: loop-stack SYMBOL: work-list GENERIC: collect-loop-info* ( tail? node -- ) @@ -34,14 +34,14 @@ GENERIC: collect-loop-info* ( tail? node -- ) [ tail-calls ] keep [ collect-loop-info* ] 2each ; : remember-loop-info ( label -- ) - label-stack get length swap loop-heights get set-at ; + loop-stack get length swap loop-heights get set-at ; M: #recursive collect-loop-info* nip [ [ label>> - [ label-stack [ swap suffix ] change ] + [ loop-stack [ swap suffix ] change ] [ remember-loop-info ] [ t >>loop? drop ] tri @@ -50,7 +50,7 @@ M: #recursive collect-loop-info* ] with-scope ; : current-loop-nesting ( label -- labels ) - label-stack get swap loop-heights get at tail ; + loop-stack get swap loop-heights get at tail ; : disqualify-loop ( label -- ) work-list get push-front ; @@ -69,7 +69,7 @@ M: #dispatch collect-loop-info* M: node collect-loop-info* 2drop ; : collect-loop-info ( node -- ) - { } label-stack set + { } loop-stack set H{ } clone loop-calls set H{ } clone loop-heights set work-list set diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor index e44cf44db7..24df9b5af3 100644 --- a/unfinished/compiler/tree/optimizer/optimizer.factor +++ b/unfinished/compiler/tree/optimizer/optimizer.factor @@ -8,7 +8,7 @@ compiler.tree.tuple-unboxing compiler.tree.def-use compiler.tree.dead-code compiler.tree.strength-reduction -compiler.tree.loop-detection +compiler.tree.loop.detection compiler.tree.branch-fusion ; IN: compiler.tree.optimizer @@ -16,11 +16,11 @@ IN: compiler.tree.optimizer normalize propagate cleanup + detect-loops + invert-loops + fuse-branches escape-analysis unbox-tuples compute-def-use remove-dead-code - strength-reduce - detect-loops - fuse-branches - elaborate ; + strength-reduce ; diff --git a/unfinished/compiler/tree/propagation/inlining/inlining.factor b/unfinished/compiler/tree/propagation/inlining/inlining.factor index 22e056ce60..d333842657 100644 --- a/unfinished/compiler/tree/propagation/inlining/inlining.factor +++ b/unfinished/compiler/tree/propagation/inlining/inlining.factor @@ -18,10 +18,7 @@ M: word splicing-nodes [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; M: quotation splicing-nodes - [ [ out-d>> ] [ in-d>> ] bi ] dip - build-tree-with - rot #copy suffix - normalize ; + build-sub-tree normalize ; : propagate-body ( #call -- ) body>> (propagate) ; diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor index 01991147f7..2e0c979f98 100755 --- a/unfinished/stack-checker/known-words/known-words.factor +++ b/unfinished/stack-checker/known-words/known-words.factor @@ -165,24 +165,27 @@ M: object infer-call* { call execute dispatch load-locals get-local drop-locals } [ t "no-compile" set-word-prop ] each +SYMBOL: +primitive+ + : non-inline-word ( word -- ) dup +called+ depends-on { { [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] } { [ dup +special+ word-prop ] [ infer-special ] } - { [ dup primitive? ] [ infer-primitive ] } + { [ dup +primitive+ word-prop ] [ infer-primitive ] } { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] } - { [ dup +inferred-effect+ word-prop ] [ cached-infer ] } { [ dup +transform-quot+ word-prop ] [ apply-transform ] } + { [ dup +inferred-effect+ word-prop ] [ cached-infer ] } { [ dup "macro" word-prop ] [ apply-macro ] } { [ dup recursive-label ] [ call-recursive-word ] } [ dup infer-word apply-word/effect ] } cond ; : define-primitive ( word inputs outputs -- ) + [ 2drop t +primitive+ set-word-prop ] [ drop "input-classes" set-word-prop ] [ nip "default-output-classes" set-word-prop ] - 3bi ; + 3tri ; ! Stack effects for all primitives \ fixnum< { fixnum fixnum } { object } define-primitive diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor index 5ec3f5ad64..d9e889f188 100755 --- a/unfinished/stack-checker/transforms/transforms.factor +++ b/unfinished/stack-checker/transforms/transforms.factor @@ -11,31 +11,45 @@ IN: stack-checker.transforms SYMBOL: +transform-quot+ SYMBOL: +transform-n+ -: (apply-transform) ( quot n -- newquot ) - dup zero? [ - drop recursive-state get 1array - ] [ - consume-d - [ #drop, ] - [ [ literal value>> ] map ] - [ first literal recursion>> ] tri prefix - ] if - swap with-datastack ; +: give-up-transform ( word -- ) + dup recursive-label + [ call-recursive-word ] + [ dup infer-word apply-word/effect ] + if ; + +: ((apply-transform)) ( word quot stack -- ) + swap with-datastack first2 + dup [ swap infer-quot drop ] [ 2drop give-up-transform ] if ; + inline + +: (apply-transform) ( word quot n -- ) + consume-d dup [ known literal? ] all? [ + dup empty? [ + drop recursive-state get 1array + ] [ + [ #drop, ] + [ [ literal value>> ] map ] + [ first literal recursion>> ] tri prefix + ] if + ((apply-transform)) + ] [ 2drop give-up-transform ] if ; : apply-transform ( word -- ) [ +inlined+ depends-on ] [ + [ ] [ +transform-quot+ word-prop ] [ +transform-n+ word-prop ] - bi (apply-transform) - first2 swap infer-quot + tri + (apply-transform) ] bi ; : apply-macro ( word -- ) [ +inlined+ depends-on ] [ + [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] - bi (apply-transform) - first2 swap infer-quot + tri + (apply-transform) ] bi ; : define-transform ( word quot n -- ) @@ -66,20 +80,80 @@ SYMBOL: +transform-n+ \ spread [ spread>quot ] 1 define-transform +\ (call-next-method) [ + [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi +] 2 define-transform + +! Constructors \ boa [ dup tuple-class? [ dup +inlined+ depends-on [ "boa-check" word-prop ] [ tuple-layout '[ , ] ] bi append - ] [ - \ boa \ no-method boa time-bomb - ] if + ] [ drop f ] if ] 1 define-transform -\ (call-next-method) [ - [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi -] 2 define-transform +\ new [ + dup tuple-class? [ + dup +inlined+ depends-on + dup all-slots rest-slice ! delegate slot + [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make + ] [ drop f ] if +] 1 define-transform + +! Membership testing +: bit-member-n 256 ; inline + +: bit-member? ( seq -- ? ) + #! Can we use a fast byte array test here? + { + { [ dup length 8 < ] [ f ] } + { [ dup [ integer? not ] contains? ] [ f ] } + { [ dup [ 0 < ] contains? ] [ f ] } + { [ dup [ bit-member-n >= ] contains? ] [ f ] } + [ t ] + } cond nip ; + +: bit-member-seq ( seq -- flags ) + bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ; + +: exact-float? ( f -- ? ) + dup float? [ dup >integer >float = ] [ drop f ] if ; inline + +: bit-member-quot ( seq -- newquot ) + [ + [ drop ] % ! drop the sequence itself; we don't use it at run time + bit-member-seq , + [ + { + { [ over fixnum? ] [ ?nth 1 eq? ] } + { [ over bignum? ] [ ?nth 1 eq? ] } + { [ over exact-float? ] [ ?nth 1 eq? ] } + [ 2drop f ] + } cond + ] % + ] [ ] make ; + +: member-quot ( seq -- newquot ) + dup bit-member? [ + bit-member-quot + ] [ + [ literalize [ t ] ] { } map>assoc + [ drop f ] suffix [ nip case ] curry + ] if ; + +\ member? [ + dup sequence? [ member-quot ] [ drop f ] if +] 1 define-transform + +: memq-quot ( seq -- newquot ) + [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc + [ drop f ] suffix [ nip cond ] curry ; + +\ memq? [ + dup sequence? [ memq-quot ] [ drop f ] if +] 1 define-transform ! Deprecated \ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform