Revision ca7ff3f7
Added by LĂ©lio Brun over 1 year ago
src/features/machine_types/machine_types.ml  

3  3 
In each node, node local annotations can specify the actual type of the 
4  4 
implementation uintXX, intXX, floatXX ... 
5  5  
6 
The module provide utility functions to query the model: 

7 
 get_var_machine_type varid nodeid returns the string denoting the actual type 

8  
9 
The actual type is used at different stages of the coompilation 

10 
 early stage: limited typing, ie validity of operation are checked 

11 
 a first version ensures that the actual type is a subtype of the declared/infered ones 

12 
eg uint8 is a valid subtype of int 

13 
 a future implementation could ensures that operations are valid 

14 
 each standard or unspecified operation should be homogeneous : 

15 
op: real > real > real is valid for any same subtype t of real: op: t > t > t 

16 
 specific nodes that explicitely defined subtypes could be used to perform casts 

17 
eg. a int2uint8 (i: int) returns (j: int) with annotations specifying i as int and j as uint8 

18 
 C backend: any print of a typed variable should rely on the actual machine type when provided 

19 
 EMF backend: idem 

20 
 Horn backend: an option could enforce the bounds provided by the machine 

21 
type or implement the cycling behavior for integer subtypes 

22 
 Salsa plugin: the information should be propagated to the plugin. 

23 
One can also imagine that results of the analysis could specify or 

24 
substitute a type by a subtype. Eg. the analysis detects that a float32 is enough for variable z and 

25 
the annotation is added to the node. 

26  
27  
28 
A posisble behavior could be 

29 
 an option to ensure type checking 

30 
 dedicated conversion functions that, in C, would generate cast or calls to simple identity functions (to be inlined) 

31  
32  
33  
34 
TODO 

35 
EMF: rajouter les memoires dans les caracteristiques du node 

36 
gerer les types plus finement: 

37 
propager les types machines aux variables fraiches creees par la normalisation 

38  
39 
*) 

6 
The module provide utility functions to query the model:  

7 
get_var_machine_type varid nodeid returns the string denoting the actual type 

8  
9 
The actual type is used at different stages of the coompilation  early 

10 
stage: limited typing, ie validity of operation are checked  a first version 

11 
ensures that the actual type is a subtype of the declared/infered ones eg 

12 
uint8 is a valid subtype of int  a future implementation could ensures that 

13 
operations are valid  each standard or unspecified operation should be 

14 
homogeneous : op: real > real > real is valid for any same subtype t of 

15 
real: op: t > t > t  specific nodes that explicitely defined subtypes 

16 
could be used to perform casts eg. a int2uint8 (i: int) returns (j: int) with 

17 
annotations specifying i as int and j as uint8  C backend: any print of a 

18 
typed variable should rely on the actual machine type when provided  EMF 

19 
backend: idem  Horn backend: an option could enforce the bounds provided by 

20 
the machine type or implement the cycling behavior for integer subtypes  

21 
Salsa plugin: the information should be propagated to the plugin. One can 

22 
also imagine that results of the analysis could specify or substitute a type 

23 
by a subtype. Eg. the analysis detects that a float32 is enough for variable 

24 
z and the annotation is added to the node. 

25  
26 
A posisble behavior could be  an option to ensure type checking  dedicated 

27 
conversion functions that, in C, would generate cast or calls to simple 

28 
identity functions (to be inlined) 

29  
30 
TODO EMF: rajouter les memoires dans les caracteristiques du node gerer les 

31 
types plus finement: propager les types machines aux variables fraiches 

32 
creees par la normalisation *) 

40  33 
open Lustre_types 
41  34  
42  35 
let is_active = false 
43 


44 
let keyword = ["machine_types"] 

45  36  
46 
module MT = 

47 
struct 

37 
let keyword = [ "machine_types" ] 

48  38  
39 
module MT = struct 

49  40 
type int_typ = 
50  41 
 Tint8_t 
51  42 
 Tint16_t 
...  ...  
58  49  
59  50 
let pp_int fmt t = 
60  51 
match t with 
61 
 Tint8_t > Format.fprintf fmt "int8" 

62 
 Tint16_t > Format.fprintf fmt "int16" 

63 
 Tint32_t > Format.fprintf fmt "int32" 

64 
 Tint64_t > Format.fprintf fmt "int64" 

65 
 Tuint8_t > Format.fprintf fmt "uint8" 

66 
 Tuint16_t > Format.fprintf fmt "uint16" 

67 
 Tuint32_t > Format.fprintf fmt "uint32" 

