backendconvert.icl 103 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
4
implementation module backendconvert

import code from library "backend_library"

5
import StdEnv, compare_types
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
6
7
8
import frontend
import backend
import backendsupport, backendpreprocess
9

clean's avatar
clean committed
10
11
12
// trace macro
(-*->) infixl
(-*->) value trace
13
	:==	value //---> trace
14
15
16
17
18
19
20
21
22
23
24
25
/*
sfoldr op r l
	:== foldr l
	where
		foldr [] = r
		foldr [a:x] = \s -> op a (foldr x) s
*/
sfoldr op r l s
	:== foldr l s
	where
		foldr [] = r
		foldr [a:x] = op a (foldr x)
clean's avatar
clean committed
26

27
::	FunctionPattern	= FP_Algebraic !(Global DefinedSymbol) ![FunctionPattern]
28
29
					| FP_Variable !FreeVar

30
:: BEMonad a :== *BackEndState -> *(!a,!*BackEndState)
31
:: BackEnder :== *BackEndState -> *BackEndState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
32

33
//
34
:: *BackEndState = {bes_backEnd :: !BackEnd, bes_varHeap :: !*VarHeap, bes_attrHeap :: !*AttrVarHeap, bes_attr_number :: !Int}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
35

36
37
38
39
appBackEnd f beState
	:== {beState & bes_backEnd = bes_backEnd}
	where
		bes_backEnd = f beState.bes_backEnd
40

41
42
43
44
45
46
47
accBackEnd f beState
	:== accBackEnd
	where
		accBackEnd
			# (result, bes_backEnd) =	f beState.bes_backEnd
			#! beState2 = {beState & bes_backEnd = bes_backEnd}
			= (result,beState2)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
48

49
50
accVarHeap f beState
	:== (result, {beState & bes_varHeap = varHeap})
51
	where
52
		(result, varHeap) =	f beState.bes_varHeap
53

54
55
56
57
58
59
60
accAttrHeap f beState
	:== (result, {beState & bes_attrHeap = attrHeap})
	where
		(result, attrHeap) =	f beState.bes_attrHeap


read_from_var_heap :: VarInfoPtr BackEndState -> (VarInfo, BackEndState)
61
read_from_var_heap ptr beState
62
63
64
	= (result, {beState & bes_varHeap = varHeap})
where
		(result, varHeap) =	readPtr ptr beState.bes_varHeap
65

66
67
write_to_var_heap ptr v beState
	= {beState & bes_varHeap = writePtr ptr v beState.bes_varHeap}
68
69
70
71
72
73
74
75

read_from_attr_heap ptr beState
	= (result, {beState & bes_attrHeap = attrHeap})
where
		(result, attrHeap) =	readPtr ptr beState.bes_attrHeap

write_to_attr_heap ptr v beState
	= {beState & bes_attrHeap = writePtr ptr v beState.bes_attrHeap}
