Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / utils.ml @ b616fe7a

History | View | Annotate | Download (8.79 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 position pred l =
57
  let rec pos p l =
58
    match l with
59
    | [] -> assert false
60
    | t::q -> if pred t then p else pos (p+1) q
61
  in pos 0 l
62

    
63
let rec duplicate x n =
64
 if n < 0 then [] else x :: duplicate x (n - 1)
65

    
66
let enumerate n =
67
  let rec aux i =
68
    if i >= n then [] else i :: aux (i+1)
69
  in aux 0
70

    
71
let rec repeat n f x =
72
 if n <= 0 then x else repeat (n-1) f (f x)
73

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

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

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

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

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

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

    
119
let simplify_rat (a,b) =
120
  let gcd = gcd a b in
121
  if (gcd =0) then
122
    (a,b)
123
  else (a/gcd,b/gcd)
124

    
125
let max_rat (a,b) (a',b') =
126
  let ratio_ab = (float_of_int a)/.(float_of_int b) in
127
  let ratio_ab' = (float_of_int a')/.(float_of_int b') in
128
  if ratio_ab > ratio_ab' then
129
    (a,b)
130
  else
131
    (a',b')
132

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

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

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

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

    
178
let reset_names () =
179
  tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0
180

    
181
(* From OCaml compiler *)
182
let new_tname () =
183
  let tname =
184
    if !tname_counter < 26
185
    then String.make 1 (Char.chr(97 + !tname_counter))
186
    else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^
187
      string_of_int(!tname_counter / 26) in
188
  incr tname_counter;
189
  tname
190

    
191
let new_crname () =
192
  incr crname_counter;
193
  Format.sprintf "c%i" (!crname_counter-1)
194

    
195
let name_of_type id =
196
  try List.assoc id !tnames with Not_found ->
197
    let name = new_tname () in
198
    tnames := (id, name) :: !tnames;
199
    name
200

    
201
let name_of_carrier id =
202
  let pp_id =
203
    try List.assoc id !crnames with Not_found ->
204
      let name = new_crname () in
205
      crnames := (id,name) :: !crnames;
206
      name
207
  in
208
  pp_id
209

    
210
let new_dname () =
211
  incr dname_counter;
212
  Format.sprintf "d%i" (!dname_counter-1)
213

    
214
let name_of_dimension id =
215
  try List.assoc id !dnames with Not_found ->
216
    let name = new_dname () in
217
    dnames := (id, name) :: !dnames;
218
    name
219

    
220
let new_iname () =
221
  incr iname_counter;
222
  Format.sprintf "t%i" (!iname_counter-1)
223

    
224
let name_of_delay id =
225
  try List.assoc id !inames with Not_found ->
226
    let name = new_iname () in
227
    inames := (id, name) :: !inames;
228
    name
229

    
230
open Format
231

    
232
let print_rat fmt (a,b) =
233
  if b=1 then
234
    Format.fprintf fmt "%i" a
235
  else
236
    if b < 0 then
237
      Format.fprintf fmt "%i/%i" (-a) (-b)
238
    else
239
      Format.fprintf fmt "%i/%i" a b
240
	
241

    
242
(* Generic pretty printing *)
243

    
244
let pp_final_char_if_non_empty c l =
245
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
246

    
247
let pp_newline_if_non_empty l =
248
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
249

    
250
let rec fprintf_list ~sep:sep f fmt = function
251
  | []   -> ()
252
  | [e]  -> f fmt e
253
  | x::r -> Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r
254

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

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

    
295
let pp_hashtbl t pp_fun beg_str end_str sep_str =
296
  if (beg_str="\n") then
297
    print_newline ()
298
  else
299
    print_string beg_str;
300
  let pp_fun1 k v =
301
    pp_fun k v;
302
    if (sep_str="\n") then
303
      print_newline ()
304
    else
305
      print_string sep_str
306
  in
307
  hashtbl_iterlast t pp_fun1 pp_fun;
308
  if (end_str="\n") then
309
    print_newline ()
310
  else
311
    print_string end_str
312

    
313
let pp_longident lid =
314
  let pp_fun (nid, tag) =
315
    print_string nid;
316
    print_string "(";
317
    print_int tag;
318
    print_string ")"
319
  in
320
  pp_list lid pp_fun "" "." "."  
321

    
322
let pp_date fmt tm =
323
  Format.fprintf fmt "%i/%i/%i, %i:%i:%i"
324
    (tm.Unix.tm_year + 1900)
325
    tm.Unix.tm_mon
326
    tm.Unix.tm_mday
327
    tm.Unix.tm_hour
328
    tm.Unix.tm_min
329
    tm.Unix.tm_sec
330

    
331
(* Used for uid in variables *)
332

    
333
let var_id_cpt = ref 0
334
let get_new_id () = incr var_id_cpt;!var_id_cpt
335

    
336

    
337
let track_exception () =
338
 if !Options.track_exceptions
339
 then (Printexc.print_backtrace stdout; flush stdout)
340
 else ()
341

    
342

    
343
(* for lexing purposes *)
344

    
345
(* Update line number for location info *)
346
let incr_line lexbuf =
347
  let pos = lexbuf.Lexing.lex_curr_p in
348
  lexbuf.Lexing.lex_curr_p <- { pos with
349
    Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
350
    Lexing.pos_bol = pos.Lexing.pos_cnum;
351
  }
352

    
353

    
354
let last_tag = ref (-1)
355
let new_tag () =
356
  incr last_tag; !last_tag
357

    
358
(* Local Variables: *)
359
(* compile-command:"make -C .." *)
360
(* End: *)