68 
 Tuint64_t > Format.fprintf fmt "uint64" 

52 
 Tint8_t > 

53 
Format.fprintf fmt "int8" 

54 
 Tint16_t > 

55 
Format.fprintf fmt "int16" 

56 
 Tint32_t > 

57 
Format.fprintf fmt "int32" 

58 
 Tint64_t > 

59 
Format.fprintf fmt "int64" 

60 
 Tuint8_t > 

61 
Format.fprintf fmt "uint8" 

62 
 Tuint16_t > 

63 
Format.fprintf fmt "uint16" 

64 
 Tuint32_t > 

65 
Format.fprintf fmt "uint32" 

66 
 Tuint64_t > 

67 
Format.fprintf fmt "uint64" 

69  68  
70  69 
let pp_c_int fmt t = 
71  70 
match t with 
72 
 Tint8_t > Format.fprintf fmt "int8_t" 

73 
 Tint16_t > Format.fprintf fmt "int16_t" 

74 
 Tint32_t > Format.fprintf fmt "int32_t" 

75 
 Tint64_t > Format.fprintf fmt "int64_t" 

76 
 Tuint8_t > Format.fprintf fmt "uint8_t" 

77 
 Tuint16_t > Format.fprintf fmt "uint16_t" 

78 
 Tuint32_t > Format.fprintf fmt "uint32_t" 

79 
 Tuint64_t > Format.fprintf fmt "uint64_t" 

71 
 Tint8_t > 

72 
Format.fprintf fmt "int8_t" 

73 
 Tint16_t > 

74 
Format.fprintf fmt "int16_t" 

75 
 Tint32_t > 

76 
Format.fprintf fmt "int32_t" 

77 
 Tint64_t > 

78 
Format.fprintf fmt "int64_t" 

79 
 Tuint8_t > 

80 
Format.fprintf fmt "uint8_t" 

81 
 Tuint16_t > 

82 
Format.fprintf fmt "uint16_t" 

83 
 Tuint32_t > 

84 
Format.fprintf fmt "uint32_t" 

85 
 Tuint64_t > 

86 
Format.fprintf fmt "uint64_t" 

80  87  
81  88 
type t = 
82  89 
 MTint of int_typ option 
...  ...  
85  92 
 MTstring 
86  93  
87  94 
open Format 
95  
88  96 
let pp fmt t = 
89  97 
match t with 
90  98 
 MTint None > 
91 
fprintf fmt "int"


99 
fprintf fmt "int" 

92  100 
 MTint (Some s) > 
93 
fprintf fmt "%a" pp_int s


101 
fprintf fmt "%a" pp_int s 

94  102 
 MTreal None > 
95 
fprintf fmt "real"


103 
fprintf fmt "real" 

96  104 
 MTreal (Some s) > 
97 
fprintf fmt "%s" s


105 
fprintf fmt "%s" s 

98  106 
 MTbool > 
99 
fprintf fmt "bool"


107 
fprintf fmt "bool" 

100  108 
 MTstring > 
101 
fprintf fmt "string"


109 
fprintf fmt "string" 

102  110  
103  111 
let pp_c fmt t = 
104  112 
match t with 
105  113 
 MTint (Some s) > 
106 
fprintf fmt "%a" pp_c_int s


114 
fprintf fmt "%a" pp_c_int s 

107  115 
 MTreal (Some s) > 
108 
fprintf fmt "%s" s 

109 
 MTint None 

110 
 MTreal None 

111 
 MTbool 

112 
 MTstring > assert false 

113 


114 


115 
let is_scalar_type t = 

116 
match t with 

117 
 MTbool 

118 
 MTint _ 

119 
 MTreal _ > true 

120 
 _ > false 

116 
fprintf fmt "%s" s 

117 
 MTint None  MTreal None  MTbool  MTstring > 

118 
assert false 

121  119  
120 
let is_scalar_type t = 

121 
match t with MTbool  MTint _  MTreal _ > true  _ > false 

122  122  
123 
let is_numeric_type t = 

124 
match t with 

125 
 MTint _ 

126 
 MTreal _ > true 

127 
 _ > false 

123 
let is_numeric_type t = match t with MTint _  MTreal _ > true  _ > false 

128  124  
129  125 
let is_int_type t = match t with MTint _ > true  _ > false 
126  
130  127 
let is_real_type t = match t with MTreal _ > true  _ > false 
128  
131  129 
let is_bool_type t = t = MTbool 
132 


133 
let is_dimension_type t = 

134 
match t with 

135 
 MTint _ 

136 
 MTbool > true 

137 
 _ > false 

