CS153/hw6/bin/alias.ml

(** Alias Analysis *)

open Ll
open Datastructures

(* The lattice of abstract pointers ----------------------------------------- *)
module SymPtr =
  struct
    type t = MayAlias           (* uid names a pointer that may be aliased *)
           | Unique             (* uid is the unique name for a pointer *)
           | UndefAlias         (* uid is not in scope or not a pointer *)

    let compare : t -> t -> int = Stdlib.compare

    let to_string = function
      | MayAlias -> "MayAlias"
      | Unique -> "Unique"
      | UndefAlias -> "UndefAlias"

  end

(* The analysis computes, at each program point, which UIDs in scope are a unique name
   for a stack slot and which may have aliases *)
type fact = SymPtr.t UidM.t

(* flow function across Ll instructions ------------------------------------- *)
(* TASK: complete the flow function for alias analysis. 

   - After an alloca, the defined UID is the unique name for a stack slot
   - A pointer returned by a load, call, bitcast, or GEP may be aliased
   - A pointer passed as an argument to a call, bitcast, GEP, or store
     (as the value being stored) may be aliased
   - Other instructions do not define pointers

 *)

let insn_flow ((u,i):uid * insn) (d:fact) : fact =
  (* define values *)
  let unique : SymPtr.t = Unique in
  let may_alias : SymPtr.t = MayAlias in
  let undef_alias : SymPtr.t = UndefAlias in

  match i with 
  | Alloca _ -> UidM.add u unique d
  | Load (ty, _) -> 
      let is_ty_ptr_namedt = match ty with | Ptr t -> 
      let r = begin match t with | Ptr t -> true | _ -> false end in r | _ -> false in
      if is_ty_ptr_namedt == true then 
      UidM.add u may_alias d 
      else d
  | Store (_, op, _) -> 
        (* update ptr arg *)
        let is_op_uid = match op with | Const _ -> true | _ -> false in
        if is_op_uid == true then d else
        let op_uid = match op with | Id i -> i | Gid i -> i | _ -> failwith "Store error should be caught above" in
        if UidM.mem op_uid d == false then d else
        UidM.update (fun _ -> may_alias) op_uid d
  | Call (_, op, _) | Bitcast (_, op, _) | Gep (_, op, _)  ->
        (* update ptr arg *)
        let op_uid = match op with | Id i -> i | Gid i -> i | _ -> failwith "Call is supposed to be a uid" in
        if UidM.mem op_uid d  == true then 
        (* update ptr returned *)
        let d1 = UidM.update (fun _ -> may_alias) op_uid d in UidM.add u may_alias d1 
        else UidM.add u may_alias d
  | Binop _ | Icmp _ -> d


(* The flow function across terminators is trivial: they never change alias info *)
let terminator_flow t (d:fact) : fact = d

(* module for instantiating the generic framework --------------------------- *)
module Fact =
  struct
    type t = fact
    let forwards = true

    let insn_flow = insn_flow
    let terminator_flow = terminator_flow
    
    (* UndefAlias is logically the same as not having a mapping in the fact. To
       compare dataflow facts, we first remove all of these *)
    let normalize : fact -> fact = 
      UidM.filter (fun _ v -> v != SymPtr.UndefAlias)

    let compare (d:fact) (e:fact) : int = 
      UidM.compare SymPtr.compare (normalize d) (normalize e)

    let to_string : fact -> string =
      UidM.to_string (fun _ v -> SymPtr.to_string v)

    (* TASK: complete the "combine" operation for alias analysis.

       The alias analysis should take the meet over predecessors to compute the
       flow into a node. You may find the UidM.merge function useful.

       It may be useful to define a helper function that knows how to take the
       meet of two SymPtr.t facts.
    *)
    let lattice (m1:SymPtr.t) (m2:SymPtr.t) : SymPtr.t = 
      match m1, m2 with 
      | MayAlias, _ -> MayAlias
      | _, MayAlias -> MayAlias
      | Unique, Unique -> Unique
      | Unique, UndefAlias -> Unique
      | UndefAlias, Unique -> Unique
      | UndefAlias, UndefAlias -> UndefAlias

    let combine (ds : fact list) : fact =
      (* used LLM to understand how the UidM.t merge function could be useful through made-up examples, and what the inputs 'a option meant *)

      (* PART 2: look at the facts, if we have non-None facts, we can merge them based on the lattice *)
      let look_at_facts _ a_opt b_opt = 
        match a_opt, b_opt with 
        | Some a, Some b -> Some (lattice a b)
        | Some a, None -> Some a
        | None, Some b -> Some b
        | _, _ -> failwith "look_at_facts: incorrect opts" in
        
      (* PART 1: create combine function that looks at the facts *)
      let rec combine_function (fl : fact list) (acc : SymPtr.t UidM.t) : SymPtr.t UidM.t =
        match fl with
        | [] -> acc
        | hd :: tl -> let result = UidM.merge look_at_facts acc hd in combine_function tl result in

      combine_function ds UidM.empty
  end

(* instantiate the general framework ---------------------------------------- *)
module Graph = Cfg.AsGraph (Fact)
module Solver = Solver.Make (Fact) (Graph)

(* expose a top-level analysis operation ------------------------------------ *)
let analyze (g:Cfg.t) : Graph.t =
  (* the analysis starts with every node set to bottom (the map of every uid 
     in the function to UndefAlias *)
  let init l = UidM.empty in

  (* the flow into the entry node should indicate that any pointer parameter 
     to the function may be aliased *)
  let alias_in = 
    List.fold_right 
      (fun (u,t) -> match t with
                    | Ptr _ -> UidM.add u SymPtr.MayAlias
                    | _ -> fun m -> m) 
      g.Cfg.args UidM.empty 
  in
  let fg = Graph.of_cfg init alias_in g in
  Solver.solve fg