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 Data.Monoid (Monoid, mempty, mappend)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified DDC.Type.Env as Env
import qualified DDC.Core.Collect as C
import qualified DDC.Core.Transform.SubstituteXX as S
import qualified DDC.Core.Transform.Trim as Trim
import qualified DDC.Type.Compounds as T
import qualified DDC.Type.Sum as TS
import qualified DDC.Type.Transform.Crush as T
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
= case checkExp (configOfProfile profile) kenv tenv xx of
Right (xx1, _, _,_)
-> let xx2 = usageX xx1
(x', info) = runWriter (trans xx2)
x'' = reannotate (\(_, AnTEC { annotTail = a }) -> a) x'
in (x'', info)
Left err
-> error $ renderIndent
$ vcat [ text "DDC.Core.Transform.Prune: core type error"
, ppr err ]
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' = transformUpX' Trim.trimX $ S.substituteXX b x1 x2
tell mempty {infoBindingsErased = 1}
return $ XCast a (weakEff antec)
$ XCast a (weakClo a x1)
$ x2'
_ -> return xx
where
weakEff antec
= CastWeakenEffect
$ T.crushEffect
$ annotEffect antec
weakClo a x1
= CastWeakenClosure
$ Trim.trimClosures a
( (map (XType . TVar)
$ Set.toList
$ C.freeT Env.empty x1)
++ (map (XVar a)
$ Set.toList
$ C.freeX Env.empty x1))
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 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]