module DDC.Core.Transform.Prune
( PruneInfo (..)
, pruneModule
, pruneX)
where
import DDC.Core.Analysis.Usage
import DDC.Core.Simplifier.Base
import DDC.Core.Transform.Reannotate
import DDC.Core.Transform.TransformUpX
import DDC.Core.Fragment
import DDC.Core.Check
import DDC.Core.Module
import DDC.Core.Exp
import DDC.Type.Env
import DDC.Base.Pretty
import Data.Typeable
import Control.Monad.Writer (Writer, runWriter, tell)
import qualified Data.Map as Map
import qualified DDC.Core.Transform.SubstituteXX as S
import qualified DDC.Type.Equiv as T
import qualified DDC.Type.Compounds as T
import qualified DDC.Type.Sum as TS
import qualified DDC.Type.Env as Env
import Prelude hiding ((<$>))
data PruneInfo
= PruneInfo
{
infoBindingsErased :: Int }
deriving Typeable
instance Pretty PruneInfo where
ppr (PruneInfo remo)
= text "Prune:"
<$> indent 4 (vcat
[ text "Removed: " <> int remo])
instance Monoid PruneInfo where
mempty = PruneInfo 0
mappend (PruneInfo r1) (PruneInfo r2)
= PruneInfo (r1 + r2)
pruneModule
:: (Show a, Show n, Ord n, Pretty n)
=> Profile n
-> Module a n
-> Module a n
pruneModule profile mm
| not $ featuresTrackedEffects
$ profileFeatures profile
= mm
| otherwise
= mm { moduleBody
= result
$ pruneX profile (moduleKindEnv mm) (moduleTypeEnv mm)
$ moduleBody mm }
pruneX
:: (Show a, Show n, Ord n, Pretty n)
=> Profile n
-> KindEnv n
-> TypeEnv n
-> Exp a n
-> TransformResult (Exp a n)
pruneX profile kenv tenv xx
=
let
(xx', info)
= transformTypeUsage profile kenv tenv
(transformUpMX pruneTrans kenv tenv)
xx
progress (PruneInfo r)
= r > 0
in TransformResult
{ result = xx'
, resultAgain = progress info
, resultProgress = progress info
, resultInfo = TransformInfo info }
transformTypeUsage profile kenv tenv trans xx
= let config = configOfProfile profile
rr = checkExp config kenv tenv Recon DemandNone xx
in case fst rr of
Right (xx1, _, _)
-> let xx2 = usageX xx1
(x', info) = runWriter (trans xx2)
x'' = reannotate (\(_, AnTEC { annotTail = a }) -> a) x'
in (x'', info)
Left _
-> error $ renderIndent
$ vcat [ text "ddc-core-simpl.Prune: core type error" ]
type Annot a n
= (UsedMap n, AnTEC a n)
pruneTrans
:: (Show a, Show n, Ord n, Pretty n)
=> KindEnv n
-> TypeEnv n
-> Exp (Annot a n) n
-> Writer PruneInfo
(Exp (Annot a n) n)
pruneTrans _ _ xx
= case xx of
XLet a@(usedMap, antec) (LLet b x1) x2
| isUnusedBind b usedMap
, isContainedEffect $ annotEffect antec
-> do
let x2' = S.substituteXX b x1 x2
tell mempty {infoBindingsErased = 1}
return $ XCast a (weakEff antec)
$ x2'
_ -> return xx
where
weakEff antec
= CastWeakenEffect
$ T.crushEffect Env.empty
$ annotEffect antec
isUnusedBind :: Ord n => Bind n -> UsedMap n -> Bool
isUnusedBind bb (UsedMap um)
= case bb of
BName n _
-> case Map.lookup n um of
Just useds -> filterUsedInCasts useds == []
Nothing -> True
BNone _ -> True
_ -> False
filterUsedInCasts :: [Used] -> [Used]
filterUsedInCasts = filter notCast
where notCast UsedInCast = False
notCast _ = True
isContainedEffect :: Ord n => Effect n -> Bool
isContainedEffect eff
= all contained
$ map T.takeTApps
$ sumList
$ T.crushEffect Env.empty eff
where
contained (c : _args)
= case c of
TCon (TyConSpec TcConAlloc) -> True
TCon (TyConSpec TcConDeepAlloc) -> True
TCon (TyConSpec TcConRead) -> True
TCon (TyConSpec TcConHeadRead) -> True
TCon (TyConSpec TcConDeepRead) -> True
_ -> False
contained [] = False
sumList (TSum ts) = TS.toList ts
sumList tt = [tt]