Slave dispatching working
[hcoop/domtool2.git] / src / order.sml
CommitLineData
095de39e
AC
1(* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
17 *)
18
19(* Topological sorting of source files to take dependencies into account *)
20
21structure Order :> ORDER = struct
22
23open Ast
24
25structure SS = StringSet
26structure SM = StringMap
27
28fun predNeeded G (p, _) =
29 case p of
30 CRoot => SS.empty
31 | CConst s =>
32 if Env.lookupContext G s then
33 SS.empty
34 else
35 SS.singleton s
36 | CPrefix p => predNeeded G p
37 | CNot p => predNeeded G p
38 | CAnd (p1, p2) => SS.union (predNeeded G p1, predNeeded G p2)
39
40fun unionCT ((c1, t1), (c2, t2)) = (SS.union (c1, c2), SS.union (t1, t2))
41
42fun typNeeded G (t, _) =
43 case t of
44 TBase s =>
45 if Env.lookupType G s then
46 (SS.empty, SS.empty)
47 else
48 (SS.empty, SS.singleton s)
49 | TList t => typNeeded G t
50 | TArrow (t1, t2) => unionCT (typNeeded G t1, typNeeded G t2)
51 | TAction (p, d, r) =>
52 let
53 val recordNeeded = SM.foldl
54 (fn (t, ss) => unionCT (ss, typNeeded G t))
55 in
56 recordNeeded (recordNeeded (predNeeded G p, SS.empty) d) r
57 end
58 | TNested (p, t) => unionCT ((predNeeded G p, SS.empty),
59 typNeeded G t)
60
61 | TError => raise Fail "TError during dependency analysis"
62 | TUnif _ => raise Fail "TUnif during dependency analysis"
63
64val empty = ((SS.empty, SS.empty), SS.empty)
65
66fun unionCTE (((c1, t1), v1), ((c2, t2), v2)) =
67 ((SS.union (c1, c2),
68 SS.union (t1, t2)),
69 SS.union (v1, v2))
70
71val dt = (TError, ErrorMsg.dummyLoc)
72
73fun expNeeded G (e, _) =
74 case e of
75 EInt _ => ((SS.empty,
76 if Env.lookupType G "int" then
77 SS.empty
78 else
79 SS.singleton "int"),
80 SS.empty)
81 | EString _ => ((SS.empty,
82 if Env.lookupType G "string" then
83 SS.empty
84 else
85 SS.singleton "string"),
86 SS.empty)
87 | EList es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
88 empty es
89
90 | ELam (x, to, e) =>
91 let
92 val G' = Env.bindVal G (x, dt, NONE)
93 in
94 case to of
95 NONE => expNeeded G' e
96 | SOME t => unionCTE ((typNeeded G t, SS.empty),
97 expNeeded G' e)
98 end
99 | EVar x =>
100 (case Env.lookupVal G x of
101 NONE => ((SS.empty, SS.empty), SS.singleton x)
102 | _ => empty)
103 | EApp (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
104
105 | ESkip => empty
106 | ESet (_, e) => expNeeded G e
107 | EGet (x, _, e) => expNeeded (Env.bindVal G (x, dt, NONE)) e
108 | ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
109 empty es
110 | ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
111 | EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
112
113fun declNeeded G (d, _, _) =
114 case d of
115 DExternType name => (Env.bindType G name, empty)
116 | DExternVal (name, t) => (Env.bindVal G (name, dt, NONE),
117 (typNeeded G t, SS.empty))
118 | DVal (name, to, e) => (Env.bindVal G (name, dt, NONE),
119 case to of
120 NONE => expNeeded G e
121 | SOME t => unionCTE ((typNeeded G t, SS.empty),
122 expNeeded G e))
123 | DContext name => (Env.bindContext G name, empty)
124
125fun fileSig (_, ds, eo) =
126 let
127 val (G', needed) = foldl
128 (fn (d, (G, needed)) =>
129 let
130 val (G', needed') = declNeeded G d
131 in
132 (G', unionCTE (needed, needed'))
133 end)
134 (Env.empty, empty) ds
135
136 val needed =
137 case eo of
138 NONE => needed
139 | SOME e => unionCTE (needed,
140 expNeeded G' e)
141 in
142 (((Env.contexts G', Env.types G'), Env.vals G'),
143 needed)
144 end
145
146fun printSig ((cs, ts), vs) =
147 (print "Contexts:";
148 SS.app (fn s => (print " "; print s; print ";")) cs;
149 print "\n Types:";
150 SS.app (fn s => (print " "; print s; print ";")) ts;
151 print "\n Values:";
152 SS.app (fn s => (print " "; print s; print ";")) vs;
153 print "\n")
154
155fun mergeProvide kind fname (m1, m2) =
156 SS.foldl (fn (name, provide) =>
157 (case SM.find (provide, name) of
158 NONE => ()
159 | SOME fname' => ErrorMsg.error NONE (String.concat ["Files ",
160 fname',
161 " and ",
162 fname,
163 " both provide ",
164 kind,
165 " ",
166 name]);
167 SM.insert (provide, name, fname)))
168 m1 m2
169
170fun order fnames =
171 let
172 fun doFile fname =
173 let
174 val file = Parse.parse fname
175 val (provide, require) = fileSig file
176 in
177 print "\nFile ";
178 print fname;
179 print "\nPROVIDE:\n";
180 printSig provide;
181 print "\nREQUIRE:\n";
182 printSig require
183 end
184
185 fun doFile (fname, (provideC, provideT, provideV, require)) =
186 let
187 val file = Parse.parse fname
188 val (((provideC', provideT'), provideV'),
189 require') = fileSig file
190 in
191 (mergeProvide "context" fname (provideC, provideC'),
192 mergeProvide "type" fname (provideT, provideT'),
193 mergeProvide "value" fname (provideV, provideV'),
194 SM.insert (require, fname, require'))
195 end
196
197 val (provideC, provideT, provideV, require) =
198 foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames
199
200 val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
201 let
202 fun consider (kind, provide) =
203 SS.foldl (fn (name, need) =>
204 case SM.find (provide, name) of
205 NONE => (ErrorMsg.error NONE
206 ("File "
207 ^ fname
208 ^ " uses undefined "
209 ^ kind
210 ^ " "
211 ^ name);
212 need)
213 | SOME fname' =>
214 SS.add (need, fname'))
215
216 val need = consider ("context", provideC)
217 SS.empty rc
218 val need = consider ("type", provideT)
219 need rt
220 val need = consider ("value", provideV)
221 need rv
222 in
223 need
224 end) require
225
226 fun loop (ready, waiting, order) =
227 case SS.find (fn _ => true) ready of
228 NONE =>
229 if SM.numItems waiting = 0 then
230 rev order
231 else
232 (ErrorMsg.error NONE "Cyclic dependency in source files";
233 order)
234 | SOME next =>
235 let
236 val (ready', waiting') =
237 SM.foldli (fn (fname, requires, (ready', waiting')) =>
238 let
239 val requires' = SS.delete (requires, next)
240 handle NotFound => requires
241 in
242 if SS.numItems requires' = 0 then
243 (SS.add (ready', fname),
244 waiting')
245 else
246 (ready',
247 SM.insert (waiting', fname, requires'))
248 end)
249 (SS.delete (ready, next), SM.empty) waiting
250 in
251 loop (ready', waiting', next :: order)
252 end
253
254 val (ready, waiting) =
255 SM.foldli (fn (fname, requires, (ready, waiting)) =>
256 if SS.numItems requires = 0 then
257 (SS.add (ready, fname),
258 waiting)
259 else
260 (ready,
261 SM.insert (waiting, fname, requires)))
262 (SS.empty, SM.empty) require
263 in
264 (*SM.appi (fn (name, fname) => print ("Context " ^ name ^ " in " ^ fname ^ "\n")) provideC;
265 SM.appi (fn (name, fname) => print ("Type " ^ name ^ " in " ^ fname ^ "\n")) provideT;
266 SM.appi (fn (name, fname) => print ("Value " ^ name ^ " in " ^ fname ^ "\n")) provideV;*)
267
268 (*SM.appi (fn (fname, requires) =>
269 (print fname;
270 print " requires:";
271 SS.app (fn fname' => (print " "; print fname')) requires;
272 print "\n")) require;*)
273
274 loop (ready, waiting, [])
275 end
276
277end