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