source: Deliverables/D2.2/8051-indexed-labels-branch/src/common/costLabel.ml @ 1357

Last change on this file since 1357 was 1357, checked in by tranquil, 10 years ago
  • changed implementation of constant indexings with extensible arrays
  • work on ASM completed
  • next: optimizations!
File size: 4.3 KB
Line 
1module Atom =
2        struct
3                include StringTools
4        end
5
6module StringMap = Map.Make(String)
7
8(** Simple expressions are for now affine maps of the form a*_+b *)
9type sexpr =
10    | Sexpr of int*int
11
12let sexpr_id = Sexpr(1, 0)
13
14let const_sexpr n = Sexpr(0, n)
15
16type index = int
17
18let make_id prefix depth = prefix ^ string_of_int depth
19
20type indexing = sexpr list
21
22type const_indexing = int ExtArray.t
23
24let const_ind_iter = ExtArray.iter
25
26let curr_const_ind = function
27    | hd :: _ -> hd
28    | _ -> invalid_arg "curr_const_ind applied to non-empty list"
29
30let init_const_indexing () = ExtArray.make ~buff:1 0 0 
31
32let enter_loop_single indexing n = ExtArray.set indexing n 0
33
34let continue_loop_single indexing n =
35        try
36                ExtArray.set indexing n (ExtArray.get indexing n + 1)
37        with | _ ->
38          invalid_arg "uninitialized loop index" 
39
40let curr_ind = function
41    | hd :: _ -> hd
42    | _ -> invalid_arg "non-empty indexing stack"
43
44let enter_loop inds = enter_loop_single (curr_ind inds)
45
46let continue_loop inds = continue_loop_single (curr_ind inds)
47
48let enter_loop_opt indexing = Option.iter (enter_loop indexing) 
49
50let continue_loop_opt indexing = Option.iter (continue_loop indexing)
51
52let new_const_ind inds = init_const_indexing () :: inds
53
54let forget_const_ind = function
55        | _ :: inds -> inds
56        | _ -> invalid_arg "non-empty indexing stack"
57
58let sexpr_of i l = 
59    try
60        List.nth l i
61    with
62                        | Failure _
63      | Invalid_argument _ -> invalid_arg "costLabel.sexpr_of"
64
65let empty_indexing = []
66
67let add_id_indexing ind = sexpr_id :: ind
68
69(* a*_+b is composed with c*_+d by substitution: *)
70(* namely a*_+b ° c*_+d = c*(a*_+b)+d              *)
71let compose_sexpr (Sexpr(a, b)) (Sexpr(c, d)) =
72    Sexpr (a * c, b * c + d)
73               
74let ev_sexpr i (Sexpr(a, b)) = a*i+b
75
76(* i|-->e ° I *)
77let rec compose_index i s l = match i, l with
78        | 0, s' :: l' -> compose_sexpr s s' :: l'
79        | x, s' :: l' -> compose_index (i-1) s l'
80        | _ -> l
81
82
83(* I°J applies every mapping in I to every mapping in J *)
84let rec compose_indexing m n = match m, n with
85        | s1 :: l1, s2 :: l2 -> compose_sexpr s1 s2 :: compose_indexing l1 l2
86        | _ -> n 
87
88let rec compose_const_indexing_i i c = function
89        | [] -> []
90        | s :: l ->
91                try
92                  const_sexpr (ev_sexpr (ExtArray.get c i) s) ::
93                         compose_const_indexing_i (i+1) c l
94                with
95                        | Invalid_argument _ ->
96                                invalid_arg "constant indexing not enough to be applied" 
97
98module IndexingSet = Set.Make(struct
99    type t = indexing
100                let compare = compare
101        end)
102
103type t = {
104    name : Atom.t;
105    i : indexing
106}
107
108let ev_indexing c lbl =
109    {lbl with i = compose_const_indexing_i 0 c lbl.i}
110
111
112(* if [pretty] is false then a name suitable for labels is given*)
113(* ('P' replaces '+') *)
114let string_of_sexpr pretty prefix i (Sexpr(a, b)) =
115        let plus = if pretty then "+" else "P" in
116        let id = prefix ^ string_of_int i in
117  let a_id_s = if a = 1 then id else string_of_int a ^ id in
118        let b_s = string_of_int b in
119        if a = 0 then b_s else
120        if b = 0 then a_id_s else a_id_s ^ plus ^ b_s
121       
122(* examples:*)
123(* [pretty] true:  (0,i1+1,2i2+2)*)
124(* [pretty] false: _0_i1P1_2i2P2 *)
125let rec string_of_indexing_tl pretty prefix i = function
126        | [] -> if pretty then ")" else ""
127        | hd :: tl ->
128                let sep = if pretty then "," else "_" in
129                let str = string_of_sexpr pretty prefix i hd in
130                sep ^ str ^ string_of_indexing_tl pretty prefix (i+1) tl
131
132let string_of_indexing pretty prefix = function
133        | [] -> ""
134        | hd :: tl ->
135                let start = if pretty then "(" else "_" in
136    let str = string_of_sexpr pretty prefix 0 hd in
137                start ^ str ^ string_of_indexing_tl pretty prefix 1 tl
138               
139let string_of_cost_label ?(pretty = false) lab =
140        lab.name ^ string_of_indexing pretty "i" lab.i
141
142let fresh l universe =
143        {name = Atom.Gen.fresh universe; i = l} 
144
145(* TODO: urgh. Necessary? *)
146type aux_t = t
147                                                       
148(** labels are endowed with a lexicographical ordering *)
149module T : Map.OrderedType with type t = aux_t =
150    struct
151        type t = aux_t
152        let compare = compare (* uses the built-in lexicographical comparison *) 
153    end
154
155module Map = Map.Make(T)   
156module Set = Set.Make(T) 
157(** [constant_map d x] produces a finite map which associates
158    [x] to every element of the set [d]. *)
159
160let indexings_of atom s =
161        let f k accu = if k.name = atom then IndexingSet.add k.i accu else accu in
162        Set.fold f s IndexingSet.empty
163
164let constant_map d x = 
165  Set.fold (fun k accu -> Map.add k x accu) d Map.empty
166       
167        (**  **)
Note: See TracBrowser for help on using the repository browser.