type_io.icl 14.3 KB
Newer Older
1
2
3
/*
	module owner: Martijn Vervoort
*/
4
5
implementation module type_io

Martijn Vervoort's avatar
Martijn Vervoort committed
6
import StdEnv, compare_constructor
7
import scanner, general, Heap, typeproperties, utilities, checksupport
8
import trans
Martijn Vervoort's avatar
Martijn Vervoort committed
9
import type_io_common
John van Groningen's avatar
John van Groningen committed
10
from genericsupport import kind_to_short_string
11

Martijn Vervoort's avatar
Martijn Vervoort committed
12
13
14
15
16
17
// normal form:
// -	type variables in type definitions are normalized by checkTypeDef in the
//		module checktypes.icl. The position of a type variable in the left-hand
//		side of a type constructor is used.
// -	algebraic datatypes; constructors are alphabetically ordered in this 
//		module
18
//
Martijn Vervoort's avatar
Martijn Vervoort committed
19
20
// unsupported:
// - 	ADTs
21

22
:: WriteTypeInfoState
23
24
25
26
27
28
	= {	wtis_n_type_vars		:: !Int
	,	wtis_common_defs		:: !{#CommonDefs}	
	,	wtis_type_defs			:: !.{#{#CheckedTypeDef}}
	,	wtis_type_heaps			:: !.TypeHeaps
	,	wtis_var_heap			:: !.VarHeap
	,	wtis_main_dcl_module_n	:: !Int
John van Groningen's avatar
John van Groningen committed
29
	,	wtis_icl_generic_defs	:: !{#GenericDef}
30
	};
John van Groningen's avatar
John van Groningen committed
31
32
33
34
35
36
37
38

write_type_info_of_types_and_constructors :: !CommonDefs !Int !Int !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
write_type_info_of_types_and_constructors {com_type_defs,com_cons_defs} n_types_with_type_functions n_constructors_with_type_functions tcl_file wtis
	# tcl_file = fwritei n_types_with_type_functions tcl_file
	# (tcl_file,wtis) = write_type_info_of_array 0 n_types_with_type_functions com_type_defs tcl_file wtis
	# tcl_file = fwritei n_constructors_with_type_functions tcl_file
	= write_type_info_of_array 0 n_constructors_with_type_functions com_cons_defs tcl_file wtis

39
40
class WriteTypeInfo a 
where
41
	write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
42

43
instance WriteTypeInfo ConsDef
44
where
45
	write_type_info {cons_ident,cons_type,cons_type_index,cons_exi_vars} tcl_file wtis=:{wtis_n_type_vars}
46
47
48
49
 		// normalize ...
 		# (th_vars,wtis)
 			= sel_type_var_heap wtis
 		# (_,(_,th_vars))
John van Groningen's avatar
John van Groningen committed
50
			= mapSt normalize_atype_var cons_exi_vars (wtis_n_type_vars,th_vars)
51
  		# wtis = { wtis & wtis_type_heaps.th_vars = th_vars }
52
53
 		// ... normalize
		# (tcl_file,wtis)
54
			= write_type_info cons_ident tcl_file wtis
55
		# (tcl_file,wtis)
56
			= write_type_info cons_type tcl_file wtis						
57
58
59
60
61
		# (tcl_file,wtis)
			= write_type_info cons_type_index tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info cons_exi_vars tcl_file wtis
		= (tcl_file,wtis)
John van Groningen's avatar
John van Groningen committed
62

63
instance WriteTypeInfo (TypeDef TypeRhs)
64
where 
John van Groningen's avatar
John van Groningen committed
65
	write_type_info {td_ident,td_arity,td_args,td_rhs,td_fun_index} tcl_file wtis
66
67
68
69
		// normalize ...
 		# (th_vars,wtis)
 			= sel_type_var_heap wtis
 		# (_,(n_type_vars,th_vars))
John van Groningen's avatar
John van Groningen committed
70
			= mapSt normalize_atype_var td_args (0,th_vars)
71
  		# wtis = { wtis & wtis_type_heaps.th_vars = th_vars, wtis_n_type_vars = n_type_vars }
72
73
 		// ... normalize
 		# (tcl_file,wtis)
74
 			= write_type_info td_ident tcl_file wtis
75
		# (tcl_file,wtis)
76
 			= write_type_info td_arity tcl_file wtis
77
 		# (tcl_file,wtis)
78
 			= write_type_info td_args tcl_file wtis
John van Groningen's avatar
John van Groningen committed
79
		| td_fun_index<>NoIndex
80
 			= write_type_info td_rhs tcl_file wtis
John van Groningen's avatar
John van Groningen committed
81
82
83
84
85
86
87
88
89
90
91
92
93
94
 			// currently not used
			# (RecordType {rt_constructor,rt_fields}) = td_rhs
			  tcl_file = fwritec GenericDictionaryTypeCode tcl_file;
			  (tcl_file,wtis) = write_type_info rt_constructor tcl_file wtis
			= write_type_info rt_fields tcl_file wtis

normalize_atype_var :: !ATypeVar (!Int,!*TypeVarHeap) -> (!Int,(!Int,!*TypeVarHeap))
normalize_atype_var td_arg=:{atv_variable={tv_info_ptr}} (id,th_vars)
	# th_vars = writePtr tv_info_ptr (TVI_Normalized id) th_vars
	= (id,(inc id,th_vars));

normalize_type_var :: !TypeVar (!Int,!*TypeVarHeap) -> (!Int,(!Int,!*TypeVarHeap))
normalize_type_var {tv_info_ptr} (id,th_vars)
	# th_vars = writePtr tv_info_ptr (TVI_Normalized id) th_vars
95
	= (id,(inc id,th_vars));
96

97
98
99
100
101
sel_type_var_heap :: !*WriteTypeInfoState -> (!*TypeVarHeap,!*WriteTypeInfoState)
sel_type_var_heap wtis=:{wtis_type_heaps}
	# (th_vars,wtis_type_heaps)
		= sel wtis_type_heaps
	= (th_vars,{ wtis & wtis_type_heaps = wtis_type_heaps} )
102
103
104
where
	sel wtis_type_heaps=:{th_vars}
		= (th_vars,{ wtis_type_heaps & th_vars = newHeap } )
105
 
106
107
instance WriteTypeInfo ATypeVar
where 
108
	write_type_info {atv_variable} tcl_file wtis
109
110
111
 		# (tcl_file,wtis)
 			= write_type_info atv_variable tcl_file wtis
 		= (tcl_file,wtis)
112

113
114
instance WriteTypeInfo TypeVar
where
115
116
117
118
119
120
121
122
	write_type_info {tv_info_ptr} tcl_file wtis
		# (th_vars,wtis)
			= sel_type_var_heap wtis
		# ( v,th_vars)
			= readPtr tv_info_ptr th_vars
		# tcl_file
			= fwritei (get_type_var_nf_number v) tcl_file

123
  		# wtis = { wtis & wtis_type_heaps.th_vars = th_vars }
124
125
126
127
 		= (tcl_file,wtis)	
 	where 
 		get_type_var_nf_number (TVI_Normalized i)	= i

128
129
instance WriteTypeInfo TypeRhs
where 
130
131
132
	write_type_info (AlgType defined_symbols) tcl_file wtis
 		# tcl_file
 			= fwritec AlgTypeCode tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
133
134
		# defined_symbols
			= (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols)
135
136
137
		# (tcl_file,wtis)
			= write_type_info defined_symbols tcl_file wtis
		= (tcl_file,wtis)
138
		
139
140
	write_type_info (SynType _) tcl_file wtis
		# tcl_file
141
 			= fwritec SynTypeCode tcl_file;
142
  		= (tcl_file,wtis) 
143
		
144
	write_type_info (RecordType {rt_constructor,rt_fields}) tcl_file wtis
145
146
 		#! tcl_file
 			= fwritec RecordTypeCode tcl_file;
147
148
149
150
151
		#! (tcl_file,wtis)
			= write_type_info rt_constructor tcl_file wtis
		#! (tcl_file,wtis)
			= write_type_info rt_fields tcl_file wtis
		= (tcl_file,wtis)
152

153
	write_type_info (AbstractType _) tcl_file wtis
154
155
 		#! tcl_file
 			= fwritec AbstractTypeCode tcl_file;
156
157
158
159
160
 		// unimplemented
		= (tcl_file,wtis)

	write_type_info (AbstractSynType _ _) tcl_file wtis
 		#! tcl_file	= fwritec AbstractTypeCode tcl_file;
161
 		// unimplemented
162
		= (tcl_file,wtis)
163
164
165
		
instance WriteTypeInfo DefinedSymbol 
where
166
167
168
169
170
171
172
173
	write_type_info {ds_ident,ds_arity,ds_index} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info ds_ident tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info ds_arity tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info ds_index tcl_file wtis
		= (tcl_file,wtis)
174
175
176

instance WriteTypeInfo Ident 
where
177
	write_type_info {id_name} tcl_file wtis
178
179
		# tcl_file
			= fwritei (size id_name) tcl_file
180
		= (fwrites id_name tcl_file,wtis)
181

182
183
instance WriteTypeInfo FieldSymbol
where
184
185
	write_type_info {fs_ident} tcl_file wtis
		= write_type_info fs_ident tcl_file wtis
186

Martijn Vervoort's avatar
Martijn Vervoort committed
187
188
instance WriteTypeInfo SymbolType
where
189
190
191
	write_type_info symbol_type tcl_file wtis
		#! ({st_vars,st_args,st_args_strictness,st_arity,st_result},wtis)
			= expand_symbol_type symbol_type wtis
192
193
194
		# (tcl_file,wtis)
			= write_type_info st_vars tcl_file wtis
		# (tcl_file,wtis)
195
196
197
			= write_type_info st_args tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info st_args_strictness tcl_file wtis
198
199
200
201
202
		# (tcl_file,wtis)
			= write_type_info st_arity tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info st_result tcl_file wtis
		= (tcl_file,wtis)
203
	where
204
		expand_symbol_type symbol_type wtis=:{wtis_common_defs,wtis_type_defs,wtis_main_dcl_module_n,wtis_type_heaps,wtis_var_heap}
205
206
			# (expanded_symbol_type,wtis_type_defs,wtis_type_heaps,wtis_var_heap)
				= convertSymbolTypeWithoutCollectingImportedConstructors False wtis_common_defs symbol_type wtis_main_dcl_module_n wtis_type_defs wtis_type_heaps wtis_var_heap;
207
			# wtis = {wtis & wtis_type_defs = wtis_type_defs, wtis_type_heaps = wtis_type_heaps, wtis_var_heap = wtis_var_heap};
208
			= (expanded_symbol_type,wtis)
209

210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
instance WriteTypeInfo StrictnessList
where
	write_type_info NotStrict tcl_file wtis
		# tcl_file
			= fwritec NotStrictCode tcl_file
		= (tcl_file,wtis)
	write_type_info (Strict i) tcl_file wtis
		# tcl_file
			= fwritec StrictCode tcl_file
		# tcl_file
			= fwritei i tcl_file
		= (tcl_file,wtis)
	write_type_info (StrictList i tail) tcl_file wtis
		# tcl_file
			= fwritec StrictListCode tcl_file
		# tcl_file
			= fwritei i tcl_file
		= write_type_info tail tcl_file wtis
				
Martijn Vervoort's avatar
Martijn Vervoort committed
229
230
instance WriteTypeInfo AType
where
231
	write_type_info {at_type} tcl_file wtis
232
233
234
		# (tcl_file,wtis)
			= write_type_info at_type tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
235
		
Martijn Vervoort's avatar
Martijn Vervoort committed
236
237
instance WriteTypeInfo Type
where
238
	write_type_info (TA type_symb_ident atypes) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
239
		# tcl_file
240
			= fwritec TypeTASCode tcl_file
241
242
243
244
		# (tcl_file,wtis)
			= write_type_info type_symb_ident tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atypes tcl_file wtis
245
246
		# (tcl_file,wtis)
			= write_type_info NotStrict tcl_file wtis			
247
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
248

249
250
	write_type_info (TAS type_symb_ident atypes strictness) tcl_file wtis
		# tcl_file
251
			= fwritec TypeTASCode tcl_file
252
253
254
		# (tcl_file,wtis)
			= write_type_info type_symb_ident tcl_file wtis
		# (tcl_file,wtis)
255
256
257
			= write_type_info atypes tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info strictness tcl_file wtis			
258
259
		= (tcl_file,wtis)

260
	write_type_info (atype1 --> atype2) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
261
262
		# tcl_file
			= fwritec TypeArrowCode tcl_file
263
264
265
266
267
		# (tcl_file,wtis)
			= write_type_info atype1 tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atype2 tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
268
		
269
	write_type_info (cons_variable :@: atypes) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
270
271
		# tcl_file
			= fwritec TypeConsApplyCode tcl_file
272
273
274
275
276
		# (tcl_file,wtis)
			= write_type_info cons_variable tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atypes tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
277
		
278
279
	write_type_info tb=:(TB basic_type) tcl_file wtis
		# (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
280
			= case basic_type of
281
282
283
284
285
286
287
				BT_Int		-> (fwritec BT_IntCode tcl_file,wtis)
				BT_Char		-> (fwritec BT_CharCode tcl_file,wtis)
				BT_Real		-> (fwritec BT_RealCode tcl_file,wtis)
				BT_Bool		-> (fwritec BT_BoolCode tcl_file,wtis)
				BT_Dynamic	-> (fwritec BT_DynamicCode tcl_file,wtis)
				BT_File		-> (fwritec BT_FileCode tcl_file,wtis)
				BT_World	-> (fwritec BT_WorldCode tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
288
289
290
				BT_String type
					# tcl_file
						= fwritec BT_StringCode tcl_file
291
292
293
294
					# (tcl_file,wtis)
						= write_type_info type tcl_file wtis
					-> (tcl_file,wtis)
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
295
	
296
	write_type_info (GTV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
297
298
		# tcl_file
			= fwritec TypeGTVCode tcl_file
299
300
301
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
302

303
	write_type_info (TV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
304
305
		# tcl_file
			= fwritec TypeTVCode tcl_file
306
307
308
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
309
		
310
	write_type_info (TQV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
311
312
		# tcl_file
			= fwritec TypeTQVCode tcl_file
313
314
315
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
316

317
318
319
320
321
322
323
	// FIXME: the universally quantifier and type vars are ignored here
	// this is really just a hack to prevent the compiler from crashing
	// on rank>1 types
	write_type_info (TFA uni_vars type) tcl_file wtis
 		# (th_vars,wtis)
 			= sel_type_var_heap wtis
 		# (_,(_,th_vars))
John van Groningen's avatar
John van Groningen committed
324
 			= mapSt normalize_atype_var uni_vars (0,th_vars)
325
326
327
328
329
330
  		# wtis
 			= { wtis & wtis_type_heaps.th_vars = th_vars }
		# (tcl_file,wtis)
			= write_type_info type tcl_file wtis
		= (tcl_file,wtis)	

331
	write_type_info TE tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
332
333
		# tcl_file
			= fwritec TypeTECode tcl_file
334
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
335

John van Groningen's avatar
John van Groningen committed
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
	write_type_info (TGenericFunctionInDictionary {glob_module,glob_object={ds_index}} type_kind generict_dict) tcl_file wtis
		# ({gen_type},wtis)
			= if (glob_module==wtis.wtis_main_dcl_module_n)
				wtis!wtis_icl_generic_defs.[ds_index]
				wtis!wtis_common_defs.[glob_module].com_generic_defs.[ds_index]
		  {wtis_type_heaps,wtis_n_type_vars} = wtis
 		  (_,(n_type_vars,th_vars))
 			= mapSt normalize_type_var gen_type.st_vars (0,wtis_type_heaps.th_vars)
  		  wtis = {wtis & wtis_type_heaps={wtis_type_heaps & th_vars = th_vars}, wtis_n_type_vars = n_type_vars}
		  tcl_file = fwritec GenericFunctionTypeCode tcl_file
		  kind_string = kind_to_short_string type_kind;
		  tcl_file = fwritei (size kind_string) tcl_file
		  tcl_file = fwrites kind_string tcl_file
		  (tcl_file,wtis) = write_type_info gen_type tcl_file wtis
		  wtis = {wtis & wtis_n_type_vars=wtis_n_type_vars}
		= (tcl_file,wtis)

Martijn Vervoort's avatar
Martijn Vervoort committed
353
354
instance WriteTypeInfo ConsVariable
where
355
	write_type_info (CV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
356
357
		# tcl_file
			= fwritec ConsVariableCVCode tcl_file
358
359
360
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
361

362
	write_type_info (TempCV temp_var_id) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
363
364
		# tcl_file
			= fwritec ConsVariableTempCVCode tcl_file
365
366
367
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
368
		
369
	write_type_info (TempQCV temp_var_id) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
370
371
		# tcl_file
			= fwritec ConsVariableTempQCVCode tcl_file
372
373
374
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
375
376
377

instance WriteTypeInfo TypeSymbIdent
where
378
379
	write_type_info tsi=:{type_ident,type_arity,type_index={glob_module,glob_object}} tcl_file wtis
		# is_type_without_definition = glob_module == cPredefinedModuleIndex
Martijn Vervoort's avatar
Martijn Vervoort committed
380
381
		# tcl_file
			= fwritec (if is_type_without_definition TypeSymbIdentWithoutDefinition TypeSymbIdentWithDefinition) tcl_file
382
		# (tcl_file,wtis)
383
			= write_type_info type_ident tcl_file wtis
384
		# (tcl_file,wtis)		 
385
			= write_type_info type_arity tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
386
387
388
		# (tcl_file,wtis)
			= write_type_info tsi.type_index tcl_file wtis
		= (tcl_file,wtis)
389

Martijn Vervoort's avatar
Martijn Vervoort committed
390
391
392
393
394
395
396
instance WriteTypeInfo (Global object) | WriteTypeInfo object
where
	write_type_info {glob_object,glob_module} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info glob_object tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info glob_module tcl_file wtis
397
		= (tcl_file,wtis)
398
 
399
400
401
// basic and structural write_type_info's
instance WriteTypeInfo Int 
where
402
403
	write_type_info i tcl_file wtis
		= (fwritei i tcl_file,wtis)
404

405
instance WriteTypeInfo {#b} | Array {#} b & WriteTypeInfo b
406
where
407
	write_type_info unboxed_array tcl_file wtis
408
409
		# s_unboxed_array = size unboxed_array
		# tcl_file = fwritei s_unboxed_array tcl_file			
John van Groningen's avatar
John van Groningen committed
410
		= write_type_info_of_array 0 s_unboxed_array unboxed_array tcl_file wtis
411

John van Groningen's avatar
John van Groningen committed
412
413
414
415
416
417
418
write_type_info_of_array i limit array tcl_file wtis
	| i == limit
		= (tcl_file,wtis)
	# (tcl_file,wtis)
		= write_type_info array.[i] tcl_file wtis
	= write_type_info_of_array (inc i) limit array tcl_file wtis
	
419
420
instance WriteTypeInfo [a] | WriteTypeInfo a
where
421
	write_type_info l tcl_file wtis
422
423
		# tcl_file
			= fwritei (length l) tcl_file
424
		= write_type_info_loop l tcl_file wtis
425
	where
426
427
428
429
430
431
		write_type_info_loop []	tcl_file wtis
			= (tcl_file,wtis)
		write_type_info_loop [x:xs] tcl_file wtis
			# (tcl_file,wtis)
				= write_type_info x tcl_file wtis
			= write_type_info_loop xs tcl_file wtis
432
433
434
			
instance WriteTypeInfo Char
where
435
	write_type_info c tcl_file wtis
436
437
		# tcl_file
			= fwritec c tcl_file;
438
		= (tcl_file,wtis);
Martijn Vervoort's avatar
Martijn Vervoort committed
439

440
441
442
443
444
445
446
447
instance WriteTypeInfo (a,b) | WriteTypeInfo a & WriteTypeInfo b
where
	write_type_info (c1,c2) tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info c1 tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info c2 tcl_file wtis
		= (tcl_file,wtis)