vocabs.hierarchy: faster all-disk-vocabs-recursive.

The old technique caused a high amount of redundant ``exists?`` checks,
even though we are traversing the directory tree.  That happens to be a
little slow on Windows, for some pathological reason, the first time
it's run. This should make it better while we also investigate why
``windows_stat`` is slower in that case.

diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor
index 508af66956a3ca77ab619b68113d63672d2dced0..aa5be0592c4d657434d1f9a65b564078a06f4b31 100644 (file)
--- a/basis/vocabs/hierarchy/hierarchy.factor
+++ b/basis/vocabs/hierarchy/hierarchy.factor
@@ -14,22 +14,11 @@ M: vocab-prefix vocab-name name>> ;
 
 <PRIVATE
 
+: visible-dir? ( entry -- ? )
+    { [ directory? ] [ name>> "." head? not ] } 1&& ;
+
 : visible-dirs ( seq -- seq' )
-    [
-        {
-            [ directory? ]
-            [ name>> "." head? not ]
-        } 1&&
-    ] filter ;
-
-: vocab-subdirs ( dir -- dirs )
-    directory-entries visible-dirs [ name>> ] map! natural-sort ;
-
-: vocab-dir? ( root name -- ? )
-    over
-    [ ".factor" append-vocab-dir append-path exists? ]
-    [ 2drop f ]
-    if ;
+    [ visible-dir? ] filter ;
 
 ERROR: vocab-root-required root ;
 
@@ -39,20 +28,36 @@ ERROR: vocab-root-required root ;
 : ensure-vocab-root/prefix ( root prefix -- root prefix )
     [ ensure-vocab-root ] [ check-vocab-name ] bi* ;
 
-: (disk-vocab-children) ( root prefix -- vocabs )
-    check-vocab-name
-    [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]
-    [ nip [ "." append '[ _ prepend ] map! ] unless-empty ]
-    [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map! ]
-    2tri ;
+: vocab-directory-entries ( root prefix -- vocab-path vocab-name entries )
+    [ ensure-vocab-root ] dip [ append-path ] keep
+    over dup exists? [ directory-entries ] [ drop { } ] if ;
+
+: (disk-vocabs) ( root prefix -- seq )
+    vocab-directory-entries visible-dirs [ name>> ] sort-with [
+        name>>
+        [ dup ".factor" append append-path append-path ]
+        [ over empty? [ nip ] [ "." glue ] if ] bi-curry bi*
+        swap exists? [ >vocab-link ] [ <vocab-prefix> ] if
+    ] 2with map ;
+
+DEFER: add-vocab%
+
+: add-vocab-children% ( vocab-path vocab-name entries -- )
+    visible-dirs [
+        name>>
+        [ append-path ]
+        [ over empty? [ nip ] [ "." glue ] if ] bi-curry bi*
+        over directory-entries add-vocab%
+    ] 2with each ;
 
-: disk-vocabs-recursive% ( root prefix -- )
-    dupd vocab-name (disk-vocab-children) [ % ] keep
-    [ disk-vocabs-recursive% ] with each ;
+: add-vocab% ( vocab-path vocab-name entries -- )
+    3dup rot file-name ".factor" append '[ name>> _ =  ] any?
+    [ >vocab-link ] [ <vocab-prefix> ] if , add-vocab-children% ;
 
 : (disk-vocabs-recursive) ( root prefix -- seq )
-    [ ensure-vocab-root ] dip
-    [ disk-vocabs-recursive% ] { } make ;
+    vocab-directory-entries
+    [ add-vocab-children% ] { } make
+    [ name>> ] sort-with ;
 
 : no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ;
 
@@ -77,7 +82,7 @@ PRIVATE>
     no-roots no-prefixes members ;
 
 : disk-vocabs-for-prefix ( prefix -- assoc )
-    [ [ vocab-roots get ] dip '[ dup _ (disk-vocab-children) ] { } map>assoc ]
+    [ [ vocab-roots get ] dip '[ dup _ (disk-vocabs) ] { } map>assoc ]
     [ unrooted-disk-vocabs [ lookup-vocab ] map! f swap 2array ]
     bi suffix ;