2 let error_prefix = "ASMCosts"
3 let warning s = prerr_endline (error_prefix ^ s)
6 type instruction_nature =
7 | Goto of BitVectors.word | Branch of BitVectors.word
8 | Direct_fun_call of BitVectors.word | Return
11 let 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
21 | `SJMP (`REL addr) ->
23 BitVectors.half_add next_pc (BitVectors.sign_extension addr) in
26 (Other, [next_pc]) (* Indirect jump; precondition: every possible
27 destination should start with its own label *)
37 let `REL addr = addr in
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)
46 let rec compare = function
47 | [] -> assert false (* do not use an this argument *)
49 | (pc1, cost1) :: (pc2, cost2) :: l when cost1 <> cost2 ->
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))
58 let rec block_costl mem costs = function
60 | [pc] when BitVectors.WordMap.mem pc costs -> 0
61 | [pc] -> block_cost mem costs pc
63 compare (List.map (fun pc -> (pc, block_costl mem costs [pc])) next_pcs)
65 and block_cost mem costs pc =
66 let (_, _, next_pcs, cost) = inst_infos mem pc in
67 cost + (block_costl mem costs next_pcs)
70 let traverse_code mem p =
72 let (_, newpc, _, _) = inst_infos mem pc in
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
82 aux (BitVectors.zero `Sixteen) p.ASM.code
85 let first_cost_label mem costs =
87 if BitVectors.WordMap.mem oldpc costs then
88 (BitVectors.WordMap.find oldpc costs, 0)
90 let (nature, pc, _, inst_cost) = inst_infos mem oldpc in
92 | Direct_fun_call pc ->
93 let (lbl, cost) = aux pc in
94 (lbl, inst_cost + cost)
98 assert false (* no such instructions before calling main *)
100 let (lbl, cost) = aux pc in
101 (lbl, inst_cost + cost)
103 aux (BitVectors.zero `Sixteen)
106 let initialize_cost mem costs costs_mapping =
107 let (lbl, cost) = first_cost_label mem costs in
109 if CostLabel.Map.mem lbl costs_mapping then
110 CostLabel.Map.find lbl costs_mapping
112 let new_cost = old_cost + cost in
113 CostLabel.Map.add lbl new_cost costs_mapping
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