Project

General

Profile

Download (12.9 KB) Statistics
| Branch: | Tag: | Revision:
1 a2d97a3e ploc
(********************************************************************)
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 22fe1c93 ploc
open Graph
13
14
type rat = int*int
15
type ident = string
16
type tag = int
17
type longident = (string * tag) list
18
19 b616fe7a xthirioux
exception TransposeError of int*int
20
21 22fe1c93 ploc
(** 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 75c459f4 Lélio Brun
module IMap = struct
36
  include Map.Make(IdentModule)
37
  let union_l m1 m2 =
38
    merge (fun _ o1 o2 -> match o1, o2 with
39
        | None, None -> None
40
        | Some _, _ -> o1
41
        | _, Some _ -> o2) m1 m2
42
end
43
44 22fe1c93 ploc
module ISet = Set.Make(IdentModule)
45 a703ed0c ploc
module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule)
46 365d1b07 ploc
module TopologicalDepGraph = Topological.Make(IdentDepGraph)
47 a703ed0c ploc
module ComponentsDepGraph = Components.Make(IdentDepGraph) 
48
                           
49 365d1b07 ploc
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*)
50
module Bfs = Traverse.Bfs (IdentDepGraph)
51
52
            
53 04a63d25 xthirioux
exception DeSome
54
let desome x = match x with Some x -> x | None -> raise DeSome
55 e2380d4d ploc
56 22fe1c93 ploc
let option_map f o =
57
  match o with
58
  | None   -> None
59
  | Some e -> Some (f e)
60
61 45c13277 xthirioux
let add_cons x l =
62
 if List.mem x l then l else x::l
63
64 bb2ca5f4 xthirioux
let rec remove_duplicates l =
65
 match l with
66
 | [] -> []
67 45c13277 xthirioux
 | t::q -> add_cons t (remove_duplicates q)
68 bb2ca5f4 xthirioux
69 22fe1c93 ploc
let position pred l =
70
  let rec pos p l =
71
    match l with
72
    | [] -> assert false
73
    | t::q -> if pred t then p else pos (p+1) q
74
  in pos 0 l
75
76 1df55e58 Lélio Brun
(* TODO: Lélio: why n+1? cf former def below *)
77
(* if n < 0 then [] else x :: duplicate x (n - 1) *)
78 90cc3b8e Lélio Brun
let duplicate x n = List.init (n+1) (fun _ -> x)
79 22fe1c93 ploc
80 1df55e58 Lélio Brun
let enumerate n = List.init n (fun i -> i)
81 22fe1c93 ploc
82
let rec repeat n f x =
83
 if n <= 0 then x else repeat (n-1) f (f x)
84
85 b616fe7a xthirioux
let transpose_list ll =
86
  let rec transpose ll =
87
    match ll with
88
    | []   -> []
89
    | [l]  -> List.map (fun el -> [el]) l
90
    | l::q -> List.map2 (fun el eq -> el::eq) l (transpose q)
91
  in match ll with
92
  | []   -> []
93
  | l::q -> let length_l = List.length l in
94 1df55e58 Lélio Brun
    List.iter (fun l' -> let length_l' = List.length l'
95
                in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q;
96
    transpose ll
97 22fe1c93 ploc
98
let rec filter_upto p n l =
99
 if n = 0 then [] else
100
 match l with
101
 | [] -> []
102
 | t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q
103
104
(* Warning: bad complexity *)
105
let list_of_imap imap =
106
  IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[])
107
108
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)
109
let rec gcd a b =
110
  if b = 0 then a
111
  else gcd b (a mod b)
112
113
(** [lcm a b] returns the least common multiple of [a] and [b]. *)
114
let lcm a b =
115
  if a = 0 && b = 0 then
116
    0
117
  else a*b/(gcd a b)
118
119
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and
120
    [(a',b')] *)
121
let sum_rat (a,b) (a',b') =
122
  if a = 0 && b = 0 then
123
    (a',b')
124
  else if a'=0 && b'=0 then
125
    (a,b)
126
  else
127
    let lcm_bb' = lcm b b' in
128
    (a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb')
129
130
let simplify_rat (a,b) =
131
  let gcd = gcd a b in
132
  if (gcd =0) then
133
    (a,b)
134
  else (a/gcd,b/gcd)
135
136
let max_rat (a,b) (a',b') =
137
  let ratio_ab = (float_of_int a)/.(float_of_int b) in
138
  let ratio_ab' = (float_of_int a')/.(float_of_int b') in
139
  if ratio_ab > ratio_ab' then
140
    (a,b)
141
  else
142
    (a',b')
143
144
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The
145
    result contains no duplicates. *)
