src/ASM/ASMCosts.ml

   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_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
  46 let 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
  58 let 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
  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)
  68
  69
  70 let 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
  85 let 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
 106 let 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
 116 let 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