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

(** 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 (n1) 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 > List.map2 (fun el eq > el::eq) l (transpose_list q)

77


78

let rec filter_upto p n l =

79

if n = 0 then [] else

80

match l with

81

 [] > []

82

 t::q > if p t then t :: filter_upto p (n1) q else filter_upto p n q

83


84

(* Warning: bad complexity *)

85

let list_of_imap imap =

86

IMap.fold (fun i v (il,vl) > (i::il,v::vl)) imap ([],[])

87


88

(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)

89

let rec gcd a b =

90

if b = 0 then a

91

else gcd b (a mod b)

92


93

(** [lcm a b] returns the least common multiple of [a] and [b]. *)

94

let lcm a b =

95

if a = 0 && b = 0 then

96

0

97

else a*b/(gcd a b)

98


99

(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and

100

[(a',b')] *)

101

let sum_rat (a,b) (a',b') =

102

if a = 0 && b = 0 then

103

(a',b')

104

else if a'=0 && b'=0 then

105

(a,b)

106

else

107

let lcm_bb' = lcm b b' in

108

(a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb')

109


110

let simplify_rat (a,b) =

111

let gcd = gcd a b in

112

if (gcd =0) then

113

(a,b)

114

else (a/gcd,b/gcd)

115


116

let max_rat (a,b) (a',b') =

117

let ratio_ab = (float_of_int a)/.(float_of_int b) in

118

let ratio_ab' = (float_of_int a')/.(float_of_int b') in

119

if ratio_ab > ratio_ab' then

120

(a,b)

121

else

122

(a',b')

123


124

(** [list_union l1 l2] returns the union of list [l1] and [l2]. The

125

result contains no duplicates. *)

126

let list_union l1 l2 =

127

let rec aux l acc =

128

match l with

129

 [] > acc

130

 x::tl >

131

if List.mem x acc then

132

aux tl acc

133

else

134

aux tl (x::acc)

135

in

136

let l1' = aux l1 [] in

137

aux l2 l1'

138


139

(** [hashtbl_add h1 h2] adds all the bindings in [h2] to [h1]. If the

140

intersection is not empty, it replaces the former binding *)

141

let hashtbl_add h1 h2 =

142

Hashtbl.iter (fun key value > Hashtbl.replace h1 key value) h2

143


144

let hashtbl_iterlast h f1 f2 =

145

let l = Hashtbl.length h in

146

ignore(

147

Hashtbl.fold

148

(fun k v cpt >

149

if cpt = l then

150

begin f2 k v; cpt+1 end

151

else

152

begin f1 k v; cpt+1 end)

153

h 1)

154


155

(** Match types variables to 'a, 'b, ..., for prettyprinting. Type

156

variables are identified by integers. *)

157

let tnames = ref ([]: (int * string) list)

158

let tname_counter = ref 0

159

(* Same for carriers *)

160

let crnames = ref ([]: (int * string) list)

161

let crname_counter = ref 0

162

(* Same for dimension *)

163

let dnames = ref ([]: (int * string) list)

164

let dname_counter = ref 0

165

(* Same for delays *)

166

let inames = ref ([]: (int * string) list)

167

let iname_counter = ref 0

168


169

let reset_names () =

170

tnames := []; tname_counter := 0; crnames := []; crname_counter := 0; dnames := []; dname_counter := 0; inames := []; iname_counter := 0

171


172

(* From OCaml compiler *)

173

let new_tname () =

174

let tname =

175

if !tname_counter < 26

176

then String.make 1 (Char.chr(97 + !tname_counter))

177

else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^

178

string_of_int(!tname_counter / 26) in

179

incr tname_counter;

180

tname

181


182

let new_crname () =

183

incr crname_counter;

184

Format.sprintf "c%i" (!crname_counter1)

185


186

let name_of_type id =

187

try List.assoc id !tnames with Not_found >

188

let name = new_tname () in

189

tnames := (id, name) :: !tnames;

190

name

191


192

let name_of_carrier id =

193

let pp_id =

194

try List.assoc id !crnames with Not_found >

195

let name = new_crname () in

196

crnames := (id,name) :: !crnames;

197

name

198

in

199

pp_id

200


201

let new_dname () =

202

incr dname_counter;

203

Format.sprintf "d%i" (!dname_counter1)

204


205

let name_of_dimension id =

206

try List.assoc id !dnames with Not_found >

207

let name = new_dname () in

208

dnames := (id, name) :: !dnames;

209

name

210


211

let new_iname () =

212

incr iname_counter;

213

Format.sprintf "t%i" (!iname_counter1)

214


215

let name_of_delay id =

216

try List.assoc id !inames with Not_found >

217

let name = new_iname () in

218

inames := (id, name) :: !inames;

219

name

220


221

open Format

222


223

let print_rat fmt (a,b) =

224

if b=1 then

225

Format.fprintf fmt "%i" a

226

else

227

if b < 0 then

228

Format.fprintf fmt "%i/%i" (a) (b)

229

else

230

Format.fprintf fmt "%i/%i" a b

231


232


233

(* Generic pretty printing *)

234


235

let pp_final_char_if_non_empty c l =

236

(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "%(%)" c)

237


238

let pp_newline_if_non_empty l =

239

(fun fmt > match l with [] > ()  _ > Format.fprintf fmt "@,")

240


241

let rec fprintf_list ~sep:sep f fmt = function

242

 [] > ()

243

 [e] > f fmt e

244

 x::r > Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r

245


246

let pp_list l pp_fun beg_str end_str sep_str =

247

if (beg_str="\n") then

248

print_newline ()

249

else

250

print_string beg_str;

251

let rec pp_l l =

252

match l with

253

 [] > ()

254

 [hd] >

255

pp_fun hd

256

 hd::tl >

257

pp_fun hd;

258

if (sep_str="\n") then

259

print_newline ()

260

else

261

print_string sep_str;

262

pp_l tl

263

in

264

pp_l l;

265

if (end_str="\n") then

266

print_newline ()

267

else

268

print_string end_str

269


270

let pp_array a pp_fun beg_str end_str sep_str =

271

if (beg_str="\n") then

272

print_newline ()

273

else

274

print_string beg_str;

275

let n = Array.length a in

276

if n > 0 then

277

begin

278

Array.iter (fun x > pp_fun x; print_string sep_str) (Array.sub a 0 (n1));

279

pp_fun a.(n1)

280

end;

281

if (end_str="\n") then

282

print_newline ()

283

else

284

print_string end_str

285


286

let pp_hashtbl t pp_fun beg_str end_str sep_str =

287

if (beg_str="\n") then

288

print_newline ()

289

else

290

print_string beg_str;

291

let pp_fun1 k v =

292

pp_fun k v;

293

if (sep_str="\n") then

294

print_newline ()

295

else

296

print_string sep_str

297

in

298

hashtbl_iterlast t pp_fun1 pp_fun;

299

if (end_str="\n") then

300

print_newline ()

301

else

302

print_string end_str

303


304

let pp_longident lid =

305

let pp_fun (nid, tag) =

306

print_string nid;

307

print_string "(";

308

print_int tag;

309

print_string ")"

310

in

311

pp_list lid pp_fun "" "." "."

312


313

let pp_date fmt tm =

314

Format.fprintf fmt "%i/%i/%i, %i:%i:%i"

315

(tm.Unix.tm_year + 1900)

316

tm.Unix.tm_mon

317

tm.Unix.tm_mday

318

tm.Unix.tm_hour

319

tm.Unix.tm_min

320

tm.Unix.tm_sec

321


322

(* Used for uid in variables *)

323


324

let var_id_cpt = ref 0

325

let get_new_id () = incr var_id_cpt;!var_id_cpt

326


327


328

let track_exception () =

329

if !Options.track_exceptions

330

then (Printexc.print_backtrace stdout; flush stdout)

331

else ()

332


333


334

(* for lexing purposes *)

335


336

(* Update line number for location info *)

337

let incr_line lexbuf =

338

let pos = lexbuf.Lexing.lex_curr_p in

339

lexbuf.Lexing.lex_curr_p < { pos with

340

Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;

341

Lexing.pos_bol = pos.Lexing.pos_cnum;

342

}

343


344


345

let last_tag = ref (1)

346

let new_tag () =

347

incr last_tag; !last_tag

348


349

(* Local Variables: *)

350

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

351

(* End: *)
