Project

General

Profile

Download (12.7 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
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
module ISet = Set.Make(IdentModule)
37
module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule)
38
module TopologicalDepGraph = Topological.Make(IdentDepGraph)
39
module ComponentsDepGraph = Components.Make(IdentDepGraph) 
40
                           
41
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*)
42
module Bfs = Traverse.Bfs (IdentDepGraph)
43

    
44
            
45
exception DeSome
46
let desome x = match x with Some x -> x | None -> raise DeSome
47

    
48
let option_map f o =
49
  match o with
50
  | None   -> None
51
  | Some e -> Some (f e)
52

    
53
let add_cons x l =
54
 if List.mem x l then l else x::l
55

    
56
let rec remove_duplicates l =
57
 match l with
58
 | [] -> []
59
 | t::q -> add_cons t (remove_duplicates q)
60

    
61
let position pred l =
62
  let rec pos p l =
63
    match l with
64
    | [] -> assert false
65
    | t::q -> if pred t then p else pos (p+1) q
66
  in pos 0 l
67

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

    
72
let enumerate n = List.init n (fun i -> i)
73

    
74
let rec repeat n f x =
75
 if n <= 0 then x else repeat (n-1) f (f x)
76

    
77
let transpose_list ll =
78
  let rec transpose ll =
79
    match ll with
80
    | []   -> []
81
    | [l]  -> List.map (fun el -> [el]) l
82
    | l::q -> List.map2 (fun el eq -> el::eq) l (transpose q)
83
  in match ll with
84
  | []   -> []
85
  | l::q -> let length_l = List.length l in
86
    List.iter (fun l' -> let length_l' = List.length l'
87
                in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q;
88
    transpose ll
89

    
90
let rec filter_upto p n l =
91
 if n = 0 then [] else
92
 match l with
93
 | [] -> []
94
 | t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q
95

    
96
(* Warning: bad complexity *)
97
let list_of_imap imap =
98
  IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[])
99

    
100
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)
101
let rec gcd a b =
102
  if b = 0 then a
103
  else gcd b (a mod b)
104

    
105
(** [lcm a b] returns the least common multiple of [a] and [b]. *)
106
let lcm a b =
107
  if a = 0 && b = 0 then
108
    0
109
  else a*b/(gcd a b)
110

    
111
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and
112
    [(a',b')] *)
113
let sum_rat (a,b) (a',b') =
114
  if a = 0 && b = 0 then
115
    (a',b')
116
  else if a'=0 && b'=0 then
117
    (a,b)
118
  else
119
    let lcm_bb' = lcm b b' in
120
    (a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb')
121

    
122
let simplify_rat (a,b) =
123
  let gcd = gcd a b in
124
  if (gcd =0) then
125
    (a,b)
126
  else (a/gcd,b/gcd)
127

    
128
let max_rat (a,b) (a',b') =
129
  let ratio_ab = (float_of_int a)/.(float_of_int b) in
130
  let ratio_ab' = (float_of_int a')/.(float_of_int b') in
131
  if ratio_ab > ratio_ab' then
132
    (a,b)
133
  else
134
    (a',b')
135

    
136
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The
137
    result contains no duplicates. *)
138
let list_union l1 l2 =
139
  let rec aux l acc =
140
    match l with
141
    | [] -> acc
142
    | x::tl ->
143
        if List.mem x acc then
144
          aux tl acc
145
        else
146
          aux tl (x::acc)
147
  in
148
  let l1' = aux l1 [] in
149
  aux l2 l1'
150

    
151
(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the
152
    intersection is not empty, it replaces the former binding *)
153
let hashtbl_add h1 h2 =
154
  Hashtbl.iter (fun key value -> Hashtbl.replace h1 key value) h2
155

    
156
let hashtbl_iterlast h f1 f2 =
157
  let l = Hashtbl.length h in
158
  ignore(
159
  Hashtbl.fold
160
    (fun k v cpt ->
161
      if cpt = l then
162
        begin f2 k v; cpt+1 end
163
      else
164
        begin f1 k v; cpt+1 end)
165
    h 1)
166

    
167
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type
168
    variables are identified by integers. *)
