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.flac
parent
8a21ff40d3
commit
7c58cb88c5
|
@ -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-recursive% ( root prefix -- )
|
||||
dupd vocab-name (disk-vocab-children) [ % ] keep
|
||||
[ disk-vocabs-recursive% ] with each ;
|
||||
: (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 ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue