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

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