lustrec / src / utils / utils.ml @ f4cba4b8
History | View | Annotate | Download (10.6 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 = |
36 |
struct |
37 |
include Map.Make(IdentModule) |
38 |
let elements m = fold (fun i n res -> (i, n)::res) m [] |
39 |
end |
40 |
|
41 |
module ISet = Set.Make(IdentModule) |
42 |
module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule) |
43 |
module TopologicalDepGraph = Topological.Make(IdentDepGraph) |
44 |
module ComponentsDepGraph = Components.Make(IdentDepGraph) |
45 |
|
46 |
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*) |
47 |
module Bfs = Traverse.Bfs (IdentDepGraph) |
48 |
|
49 |
|
50 |
exception DeSome |
51 |
let desome x = match x with Some x -> x | None -> raise DeSome |
52 |
|
53 |
let option_map f o = |
54 |
match o with |
55 |
| None -> None |
56 |
| Some e -> Some (f e) |
57 |
|
58 |
let add_cons x l = |
59 |
if List.mem x l then l else x::l |
60 |
|
61 |
let rec remove_duplicates l = |
62 |
match l with |
63 |
| [] -> [] |
64 |
| t::q -> add_cons t (remove_duplicates q) |
65 |
|
66 |
let position pred l = |
67 |
let rec pos p l = |
68 |
match l with |
69 |
| [] -> assert false |
70 |
| t::q -> if pred t then p else pos (p+1) q |
71 |
in pos 0 l |
72 |
|
73 |
let rec duplicate x n = |
74 |
if n < 0 then [] else x :: duplicate x (n - 1) |
75 |
|
76 |
let enumerate n = |
77 |
let rec aux i = |
78 |
if i >= n then [] else i :: aux (i+1) |
79 |
in aux 0 |
80 |
|
81 |
let rec repeat n f x = |
82 |
if n <= 0 then x else repeat (n-1) f (f x) |
83 |
|
84 |
let transpose_list ll = |
85 |
let rec transpose ll = |
86 |
match ll with |
87 |
| [] -> [] |
88 |
| [l] -> List.map (fun el -> [el]) l |
89 |
| l::q -> List.map2 (fun el eq -> el::eq) l (transpose q) |
90 |
in match ll with |
91 |
| [] -> [] |
92 |
| l::q -> let length_l = List.length l in |
93 |
List.iter (fun l' -> let length_l' = List.length l' |
94 |
in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q; |
95 |
transpose ll |
96 |
|
97 |
let rec filter_upto p n l = |
98 |
if n = 0 then [] else |
99 |
match l with |
100 |
| [] -> [] |
101 |
| t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q |
102 |
|
103 |
(* Warning: bad complexity *) |
104 |
let list_of_imap imap = |
105 |
IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[]) |
106 |
|
107 |
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *) |
108 |
let rec gcd a b = |
109 |
if b = 0 then a |
110 |
else gcd b (a mod b) |
111 |
|
112 |
(** [lcm a b] returns the least common multiple of [a] and [b]. *) |
113 |
let lcm a b = |
114 |
if a = 0 && b = 0 then |
115 |
0 |
116 |
else a*b/(gcd a b) |
117 |
|
118 |
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and |
119 |
[(a',b')] *) |
120 |
let sum_rat (a,b) (a',b') = |
121 |
if a = 0 && b = 0 then |
122 |
(a',b') |
123 |
else if a'=0 && b'=0 then |
124 |
(a,b) |
125 |
else |
126 |
let lcm_bb' = lcm b b' in |
127 |
(a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb') |
128 |
|
129 |
let simplify_rat (a,b) = |
130 |
let gcd = gcd a b in |
131 |
if (gcd =0) then |
132 |
(a,b) |
133 |
else (a/gcd,b/gcd) |
134 |
|
135 |
let max_rat (a,b) (a',b') = |
136 |
let ratio_ab = (float_of_int a)/.(float_of_int b) in |
137 |
let ratio_ab' = (float_of_int a')/.(float_of_int b') in |
138 |
if ratio_ab > ratio_ab' then |
139 |
(a,b) |
140 |
else |
141 |
(a',b') |
142 |
|
143 |
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The |
144 |
result contains no duplicates. *) |
145 |
let list_union l1 l2 = |
146 |
let rec aux l acc = |
147 |
match l with |
148 |
| [] -> acc |
149 |
| x::tl -> |
150 |
if List.mem x acc then |
151 |
aux tl acc |
152 |
else |
153 |
aux tl (x::acc) |
154 |
in |
155 |
let l1' = aux l1 [] in |
156 |
aux l2 l1' |
157 |
|
158 |
(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the |
159 |
intersection is not empty, it replaces the former binding *) |
160 |
let hashtbl_add h1 h2 = |
161 |
Hashtbl.iter (fun key value -> Hashtbl.replace h1 key value) h2 |
162 |
|
163 |
let hashtbl_iterlast h f1 f2 = |
164 |
let l = Hashtbl.length h in |
165 |
ignore( |
166 |
Hashtbl.fold |
167 |
(fun k v cpt -> |
168 |
if cpt = l then |
169 |
begin f2 k v; cpt+1 end |
170 |
else |
171 |
begin f1 k v; cpt+1 end) |
172 |
h 1) |
173 |
|
174 |
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type |
175 |
variables are identified by integers. *) |
176 |
let tnames = ref ([]: (int * string) list) |
177 |
let tname_counter = ref 0 |
178 |
(* Same for carriers *) |
179 |
let crnames = ref ([]: (int * string) list) |
180 |
let crname_counter = ref 0 |
181 |
(* Same for dimension *) |
182 |
let dnames = ref ([]: (int * string) list) |
183 |
let dname_counter = ref 0 |
184 |
(* Same for delays *) |
185 |
let inames = ref ([]: (int * string) list) |
186 |
let iname_counter = ref 0 |
187 |
|
188 |
let reset_names () = |
189 |
tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0 |
190 |
|
191 |
(* From OCaml compiler *) |
192 |
let new_tname () = |
193 |
let tname = |
194 |
if !tname_counter < 26 |
195 |
then String.make 1 (Char.chr(97 + !tname_counter)) |
196 |
else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^ |
197 |
string_of_int(!tname_counter / 26) in |
198 |
incr tname_counter; |
199 |
tname |
200 |
|
201 |
let new_crname () = |
202 |
incr crname_counter; |
203 |
Format.sprintf "c%i" (!crname_counter-1) |
204 |
|
205 |
let name_of_type id = |
206 |
try List.assoc id !tnames with Not_found -> |
207 |
let name = new_tname () in |
208 |
tnames := (id, name) :: !tnames; |
209 |
name |
210 |
|
211 |
let name_of_carrier id = |
212 |
let pp_id = |
213 |
try List.assoc id !crnames with Not_found -> |
214 |
let name = new_crname () in |
215 |
crnames := (id,name) :: !crnames; |
216 |
name |
217 |
in |
218 |
pp_id |
219 |
|
220 |
let new_dname () = |
221 |
incr dname_counter; |
222 |
Format.sprintf "d%i" (!dname_counter-1) |
223 |
|
224 |
let name_of_dimension id = |
225 |
try List.assoc id !dnames with Not_found -> |
226 |
let name = new_dname () in |
227 |
dnames := (id, name) :: !dnames; |
228 |
name |
229 |
|
230 |
let new_iname () = |
231 |
incr iname_counter; |
232 |
Format.sprintf "t%i" (!iname_counter-1) |
233 |
|
234 |
let name_of_delay id = |
235 |
try List.assoc id !inames with Not_found -> |
236 |
let name = new_iname () in |
237 |
inames := (id, name) :: !inames; |
238 |
name |
239 |
|
240 |
open Format |
241 |
|
242 |
let print_rat fmt (a,b) = |
243 |
if b=1 then |
244 |
Format.fprintf fmt "%i" a |
245 |
else |
246 |
if b < 0 then |
247 |
Format.fprintf fmt "%i/%i" (-a) (-b) |
248 |
else |
249 |
Format.fprintf fmt "%i/%i" a b |
250 |
|
251 |
|
252 |
(* Generic pretty printing *) |
253 |
|
254 |
let pp_final_char_if_non_empty c l = |
255 |
(fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c) |
256 |
|
257 |
let pp_newline_if_non_empty l = |
258 |
(fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,") |
259 |
|
260 |
let fprintf_list ?(eol:('a, formatter, unit) Pervasives.format = "") ~sep:sep f fmt l = |
261 |
let rec aux fmt = function |
262 |
| [] -> () |
263 |
| [e] -> f fmt e |
264 |
| x::r -> Format.fprintf fmt "%a%(%)%a" f x sep aux r |
265 |
in |
266 |
match l with |
267 |
| [] -> () |
268 |
| _ -> ( |
269 |
aux fmt l; |
270 |
Format.fprintf fmt "%(%)" eol |
271 |
) |
272 |
|
273 |
let pp_list l pp_fun beg_str end_str sep_str = |
274 |
if (beg_str="\n") then |
275 |
print_newline () |
276 |
else |
277 |
print_string beg_str; |
278 |
let rec pp_l l = |
279 |
match l with |
280 |
| [] -> () |
281 |
| [hd] -> |
282 |
pp_fun hd |
283 |
| hd::tl -> |
284 |
pp_fun hd; |
285 |
if (sep_str="\n") then |
286 |
print_newline () |
287 |
else |
288 |
print_string sep_str; |
289 |
pp_l tl |
290 |
in |
291 |
pp_l l; |
292 |
if (end_str="\n") then |
293 |
print_newline () |
294 |
else |
295 |
print_string end_str |
296 |
|
297 |
let pp_array a pp_fun beg_str end_str sep_str = |
298 |
if (beg_str="\n") then |
299 |
print_newline () |
300 |
else |
301 |
print_string beg_str; |
302 |
let n = Array.length a in |
303 |
if n > 0 then |
304 |
begin |
305 |
Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1)); |
306 |
pp_fun a.(n-1) |
307 |
end; |
308 |
if (end_str="\n") then |
309 |
print_newline () |
310 |
else |
311 |
print_string end_str |
312 |
|
313 |
let pp_iset fmt t = |
314 |
begin |
315 |
Format.fprintf fmt "{@ "; |
316 |
ISet.iter (fun s -> Format.fprintf fmt "%s@ " s) t; |
317 |
Format.fprintf fmt "}@." |
318 |
end |
319 |
|
320 |
let pp_imap pp_val fmt m = |
321 |
begin |
322 |
Format.fprintf fmt "@[{@ "; |
323 |
IMap.iter (fun key v -> Format.fprintf fmt "%s -> %a@ " key pp_val v) m; |
324 |
Format.fprintf fmt "}@ @]" |
325 |
end |
326 |
|
327 |
let pp_hashtbl t pp_fun beg_str end_str sep_str = |
328 |
if (beg_str="\n") then |
329 |
print_newline () |
330 |
else |
331 |
print_string beg_str; |
332 |
let pp_fun1 k v = |
333 |
pp_fun k v; |
334 |
if (sep_str="\n") then |
335 |
print_newline () |
336 |
else |
337 |
print_string sep_str |
338 |
in |
339 |
hashtbl_iterlast t pp_fun1 pp_fun; |
340 |
if (end_str="\n") then |
341 |
print_newline () |
342 |
else |
343 |
print_string end_str |
344 |
|
345 |
let pp_longident lid = |
346 |
let pp_fun (nid, tag) = |
347 |
print_string nid; |
348 |
print_string "("; |
349 |
print_int tag; |
350 |
print_string ")" |
351 |
in |
352 |
pp_list lid pp_fun "" "." "." |
353 |
|
354 |
let pp_date fmt tm = |
355 |
Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" |
356 |
(tm.Unix.tm_year + 1900) |
357 |
tm.Unix.tm_mon |
358 |
tm.Unix.tm_mday |
359 |
tm.Unix.tm_hour |
360 |
tm.Unix.tm_min |
361 |
tm.Unix.tm_sec |
362 |
|
363 |
(* Used for uid in variables *) |
364 |
|
365 |
let var_id_cpt = ref 0 |
366 |
let get_new_id () = incr var_id_cpt;!var_id_cpt |
367 |
|
368 |
|
369 |
(* for lexing purposes *) |
370 |
|
371 |
(* Update line number for location info *) |
372 |
let incr_line lexbuf = |
373 |
let pos = lexbuf.Lexing.lex_curr_p in |
374 |
lexbuf.Lexing.lex_curr_p <- { pos with |
375 |
Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; |
376 |
Lexing.pos_bol = pos.Lexing.pos_cnum; |
377 |
} |
378 |
|
379 |
|
380 |
let last_tag = ref (-1) |
381 |
let new_tag () = |
382 |
incr last_tag; !last_tag |
383 |
|
384 |
|
385 |
module List = |
386 |
struct |
387 |
include List |
388 |
let iteri2 f l1 l2 = |
389 |
if List.length l1 <> List.length l2 then |
390 |
raise (Invalid_argument "iteri2: lists have different lengths") |
391 |
else |
392 |
let rec run idx l1 l2 = |
393 |
match l1, l2 with |
394 |
| [], [] -> () |
395 |
| hd1::tl1, hd2::tl2 -> ( |
396 |
f idx hd1 hd2; |
397 |
run (idx+1) tl1 tl2 |
398 |
) |
399 |
| _ -> assert false |
400 |
in |
401 |
run 0 l1 l2 |
402 |
|
403 |
let rec extract l fst last = |
404 |
if last < fst then assert false else |
405 |
match l, fst with |
406 |
| hd::tl, 0 -> if last = 0 then [] else hd::(extract tl 0 (last-1)) |
407 |
| _::tl, _ -> extract tl (fst-1) (last-1) |
408 |
| [], 0 -> if last=0 then [] else assert false (* List too short *) |
409 |
| _ -> assert false |
410 |
|
411 |
end |
412 |
|
413 |
let get_date () = |
414 |
let tm = Unix.localtime (Unix.time ()) in |
415 |
let fmt = Format.str_formatter in |
416 |
pp_date fmt tm; |
417 |
(* let open Unix in *) |
418 |
(* let _ = *) |
419 |
(* Format.fprintf fmt *) |
420 |
(* "%i/%i/%i %ih%i:%i" *) |
421 |
(* tm.tm_year *) |
422 |
(* tm.tm_mon *) |
423 |
(* tm.tm_mday *) |
424 |
(* tm.tm_hour *) |
425 |
(* tm.tm_min *) |
426 |
(* tm.tm_sec *) |
427 |
(* in *) |
428 |
Format.flush_str_formatter () |
429 |
|
430 |
|
431 |
|
432 |
(* Local Variables: *) |
433 |
(* compile-command:"make -C .." *) |
434 |
(* End: *) |
435 |
|