Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / utils.ml @ 1837ce98

History | View | Annotate | Download (9.07 KB)

1
(* ----------------------------------------------------------------------------
2
 * SchedMCore - A MultiCore Scheduling Framework
3
 * Copyright (C) 2009-2011, ONERA, Toulouse, FRANCE - LIFL, Lille, FRANCE
4
 *
5
 * This file is part of Prelude
6
 *
7
 * Prelude is free software; you can redistribute it and/or
8
 * modify it under the terms of the GNU Lesser General Public License
9
 * as published by the Free Software Foundation ; either version 2 of
10
 * the License, or (at your option) any later version.
11
 *
12
 * Prelude is distributed in the hope that it will be useful, but
13
 * WITHOUT ANY WARRANTY ; without even the implied warranty of
14
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15
 * Lesser General Public License for more details.
16
 *
17
 * You should have received a copy of the GNU Lesser General Public
18
 * License along with this program ; if not, write to the Free Software
19
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
20
 * USA
21
 *---------------------------------------------------------------------------- *)
22
open Graph
23

    
24
type rat = int*int
25
type ident = string
26
type tag = int
27
type longident = (string * tag) list
28

    
29
exception TransposeError of int*int
30

    
31
(** General utility functions. *)
32
let create_hashtable size init =
33
  let tbl = Hashtbl.create size in
34
  List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
35
  tbl
36

    
37
module IdentModule =
38
struct (* Node module *)
39
  type t = ident
40
  let compare = compare
41
  let hash n = Hashtbl.hash n
42
  let equal n1 n2 = n1 = n2
43
end
44

    
45
module IMap = Map.Make(IdentModule)
46

    
47
module ISet = Set.Make(IdentModule)
48

    
49
let desome x = match x with Some x -> x | None -> failwith "desome"
50

    
51
let option_map f o =
52
  match o with
53
  | None   -> None
54
  | Some e -> Some (f e)
55

    
56
let rec remove_duplicates l =
57
 match l with
58
 | [] -> []
59
 | t::q -> if List.mem t q then remove_duplicates q else 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
let rec duplicate x n =
69
 if n < 0 then [] else x :: duplicate x (n - 1)
70

    
71
let enumerate n =
72
  let rec aux i =
73
    if i >= n then [] else i :: aux (i+1)
74
  in aux 0
75

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

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

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

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

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

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

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

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

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

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

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

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

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

    
183
let reset_names () =
184
  tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0
185

    
186
(* From OCaml compiler *)
187
let new_tname () =
188
  let tname =
189
    if !tname_counter < 26
190
    then String.make 1 (Char.chr(97 + !tname_counter))
191
    else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^
192
      string_of_int(!tname_counter / 26) in
193
  incr tname_counter;
194
  tname
195

    
196
let new_crname () =
197
  incr crname_counter;
198
  Format.sprintf "c%i" (!crname_counter-1)
199

    
200
let name_of_type id =
201
  try List.assoc id !tnames with Not_found ->
202
    let name = new_tname () in
203
    tnames := (id, name) :: !tnames;
204
    name
205

    
206
let name_of_carrier id =
207
  let pp_id =
208
    try List.assoc id !crnames with Not_found ->
209
      let name = new_crname () in
210
      crnames := (id,name) :: !crnames;
211
      name
212
  in
213
  pp_id
214

    
215
let new_dname () =
216
  incr dname_counter;
217
  Format.sprintf "d%i" (!dname_counter-1)
218

    
219
let name_of_dimension id =
220
  try List.assoc id !dnames with Not_found ->
221
    let name = new_dname () in
222
    dnames := (id, name) :: !dnames;
223
    name
224

    
225
let new_iname () =
226
  incr iname_counter;
227
  Format.sprintf "t%i" (!iname_counter-1)
228

    
229
let name_of_delay id =
230
  try List.assoc id !inames with Not_found ->
231
    let name = new_iname () in
232
    inames := (id, name) :: !inames;
233
    name
234

    
235
open Format
236

    
237
let print_rat fmt (a,b) =
238
  if b=1 then