130  
131 
let is_dimension_type t = match t with MTint _  MTbool > true  _ > false 

138  132  
139  133 
let type_int_builder = MTint None 
134  
140  135 
let type_real_builder = MTreal None 
136  
141  137 
let type_bool_builder = MTbool 
138  
142  139 
let type_string_builder = MTstring 
143  140  
144  141 
let unify _ _ = () 
142  
145  143 
let is_unifiable b1 b2 = 
146  144 
match b1, b2 with 
147 
 MTint _ , MTint _


145 
 MTint _, MTint _ 

148  146 
 MTreal _, MTreal _ 
149  147 
 MTstring, MTstring 
150 
 MTbool, MTbool > true 

151 
 _ > false 

148 
 MTbool, MTbool > 

149 
true 

150 
 _ > 

151 
false 

152  152  
153  153 
let is_exportable b = 
154  154 
match b with 
155 
 MTstring 

156 
 MTbool 

157 
 MTreal None 

158 
 MTint None > false 

159 
 _ > true 

155 
 MTstring  MTbool  MTreal None  MTint None > 

156 
false 

157 
 _ > 

158 
true 

160  159 
end 
161  160  
162  161 
module MTypes = Types.Make (MT) 
163  162  
164  163 
let type_uint8 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint8_t))) 
164  
165  165 
let type_uint16 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint16_t))) 
166  
166  167 
let type_uint32 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint32_t))) 
168  
167  169 
let type_uint64 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint64_t))) 
170  
168  171 
let type_int8 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint8_t))) 
172  
169  173 
let type_int16 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint16_t))) 
174  
170  175 
let type_int32 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint32_t))) 
176  
171  177 
let type_int64 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint64_t))) 
172  178  
173 


174 
module ConvTypes = 

175 
struct 

176 
type type_expr = MTypes.type_expr 

177  
178 
let map_type_basic f_basic = 

179 
let rec map_type_basic e = 

180 
{ MTypes.tid = e.Types.tid; 

181 
MTypes.tdesc = map_type_basic_desc (Types.type_desc e) 

182 
} 

183 
and map_type_basic_desc td = 

184 
let mape = map_type_basic in 

185 
match td with 

186 
 Types.Tbasic b > f_basic b 

187 
 Types.Tconst c > MTypes.Tconst c 

188 
 Types.Tenum e > MTypes.Tenum e 

189 
 Types.Tvar > MTypes.Tvar 

190 
 Types.Tunivar > MTypes.Tunivar 

191 


192 
 Types.Tclock te > MTypes.Tclock (mape te) 

193 
 Types.Tarrow (te1, te2) > MTypes.Tarrow (mape te1, mape te2) 

194 
 Types.Ttuple tel > MTypes.Ttuple (List.map mape tel) 

195 
 Types.Tstruct id_te_l > MTypes.Tstruct (List.map (fun (id, te) > id, mape te) id_te_l) 

196 
 Types.Tarray (de, te) > MTypes.Tarray (de, mape te) 

197 
 Types.Tstatic (de, te) > MTypes.Tstatic (de, mape te) 

198 
 Types.Tlink te > MTypes.Tlink (mape te) 

199 
in 

200 
map_type_basic 

201 


202 
let import main_typ = 

203 
let import_basic b = 

204 
if Types.BasicT.is_int_type b then MTypes.type_int else 

205 
if Types.BasicT.is_real_type b then MTypes.type_real else 

206 
if Types.BasicT.is_bool_type b then MTypes.type_bool else 

207 
(Format.eprintf "importing %a with issues!@.@?" Types.print_ty main_typ; assert false) 

208 
in 

209 
map_type_basic import_basic main_typ 

210  
211 


212 
let map_mtype_basic f_basic = 

213 
let rec map_mtype_basic e = 

214 
{ Types.tid = e.MTypes.tid; 

215 
Types.tdesc = map_mtype_basic_desc (MTypes.type_desc e) 

216 
} 

217 
and map_mtype_basic_desc td = 

218 
let mape = map_mtype_basic in 

219 
match td with 

220 
 MTypes.Tbasic b > 

221 
(* Format.eprintf "supposely basic mtype: %a@." MTypes.BasicT.pp b; *) 

222 
f_basic b 

223 
 MTypes.Tconst c > Types.Tconst c 

224 
 MTypes.Tenum e > Types.Tenum e 

225 
 MTypes.Tvar > Types.Tvar 

226 
 MTypes.Tunivar > Types.Tunivar 

227 


228 
 MTypes.Tclock te > Types.Tclock (mape te) 

