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


23

(** Types definitions and a few utility functions on types. *)

24

open Utils

25

open Dimension

26


27

type type_expr =

28

{mutable tdesc: type_desc;

29

tid: int}

30


31

and type_desc =

32

 Tconst of ident (* type constant *)

33

 Tint

34

 Treal

35

 Tbool

36

 Trat (* Actually unused for now. Only place where it can appear is

37

in a clock declaration *)

38

 Tclock of type_expr (* An type expression explicitely tagged as carrying a clock *)

39

 Tarrow of type_expr * type_expr

40

 Ttuple of type_expr list

41

 Tenum of ident list

42

 Tarray of dim_expr * type_expr

43

 Tstatic of dim_expr * type_expr (* a type carried by a dimension expression *)

44

 Tlink of type_expr (* During unification, make links instead of substitutions *)

45

 Tvar (* Monomorphic type variable *)

46

 Tunivar (* Polymorphic type variable *)

47


48

type error =

49

Unbound_value of ident

50

 Already_bound of ident

51

 Already_defined of ident

52

 Undefined_var of (unit IMap.t)

53

 Unbound_type of ident

54

 Not_a_dimension

55

 Not_a_constant

56

 WrongArity of int * int

57

 Type_clash of type_expr * type_expr

58

 Poly_imported_node of ident

59


60

exception Unify of type_expr * type_expr

61

exception Error of Location.t * error

62


63

(* Prettyprint*)

64

open Format

65


66

let rec print_ty fmt ty =

67

match ty.tdesc with

68

 Tvar >

69

fprintf fmt "_%s" (name_of_type ty.tid)

70

 Tint >

71

fprintf fmt "int"

72

 Treal >

73

fprintf fmt "real"

74

 Tbool >

75

fprintf fmt "bool"

76

 Tclock t >

77

fprintf fmt "%a clock" print_ty t

78

 Tstatic (d, t) >

79

fprintf fmt "(%a:%a)" Dimension.pp_dimension d print_ty t

80

 Tconst t >

81

fprintf fmt "%s" t

82

 Trat >

83

fprintf fmt "rat"

84

 Tarrow (ty1,ty2) >

85

fprintf fmt "%a>%a" print_ty ty1 print_ty ty2

86

 Ttuple tylist >

87

fprintf fmt "(%a)"

88

(Utils.fprintf_list ~sep:"*" print_ty) tylist

89

 Tenum taglist >

90

fprintf fmt "(%a)"

91

(Utils.fprintf_list ~sep:" + " pp_print_string) taglist

92

 Tarray (e, ty) >

93

fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e

94

 Tlink ty >

95

print_ty fmt ty

96

 Tunivar >

97

fprintf fmt "'%s" (name_of_type ty.tid)

98


99

let rec print_node_ty fmt ty =

100

match ty.tdesc with

101

 Tint >

102

fprintf fmt "int"

103

 Treal >

104

fprintf fmt "real"

105

 Tbool >

106

fprintf fmt "bool"

107

 Tclock t >

108

fprintf fmt "%a clock" print_ty t

109

 Tstatic (_, t) >

110

fprintf fmt "%a" print_node_ty t

111

 Tconst t >

112

fprintf fmt "%s" t

113

 Trat >

114

fprintf fmt "rat"

115

 Tarrow (ty1,ty2) >

116

fprintf fmt "%a>%a" print_ty ty1 print_ty ty2

117

 Ttuple tylist >

118

fprintf fmt "(%a)"

119

(Utils.fprintf_list ~sep:"*" print_ty) tylist

120

 Tenum taglist >

121

fprintf fmt "(%a)"

122

(Utils.fprintf_list ~sep:" + " pp_print_string) taglist

123

 Tarray (e, ty) >

124

fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e

125

 Tlink ty >

126

print_ty fmt ty

127

 Tunivar >

128

fprintf fmt "'%s" (name_of_type ty.tid)

129

 _ > assert false

130


131

let pp_error fmt = function

132

 Unbound_value id >

133

fprintf fmt "Unknown value %s@." id

134

 Unbound_type id >

135

fprintf fmt "Unknown type %s@." id

136

 Already_bound id >

137

fprintf fmt "%s is already declared@." id

138

 Already_defined id >

139

fprintf fmt "Multiple definitions of variable %s@." id

140

 Not_a_constant >

141

fprintf fmt "This expression is not a constant@."

142

 Not_a_dimension >

143

fprintf fmt "This expression is not a valid dimension@."

