Browse Source

most importantly: dot graphs

Simon Krajewski 1 year ago
parent
commit
e8e19b82f1
4 changed files with 104 additions and 14 deletions
  1. 14 0
      src/context/dotGraph.ml
  2. 4 1
      src/coro/coro.ml
  3. 82 0
      src/coro/coroDebug.ml
  4. 4 13
      src/optimization/analyzer.ml

+ 14 - 0
src/context/dotGraph.ml

@@ -0,0 +1,14 @@
+open Common
+open Type
+
+let get_dump_path com path name =
+	(dump_path com) :: [platform_name_macro com] @ (fst path) @ [Printf.sprintf "%s.%s" (snd path) name]
+
+let start_graph ?(graph_config=[]) base_path suffix =
+	let ch = Path.create_file false suffix [] base_path in
+	Printf.fprintf ch "digraph graphname {\n";
+	List.iter (fun s -> Printf.fprintf ch "%s;\n" s) graph_config;
+	ch,(fun () ->
+		Printf.fprintf ch "}\n";
+		close_out ch
+	)

+ 4 - 1
src/coro/coro.ml

@@ -13,7 +13,10 @@ let fun_to_coro ctx e tf =
 	let tf_expr = CoroToTexpr.block_to_texpr_coroutine ctx cb_root vcontinuation v_result v_error e.epos in
 	let tf_expr = CoroToTexpr.block_to_texpr_coroutine ctx cb_root vcontinuation v_result v_error e.epos in
 	let tf_args = tf.tf_args @ [(vcontinuation,None)] in
 	let tf_args = tf.tf_args @ [(vcontinuation,None)] in
 	let tf_type = tfun [t_dynamic; t_dynamic] ctx.com.basic.tvoid in
 	let tf_type = tfun [t_dynamic; t_dynamic] ctx.com.basic.tvoid in
-	if ctx.coro_debug then print_endline ("BEFORE:\n" ^ (s_expr_debug e));
+	if ctx.coro_debug then begin
+		print_endline ("BEFORE:\n" ^ (s_expr_debug e));
+		CoroDebug.create_dotgraph (DotGraph.get_dump_path ctx.com ([],e.epos.pfile) (Printf.sprintf "pos_%i" e.epos.pmin)) cb_root
+	end;
 	let e = {e with eexpr = TFunction {tf_args; tf_expr; tf_type}} in
 	let e = {e with eexpr = TFunction {tf_args; tf_expr; tf_type}} in
 	if ctx.coro_debug then print_endline ("AFTER:\n" ^ (s_expr_debug e));
 	if ctx.coro_debug then print_endline ("AFTER:\n" ^ (s_expr_debug e));
 	e
 	e

+ 82 - 0
src/coro/coroDebug.ml

@@ -0,0 +1,82 @@
+
+open CoroTypes
+open Type
+
+let create_dotgraph path cb =
+	print_endline (String.concat "." path);
+	let ch,close = DotGraph.start_graph path "coro" in
+	let i = ref 0 in
+	let pctx = print_context() in
+	let st = s_type pctx in
+	let se = s_expr_pretty true "" false st in
+	let edges = DynArray.create () in
+	let rec block cb =
+		let cb_id = !i in
+		let edge_block label cb_target =
+			let target_id = block cb_target in
+			DynArray.add edges (cb_id,target_id,label);
+		in
+		incr i;
+		let s = String.concat "\n" (DynArray.to_list (DynArray.map se cb.cb_el)) in
+		let snext = match cb.cb_next.next_kind with
+			| NextUnknown ->
+				None
+			| NextSub(cb_sub,cb_next) ->
+				edge_block "sub" cb_sub;
+				edge_block "next" cb_next;
+				None
+			| NextBreak ->
+				Some "break"
+			| NextContinue ->
+				Some "continue"
+			| NextReturnVoid ->
+				Some "return"
+			| NextReturn e ->
+				Some ("return " ^ se e)
+			| NextThrow e ->
+				Some ("throw " ^ se e)
+			| NextIfThen(e,cb_then,cb_next) ->
+				edge_block "then" cb_then;
+				edge_block "next" cb_next;
+				Some ("if " ^ se e)
+			| NextIfThenElse(e,cb_then,cb_else,cb_next) ->
+				edge_block "then" cb_then;
+				edge_block "else" cb_else;
+				edge_block "next" cb_next;
+				Some ("if " ^ se e)
+			| NextSwitch(switch,cb_next) ->
+				List.iter (fun (el,cb_case) ->
+					edge_block (String.concat " | " (List.map se el)) cb_case
+				) switch.cs_cases;
+				edge_block "next" cb_next;
+				Option.may (fun cb_default -> edge_block "default" cb_default) switch.cs_default;
+				Some ("switch " ^ se switch.cs_subject)
+			| NextWhile(e,cb_body,cb_next) ->
+				edge_block "body" cb_body;
+				edge_block "next" cb_next;
+				Some ("while " ^ se e)
+			| NextTry(cb_try,catches,cb_next) ->
+				edge_block "try" cb_try;
+				List.iter (fun (v,cb_catch) ->
+					edge_block (st v.v_type) cb_catch
+				) catches;
+				edge_block "next" cb_next;
+				None
+			| NextSuspend(suspend,cb_next) ->
+				edge_block "next" cb_next;
+				Some (Printf.sprintf "%s(%s)" (se suspend.cs_fun) (String.concat ", " (List.map se suspend.cs_args)))
+		in
+		let s = match snext with
+			| None ->
+				s
+			| Some snext ->
+				if s = "" then snext else s ^ "\n" ^ snext
+		in
+		Printf.fprintf ch "n%i [shape=box,label=\"%s\"];\n" cb_id (StringHelper.s_escape s);
+		cb_id
+	in
+	ignore(block cb);
+	DynArray.iter (fun (id_from,id_to,label) ->
+		Printf.fprintf ch "n%i -> n%i[label=\"%s\"];\n" id_from id_to label;
+	) edges;
+	close();

