From c15fa176351ca75892a52474ef29d893a64a47cf Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 16 Jan 2024 11:52:45 -0400 Subject: [PATCH] optimise adjustTree when adding many TreeItems (take 2) The old code traversed the list of addtreeitems once per subdirectory in the tree, so could get quite slow. Converting to Map lookups sped it up significantly. In my test case, git-annex import used to take about 2 minutes, when calling adjustTree to add back excluded files to the imported tree. This dropped it down to 6 seconds. Of which 4 seconds are the actual enumeration of the contents of the remote, so really only 2 seconds for this. The path prefix map is a bit suboptimal memory-wise, since items get stored in the map once per subdirectory on the path to the item. It would perhaps be better to use a tree data structure. Also it's suboptimal memory-wise that it builds two maps, as well as retaining a reference to addtreeitems. I could not see a way around that though. This is a fixed version of commit 2c86651180d5c8648b8244be894c26bc98a6c334. It fixes a test suite reversion. Sponsored-by: Jack Hill on Patreon --- Git/Tree.hs | 68 ++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 54 insertions(+), 14 deletions(-) diff --git a/Git/Tree.hs b/Git/Tree.hs index 06f8c21081..af2a132aa4 100644 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -1,11 +1,12 @@ {- git trees - - - Copyright 2016-2021 Joey Hess + - Copyright 2016-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Tree ( Tree(..), @@ -231,7 +232,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo = withMkTreeHandle repo $ \h -> do (l, cleanup) <- liftIO $ lsTreeWithObjects LsTree.LsTreeRecursive r repo (l', _, _) <- go h False [] 1 inTopTree l - l'' <- adjustlist h 0 inTopTree (const True) l' + l'' <- adjustlist h 0 inTopTree topTreePath l' sha <- liftIO $ mkTree h l'' void $ liftIO cleanup return sha @@ -250,7 +251,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo = in go h modified (blob:c) depth intree is Just TreeObject -> do (sl, modified, is') <- go h False [] (depth+1) (beneathSubTree i) is - sl' <- adjustlist h depth (inTree i) (beneathSubTree i) sl + sl' <- adjustlist h depth (inTree i) (gitPath i) sl let slmodified = sl' /= sl subtree <- if modified || slmodified then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) sl' @@ -268,16 +269,22 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo = _ -> giveup ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"") | otherwise = return (c, wasmodified, i:is) - adjustlist h depth ishere underhere l = do - let (addhere, rest) = partition ishere addtreeitems + adjustlist h depth ishere herepath l = do + let addhere = fromMaybe [] $ M.lookup herepath addtreeitempathmap let l' = filter (not . removed) $ addoldnew l (map treeItemToTreeContent addhere) let inl i = any (\t -> beneathSubTree t i) l' let (Tree addunderhere) = flattenTree depth $ treeItemsToTree $ - filter (\i -> underhere i && not (inl i)) rest + filter (not . inl) $ if herepath == topTreePath + then filter (not . ishere) addtreeitems + else fromMaybe [] $ + M.lookup (subTreePrefix herepath) addtreeitemprefixmap addunderhere' <- liftIO $ mapM (recordSubTree h) addunderhere return (addoldnew l' addunderhere') + addtreeitempathmap = mkPathMap addtreeitems + addtreeitemprefixmap = mkSubTreePathPrefixMap addtreeitems + removeset = S.fromList $ map (P.normalise . gitPath) removefiles removed (TreeBlob f _ _) = S.member (P.normalise (gitPath f)) removeset removed (TreeCommit f _ _) = S.member (P.normalise (gitPath f)) removeset @@ -355,12 +362,8 @@ graftTree' subtree graftloc basetree repo hdl = go basetree subdirs graftdirs subdirs = P.splitDirectories $ gitPath graftloc - -- For a graftloc of "foo/bar/baz", this generates - -- ["foo", "foo/bar", "foo/bar/baz"] graftdirs = map (asTopFilePath . toInternalGitPath) $ - mkpaths [] subdirs - mkpaths _ [] = [] - mkpaths base (d:rest) = (P.joinPath base P. d) : mkpaths (base ++ [d]) rest + pathPrefixes subdirs {- Assumes the list is ordered, with tree objects coming right before their - contents. -} @@ -413,13 +416,50 @@ instance GitPath TreeContent where gitPath (TreeCommit f _ _) = gitPath f inTopTree :: GitPath t => t -> Bool -inTopTree = inTree "." +inTopTree = inTree topTreePath + +topTreePath :: RawFilePath +topTreePath = "." inTree :: (GitPath t, GitPath f) => t -> f -> Bool inTree t f = gitPath t == P.takeDirectory (gitPath f) beneathSubTree :: (GitPath t, GitPath f) => t -> f -> Bool -beneathSubTree t f = prefix `B.isPrefixOf` P.normalise (gitPath f) +beneathSubTree t f = subTreePrefix t `B.isPrefixOf` subTreePath f + +subTreePath :: GitPath t => t -> RawFilePath +subTreePath = P.normalise . gitPath + +subTreePrefix :: GitPath t => t -> RawFilePath +subTreePrefix t + | B.null tp = tp + | otherwise = P.addTrailingPathSeparator (P.normalise tp) where tp = gitPath t - prefix = if B.null tp then tp else P.addTrailingPathSeparator (P.normalise tp) + +{- Makes a Map where the keys are directories, and the values + - are the items located in that directory. + - + - Values that are not in any subdirectory are placed in + - the topTreePath key. + -} +mkPathMap :: GitPath t => [t] -> M.Map RawFilePath [t] +mkPathMap l = M.fromListWith (++) $ + map (\ti -> (P.takeDirectory (gitPath ti), [ti])) l + +{- Input is eg splitDirectories "foo/bar/baz", + - for which it will output ["foo", "foo/bar", "foo/bar/baz"] -} +pathPrefixes :: [RawFilePath] -> [RawFilePath] +pathPrefixes = go [] + where + go _ [] = [] + go base (d:rest) = (P.joinPath base P. d) : go (base ++ [d]) rest + +{- Makes a Map where the keys are all subtree path prefixes, + - and the values are items with that subtree path prefix. + -} +mkSubTreePathPrefixMap :: GitPath t => [t] -> M.Map RawFilePath [t] +mkSubTreePathPrefixMap l = M.fromListWith (++) $ concatMap go l + where + go ti = map (\p -> (p, [ti])) + (map subTreePrefix $ pathPrefixes $ P.splitDirectories $ subTreePath ti)