## lustrec / src / utils.ml @ 22fe1c93

History | View | Annotate | Download (8.24 KB)

1 | 22fe1c93 | ploc | (* ---------------------------------------------------------------------------- |
---|---|---|---|

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 option_map f o = |
||

48 | match o with |
||

49 | | None -> None |
||

50 | | Some e -> Some (f e) |
||

51 | |||

52 | let position pred l = |
||

53 | let rec pos p l = |
||

54 | match l with |
||

55 | | [] -> assert false |
||

56 | | t::q -> if pred t then p else pos (p+1) q |
||

57 | in pos 0 l |
||

58 | |||

59 | let rec duplicate x n = |
||

60 | if n < 0 then [] else x :: duplicate x (n - 1) |
||

61 | |||

62 | let enumerate n = |
||

63 | let rec aux i = |
||

64 | if i >= n then [] else i :: aux (i+1) |
||

65 | in aux 0 |
||

66 | |||

67 | let rec repeat n f x = |
||

68 | if n <= 0 then x else repeat (n-1) f (f x) |
||

69 | |||

70 | let rec transpose_list ll = |
||

71 | match ll with |
||

72 | | [] -> [] |
||

73 | | [l] -> List.map (fun el -> [el]) l |
||

74 | | l::q -> List.map2 (fun el eq -> el::eq) l (transpose_list q) |
||

75 | |||

76 | let rec filter_upto p n l = |
||

77 | if n = 0 then [] else |
||

78 | match l with |
||

79 | | [] -> [] |
||

80 | | t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q |
||

81 | |||

82 | (* Warning: bad complexity *) |
||

83 | let list_of_imap imap = |
||

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

85 | |||

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

87 | let rec gcd a b = |
||

88 | if b = 0 then a |
||

89 | else gcd b (a mod b) |
||

90 | |||

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

92 | let lcm a b = |
||

93 | if a = 0 && b = 0 then |
||

94 | 0 |
||

95 | else a*b/(gcd a b) |
||

96 | |||

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

98 | [(a',b')] *) |
||

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

100 | if a = 0 && b = 0 then |
||

101 | (a',b') |
||

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

103 | (a,b) |
||

104 | else |
||

105 | let lcm_bb' = lcm b b' in |
||

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

107 | |||

108 | let simplify_rat (a,b) = |
||

109 | let gcd = gcd a b in |
||

110 | if (gcd =0) then |
||

111 | (a,b) |
||

112 | else (a/gcd,b/gcd) |
||

113 | |||

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

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

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

117 | if ratio_ab > ratio_ab' then |
||

118 | (a,b) |
||

119 | else |
||

120 | (a',b') |
||

121 | |||

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

123 | result contains no duplicates. *) |
||

124 | let list_union l1 l2 = |
||

125 | let rec aux l acc = |
||

126 | match l with |
||

127 | | [] -> acc |
||

128 | | x::tl -> |
||

129 | if List.mem x acc then |
||

130 | aux tl acc |
||

131 | else |
||

132 | aux tl (x::acc) |
||

133 | in |
||

134 | let l1' = aux l1 [] in |
||

135 | aux l2 l1' |
||

136 | |||

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

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

139 | let hashtbl_add h1 h2 = |
||

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

141 | |||

142 | let hashtbl_iterlast h f1 f2 = |
||

143 | let l = Hashtbl.length h in |
||

144 | ignore( |
||

145 | Hashtbl.fold |
||

146 | (fun k v cpt -> |
||

147 | if cpt = l then |
||

148 | begin f2 k v; cpt+1 end |
||

149 | else |
||

150 | begin f1 k v; cpt+1 end) |
||

151 | h 1) |
||

152 | |||

153 | (** Match types variables to 'a, 'b, ..., for pretty-printing. Type |
||

154 | variables are identified by integers. *) |
||

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

156 | let tname_counter = ref 0 |
||

157 | (* Same for carriers *) |
||

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

159 | let crname_counter = ref 0 |
||

160 | (* Same for dimension *) |
||

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

162 | let dname_counter = ref 0 |
||

163 | (* Same for delays *) |
||

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

165 | let iname_counter = ref 0 |
||

166 | |||

167 | let reset_names () = |
||

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

169 | |||

170 | (* From OCaml compiler *) |
||

171 | let new_tname () = |
||

172 | let tname = |
||

173 | if !tname_counter < 26 |
||

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

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

176 | string_of_int(!tname_counter / 26) in |
||

177 | incr tname_counter; |
||

178 | tname |
||

179 | |||

180 | let new_crname () = |
||

181 | incr crname_counter; |
||

182 | Format.sprintf "c%i" (!crname_counter-1) |
||

183 | |||

184 | let name_of_type id = |
||

185 | try List.assoc id !tnames with Not_found -> |
||

186 | let name = new_tname () in |
||

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

188 | name |
||

189 | |||

190 | let name_of_carrier id = |
||

