Compiler: no longer split blocks at fun call to propagate location

Tests: Accept test for gh747

Author: hhugo

compiler/bin-js_of_ocaml/compile.ml

@@ -162,9 +162,11 @@ let run
         let var_k = Code.Var.fresh () in
         let var_v = Code.Var.fresh () in
         Code.
-          [ Let (var_k, Prim (Extern "caml_jsstring_of_string", [ Pc (String k) ]))
-          ; Let (var_v, Prim (Extern "caml_jsstring_of_string", [ Pc (String v) ]))
-          ; Let (Var.fresh (), Prim (Extern "caml_set_static_env", [ Pv var_k; Pv var_v ]))
+          [ Let (var_k, Prim (Extern "caml_jsstring_of_string", [ Pc (String k) ])), noloc
+          ; Let (var_v, Prim (Extern "caml_jsstring_of_string", [ Pc (String v) ])), noloc
+          ; ( Let
+                (Var.fresh (), Prim (Extern "caml_set_static_env", [ Pv var_k; Pv var_v ]))
+            , noloc )
           ])
   in
   let output (one : Parse_bytecode.one) ~source_map ~linkall ~standalone output_file =

compiler/lib/code.ml

@@ -326,6 +326,11 @@ let rec constant_equal a b =
   | Int _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
       Some false
 
+type loc =
+  | No
+  | Before of Addr.t
+  | After of Addr.t
+
 type prim_arg =
   | Pv of Var.t
   | Pc of constant
@@ -361,8 +366,8 @@ type last =
 
 type block =
   { params : Var.t list
-  ; body : instr list
-  ; branch : last
+  ; body : (instr * loc) list
+  ; branch : last * loc
   }
 
 type program =
@@ -371,6 +376,9 @@ type program =
   ; free_pc : Addr.t
   }
 
+let noloc = No
+
+let location_of_pc pc = Before pc
 (****)
 
 module Print = struct
@@ -478,7 +486,7 @@ module Print = struct
     | Constant c -> Format.fprintf f "CONST{%a}" constant c
     | Prim (p, l) -> prim f p l
 
-  let instr f i =
+  let instr f (i, _loc) =
     match i with
     | Let (x, e) -> Format.fprintf f "%a = %a" Var.print x expr e
     | Assign (x, y) -> Format.fprintf f "(assign) %a = %a" Var.print x Var.print y
@@ -487,7 +495,7 @@ module Print = struct
     | Array_set (x, y, z) ->
         Format.fprintf f "%a[%a] = %a" Var.print x Var.print y Var.print z
 