169
let tnames = ref ([]: (int * string) list)
170
let tname_counter = ref 0
171
(* Same for carriers *)
172
let crnames = ref ([]: (int * string) list)
173
let crname_counter = ref 0
174
(* Same for dimension *)
175
let dnames = ref ([]: (int * string) list)
176
let dname_counter = ref 0
177
(* Same for delays *)
178
let inames = ref ([]: (int * string) list)
179
let iname_counter = ref 0
180

    
181
let reset_names () =
182
  tnames := [];
183
  tname_counter := 0;
184
  crnames := [];
185
  crname_counter := 0;
186
  dnames := [];
187
  dname_counter := 0;
188
  inames := [];
189
  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

    
255
let pp_final_char_if_non_empty c l =
256
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
257

    
258
let pp_newline_if_non_empty l =
259
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
260

    
261
module Format = struct
262
  include Format
263
  open Format
264

    
265
  let with_out_file file f =
266
    let oc = open_out file in
267
    let fmt = formatter_of_out_channel oc in
268
    f fmt;
269
    close_out oc
270

    
271
  let pp_print_nothing _fmt _ = ()
272

    
273
  let pp_print_cutcut fmt () = fprintf fmt "@,@,"
274

    
275
  let pp_print_endcut s fmt () = fprintf fmt "%s@," s
276

    
277
  let pp_print_opar fmt () = pp_print_string fmt "("
278
  let pp_print_cpar fmt () = pp_print_string fmt ")"
279
  let pp_print_obrace fmt () = pp_print_string fmt "{"
280
  let pp_print_cbrace fmt () = pp_print_string fmt "}"
281
  let pp_print_opar' fmt () = pp_print_string fmt "( "
282
  let pp_print_cpar' fmt () = pp_print_string fmt " )"
283
  let pp_print_obrace' fmt () = pp_print_string fmt "{ "
284
  let pp_print_cbrace' fmt () = pp_print_string fmt " }"
285

    
286
  let pp_print_comma fmt () = fprintf fmt ",@ "
287
  let pp_print_semicolon fmt () = fprintf fmt ";@ "
288
  let pp_print_comma' fmt () = fprintf fmt ","
289
  let pp_print_semicolon' fmt () = fprintf fmt ";"
290

    
291
  let pp_open_vbox0 fmt () = pp_open_vbox fmt 0
292

    
293
  let pp_print_list
294
      ?(pp_prologue=pp_print_nothing) ?(pp_epilogue=pp_print_nothing)
295
      ?(pp_op=pp_print_nothing) ?(pp_cl=pp_print_nothing)
296
      ?(pp_open_box=fun fmt () -> pp_open_box fmt 0)
297
      ?(pp_eol=pp_print_nothing)
298
      ?(pp_nil=pp_print_nothing)
299
      ?pp_sep pp_v fmt l =
300
    fprintf fmt "%a%a%a%a%a@]%a%a"
301
      (fun fmt l -> if l <> [] then pp_prologue fmt ()) l
302
      pp_op ()
303
      pp_open_box ()
304
      (fun fmt () ->
305
         if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l) ()
306
      (fun fmt l -> if l <> [] then pp_eol fmt ()) l
307
      pp_cl ()
308
      (fun fmt l -> if l <> [] then pp_epilogue fmt ()) l
309

    
310
  let pp_print_list_i
311
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
312
      pp_v =
313
    let i = ref 0 in
314
    pp_print_list
315
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
316
      (fun fmt x -> pp_v fmt !i x; incr i)
317

    
318
  let pp_print_list2
319
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
320
      pp_v fmt (l1, l2) =
321
    pp_print_list
322
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
323
      pp_v fmt (List.combine l1 l2)
324

    
325
  let pp_print_list_i2
326
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
327
      pp_v fmt (l1, l2) =
328
    pp_print_list_i
329
      ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
330
      (fun fmt i (x1, x2) -> pp_v fmt i x1 x2) fmt (List.combine l1 l2)
331

    
332
  let pp_print_parenthesized ?(pp_sep=pp_print_comma) =
333
    pp_print_list
334
      ~pp_op:pp_print_opar
335
      ~pp_cl:pp_print_cpar
336
      ~pp_sep
337

    
338
  let pp_print_braced ?(pp_sep=pp_print_comma) =
339
    pp_print_list
340
      ~pp_op:pp_print_obrace
341
      ~pp_cl:pp_print_cbrace