191 | let pp_id = |
||

192 | try List.assoc id !crnames with Not_found -> |
||

193 | let name = new_crname () in |
||

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

195 | name |
||

196 | in |
||

197 | pp_id |
||

198 | |||

199 | let new_dname () = |
||

200 | incr dname_counter; |
||

201 | Format.sprintf "d%i" (!dname_counter-1) |
||

202 | |||

203 | let name_of_dimension id = |
||

204 | try List.assoc id !dnames with Not_found -> |
||

205 | let name = new_dname () in |
||

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

207 | name |
||

208 | |||

209 | let new_iname () = |
||

210 | incr iname_counter; |
||

211 | Format.sprintf "t%i" (!iname_counter-1) |
||

212 | |||

213 | let name_of_delay id = |
||

214 | try List.assoc id !inames with Not_found -> |
||

215 | let name = new_iname () in |
||

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

217 | name |
||

218 | |||

219 | open Format |
||

220 | |||

221 | let print_rat fmt (a,b) = |
||

222 | if b=1 then |
||

223 | Format.fprintf fmt "%i" a |
||

224 | else |
||

225 | if b < 0 then |
||

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

227 | else |
||

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

229 | |||

230 | |||

231 | (* Generic pretty printing *) |
||

232 | |||

233 | let pp_final_char_if_non_empty c l = |
||

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

235 | |||

236 | let pp_newline_if_non_empty l = |
||

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

238 | |||

239 | let rec fprintf_list ~sep:sep f fmt = function |
||

240 | | [] -> () |
||

241 | | [e] -> f fmt e |
||

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

243 | |||

244 | let pp_list l pp_fun beg_str end_str sep_str = |
||

245 | if (beg_str="\n") then |
||

246 | print_newline () |
||

247 | else |
||

248 | print_string beg_str; |
||

249 | let rec pp_l l = |
||

250 | match l with |
||

251 | | [] -> () |
||

252 | | [hd] -> |
||

253 | pp_fun hd |
||

254 | | hd::tl -> |
||

255 | pp_fun hd; |
||

256 | if (sep_str="\n") then |
||

257 | print_newline () |
||

258 | else |
||

259 | print_string sep_str; |
||

260 | pp_l tl |
||

261 | in |
||

262 | pp_l l; |
||

263 | if (end_str="\n") then |
||

264 | print_newline () |
||

265 | else |
||

266 | print_string end_str |
||

267 | |||

268 | let pp_array a pp_fun beg_str end_str sep_str = |
||

269 | if (beg_str="\n") then |
||

270 | print_newline () |
||

271 | else |
||

272 | print_string beg_str; |
||

273 | let n = Array.length a in |
||

274 | if n > 0 then |
||

275 | begin |
||

276 | Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1)); |
||

277 | pp_fun a.(n-1) |
||

278 | end; |
||

279 | if (end_str="\n") then |
||

280 | print_newline () |
||

281 | else |
||

282 | print_string end_str |
||

283 | |||

284 | let pp_hashtbl t 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 pp_fun1 k v = |
||

290 | pp_fun k v; |
||

291 | if (sep_str="\n") then |
||

292 | print_newline () |
||

293 | else |
||

294 | print_string sep_str |
||

295 | in |
||

296 | hashtbl_iterlast t pp_fun1 pp_fun; |
||

297 | if (end_str="\n") then |
||

298 | print_newline () |
||

299 | else |
||

300 | print_string end_str |
||

301 | |||

302 | let pp_longident lid = |
||

303 | let pp_fun (nid, tag) = |
||

304 | print_string nid; |
||

305 | print_string "("; |
||

306 | print_int tag; |
||

307 | print_string ")" |
||

308 | in |
||

309 | pp_list lid pp_fun "" "." "." |
||

310 | |||

311 | |||

312 | (* Used for uid in variables *) |
||

313 | |||

314 | let var_id_cpt = ref 0 |
||

315 | let get_new_id () = incr var_id_cpt;!var_id_cpt |
||

316 | |||

317 | |||

318 | let track_exception () = |
||

319 | if !Options.track_exceptions |
||

320 | then (Printexc.print_backtrace stdout; flush stdout) |
||

321 | else () |
||

322 | |||

323 | |||

324 | (* for lexing purposes *) |
||

325 | |||

326 | (* Update line number for location info *) |
||

327 | let incr_line lexbuf = |
||

328 | let pos = lexbuf.Lexing.lex_curr_p in |
||

329 | lexbuf.Lexing.lex_curr_p <- { pos with |
||

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

331 | Lexing.pos_bol = pos.Lexing.pos_cnum; |
||

332 | } |
||

333 | |||

334 | |||

335 | let last_tag = ref (-1) |
||

336 | let new_tag () = |
||

337 | incr last_tag; !last_tag |
||

338 | |||

339 | (* Local Variables: *) |
||

340 | (* compile-command:"make -C .." *) |
||

341 | (* End: *) |