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 975 - (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 :     structure GG = GroupGraph
16 :     structure DG = DependencyGraph
17 :     structure P = PortableGraph
18 :    
19 :     structure SLM = RedBlackMapFn
20 :     (type ord_key = string list
21 :     fun compare ([], []) = EQUAL
22 :     | compare ([], _) = LESS
23 :     | compare (_, []) = GREATER
24 :     | compare (h :: t, h' :: t') =
25 :     (case String.compare (h, h') of
26 :     EQUAL => compare (t, t')
27 :     | unequal => unequal))
28 :    
29 :     structure FM = RedBlackMapFn
30 :     (type ord_key = string * string
31 :     fun compare ((v, f), (v', f')) =
32 :     case String.compare (v, v') of
33 :     EQUAL => String.compare (f, f')
34 :     | unequal => unequal)
35 :    
36 :     structure SSM = RedBlackMapFn
37 :     (type ord_key = SymbolSet.set
38 :     val compare = SymbolSet.compare)
39 :    
40 :     structure IM = RedBlackMapFn
41 :     (type ord_key = SrcPath.file * string
42 :     fun compare ((p, s), (p', s')) =
43 :     case SrcPath.compare (p, p') of
44 :     EQUAL => String.compare (s, s')
45 :     | unequal => unequal)
46 :    
47 :     val ignoredSyms = SymbolSet.addList
48 :     (SymbolSet.empty,
49 :     [PervAccess.pervStrSym, CoreSym.coreSym])
50 :    
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 :     insert (m, i, (p', SymbolSet.union (ex, ex')))
72 :     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 :     fun trim (p, ex) = (p, SymbolSet.difference (ex, ignoredSyms))
88 :     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 :     in
110 :     OS.Path.mkRelative { path = p, relativeTo = groupdir }
111 :     end
112 :    
113 :     val gensym = let val next = ref 0
114 :     in fn prefix =>
115 :     let val i = !next
116 :     in prefix ^ Int.toString i before next := i + 1
117 :     end
118 :     end
119 :    
120 :     val smlmap = ref SmlInfoMap.empty
121 :     val imports = ref SrcPathMap.empty
122 :    
123 :     fun genLIB p =
124 :     case SrcPathMap.find (!imports, p) of
125 :     SOME v => v
126 :     | NONE => let val v = gensym "l"
127 :     in
128 :     imports := SrcPathMap.insert (!imports, p, v);
129 :     v
130 :     end
131 :    
132 :     local
133 :     val symbols = ref SymbolMap.empty
134 :     in
135 :     fun genSYM s =
136 :     case SymbolMap.find (!symbols, s) of
137 :     SOME v => v
138 :     | NONE => let val (p, ns) =
139 :     case Symbol.nameSpace s of
140 :     Symbol.SIGspace => ("sig", "SIG")
141 :     | Symbol.STRspace => ("str", "STR")
142 :     | Symbol.FCTspace => ("fct", "FCT")
143 :     | Symbol.FSIGspace => ("fsg", "FSIG")
144 :     | _ => raise Fail "unexpected namespace"
145 :     val v = gensym p
146 :     in
147 :     genBind (v, P.SYM (ns, Symbol.name s));
148 :     symbols := SymbolMap.insert (!symbols, s, v);
149 :     v
150 :     end
151 :     end
152 :    
153 :     local
154 :     val sets = ref SSM.empty
155 :     in
156 :     fun genSYMS ss =
157 :     case SSM.find (!sets, ss) of
158 :     SOME v => v
159 :     | NONE => let val v = gensym "ss"
160 :     val sl = SymbolSet.listItems ss
161 :     in
162 :     genBind (v, P.SYMS (map genSYM sl));
163 :     sets := SSM.insert (!sets, ss, v);
164 :     v
165 :     end
166 :     end
167 :    
168 :     local
169 :     val filters = ref FM.empty
170 :     val imps = ref IM.empty
171 :     in
172 :     fun preventFilter (e, f) =
173 :     filters := FM.insert (!filters, (e, f), e)
174 :    
175 :     fun genFILTER (v, f) = let
176 :     val s = genSYMS f
177 :     in
178 :     case FM.find (!filters, (v, s)) of
179 :     SOME e => e
180 :     | NONE => let val e = gensym "e"
181 :     in
182 :     genBind (e, P.FILTER { env = v, syms = s });
183 :     filters := FM.insert (!filters, (v, s), e);
184 :     preventFilter (e, s);
185 :     e
186 :     end
187 :     end
188 :    
189 :     fun unlayer l = let
190 :     fun loop ([], _, a) = rev a
191 :     | loop ((h, hss) :: t, ss, a) = let
192 :     val i = SymbolSet.intersection (ss, hss)
193 :     val u = SymbolSet.union (ss, hss)
194 :     val f = SymbolSet.difference (hss, ss)
195 :     in
196 :     if SymbolSet.isEmpty f then loop (t, u, a)
197 :     else if SymbolSet.isEmpty i then loop (t, u, h :: a)
198 :     else loop (t, u, genFILTER (h, f) :: a)
199 :     end
200 :     in
201 :     loop (l, SymbolSet.empty, [])
202 :     end
203 :    
204 :     local
205 :     val merges = ref SLM.empty
206 :     in
207 :     fun genMERGE [e] = e
208 :     | genMERGE l =
209 :     (case SLM.find (!merges, l) of
210 :     SOME e => e
211 :     | NONE => let val e = gensym "e"
212 :     in
213 :     genBind (e, P.MERGE l);
214 :     merges := SLM.insert (!merges, l, e);
215 :     e
216 :     end)
217 :     end
218 :    
219 :     fun genCOMPILE (v, s, e, ex) = let
220 :     val ss = genSYMS ex
221 :     in
222 :     preventFilter (v, ss);
223 :     genBind (v, P.COMPILE { src = s, env = e, syms = ss,
224 :     native = true })(* for now! FIXME *)
225 :     end
226 :    
227 :     fun genIMPORT (lib, ex) =
228 :     if SymbolSet.isEmpty ex then ("dummy", ex)
229 :     else
230 :     let val s = genSYMS ex
231 :     in case IM.find (!imps, (lib, s)) of
232 :     SOME v => (v, ex)
233 :     | NONE =>
234 :     let val v = gensym "e"
235 :     val l = genLIB lib
236 :     in
237 :     imps := IM.insert (!imps, (lib, s), v);
238 :     genBind (v, P.IMPORT { lib = l, syms = s });
239 :     preventFilter (v, s);
240 :     (v, ex)
241 :     end
242 :     end
243 :     end
244 :    
245 :     fun smlImport i =
246 :     case lookupSml i of
247 :     NONE => NONE
248 :     | SOME lex => SOME (genIMPORT lex)
249 :    
250 :     fun binImport i = genIMPORT (lookupBin i)
251 :    
252 :     fun sn (DG.SNODE { smlinfo, localimports, globalimports }) =
253 :     case SmlInfoMap.find (!smlmap, smlinfo) of
254 :     SOME vex => vex
255 :     | NONE => let
256 :     val v = gensym "e"
257 :     val ex = case SmlInfo.exports gp smlinfo of
258 :     SOME ex => ex
259 :     | NONE => raise Fail "cannot parse SML file"
260 :     val vex = (v, ex)
261 :     val _ =
262 :     smlmap := SmlInfoMap.insert (!smlmap, smlinfo, vex)
263 :     val gi = map fsbn globalimports
264 :     val li = map sn localimports
265 :     val e = genMERGE (unlayer (li @ gi))
266 :     in
267 :     genCOMPILE (v, relname smlinfo, e, ex);
268 :     vex
269 :     end
270 :    
271 :     and fsbn (NONE, n) = sbn n
272 :     | fsbn (SOME f, n) = let
273 :     val vex as (v, ex) = sbn n
274 :     in
275 :     if SymbolSet.isSubset (ex, f) then vex
276 :     else let val f' = SymbolSet.intersection (f, ex)
277 :     val v' = genFILTER (v, f')
278 :     in
279 :     (v', f')
280 :     end
281 :     end
282 :    
283 :     and sbn (DG.SB_SNODE (n as DG.SNODE { smlinfo, ... })) =
284 :     (case smlImport smlinfo of
285 :     NONE => sn n
286 :     | SOME vex => vex)
287 :     | sbn (DG.SB_BNODE (DG.BNODE { bininfo, ... }, _, _)) =
288 :     binImport bininfo
289 :    
290 :     fun impexp (th, _, ss) =
291 :     genFILTER (#1 (fsbn (th ())), ss)
292 :    
293 :     val iel = SymbolMap.foldr (fn (ie, l) => impexp ie :: l) [] exports
294 :    
295 :     val export = genMERGE iel
296 :     in
297 :     (P.GRAPH { imports = SrcPathMap.listItems (!imports),
298 :     defs = allBindings (),
299 :     export = export },
300 :     SrcPathMap.listKeys (!imports))
301 :     end
302 :     end

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