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

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

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

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

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