146
let list_union l1 l2 =
147
  let rec aux l acc =
148
    match l with
149
    | [] -> acc
150
    | x::tl ->
151
        if List.mem x acc then
152
          aux tl acc
153
        else
154
          aux tl (x::acc)
155
  in
156
  let l1' = aux l1 [] in
157
  aux l2 l1'
158
159
(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the
160
    intersection is not empty, it replaces the former binding *)
161
let hashtbl_add h1 h2 =
162
  Hashtbl.iter (fun key value -> Hashtbl.replace h1 key value) h2
163
164
let hashtbl_iterlast h f1 f2 =
165
  let l = Hashtbl.length h in
166
  ignore(
167
  Hashtbl.fold
168
    (fun k v cpt ->
169
      if cpt = l then
170
        begin f2 k v; cpt+1 end
171
      else
172
        begin f1 k v; cpt+1 end)
173
    h 1)
174
175
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type
176
    variables are identified by integers. *)
177
let tnames = ref ([]: (int * string) list)
178
let tname_counter = ref 0
179
(* Same for carriers *)
180
let crnames = ref ([]: (int * string) list)
181
let crname_counter = ref 0
182
(* Same for dimension *)
183
let dnames = ref ([]: (int * string) list)
184
let dname_counter = ref 0
185
(* Same for delays *)
186
let inames = ref ([]: (int * string) list)
187
let iname_counter = ref 0
188
189
let reset_names () =
190 1df55e58 Lélio Brun
  tnames := [];
191
  tname_counter := 0;
192
  crnames := [];
193
  crname_counter := 0;
194
  dnames := [];
195
  dname_counter := 0;
196
  inames := [];
197
  iname_counter := 0
198 22fe1c93 ploc
199
(* From OCaml compiler *)
200
let new_tname () =
201
  let tname =
202
    if !tname_counter < 26
203
    then String.make 1 (Char.chr(97 + !tname_counter))
204
    else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^
205
      string_of_int(!tname_counter / 26) in
206
  incr tname_counter;
207
  tname
208
209
let new_crname () =
210
  incr crname_counter;
211
  Format.sprintf "c%i" (!crname_counter-1)
212
213
let name_of_type id =
214
  try List.assoc id !tnames with Not_found ->
215
    let name = new_tname () in
216
    tnames := (id, name) :: !tnames;
217
    name
218
219
let name_of_carrier id =
220
  let pp_id =
221
    try List.assoc id !crnames with Not_found ->
222
      let name = new_crname () in
223
      crnames := (id,name) :: !crnames;
224
      name
225
  in
226
  pp_id
227
228
let new_dname () =
229
  incr dname_counter;
230
  Format.sprintf "d%i" (!dname_counter-1)
231
232
let name_of_dimension id =
233
  try List.assoc id !dnames with Not_found ->
234
    let name = new_dname () in
235
    dnames := (id, name) :: !dnames;
236
    name
237
238
let new_iname () =
239
  incr iname_counter;
240
  Format.sprintf "t%i" (!iname_counter-1)
241
242
let name_of_delay id =
243
  try List.assoc id !inames with Not_found ->
244
    let name = new_iname () in
245
    inames := (id, name) :: !inames;
246
    name
247
248
open Format
249
250
let print_rat fmt (a,b) =
251
  if b=1 then
252
    Format.fprintf fmt "%i" a
253
  else
254
    if b < 0 then
255
      Format.fprintf fmt "%i/%i" (-a) (-b)
256
    else
257
      Format.fprintf fmt "%i/%i" a b
258
	
259
260
(* Generic pretty printing *)
261
262 90cc3b8e Lélio Brun
263 22fe1c93 ploc
let pp_final_char_if_non_empty c l =
264
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
265
266
let pp_newline_if_non_empty l =
267
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
268
269 90cc3b8e Lélio Brun
module Format = struct
270
  include Format
271
  open Format
272
273
  let with_out_file file f =
274
    let oc = open_out file in
275
    let fmt = formatter_of_out_channel oc in
276
    f fmt;
277
    close_out oc
278
279
  let pp_print_nothing _fmt _ = ()
280
281
  let pp_print_cutcut fmt () = fprintf fmt "@,@,"
282
283
  let pp_print_endcut s fmt () = fprintf fmt "%s@," s
284
285
  let pp_print_opar fmt () = pp_print_string fmt "("
