{-# LANGUAGE PatternGuards #-}
----------------------------------------------------------------------
-- |
-- Module : Optimize
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/16 13:56:13 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.18 $
--
-- Top-level partial evaluation for GF source modules.
-----------------------------------------------------------------------------
module GF.Compile.Optimize (optimizeModule) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Grammar.Printer
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
import GF.Data.Operations
import GF.Infra.Option
import Control.Monad
import qualified Data.Set as Set
import qualified Data.Map as Map
import GF.Text.Pretty
import Debug.Trace
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
optimizeModule :: Options -> SourceGrammar -> SourceModule -> Err SourceModule
optimizeModule opts sgr m@(name,mi)
| mstatus mi == MSComplete = do
ids <- topoSortJments m
mi <- foldM updateEvalInfo mi ids
return (name,mi)
| otherwise = return m
where
oopts = opts `addOptions` mflags mi
resenv = resourceValues oopts sgr
updateEvalInfo mi (i,info) = do
info <- evalInfo oopts resenv sgr (name,mi) i info
return (mi{jments=Map.insert i info (jments mi)})
evalInfo :: Options -> GlobalEnv -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info
evalInfo opts resenv sgr m c info = do
(if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return ()
errIn ("optimizing " ++ showIdent c) $ case info of
CncCat ptyp pde pre ppr mpmcfg -> do
pde' <- case (ptyp,pde) of
(Just (L _ typ), Just (L loc de)) -> do
de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
return (Just (L loc (factor param c 0 de)))
(Just (L loc typ), Nothing) -> do
de <- mkLinDefault gr typ
de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
return (Just (L loc (factor param c 0 de)))
_ -> return pde -- indirection
pre' <- case (ptyp,pre) of
(Just (L _ typ), Just (L loc re)) -> do
re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
return (Just (L loc (factor param c 0 re)))
(Just (L loc typ), Nothing) -> do
re <- mkLinReference gr typ
re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
return (Just (L loc (factor param c 0 re)))
_ -> return pre -- indirection
let ppr' = fmap (evalPrintname resenv c) ppr
return (CncCat ptyp pde' pre' ppr' mpmcfg)
CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $
eIn ("linearization in type" <+> mkProd cont val [] $$ "of function") $ do
pde' <- case pde of
Just (L loc de) -> do de <- partEval opts gr (cont,val) de
return (Just (L loc (factor param c 0 de)))
Nothing -> return pde
let ppr' = fmap (evalPrintname resenv c) ppr
return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
{-
ResOper pty pde
| not new && OptExpand `Set.member` optim -> do
pde' <- case pde of
Just (L loc de) -> do de <- computeConcrete gr de
return (Just (L loc (factor param c 0 de)))
Nothing -> return Nothing
return $ ResOper pty pde'
-}
_ -> return info
where
-- new = flag optNewComp opts -- computations moved to GF.Compile.GeneratePMCFG
gr = prependModule sgr m
optim = flag optOptimizations opts
param = OptParametrize `Set.member` optim
eIn cat = errIn (render ("Error optimizing" <+> cat <+> c <+> ':'))
-- | the main function for compiling linearizations
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
partEval opts = {-if flag optNewComp opts
then-} partEvalNew opts
{-else partEvalOld opts-}
partEvalNew opts gr (context, val) trm =
errIn (render ("partial evaluation" <+> ppTerm Qualified 0 trm)) $
checkPredefError trm
{-
partEvalOld opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do
let vars = map (\(bt,x,t) -> x) context
args = map Vr vars
subst = [(v, Vr v) | v <- vars]
trm1 = mkApp trm args
trm2 <- computeTerm gr subst trm1
trm3 <- if rightType trm2
then computeTerm gr subst trm2 -- compute twice??
else recordExpand val trm2 >>= computeTerm gr subst
trm4 <- checkPredefError trm3
return $ mkAbs [(Explicit,v) | v <- vars] trm4
where
-- don't eta expand records of right length (correct by type checking)
rightType (R rs) = case val of
RecType ts -> length rs == length ts
_ -> False
rightType _ = False
-- here we must be careful not to reduce
-- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
-- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ;
recordExpand :: Type -> Term -> Err Term
recordExpand typ trm = case typ of
RecType tys -> case trm of
FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
_ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
_ -> return trm
-}
-- | auxiliaries for compiling the resource
mkLinDefault :: SourceGrammar -> Type -> Err Term
mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
where
mkDefField typ = case typ of
Table p t -> do
t' <- mkDefField t
let T _ cs = mkWildCases t'
return $ T (TWild p) cs
Sort s | s == cStr -> return $ Vr varStr
QC p -> do vs <- lookupParamValues gr p
case vs of
v:_ -> return v
_ -> Bad (render ("no parameter values given to type" <+> ppQIdent Qualified p))
RecType r -> do
let (ls,ts) = unzip r
ts <- mapM mkDefField ts
return $ R (zipWith assign ls ts)
_ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
_ -> Bad (render ("linearization type field cannot be" <+> typ))
mkLinReference :: SourceGrammar -> Type -> Err Term
mkLinReference gr typ =
liftM (Abs Explicit varStr) $
case mkDefField typ (Vr varStr) of
Bad "no string" -> return Empty
x -> x
where
mkDefField ty trm =
case ty of
Table pty ty -> do ps <- allParamValues gr pty
case ps of
[] -> Bad "no string"
(p:ps) -> mkDefField ty (S trm p)
Sort s | s == cStr -> return trm
QC p -> Bad "no string"
RecType [] -> Bad "no string"
RecType rs -> do
msum (map (\(l,ty) -> mkDefField ty (P trm l)) (sortRec rs))
`mplus` Bad "no string"
_ | Just _ <- isTypeInts typ -> Bad "no string"
_ -> Bad (render ("linearization type field cannot be" <+> typ))
evalPrintname :: GlobalEnv -> Ident -> L Term -> L Term
evalPrintname resenv c (L loc pr) = L loc (normalForm resenv (L loc c) pr)
-- do even more: factor parametric branches
factor :: Bool -> Ident -> Int -> Term -> Term
factor param c i t =
case t of
T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs]
_ -> composSafeOp (factor param c i) t
where
factors ty pvs0
| not param = V ty (map snd pvs0)
factors ty [] = V ty []
factors ty pvs0@[(p,v)] = V ty [v]
factors ty pvs0@(pv:pvs) =
let t = mkFun pv
ts = map mkFun pvs
in if all (==t) ts
then T (TTyped ty) (mkCases t)
else V ty (map snd pvs0)
--- we hope this will be fresh and don't check... in GFC would be safe
qvar = identS ("q_" ++ showIdent c ++ "__" ++ show i)
mkFun (patt, val) = replace (patt2term patt) (Vr qvar) val
mkCases t = [(PV qvar, t)]
-- 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 _ _ | trm == old -> new
R _ | trm == old -> new
App x y -> App (replace old new x) (replace old new y)
_ -> composSafeOp (replace old new) trm