lustrec / src / utils.ml @ 22fe1c93
History  View  Annotate  Download (8.24 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 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 (n1) 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 (n1) 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 prettyprinting. 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_counter1) 
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_counter1) 
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_counter1) 
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 (n1)); 
277 
pp_fun a.(n1) 
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 
(* compilecommand:"make C .." *) 
341 
(* End: *) 