pass strictness information from C to Clean, print strict exported and all types in Clean

git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@877 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d

5 files changed, 371 insertions, 8 deletions

diff --git a/backend/Clean System Files/backend_library b/backend/Clean System Files/backend_library
index 780b1b4..6eb2ebe 100644
--- a/backend/Clean System Files/backend_library
+++ b/backend/Clean System Files/backend_library
@@ -1,6 +1,7 @@
 backend.dll
 BEGetVersion
 BEInit
+BECloseFiles
 BEFree
 BEArg
 BEDeclareModules
@@ -120,5 +121,7 @@ BEExportField
 BEExportFunction
 BEDefineImportedObjsAndLibs
 BESetMainDclModuleN
+BEStrictPositions
+BECopyInts
 BEDeclareDynamicTypeSymbol
 BEDynamicTempTypeSymbol
diff --git a/backend/backend.dcl b/backend/backend.dcl
index 932338d..9730e6a 100644
--- a/backend/backend.dcl
+++ b/backend/backend.dcl
@@ -42,6 +42,8 @@ BEGetVersion :: (!Int,!Int,!Int);
 // void BEGetVersion (int* current,int* oldestDefinition,int* oldestImplementation);
 BEInit :: !Int !UWorld -> (!BackEnd,!UWorld);
 // BackEnd BEInit (int argc);
+BECloseFiles :: !BackEnd -> BackEnd;
+// void BECloseFiles ();
 BEFree :: !BackEnd !UWorld -> UWorld;
 // void BEFree (BackEnd backEnd);
 BEArg :: !String !BackEnd -> BackEnd;
@@ -280,13 +282,17 @@ BEDefineImportedObjsAndLibs :: !BEStringListP !BEStringListP !BackEnd -> BackEnd
 // void BEDefineImportedObjsAndLibs (BEStringListP objs,BEStringListP libs);
 BESetMainDclModuleN :: !Int !BackEnd -> BackEnd;
 // void BESetMainDclModuleN (int main_dcl_module_n_parameter);
+BEStrictPositions :: !Int !BackEnd -> (!Int,!Int,!BackEnd);
+// void BEStrictPositions (int functionIndex,int* bits,int** positions);
+BECopyInts :: !Int !Int !Int -> Int;
+// int BECopyInts (int cLength,int* ints,int* cleanArray);
 BEDeclareDynamicTypeSymbol :: !Int !Int !BackEnd -> BackEnd;
 // void BEDeclareDynamicTypeSymbol (int typeIndex,int moduleIndex);
 BEDynamicTempTypeSymbol :: !BackEnd -> (!BESymbolP,!BackEnd);
 // BESymbolP BEDynamicTempTypeSymbol ();
-kBEVersionCurrent:==0x02000215;
+kBEVersionCurrent:==0x02000216;
 kBEVersionOldestDefinition:==0x02000213;
-kBEVersionOldestImplementation:==0x02000215;
+kBEVersionOldestImplementation:==0x02000216;
 kBEDebug:==1;
 kPredefinedModuleIndex:==1;
 BENoAnnot:==0;
diff --git a/backend/backend.icl b/backend/backend.icl
index 05ac802..3f914cb 100644
--- a/backend/backend.icl
+++ b/backend/backend.icl
@@ -51,6 +51,12 @@ BEInit a0 a1 = code {
 };
 // BackEnd BEInit (int argc);
 