76
77
78
/*
read_from_var_heap ptr heap be
	= (sreadPtr ptr heap,be)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
79

80
81
82
83
::	*BackEndState :== BackEnd

appBackEnd f beState :== f beState
accBackEnd f beState :== f beState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
84
accVarHeap f beState :== f beState
85
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
86

87
beApFunction0 f
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
88
	:== appBackEnd f
89
beApFunction1 f m1
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
90
91
	:== m1 ==> \a1
	->	appBackEnd (f a1)
92
beApFunction2 f m1 m2
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
93
94
95
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	appBackEnd (f a1 a2)
96
beApFunction3 f m1 m2 m3
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
97
98
99
100
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	appBackEnd (f a1 a2 a3)
101
beApFunction4 f m1 m2 m3 m4
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
102
103
104
105
106
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	appBackEnd (f a1 a2 a3 a4)
107
beApFunction5 f m1 m2 m3 m4 m5
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
108
109
110
111
112
113
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	m5 ==> \a5
	->	appBackEnd (f a1 a2 a3 a4 a5)
114
beApFunction6 f m1 m2 m3 m4 m5 m6
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
115
116
117
118
119
120
121
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	m5 ==> \a5
	->	m6 ==> \a6
	->	appBackEnd (f a1 a2 a3 a4 a5 a6)
122
beApFunction7 f m1 m2 m3 m4 m5 m6 m7
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
123
124
125
126
127
128
129
130
131
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	m5 ==> \a5
	->	m6 ==> \a6
	->	m7 ==> \a7
	->	appBackEnd (f a1 a2 a3 a4 a5 a6 a7)

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
beFunction0 f
	:== accBackEnd f
beFunction1 f m1
	:== m1 ==> \a1
	->	accBackEnd (f a1)
beFunction2 f m1 m2
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	accBackEnd (f a1 a2)
beFunction3 f m1 m2 m3
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	accBackEnd (f a1 a2 a3)
beFunction4 f m1 m2 m3 m4
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	accBackEnd (f a1 a2 a3 a4)
beFunction5 f m1 m2 m3 m4 m5
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	m5 ==> \a5
	->	accBackEnd (f a1 a2 a3 a4 a5)
beFunction6 f m1 m2 m3 m4 m5 m6
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	m5 ==> \a5
	->	m6 ==> \a6
	->	accBackEnd (f a1 a2 a3 a4 a5 a6)
beFunction7 f m1 m2 m3 m4 m5 m6 m7
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	m5 ==> \a5
	->	m6 ==> \a6
	->	m7 ==> \a7
	->	accBackEnd (f a1 a2 a3 a4 a5 a6 a7)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
changeArrayFunctionIndex selectIndex
	:== selectIndex

beBoolSymbol value
	:==	beFunction0 (BEBoolSymbol value)
beLiteralSymbol type value
	:==	beFunction0 (BELiteralSymbol type value)
beFunctionSymbol functionIndex moduleIndex
	:==	beFunction0 (BEFunctionSymbol functionIndex moduleIndex)
beSpecialArrayFunctionSymbol arrayFunKind functionIndex moduleIndex
	:==	beFunction0 (BESpecialArrayFunctionSymbol arrayFunKind (changeArrayFunctionIndex functionIndex) moduleIndex)
beDictionarySelectFunSymbol
	:==	beFunction0 BEDictionarySelectFunSymbol
beDictionaryUpdateFunSymbol
	:==	beFunction0 BEDictionaryUpdateFunSymbol
beConstructorSymbol moduleIndex constructorIndex
	:==	beFunction0 (BEConstructorSymbol constructorIndex moduleIndex)
194
195
196
197

beOverloadedConsSymbol moduleIndex constructorIndex deconsModuleIndex deconsIndex
	:==	beFunction0 (BEOverloadedConsSymbol constructorIndex moduleIndex deconsIndex deconsModuleIndex)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
198
199
200
201
beFieldSymbol fieldIndex moduleIndex
	:==	beFunction0 (BEFieldSymbol fieldIndex moduleIndex)
beTypeSymbol typeIndex moduleIndex
	:==	beFunction0 (BETypeSymbol typeIndex moduleIndex)
John van Groningen's avatar
John van Groningen committed
202
203
beTypeSymbolNoMark typeIndex moduleIndex
	:==	beFunction0 (BETypeSymbolNoMark typeIndex moduleIndex)
204
205
beBasicSymbol symbolIndex
	:==	beFunction0 (BEBasicSymbol symbolIndex)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
beDontCareDefinitionSymbol
	:==	beFunction0 BEDontCareDefinitionSymbol
beNoArgs
	:==	beFunction0 BENoArgs
beArgs
	:==	beFunction2 BEArgs
beNoTypeArgs
	:==	beFunction0 BENoTypeArgs
beTypeArgs
	:==	beFunction2 BETypeArgs
beNormalNode
	:==	beFunction2 BENormalNode
beIfNode
	:==	beFunction3 BEIfNode
beGuardNode
	:==	beFunction7 BEGuardNode
beSelectorNode selectorKind
	:==	beFunction2 (BESelectorNode selectorKind)
beUpdateNode
	:==	beFunction1 BEUpdateNode
beNormalTypeNode
	:==	beFunction2 BENormalTypeNode
228
229
beAddForAllTypeVariables
	:==	beFunction2 BEAddForAllTypeVariables
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
230
231
232
233
234
beVarTypeNode name
	:==	beFunction0 (BEVarTypeNode name)
beRuleAlt lineNumber
	:==	beFunction5 (BERuleAlt lineNumber)
beTypeAlt
235
	:==	beFunction3 BETypeAlt
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
beRule index isCaf
	:==	beFunction2 (BERule index isCaf)
beNodeDef sequenceNumber
	:==	beFunction1 (BENodeDef sequenceNumber)
beNoNodeDefs
	:==	beFunction0 BENoNodeDefs
beNodeDefs
	:==	beFunction2 BENodeDefs
beStrictNodeId
	:==	beFunction1 BEStrictNodeId
beNoStrictNodeIds
	:==	beFunction0 BENoStrictNodeIds
beStrictNodeIds
	:==	beFunction2 BEStrictNodeIds
beNodeIdNode
	:==	beFunction2 BENodeIdNode
beNodeId sequenceNumber
	:==	beFunction0 (BENodeId sequenceNumber)
beConstructor
	:==	beFunction1 BEConstructor
beNoConstructors
	:==	beFunction0 BENoConstructors
beAnnotateTypeNode annotation
	:==	beFunction1 (BEAnnotateTypeNode annotation)
260
261
beAttributeTypeNode
	:==	beFunction2 BEAttributeTypeNode
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
262
beDeclareRuleType functionIndex moduleIndex name
263
	:==	beApFunction0 (BEDeclareRuleType functionIndex moduleIndex name)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
264
beDefineRuleType functionIndex moduleIndex
265
	:==	beApFunction1 (BEDefineRuleType functionIndex moduleIndex)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
beCodeAlt lineNumber
	:==	beFunction3 (BECodeAlt lineNumber)
beString string
	:==	beFunction0 (BEString string)
beStrings
	:==	beFunction2 BEStrings
beNoStrings
	:==	beFunction0 BENoStrings
beCodeParameter location
	:==	beFunction1 (BECodeParameter location)
beCodeParameters
	:==	beFunction2 BECodeParameters
beNoCodeParameters
	:==	beFunction0 BENoCodeParameters
beAbcCodeBlock inline
	:==	beFunction1 (BEAbcCodeBlock inline)
beAnyCodeBlock
	:==	beFunction3 BEAnyCodeBlock
beDeclareNodeId number lhsOrRhs name
285
286
287
	:==	beApFunction0 (BEDeclareNodeId number lhsOrRhs name)
beAdjustArrayFunction backendId functionIndex moduleIndex
	:==	beApFunction0 (BEAdjustArrayFunction backendId functionIndex moduleIndex)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
288
289
290
291
292
293
beNoTypeVars
	:==	beFunction0 BENoTypeVars
beTypeVars
	:==	beFunction2 BETypeVars
beTypeVar name
	:==	beFunction0 (BETypeVar name)
294
295
beTypeVarListElem
	:==	beFunction2 BETypeVarListElem
296
297
298
299
300
301
302
303
beExportType isDictionary typeIndex
	:==	beApFunction0 (BEExportType isDictionary typeIndex)
beExportConstructor constructorIndex
	:==	beApFunction0 (BEExportConstructor constructorIndex)
beExportField isDictionaryField fieldIndex
	:==	beApFunction0 (BEExportField isDictionaryField fieldIndex)
beExportFunction functionIndex
	:==	beApFunction0 (BEExportFunction functionIndex)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
304
305
306
307
308
beTupleSelectNode arity index
	:==	beFunction1 (BETupleSelectNode arity index)
beMatchNode arity
	:==	beFunction2 (BEMatchNode arity)
beDefineImportedObjsAndLibs
309
	:== beApFunction2 BEDefineImportedObjsAndLibs
310
311
312
313
314
315
316
317
318
319
beSwitchNode
	:==	beFunction2 BESwitchNode
beDefaultNode
	:==	beFunction3 BEDefaultNode
beNoNodeIds
	:==	beFunction0 BENoNodeIds
beNodeIds
	:==	beFunction2 BENodeIds
beNodeIdListElem
	:==	beFunction1 BENodeIdListElem
320
321
322
323
324
325
326
327
328
329
330
331
beAttributeKind
	:== beFunction1 BEAttributeKind
beNoAttributeKinds
	:== beFunction0 BENoAttributeKinds
beAttributeKinds
	:== beFunction2 BEAttributeKinds
beUniVarEquation
	:== beFunction2 BEUniVarEquation
beNoUniVarEquations
	:== beFunction0 BENoUniVarEquations
beUniVarEquationsList
	:== beFunction2 BEUniVarEquationsList
332
333
334
335
beBindSpecialModule specialIdentIndex moduleIndex
	:== beApFunction0 (BEBindSpecialModule specialIdentIndex moduleIndex)
beBindSpecialFunction specialIdentIndex functionIndex moduleIndex
	:== beApFunction0 (BEBindSpecialFunction specialIdentIndex functionIndex moduleIndex)
336

337
338
339
// temporary hack
beDynamicTempTypeSymbol
	:== beFunction0 BEDynamicTempTypeSymbol
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
340

341
342
343
344
345
346
backEndConvertModules :: PredefinedSymbols FrontEndSyntaxTree !Int !*TypeVarHeap !*VarHeap !*AttrVarHeap !*BackEnd
															   -> (!*TypeVarHeap,!*VarHeap,!*AttrVarHeap,!*BackEnd)
backEndConvertModules p s main_dcl_module_n type_var_heap var_heap attr_var_heap be
	# (type_var_heap,{bes_varHeap,bes_attrHeap,bes_backEnd})
		= backEndConvertModulesH p s main_dcl_module_n type_var_heap {bes_varHeap=var_heap,bes_attrHeap=attr_var_heap,bes_backEnd=be, bes_attr_number=0}
	= (type_var_heap,bes_varHeap,bes_attrHeap,bes_backEnd)
347

348
backEndConvertModulesH :: PredefinedSymbols FrontEndSyntaxTree !Int !*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState)
349
backEndConvertModulesH predefs {fe_icl = 
350
351
352
	fe_icl =: {	icl_name, icl_functions, icl_common,
				icl_function_indices = {ifi_type_function_indices,ifi_global_function_indices},
				icl_imported_objects, icl_foreign_exports, icl_used_module_numbers, icl_modification_time},
353
	fe_components, fe_dcls, fe_arrayInstances}
354
	main_dcl_module_n type_var_heap backEnd
355
	// sanity check ...
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
356
357
358
//	| cIclModIndex <> kIclModuleIndex || cPredefinedModuleIndex <> kPredefinedModuleIndex
//		=	undef <<- "backendconvert, backEndConvertModules: module index mismatch"
	// ... sanity check
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
359
	#! backEnd = appBackEnd (BESetMainDclModuleN main_dcl_module_n) backEnd
360
361
362
	#! backEnd
		=	appBackEnd (BEDeclareModules (size fe_dcls)) backEnd
	#! backEnd
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
363
		=	predefineSymbols fe_dcls.[cPredefinedModuleIndex] predefs backEnd
clean's avatar
clean committed
364
365

	#  currentDcl
366
	   	=	fe_dcls.[main_dcl_module_n]
clean's avatar
clean committed
367
368
369
370
371
372
/*
	#  backEnd
		=	backEnd ->>
				(	"dcl conversions"
				,	currentDcl.dcl_conversions
				,	"dcl constructors"
373
				,	[constructor.cons_ident.id_name \\ constructor <-: currentDcl.dcl_common.com_cons_defs]
clean's avatar
clean committed
374
				,	"dcl selectors"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
375
				,	[selector.sd_ident.id_name \\ selector <-: currentDcl.dcl_common.com_selector_defs]
clean's avatar
clean committed
376
				,	"dcl types"
377
				,	[type.td_ident.id_name \\ type <-: currentDcl.dcl_common.com_type_defs]
378
				,	"icl constructors"
379
				,	[constructor.cons_ident.id_name \\ constructor <-: icl_common.com_cons_defs]
380
				,	"icl selectors"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
381
				,	[selector.sd_ident.id_name \\ selector <-: icl_common.com_selector_defs]
clean's avatar
clean committed
382
				,	"icl types"
383
				,	[type.td_ident.id_name \\ type <-: icl_common.com_type_defs]
clean's avatar
clean committed
384
385
				)
*/
386
387
388
389
	#! backEnd
		=	declareCurrentDclModule fe_icl fe_dcls.[main_dcl_module_n] main_dcl_module_n (backEnd -*-> "declareCurrentDclModule")
	#! backEnd
		=	declareOtherDclModules fe_dcls main_dcl_module_n icl_used_module_numbers (backEnd -*-> "declareOtherDclModules")
