diff options
Diffstat (limited to 'src/GF/Compile/BackOpt.hs')
| -rw-r--r-- | src/GF/Compile/BackOpt.hs | 141 |
1 files changed, 0 insertions, 141 deletions
diff --git a/src/GF/Compile/BackOpt.hs b/src/GF/Compile/BackOpt.hs deleted file mode 100644 index 8356f2ba2..000000000 --- a/src/GF/Compile/BackOpt.hs +++ /dev/null @@ -1,141 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : BackOpt --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:33 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- Optimizations on GF source code: sharing, parametrization, value sets. --- --- optimization: sharing branches in tables. AR 25\/4\/2003. --- following advice of Josef Svenningsson ------------------------------------------------------------------------------ - -module GF.Compile.BackOpt (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import qualified GF.Grammar.Macros as C -import GF.Grammar.PrGrammar (prt) -import GF.Data.Operations -import Data.List -import qualified GF.Infra.Modules as M - -type OptSpec = [Integer] --- - -doOptFactor :: OptSpec -> Bool -doOptFactor opt = elem 2 opt - -doOptValues :: OptSpec -> Bool -doOptValues opt = elem 3 opt - -shareOpt :: OptSpec -shareOpt = [] - -paramOpt :: OptSpec -paramOpt = [2] - -valOpt :: OptSpec -valOpt = [3] - -allOpt :: OptSpec -allOpt = [2,3] - -shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) -shareModule opt (i,m) = case m of - M.ModMod (M.Module mt st fs me ops js) -> - (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js))) - _ -> (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 - --- the function putting together optimizations -shareOptim :: OptSpec -> Ident -> Term -> Term -shareOptim opt c - | doOptFactor opt && doOptValues opt = values . factor c 0 - | doOptFactor opt = share . factor c 0 - | doOptValues opt = values - | otherwise = share - --- we need no counter to create new variable names, since variables are --- local to tables (only true in GFC) --- - -share :: Term -> Term -share t = case t of - T ty@(TComp _) cs -> shareT ty [(p, share v) | (p, v) <- cs] - _ -> C.composSafeOp share t - - where - shareT ty = finalize ty . groupC . sortC - - sortC :: [(Patt,Term)] -> [(Patt,Term)] - sortC = sortBy $ \a b -> compare (snd a) (snd b) - - groupC :: [(Patt,Term)] -> [[(Patt,Term)]] - groupC = groupBy $ \a b -> snd a == snd b - - finalize :: TInfo -> [[(Patt,Term)]] -> Term - finalize ty css = TSh ty [(map fst ps, t) | ps@((_,t):_) <- css] - --- do even more: factor parametric branches - -factor :: Ident -> Int -> Term -> Term -factor c i t = case t of - T _ [_] -> t - T _ [] -> t - T (TComp ty) cs -> - T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs] - _ -> C.composSafeOp (factor c i) t - where - - factors i psvs = -- we know psvs has at least 2 elements - let p = qqIdent c i - vs' = map (mkFun p) psvs - in if allEqs vs' - then mkCase p vs' - else psvs - - mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val - - allEqs (v:vs) = all (==v) vs - - mkCase p (v:_) = [(PV p, v)] - ---- we hope this will be fresh and don't check... in GFC would be safe - -qqIdent c i = identC ("q_" ++ prt c ++ "__" ++ show i) - - --- we need to replace subterms - -replace :: Term -> Term -> Term -> Term -replace old new trm = case trm of - - -- these are the important cases, since they can correspond to patterns - QC _ _ | trm == old -> new - App t ts | trm == old -> new - App t ts -> App (repl t) (repl ts) - R _ | isRec && trm == old -> new - _ -> C.composSafeOp repl trm - where - repl = replace old new - isRec = case trm of - R _ -> True - _ -> False - --- It is very important that this is performed only after case --- expansion since otherwise the order and number of values can --- be incorrect. Guaranteed by the TComp flag. - -values :: Term -> Term -values t = case t of - T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization - T (TComp ty) cs -> V ty [values t | (_, t) <- cs] - _ -> C.composSafeOp values t |
