lustrec / src / utils / utils.ml @ 217837e2
History  View  Annotate  Download (10.4 KB)
1 
(********************************************************************) 

2 
(* *) 
3 
(* The LustreC compiler toolset / The LustreC Development Team *) 
4 
(* Copyright 2012   ONERA  CNRS  INPT *) 
5 
(* *) 
6 
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *) 
7 
(* under the terms of the GNU Lesser General Public License *) 
8 
(* version 2.1. *) 
9 
(* *) 
10 
(********************************************************************) 
11  
12 
open Graph 
13  
14 
type rat = int*int 
15 
type ident = string 
16 
type tag = int 
17 
type longident = (string * tag) list 
18  
19 
exception TransposeError of int*int 
20  
21 
(** General utility functions. *) 
22 
let create_hashtable size init = 
23 
let tbl = Hashtbl.create size in 
24 
List.iter (fun (key, data) > Hashtbl.add tbl key data) init; 
25 
tbl 
26  
27 
module IdentModule = 
28 
struct (* Node module *) 
29 
type t = ident 
30 
let compare = compare 
31 
let hash n = Hashtbl.hash n 
32 
let equal n1 n2 = n1 = n2 
33 
end 
34  
35 
module IMap = Map.Make(IdentModule) 
36 

37 
module ISet = Set.Make(IdentModule) 
38 
module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule) 
39 
module TopologicalDepGraph = Topological.Make(IdentDepGraph) 
40 
module ComponentsDepGraph = Components.Make(IdentDepGraph) 
41 

42 
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*) 
43 
module Bfs = Traverse.Bfs (IdentDepGraph) 
44  
45 

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

