From ee3e84a1f867850ceb7ad907e951d65a55263e29 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 16 Jul 2009 00:34:50 -0500 Subject: [PATCH] define-partial-eval framework in propagation pass makes it easy to add transforms; moving some transforms from stack checker to propagation, making them stronger --- .../known-words/known-words.factor | 71 +------ .../tree/propagation/propagation-tests.factor | 25 ++- .../tree/propagation/transforms/authors.txt | 2 + .../propagation/transforms/transforms.factor | 195 ++++++++++++++++++ .../transforms/transforms.factor | 94 --------- 5 files changed, 223 insertions(+), 164 deletions(-) create mode 100644 basis/compiler/tree/propagation/transforms/authors.txt create mode 100644 basis/compiler/tree/propagation/transforms/transforms.factor diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index aec61608f1..f5ea64bc0a 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -14,7 +14,8 @@ compiler.tree.propagation.nodes compiler.tree.propagation.slots compiler.tree.propagation.simple compiler.tree.propagation.constraints -compiler.tree.propagation.call-effect ; +compiler.tree.propagation.call-effect +compiler.tree.propagation.transforms ; IN: compiler.tree.propagation.known-words \ fixnum @@ -227,39 +228,6 @@ generic-comparison-ops [ ] "outputs" set-word-prop ] assoc-each -: rem-custom-inlining ( #call -- quot/f ) - second value-info literal>> dup integer? - [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; - -{ - mod-integer-integer - mod-integer-fixnum - mod-fixnum-integer - fixnum-mod -} [ - [ - in-d>> dup first value-info interval>> [0,inf] interval-subset? - [ rem-custom-inlining ] [ drop f ] if - ] "custom-inlining" set-word-prop -] each - -\ rem [ - in-d>> rem-custom-inlining -] "custom-inlining" set-word-prop - -{ - bitand-integer-integer - bitand-integer-fixnum - bitand-fixnum-integer -} [ - [ - in-d>> second value-info >literal< [ - 0 most-positive-fixnum between? - [ [ >fixnum ] bi@ fixnum-bitand ] f ? - ] when - ] "custom-inlining" set-word-prop -] each - { numerator denominator } [ [ drop integer ] "outputs" set-word-prop ] each @@ -314,15 +282,6 @@ generic-comparison-ops [ "outputs" set-word-prop ] each -! Generate more efficient code for common idiom -\ clone [ - in-d>> first value-info literal>> { - { V{ } [ [ drop { } 0 vector boa ] ] } - { H{ } [ [ drop 0 ] ] } - [ drop f ] - } case -] "custom-inlining" set-word-prop - \ slot [ dup literal?>> [ literal>> swap value-info-slot ] [ 2drop object-info ] if @@ -346,29 +305,3 @@ generic-comparison-ops [ bi ] [ 2drop object-info ] if ] "outputs" set-word-prop - -\ instance? [ - in-d>> second value-info literal>> dup class? - [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if -] "custom-inlining" set-word-prop - -\ equal? [ - ! If first input has a known type and second input is an - ! object, we convert this to [ swap equal? ]. - in-d>> first2 value-info class>> object class= [ - value-info class>> \ equal? specific-method - [ swap equal? ] f ? - ] [ drop f ] if -] "custom-inlining" set-word-prop - -: inline-new ( class -- quot/f ) - dup tuple-class? [ - dup inlined-dependency depends-on - [ all-slots [ initial>> literalize ] map ] - [ tuple-layout '[ _ ] ] - bi append [ drop ] prepend >quotation - ] [ drop f ] if ; - -\ new [ - in-d>> first value-info literal>> inline-new -] "custom-inlining" set-word-prop diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 108afad296..0a5dbab883 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals specialized-arrays.double system sorting math.libm -math.intervals quotations ; +math.intervals quotations effects ; IN: compiler.tree.propagation.tests [ V{ } ] [ [ ] final-classes ] unit-test @@ -717,3 +717,26 @@ M: number whatever drop foo ; : that-thing ( -- class ) foo ; [ f ] [ [ that-thing new ] { new } inlined? ] unit-test + +GENERIC: whatever2 ( x -- y ) +M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; +M: f whatever2 ; + +[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test +[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test + +[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test +[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test + +[ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test +[ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test + +[ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test +[ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test + +[ f ] [ [ instance? ] { instance? } inlined? ] unit-test +[ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test +[ t ] [ [ array instance? ] { instance? } inlined? ] unit-test + +[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test +[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test diff --git a/basis/compiler/tree/propagation/transforms/authors.txt b/basis/compiler/tree/propagation/transforms/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/basis/compiler/tree/propagation/transforms/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor new file mode 100644 index 0000000000..1441897b07 --- /dev/null +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -0,0 +1,195 @@ +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences words fry generic accessors classes.tuple +classes classes.algebra definitions stack-checker.state quotations +classes.tuple.private math math.partial-dispatch math.private +math.intervals layouts math.order vectors hashtables +combinators effects generalizations assocs sets +combinators.short-circuit sequences.private locals +stack-checker +compiler.tree.propagation.info ; +IN: compiler.tree.propagation.transforms + +\ equal? [ + ! If first input has a known type and second input is an + ! object, we convert this to [ swap equal? ]. + in-d>> first2 value-info class>> object class= [ + value-info class>> \ equal? specific-method + [ swap equal? ] f ? + ] [ drop f ] if +] "custom-inlining" set-word-prop + +: rem-custom-inlining ( #call -- quot/f ) + second value-info literal>> dup integer? + [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; + +{ + mod-integer-integer + mod-integer-fixnum + mod-fixnum-integer + fixnum-mod +} [ + [ + in-d>> dup first value-info interval>> [0,inf] interval-subset? + [ rem-custom-inlining ] [ drop f ] if + ] "custom-inlining" set-word-prop +] each + +\ rem [ + in-d>> rem-custom-inlining +] "custom-inlining" set-word-prop + +{ + bitand-integer-integer + bitand-integer-fixnum + bitand-fixnum-integer +} [ + [ + in-d>> second value-info >literal< [ + 0 most-positive-fixnum between? + [ [ >fixnum ] bi@ fixnum-bitand ] f ? + ] when + ] "custom-inlining" set-word-prop +] each + +! Generate more efficient code for common idiom +\ clone [ + in-d>> first value-info literal>> { + { V{ } [ [ drop { } 0 vector boa ] ] } + { H{ } [ [ drop 0 ] ] } + [ drop f ] + } case +] "custom-inlining" set-word-prop + +: prepare-partial-eval ( #call n -- value-infos ? ) + +ERROR: bad-partial-eval quot word ; + +: check-effect ( quot word -- ) + 2dup [ infer ] [ stack-effect ] bi* effect<= + [ 2drop ] [ bad-partial-eval ] if ; + +: values ( #call n -- infos ) + [ in-d>> ] dip tail* [ value-info ] map ; + +:: define-partial-eval ( word quot n -- ) + word [ + n values + dup [ literal?>> ] all? [ + [ literal>> ] map + n firstn + quot call dup [ + [ n ndrop ] prepose + dup word check-effect + ] when + ] [ drop f ] if + ] "custom-inlining" set-word-prop ; + +: inline-new ( class -- quot/f ) + dup tuple-class? [ + dup inlined-dependency depends-on + [ all-slots [ initial>> literalize ] map ] + [ tuple-layout '[ _ ] ] + bi append >quotation + ] [ drop f ] if ; + +\ new [ inline-new ] 1 define-partial-eval + +\ instance? [ + dup class? + [ "predicate" word-prop ] [ drop f ] if +] 1 define-partial-eval + +! Shuffling +: nths-quot ( indices -- quot ) + [ [ '[ _ swap nth ] ] map ] [ length ] bi + '[ _ cleave _ narray ] ; + +\ shuffle [ + shuffle-mapping nths-quot +] 1 define-partial-eval + +! Index search +\ index [ + dup sequence? [ + dup length 4 >= [ + dup length zip >hashtable '[ _ at ] + ] [ drop f ] if + ] [ drop f ] if +] 1 define-partial-eval + +: memq-quot ( seq -- newquot ) + [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc + [ drop f ] suffix [ cond ] curry ; + +\ memq? [ + dup sequence? [ memq-quot ] [ drop f ] if +] 1 define-partial-eval + +! Membership testing +: member-quot ( seq -- newquot ) + dup length 4 <= [ + [ drop f ] swap + [ literalize [ t ] ] { } map>assoc linear-case-quot + ] [ + unique [ key? ] curry + ] if ; + +\ member? [ + dup sequence? [ member-quot ] [ drop f ] if +] 1 define-partial-eval + +! Fast at for integer maps +CONSTANT: lookup-table-at-max 256 + +: lookup-table-at? ( assoc -- ? ) + #! Can we use a fast byte array test here? + { + [ assoc-size 4 > ] + [ values [ ] all? ] + [ keys [ integer? ] all? ] + [ keys [ 0 lookup-table-at-max between? ] all? ] + } 1&& ; + +: lookup-table-seq ( assoc -- table ) + [ keys supremum 1+ ] keep '[ _ at ] { } map-as ; + +: lookup-table-quot ( seq -- newquot ) + lookup-table-seq + '[ + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup >boolean + ] [ 2drop f f ] if + ] [ 2drop f f ] if + ] ; + +: fast-lookup-table-at? ( assoc -- ? ) + values { + [ [ integer? ] all? ] + [ [ 0 254 between? ] all? ] + } 1&& ; + +: fast-lookup-table-seq ( assoc -- table ) + lookup-table-seq [ 255 or ] B{ } map-as ; + +: fast-lookup-table-quot ( seq -- newquot ) + fast-lookup-table-seq + '[ + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup 255 eq? [ drop f f ] [ t ] if + ] [ 2drop f f ] if + ] [ 2drop f f ] if + ] ; + +: at-quot ( assoc -- quot ) + dup lookup-table-at? [ + dup fast-lookup-table-at? [ + fast-lookup-table-quot + ] [ + lookup-table-quot + ] if + ] [ drop f ] if ; + +\ at* [ at-quot ] 1 define-partial-eval diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 9d1ab1332a..056eda8b61 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -107,97 +107,3 @@ IN: stack-checker.transforms ] 1 define-transform \ boa t "no-compile" set-word-prop - -! Fast at for integer maps -CONSTANT: lookup-table-at-max 256 - -: lookup-table-at? ( assoc -- ? ) - #! Can we use a fast byte array test here? - { - [ assoc-size 4 > ] - [ values [ ] all? ] - [ keys [ integer? ] all? ] - [ keys [ 0 lookup-table-at-max between? ] all? ] - } 1&& ; - -: lookup-table-seq ( assoc -- table ) - [ keys supremum 1+ ] keep '[ _ at ] { } map-as ; - -: lookup-table-quot ( seq -- newquot ) - lookup-table-seq - '[ - _ over integer? [ - 2dup bounds-check? [ - nth-unsafe dup >boolean - ] [ 2drop f f ] if - ] [ 2drop f f ] if - ] ; - -: fast-lookup-table-at? ( assoc -- ? ) - values { - [ [ integer? ] all? ] - [ [ 0 254 between? ] all? ] - } 1&& ; - -: fast-lookup-table-seq ( assoc -- table ) - lookup-table-seq [ 255 or ] B{ } map-as ; - -: fast-lookup-table-quot ( seq -- newquot ) - fast-lookup-table-seq - '[ - _ over integer? [ - 2dup bounds-check? [ - nth-unsafe dup 255 eq? [ drop f f ] [ t ] if - ] [ 2drop f f ] if - ] [ 2drop f f ] if - ] ; - -: at-quot ( assoc -- quot ) - dup lookup-table-at? [ - dup fast-lookup-table-at? [ - fast-lookup-table-quot - ] [ - lookup-table-quot - ] if - ] [ drop f ] if ; - -\ at* [ at-quot ] 1 define-transform - -! Membership testing -: member-quot ( seq -- newquot ) - dup length 4 <= [ - [ drop f ] swap - [ literalize [ t ] ] { } map>assoc linear-case-quot - ] [ - unique [ key? ] 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 [ cond ] curry ; - -\ memq? [ - dup sequence? [ memq-quot ] [ drop f ] if -] 1 define-transform - -! Index search -\ index [ - dup sequence? [ - dup length 4 >= [ - dup length zip >hashtable '[ _ at ] - ] [ drop f ] if - ] [ drop f ] if -] 1 define-transform - -! Shuffling -: nths-quot ( indices -- quot ) - [ [ '[ _ swap nth ] ] map ] [ length ] bi - '[ _ cleave _ narray ] ; - -\ shuffle [ - shuffle-mapping nths-quot -] 1 define-transform