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 | (* TODO: do not consider the very first instruction as ending the block since it |
---|
39 | contains the cost label whose cost we are trying to compute! *) |
---|
40 | let block_cost mem costs = |
---|
41 | let rec aux oldpc = |
---|
42 | if BitVectors.WordMap.mem oldpc costs then 0 |
---|
43 | else |
---|
44 | let inst,pc,inst_cost = ASMInterpret.fetch mem oldpc in |
---|
45 | let cost = match inst_nature oldpc inst with |
---|
46 | | Return -> 0 |
---|
47 | | Goto pc -> aux pc |
---|
48 | | Branch pc2 -> |
---|
49 | let pc1 = |
---|
50 | snd (BitVectors.half_add pc (BitVectors.vect_of_int 1 `Sixteen)) in |
---|
51 | let cost1 = aux pc1 in |
---|
52 | let cost2 = aux pc2 in |
---|
53 | if cost1 <> cost2 then |
---|
54 | warning |
---|
55 | (Printf.sprintf |
---|
56 | "Warning: branching to %s has cost %d; continuing has cost %d.\n" |
---|
57 | "*fixme*"(*pc2*) cost2 cost1) ; |
---|
58 | max cost1 cost2 |
---|
59 | | _ -> aux pc |
---|
60 | in |
---|
61 | cost + inst_cost |
---|
62 | in |
---|
63 | aux |
---|
64 | |
---|
65 | |
---|
66 | let traverse_code mem p = |
---|
67 | let rec aux pc code = |
---|
68 | let _,newpc,_ = ASMInterpret.fetch mem pc in |
---|
69 | match code with |
---|
70 | | [] -> CostLabel.Map.empty |
---|
71 | | _::tl when BitVectors.WordMap.mem pc p.ASM.cost_labels -> |
---|
72 | let lbl = BitVectors.WordMap.find pc p.ASM.cost_labels in |
---|
73 | let cost = block_cost mem p.ASM.cost_labels pc in |
---|
74 | let costs_mapping = aux newpc tl in |
---|
75 | CostLabel.Map.add lbl cost costs_mapping |
---|
76 | | _::tl -> aux newpc tl |
---|
77 | in |
---|
78 | aux (BitVectors.zero `Sixteen) p.ASM.code |
---|
79 | |
---|
80 | |
---|
81 | let first_cost_label mem costs = |
---|
82 | let rec aux oldpc = |
---|
83 | try (BitVectors.WordMap.find oldpc costs, 0) |
---|
84 | with |
---|
85 | | Not_found -> |
---|
86 | let inst,pc,inst_cost = ASMInterpret.fetch mem oldpc in |
---|
87 | match inst_nature oldpc inst with |
---|
88 | | Direct_fun_call pc -> |
---|
89 | let (lbl, cost) = aux pc in |
---|
90 | (lbl, inst_cost + cost) |
---|
91 | | Return |
---|
92 | | Goto _ |
---|
93 | | Branch _ -> |
---|
94 | assert false (* no such instructions before calling main *) |
---|
95 | | Other -> |
---|
96 | let (lbl, cost) = aux pc in |
---|
97 | (lbl, inst_cost + cost) |
---|
98 | in |
---|
99 | aux (BitVectors.zero `Sixteen) |
---|
100 | |
---|
101 | |
---|
102 | let initialize_cost mem costs costs_mapping = |
---|
103 | let (lbl, cost) = first_cost_label mem costs in |
---|
104 | let old_cost = |
---|
105 | assert (CostLabel.Map.mem lbl costs_mapping) ; |
---|
106 | CostLabel.Map.find lbl costs_mapping in |
---|
107 | let new_cost = old_cost + cost in |
---|
108 | CostLabel.Map.add lbl new_cost costs_mapping |
---|
109 | |
---|
110 | |
---|
111 | let compute p = |
---|
112 | let mem = ASMInterpret.load_code_memory p.ASM.code in |
---|
113 | let costs_mapping = traverse_code mem p in |
---|
114 | if p.ASM.has_main then initialize_cost mem p.ASM.cost_labels costs_mapping |
---|
115 | else costs_mapping |
---|