# SCM Repository

# View of /sml/trunk/src/cm/depend/reachable.sml

Parent Directory | Revision Log

Revision

File size: 5737 byte(s)

**737**- (**download**) (**annotate**)*Fri Nov 24 08:43:56 2000 UTC*(19 years, 10 months ago) by*blume*File size: 5737 byte(s)

further improvements to link traversals and (as a result) autoloading; See HISTORY for how to bootstrap!

(* * Get the set of reachable SNODEs in a given dependency graph. * * (C) 1999 Lucent Technologies, Bell Laboratories * * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp) *) signature REACHABLE = sig (* These two functions simply give you the set of (non-stable) * modules reachable from some root and the fringe of stable * modules that surrounds the non-stable portion. *) val reachable' : DependencyGraph.sbnode list -> SmlInfoSet.set * StableSet.set val reachable : GroupGraph.group -> SmlInfoSet.set * StableSet.set (* "snodeMap" gives us handles at arbitrary points within the (non-stable) * portion of a dependency graph. * This is used by "slave" mode compiler. *) val snodeMap : GroupGraph.group -> DependencyGraph.snode SrcPathMap.map (* Given a library (or group) g, "groupsOf g" gets the set of * subgroups (but not sub-libraries) of that group. The result * will include the argument itself. *) val groupsOf : GroupGraph.group -> SrcPathSet.set (* Given an arbitrary group graph rooted at group g, "stableLibsOf g" * gets the set of stable libraries reachable from g. *) val stableLibsOf : GroupGraph.group -> GroupGraph.group SrcPathMap.map (* Given a "closed" subset of (non-stable) nodes in a dependency graph, * "frontier" gives you the set of frontier nodes of that set. The * closed set is given by its indicator function (first argument). * ("closed" means that if a node's ancestors are all in * the set, then so is the node itself. A frontier node is a node that * is in the set but either not all of its ancestors are or the node * is an export node.) *) val frontier : (BinInfo.info -> bool) -> GroupGraph.group -> StableSet.set end structure Reachable :> REACHABLE = struct structure DG = DependencyGraph structure GG = GroupGraph local fun reach ops (export_nodes: DG.sbnode list) = let val { add, member, empty } = ops fun snode (x as DG.SNODE n, (known, stabfringe)) = let val { smlinfo = i, localimports = l, globalimports = g } = n in if member (known, i) then (known, stabfringe) else foldl farsbnode (foldl snode (add (known, i, x), stabfringe) l) g end and farsbnode ((_, n), ksf) = sbnode (n, ksf) and sbnode (DG.SB_BNODE (DG.BNODE n, _, _), (known, stabfringe)) = (known, StableSet.add (stabfringe, #bininfo n)) | sbnode (DG.SB_SNODE n, ksf) = snode (n, ksf) in foldl sbnode (empty, StableSet.empty) export_nodes end fun force f = f () fun snodeMap' (exports: DG.impexp SymbolMap.map, acc) = let fun add (m, i, x) = SrcPathMap.insert (m, SmlInfo.sourcepath i, x) fun member (m, i) = SrcPathMap.inDomain (m, SmlInfo.sourcepath i) in #1 (reach { add = add, member = member, empty = acc } (map (#2 o force o #1) (SymbolMap.listItems exports))) end in val reachable' = reach { add = fn (s, i, _) => SmlInfoSet.add (s, i), member = SmlInfoSet.member, empty = SmlInfoSet.empty } fun reachable (GG.GROUP { exports, ... }) = reachable' (map (#2 o force o #1) (SymbolMap.listItems exports)) | reachable GG.ERRORGROUP = (SmlInfoSet.empty, StableSet.empty) fun snodeMap g = let fun snm (GG.ERRORGROUP, x) = x | snm (g as GG.GROUP grec, (a, seen)) = let val { exports, sublibs, grouppath, ... } = grec in if SrcPathSet.member (seen, grouppath) then (a, seen) else foldl (fn ((_, g, _), x) => snm (g (), x)) (snodeMap' (exports, a), SrcPathSet.add (seen, grouppath)) sublibs end in #1 (snm (g, (SrcPathMap.empty, SrcPathSet.empty))) end fun groupsOf g = let fun subgroups (GG.GROUP { kind = GG.NOLIB x, ... }) = #subgroups x | subgroups (GG.GROUP { kind = GG.LIB { kind = GG.DEVELOPED x, ... }, ... }) = #subgroups x | subgroups _ = [] fun go (GG.ERRORGROUP, a) = a | go (g as GG.GROUP { grouppath, ... }, a) = let val sgl = subgroups g fun sl ((p, gth, _), a) = case gth () of g as GG.GROUP { kind = GG.NOLIB _, ... } => if SrcPathSet.member (a, p) then a else go (g, a) | _ => a in SrcPathSet.add (foldl sl a sgl, grouppath) end in go (g, SrcPathSet.empty) end fun stableLibsOf GG.ERRORGROUP = SrcPathMap.empty | stableLibsOf (g as GG.GROUP { grouppath, ... }) = let fun slo' ((_, GG.ERRORGROUP), x) = x | slo' ((p, g as GG.GROUP grec), (seen, res)) = let val { kind, sublibs, ... } = grec in if SrcPathSet.member (seen, p) then (seen, res) else let val (seen, res) = foldl slo (seen, res) sublibs val seen = SrcPathSet.add (seen, p) in case kind of GG.LIB { kind = GG.STABLE _, ... } => (seen, SrcPathMap.insert (res, p, g)) | _ => (seen, res) end end and slo ((p, gth, _), x) = slo' ((p, gth ()), x) in #2 (slo' ((grouppath, g), (SrcPathSet.empty, SrcPathMap.empty))) end fun frontier _ GG.ERRORGROUP = StableSet.empty | frontier inSet (GG.GROUP { exports, ... }) = let fun bnode (DG.BNODE n, (seen, f)) = let val i = #bininfo n val li = #localimports n in if StableSet.member (seen, i) then (seen, f) else let val seen = StableSet.add (seen, i) in if inSet i then (seen, StableSet.add (f, i)) else foldl bnode (seen, f) li end end fun get_bn ((nth, _, _), bnl) = case nth () of (_, DG.SB_BNODE (n, _, _)) => n :: bnl | _ => bnl val bnl = SymbolMap.foldl get_bn [] exports in #2 (foldl bnode (StableSet.empty, StableSet.empty) bnl) end end end

root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |

Powered by ViewVC 1.0.0 |