Changeset 1477 for Deliverables/D2.2


Ignore:
Timestamp:
Nov 1, 2011, 6:31:24 PM (9 years ago)
Author:
tranquil
Message:
  • corrected a bug
  • implemented copy propagation
  • enhanced constant propagation with some algebraic equalities
  • temporarily added immediates to RTLabs, to be seen if it is useful
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  
    1010   ease retargetting. *)
    1111
     12
     13type argument =
     14        | Reg of Register.t
     15        | Imm of AST.cst*AST.sig_type
    1216
    1317(* A function in RTLabs is a mapping from labels to
    … …  
    3842
    3943  (* Application of a binary operation. Parameters are the operation, the
    40      destination register, the two argument registers and the label of the next
     44     destination register, the two arguments and the label of the next
    4145     statement. *)
    42   | St_op2 of AST.op2 * Register.t * Register.t * Register.t * Label.t
     46  | St_op2 of AST.op2 * Register.t * argument * argument * Label.t
    4347
    4448  (* Memory load. Parameters are the size in bytes of what to load, the
    4549     register containing the address, the destination register and the label
    4650     of the next statement. *)
    47   | St_load of AST.quantity * Register.t * Register.t * Label.t
     51  | St_load of AST.quantity * argument * Register.t * Label.t
    4852
    4953  (* Memory store. Parameters are the size in bytes of what to store, the
    5054     register containing the address, the source register and the label of the
    5155     next statement. *)
    52   | St_store of AST.quantity * Register.t * Register.t * Label.t
     56  | St_store of AST.quantity * argument * argument * Label.t
    5357
    5458  (* 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  
    132132let new_ind = CostLabel.new_const_ind
    133133
     134let 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
     138let get_type_arg lenv = function
     139        | RTLabs.Reg r -> get_type lenv r
     140        | RTLabs.Imm (_, typ) -> typ
     141
    134142(* Interpret statements. *)
    135143
    … …  
    173181        let v =
    174182          Eval.op2
    175             (get_type lenv destr) (get_type lenv srcr1) (get_type lenv srcr2)
     183            (get_type lenv destr) (get_type_arg lenv srcr1) (get_type_arg lenv srcr2)
    176184            op2
    177             (get_value lenv srcr1)
    178             (get_value lenv srcr2) in
     185            (eval_arg lenv mem sp srcr1)
     186            (eval_arg lenv mem sp srcr2) in
    179187        assign_state sfrs graph sp lbl lenv mem inds trace destr v
    180188
    181189      | RTLabs.St_load (q, addr, destr, lbl) ->
    182         let addr = address_of_value (get_value lenv addr) in
     190        let addr = address_of_value (eval_arg lenv mem sp addr) in
    183191        let v = Mem.loadq mem q addr in
    184192        assign_state sfrs graph sp lbl lenv mem inds trace destr v
    185193
    186194      | RTLabs.St_store (q, addr, srcr, lbl) ->
    187         let addr = address_of_value (get_value lenv addr) in
    188         let v = get_value lenv srcr in
     195  let addr = address_of_value (eval_arg lenv mem sp addr) in
     196        let v = eval_arg lenv mem sp srcr in
    189197        let mem = Mem.storeq mem q addr v in
    190198        State (sfrs, graph, sp, lbl, lenv, mem, inds, trace)

  • Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabsPrinter.ml

    r1473 r1477  
    9595        (print_reg r)
    9696
     97let 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
    97102let print_op2 op r s = Printf.sprintf "%s %s %s"
    98   (print_reg r)
     103  (print_arg r)
    99104  (match op with
    100105  | AST.Op_add -> "+"
    … …  
    117122  | AST.Op_cmpp cmp -> (print_cmp cmp) ^ "p"
    118123  | AST.Op_cmpu cmp -> (print_cmp cmp) ^ "u")
    119         (print_reg s)
     124        (print_arg s)
    120125
    121126
    … …  
    166171  (print_reg destr)
    167172        (Memory.string_of_quantity q)
    168         (print_reg addr)
     173        (print_arg addr)
    169174        lbl
    170175  | RTLabs.St_store (q, addr, srcr, lbl) ->
    171176      Printf.sprintf "*(%s)%s := %s --> %s"
    172177  (Memory.string_of_quantity q)
    173         (print_reg addr)
    174         (print_reg srcr)
     178        (print_arg addr)
     179        (print_arg srcr)
    175180        lbl
    176181  | RTLabs.St_call_id (f, args, Some r, sg, lbl) ->

  • Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabsPrinter.mli

    r1473 r1477  
    88val print_op1 : AST.op1 -> Register.t -> string
    99
    10 val print_op2 : AST.op2 -> Register.t -> Register.t -> string
     10val print_op2 : AST.op2 -> RTLabs.argument -> RTLabs.argument -> string
    1111
    1212val print_program : RTLabs.program -> string

  • Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabsToRTL.ml

    r1340 r1477  
    700700      lbl lbl' def
    701701
    702   | RTLabs.St_op2 (op2, destr, srcr1, srcr2, lbl') ->
     702  | RTLabs.St_op2 (op2, destr, RTLabs.Reg srcr1, RTLabs.Reg srcr2, lbl') ->
    703703    translate_op2 op2 (find_local_env destr lenv)
    704704      (find_local_env srcr1 lenv) (find_local_env srcr2 lenv) lbl lbl' def
    705705
    706   | RTLabs.St_load (_, addr, destr, lbl') ->
     706  | RTLabs.St_load (_, RTLabs.Reg addr, destr, lbl') ->
    707707    translate_load (find_local_env addr lenv) (find_local_env destr lenv)
    708708      lbl lbl' def
    709709
    710   | RTLabs.St_store (_, addr, srcr, lbl') ->
     710  | RTLabs.St_store (_, RTLabs.Reg addr, RTLabs.Reg srcr, lbl') ->
    711711    translate_store (find_local_env addr lenv) (find_local_env srcr lenv)
    712712      lbl lbl' def
    … …  
    747747  | RTLabs.St_return (Some r) ->
    748748    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
     752let 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 
    751785let translate_internal def =
     786        let def = remove_immediates def in
    752787  let runiverse = def.RTLabs.f_runiverse in
    753788  let lenv =

  • Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabsUtilities.ml

    r1473 r1477  
    175175    | None -> types
    176176    | Some x -> add types x
     177
     178(* the register modified by a node *)
     179let 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
     189let 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  
    4545    TODO: are gloabl variables registers too? *)
    4646val 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 *)
     49val 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]. *)
     53val modified_at : graph -> node -> Register.t option

  • Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/constPropagation.ml

    r1473 r1477  
    2222                | T
    2323                | V of Mem.Value.t
     24                | S (* stack: could add offset *)
     25                | A of AST.ident (* address symbol *)
    2426
    2527  type property =
    … …  
    3133  let join_t x y = match x, y with
    3234                | 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
    3337                | _ -> T
    3438
    … …  
    4044                Register.FlexMap.merge choose
    4145
    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
    4947       
    5048        let find = Register.FlexMap.find
     49       
     50        let rem = Register.FlexMap.remove
    5151               
    5252        let mem = Register.FlexMap.mem
    … …  
    5555                try
    5656                        match find i p with
    57                                 | V _ -> true
    5857                                | T -> false
     58                                | _ -> true
    5959                with
    6060                        | Not_found -> false
    6161
    6262  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       
    6785  let equal : property -> property -> bool =
    6886                Register.FlexMap.equal (fun x y -> match x, y with
    69                         | T, T -> true
     87                        | T, T | S, S -> true
    7088                        | V v1, V v2 -> Mem.Value.equal v1 v2
     89                        | A i, A j -> i = j
    7190                        | _ -> false)
    7291
    7392  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
    7499
    75100end
    … …  
    99124  | Cst_sizeof t' ->
    100125          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
    101128        | _ -> assert false (* won't call in these cases *)
    102129
    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)
     130let 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
    105133  | _ -> L.T
    106134
    … …  
    111139        | L.V v1, L.V v2, _ ->
    112140                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
    113144        | _ -> 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 *)
     148let 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
    114163
    115164let semantics
    … …  
    127176        match Label.Map.find lbl graph with
    128177    | St_cst (_, Cst_float _, _) -> error_float ()
    129                 | St_cst (_, (Cst_addrsymbol _ | Cst_stack), _) -> pred_prop
    130178                | 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 ->
    134186                        let j_val = L.find j pred_prop in
    135187                        let k_val = L.find k pred_prop in
    136188      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
    137194    | _ -> pred_prop
    138195
    … …  
    154211(* 1) if we have mapped a register to a value, it must be an integer *)
    155212(* 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 *)
     215let 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
     221let 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
     249let 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
     256let 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)
    157273
    158274(* we transform statements according to the valuation found out by analyze *)
    … …  
    160276let transform_statement
    161277    (valu : F.valuation)
    162                 (p    : Label.t)
     278                (types: sig_type Register.Map.t)
     279    (p    : Label.t)
    163280                : statement -> statement = function
    164281  | St_cst (i, (Cst_offset _ | Cst_sizeof _), next) ->
    … …  
    168285        | (St_op1 (_,i,_,next) | St_op2(_,i,_,_,next)) when L.is_cst i (valu p) ->
    169286                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
    174300        | stmt -> stmt
    175301
    … …  
    182308                : internal_function =
    183309        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
    186313        (* and we eliminate resulting dead code *)
     314        let graph = RTLabsUtilities.dead_code_elim graph f_def.f_entry in
    187315        {f_def with f_graph = graph}
    188316

  • 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. *)
    23
    34val trans : Languages.transformation

  • Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/redundancyElimination.ml

    r1473 r1477  
    22    common subexpression elimination and loop-invariant code motion.
    33    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               
    57
    68open RTLabs
    79open AST
    810
    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. *)
    1516
    1617(* ----- PHASE 0 : critical edge elimination ------ *)
    … …  
    2021(* these must be avoided, inserting an empty node in-between. *)
    2122(* 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. *)
    2325
    2426let count_predecessors
    … …  
    8789(*      | Cst of cst (* do we need to consider constants? maybe only big ones? *)*)
    8890  | UnOp of op1 * Register.t
    89   | BinOp of op2 * Register.t * Register.t
     91  | BinOp of op2 * argument * argument
    9092
    9193let expr_of_stmt (s : statement) : expr option = match s with
    9294(*      | 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))
    9496        | St_op2 (op, _, s, t, _) -> Some (BinOp (op, s, t))
    9597        | _ -> None
    … …  
    99101
    100102(* 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)
     103let modified_at_stmt = RTLabsUtilities.modified_at_stmt
     104
     105let 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).*)
     111let 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
     120let 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 *)
     124let 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
     139let used_at g n = used_at_stmt (Label.Map.find n g)
    113140
    114141module ExprOrdered = struct
    … …  
    147174      List.fold_left inter (f l) ls
    148175
     176let 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
    149182let filter_unchanged (r : Register.t option) (s : expr_set) : expr_set =
    150183        match r with
    … …  
    153186                        let filter = function
    154187                                | UnOp (_, s) when r = s -> false
    155                                 | BinOp (_, s, t) when r = s || r = t -> false
     188                                | BinOp (_, s, t) when s = Reg r || t = Reg r -> false
    156189                                | _ -> true in
    157190                        ExprSet.filter filter s
    … …  
    184217end
    185218
     219module 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   
     230end
     231
    186232module Fpair = Fix.Make (Label.ImpMap) (Lpair)
    187233
    188234module Fsing = Fix.Make (Label.ImpMap) (Lsing)
    189235
     236module Fexprid = Fix.Make (Label.ImpMap) (Lexprid)
    190237(* printing tools to debug *)
    191238
    … …  
    320367(* e is preceded by an optimal computation point for it. These are expressions*)
    321368(* 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. *)
     371let semantics_isolated_used
    323372    (g : graph)
    324373                (late : Fsing.valuation)
    325374    (lbl : Label.t)
    326     (valu : Fsing.valuation)
    327                 : Fsing.property =
     375    (valu : Fexprid.valuation)
     376                : Fexprid.property =
    328377       
    329378        let stmt = Label.Map.find lbl g in
    330379        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       
     394let compute_isolated_used
    335395    (f_def : internal_function)
    336396    (delayed : Fsing.valuation)
    337     : Fsing.valuation =
     397    : Fexprid.valuation =
    338398
    339399    let graph = f_def.f_graph in
    340400               
    341     Fsing.lfp (semantics_isolated graph (late graph delayed))
     401    Fexprid.lfp (semantics_isolated_used graph (late graph delayed))
    342402
    343403(* expressions that are optimally placed at point p, without being isolated *)
    … …  
    354414                | _ -> false
    355415
     416(* mark instructions that modify an unused register *)
     417let 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
    356424(*------ PHASE 4 : place expressions, remove reduntant ones -------------*)
    357425
    358 let remove_redundant def is_redundant =
     426let remove_redundant def is_redundant is_unused =
    359427        let g = def.f_graph in
    360428        let types = RTLabsUtilities.computes_type_map def in
    361429        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
    362433                if is_redundant lbl then
    363434                        match modified_at_stmt stmt, expr_of_stmt stmt with
    364435                                | Some r, Some e ->
    365                                         let succs = RTLabsUtilities.statement_successors stmt in
     436                                        let succ = List.hd (RTLabsUtilities.statement_successors stmt) in
    366437                            let (s, (tmp, _)) =
    367438                                                try
    … …  
    373444                                                                let s = ExprMap.add e (tmp, typ) s in
    374445                                                                (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
    377447          (Label.Map.add lbl new_stmt g', s)
    378448        | _ -> assert false
    … …  
    434504  (*Printf.printf "Late:\n";
    435505  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
    437509  (*Printf.printf "isolated:\n";
    438510  print_valu_sing isol f_def.f_graph f_def.f_entry;*)
    439511        let opt = optimal late isol in
    440512        let redn = redundant f_def.f_graph late isol in
     513        let unusd = unused f_def.f_graph used in
    441514  (*Printf.printf "optimal:\n";
    442515  print_valu_sing opt f_def.f_graph f_def.f_entry;
    … …  
    445518      Printf.printf "%s : %s\n" lbl (if redn lbl then "yes" else "no") in
    446519    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       
    448527       
    449528let transform_funct = function

  • Deliverables/D2.2/8051-indexed-labels-branch/src/cminor/cminorToRTLabs.ml

    r1421 r1477  
    194194      let (rtlabs_fun, r2) = choose_destination rtlabs_fun lenv e2 in
    195195      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
    197199      let rtlabs_fun = generate rtlabs_fun stmt in
    198200      translate_exprs rtlabs_fun lenv [r1 ; r2] [e1 ; e2]
    … …  
    201203      let (rtlabs_fun, r) = choose_destination rtlabs_fun lenv e in
    202204      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
    204207      let rtlabs_fun = generate rtlabs_fun stmt in
    205208      translate_expr rtlabs_fun lenv r e
    … …  
    283286      let (rtlabs_fun, r) = choose_destination rtlabs_fun lenv e2 in
    284287      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
    286290      let rtlabs_fun = generate rtlabs_fun stmt in
    287291      translate_exprs rtlabs_fun lenv [addr ; r] [e1 ; e2]

  • Deliverables/D2.2/8051-indexed-labels-branch/src/options.ml

    r1473 r1477  
    9292    " Apply loop peeling.";
    9393               
    94                 "-const-prop", Arg.Unit (add_transformation ConstPropagation.trans),
     94                "-cst-prop", Arg.Unit (add_transformation ConstPropagation.trans),
    9595    " Apply constant propagation.";
     96
     97    "-cpy-prop", Arg.Unit (add_transformation CopyPropagation.trans),
     98    " Apply copy propagation.";
    9699
    97100    "-pre", Arg.Unit (add_transformation RedundancyElimination.trans),
Note: See TracChangeset for help on using the changeset viewer.