lustrec / src / utils.ml @ 1837ce98
History  View  Annotate  Download (9.07 KB)
1 
(*  

2 
* SchedMCore  A MultiCore Scheduling Framework 
3 
* Copyright (C) 20092011, 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 021111307 
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 
exception TransposeError of int*int 
30  
31 
(** General utility functions. *) 
32 
let create_hashtable size init = 
33 
let tbl = Hashtbl.create size in 
34 
List.iter (fun (key, data) > Hashtbl.add tbl key data) init; 
35 
tbl 
36  
37 
module IdentModule = 
38 
struct (* Node module *) 
39 
type t = ident 
40 
let compare = compare 
41 
let hash n = Hashtbl.hash n 
42 
let equal n1 n2 = n1 = n2 
43 
end 
44  
45 
module IMap = Map.Make(IdentModule) 
46  
47 
module ISet = Set.Make(IdentModule) 
48  
49 
let desome x = match x with Some x > x  None > failwith "desome" 
50  
51 
let option_map f o = 
52 
match o with 
53 
 None > None 
54 
 Some e > Some (f e) 
55  
56 
let rec remove_duplicates l = 
57 
match l with 
58 
 [] > [] 
59 
 t::q > if List.mem t q then remove_duplicates q else t :: remove_duplicates q 
60  
61 
let position pred l = 
62 
let rec pos p l = 
63 
match l with 
64 
 [] > assert false 
65 
 t::q > if pred t then p else pos (p+1) q 
66 
in pos 0 l 
67  
68 
let rec duplicate x n = 
69 
if n < 0 then [] else x :: duplicate x (n  1) 
70  
71 
let enumerate n = 
72 
let rec aux i = 
73 
if i >= n then [] else i :: aux (i+1) 
74 
in aux 0 
75  
76 
let rec repeat n f x = 
77 
if n <= 0 then x else repeat (n1) f (f x) 
78  
79 
let transpose_list ll = 
80 
let rec transpose ll = 
81 
match ll with 
82 
 [] > [] 
83 
 [l] > List.map (fun el > [el]) l 
84 
 l::q > List.map2 (fun el eq > el::eq) l (transpose q) 
85 
in match ll with 
86 
 [] > [] 
87 
 l::q > let length_l = List.length l in 
88 
List.iter (fun l' > let length_l' = List.length l' 
89 
in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q; 
90 
transpose ll 
91  
92 
let rec filter_upto p n l = 
93 
if n = 0 then [] else 
94 
match l with 
95 
 [] > [] 
96 
 t::q > if p t then t :: filter_upto p (n1) q else filter_upto p n q 
97  
98 
(* Warning: bad complexity *) 
99 
let list_of_imap imap = 
100 
IMap.fold (fun i v (il,vl) > (i::il,v::vl)) imap ([],[]) 
101  
102 
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *) 
103 
let rec gcd a b = 
104 
if b = 0 then a 
105 
else gcd b (a mod b) 
106  
107 
(** [lcm a b] returns the least common multiple of [a] and [b]. *) 
108 
let lcm a b = 
109 
if a = 0 && b = 0 then 
110 
0 
111 
else a*b/(gcd a b) 
112  
113 
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and 
114 
[(a',b')] *) 
115 
let sum_rat (a,b) (a',b') = 
116 
if a = 0 && b = 0 then 
117 
(a',b') 
118 
else if a'=0 && b'=0 then 
119 
(a,b) 
120 
else 
121 
let lcm_bb' = lcm b b' in 
122 
(a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb') 
123  
124 
let simplify_rat (a,b) = 
125 
let gcd = gcd a b in 
126 
if (gcd =0) then 
127 
(a,b) 
128 
else (a/gcd,b/gcd) 
129  
130 
let max_rat (a,b) (a',b') = 
131 
let ratio_ab = (float_of_int a)/.(float_of_int b) in 
132 
let ratio_ab' = (float_of_int a')/.(float_of_int b') in 
133 
if ratio_ab > ratio_ab' then 
134 
(a,b) 
135 
else 
136 
(a',b') 
137  
138 
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The 
139 
result contains no duplicates. *) 
140 
let list_union l1 l2 = 
141 
let rec aux l acc = 
142 
match l with 
143 
 [] > acc 