390
391
392
393
394

// tempory hack
	#! backEnd
		=	declareDynamicTemp predefs (backEnd -*-> "declareDynamicTemp")

395
396
397
398
	#! (type_var_heap,backEnd)
		=	defineDclModule main_dcl_module_n fe_dcls.[main_dcl_module_n] type_var_heap backEnd
	#! (type_var_heap,backEnd)
		=	defineOtherDclModules fe_dcls main_dcl_module_n icl_used_module_numbers type_var_heap backEnd
clean's avatar
clean committed
399

400
	#! backEnd
401
		=	appBackEnd (BEDeclareIclModule icl_name.id_name icl_modification_time (size icl_functions) (size icl_common.com_type_defs) (size icl_common.com_cons_defs) (size icl_common.com_selector_defs)) (backEnd -*-> "BEDeclareIclModule")
402
	#! backEnd
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
403
		=	declareFunctionSymbols icl_functions functionIndices
404
				(ifi_type_function_indices ++ ifi_global_function_indices) (backEnd -*-> "declareFunctionSymbols")
405
	#! (type_var_heap,backEnd)
406
		=	declare_icl_common_defs main_dcl_module_n icl_common currentDcl.dcl_common type_var_heap backEnd
407
	#! backEnd
408
409
410
411
412
413
414
		=	declareArrayInstances /*fe_arrayInstances.ali_instances_range*/fe_arrayInstances.ali_array_first_instance_indices predefs main_dcl_module_n icl_functions fe_dcls (backEnd -*-> "declareArrayInstances")
	#! backEnd
		=	declareListInstances fe_arrayInstances.ali_list_first_instance_indices PD_UListClass predefs main_dcl_module_n icl_functions fe_dcls backEnd
	#! backEnd
		=	declareListInstances fe_arrayInstances.ali_tail_strict_list_first_instance_indices PD_UTSListClass predefs main_dcl_module_n icl_functions fe_dcls backEnd
	#! backEnd
		=	adjustArrayFunctions /*fe_arrayInstances.ali_instances_range*/fe_arrayInstances.ali_array_first_instance_indices predefs main_dcl_module_n icl_functions fe_dcls icl_common.com_instance_defs icl_used_module_numbers (backEnd -*-> "adjustArrayFunctions")
415
	#! backEnd
416
		=	adjustStrictListFunctions fe_arrayInstances.ali_list_first_instance_indices fe_arrayInstances.ali_tail_strict_list_first_instance_indices predefs fe_dcls icl_used_module_numbers main_dcl_module_n backEnd;
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
417
	#! (rules, backEnd)