-  let last f l =
+  let last f (l, _loc) =
     match l with
     | Return x -> Format.fprintf f "return %a" Var.print x
     | Raise (x, `Normal) -> Format.fprintf f "raise %a" Var.print x
@@ -516,8 +524,8 @@ module Print = struct
     | Poptrap c -> Format.fprintf f "poptrap %a" cont c
 
   type xinstr =
-    | Instr of instr
-    | Last of last
+    | Instr of (instr * loc)
+    | Last of (last * loc)
 
   let block annot pc block =
     Format.eprintf "==== %d (%a) ====@." pc var_list block.params;
@@ -536,7 +544,7 @@ end
 let fold_closures p f accu =
   Addr.Map.fold
     (fun _ block accu ->
-      List.fold_left block.body ~init:accu ~f:(fun accu i ->
+      List.fold_left block.body ~init:accu ~f:(fun accu (i, _loc) ->
           match i with
           | Let (x, Closure (params, cont)) -> f (Some x) params cont accu
           | _ -> accu))
@@ -557,12 +565,12 @@ let prepend ({ start; blocks; free_pc } as p) body =
       | exception Not_found ->
           let new_start = free_pc in
           let blocks =
-            Addr.Map.add new_start { params = []; body; branch = Stop } blocks
+            Addr.Map.add new_start { params = []; body; branch = Stop, noloc } blocks
           in
           let free_pc = free_pc + 1 in
           { start = new_start; blocks; free_pc })
 
-let empty_block = { params = []; body = []; branch = Stop }
+let empty_block = { params = []; body = []; branch = Stop, noloc }
 
 let empty =
   let start = 0 in
@@ -575,16 +583,17 @@ let is_empty p =
   | 1 -> (
       let _, v = Addr.Map.choose p.blocks in
       match v with
-      | { body; branch = Stop; params = _ } -> (
+      | { body; branch = Stop, _; params = _ } -> (
           match body with
-          | ([] | [ Let (_, Prim (Extern "caml_get_global_data", _)) ]) when true -> true
+          | ([] | [ (Let (_, Prim (Extern "caml_get_global_data", _)), _) ]) when true ->
+              true
           | _ -> false)
       | _ -> false)
   | _ -> false
 
 let fold_children blocks pc f accu =
   let block = Addr.Map.find pc blocks in
-  match block.branch with
+  match fst block.branch with
   | Return _ | Raise _ | Stop -> accu
   | Branch (pc', _) | Poptrap (pc', _) -> f pc' accu
   | Pushtrap ((pc', _), _, (pc_h, _), _) ->
@@ -648,7 +657,7 @@ let fold_closures_innermost_first { start; blocks; _ } f accu =
         let block = Addr.Map.find pc blocks in
         List.fold_left block.body ~init:accu ~f:(fun accu i ->
             match i with
-            | Let (x, Closure (params, cont)) ->
+            | Let (x, Closure (params, cont)), _ ->
                 let accu = visit blocks (fst cont) f accu in
                 f (Some x) params cont accu
             | _ -> accu))
@@ -704,7 +713,8 @@ let invariant { blocks; start; _ } =
       | Constant _ -> ()
       | Prim (_, _) -> ()
     in
-    let check_instr = function
+    let check_instr (i, _loc) =
+      match i with
       | Let (x, e) ->
           define x;
           check_expr e
@@ -713,7 +723,8 @@ let invariant { blocks; start; _ } =
       | Offset_ref (_x, _i) -> ()
       | Array_set (_x, _y, _z) -> ()
     in
-    let check_last = function
+    let check_last (l, _loc) =
+      match l with
       | Return _ -> ()
       | Raise _ -> ()
       | Stop -> ()

compiler/lib/code.mli

@@ -163,6 +163,15 @@ type constant =
 
 val constant_equal : constant -> constant -> bool option
 
+type loc =
+  | No
+  | Before of Addr.t
+  | After of Addr.t
+
+val noloc : loc
+
+val location_of_pc : int -> loc
+
 type prim_arg =
   | Pv of Var.t
   | Pc of constant
@@ -198,8 +207,8 @@ type last =
 
 type block =
   { params : Var.t list
-  ; body : instr list
-  ; branch : last
+  ; body : (instr * loc) list
+  ; branch : last * loc
   }
 
 type program =
@@ -210,18 +219,18 @@ type program =
 
 module Print : sig
   type xinstr =
-    | Instr of instr
-    | Last of last
+    | Instr of (instr * loc)
+    | Last of (last * loc)
 
   val var_list : Format.formatter -> Var.t list -> unit
 
-  val instr : Format.formatter -> instr -> unit
+  val instr : Format.formatter -> instr * loc -> unit
 
   val block : (Addr.Map.key -> xinstr -> string) -> int -> block -> unit
 
   val program : (Addr.Map.key -> xinstr -> string) -> program -> unit
 
-  val last : Format.formatter -> last -> unit
+  val last : Format.formatter -> last * loc -> unit
 
   val cont : Format.formatter -> cont -> unit
 end
@@ -244,7 +253,7 @@ val traverse :
 val preorder_traverse :
   fold_blocs_poly -> (Addr.t -> 'c -> 'c) -> Addr.t -> block Addr.Map.t -> 'c -> 'c
 
-val prepend : program -> instr list -> program
+val prepend : program -> (instr * loc) list -> program
 
 val empty : program
 

compiler/lib/deadcode.ml

@@ -77,7 +77,7 @@ and mark_reachable st pc =
   then (
     st.reachable_blocks <- Addr.Set.add pc st.reachable_blocks;
     let block = Addr.Map.find pc st.blocks in
-    List.iter block.body ~f:(fun i ->
+    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 _ -> ()
@@ -89,7 +89,7 @@ and mark_reachable st pc =
             mark_var st y;
             mark_var st z
         | Offset_ref (x, _) -> mark_var st x);
-    match block.branch with
+    match fst block.branch with
     | Return x | Raise (x, _) -> mark_var st x
     | Stop -> ()
     | Branch cont | Poptrap cont -> mark_cont_reachable st cont
@@ -129,25 +129,27 @@ let filter_closure blocks st i =
   | Let (x, Closure (l, cont)) -> Let (x, Closure (l, filter_cont blocks st cont))
   | _ -> i
 
-let filter_live_last blocks st l =
-  match l with
-  | Return _ | Raise _ | Stop -> l
-  | Branch cont -> Branch (filter_cont blocks st cont)
-  | Cond (x, cont1, cont2) ->
-      Cond (x, filter_cont blocks st cont1, filter_cont blocks st cont2)
-  | Switch (x, a1, a2) ->
-      Switch
-        ( x
-        , Array.map a1 ~f:(fun cont -> filter_cont blocks st cont)
-        , Array.map a2 ~f:(fun cont -> filter_cont blocks st cont) )
-  | Pushtrap (cont1, x, cont2, pcs) ->
-      Pushtrap
-        ( filter_cont blocks st cont1
-        , x
-        , filter_cont blocks st cont2
-        , Addr.Set.inter pcs st.reachable_blocks )
-  | Poptrap cont -> Poptrap (filter_cont blocks st cont)
-
+let filter_live_last blocks st (l, loc) =
+  let l =
+    match l with
+    | Return _ | Raise _ | Stop -> l
+    | Branch cont -> Branch (filter_cont blocks st cont)
+    | Cond (x, cont1, cont2) ->
+        Cond (x, filter_cont blocks st cont1, filter_cont blocks st cont2)
+    | Switch (x, a1, a2) ->
+        Switch
+          ( x
+          , Array.map a1 ~f:(fun cont -> filter_cont blocks st cont)
+          , Array.map a2 ~f:(fun cont -> filter_cont blocks st cont) )
+    | Pushtrap (cont1, x, cont2, pcs) ->
+        Pushtrap
+          ( filter_cont blocks st cont1
+          , x
+          , filter_cont blocks st cont2
+          , Addr.Set.inter pcs st.reachable_blocks )
+    | Poptrap cont -> Poptrap (filter_cont blocks st cont)
+  in
+  l, loc
 (****)
 
 let ref_count st i =
@@ -161,7 +163,7 @@ let annot st pc xi =
   else
     match (xi : Code.Print.xinstr) with
     | Last _ -> " "
-    | Instr i ->
+    | Instr (i, _) ->
         let c = ref_count st i in
         if c > 0 then Format.sprintf "%d" c else if live_instr st i then " " else "x"
 
@@ -191,12 +193,12 @@ let f ({ blocks; _ } as p : Code.program) =
   let pure_funs = Pure_fun.f p in
   Addr.Map.iter
     (fun _ block ->
-      List.iter block.body ~f:(fun i ->
+      List.iter block.body ~f:(fun (i, _loc) ->
           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 (_, _) -> ());
-      match block.branch with
+      match fst block.branch with
       | Return _ | Raise _ | Stop -> ()
       | Branch cont -> add_cont_dep blocks defs cont
       | Cond (_, cont1, cont2) ->
@@ -225,8 +227,8 @@ let f ({ blocks; _ } as p : Code.program) =
             { params = List.filter block.params ~f:(fun x -> st.live.(Var.idx x) > 0)
             ; body =
                 List.map
-                  (List.filter block.body ~f:(fun i -> live_instr st i))
-                  ~f:(fun i -> filter_closure all_blocks st i)
+                  (List.filter block.body ~f:(fun (i, _loc) -> live_instr st i))
+                  ~f:(fun (i, loc) -> filter_closure all_blocks st i, loc)
             ; branch = filter_live_last all_blocks st block.branch
             }
             blocks)