144 
 x::tl > 
145 
if List.mem x acc then 
146 
aux tl acc 
147 
else 
148 
aux tl (x::acc) 
149 
in 
150 
let l1' = aux l1 [] in 
151 
aux l2 l1' 
152  
153 
(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the 
154 
intersection is not empty, it replaces the former binding *) 
155 
let hashtbl_add h1 h2 = 
156 
Hashtbl.iter (fun key value > Hashtbl.replace h1 key value) h2 
157  
158 
let hashtbl_iterlast h f1 f2 = 
159 
let l = Hashtbl.length h in 
160 
ignore( 
161 
Hashtbl.fold 
162 
(fun k v cpt > 
163 
if cpt = l then 
164 
begin f2 k v; cpt+1 end 
165 
else 
166 
begin f1 k v; cpt+1 end) 
167 
h 1) 
168  
169 
(** Match types variables to 'a, 'b, ..., for prettyprinting. Type 
170 
variables are identified by integers. *) 
171 
let tnames = ref ([]: (int * string) list) 
172 
let tname_counter = ref 0 
173 
(* Same for carriers *) 
174 
let crnames = ref ([]: (int * string) list) 
175 
let crname_counter = ref 0 
176 
(* Same for dimension *) 
177 
let dnames = ref ([]: (int * string) list) 
178 
let dname_counter = ref 0 
179 
(* Same for delays *) 
180 
let inames = ref ([]: (int * string) list) 
181 
let iname_counter = ref 0 
182  
183 
let reset_names () = 
184 
tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0 
185  
186 
(* From OCaml compiler *) 
187 
let new_tname () = 
188 
let tname = 
189 
if !tname_counter < 26 
190 
then String.make 1 (Char.chr(97 + !tname_counter)) 
191 
else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^ 
192 
string_of_int(!tname_counter / 26) in 
193 
incr tname_counter; 
194 
tname 
195  
196 
let new_crname () = 
197 
incr crname_counter; 
198 
Format.sprintf "c%i" (!crname_counter1) 
199  
200 
let name_of_type id = 
201 
try List.assoc id !tnames with Not_found > 
202 
let name = new_tname () in 
203 
tnames := (id, name) :: !tnames; 
204 
name 
205  
206 
let name_of_carrier id = 
207 
let pp_id = 
208 
try List.assoc id !crnames with Not_found > 
209 
let name = new_crname () in 
210 
crnames := (id,name) :: !crnames; 
211 
name 
212 
in 
213 
pp_id 
214  
215 
let new_dname () = 
216 
incr dname_counter; 
217 
Format.sprintf "d%i" (!dname_counter1) 
218  
219 
let name_of_dimension id = 
220 
try List.assoc id !dnames with Not_found > 
221 
let name = new_dname () in 
222 
dnames := (id, name) :: !dnames; 
223 
name 
224  
225 
let new_iname () = 
226 
incr iname_counter; 
227 
Format.sprintf "t%i" (!iname_counter1) 
228  
229 
let name_of_delay id = 
230 
try List.assoc id !inames with Not_found > 
231 
let name = new_iname () in 
232 
inames := (id, name) :: !inames; 
233 
name 
234  
235 
open Format 
236  
237 
let print_rat fmt (a,b) = 
238 
if b=1 then 
239 
Format.fprintf fmt "%i" a 
240 
else 
241 
if b < 0 then 
242 
Format.fprintf fmt "%i/%i" (a) (b) 
243 
else 
244 
Format.fprintf fmt "%i/%i" a b 
245 

