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.

src/GF/Compile/BackOpt.hs

@@ -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 :: OptSpec -> (Ident, Info) -> Info
-shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (shareOptim opt c t)) m)
+shareInfo opt (c, CncCat ty (Yes t) m) = CncCat ty (Yes (shareOptim opt c t)) m
-shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (shareOptim opt c t)))
+shareInfo opt (c, CncFun kxs (Yes t) m) = CncFun kxs (Yes (shareOptim opt c t)) m
-shareInfo _ i = i
+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

src/GF/Compile/Coding.hs

@@ -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]

src/GF/Compile/GrammarToGFCC.hs

@@ -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)
+      CncFun x (Yes tr) z -> CncFun x (Yes (debug (t2t tr))) z
-      CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y)
+      CncCat (Yes ty) (Yes x) y -> CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y
-      _ -> (f,j)
+      _ -> 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)))
+        ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing))
-      _ -> (f,j)
+      _ -> j
   unRec (x,ty) = case ty of
       RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (identW,typ)] 
       _ -> [(x,ty)]

src/GF/Compile/Optimize.hs

@@ -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 +++ ":")

src/GF/Compile/OptimizeGF.hs

@@ -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 :: (Ident -> Term -> Term) -> (Ident,Info) -> Info
-shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (opt c t)) m)
+shareInfo opt (c, CncCat ty (Yes t) m) = CncCat ty (Yes (opt c t)) m
-shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (opt c t)))
+shareInfo opt (c, CncFun kxs (Yes t) m) = CncFun kxs (Yes (opt c t)) m
-shareInfo _ i = i
+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

src/GF/Compile/RemoveLiT.hs

@@ -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 :: SourceGrammar -> (Ident,Info) -> Err Info
-remlResInfo gr mi@(i,info) = case info of
+remlResInfo gr (i,info) = case info of
-  ResOper pty ptr    -> liftM ((,) i) $ liftM2 ResOper (ren pty) (ren ptr)
+  ResOper pty ptr    -> liftM2 ResOper (ren pty) (ren ptr)
-  CncCat pty ptr ppr -> liftM ((,) i) $ liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
+  CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
-  CncFun mt  ptr ppr -> liftM ((,) i) $ liftM2 (CncFun mt)      (ren ptr) (ren ppr)
+  CncFun mt  ptr ppr -> liftM2 (CncFun mt)      (ren ptr) (ren ppr)
-  _ -> return mi
+  _ -> return info
  where 
    ren = remlPerh gr
 

src/GF/Compile/Rename.hs

@@ -115,15 +115,14 @@ renameIdentPatt env p = do
   t' <- renameIdentTerm env t
   term2patt t'
 
-info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo)
+info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo
-info2status mq (c,i) = (c, case i of
+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

src/GF/Data/Operations.hs

@@ -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 = Map a b
--- type BinTree a b = FiniteMap a b
 
 emptyBinTree :: BinTree a b
-emptyBinTree = NT
+emptyBinTree = Map.empty
--- emptyBinTree = emptyFM
 
 isInBinTree :: (Ord a) => a -> BinTree a b -> Bool
-isInBinTree x = err (const False) (const True) .  justLookupTree x
+isInBinTree = Map.member
--- isInBinTree = elemFM
 
 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
+lookupTree pr x tree = case Map.lookup x tree of
- NT -> fail ("no occurrence of element" +++ pr x)
+  Just y -> return y
- BT (a,b) left right 
+  _ -> fail ("no occurrence of element" +++ pr x)
-   | 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)
 
 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 (a,b) = Map.insert 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
 
 buildTree :: (Ord a) => [(a,b)] -> BinTree a b
-buildTree = sorted2tree . sortBy fs where
+buildTree = Map.fromList
-  fs (x,_) (y,_) 
-    | x < y = LT
-    | x > y = GT
-    | True  = EQ 
--- buildTree = listToFM
 
 sorted2tree :: Ord a => [(a,b)] -> BinTree a b
-sorted2tree [] = NT
+sorted2tree = Map.fromAscList
-sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where
-  (t1,(x:t2)) = splitAt (length xs `div` 2) xs
---sorted2tree = listToFM
 
---- dm less general than orig
+mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c
-mapTree :: ((a,b) -> (a,c)) -> BinTree a b -> BinTree a c
+mapTree f = Map.mapWithKey (\k v -> f (k,v))
-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)))
 
---- fm less efficient than orig?
+mapMTree :: (Ord a,Monad m) => ((a,b) -> m c) -> BinTree a b -> m (BinTree a c)
-mapMTree :: (Ord a,Monad m) => ((a,b) -> m (a,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]
-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
 
 filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b
--- filterFM f t
+filterBinTree = Map.filterWithKey
-filterBinTree f = sorted2tree . filter (uncurry f) . tree2list
 
 tree2list :: BinTree a b -> [(a,b)] -- inorder
-tree2list NT = []
+tree2list = Map.toList
-tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right
---tree2list = fmToList
 
 -- parsing