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

Martijn Vervoort's avatar
Martijn Vervoort committed
6
7
8
// WARNING: It is essential to report changes in this module to martijnv@cs.kun.nl
//			because the binary format for type-files is used by the dynamic run-time
//			system.
9

Martijn Vervoort's avatar
Martijn Vervoort committed
10
import StdEnv, compare_constructor
11
import scanner, general, Heap, typeproperties, utilities, checksupport
12
import trans
13

Martijn Vervoort's avatar
Martijn Vervoort committed
14
import type_io_common
Martijn Vervoort's avatar
Martijn Vervoort committed
15
16
17
18
19
20
// 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
21
//
Martijn Vervoort's avatar
Martijn Vervoort committed
22
23
// unsupported:
// - 	ADTs
24

Martijn Vervoort's avatar
Martijn Vervoort committed
25
F a b :== b;
Martijn Vervoort's avatar
Martijn Vervoort committed
26

27
28
:: WriteTypeInfoState
	= { 
29
30
31
32
33
34
35
36
		wtis_n_type_vars						:: !Int
	,	wtis_predefined_module_def				:: !Index
	,	wtis_common_defs						:: !{#CommonDefs}	
	,	wtis_type_defs							:: !.{#{#CheckedTypeDef}}
	,	wtis_collected_conses					:: !ImportedConstructors
	,	wtis_type_heaps							:: !.TypeHeaps
	,	wtis_var_heap							:: !.VarHeap
	,	wtis_main_dcl_module_n 					:: !Int
37
	};
Martijn Vervoort's avatar
Martijn Vervoort committed
38
	
39
40
class WriteTypeInfo a 
where
41
	write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
42
43
44
	
instance WriteTypeInfo CommonDefs
where 
45
46
47
48
49
50
51
52
	write_type_info {com_type_defs,com_cons_defs,com_selector_defs} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info com_type_defs tcl_file wtis
		# (tcl_file,wtis)
 			= write_type_info com_cons_defs tcl_file wtis
 		# (tcl_file,wtis)
 			= write_type_info com_selector_defs tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
53
54
55
		
instance WriteTypeInfo SelectorDef
where
56
57
58
59
	write_type_info {sd_type} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info sd_type tcl_file wtis
		= (tcl_file,wtis)
60
61
62
	
instance WriteTypeInfo ConsDef
where 
63
	write_type_info {cons_ident,cons_type,cons_arg_vars,cons_priority,cons_index,cons_type_index,cons_exi_vars} tcl_file wtis=:{wtis_n_type_vars}
64
65
66
67
68
69
 		// normalize ...
 		# (th_vars,wtis)
 			= sel_type_var_heap wtis
 		# (_,(_,th_vars))
 			= mapSt normalize_type_var cons_exi_vars (wtis_n_type_vars,th_vars)
  		# wtis
70
 			= { wtis & wtis_type_heaps.th_vars = th_vars }
71
 		// ... normalize
72

73
		# (tcl_file,wtis)
74
			= write_type_info cons_ident tcl_file wtis
75
76
		# (tcl_file,wtis)
			= write_type_info cons_type tcl_file wtis
77
		
78
79
80
81
		# (tcl_file,wtis)
			= write_type_info cons_arg_vars tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info cons_index tcl_file wtis
82
						
83
84
85
86
87
		# (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)
88
			
89
//1.3
90
instance WriteTypeInfo TypeDef TypeRhs
91
92
93
94
//3.1
/*2.0
instance WriteTypeInfo (TypeDef TypeRhs)
0.2*/
95
where 
96
	write_type_info {td_ident,td_arity,td_args,td_rhs} tcl_file wtis
97
98
99
100
101
102
103
		// normalize ...
 		# (th_vars,wtis)
 			= sel_type_var_heap wtis
 		# (_,(n_type_vars,th_vars))
 			= mapSt normalize_type_var td_args (0,th_vars)
  		# wtis
 			= { wtis &
104
 				wtis_type_heaps.th_vars = th_vars
105
106
107
 			,	wtis_n_type_vars		= n_type_vars
 			}
 		// ... normalize
108
 		
109
 		# (tcl_file,wtis)
110
 			= write_type_info td_ident tcl_file wtis
111
112
113
		# (tcl_file,wtis)
 			= write_type_info td_arity tcl_file wtis 				
 		# (tcl_file,wtis)
114
 			= write_type_info td_args tcl_file wtis	
115
116
117
118
119
120
121
122
123
124
		# (tcl_file,wtis)
 			= write_type_info td_rhs tcl_file wtis
 			
 		= (tcl_file,wtis)
 	
normalize_type_var :: !ATypeVar (!Int,!*TypeVarHeap) -> (!Int,(!Int,!*TypeVarHeap))
normalize_type_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));
125

126
127
128
129
130
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} )
131
132
133
where
	sel wtis_type_heaps=:{th_vars}
		= (th_vars,{ wtis_type_heaps & th_vars = newHeap } )
