[454] | 1 | module StringMap = Map.Make(String) |
---|
| 2 | |
---|
| 3 | let error_prefix = "ASMCosts" |
---|
| 4 | let warning s = prerr_endline (error_prefix ^ s) |
---|
| 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) -> Direct_fun_call (Physical.addr16_of_addr11 pc addr11) |
---|
| 14 | | `LJMP (`ADDR16 addr16) -> Goto addr16 |
---|
| 15 | | `AJMP (`ADDR11 addr11) -> Goto (Physical.addr16_of_addr11 pc addr11) |
---|
| 16 | | `SJMP (`REL addr) -> |
---|
| 17 | let _, addr = BitVectors.half_add pc (BitVectors.sign_extension addr) in |
---|
| 18 | Goto addr |
---|
| 19 | | `JMP idptr -> Other (* Indirect jump; precondition: every possible |
---|
| 20 | destination should start with its own label *) |
---|
| 21 | | `JC addr |
---|
| 22 | | `JNC addr |
---|
| 23 | | `JB (_,addr) |
---|
| 24 | | `JNB (_,addr) |
---|
| 25 | | `JBC (_,addr) |
---|
| 26 | | `JZ addr |
---|
| 27 | | `JNZ addr |
---|
| 28 | | `CJNE (_,addr) |
---|
| 29 | | `DJNZ (_,addr) -> |
---|
| 30 | let `REL addr = addr in |
---|
| 31 | let _, addr = BitVectors.half_add pc (BitVectors.sign_extension addr) in |
---|
| 32 | Branch addr |
---|
| 33 | | `RET -> Return |
---|
| 34 | | _ -> Other |
---|
| 35 | |
---|
| 36 | |
---|
| 37 | let block_cost mem costs = |
---|
| 38 | let rec aux oldpc = |
---|
| 39 | if ASMInterpret.WordMap.mem oldpc costs then 0 |
---|
| 40 | else |
---|
| 41 | let inst,pc,inst_cost = ASMInterpret.fetch mem oldpc in |
---|
| 42 | let cost = match inst_nature oldpc inst with |
---|
| 43 | | Return -> 0 |
---|
| 44 | | Goto pc -> aux pc |
---|
| 45 | | Branch pc2 -> |
---|
| 46 | let pc1 = snd (BitVectors.half_add pc (BitVectors.vect_of_int 1 `Sixteen)) in |
---|
| 47 | let cost1 = aux pc1 in |
---|
| 48 | let cost2 = aux pc2 in |
---|
| 49 | let cost = max cost1 cost2 in |
---|
| 50 | if cost1 <> cost2 then |
---|
| 51 | warning |
---|
| 52 | (Printf.sprintf |
---|
| 53 | "Warning: branching to %s has cost %d; continuing has cost %d.\n" |
---|
| 54 | "*fixme*"(*pc2*) cost2 cost1) ; |
---|
| 55 | cost |
---|
| 56 | | _ -> aux pc |
---|
| 57 | in |
---|
| 58 | cost + inst_cost |
---|
| 59 | in |
---|
| 60 | aux |
---|
| 61 | |
---|
| 62 | |
---|
| 63 | let traverse_code mem (l,costs,_) = |
---|
| 64 | let rec aux pc = |
---|
| 65 | function |
---|
| 66 | [] -> StringMap.empty |
---|
| 67 | | _::tl -> |
---|
| 68 | let _,newpc,_ = ASMInterpret.fetch mem pc in |
---|
| 69 | (try |
---|
| 70 | let lbl = ASMInterpret.WordMap.find pc costs in |
---|
| 71 | let cost = block_cost mem costs pc in |
---|
| 72 | let costs_mapping = aux newpc tl in |
---|
| 73 | StringMap.add lbl cost costs_mapping |
---|
| 74 | with |
---|
| 75 | Not_found -> |
---|
| 76 | aux pc tl) |
---|
| 77 | in |
---|
| 78 | aux (BitVectors.zero `Sixteen) l |
---|
| 79 | |
---|
| 80 | |
---|
| 81 | let first_cost_label mem costs = |
---|
| 82 | let rec aux oldpc = |
---|
| 83 | try |
---|
| 84 | ASMInterpret.WordMap.find oldpc costs,0 |
---|
| 85 | with |
---|
| 86 | Not_found -> |
---|
| 87 | let inst,pc,inst_cost = ASMInterpret.fetch mem oldpc in |
---|
| 88 | match inst_nature oldpc inst with |
---|
| 89 | | Direct_fun_call pc -> let lbl,cost = aux pc in lbl, inst_cost + cost |
---|
| 90 | | Return |
---|
| 91 | | Goto _ |
---|
| 92 | | Branch _ -> assert false(* Precondition: no function call before main *) |
---|
| 93 | | Other -> let lbl,cost = aux pc in lbl, inst_cost + cost |
---|
| 94 | in |
---|
| 95 | aux (BitVectors.zero `Sixteen) |
---|
| 96 | |
---|
| 97 | |
---|
| 98 | let initialize_cost mem costs costs_mapping = |
---|
| 99 | let lbl,cost = first_cost_label mem costs in |
---|
| 100 | let old_cost = |
---|
| 101 | if StringMap.mem lbl costs_mapping then |
---|
| 102 | StringMap.find lbl costs_mapping |
---|
| 103 | else assert false in |
---|
| 104 | let new_cost = old_cost + cost in |
---|
| 105 | StringMap.add lbl new_cost costs_mapping |
---|
| 106 | |
---|
| 107 | |
---|
| 108 | let compute (l,costs,has_main as p) = |
---|
| 109 | let mem = ASMInterpret.load_code_memory l in |
---|
| 110 | let costs_mapping = traverse_code mem p in |
---|
| 111 | if has_main then initialize_cost mem costs costs_mapping |
---|
| 112 | else costs_mapping |
---|