418
		=	convertRules [(index, icl_functions.[index]) \\ (_, index) <- functionIndices] main_dcl_module_n predefined_idents.[PD_DummyForStrictAliasFun] (backEnd -*-> "convertRules")
419
420
	#! backEnd
		=	appBackEnd (BEDefineRules rules) (backEnd -*-> "BEDefineRules")
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
421
422
423
424
	#! backEnd
		=	beDefineImportedObjsAndLibs
				(convertStrings [imported.io_name \\ imported <- icl_imported_objects | not imported.io_is_library])
				(convertStrings [imported.io_name \\ imported <- icl_imported_objects | imported.io_is_library])
clean's avatar
clean committed
425
				(backEnd -*-> "beDefineImportedObjsAndLibs")
John van Groningen's avatar
John van Groningen committed
426
	#! backEnd = appBackEnd (convertForeignExports icl_foreign_exports main_dcl_module_n) backEnd
427
	#! backEnd
428
		=	markExports fe_dcls.[main_dcl_module_n] dcl_common.com_class_defs dcl_common.com_type_defs icl_common.com_class_defs icl_common.com_type_defs (backEnd -*-> "markExports")
clean's avatar
clean committed
429
430
431
			with
				dcl_common
					=	currentDcl.dcl_common
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
432
433
	# backEnd
		=	foldSt beExportFunction exported_local_type_funs backEnd
John van Groningen's avatar
John van Groningen committed
434
		with
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
435
436
437
438
439
			exported_local_type_funs
				| False && currentDcl.dcl_module_kind == MK_None
					=	[]
				// otherwise
					=	flatten [[r.ir_from .. r.ir_to-1]
440
									\\ r <- [ifi_type_function_indices!!1]]
441
	# backEnd = bindSpecialIdents predefs icl_used_module_numbers backEnd
442
	#! backEnd = removeExpandedTypesFromDclModules fe_dcls icl_used_module_numbers backEnd
443
	= (type_var_heap,backEnd)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
444
445
	where
		functionIndices
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
			= function_indices 0 fe_components
		
		function_indices i components
			| i<size components
				= function_indices2 components.[i].component_members i components
				= []

		function_indices2 (ComponentMember member members) i components
			#! inc_i = i+1
			= [(inc_i,member) : function_indices2 members i components]
		function_indices2 (GeneratedComponentMember member _ members) i components
			#! inc_i = i+1
			= [(inc_i,member) : function_indices2 members i components]
		function_indices2 NoComponentMembers i components
			= function_indices (i+1) components
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
461

462
463
464
465
466
467
468
469
fold2StatesWithIndexA function array s1 s2 :== fold2StatesWithIndexA 0 s1 s2
	where
		fold2StatesWithIndexA index s1 s2
			| index == size array
				= (s1,s2)
				# (s1,s2) = fold2StatesWithIndexA (index+1) s1 s2
				= function index array.[index] s1 s2

470
declareOtherDclModules :: {#DclModule} Int NumberSet -> BackEnder
471
declareOtherDclModules dcls main_dcl_module_n used_module_numbers
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
472
	=	foldStateWithIndexA declareOtherDclModule dcls
473
474
475
where
	declareOtherDclModule :: ModuleIndex DclModule -> BackEnder
	declareOtherDclModule moduleIndex dclModule
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
476
477
478
		| moduleIndex == main_dcl_module_n
		|| moduleIndex == cPredefinedModuleIndex
		|| not (inNumberSet moduleIndex used_module_numbers)
479
480
481
			=	identity
			=	declareDclModule moduleIndex dclModule

482
483
484
defineOtherDclModules :: {#DclModule} Int NumberSet !*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState)
defineOtherDclModules dcls main_dcl_module_n used_module_numbers type_var_heap beState
	= fold2StatesWithIndexA defineOtherDclModule dcls type_var_heap beState
485
where
486
487
	defineOtherDclModule :: ModuleIndex DclModule !*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState)
	defineOtherDclModule moduleIndex dclModule type_var_heap beState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
488
489
490
		| moduleIndex == main_dcl_module_n
		|| moduleIndex == cPredefinedModuleIndex
		|| not (inNumberSet moduleIndex used_module_numbers)
491
492
			= (type_var_heap, beState)
			= defineDclModule moduleIndex dclModule type_var_heap beState
493

494
495
496
497
498
499
500
501
isSystem :: ModuleKind -> Bool
isSystem MK_System
	=	True
isSystem MK_Module
	=	False
isSystem _
	=	abort "backendconvert:isSystem, unknown module kind"

502
declareCurrentDclModule :: IclModule DclModule Int -> BackEnder
503
504
declareCurrentDclModule _ {dcl_module_kind=MK_None} _
	=	identity
505
506
declareCurrentDclModule {icl_common} {dcl_name, dcl_modification_time, dcl_functions, dcl_module_kind, dcl_common} main_dcl_module_n
	=	appBackEnd (BEDeclareDclModule main_dcl_module_n dcl_name.id_name dcl_modification_time  (isSystem dcl_module_kind) (size dcl_functions) (size icl_common.com_type_defs) (size dcl_common.com_cons_defs) (size dcl_common.com_selector_defs))
507

508
declareDclModule :: ModuleIndex DclModule -> BackEnder
509
510
declareDclModule moduleIndex {dcl_name, dcl_modification_time, dcl_common, dcl_functions, dcl_module_kind}
	=	appBackEnd (BEDeclareDclModule moduleIndex dcl_name.id_name dcl_modification_time (isSystem dcl_module_kind) (size dcl_functions) (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs) (size dcl_common.com_selector_defs))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
511

512
defineDclModule :: ModuleIndex DclModule !*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState)
513
defineDclModule moduleIndex {dcl_name, dcl_common, dcl_functions, dcl_type_funs, dcl_instances} type_var_heap beState
514
	# (type_var_heap,beState) = declare_dcl_common_defs moduleIndex dcl_common type_var_heap beState
515
516
	# beState = declareFunTypes moduleIndex dcl_functions [{ir_from = 0, ir_to = dcl_instances.ir_from}, dcl_type_funs] beState
	= (type_var_heap,beState)
517