229 
 MTypes.Tarrow (te1, te2) > Types.Tarrow (mape te1, mape te2) 

230 
 MTypes.Ttuple tel > Types.Ttuple (List.map mape tel) 

231 
 MTypes.Tstruct id_te_l > Types.Tstruct (List.map (fun (id, te) > id, mape te) id_te_l) 

232 
 MTypes.Tarray (de, te) > Types.Tarray (de, mape te) 

233 
 MTypes.Tstatic (de, te) > Types.Tstatic (de, mape te) 

234 
 MTypes.Tlink te > Types.Tlink (mape te) 

235 
in 

236 
map_mtype_basic 

237 


238 
let export machine_type = 

239 
let export_basic b = 

240 
if MTypes.BasicT.is_int_type b then Types.type_int else 

241 
if MTypes.BasicT.is_real_type b then Types.type_real else 

242 
if MTypes.BasicT.is_bool_type b then Types.type_bool else 

243 
( 

244 
Format.eprintf "unhandled basic mtype is %a. Issues while dealing with basic type %a@.@?" MTypes.print_ty machine_type MTypes.BasicT.pp b; 

245 
assert false 

246 
) 

247 
in 

248 
map_mtype_basic export_basic machine_type 

249  
250 
end 

179 
module ConvTypes = struct 

180 
type type_expr = MTypes.type_expr 

181  
182 
let map_type_basic f_basic = 

183 
let rec map_type_basic e = 

184 
{ 

185 
MTypes.tid = e.Types.tid; 

186 
MTypes.tdesc = map_type_basic_desc (Types.type_desc e); 

187 
} 

188 
and map_type_basic_desc td = 

189 
let mape = map_type_basic in 

190 
match td with 

191 
 Types.Tbasic b > 

192 
f_basic b 

193 
 Types.Tconst c > 

194 
MTypes.Tconst c 

195 
 Types.Tenum e > 

196 
MTypes.Tenum e 

197 
 Types.Tvar > 

198 
MTypes.Tvar 

199 
 Types.Tunivar > 

200 
MTypes.Tunivar 

201 
 Types.Tclock te > 

202 
MTypes.Tclock (mape te) 

203 
 Types.Tarrow (te1, te2) > 

204 
MTypes.Tarrow (mape te1, mape te2) 

205 
 Types.Ttuple tel > 

206 
MTypes.Ttuple (List.map mape tel) 

207 
 Types.Tstruct id_te_l > 

208 
MTypes.Tstruct (List.map (fun (id, te) > id, mape te) id_te_l) 

209 
 Types.Tarray (de, te) > 

210 
MTypes.Tarray (de, mape te) 

211 
 Types.Tstatic (de, te) > 

212 
MTypes.Tstatic (de, mape te) 

213 
 Types.Tlink te > 

214 
MTypes.Tlink (mape te) 

215 
in 

216 
map_type_basic 

217  
218 
let import main_typ = 

219 
let import_basic b = 

220 
if Types.BasicT.is_int_type b then MTypes.type_int 

221 
else if Types.BasicT.is_real_type b then MTypes.type_real 

222 
else if Types.BasicT.is_bool_type b then MTypes.type_bool 

223 
else ( 

224 
Format.eprintf "importing %a with issues!@.@?" Types.print_ty main_typ; 

225 
assert false) 

226 
in 

227 
map_type_basic import_basic main_typ 

228  
229 
let map_mtype_basic f_basic = 

230 
let rec map_mtype_basic e = 

231 
{ 

232 
Types.tid = e.MTypes.tid; 

233 
Types.tdesc = map_mtype_basic_desc (MTypes.type_desc e); 

234 
} 

235 
and map_mtype_basic_desc td = 

236 
let mape = map_mtype_basic in 

237 
match td with 

238 
 MTypes.Tbasic b > 

239 
(* Format.eprintf "supposely basic mtype: %a@." MTypes.BasicT.pp b; *) 

240 
f_basic b 

241 
 MTypes.Tconst c > 

242 
Types.Tconst c 

243 
 MTypes.Tenum e > 

244 
Types.Tenum e 

245 
 MTypes.Tvar > 

246 
Types.Tvar 

247 
 MTypes.Tunivar > 

248 
Types.Tunivar 

249 
 MTypes.Tclock te > 

250 
Types.Tclock (mape te) 

251 
 MTypes.Tarrow (te1, te2) > 

252 
Types.Tarrow (mape te1, mape te2) 

253 
 MTypes.Ttuple tel > 

254 
Types.Ttuple (List.map mape tel) 

