source: Deliverables/D2.2/8051/src/ASM/ASMCosts.ml @ 643

Last change on this file since 643 was 643, checked in by ayache, 9 years ago

Bug fix in ASMCosts in D2.2.

File size: 3.7 KB
Line 
1
2let error_prefix = "ASMCosts"
3let warning s = prerr_endline (error_prefix ^ s)
4
5
6type instruction_nature =
7  | Goto of BitVectors.word | Branch of BitVectors.word
8  | Direct_fun_call of BitVectors.word | Return
9  | Other
10
11let inst_infos mem pc =
12  let (inst, next_pc, inst_cost) = ASMInterpret.fetch mem pc in
13  let (nature, next_pcs) = match inst with
14    | `LCALL (`ADDR16 addr16) -> (Direct_fun_call addr16, [next_pc])
15    | `ACALL (`ADDR11 addr11) ->
16      (Direct_fun_call (Physical.addr16_of_addr11 pc addr11), [next_pc])
17    | `LJMP (`ADDR16 addr16) -> (Goto addr16, [addr16])
18    | `AJMP (`ADDR11 addr11) ->
19      let addr = Physical.addr16_of_addr11 pc addr11 in
20      (Goto addr, [addr])
21    | `SJMP (`REL addr) ->
22      let _, addr =
23        BitVectors.half_add next_pc (BitVectors.sign_extension addr) in
24      (Goto addr, [addr])
25    | `JMP idptr ->
26      (Other, [next_pc]) (* Indirect jump; precondition: every possible
27                            destination should start with its own label *)
28    | `JC addr
29    | `JNC addr
30    | `JB (_,addr)
31    | `JNB (_,addr)
32    | `JBC (_,addr)
33    | `JZ addr
34    | `JNZ addr
35    | `CJNE (_,addr)
36    | `DJNZ (_,addr) ->
37      let `REL addr = addr in
38      let _, addr =
39        BitVectors.half_add next_pc (BitVectors.sign_extension addr) in
40      (Branch addr, [next_pc ; addr])
41    | `RET | `RETI -> (Return, [])
42    | _ -> (Other, [next_pc]) in
43  (nature, next_pc, next_pcs, inst_cost)
44
45
46let rec compare = function
47  | [] -> assert false (* do not use an this argument *)
48  | [(_, cost)] -> cost
49  | (pc1, cost1) :: (pc2, cost2) :: l when cost1 <> cost2 ->
50    warning
51      (Printf.sprintf
52         "Warning: branching to %s has cost %d, branching to %s has cost %d"
53         (string_of_int (BitVectors.int_of_vect pc1)) cost1
54         (string_of_int (BitVectors.int_of_vect pc2)) cost2) ;
55    max cost1 (compare ((pc2, cost2) :: l))
56  | _ :: l -> compare l
57
58let rec block_costl mem costs = function
59  | [] -> 0
60  | [pc] when BitVectors.WordMap.mem pc costs -> 0
61  | [pc] -> block_cost mem costs pc
62  | next_pcs ->
63    compare (List.map (fun pc -> (pc, block_costl mem costs [pc])) next_pcs)
64
65and block_cost mem costs pc =
66  let (_, _, next_pcs, cost) = inst_infos mem pc in
67  cost + (block_costl mem costs next_pcs)
68
69
70let traverse_code mem p =
71  let rec aux pc code =
72    let (_, newpc, _, _) = inst_infos mem pc in
73    match code with
74      | [] -> CostLabel.Map.empty
75      | _::tl when BitVectors.WordMap.mem pc p.ASM.cost_labels ->
76        let lbl = BitVectors.WordMap.find pc p.ASM.cost_labels in
77        let cost = block_cost mem p.ASM.cost_labels pc in
78        let costs_mapping = aux newpc tl in
79        CostLabel.Map.add lbl cost costs_mapping
80      | _::tl -> aux newpc tl
81  in
82  aux (BitVectors.zero `Sixteen) p.ASM.code
83
84
85let first_cost_label mem costs =
86  let rec aux oldpc =
87    if BitVectors.WordMap.mem oldpc costs then
88      (BitVectors.WordMap.find oldpc costs, 0)
89    else
90      let (nature, pc, _, inst_cost) = inst_infos mem oldpc in
91      match nature with
92        | Direct_fun_call pc ->
93          let (lbl, cost) = aux pc in
94          (lbl, inst_cost + cost)
95        | Return
96        | Goto _
97        | Branch _ ->
98          assert false (* no such instructions before calling main *)
99        | Other ->
100          let (lbl, cost) = aux pc in
101          (lbl, inst_cost + cost)
102  in
103  aux (BitVectors.zero `Sixteen)
104
105
106let initialize_cost mem costs costs_mapping =
107  let (lbl, cost) = first_cost_label mem costs in
108  let old_cost =
109    if CostLabel.Map.mem lbl costs_mapping then
110      CostLabel.Map.find lbl costs_mapping
111    else 0 in
112  let new_cost = old_cost + cost in
113  CostLabel.Map.add lbl new_cost costs_mapping
114
115
116let compute p =
117  let mem = ASMInterpret.load_code_memory p.ASM.code in
118  let costs_mapping = traverse_code mem p in
119  if p.ASM.has_main then initialize_cost mem p.ASM.cost_labels costs_mapping
120  else costs_mapping
Note: See TracBrowser for help on using the repository browser.