134
 
135
136
instance WriteTypeInfo ATypeVar
where 
137
	write_type_info {atv_variable} tcl_file wtis
138
139
140
 		# (tcl_file,wtis)
 			= write_type_info atv_variable tcl_file wtis
 		= (tcl_file,wtis)
141

142
143
instance WriteTypeInfo TypeVar
where
144
145
146
147
148
149
150
151
152
153
	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

  		# wtis 
 			= { wtis &
154
 				wtis_type_heaps.th_vars = th_vars
155
156
157
158
159
 			}
 		= (tcl_file,wtis)	
 	where 
 		get_type_var_nf_number (TVI_Normalized i)	= i

160
161
instance WriteTypeInfo TypeRhs
where 
162
163
164
	write_type_info (AlgType defined_symbols) tcl_file wtis
 		# tcl_file
 			= fwritec AlgTypeCode tcl_file
165
		
Martijn Vervoort's avatar
Martijn Vervoort committed
166
167
		# defined_symbols
			= (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols)
168
169
		# (tcl_file,wtis)
			= write_type_info defined_symbols tcl_file wtis
170

171
		= (tcl_file,wtis)
172
		
173
174
	write_type_info (SynType _) tcl_file wtis
		# tcl_file
175
 			= fwritec SynTypeCode tcl_file;
176
  		= (tcl_file,wtis) 
177
		
178
	write_type_info (RecordType {rt_constructor,rt_fields}) tcl_file wtis
179
180
 		#! tcl_file
 			= fwritec RecordTypeCode tcl_file;
181
182
183
184
185
		#! (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)
186

187
	write_type_info (AbstractType _) tcl_file wtis
188
189
 		#! tcl_file
 			= fwritec AbstractTypeCode tcl_file;
190
191
192
193
194
 		// unimplemented
		= (tcl_file,wtis)

	write_type_info (AbstractSynType _ _) tcl_file wtis
 		#! tcl_file	= fwritec AbstractTypeCode tcl_file;
195
 		// unimplemented
196
		= (tcl_file,wtis)
197
198
199
		
instance WriteTypeInfo DefinedSymbol 
where
200
201
202
203
204
205
206
207
	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)
208
209
210

instance WriteTypeInfo Ident 
where
211
	write_type_info {id_name} tcl_file wtis
212
213
		# tcl_file
			= fwritei (size id_name) tcl_file
214
		= (fwrites id_name tcl_file,wtis)
215
216
217
		
instance WriteTypeInfo FieldSymbol
where
218
	write_type_info {fs_ident,fs_var,fs_index} tcl_file wtis
219
		# (tcl_file,wtis)
220
			= write_type_info fs_ident tcl_file wtis
221
222
223
224
225
		# (tcl_file,wtis)
			= write_type_info fs_var tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info fs_index tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
226
227
228
		
instance WriteTypeInfo SymbolType
where
229
230
231
	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
232
233
234
		# (tcl_file,wtis)
			= write_type_info st_vars tcl_file wtis
		# (tcl_file,wtis)
235
236
237
			= write_type_info st_args tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info st_args_strictness tcl_file wtis
238
239
240
241
242
		# (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)
243
244
	where
		expand_symbol_type symbol_type wtis=:{wtis_common_defs,wtis_type_defs,wtis_main_dcl_module_n,wtis_collected_conses,wtis_type_heaps,wtis_var_heap}
245
246
			# (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;
247
248
249
250
251
252
253
254
			# wtis
				= { wtis &
					wtis_type_defs							= wtis_type_defs
				,	wtis_type_heaps							= wtis_type_heaps
				,	wtis_var_heap							= wtis_var_heap
				};
			= (expanded_symbol_type,wtis)
				
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
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
274
275
instance WriteTypeInfo AType
where
276
	write_type_info {at_type} tcl_file wtis
277
278
279
		# (tcl_file,wtis)
			= write_type_info at_type tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
280
		
Martijn Vervoort's avatar
Martijn Vervoort committed
281
282
instance WriteTypeInfo Type
where
283
	write_type_info (TA type_symb_ident atypes) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
284
		# tcl_file
285
			= fwritec TypeTASCode tcl_file
286
287
288
289
		# (tcl_file,wtis)
			= write_type_info type_symb_ident tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atypes tcl_file wtis
290
291
		# (tcl_file,wtis)
			= write_type_info NotStrict tcl_file wtis			
292
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
293

294
295
	write_type_info (TAS type_symb_ident atypes strictness) tcl_file wtis
		# tcl_file
296
			= fwritec TypeTASCode tcl_file
297
298
299
		# (tcl_file,wtis)
			= write_type_info type_symb_ident tcl_file wtis
		# (tcl_file,wtis)
300
301
302
			= write_type_info atypes tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info strictness tcl_file wtis			
303
304
		= (tcl_file,wtis)

305
	write_type_info (atype1 --> atype2) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
