Project

General

Profile

Download (13.2 KB) Statistics
| Branch: | Tag: | Revision:
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

    
16
type ident = string
17

    
18
type tag = int
19

    
20
type longident = (string * tag) list
21

    
22
exception TransposeError of int * int
23

    
24
(** General utility functions. *)
25
let create_hashtable size init =
26
  let tbl = Hashtbl.create size in
27
  List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
28
  tbl
29

    
30
module IdentModule = struct
31
  (* Node module *)
32
  type t = ident
33

    
34
  let compare = compare
35

    
36
  let hash n = Hashtbl.hash n
37

    
38
  let equal n1 n2 = n1 = n2
39
end
40

    
41
module IMap = struct
42
  include Map.Make (IdentModule)
43

    
44
  let diff m1 m2 =
45
    merge
46
      (fun _ o1 o2 ->
47
        match o1, o2 with
48
        | Some v1, Some v2 ->
49
          if v1 = v2 then None else o1
50
        | _ ->
51
          o1)
52
      m1 m2
53

    
54
  let of_list l = List.fold_left (fun m (x, v) -> add x v m) empty l
55
end
56

    
57
module ISet = Set.Make (IdentModule)
58
module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule)
59
module TopologicalDepGraph = Topological.Make (IdentDepGraph)
60
module ComponentsDepGraph = Components.Make (IdentDepGraph)
61

    
62
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*)
63
module Bfs = Traverse.Bfs (IdentDepGraph)
64

    
65
exception DeSome
66

    
67
let desome x = match x with Some x -> x | None -> raise DeSome
68

    
69
let option_map f o = match o with None -> None | Some e -> Some (f e)
70

    
71
let add_cons x l = if List.mem x l then l else x :: l
72

    
73
let rec remove_duplicates l =
74
  match l with [] -> [] | t :: q -> add_cons t (remove_duplicates q)
75

    
76
let position pred l =
77
  let rec pos p l =
78
    match l with
79
    | [] ->
80
      assert false
81
    | t :: q ->
82
      if pred t then p else pos (p + 1) q
83
  in
84
  pos 0 l
85

    
86
(* TODO: Lélio: why n+1? cf former def below *)
87
(* if n < 0 then [] else x :: duplicate x (n - 1) *)
88
let duplicate x n = List.init (n + 1) (fun _ -> x)
89

    
90
let enumerate n = List.init n (fun i -> i)
91

    
92
let rec repeat n f x = if n <= 0 then x else repeat (n - 1) f (f x)
93

    
94
let transpose_list ll =
95
  let rec transpose ll =
96
    match ll with
97
    | [] ->
98
      []
99
    | [ l ] ->
100
      List.map (fun el -> [ el ]) l
101
    | l :: q ->
102
      List.map2 (fun el eq -> el :: eq) l (transpose q)
103
  in
104
  match ll with
105
  | [] ->
106
    []
107
  | l :: q ->
108
    let length_l = List.length l in
109
    List.iter
110
      (fun l' ->
111
        let length_l' = List.length l' in
112
        if length_l <> length_l' then
113
          raise (TransposeError (length_l, length_l')))
114
      q;
115
    transpose ll
116

    
117
let rec filter_upto p n l =
118
  if n = 0 then []
119
  else
120
    match l with
121
    | [] ->
122
      []
123
    | t :: q ->
124
      if p t then t :: filter_upto p (n - 1) q else filter_upto p n q
125

    
126
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)
127
let rec gcd a b = if b = 0 then a else gcd b (a mod b)
128

    
129
(** [lcm a b] returns the least common multiple of [a] and [b]. *)
130
let lcm a b = if a = 0 && b = 0 then 0 else a * b / gcd a b
131

    
132
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and [(a',b')] *)
133
let sum_rat (a, b) (a', b') =
134
  if a = 0 && b = 0 then a', b'
135
  else if a' = 0 && b' = 0 then a, b
136
  else
137
    let lcm_bb' = lcm b b' in
138
    (a * lcm_bb' / b) + (a' * lcm_bb' / b'), lcm_bb'
139

    
140
let simplify_rat (a, b) =
141
  let gcd = gcd a b in
142
  if gcd = 0 then a, b else a / gcd, b / gcd
143

    
144
let max_rat (a, b) (a', b') =
145
  let ratio_ab = float_of_int a /. float_of_int b in
146
  let ratio_ab' = float_of_int a' /. float_of_int b' in
147
  if ratio_ab > ratio_ab' then a, b else a', b'
148

    
149
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The result
150
    contains no duplicates. *)
