Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 376 lines (332 sloc) 10.145 kb
fccc685 Initial open-source release
MLstate authored
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 (*
19 @author Esther Baruk
20 @author Mathieu Barbin
21 **)
22
23 (* See documentation about this module in .mli *)
24
25 (* depends *)
26 let (|>) = InfixOperator.(|>)
27
28 (* shorthands *)
29 (* FIXME, replace by
30 module O = OcamlAst
31 *)
32 module O = Ocaml
33
34 (* -- *)
35
36 module App =
37 struct
38 let nary_app a b =
39 let rec aux acc a =
40 match a with
41 | O.App (c, d) ->
42 aux (d::acc) c
43 | _ -> a, acc
44 in
45 aux [b] a
46
47 let app f args =
48 List.fold_left (fun acc e -> O.App (acc, e)) f args
49 end
50
51 module Array =
52 struct
53 let relax_make a =
54 let l = match a with O.AnArray l -> l | _ -> assert false in
55 let n = List.length l in
56 let t = Ocaml.make_Var "t" in
57 let array_creation =
58 O.Cons.app3
59 (O.make_Varl ["Array"; "make"])
60 (O.Const (O.Int n))
61 (O.make_magic (O.Const (O.Int 0))) in
62 let array_filling =
63 Base.List.mapi (fun i x -> O.make_array_unsafe_set_no_magic i t x) l
64 in
65 let sequence =
66 let rec aux = function
67 | [x] -> x
68 | hd :: tl ->
69 O.Sequence(hd, aux tl)
70 | [] -> assert false
71 in
72 aux array_filling
73 in
74 let expr = O.make_Letin (O.Pat (O.PatVar (Ident.source "_"))) sequence t in
75 O.make_Letin (O.Pat (O.PatVar (Ident.source "t"))) array_creation expr
76 end
77
78 type filename = string
79 type module_name = string
80
81 module Module =
82 struct
83 type path = module_name list
84
85 let of_filename filename =
86 filename
87 |> Filename.basename
88 |> File.chop_extension
89 |> String.capitalize
90
91
92 let module_path ~full ~pwd =
93 let rec link = function
94 | [], _ -> []
95 | l, [] -> l
96 | (a::b) as pf, u::v ->
97 if String.compare a u <> 0 then pf
98 else link (b, v) in
99 link (full, pwd)
100 end
101
102 (* TODO organize !!! *)
103 (*
104 (* Transcript the type to a qml-well-parsed type in a generation of qml-code *)
105
461365b [cleanup] Base.String: changed String.split to a much simpler String.sli...
Louis Gesbert authored
106 let module_spliter = String.slice_chars "~/,.#"
fccc685 Initial open-source release
MLstate authored
107
108 let ocaml_module_path_manager_from_string full pwd =
109 let pfull = module_spliter full and ppwd = module_spliter pwd in
110 let t = ocaml_module_path_manager pfull ppwd in
111 String.concat "." t
112
113 type type_path_map = (string * string list * BslTypes.t) BslKeyMap.t
114
115
116
117
118 let to_ocaml_coercion ?(type_path_map=BslKeyMap.empty) ?(current_path=[]) =
119 let ocaml_prefix n =
120 match BslKeyMap.find_opt (BslKey.of_string n) type_path_map with
121 | Some (_, full, _) ->
122 begin
123 let link = ocaml_module_path_manager full current_path in
124 match List.rev link with
125 | t::q -> String.concat "." ((List.rev_map String.capitalize q)@[t])
126 | [] -> n
127 end
128 | None -> n in
129
130
131 *)
132
133 (* ===== Code optimization ===== *)
134
135 open Ocaml (* FIXME, when we switch to ocaml 3.12, use the local open construct *)
136
137 (*
138 FIXME, use dump-printing instead of this...
139 let pattern2str = function
140 | PatVar _ -> "PatVar"
141 | PatPair _ -> "PatPair"
142 | PatList _ -> "PatList"
143 | PatEmptyList -> "PatEmptyList"
144 | PatRecord _ -> "PatRecord"
145 | PatConstructor _ -> "PatConstructor"
146 | PatVariant _ -> "PatVariant"
147 | PatPVariant _ -> "PatPVariant"
148 | PatConst _ -> "PatConst"
149 | PatAny -> "PatAny"
150 | PatGuard _ -> "PatGuard"
151 | PatAnnot _ -> "PatAnnot"
152 | PatAs _ -> "PatAs"
153 | PatArray _ -> "PatArray"
154
155 let expr2str = function
156 | Var _ -> "Var"
157 | Pair _ -> "Pair"
158 | Verbatim _ -> "Verbatim"
159 | Constructor _ -> "Constructor"
160 | _ -> "?"
161 *)
162
163 let normalize_expr = function
164 | (Constructor (_, [])) as e -> e
165 | (Constructor (_, [Tuple _])) as e -> e
166 | Constructor (c, ps) ->
167 Constructor (c, [Tuple ps])
168 | e -> e
169
170 let normalize_pattern = function
171 | (PatConstructor (_, [])) as e -> e
172 | (PatConstructor (_, [PatTuple _])) as e -> e
173 | PatConstructor (c, pps) ->
174 PatConstructor (c, [PatTuple pps])
175 | p -> p
176
177 let ident = BaseString.concat_map "." (fun i -> i)
178
179 let rec trivial_pattern (p, e) =
180 let res =
181 match p, e with
182 | PatVar pv, Verbatim v ->
183 (* FIXME, hackish; preferrably get rid of Verbatim & properly parse Ocaml snippets in TRX *)
184 let vt = Base.String.trim v in
185 let pv = OcamlPrint.ident pv in
186 pv = vt || Printf.sprintf "( %s )" pv = vt
187 | PatVar pv, Var (Pated ([v], _)) -> pv = v
188 | PatEmptyList, EmptyList -> true
189 | PatList (phd, ptl), Cons (hd, tl) -> trivial_pattern (phd, hd) && trivial_pattern (ptl, tl)
190 | PatConstructor (pc, pps), Constructor (c, ps) ->
191 List.make_compare Ident.compare pc c = 0 && List.for_all trivial_pattern (List.combine pps ps)
192 | PatTuple ps, Tuple es -> List.length ps = List.length es && List.for_all trivial_pattern (List.combine ps es)
193 (* FIXME, handle remaining cases *)
194 | _ -> false
195 in
196 (*
197 Printf.eprintf "\n[%s | %s | " (pattern2str p) (expr2str e);
198 OcamlPrint.Output.pattern stderr p;
199 Printf.eprintf " VS ";
200 OcamlPrint.Output.expr stderr e;
201 Printf.eprintf "] -> %b " res;
202 *)
203 res
204
205 let optimize_match ~only_trivial e ps =
206 let analyze_pattern (pats, all_trivial) ((pat, guard, expr) as match_case) =
207 let case, all_trivial' =
208 if Option.is_none guard && trivial_pattern (pat, expr) then
209 let pat_var = Ident.source "__pat_var" in
210 let underscore_pattern =
211 OcamlWalk.Pat.map (fun p ->
212 match p with
213 | PatVar s -> PatVar (Ident.source ("_" ^ (OcamlPrint.ident s)))
214 | _ -> p)
215 in
216 (PatAs (underscore_pattern pat, pat_var), None, Ocaml.Cons.var pat_var), all_trivial
217 else
218 match_case, false
219 in
220 case::pats, all_trivial'
221 in
222 let ps', all_trivial = List.fold_left analyze_pattern ([], true) ps in
223 let optimized =
224 if all_trivial then
225 e
226 else if only_trivial then
227 Match (e, ps)
228 else
229 Match (e, List.rev ps')
230 in
231 (*
232 if v' <> None then begin
233 Printf.eprintf "************** Optimizing\n";
234 OcamlPrint.Output.expr stderr (Match (e, ps));
235 Printf.eprintf "\ninto:\n";
236 OcamlPrint.Output.expr stderr optimized;
237 Printf.eprintf "\n\n"
238 end;
239 *)
240 optimized
241
242 let corresponds p e =
243 let rec map_args = function
244 | [], [] -> Some IdentMap.empty
245 | p::ps, e::es ->
246 begin match map_args (ps, es) with
247 | None -> None
248 | Some m ->
249 match p, e with
250 | PatTuple ps, Tuple es ->
251 map_args (ps, es)
252 | PatVar pv, e ->
253 if IdentMap.mem pv m then
254 None
255 else
256 Some (IdentMap.add pv e m)
257 | _ -> None
258 end
259 | _ -> None
260 in
261 let res =
262 match p, e with
263 | PatConstructor (pc, pps), Constructor (c, ps) ->
264 if List.make_compare Ident.compare c pc = 0 then
265 map_args (pps, ps)
266 else
267 None
268 | _ -> None
269 in
270 (*
271 Printf.eprintf "Corresponds: ";
272 OcamlPrint.Output.pattern stderr p;
273 Printf.eprintf " with ";
274 OcamlPrint.Output.expr stderr e;
275 Printf.eprintf " => %s\n" (if res <> None then "YES" else "NO");
276 *)
277 res
278
279 let inst exp m =
280 let add_mapping v e expr =
281 Ocaml.make_Letin (Ocaml.Cons.param v) e expr
282 in
283 IdentMap.fold add_mapping m exp
284
285 let rec optimize_expr ~phase e =
286 let show _str _res = ()
287 (*
288 Printf.eprintf "***** %s *****\n" _str;
289 OcamlPrint.Output.expr stderr e;
290 Printf.eprintf " --> ";
291 OcamlPrint.Output.expr stderr _res;
292 Printf.eprintf "\n%!"
293 *)
294 in
295 let simplify1 = function
296 | Match (me, ps) -> optimize_match ~only_trivial:true me ps
297 | _ -> e
298 in
299 let simplify2 = function
300 | Match (Match (me, [(p1, None, r1); (p2, None, r2)]), [(p3, None, r3); (p4, None, r4)]) ->
301 begin match corresponds p3 r1, corresponds p4 r2 with
302 | Some m1, Some m2 ->
303 let res = Match (me, [(p1, None, inst r3 m1); (p2, None, inst r4 m2)]) in
304 res
305 | _ ->
306 match corresponds p4 r1, corresponds p3 r2 with
307 | Some m1, Some m2 ->
308 let res = Match (me, [(p1, None, inst r4 m1); (p2, None, inst r3 m2)]) in
309 res
310 | _ -> e
311 end
312 | e -> e
313 in
314 let simplify3 = function
315 | Match (me, ps) -> optimize_match ~only_trivial:false me ps
316 | _ -> e
317 in
318 match phase with
319 | `P1 ->
320 let e2 = simplify1 e in
321 if e <> e2 then show "simplify1" e2;
322 e2
323 | `P2 ->
324 let e2 = simplify2 e in
325 if e <> e2 then show "simplify2" e2;
326 let e3 = simplify3 e2 in
327 if e2 <> e3 then show "simplify3" e3;
328 e3
329
330 let optimize c =
331 let c = OcamlWalk.PatExpr.map_code normalize_expr normalize_pattern c in
332 let rec fix f a =
333 let res = f a in
334 if res = a then
335 a
336 else
337 fix f res
338 in
339 let optimize_with f c = fix (List.map (OcamlWalk.Expr.map f)) c in
340 let c = optimize_with (optimize_expr ~phase:`P1) c in
341 let c = optimize_with (optimize_expr ~phase:`P2) c in
342 c
343
344 module Misc =
345 struct
346 let size e =
347 OcamlWalk.Expr.fold (fun acc _ -> acc + 1) 0 e
348 end
349
350 module Deps =
351 struct
352 let deps add_ident acc e =
353 OcamlWalk.Expr.fold
354 (fun acc -> function
355 | Var (Labeled (_, Some _)) -> acc
356 | Var s -> add_ident s acc
357 | _ -> acc) acc e
358 end
359
360 (*
361 Keep this module at end, because it hides the module Ident from compiler lib
362 *)
363 module Ident =
364 struct
365
366 let is_operator = function
367 | "or" | "mod" | "land" | "lor" | "lxor" | "lsl" | "lsr" | "asr" -> true
368 | "" -> false
369 | s -> (
370 match s.[0] with
371 | '_' | 'a'..'z' -> false
372 | 'A'..'Z' | '0'..'9' -> false
373 | _ -> true
374 )
375 end
Something went wrong with that request. Please try again.