Mercurial > urweb

comparison src/mono_reduce.sml @ 183:c0ea24dcb86f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Optimizing 'case' in Mono_reduce
author Adam Chlipala <adamc@hcoop.net>
date Sun, 03 Aug 2008 13:30:27 -0400
parents 25b169416ea8
children 98c29e3986d3
comparison
equal deleted inserted replaced
182:d11754ffe252 183:c0ea24dcb86f
61 | (ctx, _) => ctx} 61 | (ctx, _) => ctx}
62 62
63 fun bind (env, b) = 63 fun bind (env, b) =
64 case b of 64 case b of
65 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs 65 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
66 | U.Decl.RelE (x, t) => E.pushERel env x t 66 | U.Decl.RelE (x, t) => E.pushERel env x t NONE
67 | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s 67 | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s
68 68
69 fun typ c = c 69 fun typ c = c
70 70
71 fun match (env, p : pat, e : exp) =
72 case (#1 p, #1 e) of
73 (PWild, _) => SOME env
74 | (PVar (x, t), _) => SOME (E.pushERel env x t (SOME e))
75
76 | (PPrim p, EPrim p') =>
77 if Prim.equal (p, p') then
78 SOME env
79 else
80 NONE
81
82 | (PCon (PConVar n1, NONE), ECon (n2, NONE)) =>
83 if n1 = n2 then
84 SOME env
85 else
86 NONE
87
88 | (PCon (PConVar n1, SOME p), ECon (n2, SOME e)) =>
89 if n1 = n2 then
90 match (env, p, e)
91 else
92 NONE
93
94 | (PRecord xps, ERecord xes) =>
95 let
96 fun consider (xps, env) =
97 case xps of
98 [] => SOME env
99 | (x, p, _) :: rest =>
100 case List.find (fn (x', _, _) => x' = x) xes of
101 NONE => NONE
102 | SOME (_, e, _) =>
103 case match (env, p, e) of
104 NONE => NONE
105 | SOME env => consider (rest, env)
106 in
107 consider (xps, env)
108 end
109
110 | _ => NONE
111
71 fun exp env e = 112 fun exp env e =
72 case e of 113 case e of
73 ENamed n => 114 ERel n =>
115 (case E.lookupERel env n of
116 (_, _, SOME e') => #1 e'
117 | _ => e)
118 | ENamed n =>
74 (case E.lookupENamed env n of 119 (case E.lookupENamed env n of
75 (_, _, SOME e', _) => #1 e' 120 (_, _, SOME e', _) => #1 e'
76 | _ => e) 121 | _ => e)
77 122
78 | EApp ((EAbs (_, _, _, e1), loc), e2) => 123 | EApp ((EAbs (_, _, _, e1), loc), e2) =>
79 #1 (reduceExp env (subExpInExp (0, e2) e1)) 124 #1 (reduceExp env (subExpInExp (0, e2) e1))
125
126 | ECase (disc, pes, t) =>
127 (case ListUtil.search (fn (p, body) =>
128 case match (env, p, disc) of
129 NONE => NONE
130 | SOME env => SOME (#1 (reduceExp env body))) pes of
131 NONE => e
132 | SOME e' => e')
80 133
81 | _ => e 134 | _ => e
82 135
83 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env 136 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
84 137