151
let list_union l1 l2 =
152
  let rec aux l acc =
153
    match l with
154
    | [] ->
155
      acc
156
    | x :: tl ->
157
      if List.mem x acc then aux tl acc else aux tl (x :: acc)
158
  in
159
  let l1' = aux l1 [] in
160
  aux l2 l1'
161

    
162
(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the
163
    intersection is not empty, it replaces the former binding *)
164
let hashtbl_add h1 h2 =
165
  Hashtbl.iter (fun key value -> Hashtbl.replace h1 key value) h2
166

    
167
let hashtbl_iterlast h f1 f2 =
168
  let l = Hashtbl.length h in
169
  ignore
170
    (Hashtbl.fold
171
       (fun k v cpt ->
172
         if cpt = l then (
173
           f2 k v;
174
           cpt + 1)
175
         else (
176
           f1 k v;
177
           cpt + 1))
178
       h 1)
179

    
180
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type variables
181
    are identified by integers. *)
182
let tnames = ref ([] : (int * string) list)
183

    
184
let tname_counter = ref 0
185

    
186
(* Same for carriers *)
187
let crnames = ref ([] : (int * string) list)
188

    
189
let crname_counter = ref 0
190

    
191
(* Same for dimension *)
192
let dnames = ref ([] : (int * string) list)
193

    
194
let dname_counter = ref 0
195

    
196
(* Same for delays *)
197
let inames = ref ([] : (int * string) list)
198

    
199
let iname_counter = ref 0
200

    
201
let reset_names () =
202
  tnames := [];
203
  tname_counter := 0;
204
  crnames := [];
205
  crname_counter := 0;
206
  dnames := [];
207
  dname_counter := 0;
208
  inames := [];
209
  iname_counter := 0
210

    
211
(* From OCaml compiler *)
212
let new_tname () =
213
  let tname =
214
    if !tname_counter < 26 then String.make 1 (Char.chr (97 + !tname_counter))
215
    else
216
      String.make 1 (Char.chr (97 + (!tname_counter mod 26)))
217
      ^ string_of_int (!tname_counter / 26)
218
  in
219
  incr tname_counter;
220
  tname
221

    
222
let new_crname () =
223
  incr crname_counter;
224
  Format.sprintf "c%i" (!crname_counter - 1)
225

    
226
let name_of_type id =
227
  try List.assoc id !tnames
228
  with Not_found ->
229
    let name = new_tname () in
230
    tnames := (id, name) :: !tnames;
231
    name
232

    
233
let name_of_carrier id =
234
  let pp_id =
235
    try List.assoc id !crnames
236
    with Not_found ->
237
      let name = new_crname () in
238
      crnames := (id, name) :: !crnames;
239
      name
240
  in
241
  pp_id
242

    
243
let new_dname () =
244
  incr dname_counter;
245
  Format.sprintf "d%i" (!dname_counter - 1)
246

    
247
let name_of_dimension id =
248
  try List.assoc id !dnames
249
  with Not_found ->
250
    let name = new_dname () in
251
    dnames := (id, name) :: !dnames;
252
    name
253

    
254
let new_iname () =
255
  incr iname_counter;
256
  Format.sprintf "t%i" (!iname_counter - 1)
257

    
258
let name_of_delay id =
259
  try List.assoc id !inames
260
  with Not_found ->
261
    let name = new_iname () in
262
    inames := (id, name) :: !inames;
263
    name
264

    
265
open Format
266

    
267
let print_rat fmt (a, b) =
268
  if b = 1 then Format.fprintf fmt "%i" a
269
  else if b < 0 then Format.fprintf fmt "%i/%i" (-a) (-b)
270
  else Format.fprintf fmt "%i/%i" a b
271

    
272
(* Generic pretty printing *)
273

    
274
let pp_final_char_if_non_empty c l fmt =
275
  match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c
276

    
277
let pp_newline_if_non_empty l fmt =
278
  match l with [] -> () | _ -> Format.fprintf fmt "@,"
279

    
280
module Format = struct
281
  include Format
282
  open Format
283

    
284
  let with_out_file file f =
285
    let oc = open_out file in
286
    let fmt = formatter_of_out_channel oc in
287
    f fmt;
288
    close_out oc
