Skip to content
This repository
Newer
Older
100644 564 lines (528 sloc) 20.771 kb
fccc6851 » MLstate
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
19 (* depends *)
20 module List = BaseList
21
22 (* shorthands *)
23 module Q = QmlAst
24
25 let next =
26 let r = ref 0 in
27 fun () -> incr r; !r
28
29 module type S =
30 sig
31 type effect
32 val join_effect : effect -> effect -> effect
33 val effect_of : [`bypass of BslKey.t] -> effect
34 val no_effect : effect
35 val all_effects : effect
36 val to_string : effect -> string
37 end
38
39 module type E =
40 sig
41 type effect
42 type effects
43 type typ
44 val string_of_typ : typ -> string
45 val flatten_effect : effects -> effect
46
47 type env = (effects IdentMap.t * typ IdentMap.t)
48 val infer_code : ?initial_env:env -> (BslKey.t -> Q.ty) -> Q.code -> env
49 end
50
51 module EffectAnalysis(S:S) : E with type effect = S.effect =
52 struct
53 type level = int
54 type effect = S.effect
55 type var =
56 | Fresh of level ref * int
57 | Unified of typ
58 and typ =
59 | Var of var ref
60 | Dontcare
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
61 | Arrow of bool ref (* this boolean is really a hack
62 * because after lambda lifting we have
63 * poymorphic parameters and so we can't infer anymore
64 * this whole pass should really end up in the typer
65 *) * typ list * effects * typ
fccc6851 » MLstate
2011-06-21 Initial open-source release
66 and effects = effect * effect_var ref
67 and effect_var =
68 | EFresh of level ref * int
69 | EUnified of effects
70
71 let join_effects = S.join_effect
72
73 let rec flatten_effect_aux (eff, v) =
74 match !v with
75 | EFresh (_,v) -> eff, v
76 | EUnified (eff2, v2) -> flatten_effect_aux (join_effects eff eff2, v2)
77 let flatten_effect e = fst (flatten_effect_aux e)
78
79 let rec string_of_typ = function
80 | Var v ->
81 (match !v with
82 | Fresh (lev,_) -> "_" ^ string_of_int !lev
83 | Unified ty -> string_of_typ ty)
84 | Dontcare ->
85 "dontcare"
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
86 | Arrow ({contents=true},_,_,_) ->
87 string_of_typ Dontcare
88 | Arrow ({contents=false},tyl,e,ty) ->
fccc6851 » MLstate
2011-06-21 Initial open-source release
89 let sl = String.concat " -> " (List.map string_of_typ tyl) in
90 let s = string_of_typ ty in
91 let eff, var = flatten_effect_aux e in
92 "(" ^ sl ^ " " ^ string_of_int var ^ (S.to_string eff) ^ "->" ^ " " ^ s ^ ")"
93
94 let rec traverse_normalize tra = function
95 | Dontcare
96 | Var {contents = Fresh _ } as ty -> ty
97 | Var {contents = Unified ty} -> traverse_normalize tra ty
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
98 | Arrow ({contents=true},_,_,_) -> traverse_normalize tra Dontcare
99 | Arrow (ref_,typs,effects,typ) -> Arrow (ref_,List.map tra typs,traverse_normalize_eff effects,tra typ)
fccc6851 » MLstate
2011-06-21 Initial open-source release
100 and traverse_normalize_eff ((l,v) as p) =
101 match !v with
102 | EFresh _ -> p
103 | EUnified (l2,v2) -> traverse_normalize_eff (join_effects l l2, v2)
104 let shallow_normalize ty = traverse_normalize (fun x -> x) ty
105 let rec normalize ty = traverse_normalize normalize ty
106
107 let rec occur_check v = function
108 | Dontcare -> ()
109 | Var v' ->
110 if v == v' then failwith "Cyclic unification"
111 else
112 (match !v' with
113 | Fresh _ -> ()
114 | Unified ty -> occur_check v ty)
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
115 | Arrow ({contents=true},_,_,_) ->
116 occur_check v Dontcare
117 | Arrow ({contents=false},tyl,_,ty) ->
fccc6851 » MLstate
2011-06-21 Initial open-source release
118 List.iter (occur_check v) tyl;
119 occur_check v ty
120
121 let generic_level = -1
122
123 let rec set_max_level max_level = function
124 | Dontcare -> ()
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
125 | Arrow ({contents=true},_,_,_) -> set_max_level max_level Dontcare
126 | Arrow ({contents=false},tyl,_,ty) ->
fccc6851 » MLstate
2011-06-21 Initial open-source release
127 List.iter (set_max_level max_level) tyl;
128 set_max_level max_level ty
129 | Var v ->
130 match !v with
131 | Fresh (lev,_) ->
132 if !lev <> generic_level then
133 if !lev > max_level then
134 lev := max_level
135 | Unified ty -> set_max_level max_level ty
136
137 let rec unify ty1 ty2 =
138 if ty1 == ty2 then () else (
139 let ty1 = shallow_normalize ty1 in
140 let ty2 = shallow_normalize ty2 in
141 if ty1 == ty2 then () else (
142 match ty1, ty2 with
143 | Var v1, Var v2 ->
144 let lev1 = (match !v1 with Fresh (lev1, _) -> lev1 | _ -> assert false) in
145 let lev2 = (match !v2 with Fresh (lev2, _) -> lev2 | _ -> assert false) in
146 v2 := Unified ty1;
147 lev1 := min !lev1 !lev2
148 | Var v, ty
149 | ty, Var v ->
150 occur_check v ty;
151 set_max_level (match !v with Fresh (lev, _) -> !lev | _ -> assert false) ty;
152 v := Unified ty
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
153 | Arrow (ref1,tyl1,(l1, r1),ret1), Arrow (ref2,tyl2,(l2, r2),ret2) ->
154 assert (not !ref1 && not !ref2);
155 if List.length tyl1 = List.length tyl2 then (
156 let lev1 = (match !r1 with EFresh (r,_) -> !r | _ -> assert false) in
157 let lev2 = (match !r2 with EFresh (r,_) -> !r | _ -> assert false) in
158 let r3 = ref (EFresh (ref (min lev1 lev2), next())) in
159 r1 := EUnified (l2, r3);
160 r2 := EUnified (l1, r3);
161 List.iter2 unify tyl1 tyl2;
162 unify ret1 ret2
163 ) else (
164 (* see the comment about the meaning of the ref *)
165 ref1 := true;
166 ref2 := true;
167 )
fccc6851 » MLstate
2011-06-21 Initial open-source release
168 | Dontcare, Dontcare ->
169 ()
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
170 | Dontcare, Arrow ({contents=false},tyl,(_,r),ty)
171 | Arrow ({contents=false},tyl,(_,r),ty), Dontcare ->
fccc6851 » MLstate
2011-06-21 Initial open-source release
172 (*Printf.printf "Loss of precision: unifying %s and %s\n%!"
173 (string_of_typ ty1) (string_of_typ ty2);*)
174 (match !r with
175 | EFresh (lev,_) ->
176 let r2 = ref (EFresh (lev, next())) in
177 r := EUnified (S.all_effects, r2);
178 List.iter (unify Dontcare) tyl;
179 unify Dontcare ty
180 | _ -> assert false)
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
181 | _, Arrow ({contents=true},_,_,_)
182 | Arrow ({contents=true},_,_,_), _ ->
183 assert false
fccc6851 » MLstate
2011-06-21 Initial open-source release
184 )
185 )
186
187 let rec instantiate level ((varmap,effmap) as map) = function
188 | Dontcare -> map, Dontcare
189 | Var {contents = Fresh (this_level,i)} as ty ->
190 (try map, IntMap.find i varmap
191 with Not_found ->
192 if !this_level = generic_level then
193 let v = Var (ref (Fresh (ref level, next ()))) in
194 (IntMap.add i v varmap,effmap), v
195 else
196 map, ty)
197 | Var {contents = Unified ty} ->
198 instantiate level map ty
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
199 | Arrow ({contents=true},_,_,_) -> instantiate level map Dontcare
200 | Arrow ({contents=false},tyl,effects,ty) ->
fccc6851 » MLstate
2011-06-21 Initial open-source release
201 let map, tyl = List.fold_left_map (instantiate level) map tyl in
202 let (varmap, effmap), ty = instantiate level map ty in
203 let effmap, effects = instantiate_eff level effmap effects in
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
204 (varmap, effmap), Arrow (ref false, tyl, effects, ty)
fccc6851 » MLstate
2011-06-21 Initial open-source release
205 and instantiate_eff level effmap (l,v) =
206 match !v with
207 | EFresh (this_level,i) ->
208 (try effmap, (l, IntMap.find i effmap)
209 with Not_found ->
210 if !this_level = generic_level then
211 let v = ref (EFresh (ref level, next())) in
212 IntMap.add i v effmap, (l, v)
213 else
214 effmap, (l, v))
215 | EUnified (l2,v2) -> instantiate_eff level effmap (join_effects l l2, v2)
216 let instantiate level ty =
217 snd (instantiate level (IntMap.empty,IntMap.empty) ty)
218
219 let rec generalize level = function
220 | Var v ->
221 (match !v with
222 | Fresh (this_level,_) ->
223 if !this_level <> generic_level && !this_level > level then
224 this_level := generic_level
225 | Unified ty -> generalize level ty)
226 | Dontcare -> ()
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
227 | Arrow ({contents=true},_,_,_) -> generalize level Dontcare
228 | Arrow ({contents=false},tyl,effects,ty) ->
fccc6851 » MLstate
2011-06-21 Initial open-source release
229 List.iter (generalize level) tyl;
230 generalize level ty;
231 generalize_eff level effects
232 and generalize_eff level (_,v) =
233 match !v with
234 | EFresh (this_level,_) ->
235 if !this_level <> generic_level && !this_level > level then
236 this_level := generic_level
237 | EUnified eff -> generalize_eff level eff
238
239 let next_var level = Var (ref (Fresh (ref level, next())))
240 let next_eff_var level = ref (EFresh (ref level, next()))
241
242 let infer_pattern env p level =
243 QmlAstWalk.Pattern.fold_down
244 (fun env -> function
245 | Q.PatVar (_, i) | Q.PatAs (_, _, i) ->
246 IdentMap.add i (next_var level) env
247 | _ -> env) env p
248
249 let rec convert_type varmap level = function
250 | Q.TypeArrow (tyl,ty) ->
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
251 Arrow (ref false,List.map (convert_type varmap level) tyl, (S.no_effect, next_eff_var level), convert_type varmap level ty)
fccc6851 » MLstate
2011-06-21 Initial open-source release
252 | Q.TypeVar v ->
253 (try QmlTypeVars.TypeVarMap.find v !varmap
254 with Not_found ->
255 let v2 = next_var level in
256 varmap := QmlTypeVars.TypeVarMap.add v v2 !varmap;
257 v2)
258 | _ ->
259 Dontcare
260
261 (* need to know whether we are in covariant or contravariant positions
262 * but since no bypass ever returns a function, well ... *)
263 let rewrite_arrow level effect ty =
264 let varmap = ref QmlTypeVars.TypeVarMap.empty in
265 match ty with
266 | Q.TypeArrow (tyl,ty) ->
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
267 Arrow (ref false,List.map (convert_type varmap level) tyl, (effect, next_eff_var level), convert_type varmap level ty)
fccc6851 » MLstate
2011-06-21 Initial open-source release
268 | ty -> convert_type varmap level ty
269
270 let rec infer bp env effect level e =
271 try
272 let ty =
273 match e with
274 | Q.Const _ -> Dontcare
275 | Q.Ident (_, i) ->
276 (try instantiate level (IdentMap.find i env)
277 with Not_found -> Printf.printf "Not found %s\n%!"
278 (Ident.to_string i);
279 assert false)
280 | Q.LetIn (_, iel,e) ->
281 let env =
282 List.fold_left
283 (fun new_env (i,e) ->
284 let ty = infer bp env effect (level+1) e in
285 generalize level ty;
286 IdentMap.add i ty new_env) env iel in
287 infer bp env effect (level+1) e
288 | Q.LetRecIn (_, iel, e) ->
289 let itys = List.map (fun (i,_) -> (i,next_var (level+1))) iel in
290 let env = List.fold_left (fun env (i,ty) -> IdentMap.add i ty env) env itys in
291 let tys' = List.map (fun (_,e) -> infer bp env effect (level+1) e) iel in
292 List.iter2 (fun (_,ty) ty' -> unify ty ty') itys tys';
293 List.iter (generalize level) tys';
294 infer bp env effect (level+1) e
295 | Q.Lambda (_, sl, e) ->
296 let styl = List.map (fun s -> (s, next_var level)) sl in
297 let env =
298 List.fold_left
299 (fun env (s,ty) -> IdentMap.add s ty env) env styl in
300 let effect = next_eff_var level in
301 let ty = infer bp env effect (level+1) e in
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
302 Arrow (ref false,List.map snd styl, (S.no_effect,effect), ty)
fccc6851 » MLstate
2011-06-21 Initial open-source release
303 | Q.Directive (_, `partial_apply missing, [e], _) -> (
304 let missing = Option.get missing in
305 match e with
306 | Q.Apply (_, e, el) ->
307 (* no change on the current effect, since it is a partial
308 * application *)
309 let arrow_ty = infer bp env effect level e in
310 let tyl = List.map (infer bp env effect level) el in
311 let missing_types = List.init missing (fun _ -> next_var level) in
312 let ret_ty = next_var level in
313 let new_effect = (S.no_effect,next_eff_var level) in
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
314 unify (Arrow (ref false,tyl @ missing_types,new_effect,ret_ty)) arrow_ty;
315 Arrow (ref false,missing_types,new_effect,ret_ty)
fccc6851 » MLstate
2011-06-21 Initial open-source release
316 | _ -> assert false
317 )
318 | Q.Apply (_, e, el) ->
319 let arrow_ty = infer bp env effect (level+1) e in
320 let tyl = List.map (infer bp env effect (level+1)) el in
321 let ret_ty = next_var level in
8b6760be » Valentin Gatien-Baron
2011-06-15 [hack] qmlEffects: not failing when faced with type errors
322 unify (Arrow (ref false,tyl,(S.no_effect,effect),ret_ty)) arrow_ty;
fccc6851 » MLstate
2011-06-21 Initial open-source release
323 ret_ty
324 | Q.Match (_, e, pel) ->
325 (* not sure about that node *)
326 let ___TY = infer bp env effect (level+1) e in
327 let infer_rule env (p,e) =
328 let env = infer_pattern env p level in
329 infer bp env effect (level+1) e in
330 (match pel with
331 | [] -> assert false
332 | rule_ :: pel ->
333 let ty = infer_rule env rule_ in
334 List.iter
335 (fun rule_ ->
336 let ty' = infer_rule env rule_ in
337 unify ty ty')
338 pel;
339 ty)
340 | Q.Record (_, sel) ->
341 List.iter (fun (_s,e) -> ignore (infer bp env effect (level+1) e)) sel;
342 Dontcare
343 | Q.Dot (_, e, _s) ->
344 ignore (infer bp env effect (level+1) e);
345 Dontcare (* not quite good, will have troubles with higher order *)
346 | Q.ExtendRecord (_, _s, e1, e2) ->
347 ignore (infer bp env effect (level+1) e1);
348 ignore (infer bp env effect (level+1) e2);
349 Dontcare
350 | Q.Bypass (_, b) ->
351 (* call a bypass typer, and add side effect to the arrow *)
352 let qty = bp b in
353 let its_effect = S.effect_of (`bypass b) in
354 (*Format.printf "%s has type %a and effect %s@."
355 (BslKey.to_string b) QmlPrint.pp#ty qty (S.to_string its_effect);*)
356 rewrite_arrow level its_effect qty
357 | Q.Coerce (_, e, _) ->
358 infer bp env effect (level+1) e
359 | Q.Path (_, el, _) ->
360 List.iter (function
361 | Q.ExprKey e -> ignore (infer bp env effect (level+1) e)
362 | _ -> ()) el;
363 Dontcare
364 | Q.Directive (_, `fail, el, _) ->
365 List.iter (fun e -> ignore (infer bp env effect level e)) el;
366 next_var level
367 | Q.Directive (_, ( `restricted_bypass _
368 | `expanded_bypass
369 | #Q.type_directive
370 | `recval
371 | #Q.slicer_directive
372 | `partial_apply _
373 | `lifted_lambda _
374 | `full_apply _
375 | `assert_), l, _) -> (
376 match l with
377 | [e] -> infer bp env effect (level+1) e
378 | _ -> assert false
379 )
380 | Q.Directive (_, _, el, _) ->
381 (* there should be different categories here, we care about some directives
382 * and most of the time, the type is 'a -> 'a so we don't want to lose it! *)
383 List.iter (fun e -> ignore (infer bp env effect (level+1) e)) el;
384 Dontcare in
385 (*Format.printf "%a -> %s@." QmlPrint.pp#expr e (string_of_typ ty);*)
386 ty
387 with exn ->
388 let context = QmlError.Context.expr e in
389 QmlError.serror context "QmlEffect error@.";
390 raise exn
391
392 type env = (effects IdentMap.t * typ IdentMap.t)
393 let infer_code ?(initial_env=(IdentMap.empty, IdentMap.empty)) bp code =
394 List.fold_left
395 (fun ((_,env) as full_env) ->
396 function
397 | Q.NewVal (_,iel) ->
398 let level = 0 in
399 List.fold_left
400 (fun (env_effect,last_env) (i,e) ->
401 let effect = next_eff_var generic_level in
402 let ty = infer bp env effect (level+1) e in
403 generalize level ty;
404 let last_env = IdentMap.add i ty last_env in
405 let env_effect = IdentMap.add i (S.no_effect,effect) env_effect in
406 #<If:EFFECTS_SHOW> Printf.printf "%s has type %s with effect %s\n%!" (Ident.to_string i) (string_of_typ ty) (S.to_string (flatten_effect (S.no_effect,effect)))#<End>;
407 env_effect, last_env
408 ) full_env iel
409 | Q.NewValRec (_,iel) ->
410 let level = 0 in
411 let itys = List.map (fun (i,_) -> (i,next_var (level+1))) iel in
412 let full_env = List.fold_left (fun (env_effect,env) (i,ty) -> (env_effect,IdentMap.add i ty env)) full_env itys in
413 let full_env, tys' = List.fold_left_map
414 (fun (env_effect,env) (i,e) ->
415 let effect = next_eff_var generic_level in
416 let ty = infer bp env effect (level+1) e in
417 let env = IdentMap.add i ty env in
418 let env_effect = IdentMap.add i (S.no_effect,effect) env_effect in
419 (env_effect, env), ty
420 ) full_env iel in
421 List.iter2 (fun (_i,ty) ty' -> unify ty ty') itys tys';
422 List.iter (generalize level) tys';
423 #<If:EFFECTS_SHOW> List.iter (fun (i,ty) -> Printf.printf "%s has type %s\n%!" (Ident.to_string i) (string_of_typ ty)) itys#<End>;
424 full_env
425 | _ -> assert false
426 )
427 initial_env
428 code
429 end
430
431 let effect_of' = function
432 | `bypass s ->
433 (* FIXME: this reminds me the dark days when we have no bsl
434 and huge list of bypass floating around
435 it should be replaced by a bypass property
436 it affects the way bypass interacts slicer
437 two bypass with the exactly the same definition have different behaviour
438 which is totally misleading *)
439 match BslKey.to_string s with
440 | "bslpervasives_int_neg"
441 | "bslpervasives_int_add"
442 | "bslpervasives_int_sub"
443 | "bslpervasives_int_mul"
444 | "bslpervasives_int_div"
445 | "bslpervasives_float_neg"
446 | "bslpervasives_float_add"
447 | "bslpervasives_float_sub"
448 | "bslpervasives_float_mul"
449 | "bslpervasives_float_div"
450 | "bslstring_concat"
451 | "bslstring_of_int"
452 | "bsltime_local_format"
453 | "bslpervasives_compare_int"
454 | "bslpervasives_compare_string"
455 | "bslpervasives_compare_char"
456 | "bslpervasives_compare_float"
457 | "bslpervasives_int_cmp_eq"
458 | "bslpervasives_int_cmp_neq"
459 | "bslpervasives_int_cmp_leq"
460 | "bslpervasives_int_cmp_lneq"
461 | "bslpervasives_int_cmp_gneq"
462 | "bslpervasives_int_cmp_geq"
463 | "bslvalue_tsc_get"
464 | "bslpervasives_magic_id"
465 | "bslvalue_record_name_of_field"
466 | "bslvalue_record_field_of_name"
467 | "bslnumber_int_of_float"
468 | "bslnumber_int_of_string"
469 | "bslnumber_float_of_int"
470 | "bslpervasives_string_of_char"
471 | "bslnumber_float_to_string"
472 | "bslpervasives_dump"
473 | "bslvalue_record_fold_record"
474 | "bslvalue_record_fold_2_record"
475 | "bslvalue_record_empty_constructor"
476 | "bslvalue_record_add_field"
477 | "bslvalue_record_make_record"
478 | "bslvalue_record_make_simple_record"
479 | "bslnumber_math_abs_f"
480 | "bslnumber_math_abs_i"
481 | "bslnumber_math_acos"
482 | "bslnumber_math_asin"
483 | "bslnumber_math_atan"
484 | "bslnumber_math_ceil"
485 | "bslnumber_math_cos"
486 | "bslnumber_math_exp"
487 | "bslnumber_math_floor"
488 | "bslnumber_math_isnan"
489 | "bslnumber_math_is_infinite"
490 | "bslnumber_math_is_normal"
491 | "bslnumber_math_log"
492 | "bslnumber_math_sin"
493 | "bslnumber_math_sqrt_f"
494 | "bslnumber_math_sqrt_i"
495 | "bslnumber_math_tan"
496 | "bslnumber_int_ordering"
497 | "bslpervasives_webutils_server_side"
498 | "bslpervasives_aresameobject"
499 | "bslstring_check_match_literal"
500 | "bslstring_get"
501 | "bslpervasives_int_of_first_char"
502 | "bslnumber_int_op_asr"
503 | "bslnumber_int_op_lsr"
504 | "bslnumber_int_op_lsl"
505 | "bslnumber_int_op_lnot"
506 | "bslnumber_int_op_lxor"
507 | "bslnumber_int_op_lor"
508 | "bslnumber_int_op_land"
509 | "bslnumber_int_to_char"
510 | "bslpervasives_int_mod"
511 | "bslstring_sub"
512 | "bslstring_init" (* THIS ONE IS FALSE, no side effect if the given function
513 * has no side effect either *)
514 | "bslcactutf_cactutf_length"
515 | "bslstring_length"
516 | "sys_argv"
517 | "sys_argc"
518 ->
519 `pure
520
521 | "bsltime_now" ->
522 `read
523
524 | "bslpervasives_print_endline"
525 | "bslpervasives_print_string"
526 | "bslpervasives_prerr_string"
527 | "bslpervasives_print_int"
528 | "bslpervasives_jlog" ->
529 `write
530
531 | "bslreference_create" ->
532 `alloc
533
534 | "bslpervasives_error" -> (* accepting to clean errors *)
535 `error
536
537 | _ -> `impure
538
539 module SideEffectS =
540 struct
541 type effect = bool
542 let join_effect = (||)
543 let no_effect = false
544 let all_effects = true
545 let effect_of x =
546 match effect_of' x with
547 | `pure | `alloc | `read | `error -> false
548 | `impure | `write -> true
549 let to_string = function
550 | true -> "+"
551 | false -> ""
552 end
553
554 module SlicerEffectS =
555 struct
556 include SideEffectS
557 let effect_of x =
558 match effect_of' x with
559 | `pure | `write | `error -> false
560 | `impure | `alloc | `read -> true
561 end
562
563 module SideEffect = EffectAnalysis(SideEffectS)
564 module SlicerEffect = EffectAnalysis(SlicerEffectS)
Something went wrong with that request. Please try again.