CFG/IRC: dedicated type for list of instructions (#793)

Explicit type for list of instructions / bodies.

Author: xclerc

backend/asmgen.ml

@@ -241,26 +241,26 @@ let recompute_liveness_on_cfg (cfg_with_layout : Cfg_with_layout.t) : Cfg_with_l
   let init = { Cfg_liveness.before = Reg.Set.empty; across = Reg.Set.empty; } in
   begin match Cfg_liveness.Liveness.run cfg ~init ~map:Cfg_liveness.Liveness.Instr () with
     | Ok (liveness : Cfg_liveness.Liveness.domain Cfg_dataflow.Instr.Tbl.t) ->
-      let with_liveness (instr : _ Cfg.instruction) =
+      let set_liveness (instr : _ Cfg.instruction) =
         match Cfg_dataflow.Instr.Tbl.find_opt liveness instr.id with
         | None ->
           Misc.fatal_errorf "Missing liveness information for instruction %d in function %s@."
             instr.id
             cfg.Cfg.fun_name
         | Some { Cfg_liveness.before = _; across } ->
-          Cfg.set_live instr across
+          instr.live <- across
       in
       Cfg.iter_blocks cfg ~f:(fun _label block ->
-          block.body <- ListLabels.map block.body ~f:with_liveness;
-          block.terminator <- with_liveness block.terminator;
+          Cfg.BasicInstructionList.iter block.body ~f:set_liveness;
+          set_liveness block.terminator;
         );
     | Aborted _ -> .
     | Max_iterations_reached ->
       Misc.fatal_errorf "Unable to compute liveness from CFG for function %s@."
         cfg.Cfg.fun_name;
   end;
   Cfg.iter_blocks cfg ~f:(fun _label block ->
-      block.body <- ListLabels.filter block.body ~f:(fun instr ->
+      Cfg.BasicInstructionList.filter_left block.body ~f:(fun instr ->
           not (Cfg.is_noop_move instr)));
   let layout : Label.t list =
     ListLabels.filter (Cfg_with_layout.layout cfg_with_layout) ~f:(fun label ->

backend/cfg/cfg.ml

@@ -29,9 +29,70 @@ let verbose = ref false
 
 include Cfg_intf.S
 
+module BasicInstructionList = struct
+  type instr = basic instruction
+
+  type cell =
+    { instr : instr;
+      mutable before_rev : instr list;
+      mutable after : instr list
+    }
+
+  let insert_before cell instr = cell.before_rev <- instr :: cell.before_rev
+
+  let insert_after cell instr = cell.after <- instr :: cell.after
+
+  let instr cell = cell.instr
+
+  type t = instr list ref
+
+  let make_empty () = ref []
+
+  let make_single instr = ref [instr]
+
+  let of_list l = ref l
+
+  let hd t = match !t with [] -> None | hd :: _ -> Some hd
+
+  let add_begin t instr = t := instr :: !t
+
+  let add_end t instr = t := !t @ [instr]
+
+  let is_empty t = match !t with [] -> true | _ :: _ -> false
+
+  let length t = ListLabels.length !t
+
+  let filter_left t ~f = t := ListLabels.filter ~f !t
+
+  let filter_right t ~f =
+    t
+      := ListLabels.fold_right
+           ~f:(fun elem acc -> if f elem then elem :: acc else acc)
+           !t ~init:[]
+
+  let iter t ~f = ListLabels.iter ~f !t
+
+  let iter_cell t ~f =
+    t
+      := ListLabels.concat_map !t ~f:(fun instr ->
+             let cell = { instr; before_rev = []; after = [] } in
+             f cell;
+             List.rev cell.before_rev @ [instr] @ cell.after)
+
+  let iter2 t t' ~f = ListLabels.iter2 ~f !t !t'
+
+  let fold_left t ~f ~init = ListLabels.fold_left ~f ~init !t
+
+  let fold_right t ~f ~init = ListLabels.fold_right ~f !t ~init
+
+  let transfer ~to_:t ~from:t' () =
+    t := !t @ !t';
+    t' := []
+end
+
 type basic_block =
   { start : Label.t;
-    mutable body : basic instruction list;
+    body : BasicInstructionList.t;
     mutable terminator : terminator instruction;
     mutable predecessors : Label.Set.t;
     mutable stack_offset : int;
@@ -153,6 +214,11 @@ let get_block_exn t label =
 
 let can_raise_interproc block = block.can_raise && Option.is_none block.exn
 
+let first_instruction_id (block : basic_block) : int =
+  match BasicInstructionList.hd block.body with
+  | None -> block.terminator.id
+  | Some first_instr -> first_instr.id
+
 let fun_name t = t.fun_name
 
 let entry_label t = t.entry_label
@@ -485,12 +551,7 @@ let set_stack_offset (instr : _ instruction) stack_offset =
   then
     Misc.fatal_errorf "Cfg.set_stack_offset: expected non-negative got %d"
       stack_offset;
-  if instr.stack_offset = stack_offset
-  then instr
-  else { instr with stack_offset }
-
-let set_live (instr : _ instruction) live =
-  if Reg.Set.equal instr.live live then instr else { instr with live }
+  instr.stack_offset <- stack_offset
 
 let string_of_irc_work_list = function
   | Unknown_list -> "unknown_list"

backend/cfg/cfg.mli

@@ -31,9 +31,56 @@ include module type of struct
   include Cfg_intf.S
 end
 
+module BasicInstructionList : sig
+  type instr = basic instruction
+
+  type cell
+
+  val insert_before : cell -> instr -> unit
+
+  val insert_after : cell -> instr -> unit
+
+  val instr : cell -> instr
+
+  type t
+
+  val make_empty : unit -> t
+
+  val make_single : instr -> t
+
+  val of_list : instr list -> t
+
+  val hd : t -> instr option
+
+  val add_begin : t -> instr -> unit
+
+  val add_end : t -> instr -> unit
+
+  val is_empty : t -> bool
+
+  val length : t -> int
+
+  val filter_left : t -> f:(instr -> bool) -> unit
+
+  val filter_right : t -> f:(instr -> bool) -> unit
+
+  val iter : t -> f:(instr -> unit) -> unit
+
+  val iter_cell : t -> f:(cell -> unit) -> unit
+
+  val iter2 : t -> t -> f:(instr -> instr -> unit) -> unit
+
+  val fold_left : t -> f:('a -> instr -> 'a) -> init:'a -> 'a
+
+  val fold_right : t -> f:(instr -> 'a -> 'a) -> init:'a -> 'a
+
+  (* Adds all of the elements of `from` to `to_`, and clears `from`. *)
+  val transfer : to_:t -> from:t -> unit -> unit
+end
+
 type basic_block =
   { start : Label.t;
-    mutable body : basic instruction list;
+    body : BasicInstructionList.t;
     mutable terminator : terminator instruction;
     mutable predecessors : Label.Set.t;
         (** All predecessors, both normal and exceptional paths. *)
@@ -109,6 +156,8 @@ val replace_successor_labels :
     vice versa. *)
 val can_raise_interproc : basic_block -> bool
 
+val first_instruction_id : basic_block -> int
+
 val mem_block : t -> Label.t -> bool
 
 val remove_block_exn : t -> Label.t -> unit
@@ -168,9 +217,7 @@ val is_pure_basic : basic -> bool
 
 val is_noop_move : basic instruction -> bool
 
-val set_stack_offset : 'a instruction -> int -> 'a instruction
-
-val set_live : 'a instruction -> Reg.Set.t -> 'a instruction
+val set_stack_offset : 'a instruction -> int -> unit
 
 val string_of_irc_work_list : irc_work_list -> string
 

backend/cfg/cfg_dataflow.ml

@@ -340,7 +340,7 @@ module Forward (D : Domain_S) (T : Forward_transfer with type domain = D.t) :
       in
       let normal, exceptional =
         transfer T.terminator
-          (ListLabels.fold_left block.body ~init:(value, value)
+          (Cfg.BasicInstructionList.fold_left block.body ~init:(value, value)
              ~f:(transfer T.basic))
           block.terminator
       in
@@ -479,8 +479,8 @@ module Backward (D : Domain_S) (T : Backward_transfer with type domain = D.t) :
         transfer block.terminator (T.terminator normal ~exn block.terminator)
       in
       let value =
-        ListLabels.fold_right block.body ~init:value ~f:(fun instr value ->
-            transfer instr (T.basic value ~exn instr))
+        Cfg.BasicInstructionList.fold_right block.body ~init:value
+          ~f:(fun instr value -> transfer instr (T.basic value ~exn instr))
       in
       let value =
         if block.is_trap_handler

backend/cfg/cfg_deadcode.ml

@@ -8,37 +8,30 @@ let live_before : type a. a Cfg.instruction -> liveness -> Reg.Set.t =
   | None -> fatal "no liveness information for instruction %d" instr.id
   | Some { Cfg_liveness.before; across = _ } -> before
 
-let remove_deadcode (body : Instruction.t list) liveness used_after :
-    Instruction.t list * bool =
-  let body, _, changed =
-    List.fold_right body ~init:([], used_after, false)
-      ~f:(fun (instr : Instruction.t) (acc, used_after, changed) ->
-        let before = live_before instr liveness in
-        let is_deadcode =
-          match instr.desc with
-          | Op _ as op ->
-            Cfg.is_pure_basic op
-            && Reg.disjoint_set_array used_after instr.res
-            && (not (Proc.regs_are_volatile instr.arg))
-            && not (Proc.regs_are_volatile instr.res)
-          | Call _ | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> false
-        in
-        let acc = if is_deadcode then acc else instr :: acc in
-        acc, before, changed || is_deadcode)
-  in
-  body, changed
+let remove_deadcode (body : Cfg.BasicInstructionList.t) changed liveness
+    used_after : unit =
+  let used_after = ref used_after in
+  Cfg.BasicInstructionList.filter_right body ~f:(fun (instr : Instruction.t) ->
+      let before = live_before instr liveness in
+      let is_deadcode =
+        match instr.desc with
+        | Op _ as op ->
+          Cfg.is_pure_basic op
+          && Reg.disjoint_set_array !used_after instr.res
+          && (not (Proc.regs_are_volatile instr.arg))
+          && not (Proc.regs_are_volatile instr.res)
+        | Call _ | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> false
+      in
+      used_after := before;
+      changed := !changed || is_deadcode;
+      not is_deadcode)
 
 let run cfg_with_liveness =
   let liveness = Cfg_with_liveness.liveness cfg_with_liveness in
-  let invalidate =
-    Cfg.fold_blocks (Cfg_with_liveness.cfg cfg_with_liveness) ~init:false
-      ~f:(fun _label block changed ->
-        let new_body, body_changed =
-          remove_deadcode block.body liveness
-            (live_before block.terminator liveness)
-        in
-        block.body <- new_body;
-        changed || body_changed)
-  in
-  if invalidate then Cfg_with_liveness.invalidate_liveness cfg_with_liveness;
+  let changed = ref false in
+  Cfg.iter_blocks (Cfg_with_liveness.cfg cfg_with_liveness)
+    ~f:(fun _label block ->
+      remove_deadcode block.body changed liveness
+        (live_before block.terminator liveness));
+  if !changed then Cfg_with_liveness.invalidate_liveness cfg_with_liveness;
   cfg_with_liveness

backend/cfg/cfg_equivalence.ml

@@ -408,23 +408,24 @@ let check_basic_instruction :
   check_instruction ~check_live ~check_dbg ~check_arg:true idx location expected
     result
 
-let rec check_basic_instruction_list :
+let check_basic_instruction_list :
     State.t ->
     location ->
-    int ->
-    Cfg.basic Cfg.instruction list ->
-    Cfg.basic Cfg.instruction list ->
+    Cfg.BasicInstructionList.t ->
+    Cfg.BasicInstructionList.t ->
     unit =
- fun state location idx expected result ->
-  match expected, result with
-  | [], [] -> ()
-  | _ :: _, [] ->
-    different location "bodies with different sizes (expected is longer)"
-  | [], _ :: _ ->
-    different location "bodies with different sizes (result is longer)"
-  | expected_hd :: expected_tl, result_hd :: result_tl ->
-    check_basic_instruction state location idx expected_hd result_hd;
-    check_basic_instruction_list state location (succ idx) expected_tl result_tl
+ fun state location expected result ->
+  let expected_len = Cfg.BasicInstructionList.length expected in
+  let result_len = Cfg.BasicInstructionList.length result in
+  if expected_len = result_len
+  then
+    let i = ref 0 in
+    Cfg.BasicInstructionList.iter2 expected result ~f:(fun expected result ->
+        check_basic_instruction state location !i expected result;
+        incr i)
+  else if expected_len > result_len
+  then different location "bodies with different sizes (expected is longer)"
+  else different location "bodies with different sizes (result is longer)"
 
 let check_terminator_instruction :
     State.t ->
@@ -512,7 +513,7 @@ let check_basic_block : State.t -> Cfg.basic_block -> Cfg.basic_block -> unit =
       (Label.to_string expected.start)
       (Label.to_string result.start)
   in
-  check_basic_instruction_list state location 0 expected.body result.body;
+  check_basic_instruction_list state location expected.body result.body;
   check_terminator_instruction state location expected.terminator
     result.terminator;
   (* State.add_label_sets_to_check state (location ^ " (predecessors)")

backend/cfg/cfg_intf.ml

@@ -138,10 +138,10 @@ module S = struct
     { desc : 'a;
       mutable arg : Reg.t array;
       mutable res : Reg.t array;
-      dbg : Debuginfo.t;
-      fdo : Fdo_info.t;
-      live : Reg.Set.t;
-      stack_offset : int;
+      mutable dbg : Debuginfo.t;
+      mutable fdo : Fdo_info.t;
+      mutable live : Reg.Set.t;
+      mutable stack_offset : int;
       id : int;
       mutable irc_work_list : irc_work_list
     }