246  
247 
(* Generic pretty printing *) 
248  
249 
let pp_final_char_if_non_empty c l = 
250 
(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "%(%)" c) 
251  
252 
let pp_newline_if_non_empty l = 
253 
(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "@,") 
254  
255 
let rec fprintf_list ~sep:sep f fmt = function 
256 
 [] > () 
257 
 [e] > f fmt e 
258 
 x::r > Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r 
259  
260 
let pp_list l pp_fun beg_str end_str sep_str = 
261 
if (beg_str="\n") then 
262 
print_newline () 
263 
else 
264 
print_string beg_str; 
265 
let rec pp_l l = 
266 
match l with 
267 
 [] > () 
268 
 [hd] > 
269 
pp_fun hd 
270 
 hd::tl > 
271 
pp_fun hd; 
272 
if (sep_str="\n") then 
273 
print_newline () 
274 
else 
275 
print_string sep_str; 
276 
pp_l tl 
277 
in 
278 
pp_l l; 
279 
if (end_str="\n") then 
280 
print_newline () 
281 
else 
282 
print_string end_str 
283  
284 
let pp_array a 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 n = Array.length a in 
290 
if n > 0 then 
291 
begin 
292 
Array.iter (fun x > pp_fun x; print_string sep_str) (Array.sub a 0 (n1)); 
293 
pp_fun a.(n1) 
294 
end; 
295 
if (end_str="\n") then 
296 
print_newline () 
297 
else 
298 
print_string end_str 
299  
300 
let pp_iset fmt t = 
301 
begin 
302 
Format.fprintf fmt "{@ "; 
303 
ISet.iter (fun s > Format.fprintf fmt "%s@ " s) t; 
304 
Format.fprintf fmt "}@." 
305 
end 
306  
307 
let pp_hashtbl t pp_fun beg_str end_str sep_str = 
308 
if (beg_str="\n") then 
309 
print_newline () 
310 
else 
311 
print_string beg_str; 
312 
let pp_fun1 k v = 
313 
pp_fun k v; 
314 
if (sep_str="\n") then 
315 
print_newline () 
316 
else 
317 
print_string sep_str 
318 
in 
319 
hashtbl_iterlast t pp_fun1 pp_fun; 
320 
if (end_str="\n") then 
321 
print_newline () 
322 
else 
323 
print_string end_str 
324  
325 
let pp_longident lid = 
326 
let pp_fun (nid, tag) = 
327 
print_string nid; 
328 
print_string "("; 
329 
print_int tag; 
330 
print_string ")" 
331 
in 
332 
pp_list lid pp_fun "" "." "." 
333  
334 
let pp_date fmt tm = 
335 
Format.fprintf fmt "%i/%i/%i, %i:%i:%i" 
336 
(tm.Unix.tm_year + 1900) 
337 
tm.Unix.tm_mon 
338 
tm.Unix.tm_mday 
339 
tm.Unix.tm_hour 
340 
tm.Unix.tm_min 
341 
tm.Unix.tm_sec 
342  
343 
(* Used for uid in variables *) 
344  
345 
let var_id_cpt = ref 0 
346 
let get_new_id () = incr var_id_cpt;!var_id_cpt 
347  
348  
349 
let track_exception () = 
350 
if !Options.track_exceptions 
351 
then (Printexc.print_backtrace stdout; flush stdout) 
352 
else () 
353  
354  
355 
(* for lexing purposes *) 
356  
357 
(* Update line number for location info *) 
358 
let incr_line lexbuf = 
359 
let pos = lexbuf.Lexing.lex_curr_p in 
360 
lexbuf.Lexing.lex_curr_p < { pos with 
361 
Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; 
362 
Lexing.pos_bol = pos.Lexing.pos_cnum; 
363 
} 
364  
365  
366 
let last_tag = ref (1) 
367 
let new_tag () = 
368 
incr last_tag; !last_tag 
369  
370 
(* Local Variables: *) 
371 
(* compilecommand:"make C .." *) 
372 
(* End: *) 