Commit c9014305 authored by erwan's avatar erwan
Browse files

Update: clean-up the algo.mli file

All the get_* functions (that are of no interest for users) are now in
the Register module.
parent 5afa94d3
(* Time-stamp: <modified the 19/06/2019 (at 09:55) by Erwan Jahier> *)
(* Time-stamp: <modified the 19/06/2019 (at 14:32) by Erwan Jahier> *)
open Sasacore
(** Process programmer API *)
type algo_id = string
......@@ -26,113 +28,32 @@ type 's to_register = {
copy_state: 's -> 's;
}
type 's internal_tables = {
init_state: (string, Obj.t) Hashtbl.t;
enable : (string, Obj.t) Hashtbl.t;
step : (string, Obj.t) Hashtbl.t;
actions : (string, action list) Hashtbl.t;
value_to_string : (string, Obj.t) Hashtbl.t;
copy_value : (string, Obj.t) Hashtbl.t;
mutable card : int
}
let (tbls:'s internal_tables) = {
init_state = Hashtbl.create 1;
enable = Hashtbl.create 1;
step = Hashtbl.create 1;
actions = Hashtbl.create 1;
value_to_string = Hashtbl.create 1;
copy_value = Hashtbl.create 1;
card = (-1)
}
let verbose_level = ref 0
exception Unregistred of string * string
let print_table lbl tbl =
let keys = Hashtbl.fold (fun k _ acc -> Printf.sprintf "%s,%s" k acc) tbl "" in
if !verbose_level > 0 then Printf.printf "Defined keys for %s: %s\n" lbl keys;
flush stdout
let (reg_init_state : algo_id -> (int -> 's) -> unit) =
fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s init_vars\n" algo_id;
flush stdout;
Hashtbl.replace tbls.init_state algo_id (Obj.repr x)
let (get_init_state : algo_id -> int -> 's) =
fun algo_id ->
try Obj.obj (Hashtbl.find tbls.init_state algo_id)
with Not_found ->
print_table "init_state" tbls.init_state;
raise (Unregistred ("init_state", algo_id))
let (reg_enable : algo_id -> 's enable_fun -> unit) = fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s enable\n" algo_id;
flush stdout;
Hashtbl.replace tbls.enable algo_id (Obj.repr x)
let (get_enable : algo_id -> 's enable_fun) = fun algo_id ->
try Obj.obj (Hashtbl.find tbls.enable algo_id)
with Not_found ->
print_table "enable" tbls.enable;
raise (Unregistred ("enable", algo_id))
let (reg_step : algo_id -> 's step_fun -> unit) = fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s step\n" algo_id;
flush stdout;
Hashtbl.replace tbls.step algo_id (Obj.repr x)
let (get_step : algo_id -> 's step_fun) = fun algo_id ->
try Obj.obj (Hashtbl.find tbls.step algo_id)
with Not_found ->
print_table "step" tbls.step;
raise (Unregistred ("step", algo_id))
let (reg_actions : algo_id -> action list -> unit) =
fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s actions\n" algo_id;
flush stdout;
Hashtbl.replace tbls.actions algo_id x
let (get_actions : algo_id -> action list) = fun algo_id ->
try Hashtbl.find tbls.actions algo_id
with Not_found ->
print_table "actions" tbls.actions;
raise (Unregistred ("actions", algo_id))
let (reg_value_to_string : ('s -> string) -> unit) =
fun f ->
if !verbose_level > 0 then Printf.printf "Registering value_to_string\n";
flush stdout;
Hashtbl.replace tbls.value_to_string "_global" (Obj.repr f)
let (get_value_to_string : unit -> 's -> string) = fun () ->
try Obj.obj (Hashtbl.find tbls.value_to_string "_global")
with Not_found ->
print_table "value_to_string" tbls.value_to_string;
raise (Unregistred ("value_to_string", "_global"))
let (reg_copy_value : ('s -> 's) -> unit) =
fun f ->
if !verbose_level > 0 then Printf.printf "Registering copy_value\n";
flush stdout;
Hashtbl.replace tbls.copy_value "_global" (Obj.repr f)
let (get_copy_value : unit -> ('s -> 's)) = fun () ->
try Obj.obj (Hashtbl.find tbls.copy_value "_global")
with Not_found ->
print_table "copy_value" tbls.copy_value;
raise (Unregistred ("copy_value", "_global"))
let (to_reg_neigbor : 's Register.neighbor -> 's neighbor) =
fun n ->
{
state = n.Register.state ;
pid = n.Register.pid;
reply = n.Register.reply;
}
let (to_reg_enable_fun : 's enable_fun ->
's Register.neighbor list -> 's -> action list) =
fun f nl s ->
f (List.map to_reg_neigbor nl) s
let (to_reg_step_fun : 's step_fun ->
's Register.neighbor list -> 's -> action -> 's) =
fun f nl s a ->
f (List.map to_reg_neigbor nl) s a
let (register1 : 's algo_to_register -> unit) =
fun s ->
reg_enable s.algo_id s.enab;
reg_step s.algo_id s.step;
reg_init_state s.algo_id s.init_state;
(match s.actions with None -> () | Some al -> reg_actions s.algo_id al);
Register.reg_enable s.algo_id (to_reg_enable_fun s.enab);
Register.reg_step s.algo_id (to_reg_step_fun s.step);
Register.reg_init_state s.algo_id s.init_state;
(match s.actions with None -> () | Some al -> Register.reg_actions s.algo_id al);
()
let registered = ref false
......@@ -142,17 +63,9 @@ let (register : 's to_register -> unit) =
if !registered then failwith "Register can only be called once!";
registered := true;
List.iter register1 s.algo;
reg_value_to_string s.state_to_string;
reg_copy_value s.copy_state;
Register.reg_value_to_string s.state_to_string;
Register.reg_copy_value s.copy_state;
()
let (card : unit -> int) =
fun () -> tbls.card
let (set_card : int -> unit) =
fun i ->
tbls.card <- i
let (to_string : 's -> string) =
fun v ->
(get_value_to_string ()) v
let card = Register.card
(* Time-stamp: <modified the 19/06/2019 (at 09:54) by Erwan Jahier> *)
(* Time-stamp: <modified the 19/06/2019 (at 15:46) by Erwan Jahier> *)
(** Process programmer API *)
type 's neighbor = {
......@@ -35,26 +34,7 @@ type 's to_register = {
(** To be called once *)
val register : 's to_register -> unit
(** raised by sasa if one of the function above is not registred *)
exception Unregistred of string * string
(** Topological infos *)
val card : unit -> int
(* val degree : unit -> int *)
(* val diameter : unit -> int *)
(**/**)
(** The functions below are not part of the API *)
val verbose_level: int ref
val get_enable : algo_id -> 's enable_fun
val get_step : algo_id -> 's step_fun
val get_init_state : algo_id -> int -> 's
val get_actions : algo_id -> action list
val get_value_to_string : unit -> 's -> string
val get_copy_value : unit -> ('s -> 's)
val to_string : 's -> string
val set_card : int -> unit
(* val set_degree : int -> unit *)
(* val set_diameter : int -> unit *)
;; Time-stamp: <modified the 12/06/2019 (at 09:53) by Erwan Jahier>
;; Time-stamp: <modified the 19/06/2019 (at 15:28) by Erwan Jahier>
(library
(name algo)
(public_name algo)
(libraries lutils)
(libraries sasacore)
(synopsis "The Sasa Algo API")
)
......
(* Time-stamp: <modified the 12/06/2019 (at 08:05) by Erwan Jahier> *)
(* Time-stamp: <modified the 19/06/2019 (at 10:48) by Erwan Jahier> *)
type t =
| Synchronous (* select all actions *)
......@@ -39,7 +39,7 @@ let rec map3 f l1 l2 l3 =
| (_, [], _) -> invalid_arg "map3 (2nd arg too short)"
| (_, _, []) -> invalid_arg "map3 (3rd arg too short)"
type 'v pna = 'v Process.t * 'v Algo.neighbor list * Algo.action
type 'v pna = 'v Process.t * 'v Register.neighbor list * Register.action
let (custom: 'v pna list list -> 'v Process.t list -> bool list list ->
(string -> string -> bool) -> bool list list * 'v pna list) =
......
(* Time-stamp: <modified the 12/06/2019 (at 08:04) by Erwan Jahier> *)
(* Time-stamp: <modified the 19/06/2019 (at 10:50) by Erwan Jahier> *)
type t =
| Synchronous (* select all actions *)
......@@ -8,7 +8,7 @@ type t =
| Custom (* enable/actions are communicated via stdin/stdout in RIF *)
type 'v pna = 'v Process.t * 'v Algo.neighbor list * Algo.action
type 'v pna = 'v Process.t * 'v Register.neighbor list * Register.action
(** f dummy_input_flag verbose_mode demon pl actions_ll enab
......
;; Time-stamp: <modified the 15/03/2019 (at 16:11) by Erwan Jahier>
;; Time-stamp: <modified the 19/06/2019 (at 10:47) by Erwan Jahier>
(library
(name sasacore)
(public_name sasacore)
(libraries dynlink ocamlgraph algo lutils)
(libraries dynlink ocamlgraph lutils)
(synopsis "The Sasa main files (shared by the sasa exec and the rdbgPlugin")
)
......
(* Time-stamp: <modified the 17/06/2019 (at 22:12) by Erwan Jahier> *)
(* Time-stamp: <modified the 19/06/2019 (at 10:06) by Erwan Jahier> *)
module Dico = Map.Make(String)
......@@ -14,7 +14,7 @@ let (get: 'v t -> string -> 'v) =
let (get_copy: 'v t -> string -> 'v) =
fun e pid ->
let copy_value = Algo.get_copy_value () in
let copy_value = Register.get_copy_value () in
copy_value (get e pid)
......
(* Time-stamp: <modified the 18/06/2019 (at 22:04) by Erwan Jahier> *)
(* Time-stamp: <modified the 19/06/2019 (at 10:49) by Erwan Jahier> *)
type 'v t = {
pid : string;
actions: Algo.action list;
actions: Register.action list;
init : 'v;
enable : 'v Algo.enable_fun;
step : 'v Algo.step_fun ;
enable : 'v Register.enable_fun;
step : 'v Register.step_fun ;
}
......@@ -13,7 +13,7 @@ let (dynlink_nodes: string -> unit) =
fun ml ->
let id = Filename.chop_suffix ml ".ml" in
let cmxs = id^".cmxs" in
if !Algo.verbose_level > 0 then Printf.printf "Loading %s...\n" cmxs;
if !Register.verbose_level > 0 then Printf.printf "Loading %s...\n" cmxs;
Dynlink.loadfile (Dynlink.adapt_filename cmxs)
let (make: bool -> Topology.node -> 'v -> 'v t) =
......@@ -22,7 +22,7 @@ let (make: bool -> Topology.node -> 'v -> 'v t) =
let ml = n.Topology.file in
let id = Filename.chop_suffix ml ".ml" in
let actions =
try Algo.get_actions id
try Register.get_actions id
with _ ->
if custom_mode then
failwith "Registering actions is mandatory in algorithms when using custom demon!"
......@@ -32,8 +32,8 @@ let (make: bool -> Topology.node -> 'v -> 'v t) =
pid = pid;
init = init;
actions = actions;
enable = Algo.get_enable id;
step = Algo.get_step id;
enable = Register.get_enable id;
step = Register.get_step id;
}
in
process
......
(* Time-stamp: <modified the 18/06/2019 (at 22:05) by Erwan Jahier> *)
(* Time-stamp: <modified the 19/06/2019 (at 10:47) by Erwan Jahier> *)
(** There is such a Process.t per node in the dot file. *)
type 'v t = {
pid : string; (* unique *)
actions: Algo.action list;
actions: Register.action list;
init : 'v;
enable : 'v Algo.enable_fun;
step : 'v Algo.step_fun;
enable : 'v Register.enable_fun;
step : 'v Register.step_fun;
}
......
(* Time-stamp: <modified the 19/06/2019 (at 10:51) by Erwan Jahier> *)
type 's neighbor = {
state: 's ;
pid: unit -> string;
reply: unit -> int;
}
type algo_id = string
type action = string
type 's enable_fun = 's neighbor list -> 's -> action list
type 's step_fun = 's neighbor list -> 's -> action -> 's
type 's internal_tables = {
init_state: (string, Obj.t) Hashtbl.t;
enable : (string, Obj.t) Hashtbl.t;
step : (string, Obj.t) Hashtbl.t;
actions : (string, action list) Hashtbl.t;
value_to_string : (string, Obj.t) Hashtbl.t;
copy_value : (string, Obj.t) Hashtbl.t;
mutable card : int
}
let (tbls:'s internal_tables) = {
init_state = Hashtbl.create 1;
enable = Hashtbl.create 1;
step = Hashtbl.create 1;
actions = Hashtbl.create 1;
value_to_string = Hashtbl.create 1;
copy_value = Hashtbl.create 1;
card = (-1)
}
let verbose_level = ref 0
exception Unregistred of string * string
let print_table lbl tbl =
let keys = Hashtbl.fold (fun k _ acc -> Printf.sprintf "%s,%s" k acc) tbl "" in
if !verbose_level > 0 then Printf.printf "Defined keys for %s: %s\n" lbl keys;
flush stdout
let (reg_init_state : algo_id -> (int -> 's) -> unit) =
fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s init_vars\n" algo_id;
flush stdout;
Hashtbl.replace tbls.init_state algo_id (Obj.repr x)
let (get_init_state : algo_id -> int -> 's) =
fun algo_id ->
try Obj.obj (Hashtbl.find tbls.init_state algo_id)
with Not_found ->
print_table "init_state" tbls.init_state;
raise (Unregistred ("init_state", algo_id))
let (reg_enable : algo_id -> 's enable_fun -> unit) = fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s enable\n" algo_id;
flush stdout;
Hashtbl.replace tbls.enable algo_id (Obj.repr x)
let (get_enable : algo_id -> 's enable_fun) = fun algo_id ->
try Obj.obj (Hashtbl.find tbls.enable algo_id)
with Not_found ->
print_table "enable" tbls.enable;
raise (Unregistred ("enable", algo_id))
let (reg_step : algo_id -> 's step_fun -> unit) = fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s step\n" algo_id;
flush stdout;
Hashtbl.replace tbls.step algo_id (Obj.repr x)
let (get_step : algo_id -> 's step_fun) = fun algo_id ->
try Obj.obj (Hashtbl.find tbls.step algo_id)
with Not_found ->
print_table "step" tbls.step;
raise (Unregistred ("step", algo_id))
let (reg_actions : algo_id -> action list -> unit) =
fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s actions\n" algo_id;
flush stdout;
Hashtbl.replace tbls.actions algo_id x
let (get_actions : algo_id -> action list) = fun algo_id ->
try Hashtbl.find tbls.actions algo_id
with Not_found ->
print_table "actions" tbls.actions;
raise (Unregistred ("actions", algo_id))
let (reg_value_to_string : ('s -> string) -> unit) =
fun f ->
if !verbose_level > 0 then Printf.printf "Registering value_to_string\n";
flush stdout;
Hashtbl.replace tbls.value_to_string "_global" (Obj.repr f)
let (get_value_to_string : unit -> 's -> string) = fun () ->
try Obj.obj (Hashtbl.find tbls.value_to_string "_global")
with Not_found ->
print_table "value_to_string" tbls.value_to_string;
raise (Unregistred ("value_to_string", "_global"))
let (reg_copy_value : ('s -> 's) -> unit) =
fun f ->
if !verbose_level > 0 then Printf.printf "Registering copy_value\n";
flush stdout;
Hashtbl.replace tbls.copy_value "_global" (Obj.repr f)
let (get_copy_value : unit -> ('s -> 's)) = fun () ->
try Obj.obj (Hashtbl.find tbls.copy_value "_global")
with Not_found ->
print_table "copy_value" tbls.copy_value;
raise (Unregistred ("copy_value", "_global"))
let (card : unit -> int) =
fun () -> tbls.card
let (set_card : int -> unit) =
fun i ->
tbls.card <- i
let (to_string : 's -> string) =
fun v ->
(get_value_to_string ()) v
(* Time-stamp: <modified the 19/06/2019 (at 11:28) by Erwan Jahier> *)
type 's neighbor = {
state: 's ;
pid: unit -> string;
reply: unit -> int;
}
type algo_id = string
type action = string
type 's enable_fun = 's neighbor list -> 's -> action list
type 's step_fun = 's neighbor list -> 's -> action -> 's
val reg_init_state : algo_id -> (int -> 's) -> unit
val reg_enable : algo_id -> 's enable_fun -> unit
val reg_step : algo_id -> 's step_fun -> unit
val reg_actions : algo_id -> action list -> unit
val reg_value_to_string : ('s -> string) -> unit
val reg_copy_value : ('s -> 's) -> unit
val get_enable : algo_id -> 's enable_fun
val get_step : algo_id -> 's step_fun
val get_init_state : algo_id -> int -> 's
val get_actions : algo_id -> action list
val get_value_to_string : unit -> 's -> string
val get_copy_value : unit -> ('s -> 's)
val to_string : 's -> string
val set_card : int -> unit
(* val set_degree : int -> unit *)
(* val set_diameter : int -> unit *)
val card : unit -> int
(* val degree : unit -> int *)
(* val diameter : unit -> int *)
val verbose_level: int ref
(* Time-stamp: <modified the 18/06/2019 (at 22:17) by Erwan Jahier> *)
(* Time-stamp: <modified the 19/06/2019 (at 10:49) by Erwan Jahier> *)
open Algo
open Register
open Sasacore
let (update_env_with_init : 'v Env.t -> 'v Process.t list -> 'v Env.t) =
......@@ -23,7 +23,7 @@ let (reply: Topology.t -> string -> string -> int) =
in
f 0 (g.succ p_neighbor)
let (get_neighors: Topology.t -> Topology.node_id -> 'v -> 'v Algo.neighbor list) =
let (get_neighors: Topology.t -> Topology.node_id -> 'v -> 'v Register.neighbor list) =
fun g source_id init ->
let idl = g.succ source_id in
List.map
......@@ -39,7 +39,7 @@ let (get_neighors: Topology.t -> Topology.node_id -> 'v -> 'v Algo.neighbor list
)
idl
let (dump_process: 'v Process.t * 'v Algo.neighbor list -> unit) =
let (dump_process: 'v Process.t * 'v Register.neighbor list -> unit) =
fun (p,nl) ->
let pvars = String.concat "," (State.to_var_names p.pid p.init) in
let neighbors = List.map StringOf.algo_neighbor nl in
......@@ -54,14 +54,14 @@ let (update_env: 'v Env.t -> 'v Process.t * 'v -> 'v Env.t) =
open SasArg
let (update_neighbor_env: 'v Env.t -> 'v Algo.neighbor -> 'v Algo.neighbor) =
let (update_neighbor_env: 'v Env.t -> 'v Register.neighbor -> 'v Register.neighbor) =
fun e n ->
{ n with state= Env.get_copy e (n.Algo.pid ()) }
{ n with state= Env.get_copy e (n.Register.pid ()) }
type 'v layout = ('v Process.t * 'v Algo.neighbor list) list
type 'v layout = ('v Process.t * 'v Register.neighbor list) list
type 'v enable_processes =
('v Process.t * 'v Algo.neighbor list * Algo.action) list list * bool list list
('v Process.t * 'v Register.neighbor list * Register.action) list list * bool list list
let (get_enable_processes: 'v layout -> 'v Env.t -> 'v enable_processes) =
fun pl_n e ->
......@@ -86,7 +86,7 @@ let (get_enable_processes: 'v layout -> 'v Env.t -> 'v enable_processes) =
in
all, enab_ll
let (do_step : ('v Process.t * 'v Algo.neighbor list * action) list -> 'v Env.t
let (do_step : ('v Process.t * 'v Register.neighbor list * action) list -> 'v Env.t
-> 'v Env.t) =
fun pnal e ->
let lenv_list =
......@@ -165,17 +165,17 @@ let (make : bool -> string array -> 'v t) =
let nl = g.nodes in
let nidl = List.map (fun n -> n.Topology.id) nl in
let nstr = String.concat "," nidl in
Algo.set_card (List.length nl);
Algo.verbose_level := args.verbose;
Register.set_card (List.length nl);
Register.verbose_level := args.verbose;
Random.init args.seed;
if !Algo.verbose_level > 0 then Printf.eprintf "nodes: %s\nedges:\n" nstr;
if !Register.verbose_level > 0 then Printf.eprintf "nodes: %s\nedges:\n" nstr;
let algo_files = List.map (fun n -> n.Topology.file) nl in
if dynlink then List.iter Process.dynlink_nodes (List.sort_uniq compare algo_files);
let initl = List.map (fun n ->
let algo_id = Filename.chop_suffix n.Topology.file ".ml" in
Algo.get_init_state algo_id (List.length (g.succ n.id)))
Register.get_init_state algo_id (List.length (g.succ n.id)))
nl
in
......@@ -184,7 +184,7 @@ let (make : bool -> string array -> 'v t) =
let e = Env.init () in
let e = update_env_with_init e pl in
let pl_n = List.combine pl algo_neighors in
if !Algo.verbose_level > 0 then List.iter dump_process pl_n;
if !Register.verbose_level > 0 then List.iter dump_process pl_n;
if args.output_algos then (
let fl = List.map (fun n -> Filename.chop_extension n.Topology.file) nl in
let fl = List.sort_uniq compare fl in
......
(* Time-stamp: <modified the 12/06/2019 (at 08:09) by Erwan Jahier> *)
(* Time-stamp: <modified the 19/06/2019 (at 10:50) by Erwan Jahier> *)
(* XXX find a better name *)
type 'v layout = ('v Process.t * 'v Algo.neighbor list) list
type 'v layout = ('v Process.t * 'v Register.neighbor list) list
type 'v t = SasArg.t * 'v layout * 'v Env.t
(* [make argv] *)
val make : bool -> string array -> 'v t
type 'v enable_processes =
('v Process.t * 'v Algo.neighbor list * Algo.action) list list * bool list list
('v Process.t * 'v Register.neighbor list * Register.action) list list * bool list list
val get_enable_processes: 'v layout -> 'v Env.t -> 'v enable_processes