255 
 MTypes.Tstruct id_te_l > 

256 
Types.Tstruct (List.map (fun (id, te) > id, mape te) id_te_l) 

257 
 MTypes.Tarray (de, te) > 

258 
Types.Tarray (de, mape te) 

259 
 MTypes.Tstatic (de, te) > 

260 
Types.Tstatic (de, mape te) 

261 
 MTypes.Tlink te > 

262 
Types.Tlink (mape te) 

263 
in 

264 
map_mtype_basic 

265  
266 
let export machine_type = 

267 
let export_basic b = 

268 
if MTypes.BasicT.is_int_type b then Types.type_int 

269 
else if MTypes.BasicT.is_real_type b then Types.type_real 

270 
else if MTypes.BasicT.is_bool_type b then Types.type_bool 

271 
else ( 

272 
Format.eprintf 

273 
"unhandled basic mtype is %a. Issues while dealing with basic type \ 

274 
%a@.@?" 

275 
MTypes.print_ty machine_type MTypes.BasicT.pp b; 

276 
assert false) 

277 
in 

278 
map_mtype_basic export_basic machine_type 

279 
end 

251  280  
252  281 
module Typing = Typing.Make (MTypes) (ConvTypes) 
253 


282  
254  283 
(* Associate to each (node_id, var_id) its machine type *) 
255 
let machine_type_table : (var_decl, MTypes.type_expr) Hashtbl.t = Hashtbl.create 13 

284 
let machine_type_table : (var_decl, MTypes.type_expr) Hashtbl.t = 

285 
Hashtbl.create 13 

256  286  
257  287 
(* Store the node signatures, with machine types when available *) 
258  288 
let typing_env = ref Env.initial 
259 


289  
260  290 
let is_specified v = 
261  291 
(* Format.eprintf "looking for var %a@." Printers.pp_var v; *) 
262  292 
Hashtbl.mem machine_type_table v 
...  ...  
264  294 
let pp_table fmt = 
265  295 
Format.fprintf fmt "@[<v 0>["; 
266  296 
Hashtbl.iter 
267 
(fun v typ > Format.fprintf fmt "%a > %a,@ " Printers.pp_var v MTypes.print_ty typ ) 

297 
(fun v typ > 

298 
Format.fprintf fmt "%a > %a,@ " Printers.pp_var v MTypes.print_ty typ) 

268  299 
machine_type_table; 
269  300 
Format.fprintf fmt "@]" 
270  301  
271 


272  302 
let get_specified_type v = 
273  303 
(* Format.eprintf "Looking for variable %a in table [%t]@.@?" *) 
274  304 
(* Printers.pp_var v *) 
275  305 
(* pp_table; *) 
276 
Hashtbl.find machine_type_table v


306 
Hashtbl.find machine_type_table v 

277  307  
278  308 
let is_exportable v = 
279 
is_specified v && ( 

280 
let typ = get_specified_type v in 

281 
match (MTypes.dynamic_type typ).MTypes.tdesc with 

282 
 MTypes.Tbasic b > MT.is_exportable b 

283 
 MTypes.Tconst _ > false (* Enumerated types are not "machine type" customizeable *) 

284 
 _ > assert false (* TODO deal with other constructs *) 

285 
) 

309 
is_specified v 

310 
&& 

311 
let typ = get_specified_type v in 

312 
match (MTypes.dynamic_type typ).MTypes.tdesc with 

313 
 MTypes.Tbasic b > 

314 
MT.is_exportable b 

315 
 MTypes.Tconst _ > 

316 
false (* Enumerated types are not "machine type" customizeable *) 

317 
 _ > 

318 
assert false 

319  
320 
(* TODO deal with other constructs *) 

286  321 
(* could depend on the actual computed type *) 
287  322  
288 
let type_name typ =


323 
let type_name typ = 

289  324 
MTypes.print_ty Format.str_formatter typ; 
290 
Format.flush_str_formatter ()


325 
Format.flush_str_formatter () 

291  326  
292  327 
let pp_var_type fmt v = 
293  328 
let typ = get_specified_type v in 
...  ...  
296  331 
let pp_c_var_type fmt v = 
297  332 
let typ = get_specified_type v in 
298  333 
MTypes.print_ty_param MT.pp_c fmt typ 
299 


334  
300  335 
(************** Checking types ******************) 
301 


336  
302  337 
let erroneous_annotation loc = 
303  338 
Format.eprintf "Invalid annotation for machine_type at loc %a@." 
304  339 
Location.pp_loc loc; 
305  340 
assert false 
306  341  
307  
308  342 
let valid_subtype subtype typ = 
309  343 
let mismatch subtyp typ = 
310 
Format.eprintf "Subtype mismatch %a vs %a@." MTypes.print_ty subtyp Types.print_ty typ; false 

