git.iko.soy/rowtype-yoga/purescript-native
on f8da0b9 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/DeadCodeElimination.hs
98 lines 4.5 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript.DeadCodeElimination
4-- Copyright : (c) 2014 Phil Freeman
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15module Language.PureScript.DeadCodeElimination (
16 eliminateDeadCode
17) where
19import Data.Data
20import Data.List
21import Data.Graph
22import Data.Generics
23import Data.Maybe (mapMaybe)
25import Language.PureScript.Names
26import Language.PureScript.Values
27import Language.PureScript.Declarations
29-- |
30-- Eliminate all declarations which are not a transitive dependency of the entry point module
31--
32eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]
33eliminateDeadCode entryPoints ms = map go ms
34 where
35 go (Module moduleName ds (Just exps)) = Module moduleName ds' (Just exps')
36 where
37 ds' = filter (isUsed moduleName graph vertexFor entryPointVertices) ds
38 exps' = mapMaybe (filterExport ds') exps
39 go _ = error "Exports should have been elaborated in name desugaring"
40 declarations = concatMap declarationsByModule ms
41 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
42 entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
44 filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef
45 filterExport decls r@(TypeRef name _) | (any $ typeExists name) decls = Just r
46 filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r
47 filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r
48 filterExport _ _ = Nothing
50 valueExists :: Ident -> Declaration -> Bool
51 valueExists name (ValueDeclaration name' _ _ _ _) = name == name'
52 valueExists name (ExternDeclaration _ name' _ _) = name == name'
53 valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls
54 valueExists _ _ = False
56 typeExists :: ProperName -> Declaration -> Bool
57 typeExists name (DataDeclaration name' _ _) = name == name'
58 typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls
59 typeExists _ _ = False
61type Key = (ModuleName, Either Ident ProperName)
63declarationsByModule :: Module -> [(Key, [Key])]
64declarationsByModule (Module moduleName ds _) = concatMap go ds
65 where
66 go :: Declaration -> [(Key, [Key])]
67 go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)]
68 go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
69 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
70 go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
71 go (DataBindingGroupDeclaration ds') = concatMap go ds'
72 go _ = []
74dependencies :: (Data d) => ModuleName -> d -> [Key]
75dependencies moduleName = nub . everything (++) (mkQ [] values)
76 where
77 values :: Value -> [Key]
78 values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]
79 values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]
80 values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"
81 values _ = []
83isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool
84isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _ _) =
85 let Just v' = vertexFor (moduleName, Left name)
86 in any (\v -> path graph v v') entryPointVertices
87isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =
88 any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)
89 in any (\v -> path graph v v') entryPointVertices) dctors
90isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =
91 let Just v' = vertexFor (moduleName, Left name)
92 in any (\v -> path graph v v') entryPointVertices
93isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =
94 any (\(name, _, _) -> let Just v' = vertexFor (moduleName, Left name)
95 in any (\v -> path graph v v') entryPointVertices) ds
96isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =
97 any (isUsed moduleName graph vertexFor entryPointVertices) ds
98isUsed _ _ _ _ _ = True