source: Deliverables/D4.1/ASMCosts.ml @ 1813

module StringMap = Map.Make(String)

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 block_cost mem costs =
  let rec aux oldpc =
   if ASMInterpret.WordMap.mem oldpc costs then 0
   else
    let inst,pc,inst_cost = ASMInterpret.fetch mem oldpc in
    let cost = match inst_nature oldpc inst with
     | Return -> 0
     | Goto pc -> aux pc
     | Branch pc2 ->
        let pc1 = snd (BitVectors.half_add pc (BitVectors.vect_of_int 1 `Sixteen)) in
        let cost1 = aux pc1 in
        let cost2 = aux pc2 in
        let cost = max cost1 cost2 in
        if cost1 <> cost2 then
          warning
            (Printf.sprintf
               "Warning: branching to %s has cost %d; continuing has cost %d.\n"
            "*fixme*"(*pc2*) cost2 cost1) ;
        cost
      | _ -> aux pc
    in
     cost + inst_cost
  in
  aux


let traverse_code mem (l,costs,_) =
  let rec aux pc =
   function
      [] -> StringMap.empty
    | _::tl ->
      let _,newpc,_ = ASMInterpret.fetch mem pc in
       (try
         let lbl = ASMInterpret.WordMap.find pc costs in
         let cost = block_cost mem costs pc in
         let costs_mapping = aux newpc tl in
          StringMap.add lbl cost costs_mapping
        with
         Not_found ->
           aux pc tl)
  in
  aux (BitVectors.zero `Sixteen) l


let first_cost_label mem costs =
  let rec aux oldpc =
   try
    ASMInterpret.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(* Precondition: no function call before 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 StringMap.mem lbl costs_mapping then
      StringMap.find lbl costs_mapping
    else assert false in
  let new_cost = old_cost + cost in
  StringMap.add lbl new_cost costs_mapping


let compute (l,costs,has_main as p) =
  let mem = ASMInterpret.load_code_memory l in
  let costs_mapping = traverse_code mem p in
  if has_main then initialize_cost mem costs costs_mapping
  else costs_mapping