1

(* 

2

* SchedMCore  A MultiCore Scheduling Framework

3

* Copyright (C) 20092011, 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 021111307

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 (n1) 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 (n1) 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 prettyprinting. 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_counter1)

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_counter1)

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_counter1)

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 (n1));

288

pp_fun a.(n1)

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

(* compilecommand:"make C .." *)

360

(* End: *)
