backendconvert.icl

/*
	module owner: Ronny Wichers Schreur
*/
implementation module backendconvert

import code from library "backend_library"
import compilerSwitches

import StdEnv

import frontend
import backend
import backendsupport, backendpreprocess

// trace macro
(-*->) infixl
(-*->) value trace
	:==	value //---> trace
/*
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)

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

:: BEMonad a :== *BackEndState -> *(!a,!*BackEndState)
:: BackEnder :== *BackEndState -> *BackEndState

//
:: *BackEndState = {bes_backEnd :: !BackEnd, bes_varHeap :: !*VarHeap, bes_attrHeap :: !*AttrVarHeap, bes_attr_number :: !Int}

appBackEnd f beState
	:== {beState & bes_backEnd = bes_backEnd}
	where
		bes_backEnd = f beState.bes_backEnd

accBackEnd f beState
	:== accBackEnd
	where
		accBackEnd
			# (result, bes_backEnd) =	f beState.bes_backEnd
			#! beState2 = {beState & bes_backEnd = bes_backEnd}
			= (result,beState2)

accVarHeap f beState
	:== (result, {beState & bes_varHeap = varHeap})
	where
		(result, varHeap) =	f beState.bes_varHeap

accAttrHeap f beState
	:== (result, {beState & bes_attrHeap = attrHeap})
	where
		(result, attrHeap) =	f beState.bes_attrHeap


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

write_to_var_heap ptr v beState
	= {beState & bes_varHeap = writePtr ptr v beState.bes_varHeap}

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}
/*
read_from_var_heap ptr heap be
	= (sreadPtr ptr heap,be)

::	*BackEndState :== BackEnd

appBackEnd f beState :== f beState
accBackEnd f beState :== f beState
accVarHeap f beState :== f beState
*/

beApFunction0 f
	:== appBackEnd f
beApFunction1 f m1
	:== m1 ==> \a1
	->	appBackEnd (f a1)
beApFunction2 f m1 m2
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	appBackEnd (f a1 a2)
beApFunction3 f m1 m2 m3
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	appBackEnd (f a1 a2 a3)
beApFunction4 f m1 m2 m3 m4
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	appBackEnd (f a1 a2 a3 a4)
beApFunction5 f m1 m2 m3 m4 m5
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	m5 ==> \a5
	->	appBackEnd (f a1 a2 a3 a4 a5)
beApFunction6 f m1 m2 m3 m4 m5 m6
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	m5 ==> \a5
	->	m6 ==> \a6
	->	appBackEnd (f a1 a2 a3 a4 a5 a6)
beApFunction7 f m1 m2 m3 m4 m5 m6 m7
	:== m1 ==> \a1
	->	m2 ==> \a2
	->	m3 ==> \a3
	->	m4 ==> \a4
	->	m5 ==> \a5
	->	m6 ==> \a6
	->	m7 ==> \a7
	->	appBackEnd (f a1 a2 a3 a4 a5 a6 a7)

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)

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)

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

beFieldSymbol fieldIndex moduleIndex
	:==	beFunction0 (BEFieldSymbol fieldIndex moduleIndex)
beTypeSymbol typeIndex moduleIndex
	:==	beFunction0 (BETypeSymbol typeIndex moduleIndex)
beBasicSymbol symbolIndex
	:==	beFunction0 (BEBasicSymbol symbolIndex)
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
beAddForAllTypeVariables
	:==	beFunction2 BEAddForAllTypeVariables
beVarTypeNode name
	:==	beFunction0 (BEVarTypeNode name)
beRuleAlt lineNumber
	:==	beFunction5 (BERuleAlt lineNumber)
beNoRuleAlts
	:==	beFunction0 BENoRuleAlts
beRuleAlts
	:==	beFunction2 BERuleAlts
beTypeAlt
	:==	beFunction3 BETypeAlt
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)
beAttributeTypeNode
	:==	beFunction2 BEAttributeTypeNode
