mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
experimental new evaluation
This commit is contained in:
aarne
461
src/exper/Evaluate.hs
Normal file
461
src/exper/Evaluate.hs
Normal file
@@ -0,0 +1,461 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Evaluate
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/01 15:39:12 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.19 $
|
||||
--
|
||||
-- Computation of source terms. Used in compilation and in @cc@ command.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.Evaluate (appEvalConcrete) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Data.Str
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Infra.Modules
|
||||
import GF.Infra.Option
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Grammar.Refresh
|
||||
import GF.Grammar.PatternMatch
|
||||
import GF.Grammar.Lockfield (isLockLabel) ----
|
||||
|
||||
import GF.Grammar.AppPredefined
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.List (nub,intersperse)
|
||||
import Control.Monad (liftM2, liftM)
|
||||
import Debug.Trace
|
||||
|
||||
|
||||
data EEnv = EEnv {
|
||||
computd :: Map.Map (Ident,Ident) FTerm,
|
||||
temp :: Int
|
||||
}
|
||||
|
||||
emptyEEnv = EEnv Map.empty 0
|
||||
|
||||
lookupComputed :: (Ident,Ident) -> STM EEnv (Maybe FTerm)
|
||||
lookupComputed mc = do
|
||||
env <- readSTM
|
||||
return $ Map.lookup mc $ computd env
|
||||
|
||||
updateComputed :: (Ident,Ident) -> FTerm -> STM EEnv ()
|
||||
updateComputed mc t = updateSTM (\e -> e{computd = Map.insert mc t (computd e)})
|
||||
|
||||
getTemp :: STM EEnv Ident
|
||||
getTemp = do
|
||||
env <- readSTM
|
||||
updateSTM (\e -> e{temp = temp e + 1})
|
||||
return $ identC ("#" ++ show (temp env))
|
||||
|
||||
data FTerm =
|
||||
FTC Term
|
||||
| FTF (Term -> FTerm)
|
||||
|
||||
prFTerm :: Integer -> FTerm -> String
|
||||
prFTerm i t = case t of
|
||||
FTC t -> prt t
|
||||
FTF f -> show i +++ "->" +++ prFTerm (i + 1) (f (EInt i))
|
||||
|
||||
term2fterm t = case t of
|
||||
Abs x b -> FTF (\t -> term2fterm (subst [(x,t)] b))
|
||||
_ -> FTC t
|
||||
|
||||
traceFTerm c ft = ft ----trace ("\n" ++ prt c +++ "=" +++ take 60 (prFTerm 0 ft)) ft
|
||||
|
||||
fterm2term :: FTerm -> STM EEnv Term
|
||||
fterm2term t = case t of
|
||||
FTC t -> return t
|
||||
FTF f -> do
|
||||
x <- getTemp
|
||||
b <- fterm2term $ f (Vr x)
|
||||
return $ Abs x b
|
||||
|
||||
subst g t = case t of
|
||||
Vr x -> maybe t id $ lookup x g
|
||||
_ -> composSafeOp (subst g) t
|
||||
|
||||
|
||||
appFTerm :: FTerm -> [Term] -> FTerm
|
||||
appFTerm ft ts = case (ft,ts) of
|
||||
(FTF f, x:xs) -> appFTerm (f x) xs
|
||||
_ -> ft
|
||||
{-
|
||||
(FTC _, []) -> ft
|
||||
(FTC f, [a]) -> case appPredefined (App f a) of
|
||||
Ok (t,_) -> FTC t
|
||||
_ -> error $ "error: appFTerm" +++ prFTerm 0 ft +++ unwords (map prt ts)
|
||||
_ -> error $ "error: appFTerm" +++ prFTerm 0 ft +++ unwords (map prt ts)
|
||||
-}
|
||||
|
||||
apps :: Term -> (Term,[Term])
|
||||
apps t = case t of
|
||||
App f a -> (f',xs ++ [a]) where (f',xs) = apps f
|
||||
_ -> (t,[])
|
||||
|
||||
appEvalConcrete gr bt = liftM fst $ appSTM (evalConcrete gr bt) emptyEEnv
|
||||
|
||||
evalConcrete :: SourceGrammar -> BinTree Ident Info -> STM EEnv (BinTree Ident Info)
|
||||
evalConcrete gr mo = mapMTree evaldef mo where
|
||||
|
||||
evaldef (f,info) = case info of
|
||||
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr ->
|
||||
evalIn ("\nerror in linearization of function" +++ prt f +++ ":") $
|
||||
do
|
||||
pde' <- case pde of
|
||||
Yes de -> do
|
||||
liftM yes $ pEval ty de
|
||||
_ -> return pde
|
||||
--- ppr' <- liftM yes $ evalPrintname gr c ppr pde'
|
||||
return $ (f, CncFun mt pde' ppr) -- only cat in type actually needed
|
||||
|
||||
_ -> return (f,info)
|
||||
|
||||
pEval (context,val) trm = do ---- errIn ("parteval" +++ prt_ trm) $ do
|
||||
let
|
||||
vars = map fst context
|
||||
args = map Vr vars
|
||||
subst = [(v, Vr v) | v <- vars]
|
||||
trm1 = mkApp trm args
|
||||
trm3 <- recordExpand val trm1 >>= comp subst
|
||||
return $ mkAbs vars trm3
|
||||
|
||||
recordExpand typ trm = case unComputed 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
|
||||
|
||||
comp g t = case t of
|
||||
|
||||
Q (IC "Predef") _ -> trace ("\nPredef:\n" ++ prt t) $ return t
|
||||
|
||||
Q p c -> do
|
||||
md <- lookupComputed (p,c)
|
||||
case md of
|
||||
Nothing -> do
|
||||
d <- lookRes (p,c)
|
||||
updateComputed (p,c) $ traceFTerm c $ term2fterm d
|
||||
return d
|
||||
Just d -> fterm2term d >>= comp g
|
||||
App f a -> case apps t of
|
||||
(h@(Q p c),xs) | p == IC "Predef" -> do
|
||||
xs' <- mapM (comp g) xs
|
||||
(t',b) <- stmErr $ appPredefined (foldl App h xs')
|
||||
if b then return t' else comp g t'
|
||||
(h@(Q p c),xs) -> do
|
||||
xs' <- mapM (comp g) xs
|
||||
md <- lookupComputed (p,c)
|
||||
case md of
|
||||
Just ft -> do
|
||||
t <- fterm2term $ appFTerm ft xs'
|
||||
comp g t
|
||||
Nothing -> do
|
||||
d <- lookRes (p,c)
|
||||
let ft = traceFTerm c $ term2fterm d
|
||||
updateComputed (p,c) ft
|
||||
t' <- fterm2term $ appFTerm ft xs'
|
||||
comp g t'
|
||||
_ -> do
|
||||
f' <- comp g f
|
||||
a' <- comp g a
|
||||
case (f',a') of
|
||||
(Abs x b,_) -> comp (ext x a' g) b
|
||||
(QC _ _,_) -> returnC $ App f' a'
|
||||
(FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants
|
||||
(_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants
|
||||
|
||||
(Alias _ _ d, _) -> comp g (App d a')
|
||||
|
||||
(S (T i cs) e,_) -> prawitz g i (flip App a') cs e
|
||||
|
||||
_ -> do
|
||||
(t',b) <- stmErr $ appPredefined (App f' a')
|
||||
if b then return t' else comp g t'
|
||||
|
||||
|
||||
Vr x -> do
|
||||
t' <- maybe (prtRaise (
|
||||
"context" +++ show g +++ ": no value given to variable") x) return $ lookup x g
|
||||
case t' of
|
||||
_ | t == t' -> return t
|
||||
_ -> comp g t'
|
||||
|
||||
Abs x b -> do
|
||||
b' <- comp (ext x (Vr x) g) b
|
||||
return $ Abs x b'
|
||||
|
||||
Let (x,(_,a)) b -> do
|
||||
a' <- comp g a
|
||||
comp (ext x a' g) b
|
||||
|
||||
Prod x a b -> do
|
||||
a' <- comp g a
|
||||
b' <- comp (ext x (Vr x) g) b
|
||||
return $ Prod x a' b'
|
||||
|
||||
P t l | isLockLabel l -> return $ R []
|
||||
---- a workaround 18/2/2005: take this away and find the reason
|
||||
---- why earlier compilation destroys the lock field
|
||||
|
||||
|
||||
P t l -> do
|
||||
t' <- comp g t
|
||||
case t' of
|
||||
FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants
|
||||
R r -> maybe
|
||||
(prtRaise (prt t' ++ ": no value for label") l) (comp g . snd) $
|
||||
lookup l r
|
||||
|
||||
ExtR a (R b) -> case lookup l b of ----comp g (P (R b) l) of
|
||||
Just (_,v) -> comp g v
|
||||
_ -> comp g (P a l)
|
||||
|
||||
S (T i cs) e -> prawitz g i (flip P l) cs e
|
||||
|
||||
_ -> returnC $ P t' l
|
||||
|
||||
S t@(T _ cc) v -> do
|
||||
v' <- comp g v
|
||||
case v' of
|
||||
FV vs -> do
|
||||
ts' <- mapM (comp g . S t) vs
|
||||
return $ variants ts'
|
||||
_ -> case matchPattern cc v' of
|
||||
Ok (c,g') -> comp (g' ++ g) c
|
||||
_ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t
|
||||
_ -> do
|
||||
t' <- comp g t
|
||||
return $ S t' v' -- if v' is not canonical
|
||||
|
||||
S t v -> do
|
||||
t' <- comp g t
|
||||
v' <- comp g v
|
||||
case t' of
|
||||
T _ [(PV IW,c)] -> comp g c --- an optimization
|
||||
T _ [(PT _ (PV IW),c)] -> comp g c
|
||||
|
||||
T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
|
||||
T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
|
||||
|
||||
FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
|
||||
|
||||
V ptyp ts -> do
|
||||
vs <- stmErr $ allParamValues gr ptyp
|
||||
ps <- stmErr $ mapM term2patt vs
|
||||
let cc = zip ps ts
|
||||
case v' of
|
||||
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
|
||||
_ -> case matchPattern cc v' of
|
||||
Ok (c,g') -> comp (g' ++ g) c
|
||||
_ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t
|
||||
_ -> return $ S t' v' -- if v' is not canonical
|
||||
|
||||
T _ cc -> case v' of
|
||||
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
|
||||
_ -> case matchPattern cc v' of
|
||||
Ok (c,g') -> comp (g' ++ g) c
|
||||
_ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t
|
||||
_ -> return $ S t' v' -- if v' is not canonical
|
||||
|
||||
Alias _ _ d -> comp g (S d v')
|
||||
|
||||
S (T i cs) e -> prawitz g i (flip S v') cs e
|
||||
|
||||
_ -> returnC $ S t' v'
|
||||
|
||||
-- normalize away empty tokens
|
||||
K "" -> return Empty
|
||||
|
||||
-- glue if you can
|
||||
Glue x0 y0 -> do
|
||||
x <- comp g x0
|
||||
y <- comp g y0
|
||||
case (x,y) of
|
||||
(Alias _ _ d, y) -> comp g $ Glue d y
|
||||
(x, Alias _ _ d) -> comp g $ Glue x d
|
||||
|
||||
(S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
|
||||
(s, S (T i cs) e) -> prawitz g i (Glue s) cs e
|
||||
(_,Empty) -> return x
|
||||
(Empty,_) -> return y
|
||||
(K a, K b) -> return $ K (a ++ b)
|
||||
(_, Alts (d,vs)) -> do
|
||||
---- (K a, Alts (d,vs)) -> do
|
||||
let glx = Glue x
|
||||
comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
|
||||
(Alts _, ka) -> checks [do
|
||||
y' <- stmErr $ strsFromTerm ka
|
||||
---- (Alts _, K a) -> checks [do
|
||||
x' <- stmErr $ strsFromTerm x -- this may fail when compiling opers
|
||||
return $ variants [
|
||||
foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y']
|
||||
---- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
|
||||
,return $ Glue x y
|
||||
]
|
||||
(FV ks,_) -> do
|
||||
kys <- mapM (comp g . flip Glue y) ks
|
||||
return $ variants kys
|
||||
(_,FV ks) -> do
|
||||
xks <- mapM (comp g . Glue x) ks
|
||||
return $ variants xks
|
||||
|
||||
_ -> do
|
||||
mapM_ checkNoArgVars [x,y]
|
||||
r <- composOp (comp g) t
|
||||
returnC r
|
||||
|
||||
Alts _ -> do
|
||||
r <- composOp (comp g) t
|
||||
returnC r
|
||||
|
||||
-- remove empty
|
||||
C a b -> do
|
||||
a' <- comp g a
|
||||
b' <- comp g b
|
||||
case (a',b') of
|
||||
(Alts _, K a) -> checks [do
|
||||
as <- stmErr $ strsFromTerm a' -- this may fail when compiling opers
|
||||
return $ variants [
|
||||
foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as]
|
||||
,
|
||||
return $ C a' b'
|
||||
]
|
||||
(Empty,_) -> returnC b'
|
||||
(_,Empty) -> returnC a'
|
||||
_ -> returnC $ C a' b'
|
||||
|
||||
-- reduce free variation as much as you can
|
||||
FV ts -> mapM (comp g) ts >>= returnC . variants
|
||||
|
||||
-- merge record extensions if you can
|
||||
ExtR r s -> do
|
||||
r' <- comp g r
|
||||
s' <- comp g s
|
||||
case (r',s') of
|
||||
(Alias _ _ d, _) -> comp g $ ExtR d s'
|
||||
(_, Alias _ _ d) -> comp g $ Glue r' d
|
||||
|
||||
(R rs, R ss) -> stmErr $ plusRecord r' s'
|
||||
(RecType rs, RecType ss) -> stmErr $ plusRecType r' s'
|
||||
_ -> return $ ExtR r' s'
|
||||
|
||||
-- case-expand tables
|
||||
-- if already expanded, don't expand again
|
||||
T i@(TComp _) cs -> do
|
||||
-- if there are no variables, don't even go inside
|
||||
cs' <- if (null g) then return cs else mapPairsM (comp g) cs
|
||||
return $ T i cs'
|
||||
|
||||
--- this means some extra work; should implement TSh directly
|
||||
TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps]
|
||||
|
||||
T i cs -> do
|
||||
pty0 <- stmErr $ getTableType i
|
||||
ptyp <- comp g pty0
|
||||
case allParamValues gr ptyp of
|
||||
Ok vs -> do
|
||||
|
||||
cs' <- mapM (compBranchOpt g) cs
|
||||
sts <- stmErr $ mapM (matchPattern cs') vs
|
||||
ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
|
||||
ps <- stmErr $ mapM term2patt vs
|
||||
let ps' = ps --- PT ptyp (head ps) : tail ps
|
||||
return $ --- V ptyp ts -- to save space, just course of values
|
||||
T (TComp ptyp) (zip ps' ts)
|
||||
_ -> do
|
||||
cs' <- mapM (compBranch g) cs
|
||||
return $ T i cs' -- happens with variable types
|
||||
|
||||
-- otherwise go ahead
|
||||
_ -> composOp (comp g) t >>= returnC
|
||||
|
||||
lookRes (p,c) = case lookupResDefKind gr p c of
|
||||
Ok (t,_) | noExpand p -> return t
|
||||
Ok (t,0) -> comp [] t
|
||||
Ok (t,_) -> return t
|
||||
Bad s -> raise s
|
||||
|
||||
noExpand p = errVal False $ do
|
||||
mo <- lookupModMod gr p
|
||||
return $ case getOptVal (iOpts (flags mo)) useOptimizer of
|
||||
Just "noexpand" -> True
|
||||
_ -> False
|
||||
|
||||
prtRaise s t = raise (s +++ prt t)
|
||||
|
||||
ext x a g = (x,a):g
|
||||
|
||||
returnC = return --- . computed
|
||||
|
||||
variants ts = case nub ts of
|
||||
[t] -> t
|
||||
ts -> FV ts
|
||||
|
||||
isCan v = case v of
|
||||
Con _ -> True
|
||||
QC _ _ -> True
|
||||
App f a -> isCan f && isCan a
|
||||
R rs -> all (isCan . snd . snd) rs
|
||||
_ -> False
|
||||
|
||||
compBranch g (p,v) = do
|
||||
let g' = contP p ++ g
|
||||
v' <- comp g' v
|
||||
return (p,v')
|
||||
|
||||
compBranchOpt g c@(p,v) = case contP p of
|
||||
[] -> return c
|
||||
_ -> compBranch g c
|
||||
---- _ -> err (const (return c)) return $ compBranch g c
|
||||
|
||||
contP p = case p of
|
||||
PV x -> [(x,Vr x)]
|
||||
PC _ ps -> concatMap contP ps
|
||||
PP _ _ ps -> concatMap contP ps
|
||||
PT _ p -> contP p
|
||||
PR rs -> concatMap (contP . snd) rs
|
||||
|
||||
PAs x p -> (x,Vr x) : contP p
|
||||
|
||||
PSeq p q -> concatMap contP [p,q]
|
||||
PAlt p q -> concatMap contP [p,q]
|
||||
PRep p -> contP p
|
||||
PNeg p -> contP p
|
||||
|
||||
_ -> []
|
||||
|
||||
prawitz g i f cs e = do
|
||||
cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
|
||||
return $ S (T i cs') e
|
||||
|
||||
-- | argument variables cannot be glued
|
||||
checkNoArgVars :: Term -> STM EEnv Term
|
||||
checkNoArgVars t = case t of
|
||||
Vr (IA _) -> raise $ glueErrorMsg $ prt t
|
||||
Vr (IAV _) -> raise $ glueErrorMsg $ prt t
|
||||
_ -> composOp checkNoArgVars t
|
||||
|
||||
glueErrorMsg s =
|
||||
"Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
|
||||
"Use Prelude.bind instead."
|
||||
|
||||
stmErr :: Err a -> STM s a
|
||||
stmErr e = stm (\s -> do
|
||||
v <- e
|
||||
return (v,s)
|
||||
)
|
||||
|
||||
evalIn :: String -> STM s a -> STM s a
|
||||
evalIn msg st = stm $ \s -> case appSTM st s of
|
||||
Bad e -> Bad $ msg ++++ e
|
||||
Ok vs -> Ok vs
|
||||
274
src/exper/Optimize.hs
Normal file
274
src/exper/Optimize.hs
Normal file
@@ -0,0 +1,274 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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.Infra.Modules
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Grammar.Refresh
|
||||
import GF.Grammar.Compute
|
||||
import GF.Compile.BackOpt
|
||||
import GF.Compile.CheckGrammar
|
||||
import GF.Compile.Update
|
||||
|
||||
import GF.Compile.Evaluate
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.CheckM
|
||||
import GF.Infra.Option
|
||||
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
|
||||
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
|
||||
-- only do this for resource: concrete is optimized in gfc form
|
||||
optimizeModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) ->
|
||||
Err (Ident,SourceModInfo)
|
||||
optimizeModule opts ms mo@(_,mi) = case mi of
|
||||
ModMod m0@(Module mt st fs me ops js) | st == MSComplete && isModRes m0 -> do
|
||||
mo1 <- evalModule oopts ms mo
|
||||
return $ case optim of
|
||||
"parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing
|
||||
"values" -> shareModule valOpt mo1 -- tables as courses-of-values
|
||||
"share" -> shareModule shareOpt mo1 -- sharing of branches
|
||||
"all" -> shareModule allOpt mo1 -- first parametrize then values
|
||||
"none" -> mo1 -- no optimization
|
||||
_ -> mo1 -- none; default for src
|
||||
_ -> evalModule oopts ms mo
|
||||
where
|
||||
oopts = addOptions opts (iOpts (flagsModule mo))
|
||||
optim = maybe "all" id $ getOptVal oopts useOptimizer
|
||||
|
||||
evalModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) ->
|
||||
Err (Ident,SourceModInfo)
|
||||
evalModule oopts ms mo@(name,mod) = case mod of
|
||||
|
||||
ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
|
||||
{-
|
||||
-- now: don't optimize resource
|
||||
|
||||
_ | isModRes m0 -> do
|
||||
let deps = allOperDependencies name js
|
||||
ids <- topoSortOpers deps
|
||||
MGrammar (mod' : _) <- foldM evalOp gr ids
|
||||
return $ mod'
|
||||
-}
|
||||
MTConcrete a -> do
|
||||
-----
|
||||
js0 <- appEvalConcrete gr js
|
||||
js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005
|
||||
return $ (name, ModMod (Module mt st fs me ops js'))
|
||||
|
||||
_ -> return $ (name,mod)
|
||||
_ -> return $ (name,mod)
|
||||
where
|
||||
gr0 = MGrammar $ ms
|
||||
gr = MGrammar $ (name,mod) : ms
|
||||
|
||||
evalOp g@(MGrammar ((_, ModMod m) : _)) i = do
|
||||
info <- lookupTree prt i $ jments m
|
||||
info' <- evalResInfo oopts gr (i,info)
|
||||
return $ updateRes g name i info'
|
||||
|
||||
-- | only operations need be compiled in a resource, and this is local to each
|
||||
-- definition since the module is traversed in topological order
|
||||
evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info
|
||||
evalResInfo oopts gr (c,info) = case info of
|
||||
|
||||
ResOper pty pde -> eIn "operation" $ do
|
||||
pde' <- case pde of
|
||||
Yes de | optres -> liftM yes $ comp de
|
||||
_ -> return pde
|
||||
return $ ResOper pty pde'
|
||||
|
||||
_ -> return info
|
||||
where
|
||||
comp = if optres then computeConcrete gr else computeConcreteRec gr
|
||||
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
||||
optim = maybe "all" id $ getOptVal oopts useOptimizer
|
||||
optres = case optim of
|
||||
"noexpand" -> False
|
||||
_ -> True
|
||||
|
||||
|
||||
evalCncInfo ::
|
||||
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
|
||||
evalCncInfo opts gr cnc abs (c,info) = errIn ("optimizing" +++ prt c) $ case info of
|
||||
|
||||
CncCat ptyp pde ppr -> do
|
||||
|
||||
pde' <- case (ptyp,pde) of
|
||||
(Yes typ, Yes de) ->
|
||||
liftM yes $ pEval ([(strVar, typeStr)], typ) de
|
||||
(Yes typ, Nope) ->
|
||||
liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ)
|
||||
(May b, Nope) ->
|
||||
return $ May b
|
||||
_ -> return pde -- indirection
|
||||
|
||||
ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c)
|
||||
|
||||
return (c, CncCat ptyp pde' ppr')
|
||||
|
||||
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr ->
|
||||
eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
|
||||
pde' <- case pde of
|
||||
----- Yes de -> do
|
||||
----- liftM yes $ pEval ty de
|
||||
_ -> return pde
|
||||
ppr' <- liftM yes $ evalPrintname gr c ppr pde'
|
||||
return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
|
||||
|
||||
_ -> return (c,info)
|
||||
where
|
||||
pEval = partEval opts gr
|
||||
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
||||
|
||||
-- | the main function for compiling linearizations
|
||||
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
|
||||
partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do
|
||||
let vars = map fst context
|
||||
args = map Vr vars
|
||||
subst = [(v, Vr v) | v <- vars]
|
||||
trm1 = mkApp trm args
|
||||
trm3 <- if globalTable
|
||||
then etaExpand trm1 >>= comp subst >>= outCase subst
|
||||
else etaExpand trm1 >>= comp subst
|
||||
return $ mkAbs vars trm3
|
||||
|
||||
where
|
||||
|
||||
globalTable = oElem showAll opts --- i -all
|
||||
|
||||
comp g t = {- refreshTerm t >>= -} computeTerm gr g t
|
||||
|
||||
etaExpand t = recordExpand val t --- >>= caseEx -- done by comp
|
||||
|
||||
outCase subst t = do
|
||||
pts <- getParams context
|
||||
let (args,ptyps) = unzip $ filter (flip occur t . fst) pts
|
||||
if null args
|
||||
then return t
|
||||
else do
|
||||
let argtyp = RecType $ tuple2recordType ptyps
|
||||
let pvars = map (Vr . zIdent . prt) args -- gets eliminated
|
||||
patt <- term2patt $ R $ tuple2record $ pvars
|
||||
let t' = replace (zip args pvars) t
|
||||
t1 <- comp subst $ T (TTyped argtyp) [(patt, t')]
|
||||
return $ S t1 $ R $ tuple2record args
|
||||
|
||||
--- notice: this assumes that all lin types follow the "old JFP style"
|
||||
getParams = liftM concat . mapM getParam
|
||||
getParam (argv,RecType rs) = return
|
||||
[(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)]
|
||||
---getParam (_,ty) | ty==typeStr = return [] --- in lindef
|
||||
getParam (av,ty) =
|
||||
Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av)
|
||||
--- all lin types are rec types
|
||||
|
||||
replace :: [(Term,Term)] -> Term -> Term
|
||||
replace reps trm = case trm of
|
||||
-- this is the important case
|
||||
P _ _ -> maybe trm id $ lookup trm reps
|
||||
_ -> composSafeOp (replace reps) trm
|
||||
|
||||
occur t trm = case trm of
|
||||
|
||||
-- this is the important case
|
||||
P _ _ -> t == trm
|
||||
S x y -> occur t y || occur t x
|
||||
App f x -> occur t x || occur t f
|
||||
Abs _ f -> occur t f
|
||||
R rs -> any (occur t) (map (snd . snd) rs)
|
||||
T _ cs -> any (occur t) (map snd cs)
|
||||
C x y -> occur t x || occur t y
|
||||
Glue x y -> occur t x || occur t y
|
||||
ExtR x y -> occur t x || occur t y
|
||||
FV ts -> any (occur t) ts
|
||||
V _ ts -> any (occur t) ts
|
||||
Let (_,(_,x)) y -> occur t x || occur t y
|
||||
_ -> 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 unComputed 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 = do
|
||||
case unComputed typ of
|
||||
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
|
||||
_ -> prtBad "linearization type must be a record type, not" typ
|
||||
where
|
||||
mkDefField typ = case unComputed typ of
|
||||
Table p t -> do
|
||||
t' <- mkDefField t
|
||||
let T _ cs = mkWildCases t'
|
||||
return $ T (TWild p) cs
|
||||
Sort "Str" -> return $ Vr strVar
|
||||
QC q p -> lookupFirstTag gr q p
|
||||
RecType r -> do
|
||||
let (ls,ts) = unzip r
|
||||
ts' <- mapM mkDefField ts
|
||||
return $ R $ [assign l t | (l,t) <- zip ls ts']
|
||||
_ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
|
||||
_ -> prtBad "linearization type field cannot be" typ
|
||||
|
||||
-- | Form the printname: if given, compute. If not, use the computed
|
||||
-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
|
||||
--- We cannot use linearization at this stage, since we do not know the
|
||||
--- defaults we would need for question marks - and we're not yet in canon.
|
||||
evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term
|
||||
evalPrintname gr c ppr lin =
|
||||
case ppr of
|
||||
Yes pr -> comp pr
|
||||
_ -> case lin of
|
||||
Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm
|
||||
_ -> return $ K $ prt c ----
|
||||
where
|
||||
comp = computeConcrete gr
|
||||
|
||||
oneBranch t = case t of
|
||||
Abs _ b -> oneBranch b
|
||||
R (r:_) -> oneBranch $ snd $ snd r
|
||||
T _ (c:_) -> oneBranch $ snd c
|
||||
V _ (c:_) -> oneBranch c
|
||||
FV (t:_) -> oneBranch t
|
||||
C x y -> C (oneBranch x) (oneBranch y)
|
||||
S x _ -> oneBranch x
|
||||
P x _ -> oneBranch x
|
||||
Alts (d,_) -> oneBranch d
|
||||
_ -> t
|
||||
|
||||
--- very unclean cleaner
|
||||
clean s = case s of
|
||||
'+':'+':' ':cs -> clean cs
|
||||
'"':cs -> clean cs
|
||||
c:cs -> c: clean cs
|
||||
_ -> s
|
||||
|
||||
Reference in New Issue
Block a user