Commit bf5cb12d authored by Erwan Jahier's avatar Erwan Jahier
Browse files

Add a exception contunuation to handle Lutin Exceptions correctly in rdbg.

parent 35dea30a
...@@ -23,7 +23,7 @@ clean: ...@@ -23,7 +23,7 @@ clean:
test.rif:$(EXPDIR) rabbit.cmxs test.rif:$(EXPDIR) rabbit.cmxs
rm -f test.rif0 .lurette_rc rm -f test.rif0 .lurette_rc
$(LURETTETOP) -go --output test.rif0 -seed 33 \ $(LURETTETOP) -go --output test.rif0 -seed 34 \
-rp "sut:ocaml:rabbit.cmxs:" \ -rp "sut:ocaml:rabbit.cmxs:" \
-rp 'env:lutin:rabbit.lut:-main:rabbit:-L:libm.so:-loc' && \ -rp 'env:lutin:rabbit.lut:-main:rabbit:-L:libm.so:-loc' && \
grep -v "lurette chronogram" test.rif0 | \ grep -v "lurette chronogram" test.rif0 | \
......
...@@ -699,7 +699,7 @@ type continuation = { ...@@ -699,7 +699,7 @@ type continuation = {
} }
type continuation_ldbg = { type continuation_ldbg = {
doit_ldbg:Event.ctx -> behavior -> (Event.ctx -> behavior -> Event.t) doit_ldbg:Event.ctx -> behavior -> (Event.ctx -> behavior -> Event.t)
-> (Event.ctx -> Event.t) -> Event.t; -> (Event.ctx -> Event.t) -> (Event.ctx -> string -> Event.t) -> Event.t;
dbg_ldbg: cont_mnemo list dbg_ldbg: cont_mnemo list
} }
...@@ -711,7 +711,7 @@ let (mk_cont : (behavior -> behavior) -> cont_mnemo -> continuation -> continuat ...@@ -711,7 +711,7 @@ let (mk_cont : (behavior -> behavior) -> cont_mnemo -> continuation -> continuat
let (mk_cont_ldbg : Event.ctx -> let (mk_cont_ldbg : Event.ctx ->
(Event.ctx -> behavior -> (Event.ctx -> behavior -> Event.t) -> (Event.ctx -> behavior -> (Event.ctx -> behavior -> Event.t) ->
(Event.ctx -> Event.t) -> Event.t) -> (Event.ctx -> Event.t) -> (Event.ctx -> string -> Event.t) -> Event.t) ->
cont_mnemo -> continuation_ldbg -> cont_mnemo -> continuation_ldbg ->
(Event.ctx -> continuation_ldbg -> Event.t) -> Event.t) = (Event.ctx -> continuation_ldbg -> Event.t) -> Event.t) =
fun ctx f d cin cont -> fun ctx f d cin cont ->
...@@ -1434,8 +1434,9 @@ let rec (genpath_ldbg : ...@@ -1434,8 +1434,9 @@ let rec (genpath_ldbg :
Event.ctx -> Event.ctx ->
(Event.ctx -> behavior -> Event.t) -> (Event.ctx -> behavior -> Event.t) ->
(Event.ctx -> Event.t) -> (Event.ctx -> Event.t) ->
(Event.ctx -> string -> Event.t) ->
Event.t) = Event.t) =
fun it data x ctx cont fail_cont -> (* data env = inputs + pres *) ( fun it data x ctx cont fail_cont excn_cont-> (* data env = inputs + pres *) (
(*-------------------------------------------*) (*-------------------------------------------*)
(* Correspondance id de trace -> trace exp (* Correspondance id de trace -> trace exp
N.B. on traque les récursions ? *) N.B. on traque les récursions ? *)
...@@ -1450,9 +1451,10 @@ let rec (genpath_ldbg : ...@@ -1450,9 +1451,10 @@ let rec (genpath_ldbg :
let rec (rec_genpath_ldbg : Event.ctx -> let rec (rec_genpath_ldbg : Event.ctx ->
branch_ldbg -> (Event.ctx -> behavior -> Event.t) -> branch_ldbg -> (Event.ctx -> behavior -> Event.t) ->
(Event.ctx -> Event.t) -> (Event.ctx -> Event.t) ->
(Event.ctx -> string -> Event.t) ->
Event.t Event.t
) = ) =
fun ctx br cont fail_cont -> ( fun ctx br cont fail_cont excn_cont-> (
let data = br.br_data_ldbg in let data = br.br_data_ldbg in
let x = br.br_ctrl_ldbg in let x = br.br_ctrl_ldbg in
let acc = br.br_acc_ldbg in let acc = br.br_acc_ldbg in
...@@ -1472,18 +1474,20 @@ let rec (genpath_ldbg : ...@@ -1472,18 +1474,20 @@ let rec (genpath_ldbg :
match br.br_ctrl_ldbg with match br.br_ctrl_ldbg with
(** Aliased trace *) (** Aliased trace *)
| TE_ref s -> ( | TE_ref s -> (
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg = id2trace s}) cont fail_cont) rec_genpath_ldbg ctx ({br with br_ctrl_ldbg = id2trace s})
cont fail_cont excn_cont)
(** Leaves: apply cont *) (** Leaves: apply cont *)
| TE_raise s -> br_cont.doit_ldbg ctx (Raise s) cont fail_cont | TE_raise s -> br_cont.doit_ldbg ctx (Raise s) cont fail_cont excn_cont
| TE_eps -> br_cont.doit_ldbg ctx Vanish cont fail_cont | TE_eps -> br_cont.doit_ldbg ctx Vanish cont fail_cont excn_cont
| TE_noeps e -> ( | TE_noeps e -> (
(** No eps: forbids e to vanish (but not to raise !) *) (** No eps: forbids e to vanish (but not to raise !) *)
let cont2 ctx noeps_cont = let cont2 ctx noeps_cont =
rec_genpath_ldbg rec_genpath_ldbg
ctx ({br with br_ctrl_ldbg=e; br_cont_ldbg=noeps_cont}) cont fail_cont ctx ({br with br_ctrl_ldbg=e; br_cont_ldbg=noeps_cont})
cont fail_cont excn_cont
in in
mk_cont_ldbg ctx mk_cont_ldbg ctx
(fun ctx a lcont fail_cont -> (fun ctx a lcont fail_cont excn_cont->
Verbose.exe ~flag:dbg Verbose.exe ~flag:dbg
(fun () -> (fun () ->
Printf.printf Printf.printf
...@@ -1491,7 +1495,7 @@ let rec (genpath_ldbg : ...@@ -1491,7 +1495,7 @@ let rec (genpath_ldbg :
(string_of_behavior a) (string_of_control_state x)); (string_of_behavior a) (string_of_control_state x));
match a with match a with
| Vanish -> fail_cont ctx | Vanish -> fail_cont ctx
| z -> br_cont.doit_ldbg ctx z lcont fail_cont | z -> br_cont.doit_ldbg ctx z lcont fail_cont excn_cont
) )
(Cnoeps) (Cnoeps)
br_cont br_cont
...@@ -1515,7 +1519,8 @@ let rec (genpath_ldbg : ...@@ -1515,7 +1519,8 @@ let rec (genpath_ldbg :
Event.nb = enb; Event.nb = enb;
Event.lang = "lutin"; Event.lang = "lutin";
Event.next = (fun () -> Event.next = (fun () ->
(br_cont.doit_ldbg ctx (Goto (new_acc, TE_eps)) cont fail_cont)); (br_cont.doit_ldbg ctx (Goto (new_acc, TE_eps))
cont fail_cont excn_cont));
Event.sinfo = Some (fun () -> { Event.sinfo = Some (fun () -> {
Event.expr = cstr; Event.expr = cstr;
Event.more = None; Event.more = None;
...@@ -1592,10 +1597,10 @@ let rec (genpath_ldbg : ...@@ -1592,10 +1597,10 @@ let rec (genpath_ldbg :
let (cont2 : Event.ctx -> continuation_ldbg -> Event.t) = let (cont2 : Event.ctx -> continuation_ldbg -> Event.t) =
fun ctx fby_cont -> fun ctx fby_cont ->
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=te1; rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=te1;
br_cont_ldbg=fby_cont}) cont fail_cont br_cont_ldbg=fby_cont}) cont fail_cont excn_cont
in in
mk_cont_ldbg ctx mk_cont_ldbg ctx
(fun ctx a lcont fail_cont -> (fun ctx a lcont fail_cont excn_cont->
Verbose.exe ~flag:dbg Verbose.exe ~flag:dbg
(fun () -> (fun () ->
Printf.printf "-- fby_cont (%s)\n in context %s\n" Printf.printf "-- fby_cont (%s)\n in context %s\n"
...@@ -1603,10 +1608,11 @@ let rec (genpath_ldbg : ...@@ -1603,10 +1608,11 @@ let rec (genpath_ldbg :
(string_of_control_state x)); (string_of_control_state x));
match a with match a with
| Goto (cl,n) -> | Goto (cl,n) ->
br_cont.doit_ldbg ctx (Goto (cl, put_in_seq n te2)) lcont fail_cont br_cont.doit_ldbg ctx (Goto (cl, put_in_seq n te2))
lcont fail_cont excn_cont
| Vanish -> rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=te2 }) | Vanish -> rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=te2 })
lcont fail_cont lcont fail_cont excn_cont
| Raise _ -> br_cont.doit_ldbg ctx a lcont fail_cont | Raise _ -> br_cont.doit_ldbg ctx a lcont fail_cont excn_cont
) )
(Cfby te2) (Cfby te2)
br_cont br_cont
...@@ -1616,9 +1622,10 @@ let rec (genpath_ldbg : ...@@ -1616,9 +1622,10 @@ let rec (genpath_ldbg :
| TE_prio (te::tel) -> ( | TE_prio (te::tel) -> (
(** Priority: Deadlock is catched HERE *) (** Priority: Deadlock is catched HERE *)
let fail_cont ctx = let fail_cont ctx =
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=(TE_prio tel)}) cont fail_cont rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=(TE_prio tel)})
cont fail_cont excn_cont
in in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=te}) cont fail_cont rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=te}) cont fail_cont excn_cont
) )
(** Try similar to a recurse priority *) (** Try similar to a recurse priority *)
| TE_try (e,eco) -> ( | TE_try (e,eco) -> (
...@@ -1627,22 +1634,24 @@ let rec (genpath_ldbg : ...@@ -1627,22 +1634,24 @@ let rec (genpath_ldbg :
| Some e' -> e' | Some e' -> e'
| None -> TE_eps | None -> TE_eps
in in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=ec}) cont fail_cont rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=ec}) cont fail_cont excn_cont
in in
let cont2 ctx try_cont = let cont2 ctx try_cont =
rec_genpath_ldbg ctx rec_genpath_ldbg ctx
({br with br_ctrl_ldbg=e; br_cont_ldbg=try_cont}) cont fail_cont ({br with br_ctrl_ldbg=e; br_cont_ldbg=try_cont})
cont fail_cont excn_cont
in in
mk_cont_ldbg ctx mk_cont_ldbg ctx
(fun ctx a lcont fail_cont -> (fun ctx a lcont fail_cont excn_cont ->
Verbose.exe ~flag:dbg Verbose.exe ~flag:dbg
(fun () -> (fun () ->
Printf.printf "-- try_cont (%s)\n in context %s\n" Printf.printf "-- try_cont (%s)\n in context %s\n"
(string_of_behavior a) (string_of_control_state x)); (string_of_behavior a) (string_of_control_state x));
match a with match a with
| Goto (cl,n) -> | Goto (cl,n) ->
br_cont.doit_ldbg ctx (Goto (cl, TE_try (n,eco))) lcont fail_cont br_cont.doit_ldbg ctx (Goto (cl, TE_try (n,eco)))
| _ -> br_cont.doit_ldbg ctx a lcont fail_cont lcont fail_cont excn_cont
| _ -> br_cont.doit_ldbg ctx a lcont fail_cont excn_cont
) )
(Ctry eco) (Ctry eco)
br_cont br_cont
...@@ -1657,14 +1666,14 @@ let rec (genpath_ldbg : ...@@ -1657,14 +1666,14 @@ let rec (genpath_ldbg :
TE_eps TE_eps
] ]
in in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont excn_cont
) )
(** INFINITE STRONG LOOP *) (** INFINITE STRONG LOOP *)
(* must behaves exactly as: (te\eps fby omega te) *) (* must behaves exactly as: (te\eps fby omega te) *)
| TE_omega te -> ( | TE_omega te -> (
let e' = put_in_seq (TE_noeps te) (TE_omega te) let e' = put_in_seq (TE_noeps te) (TE_omega te)
in in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont excn_cont
) )
(** ASSERT *) (** ASSERT *)
(* default assert is WEAK for backward compatibility (* default assert is WEAK for backward compatibility
...@@ -1681,7 +1690,7 @@ let rec (genpath_ldbg : ...@@ -1681,7 +1690,7 @@ let rec (genpath_ldbg :
, ,
None None
) in ) in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont excn_cont
) )
(** STRONG ASSERT *) (** STRONG ASSERT *)
(* must behave EXACTLY as (* must behave EXACTLY as
...@@ -1697,7 +1706,7 @@ let rec (genpath_ldbg : ...@@ -1697,7 +1706,7 @@ let rec (genpath_ldbg :
, ,
None None
) in ) in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont excn_cont
) )
(** Exist: problem modifies the data and support, and the cont *) (** Exist: problem modifies the data and support, and the cont *)
| TE_exist (ectx, te) -> ( | TE_exist (ectx, te) -> (
...@@ -1718,20 +1727,20 @@ let rec (genpath_ldbg : ...@@ -1718,20 +1727,20 @@ let rec (genpath_ldbg :
let new_pres = List.fold_left addp data.pres ectx in let new_pres = List.fold_left addp data.pres ectx in
let new_data = {data with pres=new_pres} in let new_data = {data with pres=new_pres} in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=te; br_data_ldbg = new_data }) rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=te; br_data_ldbg = new_data })
cont fail_cont cont fail_cont excn_cont
) )
(** Parallel: at least one ? *) (** Parallel: at least one ? *)
| TE_para ([]) -> assert false | TE_para ([]) -> assert false
| TE_para ([e]) -> rec_genpath_ldbg ctx ({br with br_ctrl_ldbg = e }) | TE_para ([e]) -> rec_genpath_ldbg ctx ({br with br_ctrl_ldbg = e })
cont fail_cont cont fail_cont excn_cont
| TE_para (e::el) -> ( | TE_para (e::el) -> (
(* continuation for the head statement *) (* continuation for the head statement *)
let cont2 ctx para_head_cont = let cont2 ctx para_head_cont =
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e; rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e;
br_cont_ldbg=para_head_cont}) cont fail_cont br_cont_ldbg=para_head_cont}) cont fail_cont excn_cont
in in
mk_cont_ldbg ctx mk_cont_ldbg ctx
( fun ctx a lcont fail_cont -> ( fun ctx a lcont fail_cont excn_cont->
Verbose.exe Verbose.exe
~flag:dbg ~flag:dbg
(fun () -> (fun () ->
...@@ -1739,11 +1748,11 @@ let rec (genpath_ldbg : ...@@ -1739,11 +1748,11 @@ let rec (genpath_ldbg :
(string_of_behavior a) (string_of_control_state x)); (string_of_behavior a) (string_of_control_state x));
match a with match a with
(* 1st raises s: whole raises s *) (* 1st raises s: whole raises s *)
| Raise s -> br_cont.doit_ldbg ctx (Raise s) lcont fail_cont | Raise s -> br_cont.doit_ldbg ctx (Raise s) lcont fail_cont excn_cont
(* 1st vanishes: others continue *) (* 1st vanishes: others continue *)
| Vanish -> ( | Vanish -> (
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg = TE_para(el)}) rec_genpath_ldbg ctx ({br with br_ctrl_ldbg = TE_para(el)})
lcont fail_cont lcont fail_cont excn_cont
) )
(* 1st do a trans ... *) (* 1st do a trans ... *)
| Goto (cl,n) -> ( | Goto (cl,n) -> (
...@@ -1757,20 +1766,21 @@ let rec (genpath_ldbg : ...@@ -1757,20 +1766,21 @@ let rec (genpath_ldbg :
rec_genpath_ldbg ctx ({br with rec_genpath_ldbg ctx ({br with
br_ctrl_ldbg= TE_para(el); br_ctrl_ldbg= TE_para(el);
br_acc_ldbg=tail_acc; br_acc_ldbg=tail_acc;
br_cont_ldbg=para_tail_cont}) lcont fail_cont br_cont_ldbg=para_tail_cont}) lcont fail_cont excn_cont
in in
mk_cont_ldbg ctx mk_cont_ldbg ctx
(fun ctx a lcont fail_cont -> (fun ctx a lcont fail_cont excn_cont->
match a with match a with
(* others vanish, 1st continue *) (* others vanish, 1st continue *)
| Vanish -> br_cont.doit_ldbg | Vanish -> br_cont.doit_ldbg
ctx (Goto (cl,n)) lcont fail_cont ctx (Goto (cl,n)) lcont fail_cont excn_cont
(* others raise -> forbidden *) (* others raise -> forbidden *)
| Raise s -> fail_cont ctx | Raise s -> fail_cont ctx
| Goto (tcl, tn) -> ( | Goto (tcl, tn) -> (
(* N.B. cl IS ALREADY accumulated in tcl *) (* N.B. cl IS ALREADY accumulated in tcl *)
br_cont.doit_ldbg br_cont.doit_ldbg
ctx (Goto (tcl, put_in_para n tn)) lcont fail_cont ctx (Goto (tcl, put_in_para n tn))
lcont fail_cont excn_cont
) )
) )
(Cpara_tail (cl, n)) (Cpara_tail (cl, n))
...@@ -1786,10 +1796,10 @@ let rec (genpath_ldbg : ...@@ -1786,10 +1796,10 @@ let rec (genpath_ldbg :
| TE_catch (i,e,eco) -> ( | TE_catch (i,e,eco) -> (
let cont2 ctx catch_cont = let cont2 ctx catch_cont =
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e ; rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e ;
br_cont_ldbg=catch_cont}) cont fail_cont br_cont_ldbg=catch_cont}) cont fail_cont excn_cont
in in
mk_cont_ldbg ctx mk_cont_ldbg ctx
(fun ctx a lcont fail_cont -> (fun ctx a lcont fail_cont excn_cont ->
Verbose.exe Verbose.exe
~flag:dbg ~flag:dbg
(fun () -> (fun () ->
...@@ -1798,17 +1808,17 @@ let rec (genpath_ldbg : ...@@ -1798,17 +1808,17 @@ let rec (genpath_ldbg :
match a with match a with
| Goto (cl,n) -> | Goto (cl,n) ->
br_cont.doit_ldbg ctx (Goto (cl, TE_catch(i, n, eco))) br_cont.doit_ldbg ctx (Goto (cl, TE_catch(i, n, eco)))
lcont fail_cont lcont fail_cont excn_cont
| Raise x -> ( | Raise x -> (
if ( x == i) then ( if ( x == i) then (
match eco with match eco with
| None -> br_cont.doit_ldbg ctx Vanish lcont fail_cont | None -> br_cont.doit_ldbg ctx Vanish lcont fail_cont excn_cont
| Some ec -> | Some ec ->
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=ec }) rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=ec })
lcont fail_cont lcont fail_cont excn_cont
) else br_cont.doit_ldbg ctx (Raise x) lcont fail_cont ) else br_cont.doit_ldbg ctx (Raise x) lcont fail_cont excn_cont
) )
| _ -> br_cont.doit_ldbg ctx a lcont fail_cont | _ -> br_cont.doit_ldbg ctx a lcont fail_cont excn_cont
) )
(Ccatch (i,eco)) (Ccatch (i,eco))
br_cont br_cont
...@@ -1837,7 +1847,7 @@ let rec (genpath_ldbg : ...@@ -1837,7 +1847,7 @@ let rec (genpath_ldbg :
| [] -> raise LocalDeadlock | [] -> raise LocalDeadlock
| [(_,e)] -> e | [(_,e)] -> e
| _ -> TE_dyn_choice (sum, cel) | _ -> TE_dyn_choice (sum, cel)
in rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont in rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont excn_cont
with LocalDeadlock -> fail_cont ctx with LocalDeadlock -> fail_cont ctx
) )
(* ad hoc node for dynamic simulation: (* ad hoc node for dynamic simulation:
...@@ -1865,7 +1875,7 @@ let rec (genpath_ldbg : ...@@ -1865,7 +1875,7 @@ let rec (genpath_ldbg :
| (wc,e)::cel' -> | (wc,e)::cel' ->
TE_prio [ e; TE_dyn_choice (sum - wc, cel') ] TE_prio [ e; TE_dyn_choice (sum - wc, cel') ]
in in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont excn_cont
) )
(** Probabilistic loops (** Probabilistic loops
just like for choice, we use an ad hoc internal structure just like for choice, we use an ad hoc internal structure
...@@ -1893,7 +1903,7 @@ let rec (genpath_ldbg : ...@@ -1893,7 +1903,7 @@ let rec (genpath_ldbg :
| _ -> TE_dyn_choice (gw+sw, [ (gw, goon_branch);(sw, TE_eps)]) | _ -> TE_dyn_choice (gw+sw, [ (gw, goon_branch);(sw, TE_eps)])
) )
in in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont excn_cont
with LocalDeadlock -> fail_cont ctx with LocalDeadlock -> fail_cont ctx
) )
(** N.B. the "cpt" here is a unique identifier used for compilation (** N.B. the "cpt" here is a unique identifier used for compilation
...@@ -1906,7 +1916,7 @@ let rec (genpath_ldbg : ...@@ -1906,7 +1916,7 @@ let rec (genpath_ldbg :
if ((imin >= 0) && (imin <= imax)) then ( if ((imin >= 0) && (imin <= imax)) then (
(* HERE *) (* HERE *)
let e' = TE_dyn_loop (LoopWeights.interval imin imax, 0, te) in let e' = TE_dyn_loop (LoopWeights.interval imin imax, 0, te) in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont excn_cont
) else ( ) else (
(* HERE: need to have a real notion of run-time error with source ref *) (* HERE: need to have a real notion of run-time error with source ref *)
let msg = Printf.sprintf let msg = Printf.sprintf
...@@ -1925,7 +1935,7 @@ let rec (genpath_ldbg : ...@@ -1925,7 +1935,7 @@ let rec (genpath_ldbg :
if ((iec > 0) && (iav > iec) && (iec <= ((20 * iav) /100))) then ( if ((iec > 0) && (iav > iec) && (iec <= ((20 * iav) /100))) then (
(* HERE *) (* HERE *)
let e' = TE_dyn_loop (LoopWeights.average iav iec, 0, te) in let e' = TE_dyn_loop (LoopWeights.average iav iec, 0, te) in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'}) cont fail_cont excn_cont
) else ( ) else (
(* HERE: need to have a real notion of run-time error with source ref *) (* HERE: need to have a real notion of run-time error with source ref *)
let msg = Printf.sprintf let msg = Printf.sprintf
...@@ -1968,16 +1978,16 @@ let rec (genpath_ldbg : ...@@ -1968,16 +1978,16 @@ let rec (genpath_ldbg :
let zeexe = of_expanded_code it.arg_opt zecode in let zeexe = of_expanded_code it.arg_opt zecode in
let inits = get_init_internal_state zeexe in let inits = get_init_internal_state zeexe in
let (cont2: Event.ctx -> Reactive.prg_ldbg -> (Event.ctx -> Event.t) let (cont2: Event.ctx -> Reactive.prg_ldbg -> (Event.ctx -> Event.t)
-> Event.t) = -> (Event.ctx -> string -> Event.t) -> Event.t) =
fun ctx zereact fail_cont -> fun ctx zereact fail_cont excn_cont->
let outids = List.map (fun (id,_) -> id) vars in let outids = List.map (fun (id,_) -> id) vars in
(* build the initial TE_dyn_erun *) (* build the initial TE_dyn_erun *)
let e' = TE_dyn_erun_ldbg (rid, zereact, outids, args, e) in let e' = TE_dyn_erun_ldbg (rid, zereact, outids, args, e) in
rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e'; rec_genpath_ldbg ctx ({br with br_ctrl_ldbg=e';
br_data_ldbg = new_data}) cont fail_cont br_data_ldbg = new_data}) cont fail_cont excn_cont
in in
cont2 ctx (Reactive.DoStep_ldbg (to_reactive_prg_ldbg rid zeexe inits)) cont2 ctx (Reactive.DoStep_ldbg (to_reactive_prg_ldbg rid zeexe inits))
fail_cont fail_cont excn_cont
(* builds the corresponding abstract reactive prg *) (* builds the corresponding abstract reactive prg *)
) )
...@@ -1985,9 +1995,23 @@ let rec (genpath_ldbg : ...@@ -1985,9 +1995,23 @@ let rec (genpath_ldbg :
| TE_dyn_erun_ldbg (rid, react, vars, args, e) -> ( | TE_dyn_erun_ldbg (rid, react, vars, args, e) -> (
(* Evaluates args in context *) (* Evaluates args in context *)
let eval_arg x = compute_exp it data x in let eval_arg x = compute_exp it data x in
let fail_cont ctx =
let msg = Printf.sprintf
"Run-time error: unexpected END while running \"%s\"" rid
in
raise (Global_error msg)
in
let excn_cont ctx x =
let msg =
Printf.sprintf
"Run-time error: unexpected EXCEPTION \"%s\" when running \"%s\""
x rid
in
raise (Global_error msg)
in
let ins = List.map eval_arg args in let ins = List.map eval_arg args in
(* call the reactive prog *) (* call the reactive prog *)
try (
let (cont3 : Event.ctx -> Reactive.prg_ldbg -> Value.t list -> Event.t) = let (cont3 : Event.ctx -> Reactive.prg_ldbg -> Value.t list -> Event.t) =
fun ctx react' outs -> fun ctx react' outs ->
(* stores the values in the LocalIns vars *) (* stores the values in the LocalIns vars *)
...@@ -2009,10 +2033,10 @@ let rec (genpath_ldbg : ...@@ -2009,10 +2033,10 @@ let rec (genpath_ldbg :
({br with ({br with
br_ctrl_ldbg=e; br_ctrl_ldbg=e;
br_data_ldbg = new_data; br_data_ldbg = new_data;
br_cont_ldbg=run_cont}) cont fail_cont br_cont_ldbg=run_cont}) cont fail_cont excn_cont
in in
mk_cont_ldbg ctx mk_cont_ldbg ctx
(fun ctx a lcont fail_cont -> (fun ctx a lcont fail_cont excn_cont ->
Verbose.exe Verbose.exe
~flag:dbgrun ~flag:dbgrun
(fun () -> (fun () ->
...@@ -2022,8 +2046,8 @@ let rec (genpath_ldbg : ...@@ -2022,8 +2046,8 @@ let rec (genpath_ldbg :
| Goto (cl,n) -> | Goto (cl,n) ->
br_cont.doit_ldbg ctx br_cont.doit_ldbg ctx
(Goto (cl, TE_dyn_erun_ldbg(rid,react',vars, args, n))) (Goto (cl, TE_dyn_erun_ldbg(rid,react',vars, args, n)))
lcont fail_cont lcont fail_cont excn_cont
| _ -> br_cont.doit_ldbg ctx a lcont fail_cont | _ -> br_cont.doit_ldbg ctx a lcont fail_cont excn_cont
) )
(Crun (rid)) (Crun (rid))
br_cont br_cont
...@@ -2045,25 +2069,11 @@ let rec (genpath_ldbg : ...@@ -2045,25 +2069,11 @@ let rec (genpath_ldbg :
Event.data = ctx.Event.ctx_data; Event.data = ctx.Event.ctx_data;
Event.sinfo = None; Event.sinfo = None;
Event.next = Event.next =
(fun () -> Reactive.step_ldbg ctx react ins cont3 fail_cont);