Updated hw6 to a newer version
Signed-off-by: jmug <u.g.a.mariano@gmail.com>
This commit is contained in:
parent
9224001a22
commit
0c04936ccf
356 changed files with 8408 additions and 4725 deletions
219
hw6/bin/constprop.ml
Normal file
219
hw6/bin/constprop.ml
Normal file
|
|
@ -0,0 +1,219 @@
|
|||
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
|
||||
Loading…
Add table
Add a link
Reference in a new issue