adamc@20
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@20
|
2 * All rights reserved.
|
adamc@20
|
3 *
|
adamc@20
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@20
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@20
|
6 *
|
adamc@20
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@20
|
8 * this list of conditions and the following disclaimer.
|
adamc@20
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@20
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@20
|
11 * and/or other materials provided with the distribution.
|
adamc@20
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@20
|
13 * derived from this software without specific prior written permission.
|
adamc@20
|
14 *
|
adamc@20
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@20
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@20
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@20
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@20
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@20
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@20
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@20
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@20
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@20
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@20
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@20
|
26 *)
|
adamc@20
|
27
|
adamc@20
|
28 (* Simplify a Core program algebraically *)
|
adamc@20
|
29
|
adamc@20
|
30 structure Reduce :> REDUCE = struct
|
adamc@20
|
31
|
adamc@20
|
32 open Core
|
adamc@20
|
33
|
adamc@1016
|
34 structure IS = IntBinarySet
|
adamc@508
|
35 structure IM = IntBinaryMap
|
adamc@20
|
36
|
adamc@908
|
37 structure E = CoreEnv
|
adamc@908
|
38
|
adamc@908
|
39 fun multiLiftExpInExp n e =
|
adamc@908
|
40 if n = 0 then
|
adamc@908
|
41 e
|
adamc@908
|
42 else
|
adamc@908
|
43 multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
|
adamc@908
|
44
|
adamc@1179
|
45 val count = CoreUtil.Exp.foldB {kind = fn (_, _, c) => c,
|
adamc@1179
|
46 con = fn (_, _, c) => c,
|
adamc@1179
|
47 exp = fn (x, e, c) =>
|
adamc@1179
|
48 case e of
|
adamc@1179
|
49 ERel x' => if x = x' then c + 1 else c
|
adamc@1179
|
50 | _ => c,
|
adamc@1179
|
51 bind = fn (x, b) =>
|
adamc@1179
|
52 case b of
|
adamc@1179
|
53 CoreUtil.Exp.RelE _ => x+1
|
adamc@1179
|
54 | _ => x} 0 0
|
adamc@1179
|
55
|
adamc@909
|
56 val dangling =
|
adamc@909
|
57 CoreUtil.Exp.existsB {kind = fn _ => false,
|
adamc@909
|
58 con = fn _ => false,
|
adamc@909
|
59 exp = fn (n, e) =>
|
adamc@909
|
60 case e of
|
adamc@909
|
61 ERel n' => n' >= n
|
adamc@909
|
62 | _ => false,
|
adamc@909
|
63 bind = fn (n, b) =>
|
adamc@909
|
64 case b of
|
adamc@909
|
65 CoreUtil.Exp.RelE _ => n + 1
|
adamc@909
|
66 | _ => n}
|
adamc@909
|
67
|
adamc@1272
|
68 val cdangling =
|
adamc@1272
|
69 CoreUtil.Exp.existsB {kind = fn _ => false,
|
adamc@1272
|
70 con = fn (n, c) =>
|
adamc@1272
|
71 case c of
|
adamc@1272
|
72 CRel n' => n' >= n
|
adamc@1272
|
73 | _ => false,
|
adamc@1272
|
74 exp = fn _ => false,
|
adamc@1272
|
75 bind = fn (n, b) =>
|
adamc@1272
|
76 case b of
|
adamc@1272
|
77 CoreUtil.Exp.RelC _ => n + 1
|
adamc@1272
|
78 | _ => n}
|
adamc@1272
|
79
|
adamc@508
|
80 datatype env_item =
|
adamc@626
|
81 UnknownK
|
adamc@626
|
82 | KnownK of kind
|
adamc@626
|
83
|
adamc@626
|
84 | UnknownC
|
adamc@508
|
85 | KnownC of con
|
adamc@21
|
86
|
adamc@508
|
87 | UnknownE
|
adamc@508
|
88 | KnownE of exp
|
adamc@20
|
89
|
adamc@626
|
90 | Lift of int * int * int
|
adamc@20
|
91
|
adamc@909
|
92 val edepth = foldl (fn (UnknownE, n) => n + 1
|
adamc@909
|
93 | (KnownE _, n) => n + 1
|
adamc@909
|
94 | (_, n) => n) 0
|
adamc@909
|
95
|
adamc@909
|
96 val edepth' = foldl (fn (UnknownE, n) => n + 1
|
adamc@909
|
97 | (KnownE _, n) => n + 1
|
adamc@909
|
98 | (Lift (_, _, n'), n) => n + n'
|
adamc@909
|
99 | (_, n) => n) 0
|
adamc@909
|
100
|
adamc@1272
|
101 val cdepth = foldl (fn (UnknownC, n) => n + 1
|
adamc@1272
|
102 | (KnownC _, n) => n + 1
|
adamc@1272
|
103 | (_, n) => n) 0
|
adamc@1272
|
104
|
adamc@1272
|
105 val cdepth' = foldl (fn (UnknownC, n) => n + 1
|
adamc@1272
|
106 | (KnownC _, n) => n + 1
|
adamc@1272
|
107 | (Lift (_, n', _), n) => n + n'
|
adamc@1272
|
108 | (_, n) => n) 0
|
adamc@1272
|
109
|
adamc@508
|
110 type env = env_item list
|
adamc@20
|
111
|
adamc@510
|
112 fun ei2s ei =
|
adamc@510
|
113 case ei of
|
adamc@626
|
114 UnknownK => "UK"
|
adamc@626
|
115 | KnownK _ => "KK"
|
adamc@626
|
116 | UnknownC => "UC"
|
adamc@510
|
117 | KnownC _ => "KC"
|
adamc@510
|
118 | UnknownE => "UE"
|
adamc@510
|
119 | KnownE _ => "KE"
|
adamc@626
|
120 | Lift (_, n1, n2) => "(" ^ Int.toString n1 ^ ", " ^ Int.toString n2 ^ ")"
|
adamc@510
|
121
|
adamc@510
|
122 fun e2s env = String.concatWith " " (map ei2s env)
|
adamc@510
|
123
|
adamc@909
|
124 (*val deKnown = List.filter (fn KnownC _ => false
|
adamc@510
|
125 | KnownE _ => false
|
adamc@626
|
126 | KnownK _ => false
|
adamc@909
|
127 | _ => true)*)
|
adamc@909
|
128
|
adamc@909
|
129 val deKnown = ListUtil.mapConcat (fn KnownC _ => []
|
adamc@909
|
130 | KnownE _ => []
|
adamc@909
|
131 | KnownK _ => []
|
adamc@909
|
132 | Lift (nk, nc, ne) => List.tabulate (nk, fn _ => UnknownK)
|
adamc@909
|
133 @ List.tabulate (nc, fn _ => UnknownC)
|
adamc@909
|
134 @ List.tabulate (ne, fn _ => UnknownE)
|
adamc@909
|
135 | x => [x])
|
adamc@510
|
136
|
adamc@930
|
137 datatype result = Yes of env | No | Maybe
|
adamc@930
|
138
|
adamc@930
|
139 fun match (env, p : pat, e : exp) =
|
adamc@942
|
140 let
|
adamc@942
|
141 val baseline = length env
|
adamc@930
|
142
|
adamc@942
|
143 fun match (env, p, e) =
|
adamc@942
|
144 case (#1 p, #1 e) of
|
adamc@942
|
145 (PWild, _) => Yes env
|
adamc@942
|
146 | (PVar (x, t), _) => Yes (KnownE (multiLiftExpInExp (length env - baseline) e) :: env)
|
adamc@930
|
147
|
adamc@942
|
148 | (PPrim p, EPrim p') =>
|
adamc@942
|
149 if Prim.equal (p, p') then
|
adamc@942
|
150 Yes env
|
adamc@942
|
151 else
|
adamc@942
|
152 No
|
adamc@930
|
153
|
adamc@942
|
154 | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) =>
|
adamc@942
|
155 if n1 = n2 then
|
adamc@942
|
156 Yes env
|
adamc@942
|
157 else
|
adamc@942
|
158 No
|
adamc@930
|
159
|
adamc@942
|
160 | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) =>
|
adamc@942
|
161 if n1 = n2 then
|
adamc@942
|
162 match (env, p, e)
|
adamc@942
|
163 else
|
adamc@942
|
164 No
|
adamc@930
|
165
|
adamc@942
|
166 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE),
|
adamc@942
|
167 ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) =>
|
adamc@942
|
168 if m1 = m2 andalso con1 = con2 then
|
adamc@942
|
169 Yes env
|
adamc@942
|
170 else
|
adamc@942
|
171 No
|
adamc@930
|
172
|
adamc@942
|
173 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep),
|
adamc@942
|
174 ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) =>
|
adamc@942
|
175 if m1 = m2 andalso con1 = con2 then
|
adamc@942
|
176 match (env, p, e)
|
adamc@942
|
177 else
|
adamc@942
|
178 No
|
adamc@930
|
179
|
adamc@942
|
180 | (PRecord xps, ERecord xes) =>
|
adamc@942
|
181 if List.exists (fn ((CName _, _), _, _) => false
|
adamc@942
|
182 | _ => true) xes then
|
adamc@942
|
183 Maybe
|
adamc@942
|
184 else
|
adamc@942
|
185 let
|
adamc@942
|
186 fun consider (xps, env) =
|
adamc@942
|
187 case xps of
|
adamc@942
|
188 [] => Yes env
|
adamc@942
|
189 | (x, p, _) :: rest =>
|
adamc@942
|
190 case List.find (fn ((CName x', _), _, _) => x' = x
|
adamc@942
|
191 | _ => false) xes of
|
adamc@942
|
192 NONE => No
|
adamc@942
|
193 | SOME (_, e, _) =>
|
adamc@942
|
194 case match (env, p, e) of
|
adamc@942
|
195 No => No
|
adamc@942
|
196 | Maybe => Maybe
|
adamc@942
|
197 | Yes env => consider (rest, env)
|
adamc@942
|
198 in
|
adamc@942
|
199 consider (xps, env)
|
adamc@942
|
200 end
|
adamc@942
|
201
|
adamc@942
|
202 | _ => Maybe
|
adamc@942
|
203 in
|
adamc@942
|
204 match (env, p, e)
|
adamc@942
|
205 end
|
adamc@930
|
206
|
adamc@626
|
207 fun kindConAndExp (namedC, namedE) =
|
adamc@508
|
208 let
|
adamc@626
|
209 fun kind env (all as (k, loc)) =
|
adamc@626
|
210 case k of
|
adamc@626
|
211 KType => all
|
adamc@626
|
212 | KArrow (k1, k2) => (KArrow (kind env k1, kind env k2), loc)
|
adamc@626
|
213 | KName => all
|
adamc@626
|
214 | KRecord k => (KRecord (kind env k), loc)
|
adamc@626
|
215 | KUnit => all
|
adamc@626
|
216 | KTuple ks => (KTuple (map (kind env) ks), loc)
|
adamc@626
|
217
|
adamc@626
|
218 | KRel n =>
|
adamc@626
|
219 let
|
adamc@626
|
220 fun find (n', env, nudge, lift) =
|
adamc@626
|
221 case env of
|
adamc@626
|
222 [] => raise Fail "Reduce.kind: KRel"
|
adamc@626
|
223 | UnknownC :: rest => find (n', rest, nudge, lift)
|
adamc@626
|
224 | KnownC _ :: rest => find (n', rest, nudge, lift)
|
adamc@626
|
225 | UnknownE :: rest => find (n', rest, nudge, lift)
|
adamc@626
|
226 | KnownE _ :: rest => find (n', rest, nudge, lift)
|
adamc@626
|
227 | Lift (lift', _, _) :: rest => find (n', rest, nudge + lift', lift + lift')
|
adamc@626
|
228 | UnknownK :: rest =>
|
adamc@626
|
229 if n' = 0 then
|
adamc@626
|
230 (KRel (n + nudge), loc)
|
adamc@626
|
231 else
|
adamc@626
|
232 find (n' - 1, rest, nudge, lift + 1)
|
adamc@626
|
233 | KnownK k :: rest =>
|
adamc@626
|
234 if n' = 0 then
|
adamc@626
|
235 kind (Lift (lift, 0, 0) :: rest) k
|
adamc@626
|
236 else
|
adamc@626
|
237 find (n' - 1, rest, nudge - 1, lift)
|
adamc@626
|
238 in
|
adamc@626
|
239 find (n, env, 0, 0)
|
adamc@626
|
240 end
|
adamc@626
|
241 | KFun (x, k) => (KFun (x, kind (UnknownK :: env) k), loc)
|
adamc@626
|
242
|
adamc@508
|
243 fun con env (all as (c, loc)) =
|
adamc@510
|
244 ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*)
|
adamc@508
|
245 case c of
|
adamc@508
|
246 TFun (c1, c2) => (TFun (con env c1, con env c2), loc)
|
adamc@626
|
247 | TCFun (x, k, c2) => (TCFun (x, kind env k, con (UnknownC :: env) c2), loc)
|
adamc@626
|
248 | TKFun (x, c2) => (TKFun (x, con (UnknownK :: env) c2), loc)
|
adamc@508
|
249 | TRecord c => (TRecord (con env c), loc)
|
adamc@215
|
250
|
adamc@508
|
251 | CRel n =>
|
adamc@508
|
252 let
|
adamc@626
|
253 fun find (n', env, nudge, liftK, liftC) =
|
adamc@510
|
254 case env of
|
adamc@510
|
255 [] => raise Fail "Reduce.con: CRel"
|
adamc@626
|
256 | UnknownK :: rest => find (n', rest, nudge, liftK + 1, liftC)
|
adamc@626
|
257 | KnownK _ :: rest => find (n', rest, nudge, liftK, liftC)
|
adamc@626
|
258 | UnknownE :: rest => find (n', rest, nudge, liftK, liftC)
|
adamc@626
|
259 | KnownE _ :: rest => find (n', rest, nudge, liftK, liftC)
|
adamc@626
|
260 | Lift (liftK', liftC', _) :: rest => find (n', rest, nudge + liftC',
|
adamc@626
|
261 liftK + liftK', liftC + liftC')
|
adamc@510
|
262 | UnknownC :: rest =>
|
adamc@510
|
263 if n' = 0 then
|
adamc@510
|
264 (CRel (n + nudge), loc)
|
adamc@510
|
265 else
|
adamc@626
|
266 find (n' - 1, rest, nudge, liftK, liftC + 1)
|
adamc@510
|
267 | KnownC c :: rest =>
|
adamc@510
|
268 if n' = 0 then
|
adamc@626
|
269 con (Lift (liftK, liftC, 0) :: rest) c
|
adamc@510
|
270 else
|
adamc@626
|
271 find (n' - 1, rest, nudge - 1, liftK, liftC)
|
adamc@508
|
272 in
|
adamc@510
|
273 (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*)
|
adamc@626
|
274 find (n, env, 0, 0, 0)
|
adamc@508
|
275 end
|
adamc@508
|
276 | CNamed n =>
|
adamc@508
|
277 (case IM.find (namedC, n) of
|
adamc@508
|
278 NONE => all
|
adamc@508
|
279 | SOME c => c)
|
adamc@508
|
280 | CFfi _ => all
|
adamc@508
|
281 | CApp (c1, c2) =>
|
adamc@508
|
282 let
|
adamc@508
|
283 val c1 = con env c1
|
adamc@508
|
284 val c2 = con env c2
|
adamc@508
|
285 in
|
adamc@508
|
286 case #1 c1 of
|
adamc@508
|
287 CAbs (_, _, b) =>
|
adamc@510
|
288 con (KnownC c2 :: deKnown env) b
|
adamc@215
|
289
|
adamc@621
|
290 | CApp ((CMap (dom, ran), _), f) =>
|
adamc@508
|
291 (case #1 c2 of
|
adamc@626
|
292 CRecord (_, []) => (CRecord (kind env ran, []), loc)
|
adamc@621
|
293 | CRecord (_, (x, c) :: rest) =>
|
adamc@510
|
294 con (deKnown env)
|
adamc@621
|
295 (CConcat ((CRecord (ran, [(x, (CApp (f, c), loc))]), loc),
|
adamc@626
|
296 (CApp (c1, (CRecord (kind env dom, rest), loc)), loc)), loc)
|
adamc@508
|
297 | _ => (CApp (c1, c2), loc))
|
adamc@20
|
298
|
adamc@508
|
299 | _ => (CApp (c1, c2), loc)
|
adamc@508
|
300 end
|
adamc@626
|
301 | CAbs (x, k, b) => (CAbs (x, kind env k, con (UnknownC :: env) b), loc)
|
adamc@626
|
302
|
adamc@626
|
303 | CKApp (c1, k) =>
|
adamc@626
|
304 let
|
adamc@626
|
305 val c1 = con env c1
|
adamc@626
|
306 in
|
adamc@626
|
307 case #1 c1 of
|
adamc@626
|
308 CKAbs (_, b) =>
|
adamc@626
|
309 con (KnownK k :: deKnown env) b
|
adamc@626
|
310
|
adamc@626
|
311 | _ => (CKApp (c1, kind env k), loc)
|
adamc@626
|
312 end
|
adamc@626
|
313 | CKAbs (x, b) => (CKAbs (x, con (UnknownK :: env) b), loc)
|
adamc@20
|
314
|
adamc@508
|
315 | CName _ => all
|
adamc@21
|
316
|
adamc@626
|
317 | CRecord (k, xcs) => (CRecord (kind env k, map (fn (x, c) => (con env x, con env c)) xcs), loc)
|
adamc@508
|
318 | CConcat (c1, c2) =>
|
adamc@508
|
319 let
|
adamc@508
|
320 val c1 = con env c1
|
adamc@508
|
321 val c2 = con env c2
|
adamc@508
|
322 in
|
adamc@508
|
323 case (#1 c1, #1 c2) of
|
adamc@508
|
324 (CRecord (k, xcs1), CRecord (_, xcs2)) =>
|
adamc@626
|
325 (CRecord (kind env k, xcs1 @ xcs2), loc)
|
adamc@1122
|
326 | (CRecord (_, []), _) => c2
|
adamc@1122
|
327 | (_, CRecord (_, [])) => c1
|
adamc@508
|
328 | _ => (CConcat (c1, c2), loc)
|
adamc@508
|
329 end
|
adamc@626
|
330 | CMap (dom, ran) => (CMap (kind env dom, kind env ran), loc)
|
adamc@74
|
331
|
adamc@508
|
332 | CUnit => all
|
adamc@21
|
333
|
adamc@508
|
334 | CTuple cs => (CTuple (map (con env) cs), loc)
|
adamc@508
|
335 | CProj (c, n) =>
|
adamc@508
|
336 let
|
adamc@508
|
337 val c = con env c
|
adamc@508
|
338 in
|
adamc@508
|
339 case #1 c of
|
adamc@508
|
340 CTuple cs => List.nth (cs, n - 1)
|
adamc@508
|
341 | _ => (CProj (c, n), loc)
|
adamc@510
|
342 end)
|
adamc@22
|
343
|
adamc@509
|
344 fun patCon pc =
|
adamc@509
|
345 case pc of
|
adamc@509
|
346 PConVar _ => pc
|
adamc@509
|
347 | PConFfi {mod = m, datatyp, params, con = c, arg, kind} =>
|
adamc@509
|
348 PConFfi {mod = m, datatyp = datatyp, params = params, con = c,
|
adamc@509
|
349 arg = Option.map (con (map (fn _ => UnknownC) params)) arg,
|
adamc@509
|
350 kind = kind}
|
adamc@509
|
351
|
adamc@509
|
352
|
adamc@509
|
353 val k = (KType, ErrorMsg.dummySpan)
|
adamc@509
|
354 fun doPart e (this as (x, t), rest) =
|
adamc@509
|
355 ((x, (EField (e, x, {field = t, rest = (CRecord (k, rest), #2 t)}), #2 t), t),
|
adamc@509
|
356 this :: rest)
|
adamc@509
|
357
|
adamc@509
|
358 fun exp env (all as (e, loc)) =
|
adamc@909
|
359 let
|
adamc@909
|
360 (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
|
adamc@909
|
361 ("env", Print.PD.string (e2s env))]*)
|
adamc@1176
|
362 (*val () = if dangling (edepth env) all then
|
adamc@909
|
363 (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
|
adamc@909
|
364 ("env", Print.PD.string (e2s env))];
|
adamc@909
|
365 raise Fail "!")
|
adamc@909
|
366 else
|
adamc@1176
|
367 ()*)
|
adamc@1272
|
368 (*val () = if cdangling (cdepth env) all then
|
adamc@1272
|
369 Print.prefaces "Bad exp" [("e", CorePrint.p_exp CoreEnv.empty all),
|
adamc@1272
|
370 ("env", Print.PD.string (e2s env))]
|
adamc@1272
|
371 else
|
adamc@1272
|
372 ()*)
|
adamc@509
|
373
|
adamc@909
|
374 val r = case e of
|
adamc@909
|
375 EPrim _ => all
|
adamc@909
|
376 | ERel n =>
|
adamc@909
|
377 let
|
adamc@909
|
378 fun find (n', env, nudge, liftK, liftC, liftE) =
|
adamc@909
|
379 case env of
|
adamc@909
|
380 [] => raise Fail ("Reduce.exp: ERel (" ^ ErrorMsg.spanToString loc ^ ")")
|
adamc@909
|
381 | UnknownK :: rest => find (n', rest, nudge, liftK + 1, liftC, liftE)
|
adamc@909
|
382 | KnownK _ :: rest => find (n', rest, nudge, liftK, liftC, liftE)
|
adamc@909
|
383 | UnknownC :: rest => find (n', rest, nudge, liftK, liftC + 1, liftE)
|
adamc@909
|
384 | KnownC _ :: rest => find (n', rest, nudge, liftK, liftC, liftE)
|
adamc@909
|
385 | Lift (liftK', liftC', liftE') :: rest =>
|
adamc@909
|
386 find (n', rest, nudge + liftE',
|
adamc@909
|
387 liftK + liftK', liftC + liftC', liftE + liftE')
|
adamc@909
|
388 | UnknownE :: rest =>
|
adamc@909
|
389 if n' = 0 then
|
adamc@909
|
390 (ERel (n + nudge), loc)
|
adamc@909
|
391 else
|
adamc@909
|
392 find (n' - 1, rest, nudge, liftK, liftC, liftE + 1)
|
adamc@909
|
393 | KnownE e :: rest =>
|
adamc@909
|
394 if n' = 0 then
|
adamc@909
|
395 ((*print "SUBSTITUTING\n";*)
|
adamc@909
|
396 exp (Lift (liftK, liftC, liftE) :: rest) e)
|
adamc@909
|
397 else
|
adamc@909
|
398 find (n' - 1, rest, nudge - 1, liftK, liftC, liftE)
|
adamc@909
|
399 in
|
adamc@909
|
400 (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*)
|
adamc@909
|
401 find (n, env, 0, 0, 0, 0)
|
adamc@909
|
402 end
|
adamc@909
|
403 | ENamed n =>
|
adamc@909
|
404 (case IM.find (namedE, n) of
|
adamc@909
|
405 NONE => all
|
adamc@909
|
406 | SOME e => e)
|
adamc@909
|
407 | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc,
|
adamc@909
|
408 map (con env) cs, Option.map (exp env) eo), loc)
|
adamc@909
|
409 | EFfi _ => all
|
adamc@909
|
410 | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc)
|
adamc@908
|
411
|
adamc@909
|
412 (*| EApp (
|
adamc@909
|
413 (EApp
|
adamc@909
|
414 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
|
adamc@909
|
415 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@909
|
416 (ECase (ed, pes, {disc, ...}), _)), _),
|
adamc@909
|
417 trans2) =>
|
adamc@909
|
418 let
|
adamc@909
|
419 val e' = (EFfi ("Basis", "bind"), loc)
|
adamc@909
|
420 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@909
|
421 val e' = (ECApp (e', t1), loc)
|
adamc@909
|
422 val e' = (ECApp (e', t2), loc)
|
adamc@909
|
423 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@908
|
424
|
adamc@909
|
425 val pes = map (fn (p, e) =>
|
adamc@909
|
426 let
|
adamc@909
|
427 val e' = (EApp (e', e), loc)
|
adamc@909
|
428 val e' = (EApp (e',
|
adamc@909
|
429 multiLiftExpInExp (E.patBindsN p)
|
adamc@909
|
430 trans2), loc)
|
adamc@909
|
431 val e' = exp env e'
|
adamc@909
|
432 in
|
adamc@909
|
433 (p, e')
|
adamc@909
|
434 end) pes
|
adamc@909
|
435 in
|
adamc@909
|
436 (ECase (exp env ed,
|
adamc@909
|
437 pes,
|
adamc@909
|
438 {disc = con env disc,
|
adamc@909
|
439 result = (CApp ((CFfi ("Basis", "transaction"), loc), con env t2), loc)}),
|
adamc@909
|
440 loc)
|
adamc@909
|
441 end*)
|
adamc@908
|
442
|
adamc@909
|
443 | EApp (e1, e2) =>
|
adamc@909
|
444 let
|
adamc@910
|
445 val env' = deKnown env
|
adamc@910
|
446
|
adamc@909
|
447 val e1 = exp env e1
|
adamc@909
|
448 val e2 = exp env e2
|
adamc@909
|
449 in
|
adamc@1179
|
450 case #1 e1 of
|
adamc@1179
|
451 EAbs (_, _, _, b) =>
|
adamc@1181
|
452 let
|
adamc@1181
|
453 val r = exp (KnownE e2 :: env') b
|
adamc@1181
|
454 in
|
adamc@1181
|
455 (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b),
|
adamc@1181
|
456 ("env", Print.PD.string (e2s env')),
|
adamc@1181
|
457 ("e2", CorePrint.p_exp CoreEnv.empty e2),
|
adamc@1181
|
458 ("r", CorePrint.p_exp CoreEnv.empty r)];*)
|
adamc@1181
|
459 r
|
adamc@1181
|
460 end
|
adamc@1179
|
461 | _ => (EApp (e1, e2), loc)
|
adamc@909
|
462 end
|
adamc@509
|
463
|
adamc@909
|
464 | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc)
|
adamc@509
|
465
|
adamc@909
|
466 | ECApp (e, c) =>
|
adamc@909
|
467 let
|
adamc@909
|
468 val e = exp env e
|
adamc@909
|
469 val c = con env c
|
adamc@909
|
470 in
|
adamc@909
|
471 case #1 e of
|
adamc@1181
|
472 ECAbs (_, _, b) =>
|
adamc@1181
|
473 let
|
adamc@1181
|
474 val r = exp (KnownC c :: deKnown env) b
|
adamc@1181
|
475 in
|
adamc@1181
|
476 (*Print.prefaces "csub" [("l", Print.PD.string (ErrorMsg.spanToString loc)),
|
adamc@1181
|
477 ("env", Print.PD.string (e2s (deKnown env))),
|
adamc@1181
|
478 ("b", CorePrint.p_exp CoreEnv.empty b),
|
adamc@1181
|
479 ("c", CorePrint.p_con CoreEnv.empty c),
|
adamc@1181
|
480 ("r", CorePrint.p_exp CoreEnv.empty r)];*)
|
adamc@1181
|
481 r
|
adamc@1181
|
482 end
|
adamc@909
|
483 | _ => (ECApp (e, c), loc)
|
adamc@909
|
484 end
|
adamc@626
|
485
|
adamc@909
|
486 | ECAbs (x, k, e) => (ECAbs (x, kind env k, exp (UnknownC :: env) e), loc)
|
adamc@626
|
487
|
adamc@909
|
488 | EKApp (e, k) =>
|
adamc@909
|
489 let
|
adamc@909
|
490 val e = exp env e
|
adamc@909
|
491 in
|
adamc@909
|
492 case #1 e of
|
adamc@1181
|
493 EKAbs (_, b) =>
|
adamc@1181
|
494 let
|
adamc@1181
|
495 val r = exp (KnownK k :: deKnown env) b
|
adamc@1181
|
496 in
|
adamc@1181
|
497 (*Print.prefaces "ksub" [("l", Print.PD.string (ErrorMsg.spanToString loc)),
|
adamc@1181
|
498 ("b", CorePrint.p_exp CoreEnv.empty b),
|
adamc@1181
|
499 ("k", CorePrint.p_kind CoreEnv.empty k),
|
adamc@1181
|
500 ("r", CorePrint.p_exp CoreEnv.empty r)];*)
|
adamc@1181
|
501 r
|
adamc@1181
|
502 end
|
adamc@909
|
503 | _ => (EKApp (e, kind env k), loc)
|
adamc@909
|
504 end
|
adamc@509
|
505
|
adamc@909
|
506 | EKAbs (x, e) => (EKAbs (x, exp (UnknownK :: env) e), loc)
|
adamc@509
|
507
|
adamc@909
|
508 | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc)
|
adamc@909
|
509 | EField (e, c, {field, rest}) =>
|
adamc@909
|
510 let
|
adamc@909
|
511 val e = exp env e
|
adamc@909
|
512 val c = con env c
|
adamc@509
|
513
|
adamc@909
|
514 fun default () = (EField (e, c, {field = con env field, rest = con env rest}), loc)
|
adamc@909
|
515 in
|
adamc@909
|
516 case (#1 e, #1 c) of
|
adamc@909
|
517 (ERecord xcs, CName x) =>
|
adamc@909
|
518 (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of
|
adamc@909
|
519 NONE => default ()
|
adamc@909
|
520 | SOME (_, e, _) => e)
|
adamc@909
|
521 | _ => default ()
|
adamc@909
|
522 end
|
adamc@509
|
523
|
adamc@909
|
524 | EConcat (e1, c1, e2, c2) =>
|
adamc@909
|
525 let
|
adamc@909
|
526 val e1 = exp env e1
|
adamc@909
|
527 val e2 = exp env e2
|
adamc@909
|
528 in
|
adamc@909
|
529 case (#1 e1, #1 e2) of
|
adamc@909
|
530 (ERecord xes1, ERecord xes2) => (ERecord (xes1 @ xes2), loc)
|
adamc@909
|
531 | _ =>
|
adamc@909
|
532 let
|
adamc@909
|
533 val c1 = con env c1
|
adamc@909
|
534 val c2 = con env c2
|
adamc@909
|
535 in
|
adamc@909
|
536 case (#1 c1, #1 c2) of
|
adamc@909
|
537 (CRecord (k, xcs1), CRecord (_, xcs2)) =>
|
adamc@909
|
538 let
|
adamc@909
|
539 val (xes1, rest) = ListUtil.foldlMap (doPart e1) [] xcs1
|
adamc@909
|
540 val (xes2, _) = ListUtil.foldlMap (doPart e2) rest xcs2
|
adamc@909
|
541 in
|
adamc@909
|
542 exp (deKnown env) (ERecord (xes1 @ xes2), loc)
|
adamc@909
|
543 end
|
adamc@909
|
544 | _ => (EConcat (e1, c1, e2, c2), loc)
|
adamc@909
|
545 end
|
adamc@909
|
546 end
|
adamc@509
|
547
|
adamc@909
|
548 | ECut (e, c, {field, rest}) =>
|
adamc@909
|
549 let
|
adamc@909
|
550 val e = exp env e
|
adamc@909
|
551 val c = con env c
|
adamc@509
|
552
|
adamc@909
|
553 fun default () =
|
adamc@909
|
554 let
|
adamc@909
|
555 val rest = con env rest
|
adamc@909
|
556 in
|
adamc@909
|
557 case #1 rest of
|
adamc@909
|
558 CRecord (k, xcs) =>
|
adamc@909
|
559 let
|
adamc@909
|
560 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
|
adamc@909
|
561 in
|
adamc@909
|
562 exp (deKnown env) (ERecord xes, loc)
|
adamc@909
|
563 end
|
adamc@909
|
564 | _ => (ECut (e, c, {field = con env field, rest = rest}), loc)
|
adamc@909
|
565 end
|
adamc@909
|
566 in
|
adamc@909
|
567 case (#1 e, #1 c) of
|
adamc@909
|
568 (ERecord xes, CName x) =>
|
adamc@909
|
569 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes then
|
adamc@909
|
570 (ERecord (List.filter (fn ((CName x', _), _, _) => x' <> x
|
adamc@909
|
571 | _ => raise Fail "Reduce: ECut") xes), loc)
|
adamc@909
|
572 else
|
adamc@909
|
573 default ()
|
adamc@909
|
574 | _ => default ()
|
adamc@909
|
575 end
|
adamc@509
|
576
|
adamc@909
|
577 | ECutMulti (e, c, {rest}) =>
|
adamc@909
|
578 let
|
adamc@909
|
579 val e = exp env e
|
adamc@909
|
580 val c = con env c
|
adamc@509
|
581
|
adamc@909
|
582 fun default () =
|
adamc@909
|
583 let
|
adamc@909
|
584 val rest = con env rest
|
adamc@909
|
585 in
|
adamc@909
|
586 case #1 rest of
|
adamc@909
|
587 CRecord (k, xcs) =>
|
adamc@909
|
588 let
|
adamc@909
|
589 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
|
adamc@909
|
590 in
|
adamc@909
|
591 exp (deKnown env) (ERecord xes, loc)
|
adamc@909
|
592 end
|
adamc@909
|
593 | _ => (ECutMulti (e, c, {rest = rest}), loc)
|
adamc@909
|
594 end
|
adamc@909
|
595 in
|
adamc@909
|
596 case (#1 e, #1 c) of
|
adamc@909
|
597 (ERecord xes, CRecord (_, xcs)) =>
|
adamc@909
|
598 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes
|
adamc@909
|
599 andalso List.all (fn ((CName _, _), _) => true | _ => false) xcs then
|
adamc@909
|
600 (ERecord (List.filter (fn ((CName x', _), _, _) =>
|
adamc@909
|
601 List.all (fn ((CName x, _), _) => x' <> x
|
adamc@909
|
602 | _ => raise Fail "Reduce: ECutMulti [1]") xcs
|
adamc@909
|
603 | _ => raise Fail "Reduce: ECutMulti [2]") xes), loc)
|
adamc@909
|
604 else
|
adamc@909
|
605 default ()
|
adamc@909
|
606 | _ => default ()
|
adamc@909
|
607 end
|
adamc@823
|
608
|
adamc@909
|
609 | ECase (_, [((PRecord [], _), e)], _) => exp env e
|
adamc@909
|
610 | ECase (_, [((PWild, _), e)], _) => exp env e
|
adamc@509
|
611
|
adamc@909
|
612 | ECase (e, pes, {disc, result}) =>
|
adamc@909
|
613 let
|
adamc@909
|
614 fun patBinds (p, _) =
|
adamc@909
|
615 case p of
|
adamc@909
|
616 PWild => 0
|
adamc@909
|
617 | PVar _ => 1
|
adamc@909
|
618 | PPrim _ => 0
|
adamc@909
|
619 | PCon (_, _, _, NONE) => 0
|
adamc@909
|
620 | PCon (_, _, _, SOME p) => patBinds p
|
adamc@909
|
621 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
|
adamc@509
|
622
|
adamc@909
|
623 fun pat (all as (p, loc)) =
|
adamc@909
|
624 case p of
|
adamc@909
|
625 PWild => all
|
adamc@909
|
626 | PVar (x, t) => (PVar (x, con env t), loc)
|
adamc@909
|
627 | PPrim _ => all
|
adamc@909
|
628 | PCon (dk, pc, cs, po) =>
|
adamc@909
|
629 (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc)
|
adamc@909
|
630 | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc)
|
adamc@930
|
631
|
adamc@930
|
632 fun push () =
|
adamc@930
|
633 (ECase (exp env e,
|
adamc@930
|
634 map (fn (p, e) => (pat p,
|
adamc@930
|
635 exp (List.tabulate (patBinds p,
|
adamc@930
|
636 fn _ => UnknownE) @ env) e))
|
adamc@930
|
637 pes, {disc = con env disc, result = con env result}), loc)
|
adamc@930
|
638
|
adamc@930
|
639 fun search pes =
|
adamc@930
|
640 case pes of
|
adamc@930
|
641 [] => push ()
|
adamc@930
|
642 | (p, body) :: pes =>
|
adamc@930
|
643 case match (env, p, e) of
|
adamc@930
|
644 No => search pes
|
adamc@930
|
645 | Maybe => push ()
|
adamc@930
|
646 | Yes env' => exp env' body
|
adamc@909
|
647 in
|
adamc@930
|
648 search pes
|
adamc@909
|
649 end
|
adamc@509
|
650
|
adamc@909
|
651 | EWrite e => (EWrite (exp env e), loc)
|
adamc@909
|
652 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
|
adamc@607
|
653
|
adamc@910
|
654 | ELet (x, t, e1, e2) =>
|
adam@1289
|
655 let
|
adam@1289
|
656 val t = con env t
|
adam@1289
|
657 in
|
adam@1289
|
658 if ESpecialize.functionInside t then
|
adam@1289
|
659 exp (KnownE e1 :: env) e2
|
adam@1289
|
660 else
|
adam@1314
|
661 (ELet (x, t, exp env e1, exp (UnknownE :: env) e2), loc)
|
adam@1289
|
662 end
|
adamc@909
|
663
|
adamc@1020
|
664 | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc)
|
adamc@909
|
665 in
|
adamc@909
|
666 (*if dangling (edepth' (deKnown env)) r then
|
adamc@909
|
667 (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
|
adamc@909
|
668 ("r", CorePrint.p_exp CoreEnv.empty r)];
|
adamc@909
|
669 raise Fail "!!")
|
adamc@909
|
670 else
|
adamc@909
|
671 ();*)
|
adamc@1272
|
672 (*if cdangling (cdepth' (deKnown env)) r then
|
adamc@1272
|
673 (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
|
adamc@1272
|
674 ("r", CorePrint.p_exp CoreEnv.empty r)];
|
adamc@1272
|
675 raise Fail "!!")
|
adamc@1272
|
676 else
|
adamc@1272
|
677 ();*)
|
adamc@909
|
678 r
|
adamc@909
|
679 end
|
adamc@417
|
680 in
|
adamc@626
|
681 {kind = kind, con = con, exp = exp}
|
adamc@417
|
682 end
|
adamc@21
|
683
|
adamc@626
|
684 fun kind namedC env k = #kind (kindConAndExp (namedC, IM.empty)) env k
|
adamc@626
|
685 fun con namedC env c = #con (kindConAndExp (namedC, IM.empty)) env c
|
adamc@626
|
686 fun exp (namedC, namedE) env e = #exp (kindConAndExp (namedC, namedE)) env e
|
adamc@20
|
687
|
adamc@508
|
688 fun reduce file =
|
adamc@508
|
689 let
|
adamc@1016
|
690 val uses = CoreUtil.File.fold {kind = fn (_, m) => m,
|
adamc@1016
|
691 con = fn (_, m) => m,
|
adamc@1016
|
692 exp = fn (e, m) =>
|
adamc@1016
|
693 case e of
|
adamc@1016
|
694 ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0))
|
adamc@1016
|
695 | _ => m,
|
adamc@1016
|
696 decl = fn (_, m) => m}
|
adamc@1016
|
697 IM.empty file
|
adamc@1016
|
698
|
adamc@1016
|
699 fun isPoly names = CoreUtil.Con.exists {kind = fn _ => false,
|
adamc@1016
|
700 con = fn TCFun _ => true
|
adamc@1016
|
701 | TKFun _ => true
|
adamc@1016
|
702 | CNamed n => IS.member (names, n)
|
adamc@1016
|
703 | _ => false}
|
adamc@1016
|
704
|
adamc@1016
|
705 val size = CoreUtil.Exp.fold {kind = fn (_, n) => n,
|
adamc@1016
|
706 con = fn (_, n) => n,
|
adamc@1016
|
707 exp = fn (_, n) => n + 1} 0
|
adamc@1016
|
708
|
adamc@1016
|
709 fun mayInline (polyC, n, t, e) =
|
adamc@1240
|
710 let
|
adamc@1240
|
711 fun isPolicy t =
|
adamc@1240
|
712 case #1 t of
|
adamc@1240
|
713 CFfi ("Basis", "sql_policy") => true
|
adamc@1240
|
714 | TFun (_, t) => isPolicy t
|
adamc@1240
|
715 | _ => false
|
adamc@1240
|
716 in
|
adamc@1240
|
717 case IM.find (uses, n) of
|
adamc@1240
|
718 NONE => false
|
adamc@1240
|
719 | SOME count => count <= 1
|
adamc@1240
|
720 orelse (case #1 e of
|
adamc@1240
|
721 ERecord _ => true
|
adamc@1240
|
722 | _ => false)
|
adamc@1240
|
723 orelse isPolicy t
|
adamc@1240
|
724 orelse isPoly polyC t
|
adamc@1240
|
725 orelse size e <= Settings.getCoreInline ()
|
adamc@1240
|
726 end
|
adamc@1016
|
727
|
adamc@1016
|
728 fun doDecl (d as (_, loc), st as (polyC, namedC, namedE)) =
|
adamc@508
|
729 case #1 d of
|
adamc@508
|
730 DCon (x, n, k, c) =>
|
adamc@508
|
731 let
|
adamc@626
|
732 val k = kind namedC [] k
|
adamc@509
|
733 val c = con namedC [] c
|
adamc@508
|
734 in
|
adamc@508
|
735 ((DCon (x, n, k, c), loc),
|
adamc@1016
|
736 (if isPoly polyC c then
|
adamc@1016
|
737 IS.add (polyC, n)
|
adamc@1016
|
738 else
|
adamc@1016
|
739 polyC,
|
adamc@1016
|
740 IM.insert (namedC, n, c),
|
adamc@1016
|
741 namedE))
|
adamc@508
|
742 end
|
adamc@807
|
743 | DDatatype dts =>
|
adamc@807
|
744 ((DDatatype (map (fn (x, n, ps, cs) =>
|
adamc@807
|
745 let
|
adamc@807
|
746 val env = map (fn _ => UnknownC) ps
|
adamc@807
|
747 in
|
adamc@807
|
748 (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs)
|
adamc@807
|
749 end) dts), loc),
|
adamc@1016
|
750 (if List.exists (fn (_, _, _, cs) => List.exists (fn (_, _, co) => case co of
|
adamc@1016
|
751 NONE => false
|
adamc@1016
|
752 | SOME c => isPoly polyC c) cs)
|
adamc@1016
|
753 dts then
|
adamc@1016
|
754 foldl (fn ((_, n, _, _), polyC) => IS.add (polyC, n)) polyC dts
|
adamc@1016
|
755 else
|
adamc@1016
|
756 polyC,
|
adamc@1016
|
757 namedC,
|
adamc@1016
|
758 namedE))
|
adamc@508
|
759 | DVal (x, n, t, e, s) =>
|
adamc@508
|
760 let
|
adamc@509
|
761 val t = con namedC [] t
|
adamc@509
|
762 val e = exp (namedC, namedE) [] e
|
adamc@508
|
763 in
|
adamc@508
|
764 ((DVal (x, n, t, e, s), loc),
|
adamc@1016
|
765 (polyC,
|
adamc@1016
|
766 namedC,
|
adamc@1016
|
767 if mayInline (polyC, n, t, e) then
|
adamc@1016
|
768 IM.insert (namedE, n, e)
|
adamc@1016
|
769 else
|
adamc@1016
|
770 namedE))
|
adamc@508
|
771 end
|
adamc@508
|
772 | DValRec vis =>
|
adamc@910
|
773 ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t,
|
adamc@910
|
774 exp (namedC, namedE) [] e, s)) vis), loc),
|
adamc@508
|
775 st)
|
adamc@508
|
776 | DExport _ => (d, st)
|
adamc@707
|
777 | DTable (s, n, c, s', pe, pc, ce, cc) => ((DTable (s, n, con namedC [] c, s',
|
adamc@707
|
778 exp (namedC, namedE) [] pe,
|
adamc@707
|
779 con namedC [] pc,
|
adamc@707
|
780 exp (namedC, namedE) [] ce,
|
adamc@707
|
781 con namedC [] cc), loc), st)
|
adamc@508
|
782 | DSequence _ => (d, st)
|
adamc@754
|
783 | DView (s, n, s', e, c) => ((DView (s, n, s', exp (namedC, namedE) [] e, con namedC [] c), loc), st)
|
adamc@508
|
784 | DDatabase _ => (d, st)
|
adamc@509
|
785 | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
|
adamc@720
|
786 | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st)
|
adamc@1075
|
787 | DTask (e1, e2) =>
|
adamc@1073
|
788 let
|
adamc@1075
|
789 val e1 = exp (namedC, namedE) [] e1
|
adamc@1075
|
790 val e2 = exp (namedC, namedE) [] e2
|
adamc@1073
|
791 in
|
adamc@1075
|
792 ((DTask (e1, e2), loc),
|
adamc@1073
|
793 (polyC,
|
adamc@1073
|
794 namedC,
|
adamc@1073
|
795 namedE))
|
adamc@1073
|
796 end
|
adamc@1199
|
797 | DPolicy e1 =>
|
adamc@1199
|
798 let
|
adamc@1199
|
799 val e1 = exp (namedC, namedE) [] e1
|
adamc@1199
|
800 in
|
adamc@1199
|
801 ((DPolicy e1, loc),
|
adamc@1199
|
802 (polyC,
|
adamc@1199
|
803 namedC,
|
adamc@1199
|
804 namedE))
|
adamc@1199
|
805 end
|
adam@1294
|
806 | DOnError _ => (d, st)
|
adamc@20
|
807
|
adamc@1016
|
808 val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file
|
adamc@508
|
809 in
|
adamc@508
|
810 file
|
adamc@508
|
811 end
|
adamc@20
|
812
|
adamc@20
|
813 end
|