From 35aa3bc27892d10bd92dbde1c42adc568656a15b Mon Sep 17 00:00:00 2001
From: Erwan Jahier <erwan.jahier@univ-grenoble-alpes.fr>
Date: Thu, 9 May 2019 22:13:16 +0200
Subject: [PATCH] New: add a --generate-rdbg-load (hidden) option used by rdbg
to generate sessions
This is necessary because I cannot Dynlink .cmxs files from a ocaml
toplevel. Hence, one way to load the algos from rdbg is to
#load .cma files. This option generates an ocaml file that
can be #used by automatically generated rdbg-session.ml files.
---
lib/sasacore/sasArg.ml | 13 ++++++++++---
lib/sasacore/sasArg.mli | 3 ++-
lib/sasacore/sasa.ml | 22 +++++++++++++++++++++-
test/dfs/rdbg-session.ml | 1 -
test/my-rdbg-tuning.ml | 12 +++++++++---
test/rdbg-utils/dot.ml | 29 ++++++++++++++++++++---------
6 files changed, 62 insertions(+), 18 deletions(-)
diff --git a/lib/sasacore/sasArg.ml b/lib/sasacore/sasArg.ml
index 86e6837b..822a4bbb 100644
--- a/lib/sasacore/sasArg.ml
+++ b/lib/sasacore/sasArg.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 02/04/2019 (at 08:25) by Erwan Jahier> *)
+(* Time-stamp: <modified the 06/05/2019 (at 14:47) by Erwan Jahier> *)
type t = {
@@ -11,6 +11,7 @@ type t = {
mutable ifi: bool;
mutable gen_lutin: bool;
mutable dummy_input: bool;
+ mutable generate_rdbg_load_files: bool;
mutable _args : (string * Arg.spec * string) list;
mutable _user_man : (string * string list) list;
@@ -38,6 +39,7 @@ let (make_args : unit -> t) =
ifi = false;
gen_lutin = false;
dummy_input = false;
+ generate_rdbg_load_files = false;
_args = [];
_user_man = [];
_hidden_man = [];
@@ -119,6 +121,11 @@ let (mkoptab : string array -> t -> unit) =
(Arg.Unit(fun () -> args.gen_lutin <- true))
["Generate Lutin demons and exit"];
+ mkopt args ~hide:true ["--generate-rdbg-load"]
+ (Arg.Unit(fun () -> args.generate_rdbg_load_files <- true))
+ ["Generate a file meant to be included by rdbg, and exit. ";
+ "This file allows one to load the node algo cma files "];
+
mkopt args ~hide:true ["--dummy-input"]
(Arg.Unit(fun () -> args.dummy_input <- true))
["Add a dummy input to sasa so that built-in demon can be used from rdbg"];
@@ -131,7 +138,7 @@ let (mkoptab : string array -> t -> unit) =
(Arg.Int (fun i -> args.length <- i))
["Maximum number of steps to be done (" ^ (string_of_int args.length) ^ " by default).\n"];
- mkopt args ~hide:true ["--version";"-version";"-v"]
+ mkopt args ["--version";"-version";"-v"]
(Arg.Unit (fun _ ->
(print_string (SasaVersion.str^"-"^SasaVersion.sha^"\n");flush stdout;exit 0)))
["Display the sasa version and exit."];
@@ -198,7 +205,7 @@ let parse argv = (
exit 2;
| x::_ -> x
);
- args
+ args
)
with
| Arg.Bad msg ->
diff --git a/lib/sasacore/sasArg.mli b/lib/sasacore/sasArg.mli
index 8b2aac96..3722d728 100644
--- a/lib/sasacore/sasArg.mli
+++ b/lib/sasacore/sasArg.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 02/04/2019 (at 14:43) by Erwan Jahier> *)
+(* Time-stamp: <modified the 06/05/2019 (at 14:24) by Erwan Jahier> *)
type t = {
mutable topo: string;
@@ -10,6 +10,7 @@ type t = {
mutable ifi: bool;
mutable gen_lutin: bool;
mutable dummy_input: bool;
+ mutable generate_rdbg_load_files: bool;
mutable _args : (string * Arg.spec * string) list;
mutable _user_man : (string * string list) list;
diff --git a/lib/sasacore/sasa.ml b/lib/sasacore/sasa.ml
index ad66f48b..01c49728 100644
--- a/lib/sasacore/sasa.ml
+++ b/lib/sasacore/sasa.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 09/05/2019 (at 21:58) by Erwan Jahier> *)
+(* Time-stamp: <modified the 09/05/2019 (at 21:59) by Erwan Jahier> *)
open Algo
open Sasacore
@@ -175,6 +175,26 @@ let (make : bool -> string array -> t) =
let e = update_env_with_init e pl algo_neighors in
let pl_n = List.combine pl algo_neighors in
if !Algo.verbose_level > 0 then List.iter dump_process pl_n;
+ if args.generate_rdbg_load_files then (
+ let fn = Printf.sprintf "load-%s.ml" args.topo in
+ if Sys.file_exists fn then (
+ Printf.eprintf "%s already exists: rename it to update.\n" fn;
+ flush stderr; exit 0
+ ) else
+ let oc = open_out fn in
+ let files = List.fold_left
+ (fun acc n ->
+ let f = (Filename.chop_extension n.Topology.file) ^ ".cma" in
+
+ if List.mem f acc then acc else f::acc)
+ [] nl
+ in
+ let loadl = List.map (fun s -> Printf.sprintf "#load \"%s\"" s) files in
+ Printf.fprintf oc "%s" (String.concat "\n" loadl);
+ flush oc;
+ close_out oc;
+ exit 0
+ );
if args.gen_lutin then (
let fn = (Filename.remove_extension args.topo) ^ ".lut" in
if Sys.file_exists fn then (
diff --git a/test/dfs/rdbg-session.ml b/test/dfs/rdbg-session.ml
index d113176d..918ecda1 100644
--- a/test/dfs/rdbg-session.ml
+++ b/test/dfs/rdbg-session.ml
@@ -53,5 +53,4 @@ let dotfile = "g.dot";;
#use "../my-rdbg-tuning.ml";;
-let _ = n (); d (); ignore (Sys.command ("zathura sasa-g.dot.pdf&"))
diff --git a/test/my-rdbg-tuning.ml b/test/my-rdbg-tuning.ml
index e53bcb39..ba17aaff 100644
--- a/test/my-rdbg-tuning.ml
+++ b/test/my-rdbg-tuning.ml
@@ -1,5 +1,6 @@
(* Some useful short-cuts for rdbg interactive sessions *)
+
let _ = time_travel true;;
@@ -36,6 +37,7 @@ let pa () = patchwork p dotfile !e;;
let os () = osage p dotfile !e;;
+
(* Convergence is reached when data does not change *)
let rec go () =
let data = !e.data in
@@ -90,13 +92,17 @@ let (round : Event.t -> bool) =
);
res
-
+(* go to next and previous rounds *)
let nr () = e:=next_round !e; circo p dotfile !e;;
-let pr () = e:=goto_last_ckpt !e.nb;;
-(**********************************************************************)
+let pr () = e:=goto_last_ckpt !e.nb; circo p dotfile !e;;
+(* checkpoint at rounds! *)
let _ = check_ref := round;;
+
+
+let _ = d (); Sys.command (Printf.sprintf "zathura sasa-%s.pdf&" dotfile)
+
let _ = print_string "
--> type 'man' for online help
"
diff --git a/test/rdbg-utils/dot.ml b/test/rdbg-utils/dot.ml
index e23d5590..0b06cfcd 100644
--- a/test/rdbg-utils/dot.ml
+++ b/test/rdbg-utils/dot.ml
@@ -23,8 +23,8 @@ let (is_parent: string -> string -> int -> Event.t -> bool) =
| Some (I j) -> j > -1 && i = j
| _ -> false
-let (get_processes : string -> Event.t -> process list) =
- fun f e ->
+let (get_processes : Event.t -> process list) =
+ fun e ->
(* if e.kind <> Ltop then (
print_string "dot should be called from Ltop event\n";
failwith "exit dot"
@@ -94,7 +94,7 @@ let (get_parent_var_name: nodes list -> string) =
(* Compute a dot from the content of e.data *)
let to_pdf engine par_var g f e =
let nodes = g.nodes in
- let (pidl : process list) = get_processes f e in
+ let (pidl : process list) = get_processes e in
let oc = open_out ("sasa-"^f) in
let nodes_decl =
String.concat "\n"
@@ -166,7 +166,12 @@ subgraph undir {\n\t edge [dir=none]\n%s} " trans_dir_str trans_undir_str
nodes_decl trans_str;
flush oc;
close_out oc;
- Sys.command (Printf.sprintf "%s -Tpdf sasa-%s -o sasa-%s.pdf" engine f f)
+ if Sys.command (Printf.sprintf "%s -Tpdf sasa-%s -o sasa-%s.pdf" engine f f) > 0
+ then (
+ Printf.printf "'%s -Tpdf sasa-%s -o sasa-%s.pdf' Failed\n" engine f f;
+ flush stdout
+ )
+
;;
let dot = to_pdf "dot" "_par" ;;
@@ -200,10 +205,13 @@ let get_removable pl =
pl
in
List.map (fun p -> p.name) pl
+(***********************************************************************)
+
+
(* *)
-let next_round nodes f e =
- let (pl : process list) = get_processes f e in
+let next_round e =
+ let (pl : process list) = get_processes e in
let p_with_enable_action =
List.filter
(fun p -> List.exists (fun (_,enab,acti) -> enab&¬(acti)) p.actions)
@@ -215,7 +223,7 @@ let next_round nodes f e =
flush stdout;
let rec go cpidl e =
let e = step e in
- let pl = get_processes f e in
+ let pl = get_processes e in
let removable = get_removable pl in
Printf.printf "Current process: %s\n" (String.concat "," cpidl);
Printf.printf "Removable process: %s\n" (String.concat "," removable);
@@ -224,7 +232,10 @@ let next_round nodes f e =
if cpidl = [] then e else go cpidl e
in
go pidl e
-
+
+
+
+
(***********************************************************************)
let _ = print_string "
@@ -243,7 +254,7 @@ let dotfile = \"g.dot\";;
let p = Topology.read dotfile;;
let d () = dot (p.nodes, dotfile) !e;;
let sd () = s();d();;
-let nr () = e:=next_round p.nodes dotfile !e; d();;
+let nr () = e:=next_round dotfile !e; d();;
let _ = n (); d (); Sys.command (\"zathura sasa-g.dot.pdf&\")
--
GitLab