lustrec / src / utils.ml @ 17abbe95
History | View | Annotate | Download (8.24 KB)
1 |
(* ---------------------------------------------------------------------------- |
---|---|
2 |
* SchedMCore - A MultiCore Scheduling Framework |
3 |
* Copyright (C) 2009-2011, ONERA, Toulouse, FRANCE - LIFL, Lille, FRANCE |
4 |
* |
5 |
* This file is part of Prelude |
6 |
* |
7 |
* Prelude is free software; you can redistribute it and/or |
8 |
* modify it under the terms of the GNU Lesser General Public License |
9 |
* as published by the Free Software Foundation ; either version 2 of |
10 |
* the License, or (at your option) any later version. |
11 |
* |
12 |
* Prelude is distributed in the hope that it will be useful, but |
13 |
* WITHOUT ANY WARRANTY ; without even the implied warranty of |
14 |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
15 |
* Lesser General Public License for more details. |
16 |
* |
17 |
* You should have received a copy of the GNU Lesser General Public |
18 |
* License along with this program ; if not, write to the Free Software |
19 |
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 |
20 |
* USA |
21 |
*---------------------------------------------------------------------------- *) |
22 |
open Graph |
23 |
|
24 |
type rat = int*int |
25 |
type ident = string |
26 |
type tag = int |
27 |
type longident = (string * tag) list |
28 |
|
29 |
(** General utility functions. *) |
30 |
let create_hashtable size init = |
31 |
let tbl = Hashtbl.create size in |
32 |
List.iter (fun (key, data) -> Hashtbl.add tbl key data) init; |
33 |
tbl |
34 |
|
35 |
module IdentModule = |
36 |
struct (* Node module *) |
37 |
type t = ident |
38 |
let compare = compare |
39 |
let hash n = Hashtbl.hash n |
40 |
let equal n1 n2 = n1 = n2 |
41 |
end |
42 |
|
43 |
module IMap = Map.Make(IdentModule) |
44 |
|
45 |
module ISet = Set.Make(IdentModule) |
46 |
|
47 |
let option_map f o = |
48 |
match o with |
49 |
| None -> None |
50 |
| Some e -> Some (f e) |
51 |
|
52 |
let position pred l = |
53 |
let rec pos p l = |
54 |
match l with |
55 |
| [] -> assert false |
56 |
| t::q -> if pred t then p else pos (p+1) q |
57 |
in pos 0 l |
58 |
|
59 |
let rec duplicate x n = |
60 |
if n < 0 then [] else x :: duplicate x (n - 1) |
61 |
|
62 |
let enumerate n = |
63 |
let rec aux i = |
64 |
if i >= n then [] else i :: aux (i+1) |
65 |
in aux 0 |
66 |
|
67 |
let rec repeat n f x = |
68 |
if n <= 0 then x else repeat (n-1) f (f x) |
69 |
|
70 |
let rec transpose_list ll = |
71 |
match ll with |
72 |
| [] -> [] |
73 |
| [l] -> List.map (fun el -> [el]) l |
74 |
| l::q -> List.map2 (fun el eq -> el::eq) l (transpose_list q) |
75 |
|
76 |
let rec filter_upto p n l = |
77 |
if n = 0 then [] else |
78 |
match l with |
79 |
| [] -> [] |
80 |
| t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q |
81 |
|
82 |
(* Warning: bad complexity *) |
83 |
let list_of_imap imap = |
84 |
IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[]) |
85 |
|
86 |
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *) |
87 |
let rec gcd a b = |
88 |
if b = 0 then a |
89 |
else gcd b (a mod b) |
90 |
|
91 |
(** [lcm a b] returns the least common multiple of [a] and [b]. *) |
92 |
let lcm a b = |
93 |
if a = 0 && b = 0 then |
94 |
0 |
95 |
else a*b/(gcd a b) |
96 |
|
97 |
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and |
98 |
[(a',b')] *) |
99 |
let sum_rat (a,b) (a',b') = |
100 |
if a = 0 && b = 0 then |
101 |
(a',b') |
102 |
else if a'=0 && b'=0 then |
103 |
(a,b) |
104 |
else |
105 |
let lcm_bb' = lcm b b' in |
106 |
(a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb') |
107 |
|
108 |
let simplify_rat (a,b) = |
109 |
let gcd = gcd a b in |
110 |
if (gcd =0) then |
111 |
(a,b) |
112 |
else (a/gcd,b/gcd) |
113 |
|
114 |
let max_rat (a,b) (a',b') = |
115 |
let ratio_ab = (float_of_int a)/.(float_of_int b) in |
116 |
let ratio_ab' = (float_of_int a')/.(float_of_int b') in |
117 |
if ratio_ab > ratio_ab' then |
118 |
(a,b) |
119 |
else |
120 |
(a',b') |
121 |
|
122 |
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The |
123 |
result contains no duplicates. *) |
124 |
let list_union l1 l2 = |
125 |
let rec aux l acc = |
126 |
match l with |
127 |
| [] -> acc |
128 |
| x::tl -> |
129 |
if List.mem x acc then |
130 |
aux tl acc |
131 |
else |
132 |
aux tl (x::acc) |
133 |
in |
134 |
let l1' = aux l1 [] in |
135 |
aux l2 l1' |
136 |
|
137 |
(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the |
138 |
intersection is not empty, it replaces the former binding *) |
139 |
let hashtbl_add h1 h2 = |
140 |
Hashtbl.iter (fun key value -> Hashtbl.replace h1 key value) h2 |
141 |
|
142 |
let hashtbl_iterlast h f1 f2 = |
143 |
let l = Hashtbl.length h in |
144 |
ignore( |
145 |
Hashtbl.fold |
146 |
(fun k v cpt -> |
147 |
if cpt = l then |
148 |
begin f2 k v; cpt+1 end |
149 |
else |
150 |
begin f1 k v; cpt+1 end) |
151 |
h 1) |
152 |
|
153 |
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type |
154 |
variables are identified by integers. *) |
155 |
let tnames = ref ([]: (int * string) list) |
156 |
let tname_counter = ref 0 |
157 |
(* Same for carriers *) |
158 |
let crnames = ref ([]: (int * string) list) |
159 |
let crname_counter = ref 0 |
160 |
(* Same for dimension *) |
161 |
let dnames = ref ([]: (int * string) list) |
162 |
let dname_counter = ref 0 |
163 |
(* Same for delays *) |
164 |
let inames = ref ([]: (int * string) list) |
165 |
let iname_counter = ref 0 |
166 |
|
167 |
let reset_names () = |
168 |
tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0 |
169 |
|
170 |
(* From OCaml compiler *) |
171 |
let new_tname () = |
172 |
let tname = |
173 |
if !tname_counter < 26 |
174 |
then String.make 1 (Char.chr(97 + !tname_counter)) |
175 |
else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^ |
176 |
string_of_int(!tname_counter / 26) in |
177 |
incr tname_counter; |
178 |
tname |
179 |
|
180 |
let new_crname () = |
181 |
incr crname_counter; |
182 |
Format.sprintf "c%i" (!crname_counter-1) |
183 |
|
184 |
let name_of_type id = |
185 |
try List.assoc id !tnames with Not_found -> |
186 |
let name = new_tname () in |
187 |
tnames := (id, name) :: !tnames; |
188 |
name |
189 |
|
190 |
let name_of_carrier id = |
191 |
let pp_id = |
192 |
try List.assoc id !crnames with Not_found -> |
193 |
let name = new_crname () in |
194 |
crnames := (id,name) :: !crnames; |
195 |
name |
196 |
in |
197 |
pp_id |
198 |
|
199 |
let new_dname () = |
200 |
incr dname_counter; |
201 |
Format.sprintf "d%i" (!dname_counter-1) |
202 |
|
203 |
let name_of_dimension id = |
204 |
try List.assoc id !dnames with Not_found -> |
205 |
let name = new_dname () in |
206 |
dnames := (id, name) :: !dnames; |
207 |
name |
208 |
|
209 |
let new_iname () = |
210 |
incr iname_counter; |
211 |
Format.sprintf "t%i" (!iname_counter-1) |
212 |
|
213 |
let name_of_delay id = |
214 |
try List.assoc id !inames with Not_found -> |
215 |
let name = new_iname () in |
216 |
inames := (id, name) :: !inames; |
217 |
name |
218 |
|
219 |
open Format |
220 |
|
221 |
let print_rat fmt (a,b) = |
222 |
if b=1 then |
223 |
Format.fprintf fmt "%i" a |
224 |
else |
225 |
if b < 0 then |
226 |
Format.fprintf fmt "%i/%i" (-a) (-b) |
227 |
else |
228 |
Format.fprintf fmt "%i/%i" a b |
229 |
|
230 |
|
231 |
(* Generic pretty printing *) |
232 |
|
233 |
let pp_final_char_if_non_empty c l = |
234 |
(fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c) |
235 |
|
236 |
let pp_newline_if_non_empty l = |
237 |
(fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,") |
238 |
|
239 |
let rec fprintf_list ~sep:sep f fmt = function |
240 |
| [] -> () |
241 |
| [e] -> f fmt e |
242 |
| x::r -> Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r |
243 |
|
244 |
let pp_list l pp_fun beg_str end_str sep_str = |
245 |
if (beg_str="\n") then |
246 |
print_newline () |
247 |
else |
248 |
print_string beg_str; |
249 |
let rec pp_l l = |
250 |
match l with |
251 |
| [] -> () |
252 |
| [hd] -> |
253 |
pp_fun hd |
254 |
| hd::tl -> |
255 |
pp_fun hd; |
256 |
if (sep_str="\n") then |
257 |
print_newline () |
258 |
else |
259 |
print_string sep_str; |
260 |
pp_l tl |
261 |
in |
262 |
pp_l l; |
263 |
if (end_str="\n") then |
264 |
print_newline () |
265 |
else |
266 |
print_string end_str |
267 |
|
268 |
let pp_array a pp_fun beg_str end_str sep_str = |
269 |
if (beg_str="\n") then |
270 |
print_newline () |
271 |
else |
272 |
print_string beg_str; |
273 |
let n = Array.length a in |
274 |
if n > 0 then |
275 |
begin |
276 |
Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1)); |
277 |
pp_fun a.(n-1) |
278 |
end; |
279 |
if (end_str="\n") then |
280 |
print_newline () |
281 |
else |
282 |
print_string end_str |
283 |
|
284 |
let pp_hashtbl t pp_fun beg_str end_str sep_str = |
285 |
if (beg_str="\n") then |
286 |
print_newline () |
287 |
else |
288 |
print_string beg_str; |
289 |
let pp_fun1 k v = |
290 |
pp_fun k v; |
291 |
if (sep_str="\n") then |
292 |
print_newline () |
293 |
else |
294 |
print_string sep_str |
295 |
in |
296 |
hashtbl_iterlast t pp_fun1 pp_fun; |
297 |
if (end_str="\n") then |
298 |
print_newline () |
299 |
else |
300 |
print_string end_str |
301 |
|
302 |
let pp_longident lid = |
303 |
let pp_fun (nid, tag) = |
304 |
print_string nid; |
305 |
print_string "("; |
306 |
print_int tag; |
307 |
print_string ")" |
308 |
in |
309 |
pp_list lid pp_fun "" "." "." |
310 |
|
311 |
|
312 |
(* Used for uid in variables *) |
313 |
|
314 |
let var_id_cpt = ref 0 |
315 |
let get_new_id () = incr var_id_cpt;!var_id_cpt |
316 |
|
317 |
|
318 |
let track_exception () = |
319 |
if !Options.track_exceptions |
320 |
then (Printexc.print_backtrace stdout; flush stdout) |
321 |
else () |
322 |
|
323 |
|
324 |
(* for lexing purposes *) |
325 |
|
326 |
(* Update line number for location info *) |
327 |
let incr_line lexbuf = |
328 |
let pos = lexbuf.Lexing.lex_curr_p in |
329 |
lexbuf.Lexing.lex_curr_p <- { pos with |
330 |
Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; |
331 |
Lexing.pos_bol = pos.Lexing.pos_cnum; |
332 |
} |
333 |
|
334 |
|
335 |
let last_tag = ref (-1) |
336 |
let new_tag () = |
337 |
incr last_tag; !last_tag |
338 |
|
339 |
(* Local Variables: *) |
340 |
(* compile-command:"make -C .." *) |
341 |
(* End: *) |