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