Commit 35aa3bc2 authored by erwan's avatar erwan
Browse files

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.
parent 7212f2ea
(* 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 ->
......
(* 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;
......
(* 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 (
......
......@@ -53,5 +53,4 @@ let dotfile = "g.dot";;
#use "../my-rdbg-tuning.ml";;
let _ = n (); d (); ignore (Sys.command ("zathura sasa-g.dot.pdf&"))
(* 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
"
......
......@@ -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&&not(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&\")
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment