@@ -31,13 +31,13 @@ import Data.Text (pack)
3131-- UseMap maps names to the set of used (reachable) argument positions.
3232type UseMap = Map Name IntSet
3333
34−data Arg = Arg !Int | Result
34+data Arg = Arg !Int | Result deriving (Eq, Ord)
3535
3636instance Show Arg where
3737 show (Arg i) = show i
3838 show Result = "*"
3939
40−type Node = (Name, Int)
40+type Node = (Name, Arg)
4141type Deps = Map Cond (Set Node)
4242
4343-- "Condition" is the conjunction
@@ -53,11 +53,15 @@ type Vars = Map Name Var
5353minimalUsage :: Deps -> UseMap
5454minimalUsage = gather . forwardChain . triggerMain
5555 where
56− gather :: Ord a => Set (a, Int) -> Map a IntSet
57− gather = foldr (\(n,i) -> M.insertWith IS.union n (IS.singleton i)) M.empty . S.toList
56+ gather :: Set (Name, Arg) -> UseMap
57+ gather = foldr ins M.empty . S.toList
58+ where
59+ ins :: Node -> UseMap -> UseMap
60+ ins (n, Result) = id
61+ ins (n, Arg i ) = M.insertWith IS.union n (IS.singleton i)
5862
5963 triggerMain :: Deps -> Deps
60− triggerMain = M.insert S.empty $ S.singleton (main, -1)
64+ triggerMain = M.insertWith S.union S.empty $ S.singleton (main, Result)
6165 where
6266 main = NS (UN $ pack "main") [pack "Main"]
6367
@@ -110,14 +114,14 @@ buildDepMap ctx ns = dfs S.empty M.empty ns
110114 = getDepsSC fn varMap sc
111115 where
112116 -- the variables that arose as function arguments only depend on (n, i)
113− varMap = M.fromList [(v, S.singleton (fn,i)) | (v,i) <- zip vars [0..]]
117+ varMap = M.fromList [(v, S.singleton (fn, Arg i)) | (v,i) <- zip vars [0..]]
114118 (vars, sc) = cases_compiletime cdefs -- TODO: or cases_runtime?
115119
116120 getDepsSC :: Name -> Vars -> SC -> Deps
117121 getDepsSC fn vs ImpossibleCase = M.empty
118122 getDepsSC fn vs (UnmatchedCase msg) = M.empty
119123 getDepsSC fn vs (ProjCase t alt) = error "ProjCase not supported"
120− getDepsSC fn vs (STerm t) = getDepsTerm vs [] (S.singleton (fn, -1)) t
124+ getDepsSC fn vs (STerm t) = getDepsTerm vs [] (S.singleton (fn, Result)) t
121125 getDepsSC fn vs (Case n alts) = unionMap (getDepsAlt fn vs var) alts
122126 where
123127 var = fromMaybe (error $ "nonpatvar in case: " ++ show n) (M.lookup n vs)
@@ -132,7 +136,7 @@ buildDepMap ctx ns = dfs S.empty M.empty ns
132136 where
133137 -- Here we insert dependencies that arose from pattern matching on a constructor.
134138 -- n = ctor name, j = ctor arg#, i = fun arg# of the cased var, cs = ctors of the cased var
135− vs' = M.fromList [(v, S.insert (n,j) var) | (v,j) <- zip ns [0..]]
139+ vs' = M.fromList [(v, S.insert (n, Arg j) var) | (v,j) <- zip ns [0..]]
136140
137141 -- Named variables -> DeBruijn variables -> Conds/guards -> Term -> Deps
138142 getDepsTerm :: Vars -> [Cond -> Deps] -> Cond -> Term -> Deps
@@ -162,14 +166,16 @@ buildDepMap ctx ns = dfs S.empty M.empty ns
162166 getDepsTerm vs bs cd app@(App _ _)
163167 | (fun, args) <- unApply app = case fun of
164168 -- these depend on whether the referred thing uses the argument
165− P Ref n _ -> unionMap (getDepsArgs n) $ zip [0..] args
166− P (DCon _ _) n _ -> unionMap (getDepsArgs n) $ zip [0..] args
169+ P Ref n _ -> node n args
170+ P (DCon _ _) n _ -> node n args
167171
168172 -- these do not
169173 P (TCon _ _) n _ -> unionMap (getDepsTerm vs bs cd) args
170174 P Bound n _ -> unionMap (getDepsTerm vs bs cd) args
171175 where
172− getDepsArgs n (i, t) = getDepsTerm vs bs (S.insert (n,i) . S.insert (n,-1) $ cd) t
176+ node n = M.insertWith S.union cd (S.singleton (n, Result))
177+ . unionMap (getDepsArgs n) . zip [0..]
178+ getDepsArgs n (i, t) = getDepsTerm vs bs (S.insert (n, Arg i) cd) t
173179
174180 -- the easy cases
175181 getDepsTerm vs bs cd (Constant _) = M.empty