backendconvert.icl 84.1 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
4
5
6
7
8
9
implementation module backendconvert

import code from library "backend_library"

import StdEnv

import frontend
import backend
import backendsupport, backendpreprocess
10
11

//import RWSDebug
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
12

clean's avatar
clean committed
13
14
15
16
// trace macro
(-*->) infixl
(-*->) value trace
	:==	value // ---> trace
17
18
19
20
21
22
23
24
25
26
27
28
/*
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
29

30
31
32
33
34
// fix spelling, this will be removed when cases are implemented in the back end
:: BackEndBody :== BackendBody
BackEndBody x :== BackendBody x


35
:: BEMonad a :== St !*BackEndState !a
clean's avatar
clean committed
36

37
:: BackEnder :== *BackEndState -> *BackEndState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
38

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

42
43
44
45
appBackEnd f beState
	:== {beState & bes_backEnd = bes_backEnd}
	where
		bes_backEnd = f beState.bes_backEnd
46

47
48
49
50
51
52
53
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
54

55
56
accVarHeap f beState
	:== (result, {beState & bes_varHeap = varHeap})
57
	where
58
		(result, varHeap) =	f beState.bes_varHeap
59

60
61
62
63
64
65
66
accAttrHeap f beState
	:== (result, {beState & bes_attrHeap = attrHeap})
	where
		(result, attrHeap) =	f beState.bes_attrHeap


read_from_var_heap :: VarInfoPtr BackEndState -> (VarInfo, BackEndState)
67
read_from_var_heap ptr beState
68
69
70
	= (result, {beState & bes_varHeap = varHeap})
where
		(result, varHeap) =	readPtr ptr beState.bes_varHeap
71

72
73
write_to_var_heap ptr v beState
	= {beState & bes_varHeap = writePtr ptr v beState.bes_varHeap}
74
75
76
77
78
79
80
81

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}
82
83
84
/*
read_from_var_heap ptr heap be
	= (sreadPtr ptr heap,be)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
85

86
87
88
89
::	*BackEndState :== BackEnd

appBackEnd f beState :== f beState
accBackEnd f beState :== f beState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
90
accVarHeap f beState :== f beState
91
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
92

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

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
177
178
179
180
181
182
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
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
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)
200
201
202
203

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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
204
205
206
207
beFieldSymbol fieldIndex moduleIndex
	:==	beFunction0 (BEFieldSymbol fieldIndex moduleIndex)
beTypeSymbol typeIndex moduleIndex
	:==	beFunction0 (BETypeSymbol typeIndex moduleIndex)
208
209
beBasicSymbol symbolIndex
	:==	beFunction0 (BEBasicSymbol symbolIndex)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
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
beVarTypeNode name
	:==	beFunction0 (BEVarTypeNode name)
beRuleAlt lineNumber
	:==	beFunction5 (BERuleAlt lineNumber)
beNoRuleAlts
	:==	beFunction0 BENoRuleAlts
beRuleAlts
	:==	beFunction2 BERuleAlts
beTypeAlt
241
	:==	beFunction3 BETypeAlt
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
beRule index isCaf
	:==	beFunction2 (BERule index isCaf)
beNoRules
	:==	beFunction0 BENoRules
beRules
	:==	beFunction2 BERules
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)
beWildCardNodeId
	:==	beFunction0 BEWildCardNodeId
beConstructor
	:==	beFunction1 BEConstructor
beNoConstructors
	:==	beFunction0 BENoConstructors
beConstructors
	:==	beFunction2 BEConstructors
beNoFields
	:==	beFunction0 BENoFields
beFields
	:==	beFunction2 BEFields
beField fieldIndex moduleIndex 
	:==	beFunction1 (BEField fieldIndex moduleIndex)
beAnnotateTypeNode annotation
	:==	beFunction1 (BEAnnotateTypeNode annotation)
280
281
beAttributeTypeNode
	:==	beFunction2 BEAttributeTypeNode
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
282
beDeclareRuleType functionIndex moduleIndex name
283
	:==	beApFunction0 (BEDeclareRuleType functionIndex moduleIndex name)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
284
beDefineRuleType functionIndex moduleIndex
285
	:==	beApFunction1 (BEDefineRuleType functionIndex moduleIndex)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
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
305
306
307
	:==	beApFunction0 (BEDeclareNodeId number lhsOrRhs name)
beAdjustArrayFunction backendId functionIndex moduleIndex
	:==	beApFunction0 (BEAdjustArrayFunction backendId functionIndex moduleIndex)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
308
309
310
311
312
313
314
315
beFlatType
	:==	beFunction2 BEFlatType
beNoTypeVars
	:==	beFunction0 BENoTypeVars
beTypeVars
	:==	beFunction2 BETypeVars
beTypeVar name
	:==	beFunction0 (BETypeVar name)
clean's avatar
clean committed
316
beExportType dclTypeIndex iclTypeIndex
317
	:==	beApFunction0 (BEExportType dclTypeIndex iclTypeIndex)
clean's avatar
clean committed
318
beExportConstructor dclConstructorIndex iclConstructorIndex
319
	:==	beApFunction0 (BEExportConstructor dclConstructorIndex iclConstructorIndex)
clean's avatar
clean committed
320
beExportField dclFieldIndex iclFieldIndex
321
	:==	beApFunction0 (BEExportField dclFieldIndex iclFieldIndex)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
322
beExportFunction dclIndexFunctionIndex iclFunctionIndex
323
	:==	beApFunction0 (BEExportFunction dclIndexFunctionIndex iclFunctionIndex)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
324
325
326
327
328
beTupleSelectNode arity index
	:==	beFunction1 (BETupleSelectNode arity index)
beMatchNode arity
	:==	beFunction2 (BEMatchNode arity)
beDefineImportedObjsAndLibs
329
	:== beApFunction2 BEDefineImportedObjsAndLibs
clean's avatar
clean committed
330
beAbsType
331
	:== beApFunction1 BEAbsType
332
333
334
335
336
337
338
339
340
341
342
343
344
345
beSwitchNode
	:==	beFunction2 BESwitchNode
beCaseNode symbolArity
	:== beFunction4 (BECaseNode symbolArity)
bePushNode symbolArity
	:== beFunction3 (BEPushNode symbolArity)
beDefaultNode
	:==	beFunction3 BEDefaultNode
beNoNodeIds
	:==	beFunction0 BENoNodeIds
beNodeIds
	:==	beFunction2 BENodeIds
beNodeIdListElem
	:==	beFunction1 BENodeIdListElem
346
347
348
349
350
351
352
353
354
355
356
357
358
beAttributeKind
	:== beFunction1 BEAttributeKind
beNoAttributeKinds
	:== beFunction0 BENoAttributeKinds
beAttributeKinds
	:== beFunction2 BEAttributeKinds
beUniVarEquation
	:== beFunction2 BEUniVarEquation
beNoUniVarEquations
	:== beFunction0 BENoUniVarEquations
beUniVarEquationsList
	:== beFunction2 BEUniVarEquationsList

359
360
361
// temporary hack
beDynamicTempTypeSymbol
	:== beFunction0 BEDynamicTempTypeSymbol
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
362
363
364
365
366

notYetImplementedExpr :: Expression
notYetImplementedExpr
	=	(BasicExpr (BVS "\"error in compiler (something was not implemented by lazy Ronny)\"") BT_Int)

367
backEndConvertModules :: PredefinedSymbols FrontEndSyntaxTree !Int *VarHeap *AttrVarHeap *BackEnd -> (!*VarHeap, *AttrVarHeap, !*BackEnd)
368
369
370
371
/*
backEndConvertModules p s main_dcl_module_n v be
	= (newHeap,backEndConvertModulesH p s v be)
*/
372
373
374
backEndConvertModules p s main_dcl_module_n var_heap attr_var_heap be
	# {bes_varHeap,bes_attrHeap,bes_backEnd} = backEndConvertModulesH p s main_dcl_module_n {bes_varHeap=var_heap,bes_attrHeap=attr_var_heap,bes_backEnd=be, bes_attr_number = 0}
	= (bes_varHeap,bes_attrHeap,bes_backEnd)
