lhc-0.6.20081127: src/E/SSimplify.hs
module E.SSimplify(
Occurance(..),
cacheSimpOpts,
simplifyE,
collectOccurance',
programPruneOccurance,
programSSimplify,
programSSimplifyPStat,
SimplifyOpts(..),
emptySimplifyOpts
) where
import Util.RWS
import Control.Monad.Identity
import Control.Monad.Writer
import Control.Monad.Reader
import Data.Typeable
import Data.Monoid
import List hiding(delete,union,insert)
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Traversable as T
import Data.DeriveTH
import Data.Derive.All
import StringTable.Atom
import C.Prims
import DataConstructors
import Doc.PPrint
import E.E
import E.Eta
import E.Inline
import E.PrimOpt
import E.Program
import E.Rules
import E.Subst
import E.Traverse(runRename)
import E.TypeCheck
import E.Values
import GenUtil hiding (split)
import Info.Types
import Name.Id
import Name.Name
import Name.Names
import Name.VConsts
import Cmm.Number
import Options
import Stats hiding(null,new,print,Stats,singleton)
import Support.CanType
import Support.FreeVars
import Util.Graph
import Util.HasSize
import Util.NameMonad
import Util.ReaderWriter
import Util.SetLike as S
import qualified E.Demand as Demand
import qualified FlagDump as FD
import qualified FlagOpts as FO
import qualified Info.Info as Info
import System.Random
import Debug.Trace
type Bind = (TVr,E)
data Occurance =
Unused -- ^ unused means a var is not used at the term level, but might be at the type level
| Once -- ^ Used at most once not inside a lambda or as an argument
| OnceInLam -- ^ used once inside a lambda
| ManyBranch -- ^ used once in several branches
| Many -- ^ used many or an unknown number of times
| LoopBreaker -- ^ chosen as a loopbreaker, never inline
deriving(Show,Eq,Ord)
data UseInfo = UseInfo {
useOccurance :: !Occurance, -- ^ occurance Info
minimumArgs :: !Int -- ^ minimum number of args that are ever passed to this function (if used)
}
deriving(Show,Eq,Ord,Typeable)
noUseInfo = UseInfo { useOccurance = Many, minimumArgs = 0 }
notUsedInfo = UseInfo { useOccurance = Unused, minimumArgs = maxBound }
newtype OM a = OM (ReaderWriter IdSet (OMap,IdSet) a)
deriving(Monad,Functor,MonadWriter (OMap,IdSet),MonadReader IdSet)
unOM (OM a) = a
newtype OMap = OMap (IdMap UseInfo)
deriving(HasSize,SetLike,BuildSet (Id,UseInfo),MapLike Id UseInfo,Show,IsEmpty,Eq,Ord)
andOM x y = munionWith andOcc x y
andOcc UseInfo { useOccurance = Unused } x = x
andOcc x UseInfo { useOccurance = Unused } = x
andOcc x y = UseInfo { useOccurance = Many, minimumArgs = min (minimumArgs x) (minimumArgs y) }
instance Monoid OMap where
mempty = OMap mempty
mappend (OMap a) (OMap b) = OMap (andOM a b)
data Range = Done OutE | Susp InE Subst
deriving(Show,Eq,Ord)
type Subst = IdMap Range
data Forced = ForceInline | ForceNoinline | NotForced
deriving(Eq,Ord)
type InE = E
type OutE = E
type InTVr = TVr
type OutTVr = TVr
data Binding =
NotAmong [Name]
| IsBoundTo {
bindingOccurance :: Occurance,
bindingE :: OutE,
bindingCheap :: Bool,
inlineForced :: Forced,
bindingAtomic :: Bool
}
| NotKnown
deriving(Ord,Eq)
data Env = Env {
envCachedSubst :: IdMap E,
envSubst :: Subst,
envRules :: IdMap ARules,
envInScope :: IdMap Binding,
envInScopeCache :: IdMap E
}
$(derive makeMonoid ''Env)
$(derive makeUpdate ''Env)
maybeLetRec [] e = e
maybeLetRec ds e = ELetRec ds e
-- | occurance analysis
grump :: OM a -> OM (a,OMap)
grump m = fmap ( \ (x, (y,z)) -> (x,y) ) $ censor (\ (_,y) -> (mempty,y)) (listen m)
collectOccurance' :: E -> (E,IdMap UseInfo)
collectOccurance' e = (fe,omap) where
(fe,(OMap omap,_)) = runReaderWriter (unOM $ collectOccurance e) mempty
collectOccurance :: E -> OM E -- ^ (annotated expression, free variables mapped to their occurance info)
collectOccurance e = f e where
f e@ESort {} = return e
f e@Unknown {} = return e
f (EPi tvr@TVr { tvrIdent = 0, tvrType = a} b) = arg $ do
a <- f a
b <- f b
return (EPi tvr { tvrType = a } b)
f (EPi tvr@(TVr { tvrIdent = n, tvrType = a}) b) = arg $ do
a <- f a
(b,tfvs) <- grump (f b)
case mlookup n tfvs of
Nothing -> tell (tfvs,mempty) >> return (EPi tvr { tvrIdent = 0, tvrType = a } b)
Just occ -> tell (mdelete n tfvs,singleton n) >> return (EPi (annb' tvr { tvrType = a }) b)
f (ELit lc@LitCons { litArgs = as, litType = t }) = arg $ do
t <- f t
as <- mapM f as
return (ELit lc { litArgs = as, litType = t })
f (ELit (LitInt i t)) = do
t <- arg (f t)
return $ ELit (LitInt i t)
f (EPrim p as t) = arg $ do
t <- f t
as <- mapM f as
return (EPrim p as t)
f (EError err t) = do
t <- arg (f t)
return $ EError err t
f e | (b,as@(_:_)) <- fromLam e = do
(b',bvs) <- grump (f b)
(as',asfv) <- grump (arg $ mapM ftvr as)
let avs = bvs `andOM` asfv
as'' = map (annbind' avs) as'
case all (getProperty prop_ONESHOT) as of
True -> tell $ (foldr mdelete avs (map tvrIdent as),fromList $ map tvrIdent as)
False -> tell $ (inLam $ foldr mdelete avs (map tvrIdent as),fromList $ map tvrIdent as)
return (foldr ELam b' as'')
f e | Just (x,t) <- from_unsafeCoerce e = do x <- f x ; t <- (arg (f t)); return (prim_unsafeCoerce x t)
f (EVar tvr@TVr { tvrIdent = n, tvrType = t}) = do
tell $ (msingleton n UseInfo { useOccurance = Once, minimumArgs = 0 },mempty)
t <- arg (f t)
return $ EVar tvr { tvrType = t }
f e | (EVar tvr@TVr { tvrIdent = n, tvrType = t},xs@(_:_)) <- fromAp e = do
tell $ (msingleton n UseInfo { useOccurance = Once, minimumArgs = length xs },mempty)
t <- arg (f t)
xs <- arg (mapM f xs)
return (foldl EAp (EVar tvr { tvrType = t}) xs)
f e | (x,xs@(_:_)) <- fromAp e = do
x <- f x
xs <- arg (mapM f xs)
return (foldl EAp x xs)
f ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} = do
scrut' <- f e
(d',fvb) <- grump (T.mapM f d)
(as',fvas) <- mapAndUnzipM (grump . alt) as
let fidm = orMaps (fvb:fvas)
ct <- arg $ f (eCaseType ec)
b <- arg (ftvr b)
tell $ (mdelete (tvrIdent b) fidm,singleton (tvrIdent b))
return $ caseUpdate ec { eCaseScrutinee = scrut', eCaseAlts = as', eCaseBind = annbind' fidm b, eCaseType = ct, eCaseDefault = d'}
f ELetRec { eDefs = ds, eBody = e } = do
(e',fve) <- grump (f e)
ds''' <- collectDs (map bindComb ds) fve
return (maybeLetRec (map combBind ds''') e')
f e = error $ "SSimplify.collectOcc.f: " ++ show e
alt (Alt l e) = do
(e',fvs) <- grump (f e)
l <- arg (mapLitBindsM ftvr l)
l <- arg (T.mapM f l)
let fvs' = foldr mdelete fvs (map tvrIdent $ litBinds l)
l' = mapLitBinds (annbind' fvs) l
tell (fvs',fromList $ map tvrIdent (litBinds l'))
return (Alt l' e')
arg m = do
let mm (OMap mp,y) = (OMap $ fmap (const noUseInfo) mp,y)
censor mm m
ftvr tvr = do
tt <- f (tvrType tvr)
return tvr { tvrType = tt }
collectDs :: [Comb] -> OMap -> OM [Comb]
collectDs ds (OMap fve) = do
ds' <- mapM (grump . collectBinding) ds
exp <- ask
let graph = newGraph ds' (\ ((comb,_),_) -> combIdent comb) (\ ((_,rv),fv) -> mkeys (fv `mappend` rv))
rds = reachable graph (mkeys fve ++ [ combIdent t | t <- ds, (combIdent t `member` exp)])
-- ignore rules when calculating loopbreakers
-- we must not simplify the expanded body of a rule without recalculating occurance info.
graph' = newGraph rds (\ ((comb,_),_) -> combIdent comb) (\ (_,fv) -> mkeys fv)
(lb,lbds) = findLoopBreakers (\ ((comb,_),_) -> loopFunc (combHead comb) (combBody comb)) (const True) graph'
ds'' = map ( \ ((t,rv),rv') -> (t,rv `mappend` rv') ) lbds
fids = foldl andOM mempty (fve:map unOMap (snds ds''))
ffids = fromList [ (tvrIdent t,lup t) | (Comb { combHead = t },_) <- ds'' ]
cycNodes = (fromList $ [ combIdent c | ((c,_),_) <- cyclicNodes graph'] :: IdSet)
calcStrictInfo :: TVr -> TVr
calcStrictInfo t
| tvrIdent t `member` cycNodes = setProperty prop_CYCLIC t
| otherwise = t
lup t = case tvrIdent t `elem` [ combIdent c | ((c,_),_) <- lb] of
True -> noUseInfo { useOccurance = LoopBreaker }
False -> case (tvrIdent t `member` exp) of
True -> noUseInfo
False | Just r <- mlookup (tvrIdent t) fids -> r
ds''' = [ combHead_s (calcStrictInfo $ annbind ffids (combHead comb)) comb | (comb,_) <- ds'']
froo comb = (combHead_s (combHead comb) {tvrType = t' } comb,fvs) where
(t',fvs) = collectOccurance' (tvrType $ combHead comb)
(ds'''',nfids) = unzip $ map froo ds'''
nfid' = fmap (const noUseInfo) (mconcat nfids)
tell $ ((OMap $ nfid' `andOM` fids) S.\\ ffids,fromList (map combIdent ds''''))
return (ds'''')
programPruneOccurance :: Program -> Program
programPruneOccurance prog =
let dsIn = progCombinators prog -- (runIdentity $ programMapBodies (return . subst (tVr (-1) Unknown) Unknown) prog)
(dsIn',(OMap fvs,uids)) = runReaderWriter (unOM $ collectDs dsIn mempty) (progEntry prog)
in --trace ("dsIn: "++show (length dsIn)) $
(progCombinators_s dsIn' prog) { progFreeIds = idMapToIdSet fvs, progUsedIds = uids }
-- delete any occurance info for non-let-bound vars to be safe
annb' tvr = tvrInfo_u (Info.delete noUseInfo) tvr
annbind' idm tvr = case mlookup (tvrIdent tvr) idm of
Nothing | sortTermLike (getType tvr) -> annb' tvr { tvrIdent = 0 }
_ -> annb' tvr
-- add ocucrance info
annbind idm tvr = case mlookup (tvrIdent tvr) idm of
Nothing -> annb notUsedInfo tvr { tvrIdent = 0 }
Just x -> annb x tvr
annb x tvr = tvrInfo_u (Info.insert x) tvr
mapLitBinds f lc@LitCons { litArgs = es } = lc { litArgs = map f es }
mapLitBinds f (LitInt e t) = LitInt e t
mapLitBindsM f lc@LitCons { litArgs = es } = do
es <- mapM f es
return lc { litArgs = es }
mapLitBindsM f (LitInt e t) = return $ LitInt e t
collectBinding :: Comb -> OM (Comb,OMap)
collectBinding comb = do
e' <- collectOccurance $ combBody comb
let rvars = freeVars (combRules comb) :: IdSet
romap = OMap (idSetToIdMap (const noUseInfo) rvars)
return (combBody_s e' comb,romap)
unOMap (OMap x) = x
collectCombs :: [Comb] -> OMap -> OM [Comb]
collectCombs cs _ = return cs
-- TODO this should use the occurance info
-- loopFunc t _ | getProperty prop_PLACEHOLDER t = -100 -- we must not choose the placeholder as the loopbreaker
loopFunc t e = negate (baseInlinability t e)
inLam (OMap om) = OMap (fmap il om) where
il ui@UseInfo { useOccurance = Once } = ui { useOccurance = OnceInLam }
il ui = ui { useOccurance = Many }
--andOM :: IdMap UseInfo -> IdMap UseInfo -> IdMap UseInfo
orMaps ms = OMap $ fmap orMany $ foldl (munionWith (++)) mempty (map (fmap (:[])) (map unOMap ms)) where
unOMap (OMap m) = m
orMany [] = error "empty orMany"
orMany xs = f (filter ((/= Unused) . useOccurance) xs) where
f [] = notUsedInfo
f [x] = x
f xs = if all good (map useOccurance xs) then ui ManyBranch else ui Many where
good Once = True
good ManyBranch = True
good _ = False
ui x = UseInfo { minimumArgs = minimum (map minimumArgs xs), useOccurance = x }
data SimplifyOpts = SimpOpts {
so_noInlining :: Bool, -- ^ this inhibits all inlining inside functions which will always be inlined
so_finalPhase :: Bool, -- ^ no rules and don't inhibit inlining
so_boundVars :: IdMap Comb, -- ^ bound variables
so_forwardVars :: IdSet, -- ^ variables that we know will exist, but might not yet.
so_boundVarsCache :: IdSet,
so_cachedScope :: Env
}
{- derive: Monoid -}
emptySimplifyOpts = SimpOpts { so_noInlining = False
, so_finalPhase = False
, so_boundVars = mempty
, so_forwardVars = mempty
, so_boundVarsCache = mempty
, so_cachedScope = mempty }
cacheSimpOpts opts = opts {
so_boundVarsCache = idMapToIdSet (so_boundVars opts),
so_cachedScope = cacheSubst (extendScope initScope mempty { envSubst = mapMaybeIdMap bb (so_boundVars opts), envRules = rules })
} where
bb Comb { combBody = e } | isFullyConst e = Just (Done e)
bb _ = Nothing
initScope = fmap (\ c -> fixInline (so_finalPhase opts) (combHead c) $ isBoundTo noUseInfo (combBody c)) (so_boundVars opts)
rules = mapMaybeIdMap f (so_boundVars opts)
f Comb { combRules = rs } = if null rs then Nothing else Just $ arules rs
isBoundTo o e = IsBoundTo {
bindingOccurance = useOccurance o,
bindingE = e,
bindingCheap = isCheap e,
inlineForced = if useOccurance o == LoopBreaker then ForceNoinline else NotForced,
bindingAtomic = atomic
} where
atomic = isAtomic e
instance Monoid Forced where
mempty = NotForced
mappend NotForced x = x
mappend x NotForced = x
mappend _ ForceNoinline = ForceNoinline
mappend ForceNoinline _ = ForceNoinline
mappend ForceInline ForceInline = ForceInline
fixInline finalPhase v bt@IsBoundTo {} = bt { inlineForced = inlineForced bt `mappend` calcForced finalPhase v } where
calcForced finalPhase v =
let props = getProperties v in
case (forceNoinline props,finalPhase,forceInline props) of
(True,_,_) -> ForceNoinline
(False,True,_) -> NotForced
(False,False,True) -> ForceInline
(False,False,False) -> NotForced
susp:: E -> Subst -> Range
susp e sub = Susp e sub
insertSuspSubst :: TVr -> InE -> Env -> Env
insertSuspSubst t e env = insertSuspSubst' (tvrIdent t) e env
insertSuspSubst' :: Id -> InE -> Env -> Env
insertSuspSubst' 0 _e env = env
insertSuspSubst' t e env = cacheSubst env { envSubst = minsert t (susp e (envSubst env)) (envSubst env) }
insertRange :: Id -> Range -> Env -> Env
insertRange 0 e env = env
insertRange t e env = cacheSubst env { envSubst = minsert t e (envSubst env) }
insertDoneSubst :: TVr -> OutE -> Env -> Env
insertDoneSubst t e env = insertDoneSubst' (tvrIdent t) e env
insertDoneSubst' :: Id -> OutE -> Env -> Env
insertDoneSubst' 0 _e env = env
insertDoneSubst' t e env = insertRange t (Done e) env
insertInScope :: Id -> Binding -> Env -> Env
insertInScope 0 _b env = env
insertInScope t b env = extendScope (msingleton t b) env
extendScope :: IdMap Binding -> Env -> Env
extendScope m env = cacheSubst env { envInScope = m `union` envInScope env
, envInScopeCache = cachedM `union` envInScopeCache env }
where cachedM = mapMaybeIdMap fromBinding m
fromBinding (IsBoundTo {bindingE = e}) = Just e
fromBinding _ = Nothing
changeScope :: (Binding -> Binding) -> Env -> Env
changeScope fn env = cacheScope $ cacheSubst env { envInScope = fmap fn (envInScope env) }
cacheScope :: Env -> Env
cacheScope env = env { envInScopeCache = mapMaybeIdMap fromBinding (envInScope env) }
where fromBinding (IsBoundTo {bindingE = e}) = Just e
fromBinding _ = Nothing
substLookup :: Id -> SM (Maybe Range)
substLookup id = SM $ ask >>= return . mlookup id . envSubst
substAddList ls env = cacheSubst env { envSubst = fromList ls `union` envSubst env }
applySubst :: Subst -> IdMap a -> IdMap OutE
applySubst s nn = applySubst' s where
check n = n `mmember` s || n `mmember` nn
applySubst' s = fmap g s
g (Done e) = e
g (Susp e s') = doSubst' False False (applySubst' s') check e
evalRange :: Range -> SM OutE
evalRange (Done e) = return e
evalRange (Susp e s) = localEnv (envSubst_s s) $ dosub e
cacheSubst env = env { envCachedSubst = applySubst (envSubst env) (envInScope env) }
dosub :: InE -> SM OutE
dosub e = ask >>= \inb -> coerceOpt return (doSubst' False False (envCachedSubst inb) (`mmember` envCachedSubst inb) e)
simplifyE :: SimplifyOpts -> InE -> (Stat,OutE)
simplifyE sopts e = (stat,e') where
Identity ([Comb { combBody = e' }],stat) = runStatT $ simplifyDs program sopts [bindComb (tvrSilly,e)]
programSSimplify :: SimplifyOpts -> Program -> Program
programSSimplify sopts prog = let
Identity (dsIn,stats) = runStatT $ simplifyDs prog sopts (progCombinators prog)
in (progCombinators_s dsIn prog) { progStats = progStats prog `mappend` stats }
programSSimplifyPStat :: SimplifyOpts -> Program -> IO Program
programSSimplifyPStat sopts prog = do
setPrintStats True
dsIn <- simplifyDs prog sopts (progCombinators prog)
return (progCombinators_s dsIn prog)
data Cont =
ApplyTo {
contArg :: Range,
contNext :: Cont
}
| LazyContext TVr -- the RHS of a let statement
| StartContext
-- | ArgContext
| Coerce Range Cont
{- | Scrutinee {
contExamined :: Bool -- ^ whether the result is actually examined, or just bound to a variable
}-}
deriving(Show)
isApplyTo ApplyTo {} = True
isApplyTo _ = False
simplifyDs :: forall m . MonadStats m => Program -> SimplifyOpts -> [Comb] -> m [Comb]
simplifyDs prog sopts dsIn = ans where
finalPhase = so_finalPhase sopts
ans = do
let ((dsOut,_),stats) = runSM (so_cachedScope sopts) doit
mtickStat stats
let lupRules t = concat [ combRules c | c <- dsIn, combIdent c == t]
return [ combRules_s (lupRules (tvrIdent t)) $ bindComb (t,e) | (t,e) <- dsOut ]
getType e = infertype (progDataTable prog) e
doit = do
smAddNamesIdSet (progUsedIds prog)
smAddBoundNamesIdSet (progFreeIds prog)
smAddBoundNamesIdSet (sfilter (`notElem` map combIdent dsIn) $ so_forwardVars sopts)
smAddBoundNamesIdSet (so_boundVarsCache sopts)
doDs (map combBind dsIn)
makeRange b = do
sub <- asks envSubst
return $ susp b sub
f :: Cont -> InE -> SM OutE
--f cont e | trace (take 20 (show cont) ++ " - " ++ take 40 (show e)) False = undefined
-- f ArgContext e = dosub e
f c (EAp a b) = do
b' <- makeRange b
f ApplyTo { contArg = b', contNext = c } a
f (ApplyTo rng cont) (ELam t b) = do
addBoundNames [tvrIdent t]
mtick (toAtom $ "E.Simplify.f-beta-reduce/{" ++ pprint t)
localEnv (insertRange (tvrIdent t) rng) $ f cont b
f (ApplyTo rng cont) (EPi t b) = do
addBoundNames [tvrIdent t]
mtick (toAtom $ "E.Simplify.f-pi-reduce/{" ++ pprint t)
localEnv (insertRange (tvrIdent t) rng) $ f cont b
f cont (EVar v) = do
z <- substLookup (tvrIdent v)
case z of
Just (Done e) -> done cont e
Just (Susp e s) -> localEnv (envSubst_s s) $ f cont e
Nothing -> done cont (EVar v)
f (Coerce t cont) (EError s _) = evalRange t >>= \t' -> done cont (EError s t')
f (Coerce t cont) (ELit (LitInt n _)) = evalRange t >>= \t' -> done cont (ELit (LitInt n t'))
f cont v | Just (e,t) <- from_unsafeCoerce v =
makeRange t >>= \t' -> f (g t' cont) e where g t' (Coerce _ cont) = Coerce t' cont ; g t' cont = Coerce t' cont
f cont ep@EPrim {} = do
ep' <- primOpt' (progDataTable prog) ep
ep'' <- dosub ep'
done cont ep''
f cont e@ELit {} = dosub e >>= done cont
f cont (ELam v e) = do
addNames [tvrIdent v]
v' <- nname v
e' <- localEnv (insertDoneSubst v (EVar v') . insertInScope (tvrIdent v') NotKnown) $ f StartContext e
done cont $ ELam v' e'
f cont e@(EPi (TVr { tvrIdent = n }) _) = do
addNames [n]
e' <- dosub e
done cont e'
f cont (EError s t) = (EError s `fmap` dosub t) >>= done cont
f cont ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} = do
addNames (map tvrIdent $ caseBinds ec)
-- e' <- f (Scrutinee (not $ null as)) e
e' <- f StartContext e
ec' <- doCaseCont cont e' (eCaseType ec) b as d
done StartContext ec'
f cont ELetRec { eDefs = [], eBody = e } = f cont e
f cont ELetRec { eDefs = ds@(_:_), eBody = e } = do
tickCont cont "let"
(ds',inb') <- doDs ds
e' <- localEnv (const inb') $ f cont e
res <- case ds' of
[(t,e)] | worthStricting e, Just (Demand.S _) <- Info.lookup (tvrInfo t), not (getProperty prop_CYCLIC t) -> do
mtick $ "E.Simplify.strictness.let-to-case/{" ++ pprint t
return $ eStrictLet t e e'
[(t,ec@ECase { eCaseScrutinee = sc@(EPrim (APrim p _) _ _), eCaseAlts = [], eCaseDefault = Just def })] | primEagerSafe p && not (getProperty prop_CYCLIC t) -> do
mtick $ "E.Simplify.strictness.cheap-eagerness.def/{" ++ pprint t
return $ caseUpdate ec { eCaseDefault = Just $ ELetRec [(t,def)] e', eCaseType = getType e' }
[(t,ec@ECase { eCaseScrutinee = sc@(EPrim (APrim p _) _ _), eCaseAlts = [Alt c def], eCaseDefault = Nothing })] | primEagerSafe p && not (getProperty prop_CYCLIC t) -> do
mtick $ "E.Simplify.strictness.cheap-eagerness.con/{" ++ pprint t
return $ caseUpdate ec { eCaseAlts = [Alt c (ELetRec [(t,def)] e')], eCaseType = getType e' }
_ -> do
let fn ds (ELetRec { eDefs = ds', eBody = e}) | not (hasRepeatUnder fst (ds ++ ds')) = fn (ds' ++ ds) e
fn ds e = f ds (Set.fromList $ fsts ds) [] False where
f ((t,ELetRec { eDefs = ds', eBody = e}):rs) us ds b | all (not . (`Set.member` us)) (fsts ds') = f ((t,e):rs) (Set.fromList (fsts ds') `Set.union` us) (ds':ds) True
f (te:rs) us ds b = f rs us ([te]:ds) b
f [] _ ds True = fn (concat ds) e
f [] _ ds False = (concat ds,e)
let (ds'',e'') = fn ds' e'
when (flint && hasRepeatUnder fst ds'') $ fail "hasRepeats!"
mticks (length ds'' - length ds') (toAtom $ "E.Simplify.let-coalesce")
return $ eLetRec ds'' e''
done StartContext res
f cont e = trace ("Fall through: " ++ show (cont,e)) $ dosub e >>= done cont
showName t | isValidAtom t || dump FD.EVerbose = tvrShowName (tVr t Unknown)
| otherwise = "(epheremal)"
-- Rename a if necessary. We always have to substitute all occurrences because we update the type.
-- nname tvr = renameSM tvr
nname tvr@(TVr { tvrIdent = n, tvrType = t}) = do
t' <- dosub t
inb <- ask
let t'' = substMap' (envInScopeCache inb) t'
n' <- if n == 0 then return 0 else uniqueName n
return $ tvr { tvrIdent = n', tvrType = t'' }
-- TODO - case simplification
tickCont (ApplyTo _ cont) cs = mtick ("E.Simplify.application-push." ++ cs) >> tickCont cont cs
tickCont (Coerce _ cont) cs = mtick ("E.Simplify.coerce-push." ++ cs) >> tickCont cont cs
tickCont _ _ = return ()
contType (ApplyTo z cont) t = contType cont t >>= \t' -> evalRange z >>= \z' -> return (eAp t' z')
contType (Coerce t cont) _ = evalRange t
contType _ t = return t
doCaseCont :: Cont -> OutE -> InE -> InTVr -> [Alt InE] -> (Maybe InE) -> SM OutE
doCaseCont cont e t b as d = do
inb <- ask
let
varval = do EVar v <- return e; mlookup (tvrIdent v) (envInScope inb)
doCase ELetRec { eDefs = ds, eBody = e} t b as d = do
mtick "E.Simplify.let-from-case"
e' <- doCaseCont cont e t b as d
done StartContext (substLet' ds e')
doCase _ t b as d | Just IsBoundTo { bindingE = ELit l } <- varval = doConstCase cont l t b as d
doCase (EPi TVr { tvrType = x} y) t b as d = doConstCase cont litCons { litName = tc_Arrow, litArgs = [x,y], litType = eStar} t b as d
doCase (ELit l) t b as d = doConstCase cont l t b as d
doCase (EVar v) t b as d | Just IsBoundTo { bindingE = e } <- varval , isBottom e = do
mtick "E.Simplify.case-of-bottom'"
t' <- makeRange t
done (Coerce t' cont) (EVar v)
doCase e t b as d | isBottom e = do
mtick "E.Simplify.case-of-bottom"
t' <- makeRange t
done (Coerce t' cont) e
doCase ic@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d } t b' as' d'
| length (filter (not . isBottom) (caseBodies ic)) <= 1 ||
all whnfOrBot (caseBodies ic) ||
all whnfOrBot (caseBodies emptyCase { eCaseAlts = as', eCaseDefault = d'} ) = do
mtick (toAtom "E.Simplify.case-of-case")
let f (Alt l e) = do
e' <- localEnv (extendScope (fromList [ (n,NotKnown) | TVr { tvrIdent = n } <- litBinds l ]))
$ doCaseCont StartContext e t b' as' d'
return (Alt l e')
--g e >>= return . Alt l
g x = localEnv (insertInScope (tvrIdent b) NotKnown) $ doCaseCont StartContext x t b' as' d'
as'' <- mapM f as
d'' <- T.mapM g d
t' <- dosub t
done cont $ caseUpdate ECase {
eCaseAllFV = error "eCaseAllFV",
eCaseScrutinee = e,
eCaseType = t',
eCaseBind = b,
eCaseAlts = as'',
eCaseDefault = d''} -- XXX -- we duplicate code so continue for next renaming pass before going further.
doCase ic@ECase { eCaseType = it, eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d } t b' as' d' | not (isUnboxedTuple it) = do
mtick (toAtom "E.Simplify.case-of-case-join")
n1 <- newName
n2 <- newName
let cvar = setProperty prop_ONESHOT $ tVr n1 it
rcc <- doCaseCont StartContext (EVar cvar) t b' as' d'
let fbody = ELam cvar rcc
zvar = setProperties [prop_JOINPOINT,prop_ONESHOT] $ tVr n2 (EPi tvr { tvrType = it } (getType rcc))
nic <- flip caseBodiesMapM ic $ \body -> return $ eLet cvar body (eAp (EVar zvar) (EVar cvar))
done cont $ eLet zvar fbody nic { eCaseType = getType rcc }
doCase e t b as@(Alt LitCons { litName = n } _:_) (Just d) | Just nsib <- numberSiblings (progDataTable prog) n, nsib <= length as = do
mtick "E.Simplify.case-no-default"
doCase e t b as Nothing
doCase e t b (a@(Alt LitCons { litName = n } _):_) (Just d) | Just _ <- fromUnboxedNameTuple n = do
mtick "E.Simplify.case-unboxed-no-default"
doCase e t b [a] Nothing
{-
Remove the default case if possible.
case lst of [] -> True; _ -> False
==>
case lst of [] -> True; (:) uniq1 uniq2 -> False
-}
doCase e t b as (Just d) | te /= tWorld__, (ELit LitCons { litName = cn }) <- followAliases dt te
, Just Constructor { conChildren = DataNormal cs } <- getConstructor cn dt
, length as == length cs - 1 || (False && length as < length cs && isAtomic d) = do
let ns = [ n | Alt ~LitCons { litName = n } _ <- as ]
ls = filter (`notElem` ns) cs
ff n = do
con <- getConstructor n dt
let g t = do
n <- newName
return $ tVr n t
ts <- mapM g (slotTypes (progDataTable prog) n te)
let wtd = ELit $ updateLit (progDataTable prog) litCons { litName = n, litArgs = map EVar ts, litType = te }
return $ Alt (updateLit (progDataTable prog) litCons { litName = n, litArgs = ts, litType = te }) (eLet b wtd d)
mtick $ "E.Simplify.case-improve-default.{" ++ show (sort ls) ++ "}"
ls' <- mapM ff ls
--ec <- dosub $ caseUpdate emptyCase { eCaseScrutinee = e, eCaseType = t, eCaseBind = b, eCaseAlts = as ++ ls' }
--localEnv (envSubst_s mempty) $ f StartContext (caseUpdate ec { eCaseScrutinee = e })
doCase e t b (as ++ ls') Nothing
where
te = getType b
dt = (progDataTable prog)
doCase e _ b [] (Just d) | not (isLifted e || isUnboxed (getType e)) = do
mtick "E.Simplify.case-unlifted"
b' <- nname b
d' <- localEnv (insertDoneSubst b (EVar b') . (insertInScope (tvrIdent b') (fixInline finalPhase b' $ isBoundTo noUseInfo e))) $ f cont d
done StartContext $ eLet b' e d'
doCase e@ELam {} _ b [] (Just d) = do
mtick "E.Simplify.case-lambda"
b' <- nname b
d' <- localEnv (insertDoneSubst b (EVar b') . (insertInScope (tvrIdent b') (fixInline finalPhase b' $ isBoundTo noUseInfo e))) $ f cont d
done StartContext $ eLet b' e d'
-- atomic unboxed values may be substituted or discarded without replicating work or affecting program semantics.
doCase e _ b [] (Just d) | isUnboxed (getType e), isAtomic e = do
mtick "E.Simplify.case-atomic-unboxed"
localEnv (insertDoneSubst b e) $ f cont d
doCase e _ TVr { tvrIdent = 0 } [] (Just d) | isOmittable inb e = do
mtick "E.Simplify.case-omittable"
f cont d
doCase (EVar v) _ b [] (Just d) | Just (NotAmong _) <- varval = do
mtick $ "E.Simplify.case-evaled/{" ++ pprint v
localEnv (insertDoneSubst b (EVar v)) $ f cont d
doCase e _ b [] (Just (EVar v')) | b == v' = do
mtick $ "E.Simplify.case-trailing/{" ++ pprint b
done cont e
doCase scrut _ v [] (Just sc@ECase { eCaseScrutinee = EVar v'} ) | v == v', tvrIdent v `notMember` (freeVars (caseBodies sc) :: IdSet) = do
mtick "E.Simplify.case-default-case"
doCase scrut (eCaseType sc) (eCaseBind sc) (eCaseAlts sc) (eCaseDefault sc)
doCase e t b as d = do
tickCont cont "case"
b' <- nname b
(ids,b') <- case (e,tvrIdent b') of
(EVar v,0) -> do
nn <- newName
b' <- return b' { tvrIdent = nn }
return $ (insertInScope (tvrIdent v) (isBoundTo noUseInfo (EVar b')),b')
(EVar v,_) -> return $ (insertDoneSubst b (EVar b') . insertInScope (tvrIdent v) (isBoundTo noUseInfo (EVar b')),b')
_ -> return $ (insertDoneSubst b (EVar b'),b')
inb <- ask
let dd e' = localEnv (const $ ids $ extendScope newinb inb) $ f cont e' where
na = NotAmong [ n | Alt LitCons { litName = n } _ <- as]
newinb = fromList [ (n,na) | EVar (TVr { tvrIdent = n }) <- [EVar b']]
da (Alt (LitInt n t) ae) = do
t' <- dosub t
let p' = LitInt n t'
e' <- localEnv (ids . mins e (patToLitEE p')) $ f cont ae
return $ Alt p' e'
da (Alt lc@LitCons { litName = n, litArgs = ns, litType = t } ae) = do
t' <- dosub t
ns' <- mapM nname ns
let p' = lc { litArgs = ns', litType = t' }
nsub = [ (n,Done (EVar t)) | TVr { tvrIdent = n } <- ns | t <- ns' ]
ninb = fromList [ (n,NotKnown) | TVr { tvrIdent = n } <- ns' ]
e' <- localEnv (const $ ids $ substAddList nsub (extendScope ninb $ mins e (patToLitEE p') inb)) $ f cont ae
return $ Alt p' e'
mins _ e | 0 `notMember` (freeVars e :: IdSet) = insertInScope (tvrIdent b') (isBoundTo noUseInfo e)
mins _ _ = id
d' <- T.mapM dd d
as' <- mapM da as
t' <- dosub t
t' <- contType cont t'
done StartContext $ caseUpdate ECase {
eCaseAllFV = error "eCaseAllFV",
eCaseScrutinee = e,
eCaseType = t',
eCaseBind = b',
eCaseAlts = as',
eCaseDefault = d'}
doCase e t b as d
isOmittable _ ELit {} = True
isOmittable _ EPi {} = True
isOmittable _ ELam {} = True
isOmittable _ (EPrim (APrim p _) _ _) = primIsConstant p
isOmittable inb (EVar v) = case mlookup (tvrIdent v) (envInScope inb) of
Just IsBoundTo { bindingE = e } | not (isEVar e) -> isOmittable inb e
Just (NotAmong _) -> True
_ -> False
isOmittable _ _ = False
doConstCase :: Cont -> {- Out -} Lit E E -> InE -> InTVr -> [Alt E] -> Maybe InE -> SM OutE
doConstCase cont l t b as d = do
t' <- dosub t
mr <- match l as (b,d)
inb <- ask
case mr of
Just (bs,e) -> do
let bs' = [ x | x@(TVr { tvrIdent = n },_) <- bs, n /= 0]
binds <- mapM (\ (v,e) -> nname v >>= return . (,,) e v) bs'
e' <- localEnv (substAddList [ (n,Done $ EVar nt) | (_,TVr { tvrIdent = n },nt) <- binds] . extendScope (fromList [ (n,isBoundTo noUseInfo e) | (e,_,TVr { tvrIdent = n }) <- binds])) $ f StartContext e
done cont $ eLetRec [ (v,e) | (e,_,v) <- binds ] e'
Nothing -> do
done cont $ EError ("match falls off bottom: " ++ pprint l) t'
match m@LitCons { litName = c, litArgs = xs } ((Alt LitCons { litName = c', litArgs = bs } e):rs) d@(b,_) | c == c' = do
mtick (toAtom $ "E.Simplify.known-case." ++ show c )
return $ Just ((b,ELit m):(zip bs xs),e)
| otherwise = match m rs d
match m@(LitInt x _) ((Alt (LitInt y _) e):rs) d@(b,_) | x == y = do
mtick (toAtom $ "E.Simplify.known-case." ++ show x)
return $ Just ([(b,ELit m)],e)
| otherwise = match m rs d
match m@LitCons { litName = c } [] (_,Just e) | Just _ <- fromUnboxedNameTuple c = do
mtick (toAtom $ "E.Simplify.known-case._#" ++ show c )
return (Just ([],e))
match l [] (b,Just e) = do
mtick (toAtom "E.Simplify.known-case._")
return $ Just ([(b,ELit l)],e)
match m [] (_,Nothing) = do
mtick (toAtom "E.Simplify.known-case.unmatch")
return Nothing
match m as d = error $ "Odd Match: " ++ show ((m,getType m),as,d)
applyRule :: OutTVr -> [OutE] -> SM (Maybe (OutE,[OutE]))
applyRule v xs = do
inb <- ask
z <- builtinRule v xs
let lup x = case mlookup x (envInScope inb) of
Just IsBoundTo { bindingE = e } -> Just e
_ -> Nothing
case z of
Nothing | fopts FO.Rules -> applyRules lup (mfindWithDefault mempty (tvrIdent v) $ envRules inb) xs
x -> return x
done cont e = z cont [] where
z (ApplyTo r cont') rs = evalRange r >>= \a -> z cont' (a:rs)
z (Coerce t cont) rs = do
t' <- evalRange t
z <- hFunc e (reverse rs)
done cont (prim_unsafeCoerce z t')
z _ rs = hFunc e (reverse rs)
hFunc :: OutE -> [OutE] -> SM OutE
hFunc (EVar v) xs' = do
inb <- ask
z <- applyRule v xs'
let txs = map tx xs' where
tx (ELit l) = knowLit l
tx EPi {} = KnowSomething
tx (EVar v) = case mlookup (tvrIdent v) (envInScope inb) of
Just (NotAmong xs) -> KnowNotOneOf xs
Just IsBoundTo { bindingE = ELit l } -> knowLit l
Just IsBoundTo {} -> KnowSomething
_ -> KnowNothing
tx _ = KnowNothing
knowLit LitCons { litName = c } = KnowIsCon c
knowLit (LitInt n _) = KnowIsNum n
case z of
(Just (x,xs)) -> didInline x xs -- h x xs inb
_ -> case mlookup (tvrIdent v) (envInScope inb) of
Just IsBoundTo { inlineForced = ForceNoinline } -> appVar v xs'
Just IsBoundTo { bindingOccurance = Once } -> error "IsBoundTo: Once"
Just IsBoundTo { bindingE = e, bindingAtomic = True } -> do
mtick (toAtom $ "E.Simplify.inline.atomic/{" ++ tvrShowName v ++ "}")
didInline e xs'
Just IsBoundTo { bindingE = e, inlineForced = ForceInline } | someBenefit v e txs -> do
mtick (toAtom $ "E.Simplify.inline.Forced/{" ++ tvrShowName v ++ "}")
didInline e xs'
Just IsBoundTo { bindingOccurance = OnceInLam, bindingE = e, bindingCheap = True } | someBenefit v e txs -> do
mtick (toAtom $ "E.Simplify.inline.OnceInLam/{" ++ showName (tvrIdent v) ++ "}")
didInline e xs'
Just IsBoundTo { bindingOccurance = ManyBranch, bindingE = e } | multiInline v e txs -> do
mtick (toAtom $ "E.Simplify.inline.ManyBranch/{" ++ showName (tvrIdent v) ++ "}")
didInline e xs'
Just IsBoundTo { bindingOccurance = Many, bindingE = e, bindingCheap = True } | multiInline v e txs -> do
mtick (toAtom $ "E.Simplify.inline.Many/{" ++ showName (tvrIdent v) ++ "}")
didInline e xs'
Just _ -> appVar v xs'
Nothing -> appVar v xs'
-- Nothing | tvrIdent v `Set.member` exports -> app (EVar v,xs')
-- Nothing -> error $ "Var not in scope: " ++ show v
hFunc e xs' = do app (e,xs')
didInline ::OutE -> [OutE] -> SM OutE
didInline z zs = return (foldl EAp z zs)
didInline z zs = do
used <- smUsedNames
let (ne,nn) = runRename used (foldl EAp z zs)
smAddNamesIdSet nn
return ne
appVar v xs = do
me <- etaExpandAp (progDataTable prog) v xs
case me of
Just e -> return e
Nothing -> app (EVar v,xs)
app (e,[]) = return e
app (e,xs) = app' e xs
app' (ELit lc@LitCons { litName = n, litArgs = xs, litType = EPi ta tt }) (a:as) = do
mtick (toAtom $ "E.Simplify.typecon-reduce.{" ++ show n ++ "}" )
app' (ELit lc { litArgs = xs ++ [a], litType = subst ta a tt }) as
app' (ELit LitCons { litName = n, litArgs = es, litAliasFor = Just af }) bs@(_:_) = do
mtick (toAtom $ "E.Simplify.newtype-reduce.{" ++ show n ++ "}" )
app' (foldl eAp af (es ++ bs)) []
app' (EError s t) xs = do
mticks (length xs) (toAtom "E.Simplify.error-application")
return $ EError s (foldl eAp t xs)
app' e as = do
return $ foldl EAp e as
doDs ds = do
addNames $ map (tvrIdent . fst) ds
let z :: (InTVr,InE) -> SM (Id,UseInfo,OutTVr,InE)
z (t,EVar t') | t == t' = do -- look for simple loops and replace them with errors.
t'' <- nname t
mtick $ "E.Simplify.<<loop>>.{" ++ showName (tvrIdent t) ++ "}"
return (tvrIdent t,noUseInfo,t'',EError "<<loop>>" (getType t))
z (t,e) = do
t' <- nname t
case Info.lookup (tvrInfo t) of
_ | forceNoinline t -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e)
Just ui@UseInfo { useOccurance = Once } -> return (tvrIdent t,ui,error $ "Once: " ++ show t,e)
Just n -> return (tvrIdent t,n,t',e)
-- We don't want to inline things we don't have occurance info for because they might lead to an infinite loop. hopefully the next pass will fix it.
Nothing -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e)
-- Nothing -> error $ "No Occurance info for " ++ show t
w :: [(Id,UseInfo,OutTVr,InE)] -> [(OutTVr,OutE)] -> SM ([(OutTVr,OutE)],Env)
w ((t,UseInfo { useOccurance = Once },t',e):rs) ds = do
mtick $ "E.Simplify.inline.Once/{" ++ showName t ++ "}"
w rs ds -- (minsert t (Susp e sub) sub) inb ds
w ((t,n,t',e):rs) ds = do
let inb = case isForced of
ForceInline -> cacheSubst . changeScope nogrowth
_ -> id
isForced = calcForced finalPhase t'
nogrowth IsBoundTo { bindingAtomic = False } = NotKnown
nogrowth x = x
e' <- localEnv inb $ f (LazyContext t') e
let ibt = fixInline finalPhase t' $ isBoundTo n e'
case (bindingAtomic ibt,inlineForced ibt) of
(True,f) | f /= ForceNoinline -> do
--when (n /= Unused) $ mtick $ "E.Simplify.inline.Atomic.{" ++ showName t ++ "}"
localEnv (insertDoneSubst' t e' . insertInScope (tvrIdent t') ibt) $ w rs ((t',e'):ds)
_ -> localEnv (insertInScope (tvrIdent t') ibt) $ w rs ((t',e'):ds)
w [] ds = ask >>= \inb -> return (ds,inb)
s' <- mapM z ds
inb <- ask
let sub'' = fromList [ (t,susp e sub'') | (t, UseInfo { useOccurance = Once },_,e) <- s'] `union`
fromList [ (t,Done (EVar t')) | (t,n,t',_) <- s', useOccurance n /= Once] `union`
envSubst inb
(ds',inb') <- localEnv (envSubst_s sub'' . extendScope (fromList [ (tvrIdent t',NotKnown) | (_,n,t',_) <- s', useOccurance n /= Once])) $ w s' []
let minArgs t = case Info.lookup (tvrInfo t) of
Just (UseInfo { minimumArgs = min }) -> min
Nothing -> 0
ds' <- sequence [ etaExpandDef' (progDataTable prog) (minArgs t) t e | (t,e) <- ds']
return (ds',inb')
data KnowSomething = KnowNothing | KnowNotOneOf [Name] | KnowIsCon Name | KnowIsNum Number | KnowSomething
deriving(Eq)
someBenefit _ e _ | isAtomic e = True
someBenefit _ ELit {} _ = True
someBenefit _ EPi {} _ = True
someBenefit _ EPrim {} _ = True
someBenefit v ELetRec { eDefs = ds, eBody = e } xs | someBenefit v e xs = True
--someBenefit _v ECase {} (_:_) = True
someBenefit _ e xs | f e xs = True where
f (ELam _ e) (_:xs) = f e xs
f ELam {} [] = any (/= KnowNothing) xs
f _ _ = not (null xs)
someBenefit v e xs = any (/= KnowNothing) xs
exprSize ::
Int -- ^ maximum size before bailing out
-> E -- ^ expression
-> Int -- ^ discount for case of something known
-> [(Id,KnowSomething)] -- ^ things that are known
-> Maybe Int
exprSize max e discount known = f max e >>= \n -> return (max - n) where
f n _ | n <= 0 = fail "exprSize: expression too big"
f n EVar {} = return $! n - 1
f n (EAp x@(EVar v) y) | Just _ <- lookup (tvrIdent v) known = do
v <- f (n + discount) x
f v x
f n (EAp x y) = do
v <- f n x
f v x
f n (ELam t x) = f (n - 1) x
f n EPi {} = return $! n - 1
f n ELit {} = return $! n - 1
f n ESort {} = return $! n - 1
f n EPrim {} = return $! n - 1
f n EError {} = return $! n - 1
f n ec@ECase { eCaseScrutinee = EVar tv } | Just l <- lookup (tvrIdent tv) known = do
n <- f (n + discount) (EVar tv)
let g n [] | Just d <- eCaseDefault ec = f n d
| otherwise = return n
g n (Alt LitCons { litName = c' } e:rs) | KnowIsCon c <- l = if c == c' then f n e else g n rs
g n (Alt (LitInt c' _) e:rs) | KnowIsNum c <- l = if c == c' then f n e else g n rs
g n (Alt LitCons { litName = c } e:rs) | KnowNotOneOf na <- l = if c `elem` na then g n rs else f n e >>= \n' -> g n' rs
g n (Alt _ e:rs) = f n e >>= \n' -> g n' rs
g n (eCaseAlts ec)
f n ec@ECase {} = do
n <- f n (eCaseScrutinee ec)
foldM f n (caseBodies ec)
f n ELetRec {eDefs = ds, eBody = e } = do
n <- foldM f n (snds ds)
f n e
noSizeIncrease e xs = f e xs where
currentSize = 1 + length xs
f (ELam t e) (x:xs) = f e xs
f ELam {} [] = False -- ^ abort if we will create a lambda
f e [] = isJust $ exprSize currentSize e 3 []
f e xs = isJust $ exprSize (currentSize - length xs) e 3 []
--multiInline _ e xs | isSmall (f e xs) = True where -- should be noSizeIncrease
-- f e [] = e
-- f (ELam _ e) (_:xs) = f e xs
-- f e xs = foldl EAp e xs
--
--
scrutineeDiscount = 4
extraArgDiscount = 1
knowSomethingDiscount = 2
multiInline _ e xs | noSizeIncrease e xs = True
multiInline v e xs | not (someBenefit v e xs) = False
multiInline v e xs = f e xs [] where
currentSize = 1 + length xs
f (ELam t e) (KnowNothing:xs) rs = f e xs rs
f (ELam t e) (x:xs) rs = f e xs ((tvrIdent t,x):rs)
f e xs rs = isJust $ exprSize (knowSomethingDiscount*(length rs) + discount + currentSize + (if null xs then 0 else extraArgDiscount)) e scrutineeDiscount rs where
discount = if safeToDup e then 4 else 0
worthStricting EError {} = True
worthStricting ELit {} = False
worthStricting ELam {} = False
worthStricting x = sortTermLike x
coerceOpt :: MonadStats m => (E -> m E) -> E -> m E
coerceOpt fn e = do
let (n,e',p) = unsafeCoerceOpt e
n `seq` stat_unsafeCoerce `seq` mticks n stat_unsafeCoerce
e'' <- fn e'
return (p e'')
stat_unsafeCoerce = toAtom "E.Simplify.unsafeCoerce"
-----------------------
-- simplification Monad
-----------------------
data SmState = SmState {
idsUsed :: !IdSet,
idsBound :: !IdSet,
smStdGen :: !StdGen
}
smState = SmState { idsUsed = mempty, idsBound = mempty, smStdGen = mkStdGen 42 }
newtype SM a = SM (RWS Env Stats.Stat SmState a)
deriving(Monad,Functor,MonadReader Env, MonadState SmState)
localEnv f (SM action) = SM $ local (cacheSubst . f) action
runSM :: Env -> SM a -> (a,Stat)
runSM env (SM x) = (r,s) where
(r,_,s) = runRWS x (cacheSubst env) smState
instance MonadStats SM where
mticks' n k = SM $ tell (Stats.singleStat n k) >> return ()
modifyIds fn = SM $ modify f where
f s@SmState { idsUsed = used, idsBound = bound, smStdGen=gen } = case fn (used,bound) of (used',bound') -> s { idsUsed = used', idsBound = bound', smStdGen = gen }
getIds = SM $ liftM f get where
f s@SmState { idsUsed = used, idsBound = bound } = (used,bound)
putIds x = SM $ modify (f x) where
f (used,bound) = \s -> s { idsUsed = used, idsBound = bound }
instance NameMonad Id SM where
addNames ns = do
modifyIds (\ (used,bound) -> -- trace ("AddNames: " ++ show (size used,size bound)) $
(fromList ns `union` used, bound) )
addBoundNames ns = do
let nset = fromList ns
modifyIds (\ (used,bound) -> --trace ("AddBoundNames: " ++ show (size used, size bound))
(nset `union` used, nset `union` bound) )
uniqueName n = do
(used,bound) <- getIds
if n `member` bound then newName else putIds (insert n used,insert n bound) >> return n
newNameFrom vs = do
(used,bound) <- getIds
let f (x:xs)
| x `member` used = f xs
| otherwise = x
f [] = error "newNameFrom: finite list!"
nn = f vs
putIds (insert nn used, insert nn bound)
return nn
newName = do
(used,bound) <- getIds
let genNames i = [st, st + 2 ..] where
st = abs i + 2 + abs i `mod` 2
-- trace ("newName: "++ show (size used, size bound)) $ return ()
--newNameFrom (genNames (size used + size bound))
sm <- get
let (g1,g2) = split (smStdGen sm)
put sm{smStdGen = g1}
newNameFrom (filter (>0) $ filter even $ randoms g2)
smUsedNames = SM $ gets idsUsed
smBoundNames = SM $ gets idsBound
smAddNamesIdSet nset = --trace ("addNamesIdSet: "++ show (size nset)) $
do modifyIds (\ (used,bound) -> (nset `union` used, bound) )
smAddBoundNamesIdSet nset = --trace ("addBoundNamesIdSet: "++show (size nset)) $
do modifyIds (\ (used,bound) -> (nset `union` used, nset `union` bound) )
smAddBoundNamesIdMap = smAddNamesIdSet . idMapToIdSet