beDeclareRuleType functionIndex moduleIndex name
	:==	beApFunction0 (BEDeclareRuleType functionIndex moduleIndex name)
beDefineRuleType functionIndex moduleIndex
	:==	beApFunction1 (BEDefineRuleType functionIndex moduleIndex)
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
	:==	beApFunction0 (BEDeclareNodeId number lhsOrRhs name)
beAdjustArrayFunction backendId functionIndex moduleIndex
	:==	beApFunction0 (BEAdjustArrayFunction backendId functionIndex moduleIndex)
beFlatType
	:==	beFunction2 BEFlatType
//beFlatTypeX
//	:==	beFunction3 BEFlatTypeX
beNoTypeVars
	:==	beFunction0 BENoTypeVars
beTypeVars
	:==	beFunction2 BETypeVars
beTypeVar name
	:==	beFunction0 (BETypeVar name)
beTypeVarListElem
	:==	beFunction2 BETypeVarListElem
beExportType dclTypeIndex iclTypeIndex
	:==	beApFunction0 (BEExportType dclTypeIndex iclTypeIndex)
beExportConstructor dclConstructorIndex iclConstructorIndex
	:==	beApFunction0 (BEExportConstructor dclConstructorIndex iclConstructorIndex)
beExportField dclFieldIndex iclFieldIndex
	:==	beApFunction0 (BEExportField dclFieldIndex iclFieldIndex)
beExportFunction dclIndexFunctionIndex iclFunctionIndex
	:==	beApFunction0 (BEExportFunction dclIndexFunctionIndex iclFunctionIndex)
beTupleSelectNode arity index
	:==	beFunction1 (BETupleSelectNode arity index)
beMatchNode arity
	:==	beFunction2 (BEMatchNode arity)
beDefineImportedObjsAndLibs
	:== beApFunction2 BEDefineImportedObjsAndLibs
beAbsType
	:== beApFunction1 BEAbsType
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
beAttributeKind
	:== beFunction1 BEAttributeKind
beNoAttributeKinds
	:== beFunction0 BENoAttributeKinds
beAttributeKinds
	:== beFunction2 BEAttributeKinds
beUniVarEquation
	:== beFunction2 BEUniVarEquation
beNoUniVarEquations
	:== beFunction0 BENoUniVarEquations
beUniVarEquationsList
	:== beFunction2 BEUniVarEquationsList
beBindSpecialModule specialIdentIndex moduleIndex
	:== beApFunction0 (BEBindSpecialModule specialIdentIndex moduleIndex)
beBindSpecialFunction specialIdentIndex functionIndex moduleIndex
	:== beApFunction0 (BEBindSpecialFunction specialIdentIndex functionIndex moduleIndex)

// temporary hack
beDynamicTempTypeSymbol
	:== beFunction0 BEDynamicTempTypeSymbol

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

backEndConvertModules :: PredefinedSymbols FrontEndSyntaxTree !Int *VarHeap *AttrVarHeap *BackEnd -> (!*VarHeap, *AttrVarHeap, !*BackEnd)
/*
backEndConvertModules p s main_dcl_module_n v be
	= (newHeap,backEndConvertModulesH p s v be)
*/
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)

backEndConvertModulesH :: PredefinedSymbols FrontEndSyntaxTree !Int *BackEndState -> *BackEndState
backEndConvertModulesH predefs {fe_icl = 
	fe_icl =: {icl_name, icl_functions, icl_common,icl_global_functions,icl_imported_objects,icl_used_module_numbers, icl_modification_time},
	fe_components, fe_dcls, fe_arrayInstances}
	main_dcl_module_n backEnd
	// sanity check ...
//	| cIclModIndex <> kIclModuleIndex || cPredefinedModuleIndex <> kPredefinedModuleIndex
//		=	undef <<- "backendconvert, backEndConvertModules: module index mismatch"
	// ... sanity check
