utils/ext-core/Language/Core/ElimDeadCode.hs

   1 {-
   2    This module eliminates unused top-level bindings, under the
   3    assumption that all top-level bindings with qualified names
   4    should be retained.
   5 -}
   6 module Language.Core.ElimDeadCode(elimDeadCode) where
   7
   8 import Language.Core.Core
   9 import Language.Core.Printer()
  10 import Language.Core.Utils
  11
  12 import Control.Monad.Reader
  13 import Data.Generics
  14 import Data.List
  15 import Data.Maybe
  16 import qualified Data.Map as M
  17 import qualified Data.Set as S
  18
  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)
  27
  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
  33
  34 mkVarEnv :: [Vdefg] -> M.Map (Qual Var) Exp
  35 mkVarEnv vgs =
  36   let vdefs = flattenBinds vgs in
  37     M.fromList [(v, e) | (Vdef (v, _, e)) <- vdefs]
  38
  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]
  43 mkTyEnv tdefs =
  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)]
  49                                    _ -> []) tdefs)
  50
  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)
  58       then return nextOld
  59       else findUsed nextOld nextStuff
  60
  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')
  69
  70 varsAndConsInOne :: Qual Var -> DeadM DeadSet
  71 varsAndConsInOne vr = do
  72   def <- findDefn vr
  73   return $ maybe emptySet
  74     (noNames emptySet unionThree (mkQ emptySet usedNamesAll)) def
  75
  76 varsAndConsInOne' :: Qual Tcon -> DeadM DeadSet
  77 varsAndConsInOne' tc = do
  78   ty <- findRepTy tc
  79   return $ maybe emptySet
  80     (noNames emptySet unionThree
  81               (mkQ emptySet usedStuffTys)) ty
  82
  83 emptySet :: DeadSet
  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.
  88 mkStartSet mn vds =
  89   (S.fromList (filter ((== Just mn) . getModule) (exportedNames vds)),
  90    S.empty, S.empty)
  91
  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)
  98
  99
 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])
 102
 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)
 107
 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)
 110
 111 usedNamesAll :: Exp -> DeadSet
 112 usedNamesAll = (noNames emptySet unionThree
 113   ((mkQ emptySet usedStuff) `extQ` usedStuffTys `extQ` usedStuffAlts))
 114
 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
 119
 120 usedStuffAlts :: Alt -> DeadSet
 121 usedStuffAlts (Acon qdc _ _ _) = (S.empty, S.singleton qdc, S.empty)
 122 usedStuffAlts _ = emptySet
 123
 124 usedStuffTys :: Ty -> DeadSet
 125 usedStuffTys (Tcon qtc) = (S.empty, S.empty, S.singleton qtc)
 126 usedStuffTys _          = emptySet