lci/lib/analysis/Dataflow.ml

module type C = sig
  type elt
  type internal

  type internal_node = {
    internal_in: internal list;
    internal_out: internal list;
    internal_between: (internal list * internal list) list;
  }

  type cfgt = elt Cfg.cfginternal

  type t = {
    t: cfgt;
    internal_var: internal_node Cfg.NodeMap.t;
  }

  val from_cfg : cfgt -> t
  val to_cfg : t -> cfgt

  val fixed_point :
    ?init : (elt list -> internal_node) ->
    ?update : (t -> Cfg.Node.t -> internal_node) ->
    t ->
    t

  val pp : out_channel -> t -> unit
end

module Make (M: Cfg.PrintableType) (I: Cfg.PrintableType) = struct
  type elt = M.t
  type internal = I.t

  type internal_node = {
    internal_in: internal list;
    internal_out: internal list;
    internal_between: (internal list * internal list) list;
  }

  let compare_internal_node (a:internal_node) (b:internal_node) : bool =
    match Utility.equality a.internal_in b.internal_in,
          Utility.equality a.internal_out b.internal_out,
          (List.fold_left2 (fun acc (ain, aout) (bin, bout)
                             -> acc &&
                                (Utility.equality ain bin) &&
                                (Utility.equality aout bout)
            ) true a.internal_between b.internal_between)
    with
    | true, true, true -> true
    | _, _, _ -> false

  type cfgt = elt Cfg.cfginternal

  type t = {
    t: cfgt;
    internal_var: internal_node Cfg.NodeMap.t;
  }

  let compare_internal a b =
    Cfg.NodeMap.fold
      (fun node bi acc ->
         match Cfg.NodeMap.find_opt node a with
           None -> false
         | Some ai -> acc && compare_internal_node ai bi
      ) b true

  let from_cfg (cfg: cfgt) : t =
    {t = cfg; internal_var = Cfg.NodeMap.empty}

  let to_cfg ({t; _}: t) : cfgt =
    t


  open Cfg
  let pp (ppf: out_channel) (c: t) : unit = (
    Printf.fprintf ppf "Cfg:\n";
    Printf.fprintf ppf "Nodes' ids: ";
    List.iter (fun (x : Node.t) ->
        Printf.fprintf ppf "%d " x.id) (NodeSet.to_list c.t.nodes);
    Printf.fprintf ppf "\n";

    Printf.fprintf ppf "Nodes' edges:\n";
    List.iter (fun ((n, (a, b)) : (Node.t * (Node.t * Node.t option))) : unit ->
        match b with
          None -> Printf.fprintf ppf "\t%d -> %d\n" n.id a.id
        | Some b -> Printf.fprintf ppf "\t%d -> %d, %d\n" n.id a.id b.id
      ) (NodeMap.to_list c.t.edges);
    Printf.fprintf ppf "\n";

    Printf.fprintf ppf "Nodes' back edges:\n";
    List.iter (fun ((n, xs) : (Node.t * (Node.t list))) : unit ->
        Printf.fprintf ppf "\t%d -> " n.id;
        List.iter (fun (x: Node.t) -> Printf.fprintf ppf "%d, " x.id) xs;
        Printf.fprintf ppf "\n"
      ) (NodeMap.to_list c.t.reverse_edges);
    Printf.fprintf ppf "\n";

    Printf.fprintf ppf "Input Value: ";
    (match c.t.input_val with
       Some i -> Printf.fprintf ppf "%d" i;
     | None   -> Printf.fprintf ppf "None";);
    Printf.fprintf ppf "\n";

    Printf.fprintf ppf "Input and Output Vars: ";
    (match c.t.input_output_var with
       Some (i, o) -> Printf.fprintf ppf "(in: %s, out: %s)" i o;
     | None   -> Printf.fprintf ppf "None";);
    Printf.fprintf ppf "\n";

    Printf.fprintf ppf "Initial node's id: ";
    (match c.t.initial with
       Some i -> Printf.fprintf ppf "%d" (i.id);
     | None   -> Printf.fprintf ppf "None";);
    Printf.fprintf ppf "\n";

    Printf.fprintf ppf "Terminal node's id: ";
    (match c.t.terminal with
       Some i -> Printf.fprintf ppf "%d" (i.id);
     | None   -> Printf.fprintf ppf "None";);
    Printf.fprintf ppf "\n";

    Printf.fprintf ppf "Code:\n";
    List.iter (fun ((n, stms) : Node.t * elt list) : unit ->
        Printf.fprintf ppf "\tid %d --> %a\n%!" n.id M.pp_list stms
      ) (NodeMap.to_list c.t.content);
    Printf.fprintf ppf "\n";

    Printf.fprintf ppf "Analysis structure:\n";
    List.iter (fun ((n, {internal_in; internal_out; internal_between})
                    : (Node.t * internal_node)) : unit ->
                Printf.fprintf ppf "Node: %d\n" n.id;
                Printf.fprintf ppf "Internal Input: ";
                Printf.fprintf ppf "%a\n" I.pp_list internal_in;
                Printf.fprintf ppf "Internal Output: ";
                Printf.fprintf ppf "%a\n" I.pp_list internal_out;
                Printf.fprintf ppf "Internal Between: ";
                List.iter (fun (i, o) ->
                    Printf.fprintf ppf "IN: %a;" I.pp_list i;
                    Printf.fprintf ppf "OUT: %a;" I.pp_list o;)
                  internal_between;
                Printf.fprintf ppf "\n";
              ) (NodeMap.to_list c.internal_var);
    Printf.fprintf ppf "\n";
  )


  let fixed_point
      ?(init : (elt list -> internal_node) =
               (fun _ -> {internal_in = [];
                          internal_out = [];
                          internal_between = []}))
      ?(update : (t -> Cfg.Node.t -> internal_node) =
                 (fun t n -> Cfg.NodeMap.find n t.internal_var))
      (t: t)
    : t =
    (* init function is applied only once to each node content,
       the update function takes the node and the whole structure and is
       expected to return the updated structure for the appropriate node,
       update function is applied to the resulting structure until no change is
       observed with compareinternal function
    *)
    let rec aux t =
      let newt =
        {t with
         internal_var = Cfg.NodeMap.mapi (fun n _ -> update t n) t.internal_var}
      in
      if compare_internal newt.internal_var t.internal_var
      then newt
      else aux newt
    in

    let content =
      List.fold_left
        (fun cfg node -> Cfg.NodeMap.add node {internal_in = [];
                                               internal_out = [];
                                               internal_between = []} cfg)
        Cfg.NodeMap.empty
        (Cfg.NodeSet.to_list t.t.nodes)
    in

    let code = (* we add back in the nodes with no code (there is no binding
                  in the t.t.content map) *)
      Cfg.NodeMap.union (fun _n c _empty -> Some c)
        t.t.content
        (Cfg.NodeMap.of_list
           (Cfg.NodeSet.to_list t.t.nodes |> List.map (fun c -> (c, []))))
    in

    let content = Cfg.NodeMap.union
        (fun _key _empty code -> Some code)
        content
        (Cfg.NodeMap.map init code)
    in
    aux { t with internal_var = content }

end