Source map improvements

compiler/bin-wasm_of_ocaml/compile.ml

@@ -43,7 +43,10 @@ let update_sourcemap ~sourcemap_root ~sourcemap_don't_inline_content sourcemap_f
       else
         Some
           (List.map source_map.sources ~f:(fun file ->
-               if Sys.file_exists file && not (Sys.is_directory file)
+               if String.equal file Wa_source_map.blackbox_filename
+               then
+                 Some (Source_map.Source_content.create Wa_source_map.blackbox_contents)
+               else if Sys.file_exists file && not (Sys.is_directory file)
                then Some (Source_map.Source_content.create (Fs.read_file file))
                else None))
     in
@@ -52,6 +55,10 @@ let update_sourcemap ~sourcemap_root ~sourcemap_don't_inline_content sourcemap_f
         sources_content
       ; sourceroot =
           (if Option.is_some sourcemap_root then sourcemap_root else source_map.sourceroot)
+      ; ignore_list =
+          (if List.mem Wa_source_map.blackbox_filename ~set:source_map.sources
+           then [ Wa_source_map.blackbox_filename ]
+           else [])
       }
     in
     Source_map.to_file (Standard source_map) sourcemap_file)

compiler/lib/wasm/wa_ast.ml

@@ -191,8 +191,7 @@ and instruction =
   | StructSet of var * int * expression * expression
   | Return_call of var * expression list
   | Return_call_ref of var * expression * expression list
-  | Location of Parse_info.t option * instruction
-      (** Instruction with attached location information *)
+  | Event of Parse_info.t  (** Location information *)
 
 type import_desc =
   | Fun of func_type

compiler/lib/wasm/wa_code_generation.ml

@@ -285,16 +285,21 @@ let blk l st =
   let (), st = l { st with instrs = [] } in
   List.rev st.instrs, { st with instrs }
 
-let with_location loc instrs st =
-  let (), st = instrs st in
+let event loc : unit t =
+ fun st ->
   ( ()
-  , { st with
-      instrs =
-        (match st.instrs with
-        | [] -> []
-        | Location (_, i) :: rem -> Location (loc, i) :: rem
-        | i :: rem -> Location (loc, i) :: rem)
-    } )
+  , match st.instrs with
+    | Event _ :: instrs | instrs -> { st with instrs = Event loc :: instrs } )
+
+let hidden_location =
+  { Parse_info.src = Some Wa_source_map.blackbox_filename
+  ; name = None
+  ; col = 0
+  ; line = 1
+  ; idx = 0
+  }
+
+let no_event = event hidden_location
 
 let cast ?(nullable = false) typ e =
   let* e = e in