/*
	#  backEnd
		=	ruleDoesNotMatch 1 backEnd
			with
				ruleDoesNotMatch 0 backEnd
					=	backEnd
	#  backEnd
		=	abort "front end abort" backEnd
*/	#! backEnd = appBackEnd (BESetMainDclModuleN main_dcl_module_n) backEnd
	#! backEnd
		=	appBackEnd (BEDeclareModules (size fe_dcls)) backEnd
	#! backEnd
		=	predefineSymbols fe_dcls.[cPredefinedModuleIndex] predefs backEnd

	#  currentDcl
	   	=	fe_dcls.[main_dcl_module_n]
/*
	#  backEnd
		=	backEnd ->>
				(	"dcl conversions"
				,	currentDcl.dcl_conversions
				,	"dcl constructors"
				,	[constructor.cons_ident.id_name \\ constructor <-: currentDcl.dcl_common.com_cons_defs]
				,	"dcl selectors"
				,	[selector.sd__ident.id_name \\ selector <-: currentDcl.dcl_common.com_selector_defs]
				,	"dcl types"
				,	[type.td_ident.id_name \\ type <-: currentDcl.dcl_common.com_type_defs]
				,	"icl constructors"
				,	[constructor.cons_ident.id_name \\ constructor <-: icl_common.com_cons_defs]
				,	"icl selectors"
				,	[selector.sd__ident.id_name \\ selector <-: icl_common.com_selector_defs]
				,	"icl types"
				,	[type.td_ident.id_name \\ type <-: icl_common.com_type_defs]
				)
*/
	#! 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")

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

	#! backEnd
		=	defineDclModule main_dcl_module_n fe_dcls.[main_dcl_module_n] (backEnd -*-> "defineDclModule(cIclMoIndex)")
	#! backEnd
		=	defineOtherDclModules fe_dcls main_dcl_module_n icl_used_module_numbers (backEnd -*-> "defineOtherDclModules")

	#! backEnd
		=	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")
	#! backEnd
		=	declareFunctionSymbols icl_functions functionIndices icl_global_functions (backEnd -*-> "declareFunctionSymbols")
	#! backEnd
		=	declare main_dcl_module_n icl_common (backEnd -*-> "declare (main_dcl_module_n)")
	#! backEnd
		=	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")
	#! backEnd
		=	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;
	#! (rules, backEnd)
		=	convertRules [(index, icl_functions.[index]) \\ (_, index) <- functionIndices] main_dcl_module_n predefined_idents.[PD_DummyForStrictAliasFun] (backEnd -*-> "convertRules")
	#! backEnd
		=	appBackEnd (BEDefineRules rules) (backEnd -*-> "BEDefineRules")
	#! 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])
				(backEnd -*-> "beDefineImportedObjsAndLibs")
	#! 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 (backEnd -*-> "markExports")
			with
				dcl_common
					=	currentDcl.dcl_common
	# backEnd = bindSpecialIdents predefs icl_used_module_numbers backEnd
	#! backEnd = removeExpandedTypesFromDclModules fe_dcls icl_used_module_numbers backEnd
	=	(backEnd -*-> "backend done")
	where
		functionIndices
			=	flatten [[(componentIndex, member) \\ member <- group.group_members] \\ group <-: fe_components & componentIndex <- [1..]]

declareOtherDclModules :: {#DclModule} Int NumberSet -> BackEnder
declareOtherDclModules dcls main_dcl_module_n used_module_numbers
	=	foldStateWithIndexA declareOtherDclModule dcls
where
	declareOtherDclModule :: ModuleIndex DclModule -> BackEnder
	declareOtherDclModule moduleIndex dclModule
		| moduleIndex == main_dcl_module_n || moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers)
			=	identity
		// otherwise
			=	declareDclModule moduleIndex dclModule

