Source map improvements

CHANGES.md

@@ -19,6 +19,7 @@
 * Compiler: warn on joo_global_object
 * Compiler: revisit static env handling (#1708)
 * Compiler: Emit index source_map to avoid changing mappings (#1714, #1715)
+* Compiler: improved source map generation (#1716)
 * Runtime: change Sys.os_type on windows (Cygwin -> Win32)
 * Runtime: backtraces are really expensive, they need to be be explicitly
   requested at compile time (--enable with-js-error) or at startup (OCAMLRUNPARAM=b=1)

compiler/bin-js_of_ocaml/compile.ml

@@ -79,7 +79,9 @@ let find_source file =
   match Builtins.find file with
   | Some f -> Some (Source_map.Source_content.create (Builtins.File.content f))
   | None ->
-      if Sys.file_exists file && not (Sys.is_directory file)
+      if String.equal file Js_output.blackbox_filename
+      then Some (Source_map.Source_content.create "(* generated code *)")
+      else if Sys.file_exists file && not (Sys.is_directory file)
       then
         let content = Fs.read_file file in
         Some (Source_map.Source_content.create content)
@@ -99,9 +101,18 @@ let sourcemap_section_of_info
         | None -> filename
         | Some _ -> Filename.concat "/builtin" filename)
   in
+  let ignore_list =
+    List.filter sources ~f:(fun filename -> String.is_prefix ~prefix:"/builtin/" filename)
+  in
   let offset, mappings = Source_map.Mappings.encode_with_offset mappings in
   let map =
-    { (base : Source_map.Standard.t) with sources; sources_content; names; mappings }
+    { (base : Source_map.Standard.t) with
+      sources
+    ; sources_content
+    ; names
+    ; mappings
+    ; ignore_list
+    }
   in
   { Source_map.Index.offset; map }
 

compiler/lib/code.ml

@@ -75,10 +75,6 @@ module Var : sig
 
   val compare : t -> t -> int
 
-  val get_loc : t -> Parse_info.t option
-
-  val loc : t -> Parse_info.t -> unit
-
   val name : t -> string -> unit
 
   val get_name : t -> string option
@@ -157,13 +153,10 @@ end = struct
 
   let printer = Var_printer.create Var_printer.Alphabet.javascript
 
-  let locations = Hashtbl.create 17
-
   let last_var = ref 0
 
   let reset () =
     last_var := 0;
-    Hashtbl.clear locations;
     Var_printer.reset printer
 
   let to_string ?origin i = Var_printer.to_string printer ?origin i
@@ -174,14 +167,6 @@ end = struct
 
   let name i nm = Var_printer.name printer i nm
 
-  let loc i pi = Hashtbl.add locations i pi
-
-  (*;
-    Format.eprintf "loc for %d : %d-%d\n%!"
-                   i pi.Parse_info.line pi.Parse_info.col
-  *)
-  let get_loc i = try Some (Hashtbl.find locations i) with Not_found -> None
-
   let fresh () =
     incr last_var;
     !last_var
@@ -199,11 +184,7 @@ end = struct
 
   let get_name i = Var_printer.get_name printer i
 
-  let propagate_name i j =
-    Var_printer.propagate_name printer i j;
-    match get_loc i with
-    | None -> ()
-    | Some l -> loc j l
+  let propagate_name i j = Var_printer.propagate_name printer i j
 
   let set_pretty b = Var_printer.set_pretty printer b
 
@@ -446,6 +427,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 +586,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 +888,13 @@ let invariant { blocks; start; _ } =
       | Set_field (_, _i, _, _) -> ()
       | Offset_ref (_x, _i) -> ()
       | Array_set (_x, _y, _z) -> ()
+      | Event _ -> ()
+    in
+    let rec check_events l =
+      match l with
+      | (Event _, _) :: (Event _, _) :: _ -> assert false
+      | _ :: r -> check_events r
+      | [] -> ()
     in
     let check_last (l, _loc) =
       match l with
@@ -925,5 +915,6 @@ let invariant { blocks; start; _ } =
       (fun _pc block ->
         List.iter block.params ~f:define;
         List.iter block.body ~f:check_instr;
+        check_events block.body;
         check_last block.branch)
       blocks)

compiler/lib/code.mli

@@ -68,10 +68,6 @@ module Var : sig
 
   val compare : t -> t -> int
 
-  val loc : t -> Parse_info.t -> unit
-
-  val get_loc : t -> Parse_info.t option
-
   val get_name : t -> string option
 
   val name : t -> string -> unit
@@ -229,6 +225,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

@@ -139,6 +139,28 @@ let dominance_frontier g idom =
     g.preds;
   frontiers
 
+(* Last instruction of a block, ignoring events *)
+let rec last_instr l =
+  match l with
+  | [] -> None
+  | [ i ] | [ i; (Event _, _) ] -> Some i
+  | _ :: rem -> last_instr rem
+
+(* Split a block, separating the last instruction from the preceeding
+   ones, ignoring events *)
+let block_split_last xs =
+  let rec aux acc = function
+    | [] -> None
+    | [ x ] | [ x; (Event _, _) ] -> Some (List.rev acc, x)
+    | x :: xs -> aux (x :: acc) xs
+  in
+  aux [] xs
+
+let empty_body b =
+  match b with
+  | [] | [ (Event _, _) ] -> true
+  | _ -> false
+
 (****)
 
 (*
@@ -176,7 +198,7 @@ let compute_needed_transformations ~cfg ~idom ~cps_needed ~blocks ~start =
       let block = Addr.Map.find pc blocks in
       (match fst block.branch with
       | Branch (dst, _) -> (
-          match List.last block.body with
+          match last_instr block.body with
           | Some
               ( Let
                   (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _)))
@@ -572,7 +594,7 @@ let cps_block ~st ~k pc block =
   in
 
   let rewritten_block =
-    match List.split_last block.body, block.branch with
+    match block_split_last block.body, block.branch with
     | Some (body_prefix, (Let (x, e), loc)), (Return ret, _loc_ret) ->
         Option.map (rewrite_instr x e loc) ~f:(fun f ->
             assert (List.is_empty alloc_jump_closures);
@@ -593,7 +615,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
@@ -847,7 +869,7 @@ let split_blocks ~cps_needed (p : Code.program) =
     let is_split_point i r branch =
       match i with
       | Let (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) ->
-          ((not (List.is_empty r))
+          ((not (empty_body r))
           ||
           match fst branch with
           | Branch _ -> false
@@ -904,7 +926,7 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program =
   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