source: Deliverables/D2.2/8051/src/cminor/cminorPointers.ml @ 640

let union_list =
  List.fold_left StringTools.Set.union StringTools.Set.empty


(** [is_pointer ptrs e] returns true iff the expression [e] represents an
    address when considering that the variables in the set [ptrs] are
    pointers. *)

let rec is_pointer ptrs = function
  | Cminor.Id x -> StringTools.Set.mem x ptrs
  | Cminor.Cst (AST.Cst_stackoffset _) | Cminor.Cst (AST.Cst_addrsymbol _) ->
    true
  | Cminor.Op1 (AST.Op_id, e) -> is_pointer ptrs e
  | Cminor.Op1 (AST.Op_ptrofint, _) -> true
  | Cminor.Op2 (AST.Op_addp, _, _) | Cminor.Op2 (AST.Op_subp, _, _) -> true
  | Cminor.Mem (Memory.MQ_pointer, _) -> true
  | Cminor.Cond (_, e2, e3) -> (is_pointer ptrs e2) || (is_pointer ptrs e3)
  | Cminor.Exp_cost (_, e) -> is_pointer ptrs e
  | _ -> false

(** [is_op1_pointer op1] returns true iff [op1] returns a pointer. *)

let is_op1_pointer = function
  | AST.Op_intofptr -> true
  | _ -> false

(** When [op2_ptr_args op2 = (b1, b2)] [b1] (resp. [b2]) is true iff the first
    (resp. second) argument of [op2] must be a pointer. *)

let op2_ptr_args = function
  | AST.Op_cmpp _ -> (true, true)
  | AST.Op_addp | AST.Op_subp -> (true, false)
  | _ -> (false, false)

(** [expression_pointer is_pointer e] returns the set of variables that
    represent an address in the expression [e]. The [is_pointer] function is a
    predicate telling whether or not a given variable is a pointer. *)

let rec expression_pointers is_pointer = function
  | Cminor.Id x when is_pointer -> StringTools.Set.singleton x
  | Cminor.Id x -> StringTools.Set.empty
  | Cminor.Cst _ -> StringTools.Set.empty
  | Cminor.Exp_cost (_, e)
  | Cminor.Op1 (AST.Op_id, e) -> expression_pointers is_pointer e
  | Cminor.Op1 (op1, e) -> expression_pointers (is_op1_pointer op1) e
  | Cminor.Op2 (op2, e1, e2) ->
    let (b1, b2) = op2_ptr_args op2 in
    let res1 = expression_pointers b1 e1 in
    let res2 = expression_pointers b2 e2 in
    union_list [res1 ; res2]
  | Cminor.Mem (_, e) -> expression_pointers true e
  | Cminor.Cond (e1, e2, e3) ->
    let res1 = expression_pointers false e1 in
    let res2 = expression_pointers is_pointer e2 in
    let res3 = expression_pointers is_pointer e3 in
    union_list [res1 ; res2 ; res3]


(** [f_statement_pointers ret_type ptrs stmt subexp_res substmt_res] returns the
    set of variables that are pointers in [stmt]. [ret_type] is the type of the
    returned expression of the statement, if any. [ptrs] is a set of already
    known pointer variables. [subexp_res] is not used. [substmt_res] is the
    result of the application of the function on the sub-statements of
    [stmt]. *)

let f_statement_pointers ret_type ptrs stmt _ substmt_res =
  let ptrs = union_list (ptrs :: substmt_res) in
  let stmt_ptrs = match stmt with
    | Cminor.St_assign (x, e) ->
      let res1 =
        if is_pointer ptrs e then StringTools.Set.singleton x
        else StringTools.Set.empty in
      let res2 = expression_pointers (StringTools.Set.mem x ptrs) e in
      union_list [res1 ; res2]
    | Cminor.St_store (_, e1, e2) ->
      let res1 =
        expression_pointers
          true (* when storing, [e1] must be an address *) e1 in
      let res2 = expression_pointers false e2 in
      union_list [res1 ; res2]
    | Cminor.St_call (None, f, args, sg)
    | Cminor.St_tailcall (f, args, sg) ->
      let res1 =
        expression_pointers
          true (* when calling, [f] must be an address *) f in
      (* Fetch the results on the arguments of the function. *)
      let f typ e = expression_pointers (typ = AST.Sig_ptr) e in
      let res2 = union_list (List.map2 f sg.AST.args args) in
      union_list [res1 ; res2]
    | Cminor.St_call (Some x, f, args, sg) ->
      let res1 =
        if sg.AST.res = AST.Type_ret AST.Sig_ptr then
          StringTools.Set.singleton x
        else StringTools.Set.empty in
      let res2 = expression_pointers true f in
      let f typ e = expression_pointers (typ = AST.Sig_ptr) e in
      let res3 = union_list (List.map2 f sg.AST.args args) in
      union_list [res1 ; res2 ; res3]
    | Cminor.St_ifthenelse (e, _, _) -> expression_pointers false e
    | Cminor.St_return (Some e) ->
      expression_pointers (ret_type = AST.Type_ret AST.Sig_ptr) e
    | _ -> StringTools.Set.empty
  in
  union_list [ptrs ; stmt_ptrs]

(** [statement_pointers type_ret stmt ptrs] is one iteration that collects the
    pointers of [stmt]. [type_ret] is the type of the returned expression of the
    statement, if any. [ptrs] is a set of already known pointer variables.  *)

let statement_pointers type_ret stmt ptrs =
  CminorFold.statement_left (fun _ _ -> StringTools.Set.empty)
    (f_statement_pointers type_ret ptrs) stmt


(* A function that iterates another function until a fixpoint is reached. The
   result is a set of strings. *)

let rec fixpoint f s =
  let s' = f s in
  if StringTools.Set.equal s s' then s
  else fixpoint f s'


let internal_pointers def =
  (* The pointers of a function are found by iterating one step of collecting
     the pointers until a fixpoint is reached. *)
  let ptrs =
    fixpoint
      (statement_pointers def.Cminor.f_sig.AST.res def.Cminor.f_body)
      StringTools.Set.empty in
  let ptrs = StringTools.Set.fold (fun x l -> x :: l) ptrs [] in
  { def with Cminor.f_ptrs = ptrs }

let fun_def_pointers (id, def) =
  let def' = match def with
    | Cminor.F_int def -> Cminor.F_int (internal_pointers def)
    | _ -> def
  in
  (id, def')

(** [fill p] sets the pointer variables field of each function of the program
    [p]. The algorithm works as a fixpoint: initially, there are no pointers,
    then we collect the pointers found in one pass and repeat the operation
    considering the new result. *)

let fill p =
  { p with Cminor.functs = List.map fun_def_pointers p.Cminor.functs }