Add a debug flag to get profiling data on the interpreter

examples/in_progress/multiprecision/lineardecision.mlw

@@ -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 d1) *. (from_int n2 /. from_int d2)
                   = rinterp a y *. rinterp b y };
-      simp r
+      r
     end
   end
 
@@ -945,6 +945,12 @@ let rinv (a:t)
   | (n,d) -> if n = 0 || d = 0 then raise QError else (d,n)
   end
 
+let is_zero (a:t)
+  ensures { result <-> req a rzero }
+= match a with
+  | (n,d) -> n = 0 && d <> 0
+  end
+
 end
 
 module LinearDecisionRational
@@ -1251,8 +1257,8 @@ let madd (a b:t)
   raises  { Q.QError -> true }
 = match a, b with
   | (q1, e1), (q2, e2) ->
-    if Q.req q1 Q.rzero then b
-    else if Q.req q2 Q.rzero then a
+    if Q.is_zero q1 then b
+    else if Q.is_zero q2 then a
     else if same_exp e1 e2
     then begin
       let q = Q.radd q1 q2 in
@@ -1273,7 +1279,7 @@ let mmul (a b:t)
 = match a, b with
   | (q1,e1), (q2,e2) ->
     let q = Q.rmul q1 q2 in
-    if Q.req q Q.rzero then mzero
+    if Q.is_zero q then mzero
     else begin
       let e = add_exp e1 e2 in
       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)
 let predicate meq (a b:t)
   ensures { result -> forall y. minterp a y = minterp b y }
 = 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
 
 let minv (a:t)

src/transform/reification.ml

@@ -18,6 +18,9 @@ let debug_interp = Debug.register_info_flag
 let debug_refl = Debug.register_info_flag
                      ~desc:"Reflection transformations"
                      "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
 
@@ -601,8 +604,6 @@ open Ity
 
 exception CannotReduce
 
-let append l = List.fold_left (fun acc s -> acc^":"^s) "" l
-
 type value =
   | Vconstr of rsymbol * field list
   | Vtuple of value list
@@ -615,7 +616,7 @@ type value =
 
 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
 
@@ -931,9 +932,36 @@ type info = {
     recs: rsymbol Mrs.t;
     funs: decl Mrs.t;
     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 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 =
                 print_id id print_value v;
               add_id id v info)
             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@.";
       let res = try begin
         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 =
      let ov = match oe with
        | None -> None
        | 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@.";
                          raise CannotReduce
   | Eabsurd -> Debug.dprintf debug_interp "Eabsurd@.";
@@ -1295,13 +1329,16 @@ let reflection_by_function do_trans s env = Trans.store (fun task ->
                        recs = Mrs.empty;
                        vars = vars;
                        get_decl = get_decl;
+                       cur_rs = rs;
                        cs = [];
                        } in
           Debug.dprintf debug_refl "eval_fun@.";
+          ts := Unix.gettimeofday ();
           let res =
             try term_of_value (eval_fun decl info)
-            with Raised (xs,_,s) ->
-              Format.eprintf "Raised %s %s@." (xs.xs_name.id_string) s;
+            with Raised (xs,_,cs) ->
+              Format.eprintf "Raised %s %a@." (xs.xs_name.id_string)
+                (Pp.print_list Pp.semi Expr.print_rs) cs;
               raise (ReductionFail renv) (*(try eval_fun decl info with Raised _ -> Vbool false)*) in
           Debug.dprintf debug_refl "res %a@." Pretty.print_term res;
           let rinfo = {renv with subst = Mvs.add vres res renv.subst} in