219 lines
7.8 KiB
OCaml
219 lines
7.8 KiB
OCaml
open Ll
|
|
open Datastructures
|
|
|
|
(* The lattice of symbolic constants ---------------------------------------- *)
|
|
module SymConst =
|
|
struct
|
|
type t = NonConst (* Uid may take on multiple values at runtime *)
|
|
| Const of int64 (* Uid will always evaluate to const i64 or i1 *)
|
|
| UndefConst (* Uid is not defined at the point *)
|
|
|
|
let compare (a:t) (b:t) =
|
|
match a, b with
|
|
| (Const i, Const j) -> Int64.compare i j
|
|
| (NonConst, NonConst) | (UndefConst, UndefConst) -> 0
|
|
| (NonConst, _) | (_, UndefConst) -> 1
|
|
| (UndefConst, _) | (_, NonConst) -> -1
|
|
|
|
let to_string : t -> string = function
|
|
| NonConst -> "NonConst"
|
|
| Const i -> Printf.sprintf "Const (%LdL)" i
|
|
| UndefConst -> "UndefConst"
|
|
|
|
|
|
end
|
|
|
|
(* The analysis computes, at each program point, which UIDs in scope will evaluate
|
|
to integer constants *)
|
|
type fact = SymConst.t UidM.t
|
|
|
|
|
|
|
|
(* flow function across Ll instructions ------------------------------------- *)
|
|
(* - Uid of a binop or icmp with const arguments is constant-out
|
|
- Uid of a binop or icmp with an UndefConst argument is UndefConst-out
|
|
- Uid of a binop or icmp with an NonConst argument is NonConst-out
|
|
- Uid of stores and void calls are UndefConst-out
|
|
- Uid of all other instructions are NonConst-out
|
|
*)
|
|
|
|
let compute_const_bop (bop:bop) (i1:int64) (i2:int64) : int64=
|
|
match bop with
|
|
| Add -> Int64.add i1 i2
|
|
| Sub -> Int64.sub i1 i2
|
|
| Mul -> Int64.mul i1 i2
|
|
| And -> Int64.logand i1 i2
|
|
| Or -> Int64.logor i1 i2
|
|
| Xor -> Int64.logxor i1 i2
|
|
| Shl -> Int64.shift_left i1 (Int64.to_int i2)
|
|
| Ashr -> Int64.shift_right i1 (Int64.to_int i2)
|
|
| Lshr -> Int64.shift_right_logical i1 (Int64.to_int i2)
|
|
|
|
let compute_const_cnd (cnd:cnd) (i1:int64) (i2:int64) =
|
|
let result = match cnd with
|
|
| Eq -> i1 == i2
|
|
| Ne -> i1 != i2
|
|
| Slt -> i1 < i2
|
|
| Sle -> i1 <= i2
|
|
| Sgt -> i1 > i2
|
|
| Sge -> i1 >= i2
|
|
in if result then 1L else 0L
|
|
|
|
let meet_facts (c1:SymConst.t) (c2:SymConst.t) (bop:bop option) (cnd:cnd option): SymConst.t =
|
|
(* NonConst <= Const c <= UndefConst *)
|
|
match c1, c2 with
|
|
| NonConst, _ -> NonConst
|
|
| _, NonConst -> NonConst
|
|
| Const a, Const b ->
|
|
begin match bop, cnd with
|
|
| Some c, _ -> Const (compute_const_bop c a b)
|
|
| _, Some c -> Const (compute_const_cnd c a b)
|
|
| _ -> failwith "meet_facts self-error: did not supply a bop or a cnd" end
|
|
| Const a, UndefConst -> Const a
|
|
| UndefConst, Const b -> Const b
|
|
| UndefConst, UndefConst -> UndefConst
|
|
|
|
let op_symconst (op:operand) (i:insn) (d:fact): SymConst.t =
|
|
match op with
|
|
| Const c -> Const c
|
|
| Null -> NonConst
|
|
| Id i | Gid i -> begin match UidM.find_opt i d with
|
|
| Some c -> c | None -> UndefConst end
|
|
|
|
let insn_flow (u,i:uid * insn) (d:fact) : fact =
|
|
let nonconst : SymConst.t = NonConst in
|
|
let undefconst : SymConst.t = UndefConst in
|
|
|
|
match i with
|
|
| Binop (bop, _, op1, op2) ->
|
|
let op_symconst1 = op_symconst op1 i d in
|
|
let op_symconst2 = op_symconst op2 i d in
|
|
let symconst = meet_facts op_symconst1 op_symconst2 (Some bop) None in
|
|
UidM.add u symconst d
|
|
| Icmp (cnd, _, op1, op2) ->
|
|
let op_symconst1 = op_symconst op1 i d in
|
|
let op_symconst2 = op_symconst op2 i d in
|
|
let symconst = meet_facts op_symconst1 op_symconst2 None (Some cnd) in
|
|
UidM.add u symconst d
|
|
| Store (_, _, _) | Call (Void, _, _) -> UidM.add u undefconst d
|
|
| _ -> UidM.add u nonconst d
|
|
|
|
(* The flow function across terminators is trivial: they never change const info *)
|
|
let terminator_flow (t:terminator) (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
|
|
|
|
let normalize : fact -> fact =
|
|
UidM.filter (fun _ v -> v != SymConst.UndefConst)
|
|
|
|
let compare (d:fact) (e:fact) : int =
|
|
UidM.compare SymConst.compare (normalize d) (normalize e)
|
|
|
|
let to_string : fact -> string =
|
|
UidM.to_string (fun _ v -> SymConst.to_string v)
|
|
|
|
|
|
(* The constprop analysis should take the meet over predecessors to compute the
|
|
flow into a node. You may find the UidM.merge function useful *)
|
|
|
|
let combine (ds:fact list) : fact =
|
|
(* merge function to call meet facts *)
|
|
let merge_function _ a_opt b_opt =
|
|
match a_opt, b_opt with
|
|
| Some a, Some b -> if a == b then Some b else None
|
|
| Some a, None -> Some a
|
|
| None, Some b -> Some b
|
|
| _, _ -> failwith "" in
|
|
|
|
(* combine function to call merge function *)
|
|
let rec combine_function (fl : fact list) (acc : SymConst.t UidM.t) : SymConst.t UidM.t =
|
|
match fl with
|
|
| [] -> acc
|
|
| hd :: tl -> let result = UidM.merge merge_function 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 UndefConst *)
|
|
let init l = UidM.empty in
|
|
|
|
(* the flow into the entry node should indicate that any parameter to the
|
|
function is not a constant *)
|
|
let cp_in = List.fold_right
|
|
(fun (u,_) -> UidM.add u SymConst.NonConst)
|
|
g.Cfg.args UidM.empty
|
|
in
|
|
let fg = Graph.of_cfg init cp_in g in
|
|
Solver.solve fg
|
|
|
|
|
|
(* run constant propagation on a cfg given analysis results ----------------- *)
|
|
(* HINT: your cp_block implementation will probably rely on several helper
|
|
functions. *)
|
|
let run (cg:Graph.t) (cfg:Cfg.t) : Cfg.t =
|
|
let open SymConst in
|
|
|
|
let cp_block (l:Ll.lbl) (cfg:Cfg.t) : Cfg.t =
|
|
let b = Cfg.block cfg l in
|
|
let cb = Graph.uid_out cg l in
|
|
|
|
let rec check_operand (op:operand) (insn:insn) =
|
|
let op1_new = match op with
|
|
| Id i | Gid i ->
|
|
let fact = cb i in
|
|
let symconst : SymConst.t = op_symconst op insn fact in
|
|
let r = begin match symconst with
|
|
| Const c -> Some c
|
|
| _ -> None end in r
|
|
| _ -> None in op1_new in
|
|
|
|
let rec iterate_instructions (uid_insn_list : (uid * insn) list) (new_uid_insn_list : (uid * insn) list) =
|
|
match uid_insn_list with
|
|
| [] -> new_uid_insn_list
|
|
| hd :: tl ->
|
|
let uid, insn = hd in
|
|
(* we want to see if the value is a var = constant *)
|
|
(* if this is the case, we'll want to check every other instruction and "propogate it" in there *)
|
|
let new_uid_insn = match insn with
|
|
| Binop (bop, ty, op1, op2) ->
|
|
let check_op1 = check_operand op1 insn in
|
|
let check_op2 = check_operand op2 insn in
|
|
let new_op1 : operand = match check_op1 with | Some c -> Const c | _ -> op1 in
|
|
let new_op2 : operand = match check_op2 with | Some c -> Const c | _ -> op2 in
|
|
(uid, Binop (bop, ty, new_op1, new_op2))
|
|
| _ -> failwith "nye"
|
|
in iterate_instructions tl (new_uid_insn_list @ [new_uid_insn]) in
|
|
|
|
(* WE ALSO NEED TO DO THE TERMINATOR INSTRUCTION, SAME IDEA :) *)
|
|
|
|
|
|
let new_uid_insns = iterate_instructions b.insns [] in
|
|
let new_block = { insns = new_uid_insns; term = b.term } in
|
|
|
|
let remove_old_block = LblM.remove l cfg.blocks in
|
|
let new_block_same_lbl = LblM.add l new_block cfg.blocks in
|
|
|
|
let new_cfg : Cfg.cfg = {
|
|
blocks = new_block_same_lbl;
|
|
preds = cfg.preds;
|
|
ret_ty = cfg.ret_ty;
|
|
args = cfg.args;
|
|
} in
|
|
|
|
new_cfg
|
|
in
|
|
|
|
LblS.fold cp_block (Cfg.nodes cfg) cfg
|