lci/lib/analysis/Dataflow.ml

module type C = sig
  type elt
  type internal

  type internalnode = {
    internalin: internal list;
    internalout: internal list;
    internalbetween: (internal list * internal list) list;
  }

  type cfgt = elt Cfg.cfginternal

  type t = {
    t: cfgt;
    internalvar: internalnode Cfg.NodeMap.t;
  }

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

  val fixed_point : ?init:(elt list -> internalnode) -> ?update:(t -> Cfg.Node.t -> internalnode) -> 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 internalnode = {
    internalin: internal list;
    internalout: internal list;
    internalbetween: (internal list * internal list) list;
  }

  type cfgt = elt Cfg.cfginternal

  type t = {
    t: cfgt;
    internalvar: internalnode Cfg.NodeMap.t;
  }

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

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

  let fixed_point
      ?(init : (elt list -> internalnode) =
               (fun _ -> {internalin = []; internalout = []; internalbetween = []}))
      ?(update : (t -> Cfg.Node.t -> internalnode) =
                 (fun t n -> Cfg.NodeMap.find n t.internalvar))
      (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
    *)
    let rec helper t =
      let newt =
        {t with
         internalvar = Cfg.NodeMap.mapi (fun n _ -> update t n) t.internalvar}
      in
      if newt = t then newt else helper newt
    in
    let content = List.fold_left
        (fun cfg node -> Cfg.NodeMap.add node {internalin = [];
                                               internalout = [];
                                               internalbetween = []} cfg)
        Cfg.NodeMap.empty
        (Cfg.NodeSet.to_list t.t.nodes)
    in
    let content = Cfg.NodeMap.union
        (fun _ket _empty code -> Some code)
        content
        (Cfg.NodeMap.map init t.t.content)
    in
    helper { t with internalvar = content }


  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.reverseEdges);
    Printf.fprintf ppf "\n";

    Printf.fprintf ppf "Input Value: ";
    (match c.t.inputVal 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.inputOutputVar 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.pplist stms
      ) (NodeMap.to_list c.t.content);
    Printf.fprintf ppf "\n";

    Printf.fprintf ppf "Analysis structure:\n";
    List.iter (fun ((n, {internalin; internalout; internalbetween})
                    : (Node.t * internalnode)) : unit ->
                Printf.fprintf ppf "Node: %d\n" n.id;
                Printf.fprintf ppf "Internal Input: ";
                Printf.fprintf ppf "%a\n" I.pplist internalin;
                Printf.fprintf ppf "Internal Output: ";
                Printf.fprintf ppf "%a\n" I.pplist internalout;
                Printf.fprintf ppf "Internal Between: ";
                List.iter (fun (i, o) ->
                    Printf.fprintf ppf "IN: %a;" I.pplist i;
                    Printf.fprintf ppf "OUT: %a;" I.pplist o;) internalbetween;
                Printf.fprintf ppf "\n";
              ) (NodeMap.to_list c.internalvar);
    Printf.fprintf ppf "\n";
end