Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/depend/to-portable.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/depend/to-portable.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 977 - (view) (download)

1 : blume 975 (* to-portable.sml
2 :     *
3 :     * (C) 2001 Lucent Technologies, Bell Labs
4 :     *
5 :     * Generate list-of-edges dependency graph representation from
6 :     * internal CM data structures.
7 :     *
8 :     * author: Matthias Blume (blume@research.bell-labs.com)
9 :     *)
10 :     structure ToPortable : sig
11 :     val export : GroupGraph.group * GeneralParams.info ->
12 :     PortableGraph.graph * SrcPath.file list
13 :     end = struct
14 :    
15 : blume 977 structure SS = SymbolSet
16 : blume 975 structure GG = GroupGraph
17 :     structure DG = DependencyGraph
18 :     structure P = PortableGraph
19 :    
20 :     structure SLM = RedBlackMapFn
21 :     (type ord_key = string list
22 :     fun compare ([], []) = EQUAL
23 :     | compare ([], _) = LESS
24 :     | compare (_, []) = GREATER
25 :     | compare (h :: t, h' :: t') =
26 :     (case String.compare (h, h') of
27 :     EQUAL => compare (t, t')
28 :     | unequal => unequal))
29 :    
30 :     structure FM = RedBlackMapFn
31 :     (type ord_key = string * string
32 :     fun compare ((v, f), (v', f')) =
33 :     case String.compare (v, v') of
34 :     EQUAL => String.compare (f, f')
35 :     | unequal => unequal)
36 :    
37 :     structure SSM = RedBlackMapFn
38 : blume 977 (type ord_key = SS.set
39 :     val compare = SS.compare)
40 : blume 975
41 :     structure IM = RedBlackMapFn
42 :     (type ord_key = SrcPath.file * string
43 :     fun compare ((p, s), (p', s')) =
44 :     case SrcPath.compare (p, p') of
45 :     EQUAL => String.compare (s, s')
46 :     | unequal => unequal)
47 :    
48 : blume 977 val ignoredSyms = SS.addList (SS.empty,
49 :     [PervAccess.pervStrSym, CoreSym.coreSym])
50 : blume 975
51 :     fun export (GG.ERRORGROUP, _) = raise Fail "ToPortable.export ERRORGROUP"
52 :     | export (GG.GROUP { exports, sublibs, grouppath, ... }, gp) = let
53 :    
54 :     val cwd = OS.FileSys.getDir ()
55 :    
56 :     fun toAbsolute p =
57 :     if OS.Path.isAbsolute p then p
58 :     else OS.Path.mkAbsolute { path = p, relativeTo = cwd }
59 :    
60 :     val groupdir =
61 :     OS.Path.dir (toAbsolute (SrcPath.osstring grouppath))
62 :    
63 :     local
64 :     fun mkInvMap [] = (SmlInfoMap.empty, StableMap.empty)
65 :     | mkInvMap ((p, gth, _) :: ls) = let
66 :     val (sm, bm) = mkInvMap ls
67 :     fun update (find, insert) (m, i, (p, ex)) =
68 :     case find (m, i) of
69 :     NONE => insert (m, i, (p, ex))
70 :     | SOME (p', ex') =>
71 : blume 977 insert (m, i, (p', SS.union (ex, ex')))
72 : blume 975 val su = update (SmlInfoMap.find, SmlInfoMap.insert)
73 :     val bu = update (StableMap.find, StableMap.insert)
74 :     fun oneE (sy, (th, _, ex), (sm, bm)) =
75 :     case th () of
76 :     (_, DG.SB_BNODE (DG.BNODE n, _, _)) =>
77 :     (sm, bu (bm, #bininfo n, (p, ex)))
78 :     | (_, DG.SB_SNODE (DG.SNODE n)) =>
79 :     (su (sm, #smlinfo n, (p, ex)), bm)
80 :     in
81 :     case gth () of
82 :     GG.GROUP { exports, ... } =>
83 :     SymbolMap.foldli oneE (sm, bm) exports
84 :     | _ => (sm, bm)
85 :     end
86 :     val (sm, bm) = mkInvMap sublibs
87 : blume 977 fun trim (p, ex) = (p, SS.difference (ex, ignoredSyms))
88 : blume 975 val sm = SmlInfoMap.map trim sm
89 :     val bm = StableMap.map trim bm
90 :     in
91 :     fun lookupBin i =
92 :     case StableMap.find (bm, i) of
93 :     SOME pex => pex
94 :     | NONE => raise Fail "lookupBin"
95 :    
96 :     fun lookupSml i = SmlInfoMap.find (sm, i)
97 :     end
98 :    
99 :     local
100 :     val bindings = ref []
101 :     in
102 :     fun genBind (lhs, rhs) =
103 :     bindings := P.DEF { lhs = lhs, rhs = rhs } :: !bindings
104 :     fun allBindings () = rev (!bindings)
105 :     end
106 :    
107 :     fun relname i = let
108 :     val p = toAbsolute (SrcPath.osstring (SmlInfo.sourcepath i))
109 : blume 977 val s = OS.Path.mkRelative { path = p, relativeTo = groupdir }
110 :     val { arcs, isAbs, vol } = OS.Path.fromString s
111 :     fun badarc a =
112 :     a <> OS.Path.currentArc andalso
113 :     a <> OS.Path.parentArc andalso
114 :     (a = "." orelse a = ".." orelse Char.contains a #"/")
115 :     fun toUnix [] = "."
116 :     | toUnix (h :: t) = let
117 :     fun trans a =
118 :     if a = OS.Path.currentArc then "."
119 :     else if a = OS.Path.parentArc then ".."
120 :     else a
121 :     in
122 :     concat (rev (foldl (fn (a, l) =>
123 :     trans a :: "/" :: l)
124 :     [trans h] t))
125 :     end
126 : blume 975 in
127 : blume 977 if isAbs orelse vol <> "" orelse List.exists badarc arcs then
128 :     (s, true)
129 :     else
130 :     (toUnix arcs, false)
131 : blume 975 end
132 :    
133 :     val gensym = let val next = ref 0
134 :     in fn prefix =>
135 :     let val i = !next
136 :     in prefix ^ Int.toString i before next := i + 1
137 :     end
138 :     end
139 :    
140 :     val smlmap = ref SmlInfoMap.empty
141 :     val imports = ref SrcPathMap.empty
142 :    
143 :     fun genLIB p =
144 :     case SrcPathMap.find (!imports, p) of
145 :     SOME v => v
146 :     | NONE => let val v = gensym "l"
147 :     in
148 :     imports := SrcPathMap.insert (!imports, p, v);
149 :     v
150 :     end
151 :    
152 :     local
153 :     val symbols = ref SymbolMap.empty
154 :     in
155 :     fun genSYM s =
156 :     case SymbolMap.find (!symbols, s) of
157 :     SOME v => v
158 :     | NONE => let val (p, ns) =
159 :     case Symbol.nameSpace s of
160 :     Symbol.SIGspace => ("sig", "SIG")
161 :     | Symbol.STRspace => ("str", "STR")
162 :     | Symbol.FCTspace => ("fct", "FCT")
163 :     | Symbol.FSIGspace => ("fsg", "FSIG")
164 :     | _ => raise Fail "unexpected namespace"
165 :     val v = gensym p
166 :     in
167 :     genBind (v, P.SYM (ns, Symbol.name s));
168 :     symbols := SymbolMap.insert (!symbols, s, v);
169 :     v
170 :     end
171 :     end
172 :    
173 :     local
174 :     val sets = ref SSM.empty
175 :     in
176 :     fun genSYMS ss =
177 :     case SSM.find (!sets, ss) of
178 :     SOME v => v
179 :     | NONE => let val v = gensym "ss"
180 : blume 977 val sl = SS.listItems ss
181 : blume 975 in
182 :     genBind (v, P.SYMS (map genSYM sl));
183 :     sets := SSM.insert (!sets, ss, v);
184 :     v
185 :     end
186 :     end
187 :    
188 :     local
189 :     val filters = ref FM.empty
190 :     val imps = ref IM.empty
191 :     in
192 :     fun preventFilter (e, f) =
193 :     filters := FM.insert (!filters, (e, f), e)
194 :    
195 :     fun genFILTER (v, f) = let
196 :     val s = genSYMS f
197 :     in
198 :     case FM.find (!filters, (v, s)) of
199 :     SOME e => e
200 :     | NONE => let val e = gensym "e"
201 :     in
202 :     genBind (e, P.FILTER { env = v, syms = s });
203 :     filters := FM.insert (!filters, (v, s), e);
204 :     preventFilter (e, s);
205 :     e
206 :     end
207 :     end
208 :    
209 : blume 977 fun genFILTER' (vex as (v, ex), f) = let
210 :     val f' = SS.intersection (ex, f)
211 :     in
212 :     if SS.equal (ex, f') then vex
213 :     else (genFILTER (v, f'), f')
214 :     end
215 :    
216 : blume 975 fun unlayer l = let
217 :     fun loop ([], _, a) = rev a
218 :     | loop ((h, hss) :: t, ss, a) = let
219 : blume 977 val i = SS.intersection (ss, hss)
220 :     val u = SS.union (ss, hss)
221 :     val f = SS.difference (hss, ss)
222 : blume 975 in
223 : blume 977 if SS.isEmpty f then loop (t, u, a)
224 :     else if SS.isEmpty i then loop (t, u, h :: a)
225 : blume 975 else loop (t, u, genFILTER (h, f) :: a)
226 :     end
227 :     in
228 : blume 977 loop (l, SS.empty, [])
229 : blume 975 end
230 :    
231 :     local
232 :     val merges = ref SLM.empty
233 :     in
234 :     fun genMERGE [e] = e
235 :     | genMERGE l =
236 :     (case SLM.find (!merges, l) of
237 :     SOME e => e
238 :     | NONE => let val e = gensym "e"
239 :     in
240 :     genBind (e, P.MERGE l);
241 :     merges := SLM.insert (!merges, l, e);
242 :     e
243 :     end)
244 :     end
245 :    
246 :     fun genCOMPILE (v, s, e, ex) = let
247 :     val ss = genSYMS ex
248 :     in
249 :     preventFilter (v, ss);
250 : blume 977 genBind (v, P.COMPILE { src = s, env = e, syms = ss })
251 : blume 975 end
252 :    
253 :     fun genIMPORT (lib, ex) =
254 : blume 977 if SS.isEmpty ex then ("dummy", ex)
255 : blume 975 else
256 :     let val s = genSYMS ex
257 :     in case IM.find (!imps, (lib, s)) of
258 :     SOME v => (v, ex)
259 :     | NONE =>
260 :     let val v = gensym "e"
261 :     val l = genLIB lib
262 :     in
263 :     imps := IM.insert (!imps, (lib, s), v);
264 :     genBind (v, P.IMPORT { lib = l, syms = s });
265 :     preventFilter (v, s);
266 :     (v, ex)
267 :     end
268 :     end
269 :     end
270 :    
271 :     fun smlImport i =
272 :     case lookupSml i of
273 :     NONE => NONE
274 :     | SOME lex => SOME (genIMPORT lex)
275 :    
276 :     fun binImport i = genIMPORT (lookupBin i)
277 :    
278 :     fun sn (DG.SNODE { smlinfo, localimports, globalimports }) =
279 :     case SmlInfoMap.find (!smlmap, smlinfo) of
280 :     SOME vex => vex
281 :     | NONE => let
282 :     val v = gensym "e"
283 :     val ex = case SmlInfo.exports gp smlinfo of
284 :     SOME ex => ex
285 :     | NONE => raise Fail "cannot parse SML file"
286 :     val vex = (v, ex)
287 :     val _ =
288 :     smlmap := SmlInfoMap.insert (!smlmap, smlinfo, vex)
289 :     val gi = map fsbn globalimports
290 :     val li = map sn localimports
291 :     val e = genMERGE (unlayer (li @ gi))
292 :     in
293 :     genCOMPILE (v, relname smlinfo, e, ex);
294 :     vex
295 :     end
296 :    
297 :     and fsbn (NONE, n) = sbn n
298 : blume 977 | fsbn (SOME f, n) = genFILTER' (sbn n, f)
299 : blume 975
300 :     and sbn (DG.SB_SNODE (n as DG.SNODE { smlinfo, ... })) =
301 :     (case smlImport smlinfo of
302 :     NONE => sn n
303 :     | SOME vex => vex)
304 :     | sbn (DG.SB_BNODE (DG.BNODE { bininfo, ... }, _, _)) =
305 :     binImport bininfo
306 :    
307 : blume 977 fun impexp (th, _, ss) = #1 (genFILTER' (fsbn (th ()), ss))
308 : blume 975
309 :     val iel = SymbolMap.foldr (fn (ie, l) => impexp ie :: l) [] exports
310 :    
311 :     val export = genMERGE iel
312 :     in
313 :     (P.GRAPH { imports = SrcPathMap.listItems (!imports),
314 :     defs = allBindings (),
315 :     export = export },
316 :     SrcPathMap.listKeys (!imports))
317 :     end
318 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0