@@ -457,13 +462,11 @@ let get_i31_value x st =
       let x = Var.fresh () in
       let x, st = add_var ~typ:I32 x st in
       Some x, { st with instrs = LocalSet (x', RefI31 (LocalTee (x, e))) :: rem }
-  | Location (loc, LocalSet (x', RefI31 e)) :: rem when Code.Var.equal x x' && is_smi e ->
+  | Event loc :: LocalSet (x', RefI31 e) :: rem when Code.Var.equal x x' && is_smi e ->
       let x = Var.fresh () in
       let x, st = add_var ~typ:I32 x st in
       ( Some x
-      , { st with
-          instrs = Location (loc, LocalSet (x', RefI31 (LocalTee (x, e)))) :: rem
-        } )
+      , { st with instrs = Event loc :: LocalSet (x', RefI31 (LocalTee (x, e))) :: rem } )
   | _ -> None, st
 
 let load x =

compiler/lib/wasm/wa_code_generation.mli

@@ -138,7 +138,9 @@ val is_small_constant : Wa_ast.expression -> bool t
 
 val get_i31_value : Wa_ast.var -> Wa_ast.var option t
 
-val with_location : Parse_info.t option -> unit t -> unit t
+val event : Parse_info.t -> unit t
+
+val no_event : unit t
 
 type type_def =
   { supertype : Wa_ast.var option

compiler/lib/wasm/wa_curry.ml

@@ -71,6 +71,7 @@ module Make (Target : Wa_target_sig.S) = struct
     in
     let f = Code.Var.fresh_n "f" in
     let body =
+      let* () = no_event in
       let* () = bind_parameters args in
       let* _ = add_var f in
       let* args' = expression_list load args in
@@ -121,6 +122,7 @@ module Make (Target : Wa_target_sig.S) = struct
     let x = Code.Var.fresh_n "x" in
     let f = Code.Var.fresh_n "f" in
     let body =
+      let* () = no_event in
       let* _ = add_var x in
       let* _ = add_var f in
       push (Closure.curry_allocate ~cps:false ~arity m ~f:name' ~closure:f ~arg:x)
@@ -141,6 +143,7 @@ module Make (Target : Wa_target_sig.S) = struct
     in
     let f = Code.Var.fresh_n "f" in
     let body =
+      let* () = no_event in
       let* () = bind_parameters args in
       let* _ = add_var f in
       let* args' = expression_list load args in
@@ -192,6 +195,7 @@ module Make (Target : Wa_target_sig.S) = struct
     let cont = Code.Var.fresh_n "cont" in
     let f = Code.Var.fresh_n "f" in
     let body =
+      let* () = no_event in
       let* _ = add_var x in
       let* _ = add_var cont in
       let* _ = add_var f in
@@ -215,6 +219,7 @@ module Make (Target : Wa_target_sig.S) = struct
     in
     let f = Code.Var.fresh_n "f" in
     let body =
+      let* () = no_event in
       let* () = bind_parameters l in
       let* _ = add_var f in
       Memory.check_function_arity
@@ -248,6 +253,7 @@ module Make (Target : Wa_target_sig.S) = struct
     in
     let f = Code.Var.fresh_n "f" in
     let body =
+      let* () = no_event in
       let* () = bind_parameters l in
       let* _ = add_var f in
       Memory.check_function_arity
@@ -287,6 +293,7 @@ module Make (Target : Wa_target_sig.S) = struct
     in
     let f = Code.Var.fresh_n "f" in
     let body =
+      let* () = no_event in
       let* () = bind_parameters l in
       let* _ = add_var f in
       let* typ, closure = Memory.load_real_closure ~cps ~arity (load f) in

compiler/lib/wasm/wa_gc_target.ml

@@ -1679,14 +1679,18 @@ let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler =
        try_
          { params = []; result = [] }
          (body ~result_typ:[] ~fall_through:(`Block (-1)) ~context:(`Skip :: context))
-         [ ocaml_tag, store ~always:true x (return (W.Pop Value.value))
+         [ ( ocaml_tag
+           , let* () = no_event in
+             store ~always:true x (return (W.Pop Value.value)) )
          ; ( js_tag
-           , let exn = Code.Var.fresh () in
+           , let* () = no_event in
+             let exn = Code.Var.fresh () in
              let* () = store ~always:true ~typ:externref exn (return (W.Pop externref)) in
              let* exn = load exn in
              store ~always:true x (return (W.Call (f, [ exn ]))) )
          ]
      in
+     let* () = no_event in
      exn_handler ~result_typ ~fall_through ~context)
 
 let post_process_function_body = Wa_initialize_locals.f

compiler/lib/wasm/wa_generate.ml

@@ -38,7 +38,6 @@ module Generate (Target : Wa_target_sig.S) = struct
     ; global_context : Wa_code_generation.context
     ; debug : Parse_bytecode.Debug.t
     }
-  [@@warning "-69"]
 
   type repr =
     | Value
@@ -675,37 +674,34 @@ module Generate (Target : Wa_target_sig.S) = struct
             | (Not | Lt | Le | Eq | Neq | Ult | Array_get | IsInt | Vectlength), _ ->
                 assert false))
 
-  and translate_instr ctx context loc i =
-    with_location
-      loc
-      (match i with
-      | Assign (x, y) -> assign x (load y)
-      | Let (x, e) ->
-          if ctx.live.(Var.idx x) = 0
-          then drop (translate_expr ctx context x e)
-          else store x (translate_expr ctx context x e)
-      | Set_field (x, n, Non_float, y) -> Memory.set_field (load x) n (load y)
-      | Set_field (x, n, Float, y) ->
-          Memory.float_array_set
-            (load x)
-            (Constant.translate (Int (Targetint.of_int_warning_on_overflow n)))
-            (load y)
-      | Offset_ref (x, n) ->
-          Memory.set_field
-            (load x)
-            0
-            (Value.val_int
-               Arith.(Value.int_val (Memory.field (load x) 0) + const (Int32.of_int n)))
-      | Array_set (x, y, z) -> Memory.array_set (load x) (load y) (load z)
-      | Event _ -> assert false)
+  and translate_instr ctx context i =
+    match i with
+    | Assign (x, y) -> assign x (load y)
+    | Let (x, e) ->
+        if ctx.live.(Var.idx x) = 0
+        then drop (translate_expr ctx context x e)
+        else store x (translate_expr ctx context x e)
+    | Set_field (x, n, Non_float, y) -> Memory.set_field (load x) n (load y)
+    | Set_field (x, n, Float, y) ->
+        Memory.float_array_set
+          (load x)
+          (Constant.translate (Int (Targetint.of_int_warning_on_overflow n)))
+          (load y)
+    | Offset_ref (x, n) ->
+        Memory.set_field
+          (load x)
+          0
+          (Value.val_int
+             Arith.(Value.int_val (Memory.field (load x) 0) + const (Int32.of_int n)))
+    | Array_set (x, y, z) -> Memory.array_set (load x) (load y) (load z)
+    | Event loc -> event loc
 
-  and translate_instrs ctx context loc l =
+  and translate_instrs ctx context l =
     match l with
-    | [] -> return loc
-    | Event loc :: rem -> translate_instrs ctx context (Some loc) rem
+    | [] -> return ()
     | i :: rem ->
-        let* () = translate_instr ctx context loc i in
-        translate_instrs ctx context loc rem
+        let* () = translate_instr ctx context i in
+        translate_instrs ctx context rem
 
   let parallel_renaming params args =
     let rec visit visited prev s m x l =
@@ -896,58 +892,56 @@ module Generate (Target : Wa_target_sig.S) = struct
             else code ~context
           in
           translate_tree result_typ fall_through pc' context
-      | [] ->
+      | [] -> (
           let block = Addr.Map.find pc ctx.blocks in
-          let* loc = translate_instrs ctx context None block.body in
+          let* () = translate_instrs ctx context block.body in
           let branch = block.branch in
-          with_location
-            loc
-            (match branch with
-            | Branch cont -> translate_branch result_typ fall_through pc cont context
-            | Return x -> (
-                let* e = load x in
-                match fall_through with
-                | `Return -> instr (Push e)
-                | `Block _ -> instr (Return (Some e)))
-            | Cond (x, cont1, cont2) ->
-                let context' = extend_context fall_through context in
-                if_
-                  { params = []; result = result_typ }
-                  (Value.check_is_not_zero (load x))
-                  (translate_branch result_typ fall_through pc cont1 context')
-                  (translate_branch result_typ fall_through pc cont2 context')
-            | Stop -> (
-                let* e = Value.unit in
-                match fall_through with
-                | `Return -> instr (Push e)
-                | `Block _ -> instr (Return (Some e)))
-            | Switch (x, a) ->
-                let len = Array.length a in
-                let l = Array.to_list (Array.sub a ~pos:0 ~len:(len - 1)) in
-                let dest (pc, args) =
-                  assert (List.is_empty args);
-                  label_index context pc
-                in
-                let* e = Value.int_val (load x) in
-                instr (Br_table (e, List.map ~f:dest l, dest a.(len - 1)))
-            | Raise (x, _) ->
-                let* e = load x in
-                let* tag = register_import ~name:exception_name (Tag Value.value) in
-                instr (Throw (tag, e))
-            | Pushtrap (cont, x, cont') ->
-                handle_exceptions
-                  ~result_typ
-                  ~fall_through
-                  ~context:(extend_context fall_through context)
-                  (wrap_with_handlers
-                     p
-                     (fst cont)
-                     (fun ~result_typ ~fall_through ~context ->
-                       translate_branch result_typ fall_through pc cont context))
-                  x
-                  (fun ~result_typ ~fall_through ~context ->
-                    translate_branch result_typ fall_through pc cont' context)
-            | Poptrap cont -> translate_branch result_typ fall_through pc cont context)
+          match branch with
+          | Branch cont -> translate_branch result_typ fall_through pc cont context
+          | Return x -> (
+              let* e = load x in
+              match fall_through with
+              | `Return -> instr (Push e)
+              | `Block _ -> instr (Return (Some e)))
+          | Cond (x, cont1, cont2) ->
+              let context' = extend_context fall_through context in
+              if_
+                { params = []; result = result_typ }
+                (Value.check_is_not_zero (load x))
+                (translate_branch result_typ fall_through pc cont1 context')
+                (translate_branch result_typ fall_through pc cont2 context')
+          | Stop -> (
+              let* e = Value.unit in
+              match fall_through with
+              | `Return -> instr (Push e)
+              | `Block _ -> instr (Return (Some e)))
+          | Switch (x, a) ->
+              let len = Array.length a in
+              let l = Array.to_list (Array.sub a ~pos:0 ~len:(len - 1)) in
+              let dest (pc, args) =
+                assert (List.is_empty args);
+                label_index context pc
+              in
+              let* e = Value.int_val (load x) in
+              instr (Br_table (e, List.map ~f:dest l, dest a.(len - 1)))
+          | Raise (x, _) ->
+              let* e = load x in
+              let* tag = register_import ~name:exception_name (Tag Value.value) in
+              instr (Throw (tag, e))
+          | Pushtrap (cont, x, cont') ->
+              handle_exceptions
+                ~result_typ
+                ~fall_through
+                ~context:(extend_context fall_through context)
+                (wrap_with_handlers
+                   p
+                   (fst cont)
+                   (fun ~result_typ ~fall_through ~context ->
+                     translate_branch result_typ fall_through pc cont context))
+                x
+                (fun ~result_typ ~fall_through ~context ->
+                  translate_branch result_typ fall_through pc cont' context)
+          | Poptrap cont -> translate_branch result_typ fall_through pc cont context)
     and translate_branch result_typ fall_through src (dst, args) context =
       let* () =
         if List.is_empty args
@@ -1001,15 +995,27 @@ module Generate (Target : Wa_target_sig.S) = struct
         ~context:ctx.global_context
         ~param_names
         ~body:
-          (let* () = build_initial_env in
-           wrap_with_handlers
-             p
-             pc
-             ~result_typ:[ Value.value ]
-             ~fall_through:`Return
-             ~context:[]
-             (fun ~result_typ ~fall_through ~context ->
-               translate_branch result_typ fall_through (-1) cont context))
+          (let* () =
+             let block = Addr.Map.find pc ctx.blocks in
+             match block.body with
+             | Event start_loc :: _ -> event start_loc
+             | _ -> no_event
+           in
+           let* () = build_initial_env in
+           let* () =
+             wrap_with_handlers
+               p
+               pc
+               ~result_typ:[ Value.value ]
+               ~fall_through:`Return
+               ~context:[]
+               (fun ~result_typ ~fall_through ~context ->
+                 translate_branch result_typ fall_through (-1) cont context)
+           in
+           let end_loc = Parse_bytecode.Debug.find_loc ctx.debug ~position:After pc in
+           match end_loc with
+           | Some loc -> event loc
+           | None -> return ())
     in
     let body = post_process_function_body ~param_names ~locals body in
     W.Function

compiler/lib/wasm/wa_initialize_locals.ml

@@ -97,15 +97,14 @@ and scan_instruction ctx i =
       List.iter ~f:(fun (_, l) -> scan_instructions ctx l) catches;
       Option.iter ~f:(fun l -> scan_instructions ctx l) catch_all
   | CallInstr (_, l) | Return_call (_, l) -> scan_expressions ctx l
-  | Br (_, None) | Return None | Rethrow _ | Nop -> ()
+  | Br (_, None) | Return None | Rethrow _ | Nop | Event _ -> ()
   | ArraySet (_, e, e', e'') ->
       scan_expression ctx e;
       scan_expression ctx e';
       scan_expression ctx e''
   | Return_call_ref (_, e', l) ->
       scan_expressions ctx l;
       scan_expression ctx e'
-  | Location (_, i) -> scan_instruction ctx i
 
 and scan_instructions ctx l =
   let ctx = fork_context ctx in