Add an Event instruction

This is simpler than to associate a location to all instructions.
Also, this avoid the issue of locations getting lost because an
instruction gets optimized away.

Author: vouillon

compiler/lib/code.ml

@@ -446,6 +446,7 @@ type instr =
   | Set_field of Var.t * int * field_type * Var.t
   | Offset_ref of Var.t * int
   | Array_set of Var.t * Var.t * Var.t
+  | Event of Parse_info.t
 
 type last =
   | Return of Var.t
@@ -604,6 +605,7 @@ module Print = struct
     | Offset_ref (x, i) -> Format.fprintf f "%a[0] += %d" Var.print x i
     | Array_set (x, y, z) ->
         Format.fprintf f "%a[%a] = %a" Var.print x Var.print y Var.print z
+    | Event loc -> Format.fprintf f "event %s" (Parse_info.to_string loc)
 
   let last f (l, _loc) =
     match l with
@@ -905,6 +907,7 @@ let invariant { blocks; start; _ } =
       | Set_field (_, _i, _, _) -> ()
       | Offset_ref (_x, _i) -> ()
       | Array_set (_x, _y, _z) -> ()
+      | Event _ -> ()
     in
     let check_last (l, _loc) =
       match l with

compiler/lib/code.mli

@@ -229,6 +229,7 @@ type instr =
   | Set_field of Var.t * int * field_type * Var.t
   | Offset_ref of Var.t * int
   | Array_set of Var.t * Var.t * Var.t
+  | Event of Parse_info.t
 
 type last =
   | Return of Var.t

compiler/lib/deadcode.ml

@@ -90,7 +90,7 @@ and mark_reachable st pc =
     List.iter block.body ~f:(fun (i, _loc) ->
         match i with
         | Let (_, e) -> if not (pure_expr st.pure_funs e) then mark_expr st e
-        | Assign _ -> ()
+        | Event _ | Assign _ -> ()
         | Set_field (x, _, _, y) -> (
             match st.defs.(Var.idx x) with
             | [ Expr (Block _) ] when st.live.(Var.idx x) = 0 ->
@@ -125,7 +125,7 @@ let live_instr st i =
   match i with
   | Let (x, e) -> st.live.(Var.idx x) > 0 || not (pure_expr st.pure_funs e)
   | Assign (x, _) | Set_field (x, _, _, _) -> st.live.(Var.idx x) > 0
-  | Offset_ref _ | Array_set _ -> true
+  | Event _ | Offset_ref _ | Array_set _ -> true
 
 let rec filter_args st pl al =
   match pl, al with
@@ -201,7 +201,8 @@ let f ({ blocks; _ } as p : Code.program) =
           match i with
           | Let (x, e) -> add_def defs x (Expr e)
           | Assign (x, y) -> add_def defs x (Var y)
-          | Set_field (_, _, _, _) | Array_set (_, _, _) | Offset_ref (_, _) -> ());
+          | Event _ | Set_field (_, _, _, _) | Array_set (_, _, _) | Offset_ref (_, _) ->
+              ());
       match fst block.branch with
       | Return _ | Raise _ | Stop -> ()
       | Branch cont -> add_cont_dep blocks defs cont
@@ -228,10 +229,16 @@ let f ({ blocks; _ } as p : Code.program) =
             pc
             { params = List.filter block.params ~f:(fun x -> st.live.(Var.idx x) > 0)
             ; body =
-                List.filter_map block.body ~f:(fun (i, loc) ->
-                    if live_instr st i
-                    then Some (filter_closure all_blocks st i, loc)
-                    else None)
+                List.fold_left block.body ~init:[] ~f:(fun acc (i, loc) ->
+                    match i, acc with
+                    | Event _, (Event _, _) :: prev ->
+                        (* Avoid consecutive events (keep just the last one) *)
+                        (i, loc) :: prev
+                    | _ ->
+                        if live_instr st i
+                        then (filter_closure all_blocks st i, loc) :: acc
+                        else acc)
+                |> List.rev
             ; branch = filter_live_last all_blocks st block.branch
             }
             blocks)