+BECloseFiles :: !BackEnd -> BackEnd;
+BECloseFiles a0 = code {
+	ccall BECloseFiles ":V:I"
+};
+// void BECloseFiles ();
+
 BEFree :: !BackEnd !UWorld -> UWorld;
 BEFree a0 a1 = code {
 	ccall BEFree "I:V:I"
@@ -765,6 +771,18 @@ BESetMainDclModuleN a0 a1 = code {
 };
 // void BESetMainDclModuleN (int main_dcl_module_n_parameter);
 
+BEStrictPositions :: !Int !BackEnd -> (!Int,!Int,!BackEnd);
+BEStrictPositions a0 a1 = code {
+	ccall BEStrictPositions "I:VII:I"
+};
+// void BEStrictPositions (int functionIndex,int* bits,int** positions);
+
+BECopyInts :: !Int !Int !Int -> Int;
+BECopyInts a0 a1 a2 = code {
+	ccall BECopyInts "III:I"
+};
+// int BECopyInts (int cLength,int* ints,int* cleanArray);
+
 BEDeclareDynamicTypeSymbol :: !Int !Int !BackEnd -> BackEnd;
 BEDeclareDynamicTypeSymbol a0 a1 a2 = code {
 	ccall BEDeclareDynamicTypeSymbol "II:V:I"
@@ -776,9 +794,9 @@ BEDynamicTempTypeSymbol a0 = code {
 	ccall BEDynamicTempTypeSymbol ":I:I"
 };
 // BESymbolP BEDynamicTempTypeSymbol ();
-kBEVersionCurrent:==0x02000215;
+kBEVersionCurrent:==0x02000216;
 kBEVersionOldestDefinition:==0x02000213;
-kBEVersionOldestImplementation:==0x02000215;
+kBEVersionOldestImplementation:==0x02000216;
 kBEDebug:==1;
 kPredefinedModuleIndex:==1;
 BENoAnnot:==0;
diff --git a/backend/backendinterface.dcl b/backend/backendinterface.dcl
index 20dde99..b380398 100644
--- a/backend/backendinterface.dcl
+++ b/backend/backendinterface.dcl
@@ -5,4 +5,4 @@ definition module backendinterface
 
 import frontend
 
-backEndInterface :: !{#Char} [{#Char}] !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*AttrVarHeap !*File !*Files -> (!Bool, !*VarHeap, !*AttrVarHeap, !*File, !*Files)
+backEndInterface :: !{#Char} [{#Char}] !ListTypesOption !{#Char} !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*AttrVarHeap !*File !*Files -> (!Bool, !*VarHeap, !*AttrVarHeap, !*File, !*Files)
diff --git a/backend/backendinterface.icl b/backend/backendinterface.icl
index d16fb84..504e19f 100644
--- a/backend/backendinterface.icl
+++ b/backend/backendinterface.icl
@@ -8,7 +8,7 @@ import StdEnv
 import frontend
 import backend
 import backendpreprocess, backendsupport, backendconvert
-import RWSDebug, Version
+import Version
 
 checkVersion :: VersionsCompatability *File -> (!Bool, !*File)
 checkVersion VersionsAreCompatible errorFile
@@ -22,8 +22,8 @@ checkVersion VersionObservedIsTooOld errorFile
 			=	fwrites "[Backend] the back end library is too old\n" errorFile
 	=	(False, errorFile)
 
-backEndInterface :: !{#Char} [{#Char}] !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*AttrVarHeap !*File !*Files -> (!Bool, !*VarHeap, !*AttrVarHeap, !*File, !*Files)
-backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_icl,fe_components} main_dcl_module_n var_heap attrHeap errorFile files
+backEndInterface :: !{#Char} [{#Char}] !ListTypesOption !{#Char} !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*AttrVarHeap !*File !*Files -> (!Bool, !*VarHeap, !*AttrVarHeap, !*File, !*Files)
+backEndInterface outputFileName commandLineArgs listTypes typesPath predef_symbols syntaxTree=:{fe_icl,fe_components,fe_dcls} main_dcl_module_n var_heap attrHeap errorFile files
 	# (observedCurrent, observedOldestDefinition, observedOldestImplementation)
 		=	BEGetVersion
 	  observedVersion =
@@ -61,6 +61,342 @@ backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_i
 		=	backEndConvertModules predef_symbols syntaxTree main_dcl_module_n varHeap attrHeap backEnd
 	# (success, backEnd)
 		=	BEGenerateCode outputFileName backEnd
+	# backEnd
+		=	BECloseFiles backEnd
+	# (attrHeap, files, backEnd)
+		// FIXME: should be type file
+		=	optionallyPrintFunctionTypes listTypes typesPath (DictionaryToClassInfo main_dcl_module_n fe_icl fe_dcls) fe_components fe_icl.icl_functions attrHeap files backEnd
 	# backEndFiles
 		=	BEFree backEnd backEndFiles
 	=	(backEndFiles == 0 && success, var_heap, attrHeap, errorFile, files)
+import typesupport
+
+optionallyPrintFunctionTypes :: ListTypesOption {#Char} DictionaryToClassInfo {!Group} {#FunDef} *AttrVarHeap *Files !*BackEnd -> (*AttrVarHeap, *Files, *BackEnd)
+optionallyPrintFunctionTypes {lto_listTypesKind, lto_showAttributes} typesPath info components functions attrHeap files backEnd
+	| lto_listTypesKind == ListTypesStrictExports || lto_listTypesKind == ListTypesAll
+		# (opened, typesFile, files)
+			=	fopen typesPath FAppendText files
+		| not opened
+			=	abort ("couldn't open types file \"" +++ typesPath +++ "\"\n")
+		# (attrHeap, typesFile, backEnd)
+			=	printFunctionTypes (lto_listTypesKind == ListTypesAll) lto_showAttributes info components functions attrHeap typesFile backEnd
+		# (closed, files)
+			=	fclose typesFile files
+		| not closed
+			=	abort ("couldn't close types file \"" +++ typesPath +++ "\"\n")
+		=	(attrHeap, files, backEnd)
+	// otherwise
+		=	(attrHeap, files, backEnd)
+
+printFunctionTypes :: Bool Bool DictionaryToClassInfo {!Group} {#FunDef} *AttrVarHeap *File *BackEnd -> (*AttrVarHeap, *File, *BackEnd)
+printFunctionTypes all attr info components functions attrHeap file backEnd
+	=	foldSt (printFunctionType all attr info) [(index, functions.[index]) \\ (_, index) <- functionIndices] (attrHeap, file, backEnd)
+	where
+		functionIndices
+			=	flatten [[(componentIndex, member) \\ member <- group.group_members] \\ group <-: components & componentIndex <- [1..]]
+
+printFunctionType :: Bool Bool DictionaryToClassInfo (Int, FunDef) (*AttrVarHeap, *File, *BackEnd) -> (*AttrVarHeap, *File, *BackEnd)
+printFunctionType all attr info (functionIndex, {fun_symb,fun_type=Yes type}) (attrHeap, file, backEnd)
+	| not all && functionIndex > size info.dtic_dclModules.[info.dtci_iclModuleIndex].dcl_functions
+		=	(attrHeap, file, backEnd)
+	# (strictnessAdded, type, backEnd)
+		=	addStrictnessFromBackEnd functionIndex fun_symb.id_name backEnd type
+	| not strictnessAdded && not all
+		=	(attrHeap, file, backEnd)
+	// FIXME: shouldn't have to repair the invariant here
+	# (type, attrHeap)
+		=	collectSymbolTypeAttrVars type attrHeap
+	# type
+		=	dictionariesToClasses info type
+	# (type, attrHeap)
+		=	beautifulizeAttributes type attrHeap
+	# file
+		=	file <<< fun_symb <<< " :: "
+				<:: ({ form_properties = (if attr cAttributed 0) bitor cAnnotated, form_attr_position = No }, type, Yes initialTypeVarBeautifulizer) <<< '\n'
+	=	(attrHeap, file, backEnd)
+
+addStrictnessFromBackEnd :: Int {#Char} *BackEnd SymbolType -> (Bool, SymbolType, *BackEnd)
+addStrictnessFromBackEnd functionIndex functionName backEnd type
+	# (bitSize, strictPositionsC, backEnd)
+		=	BEStrictPositions functionIndex backEnd
+	| bitSize == 0 // short cut
+		=	(False, type, backEnd)
+	# strictPositions
+		=	copyInts ((bitSize+31)/32) strictPositionsC // assumes 32 bit ints
+	# strictnessInfo
+		=	{si_robust_encoding = False, si_positions = strictPositions, si_size = bitSize, si_name = functionName}
+	  offset
+	  	=	0
+	# (robust, offset)
+		=	nextBit strictnessInfo offset
+	  strictnessInfo
+	  	=	{strictnessInfo & si_robust_encoding = robust}
+	# (anyStrictnessAdded, offset)
+		=	nextBit strictnessInfo offset
+	# (type, offset)
+		=	addStrictness strictnessInfo type offset
+	# type
+		=	checkFinalOffset strictnessInfo offset type
+	= (anyStrictnessAdded, type, backEnd)
+
+:: StrictnessInfo =
+	{	si_size :: !Int
+	,	si_positions :: !LargeBitvect
+	,	si_name :: {#Char}
+	,	si_robust_encoding :: !Bool
+	}
+
+class addStrictness a :: !StrictnessInfo !a Int -> (!a, !Int)
+
+nextBit :: StrictnessInfo Int -> (Bool, Int)
+nextBit {si_size, si_positions, si_robust_encoding} offset
+	| offset < si_size
+		=	(bitvectSelect offset si_positions, offset+1)
+	// otherwise
+		| si_robust_encoding
+			=	abort "backendinterface, nextBit: bit vector too small"
+		// otherwise
+			=	(False, offset)
+
+checkStrictness :: StrictnessInfo Bool Int -> Int
+checkStrictness info=:{si_robust_encoding} wasStrict offset
+	| si_robust_encoding
+		# (bit, offset)
+			=	nextBit info offset
+		| bit <> wasStrict
+			=	abort "backendinterface, checkStrictness: wrong info for strictness annotation"
+		=	offset
+	// otherwise
+		=	offset
+
+checkType :: StrictnessInfo Bool Int -> Int
+checkType info=:{si_robust_encoding} isTuple offset
+	| si_robust_encoding
+		# (bit, offset)
+			=	nextBit info offset
+		| bit <> isTuple
+			=	abort "backendinterface, checkType: wrong type"
+		=	offset
+	// otherwise
+		=	offset
+
+checkFinalOffset :: StrictnessInfo Int a -> a
+checkFinalOffset info=:{si_size, si_robust_encoding} offset value
+	| offset < si_size || (si_robust_encoding && offset > si_size)
+		=	abort "backendinterface, checkFinalOffset: wrong offset"
+	// otherwise
+		=	value
+
+instance addStrictness SymbolType where
+	addStrictness strictPositions=:{si_size} args offset
+		| offset >= si_size // short cut
+			=	(args, offset)
+	addStrictness strictPositions type=:{st_args} offset
+		# (st_args, offset)
+			=	addStrictness strictPositions st_args offset
+		=	({type & st_args = st_args}, offset)
+
+instance addStrictness [a] | addStrictness a where
+	addStrictness strictPositions l offset
+		=	mapSt (addStrictness strictPositions) l offset
+
+instance addStrictness AType where
+	addStrictness strictPositions arg=:{at_annotation, at_type} offset
+		# (at_annotation, offset)
+			=	addStrictness strictPositions at_annotation offset
+		# (at_type, offset)
+			=	addStrictnessToType strictPositions (at_annotation == AN_Strict) at_type offset
+		=	({arg & at_annotation = at_annotation, at_type = at_type}, offset)
+
+instance addStrictness Annotation where
+	addStrictness info annotation offset
+		# offset
+			=	checkStrictness info wasStrict offset
+		# (strictAdded, offset)
+			=	nextBit info offset
+		| strictAdded
+			| wasStrict
+				=	abort "backendinterface, addStrictness: already strict"
+			// otherwise
+				=	(AN_Strict, offset)
+		// otherwise
+			=	(annotation, offset)
+		where
+			wasStrict
+				=	annotation == AN_Strict
+
+addStrictnessToType :: StrictnessInfo Bool Type Int -> (Type, Int)
+addStrictnessToType strictPositions isStrict type=:(TA ident=:{type_name,type_arity} args) offset
+	# offset
+		=	checkType strictPositions isTuple offset
+	| isTuple && isStrict
+		# (args, offset)
+			=	addStrictness strictPositions args offset
+		=	(TA ident args, offset)
+	// otherwise
+		=	(type, offset)
+	where
+		// FIXME: don't match on name but use predef info
+		isTuple
+			= type_name.id_name == "_Tuple" +++ toString type_arity
+addStrictnessToType strictPositions _ type offset
+	# offset
+		=	checkType strictPositions False offset
+	=	(type, offset)
+
+collectSymbolTypeAttrVars :: SymbolType *AttrVarHeap -> (SymbolType, *AttrVarHeap)
+collectSymbolTypeAttrVars type=:{st_attr_vars, st_result, st_args} attrVarHeap
+	# attrVarHeap
+		=	foldSt markAttrVarCollected st_attr_vars attrVarHeap
+	# (st_attr_vars, attrVarHeap)
+		=	collectAttrVars st_result (collectAttrVars st_args (st_attr_vars, attrVarHeap))
+	=	({type & st_attr_vars = st_attr_vars}, attrVarHeap)
+
+/* maybe should collect st_vars as well (these are not used currently) */
+class collectAttrVars a :: a ([AttributeVar], *AttrVarHeap) -> ([AttributeVar], *AttrVarHeap)
+
+instance collectAttrVars AType where
+	collectAttrVars {at_attribute, at_type} collect
+		=	collectAttrVars at_attribute (collectAttrVars at_type collect)
+
+instance collectAttrVars TypeAttribute where
+	collectAttrVars (TA_Var attrVar) collect
+		=	collectAttrVars attrVar collect
+	collectAttrVars (TA_RootVar attrVar) collect
+		=	collectAttrVars attrVar collect
+	collectAttrVars (TA_List _ attribute) collect
+		=	collectAttrVars attribute collect
+	collectAttrVars (TA_Locked attribute) collect
+		=	collectAttrVars attribute collect
+	collectAttrVars _ collect
+		=	collect
+
+instance collectAttrVars Type where
+	collectAttrVars (TA _ types) collect
+		=	collectAttrVars types collect
+	collectAttrVars (type1 --> type2) collect
+		=	collectAttrVars type1 (collectAttrVars type2 collect)
+	collectAttrVars (TArrow1 type) collect
+		=	collectAttrVars type collect
+	collectAttrVars (_ :@: types) collect
+		=	collectAttrVars types collect
+	collectAttrVars (TFA _ type) collect
+		=	collectAttrVars type collect
+	collectAttrVars _ collect
+		=	collect
+
+instance collectAttrVars AttributeVar where
+	collectAttrVars  attrVar=:{av_info_ptr} (attrVars, attrVarHeap)
+		# (info, attrVarHeap)
+			=	readPtr av_info_ptr attrVarHeap
+		=	case info of
+				AVI_Collected
+					->	(attrVars, attrVarHeap)
+				_
+					->	([attrVar : attrVars], markAttrVarCollected attrVar attrVarHeap)
+
+instance collectAttrVars [a] | collectAttrVars a where
+	collectAttrVars l collect
+		=	foldSt collectAttrVars l collect
+
+markAttrVarCollected :: AttributeVar *AttrVarHeap -> *AttrVarHeap
+markAttrVarCollected {av_info_ptr} attrVarHeap
+	=	writePtr av_info_ptr AVI_Collected attrVarHeap
+
+:: DictionaryToClassInfo =
+	{	dtci_iclModuleIndex :: Int
+	,	dtci_iclModule :: IclModule
+	,	dtic_dclModules :: {#DclModule}
+	}
+
+DictionaryToClassInfo iclModuleIndex iclModule dclModules :== 
+	{	dtci_iclModuleIndex = iclModuleIndex
+	,	dtci_iclModule = iclModule
+	,	dtic_dclModules = dclModules
+	}
+
+dictionariesToClasses :: DictionaryToClassInfo SymbolType -> SymbolType
+dictionariesToClasses info type=:{st_args, st_arity, st_context=[]}
+	# (reversedTypes, reversedContexts)
+		=	dictionaryArgsToClasses info st_args ([], [])
+	=	{type & st_args = reverse reversedTypes, st_context = reverse reversedContexts,
+				st_arity = st_arity - length reversedContexts}
+
+dictionaryArgsToClasses :: DictionaryToClassInfo [AType] ([AType], [TypeContext]) -> ([AType], [TypeContext])
+dictionaryArgsToClasses info args result
+	=	foldSt (dictionaryArgToClass info) args result
+
+dictionaryArgToClass :: DictionaryToClassInfo AType ([AType], [TypeContext]) -> ([AType], [TypeContext])
+dictionaryArgToClass info type=:{at_type=TA typeSymbol args} (reversedTypes, reversedContexts)
+	=	case typeToClass info typeSymbol of
+			Yes klass
+				->	(reversedTypes, [context : reversedContexts])
+				with
+					context	
+						=	{tc_class = klass, tc_types = [at_type \\ {at_type} <- args], tc_var = nilPtr}
+			No
+				->	([type : reversedTypes], reversedContexts)
+dictionaryArgToClass _ type (reversedTypes, reversedContexts)
+	=	([type : reversedTypes], reversedContexts)
+
+typeToClass :: DictionaryToClassInfo TypeSymbIdent -> Optional (Global DefinedSymbol)
+typeToClass info {type_name, type_arity, type_index={glob_module, glob_object}}
+	=	case typeIndexToClassIndex info glob_module glob_object of
+			Yes classIndex
+				->	Yes {glob_module=glob_module, glob_object = {ds_ident = type_name, ds_arity = type_arity, ds_index = glob_object}}
+			No
+				->	No
+	where
+		/*
+			This how the types are organised (#classes == #dictionaries)
+
+						  com_classes
+			+--------(1)-------+--------(2)-------+
+			|   dcl classes    |   icl classes    |
+			+------------------+------------------+
+						  nDclClasses		 nIclClasses
+
+									com_type_defs
+			+-----------+--------(1)-------+-----------+--------(2)-------+
+			| dcl types | dcl dictionaries | icl types | icl dictionaries |
+			+-----------+------------------+-----------+------------------+
+									   nDclTypes					   nIclTypes
+		*/
+		typeIndexToClassIndex :: DictionaryToClassInfo Int Int -> Optional Int
+		typeIndexToClassIndex {dtci_iclModuleIndex, dtci_iclModule, dtic_dclModules} moduleIndex typeIndex
+			| moduleIndex <> dtci_iclModuleIndex || typeIndex < nDclTypes
+				=	toClassIndex typeIndex nDclTypes nDclClasses 0
+			// otherwise
+				=	toClassIndex (typeIndex-nDclTypes) (nIclTypes-nDclTypes) (nIclClasses-nDclClasses) nDclClasses
+			where
+				dclModule
+					=	dtic_dclModules.[moduleIndex]
+				nDclTypes
+					=	size dclModule.dcl_common.com_type_defs
+				nDclClasses
+					=	size dclModule.dcl_common.com_class_defs
+				nIclTypes
+					=	size dtci_iclModule.icl_common.com_type_defs
+				nIclClasses
+					=	size dtci_iclModule.icl_common.com_class_defs
+
+				toClassIndex :: Int Int Int Int -> Optional Int
+				toClassIndex typeIndex nTypes nClasses offset
+					| classIndex < 0
+						=	No
+					// otherwise
+						=	Yes (classIndex + offset)
+					where
+						classIndex
+							=	typeIndex - (nTypes - nClasses)
+
+copyInts :: !Int !Int -> {#Int}
+copyInts length cArray
+    = code {
+    		push_b 0
+            create_array_ INT 0 1
+  
+            push_a  0
+            ccall   BECopyInts "IIA-I"
+            pop_b   1
+	}