source: Deliverables/D2.2/8051/src/RTLabs/RTLabsGraph.ml @ 1580

(** this module provides some utilities relative to RTLabs graphs *)

type node = Label.t
type statement = RTLabs.statement

module NodeMap = Label.Map
module NodeSet = Label.Set

type t = RTLabs.graph

open RTLabs

(** Successors of a statement *)
let successors (stmt : statement) =
  match stmt with
  | St_return _
  | St_tailcall_id _
  | St_tailcall_ptr _ ->
    []
  | St_skip l
  | St_cost (_, l)
  | St_ind_0 (_, l)
  | St_ind_inc (_, l)
  | St_cst (_, _, l)
  | St_op1 (_, _, _, l)
  | St_op2 (_, _, _, _, l)
  | St_load (_, _, _, l)
  | St_store (_, _, _, l)
  | St_call_ptr (_, _, _, _, l)
  | St_call_id (_, _, _, _, l) ->
    [l]
  | St_cond (_, l1, l2) ->
    [l1 ; l2]
  | St_jumptable (_, ls) -> ls

let skip lbl = St_skip lbl

let fill_succs stmt succs = match stmt, succs with
  | (St_return _
        | St_tailcall_id _
        | St_tailcall_ptr _) as inst, [] -> inst
  | St_skip _, [lbl] -> St_skip lbl
  | St_cost (cost_lbl, _), [lbl] -> St_cost (cost_lbl, lbl)
  | St_ind_0 (i, _), [lbl] -> St_ind_0 (i, lbl)
  | St_ind_inc (i, _), [lbl] -> St_ind_inc (i, lbl)
  | St_cst (r, k, _), [lbl] -> St_cst (r, k, lbl)
  | St_op1 (o, r, s, _), [lbl] -> St_op1 (o, r, s, lbl)
  | St_op2 (o, r, a, b, _), [lbl] -> St_op2 (o, r, a, b, lbl)
  | St_load (r, a, b, _), [lbl] -> St_load (r, a, b, lbl)
  | St_store (a, b, c, _), [lbl] -> St_store (a, b, c, lbl)
  | St_call_ptr (f, args, ret, s, _), [lbl] -> St_call_ptr (f, args, ret, s, lbl)
  | St_call_id (f, args, ret, s, _), [lbl] -> St_call_id (f, args, ret, s, lbl)
  | St_cond (r, _, _), [lbl1; lbl2] -> St_cond (r, lbl1, lbl2)
  | St_jumptable (r, _), ls -> St_jumptable (r, ls)
  | _ -> invalid_arg "fill_succs: provided successors do not match statement"

(** Exported helper functions *)
let compute_type_map
    (f_def : internal_function)
    : AST.sig_type Register.Map.t =
  let types = Register.Map.empty in
  let add map (r, typ)  = Register.Map.add r typ map in
  let types = List.fold_left add types f_def.f_params in
  let types = List.fold_left add types f_def.f_locals in
  match f_def.f_result with
    | None -> types
    | Some x -> add types x

(* the register directly modified by a node *)
let modified_at_stmt stmt =
  match stmt with
    | St_op1 (_, r, _, _)
    | St_op2 (_, r, _, _, _)
    | St_cst (r, _, _)
    | St_load (_, _, r, _)
    | St_call_id (_, _, Some r, _, _)
    | St_call_ptr (_, _, Some r, _, _) -> Some r
    | _ -> None

let modified_at (g : graph) (n : Label.t) : Register.t option =
  modified_at_stmt (Label.Map.find n g)