Commit 44f44412 by Raphael Rieu-Helft

### Add a debug flag to get profiling data on the interpreter

parent 00755d2d
 ... @@ -920,7 +920,7 @@ let rmul (a b:t) ... @@ -920,7 +920,7 @@ let rmul (a b:t) = (from_int n1 *. from_int n2) /. (from_int d1 *. from_int d2) = (from_int n1 *. from_int n2) /. (from_int d1 *. from_int d2) = (from_int n1 /. from_int d1) *. (from_int n2 /. from_int d2) = (from_int n1 /. from_int d1) *. (from_int n2 /. from_int d2) = rinterp a y *. rinterp b y }; = rinterp a y *. rinterp b y }; simp r r end end end end ... @@ -945,6 +945,12 @@ let rinv (a:t) ... @@ -945,6 +945,12 @@ let rinv (a:t) | (n,d) -> if n = 0 || d = 0 then raise QError else (d,n) | (n,d) -> if n = 0 || d = 0 then raise QError else (d,n) end end let is_zero (a:t) ensures { result <-> req a rzero } = match a with | (n,d) -> n = 0 && d <> 0 end end end module LinearDecisionRational module LinearDecisionRational ... @@ -1251,8 +1257,8 @@ let madd (a b:t) ... @@ -1251,8 +1257,8 @@ let madd (a b:t) raises { Q.QError -> true } raises { Q.QError -> true } = match a, b with = match a, b with | (q1, e1), (q2, e2) -> | (q1, e1), (q2, e2) -> if Q.req q1 Q.rzero then b if Q.is_zero q1 then b else if Q.req q2 Q.rzero then a else if Q.is_zero q2 then a else if same_exp e1 e2 else if same_exp e1 e2 then begin then begin let q = Q.radd q1 q2 in let q = Q.radd q1 q2 in ... @@ -1273,7 +1279,7 @@ let mmul (a b:t) ... @@ -1273,7 +1279,7 @@ let mmul (a b:t) = match a, b with = match a, b with | (q1,e1), (q2,e2) -> | (q1,e1), (q2,e2) -> let q = Q.rmul q1 q2 in let q = Q.rmul q1 q2 in if Q.req q Q.rzero then mzero if Q.is_zero q then mzero else begin else begin let e = add_exp e1 e2 in let e = add_exp e1 e2 in assert { forall y. minterp (q,e) y = minterp a y *. minterp b y assert { forall y. minterp (q,e) y = minterp a y *. minterp b y ... @@ -1310,7 +1316,7 @@ let rec predicate pure_same_exp (e1 e2: exp) ... @@ -1310,7 +1316,7 @@ let rec predicate pure_same_exp (e1 e2: exp) let predicate meq (a b:t) let predicate meq (a b:t) ensures { result -> forall y. minterp a y = minterp b y } ensures { result -> forall y. minterp a y = minterp b y } = match (a,b) with = match (a,b) with | (q1,e1), (q2,e2) -> (Q.req q1 q2 && pure_same_exp e1 e2) || (Q.req q1 Q.rzero && Q.req q2 Q.rzero) | (q1,e1), (q2,e2) -> (Q.req q1 q2 && pure_same_exp e1 e2) || (Q.is_zero q1 && Q.is_zero q2) end end let minv (a:t) let minv (a:t) ... ...
 ... @@ -150,10 +150,10 @@ ... @@ -150,10 +150,10 @@ ... @@ -1131,7 +1131,7 @@ ... @@ -1131,7 +1131,7 @@ ... @@ -1141,24 +1141,24 @@ ... @@ -1141,24 +1141,24 @@ ... @@ -1180,10 +1180,10 @@ ... @@ -1180,10 +1180,10 @@ ... @@ -1195,10 +1195,10 @@ ... @@ -1195,10 +1195,10 @@ ... @@ -1232,34 +1232,34 @@ ... @@ -1232,34 +1232,34 @@ ... @@ -1305,17 +1305,17 @@ ... @@ -1305,17 +1305,17 @@ ... @@ -1359,16 +1359,16 @@ ... @@ -1359,16 +1359,16 @@ ... @@ -1787,6 +1787,31 @@ ... @@ -1787,6 +1787,31 @@ ... @@ -2508,43 +2533,43 @@ ... @@ -2508,43 +2533,43 @@ ... @@ -2563,7 +2588,15 @@ ... @@ -2563,7 +2588,15 @@ ... ...
No preview for this file type
 ... @@ -18,6 +18,9 @@ let debug_interp = Debug.register_info_flag ... @@ -18,6 +18,9 @@ let debug_interp = Debug.register_info_flag let debug_refl = Debug.register_info_flag let debug_refl = Debug.register_info_flag ~desc:"Reflection transformations" ~desc:"Reflection transformations" "reflection" "reflection" let debug_flamegraph = Debug.register_info_flag ~desc:"Print callstacks from the interpreter in Flamegraph input format." "interp_flamegraph" let print_id fmt id = Format.fprintf fmt "%s" id.id_string let print_id fmt id = Format.fprintf fmt "%s" id.id_string ... @@ -601,8 +604,6 @@ open Ity ... @@ -601,8 +604,6 @@ open Ity exception CannotReduce exception CannotReduce let append l = List.fold_left (fun acc s -> acc^":"^s) "" l type value = type value = | Vconstr of rsymbol * field list | Vconstr of rsymbol * field list | Vtuple of value list | Vtuple of value list ... @@ -615,7 +616,7 @@ type value = ... @@ -615,7 +616,7 @@ type value = and field = Fimmutable of value | Fmutable of value ref and field = Fimmutable of value | Fmutable of value ref exception Raised of xsymbol * value option * string exception Raised of xsymbol * value option * rsymbol list open Format open Format ... @@ -931,9 +932,36 @@ type info = { ... @@ -931,9 +932,36 @@ type info = { recs: rsymbol Mrs.t; recs: rsymbol Mrs.t; funs: decl Mrs.t; funs: decl Mrs.t; get_decl: rsymbol -> Mltree.decl; get_decl: rsymbol -> Mltree.decl; cs: string list; (* callstack for debugging *) cur_rs: rsymbol; (* current function *) cs: rsymbol list; (* callstack for debugging/profiling *) } } let ts = ref 0. (* timestamp for current callstack *) let print_callstack cs time = Format.eprintf "%a %d@." (Pp.print_list (fun fmt () -> Format.fprintf fmt ";") Expr.print_rs) (List.rev cs) (int_of_float (time *. 100000000.)) let cs_push info rs = let new_cs = rs :: info.cs in if Debug.test_flag debug_flamegraph then begin let ts_end = Unix.gettimeofday () in print_callstack info.cs (ts_end -. !ts); ts := Unix.gettimeofday (); { info with cur_rs = rs; cs = new_cs } end else { info with cur_rs = rs; cs = new_cs } let cs_pop info = if Debug.test_flag debug_flamegraph then begin let ts_end = Unix.gettimeofday () in print_callstack info.cs (ts_end -. !ts); ts := Unix.gettimeofday () end let get pv info : value = Mid.find pv.pv_vs.vs_name info.vars let get pv info : value = Mid.find pv.pv_vs.vs_name info.vars let add_id id v info = {info with vars = Mid.add id v info.vars} let add_id id v info = {info with vars = Mid.add id v info.vars} ... @@ -992,7 +1020,13 @@ let rec interp_expr info (e:Mltree.expr) : value = ... @@ -992,7 +1020,13 @@ let rec interp_expr info (e:Mltree.expr) : value = print_id id print_value v; print_id id print_value v; add_id id v info) add_id id v info) info le vl in info le vl in interp_expr { info' with cs = rs.rs_name.id_string::(info'.cs) } e in if rs_equal rs info.cur_rs then interp_expr info' e else begin let info' = cs_push info' rs in let v = interp_expr info' e in cs_pop info'; v end in Debug.dprintf debug_interp "eval call@."; Debug.dprintf debug_interp "eval call@."; let res = try begin let res = try begin let rs = if Mrs.mem rs info.recs then Mrs.find rs info.recs else rs in let rs = if Mrs.mem rs info.recs then Mrs.find rs info.recs else rs in ... @@ -1125,7 +1159,7 @@ let rec interp_expr info (e:Mltree.expr) : value = ... @@ -1125,7 +1159,7 @@ let rec interp_expr info (e:Mltree.expr) : value = let ov = match oe with let ov = match oe with | None -> None | None -> None | Some e -> Some (interp_expr info e) in | Some e -> Some (interp_expr info e) in raise (Raised (xs, ov, append info.cs)) raise (Raised (xs, ov, info.cs)) | Eexn _ -> Debug.dprintf debug_interp "Eexn@."; | Eexn _ -> Debug.dprintf debug_interp "Eexn@."; raise CannotReduce raise CannotReduce | Eabsurd -> Debug.dprintf debug_interp "Eabsurd@."; | Eabsurd -> Debug.dprintf debug_interp "Eabsurd@."; ... @@ -1295,13 +1329,16 @@ let reflection_by_function do_trans s env = Trans.store (fun task -> ... @@ -1295,13 +1329,16 @@ let reflection_by_function do_trans s env = Trans.store (fun task -> recs = Mrs.empty; recs = Mrs.empty; vars = vars; vars = vars; get_decl = get_decl; get_decl = get_decl; cur_rs = rs; cs = []; cs = [];