defineOtherDclModules :: {#DclModule} Int NumberSet -> BackEnder
defineOtherDclModules dcls main_dcl_module_n used_module_numbers
	=	foldStateWithIndexA defineOtherDclModule dcls
where
	defineOtherDclModule :: ModuleIndex DclModule -> BackEnder
	defineOtherDclModule moduleIndex dclModule
		| moduleIndex == main_dcl_module_n || moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers)
			=	identity		
		// otherwise
			=	defineDclModule moduleIndex dclModule

isSystem :: ModuleKind -> Bool
isSystem MK_System
	=	True
isSystem MK_Module
	=	False
isSystem _
	=	abort "backendconvert:isSystem, unknown module kind"

declareCurrentDclModule :: IclModule DclModule Int -> BackEnder
declareCurrentDclModule _ {dcl_module_kind=MK_None} _
	=	identity
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))

declareDclModule :: ModuleIndex DclModule -> BackEnder
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))

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

removeExpandedTypesFromDclModules :: {#DclModule} NumberSet -> BackEnder
removeExpandedTypesFromDclModules dcls used_module_numbers
	=	foldStateWithIndexA removeExpandedTypesFromDclModule dcls
where
	removeExpandedTypesFromDclModule :: ModuleIndex DclModule -> BackEnder
	removeExpandedTypesFromDclModule moduleIndex dclModule=:{dcl_functions}
		| moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers)
			= identity
			= foldStateWithIndexA (removeExpandedTypesFromFunType moduleIndex)  dcl_functions
			where
				removeExpandedTypesFromFunType :: ModuleIndex Index FunType -> BackEnder
				removeExpandedTypesFromFunType moduleIndex functionIndex {ft_ident, ft_type_ptr}
					= \be0 ->	let (ft_type,be) = read_from_var_heap ft_type_ptr be0 in
						(case ft_type of
							VI_ExpandedType expandedType
								->	write_to_var_heap ft_type_ptr VI_Empty	
							_
								->	identity) be

:: DeclVarsInput :== Ident

class declareVars a :: a !DeclVarsInput -> BackEnder

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

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

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

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

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

instance declareVars (Optional a) | declareVars a where
	declareVars :: (Optional a) !DeclVarsInput -> BackEnder | declareVars a
	declareVars (Yes x) dvInput
		=	declareVars x dvInput
	declareVars No _
		=	identity

instance declareVars FunctionPattern where
	declareVars :: FunctionPattern !DeclVarsInput -> BackEnder
	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
	declareVars :: Expression !DeclVarsInput -> BackEnder
	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
	declareVars (Conditional {if_cond, if_then, if_else}) dvInput
		=	declareVars if_cond dvInput
		o`	declareVars if_then dvInput
		o`	declareVars if_else dvInput
	declareVars (Case caseExpr) dvInput
		=	declareVars caseExpr dvInput
	declareVars (AnyCodeExpr _ outParams _) _
		=	foldState declVar outParams 
	  where
		declVar {bind_dst=freeVar} 
			= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_ident.id_name
	declareVars _ _
		=	identity

instance declareVars TransformedBody where
	declareVars :: TransformedBody !DeclVarsInput -> BackEnder
	declareVars {tb_args, tb_rhs} dvInput
		=	declareVars tb_args dvInput
		o`	declareVars tb_rhs dvInput

instance declareVars BackendBody where
	declareVars :: BackendBody !DeclVarsInput -> BackEnder
	declareVars {bb_args, bb_rhs} dvInput
		=	declareVars bb_args dvInput
		o`	declareVars bb_rhs dvInput

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
	declareVars (OverloadedListPatterns _ decons_expr patterns) dvInput
		=	declareVars patterns dvInput

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

class declare a :: ModuleIndex a  -> BackEnder

class declareWithIndex a :: Index ModuleIndex a -> BackEnder

