Mercurial > urweb

comparison src/mono_reduce.sml @ 252:7e9bd70ad3ce

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Monoized and optimized initial query test
author Adam Chlipala <adamc@hcoop.net>
date Sun, 31 Aug 2008 13:58:47 -0400
parents 8e9f97508f0d
children 7f6620853c36
comparison
equal deleted inserted replaced
251:326fb4686f60 252:7e9bd70ad3ce
32 open Mono 32 open Mono
33 33
34 structure E = MonoEnv 34 structure E = MonoEnv
35 structure U = MonoUtil 35 structure U = MonoUtil
36 36
37 val liftExpInExp = 37
38 U.Exp.mapB {typ = fn t => t, 38 fun impure (e, _) =
39 exp = fn bound => fn e => 39 case e of
40 case e of 40 EWrite _ => true
41 ERel xn => 41 | EQuery _ => true
42 if xn < bound then 42 | EAbs _ => false
43 e 43
44 else 44 | EPrim _ => false
45 ERel (xn + 1) 45 | ERel _ => false
46 | _ => e, 46 | ENamed _ => false
47 bind = fn (bound, U.Exp.RelE _) => bound + 1 47 | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e)
48 | (bound, _) => bound} 48 | EFfi _ => false
49 49 | EFfiApp _ => false
50 val subExpInExp = 50 | EApp ((EFfi _, _), _) => false
51 | EApp _ => true
52
53 | ERecord xes => List.exists (fn (_, e, _) => impure e) xes
54 | EField (e, _) => impure e
55
56 | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
57
58 | EStrcat (e1, e2) => impure e1 orelse impure e2
59
60 | ESeq (e1, e2) => impure e1 orelse impure e2
61 | ELet (_, _, e1, e2) => impure e1 orelse impure e2
62
63 | EClosure (_, es) => List.exists impure es
64
65
66 val liftExpInExp = Monoize.liftExpInExp
67
68 val subExpInExp' =
51 U.Exp.mapB {typ = fn t => t, 69 U.Exp.mapB {typ = fn t => t,
52 exp = fn (xn, rep) => fn e => 70 exp = fn (xn, rep) => fn e =>
53 case e of 71 case e of
54 ERel xn' => 72 ERel xn' =>
55 (case Int.compare (xn', xn) of 73 (case Int.compare (xn', xn) of
58 | LESS => e) 76 | LESS => e)
59 | _ => e, 77 | _ => e,
60 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) 78 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
61 | (ctx, _) => ctx} 79 | (ctx, _) => ctx}
62 80
63 fun bind (env, b) = 81 fun subExpInExp (n, e1) e2 =
64 case b of 82 let
65 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs 83 val r = subExpInExp' (n, e1) e2
66 | U.Decl.RelE (x, t) => E.pushERel env x t NONE 84 in
67 | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s 85 (*Print.prefaces "subExpInExp" [("e1", MonoPrint.p_exp MonoEnv.empty e1),
86 ("e2", MonoPrint.p_exp MonoEnv.empty e2),
87 ("r", MonoPrint.p_exp MonoEnv.empty r)];*)
88 r
89 end
68 90
69 fun typ c = c 91 fun typ c = c
70 92
71 fun match (env, p : pat, e : exp) = 93 fun match (env, p : pat, e : exp) =
72 case (#1 p, #1 e) of 94 case (#1 p, #1 e) of
130 | ENamed n => 152 | ENamed n =>
131 (case E.lookupENamed env n of 153 (case E.lookupENamed env n of
132 (_, _, SOME e', _) => #1 e' 154 (_, _, SOME e', _) => #1 e'
133 | _ => e) 155 | _ => e)
134 156
135 | EApp ((EAbs (_, _, _, e1), loc), e2) => 157 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
136 #1 (reduceExp env (subExpInExp (0, e2) e1)) 158 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp env e1),
159 ("e2", MonoPrint.p_exp env e2)];*)
160 if impure e2 then
161 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
162 else
163 #1 (reduceExp env (subExpInExp (0, e2) e1)))
137 164
138 | ECase (disc, pes, _) => 165 | ECase (disc, pes, _) =>
139 (case ListUtil.search (fn (p, body) => 166 (case ListUtil.search (fn (p, body) =>
140 case match (env, p, disc) of 167 case match (env, p, disc) of
141 NONE => NONE 168 NONE => NONE
142 | SOME env => SOME (#1 (reduceExp env body))) pes of 169 | SOME env => SOME (#1 (reduceExp env body))) pes of
143 NONE => e 170 NONE => e
144 | SOME e' => e') 171 | SOME e' => e')
145 172
173 | EField ((ERecord xes, _), x) =>
174 (case List.find (fn (x', _, _) => x' = x) xes of
175 SOME (_, e, _) => #1 e
176 | NONE => e)
177
178 | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
179 let
180 val e' = (ELet (x2, t2, e1,
181 (ELet (x1, t1, b1,
182 liftExpInExp 1 b2), loc)), loc)
183 in
184 Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
185 ("e'", MonoPrint.p_exp env e')];
186 #1 (reduceExp env e')
187 end
188 | EApp ((ELet (x, t, e, b), loc), e') =>
189 #1 (reduceExp env (ELet (x, t, e,
190 (EApp (b, liftExpInExp 0 e'), loc)), loc))
191 | ELet (x, t, e', b) =>
192 if impure e' then
193 e
194 else
195 #1 (reduceExp env (subExpInExp (0, e') b))
196
146 | _ => e 197 | _ => e
147 198
199 and bind (env, b) =
200 case b of
201 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
202 | U.Decl.RelE (x, t) => E.pushERel env x t NONE
203 | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s
204
148 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env 205 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
149 206
150 fun decl env d = d 207 fun decl env d = d
151 208
152 val reduce = U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty 209 val reduce = U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty