1 2 -- ==========================================================-- 3 -- === Dependancy analyser dependancy.m (1) ===-- 4 -- ==========================================================-- 5 6 module Dependancy where 7 import BaseDefs 8 import Utils 9 10 -- ==========================================================-- 11 -- 12 deBindersOf :: [(a,b)] -> [a] 13 14 deBindersOf defns = [name | (name, rhs) <- defns] 15 16 17 -- ==========================================================-- 18 -- 19 deValuesOf :: [(a,b)] -> [b] 20 21 deValuesOf defns = [rhs | (name, rhs) <- defns] 22 23 24 -- ==========================================================-- 25 -- 26 deFreeVars :: CExpr -> AnnExpr Naam (Set Naam) 27 28 deFreeVars (ENum k) = (utSetEmpty, ANum k) 29 deFreeVars (EVar v) = (utSetSingleton v, AVar v) 30 deFreeVars (EConstr n) = (utSetEmpty, AConstr n) 31 32 deFreeVars (EAp e1 e2) 33 = (utSetUnion (deFreeVarsOf e1') (deFreeVarsOf e2'), AAp e1' e2') 34 where e1' = deFreeVars e1 35 e2' = deFreeVars e2 36 37 deFreeVars (ECase e alts) 38 = (utSetUnion (deFreeVarsOf e') free, ACase e' alts') 39 where e' = deFreeVars e 40 alts' = [(t, (ns, deFreeVars e)) | (t, (ns, e)) <- alts] 41 free = utSetUnionList (map f alts') 42 f (t, (ns, e)) = utSetSubtraction (deFreeVarsOf e) (utSetFromList ns) 43 44 deFreeVars (ELam args body) 45 = (utSetSubtraction (deFreeVarsOf body') (utSetFromList args), ALam args body') 46 where body' = deFreeVars body 47 48 deFreeVars (ELet isRec defns body) 49 = (utSetUnion defnsFree bodyFree, ALet isRec defns' body') 50 where binders = deBindersOf defns 51 binderSet = utSetFromList binders 52 values' = map deFreeVars (deValuesOf defns) 53 defns' = zip binders values' 54 freeInValues = utSetUnionList (map deFreeVarsOf values') 55 defnsFree | isRec = utSetSubtraction freeInValues binderSet 56 | otherwise = freeInValues 57 body' = deFreeVars body 58 bodyFree = utSetSubtraction (deFreeVarsOf body') binderSet 59 60 61 -- ==========================================================-- 62 -- 63 deFreeVarsOf :: AnnExpr Naam (Set Naam) -> Set Naam 64 65 deFreeVarsOf (free_vars, expr) = free_vars 66 67 68 69 -- ==========================================================-- 70 -- 71 deDepthFirstSearch :: (Ord a) => 72 (a -> [a]) -> -- The map, 73 (Set a, [a]) -> -- state: visited set, 74 -- current sequence of vertices 75 [a] -> -- input vertices sequence 76 (Set a, [a]) -- final state 77 78 deDepthFirstSearch 79 = foldl . search 80 where 81 search relation (visited, sequence) vertex 82 | utSetElementOf vertex visited = (visited, sequence ) 83 | otherwise = (visited', vertex: sequence') 84 where 85 (visited', sequence') 86 = deDepthFirstSearch relation 87 (utSetUnion visited (utSetSingleton vertex), sequence) 88 (relation vertex) 89 90 91 92 -- ==========================================================-- 93 -- 94 deSpanningSearch :: (Ord a) => 95 (a -> [a]) -> -- The map 96 (Set a, [Set a]) -> -- Current state: visited set, 97 -- current sequence of vertice sets 98 [a] -> -- Input sequence of vertices 99 (Set a, [Set a]) -- Final state 100 101 deSpanningSearch 102 = foldl . search 103 where 104 search relation (visited, utSetSequence) vertex 105 | utSetElementOf vertex visited = (visited, utSetSequence ) 106 | otherwise = (visited', utSetFromList (vertex: sequence): utSetSequence) 107 where 108 (visited', sequence) 109 = deDepthFirstSearch relation 110 (utSetUnion visited (utSetSingleton vertex), []) 111 (relation vertex) 112 113 114 115 -- ==========================================================-- 116 -- 117 deScc :: (Ord a) => 118 (a -> [a]) -> -- The "ins" map 119 (a -> [a]) -> -- The "outs" map 120 [a] -> -- The root vertices 121 [Set a] -- The topologically sorted components 122 123 deScc ins outs 124 = spanning . depthFirst 125 where depthFirst = second . deDepthFirstSearch outs (utSetEmpty, []) 126 spanning = second . deSpanningSearch ins (utSetEmpty, []) 127 128 129 130 -- ==========================================================-- 131 -- 132 deDependancy :: CExprP Naam -> CExprP Naam 133 134 deDependancy = deDepends . deFreeVars 135 136 137 138 -- ==========================================================-- 139 -- 140 deDepends (free, ANum n) = ENum n 141 deDepends (free, AConstr n) = EConstr n 142 deDepends (free, AVar v) = EVar v 143 deDepends (free, AAp e1 e2) = EAp (deDepends e1) (deDepends e2) 144 145 deDepends (free, ACase body alts) = ECase (deDepends body) 146 [(t, (ns, deDepends e)) 147 | (t, (ns, e)) <- alts] 148 149 deDepends (free, ALam ns body) = ELam ns (deDepends body) 150 151 deDepends (free, ALet isRec defns body) 152 = foldr (deElet isRec) (deDepends body) defnGroups 153 where 154 binders = deBindersOf defns 155 binderSet | isRec = utSetFromList binders 156 | otherwise = utSetEmpty 157 edges = [(n, f) | (n, (free, e)) <- defns, 158 f <- utSetToList (utSetIntersection free binderSet)] 159 ins v = [u | (u,w) <- edges, v==w] 160 outs v = [w | (u,w) <- edges, v==u] 161 components = map utSetToList (deScc ins outs binders) 162 defnGroups = [[(n, utSureLookup defns "depends`defnGroups" n) 163 | n <- ns] | ns <- components] 164 165 166 167 -- ==========================================================-- 168 -- 169 deElet isRec dfs e 170 = if not isRec || nonRec dfs 171 then ELet False dfs' e 172 else ELet True dfs' e 173 where dfs' = [(n, deDepends e) | (n,e) <- dfs] 174 nonRec [(n, (free, e))] = not (utSetElementOf n free) 175 nonRec dfs = False 176 177 -- ==========================================================-- 178 -- === End dependancy.m (1) ===-- 179 -- ==========================================================--