Changeset 1477 for Deliverables/D2.2
- Timestamp:
- Nov 1, 2011, 6:31:24 PM (9 years ago)
- Location:
- Deliverables/D2.2/8051-indexed-labels-branch/src
- Files:
-
- 2 added
- 12 edited
Legend:
- Unmodified
- Added
- Removed
-
Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabs.mli
r1340 r1477 10 10 ease retargetting. *) 11 11 12 13 type argument = 14 | Reg of Register.t 15 | Imm of AST.cst*AST.sig_type 12 16 13 17 (* A function in RTLabs is a mapping from labels to … … 38 42 39 43 (* Application of a binary operation. Parameters are the operation, the 40 destination register, the two argument registers and the label of the next44 destination register, the two arguments and the label of the next 41 45 statement. *) 42 | St_op2 of AST.op2 * Register.t * Register.t * Register.t * Label.t46 | St_op2 of AST.op2 * Register.t * argument * argument * Label.t 43 47 44 48 (* Memory load. Parameters are the size in bytes of what to load, the 45 49 register containing the address, the destination register and the label 46 50 of the next statement. *) 47 | St_load of AST.quantity * Register.t * Register.t * Label.t51 | St_load of AST.quantity * argument * Register.t * Label.t 48 52 49 53 (* Memory store. Parameters are the size in bytes of what to store, the 50 54 register containing the address, the source register and the label of the 51 55 next statement. *) 52 | St_store of AST.quantity * Register.t * Register.t * Label.t56 | St_store of AST.quantity * argument * argument * Label.t 53 57 54 58 (* Call to a function given its name. Parameters are the name of the -
Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabsInterpret.ml
r1357 r1477 132 132 let new_ind = CostLabel.new_const_ind 133 133 134 let eval_arg lenv mem sp = function 135 | RTLabs.Reg r -> get_value lenv r 136 | RTLabs.Imm (c, t) -> Eval.cst mem sp t c 137 138 let get_type_arg lenv = function 139 | RTLabs.Reg r -> get_type lenv r 140 | RTLabs.Imm (_, typ) -> typ 141 134 142 (* Interpret statements. *) 135 143 … … 173 181 let v = 174 182 Eval.op2 175 (get_type lenv destr) (get_type lenv srcr1) (get_typelenv srcr2)183 (get_type lenv destr) (get_type_arg lenv srcr1) (get_type_arg lenv srcr2) 176 184 op2 177 ( get_value lenvsrcr1)178 ( get_value lenvsrcr2) in185 (eval_arg lenv mem sp srcr1) 186 (eval_arg lenv mem sp srcr2) in 179 187 assign_state sfrs graph sp lbl lenv mem inds trace destr v 180 188 181 189 | RTLabs.St_load (q, addr, destr, lbl) -> 182 let addr = address_of_value ( get_value lenvaddr) in190 let addr = address_of_value (eval_arg lenv mem sp addr) in 183 191 let v = Mem.loadq mem q addr in 184 192 assign_state sfrs graph sp lbl lenv mem inds trace destr v 185 193 186 194 | RTLabs.St_store (q, addr, srcr, lbl) -> 187 let addr = address_of_value (get_value lenvaddr) in188 let v = get_value lenvsrcr in195 let addr = address_of_value (eval_arg lenv mem sp addr) in 196 let v = eval_arg lenv mem sp srcr in 189 197 let mem = Mem.storeq mem q addr v in 190 198 State (sfrs, graph, sp, lbl, lenv, mem, inds, trace) -
Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabsPrinter.ml
r1473 r1477 95 95 (print_reg r) 96 96 97 let print_arg = function 98 | RTLabs.Reg r -> print_reg r 99 | RTLabs.Imm (c, t) -> 100 Printf.sprintf "(%s)%s" (Primitive.print_type t) (print_cst c) 101 97 102 let print_op2 op r s = Printf.sprintf "%s %s %s" 98 (print_ reg r)103 (print_arg r) 99 104 (match op with 100 105 | AST.Op_add -> "+" … … 117 122 | AST.Op_cmpp cmp -> (print_cmp cmp) ^ "p" 118 123 | AST.Op_cmpu cmp -> (print_cmp cmp) ^ "u") 119 (print_ reg s)124 (print_arg s) 120 125 121 126 … … 166 171 (print_reg destr) 167 172 (Memory.string_of_quantity q) 168 (print_ reg addr)173 (print_arg addr) 169 174 lbl 170 175 | RTLabs.St_store (q, addr, srcr, lbl) -> 171 176 Printf.sprintf "*(%s)%s := %s --> %s" 172 177 (Memory.string_of_quantity q) 173 (print_ reg addr)174 (print_ reg srcr)178 (print_arg addr) 179 (print_arg srcr) 175 180 lbl 176 181 | RTLabs.St_call_id (f, args, Some r, sg, lbl) -> -
Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabsPrinter.mli
r1473 r1477 8 8 val print_op1 : AST.op1 -> Register.t -> string 9 9 10 val print_op2 : AST.op2 -> R egister.t -> Register.t -> string10 val print_op2 : AST.op2 -> RTLabs.argument -> RTLabs.argument -> string 11 11 12 12 val print_program : RTLabs.program -> string -
Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabsToRTL.ml
r1340 r1477 700 700 lbl lbl' def 701 701 702 | RTLabs.St_op2 (op2, destr, srcr1,srcr2, lbl') ->702 | RTLabs.St_op2 (op2, destr, RTLabs.Reg srcr1, RTLabs.Reg srcr2, lbl') -> 703 703 translate_op2 op2 (find_local_env destr lenv) 704 704 (find_local_env srcr1 lenv) (find_local_env srcr2 lenv) lbl lbl' def 705 705 706 | RTLabs.St_load (_, addr, destr, lbl') ->706 | RTLabs.St_load (_, RTLabs.Reg addr, destr, lbl') -> 707 707 translate_load (find_local_env addr lenv) (find_local_env destr lenv) 708 708 lbl lbl' def 709 709 710 | RTLabs.St_store (_, addr,srcr, lbl') ->710 | RTLabs.St_store (_, RTLabs.Reg addr, RTLabs.Reg srcr, lbl') -> 711 711 translate_store (find_local_env addr lenv) (find_local_env srcr lenv) 712 712 lbl lbl' def … … 747 747 | RTLabs.St_return (Some r) -> 748 748 add_graph lbl (RTL.St_return (find_local_env r lenv)) def 749 750 749 750 | _ -> assert false (*not possible because of previous removal of immediates*) 751 752 let remove_immediates def = 753 let load_arg a lbl g rs = match a with 754 | RTLabs.Reg r -> (lbl, g, rs, r) 755 | RTLabs.Imm (c, t) -> 756 let new_l = Label.Gen.fresh def.RTLabs.f_luniverse in 757 let new_r = Register.fresh def.RTLabs.f_runiverse in 758 let g = Label.Map.add lbl (RTLabs.St_cst (new_r, c, new_l)) g in 759 (new_l, g, (new_r, t) :: rs, new_r) in 760 let f lbl stmt (g, rs) = 761 match stmt with 762 | RTLabs.St_op2(op, r, a1, a2, l) -> 763 let (lbl', g, rs, r1) = load_arg a1 lbl g rs in 764 let (lbl', g, rs, r2) = load_arg a2 lbl' g rs in 765 let s = RTLabs.St_op2 (op, r, RTLabs.Reg r1, RTLabs.Reg r2, l) in 766 let g = Label.Map.add lbl' s g in 767 (g, rs) 768 | RTLabs.St_store(q, a1, a2, l) -> 769 let (lbl', g, rs, r1) = load_arg a1 lbl g rs in 770 let (lbl', g, rs, r2) = load_arg a2 lbl' g rs in 771 let s = RTLabs.St_store (q, RTLabs.Reg r1, RTLabs.Reg r2, l) in 772 let g = Label.Map.add lbl' s g in 773 (g, rs) 774 | RTLabs.St_load (q, a, r, l) -> 775 let (lbl', g, rs, r1) = load_arg a lbl g rs in 776 let s = RTLabs.St_load (q, RTLabs.Reg r1, r, l) in 777 let g = Label.Map.add lbl' s g in 778 (g, rs) 779 | _ -> (g, rs) in 780 let g = def.RTLabs.f_graph in 781 let (g, rs) = Label.Map.fold f g (g, []) in 782 let locals = List.rev_append rs def.RTLabs.f_locals in 783 { def with RTLabs.f_graph = g; RTLabs.f_locals = locals } 784 751 785 let translate_internal def = 786 let def = remove_immediates def in 752 787 let runiverse = def.RTLabs.f_runiverse in 753 788 let lenv = -
Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabsUtilities.ml
r1473 r1477 175 175 | None -> types 176 176 | Some x -> add types x 177 178 (* the register modified by a node *) 179 let modified_at_stmt stmt = 180 match stmt with 181 | St_op1 (_, r, _, _) 182 | St_op2 (_, r, _, _, _) 183 | St_cst (r, _, _) 184 | St_load (_, _, r, _) 185 | St_call_id (_, _, Some r, _, _) 186 | St_call_ptr (_, _, Some r, _, _) -> Some r 187 | _ -> None 188 189 let modified_at (g : graph) (n : Label.t) : Register.t option = 190 modified_at_stmt (Label.Map.find n g) 191 -
Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabsUtilities.mli
r1473 r1477 45 45 TODO: are gloabl variables registers too? *) 46 46 val computes_type_map : internal_function -> AST.sig_type Register.Map.t 47 48 (** Tells what local register is directly modified by the statement, if any *) 49 val modified_at_stmt : statement -> Register.t option 50 51 (** [modified_at g l] is the same as [modified_at_stmt s] where [s] is the 52 statement in [g] at [l]. *) 53 val modified_at : graph -> node -> Register.t option -
Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/constPropagation.ml
r1473 r1477 22 22 | T 23 23 | V of Mem.Value.t 24 | S (* stack: could add offset *) 25 | A of AST.ident (* address symbol *) 24 26 25 27 type property = … … 31 33 let join_t x y = match x, y with 32 34 | V v1, V v2 when Mem.Value.equal v1 v2 -> V v1 35 | S, S -> S 36 | A i, A j when i = j -> A i 33 37 | _ -> T 34 38 … … 40 44 Register.FlexMap.merge choose 41 45 42 let bind i v p = 43 let new_binding = 44 try 45 join_t v (Register.FlexMap.find i p) 46 with 47 | Not_found -> v in 48 Register.FlexMap.add i new_binding p 46 let bind = Register.FlexMap.add 49 47 50 48 let find = Register.FlexMap.find 49 50 let rem = Register.FlexMap.remove 51 51 52 52 let mem = Register.FlexMap.mem … … 55 55 try 56 56 match find i p with 57 | V _ -> true58 57 | T -> false 58 | _ -> true 59 59 with 60 60 | Not_found -> false 61 61 62 62 let find_cst i p = 63 match find i p with 64 | V v -> v 65 | T -> raise Not_found 66 63 match find i p with 64 | T -> raise Not_found 65 | v -> v 66 67 68 69 let is_top i p = 70 try 71 match find i p with 72 | T -> true 73 | _ -> false 74 with 75 | Not_found -> false 76 77 let is_zero i p = 78 try 79 match find i p with 80 | V v -> Mem.Value.is_false v 81 | _ -> false 82 with 83 | Not_found -> false 84 67 85 let equal : property -> property -> bool = 68 86 Register.FlexMap.equal (fun x y -> match x, y with 69 | T, T -> true87 | T, T | S, S -> true 70 88 | V v1, V v2 -> Mem.Value.equal v1 v2 89 | A i, A j -> i = j 71 90 | _ -> false) 72 91 73 92 let is_maximal _ = false 93 94 let print = function 95 | T -> "T" 96 | V v -> Mem.Value.to_string v 97 | S -> "STACK" 98 | A i -> "*" ^ i 74 99 75 100 end … … 99 124 | Cst_sizeof t' -> 100 125 L.V (cast_to_std t (Mem.Value.of_int (MemTarget.concrete_size t'))) 126 | Cst_stack -> L.S 127 | Cst_addrsymbol i -> L.A i 101 128 | _ -> assert false (* won't call in these cases *) 102 129 103 let do_the_op1 type_of i j op x = match x with 104 | L.V v -> L.V (Eval.op1 (type_of i) (type_of j) op v) 130 let do_the_op1 type_of i j op x = match op, x with 131 | _, L.V v -> L.V (Eval.op1 (type_of i) (type_of j) op v) 132 | Op_id, _ -> x 105 133 | _ -> L.T 106 134 … … 111 139 | L.V v1, L.V v2, _ -> 112 140 L.V (Eval.op2 (type_of i) (type_of j) (type_of k) op v1 v2) 141 (* ops with stack and address symbols are not considered constant, unless *) 142 (* clearly so *) 143 | x, L.V v, (Op_addp | Op_subp) when Mem.Value.is_false v -> x 113 144 | _ -> L.T 145 146 (* this is used to mark some results of a bin op as constant even if its *) 147 (* operands are not both constant *) 148 let mark_const_op op i j k prop = 149 match L.is_zero j prop, L.is_zero k prop, op with 150 | true, _, (Op_mul | Op_div | Op_divu | Op_mod | Op_modu | Op_and | 151 Op_shl | Op_shr | Op_shru | Op_cmpu Cmp_gt) 152 | _, true, (Op_mul | Op_and | Op_cmpu Cmp_lt) -> 153 L.bind i (L.V Mem.Value.zero) prop 154 | true, _, Op_cmpu Cmp_le 155 | _, true, Op_cmpu Cmp_ge -> L.bind i (L.V (Mem.Value.of_bool true)) prop 156 | _, _, (Op_cmp Cmp_eq | Op_cmpu Cmp_eq | Op_cmpp Cmp_eq) 157 when Register.equal j k -> L.bind i (L.V (Mem.Value.of_bool true)) prop 158 | _, _, (Op_cmp Cmp_ne | Op_cmp Cmp_gt | Op_cmp Cmp_lt | 159 Op_cmpu Cmp_ne | Op_cmpu Cmp_gt | Op_cmpu Cmp_lt | 160 Op_cmpp Cmp_ne | Op_cmpp Cmp_gt | Op_cmpp Cmp_lt) 161 when Register.equal j k -> L.bind i (L.V (Mem.Value.of_bool false)) prop 162 | _ -> L.rem i prop 114 163 115 164 let semantics … … 127 176 match Label.Map.find lbl graph with 128 177 | St_cst (_, Cst_float _, _) -> error_float () 129 | St_cst (_, (Cst_addrsymbol _ | Cst_stack), _) -> pred_prop130 178 | St_cst (i, k, _) -> L.bind i (cst (type_of i) k) pred_prop 131 | St_op1 (op, i, j, _) when L.mem j pred_prop -> 132 L.bind i (do_the_op1 type_of i j op (L.find j pred_prop)) pred_prop 133 | St_op2 (op,i, j, k, _) when L.mem j pred_prop && L.mem k pred_prop -> 179 | St_op1 (op, i, j, _) -> 180 (try 181 L.bind i (do_the_op1 type_of i j op (L.find j pred_prop)) pred_prop 182 with 183 | Not_found -> L.rem i pred_prop) 184 185 | St_op2 (op,i,Reg j,Reg k,_) when L.mem j pred_prop && L.mem k pred_prop -> 134 186 let j_val = L.find j pred_prop in 135 187 let k_val = L.find k pred_prop in 136 188 L.bind i (do_the_op2 type_of i j k op j_val k_val) pred_prop 189 | St_op2 (op, i, Reg j, Reg k, _) -> 190 mark_const_op op i j k pred_prop 191 | St_load (_, _, i, _) 192 | St_call_id (_, _, Some i, _, _) 193 | St_call_ptr (_, _, Some i, _, _) -> L.rem i pred_prop 137 194 | _ -> pred_prop 138 195 … … 154 211 (* 1) if we have mapped a register to a value, it must be an integer *) 155 212 (* 2) we are turning abstract offsets and sizes into integers *) 156 let cst_of_value v = Cst_int (Mem.Value.to_int v) 213 (* 3) this shares the problem with AST constants of representability *) 214 (* with ocaml 31 bits integers *) 215 let cst_of_value = function 216 | L.V v -> Cst_int (Mem.Value.to_int v) 217 | L.S -> Cst_stack 218 | L.A i -> Cst_addrsymbol i 219 | _ -> invalid_arg "cst_of_value" 220 221 let simpl_imm_op2 op i j k types prop l = 222 let f r = 223 try 224 Some (L.find_cst r prop) 225 with 226 | Not_found -> None in 227 let one = Mem.Value.of_int 1 in 228 let type_of r = Register.Map.find r types in 229 match f j, f k, op with 230 | Some (L.V v), _, (Op_add | Op_or | Op_xor ) when Mem.Value.is_false v -> 231 St_op1(Op_id, i, k, l) 232 | Some (L.V v), _, Op_mul when Mem.Value.equal v one -> 233 St_op1(Op_id, i, k, l) 234 | _, Some (L.V v), (Op_add | Op_sub | Op_addp | Op_subp | Op_or | Op_xor) 235 when Mem.Value.is_false v -> 236 St_op1(Op_id, i, j, l) 237 | _, Some (L.V v), Op_mul when Mem.Value.equal v one -> 238 St_op1(Op_id, i, j, l) 239 | Some (L.V v), _, Op_sub when Mem.Value.is_false v -> 240 St_op1(Op_negint, i, k, l) 241 | Some v, Some u, _ -> 242 let a1 = Imm (cst_of_value v, type_of j) in 243 let a2 = Imm (cst_of_value u, type_of k) in 244 St_op2(op, i, a1, a2, l) 245 | Some v, _, _ -> St_op2(op, i, Imm (cst_of_value v, type_of j), Reg k, l) 246 | _, Some v, _ -> St_op2(op, i, Reg j, Imm (cst_of_value v, type_of k), l) 247 | _ -> St_op2(op, i, Reg j, Reg k, l) 248 249 let simpl_imm_load q i j types prop l = 250 try 251 let v = L.find_cst i prop in 252 St_load(q, Imm (cst_of_value v, Register.Map.find i types), j, l) 253 with 254 | Not_found -> St_load (q, Reg i, j, l) 255 256 let simpl_imm_store q i j types prop l = 257 let f r = 258 try 259 Some (L.find_cst r prop) 260 with 261 | Not_found -> None in 262 let type_of r = Register.Map.find r types in 263 match f i, f j with 264 | Some v, Some u -> 265 let a1 = Imm (cst_of_value v, type_of i) in 266 let a2 = Imm (cst_of_value u, type_of j) in 267 St_store(q, a1, a2, l) 268 | Some v, _ -> 269 St_store(q, Imm (cst_of_value v, type_of i), Reg j, l) 270 | _, Some u -> 271 St_store(q, Reg i, Imm (cst_of_value u, type_of j), l) 272 | _ -> St_store(q, Reg i, Reg j, l) 157 273 158 274 (* we transform statements according to the valuation found out by analyze *) … … 160 276 let transform_statement 161 277 (valu : F.valuation) 162 (p : Label.t) 278 (types: sig_type Register.Map.t) 279 (p : Label.t) 163 280 : statement -> statement = function 164 281 | St_cst (i, (Cst_offset _ | Cst_sizeof _), next) -> … … 168 285 | (St_op1 (_,i,_,next) | St_op2(_,i,_,_,next)) when L.is_cst i (valu p) -> 169 286 St_cst (i, cst_of_value (L.find_cst i (valu p)), next) 170 | St_cond (i, if_true, if_false) when L.is_cst i (valu p) -> 171 let next = 172 if Mem.Value.is_true (L.find_cst i (valu p)) then if_true else if_false in 173 St_skip next 287 | St_op2 (op, i, Reg j, Reg k, l) -> 288 simpl_imm_op2 op i j k types (valu p) l 289 | St_load (q, Reg i, j, l) -> 290 simpl_imm_load q i j types (valu p) l 291 | St_store (q, Reg i, Reg j, l) -> 292 simpl_imm_store q i j types (valu p) l 293 | St_op2 _ | St_load _ | St_store _ -> 294 assert false (* there should not be any imm argument *) 295 | St_cond (i, if_true, if_false) as s when L.is_cst i (valu p) -> 296 let s = match L.find_cst i (valu p) with 297 | L.V v when Mem.Value.is_false v -> St_skip if_false 298 | L.V _ | L.A _ -> St_skip if_true 299 | _ -> s in s 174 300 | stmt -> stmt 175 301 … … 182 308 : internal_function = 183 309 let valu = analyze f_def in 184 (* we transform the graph according to the analysis *) 185 let graph = Label.Map.mapi (transform_statement valu) f_def.f_graph in 310 (* we transform the graph according to the analysis *) 311 let types = RTLabsUtilities.computes_type_map f_def in 312 let graph = Label.Map.mapi (transform_statement valu types) f_def.f_graph in 186 313 (* and we eliminate resulting dead code *) 314 let graph = RTLabsUtilities.dead_code_elim graph f_def.f_entry in 187 315 {f_def with f_graph = graph} 188 316 -
Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/constPropagation.mli
r1468 r1477 1 (** Transofmration that performs a single pass of constant propagation *) 1 (** Transofmration that performs a single pass of copy propagation. Does not 2 use equivalence classes, so it can miss some copies. *) 2 3 3 4 val trans : Languages.transformation -
Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/redundancyElimination.ml
r1473 r1477 2 2 common subexpression elimination and loop-invariant code motion. 3 3 This is a reformulation of material found in Muchnick, Advanced compiler 4 design and implementation. *) 4 design and implementation. 5 Along the way we also perform a first rough liveness analysis. *) 6 5 7 6 8 open RTLabs 7 9 open AST 8 10 9 let error_prefix = "RTLabs to RTL" 10 let error = Error.global_error error_prefix 11 12 let error_int () = error "int16 and int32 not supported." 13 let error_float () = error "float not supported." 14 let error_shift () = error "Shift operations not supported." 11 (* Notes: To move loop-invariant computation, peeling is needed. It would *) 12 (* also profit from algebraic transformations that piece together *) 13 (* loop-constants: if x and y are loop-invariants, then x*y*i won't be *) 14 (* optimized unless it is transformed to (x*y)*i. Pretty important for *) 15 (* array addresses. *) 15 16 16 17 (* ----- PHASE 0 : critical edge elimination ------ *) … … 20 21 (* these must be avoided, inserting an empty node in-between. *) 21 22 (* Note: maybe in our case we can avoid this, as branchings will have *) 22 (* emit cost nodes afterwards. To be checked. *) 23 (* emit cost nodes afterwards. To be checked. Empirically I haven't found *) 24 (* an example where this transformation really applies. *) 23 25 24 26 let count_predecessors … … 87 89 (* | Cst of cst (* do we need to consider constants? maybe only big ones? *)*) 88 90 | UnOp of op1 * Register.t 89 | BinOp of op2 * Register.t * Register.t91 | BinOp of op2 * argument * argument 90 92 91 93 let expr_of_stmt (s : statement) : expr option = match s with 92 94 (* | St_cst (_, c, _) -> Some (Cst c)*) 93 | St_op1 (op, _, s, _) -> Some (UnOp (op, s))95 | St_op1 (op, _, s, _) when op <> Op_id -> Some (UnOp (op, s)) 94 96 | St_op2 (op, _, s, t, _) -> Some (BinOp (op, s, t)) 95 97 | _ -> None … … 99 101 100 102 (* the register modified by a node *) 101 let modified_at_stmt stmt = 102 match stmt with 103 | St_op1 (_, r, _, _) 104 | St_op2 (_, r, _, _, _) 105 | St_cst (r, _, _) 106 | St_load (_, r, _, _) 107 | St_call_id (_, _, Some r, _, _) 108 | St_call_ptr (_, _, Some r, _, _) -> Some r 109 | _ -> None 110 111 let modified_at (g : graph) (n : Label.t) : Register.t option = 112 modified_at_stmt (Label.Map.find n g) 103 let modified_at_stmt = RTLabsUtilities.modified_at_stmt 104 105 let modified_at = RTLabsUtilities.modified_at 106 107 (* registers on which the value computed at the statement depends, which are*) 108 (* needed if the modified register is needed. Below used_at lists those*) 109 (* registers that may be needed regardless (i.e. in non-side-effect-free *) 110 (* statements).*) 111 let vars_of_stmt = function 112 | St_op2 (_, _, Reg s, Reg t, _) -> 113 Register.Set.add s (Register.Set.singleton t) 114 | St_load (_, Reg s, _, _) 115 | St_op1 (_, _, s, _) 116 | St_op2 (_, _, Reg s, _, _) 117 | St_op2 (_, _, _, Reg s, _) -> Register.Set.singleton s 118 | _ -> Register.Set.empty 119 120 let vars_of (g : graph) (n : Label.t) : Register.Set.t = 121 vars_of_stmt (Label.Map.find n g) 122 123 (* used in possibly non side-effect-free statements *) 124 let used_at_stmt = function 125 | St_call_id (_, rs, _, _, _) 126 | St_call_ptr (_, rs, _, _, _) 127 | St_tailcall_id (_, rs, _) 128 | St_tailcall_ptr (_, rs, _) -> 129 let f s r = Register.Set.add r s in 130 List.fold_left f Register.Set.empty rs 131 | St_store (_, Reg s, Reg t, _) -> 132 Register.Set.add s (Register.Set.singleton t) 133 | St_return (Some r) 134 | St_cond (r, _, _) 135 | St_store (_, Reg r, _, _) 136 | St_store (_, _, Reg r, _) -> Register.Set.singleton r 137 | _ -> Register.Set.empty 138 139 let used_at g n = used_at_stmt (Label.Map.find n g) 113 140 114 141 module ExprOrdered = struct … … 147 174 List.fold_left inter (f l) ls 148 175 176 let big_union (f : Label.t -> Register.Set.t) (ls : Label.t list) 177 : Register.Set.t = 178 (* generalized union *) 179 let union s l' = Register.Set.union s (f l') in 180 List.fold_left union Register.Set.empty ls 181 149 182 let filter_unchanged (r : Register.t option) (s : expr_set) : expr_set = 150 183 match r with … … 153 186 let filter = function 154 187 | UnOp (_, s) when r = s -> false 155 | BinOp (_, s, t) when r = s || r = t-> false188 | BinOp (_, s, t) when s = Reg r || t = Reg r -> false 156 189 | _ -> true in 157 190 ExprSet.filter filter s … … 184 217 end 185 218 219 module Lexprid = struct 220 221 (* A property is a set of expressions and a set of registers. *) 222 type property = expr_set * Register.Set.t 223 224 let bottom = (ExprSet.empty, Register.Set.empty) 225 226 let equal (a, b) (c, d) = ExprSet.equal a c && Register.Set.equal b d 227 228 let is_maximal _ = false 229 230 end 231 186 232 module Fpair = Fix.Make (Label.ImpMap) (Lpair) 187 233 188 234 module Fsing = Fix.Make (Label.ImpMap) (Lsing) 189 235 236 module Fexprid = Fix.Make (Label.ImpMap) (Lexprid) 190 237 (* printing tools to debug *) 191 238 … … 320 367 (* e is preceded by an optimal computation point for it. These are expressions*) 321 368 (* which will not be touched *) 322 let semantics_isolated 369 (* A variable is used at entry if every use of it later in the execution path *) 370 (* is to compute variables which are in turn used. *) 371 let semantics_isolated_used 323 372 (g : graph) 324 373 (late : Fsing.valuation) 325 374 (lbl : Label.t) 326 (valu : F sing.valuation)327 : F sing.property =375 (valu : Fexprid.valuation) 376 : Fexprid.property = 328 377 329 378 let stmt = Label.Map.find lbl g in 330 379 let succs = RTLabsUtilities.statement_successors stmt in 331 let f l = late l ++ (valu l --* expr_of g l) in 332 big_inter f succs 333 334 let compute_isolated 380 let f l = late l ++ (fst (valu l) --* expr_of g l) in 381 let isol = big_inter f succs in 382 383 let f l = 384 let used_out = snd (valu l) in 385 let used_out = match modified_at g l with 386 | Some r when Register.Set.mem r used_out -> 387 Register.Set.union (Register.Set.remove r used_out) (vars_of g l) 388 | _ -> used_out in 389 Register.Set.union used_out (used_at g l) in 390 let used = big_union f succs in 391 392 (isol, used) 393 394 let compute_isolated_used 335 395 (f_def : internal_function) 336 396 (delayed : Fsing.valuation) 337 : F sing.valuation =397 : Fexprid.valuation = 338 398 339 399 let graph = f_def.f_graph in 340 400 341 F sing.lfp (semantics_isolated graph (late graph delayed))401 Fexprid.lfp (semantics_isolated_used graph (late graph delayed)) 342 402 343 403 (* expressions that are optimally placed at point p, without being isolated *) … … 354 414 | _ -> false 355 415 416 (* mark instructions that modify an unused register *) 417 let unused g used lbl = 418 match modified_at g lbl with 419 | Some r when Register.Set.mem r (used lbl) -> 420 false 421 | Some r -> true 422 | _ -> false 423 356 424 (*------ PHASE 4 : place expressions, remove reduntant ones -------------*) 357 425 358 let remove_redundant def is_redundant =426 let remove_redundant def is_redundant is_unused = 359 427 let g = def.f_graph in 360 428 let types = RTLabsUtilities.computes_type_map def in 361 429 let f lbl stmt (g', s) = 430 if is_unused lbl then 431 let succ = List.hd (RTLabsUtilities.statement_successors stmt) in 432 (Label.Map.add lbl (St_skip succ) g', s) else 362 433 if is_redundant lbl then 363 434 match modified_at_stmt stmt, expr_of_stmt stmt with 364 435 | Some r, Some e -> 365 let succ s = RTLabsUtilities.statement_successors stmtin436 let succ = List.hd (RTLabsUtilities.statement_successors stmt) in 366 437 let (s, (tmp, _)) = 367 438 try … … 373 444 let s = ExprMap.add e (tmp, typ) s in 374 445 (s, (tmp, typ)) in 375 let new_stmt = St_op1 (Op_id, r, tmp, lbl) in 376 let new_stmt = RTLabsUtilities.fill_labels new_stmt succs in 446 let new_stmt = St_op1 (Op_id, r, tmp, succ) in 377 447 (Label.Map.add lbl new_stmt g', s) 378 448 | _ -> assert false … … 434 504 (*Printf.printf "Late:\n"; 435 505 print_valu_sing late f_def.f_graph f_def.f_entry;*) 436 let isol = compute_isolated f_def delay in 506 let isol_used = compute_isolated_used f_def delay in 507 let isol = fun lbl -> fst (isol_used lbl) in 508 let used = fun lbl -> snd (isol_used lbl) in 437 509 (*Printf.printf "isolated:\n"; 438 510 print_valu_sing isol f_def.f_graph f_def.f_entry;*) 439 511 let opt = optimal late isol in 440 512 let redn = redundant f_def.f_graph late isol in 513 let unusd = unused f_def.f_graph used in 441 514 (*Printf.printf "optimal:\n"; 442 515 print_valu_sing opt f_def.f_graph f_def.f_entry; … … 445 518 Printf.printf "%s : %s\n" lbl (if redn lbl then "yes" else "no") in 446 519 RTLabsUtilities.dfs_iter f f_def.f_graph f_def.f_entry;*) 447 store_optimal_computation (remove_redundant f_def redn) opt 520 let f lbl _ s = Register.Set.union (used lbl) s in 521 let regs_used = 522 RTLabsUtilities.dfs_fold f f_def.f_graph f_def.f_entry Register.Set.empty in 523 let filter (r, _) = Register.Set.mem r regs_used in 524 let f_def = { f_def with f_locals = List.filter filter f_def.f_locals } in 525 store_optimal_computation (remove_redundant f_def redn unusd) opt 526 448 527 449 528 let transform_funct = function -
Deliverables/D2.2/8051-indexed-labels-branch/src/cminor/cminorToRTLabs.ml
r1421 r1477 194 194 let (rtlabs_fun, r2) = choose_destination rtlabs_fun lenv e2 in 195 195 let old_entry = rtlabs_fun.RTLabs.f_entry in 196 let stmt = RTLabs.St_op2 (op2, destr, r1, r2, old_entry) in 196 let r1_arg = RTLabs.Reg r1 in 197 let r2_arg = RTLabs.Reg r2 in 198 let stmt = RTLabs.St_op2 (op2, destr, r1_arg, r2_arg, old_entry) in 197 199 let rtlabs_fun = generate rtlabs_fun stmt in 198 200 translate_exprs rtlabs_fun lenv [r1 ; r2] [e1 ; e2] … … 201 203 let (rtlabs_fun, r) = choose_destination rtlabs_fun lenv e in 202 204 let old_entry = rtlabs_fun.RTLabs.f_entry in 203 let stmt = RTLabs.St_load (chunk, r, destr, old_entry) in 205 let stmt = 206 RTLabs.St_load (chunk, RTLabs.Reg r, destr, old_entry) in 204 207 let rtlabs_fun = generate rtlabs_fun stmt in 205 208 translate_expr rtlabs_fun lenv r e … … 283 286 let (rtlabs_fun, r) = choose_destination rtlabs_fun lenv e2 in 284 287 let old_entry = rtlabs_fun.RTLabs.f_entry in 285 let stmt = RTLabs.St_store (chunk, addr, r, old_entry) in 288 let stmt = 289 RTLabs.St_store (chunk, RTLabs.Reg addr, RTLabs.Reg r, old_entry) in 286 290 let rtlabs_fun = generate rtlabs_fun stmt in 287 291 translate_exprs rtlabs_fun lenv [addr ; r] [e1 ; e2] -
Deliverables/D2.2/8051-indexed-labels-branch/src/options.ml
r1473 r1477 92 92 " Apply loop peeling."; 93 93 94 "-c onst-prop", Arg.Unit (add_transformation ConstPropagation.trans),94 "-cst-prop", Arg.Unit (add_transformation ConstPropagation.trans), 95 95 " Apply constant propagation."; 96 97 "-cpy-prop", Arg.Unit (add_transformation CopyPropagation.trans), 98 " Apply copy propagation."; 96 99 97 100 "-pre", Arg.Unit (add_transformation RedundancyElimination.trans),
Note: See TracChangeset
for help on using the changeset viewer.