fixing escaping arcs

src/preproc/grc.ml

@@ -98,13 +98,15 @@ module Flowgraph = struct
       | Exit of int
       | Return_code of int
       | Local_signal of Ast.valued_signal
+      | Sync_a of int list
       | Instantiate_run of Ast.ident * Ast.signal Ast.run_param list * Ast.loc
       | Compressed of action * action
 
     type test_value =
       | Signal of Ast.signal * Ast.atom option
       | Selection of int
       | Sync of (int list * (t * Ast.ident) Utils.IntMap.t)
+      | Code of int
       | Is_paused of Ast.ident * Ast.signal Ast.run_param list * Ast.loc
       | Finished
 
@@ -185,13 +187,15 @@ module Flowgraph = struct
       | Exit of int
       | Return_code of int
       | Local_signal of valued_signal
+      | Sync_a of int list
       | Instantiate_run of ident * signal run_param list * loc
       | Compressed of action * action
 
     type test_value =
       | Signal of signal * atom option
       | Selection of int
       | Sync of (int list * (t * Ast.ident) IntMap.t)
+      | Code of int
       | Is_paused of ident * signal run_param list * loc
       | Finished
 
@@ -208,7 +212,7 @@ module Flowgraph = struct
     module Fgtbl = Hashtbl.Make(struct
         type t = flowgraph
         let hash = Hashtbl.hash
-        let equal = (==)
+        let equal = (=)
       end)
 
     module Synctbl = Hashtbl.Make(struct
@@ -351,7 +355,7 @@ module Flowgraph = struct
       match act with
       | Emit vs when vs.signal.ident.content = s.ident.content -> true
       | Compressed (a1, a2) -> emits s a1 || emits s a2
-      | Atom _ | Emit _ | Enter _ | Exit _
+      | Atom _ | Emit _ | Enter _ | Exit _ | Sync_a _
       | Return_code _ | Local_signal _ | Instantiate_run _ -> false
 
     let compress ?env fg =
@@ -396,7 +400,9 @@ module Flowgraph = struct
             Dot_pp.(font blue (fun fmt x -> fprintf fmt "%s ?" x)) s.ident.content
           | Selection i -> fprintf fmt "%d ?" i
           | Finished -> fprintf fmt "finished ?"
-          | Sync (lid, _c) -> fprintf fmt "sync(%a)" (MList.pp_iter ~sep:", " Format.pp_print_int) lid
+          | Code i -> fprintf fmt "code %d" i
+          | Sync (lid, _c) ->
+            fprintf fmt "sync(%a)" (MList.pp_iter ~sep:", " Format.pp_print_int) lid
           | Is_paused (id, _, _) -> fprintf fmt "paused %s ?" id.content
         end)
 
@@ -411,6 +417,8 @@ module Flowgraph = struct
       | Enter i -> fprintf fmt "%a" (bold @@ font darkgreen int) i
       | Return_code i -> fprintf fmt "ret %d" i
       | Exit i -> fprintf fmt "%a" (bold @@ font red int) i
+      | Sync_a lid ->
+        fprintf fmt "sync_a(%a)" (MList.pp_iter ~sep:", " Format.pp_print_int) lid
       | Instantiate_run (id, _, _) ->
         fprintf fmt "instantiate %a" (font darkgreen str) id.content
       | Local_signal vs ->
@@ -434,7 +442,9 @@ module Flowgraph = struct
           | Signal (s, Some at) ->
             fprintf fmt "Signal (%s, %a) " s.ident.content printexp at.exp
           | Selection i -> fprintf fmt "Selection %d" i
-          | Sync (lid, _) -> fprintf fmt "Sync(%a)" (MList.pp_iter ~sep:", " Format.pp_print_int) lid
+          | Code i -> fprintf fmt "Code %d" i
+          | Sync (lid, _) ->
+            fprintf fmt "Sync(%a)" (MList.pp_iter ~sep:", " Format.pp_print_int) lid
           | Finished -> fprintf fmt "Finished"
           | Is_paused (id, _, _) -> fprintf fmt "Is_paused %s" id.content
         end)
@@ -446,7 +456,9 @@ module Flowgraph = struct
           | Signal (s, Some at) ->
             fprintf fmt "(%s, %a)?" s.ident.content printexp at.exp
           | Selection i -> fprintf fmt "%d" i
-          | Sync (lid, _) -> fprintf fmt "(%a)" (MList.pp_iter ~sep:", " Format.pp_print_int) lid
+          | Code i -> fprintf fmt "c%d" i
+          | Sync (lid, _) ->
+            fprintf fmt "(%a)" (MList.pp_iter ~sep:", " Format.pp_print_int) lid
           | Finished -> fprintf fmt "f"
           | Is_paused (id, _, _) -> fprintf fmt "p(%s)?" id.content
         end)
@@ -458,6 +470,8 @@ module Flowgraph = struct
           | Atom _ -> fprintf fmt "Atom"
           | Enter i -> fprintf fmt "Enter %d" i
           | Exit i -> fprintf fmt "Exit %d" i
+          | Sync_a lid -> 
+            fprintf fmt "sa(%a)" (MList.pp_iter ~sep:", " Format.pp_print_int) lid
           | Return_code i -> fprintf fmt "Return_code %d" i
           | Instantiate_run (id, _, _) -> fprintf fmt "Instantiate_run %s" id.content
           | Local_signal vs -> fprintf fmt "Local_signal %s" vs.signal.ident.content
@@ -647,6 +661,17 @@ module Of_ast = struct
     let enter_node env p next = call env (Fg.Enter p.Tagged.id) next
     let sync_node env c (t1, t2, endt) = test_node env (Fg.Sync (c)) (t1, t2, endt)
 