289

    
290
  let pp_print_nothing _fmt _ = ()
291

    
292
  let pp_print_cutcut fmt () = fprintf fmt "@,@,"
293

    
294
  let pp_print_endcut s fmt () = fprintf fmt "%s@," s
295

    
296
  let pp_print_opar fmt () = pp_print_string fmt "("
297

    
298
  let pp_print_cpar fmt () = pp_print_string fmt ")"
299

    
300
  let pp_print_obracket fmt () = pp_print_string fmt "["
301

    
302
  let pp_print_cbracket fmt () = pp_print_string fmt "]"
303

    
304
  let pp_print_obrace fmt () = pp_print_string fmt "{"
305

    
306
  let pp_print_cbrace fmt () = pp_print_string fmt "}"
307

    
308
  let pp_print_opar' fmt () = pp_print_string fmt "( "
309

    
310
  let pp_print_cpar' fmt () = pp_print_string fmt " )"
311

    
312
  let pp_print_obrace' fmt () = pp_print_string fmt "{ "
313

    
314
  let pp_print_cbrace' fmt () = pp_print_string fmt " }"
315

    
316
  let pp_print_comma fmt () = fprintf fmt ",@ "
317

    
318
  let pp_print_semicolon fmt () = fprintf fmt ";@ "
319

    
320
  let pp_print_comma' fmt () = fprintf fmt ","
321

    
322
  let pp_print_semicolon' fmt () = fprintf fmt ";"
323

    
324
  let pp_open_vbox0 fmt () = pp_open_vbox fmt 0
325

    
326
  let pp_print_list ?(pp_prologue = pp_print_nothing)
327
      ?(pp_epilogue = pp_print_nothing) ?(pp_op = pp_print_nothing)
328
      ?(pp_cl = pp_print_nothing)
329
      ?(pp_open_box = fun fmt () -> pp_open_box fmt 0)
330
      ?(pp_eol = pp_print_nothing) ?(pp_nil = pp_print_nothing) ?pp_sep pp_v fmt
331
      l =
332
    fprintf fmt "%a%a%a%a%a@]%a%a"
333
      (fun fmt l -> if l <> [] then pp_prologue fmt ())
334
      l pp_op () pp_open_box ()
335
      (fun fmt () ->
336
        if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l)
337
      ()
338
      (fun fmt l -> if l <> [] then pp_eol fmt ())
339
      l pp_cl ()
340
      (fun fmt l -> if l <> [] then pp_epilogue fmt ())
341
      l
342

    
343
  let pp_comma_list = pp_print_list ~pp_sep:pp_print_comma
344

    
345
  let pp_print_list_i ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
346
      ?pp_eol ?pp_sep pp_v =
347
    let i = ref 0 in
348
    pp_print_list ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
349
      ?pp_sep (fun fmt x ->
350
        pp_v fmt !i x;
351
        incr i)
352

    
353
  let pp_print_list2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
354
      ?pp_eol ?pp_sep pp_v fmt (l1, l2) =
355
    pp_print_list ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
356
      ?pp_sep pp_v fmt (List.combine l1 l2)
357

    
358
  let pp_print_list_i2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
359
      ?pp_eol ?pp_sep pp_v fmt (l1, l2) =
360
    pp_print_list_i ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
361
      ?pp_sep
362
      (fun fmt i (x1, x2) -> pp_v fmt i x1 x2)
363
      fmt (List.combine l1 l2)
364

    
365
  let pp_print_parenthesized ?(pp_sep = pp_print_comma) =
366
    pp_print_list ~pp_op:pp_print_opar ~pp_cl:pp_print_cpar ~pp_sep
367

    
368
  let pp_print_bracketed ?(pp_sep = pp_print_comma) =
369
    pp_print_list ~pp_op:pp_print_obracket ~pp_cl:pp_print_cbracket ~pp_sep
370

    
371
  let pp_print_braced ?(pp_sep = pp_print_comma) =
372
    pp_print_list ~pp_op:pp_print_obrace ~pp_cl:pp_print_cbrace ~pp_sep
373

    
374
  let pp_print_braced' ?(pp_sep = pp_print_comma) =
375
    pp_print_list ~pp_op:pp_print_obrace' ~pp_cl:pp_print_cbrace' ~pp_sep
376
end
377

    
378
let fprintf_list ?(eol : ('a, formatter, unit) format = "") ~sep f fmt l =
379
  Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "%(%)" sep) f fmt l);
