source: Deliverables/D4.1/ASMCosts.ml

Last change on this file was 454, checked in by sacerdot, 9 years ago

CSC + Nicolas + Dominic:

1) back-porting of changes by Nicolas from the compiler
2) new file ASMCosts to compute the cost of labels
3) several changes here and there to implement 2)

File size: 3.3 KB
Line 
1module StringMap = Map.Make(String)
2
3let error_prefix = "ASMCosts"
4let warning s = prerr_endline (error_prefix ^ s)
5
6type instruction_nature =
7  | Goto of BitVectors.word | Branch of BitVectors.word
8  | Direct_fun_call of BitVectors.word | Return
9  | Other
10
11let 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
37let 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
63let 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
81let 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
98let 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
108let 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
Note: See TracBrowser for help on using the repository browser.