Mercurial > urweb

comparison src/reduce_local.sml @ 1062:3bc726a822fb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Shake bug fix; pattern reduction in ReduceLocal
author Adam Chlipala <adamc@hcoop.net>
date Tue, 08 Dec 2009 11:45:19 -0500
parents dfe34fad749d
children b2311dfb3158
comparison
equal deleted inserted replaced
1061:e8a35d710ab9 1062:3bc726a822fb
31 31
32 open Core 32 open Core
33 33
34 structure IM = IntBinaryMap 34 structure IM = IntBinaryMap
35 35
36 fun multiLiftExpInExp n e =
37 if n = 0 then
38 e
39 else
40 multiLiftExpInExp (n - 1) (CoreEnv.liftExpInExp 0 e)
41
36 datatype env_item = 42 datatype env_item =
37 Unknown 43 Unknown
38 | Known of exp 44 | Known of exp
39 45
40 | Lift of int 46 | Lift of int
41 47
42 type env = env_item list 48 type env = env_item list
43 49
44 val deKnown = List.filter (fn Known _ => false 50 val deKnown = List.filter (fn Known _ => false
45 | _ => true) 51 | _ => true)
52
53 datatype result = Yes of env | No | Maybe
54
55 fun match (env, p : pat, e : exp) =
56 let
57 val baseline = length env
58
59 fun match (env, p, e) =
60 case (#1 p, #1 e) of
61 (PWild, _) => Yes env
62 | (PVar (x, t), _) => Yes (Known (multiLiftExpInExp (length env - baseline) e) :: env)
63
64 | (PPrim p, EPrim p') =>
65 if Prim.equal (p, p') then
66 Yes env
67 else
68 No
69
70 | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) =>
71 if n1 = n2 then
72 Yes env
73 else
74 No
75
76 | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) =>
77 if n1 = n2 then
78 match (env, p, e)
79 else
80 No
81
82 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE),
83 ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) =>
84 if m1 = m2 andalso con1 = con2 then
85 Yes env
86 else
87 No
88
89 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep),
90 ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) =>
91 if m1 = m2 andalso con1 = con2 then
92 match (env, p, e)
93 else
94 No
95
96 | (PRecord xps, ERecord xes) =>
97 if List.exists (fn ((CName _, _), _, _) => false
98 | _ => true) xes then
99 Maybe
100 else
101 let
102 fun consider (xps, env) =
103 case xps of
104 [] => Yes env
105 | (x, p, _) :: rest =>
106 case List.find (fn ((CName x', _), _, _) => x' = x
107 | _ => false) xes of
108 NONE => No
109 | SOME (_, e, _) =>
110 case match (env, p, e) of
111 No => No
112 | Maybe => Maybe
113 | Yes env => consider (rest, env)
114 in
115 consider (xps, env)
116 end
117
118 | _ => Maybe
119 in
120 match (env, p, e)
121 end
46 122
47 fun exp env (all as (e, loc)) = 123 fun exp env (all as (e, loc)) =
48 case e of 124 case e of
49 EPrim _ => all 125 EPrim _ => all
50 | ERel n => 126 | ERel n =>
125 | PVar _ => 1 201 | PVar _ => 1
126 | PPrim _ => 0 202 | PPrim _ => 0
127 | PCon (_, _, _, NONE) => 0 203 | PCon (_, _, _, NONE) => 0
128 | PCon (_, _, _, SOME p) => patBinds p 204 | PCon (_, _, _, SOME p) => patBinds p
129 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts 205 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
130 in 206
131 (ECase (exp env e, 207 fun push () =
132 map (fn (p, e) => (p, 208 (ECase (exp env e,
133 exp (List.tabulate (patBinds p, fn _ => Unknown) @ env) e)) 209 map (fn (p, e) => (p,
134 pes, others), loc) 210 exp (List.tabulate (patBinds p,
211 fn _ => Unknown) @ env) e))
212 pes, others), loc)
213
214 fun search pes =
215 case pes of
216 [] => push ()
217 | (p, body) :: pes =>
218 case match (env, p, e) of
219 No => search pes
220 | Maybe => push ()
221 | Yes env' => exp env' body
222 in
223 search pes
135 end 224 end
136 225
137 | EWrite e => (EWrite (exp env e), loc) 226 | EWrite e => (EWrite (exp env e), loc)
138 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) 227 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
139 228