518
removeExpandedTypesFromDclModules :: {#DclModule} NumberSet -> BackEnder
519
520
521
522
removeExpandedTypesFromDclModules dcls used_module_numbers
	=	foldStateWithIndexA removeExpandedTypesFromDclModule dcls
where
	removeExpandedTypesFromDclModule :: ModuleIndex DclModule -> BackEnder
523
	removeExpandedTypesFromDclModule moduleIndex dclModule=:{dcl_functions,dcl_common={com_cons_defs,com_selector_defs}}
524
		| moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers)
525
			= identity
526
527
528
			= foldStateA removeExpandedTypesFromFunType dcl_functions
			o` foldStateA removeExpandedTypesFromConsType com_cons_defs
			o` foldStateA removeExpandedTypesFromSelectorType com_selector_defs
529
			where
530
531
532
				removeExpandedTypesFromFunType :: FunType -> BackEnder
				removeExpandedTypesFromFunType {ft_type_ptr}
					= \be0 -> let (ft_type,be) = read_from_var_heap ft_type_ptr be0 in
533
534
535
536
537
						(case ft_type of
							VI_ExpandedType expandedType
								->	write_to_var_heap ft_type_ptr VI_Empty	
							_
								->	identity) be
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
538

539
540
541
				removeExpandedTypesFromSelectorType :: SelectorDef -> BackEnder
				removeExpandedTypesFromSelectorType {sd_type_ptr}
					= \be0
542
543
544
						= if (not (isNilPtr sd_type_ptr))
							(write_to_var_heap sd_type_ptr VI_Empty be0)
							be0
545
546
547
548

				removeExpandedTypesFromConsType :: ConsDef -> BackEnder
				removeExpandedTypesFromConsType {cons_type_ptr}
					= \be0
549
550
551
						= if (not (isNilPtr cons_type_ptr))
							(write_to_var_heap cons_type_ptr VI_Empty be0)
							be0
552

553
:: DeclVarsInput :== Ident
554

555
class declareVars a :: a !DeclVarsInput -> BackEnder
556
557

instance declareVars [a] | declareVars a where
558
	declareVars :: [a] !DeclVarsInput -> BackEnder | declareVars a
559
560
561
562
	declareVars list dvInput
		=	foldState (flip declareVars dvInput) list

instance declareVars (Ptr VarInfo) where
563
	declareVars varInfoPtr _
564
		=	declareVariable BELhsNodeId varInfoPtr "_var???"	// +++ name
565
566

instance declareVars FreeVar where
567
	declareVars :: FreeVar !DeclVarsInput -> BackEnder
568
	declareVars freeVar _
569
		=	declareVariable BELhsNodeId freeVar.fv_info_ptr freeVar.fv_ident.id_name
570

571
572
instance declareVars LetBind where
	declareVars :: LetBind !DeclVarsInput -> BackEnder
573
	declareVars {lb_src=App {app_symb, app_args=[Var _:_]}, lb_dst=freeVar} aliasDummyId
574
		| not (isNilPtr app_symb.symb_ident.id_info) && app_symb.symb_ident==aliasDummyId
575
			= identity		// we have an alias. Don't declare the same variable twice
576
		= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_ident.id_name
577
	declareVars {lb_dst=freeVar} _
578
		= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_ident.id_name
579

