Mercurial > urweb

comparison src/mono_reduce.sml @ 2211:ef766ef6e242

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge.
author Ziv Scully <ziv@mit.edu>
date Sat, 13 Sep 2014 19:16:07 -0400
parents 04d7d563a36f
children 1b76ae703cbb
comparison
equal deleted inserted replaced
2210:69c0f36255cb 2211:ef766ef6e242
1 (* Copyright (c) 2008, 2013, Adam Chlipala 1 (* Copyright (c) 2008, 2013-2014, Adam Chlipala
2 * All rights reserved. 2 * All rights reserved.
3 * 3 *
4 * Redistribution and use in source and binary forms, with or without 4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met: 5 * modification, are permitted provided that the following conditions are met:
6 * 6 *
188 fun match (env, p : pat, e : exp) = 188 fun match (env, p : pat, e : exp) =
189 case (#1 p, #1 e) of 189 case (#1 p, #1 e) of
190 (PWild, _) => Yes env 190 (PWild, _) => Yes env
191 | (PVar (x, t), _) => Yes ((x, t, e) :: env) 191 | (PVar (x, t), _) => Yes ((x, t, e) :: env)
192 192
193 | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) => 193 | (PPrim (Prim.String (_, s)), EStrcat ((EPrim (Prim.String (_, s')), _), _)) =>
194 if String.isPrefix s' s then 194 if String.isPrefix s' s then
195 Maybe 195 Maybe
196 else 196 else
197 No 197 No
198 198
199 | (PPrim (Prim.String s), EStrcat (_, (EPrim (Prim.String s'), _))) => 199 | (PPrim (Prim.String (_, s)), EStrcat (_, (EPrim (Prim.String (_, s')), _))) =>
200 if String.isSuffix s' s then 200 if String.isSuffix s' s then
201 Maybe 201 Maybe
202 else 202 else
203 No 203 No
204 204
469 | ERecord xets => List.concat (map (summarize d o #2) xets) 469 | ERecord xets => List.concat (map (summarize d o #2) xets)
470 | EField (e, _) => summarize d e 470 | EField (e, _) => summarize d e
471 471
472 | ECase (e, pes, _) => 472 | ECase (e, pes, _) =>
473 let 473 let
474 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes 474 val lss = map (fn (p, e) => summarize (if d = ~1 then ~1 else d + patBinds p) e) pes
475 475
476 fun splitRel ls acc = 476 fun splitRel ls acc =
477 case ls of 477 case ls of
478 [] => (acc, false, ls) 478 [] => (acc, false, ls)
479 | UseRel :: ls => (acc, true, ls) 479 | UseRel :: ls => (acc, true, ls)
500 | ERedirect (e, _) => summarize d e @ [Abort] 500 | ERedirect (e, _) => summarize d e @ [Abort]
501 501
502 | EWrite e => summarize d e @ [WritePage] 502 | EWrite e => summarize d e @ [WritePage]
503 503
504 | ESeq (e1, e2) => summarize d e1 @ summarize d e2 504 | ESeq (e1, e2) => summarize d e1 @ summarize d e2
505 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2 505 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (if d = ~1 then ~1 else d + 1) e2
506 506
507 | EClosure (_, es) => List.concat (map (summarize d) es) 507 | EClosure (_, es) => List.concat (map (summarize d) es)
508 508
509 | EQuery {query, body, initial, ...} => 509 | EQuery {query, body, initial, ...} =>
510 List.concat [summarize d query, 510 List.concat [summarize d query,
511 summarize d initial, 511 summarize d initial,
512 [ReadDb], 512 [ReadDb],
513 summarize (d + 2) body] 513 summarize (if d = ~1 then ~1 else d + 2) body]
514 514
515 | EDml (e, _) => summarize d e @ [WriteDb] 515 | EDml (e, _) => summarize d e @ [WriteDb]
516 | ENextval e => summarize d e @ [WriteDb] 516 | ENextval e => summarize d e @ [WriteDb]
517 | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb] 517 | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
518 | EUnurlify (e, _, _) => summarize d e 518 | EUnurlify (e, _, _) => summarize d e
583 let 583 let
584 val effs_e' = summarize 0 e' 584 val effs_e' = summarize 0 e'
585 val effs_e' = List.filter (fn x => x <> UseRel) effs_e' 585 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
586 val effs_b = summarize 0 b 586 val effs_b = summarize 0 b
587 587
588 (*val () = Print.fprefaces outf "Try" 588 (*val () = Print.prefaces "Try"
589 [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*) 589 [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
590 ("e'", MonoPrint.p_exp env e'), 590 ("e'", MonoPrint.p_exp env e'),
591 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), 591 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
592 ("e'_eff", p_events effs_e'), 592 ("e'_eff", p_events effs_e'),
593 ("b_eff", p_events effs_b)]*) 593 ("b_eff", p_events effs_b)]*)
683 EAbs ("y", dom, result, 683 EAbs ("y", dom, result,
684 (ECase (liftExpInExp 0 e', 684 (ECase (liftExpInExp 0 e',
685 map (fn (p, (EAbs (_, _, _, e), _)) => 685 map (fn (p, (EAbs (_, _, _, e), _)) =>
686 (p, swapExpVarsPat (0, patBinds p) e) 686 (p, swapExpVarsPat (0, patBinds p) e)
687 | (p, (EError (e, (TFun (_, t), _)), loc)) => 687 | (p, (EError (e, (TFun (_, t), _)), loc)) =>
688 (p, (EError (e, t), loc)) 688 (p, (EError (liftExpInExp (patBinds p) e, t), loc))
689 | (p, e) => 689 | (p, e) =>
690 (p, (EApp (liftExpInExp (patBinds p) e, 690 (p, (EApp (liftExpInExp (patBinds p) e,
691 (ERel (patBinds p), loc)), loc))) 691 (ERel (patBinds p), loc)), loc)))
692 pes, 692 pes,
693 {disc = disc, result = result}), loc)) 693 {disc = disc, result = result}), loc))
754 EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE) 754 EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE)
755 (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) 755 (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
756 756
757 | ELet (x, t, e', b) => doLet (x, t, e', b) 757 | ELet (x, t, e', b) => doLet (x, t, e', b)
758 758
759 | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => 759 | EStrcat ((EPrim (Prim.String (k1, s1)), _), (EPrim (Prim.String (k2, s2)), _)) =>
760 EPrim (Prim.String (s1 ^ s2)) 760 EPrim (Prim.String ((case (k1, k2) of
761 (Prim.Html, Prim.Html) => Prim.Html
762 | _ => Prim.Normal), s1 ^ s2))
761 763
762 | ESignalBind ((ESignalReturn e1, loc), e2) => 764 | ESignalBind ((ESignalReturn e1, loc), e2) =>
763 #1 (reduceExp env (EApp (e2, e1), loc)) 765 #1 (reduceExp env (EApp (e2, e1), loc))
764 766
765 | _ => e 767 | _ => e