144

 WrongArity (ar1, ar2) >

145

fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2

146

 Undefined_var vmap >

147

fprintf fmt "No definition provided for variable(s): %a@."

148

(Utils.fprintf_list ~sep:"," pp_print_string)

149

(fst (Utils.list_of_imap vmap))

150

 Type_clash (ty1,ty2) >

151

Utils.reset_names ();

152

fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2

153

 Poly_imported_node id >

154

fprintf fmt "Imported nodes cannot have a polymorphic type@."

155


156


157

let new_id = ref (1)

158


159

let new_ty desc =

160

incr new_id; {tdesc = desc; tid = !new_id }

161


162

let new_var () =

163

new_ty Tvar

164


165

let new_univar () =

166

new_ty Tunivar

167


168

let rec repr =

169

function

170

{tdesc = Tlink t'} >

171

repr t'

172

 t > t

173


174

let get_static_value ty =

175

match (repr ty).tdesc with

176

 Tstatic (d, _) > Some d

177

 _ > None

178


179

let rec is_dimension_type ty =

180

match (repr ty).tdesc with

181

 Tint

182

 Tbool > true

183

 Tclock ty'

184

 Tstatic (_, ty') > is_dimension_type ty'

185

 _ > false

186


187

let rec dynamic_type ty =

188

let ty = repr ty in

189

match ty.tdesc with

190

 Tstatic (_, ty') > ty'

191

 _ > ty

192


193

let map_tuple_type f ty =

194

let ty = dynamic_type ty in

195

match ty.tdesc with

196

 (Ttuple ty_list) > { ty with tdesc = Ttuple (List.map f ty_list) }

197

 _ > f ty

198

let rec is_array_type ty =

199

match (repr ty).tdesc with

200

 Tarray _ > true

201

 Tstatic (_, ty') > is_array_type ty'

202

 _ > false

203


204

let array_type_dimension ty =

205

match (dynamic_type ty).tdesc with

206

 Tarray (d, _) > d

207

 _ > assert false

208


209

let rec array_type_multi_dimension ty =

210

match (dynamic_type ty).tdesc with

211

 Tarray (d, ty') > d :: array_type_multi_dimension ty'

212

 _ > []

213


214

let array_element_type ty =

215

match (dynamic_type ty).tdesc with

216

 Tarray (_, ty') > ty'

217

 _ > assert false

218


219

let rec array_base_type ty =

220

let ty = repr ty in

221

match ty.tdesc with

222

 Tarray (_, ty')

223

 Tstatic (_, ty') > array_base_type ty'

224

 _ > ty

225


226

let rec is_generic_type ty =

227

match (dynamic_type ty).tdesc with

228

 Tarray (d, ty') >

229

(not (Dimension.is_dimension_const d))  (is_generic_type ty')

230

 _ > false

231


232

(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type

233

(ensured by language syntax) *)

234

let rec split_arrow ty =

235

match (repr ty).tdesc with

236

 Tarrow (tin,tout) > tin,tout

237

 Tstatic (_, ty') > split_arrow ty'

238

(* Functions are not first order, I don't think the var case

239

needs to be considered here *)

240

 _ > Format.eprintf "%a@." print_ty ty; assert false

241


242

(** Returns the type corresponding to a type list. *)

243

let type_of_type_list tyl =

244

if (List.length tyl) > 1 then

245

new_ty (Ttuple tyl)

246

else

247

List.hd tyl

248


249

let type_list_of_type ty =

250

match (repr ty).tdesc with

251

 Ttuple tl > tl

252

 _ > [ty]

253


254

(** [is_polymorphic ty] returns true if [ty] is polymorphic. *)

255

let rec is_polymorphic ty =

256

match ty.tdesc with

257

 Tenum _  Tvar  Tint  Treal  Tbool  Trat  Tconst _ > false

258

 Tclock ty > is_polymorphic ty

259

 Tarrow (ty1,ty2) > (is_polymorphic ty1)  (is_polymorphic ty2)

260

 Ttuple tl > List.exists (fun t > is_polymorphic t) tl

261

 Tlink t' > is_polymorphic t'

262

 Tarray (d, ty)

263

 Tstatic (d, ty) > Dimension.is_polymorphic d  is_polymorphic ty

264

 Tunivar > true

265


266


267

let mktyptuple nb typ =

268

let array = Array.make nb typ in

269

Ttuple (Array.to_list array)

270


271


272

(* Local Variables: *)

273

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

274

(* End: *)
