WIP

Author: hhugo

compiler/lib/code.ml

@@ -352,13 +352,13 @@ type instr =
   | Array_set of Var.t * Var.t * Var.t * loc
 
 type last =
-  | Return of Var.t
-  | Raise of Var.t * [ `Normal | `Notrace | `Reraise ]
-  | Stop
+  | Return of Var.t * loc
+  | Raise of Var.t * [ `Normal | `Notrace | `Reraise ] * loc
+  | Stop of loc
   | Branch of cont
-  | Cond of Var.t * cont * cont
-  | Switch of Var.t * cont array * cont array
-  | Pushtrap of cont * Var.t * cont * Addr.Set.t
+  | Cond of Var.t * cont * cont * loc
+  | Switch of Var.t * cont array * cont array * loc
+  | Pushtrap of cont * Var.t * cont * Addr.Set.t * loc
   | Poptrap of cont
 
 type block =
@@ -491,20 +491,20 @@ module Print = struct
 
   let last f l =
     match l with
-    | Return x -> Format.fprintf f "return %a" Var.print x
-    | Raise (x, `Normal) -> Format.fprintf f "raise %a" Var.print x
-    | Raise (x, `Reraise) -> Format.fprintf f "reraise %a" Var.print x
-    | Raise (x, `Notrace) -> Format.fprintf f "raise_notrace %a" Var.print x
-    | Stop -> Format.fprintf f "stop"
+    | Return (x, _) -> Format.fprintf f "return %a" Var.print x
+    | Raise (x, `Normal, _) -> Format.fprintf f "raise %a" Var.print x
+    | Raise (x, `Reraise, _) -> Format.fprintf f "reraise %a" Var.print x
+    | Raise (x, `Notrace, _) -> Format.fprintf f "raise_notrace %a" Var.print x
+    | Stop _ -> Format.fprintf f "stop"
     | Branch c -> Format.fprintf f "branch %a" cont c
-    | Cond (x, cont1, cont2) ->
+    | Cond (x, cont1, cont2, _) ->
         Format.fprintf f "if %a then %a else %a" Var.print x cont cont1 cont cont2
-    | Switch (x, a1, a2) ->
+    | Switch (x, a1, a2, _) ->
         Format.fprintf f "switch %a {" Var.print x;
         Array.iteri a1 ~f:(fun i c -> Format.fprintf f "int %d -> %a; " i cont c);
         Array.iteri a2 ~f:(fun i c -> Format.fprintf f "tag %d -> %a; " i cont c);
         Format.fprintf f "}"
-    | Pushtrap (cont1, x, cont2, pcs) ->
+    | Pushtrap (cont1, x, cont2, pcs, _) ->
         Format.fprintf
           f
           "pushtrap %a handler %a => %a continuation %s"
@@ -559,12 +559,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 (-1) } 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 (-1) }
 
 let empty =
   let start = 0 in
@@ -577,7 +577,7 @@ 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
@@ -588,17 +588,17 @@ let is_empty p =
 let fold_children blocks pc f accu =
   let block = Addr.Map.find pc blocks in
   match block.branch with
-  | Return _ | Raise _ | Stop -> accu
+  | Return _ | Raise _ | Stop _ -> accu
   | Branch (pc', _) | Poptrap (pc', _) -> f pc' accu