286
  let pp_print_cpar fmt () = pp_print_string fmt ")"
287
  let pp_print_obrace fmt () = pp_print_string fmt "{"
288
  let pp_print_cbrace fmt () = pp_print_string fmt "}"
289 15c3e4e7 Lélio Brun
  let pp_print_opar' fmt () = pp_print_string fmt "( "
290
  let pp_print_cpar' fmt () = pp_print_string fmt " )"
291
  let pp_print_obrace' fmt () = pp_print_string fmt "{ "
292
  let pp_print_cbrace' fmt () = pp_print_string fmt " }"
293 90cc3b8e Lélio Brun
294
  let pp_print_comma fmt () = fprintf fmt ",@ "
295
  let pp_print_semicolon fmt () = fprintf fmt ";@ "
296
  let pp_print_comma' fmt () = fprintf fmt ","
297
  let pp_print_semicolon' fmt () = fprintf fmt ";"
298
299
  let pp_open_vbox0 fmt () = pp_open_vbox fmt 0
300
301
  let pp_print_list
302
      ?(pp_prologue=pp_print_nothing) ?(pp_epilogue=pp_print_nothing)
303
      ?(pp_op=pp_print_nothing) ?(pp_cl=pp_print_nothing)
304
      ?(pp_open_box=fun fmt () -> pp_open_box fmt 0)
305 c226a3ba Lélio Brun
      ?(pp_eol=pp_print_nothing)
306
      ?(pp_nil=pp_print_nothing)
307
      ?pp_sep pp_v fmt l =
308 90cc3b8e Lélio Brun
    fprintf fmt "%a%a%a%a%a@]%a%a"
309
      (fun fmt l -> if l <> [] then pp_prologue fmt ()) l
310
      pp_op ()
311
      pp_open_box ()
312 c226a3ba Lélio Brun
      (fun fmt () ->
313
         if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l) ()
314 90cc3b8e Lélio Brun
      (fun fmt l -> if l <> [] then pp_eol fmt ()) l
315
      pp_cl ()
316
      (fun fmt l -> if l <> [] then pp_epilogue fmt ()) l
317
318
  let pp_print_list_i
319
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
320
      pp_v =
321
    let i = ref 0 in
322
    pp_print_list
323
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
324
      (fun fmt x -> pp_v fmt !i x; incr i)
325
326
  let pp_print_list2
327
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
328
      pp_v fmt (l1, l2) =
329
    pp_print_list
330
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
331
      pp_v fmt (List.combine l1 l2)
332
333
  let pp_print_list_i2
334
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
335
      pp_v fmt (l1, l2) =
336
    pp_print_list_i
337
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
338
      (fun fmt i (x1, x2) -> pp_v fmt i x1 x2) fmt (List.combine l1 l2)
339
340
  let pp_print_parenthesized ?(pp_sep=pp_print_comma) =
341
    pp_print_list
342
      ~pp_op:pp_print_opar
343
      ~pp_cl:pp_print_cpar
344
      ~pp_sep
345
346
  let pp_print_braced ?(pp_sep=pp_print_comma) =
347
    pp_print_list
348
      ~pp_op:pp_print_obrace
349
      ~pp_cl:pp_print_cbrace
350
      ~pp_sep
351
352 15c3e4e7 Lélio Brun
  let pp_print_braced' ?(pp_sep=pp_print_comma) =
353
    pp_print_list
354
      ~pp_op:pp_print_obrace'
355
      ~pp_cl:pp_print_cbrace'
356
      ~pp_sep
357 90cc3b8e Lélio Brun
end
358
359 ca7e8027 Lélio Brun
let fprintf_list ?(eol:('a, formatter, unit) format = "") ~sep:sep f fmt l =
360 1df55e58 Lélio Brun
  Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "%(%)" sep) f fmt l);
361
  if l <> [] then Format.fprintf fmt "%(%)" eol
362
363 22fe1c93 ploc
let pp_list l pp_fun beg_str end_str sep_str =
364
  if (beg_str="\n") then
365
    print_newline ()
366
  else
367
    print_string beg_str;
368
  let rec pp_l l =
369
    match l with
370
    | [] -> ()
371
    | [hd] -> 
372
        pp_fun hd
373
    | hd::tl ->
374
        pp_fun hd;
375
        if (sep_str="\n") then
376
          print_newline ()
377
        else
378
          print_string sep_str;
379
        pp_l tl
380
  in
381
  pp_l l;
382
  if (end_str="\n") then