instance declare {#a} | declareWithIndex a & Array {#} a where
	declare :: ModuleIndex  {#a} -> BackEnder | declareWithIndex a & Array {#} a 
	declare moduleIndex array
		=	foldStateWithIndexA (\i -> declareWithIndex i moduleIndex) array

declareFunctionSymbols :: {#FunDef} [(Int, Int)] [IndexRange] *BackEndState -> *BackEndState
declareFunctionSymbols functions functionIndices globalFunctions backEnd
	=	foldl declare backEnd [(functionIndex, componentIndex, functions.[functionIndex]) \\ (componentIndex, functionIndex) <- functionIndices]
	where
		declare backEnd (functionIndex, componentIndex, function)
			=	appBackEnd (BEDeclareFunction (functionName function.fun_ident.id_name functionIndex globalFunctions) 
					function.fun_arity functionIndex componentIndex) backEnd
			where
				functionName :: {#Char} Int [IndexRange] -> {#Char}
				functionName name functionIndex icl_global_functions
//					| trace_t ("|"+++toString functionIndex)
					| index_in_ranges functionIndex icl_global_functions
						=	name
						=	(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

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

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
//	| trace_tn ("declareArrayInstances "+++toString ir_from+++" "+++toString ir_to)
//	=	foldStateWithIndexRangeA declareArrayInstance ir_from ir_to functions
	= folds (declareArrayInstances 0) array_first_instance_indices
	where
		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

		declareArrayInstance :: Index FunDef -> BackEnder
		declareArrayInstance index {fun_ident={id_name}, fun_type=Yes type}
			=	beDeclareRuleType index main_dcl_module_n (id_name +++ ";" +++ toString index)
			o`	beDefineRuleType index main_dcl_module_n (convertTypeAlt index main_dcl_module_n type)

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_ident={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)

instance declare CommonDefs where
	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

instance declareWithIndex (TypeDef a) where
	declareWithIndex :: Index ModuleIndex (TypeDef a) -> BackEnder
	declareWithIndex typeIndex moduleIndex {td_ident}
		=	appBackEnd (BEDeclareType typeIndex moduleIndex td_ident.id_name)

declareFunTypes :: ModuleIndex {#FunType} Int -> BackEnder
declareFunTypes moduleIndex funTypes nrOfDclFunctions
		=	foldStateWithIndexA (declareFunType moduleIndex nrOfDclFunctions) funTypes

declareFunType :: ModuleIndex Index Int FunType -> BackEnder
declareFunType moduleIndex nrOfDclFunctions functionIndex {ft_ident, ft_type_ptr}
	= \be0 -> let (vi,be) = read_from_var_heap ft_type_ptr be0 in
					(case vi of
						VI_ExpandedType expandedType
							->	beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex nrOfDclFunctions)
							o`	beDefineRuleType functionIndex moduleIndex (convertTypeAlt functionIndex moduleIndex expandedType)
						_
							->	identity) be
		where
			functionName :: {#Char} Int Int -> {#Char}
			functionName name functionIndex nrOfDclFunctions 
//				| trace_tn (name+++(if (functionIndex < nrOfDclFunctions) "" (";" +++ toString functionIndex)))

				| functionIndex < nrOfDclFunctions
					=	name
				// otherwise
					=	name +++ ";" +++ toString functionIndex

defineTypes :: ModuleIndex {#ConsDef} {#SelectorDef} {#CheckedTypeDef} -> BackEnder
defineTypes moduleIndex constructors selectors types
	=	foldStateWithIndexA (defineType moduleIndex constructors selectors) types

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

convertTypeVars :: [ATypeVar] -> BEMonad BETypeVarListP
convertTypeVars typeVars
	=	sfoldr (beTypeVars o convertTypeVar) beNoTypeVars typeVars

convertTypeVar :: ATypeVar -> BEMonad BETypeVarListP
convertTypeVar typeVar
	=	beTypeVarListElem (beTypeVar typeVar.atv_variable.tv_ident.id_name) (convertAttribution typeVar.atv_attribute)

defineType :: ModuleIndex {#ConsDef} {#SelectorDef} Index CheckedTypeDef *BackEndState -> *BackEndState
defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgType constructorSymbols} be
	# (flatType, be)
		=	convertTypeLhs moduleIndex typeIndex td_attribute td_args be
	# (constructors, be)
		=	convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be
	=	appBackEnd (BEAlgebraicType flatType constructors) be
defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args, td_rhs=RecordType {rt_constructor, rt_fields, rt_is_boxed_record}} be
//	| trace_tn constructorDef.cons_ident
	# (flatType, be)
		=	convertTypeLhs moduleIndex typeIndex td_attribute td_args be
	# (fields, be)
		=	convertSelectors moduleIndex selectors rt_fields constructorDef.cons_type.st_args_strictness be
	# (constructorType,be) = constructorTypeFunction be
	# (constructorTypeNode, be)
		=	beNormalTypeNode
				(beConstructorSymbol moduleIndex constructorIndex)
				(convertSymbolTypeArgs constructorType)
				be
	=	appBackEnd (BERecordType moduleIndex flatType constructorTypeNode fields) be
	where
		constructorIndex
			=	rt_constructor.ds_index
		constructorDef
			=	constructors.[constructorIndex]
		constructorTypeFunction be0
			= let (cons_type,be) = read_from_var_heap constructorDef.cons_type_ptr be0 in
					(case cons_type of
						VI_ExpandedType expandedType
							->	(expandedType,be)
						_
							->	(constructorDef.cons_type,be))
defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractType _} be
 	=	beAbsType (convertTypeLhs moduleIndex typeIndex td_attribute td_args) be
defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractSynType _ _} be
 	=	beAbsType (convertTypeLhs moduleIndex typeIndex td_attribute td_args) be
defineType _ _ _ _ _ be
	=	be

convertConstructors :: Int {#Char} ModuleIndex {#ConsDef} [DefinedSymbol] -> BEMonad BEConstructorListP
convertConstructors typeIndex typeName moduleIndex constructors symbols
	=	sfoldr (beConstructors o convertConstructor typeIndex typeName moduleIndex constructors) beNoConstructors symbols

convertConstructor :: Int {#Char} ModuleIndex {#ConsDef} DefinedSymbol -> BEMonad BEConstructorListP
convertConstructor typeIndex typeName moduleIndex constructorDefs {ds_index}
	= \be0 -> let (constructorType,be) = constructorTypeFunction be0 in
		(appBackEnd (BEDeclareConstructor ds_index moduleIndex constructorDef.cons_ident.id_name) // +++ remove declare
		o`	beConstructor
			(beNormalTypeNode
				(beConstructorSymbol moduleIndex ds_index)
				(convertSymbolTypeArgs constructorType))) be
	where
		constructorDef
			=	constructorDefs.[ds_index]
		constructorTypeFunction be0
			= let (cons_type,be) = read_from_var_heap constructorDef.cons_type_ptr be0 in
					(case cons_type of
						VI_ExpandedType expandedType
							->	(expandedType,be) // ->> (typeName, typeIndex, constructorDef.cons_ident.id_name, ds_index, expandedType)
						_
							->	(constructorDef.cons_type,be)) // ->> (typeName, typeIndex, constructorDef.cons_ident.id_name, ds_index, constructorDef.cons_type)


foldrAi function result array
	:== foldrA 0
	where
		arraySize
			=	size array
		foldrA index
			| index == arraySize
				=	result
			// otherwise
				=	function index array.[index] (foldrA (index+1))

//convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} -> BEMonad BEFieldListP
convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} StrictnessList -> BEMonad BEFieldListP
convertSelectors moduleIndex selectors symbols strictness
	=	foldrAi (\i -> (beFields o convertSelector moduleIndex selectors (arg_is_strict i strictness))) beNoFields symbols

convertSelector :: ModuleIndex {#SelectorDef} Bool FieldSymbol -> BEMonad BEFieldListP
convertSelector moduleIndex selectorDefs is_strict {fs_index}
	= \be0 -> let (selectorType,be) = selectorTypeFunction be0 in
		(	appBackEnd (BEDeclareField fs_index moduleIndex selectorDef.sd__ident.id_name)
		o`	beField fs_index moduleIndex (convertAnnotAndTypeNode (if is_strict AN_Strict AN_None) (selectorType.st_result))) be
	where
		selectorDef
			=	selectorDefs.[fs_index]
		selectorTypeFunction be0
			= let (sd_type,be) = read_from_var_heap selectorDef.sd_type_ptr be0 in
				(case sd_type of
					VI_ExpandedType expandedType
						->	(expandedType,be)
					_
						->	(selectorDef.sd_type,be))

declareDynamicTemp :: PredefinedSymbols -> BackEnder
declareDynamicTemp predefs
	=	appBackEnd (BEDeclareDynamicTypeSymbol predefs.[PD_StdDynamic].pds_def predefs.[PD_Dyn_DynamicTemp].pds_def)

predefineSymbols :: DclModule PredefinedSymbols -> BackEnder
predefineSymbols {dcl_common} predefs
	=	appBackEnd (BEDeclarePredefinedModule (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs))
	o`	foldState predefine_list_type list_types
	o`	foldState predefineType types
	o`	foldState predefine_list_constructor list_constructors
	o`	foldState predefineConstructor constructors
	where
		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)
				]

		predefine_list_type (index,head_strictness,tail_strictness)
			// sanity check ...
			| predefs.[index].pds_def == NoIndex
				=	abort "backendconvert, predefineSymbols predef is not a type"
			// ... sanity check
			=	appBackEnd (BEPredefineListTypeSymbol predefs.[index].pds_def cPredefinedModuleIndex BEListType head_strictness tail_strictness) // id

		types :: [(Int, Int, BESymbKind)]
		types
			=	[	
					(PD_LazyArrayType, 1, BEArrayType)
				,	(PD_StrictArrayType, 1, BEStrictArrayType)
				,	(PD_UnboxedArrayType, 1, BEUnboxedArrayType)
				:	[(index, index-PD_Arity2TupleType+2, BETupleType) \\ index <- [PD_Arity2TupleType..PD_Arity32TupleType]]
				]

		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
		
		constructors :: [(Int, Int, BESymbKind)]
		constructors
			=	[(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)


bindSpecialIdents :: PredefinedSymbols NumberSet -> BackEnder
bindSpecialIdents predefs usedModules
	=	foldState (bindSpecialModule predefs usedModules) specialModules
	where
		bindSpecialModule :: PredefinedSymbols NumberSet (Int, BESpecialIdentIndex, [(Int, BESpecialIdentIndex)]) -> BackEnder
		bindSpecialModule predefs usedModules (predefIndex, specialIdentIndex, specialFunctions)
			| moduleIndex == NoIndex || not (inNumberSet moduleIndex usedModules)
				=	identity
			// otherwise
				=	beBindSpecialModule specialIdentIndex moduleIndex
				o`	foldState (bindSpecialFunction predefs) specialFunctions
				where
					predef
						=	predefs.[predefIndex]
					moduleIndex
						=	predef.pds_def

		bindSpecialFunction :: PredefinedSymbols (Int, BESpecialIdentIndex) -> BackEnder
		bindSpecialFunction predefs (predefIndex, specialIdentIndex)
			| predef.pds_def == NoIndex
				=	identity
			// otherwise
				=	beBindSpecialFunction specialIdentIndex predef.pds_def predef.pds_module
				where
					predef
						=	predefs.[predefIndex]

		specialModules
			=	[	(PD_StdMisc, BESpecialIdentStdMisc,
						[	(PD_abort,	BESpecialIdentAbort)
						,	(PD_undef,	BESpecialIdentUndef)
						]
					)
				,	(PD_StdBool, BESpecialIdentStdBool,
						[	(PD_AndOp,	BESpecialIdentAnd)
						,	(PD_OrOp,	BESpecialIdentOr)
						]
					)
				]