define-partial-eval framework in propagation pass makes it easy to add transforms...

diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index aec61608f1cb9ca83e7fe63b6840c0f2072ab4b6..f5ea64bc0a48348dce16161570f3baf6bc9f88e1 100644 (file)
--- 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 <class-info> ] "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 <hashtable> ] ] }
-        [ 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 '[ _ <tuple-boa> ] ]
-        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 108afad2960ce254cbd5d47d5675aab97c9e8823..0a5dbab88339a2ee0ab3fb7fd1a0e404b4c630d8 100644 (file)
--- 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 (file)
index 0000000..a44f8d7
--- /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 (file)
index 0000000..1441897
--- /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 <hashtable> ] ] }
+        [ 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 '[ _ <tuple-boa> ] ]
+        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 9d1ab1332a3f8c80aacd710350d203f57fe6cbdd..056eda8b6120d0edc86ae4e1a95414e965b77857 100755 (executable)
--- 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