msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

My profiling showed that the BinTree operations were responsible for about 60% of the CPU time when reading a large .gfo file. Replacing BinTree by Data.Map reduced this to about 6%, which meant about 50% reduction in total CPU time.

Browse Source
This commit is contained in:
bjorn
2008-11-26 15:44:22 +00:00
parent 22269d277e
commit 499d6ade49
8 changed files with 45 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
src/GF/Compile/BackOpt.hs
View File

@@ -38,10 +38,11 @@ shareModule opt (i,m) = case m of
(i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo))))
_ -> (i,m)
shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (shareOptim opt c t)) m)
shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (shareOptim opt c t)) m)
shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (shareOptim opt c t)))
shareInfo _ i = i
shareInfo :: OptSpec -> (Ident, Info) -> Info
shareInfo opt (c, CncCat ty (Yes t) m) = CncCat ty (Yes (shareOptim opt c t)) m
shareInfo opt (c, CncFun kxs (Yes t) m) = CncFun kxs (Yes (shareOptim opt c t)) m
shareInfo opt (c, ResOper ty (Yes t)) = ResOper ty (Yes (shareOptim opt c t))
shareInfo _ (_,i) = i
-- the function putting together optimizations
shareOptim :: OptSpec -> Ident -> Term -> Term

3
src/GF/Compile/Coding.hs
View File

@@ -26,13 +26,12 @@ codeSourceModule co (id,moi) = case moi of
ModMod mo -> (id, ModMod $ replaceJudgements mo (mapTree codj (jments mo)))
_ -> (id,moi)
where
codj (c,info) = (c, case info of
codj (c,info) = case info of
ResOper pty pt -> ResOper (mapP codt pty) (mapP codt pt)
ResOverload es tyts -> ResOverload es [(codt ty,codt t) | (ty,t) <- tyts]
CncCat pty pt mpr -> CncCat pty (mapP codt pt) (mapP codt mpr)
CncFun mty pt mpr -> CncFun mty (mapP codt pt) (mapP codt mpr)
_ -> info
)
codt t = case t of
K s -> K (co s)
T ty cs -> T ty [(codp p,codt v) | (p,v) <- cs]

10
src/GF/Compile/GrammarToGFCC.hs
View File

@@ -283,9 +283,9 @@ canon2canon abs cg0 =
j2j cg (f,j) =
let debug = traceD ("+ " ++ prt f) in
case j of
CncFun x (Yes tr) z -> (f,CncFun x (Yes (debug (t2t tr))) z)
CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y)
_ -> (f,j)
CncFun x (Yes tr) z -> CncFun x (Yes (debug (t2t tr))) z
CncCat (Yes ty) (Yes x) y -> CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y
_ -> j
where
cg1 = cg
t2t = term2term f cg1 pv
@@ -295,8 +295,8 @@ canon2canon abs cg0 =
-- flatten record arguments of param constructors
p2p (f,j) = case j of
ResParam (Yes (ps,v)) ->
(f,ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing)))
_ -> (f,j)
ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing))
_ -> j
unRec (x,ty) = case ty of
RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (identW,typ)]
_ -> [(x,ty)]

8
src/GF/Compile/Optimize.hs
View File

@@ -107,7 +107,7 @@ evalResInfo oopts gr (c,info) = case info of
evalCncInfo ::
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err Info
evalCncInfo opts gr cnc abs (c,info) = do
seq (prtIf (verbAtLeast opts Verbose) c) $ return ()
@@ -126,7 +126,7 @@ evalCncInfo opts gr cnc abs (c,info) = do
ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c)
return (c, CncCat ptyp pde' ppr')
return (CncCat ptyp pde' ppr')
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> --trace (prt c) $
eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
@@ -136,9 +136,9 @@ evalCncInfo opts gr cnc abs (c,info) = do
_ -> return pde
ppr' <- liftM yes $ evalPrintname gr c ppr pde'
return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
return $ CncFun mt pde' ppr' -- only cat in type actually needed
_ -> return (c,info)
_ -> return info
where
pEval = partEval opts gr
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")

9
src/GF/Compile/OptimizeGF.hs
View File

@@ -51,10 +51,11 @@ processModule opt (i,m) = case m of
(i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo))))
_ -> (i,m)
shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (opt c t)) m)
shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (opt c t)) m)
shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (opt c t)))
shareInfo _ i = i
shareInfo :: (Ident -> Term -> Term) -> (Ident,Info) -> Info
shareInfo opt (c, CncCat ty (Yes t) m) = CncCat ty (Yes (opt c t)) m
shareInfo opt (c, CncFun kxs (Yes t) m) = CncFun kxs (Yes (opt c t)) m
shareInfo opt (c, ResOper ty (Yes t)) = ResOper ty (Yes (opt c t))
shareInfo _ (_,i) = i
-- the function putting together optimizations
optim :: Ident -> Term -> Term

12
src/GF/Compile/RemoveLiT.hs
View File

@@ -40,12 +40,12 @@ remlModule gr mi@(name,mod) = case mod of
return $ (name,mod2)
_ -> return mi
remlResInfo :: SourceGrammar -> (Ident,Info) -> Err (Ident,Info)
remlResInfo gr mi@(i,info) = case info of
ResOper pty ptr -> liftM ((,) i) $ liftM2 ResOper (ren pty) (ren ptr)
CncCat pty ptr ppr -> liftM ((,) i) $ liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
CncFun mt ptr ppr -> liftM ((,) i) $ liftM2 (CncFun mt) (ren ptr) (ren ppr)
_ -> return mi
remlResInfo :: SourceGrammar -> (Ident,Info) -> Err Info
remlResInfo gr (i,info) = case info of
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr)
_ -> return info
where
ren = remlPerh gr

