From 51fff6daed68ec671bdc3d0d568d3fef91ad5bcd Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 3 Oct 2007 16:04:30 +0000 Subject: [PATCH] added optimization to GrammarToGFCC --- src/GF/Canon/GFCC/CheckGFCC.hs | 8 +- src/GF/Devel/GFC.hs | 4 +- src/GF/Devel/GrammarToGFCC.hs | 138 --------------------------------- src/GF/Devel/OptimizeGFCC.hs | 121 +++++++++++++++++++++++++++++ 4 files changed, 130 insertions(+), 141 deletions(-) create mode 100644 src/GF/Devel/OptimizeGFCC.hs diff --git a/src/GF/Canon/GFCC/CheckGFCC.hs b/src/GF/Canon/GFCC/CheckGFCC.hs index a94e0e1fb..05f591627 100644 --- a/src/GF/Canon/GFCC/CheckGFCC.hs +++ b/src/GF/Canon/GFCC/CheckGFCC.hs @@ -25,8 +25,12 @@ checkGFCC gfcc = do checkConcrete :: GFCC -> (CId,Concr) -> IO ((CId,Concr),Bool) checkConcrete gfcc (lang,cnc) = labelBoolIO ("happened in language " ++ printTree lang) $ do - (rs,bs) <- mapM (checkLin gfcc lang) (linRules cnc) >>= return . unzip + (rs,bs) <- mapM checkl (Map.assocs cnc) >>= return . unzip return ((lang,Map.fromAscList rs),and bs) + where + checkl r@(CId f,_) = case head f of + '_' -> return (r,True) + _ -> checkLin gfcc lang r checkLin :: GFCC -> CId -> (CId,Term) -> IO ((CId,Term),Bool) checkLin gfcc lang (f,t) = @@ -89,7 +93,7 @@ checkTerm (args,val) trm = case inferTerm args trm of putStrLn $ "term: " ++ printTree trm ++ "\nexpected type: " ++ printTree val ++ "\ninferred type: " ++ printTree ty - return (trm,False) + return (t,False) Bad s -> do putStrLn s return (trm,False) diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs index 0e3c75501..8b694c3dc 100644 --- a/src/GF/Devel/GFC.hs +++ b/src/GF/Devel/GFC.hs @@ -2,6 +2,7 @@ module Main where import GF.Devel.Compile import GF.Devel.GrammarToGFCC +import GF.Devel.OptimizeGFCC import GF.Canon.GFCC.CheckGFCC import GF.Canon.GFCC.PrintGFCC import GF.Canon.GFCC.DataGFCC @@ -21,7 +22,8 @@ main = do gr <- batchCompile opts fs let name = justModuleName (last fs) let (abs,gc0) = mkCanon2gfcc opts name gr - gc <- check gc0 + gc1 <- check gc0 + let gc = if oElem (iOpt "noopt") opts then gc1 else optGFCC gc1 let target = abs ++ ".gfcc" writeFile target (printGFCC gc) putStrLn $ "wrote file " ++ target diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index 6a499b21f..0b226acf2 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -48,7 +48,6 @@ canon2gfcc opts cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = (f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f] cncs = [C.Cnc (i2i lang) (concr m) | (lang,M.ModMod m) <- cms] concr mo = cats mo ++ lindefs mo ++ - (if oElem (iOpt "noopt") opts then id else optConcrete) [C.Lin (i2i f) (mkTerm tr) | (f,CncFun _ (Yes tr) _) <- tree2list (M.jments mo)] cats mo = [C.Lin (i2ic c) (mkCType ty) | @@ -355,16 +354,6 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of mkLab k = LIdent (("_" ++ show k)) - -{- -{CommonScand.VI} ({CommonScand.VSupin} (table ({CommonScand.VType} ) { - CommonScand.VAct => {CommonScand.Act} ; - CommonScand.VPass => {CommonScand.Pass} ; - CommonScand.VRefl => {CommonScand.Act} -} ! {CommonScand.VAct} --} - - -- remove lock fields; in fact, any empty records and record types unlock = filter notlock where notlock (l,(_, t)) = case t of --- need not look at l @@ -378,130 +367,3 @@ unlockTyp = filter notlock where prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n --- back-end optimization: --- suffix analysis followed by common subexpression elimination - -optConcrete :: [C.CncDef] -> [C.CncDef] -optConcrete defs = subex - [C.Lin f (optTerm t) | C.Lin f t <- defs] - --- analyse word form lists into prefix + suffixes --- suffix sets can later be shared by subex elim - -optTerm :: C.Term -> C.Term -optTerm tr = case tr of - C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts] - C.R ts -> C.R $ map optTerm ts - C.P t v -> C.P (optTerm t) v - C.L x t -> C.L x (optTerm t) - _ -> tr - where - optToks ss = prf : suffs where - prf = pref (head ss) (tail ss) - suffs = map (drop (length prf)) ss - pref cand ss = case ss of - s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss - _ -> cand - isK t = case t of - C.K (C.KS _) -> True - _ -> False - mkSuff ("":ws) = C.R (map (C.K . C.KS) ws) - mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws)) - - --- common subexpression elimination; see ./Subexpression.hs for the idea - -subex :: [C.CncDef] -> [C.CncDef] -subex js = errVal js $ do - (tree,_) <- appSTM (getSubtermsMod js) (Map.empty,0) - return $ addSubexpConsts tree js - -type TermList = Map.Map C.Term (Int,Int) -- number of occs, id -type TermM a = STM (TermList,Int) a - -addSubexpConsts :: TermList -> [C.CncDef] -> [C.CncDef] -addSubexpConsts tree lins = - let opers = sortBy (\ (C.Lin f _) (C.Lin g _) -> compare f g) - [C.Lin (fid id) trm | (trm,(_,id)) <- list] - in map mkOne $ opers ++ lins - where - mkOne (C.Lin f trm) = (C.Lin f (recomp f trm)) - recomp f t = case Map.lookup t tree of - Just (_,id) | fid id /= f -> C.F $ fid id -- not to replace oper itself - _ -> case t of - C.R ts -> C.R $ map (recomp f) ts - C.S ts -> C.S $ map (recomp f) ts - C.W s t -> C.W s (recomp f t) - C.P t p -> C.P (recomp f t) (recomp f p) - C.RP t p -> C.RP (recomp f t) (recomp f p) - C.L x t -> C.L x (recomp f t) - _ -> t - fid n = C.CId $ "_" ++ show n - list = Map.toList tree - -getSubtermsMod :: [C.CncDef] -> TermM TermList -getSubtermsMod js = do - mapM (getInfo collectSubterms) js - (tree0,_) <- readSTM - return $ Map.filter (\ (nu,_) -> nu > 1) tree0 - where - getInfo get (C.Lin f trm) = do - get trm - return () - -collectSubterms :: C.Term -> TermM () -collectSubterms t = case t of - C.R ts -> do - mapM collectSubterms ts - add t - C.RP u v -> do - collectSubterms v - add t - C.S ts -> do - mapM collectSubterms ts - add t - C.W s u -> do - collectSubterms u - add t - C.P p u -> do - collectSubterms p - collectSubterms u - add t - _ -> return () - where - add t = do - (ts,i) <- readSTM - let - ((count,id),next) = case Map.lookup t ts of - Just (nu,id) -> ((nu+1,id), i) - _ -> ((1, i ), i+1) - writeSTM (Map.insert t (count,id) ts, next) - -{- --- needed in the past -isStr tr = case tr of - App _ _ -> False - QC _ _ -> False - EInt _ -> False - R rs -> any (isStr . trmAss) rs - FV ts -> any isStr ts - S t _ -> isStr t - Empty -> True - T _ cs -> any isStr [v | (_, v) <- cs] - V _ ts -> any isStr ts - P t r -> case getLab tr of - Ok (cat,labs) -> case - Map.lookup (cat,labs) labels of - Just (ty,_) -> isStrType ty - _ -> True ---- TODO? - _ -> True - _ -> True ---- - trmAss (_,(_, t)) = t - - -isStrType ty = case ty of - Sort "Str" -> True - RecType ts -> any isStrType [t | (_, t) <- ts] - Table _ t -> isStrType t - _ -> False --} diff --git a/src/GF/Devel/OptimizeGFCC.hs b/src/GF/Devel/OptimizeGFCC.hs new file mode 100644 index 000000000..27f510828 --- /dev/null +++ b/src/GF/Devel/OptimizeGFCC.hs @@ -0,0 +1,121 @@ +module GF.Devel.OptimizeGFCC where + +import qualified GF.Canon.GFCC.AbsGFCC as C +import qualified GF.Canon.GFCC.DataGFCC as D +import qualified GF.Canon.GFCC.PrintGFCC as Pr + +import qualified GF.Infra.Option as O + +import GF.Infra.Option +import GF.Data.Operations + +import Data.List +import Data.Char (isDigit) +import qualified Data.Map as Map +import Debug.Trace ---- + + +-- back-end optimization: +-- suffix analysis followed by common subexpression elimination + +optGFCC :: D.GFCC -> D.GFCC +optGFCC gfcc = gfcc { + D.concretes = + Map.fromAscList + [(lang, (opt cnc)) | (lang,cnc) <- Map.assocs (D.concretes gfcc)] + } + where + opt cnc = Map.fromAscList $ subex [(f,optTerm t) | (f,t) <- Map.assocs cnc] + +-- analyse word form lists into prefix + suffixes +-- suffix sets can later be shared by subex elim + +optTerm :: C.Term -> C.Term +optTerm tr = case tr of + C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts] + C.R ts -> C.R $ map optTerm ts + C.P t v -> C.P (optTerm t) v + C.L x t -> C.L x (optTerm t) + _ -> tr + where + optToks ss = prf : suffs where + prf = pref (head ss) (tail ss) + suffs = map (drop (length prf)) ss + pref cand ss = case ss of + s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss + _ -> cand + isK t = case t of + C.K (C.KS _) -> True + _ -> False + mkSuff ("":ws) = C.R (map (C.K . C.KS) ws) + mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws)) + + +-- common subexpression elimination; see ./Subexpression.hs for the idea + +subex :: [(C.CId,C.Term)] -> [(C.CId,C.Term)] +subex js = errVal js $ do + (tree,_) <- appSTM (getSubtermsMod js) (Map.empty,0) + return $ addSubexpConsts tree js + +type TermList = Map.Map C.Term (Int,Int) -- number of occs, id +type TermM a = STM (TermList,Int) a + +addSubexpConsts :: TermList -> [(C.CId,C.Term)] -> [(C.CId,C.Term)] +addSubexpConsts tree lins = + let opers = sortBy (\ (f,_) (g,_) -> compare f g) + [(fid id, trm) | (trm,(_,id)) <- list] + in map mkOne $ opers ++ lins + where + mkOne (f,trm) = (f, recomp f trm) + recomp f t = case Map.lookup t tree of + Just (_,id) | fid id /= f -> C.F $ fid id -- not to replace oper itself + _ -> case t of + C.R ts -> C.R $ map (recomp f) ts + C.S ts -> C.S $ map (recomp f) ts + C.W s t -> C.W s (recomp f t) + C.P t p -> C.P (recomp f t) (recomp f p) + C.RP t p -> C.RP (recomp f t) (recomp f p) + C.L x t -> C.L x (recomp f t) + _ -> t + fid n = C.CId $ "_" ++ show n + list = Map.toList tree + +getSubtermsMod :: [(C.CId,C.Term)] -> TermM TermList +getSubtermsMod js = do + mapM (getInfo collectSubterms) js + (tree0,_) <- readSTM + return $ Map.filter (\ (nu,_) -> nu > 1) tree0 + where + getInfo get (f,trm) = do + get trm + return () + +collectSubterms :: C.Term -> TermM () +collectSubterms t = case t of + C.R ts -> do + mapM collectSubterms ts + add t + C.RP u v -> do + collectSubterms v + add t + C.S ts -> do + mapM collectSubterms ts + add t + C.W s u -> do + collectSubterms u + add t + C.P p u -> do + collectSubterms p + collectSubterms u + add t + _ -> return () + where + add t = do + (ts,i) <- readSTM + let + ((count,id),next) = case Map.lookup t ts of + Just (nu,id) -> ((nu+1,id), i) + _ -> ((1, i ), i+1) + writeSTM (Map.insert t (count,id) ts, next) +