compiler/lib/duplicate.ml

@@ -44,6 +44,7 @@ let instr s i =
   | Set_field (x, n, typ, y) -> Set_field (s x, n, typ, s y)
   | Offset_ref (x, n) -> Offset_ref (s x, n)
   | Array_set (x, y, z) -> Array_set (s x, s y, s z)
+  | Event _ -> i
 
 let instrs s l = List.map l ~f:(fun (i, loc) -> instr s i, loc)
 

compiler/lib/effects.ml

@@ -593,7 +593,7 @@ let cps_block ~st ~k pc block =
             in
             let instrs, branch = f ~k:k' in
             body_prefix, constr_cont @ instrs, branch)
-    | Some (_, ((Set_field _ | Offset_ref _ | Array_set _ | Assign _), _)), _
+    | Some (_, ((Event _ | Set_field _ | Offset_ref _ | Array_set _ | Assign _), _)), _
     | Some _, ((Raise _ | Stop | Cond _ | Switch _ | Pushtrap _ | Poptrap _), _)
     | None, _ -> None
   in
@@ -901,10 +901,18 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program =
       | None -> cont
   in
   let resolve cont = resolve_rec Addr.Set.empty cont in
+  let empty_body b =
+    List.for_all
+      ~f:(fun (i, _) ->
+        match i with
+        | Event _ -> true
+        | _ -> false)
+      b
+  in
   Addr.Map.iter
     (fun pc block ->
       match block with
-      | { params; body = []; branch = Branch cont, _; _ } ->
+      | { params; body; branch = Branch cont, _; _ } when empty_body body ->
           let args =
             List.fold_left
               ~f:(fun args x -> Var.Set.add x args)

compiler/lib/eval.ml

@@ -456,8 +456,11 @@ let rec do_not_raise pc visited blocks =
     let b = Addr.Map.find pc blocks in
     List.iter b.body ~f:(fun (i, _loc) ->
         match i with
-        | Array_set (_, _, _) | Offset_ref (_, _) | Set_field (_, _, _, _) | Assign _ ->
-            ()
+        | Event _
+        | Array_set (_, _, _)
+        | Offset_ref (_, _)
+        | Set_field (_, _, _, _)
+        | Assign _ -> ()
         | Let (_, e) -> (
             match e with
             | Block (_, _, _, _) | Field (_, _, _) | Constant _ | Closure _ -> ()

compiler/lib/flow.ml

@@ -122,7 +122,7 @@ let program_deps { blocks; _ } =
           | Assign (x, y) ->
               add_dep deps x y;
               add_assign_def vars defs x y
-          | Set_field _ | Array_set _ | Offset_ref _ -> ());
+          | Event _ | Set_field _ | Array_set _ | Offset_ref _ -> ());
       match fst block.branch with
       | Return _ | Raise _ | Stop -> ()
       | Branch cont | Poptrap cont -> cont_deps blocks vars deps defs cont
@@ -256,7 +256,7 @@ let program_escape defs known_origins { blocks; _ } =
       List.iter block.body ~f:(fun (i, _loc) ->
           match i with
           | Let (x, e) -> expr_escape st x e
-          | Assign _ -> ()
+          | Event _ | Assign _ -> ()
           | Set_field (x, _, _, y) | Array_set (x, _, y) ->
               Var.Set.iter
                 (fun y -> Var.ISet.add possibly_mutable y)

compiler/lib/freevars.ml

@@ -55,6 +55,7 @@ let iter_instr_free_vars f i =
       f y;
       f z
   | Assign (_, y) -> f y
+  | Event _ -> ()
 
 let iter_last_free_var f l =
   match l with
@@ -79,7 +80,7 @@ let iter_block_free_vars f block =
 let iter_instr_bound_vars f i =
   match i with
   | Let (x, _) -> f x
-  | Set_field _ | Offset_ref _ | Array_set _ | Assign _ -> ()
+  | Event _ | Set_field _ | Offset_ref _ | Array_set _ | Assign _ -> ()
 
 let iter_last_bound_vars f l =
   match l with

compiler/lib/generate.ml

@@ -345,14 +345,11 @@ let bool e = J.ECond (e, one, zero)
 
 (****)
 
-let source_location debug ?force (pc : Code.loc) =
-  match Parse_bytecode.Debug.find_loc debug ?force pc with
+let source_location ctx position pc =
+  match Parse_bytecode.Debug.find_loc ctx.Ctx.debug ~position pc with
   | Some pi -> J.Pi pi
   | None -> J.N
 
-let source_location_ctx ctx ?force (pc : Code.loc) =
-  source_location ctx.Ctx.debug ?force pc
-
 (****)
 
 let float_const f = J.ENum (J.Num.of_float f)
@@ -1101,14 +1098,14 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
       let (px, cx), queue = access_queue queue x in
       (Mlvalue.Block.field cx n, or_p px mutable_p, queue), []
   | Closure (args, ((pc, _) as cont)) ->
-      let loc = source_location_ctx ctx ~force:After (After pc) in
+      let loc = source_location ctx After pc in
       let fv = Addr.Map.find pc ctx.freevars in
       let clo = compile_closure ctx cont in
       let clo =
         match clo with
         | (st, x) :: rem ->
             let loc =
-              match x, source_location_ctx ctx (Before pc) with
+              match x, source_location ctx Before pc with
               | (J.U | J.N), (J.U | J.N) -> J.U
               | x, (J.U | J.N) -> x
               | (J.U | J.N), x -> x
@@ -1371,18 +1368,16 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
       in
       res, []
 
-and translate_instr ctx expr_queue instr =
-  let instr, pc = instr in
+and translate_instr ctx expr_queue loc instr =
+  let instr, _ = instr in
   match instr with
   | Assign (x, y) ->
-      let loc = source_location_ctx ctx pc in
       let (_py, cy), expr_queue = access_queue expr_queue y in
       flush_queue
         expr_queue
         mutator_p
         [ J.Expression_statement (J.EBin (J.Eq, J.EVar (J.V x), cy)), loc ]
   | Let (x, e) -> (
-      let loc = source_location_ctx ctx pc in
       let (ce, prop, expr_queue), instrs = translate_expr ctx expr_queue loc x e 0 in
       let keep_name x =
         match Code.Var.get_name x with
@@ -1408,15 +1403,13 @@ and translate_instr ctx expr_queue instr =
             prop
             (instrs @ [ J.variable_declaration [ J.V x, (ce, loc) ], loc ]))
   | Set_field (x, n, _, y) ->
-      let loc = source_location_ctx ctx pc in
       let (_px, cx), expr_queue = access_queue expr_queue x in
       let (_py, cy), expr_queue = access_queue expr_queue y in
       flush_queue
         expr_queue
         mutator_p
         [ J.Expression_statement (J.EBin (J.Eq, Mlvalue.Block.field cx n, cy)), loc ]
   | Offset_ref (x, n) ->
-      let loc = source_location_ctx ctx pc in
       (* FIX: may overflow.. *)
       let (_px, cx), expr_queue = access_queue expr_queue x in
       let expr = Mlvalue.Block.field cx 0 in
@@ -1429,20 +1422,20 @@ and translate_instr ctx expr_queue instr =
       in
       flush_queue expr_queue mutator_p [ J.Expression_statement expr', loc ]
   | Array_set (x, y, z) ->
-      let loc = source_location_ctx ctx pc in
       let (_px, cx), expr_queue = access_queue expr_queue x in
       let (_py, cy), expr_queue = access_queue expr_queue y in
       let (_pz, cz), expr_queue = access_queue expr_queue z in
       flush_queue
         expr_queue
         mutator_p
         [ J.Expression_statement (J.EBin (J.Eq, Mlvalue.Array.field cx cy, cz)), loc ]
+  | Event _ -> [], expr_queue
 
-and translate_instrs_rev (ctx : Ctx.t) expr_queue instrs acc_rev muts_map : _ * _ =
+and translate_instrs_rev (ctx : Ctx.t) loc expr_queue instrs acc_rev muts_map =
   match instrs with
-  | [] -> acc_rev, expr_queue
+  | [] -> loc, acc_rev, expr_queue
   | (Let (_, Closure _), _) :: _ ->
-      let names, pcs, all, rem = collect_closures instrs in
+      let names, pcs, all, rem, loc = collect_closures loc instrs in
       let fvs =
         List.fold_left pcs ~init:Code.Var.Set.empty ~f:(fun acc pc ->
             Code.Var.Set.union acc (Addr.Map.find pc ctx.freevars))
@@ -1519,13 +1512,13 @@ and translate_instrs_rev (ctx : Ctx.t) expr_queue instrs acc_rev muts_map : _ *
         List.fold_left
           all
           ~init:([], [], expr_queue)
-          ~f:(fun (mut_rec, st_rev, expr_queue) i ->
+          ~f:(fun (mut_rec, st_rev, expr_queue) (i, loc) ->
             let x' =
               match i with
               | Let (x', _), _ -> x'
               | _ -> assert false
             in
-            let l, expr_queue = translate_instr ctx expr_queue i in
+            let l, expr_queue = translate_instr ctx expr_queue loc i in
             if Code.Var.Set.mem x' fvs
             then
               let mut_rec =
@@ -1547,17 +1540,19 @@ and translate_instrs_rev (ctx : Ctx.t) expr_queue instrs acc_rev muts_map : _ *
       let acc_rev = vd Let bind_fvs_muts @ acc_rev in
       let acc_rev = funs_rev @ acc_rev in
       let acc_rev = vd Let bind_fvs_rec @ acc_rev in
-      translate_instrs_rev ctx expr_queue rem acc_rev muts_map
+      translate_instrs_rev ctx loc expr_queue rem acc_rev muts_map
+  | (Event loc, _) :: rem ->
+      translate_instrs_rev ctx (J.Pi loc) expr_queue rem acc_rev muts_map
   | instr :: rem ->
-      let st, expr_queue = translate_instr ctx expr_queue instr in
+      let st, expr_queue = translate_instr ctx expr_queue loc instr in
       let acc_rev = List.rev_append st acc_rev in
-      translate_instrs_rev ctx expr_queue rem acc_rev muts_map
+      translate_instrs_rev ctx loc expr_queue rem acc_rev muts_map
 
 and translate_instrs (ctx : Ctx.t) expr_queue instrs =
-  let st_rev, expr_queue =
-    translate_instrs_rev (ctx : Ctx.t) expr_queue instrs [] Var.Map.empty
+  let loc, st_rev, expr_queue =
+    translate_instrs_rev (ctx : Ctx.t) J.N expr_queue instrs [] Var.Map.empty
   in
-  List.rev st_rev, expr_queue
+  loc, List.rev st_rev, expr_queue
 
 (* Compile loops. *)
 and compile_block st queue (pc : Addr.t) scope_stack ~fall_through =
@@ -1591,7 +1586,7 @@ and compile_block st queue (pc : Addr.t) scope_stack ~fall_through =
           if debug () then Format.eprintf "}@]@,";
           let for_loop =
             ( J.For_statement (J.Left None, None, None, Js_simpl.block body)
-            , source_location_ctx st.ctx (Code.location_of_pc pc) )
+            , source_location st.ctx Before pc )
           in
           let label = if !lab_used then Some lab else None in
           let for_loop =
@@ -1613,7 +1608,7 @@ and compile_block_no_loop st queue (pc : Addr.t) ~fall_through scope_stack =
   if debug () then Format.eprintf "Compiling block %d@;" pc;
   st.visited_blocks := Addr.Set.add pc !(st.visited_blocks);
   let block = Addr.Map.find pc st.ctx.blocks in
-  let seq, queue = translate_instrs st.ctx queue block.body in
+  let loc, seq, queue = translate_instrs st.ctx queue block.body in
   let nbbranch =
     match fst block.branch with
     | Switch (_, a) ->
@@ -1635,7 +1630,7 @@ and compile_block_no_loop st queue (pc : Addr.t) ~fall_through scope_stack =
   in
   let rec loop ~scope_stack ~fall_through l =
     match l with
-    | [] -> compile_conditional st queue ~fall_through block.branch scope_stack
+    | [] -> compile_conditional st queue ~fall_through loc block.branch scope_stack
     | x :: xs -> (
         let l = J.Label.fresh () in
         let used = ref false in
@@ -1679,8 +1674,7 @@ and compile_decision_tree kind st scope_stack loc cx dtree ~fall_through =
         in
         ( never1 && never2
         , Js_simpl.if_statement
-            ~function_end:(fun () ->
-              source_location_ctx st.ctx ~force:After (After st.pc))
+            ~function_end:(fun () -> source_location st.ctx After st.pc)
             e'
             loc
             (Js_simpl.block iftrue)
@@ -1744,8 +1738,8 @@ and compile_decision_tree kind st scope_stack loc cx dtree ~fall_through =
   let never, code = loop cx scope_stack dtree in
   never, binds @ code
 
-and compile_conditional st queue ~fall_through last scope_stack : _ * _ =
-  let last, pc = last in
+and compile_conditional st queue ~fall_through loc last scope_stack : _ * _ =
+  let last, _ = last in
   (if debug ()
    then
      match last with
@@ -1756,7 +1750,6 @@ and compile_conditional st queue ~fall_through last scope_stack : _ * _ =
      | Stop -> Format.eprintf "stop;@;"
      | Cond (x, _, _) -> Format.eprintf "@[<hv 2>cond(%a){@;" Code.Var.print x
      | Switch (x, _) -> Format.eprintf "@[<hv 2>switch(%a){@;" Code.Var.print x);
-  let loc = source_location_ctx st.ctx pc in
   let res =
     match last with
     | Return x ->
@@ -1769,7 +1762,7 @@ and compile_conditional st queue ~fall_through last scope_stack : _ * _ =
           | ECall _ -> (
               (* We usually don't have a good locations for tail
                  calls, so use the end of the function instead *)
-              match source_location_ctx st.ctx ~force:After (After st.pc) with
+              match source_location st.ctx After st.pc with
               | J.N -> loc
               | loc -> loc)
           | _ -> loc
@@ -1940,12 +1933,14 @@ and compile_closure ctx (pc, args) =
   if debug () then Format.eprintf "}@]@;";
   res
 
-and collect_closures l =
+and collect_closures loc l =
   match l with
+  | (Event loc, _) :: ((Let (_, Closure _), _) :: _ as rem) ->
+      collect_closures (J.Pi loc) rem
   | ((Let (x, Closure (_, (pc, _))), _loc) as i) :: rem ->
-      let names', pcs', i', rem' = collect_closures rem in
-      x :: names', pc :: pcs', i :: i', rem'
-  | _ -> [], [], [], l
+      let names', pcs', i', rem', loc' = collect_closures loc rem in
+      x :: names', pc :: pcs', (i, loc) :: i', rem', loc'
+  | _ -> [], [], [], l, loc
 
 let generate_shared_value ctx =
   let strings =

compiler/lib/generate.mli

@@ -30,9 +30,3 @@ val f :
   -> Javascript.program
 
 val init : unit -> unit
-
-val source_location :
-     Parse_bytecode.Debug.t
-  -> ?force:Parse_bytecode.Debug.force
-  -> Code.loc
-  -> Javascript.location