-  | Pushtrap ((pc', _), _, (pc_h, _), _) ->
+  | Pushtrap ((pc', _), _, (pc_h, _), _, _) ->
       let accu = f pc' accu in
       let accu = f pc_h accu in
       accu
-  | Cond (_, (pc1, _), (pc2, _)) ->
+  | Cond (_, (pc1, _), (pc2, _), _) ->
       let accu = f pc1 accu in
       let accu = f pc2 accu in
       accu
-  | Switch (_, a1, a2) ->
+  | Switch (_, a1, a2, _) ->
       let accu = Array.fold_right ~init:accu ~f:(fun (pc, _) accu -> f pc accu) a1 in
       let accu = Array.fold_right ~init:accu ~f:(fun (pc, _) accu -> f pc accu) a2 in
       accu
@@ -719,15 +719,15 @@ let invariant { blocks; start; _ } =
     let check_last = function
       | Return _ -> ()
       | Raise _ -> ()
-      | Stop -> ()
+      | Stop _ -> ()
       | Branch cont -> check_cont cont
-      | Cond (_x, cont1, cont2) ->
+      | Cond (_x, cont1, cont2, _) ->
           check_cont cont1;
           check_cont cont2
-      | Switch (_x, a1, a2) ->
+      | Switch (_x, a1, a2, _) ->
           Array.iteri a1 ~f:(fun _ cont -> check_cont cont);
           Array.iteri a2 ~f:(fun _ cont -> check_cont cont)
-      | Pushtrap (cont1, _x, cont2, _pcs) ->
+      | Pushtrap (cont1, _x, cont2, _pcs, _) ->
           check_cont cont1;
           check_cont cont2
       | Poptrap cont -> check_cont cont

compiler/lib/code.mli

@@ -189,13 +189,13 @@ type instr =
   | Array_set of Var.t * Var.t * Var.t * loc
 
 type last =
-  | Return of Var.t
-  | Raise of Var.t * [ `Normal | `Notrace | `Reraise ]
-  | Stop
+  | Return of Var.t * loc
+  | Raise of Var.t * [ `Normal | `Notrace | `Reraise ] * loc
+  | Stop of loc
   | Branch of cont
-  | Cond of Var.t * cont * cont
-  | Switch of Var.t * cont array * cont array
-  | Pushtrap of cont * Var.t * cont * Addr.Set.t
+  | Cond of Var.t * cont * cont * loc
+  | Switch of Var.t * cont array * cont array * loc
+  | Pushtrap of cont * Var.t * cont * Addr.Set.t * loc
   | Poptrap of cont
 
 type block =

compiler/lib/deadcode.ml

@@ -90,18 +90,18 @@ and mark_reachable st pc =
             mark_var st z
         | Offset_ref (x, _, _) -> mark_var st x);
     match block.branch with
-    | Return x | Raise (x, _) -> mark_var st x
-    | Stop -> ()
+    | Return (x, _) | Raise (x, _, _) -> mark_var st x
+    | Stop _ -> ()
     | Branch cont | Poptrap cont -> mark_cont_reachable st cont
-    | Cond (x, cont1, cont2) ->
+    | Cond (x, cont1, cont2, _) ->
         mark_var st x;
         mark_cont_reachable st cont1;
         mark_cont_reachable st cont2
-    | Switch (x, a1, a2) ->
+    | Switch (x, a1, a2, _) ->
         mark_var st x;
         Array.iter a1 ~f:(fun cont -> mark_cont_reachable st cont);
         Array.iter a2 ~f:(fun cont -> mark_cont_reachable st cont)
-    | Pushtrap (cont1, _, cont2, _) ->
+    | Pushtrap (cont1, _, cont2, _, _) ->
         mark_cont_reachable st cont1;
         mark_cont_reachable st cont2)
 
@@ -132,21 +132,23 @@ let filter_closure blocks st i =
 
 let filter_live_last blocks st l =
   match l with
-  | Return _ | Raise _ | Stop -> l
+  | 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) ->
+  | Cond (x, cont1, cont2, loc) ->
+      Cond (x, filter_cont blocks st cont1, filter_cont blocks st cont2, loc)
+  | Switch (x, a1, a2, loc) ->
       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) ->
+        , Array.map a2 ~f:(fun cont -> filter_cont blocks st cont)
+        , loc )
+  | Pushtrap (cont1, x, cont2, pcs, loc) ->
       Pushtrap
         ( filter_cont blocks st cont1
         , x
         , filter_cont blocks st cont2
-        , Addr.Set.inter pcs st.reachable_blocks )
+        , Addr.Set.inter pcs st.reachable_blocks
+        , loc )
   | Poptrap cont -> Poptrap (filter_cont blocks st cont)
 
 (****)
@@ -198,15 +200,15 @@ let f ({ blocks; _ } as p : Code.program) =
           | Assign (x, y, _) -> add_def defs x (Var y)
           | Set_field (_, _, _, _) | Array_set (_, _, _, _) | Offset_ref (_, _, _) -> ());
       match block.branch with
-      | Return _ | Raise _ | Stop -> ()
+      | Return _ | Raise _ | Stop _ -> ()
       | Branch cont -> add_cont_dep blocks defs cont
-      | Cond (_, cont1, cont2) ->
+      | Cond (_, cont1, cont2, _) ->
           add_cont_dep blocks defs cont1;
           add_cont_dep blocks defs cont2
-      | Switch (_, a1, a2) ->
+      | Switch (_, a1, a2, _) ->
           Array.iter a1 ~f:(fun cont -> add_cont_dep blocks defs cont);
           Array.iter a2 ~f:(fun cont -> add_cont_dep blocks defs cont)
-      | Pushtrap (cont, _, cont_h, _) ->
+      | Pushtrap (cont, _, cont_h, _, _) ->
           add_cont_dep blocks defs cont_h;
           add_cont_dep blocks defs cont
       | Poptrap cont -> add_cont_dep blocks defs cont)