239
    Format.fprintf fmt "%i" a
240
  else
241
    if b < 0 then
242
      Format.fprintf fmt "%i/%i" (-a) (-b)
243
    else
244
      Format.fprintf fmt "%i/%i" a b
245
	
246

    
247
(* Generic pretty printing *)
248

    
249
let pp_final_char_if_non_empty c l =
250
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
251

    
252
let pp_newline_if_non_empty l =
253
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
254

    
255
let rec fprintf_list ~sep:sep f fmt = function
256
  | []   -> ()
257
  | [e]  -> f fmt e
258
  | x::r -> Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r
259

    
260
let pp_list l pp_fun beg_str end_str sep_str =
261
  if (beg_str="\n") then
262
    print_newline ()
263
  else
264
    print_string beg_str;
265
  let rec pp_l l =
266
    match l with
267
    | [] -> ()
268
    | [hd] -> 
269
        pp_fun hd
270
    | hd::tl ->
271
        pp_fun hd;
272
        if (sep_str="\n") then
273
          print_newline ()
274
        else
275
          print_string sep_str;
276
        pp_l tl
277
  in
278
  pp_l l;
279
  if (end_str="\n") then
280
    print_newline ()
281
  else
282
    print_string end_str
283

    
284
let pp_array a pp_fun beg_str end_str sep_str =
285
  if (beg_str="\n") then
286
    print_newline ()
287
  else
288
    print_string beg_str;
289
  let n = Array.length a in
290
  if n > 0 then
291
    begin
292
      Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1));
293
      pp_fun a.(n-1)
294
    end;
295
  if (end_str="\n") then
296
    print_newline ()
297
  else
298
    print_string end_str
299

    
300
let pp_iset fmt t =
301
  begin
302
    Format.fprintf fmt "{@ ";
303
    ISet.iter (fun s -> Format.fprintf fmt "%s@ " s) t;
304
    Format.fprintf fmt "}@."
305
  end
306

    
307
let pp_hashtbl t pp_fun beg_str end_str sep_str =
308
  if (beg_str="\n") then
309
    print_newline ()
310
  else
311
    print_string beg_str;
312
  let pp_fun1 k v =
313
    pp_fun k v;
314
    if (sep_str="\n") then
315
      print_newline ()
316
    else
317
      print_string sep_str
318
  in
319
  hashtbl_iterlast t pp_fun1 pp_fun;
320
  if (end_str="\n") then
321
    print_newline ()
322
  else
323
    print_string end_str
324

    
325
let pp_longident lid =
326
  let pp_fun (nid, tag) =
327
    print_string nid;
328
    print_string "(";
329
    print_int tag;
330
    print_string ")"
331
  in
332
  pp_list lid pp_fun "" "." "."  
333

    
334
let pp_date fmt tm =
335
  Format.fprintf fmt "%i/%i/%i, %i:%i:%i"
336
    (tm.Unix.tm_year + 1900)
337
    tm.Unix.tm_mon
338
    tm.Unix.tm_mday
339
    tm.Unix.tm_hour
340
    tm.Unix.tm_min
341
    tm.Unix.tm_sec
342

    
343
(* Used for uid in variables *)
344

    
345
let var_id_cpt = ref 0
346
let get_new_id () = incr var_id_cpt;!var_id_cpt
347

    
348

    
349
let track_exception () =
350
 if !Options.track_exceptions
351
 then (Printexc.print_backtrace stdout; flush stdout)
352
 else ()
353

    
354

    
355
(* for lexing purposes *)
356

    
357
(* Update line number for location info *)
358
let incr_line lexbuf =
359
  let pos = lexbuf.Lexing.lex_curr_p in
360
  lexbuf.Lexing.lex_curr_p <- { pos with
361
    Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
362
    Lexing.pos_bol = pos.Lexing.pos_cnum;
363
  }
364

    
365

    
366
let last_tag = ref (-1)
367
let new_tag () =
368
  incr last_tag; !last_tag
369

    
370
(* Local Variables: *)
371
(* compile-command:"make -C .." *)
372
(* End: *)