+ 4 - 13
src/optimization/analyzer.ml

@@ -842,19 +842,10 @@ module Debug = struct
 			end
 			end
 		) g.g_var_infos
 		) g.g_var_infos
 
 
-	let get_dump_path ctx c cf =
-		(dump_path ctx.com) :: [platform_name_macro ctx.com] @ (fst c.cl_path) @ [Printf.sprintf "%s.%s" (snd c.cl_path) cf.cf_name]
-
 	let dot_debug ctx c cf =
 	let dot_debug ctx c cf =
 		let g = ctx.graph in
 		let g = ctx.graph in
 		let start_graph ?(graph_config=[]) suffix =
 		let start_graph ?(graph_config=[]) suffix =
-			let ch = Path.create_file false suffix [] (get_dump_path ctx c cf) in
-			Printf.fprintf ch "digraph graphname {\n";
-			List.iter (fun s -> Printf.fprintf ch "%s;\n" s) graph_config;
-			ch,(fun () ->
-				Printf.fprintf ch "}\n";
-				close_out ch
-			)
+			DotGraph.start_graph ~graph_config (DotGraph.get_dump_path ctx.com c cf) suffix
 		in
 		in
 		let ch,f = start_graph "-cfg.dot" in
 		let ch,f = start_graph "-cfg.dot" in
 		List.iter (fun bb -> dot_debug_node g ch [NILoopGroups;NIScopes;NIPhi;NIExpr] bb) g.g_nodes;
 		List.iter (fun bb -> dot_debug_node g ch [NILoopGroups;NIScopes;NIPhi;NIExpr] bb) g.g_nodes;
@@ -1087,12 +1078,12 @@ module Run = struct
 					print_endline (Type.s_expr_pretty true "" false (s_type (print_context())) e);
 					print_endline (Type.s_expr_pretty true "" false (s_type (print_context())) e);
 					print_endline (Printf.sprintf "</%s>" s);
 					print_endline (Printf.sprintf "</%s>" s);
 				) (List.rev actx.debug_exprs);
 				) (List.rev actx.debug_exprs);
-				Debug.dot_debug actx c cf;
-				print_endline (Printf.sprintf "dot graph written to %s" (String.concat "/" (Debug.get_dump_path actx c cf)));
+				Debug.dot_debug actx c.cl_path cf.cf_name;
+				print_endline (Printf.sprintf "dot graph written to %s" (String.concat "/" (DotGraph.get_dump_path actx.com c.cl_path cf.cf_name)));
 			in
 			in
 			let maybe_debug () = match config.debug_kind with
 			let maybe_debug () = match config.debug_kind with
 				| DebugNone -> ()
 				| DebugNone -> ()
-				| DebugDot -> Debug.dot_debug actx c cf;
+				| DebugDot -> Debug.dot_debug actx c.cl_path cf.cf_name;
 				| DebugFull -> debug()
 				| DebugFull -> debug()
 			in
 			in
 			let e = try
 			let e = try