580
581
582
declareVariable :: Int (Ptr VarInfo) {#Char} -> BackEnder
declareVariable lhsOrRhs varInfoPtr name
	= \be0 -> let (variable_sequence_number,be) = getVariableSequenceNumber varInfoPtr be0 in
583
		beDeclareNodeId variable_sequence_number lhsOrRhs name be
584
585

instance declareVars (Optional a) | declareVars a where
586
	declareVars :: (Optional a) !DeclVarsInput -> BackEnder | declareVars a
587
588
589
590
591
592
	declareVars (Yes x) dvInput
		=	declareVars x dvInput
	declareVars No _
		=	identity

instance declareVars FunctionPattern where
593
	declareVars :: FunctionPattern !DeclVarsInput -> BackEnder
594
	declareVars (FP_Algebraic _ freeVars) dvInput
595
596
597
598
599
		=	declareVars freeVars dvInput
	declareVars (FP_Variable freeVar) dvInput
		=	declareVars freeVar dvInput

instance declareVars Expression where
600
	declareVars :: Expression !DeclVarsInput -> BackEnder
601
602
603
604
	declareVars (Let {let_strict_binds, let_lazy_binds, let_expr}) dvInput
		=	declareVars let_strict_binds dvInput
		o`	declareVars let_lazy_binds dvInput
		o`	declareVars let_expr dvInput
John van Groningen's avatar
John van Groningen committed
605
606
607
	declareVars (Conditional {if_cond, if_then, if_else}) dvInput
		=	declareVars if_cond dvInput
		o`	declareVars if_then dvInput
608
		o`	declareVars if_else dvInput
609
610
	declareVars (Case caseExpr) dvInput
		=	declareVars caseExpr dvInput
611
612
	declareVars (AnyCodeExpr _ outParams _) _
		=	foldState declVar outParams 
613
	  where
614
		declVar {bind_dst=freeVar} 
615
			= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_ident.id_name
616
617
618
619
	declareVars _ _
		=	identity

instance declareVars TransformedBody where
620
	declareVars :: TransformedBody !DeclVarsInput -> BackEnder
621
622
623
624
	declareVars {tb_args, tb_rhs} dvInput
		=	declareVars tb_args dvInput
		o`	declareVars tb_rhs dvInput

625
626
627
628
629
630
631
632
633
634
instance declareVars Case where
	declareVars {case_expr, case_guards, case_default} dvInput
		=	declareVars case_guards dvInput
		o`	declareVars case_default dvInput

instance declareVars CasePatterns where
	declareVars (AlgebraicPatterns _ patterns) dvInput
		=	declareVars patterns dvInput
	declareVars (BasicPatterns _ patterns) dvInput
		=	declareVars patterns dvInput
635
636
	declareVars (OverloadedListPatterns _ decons_expr patterns) dvInput
		=	declareVars patterns dvInput
637
638
639
640
641
642
643
644
645
646

instance declareVars AlgebraicPattern where
	declareVars {ap_vars, ap_expr} dvInput
		=	declareVars ap_vars dvInput
		o`	declareVars ap_expr dvInput

instance declareVars BasicPattern where
	declareVars {bp_expr} dvInput
		=	declareVars bp_expr dvInput

647
class declare a :: ModuleIndex a  -> BackEnder
648

649
class declareWithIndex a :: Index ModuleIndex a -> BackEnder
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
650

651
instance declare {#a} | declareWithIndex a & Array {#} a where
652
653
654
	declare :: ModuleIndex  {#a} -> BackEnder | declareWithIndex a & Array {#} a 
	declare moduleIndex array
		=	foldStateWithIndexA (\i -> declareWithIndex i moduleIndex) array
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
655

656
657
658
declareFunctionSymbols :: {#FunDef} [(Int, Int)] [IndexRange] *BackEndState -> *BackEndState
declareFunctionSymbols functions functionIndices globalFunctions backEnd
	=	foldl declare backEnd [(functionIndex, componentIndex, functions.[functionIndex]) \\ (componentIndex, functionIndex) <- functionIndices]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
659
	where
660
		declare backEnd (functionIndex, componentIndex, function)
661
			=	appBackEnd (BEDeclareFunction (functionName function.fun_ident.id_name functionIndex globalFunctions) 
662
					function.fun_arity functionIndex componentIndex) backEnd
663
			where
664
665
666
				functionName :: {#Char} Int [IndexRange] -> {#Char}
				functionName name functionIndex icl_global_functions
					| index_in_ranges functionIndex icl_global_functions
667
						=	name
668
669
670
671
672
673
						=	(name +++ ";" +++ toString functionIndex)
					where
						index_in_ranges index [{ir_from, ir_to}:ranges]
							= (index>=ir_from && index < ir_to) || index_in_ranges index ranges;
						index_in_ranges index []
							= False
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
674
675
676
677
678
679
680
681
682
683
684
685

// move to backendsupport
foldStateWithIndexRangeA function frm to array
	:== foldStateWithIndexRangeA frm
	where
		foldStateWithIndexRangeA index
			| index == to
				=	identity
			// otherwise
				=	function index array.[index]
				o`	foldStateWithIndexRangeA (index+1)

686
687
688
689
690
691
692
693
694
folds op l r :== folds l r
	where
		folds [] r = r
		folds [a:x]	r = folds x (op a r)

declareArrayInstances :: [Int] /*IndexRange*/ PredefinedSymbols Int {#FunDef} {#DclModule} -> BackEnder
declareArrayInstances [] predefs main_dcl_module_n functions dcls
	= identity
declareArrayInstances array_first_instance_indices /*{ir_from, ir_to}*/ predefs main_dcl_module_n functions dcls
clean's avatar
clean committed
695
//	| trace_tn ("declareArrayInstances "+++toString ir_from+++" "+++toString ir_to)
696
697
//	=	foldStateWithIndexRangeA declareArrayInstance ir_from ir_to functions
	= folds (declareArrayInstances 0) array_first_instance_indices
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
698
	where
699
700
701
702
703
704
705
706
707
708
709
710
711
712
		arrayModuleIndex = predefs.[PD_StdArray].pds_def
		arrayClassIndex = predefs.[PD_ArrayClass].pds_def
		stdArray = dcls.[arrayModuleIndex]
		arrayClass = stdArray.dcl_common.com_class_defs.[arrayClassIndex]
		n_array_class_members=size arrayClass.class_members

		declareArrayInstances :: Int Index *BackEndState -> *BackEndState
		declareArrayInstances member_n first_member_index backend
			| member_n==n_array_class_members
				= backend
				# function_index=first_member_index+member_n
				# backend = declareArrayInstance function_index functions.[function_index] backend
				= declareArrayInstances (member_n+1) first_member_index backend

713
		declareArrayInstance :: Index FunDef -> BackEnder
714
		declareArrayInstance index {fun_ident={id_name}, fun_type=Yes type}
715
716
			=	beDeclareRuleType index main_dcl_module_n (id_name +++ ";" +++ toString index)
			o`	beDefineRuleType index main_dcl_module_n (convertTypeAlt index main_dcl_module_n type)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
717

718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
declareListInstances :: [Int] Int PredefinedSymbols Int {#FunDef} {#DclModule} -> BackEnder
declareListInstances [] predef_list_class_index predefs main_dcl_module_n functions dcls
	= identity
declareListInstances array_first_instance_indices predef_list_class_index predefs main_dcl_module_n functions dcls
	= folds (declareListInstances 0) array_first_instance_indices
	where
		strictListModuleIndex = predefs.[PD_StdStrictLists].pds_def
		listClassIndex = predefs.[predef_list_class_index].pds_def
		stdStrictLists = dcls.[strictListModuleIndex]
		listClass = stdStrictLists.dcl_common.com_class_defs.[listClassIndex]
		n_list_class_members=size listClass.class_members

		declareListInstances :: Int Index *BackEndState -> *BackEndState
		declareListInstances member_n first_member_index backend
			| member_n==n_list_class_members
				= backend
				# function_index=first_member_index+member_n
				# backend = declareListInstance function_index functions.[function_index] backend
				= declareListInstances (member_n+1) first_member_index backend

		declareListInstance :: Index FunDef -> BackEnder
739
		declareListInstance index {fun_ident={id_name}, fun_type=Yes type}
740
741
742
743
//			| trace_tn ("declareListInstance "+++toString index+++" "+++toString main_dcl_module_n)
			=	beDeclareRuleType index main_dcl_module_n (id_name +++ ";" +++ toString index)
			o`	beDefineRuleType index main_dcl_module_n (convertTypeAlt index main_dcl_module_n type)

744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
declare_icl_common_defs :: ModuleIndex CommonDefs CommonDefs !*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState)
declare_icl_common_defs moduleIndex {com_cons_defs,com_type_defs,com_selector_defs,com_class_defs,com_member_defs} dcl_common_defs type_var_heap bes
	# n_dcl_type_defs = size dcl_common_defs.com_type_defs
	  n_dcl_class_defs = size dcl_common_defs.com_class_defs
	  n_type_defs = size com_type_defs
	  n_class_defs = size com_class_defs
	  first_exported_dictionary_i = n_dcl_type_defs-n_dcl_class_defs
	  first_local_dictionary_i = n_type_defs-(n_class_defs-n_dcl_class_defs)
	  bes = declare moduleIndex com_type_defs bes
	  (type_var_heap,bes)
		= defineTypes 0 first_exported_dictionary_i moduleIndex com_cons_defs com_selector_defs com_type_defs type_var_heap bes
	  (type_var_heap,bes)
		= define_dictionary_types first_exported_dictionary_i 0 n_dcl_type_defs moduleIndex
									com_cons_defs com_selector_defs com_type_defs com_class_defs com_member_defs type_var_heap bes
	  (type_var_heap,bes)
		= defineTypes n_dcl_type_defs first_local_dictionary_i moduleIndex com_cons_defs com_selector_defs com_type_defs type_var_heap bes
	= define_dictionary_types first_local_dictionary_i n_dcl_class_defs n_type_defs moduleIndex
								com_cons_defs com_selector_defs com_type_defs com_class_defs com_member_defs type_var_heap bes

declare_dcl_common_defs :: ModuleIndex CommonDefs !*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState)
declare_dcl_common_defs moduleIndex {com_cons_defs,com_type_defs,com_selector_defs,com_class_defs,com_member_defs} type_var_heap bes
	# n_type_defs = size com_type_defs
	  n_class_defs = size com_class_defs
	  first_dictionary_i = n_type_defs-n_class_defs
	  bes = declare moduleIndex com_type_defs bes
	  (type_var_heap,bes)
		= defineTypes 0 first_dictionary_i moduleIndex com_cons_defs com_selector_defs com_type_defs type_var_heap bes
	= define_dictionary_types first_dictionary_i 0 n_type_defs moduleIndex
								com_cons_defs com_selector_defs com_type_defs com_class_defs com_member_defs type_var_heap bes
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
773

