source: Deliverables/D2.2/8051/src/ASM/ASMCosts.ml @ 621

let error_prefix = "ASMCosts"
let warning s = prerr_endline (error_prefix ^ s)


type instruction_nature =
  | Goto of BitVectors.word | Branch of BitVectors.word
  | Direct_fun_call of BitVectors.word | Return
  | Other

let inst_nature pc = function
  | `LCALL (`ADDR16 addr16) -> Direct_fun_call addr16
  | `ACALL (`ADDR11 addr11) ->
    Direct_fun_call (Physical.addr16_of_addr11 pc addr11)
  | `LJMP (`ADDR16 addr16) -> Goto addr16
  | `AJMP (`ADDR11 addr11) -> Goto (Physical.addr16_of_addr11 pc addr11)
  | `SJMP (`REL addr) ->
      let _, addr = BitVectors.half_add pc (BitVectors.sign_extension addr) in
       Goto addr
  | `JMP idptr -> Other (* Indirect jump; precondition: every possible
                           destination should start with its own label *)
  | `JC addr
  | `JNC addr
  | `JB (_,addr)
  | `JNB (_,addr)
  | `JBC (_,addr)
  | `JZ addr
  | `JNZ addr
  | `CJNE (_,addr)
  | `DJNZ (_,addr) ->
      let `REL addr = addr in
      let _, addr = BitVectors.half_add pc (BitVectors.sign_extension addr) in
       Branch addr
  | `RET -> Return
  | _ -> Other


let treat mem costs pc =
  let (inst, next_pc, inst_cost) = ASMInterpret.fetch mem pc in
  let next_pcs = match inst_nature pc inst with
    | Return -> []
    | Goto pc -> [pc]
    | Branch pc2 ->
      let pc1 =
        snd (BitVectors.half_add pc (BitVectors.vect_of_int 1 `Sixteen)) in
      [pc1 ; pc2]
    | _ -> [next_pc] in
  (inst_cost, next_pcs)

let compare pc1 cost1 pc2 cost2 =
  if cost1 <> cost2 then
    warning
      (Printf.sprintf
         "Warning: branching to %s has cost %d, branching to %s has cost %d"
         "*fixme*"(* pc1 *) cost1 "*fixme*" (* pc2 *) cost2) ;
  max cost1 cost2

let block_cost mem costs pc =
  let treat = treat mem costs in
  let (init_cost, next_pcs) = treat pc in
  let rec aux = function
    | [] -> 0
    | [pc] when BitVectors.WordMap.mem pc costs -> 0
    | [pc] -> full_cost pc
    | [pc1 ; pc2] when BitVectors.WordMap.mem pc1 costs &&
                       BitVectors.WordMap.mem pc2 costs -> 0
    | [pc1 ; pc2] when BitVectors.WordMap.mem pc1 costs ->
      let cost2 = full_cost pc2 in
      compare pc1 0 pc2 cost2
    | [pc1 ; pc2] when BitVectors.WordMap.mem pc2 costs ->
      let cost1 = full_cost pc1 in
      compare pc1 cost1 pc2 0
    | [pc1 ; pc2] ->
      let cost1 = full_cost pc1 in
      let cost2 = full_cost pc2 in
      compare pc1 cost1 pc2 cost2
    | _ -> assert false (* should be impossible: only 0, 1 or 2 following pcs *)
  and full_cost pc =
    let (cost, next_pcs) = treat pc in
    cost + (aux next_pcs) in
  init_cost + (aux next_pcs)


let traverse_code mem p =
  let rec aux pc code =
    let _,newpc,_ = ASMInterpret.fetch mem pc in
    match code with
      | [] -> CostLabel.Map.empty
      | _::tl when BitVectors.WordMap.mem pc p.ASM.cost_labels ->
        let lbl = BitVectors.WordMap.find pc p.ASM.cost_labels in
        let cost = block_cost mem p.ASM.cost_labels pc in
        let costs_mapping = aux newpc tl in
        CostLabel.Map.add lbl cost costs_mapping
      | _::tl -> aux newpc tl
  in
  aux (BitVectors.zero `Sixteen) p.ASM.code


let first_cost_label mem costs =
  let rec aux oldpc =
    try (BitVectors.WordMap.find oldpc costs, 0)
    with
      | Not_found ->
        let inst,pc,inst_cost = ASMInterpret.fetch mem oldpc in
        match inst_nature oldpc inst with
          | Direct_fun_call pc ->
            let (lbl, cost) = aux pc in
            (lbl, inst_cost + cost)
          | Return
          | Goto _
          | Branch _ ->
            assert false (* no such instructions before calling main *)
          | Other ->
            let (lbl, cost) = aux pc in
            (lbl, inst_cost + cost)
  in
  aux (BitVectors.zero `Sixteen)


let initialize_cost mem costs costs_mapping =
  let (lbl, cost) = first_cost_label mem costs in
  let old_cost =
    if CostLabel.Map.mem lbl costs_mapping then
      CostLabel.Map.find lbl costs_mapping
    else 0 in
  let new_cost = old_cost + cost in
  CostLabel.Map.add lbl new_cost costs_mapping


let compute p =
  let mem = ASMInterpret.load_code_memory p.ASM.code in
  let costs_mapping = traverse_code mem p in
  if p.ASM.has_main then initialize_cost mem p.ASM.cost_labels costs_mapping
  else costs_mapping