5
src/GF/Compile/Rename.hs
View File

@@ -115,15 +115,14 @@ renameIdentPatt env p = do
t' <- renameIdentTerm env t
term2patt t'
info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo)
info2status mq (c,i) = (c, case i of
info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo
info2status mq (c,i) = case i of
AbsFun _ (Yes EData) -> maybe Con QC mq
ResValue _ -> maybe Con QC mq
ResParam _ -> maybe Con QC mq
AnyInd True m -> maybe Con (const (QC m)) mq
AnyInd False m -> maybe Cn (const (Q m)) mq
_ -> maybe Cn Q mq
)
tree2status :: OpenSpec Ident -> BinTree Ident Info -> BinTree Ident StatusInfo
tree2status o = case o of

77
src/GF/Data/Operations.hs
View File

@@ -77,7 +77,8 @@ module GF.Data.Operations (-- * misc functions
import Data.Char (isSpace, toUpper, isSpace, isDigit)
import Data.List (nub, sortBy, sort, deleteBy, nubBy)
--import Data.FiniteMap
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus)
import GF.Data.ErrM
@@ -267,32 +268,22 @@ updatePerhapsHard old p1 p2 = case (p1,p2) of
_ -> unifPerhaps p1 p2
-- binary search trees
--- FiniteMap implementation is slower in crucial tests
data BinTree a b = NT | BT (a,b) !(BinTree a b) !(BinTree a b) deriving (Show)
-- type BinTree a b = FiniteMap a b
type BinTree a b = Map a b
emptyBinTree :: BinTree a b
emptyBinTree = NT
-- emptyBinTree = emptyFM
emptyBinTree = Map.empty
isInBinTree :: (Ord a) => a -> BinTree a b -> Bool
isInBinTree x = err (const False) (const True) . justLookupTree x
-- isInBinTree = elemFM
isInBinTree = Map.member
justLookupTree :: (Monad m,Ord a) => a -> BinTree a b -> m b
justLookupTree = lookupTree (const [])
lookupTree :: (Monad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b
lookupTree pr x tree = case tree of
NT -> fail ("no occurrence of element" +++ pr x)
BT (a,b) left right
| x < a -> lookupTree pr x left
| x > a -> lookupTree pr x right
| x == a -> return b
--lookupTree pr x tree = case lookupFM tree x of
-- Just y -> return y
-- _ -> fail ("no occurrence of element" +++ pr x)
lookupTree pr x tree = case Map.lookup x tree of
Just y -> return y
_ -> fail ("no occurrence of element" +++ pr x)
lookupTreeMany :: Ord a => (a -> String) -> [BinTree a b] -> a -> Err b
lookupTreeMany pr (t:ts) x = case lookupTree pr x t of
@@ -306,60 +297,26 @@ lookupTreeManyAll pr (t:ts) x = case lookupTree pr x t of
_ -> lookupTreeManyAll pr ts x
lookupTreeManyAll pr [] x = []
-- | destructive update
updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b
-- updateTree (a,b) tr = addToFM tr a b
updateTree = updateTreeGen True
-- | destructive or not
updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree a b -> BinTree a b
updateTreeGen destr z@(x,y) tree = case tree of
NT -> BT z NT NT
BT c@(a,b) left right
| x < a -> let left' = updateTree z left in BT c left' right
| x > a -> let right' = updateTree z right in BT c left right'
| otherwise -> if destr
then BT z left right -- removing the old value of a
else tree -- retaining the old value if one exists
updateTree (a,b) = Map.insert a b
buildTree :: (Ord a) => [(a,b)] -> BinTree a b
buildTree = sorted2tree . sortBy fs where
fs (x,_) (y,_)
| x < y = LT
| x > y = GT
| True = EQ
-- buildTree = listToFM
buildTree = Map.fromList
sorted2tree :: Ord a => [(a,b)] -> BinTree a b
sorted2tree [] = NT
sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where
(t1,(x:t2)) = splitAt (length xs `div` 2) xs
--sorted2tree = listToFM
sorted2tree = Map.fromAscList
--- dm less general than orig
mapTree :: ((a,b) -> (a,c)) -> BinTree a b -> BinTree a c
mapTree f NT = NT
mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right)
--mapTree f = mapFM (\k v -> snd (f (k,v)))
mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c
mapTree f = Map.mapWithKey (\k v -> f (k,v))
--- fm less efficient than orig?
mapMTree :: (Ord a,Monad m) => ((a,b) -> m (a,c)) -> BinTree a b -> m (BinTree a c)
mapMTree f NT = return NT
mapMTree f (BT a left right) = do
a' <- f a
left' <- mapMTree f left
right' <- mapMTree f right
return $ BT a' left' right'
--mapMTree f t = liftM listToFM $ mapM f $ fmToList t
mapMTree :: (Ord a,Monad m) => ((a,b) -> m c) -> BinTree a b -> m (BinTree a c)
mapMTree f t = liftM Map.fromList $ sequence [liftM ((,) k) (f (k,x)) | (k,x) <- Map.toList t]
filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b
-- filterFM f t
filterBinTree f = sorted2tree . filter (uncurry f) . tree2list
filterBinTree = Map.filterWithKey
tree2list :: BinTree a b -> [(a,b)] -- inorder
tree2list NT = []
tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right
--tree2list = fmToList
tree2list = Map.toList
-- parsing