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

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