Mercurial > urweb

comparison src/reduce.sml @ 908:ed06e25c70ef

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Convert to requiring explicit 'rpc' marker
author Adam Chlipala <adamc@hcoop.net>
date Sat, 22 Aug 2009 12:55:18 -0400
parents 669ac5e9a69e
children 1d3f60e74ec7
comparison
equal deleted inserted replaced
907:5fe49effbc83 908:ed06e25c70ef
31 31
32 open Core 32 open Core
33 33
34 structure IM = IntBinaryMap 34 structure IM = IntBinaryMap
35 35
36 structure E = CoreEnv
37
38 fun multiLiftExpInExp n e =
39 if n = 0 then
40 e
41 else
42 multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
43
36 datatype env_item = 44 datatype env_item =
37 UnknownK 45 UnknownK
38 | KnownK of kind 46 | KnownK of kind
39 47
40 | UnknownC 48 | UnknownC
252 | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, 260 | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc,
253 map (con env) cs, Option.map (exp env) eo), loc) 261 map (con env) cs, Option.map (exp env) eo), loc)
254 | EFfi _ => all 262 | EFfi _ => all
255 | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc) 263 | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc)
256 264
265 | EApp (
266 (EApp
267 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
268 _), _),
269 (EApp (
270 (EApp (
271 (ECApp (
272 (ECApp ((EFfi ("Basis", "return"), _), _), _),
273 _), _),
274 _), _), v), _)), _), trans2) => exp env (EApp (trans2, v), loc)
275
276 (*| EApp (
277 (EApp
278 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
279 (EFfi ("Basis", "transaction_monad"), _)), _),
280 (ECase (ed, pes, {disc, ...}), _)), _),
281 trans2) =>
282 let
283 val e' = (EFfi ("Basis", "bind"), loc)
284 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
285 val e' = (ECApp (e', t1), loc)
286 val e' = (ECApp (e', t2), loc)
287 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
288
289 val pes = map (fn (p, e) =>
290 let
291 val e' = (EApp (e', e), loc)
292 val e' = (EApp (e',
293 multiLiftExpInExp (E.patBindsN p)
294 trans2), loc)
295 val e' = exp env e'
296 in
297 (p, e')
298 end) pes
299 in
300 (ECase (exp env ed,
301 pes,
302 {disc = con env disc,
303 result = (CApp ((CFfi ("Basis", "transaction"), loc), con env t2), loc)}),
304 loc)
305 end*)
306
307 | EApp (
308 (EApp
309 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
310 (EFfi ("Basis", "transaction_monad"), _)), _),
311 (EServerCall (n, es, ke, dom, ran), _)), _),
312 trans2) =>
313 let
314 val e' = (EFfi ("Basis", "bind"), loc)
315 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
316 val e' = (ECApp (e', dom), loc)
317 val e' = (ECApp (e', t2), loc)
318 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
319 val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
320 val e' = (EApp (e', E.liftExpInExp 0 trans2), loc)
321 val e' = (EAbs ("x", dom, t2, e'), loc)
322 val e' = (EServerCall (n, es, e', dom, t2), loc)
323 in
324 exp env e'
325 end
326
327 | EApp (
328 (EApp
329 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _),
330 (EFfi ("Basis", "transaction_monad"), _)), _),
331 (EApp ((EApp
332 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
333 (EFfi ("Basis", "transaction_monad"), _)), _),
334 trans1), _), trans2), _)), _),
335 trans3) =>
336 let
337 val e'' = (EFfi ("Basis", "bind"), loc)
338 val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc)
339 val e'' = (ECApp (e'', t2), loc)
340 val e'' = (ECApp (e'', t3), loc)
341 val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc)
342 val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc)
343 val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc)
344 val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc)
345
346 val e' = (EFfi ("Basis", "bind"), loc)
347 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
348 val e' = (ECApp (e', t1), loc)
349 val e' = (ECApp (e', t3), loc)
350 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
351 val e' = (EApp (e', trans1), loc)
352 val e' = (EApp (e', e''), loc)
353 in
354 exp env e'
355 end
356
257 | EApp (e1, e2) => 357 | EApp (e1, e2) =>
258 let 358 let
259 val e1 = exp env e1 359 val e1 = exp env e1
260 val e2 = exp env e2 360 val e2 = exp env e2
261 in 361 in
422 | EWrite e => (EWrite (exp env e), loc) 522 | EWrite e => (EWrite (exp env e), loc)
423 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) 523 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
424 524
425 | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc) 525 | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc)
426 526
427 | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, con env t), loc)) 527 | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e,
528 con env t1, con env t2), loc))
428 in 529 in
429 {kind = kind, con = con, exp = exp} 530 {kind = kind, con = con, exp = exp}
430 end 531 end
431 532
432 fun kind namedC env k = #kind (kindConAndExp (namedC, IM.empty)) env k 533 fun kind namedC env k = #kind (kindConAndExp (namedC, IM.empty)) env k