383
    print_newline ()
384
  else
385
    print_string end_str
386
387
let pp_array a pp_fun beg_str end_str sep_str =
388
  if (beg_str="\n") then
389
    print_newline ()
390
  else
391
    print_string beg_str;
392
  let n = Array.length a in
393
  if n > 0 then
394
    begin
395
      Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1));
396
      pp_fun a.(n-1)
397
    end;
398
  if (end_str="\n") then
399
    print_newline ()
400
  else
401
    print_string end_str
402
403 8a183477 xthirioux
let pp_iset fmt t =
404 7ee5f69e Lélio Brun
  Format.fprintf fmt "@[<hv 0>@[<hv 2>{";
405
  ISet.iter (fun s -> Format.fprintf fmt "@ %s" s) t;
406
  Format.fprintf fmt "@]@ }@]"
407
408
let pp_imap ?(comment="") pp_val fmt m =
409
  Format.fprintf fmt "@[<hv 0>@[<hv 2>{ %s" comment;
410
  IMap.iter (fun key v -> Format.fprintf fmt "@ %s -> %a" key pp_val v) m;
411
  Format.fprintf fmt "@]@ }@]"
412
413 22fe1c93 ploc
let pp_hashtbl t pp_fun beg_str end_str sep_str =
414
  if (beg_str="\n") then
415
    print_newline ()
416
  else
417
    print_string beg_str;
418
  let pp_fun1 k v =
419
    pp_fun k v;
420
    if (sep_str="\n") then
421
      print_newline ()
422
    else
423
      print_string sep_str
424
  in
425
  hashtbl_iterlast t pp_fun1 pp_fun;
426
  if (end_str="\n") then
427
    print_newline ()
428
  else
429
    print_string end_str
430
431
let pp_longident lid =
432
  let pp_fun (nid, tag) =
433
    print_string nid;
434
    print_string "(";
435
    print_int tag;
436
    print_string ")"
437
  in
438
  pp_list lid pp_fun "" "." "."  
439
440 5c1184ad ploc
let pp_date fmt tm =
441 1df55e58 Lélio Brun
  let open Unix in
442 0f36882c xthirioux
  Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i"
443 1df55e58 Lélio Brun
    (tm.tm_year + 1900)
444
    tm.tm_mon
445
    tm.tm_mday
446
    tm.tm_hour
447
    tm.tm_min
448
    tm.tm_sec
449 22fe1c93 ploc
450
(* Used for uid in variables *)
451
452 1df55e58 Lélio Brun
let get_new_id =
453
  let var_id_cpt = ref 0 in
454
  fun () -> incr var_id_cpt; !var_id_cpt
455 22fe1c93 ploc
456 1df55e58 Lélio Brun
let new_tag =
457
  let last_tag = ref (-1) in
458
  fun () -> incr last_tag; !last_tag
459 22fe1c93 ploc
460
461 1df55e58 Lélio Brun
module List = struct
462 6fa45cb6 ploc
  include List 
463
  let iteri2 f l1 l2 =
464
    if List.length l1 <> List.length l2 then
465
      raise (Invalid_argument "iteri2: lists have different lengths")
466
    else
467
      let rec run idx l1 l2 =
468 1df55e58 Lélio Brun
        match l1, l2 with
469
        | [], [] -> ()
470
        | hd1::tl1, hd2::tl2 ->
471
          f idx hd1 hd2;
472
          run (idx+1) tl1 tl2
473
        | _ -> assert false
474 6fa45cb6 ploc
      in
475
      run 0 l1 l2
476 57d61d67 ploc
477
  let rec extract l fst last =
478
    if last < fst then assert false else
479
      match l, fst with
480
      | hd::tl, 0 -> if last = 0 then [] else hd::(extract tl 0 (last-1))
481
      | _::tl, _ -> extract tl (fst-1) (last-1)
482
      | [], 0 -> if last=0 then [] else assert false (* List too short *)
483
      | _ -> assert false 
484 1df55e58 Lélio Brun
485 6fa45cb6 ploc
end
486
487 57d61d67 ploc
let get_date () =
488 7d77632f ploc
  let tm = Unix.localtime (Unix.time ()) in 
489 57d61d67 ploc
  let fmt = Format.str_formatter in
490 7d77632f ploc
  pp_date fmt tm;
491 57d61d67 ploc
  Format.flush_str_formatter ()
492
493 1df55e58 Lélio Brun
(* Local Variables: *)
494
(* compile-command:"make -C .." *)
495
(* End: *)