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;
  }

  let compareinternalnode (a:internalnode) (b:internalnode) : bool =
    match Utility.equality a.internalin b.internalin,
          Utility.equality a.internalout b.internalout,
          (List.fold_left2 (fun acc (ain, aout) (bin, bout)
                            -> acc && (Utility.equality ain bin) && (Utility.equality aout bout)
            ) true a.internalbetween b.internalbetween)
    with
    | true, true, true -> true
    | _, _, _ -> false

  type cfgt = elt Cfg.cfginternal

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

  let compareinternal (a: internalnode Cfg.NodeMap.t) (b: internalnode Cfg.NodeMap.t) =
    Cfg.NodeMap.fold
      (fun node bi acc ->
         match Cfg.NodeMap.find_opt node a with
           None -> false
         | Some ai -> acc && compareinternalnode ai bi
      ) b true

  let from_cfg (cfg: cfgt) : t =
    {t = cfg; internalvar = 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.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";
  )


  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 compareinternal newt.internalvar t.internalvar
      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 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
    helper { t with internalvar = content }

end