375

376
backEndConvertModulesH :: PredefinedSymbols FrontEndSyntaxTree !Int *BackEndState -> *BackEndState
377
378
379
380
backEndConvertModulesH predefs {fe_icl = 
	fe_icl =: {icl_name, icl_functions, icl_common,icl_imported_objects,icl_used_module_numbers},
	fe_components, fe_dcls, fe_arrayInstances, fe_dclIclConversions, fe_iclDclConversions,fe_globalFunctions}
	main_dcl_module_n backEnd
381
	// sanity check ...
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
382
383
384
385
386
387
388
//	| cIclModIndex <> kIclModuleIndex || cPredefinedModuleIndex <> kPredefinedModuleIndex
//		=	undef <<- "backendconvert, backEndConvertModules: module index mismatch"
	// ... sanity check
/*
	#  backEnd
		=	ruleDoesNotMatch 1 backEnd
			with
389
390
				ruleDoesNotMatch 0 backEnd
					=	backEnd
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
391
392
	#  backEnd
		=	abort "front end abort" backEnd
393
*/	#! backEnd = appBackEnd (BESetMainDclModuleN main_dcl_module_n) backEnd
394
395
396
	#! backEnd
		=	appBackEnd (BEDeclareModules (size fe_dcls)) backEnd
	#! backEnd
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
397
		=	predefineSymbols fe_dcls.[cPredefinedModuleIndex] predefs backEnd
clean's avatar
clean committed
398
399

	#  currentDcl
400
	   	=	fe_dcls.[main_dcl_module_n]
clean's avatar
clean committed
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
	   typeConversions
		=	currentModuleTypeConversions icl_common.com_class_defs currentDcl.dcl_common.com_class_defs currentDcl.dcl_conversions
/*
	# 	rstypes = reshuffleTypes (size icl_common.com_type_defs) typeConversions {type.td_name.id_name \\ type <-: currentDcl.dcl_common.com_type_defs}
		types = {type.td_name.id_name \\ type <-: icl_common.com_type_defs}
	#  backEnd
		=	backEnd ->>
				(	"dcl conversions"
				,	currentDcl.dcl_conversions
				,	"dcl constructors"
				,	[constructor.cons_symb.id_name \\ constructor <-: currentDcl.dcl_common.com_cons_defs]
				,	"dcl selectors"
				,	[selector.sd_symb.id_name \\ selector <-: currentDcl.dcl_common.com_selector_defs]
				,	"dcl types"
				,	[type.td_name.id_name \\ type <-: currentDcl.dcl_common.com_type_defs]
				,	"icl selectors"
				,	[constructor.cons_symb.id_name \\ constructor <-: icl_common.com_cons_defs]
				,	"icl fields"
				,	[selector.sd_symb.id_name \\ selector <-: icl_common.com_selector_defs]
				,	"icl types"
				,	[type.td_name.id_name \\ type <-: icl_common.com_type_defs]
				,	"compare names"
				,	(rstypes, types)
				)
*/
426
427
428
429
	#! 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")
430
431
432
433
434

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

435
	#! backEnd
436
		=	defineDclModule main_dcl_module_n fe_dcls.[main_dcl_module_n] (backEnd -*-> "defineDclModule(cIclMoIndex)")
437
	#! backEnd
