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