344 
Format.eprintf "Subtype mismatch %a vs %a@." MTypes.print_ty subtyp 

345 
Types.print_ty typ; 

346 
false 

311  347 
in 
312  348 
match (MTypes.dynamic_type subtype).MTypes.tdesc with 
313 
 MTypes.Tconst c > Types.is_const_type typ c 

314 
 MTypes.Tbasic MT.MTint _ > Types.is_int_type typ 

315 
 MTypes.Tbasic MT.MTreal _ > Types.is_real_type typ 

316 
 MTypes.Tbasic MT.MTbool > Types.is_bool_type typ 

317 
 _ > mismatch subtype typ 

318 


349 
 MTypes.Tconst c > 

350 
Types.is_const_type typ c 

351 
 MTypes.Tbasic (MT.MTint _) > 

352 
Types.is_int_type typ 

353 
 MTypes.Tbasic (MT.MTreal _) > 

354 
Types.is_real_type typ 

355 
 MTypes.Tbasic MT.MTbool > 

356 
Types.is_bool_type typ 

357 
 _ > 

358 
mismatch subtype typ 

359  
319  360 
let type_of_name name = 
320  361 
match name with 
321 
 "uint8" > type_uint8 

322 
 "uint16" > type_uint16 

323 
 "uint32" > type_uint32 

324 
 "uint64" > type_uint64 

325 
 "int8" > type_int8 

326 
 "int16" > type_int16 

327 
 "int32" > type_int32 

328 
 "int64" > type_int64 

329 
 _ > assert false (* unknown custom machine type *) 

330 


362 
 "uint8" > 

363 
type_uint8 

364 
 "uint16" > 

365 
type_uint16 

366 
 "uint32" > 

367 
type_uint32 

368 
 "uint64" > 

369 
type_uint64 

370 
 "int8" > 

371 
type_int8 

372 
 "int16" > 

373 
type_int16 

374 
 "int32" > 

375 
type_int32 

376 
 "int64" > 

377 
type_int64 

378 
 _ > 

379 
assert false 

380 
(* unknown custom machine type *) 

381  
331  382 
let register_var var typ = 
332  383 
(* let typ = type_of_name type_name in *) 
333 
if valid_subtype typ var.var_type then ( 

334 
Hashtbl.add machine_type_table var typ 

335 
) 

336 
else 

337 
erroneous_annotation var.var_loc 

338 


384 
if valid_subtype typ var.var_type then Hashtbl.add machine_type_table var typ 

385 
else erroneous_annotation var.var_loc 

386  
339  387 
(* let register_var_opt var type_name_opt = *) 
340  388 
(* match type_name_opt with *) 
341  389 
(*  None > () *) 
342  390 
(*  Some type_name > register_var var type_name *) 
343 


391  
344  392 
(************** Registering annotations ******************) 
345  393  
346 


347  394 
let register_node vars annots = 
348 
List.fold_left (fun accu annot > 

349 
let annl = annot.annots in 

350 
List.fold_left (fun accu (kwd, value) > 

351 
if kwd = keyword then 

352 
let expr = value.eexpr_qfexpr in 

353 
match Corelang.expr_list_of_expr expr with 

354 
 [var_id; type_name] > ( 

355 
match var_id.expr_desc, type_name.expr_desc with 

356 
 Expr_ident var_id, Expr_const (Const_string type_name) > 

357 
let var = List.find (fun v > v.var_id = var_id) vars in 

358 
Log.report ~level:2 (fun fmt > 

359 
Format.fprintf fmt "Recorded type %s for variable %a (parent node is %s)@ " 

360 
type_name 

361 
Printers.pp_var var 

362 
(match var.var_parent_nodeid with Some id > id  None > "unknown") 

363 
); 

364 
let typ = type_of_name type_name in 

365 
register_var var typ; 

366 
var::accu 

367 
 _ > erroneous_annotation expr.expr_loc 

368 
) 

369 
 _ > erroneous_annotation expr.expr_loc 

370 
else 

371 
accu 

372 
) accu annl 

373 
) [] annots 

374  
395 
List.fold_left 

