Skip to content
Snippets Groups Projects
Commit 7105bae2 authored by erwan's avatar erwan
Browse files

Update: add en embrionic lib for using sasa from rdbg

parent a50dc191
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
Showing
with 313 additions and 0 deletions
test/rdbg-utils/dot.ml 0 → 100644
+ 313
− 0
View file @ 7105bae2
#require "ocamlgraph";;
open Graph
open Graph.Dot_ast
open Data
open Event
(* XXX duplicated from lib/sasacore/topology.ml:
make a user lib out of it.
*)
type node_id = string
type node = {
id: node_id;
file: string;
init: (string * string) list;
}
type edge = node_id * node_id list
type t = node list * string
type node_info_t = (string, node) Hashtbl.t
let node_info:node_info_t = Hashtbl.create 100
type node_succ_t = (string, string list) Hashtbl.t
let node_succ:node_succ_t = Hashtbl.create 100
let (of_id:Dot_ast.id -> string) =
function Ident str | Html str | Number str | String str -> str
let (of_node_id:Dot_ast.node_id -> string) = fun id -> of_id (fst id)
let (of_node:Dot_ast.node -> string) = function
| NodeId node_id -> of_node_id node_id
| NodeSub _subgraph -> assert false
let (get_file: Dot_ast.node_id -> Dot_ast.attr list -> string) =
fun node_id attrs ->
let attrs = List.flatten attrs in
try (
match List.assoc (Ident "algo") attrs with
None -> assert false
| Some id -> of_id id
)
with Not_found -> failwith ((of_node_id node_id)^" should have an algo attribute")
let (get_init: Dot_ast.attr list -> (string * string) list ) =
fun attrs ->
let attrs = List.flatten attrs in (* XXX why a list of list ? *)
let init_list =
List.fold_left
(fun acc (id,idopt) ->
if id <> Ident "init" then acc else
match idopt with
| Some (String id) -> (
try
let i = String.index id '=' in
let l = String.length id in
(String.sub id 0 i, String.sub id (i+1) (l-i-1))::acc
with
Not_found -> acc
)
| _ -> acc
)
[]
attrs
in
init_list
let (do_stmt: bool -> node list -> Dot_ast.stmt -> node list) =
fun directed n stmt ->
match stmt with
| Node_stmt (node_id, attrs) ->
let id = of_node_id node_id in
let inits = get_init attrs in
let node = { id=id ; file = get_file node_id attrs ; init = inits } in
if Hashtbl.mem node_info id then
failwith (id ^ " defined twice")
else
Hashtbl.add node_info id node;
node::n
| Edge_stmt (node, nodes, _attrs) ->
let node = of_node node in
let nodes = List.map of_node nodes in
(* for egdes written "a -- b -- c -- d", which
is a shortcut for "
a -- b
b -- c
c -- d
"
Graph.Dot.parse_dot_ast returns the pair a,[b,c,d]
which is weird IMHO.
The code below add the missing edges:
*)
let add_edge n1 n2 =
if n1 = n2 then failwith
(Printf.sprintf "Bad topology: %s can not ne a neighbor of itself!" n1);
let pn1 = try Hashtbl.find node_succ n1 with Not_found -> [] in
let pn2 = try Hashtbl.find node_succ n2 with Not_found -> [] in
Hashtbl.replace node_succ n1 (n2::pn1);
if not directed then Hashtbl.replace node_succ n2 (n1::pn2);
n2
in
ignore (List.fold_left add_edge node nodes);
n
| Attr_graph _attrs -> n
| Attr_node _attrs -> n
| Attr_edge _attrs -> n
| Equal (_id1, _id2) -> assert false
| Subgraph _subgraph -> assert false
let (read: string -> t) = fun f ->
let dot_file = Graph.Dot.parse_dot_ast f in
assert (not dot_file.strict);
let res = List.fold_left (do_stmt dot_file.digraph) [] dot_file.stmts in
List.rev res,f
;;
let succ str = try Hashtbl.find node_succ str with Not_found -> []
(* XXX bad name: process? *)
type pid = {
name: string;
actions: (string * bool * bool) list; (* (action name, enabled, active) *)
vars: (string * Data.v) list (* pid local vars*)
}
let (is_parent: string -> int -> Event.t -> bool) =
fun a i e ->
(* XXX marche ssi une variable s'appelle par!
je devrais au moins generaliser avec l'existence
d'une variable de type parent (et encore)
*)
match List.assoc_opt (a^"_par") e.data with
| None -> false
| Some (I j) -> i = j
| _ -> false
let (get_pidl : node list -> string -> Event.t -> pid list) =
fun nodes f e ->
if e.kind <> Ltop then (
print_string "print_dot should be called from Ltop event\n";
failwith "exit print_dot"
);
let l = List.map (fun (x,v) -> Str.split (Str.regexp "_") x, v) e.data in
let rec sortv (enab, other) (x,v) =
match x with
| ["Enab";pid;a] -> (pid,a,v)::enab, other
| [pid; str] -> enab, (pid,str,v)::other
| _ -> assert false
in
let enab, other = List.fold_left sortv ([],[]) l in
let rec (build_pidl: pid list -> (string * string * Data.v) list ->
(string * string * Data.v) list -> pid list) =
fun pidl enab other ->
match enab with
| [] -> pidl
| (pid, _, _)::_ ->
let enab_pid_list, enab = List.partition (fun (pid0,_,_) -> pid=pid0) enab in
let other_pid, other = List.partition (fun (pid0,_,_) -> pid=pid0) other in
let acti_pid, vars_pid =
List.partition
(fun (_,n,_) -> List.exists (fun (_,n2,_) -> n2=n) enab_pid_list)
other_pid
in
let get_actions (_, n, enabv) =
let (_,_,activ) = List.find (fun (_,n0, _) -> n=n0) acti_pid in
(n, enabv = Data.B true, activ = B true)
in
let pid = {
name = pid;
actions = List.map get_actions enab_pid_list;
vars = List.map (fun (_,n,v) -> n,v) vars_pid;
}
in
build_pidl (pid::pidl) enab other
in
let pidl = build_pidl [] enab other in
List.rev pidl
(* Compute a dot from the content of e.data *)
let print_dot (nodes,f) e =
let (pidl : pid list) = get_pidl nodes f e in
let oc = open_out ("sasa-"^f) in
let nodes_decl =
String.concat "\n"
(List.map
(fun pid ->
let color =
if List.exists (fun (_,_,a) -> a) pid.actions then
"fillcolor=gold,style=filled,"
else
if List.exists (fun (_,e,_) -> e) pid.actions then
"fillcolor=green,style=filled,"
else ""
in
let enabled = String.concat ","
(List.map
(fun (n,_,_) -> n)
(List.filter (fun (_,e,_) -> e) pid.actions))
in
let enabled = if enabled = "" then "" else (enabled^"|") in
let loc = String.concat "|"
(List.map (fun (n,v) ->
Printf.sprintf "%s=%s" n (Data.val_to_string string_of_float v))
pid.vars
)
in
Printf.sprintf " %s [%slabel=\"%s|{%s%s}\"] "
pid.name color pid.name enabled loc
)
pidl
)
in
let trans =
List.flatten
(List.map
(fun n ->
let l = succ n.id in
List.mapi (fun i t ->
if is_parent n.id i e then
Printf.sprintf "%s -> %s" n.id t
else if n.id < t then
Printf.sprintf "%s -- %s" n.id t
else
Printf.sprintf "%s -- %s" t n.id
)
l
)
nodes
)
in
let trans = List.sort_uniq compare trans in
let is_directed str =
try
ignore (Str.search_forward (Str.regexp "->") str 0);
true
with Not_found -> false
in
let trans_dir,trans_undir = List.partition is_directed trans in
let trans_dir_str = String.concat "\n" trans_dir in
let trans_undir_str = String.concat "\n" trans_undir in
let trans_undir_str = Str.global_replace (Str.regexp "--") "->" trans_undir_str in
let trans_str =
(* if trans_dir_str = "" then trans_undir_str else *)
Printf.sprintf "subgraph dir {\n\t%s}
subgraph undir {\n\t edge [dir=none]\n%s} " trans_dir_str trans_undir_str
in
Printf.fprintf oc
"digraph %s {\nlabel=\"%s step %d\"\nnode [shape=record];\n%s\n%s\n}\n"
"g" f e.step
nodes_decl trans_str;
flush oc;
close_out oc;
Sys.command (Printf.sprintf "dot -Tpdf sasa-%s -o sasa-%s.pdf" f f)
;;
(***********************************************************************)
let get_removable pl =
let pl = List.filter
(fun p ->
(List.exists (fun (_,_,acti) -> acti) p.actions) ||
(List.for_all (fun (_,enab,_) -> (not enab)) p.actions)
)
pl
in
List.map (fun p -> p.name) pl
let next_round nodes f e =
let (pl : pid list) = get_pidl nodes f e in
let p_with_enable_action =
List.filter
(fun p -> List.exists (fun (_,enab,acti) -> enab&&not(acti)) p.actions)
pl
in
let pidl = List.map (fun p -> p.name) p_with_enable_action in
Printf.printf "The processes to check : %s\n" (String.concat "," pidl);
flush stdout;
let rec go cpidl e =
let e = step e in
let pl = get_pidl nodes f 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);
flush stdout;
let cpidl = List.filter (fun pid -> not (List.mem pid removable)) cpidl in
if cpidl = [] then e else go cpidl e
in
go pidl e
(***********************************************************************)
let _ = print_string "
===> Use the read fonction to load the dot file
===> Use the print_dot function at Ltop event to generated dot files
You migth want to add something along those lines at the end of your rdbg-session.ml file
(the name of the dot file and the path to the dot.ml file migth need to be adapted
to your context tough):
;;
#use \"../rdbg-utils/dot.ml\";;
let nodes,dotfile = read \"g.dot\";;
let d () = print_dot (nodes, dotfile) !e;;
let sd () = s();d();;
let nr () = e:=next_round nodes dotfile !e; d();;
let _ = n (); d (); Sys.command (\"zathura sasa-g.dot.pdf&\")
"
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