306
307
		# tcl_file
			= fwritec TypeArrowCode tcl_file
308
309
310
311
312
		# (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
313
		
314
	write_type_info (cons_variable :@: atypes) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
315
316
		# tcl_file
			= fwritec TypeConsApplyCode tcl_file
317
318
319
320
321
		# (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
322
		
323
324
	write_type_info tb=:(TB basic_type) tcl_file wtis
		# (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
325
			= case basic_type of
326
327
328
329
330
331
332
				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
333
334
335
				BT_String type
					# tcl_file
						= fwritec BT_StringCode tcl_file
336
337
338
339
					# (tcl_file,wtis)
						= write_type_info type tcl_file wtis
					-> (tcl_file,wtis)
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
340
	
341
	write_type_info (GTV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
342
343
		# tcl_file
			= fwritec TypeGTVCode tcl_file
344
345
346
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
347

348
	write_type_info (TV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
349
350
		# tcl_file
			= fwritec TypeTVCode tcl_file
351
352
353
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
354
		
355
	write_type_info (TQV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
356
357
		# tcl_file
			= fwritec TypeTQVCode 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
363
364
365
366
367
368
369
370
371
372
373
374
375
	// 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))
 			= mapSt normalize_type_var uni_vars (0,th_vars)
  		# wtis
 			= { wtis & wtis_type_heaps.th_vars = th_vars }
		# (tcl_file,wtis)
			= write_type_info type tcl_file wtis
		= (tcl_file,wtis)	

376
	write_type_info TE tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
377
378
		# tcl_file
			= fwritec TypeTECode tcl_file
379
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
380
381
382

instance WriteTypeInfo ConsVariable
where
383
	write_type_info (CV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
384
385
		# tcl_file
			= fwritec ConsVariableCVCode tcl_file
386
387
388
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
389

390
	write_type_info (TempCV temp_var_id) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
391
392
		# tcl_file
			= fwritec ConsVariableTempCVCode tcl_file
393
394
395
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
396
		
397
	write_type_info (TempQCV temp_var_id) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
398
399
		# tcl_file
			= fwritec ConsVariableTempQCVCode tcl_file
400
401
402
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
403
404
405

instance WriteTypeInfo TypeSymbIdent
where
406
	write_type_info tsi=:{type_ident,type_arity,type_index={glob_module,glob_object}} tcl_file wtis=:{wtis_predefined_module_def}
Martijn Vervoort's avatar
Martijn Vervoort committed
407
408
409
410
411
		# is_type_without_definition
			= glob_module == wtis_predefined_module_def
		# tcl_file
			= fwritec (if is_type_without_definition TypeSymbIdentWithoutDefinition TypeSymbIdentWithDefinition) tcl_file

412
		# (tcl_file,wtis)
413
			= write_type_info type_ident tcl_file wtis
414
		# (tcl_file,wtis)		 
415
			= write_type_info type_arity tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
416
417
		# (tcl_file,wtis)
			= write_type_info tsi.type_index tcl_file wtis
418

Martijn Vervoort's avatar
Martijn Vervoort committed
419
		= (tcl_file,wtis)
420

Martijn Vervoort's avatar
Martijn Vervoort committed
421
422
423
424
425
426
427
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
428
		= (tcl_file,wtis)
429
 
430
431
432
// basic and structural write_type_info's
instance WriteTypeInfo Int 
where
433
434
	write_type_info i tcl_file wtis
		= (fwritei i tcl_file,wtis)
435

436
437
438
439
//1.3
instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b
//3.1
/*2.0
440
instance WriteTypeInfo {#b} | Array {#} b & WriteTypeInfo b
441
0.2*/
442
where
443
	write_type_info unboxed_array tcl_file wtis
444
445
446
447
448
		# s_unboxed_array
			= size unboxed_array
		# tcl_file
			= fwritei s_unboxed_array tcl_file
			
449
		= write_type_info_loop 0 s_unboxed_array tcl_file wtis
450
	where 
451

452
		write_type_info_loop i limit tcl_file wtis
453
			| i == limit
454
455
456
457
				= (tcl_file,wtis)
			# (tcl_file,wtis)
				= write_type_info unboxed_array.[i] tcl_file wtis
			= write_type_info_loop (inc i) limit tcl_file wtis
458
459
460
			
instance WriteTypeInfo [a] | WriteTypeInfo a
where
461
	write_type_info l tcl_file wtis
462
463
		# tcl_file
			= fwritei (length l) tcl_file
464
		= write_type_info_loop l tcl_file wtis
465
	where
466
467
468
469
470
471
		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
472
473
474
			
instance WriteTypeInfo Char
where
475
	write_type_info c tcl_file wtis
476
477
		# tcl_file
			= fwritec c tcl_file;
478
		= (tcl_file,wtis);
Martijn Vervoort's avatar
Martijn Vervoort committed
479

480
481
482
483
484
485
486
487
488
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)