clean's avatar
clean committed
774
instance declareWithIndex (TypeDef a) where
775
	declareWithIndex :: Index ModuleIndex (TypeDef a) -> BackEnder
776
777
	declareWithIndex typeIndex moduleIndex {td_ident}
		=	appBackEnd (BEDeclareType typeIndex moduleIndex td_ident.id_name)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
778

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
779
780
781
declareFunTypes :: ModuleIndex {#FunType} [IndexRange] -> BackEnder
declareFunTypes moduleIndex funTypes ranges
		=	foldStateWithIndexA (declareFunType moduleIndex ranges) funTypes
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
782

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
783
784
declareFunType :: ModuleIndex [IndexRange] Int FunType -> BackEnder
declareFunType moduleIndex ranges functionIndex {ft_ident, ft_type_ptr}
785
	= \be0 -> let (vi,be) = read_from_var_heap ft_type_ptr be0 in
786
787
					(case vi of
						VI_ExpandedType expandedType
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
788
							->	beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex ranges)
789
790
791
							o`	beDefineRuleType functionIndex moduleIndex (convertTypeAlt functionIndex moduleIndex expandedType)
						_
							->	identity) be
792
		where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
793
794
795
			functionName :: {#Char} Int [IndexRange] -> {#Char}
			functionName name functionIndex ranges 
				| index_in_ranges functionIndex ranges
796
					=	name
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
797
798
799
800
801
802
					=	(name +++ ";" +++ toString functionIndex)
				where
					index_in_ranges index [{ir_from, ir_to}:ranges]
						= (index>=ir_from && index < ir_to) || index_in_ranges index ranges;
					index_in_ranges index []
						= False
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
803

804
805
806
807
808
809
defineTypes :: !Int !Int ModuleIndex {#ConsDef} {#SelectorDef} {#CheckedTypeDef} !*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState)
defineTypes type_i type_i_stop moduleIndex constructors selectors types type_var_heap bes
	| type_i<type_i_stop
		# (type_var_heap,bes) = defineType moduleIndex constructors selectors type_i types.[type_i] type_var_heap bes
		= defineTypes (type_i+1) type_i_stop moduleIndex constructors selectors types type_var_heap bes
		= (type_var_heap,bes)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
810

811
812
813
814
815
816
817
818
define_dictionary_types :: !Int !Int !Int ModuleIndex {#ConsDef} {#SelectorDef} {#CheckedTypeDef} {#ClassDef} {#MemberDef} !*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState)
define_dictionary_types type_i class_i type_i_stop moduleIndex constructors selectors types class_defs member_defs type_var_heap bes
	| type_i<type_i_stop
		# (type_var_heap,bes)
			= define_dictionary_type moduleIndex constructors selectors type_i types.[type_i] class_defs.[class_i] member_defs type_var_heap bes
		= define_dictionary_types (type_i+1) (class_i+1) type_i_stop moduleIndex constructors selectors types class_defs member_defs type_var_heap bes
		= (type_var_heap,bes)

819
820
821
822
823
824
825
826
convertTypeLhs :: ModuleIndex Index TypeAttribute [ATypeVar] !*TypeVarHeap !*BackEndState -> (!BEFlatTypeP, !*TypeVarHeap,!*BackEndState)
convertTypeLhs moduleIndex typeIndex attribute args type_var_heap bes
	= convertTypeDefToFlatType (beTypeSymbol typeIndex moduleIndex) attribute args type_var_heap bes

convertTypeDefToFlatType :: (BEMonad BESymbolP) TypeAttribute [ATypeVar] !*TypeVarHeap !*BackEndState -> (!BEFlatTypeP, !*TypeVarHeap,!*BackEndState)
convertTypeDefToFlatType type_symbol_m attribute args type_var_heap bes
	# (a1,bes) = type_symbol_m bes
	  (a2,bes) = convertAttribution attribute bes
827
	  (a3,type_var_heap,bes) = convertAndNumberLhsTypeVars args 0 type_var_heap bes
828
829
	  (flat_type_p,bes) = accBackEnd (BEFlatType a1 a2 a3) bes
	= (flat_type_p,type_var_heap,bes)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
830
831
832

convertTypeVars :: [ATypeVar] -> BEMonad BETypeVarListP
convertTypeVars typeVars
833
	=	sfoldr (beTypeVars o convertTypeVar) beNoTypeVars typeVars
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
834

835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
convertAndNumberLhsTypeVars :: [ATypeVar] Int !*TypeVarHeap !*BackEndState -> (!BETypeVarListP,!*TypeVarHeap,!*BackEndState)
convertAndNumberLhsTypeVars [a=:{atv_variable={tv_info_ptr}}:x] arg_n type_var_heap beState
	# type_var_heap = writePtr tv_info_ptr (TVI_TypeVarArgN arg_n) type_var_heap
	  (a1,beState) = convertNumberedTypeVar a arg_n beState
	  (a2,type_var_heap,beState) = convertAndNumberLhsTypeVars x (arg_n+1) type_var_heap beState
	  (type_vars,beState) = accBackEnd (BETypeVars a1 a2) beState
	= (type_vars,type_var_heap,beState)
convertAndNumberLhsTypeVars [] arg_n type_var_heap beState
	# (type_vars,beState) = accBackEnd BENoTypeVars beState
	= (type_vars,type_var_heap,beState)

remove_TVI_TypeVarArgN_in_args :: [ATypeVar] !*TypeVarHeap -> *TypeVarHeap
remove_TVI_TypeVarArgN_in_args [{atv_variable={tv_info_ptr}}:args] type_var_heap
	# type_var_heap = writePtr tv_info_ptr TVI_Empty type_var_heap
	= remove_TVI_TypeVarArgN_in_args args type_var_heap
remove_TVI_TypeVarArgN_in_args [] type_var_heap
	= type_var_heap

convertNumberedTypeVar :: ATypeVar Int -> BEMonad BETypeVarListP
convertNumberedTypeVar typeVar arg_n
	= beTypeVarListElem (accBackEnd (BENumberedTypeVar typeVar.atv_variable.tv_ident.id_name arg_n)) (convertAttribution typeVar.atv_attribute)

857
convertTypeVar :: ATypeVar -> BEMonad BETypeVarListP
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
858
convertTypeVar typeVar
859
	=	beTypeVarListElem (beTypeVar typeVar.atv_variable.tv_ident.id_name) (convertAttribution typeVar.atv_attribute)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
860

861
defineType :: ModuleIndex {#ConsDef} {#SelectorDef} Index CheckedTypeDef !*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState)
862
defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgType constructorSymbols} type_var_heap be
863
	# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be
864
865
	  (constructors,type_var_heap,be)
		= convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols type_var_heap be
866
	  be = appBackEnd (BEAlgebraicType flatType constructors) be
867
	  type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
868
869
	= (type_var_heap,be)
defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args, td_rhs=RecordType {rt_constructor, rt_fields, rt_is_boxed_record}, td_fun_index} type_var_heap be
John van Groningen's avatar
John van Groningen committed
870
871
	# constructorIndex = rt_constructor.ds_index
	  constructorDef = constructors.[constructorIndex]
872
	  (flatType,type_var_heap,be)
John van Groningen's avatar
John van Groningen committed
873
		= if (td_fun_index<>NoIndex)
874
			(convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be)
John van Groningen's avatar
John van Groningen committed
875
			// define the record without marking, to prevent code generation for many unused generic dictionaries
876
			(convertTypeDefToFlatType (beTypeSymbolNoMark typeIndex moduleIndex) td_attribute td_args type_var_heap be)
877
878
879
	  (fields,type_var_heap,be)
		= convertSelectors moduleIndex selectors rt_fields constructorDef.cons_type.st_args_strictness type_var_heap be
	  (constructorType,be) = constructorTypeFunction constructorDef be
880
	  (type_arg_p,type_var_heap,be) = convertTypeDefAnnotatedTypeArgs constructorType.st_args constructorType.st_args_strictness type_var_heap be
881
882
	  (symbol_p,be) = beConstructorSymbol moduleIndex constructorIndex be
	  (constructorTypeNode,be) = accBackEnd (BENormalTypeNode symbol_p type_arg_p) be
883
	  be = appBackEnd (BERecordType moduleIndex flatType constructorTypeNode (if rt_is_boxed_record 1 0) fields) be
884
	  type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
885
	= (type_var_heap,be)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
886
	where
887
888
889
890
891
892
893
		constructorTypeFunction constructorDef bes
			# (cons_type,bes) = read_from_var_heap constructorDef.cons_type_ptr bes
			= case cons_type of
					VI_ExpandedType expandedType
						->	(expandedType,bes)
					_
						->	(constructorDef.cons_type,bes)
894
defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractType _} type_var_heap be
895
896
 	# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be
	  be = appBackEnd (BEAbsType flatType) be
897
	  type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
898
899
 	= (type_var_heap,be)
defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractSynType _ _} type_var_heap be
900
901
 	# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be
	  be = appBackEnd (BEAbsType flatType) be
902
	  type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
903
904
 	= (type_var_heap,be)
defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=ExtensibleAlgType constructorSymbols} type_var_heap be
905
	# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be
906
907
	  (constructors,type_var_heap,be)
		= convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols type_var_heap be
908
	  be = appBackEnd (BEExtendableAlgebraicType flatType constructors) be
909
	  type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
910
911
	= (type_var_heap,be)
defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgConses constructorSymbols _} type_var_heap be
912
	# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be
913
914
	  (constructors,type_var_heap,be)
		= convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols type_var_heap be
915
	  be = appBackEnd (BEExtendableAlgebraicType flatType constructors) be
916
	  type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
917
918
919
	= (type_var_heap,be)
defineType _ _ _ _ _ type_var_heap be
	= (type_var_heap,be)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
920

921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
define_dictionary_type :: ModuleIndex {#ConsDef} {#SelectorDef} Index CheckedTypeDef ClassDef {#MemberDef}
						!*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState)
define_dictionary_type moduleIndex constructors selectors typeIndex
						{td_attribute,td_args,td_rhs=RecordType {rt_constructor,rt_fields,rt_is_boxed_record},td_fun_index}
						{class_members} member_defs type_var_heap bes
	# constructorIndex = rt_constructor.ds_index
	  constructorDef = constructors.[constructorIndex]
	  (flatType,type_var_heap,bes)
		= if (td_fun_index<>NoIndex)
			(convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap bes)
			// define the record without marking, to prevent code generation for many unused generic dictionaries
			(convertTypeDefToFlatType (beTypeSymbolNoMark typeIndex moduleIndex) td_attribute td_args type_var_heap bes)
	  (fields,type_var_heap,bes)
		= convert_dictionary_selectors moduleIndex selectors rt_fields class_members constructorDef.cons_type.st_args_strictness member_defs type_var_heap bes
	  (constructorType,bes) = constructorTypeFunction constructorDef bes
	  (type_arg_p,type_var_heap,bes) = convertTypeDefAnnotatedTypeArgs constructorType.st_args constructorType.st_args_strictness type_var_heap bes
	  (symbol_p,bes) = beConstructorSymbol moduleIndex constructorIndex bes
	  (constructorTypeNode,bes) = accBackEnd (BENormalTypeNode symbol_p type_arg_p) bes
	  bes = appBackEnd (BERecordType moduleIndex flatType constructorTypeNode (if rt_is_boxed_record 1 0) fields) bes
	  type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
	= (type_var_heap,bes)
	where
		constructorTypeFunction constructorDef bes
			# (cons_type,bes) = read_from_var_heap constructorDef.cons_type_ptr bes
			= case cons_type of
					VI_ExpandedType expandedType
						->	(expandedType,bes)
					_
						->	(constructorDef.cons_type,bes)

951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969