Skip to content

GitLab

Commit 9d0c853a authored by erwan's avatar erwan
Browse files

Update: monadisation of Lutin, part 4. 

Rationale: make rdbg time traveling work.
parent 7a6ac267
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 3332 additions and 4179 deletions
_oasis
View file @ 9d0c853a
......@@ -27,7 +27,7 @@ Executable lutin
Path: lutin/src
MainIs: main.ml
BuildDepends: str,unix,num,rdbg-plugin (>= 1.177),lutin-utils,ezdl,gbddml,polka,camlp4,camlidl,gmp
NativeOpt: -package num # XXX turn around a bug in oasis/ocamlbuild/ocamlfind?
NativeOpt: -warn-error "+26" -package num # XXX turn around a bug in oasis/ocamlbuild/ocamlfind?
Build: true
Install:true
CompiledObject: native
......
ltop/src/lurettetop.ml
View file @ 9d0c853a
......@@ -73,7 +73,7 @@ let main_read_arg () =
args.tmp_dir <- lurette_tmp_dir;
Unix.putenv "TMPDIR" (String.escaped lurette_tmp_dir) ;
in
let source_dir = (Filename.concat (ExtTools.lurette_path()) "source") in
let _source_dir = (Filename.concat (ExtTools.lurette_path()) "source") in
match args.sut_compiler with
| Scade -> assert false
| VerimagV4
......
ltop/src/runDirect.ml
View file @ 9d0c853a
......@@ -89,7 +89,7 @@ let (make_rp_list : reactive_program list ->
(Data.subst list -> ctx -> (Data.subst list -> ctx -> Event.t) ->
Event.t) list * Data.subst list list * Data.subst list list) =
fun rpl ->
let add_init init (a,b,c,d,e) = (a,b,c,d,e,init,init) in
let _add_init init (a,b,c,d,e) = (a,b,c,d,e,init,init) in
let aux rp =
let plugin =
match rp with
......
lurette-nocaml/src/lurette.ml
View file @ 9d0c853a
(* Time-stamp: <modified the 29/03/2019 (at 14:53) by Erwan Jahier> *)
(* Time-stamp: <modified the 11/04/2019 (at 14:56) by Erwan Jahier> *)
(* Mimick the behavior of 'rdbg -lurette', but without the dependency
on ocaml *)
open Event
......@@ -77,11 +77,11 @@ let _ =
args.verbose <- if !verbose then 1 else 0 ;
args.output <- !output_file ;
args.overwrite_output = !overwrite_output;
args.stop_on_oracle_error = not !dont_stop_on_oracle_error;
args.log = !log;
args.cov_file = !cov_file;
args.reset_cov_file = !reset_cov_file;
args.overwrite_output <- !overwrite_output;
args.stop_on_oracle_error <- not !dont_stop_on_oracle_error;
args.log <- !log;
args.cov_file <- !cov_file;
args.reset_cov_file <- !reset_cov_file;
args.debug_rdbg <- !drdbg;
args.rdbg <- false;
......
lutin/src/auto2Lucky.ml
View file @ 9d0c853a
......@@ -42,13 +42,13 @@ let print_header
)
open Util
let make
(srcname: string)
(mnode : string)
(auto : AutoGen.t)
(os : Pervasives.out_channel) =
(
(* le source au cas ou ... *)
let source_code = AutoGen.source auto in
......@@ -61,8 +61,7 @@ let make
let etab2prof s xi acc = (
(s, xi.xi_prof)::acc
) in
let xlist = Hashtbl.fold etab2prof
(Expand.extern_tab source_code) [] in
let xlist = Util.StringMap.fold etab2prof (Expand.extern_tab source_code) [] in
if (xlist = []) then ()
else (
fprintf os "\nfunctions {\n";
......@@ -79,7 +78,7 @@ let make
(* pour les dumps des vars support *)
(* Hashtbl.iter (print_support Local) (Expand.support_tab source_code); *)
let print_support nme = (
let info = Util.hfind (Expand.support_tab source_code) nme in
let info = Util.StringMap.find nme (Expand.support_tab source_code) in
fprintf os " %s : %s"
(CoIdent.to_string nme)
(CkTypeEff.to_string info.si_type);
......@@ -104,8 +103,7 @@ let make
(* pour les dumps de la liste d'alias *)
let print_alias nme = (
let info = Util.hfind
(Expand.alias_tab source_code) nme in
let info = StringMap.find nme (Expand.alias_tab source_code) in
fprintf os " %s : %s"
(CoIdent.to_string nme)
(CkTypeEff.to_string info.ai_type);
......
lutin/src/autoExplore.ml deleted 100644 → 0
View file @ 7a6ac267
This diff is collapsed.
lutin/src/autoGen.ml
View file @ 9d0c853a
......@@ -354,12 +354,8 @@ let gentrans
(* Correspondance id de trace -> trace exp
N.B. on traque les récursions ? *)
(*-------------------------------------------*)
let id2trace s = (
(Util.hfind (Expand.trace_tab xenv) s).ti_def_exp
) in
let unalias s = (
(Util.hfind (Expand.alias_tab xenv) s).ai_def_exp
) in
let id2trace s = (StringMap.find s (Expand.trace_tab xenv)).ti_def_exp in
let unalias s = (StringMap.find s (Expand.alias_tab xenv)).ai_def_exp in
(*-------------------------------------------*)
(* LA FONCTION RÉCURSIVE *)
......@@ -891,7 +887,7 @@ let init (xenv : Expand.t) =
}
in
let is = Expand.main_trace xenv in
let ie = (Util.hfind (Expand.trace_tab xenv) is).ti_def_exp in
let ie = (Util.StringMap.find is (Expand.trace_tab xenv)).ti_def_exp in
let init_control, res = get_stable res ie in
let final_control, res = get_sink res "vanish" in
{ res with
......@@ -924,12 +920,9 @@ let rec ttree2trans (it:t) (src: string) (tt : ttree) = (
)
let get_state_def (it:t) (ix: string) =
StringMap.find ix it._state2trace
let get_state_def (it:t) (ix: string) = StringMap.find ix it._state2trace
let get_state_info (it:t) (ix: string) =
StringMap.find ix it.states
let get_state_info (it:t) (ix: string) = StringMap.find ix it.states
(*
*)
......
lutin/src/ckTypeEff.ml
View file @ 9d0c853a
......@@ -191,20 +191,20 @@ let rec of_texp = ( function
x ref -> x
*)
let lifts_to t1 t2 = (
let res =
(t1 = t2)
or ((t1 = boolref) && (t2 = boolean))
or ((t1 = boolean) && (t2 = trace))
or ((t1 = boolref) && (t2 = trace))
or ((t1 = integer) && (t2 = weight))
or ((t1 = intref) && (t2 = weight))
or (
match (t1,t2) with
(TEFF_ref x, TEFF_data y) -> (x = y)
| _ -> false
)
in
res
let res =
(t1 = t2)
|| ((t1 = boolref) && (t2 = boolean))
|| ((t1 = boolean) && (t2 = trace))
|| ((t1 = boolref) && (t2 = trace))
|| ((t1 = integer) && (t2 = weight))
|| ((t1 = intref) && (t2 = weight))
|| (
match (t1,t2) with
(TEFF_ref x, TEFF_data y) -> (x = y)
| _ -> false
)
in
res
)
(* compatibilit d'un profil avec une liste de types de params
Renvoie le type eff du rsultat ou lve une exception :
......
lutin/src/coAlgExp.ml
View file @ 9d0c853a
......@@ -95,7 +95,7 @@ let of_alias i t c =
{ ae_type = t; ae_ctrl = c; ae_val = AE_alias i }
let of_call i t args = (
let f b ae = (b or ae.ae_ctrl) in
let f b ae = (b || ae.ae_ctrl) in
let c = List.fold_left f false args in
{ ae_type = t; ae_ctrl = c; ae_val = AE_call (i, args)}
)
......
lutin/src/exp.ml
View file @ 9d0c853a
......@@ -238,7 +238,7 @@ let rec (simplifie_a_little : formula -> formula) =
let f1' = simplifie_a_little f1
and f2' = simplifie_a_little f2
in
if f1 <> f1' or f2 <> f2' then
if f1 <> f1' || f2 <> f2' then
simplifie_a_little (And(f1', f2'))
else
And(f1', f2')
......@@ -246,7 +246,7 @@ let rec (simplifie_a_little : formula -> formula) =
let f1' = simplifie_a_little f1
and f2' = simplifie_a_little f2 in
let f12' = Or(f1', f2') in
if f1 <> f1' or f2 <> f2' then
if f1 <> f1' || f2 <> f2' then
simplifie_a_little f12'
else
f12'
......
lutin/src/expand.ml
View file @ 9d0c853a
This diff is collapsed.
lutin/src/expand.mli
View file @ 9d0c853a
......@@ -49,26 +49,28 @@ val make : CheckEnv.t -> Syntaxe.package -> string -> t
type support_scope
type support_nature =
Input
| Output
| LocalIn
| LocalOut
and support_info = {
| Input
| Output
| LocalIn
| LocalOut
type support_info = {
si_ident : CoIdent.t ;
si_nature : support_nature ;
si_type : CkTypeEff.t ;
si_ref_exp : CoAlgExp.t ;
si_src : CoIdent.src_stack;
(* on ne la crée qu'à la demande *)
mutable si_pre_ref_exp : CoAlgExp.t option ;
si_pre_ref_exp : CoAlgExp.t option ;
si_default : CoAlgExp.t option ;
si_scope : support_scope option ;
si_init : CoAlgExp.t option ;
si_range : (CoAlgExp.t *CoAlgExp.t) option ;
}
open Util
(* support_info that are actually used in pre's *)
val support_tab : t -> (CoIdent.t, support_info) Hashtbl.t
val support_tab : t -> support_info StringMap.t
(* support_info that are actually used in pre's *)
val support_pres : t -> (CoIdent.t * support_info) list
......@@ -91,12 +93,12 @@ type alias_info = {
ai_src : CoIdent.src_stack
}
val alias_tab : t -> (CoIdent.t, alias_info) Hashtbl.t
val alias_tab : t -> alias_info StringMap.t
val alias_list : t -> CoIdent.t list
(* Run tab *)
(* not necessary ?
val run_tab : t -> (CoIdent.t, t) Hashtbl.t
val run_tab : t -> (CoIdent.t, t) StringMap.t
*)
val get_run_expanded_code : t -> CoIdent.t -> t
......@@ -108,7 +110,7 @@ type trace_info = {
ti_src : CoIdent.src_stack ;
}
val trace_tab : t -> (CoIdent.t, trace_info) Hashtbl.t
val trace_tab : t -> trace_info StringMap.t
val get_trace_info : t -> CoIdent.t -> trace_info
......@@ -124,7 +126,7 @@ type extern_info = {
xi_src : Lexeme.t
}
val extern_tab : t -> (string, extern_info) Hashtbl.t
val extern_tab : t -> extern_info StringMap.t
(** Identificateur (target) de la trace principale *)
val main_trace : t -> CoIdent.t
......
lutin/src/luc2alice.ml
View file @ 9d0c853a
......@@ -233,15 +233,9 @@ let (gen_alice_stub_c : alice_args -> unit) =
fun args ->
let amn = Filename.basename args.alice_module_name in
let oc = my_open_out (Filename.concat args.output_dir (amn ^ ".cpp")) in
let put s = output_string oc s in
let putln s = output_string oc (s^"\n") in
let rec putlist = function
[] -> ()
| [x] -> put x
| x::l' -> put x; put ", "; putlist l'
in
putln (Util.entete "// " "");
putln (gen_alice_stub args)
putln (Util.entete "// " "");
putln (gen_alice_stub args)
let (gen_alice_stub_h : alice_args -> unit) =
......
lutin/src/luc2c.ml
View file @ 9d0c853a
......@@ -480,7 +480,7 @@ Input procedures must be used:
)
in_vars;
let lut_file = (List.hd option.env) (* only work with lutin XXX fixme? *) in
let _lut_file = (List.hd option.env) (* only work with lutin XXX fixme? *) in
(* let lut_dir = Filename.dirname lut_file in *)
putln ("
/*--------
......
lutin/src/lucFGen.ml
View file @ 9d0c853a
......@@ -83,119 +83,119 @@ let (get_all_formula: t -> formula list) =
fun a ->
let rec aux a acc =
let (a', f, _nl) = choose_one_formula a in
if no_more_formula a' then acc else (aux a' (f::acc))
if no_more_formula a' then acc else (aux a' (f::acc))
in
aux a []
(****************************************************************************)
let rec (wt_list_to_cont : Var.env_in -> Prog.state -> wt_cont list ->
formula -> node list -> t -> t) =
formula -> node list -> t -> t) =
fun input state wtl facc nl fgen ->
(* [nl] is the list of nodes that correspond to [facc] *)
let _ = if debug then (print_string "XXX wt_list_to_cont\n"; flush stdout) in
match wtl with
| [] -> Cont (fun () -> (fgen, facc, nl))
| wt::wtl' ->
if wt = WFinish then
fgen
else
match choose_one_formula_atomic input state facc wt with
| WFinish, False, "" ->
fgen
| WStop str, _, "" ->
RStop str
| wt2, f2, n ->
let fgen' =
Cont (fun () ->
call_cont (wt_list_to_cont input state (wt2::wtl') facc nl fgen))
in
wt_list_to_cont input state wtl' f2 (n::nl) fgen'
match wtl with
| [] -> Cont (fun () -> (fgen, facc, nl))
| wt::wtl' ->
if wt = WFinish then
fgen
else
match choose_one_formula_atomic input state facc wt with
| WFinish, False, "" ->
fgen
| WStop str, _, "" ->
RStop str
| wt2, f2, n ->
let fgen' =
Cont (fun () ->
call_cont (wt_list_to_cont input state (wt2::wtl') facc nl fgen))
in
wt_list_to_cont input state wtl' f2 (n::nl) fgen'
and
(choose_one_formula_atomic : Var.env_in -> Prog.state ->
Exp.formula -> wt_cont -> wt_cont * formula * node) =
(choose_one_formula_atomic : Var.env_in -> Prog.state ->
Exp.formula -> wt_cont -> wt_cont * formula * node) =
fun input state facc cont ->
let _ = if debug then (print_string "XXX choose_one_formula_atomic\n"; flush stdout) in
match cont with
| WFinish -> WFinish, False, ""
| WStop _ -> cont, True, ""
| WCont _ ->
let (cont', f, n) = call_wt_cont cont in
let _ = if debug then (print_string ("XXX "^ n ^ "\n"); flush stdout) in
let facc' =
match f,facc with
True, True -> True
| True, f -> f
| f, True -> f
| _,_ -> And(f,facc)
in
let ctx_msg = Prog.ctrl_state_to_string_long state.d.ctrl_state in
Utils.time_C "is_sat";
let sat = (Solver.is_satisfiable input state.d.memory state.d.verbose ctx_msg facc' "") in
Utils.time_R "is_sat";
if sat then (cont', facc', n)
else choose_one_formula_atomic input state facc cont'
match cont with
| WFinish -> WFinish, False, ""
| WStop _ -> cont, True, ""
| WCont _ ->
let (cont', f, n) = call_wt_cont cont in
let _ = if debug then (print_string ("XXX "^ n ^ "\n"); flush stdout) in
let facc' =
match f,facc with
True, True -> True
| True, f -> f
| f, True -> f
| _,_ -> And(f,facc)
in
let ctx_msg = Prog.ctrl_state_to_string_long state.d.ctrl_state in
Utils.time_C "is_sat";
let sat = (Solver.is_satisfiable input state.d.memory state.d.verbose ctx_msg facc' "") in
Utils.time_R "is_sat";
if sat then (cont', facc', n)
else choose_one_formula_atomic input state facc cont'
and (wt_to_cont : Var.env_in -> Prog.state -> wt -> wt_cont -> wt_cont) =
fun input state (tbl, n) cont ->
let _ = if debug then (print_string ("XXX wt_to_cont "^ n ^"\n"); flush stdout) in
let children = Util.StringMap.find n tbl in
match children with
| Prog.Stop str -> WStop str
| Leave (f,nstate) -> WCont(fun () -> (cont, f, nstate))
| Children l ->
if l = [] then
cont
else
let (l1, l2) = List.partition (fun (dw,_) -> dw = Infin) l in
(match l1 with
| [] ->
let get_weigth dw =
match dw with
| V i -> if i < 0 then 0 else i (* a negative weight means null weigth *)
| Infin -> assert false
in
let w_sum =
List.fold_left (fun acc (dw,_) -> acc+(get_weigth dw)) 0 l2
in
if w_sum = 0 then cont else
let j = 1 + Random.int w_sum in
let rec get_jth_trans j list acc =
match list with
[] -> assert false
| (dw,nt)::tail ->
let newj = j - (get_weigth dw) in
if (newj < 1) then
nt, (rev_append acc tail)
else
get_jth_trans newj tail ((dw,nt)::acc)
in
let (nt,l2') = get_jth_trans j l2 [] in
let tbl' = Util.StringMap.add n (Children l2') tbl in
let tbl'' = Util.StringMap.remove n tbl in (* to optimize mem *)
let cont' = WCont(fun () ->
call_wt_cont (wt_to_cont input state (tbl', n) cont)
)
in
wt_to_cont input state (tbl'', nt) cont'
| [(_,nt)] ->
let tbl' = Util.StringMap.add n (Children l2) tbl in
let tbl'' = Util.StringMap.remove n tbl in
let cont' = WCont(fun () ->
call_wt_cont (wt_to_cont input state (tbl', n) cont)
)
in
wt_to_cont input state (tbl'', nt) cont'
| _::_ ->
failwith
"Only one transition with a infinite weigth is allowed"
)
match children with
| Prog.Stop str -> WStop str
| Leave (f,nstate) -> WCont(fun () -> (cont, f, nstate))
| Children l ->
if l = [] then
cont
else
let (l1, l2) = List.partition (fun (dw,_) -> dw = Infin) l in
(match l1 with
| [] ->
let get_weigth dw =
match dw with
| V i -> if i < 0 then 0 else i (* a negative weight means null weigth *)
| Infin -> assert false
in
let w_sum =
List.fold_left (fun acc (dw,_) -> acc+(get_weigth dw)) 0 l2
in
if w_sum = 0 then cont else
let j = 1 + Random.int w_sum in
let rec get_jth_trans j list acc =
match list with
[] -> assert false
| (dw,nt)::tail ->
let newj = j - (get_weigth dw) in
if (newj < 1) then
nt, (rev_append acc tail)
else
get_jth_trans newj tail ((dw,nt)::acc)
in
let (nt,l2') = get_jth_trans j l2 [] in
let tbl' = Util.StringMap.add n (Children l2') tbl in
let tbl'' = Util.StringMap.remove n tbl in (* to optimize mem *)
let cont' = WCont(fun () ->
call_wt_cont (wt_to_cont input state (tbl', n) cont)
)
in
wt_to_cont input state (tbl'', nt) cont'
| [(_,nt)] ->
let tbl' = Util.StringMap.add n (Children l2) tbl in
let tbl'' = Util.StringMap.remove n tbl in
let cont' = WCont(fun () ->
call_wt_cont (wt_to_cont input state (tbl', n) cont)
)
in
wt_to_cont input state (tbl'', nt) cont'
| _::_ ->
failwith
"Only one transition with a infinite weigth is allowed"
)
(****************************************************************************)
(* NO LONGER EXPORTED *)
let (_internal_get : Var.env_in -> Prog.state -> t list) =
......@@ -214,7 +214,7 @@ Utils.time_R "wt_to_cont";
Utils.time_C "wt_list_to_cont";
let res = wt_list_to_cont input state wt_cont_l True [] Finish in
Utils.time_R "wt_list_to_cont";
res
res
)
nll
......@@ -222,17 +222,17 @@ Utils.time_R "wt_list_to_cont";
(* EXPORTED *)
let rec (fgen_of_t : t -> FGen.t) =
fun t ->
{
FGen.choose_one_formula = (
fun () ->
let (t',s,f) = choose_one_formula t in
(fgen_of_t t',s,f)
) ;
FGen.get_all_formula = (
fun () -> get_all_formula t
)
}
fun t ->
{
FGen.choose_one_formula = (
fun () ->
let (t',s,f) = choose_one_formula t in
(fgen_of_t t',s,f)
) ;
FGen.get_all_formula = (
fun () -> get_all_formula t
)
}
let get i s = List.map fgen_of_t (_internal_get i s)
lutin/src/lutExe.ml
View file @ 9d0c853a
This diff is collapsed.
lutin/src/lutExe.mli
View file @ 9d0c853a
......@@ -81,8 +81,7 @@ val find_some_sols : t -> Thickness.formula_draw_nb -> Thickness.numeric -> guar
val find_one_sol : t -> guard -> (Var.env_out * Var.env_loc)
(* the "t" is given in order to filter necessary pres, not really necessary *)
val make_pre : t -> Var.env_in -> Var.env_out -> Var.env_loc -> Var.env
val make_pre : Var.env_in -> Var.env_out -> Var.env_loc -> Var.env
(*
May raise Deadlock (or Event.Error ("deadlock",event))
......
lutin/src/lutProg.ml
View file @ 9d0c853a
......@@ -320,7 +320,7 @@ let init_vars (it: t) = (
(***********************************************************)
let add_support mode it id = (
let nme = CoIdent.to_string id in
let info = Util.hfind (Expand.support_tab source_code) id in
let info = Util.StringMap.find id (Expand.support_tab source_code) in
(* Verbose.put ~flag:dbg " LutProg.add_support \"%s\"\n" nme; *)
let res = lucky_make_var it mnode nme (lucky_type_of info.Expand.si_type) mode info.Expand.si_range in
(* init ? *)
......@@ -344,7 +344,7 @@ let init_vars (it: t) = (
let add_alias it id = (
let nme = CoIdent.to_string id in
Verbose.put ~flag:dbg " LutProg.add_alias \"%s\"\n" nme;
let info = Util.hfind (Expand.alias_tab source_code) id in
let info = Util.StringMap.find id (Expand.alias_tab source_code) in
(* les alias sont des Local spciaux en lucky *)
let res = Var.set_alias
(lucky_make_var it mnode nme (lucky_type_of info.Expand.ai_type) Var.Local None)
......
lutin/src/lutinRun.ml
View file @ 9d0c853a
(* Time-stamp: <modified the 10/04/2019 (at 10:10) by Erwan Jahier> *)
(* Time-stamp: <modified the 12/04/2019 (at 11:32) by Erwan Jahier> *)
(**********************************************************************************)
type vars = (string * Data.t) list
......@@ -23,6 +23,10 @@ open RdbgPlugin
type ctx = Event.t
type e = Event.t
let compact str =