Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / utils.ml @ a55c2d70

History | View | Annotate | Download (8.62 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
(** General utility functions. *)
30
let create_hashtable size init =
31
  let tbl = Hashtbl.create size in
32
  List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
33
  tbl
34

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

    
43
module IMap = Map.Make(IdentModule)
44

    
45
module ISet = Set.Make(IdentModule)
46

    
47
let desome x = match x with Some x -> x | None -> failwith "desome"
48

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

    
54
let position pred l =
55
  let rec pos p l =
56
    match l with
57
    | [] -> assert false
58
    | t::q -> if pred t then p else pos (p+1) q
59
  in pos 0 l
60

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

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

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

    
72
let rec transpose_list ll =
73
 match ll with
74
 | []   -> []
75
 | [l]  -> List.map (fun el -> [el]) l
76
 | l::q -> 
77
   let length_l = List.length l in
78
   if not (List.for_all (fun l' -> List.length l' = length_l) q) then
79
     assert false
80
   ;
81
   List.map2 (fun el eq -> el::eq) l (transpose_list q)
82

    
83
let rec filter_upto p n l =
84
 if n = 0 then [] else
85
 match l with
86
 | [] -> []
87
 | t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q
88

    
89
(* Warning: bad complexity *)
90
let list_of_imap imap =
91
  IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[])
92

    
93
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)
94
let rec gcd a b =
95
  if b = 0 then a
96
  else gcd b (a mod b)
97

    
98
(** [lcm a b] returns the least common multiple of [a] and [b]. *)
99
let lcm a b =
100
  if a = 0 && b = 0 then
101
    0
102
  else a*b/(gcd a b)
103

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

    
115
let simplify_rat (a,b) =
116
  let gcd = gcd a b in
117
  if (gcd =0) then
118
    (a,b)
119
  else (a/gcd,b/gcd)
120

    
121
let max_rat (a,b) (a',b') =
122
  let ratio_ab = (float_of_int a)/.(float_of_int b) in
123
  let ratio_ab' = (float_of_int a')/.(float_of_int b') in
124
  if ratio_ab > ratio_ab' then
125
    (a,b)
126
  else
127
    (a',b')
128

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

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

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

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

    
174
let reset_names () =
175
  tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0
176

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

    
187
let new_crname () =
188
  incr crname_counter;
189
  Format.sprintf "c%i" (!crname_counter-1)
190

    
191
let name_of_type id =
192
  try List.assoc id !tnames with Not_found ->
193
    let name = new_tname () in
194
    tnames := (id, name) :: !tnames;
195
    name
196

    
197
let name_of_carrier id =
198
  let pp_id =
199
    try List.assoc id !crnames with Not_found ->
200
      let name = new_crname () in
201
      crnames := (id,name) :: !crnames;
202
      name
203
  in
204
  pp_id
205

    
206
let new_dname () =
207
  incr dname_counter;
208
  Format.sprintf "d%i" (!dname_counter-1)
209

    
210
let name_of_dimension id =
211
  try List.assoc id !dnames with Not_found ->
212
    let name = new_dname () in
213
    dnames := (id, name) :: !dnames;
214
    name
215

    
216
let new_iname () =
217
  incr iname_counter;
218
  Format.sprintf "t%i" (!iname_counter-1)
219

    
220
let name_of_delay id =
221
  try List.assoc id !inames with Not_found ->
222
    let name = new_iname () in
223
    inames := (id, name) :: !inames;
224
    name
225

    
226
open Format
227

    
228
let print_rat fmt (a,b) =
229
  if b=1 then
230
    Format.fprintf fmt "%i" a
231
  else
232
    if b < 0 then
233
      Format.fprintf fmt "%i/%i" (-a) (-b)
234
    else
235
      Format.fprintf fmt "%i/%i" a b
236
	
237

    
238
(* Generic pretty printing *)
239

    
240
let pp_final_char_if_non_empty c l =
241
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
242

    
243
let pp_newline_if_non_empty l =
244
  (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
245

    
246
let rec fprintf_list ~sep:sep f fmt = function
247
  | []   -> ()
248
  | [e]  -> f fmt e
249
  | x::r -> Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r
250

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

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

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

    
309
let pp_longident lid =
310
  let pp_fun (nid, tag) =
311
    print_string nid;
312
    print_string "(";
313
    print_int tag;
314
    print_string ")"
315
  in
316
  pp_list lid pp_fun "" "." "."  
317

    
318
let pp_date fmt tm =
319
  Format.fprintf fmt "%i/%i/%i, %i:%i:%i"
320
    (tm.Unix.tm_year + 1900)
321
    tm.Unix.tm_mon
322
    tm.Unix.tm_mday
323
    tm.Unix.tm_hour
324
    tm.Unix.tm_min
325
    tm.Unix.tm_sec
326

    
327
(* Used for uid in variables *)
328

    
329
let var_id_cpt = ref 0
330
let get_new_id () = incr var_id_cpt;!var_id_cpt
331

    
332

    
333
let track_exception () =
334
 if !Options.track_exceptions
335
 then (Printexc.print_backtrace stdout; flush stdout)
336
 else ()
337

    
338

    
339
(* for lexing purposes *)
340

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

    
349

    
350
let last_tag = ref (-1)
351
let new_tag () =
352
  incr last_tag; !last_tag
353

    
354
(* Local Variables: *)
355
(* compile-command:"make -C .." *)
356
(* End: *)