247  
248 
(* Generic pretty printing *) 
249  
250 
let pp_final_char_if_non_empty c l = 
251 
(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "%(%)" c) 
252  
253 
let pp_newline_if_non_empty l = 
254 
(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "@,") 
255  
256 
let fprintf_list ?(eol:('a, formatter, unit) Pervasives.format = "") ~sep:sep f fmt l = 
257 
let rec aux fmt = function 
258 
 [] > () 
259 
 [e] > f fmt e 
260 
 x::r > Format.fprintf fmt "%a%(%)%a" f x sep aux r 
261 
in 
262 
match l with 
263 
 [] > () 
264 
 _ > ( 
265 
aux fmt l; 
266 
Format.fprintf fmt "%(%)" eol 
267 
) 
268 

269 
let pp_list l pp_fun beg_str end_str sep_str = 
270 
if (beg_str="\n") then 
271 
print_newline () 
272 
else 
273 
print_string beg_str; 
274 
let rec pp_l l = 
275 
match l with 
276 
 [] > () 
277 
 [hd] > 
278 
pp_fun hd 
279 
 hd::tl > 
280 
pp_fun hd; 
281 
if (sep_str="\n") then 
282 
print_newline () 
283 
else 
284 
print_string sep_str; 
285 
pp_l tl 
286 
in 
287 
pp_l l; 
288 
if (end_str="\n") then 
289 
print_newline () 
290 
else 
291 
print_string end_str 
292  
293 
let pp_array a pp_fun beg_str end_str sep_str = 
294 
if (beg_str="\n") then 
295 
print_newline () 
296 
else 
297 
print_string beg_str; 
298 
let n = Array.length a in 
299 
if n > 0 then 
300 
begin 
301 
Array.iter (fun x > pp_fun x; print_string sep_str) (Array.sub a 0 (n1)); 
302 
pp_fun a.(n1) 
303 
end; 
304 
if (end_str="\n") then 
305 
print_newline () 
306 
else 
307 
print_string end_str 
308  
309 
let pp_iset fmt t = 
310 
begin 
311 
Format.fprintf fmt "{@ "; 
312 
ISet.iter (fun s > Format.fprintf fmt "%s@ " s) t; 
313 
Format.fprintf fmt "}@." 
314 
end 
315  
316 
let pp_imap pp_val fmt m = 
317 
begin 
318 
Format.fprintf fmt "@[{@ "; 
319 
IMap.iter (fun key v > Format.fprintf fmt "%s > %a@ " key pp_val v) m; 
320 
Format.fprintf fmt "}@ @]" 
321 
end 
322 

323 
let pp_hashtbl t pp_fun beg_str end_str sep_str = 
324 
if (beg_str="\n") then 
325 
print_newline () 
326 
else 
327 
print_string beg_str; 
328 
let pp_fun1 k v = 
329 
pp_fun k v; 
330 
if (sep_str="\n") then 
331 
print_newline () 
332 
else 
333 
print_string sep_str 
334 
in 
335 
hashtbl_iterlast t pp_fun1 pp_fun; 
336 
if (end_str="\n") then 
337 
print_newline () 
338 
else 
339 
print_string end_str 
340  
341 
let pp_longident lid = 
342 
let pp_fun (nid, tag) = 
343 
print_string nid; 
344 
print_string "("; 
345 
print_int tag; 
346 
print_string ")" 
347 
in 
348 
pp_list lid pp_fun "" "." "." 
349  
350 
let pp_date fmt tm = 
351 
Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" 
352 
(tm.Unix.tm_year + 1900) 
353 
tm.Unix.tm_mon 
354 
tm.Unix.tm_mday 
355 
tm.Unix.tm_hour 
356 
tm.Unix.tm_min 
357 
tm.Unix.tm_sec 
358  
359 
(* Used for uid in variables *) 
360  
361 
let var_id_cpt = ref 0 
362 
let get_new_id () = incr var_id_cpt;!var_id_cpt 
363  
364  
365 
(* for lexing purposes *) 
366  
367 
(* Update line number for location info *) 
368 
let incr_line lexbuf = 
369 
let pos = lexbuf.Lexing.lex_curr_p in 
370 
lexbuf.Lexing.lex_curr_p < { pos with 
371 
Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; 
372 
Lexing.pos_bol = pos.Lexing.pos_cnum; 
373 
} 
374  
375  
376 
let last_tag = ref (1) 
377 
let new_tag () = 
378 
incr last_tag; !last_tag 
379  
380  
381 
module List = 
382 
struct 
383 
include List 
384 
let iteri2 f l1 l2 = 
385 
if List.length l1 <> List.length l2 then 
386 
raise (Invalid_argument "iteri2: lists have different lengths") 
387 
else 
388 
let rec run idx l1 l2 = 
389 
match l1, l2 with 
390 
 [], [] > () 
391 
 hd1::tl1, hd2::tl2 > ( 
392 
f idx hd1 hd2; 
393 
run (idx+1) tl1 tl2 
394 
) 
395 
 _ > assert false 
396 
in 
397 
run 0 l1 l2 
398  
399 
let rec extract l fst last = 
400 
if last < fst then assert false else 
401 
match l, fst with 
402 
 hd::tl, 0 > if last = 0 then [] else hd::(extract tl 0 (last1)) 
403 
 _::tl, _ > extract tl (fst1) (last1) 
404 
 [], 0 > if last=0 then [] else assert false (* List too short *) 
405 
 _ > assert false 
406 

407 
end 
408  
409 
let get_date () = 
410 
let tm = Unix.localtime (Unix.time ()) in 
411 
let fmt = Format.str_formatter in 
412 
pp_date fmt tm; 
413 
(* let open Unix in *) 
414 
(* let _ = *) 
415 
(* Format.fprintf fmt *) 
416 
(* "%i/%i/%i %ih%i:%i" *) 
417 
(* tm.tm_year *) 
418 
(* tm.tm_mon *) 
419 
(* tm.tm_mday *) 
420 
(* tm.tm_hour *) 
421 
(* tm.tm_min *) 
422 
(* tm.tm_sec *) 
423 
(* in *) 
424 
Format.flush_str_formatter () 
425  
426 
(* Local Variables: *) 
427 
(* compilecommand:"make C .." *) 
428 
(* End: *) 