197 lines
6.2 KiB
OCaml
197 lines
6.2 KiB
OCaml
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
|