2 This module eliminates unused top-level bindings, under the
3 assumption that all top-level bindings with qualified names
6 module Language.Core.ElimDeadCode(elimDeadCode) where
8 import Language.Core.Core
9 import Language.Core.Printer()
10 import Language.Core.Utils
12 import Control.Monad.Reader
16 import qualified Data.Map as M
17 import qualified Data.Set as S
19 elimDeadCode :: Module -> Module
20 elimDeadCode (Module mn tdefs vdefgs) = runReader (do
21 (usedVars, usedDcons, usedTcons) <- findUsed emptySet
22 (mkStartSet mn vdefgs)
23 let isUsed (Vdef (v,_,_)) = v `S.member` usedVars
24 let newVdefgs = [Rec $ filter isUsed (flattenBinds vdefgs)]
25 let newTdefs = filter (tdefIsUsed usedTcons usedDcons) tdefs in
26 return $ Module mn newTdefs newVdefgs) ((mkVarEnv vdefgs), mkTyEnv tdefs)
28 tdefIsUsed :: S.Set (Qual Tcon) -> S.Set (Qual Dcon) -> Tdef -> Bool
29 tdefIsUsed tcs dcs (Data qtc _ cdefs) =
30 (qtc `S.member` tcs || any (\ (Constr qdc _ _) -> qdc `S.member` dcs) cdefs)
31 tdefIsUsed tcs _ (Newtype qtc qtc_co _ _) =
32 qtc `S.member` tcs || qtc_co `S.member` tcs
34 mkVarEnv :: [Vdefg] -> M.Map (Qual Var) Exp
36 let vdefs = flattenBinds vgs in
37 M.fromList [(v, e) | (Vdef (v, _, e)) <- vdefs]
39 -- if there is a Newtype qtc qtc_co ty,
40 -- generate: qtc |-> ty and qtc_co |-> ty
41 -- roughly the same for rhs's of Data decls
42 mkTyEnv :: [Tdef] -> M.Map (Qual Tcon) [Ty]
44 M.fromList ([(qtc, [ty]) | (Newtype qtc _ _ ty) <- tdefs]
45 ++ [(qtc, [ty]) | (Newtype _ qtc _ ty) <- tdefs]
46 ++ concatMap (\ td -> case td of
47 Data qtc _ cdefs -> [(qtc, concatMap
48 (\ (Constr _ _ ts) -> ts) cdefs)]
51 findUsed :: DeadSet -> DeadSet -> DeadM DeadSet
52 findUsed _old@(oldVars,oldDcs,oldTcs) _new@(newVars,newDcs,newTcs) = do
53 let (todoVars, todoTcs) = ((S.\\) newVars oldVars, (S.\\) newTcs oldTcs)
54 let nextOld = (oldVars `S.union` todoVars, oldDcs `S.union` newDcs,
55 oldTcs `S.union` todoTcs)
56 nextStuff <- getVarsAndConsIn (todoVars, todoTcs)
57 if (S.null todoVars && S.null todoTcs)
59 else findUsed nextOld nextStuff
61 getVarsAndConsIn :: (S.Set (Qual Var), S.Set (Qual Tcon)) -> DeadM DeadSet
62 getVarsAndConsIn (vs, tcs) = do
63 vs1 <- mapM varsAndConsInOne (S.toList vs)
64 ts1 <- mapM varsAndConsInOne' (S.toList tcs)
65 let (vs'::[S.Set (Qual Var)], dcs'::[S.Set (Qual Dcon)],
66 ts'::[S.Set (Qual Tcon)]) = unzip3 (vs1 ++ ts1)
67 return (foldl' S.union S.empty vs', foldl' S.union S.empty dcs',
68 foldl' S.union S.empty ts')
70 varsAndConsInOne :: Qual Var -> DeadM DeadSet
71 varsAndConsInOne vr = do
73 return $ maybe emptySet
74 (noNames emptySet unionThree (mkQ emptySet usedNamesAll)) def
76 varsAndConsInOne' :: Qual Tcon -> DeadM DeadSet
77 varsAndConsInOne' tc = do
79 return $ maybe emptySet
80 (noNames emptySet unionThree
81 (mkQ emptySet usedStuffTys)) ty
84 emptySet = (S.empty, S.empty, S.empty)
85 mkStartSet :: AnMname -> [Vdefg] -> DeadSet
86 -- Initially, we assume the definitions of any exported functions are not
87 -- dead, and work backwards from there.
89 (S.fromList (filter ((== Just mn) . getModule) (exportedNames vds)),
92 exportedNames :: [Vdefg] -> [Qual Var]
93 exportedNames vdefgs =
94 let vds = flattenBinds vdefgs in
95 filter isQual (vdefNames vds)
96 where isQual = isJust . fst
97 vdefNames = map (\ (Vdef (n,_,_)) -> n)
100 type DeadSet = (S.Set (Qual Var), S.Set (Qual Dcon), S.Set (Qual Tcon))
101 type DeadM = Reader (M.Map (Qual Var) Exp, M.Map (Qual Tcon) [Ty])
103 findDefn :: Qual Var -> DeadM (Maybe Exp)
104 findDefn vr = asks ((M.lookup vr) . fst)
105 findRepTy :: Qual Tcon -> DeadM (Maybe [Ty])
106 findRepTy tc = asks ((M.lookup tc) . snd)
108 unionThree :: DeadSet -> DeadSet -> DeadSet
109 unionThree (a,b,c) (d,e,f) = (a `S.union` d, b `S.union` e, c `S.union` f)
111 usedNamesAll :: Exp -> DeadSet
112 usedNamesAll = (noNames emptySet unionThree
113 ((mkQ emptySet usedStuff) `extQ` usedStuffTys `extQ` usedStuffAlts))
115 usedStuff :: Exp -> DeadSet
116 usedStuff (Var qv) = (S.singleton qv, S.empty, S.empty)
117 usedStuff (Dcon dc) = (S.empty, S.singleton dc, S.empty)
118 usedStuff _ = emptySet
120 usedStuffAlts :: Alt -> DeadSet
121 usedStuffAlts (Acon qdc _ _ _) = (S.empty, S.singleton qdc, S.empty)
122 usedStuffAlts _ = emptySet
124 usedStuffTys :: Ty -> DeadSet
125 usedStuffTys (Tcon qtc) = (S.empty, S.empty, S.singleton qtc)
126 usedStuffTys _ = emptySet