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

Last change on this file since 631 was 631, checked in by ayache, 10 years ago

Some bugs fixed in D2.2.

File size: 4.5 KB
Line 
1
2let error_prefix = "ASMCosts"
3let warning s = prerr_endline (error_prefix ^ s)
4
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) ->
14    Direct_fun_call (Physical.addr16_of_addr11 pc addr11)
15  | `LJMP (`ADDR16 addr16) -> Goto addr16
16  | `AJMP (`ADDR11 addr11) -> Goto (Physical.addr16_of_addr11 pc addr11)
17  | `SJMP (`REL addr) ->
18      let _, addr = BitVectors.half_add pc (BitVectors.sign_extension addr) in
19       Goto addr
20  | `JMP idptr -> Other (* Indirect jump; precondition: every possible
21                           destination should start with its own label *)
22  | `JC addr
23  | `JNC addr
24  | `JB (_,addr)
25  | `JNB (_,addr)
26  | `JBC (_,addr)
27  | `JZ addr
28  | `JNZ addr
29  | `CJNE (_,addr)
30  | `DJNZ (_,addr) ->
31      let `REL addr = addr in
32      let _, addr = BitVectors.half_add pc (BitVectors.sign_extension addr) in
33       Branch addr
34  | `RET | `RETI -> Return
35  | _ -> Other
36
37
38let treat mem costs pc =
39  let (inst, next_pc, inst_cost) = ASMInterpret.fetch mem pc in
40(*
41  (* <DEBUG> *)
42  Printf.printf "%s%s: %s\n%!"
43    (if BitVectors.WordMap.mem pc costs then
44        BitVectors.WordMap.find pc costs ^ ": "
45     else "")
46    (BitVectors.string_of_vect pc)
47    (Pretty.pp_instruction inst) ;
48  (* </DEBUG> *)
49*)
50  let next_pcs = match inst_nature pc inst with
51    | Return -> []
52    | Goto pc -> [pc]
53    | Branch pc2 ->
54      [next_pc ; pc2]
55    | Direct_fun_call _ | Other -> [next_pc] in
56  (inst_cost, next_pcs)
57
58let compare pc1 cost1 pc2 cost2 =
59  if cost1 <> cost2 then
60    warning
61      (Printf.sprintf
62         "Warning: branching to %s has cost %d, branching to %s has cost %d"
63         "*fixme*" (* pc1 *) cost1 "*fixme*" (* pc2 *) cost2) ;
64  max cost1 cost2
65
66let block_cost mem costs pc =
67  let treat = treat mem costs in
68  let (init_cost, next_pcs) = treat pc in
69  let rec aux = function
70    | [] -> 0
71    | [pc] when BitVectors.WordMap.mem pc costs ->0
72    | [pc] -> full_cost pc
73    | [pc1 ; pc2] when BitVectors.WordMap.mem pc1 costs &&
74                       BitVectors.WordMap.mem pc2 costs -> 0
75    | [pc1 ; pc2] when BitVectors.WordMap.mem pc1 costs ->
76      let cost2 = full_cost pc2 in
77      compare pc1 0 pc2 cost2
78    | [pc1 ; pc2] when BitVectors.WordMap.mem pc2 costs ->
79      let cost1 = full_cost pc1 in
80      compare pc1 cost1 pc2 0
81    | [pc1 ; pc2] ->
82      let cost1 = full_cost pc1 in
83      let cost2 = full_cost pc2 in
84      compare pc1 cost1 pc2 cost2
85    | _ -> assert false (* should be impossible: only 0, 1 or 2 following pcs *)
86  and full_cost pc =
87    let (cost, next_pcs) = treat pc in
88    cost + (aux next_pcs) in
89  init_cost + (aux next_pcs)
90
91
92let traverse_code mem p =
93  let rec aux pc code =
94    let inst,newpc,_ = ASMInterpret.fetch mem pc in
95(*
96    (* <DEBUG> *)
97    Printf.printf "Traversing %s: %s\n%!"
98      (BitVectors.string_of_vect pc) (Pretty.pp_instruction inst) ;
99    (* </DEBUG> *)
100*)
101    match code with
102      | [] -> CostLabel.Map.empty
103      | _::tl when BitVectors.WordMap.mem pc p.ASM.cost_labels ->
104        let lbl = BitVectors.WordMap.find pc p.ASM.cost_labels in
105        let cost = block_cost mem p.ASM.cost_labels pc in
106        let costs_mapping = aux newpc tl in
107        CostLabel.Map.add lbl cost costs_mapping
108      | _::tl -> aux newpc tl
109  in
110  aux (BitVectors.zero `Sixteen) p.ASM.code
111
112
113let first_cost_label mem costs =
114  let rec aux oldpc =
115    try (BitVectors.WordMap.find oldpc costs, 0)
116    with
117      | Not_found ->
118        let inst,pc,inst_cost = ASMInterpret.fetch mem oldpc in
119        match inst_nature oldpc inst with
120          | Direct_fun_call pc ->
121            let (lbl, cost) = aux pc in
122            (lbl, inst_cost + cost)
123          | Return
124          | Goto _
125          | Branch _ ->
126            assert false (* no such instructions before calling main *)
127          | Other ->
128            let (lbl, cost) = aux pc in
129            (lbl, inst_cost + cost)
130  in
131  aux (BitVectors.zero `Sixteen)
132
133
134let initialize_cost mem costs costs_mapping =
135  let (lbl, cost) = first_cost_label mem costs in
136  let old_cost =
137    if CostLabel.Map.mem lbl costs_mapping then
138      CostLabel.Map.find lbl costs_mapping
139    else 0 in
140  let new_cost = old_cost + cost in
141  CostLabel.Map.add lbl new_cost costs_mapping
142
143
144let compute p =
145(*
146  (* <DEBUG> *)
147  Printf.printf "%s\n\n%!" (Pretty.print_program p) ;
148  (* </DEBUG> *)
149*)
150  let mem = ASMInterpret.load_code_memory p.ASM.code in
151  let costs_mapping = traverse_code mem p in
152  if p.ASM.has_main then initialize_cost mem p.ASM.cost_labels costs_mapping
153  else costs_mapping
Note: See TracBrowser for help on using the repository browser.