clean's avatar
clean committed
438
		=	reshuffleTypes (size icl_common.com_type_defs) typeConversions (backEnd -*-> "reshuffleTypes")
439
	#! backEnd
440
		=	defineOtherDclModules fe_dcls main_dcl_module_n icl_used_module_numbers (backEnd -*-> "defineOtherDclModules")
clean's avatar
clean committed
441

442
443
444
	#! backEnd
		=	appBackEnd (BEDeclareIclModule icl_name.id_name (size icl_functions) (size icl_common.com_type_defs) (size icl_common.com_cons_defs) (size icl_common.com_selector_defs)) (backEnd -*-> "BEDeclareIclModule")
	#! backEnd
445
		=	declareFunctionSymbols icl_functions (getConversions fe_iclDclConversions) functionIndices fe_globalFunctions (backEnd -*-> "declareFunctionSymbols")
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
446
447
448
449
450
451
		with
			getConversions :: (Optional {#Int}) -> {#Int}
			getConversions No
				=	{}
			getConversions (Yes conversions)
				=	conversions
452
	#! backEnd
453
		=	declare main_dcl_module_n icl_common (backEnd -*-> "declare (main_dcl_module_n)")
454
	#! backEnd
455
456
457
458
459
460
461
		=	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")
462
	#! backEnd
463
		=	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
464
	#! (rules, backEnd)
465
		=	convertRules [(index, icl_functions.[index]) \\ (_, index) <- functionIndices] main_dcl_module_n predefs.[PD_DummyForStrictAliasFun].pds_ident (backEnd -*-> "convertRules")
466
467
	#! backEnd
		=	appBackEnd (BEDefineRules rules) (backEnd -*-> "BEDefineRules")
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
468
469
470
471
	#! 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
472
				(backEnd -*-> "beDefineImportedObjsAndLibs")
473
474
	#! backEnd
		=	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 fe_dclIclConversions (backEnd -*-> "markExports")
clean's avatar
clean committed
475
476
477
			with
				dcl_common
					=	currentDcl.dcl_common
478
479
	#! backEnd = removeExpandedTypesFromDclModules fe_dcls icl_used_module_numbers backEnd
	=	(backEnd -*-> "backend done")
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
480
481
	where
		functionIndices
482
			=	flatten [[(componentIndex, member) \\ member <- group.group_members] \\ group <-: fe_components & componentIndex <- [1..]]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
483

484
declareOtherDclModules :: {#DclModule} Int NumberSet -> BackEnder
485
declareOtherDclModules dcls main_dcl_module_n used_module_numbers
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
486
	=	foldStateWithIndexA declareOtherDclModule dcls
487
488
489
where
	declareOtherDclModule :: ModuleIndex DclModule -> BackEnder
	declareOtherDclModule moduleIndex dclModule
490
		| moduleIndex == main_dcl_module_n || moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers)
491
492
493
494
			=	identity
		// otherwise
			=	declareDclModule moduleIndex dclModule

495
496
497
defineOtherDclModules :: {#DclModule} Int NumberSet -> BackEnder
defineOtherDclModules dcls main_dcl_module_n used_module_numbers
	=	foldStateWithIndexA defineOtherDclModule dcls
498
where
499
500
	defineOtherDclModule :: ModuleIndex DclModule -> BackEnder
	defineOtherDclModule moduleIndex dclModule
501
		| moduleIndex == main_dcl_module_n || moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers)
502
503
			=	identity
		// otherwise
504
			=	defineDclModule moduleIndex dclModule
505

506
507
508
509
510
511
512
513
isSystem :: ModuleKind -> Bool
isSystem MK_System
	=	True
isSystem MK_Module
	=	False
isSystem _
	=	abort "backendconvert:isSystem, unknown module kind"

514
declareCurrentDclModule :: IclModule DclModule Int -> BackEnder
515
516
517
518
519
declareCurrentDclModule _ {dcl_module_kind=MK_None} _
	=	identity
declareCurrentDclModule {icl_common} {dcl_name, dcl_functions, dcl_module_kind, dcl_common} main_dcl_module_n
	=	appBackEnd (BEDeclareDclModule main_dcl_module_n dcl_name.id_name (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))

520
declareDclModule :: ModuleIndex DclModule -> BackEnder
521
522
declareDclModule moduleIndex {dcl_name, dcl_common, dcl_functions, dcl_module_kind}
	=	appBackEnd (BEDeclareDclModule moduleIndex dcl_name.id_name (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))
523
/*
524
525
defineCurrentDclModule :: IclModule DclModule {#Int} -> BackEnder
defineCurrentDclModule {icl_common} {dcl_name, dcl_common, dcl_functions, dcl_is_system, dcl_conversions} typeConversions
526
527
	=	declareCurrentDclModuleTypes icl_common.com_type_defs typeConversions
	o`	defineCurrentDclModuleTypes dcl_common.com_cons_defs dcl_common.com_selector_defs dcl_common.com_type_defs typeConversions
528
*/
529
530
531
532
defineDclModule :: ModuleIndex DclModule -> BackEnder
defineDclModule moduleIndex {dcl_name, dcl_common, dcl_functions,dcl_instances}
	=	declare moduleIndex dcl_common
	o`	declareFunTypes moduleIndex dcl_functions dcl_instances.ir_from
533

534
removeExpandedTypesFromDclModules :: {#DclModule} NumberSet -> BackEnder
535
536
537
538
539
removeExpandedTypesFromDclModules dcls used_module_numbers
	=	foldStateWithIndexA removeExpandedTypesFromDclModule dcls
where
	removeExpandedTypesFromDclModule :: ModuleIndex DclModule -> BackEnder
	removeExpandedTypesFromDclModule moduleIndex dclModule=:{dcl_functions}
540
		| moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers)
541
542
543
544
545
			= identity
			= foldStateWithIndexA (removeExpandedTypesFromFunType moduleIndex)  dcl_functions
			where
				removeExpandedTypesFromFunType :: ModuleIndex Index FunType -> BackEnder
				removeExpandedTypesFromFunType moduleIndex functionIndex {ft_symb, ft_type_ptr}
546
					= \be0 ->	let (ft_type,be) = read_from_var_heap ft_type_ptr be0 in
547
548
549
550
551
						(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
552

clean's avatar
clean committed
553
554
555
556
// move types from their dcl to icl positions

class swapTypes a :: Int Int *a -> *a

557
558
instance swapTypes BackEndState where
//instance swapTypes BackEnd where
clean's avatar
clean committed
559
	swapTypes i j be
560
		=	appBackEnd (BESwapTypes i j) be
clean's avatar
clean committed
561
562
563
564
565
566
567
568
569
570
571
572

instance swapTypes {{#Char}} where
	swapTypes i j a
		=	swap i j a

swap i j a
	#! iValue = a.[i]
	#! jValue = a.[j]
	=	{a & [i] = jValue, [j] = iValue}

reshuffleTypes :: Int {#Int} *a -> *a | swapTypes a
reshuffleTypes nIclTypes dclIclConversions be
clean's avatar
clean committed
573
	=	thd3 (foldStateWithIndexA (swapType nDclTypes) dclIclConversions (idP nDclTypes, idP nIclTypes, be))
clean's avatar
clean committed
574
	where
clean's avatar
clean committed
575
576
577
		nDclTypes
			=	size dclIclConversions

clean's avatar
clean committed
578
579
580
581
		idP :: Int -> .{#Int}
		idP n
			=	{i \\ i <- [0 .. n-1]}

clean's avatar
clean committed
582
583
		swapType :: Int Int Int (*{#Int}, *{#Int},  *a) -> (*{#Int}, *{#Int},  *a) | swapTypes a
		swapType nDclTypes dclIndex iclIndex state=:(p,p`,be)
clean's avatar
clean committed
584
585
586
587
588
589
590
591
592
			#! frm
				=	p.[dclIndex]
			#! to
				=	iclIndex
			| frm == to
				=	state
			// otherwise
				#! frm` = dclIndex
				#! to` = p`.[iclIndex]
clean's avatar
clean committed
593
				#! to` = if (to` >= nDclTypes) frm` to`
clean's avatar
clean committed
594
595
				=	(swap frm` to` p, swap frm to p`, swapTypes frm to be)

596
:: DeclVarsInput :== Ident
597

598
class declareVars a :: a !DeclVarsInput -> BackEnder
599
600

instance declareVars [a] | declareVars a where
601
	declareVars :: [a] !DeclVarsInput -> BackEnder | declareVars a
602
603
604
605
	declareVars list dvInput
		=	foldState (flip declareVars dvInput) list

instance declareVars (Ptr VarInfo) where
606
	declareVars varInfoPtr _
607
		=	declareVariable BELhsNodeId varInfoPtr "_var???"	// +++ name
608
609

instance declareVars FreeVar where
610
	declareVars :: FreeVar !DeclVarsInput -> BackEnder
611
612
	declareVars freeVar _
		=	declareVariable BELhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name
613

614
615
instance declareVars LetBind where
	declareVars :: LetBind !DeclVarsInput -> BackEnder
616
	declareVars {lb_src=App {app_symb, app_args=[Var _:_]}, lb_dst=freeVar} aliasDummyId
John van Groningen's avatar
John van Groningen committed
617
		| not (isNilPtr app_symb.symb_name.id_info) && app_symb.symb_name==aliasDummyId
618
			= identity		// we have an alias. Don't declare the same variable twice
619
620
621
		= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name
	declareVars {lb_dst=freeVar} _
		= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name
622

623
624
625
declareVariable :: Int (Ptr VarInfo) {#Char} -> BackEnder
declareVariable lhsOrRhs varInfoPtr name
	= \be0 -> let (variable_sequence_number,be) = getVariableSequenceNumber varInfoPtr be0 in
626
		beDeclareNodeId variable_sequence_number lhsOrRhs name be
627
628

instance declareVars (Optional a) | declareVars a where
629
	declareVars :: (Optional a) !DeclVarsInput -> BackEnder | declareVars a
630
631
632
633
634
635
	declareVars (Yes x) dvInput
		=	declareVars x dvInput
	declareVars No _
		=	identity

instance declareVars FunctionPattern where
636
	declareVars :: FunctionPattern !DeclVarsInput -> BackEnder
637
638
639
640
641
642
643
644
645
646
647
	declareVars (FP_Algebraic _ freeVars optionalVar) dvInput
		=	declareVars freeVars dvInput
		o`	declareVars optionalVar dvInput
	declareVars (FP_Variable freeVar) dvInput
		=	declareVars freeVar dvInput
	declareVars (FP_Basic _ optionalVar) dvInput
		=	declareVars optionalVar dvInput
	declareVars FP_Empty dvInput
		=	identity

instance declareVars Expression where
648
	declareVars :: Expression !DeclVarsInput -> BackEnder
649
650
651
652
	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
653
654
655
	declareVars (Conditional {if_cond, if_then, if_else}) dvInput
		=	declareVars if_cond dvInput
		o`	declareVars if_then dvInput
656
		o`	declareVars if_else dvInput
657
658
	declareVars (Case caseExpr) dvInput
		=	declareVars caseExpr dvInput
659
660
	declareVars (AnyCodeExpr _ outParams _) _
		=	foldState declVar outParams 
661
	  where
662
663
		declVar {bind_dst=freeVar} 
			= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name
664
665
666
667
	declareVars _ _
		=	identity

instance declareVars TransformedBody where
668
	declareVars :: TransformedBody !DeclVarsInput -> BackEnder
669
670
671
672
673
	declareVars {tb_args, tb_rhs} dvInput
		=	declareVars tb_args dvInput
		o`	declareVars tb_rhs dvInput

instance declareVars BackendBody where
674
	declareVars :: BackendBody !DeclVarsInput -> BackEnder
675
676
677
678
	declareVars {bb_args, bb_rhs} dvInput
		=	declareVars bb_args dvInput
		o`	declareVars bb_rhs dvInput

679
680
681
682
683
684
685
686
687
688
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
689
690
	declareVars (OverloadedListPatterns _ decons_expr patterns) dvInput
		=	declareVars patterns dvInput
691
692
693
694
695
696
697
698
699
700

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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
701
702
:: ModuleIndex :== Index

703
class declare a :: ModuleIndex a  -> BackEnder
704

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

707
//1.3
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
708
instance declare {#a} | declareWithIndex a & ArrayElem a where
709
	declare :: ModuleIndex  {#a} -> BackEnder | declareWithIndex a & ArrayElem a 
710
711
712
//3.1
/*2.0
instance declare {#a} | declareWithIndex a & Array {#} a where
713
	declare :: ModuleIndex  {#a} -> BackEnder | declareWithIndex a & Array {#} a 
714
0.2*/
715
716
	declare moduleIndex array
		=	foldStateWithIndexA (\i -> declareWithIndex i moduleIndex) array
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
717

718
declareFunctionSymbols :: {#FunDef} {#Int} [(Int, Int)] IndexRange *BackEndState -> *BackEndState
719
declareFunctionSymbols functions iclDclConversions functionIndices globalFunctions backEnd
720
	=	foldl (declare iclDclConversions) backEnd [(functionIndex, componentIndex, functions.[functionIndex]) \\ (componentIndex, functionIndex) <- functionIndices]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
721
	where
722
		declare iclDclConversions backEnd (functionIndex, componentIndex, function)
723
724
			=	appBackEnd (BEDeclareFunction (functionName function.fun_symb.id_name functionIndex iclDclConversions globalFunctions) 
					function.fun_arity functionIndex componentIndex) backEnd
725
726
727
			where
				functionName :: {#Char} Int {#Int} IndexRange -> {#Char}
				functionName name functionIndex iclDclConversions {ir_from, ir_to}
clean's avatar
clean committed
728
//				| trace_t ("|"+++toString functionIndex)
729
730
731
732
					| functionIndex >= ir_to || functionIndex < ir_from
						=	(name +++ ";" +++ toString iclDclConversions.[functionIndex])
					// otherwise
						=	name
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
733
734
735
736
737
738
739
740
741
742
743
744

// 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)

745
746
747
748
749
750
751
752
753
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
754
//	| trace_tn ("declareArrayInstances "+++toString ir_from+++" "+++toString ir_to)
755
756
//	=	foldStateWithIndexRangeA declareArrayInstance ir_from ir_to functions
	= folds (declareArrayInstances 0) array_first_instance_indices
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
757
	where
758
759
760
761
762
763
764
765
766
767
768
769
770
771
		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

772
		declareArrayInstance :: Index FunDef -> BackEnder
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
773
		declareArrayInstance index {fun_symb={id_name}, fun_type=Yes type}
774
775
			=	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
776

777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
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
		declareListInstance index {fun_symb={id_name}, fun_type=Yes type}
//			| 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)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
803
instance declare CommonDefs where
804
805
806
807
	declare :: ModuleIndex CommonDefs -> BackEnder
	declare moduleIndex {com_cons_defs, com_type_defs, com_selector_defs, com_class_defs}
		=	declare moduleIndex com_type_defs
		o`	defineTypes moduleIndex com_cons_defs com_selector_defs com_type_defs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
808

clean's avatar
clean committed
809
instance declareWithIndex (TypeDef a) where
810
811
	declareWithIndex :: Index ModuleIndex (TypeDef a) -> BackEnder
	declareWithIndex typeIndex moduleIndex {td_name}
812
		=	appBackEnd (BEDeclareType typeIndex moduleIndex td_name.id_name)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
813

814
815
816
declareFunTypes :: ModuleIndex {#FunType} Int -> BackEnder
declareFunTypes moduleIndex funTypes nrOfDclFunctions
		=	foldStateWithIndexA (declareFunType moduleIndex nrOfDclFunctions) funTypes
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
817

818
819
820
declareFunType :: ModuleIndex Index Int FunType -> BackEnder
declareFunType moduleIndex nrOfDclFunctions functionIndex {ft_symb, ft_type_ptr}
	= \be0 -> let (vi,be) = read_from_var_heap ft_type_ptr be0 in
821
822
823
					(case vi of
						VI_ExpandedType expandedType
							->	beDeclareRuleType functionIndex moduleIndex (functionName ft_symb.id_name functionIndex nrOfDclFunctions)
clean's avatar
clean committed
824
//							->	beDeclareRuleType functionIndex moduleIndex (functionName moduleIndex ft_symb.id_name functionIndex nrOfDclFunctions)
825
826
827
							o`	beDefineRuleType functionIndex moduleIndex (convertTypeAlt functionIndex moduleIndex expandedType)
						_
							->	identity) be
828
		where
829
830
831
832
//			functionName :: Int {#Char} Int Int -> {#Char}
//			functionName moduleIndex name functionIndex nrOfDclFunctions 
//				| trace_t (":"+++toString moduleIndex+++" "+++toString functionIndex)

833
834
835
836
837
838
			functionName :: {#Char} Int Int -> {#Char}
			functionName name functionIndex nrOfDclFunctions 
				| functionIndex < nrOfDclFunctions
					=	name
				// otherwise
					=	name +++ ";" +++ toString functionIndex
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882

currentModuleTypeConversions :: {#ClassDef} {#ClassDef} (Optional ConversionTable) -> {#Int}
currentModuleTypeConversions iclClasses dclClasses (Yes conversionTable)
	// sanity check ...
	| sort [dclClass.class_dictionary.ds_index \\ dclClass <-: dclClasses]
				<> [size typeConversions .. size typeConversions + size dclClasses - 1]
		=	abort "backendconvert, currentModuleTypeConversions wrong index range for dcl dictionary types"
	// ... sanity check
	| nDclClasses == 0
		=	typeConversions
	// otherwise
		=	{createArray (nDclTypes + nDclClasses) NoIndex
				& [i] = typeConversion
					\\ typeConversion <-: typeConversions & i <- [0..]}
			:-  foldStateWithIndexA (updateDictionaryTypeIndex classConversions) classConversions
	where
		typeConversions
			=	conversionTable.[cTypeDefs]
		nDclTypes
			=	size typeConversions
		classConversions
			=	conversionTable.[cClassDefs]
		nDclClasses
			=	size classConversions

		updateDictionaryTypeIndex :: {#Int} Int Int *{#Int} -> *{#Int}
		updateDictionaryTypeIndex classConversions dclClassIndex iclClassIndex allTypeConversions
			// sanity check ...
			# (oldIndex, allTypeConversions)
				=	uselect allTypeConversions dclTypeIndex
			| oldIndex <> NoIndex
				=	abort "backendconvert, updateDictionaryTypeIndex wrong index overwritten"
			// ... sanity chechk
			=	{allTypeConversions & [dclTypeIndex] = iclTypeIndex}
			where
				dclTypeIndex
					=	dclClasses.[dclClassIndex].class_dictionary.ds_index
				iclClassIndex
					=	classConversions.[dclClassIndex]
				iclTypeIndex
					=	iclClasses.[iclClassIndex].class_dictionary.ds_index
currentModuleTypeConversions _ _ No
	=	{}

883
/*
884
declareCurrentDclModuleTypes :: {#CheckedTypeDef} {#Int} -> BackEnder
885
*/
886
887
888
defineTypes :: ModuleIndex {#ConsDef} {#SelectorDef} {#CheckedTypeDef} -> BackEnder
defineTypes moduleIndex constructors selectors types
	=	foldStateWithIndexA (defineType moduleIndex constructors selectors) types
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
889
890
891
892
893
894
895

convertTypeLhs :: ModuleIndex Index  [ATypeVar] -> BEMonad BEFlatTypeP
convertTypeLhs moduleIndex typeIndex args
	=	beFlatType (beTypeSymbol typeIndex moduleIndex) (convertTypeVars args)

convertTypeVars :: [ATypeVar] -> BEMonad BETypeVarListP
convertTypeVars typeVars
896
	=	sfoldr (beTypeVars o convertTypeVar) beNoTypeVars typeVars
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
897
898
899
900
901

convertTypeVar :: ATypeVar -> BEMonad BETypeVarP
convertTypeVar typeVar
	=	beTypeVar typeVar.atv_variable.tv_name.id_name

902
903
defineType :: ModuleIndex {#ConsDef} {#SelectorDef} Index CheckedTypeDef *BackEndState -> *BackEndState
defineType moduleIndex constructors _ typeIndex {td_name, td_args, td_rhs=AlgType constructorSymbols} be
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
904
905
906
	# (flatType, be)
		=	convertTypeLhs moduleIndex typeIndex td_args be
	# (constructors, be)
907
		=	convertConstructors typeIndex td_name.id_name moduleIndex constructors constructorSymbols be
908
	=	appBackEnd (BEAlgebraicType flatType constructors) be
909
defineType moduleIndex constructors selectors typeIndex {td_args, td_rhs=RecordType {rt_constructor, rt_fields}} be
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
910
911
912
	# (flatType, be)
		=	convertTypeLhs moduleIndex typeIndex td_args be
	# (fields, be)
913
		=	convertSelectors moduleIndex selectors rt_fields be
914
	# (constructorType,be) = constructorTypeFunction be
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
915
916
917
918
919
	# (constructorTypeNode, be)
		=	beNormalTypeNode
				(beConstructorSymbol moduleIndex constructorIndex)
				(convertSymbolTypeArgs constructorType)
				be
920
	=	appBackEnd (BERecordType moduleIndex flatType constructorTypeNode fields) be
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
921
922
923
924
925
	where
		constructorIndex
			=	rt_constructor.ds_index
		constructorDef
			=	constructors.[constructorIndex]
926
		constructorTypeFunction be0
927
			= let (cons_type,be) = read_from_var_heap constructorDef.cons_type_ptr be0 in
928
929
930
931
932
					(case cons_type of
						VI_ExpandedType expandedType
							->	(expandedType,be)
						_
							->	(constructorDef.cons_type,be))
933
defineType moduleIndex _ _ typeIndex {td_args, td_rhs=AbstractType _} be
clean's avatar
clean committed
934
 	=	beAbsType (convertTypeLhs moduleIndex typeIndex td_args) be
935
defineType _ _ _ _ _ be
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
936
937
	=	be

938
939
940
convertConstructors :: Int {#Char} ModuleIndex {#ConsDef} [DefinedSymbol] -> BEMonad BEConstructorListP
convertConstructors typeIndex typeName moduleIndex constructors symbols
	=	sfoldr (beConstructors o convertConstructor typeIndex typeName moduleIndex constructors) beNoConstructors symbols
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
941

942
943
convertConstructor :: Int {#Char} ModuleIndex {#ConsDef} DefinedSymbol -> BEMonad BEConstructorListP
convertConstructor typeIndex typeName moduleIndex constructorDefs {ds_index}
944
945
946
	= \be0 -> let (constructorType,be) = constructorTypeFunction be0 in
		(appBackEnd (BEDeclareConstructor ds_index moduleIndex constructorDef.cons_symb.id_name) // +++ remove declare
		o`	beConstructor
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
947
948
			(beNormalTypeNode
				(beConstructorSymbol moduleIndex ds_index)
949
				(convertSymbolTypeArgs constructorType))) be
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
950
951
952
	where
		constructorDef
			=	constructorDefs.[ds_index]
953
		constructorTypeFunction be0
954
			= let (cons_type,be) = read_from_var_heap constructorDef.cons_type_ptr be0 in
955
956
957
958
959
					(case cons_type of
						VI_ExpandedType expandedType
							->	(expandedType,be) // ->> (typeName, typeIndex, constructorDef.cons_symb.id_name, ds_index, expandedType)
						_
							->	(constructorDef.cons_type,be)) // ->> (typeName, typeIndex, constructorDef.cons_symb.id_name, ds_index, constructorDef.cons_type)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
960

961
962
963
convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} -> BEMonad BEFieldListP
convertSelectors moduleIndex selectors symbols
	=	foldrA (beFields o convertSelector moduleIndex selectors) beNoFields symbols
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
964

965
966
convertSelector :: ModuleIndex {#SelectorDef} FieldSymbol -> BEMonad BEFieldListP
convertSelector moduleIndex selectorDefs {fs_index}
967
968
969
	= \be0 -> let (selectorType,be) = selectorTypeFunction be0 in
		(	appBackEnd (BEDeclareField fs_index moduleIndex selectorDef.sd_symb.id_name)
		o`	beField fs_index moduleIndex (convertAnnotTypeNode (selectorType.st_result))) be
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
970
971
972
	where
		selectorDef
			=	selectorDefs.[fs_index]
973
		selectorTypeFunction be0
974
			= let (sd_type,be) = read_from_var_heap selectorDef.sd_type_ptr be0 in
975
				(case sd_type of
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
976
					VI_ExpandedType expandedType
977
						->	(expandedType,be)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
978
					_
979
						->	(selectorDef.sd_type,be))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
980

981
982
declareDynamicTemp :: PredefinedSymbols -> BackEnder
declareDynamicTemp predefs
983
	=	appBackEnd (BEDeclareDynamicTypeSymbol predefs.[PD_StdDynamic].pds_def predefs.[PD_DynamicTemp].pds_def)
984

985
predefineSymbols :: DclModule PredefinedSymbols -> BackEnder
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
986
predefineSymbols {dcl_common} predefs
987
	=	appBackEnd (BEDeclarePredefinedModule (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs))
988
	o`	foldState predefine_list_type list_types
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
989
	o`	foldState predefineType types
990
	o`	foldState predefine_list_constructor list_constructors
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
991
992
	o`	foldState predefineConstructor constructors
	where
993
994
995
996
997
998
999
1000
1001
1002
		list_types :: [(Int,Int,Int)]
		list_types
			=	[
					(PD_ListType,0,0),
					(PD_StrictListType,2,0),
					(PD_UnboxedListType,3,0),
					(PD_TailStrictListType,0,1),
					(PD_StrictTailStrictListType,2,1),
					(PD_UnboxedTailStrictListType,3,1)
				]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1003

1004
		predefine_list_type (index,head_strictness,tail_strictness)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1005
1006
			// sanity check ...
			| predefs.[index].pds_def == NoIndex
1007
				=	abort "backendconvert, predefineSymbols predef is not a type"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1008
			// ... sanity check
1009
			=	appBackEnd (BEPredefineListTypeSymbol predefs.[index].pds_def cPredefinedModuleIndex BEListType head_strictness tail_strictness) // id
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1010
1011
1012

		types :: [(Int, Int, BESymbKind)]
		types
1013
1014
1015
1016
			=	[	
//					(PD_ListType, 1, BEListType),
					
					(PD_LazyArrayType, 1, BEArrayType)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1017
1018
1019
1020
1021
				,	(PD_StrictArrayType, 1, BEStrictArrayType)
				,	(PD_UnboxedArrayType, 1, BEUnboxedArrayType)
				:	[(index, index-PD_Arity2TupleType+2, BETupleType) \\ index <- [PD_Arity2TupleType..PD_Arity32TupleType]]
				]

1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
		predefineType (index, arity, symbolKind)
			// sanity check ...
			| predefs.[index].pds_def == NoIndex
				=	abort "backendconvert, predefineSymbols predef is not a type"
			// ... sanity check
			=	appBackEnd (BEPredefineTypeSymbol arity predefs.[index].pds_def cPredefinedModuleIndex symbolKind)

		list_constructors :: [(Int,BESymbKind,Int,Int)]
		list_constructors
			=	[
					(PD_NilSymbol, BENilSymb,0,0),
					(PD_StrictNilSymbol, BENilSymb,2,0),
					(PD_UnboxedNilSymbol, BENilSymb,4/*3*/,0),
					(PD_TailStrictNilSymbol, BENilSymb,0,1),
					(PD_StrictTailStrictNilSymbol, BENilSymb,2,1),
					(PD_UnboxedTailStrictNilSymbol, BENilSymb,4/*3*/,1),
					(PD_OverloadedNilSymbol, BENilSymb,0,0),
					(PD_ConsSymbol, BEConsSymb,0,0),
					(PD_StrictConsSymbol, BEConsSymb,2,0),
					(PD_UnboxedConsSymbol, BEConsSymb,3,0),
					(PD_TailStrictConsSymbol, BEConsSymb,0,1),
					(PD_StrictTailStrictConsSymbol, BEConsSymb,2,1),
					(PD_UnboxedTailStrictConsSymbol, BEConsSymb,3,1),
					(PD_OverloadedConsSymbol, BEConsSymb,1,0)
				]

		predefine_list_constructor (index,symbolKind,head_strictness,tail_strictness)
			// sanity check ...
			| predefs.[index].pds_def == NoIndex
				=	abort "backendconvert, predefineSymbols predef is not a constructor"
			// ... sanity check
			= appBackEnd (BEPredefineListConstructorSymbol predefs.[index].pds_def cPredefinedModuleIndex symbolKind head_strictness tail_strictness) // id
		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1055
1056
		constructors :: [(Int, Int, BESymbKind)]
		constructors
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
			=	
//				[(PD_NilSymbol, 0, BENilSymb), (PD_ConsSymbol, 3, BEConsSymb) : 

				[(index, index-PD_Arity2TupleSymbol+2, BETupleSymb) \\ index <- [PD_Arity2TupleSymbol..PD_Arity32TupleSymbol]]

//				]
 
		predefineConstructor (index, arity, symbolKind)
			// sanity check ...
			| predefs.[index].pds_def == NoIndex
				=	abort "backendconvert, predefineSymbols predef is not a constructor"
			// ... sanity check
			=	appBackEnd (BEPredefineConstructorSymbol arity predefs.[index].pds_def cPredefinedModuleIndex symbolKind)

adjustStrictListFunctions :: [Int] [Int] {#PredefinedSymbol} {#DclModule} NumberSet Int *BackEndState -> *BackEndState;
adjustStrictListFunctions list_first_instance_indices tail_strict_list_first_instance_indices predefs dcls used_module_numbers main_dcl_module_n backEnd
	| std_strict_list_module_index==NoIndex || not (inNumberSet std_strict_list_module_index used_module_numbers)
		|| std_strict_list_module_index==main_dcl_module_n
		= backEnd
		# std_strict_lists_instances=std_strict_lists.dcl_common.com_instance_defs
		# backEnd = adjust_strict_list_instances 0 std_strict_lists_instances backEnd
		# std_strict_lists_nil_functions=std_strict_lists.dcl_functions
		# first_instance_index=std_strict_lists.dcl_instances.ir_from;
		# backEnd=adjust_overloaded_nil_functions 0 first_instance_index std_strict_lists_nil_functions backEnd
		# backEnd=adjustRecordListInstances list_first_instance_indices backEnd
		= adjustRecordListInstances tail_strict_list_first_instance_indices backEnd
where
	std_strict_lists=dcls.[std_strict_list_module_index]
	std_strict_list_module_index=predefs.[PD_StdStrictLists].pds_def

	adjust_strict_list_instances i instances backEnd
		| i<size instances
			# instance_i = instances.[i]
//			| is_instance_for_basic_type instance_i.ins_type.it_types && trace_tn ("instance: "+++toString instance_i.ins_ident) && trace_tn (types_to_string instance_i.ins_type.it_types)
			| isEmpty instance_i.ins_type.it_context // && trace_t ("instance: "+++toString instance_i.ins_ident+++" ") && trace_t (types_to_string instance_i.ins_type.it_types+++" ")
				# backEnd = adjust_strict_list_members 0 instance_i.ins_members backEnd
				= adjust_strict_list_instances (i+1) instances backEnd
				= adjust_strict_list_instances (i+1) instances backEnd
			= backEnd
	where
//		is_instance_for_basic_type [TB _] = True
//		is_instance_for_basic_type _ = False
		
		adjust_strict_list_members i members backEnd
			| i<size members
				# member=members.[i]
				# member_name=member.ds_ident.id_name
				| size member_name>0 && member_name.[0]=='c' // && trace_tn ("member: "+++member_name)
					# (ft_type,backEnd) = read_from_var_heap std_strict_lists.dcl_functions.[member.ds_index].ft_type_ptr backEnd
					= case ft_type of
						VI_ExpandedType _
							# backEnd=appBackEnd (BEAdjustStrictListConsInstance member.ds_index std_strict_list_module_index) backEnd
							-> adjust_strict_list_members (i+1) members backEnd
						_
							-> adjust_strict_list_members (i+1) members backEnd					
					= adjust_strict_list_members (i+1) members backEnd
				= backEnd

	adjust_overloaded_nil_functions function_index first_instance_index std_strict_lists_nil_functions backEnd
		| function_index<first_instance_index
			# backEnd = appBackEnd (BEAdjustOverloadedNilFunction function_index std_strict_list_module_index) backEnd
			= adjust_overloaded_nil_functions (function_index+1) first_instance_index std_strict_lists_nil_functions backEnd
			= backEnd

	adjustRecordListInstances [] back_end
		= back_end
	adjustRecordListInstances [index:indices] backend
//		| trace_tn ("adjustRecordListInstances "+++toString index+++" "+++toString main_dcl_module_n)
		# backend = appBackEnd (BEAdjustStrictListConsInstance index main_dcl_module_n) backend
		# backend = appBackEnd (BEAdjustUnboxedListDeconsInstance (index+1) main_dcl_module_n) backend
		= adjustRecordListInstances indices backend


types_to_string []
	= ""
types_to_string [e:l]
	= type_to_string e+++" "+++types_to_string l
	
type_to_string (TB BT_Int) = "Int"
type_to_string (TB BT_Char) = "Char"
type_to_string (TB BT_Real) = "Real"
type_to_string (TB BT_Bool) = "Bool"
type_to_string (TB BT_File) = "File"
type_to_string _ = "?"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1141
1142