+    let gen_codes ({ Fg.exits; _ } as env) lid fg =
+      if not @@ IntMap.is_empty exits then
+        let l = List.sort (fun (kx, _) (ky, _) -> compare ky kx)
+          @@ IntMap.bindings exits
+        in
+        call env (Fg.Sync_a lid) @@
+        List.fold_left (fun acc (code, (ex, _)) ->
+            test_node env (Code code) (ex, acc, Some ex)
+          ) fg l
+      else fg
+
 
     (* Both surface and depth use a hashconsing function memo_rec : The result
        of S(p) and D(p) is stored in a hashtbl indexed by p where p is the
@@ -662,7 +687,6 @@ module Of_ast = struct
           Fg.Grctbl.add h (x, p, e) y; y
       in g
 
-
     (** See the compiling rules in documentation *)
     let surface _o h =
       let open Tagged in let open Fg in
@@ -733,6 +757,7 @@ module Of_ast = struct
             with
             | Not_found ->
               let n = sync_node env (lid, env.exits) (pause, exit_node env p endp, None) in
+              let n = gen_codes env lid n in
               Synctbl.add env.synctbl lid n; n
           in
           let exits = IntMap.(fold (fun k (_, lbl) m ->
@@ -793,6 +818,7 @@ module Of_ast = struct
           let syn = try Synctbl.find env.synctbl lid with
             | Not_found ->
               let n = sync_node env (lid, env.exits) (pause, exit_node env p endp, None) in
+              let n = gen_codes env lid n in
               Synctbl.add env.synctbl lid n; n
           in
           let exits = IntMap.(fold (fun k (_, lbl) m ->

src/preproc/grc.mli

@@ -61,13 +61,15 @@ module Flowgraph : sig
       | Exit of int
       | Return_code of int
       | Local_signal of Ast.valued_signal
+      | Sync_a of int list
       | Instantiate_run of Ast.ident * Ast.signal Ast.run_param list * Ast.loc
       | Compressed of action * action
 
     type test_value =
       | Signal of Ast.signal * Ast.atom option
       | Selection of int
       | Sync of (int list * (t * Ast.ident) Utils.IntMap.t)
+      | Code of int
       | Is_paused of Ast.ident * Ast.signal Ast.run_param list * Ast.loc
       | Finished
 

src/preproc/grc2ml.ml

@@ -50,6 +50,7 @@ let remove_ident_renaming s =
 type ml_test_expr =
   | MLsig of Ast.signal
   | MLselect of int
+  | MLcode of int
   | MLor of ml_test_expr list
   | MLand of ml_test_expr * ml_test_expr
   | MLboolexpr of Ast.atom
@@ -77,6 +78,7 @@ and ml_ast =
 let rec pp_ml_test_expr fmt = Format.(function
   | MLsig s -> fprintf fmt "present %s" s.ident.content
   | MLselect i -> fprintf fmt "select %d" i
+  | MLcode i -> fprintf fmt "code %d" i
   | MLfinished -> fprintf fmt "finished"
   | MLor l ->
     fprintf fmt "%a" (MList.pp_iter ~sep:" || " pp_ml_test_expr) l
@@ -194,6 +196,7 @@ let rec mk_ml_action deps mr a =
   | Atom e -> mls @@ MLunitexpr e
   | Enter i -> mls @@ MLenter i
   | Exit i -> ml @@ MLexit i :: List.map (fun x -> MLexit x) deps.(i)
+  | Sync_a _ -> nop
   | Return_code i -> mls @@ MLreturn_code i
   | Local_signal vs -> mls @@ MLassign_signal (vs.signal.ident, MLexpr vs.svalue)
   | Instantiate_run (id, sigs, loc) ->
@@ -232,6 +235,7 @@ let mk_test_expr mr tv =
   | Signal (vs, Some at) ->
     mr := SignalSet.add vs !mr; MLand (MLsig vs, MLboolexpr at)
   | Selection i -> MLselect i
+  | Code i -> MLcode i
   | Sync (lid, _) -> MLor (List.map (fun x -> MLselect x) lid)
   | Finished -> MLfinished
   | Is_paused (id, sigs, loc) -> MLis_pause (MLcall (id, sigs, loc))

src/preproc/ml2ocaml.ml

@@ -431,6 +431,7 @@ let rec mk_test env depl test =
   match test with
   | MLsig s -> [%expr !?[%e add_deref_local s]]
   | MLselect i -> [%expr Bitset.mem [%e select_env_ident] [%e int_const i]]
+  | MLcode i -> [%expr Bitset.mem [%e return_codes_ident] [%e int_const i]]
   | MLor [] -> [%expr true]
   | MLor (h :: mltes) ->
     List.fold_left (fun acc mlt ->

tests/ppx/test2_ppx.ml

@@ -6,20 +6,22 @@ open Pendulum.Runtime_ast
 
 let dummyatom () = Format.printf "Hello\n"
 
+
 let%sync bug_exit_par_nested ~dsource ~print:(pdf,dot) i =
   trap pouet (
-    (* trap pouet2 (
-     *   !(print_endline "Ok0")
-     *   || *)
+    trap pouet2 (
+      !(print_endline "Ok0")
+      ||
       (!(print_endline "Ok1");
        loop (present i (exit pouet))
        ||
        (!(print_endline "Ok2"); (* exit pouet2 *))
       )
-    (* ) *)
+    )
   )
 
 
+
 (* TODO : Check never returns *)
 (* let%sync reincarnation2 o1 o2 (\* ~dsource *\) =
  *   loop (