396 
(fun accu annot > 

397 
let annl = annot.annots in 

398 
List.fold_left 

399 
(fun accu (kwd, value) > 

400 
if kwd = keyword then 

401 
let expr = value.eexpr_qfexpr in 

402 
match Corelang.expr_list_of_expr expr with 

403 
 [ var_id; type_name ] > ( 

404 
match var_id.expr_desc, type_name.expr_desc with 

405 
 Expr_ident var_id, Expr_const (Const_string type_name) > 

406 
let var = List.find (fun v > v.var_id = var_id) vars in 

407 
Log.report ~level:2 (fun fmt > 

408 
Format.fprintf fmt 

409 
"Recorded type %s for variable %a (parent node is %s)@ " 

410 
type_name Printers.pp_var var 

411 
(match var.var_parent_nodeid with 

412 
 Some id > 

413 
id 

414 
 None > 

415 
"unknown")); 

416 
let typ = type_of_name type_name in 

417 
register_var var typ; 

418 
var :: accu 

419 
 _ > 

420 
erroneous_annotation expr.expr_loc) 

421 
 _ > 

422 
erroneous_annotation expr.expr_loc 

423 
else accu) 

424 
accu annl) 

425 
[] annots 

375  426  
376  427 
let check_node nd vars = 
377 
(* TODO check that all access to vars are valid *) 

428 
(* TODO check that all access to vars are valid *)


378  429 
() 
379 


430  
380  431 
let type_of_vlist vars = 
381 
let tyl = List.map (fun v > if is_specified v then get_specified_type v else 

382 
ConvTypes.import v.var_type 

383 
) vars in 

432 
let tyl = 

433 
List.map 

434 
(fun v > 

435 
if is_specified v then get_specified_type v 

436 
else ConvTypes.import v.var_type) 

437 
vars 

438 
in 

384  439 
MTypes.type_of_type_list tyl 
385  440  
386 


387  441 
let load prog = 
388  442 
let init_env = 
389 
Env.fold (fun id typ env >


390 
Env.add_value env id (ConvTypes.import typ)


391 
)


392 
Basic_library.type_env Env.initial in


443 
Env.fold 

444 
(fun id typ env > Env.add_value env id (ConvTypes.import typ))


445 
Basic_library.type_env Env.initial


446 
in 

393  447 
let env = 
394 
List.fold_left (fun type_env top > 

395 
match top.top_decl_desc with 

396 
 Node nd > 

397 
(* Format.eprintf "Registeing node %s@." nd.node_id; *) 

398 
let vars = nd.node_inputs @ nd.node_outputs @ nd.node_locals in 

399 
let constrained_vars = register_node vars nd.node_annot in 

400 
check_node nd constrained_vars; 

401  
402 
(* Computing the node type *) 

403 
let ty_ins = type_of_vlist nd.node_inputs in 

404 
let ty_outs = type_of_vlist nd.node_outputs in 

405 
let ty_node = MTypes.new_ty (MTypes.Tarrow (ty_ins,ty_outs)) in 

406 
Typing.generalize ty_node; 

407 
let env = Env.add_value type_env nd.node_id ty_node in 

408 
(* Format.eprintf "Env: %a" (Env.pp_env MTypes.print_ty) env; *) 

409 
env 

410  
411 
 _ > type_env 

412 
(*  ImportedNode ind > *) 

413 
(* let vars = ind.nodei_inputs @ ind.nodei_outputs in *) 

414 
(* register_node ind.nodei_id vars ind.nodei_annot *) 

415 
(*  _ > () TODO: shall we load something for Open statements? *) 

416 
) init_env prog 

448 
List.fold_left 

449 
(fun type_env top > 

450 
match top.top_decl_desc with 

451 
 Node nd > 

452 
(* Format.eprintf "Registeing node %s@." nd.node_id; *) 

453 
let vars = nd.node_inputs @ nd.node_outputs @ nd.node_locals in 

454 
let constrained_vars = register_node vars nd.node_annot in 

455 
check_node nd constrained_vars; 

456  
457 
(* Computing the node type *) 

458 
let ty_ins = type_of_vlist nd.node_inputs in 

459 
let ty_outs = type_of_vlist nd.node_outputs in 

460 
let ty_node = MTypes.new_ty (MTypes.Tarrow (ty_ins, ty_outs)) in 

461 
Typing.generalize ty_node; 

462 
let env = Env.add_value type_env nd.node_id ty_node in 

463 
(* Format.eprintf "Env: %a" (Env.pp_env MTypes.print_ty) env; *) 

464 
env 

465 
 _ > 

466 
type_env 

467 
(*  ImportedNode ind > *) 

468 
(* let vars = ind.nodei_inputs @ ind.nodei_outputs in *) 

469 
(* register_node ind.nodei_id vars ind.nodei_annot *) 

470 
(*  _ > () TODO: shall we load something for Open statements? *)) 

