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

Last change on this file since 619 was 619, checked in by ayache, 9 years ago

Update of D2.2 from Paris.

File size: 3.4 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 -> Return
35  | _ -> Other
36
37
38(* TODO: do not consider the very first instruction as ending the block since it
39   contains the cost label whose cost we are trying to compute! *)
40let block_cost mem costs =
41  let rec aux oldpc =
42    if BitVectors.WordMap.mem oldpc costs then 0
43    else
44      let inst,pc,inst_cost = ASMInterpret.fetch mem oldpc in
45      let cost = match inst_nature oldpc inst with
46        | Return -> 0
47        | Goto pc -> aux pc
48        | Branch pc2 ->
49          let pc1 =
50            snd (BitVectors.half_add pc (BitVectors.vect_of_int 1 `Sixteen)) in
51          let cost1 = aux pc1 in
52          let cost2 = aux pc2 in
53          if cost1 <> cost2 then
54            warning
55              (Printf.sprintf
56                 "Warning: branching to %s has cost %d; continuing has cost %d.\n"
57                 "*fixme*"(*pc2*) cost2 cost1) ;
58        max cost1 cost2
59      | _ -> aux pc
60    in
61     cost + inst_cost
62  in
63  aux
64
65
66let traverse_code mem p =
67  let rec aux pc code =
68    let _,newpc,_ = ASMInterpret.fetch mem pc in
69    match code with
70      | [] -> CostLabel.Map.empty
71      | _::tl when BitVectors.WordMap.mem pc p.ASM.cost_labels ->
72        let lbl = BitVectors.WordMap.find pc p.ASM.cost_labels in
73        let cost = block_cost mem p.ASM.cost_labels pc in
74        let costs_mapping = aux newpc tl in
75        CostLabel.Map.add lbl cost costs_mapping
76      | _::tl -> aux newpc tl
77  in
78  aux (BitVectors.zero `Sixteen) p.ASM.code
79
80
81let first_cost_label mem costs =
82  let rec aux oldpc =
83    try (BitVectors.WordMap.find oldpc costs, 0)
84    with
85      | Not_found ->
86        let inst,pc,inst_cost = ASMInterpret.fetch mem oldpc in
87        match inst_nature oldpc inst with
88          | Direct_fun_call pc ->
89            let (lbl, cost) = aux pc in
90            (lbl, inst_cost + cost)
91          | Return
92          | Goto _
93          | Branch _ ->
94            assert false (* no such instructions before calling main *)
95          | Other ->
96            let (lbl, cost) = aux pc in
97            (lbl, inst_cost + cost)
98  in
99  aux (BitVectors.zero `Sixteen)
100
101
102let initialize_cost mem costs costs_mapping =
103  let (lbl, cost) = first_cost_label mem costs in
104  let old_cost =
105    assert (CostLabel.Map.mem lbl costs_mapping) ;
106    CostLabel.Map.find lbl costs_mapping in
107  let new_cost = old_cost + cost in
108  CostLabel.Map.add lbl new_cost costs_mapping
109
110
111let compute p =
112  let mem = ASMInterpret.load_code_memory p.ASM.code in
113  let costs_mapping = traverse_code mem p in
114  if p.ASM.has_main then initialize_cost mem p.ASM.cost_labels costs_mapping
115  else costs_mapping
Note: See TracBrowser for help on using the repository browser.