Changeset 634

Timestamp:

03/04/11 17:59:34 (2 years ago)

Author:

ayache

Message:

Bug fix in ASMCosts in D2.2.

Files:

• Deliverables/D2.2/8051/src/ASM/ASMCosts.ml (modified) (4 diffs)

Deliverables/D2.2/8051/src/ASM/ASMCosts.ml

@@ -9 +9 @@
   | 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 inst_infos mem pc =
+  let (inst, next_pc, inst_cost) = ASMInterpret.fetch mem pc in
+  let (nature, next_pcs) = match inst with
+    | `LCALL (`ADDR16 addr16) -> (Direct_fun_call addr16, [next_pc])
+    | `ACALL (`ADDR11 addr11) ->
+      (Direct_fun_call (Physical.addr16_of_addr11 pc addr11), [next_pc])
+    | `LJMP (`ADDR16 addr16) -> (Goto addr16, [addr16])
+    | `AJMP (`ADDR11 addr11) ->
+      let addr = Physical.addr16_of_addr11 pc addr11 in
+      (Goto addr, [addr])
+    | `SJMP (`REL addr) ->
+      let _, addr =
+        BitVectors.half_add next_pc (BitVectors.sign_extension addr) in
+      (Goto addr, [addr])
+    | `JMP idptr ->
+      (Other, [next_pc]) (* 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 | `RETI -> Return
-  | _ -> Other
+      let _, addr =
+        BitVectors.half_add next_pc (BitVectors.sign_extension addr) in
+      (Branch addr, [next_pc ; addr])
+    | `RET | `RETI -> (Return, [])
+    | _ -> (Other, [next_pc]) in
+  (nature, next_pc, next_pcs, inst_cost)
 
-
-let treat mem costs pc =
-  let (inst, next_pc, inst_cost) = ASMInterpret.fetch mem pc in
-(*
-  (* <DEBUG> *)
-  Printf.printf "%s%s: %s\n%!"
-    (if BitVectors.WordMap.mem pc costs then
-        BitVectors.WordMap.find pc costs ^ ": "
-     else "")
-    (BitVectors.string_of_vect pc)
-    (Pretty.pp_instruction inst) ;
-  (* </DEBUG> *)
-*)
-  let next_pcs = match inst_nature pc inst with
-    | Return -> []
-    | Goto pc -> [pc]
-    | Branch pc2 ->
-      [next_pc ; pc2]
-    | Direct_fun_call _ | Other -> [next_pc] in
-  (inst_cost, next_pcs)
 
 let compare pc1 cost1 pc2 cost2 =
@@ -64 +52 @@
   max cost1 cost2
 
-let block_cost mem costs pc =
-  let treat = treat mem costs 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
-  full_cost pc
+let rec block_costl mem costs = function
+  | [] -> 0
+  | [pc] when BitVectors.WordMap.mem pc costs -> 0
+  | [pc] ->
+    let (_, _, next_pcs, cost) = inst_infos mem pc in
+    cost + (block_costl mem costs next_pcs)
+  | pc1 :: pc2 :: _ ->
+    let cost1 = block_costl mem costs [pc1] in
+    let cost2 = block_costl mem costs [pc2] in
+    compare pc1 cost1 pc2 cost2
+
+let block_cost mem costs pc = block_costl mem costs [pc]
 
 
 let traverse_code mem p =
   let rec aux pc code =
-    let inst,newpc,_ = ASMInterpret.fetch mem pc in
-(*
-    (* <DEBUG> *)
-    Printf.printf "Traversing %s: %s\n%!"
-      (BitVectors.string_of_vect pc) (Pretty.pp_instruction inst) ;
-    (* </DEBUG> *)
-*)
+    let (_, newpc, _, _) = inst_infos 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 cost = block_cost mem p.ASM.cost_labels newpc in
         let costs_mapping = aux newpc tl in
         CostLabel.Map.add lbl cost costs_mapping
@@ -115 +86 @@
       (BitVectors.WordMap.find oldpc costs, 0)
     else
-      let (inst, pc, inst_cost) = ASMInterpret.fetch mem oldpc in
-      match inst_nature oldpc inst with
+      let (nature, pc, _, inst_cost) = inst_infos mem oldpc in
+      match nature with
         | Direct_fun_call pc ->
           let (lbl, cost) = aux pc in
@@ -142 +113 @@
 
 let compute p =
-(*
-  (* <DEBUG> *)
-  Printf.printf "%s\n\n%!" (Pretty.print_program p) ;
-  (* </DEBUG> *)
-*)
   let mem = ASMInterpret.load_code_memory p.ASM.code in
   let costs_mapping = traverse_code mem p in