380
  if l <> [] then Format.fprintf fmt "%(%)" eol
381

    
382
let pp_list l pp_fun beg_str end_str sep_str =
383
  if beg_str = "\n" then print_newline () else print_string beg_str;
384
  let rec pp_l l =
385
    match l with
386
    | [] ->
387
      ()
388
    | [ hd ] ->
389
      pp_fun hd
390
    | hd :: tl ->
391
      pp_fun hd;
392
      if sep_str = "\n" then print_newline () else print_string sep_str;
393
      pp_l tl
394
  in
395
  pp_l l;
396
  if end_str = "\n" then print_newline () else print_string end_str
397

    
398
let pp_array a pp_fun beg_str end_str sep_str =
399
  if beg_str = "\n" then print_newline () else print_string beg_str;
400
  let n = Array.length a in
401
  if n > 0 then (
402
    Array.iter
403
      (fun x ->
404
        pp_fun x;
405
        print_string sep_str)
406
      (Array.sub a 0 (n - 1));
407
    pp_fun a.(n - 1));
408
  if end_str = "\n" then print_newline () else print_string end_str
409

    
410
let pp_iset fmt t =
411
  Format.fprintf fmt "@[<hv 0>@[<hv 2>{";
412
  ISet.iter (fun s -> Format.fprintf fmt "@ %s" s) t;
413
  Format.fprintf fmt "@]@ }@]"
414

    
415
let pp_imap ?(comment = "") pp_val fmt m =
416
  Format.fprintf fmt "@[<hv 0>@[<hv 2>{ %s" comment;
417
  IMap.iter (fun key v -> Format.fprintf fmt "@ %s -> %a" key pp_val v) m;
418
  Format.fprintf fmt "@]@ }@]"
419

    
420
let pp_hashtbl t pp_fun beg_str end_str sep_str =
421
  if beg_str = "\n" then print_newline () else print_string beg_str;
422
  let pp_fun1 k v =
423
    pp_fun k v;
424
    if sep_str = "\n" then print_newline () else print_string sep_str
425
  in
426
  hashtbl_iterlast t pp_fun1 pp_fun;
427
  if end_str = "\n" then print_newline () else print_string end_str
428

    
429
let pp_longident lid =
430
  let pp_fun (nid, tag) =
431
    print_string nid;
432
    print_string "(";
433
    print_int tag;
434
    print_string ")"
435
  in
436
  pp_list lid pp_fun "" "." "."
437

    
438
let pp_date fmt tm =
439
  let open Unix in
440
  Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" (tm.tm_year + 1900) tm.tm_mon
441
    tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
442

    
443
(* Used for uid in variables *)
444

    
445
let get_new_id =
446
  let var_id_cpt = ref 0 in
447
  fun () ->
448
    incr var_id_cpt;
449
    !var_id_cpt
450

    
451
let new_tag =
452
  let last_tag = ref (-1) in
453
  fun () ->
454
    incr last_tag;
455
    !last_tag
456

    
457
module List = struct
458
  include List
459

    
460
  let iteri2 f l1 l2 =
461
    if List.length l1 <> List.length l2 then
462
      raise (Invalid_argument "iteri2: lists have different lengths")
463
    else
464
      let rec run idx l1 l2 =
465
        match l1, l2 with
466
        | [], [] ->
467
          ()
468
        | hd1 :: tl1, hd2 :: tl2 ->
469
          f idx hd1 hd2;
470
          run (idx + 1) tl1 tl2
471
        | _ ->
472
          assert false
473
      in
474
      run 0 l1 l2
475

    
476
  let rec extract l fst last =
477
    if last < fst then assert false
478
    else
479
      match l, fst with
480
      | hd :: tl, 0 ->
481
        if last = 0 then [] else hd :: extract tl 0 (last - 1)
482
      | _ :: tl, _ ->
483
        extract tl (fst - 1) (last - 1)
484
      | [], 0 ->
485
        if last = 0 then [] else assert false (* List too short *)
486
      | _ ->
487
        assert false
488
end
489

    
490
let get_date () =
491
  let tm = Unix.localtime (Unix.time ()) in
492
  let fmt = Format.str_formatter in
493
  pp_date fmt tm;
494
  Format.flush_str_formatter ()
495

    
496
(* Local Variables: *)
497
(* compile-command:"make -C .." *)
498
(* End: *)
(7-7/7)