case now optimizes contiguous integer ranges

core/combinators/combinators-docs.factor

@@ -7,11 +7,7 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
 "Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
 { $subsection cond>quot }
 { $subsection case>quot }
-{ $subsection alist>quot }
+{ $subsection alist>quot } ;
-"A powerful tool used to optimize code in several places is open-coded hashtable dispatch:"
-{ $subsection hash-case>quot }
-{ $subsection distribute-buckets }
-{ $subsection hash-dispatch-quot } ;
 
 ARTICLE: "combinators" "Additional combinators"
 "The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":"
@@ -104,19 +100,17 @@ HELP: case>quot
 { $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } }
 { $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
 $nl
-"The quotation actually tests each possible case in order;" { $link hash-case>quot } " produces more efficient code." } ;
+"This word uses three strategies:"
+{ $list
+    "If the assoc only has a few keys, a linear search is generated."
+    { "If the assoc has a large number of keys which form a contiguous range of integers, a direct dispatch is generated using the " { $link dispatch } " word together with a bounds check." }
+    "Otherwise, an open-coded hashtable dispatch is generated."
+} } ;
 
 HELP: distribute-buckets
 { $values { "assoc" "an alist" } { "initial" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- assoc )" } } { "buckets" "a new array" } }
 { $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." }
-{ $notes "This word is used in the implemention of " { $link hash-case>quot } " and " { $link standard-combination } "." } ;
+{ $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ;
-
-HELP: hash-case>quot
-{ $values { "default" quotation } { "assoc" "an association list mapping quotations to quotations" } { "quot" quotation } }
-{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
-$nl
-"The quotation uses an efficient hash-based search to avoid testing the object against all possible keys." }
-{ $notes "This word is used behind the scenes to compile " { $link case } " forms efficiently; it can also be called directly,  which is useful for meta-programming." } ;
 
 HELP: dispatch ( n array -- )
 { $values { "n" "a fixnum" } { "array" "an array of quotations" } }

core/combinators/combinators-tests.factor

@@ -69,3 +69,10 @@ namespaces combinators words ;
 
 ! Interpreted
 [ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
+
+[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
+[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
+[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test
+[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test
+[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test
+[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test

core/combinators/combinators.factor

@@ -1,8 +1,9 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: combinators
 USING: arrays sequences sequences.private math.private
-kernel kernel.private math assocs quotations vectors ;
+kernel kernel.private math assocs quotations vectors
+hashtables sorting ;
 
 TUPLE: no-cond ;
 
@@ -31,16 +32,24 @@ TUPLE: no-case ;
 : recursive-hashcode ( n obj quot -- code )
     pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
 
+! These go here, not in sequences and hashtables, since those
+! two depend on combinators
 M: sequence hashcode*
     [ sequence-hashcode ] recursive-hashcode ;
 
+M: hashtable hashcode*
+    [
+        dup assoc-size 1 number=
+        [ assoc-hashcode ] [ nip assoc-size ] if
+    ] recursive-hashcode ;
+
 : alist>quot ( default assoc -- quot )
     [ rot \ if 3array append [ ] like ] assoc-each ;
 
 : cond>quot ( assoc -- quot )
     reverse [ no-cond ] swap alist>quot ;
 
-: case>quot ( default assoc -- quot )
+: linear-case-quot ( default assoc -- quot )
     [ >r [ dupd = ] curry r> \ drop add* ] assoc-map
     alist>quot ;
 
@@ -63,20 +72,50 @@ M: sequence hashcode*
 
 : hash-case-table ( default assoc -- array )
     V{ } [ 1array ] distribute-buckets
-    [ case>quot ] with map ;
+    [ linear-case-quot ] with map ;
 
 : hash-dispatch-quot ( table -- quot )
     [ length 1- [ fixnum-bitand ] curry ] keep
     [ dispatch ] curry append ;
 
-: hash-case>quot ( default assoc -- quot )
+: hash-case-quot ( default assoc -- quot )
+    hash-case-table hash-dispatch-quot
+    [ dup hashcode >fixnum ] swap append ;
+
+: contiguous-range? ( keys -- from to ? )
+    dup [ fixnum? ] all? [
+        dup all-unique? [
+            dup infimum over supremum
+            [ - swap prune length + 1 = ] 2keep rot
+        ] [
+            drop f f f
+        ] if
+    ] [
+        drop f f f
+    ] if ;
+
+: dispatch-case ( value from to default array -- )
+    >r >r 3dup between? [
+        drop - >fixnum r> drop r> dispatch
+    ] [
+        2drop r> call r> drop
+    ] if ; inline
+
+: dispatch-case-quot ( default assoc from to -- quot )
+    -roll -roll sort-keys values [ >quotation ] map
+    [ dispatch-case ] 2curry 2curry ;
+
+: case>quot ( default assoc -- quot )
     dup empty? [
         drop
     ] [
         dup length 4 <= [
-            case>quot
+            linear-case-quot
         ] [
-            hash-case-table hash-dispatch-quot
+            dup keys contiguous-range? [
-            [ dup hashcode >fixnum ] swap append
+                dispatch-case-quot
+            ] [
+                2drop hash-case-quot
+            ] if
         ] if
     ] if ;

core/hashtables/hashtables.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private slots.private math assocs
-math.private sequences sequences.private vectors
+math.private sequences sequences.private vectors ;
-combinators ;
 IN: hashtables
 
 <PRIVATE
@@ -161,17 +160,10 @@ M: hashtable clone
     (clone) dup hash-array clone over set-hash-array ;
 
 M: hashtable equal?
-    {
+    over hashtable? [
-        { [ over hashtable? not ] [ 2drop f ] }
+        2dup [ assoc-size ] 2apply number=
-        { [ 2dup [ assoc-size ] 2apply number= not ] [ 2drop f ] }
+        [ assoc= ] [ 2drop f ] if
-        { [ t ] [ assoc= ] }
+    ] [ 2drop f ] if ;
-    } cond ;
-
-M: hashtable hashcode*
-    [
-        dup assoc-size 1 number=
-        [ assoc-hashcode ] [ nip assoc-size ] if
-    ] recursive-hashcode ;
 
 ! Default method
 M: assoc new-assoc drop <hashtable> ;

core/inference/transforms/transforms.factor

@@ -35,7 +35,7 @@ IN: inference.transforms
             dup peek swap 1 head*
         ] [
             [ no-case ] swap
-        ] if hash-case>quot
+        ] if case>quot
     ] if
 ] 1 define-transform