471 
init_env prog 

417  472 
in 
418  473 
typing_env := env 
419  474  
...  ...  
421  476 
let init_env = !typing_env in 
422  477 
(* Format.eprintf "Init env: %a@." (Env.pp_env MTypes.print_ty) init_env; *) 
423  478 
(* Rebuilding the variables environment from accumulated knowledge *) 
424 
let env,vars = (* First, we add non specified variables *) 

425 
List.fold_left (fun (env, vars) v > 

426 
if not (is_specified v) then 

427 
let env = Env.add_value env v.var_id (ConvTypes.import v.var_type) in 

428 
env, v::vars 

429 
else 

430 
env, vars 

431 
) (init_env, []) init_vars 

479 
let env, vars = 

480 
(* First, we add non specified variables *) 

481 
List.fold_left 

482 
(fun (env, vars) v > 

483 
if not (is_specified v) then 

484 
let env = Env.add_value env v.var_id (ConvTypes.import v.var_type) in 

485 
env, v :: vars 

486 
else env, vars) 

487 
(init_env, []) init_vars 

432  488 
in 
433 


489  
434  490 
(* Then declared ones *) 
435  491 
let env, vars = 
436 
Hashtbl.fold (fun vdecl machine_type (env, vds) >


437 
if vdecl.var_parent_nodeid = Some parentid then (


438 
(* Format.eprintf "Adding variable %a to the environement@.@?" Printers.pp_var vdecl; *)


439 
let env = Env.add_value env vdecl.var_id machine_type in


440 
env, vdecl::vds


441 
)


442 
else


443 
env, vds


444 
) machine_type_table (env, vars)


492 
Hashtbl.fold 

493 
(fun vdecl machine_type (env, vds) >


494 
if vdecl.var_parent_nodeid = Some parentid then


495 
(* Format.eprintf "Adding variable %a to the environement@.@?"


496 
Printers.pp_var vdecl; *)


497 
let env = Env.add_value env vdecl.var_id machine_type in


498 
env, vdecl :: vds


499 
else env, vds)


500 
machine_type_table (env, vars)


445  501 
in 
446  502  
447 


448 
(* Format.eprintf "env with local vars: %a@." (Env.pp_env MTypes.print_ty) env; *)


503 
(* Format.eprintf "env with local vars: %a@." (Env.pp_env MTypes.print_ty) 

504 
env; *)


449  505 
(* Format.eprintf "expr = %a@." Printers.pp_expr expr; *) 
450  506 
(* let res = *) 
451 
Typing.type_expr 

452 
(env,vars) 

453 
false (* not in main node *) 

454 
false (* no a constant *) 

455 
expr 

456 
(* in *) 

457 
(* Format.eprintf "typing ok = %a@." MTypes.print_ty res; *) 

458 
(* res *) 

459 


460 
(* Typing the expression (vars = expr) in node 

461 


462 
*) 

507 
Typing.type_expr (env, vars) false (* not in main node *) false 

508 
(* no a constant *) expr 

509  
510 
(* in *) 

511 
(* Format.eprintf "typing ok = %a@." MTypes.print_ty res; *) 

512 
(* res *) 

513  
514 
(* Typing the expression (vars = expr) in node *) 

463  515 
let type_def node vars expr = 
464  516 
(* Format.eprintf "Typing def %a = %a@.@." *) 
465  517 
(* (Utils.fprintf_list ~sep:", " Printers.pp_var) vars *) 
466  518 
(* Printers.pp_expr expr *) 
467  519 
(* ; *) 
468 
let typ = type_expr node expr in


469 
(* Format.eprintf "Type is %a. Saving stuff@.@." MTypes.print_ty typ; *)


470 
let typ = MTypes.type_list_of_type typ in


471 
List.iter2 register_var vars typ


520 
let typ = type_expr node expr in 

521 
(* Format.eprintf "Type is %a. Saving stuff@.@." MTypes.print_ty typ; *) 

522 
let typ = MTypes.type_list_of_type typ in


523 
List.iter2 register_var vars typ


472  524  
473  525 
let has_machine_type () = 
474  526 
let annl = Annotations.get_expr_annotations keyword in 
475  527 
(* Format.eprintf "has _mchine _type annotations: %i@." (List.length annl); *) 
476  528 
List.length annl > 0 
477 


529  
478  530 
(* Local Variables: *) 
479  531 
(* compilecommand:"make C ../.." *) 
480  532 
(* End: *) 
481 
Also available in: Unified diff
reformatting