342
      ~pp_sep
343

    
344
  let pp_print_braced' ?(pp_sep=pp_print_comma) =
345
    pp_print_list
346
      ~pp_op:pp_print_obrace'
347
      ~pp_cl:pp_print_cbrace'
348
      ~pp_sep
349
end
350

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

    
355
let pp_list l pp_fun beg_str end_str sep_str =
356
  if (beg_str="\n") then
357
    print_newline ()
358
  else
359
    print_string beg_str;
360
  let rec pp_l l =
361
    match l with
362
    | [] -> ()
363
    | [hd] -> 
364
        pp_fun hd
365
    | hd::tl ->
366
        pp_fun hd;
367
        if (sep_str="\n") then
368
          print_newline ()
369
        else
370
          print_string sep_str;
371
        pp_l tl
372
  in
373
  pp_l l;
374
  if (end_str="\n") then
375
    print_newline ()
376
  else
377
    print_string end_str
378

    
379
let pp_array a pp_fun beg_str end_str sep_str =
380
  if (beg_str="\n") then
381
    print_newline ()
382
  else
383
    print_string beg_str;
384
  let n = Array.length a in
385
  if n > 0 then
386
    begin
387
      Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1));
388
      pp_fun a.(n-1)
389
    end;
390
  if (end_str="\n") then
391
    print_newline ()
392
  else
393
    print_string end_str
394

    
395
let pp_iset fmt t =
396
  Format.fprintf fmt "@[<hv 0>@[<hv 2>{";
397
  ISet.iter (fun s -> Format.fprintf fmt "@ %s" s) t;
398
  Format.fprintf fmt "@]@ }@]"
399

    
400
let pp_imap ?(comment="") pp_val fmt m =
401
  Format.fprintf fmt "@[<hv 0>@[<hv 2>{ %s" comment;
402
  IMap.iter (fun key v -> Format.fprintf fmt "@ %s -> %a" key pp_val v) m;
403
  Format.fprintf fmt "@]@ }@]"
404

    
405
let pp_hashtbl t pp_fun beg_str end_str sep_str =
406
  if (beg_str="\n") then
407
    print_newline ()
408
  else
409
    print_string beg_str;
410
  let pp_fun1 k v =
411
    pp_fun k v;
412
    if (sep_str="\n") then
413
      print_newline ()
414
    else
415
      print_string sep_str
416
  in
417
  hashtbl_iterlast t pp_fun1 pp_fun;
418
  if (end_str="\n") then
419
    print_newline ()
420
  else
421
    print_string end_str
422

    
423
let pp_longident lid =
424
  let pp_fun (nid, tag) =
425
    print_string nid;
426
    print_string "(";
427
    print_int tag;
428
    print_string ")"
429
  in
430
  pp_list lid pp_fun "" "." "."  
431

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

    
442
(* Used for uid in variables *)
443

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

    
448
let new_tag =
449
  let last_tag = ref (-1) in
450
  fun () -> incr last_tag; !last_tag
451

    
452

    
453
module List = struct
454
  include List 
455
  let iteri2 f l1 l2 =
456
    if List.length l1 <> List.length l2 then
457
      raise (Invalid_argument "iteri2: lists have different lengths")
458
    else
459
      let rec run idx l1 l2 =
460
        match l1, l2 with
461
        | [], [] -> ()
462
        | hd1::tl1, hd2::tl2 ->
463
          f idx hd1 hd2;
464
          run (idx+1) tl1 tl2
465
        | _ -> assert false
466
      in
467
      run 0 l1 l2
468

    
469
  let rec extract l fst last =
470
    if last < fst then assert false else
471
      match l, fst with
472
      | hd::tl, 0 -> if last = 0 then [] else hd::(extract tl 0 (last-1))
473
      | _::tl, _ -> extract tl (fst-1) (last-1)
474
      | [], 0 -> if last=0 then [] else assert false (* List too short *)
475
      | _ -> assert false 
476

    
477
end
478

    
479
let get_date () =
480
  let tm = Unix.localtime (Unix.time ()) in 
481
  let fmt = Format.str_formatter in
482
  pp_date fmt tm;
483
  Format.flush_str_formatter ()
484

    
485
(* Local Variables: *)
486
(* compile-command:"make -C .." *)
487
(* End: *)
(7-7/7)