Skip to content
This repository
Newer
Older
100644 220 lines (204 sloc) 7.618 kb
fccc6851 »
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 module Q = QmlAst
19 module List = Base.List
20
21 type env = Q.pat IdentMap.t
22 type ignored_directive = [ Q.type_directive | Q.slicer_directive ]
23
24 module S =
25 struct
26 type t = (QmlAst.annotmap * env)
27 let pass = "pass_SimplifyEquality"
28 let pp f (_,map) =
29 IdentMap.iter
30 (fun k v ->
31 Format.fprintf f "@[<2>%s -> %a@]@\n" (Ident.to_string k) QmlPrint.pp#pat v
32 ) map
33 end
34
35 module R =
36 struct
37 include ObjectFiles.Make(S)
38 let save ~loaded_env ~env ~annotmap =
39 let diff = IdentMap.diff env loaded_env in
40 let small_annotmap = QmlRefresh.restrict_annotmap_fold_pat
41 (fun r acc map ->
42 IdentMap.fold
43 (fun _ pat acc ->
44 r acc pat
45 ) map acc
46 ) annotmap diff in
47 save (small_annotmap, diff)
48 let load annotmap =
49 fold_with_name
50 (fun package (annotmap,env) (annotmap_old,map) ->
51 let annotmap_old = QmlRefresh.refresh_annotmap package annotmap_old in
52 IdentMap.fold
53 (fun k pat (annotmap,env) ->
54 let annotmap, pat = QmlRefresh.refresh_pat package ~annotmap_old annotmap pat in
55 annotmap, IdentMap.add k pat env
56 ) map (annotmap,env)
57 ) (annotmap,IdentMap.empty)
58 end
59
60 (* FIXME: when the pattern ast is better, we won't need the annotmap here *)
61 let rec pattern_of_expr env annotmap = function
62 | Q.Ident (_, i) -> (
63 let previous =
64 try
65 IdentMap.find i env
66 with
67 | Not_found -> raise Exit
68 in
69 QmlAstCons.TypedPat.copy annotmap previous
70 )
71 | Q.Const (label, const_expr) ->
72 (* not rewriting a == 0 into match a with 0 -> ...*)
73 annotmap, Q.PatConst (label, const_expr)
74 | Q.Coerce (_, e, _)
75 | Q.Directive (_, #ignored_directive, [e], _) ->
76 pattern_of_expr env annotmap e
77 | Q.Record (_label, sel) ->
78 let annotmap, spl = List.fold_left_map
79 (fun annotmap (s, e) ->
80 let annotmap, p = pattern_of_expr env annotmap e in
81 annotmap, (s, p)) annotmap sel in
82 QmlAstCons.TypedPat.record annotmap spl
83 | _ -> raise Exit
84 let pattern_of_expr env annotmap e = pattern_of_expr env annotmap e
85
86 let rec is_patemptyrecord = function
87 | Q.PatCoerce (_, e, _) -> is_patemptyrecord e
88 | Q.PatRecord (_, [], _) -> true
89 | _ -> false
90 let rec is_simple_patrecord = function
91 | Q.PatCoerce (_, e, _) -> is_simple_patrecord e
92 | Q.PatRecord (_, [field_name, field_value], `closed) ->
93 if is_patemptyrecord field_value then Some field_name else None
94 | _ -> None
95 let rec get_name = function
96 | Q.Coerce (_, e, _)
97 | Q.Directive (_, #ignored_directive, [e], _) -> get_name e
98 | Q.Ident (_, i) -> Some i
99 | _ -> None
100
101 let generate_match ?e1 ?e2 gamma annotmap kind expr pat =
102 let annotmap, any = QmlAstCons.TypedPat.any annotmap in
103 let annotmap, e1 =
104 match e1 with
105 | None -> QmlAstCons.TypedExpr._true (annotmap,gamma)
106 | Some e1 -> annotmap, e1 in
107 let annotmap, e2 =
108 match e2 with
109 | None -> QmlAstCons.TypedExpr._false (annotmap,gamma)
110 | Some e2 -> annotmap, e2 in
111 let e1, e2 =
112 match kind with
113 | `equality -> e1, e2
114 | `inequality -> e2, e1 in
115 QmlAstCons.TypedExpr.match_ annotmap expr [pat, e1; any, e2]
116
117 let rec match_equality_to_record env annotmap equality_ident inequality_ident = function
118 | Q.Coerce (_, e, _)
119 | Q.Directive (_, #Q.type_directive, [e], _) -> match_equality_to_record env annotmap equality_ident inequality_ident e
120 | Q.Apply (_, Q.Ident (_, i), [e1;e2]) ->
121 let ident =
122 if Ident.equal i equality_ident then
123 Some `equality
124 else if Ident.equal i inequality_ident then
125 Some `inequality
126 else
127 None in (
128 match ident with
129 | Some kind -> (
130 try
131 let annotmap, p = pattern_of_expr env annotmap e1 in
132 Some (annotmap, kind, e2, p)
133 with Exit ->
134 try
135 let annotmap, p = pattern_of_expr env annotmap e2 in
136 Some (annotmap, kind, e1, p)
137 with Exit ->
138 None
139 )
140 | None -> None
141 )
142 | _ -> None
143
144 let update_env env annotmap iel =
145 List.fold_left
146 (fun (env, annotmap) (i, e) ->
147 try
148 let annotmap, p = pattern_of_expr env annotmap e in
149 IdentMap.add i p env, annotmap
150 with Exit ->
151 match get_name e with
152 | Some j -> (
153 try (IdentMap.add i (IdentMap.find j env) env, annotmap)
154 with Not_found -> (env, annotmap)
155 )
156 | None ->
157 (env, annotmap)
158 ) (env, annotmap) iel
159
160 let rewrite_equality_expr equality_ident inequality_ident gamma acc e =
161 let aux self tra env acc e =
162 match e with
163 | Q.LetIn (_, iel, _)
164 | Q.LetRecIn (_, iel, _) ->
165 let env, acc = update_env env acc iel in
166 tra env acc e
167 | Q.Match (_, e0, [p1,e1; p2,e2]) ->
168 (match is_simple_patrecord p1, is_simple_patrecord p2 with
169 | Some "true", Some "false" ->
170 (match match_equality_to_record env acc equality_ident inequality_ident e0 with
171 | None -> tra env acc e
172 | Some (acc, kind, e, p) ->
173 let acc, e = generate_match gamma ~e1 ~e2 acc kind e p in
174 self env acc e
175 )
176 | _ -> tra env acc e)
177 | _ ->
178 match match_equality_to_record env acc equality_ident inequality_ident e with
179 | None -> tra env acc e
180 | Some (acc, kind, e, p) ->
181 let acc, e = generate_match gamma acc kind e p in
182 self env acc e
183 in
184 QmlAstWalk.Expr.self_traverse_foldmap_context_down aux acc e
185
186 let rewrite_equality equality_ident inequality_ident env gamma annotmap code =
187 List.fold_left_map
188 (fun (env,acc) -> function
189 | Q.NewVal (label,iel)
190 | Q.NewValRec (label,iel) as c ->
191 let env, acc = update_env env acc iel in
192 let acc, iel =
193 List.fold_left_map
194 (fun acc (i,e) ->
195 let acc, e = rewrite_equality_expr equality_ident inequality_ident gamma env acc e in
196 acc, (i,e)) acc iel in
197 (match c with
198 | Q.NewVal _ -> (env, acc), Q.NewVal (label, iel)
199 | Q.NewValRec _ -> (env, acc), Q.NewValRec (label, iel)
200 | _ -> assert false)
201 | c -> (env, acc), c) (env,annotmap) code
202
203 let process_code val_ gamma annotmap code =
204 #<If:SIMPLIFYMAGIC_DISABLE>
205 annotmap, code
206 #<Else>
207 try
208 let annotmap, loaded_env = R.load annotmap in
209 let equality_ident = val_ Opacapi.(==) in
210 let inequality_ident = val_ Opacapi.(!=) in
211 let (env, annotmap), code = rewrite_equality equality_ident inequality_ident loaded_env gamma annotmap code in
212 R.save ~loaded_env ~env ~annotmap;
213 annotmap, code
214 with
215 | Not_found (* no equality *)
216 | QmlTyperException.Exception _ (* no boolean type *) ->
217 R.save ~loaded_env:IdentMap.empty ~env:IdentMap.empty ~annotmap;
218 annotmap, code
219 #<End>
Something went wrong with that request. Please try again.