store strictness annotations in SymbolType instead of AType

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

2 files changed, 160 insertions, 66 deletions

diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl
index 0e9d0a5..6a75b15 100644
--- a/backend/backendconvert.icl
+++ b/backend/backendconvert.icl
@@ -790,12 +790,14 @@ declareFunType moduleIndex nrOfDclFunctions functionIndex {ft_symb, ft_type_ptr}
 
 			functionName :: {#Char} Int Int -> {#Char}
 			functionName name functionIndex nrOfDclFunctions 
+//				| trace_tn (name+++(if (functionIndex < nrOfDclFunctions) "" (";" +++ toString functionIndex)))
+
 				| functionIndex < nrOfDclFunctions
 					=	name
 				// otherwise
 					=	name +++ ";" +++ toString functionIndex
 
-import StdDebug
+//import StdDebug
 
 /*
 declareCurrentDclModuleTypes :: {#CheckedTypeDef} {#Int} -> BackEnder
@@ -824,10 +826,13 @@ defineType moduleIndex constructors _ typeIndex {td_name, td_args, td_rhs=AlgTyp
 		=	convertConstructors typeIndex td_name.id_name moduleIndex constructors constructorSymbols be
 	=	appBackEnd (BEAlgebraicType flatType constructors) be
 defineType moduleIndex constructors selectors typeIndex {td_args, td_rhs=RecordType {rt_constructor, rt_fields}} be
+//	| trace_tn constructorDef.cons_symb
+
 	# (flatType, be)
 		=	convertTypeLhs moduleIndex typeIndex td_args be
 	# (fields, be)
-		=	convertSelectors moduleIndex selectors rt_fields be
+//		=	convertSelectors moduleIndex selectors rt_fields be
+		=	convertSelectors moduleIndex selectors rt_fields constructorDef.cons_type.st_args_strictness be
 	# (constructorType,be) = constructorTypeFunction be
 	# (constructorTypeNode, be)
 		=	beNormalTypeNode
@@ -875,15 +880,32 @@ convertConstructor typeIndex typeName moduleIndex constructorDefs {ds_index}
 						_
 							->	(constructorDef.cons_type,be)) // ->> (typeName, typeIndex, constructorDef.cons_symb.id_name, ds_index, constructorDef.cons_type)
 
-convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} -> BEMonad BEFieldListP
-convertSelectors moduleIndex selectors symbols
-	=	foldrA (beFields o convertSelector moduleIndex selectors) beNoFields symbols
 
-convertSelector :: ModuleIndex {#SelectorDef} FieldSymbol -> BEMonad BEFieldListP
-convertSelector moduleIndex selectorDefs {fs_index}
+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
+//	=	foldrA (beFields o convertSelector moduleIndex selectors) beNoFields symbols
+	=	foldrAi (\i -> (beFields o convertSelector moduleIndex selectors (arg_is_strict i strictness))) beNoFields symbols
+
+//convertSelector :: ModuleIndex {#SelectorDef} FieldSymbol -> BEMonad BEFieldListP
+convertSelector :: ModuleIndex {#SelectorDef} Bool FieldSymbol -> BEMonad BEFieldListP
+//convertSelector moduleIndex selectorDefs {fs_index}
+convertSelector moduleIndex selectorDefs is_strict {fs_index}
 	= \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
+//		o`	beField fs_index moduleIndex (convertAnnotTypeNode (selectorType.st_result))) be
+		o`	beField fs_index moduleIndex (convertAnnotAndTypeNode (if is_strict AN_Strict AN_None) (selectorType.st_result))) be
 	where
 		selectorDef
 			=	selectorDefs.[fs_index]
@@ -1238,6 +1260,7 @@ convertRules rules main_dcl_module_n aliasDummyId be
 
 convertRule :: Ident (Int,FunDef) Int -> BEMonad BEImpRuleP
 convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun_kind, fun_symb}) main_dcl_module_n
+//	| trace_tn fun_symb.id_name
 	=	beRule index (cafness fun_kind)
 			(convertTypeAlt index main_dcl_module_n (type -*-> ("convertRule", fun_symb.id_name, index, type)))
 			(convertFunctionBody index (positionToLineNumber fun_pos) aliasDummyId body main_dcl_module_n)
@@ -1324,8 +1347,9 @@ convertAttributeKind attributeVar
 	=	beAttributeKind (convertAttributeVar attributeVar)
 
 convertSymbolTypeArgs :: SymbolType -> BEMonad BETypeArgP
-convertSymbolTypeArgs {st_args}
-	=	convertTypeArgs st_args
+convertSymbolTypeArgs {st_args,st_args_strictness}
+//	=	convertTypeArgs st_args
+	= convertAnnotatedTypeArgs st_args st_args_strictness
 
 convertBasicTypeKind :: BasicType -> BESymbKind
 convertBasicTypeKind BT_Int
@@ -1392,7 +1416,7 @@ convertAttribution attr
 	=	abort "backendconvert, convertAttribution: unknown TypeAttribute" // <<- attr
 
 convertAnnotTypeNode :: AType -> BEMonad BETypeNodeP
-convertAnnotTypeNode {at_type, at_annotation, at_attribute}
+convertAnnotTypeNode {at_type, at_attribute}
 /*
 	=	convertTypeNode at_type
 	:-	beAnnotateTypeNode (convertAnnotation at_annotation)
@@ -1405,6 +1429,15 @@ convertAnnotTypeNode {at_type, at_annotation, at_attribute}
 	:-	beAttributeTypeNode c_attrib
 //	) s
 	where
+		c_annot = convertAnnotation AN_None // at_annotation
+		c_attrib = convertAttribution at_attribute
+
+convertAnnotAndTypeNode :: Annotation AType -> BEMonad BETypeNodeP
+convertAnnotAndTypeNode at_annotation {at_type, at_attribute}
+	= convertTypeNode at_type
+	:-	beAnnotateTypeNode c_annot
+	:-	beAttributeTypeNode c_attrib
+	where
 		c_annot = convertAnnotation at_annotation
 		c_attrib = convertAttribution at_attribute
 
@@ -1417,6 +1450,9 @@ convertTypeNode (TB basicType)
 	=	beNormalTypeNode (beBasicSymbol (convertBasicTypeKind basicType)) beNoTypeArgs	
 convertTypeNode (TA typeSymbolIdent typeArgs)
 	=	beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertTypeArgs typeArgs )
+convertTypeNode (TAS typeSymbolIdent typeArgs strictness)
+//	=	beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertTypeArgs typeArgs )
+	=	beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertAnnotatedTypeArgs typeArgs strictness)
 convertTypeNode (TV {tv_name})
 	=	beVarTypeNode tv_name.id_name
 convertTypeNode (TempQV n)
@@ -1426,7 +1462,7 @@ convertTypeNode (TempV n)
 convertTypeNode (a --> b) 
 	=	beNormalTypeNode (beBasicSymbol BEFunType) (convertTypeArgs [a, b])
 convertTypeNode (a :@: b)
-	=	beNormalTypeNode (beBasicSymbol BEApplySymb) (convertTypeArgs [{at_attribute=TA_Multi, at_annotation=AN_None, at_type = consVariableToType a} : b])
+	=	beNormalTypeNode (beBasicSymbol BEApplySymb) (convertTypeArgs [{at_attribute=TA_Multi, at_type = consVariableToType a} : b])
 convertTypeNode TE
 	=	beNormalTypeNode beDontCareDefinitionSymbol beNoTypeArgs
 convertTypeNode (TFA vars type)
@@ -1446,6 +1482,16 @@ convertTypeArgs :: [AType] -> BEMonad BETypeArgP
 convertTypeArgs args
 	=	sfoldr (beTypeArgs o convertAnnotTypeNode) beNoTypeArgs args
 
+convertAnnotatedTypeArgs :: [AType] StrictnessList -> BEMonad BETypeArgP
+convertAnnotatedTypeArgs args strictness
+	= foldr args 0
+	where
+		foldr [] i
+			= beNoTypeArgs
+		foldr [a:x] i
+//			| trace_tn (toString i+++" "+++toString (arg_strictness_annotation i strictness))
+			= (beTypeArgs o (convertAnnotAndTypeNode (arg_strictness_annotation i strictness))) a (foldr x (i+1))
+
 convertTransformedBody :: Int Int Ident TransformedBody Int -> BEMonad BERuleAltP
 convertTransformedBody functionIndex lineNumber aliasDummyId body main_dcl_module_n
 	| isCodeBlock body.tb_rhs
diff --git a/backend/backendinterface.icl b/backend/backendinterface.icl
index afb53af..45df650 100644
--- a/backend/backendinterface.icl
+++ b/backend/backendinterface.icl
@@ -99,6 +99,9 @@ printFunctionType :: Bool Bool DictionaryToClassInfo (Int, FunDef) (*AttrVarHeap
 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)
+
+//	| trace_tn (toString fun_symb) && True ---> type.st_args
+
 	# (strictnessAdded, type, backEnd)
 		=	addStrictnessFromBackEnd functionIndex fun_symb.id_name backEnd type
 	| not strictnessAdded && not all
@@ -127,6 +130,9 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
 		=	{si_robust_encoding = False, si_positions = strictPositions, si_size = bitSize, si_name = functionName}
 	  offset
 	  	=	0
+
+//	| trace_tn (toString bitSize+++" "+++toString strictPositions.[0])
+
 	# (robust, offset)
 		=	nextBit strictnessInfo offset
 	  strictnessInfo
@@ -134,11 +140,19 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
 	# (anyStrictnessAdded, offset)
 		=	nextBit strictnessInfo offset
 	# (type, offset)
-		=	addStrictness strictnessInfo type offset
+		=	addStrictnessToSymbolType strictnessInfo type offset
 	# type
 		=	checkFinalOffset strictnessInfo offset type
 	= (anyStrictnessAdded, type, backEnd)
 
+addStrictnessToSymbolType strictPositions=:{si_size} args offset
+	| offset >= si_size // short cut
+		=	(args, offset)
+addStrictnessToSymbolType strictPositions type=:{st_args,st_args_strictness} offset
+	# (st_args, offset,args_strictness)
+		=	addStrictness strictPositions st_args offset st_args_strictness 0
+	=	({type & st_args = st_args,st_args_strictness=args_strictness}, offset)
+
 :: StrictnessInfo =
 	{	si_size :: !Int
 	,	si_positions :: !LargeBitvect
@@ -146,7 +160,7 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
 	,	si_robust_encoding :: !Bool
 	}
 
-class addStrictness a :: !StrictnessInfo !a Int -> (!a, !Int)
+class addStrictness a :: !StrictnessInfo !a Int StrictnessList Int -> (!a, !Int,!StrictnessList)
 
 nextBit :: StrictnessInfo Int -> (Bool, Int)
 nextBit {si_size, si_positions, si_robust_encoding} offset
@@ -187,58 +201,64 @@ checkFinalOffset info=:{si_size, si_robust_encoding} offset value
 	// 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
+	addStrictness strictPositions [] offset args_strictness args_strictness_index
+		= ([],offset,args_strictness)
+	addStrictness strictPositions [type:types] offset args_strictness args_strictness_index
+		# (type,offset,args_strictness)=addStrictness strictPositions type offset args_strictness args_strictness_index
+		# (types,offset,args_strictness)=addStrictness strictPositions types offset args_strictness (args_strictness_index+1)
+		= ([type:types],offset,args_strictness)
 
 instance addStrictness AType where
-	addStrictness strictPositions arg=:{at_annotation, at_type} offset
-		# (at_annotation, offset)
-			=	addStrictness strictPositions at_annotation offset
+	addStrictness strictPositions arg=:{at_type} offset args_strictness args_strictness_index
+		# (is_strict,offset,args_strictness)
+			=	addStrictnessAnnotation strictPositions offset args_strictness args_strictness_index
 		# (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
+			=	addStrictnessToType strictPositions is_strict at_type offset
+		=	({arg & at_type=at_type}, offset,args_strictness)
+
+addStrictnessAnnotation info offset args_strictness args_strictness_index
+	# wasStrict = arg_is_strict args_strictness_index args_strictness
+	# 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
+			# args_strictness = add_strictness args_strictness_index args_strictness
+			=	(True, offset,args_strictness)
+	// otherwise
+		=	(wasStrict, offset,args_strictness)
 
 addStrictnessToType :: StrictnessInfo Bool Type Int -> (Type, Int)
-addStrictnessToType strictPositions isStrict type=:(TA ident=:{type_name,type_arity} args) offset
+addStrictnessToType strictPositions isStrict type=:(TA ident=:{type_index={glob_object,glob_module}} args) offset
 	# offset
 		=	checkType strictPositions isTuple offset
 	| isTuple && isStrict
-		# (args, offset)
-			=	addStrictness strictPositions args offset
-		=	(TA ident args, offset)
+		# (args, offset,args_strictness)
+			=	addStrictness strictPositions args offset NotStrict 0
+		| is_not_strict args_strictness
+			=	(TA ident args, offset)
+			=	(TAS ident args args_strictness, offset)
 	// otherwise
 		=	(type, offset)
 	where
-		// FIXME: don't match on name but use predef info
 		isTuple
-			= type_name.id_name == "_Tuple" +++ toString type_arity
+			= glob_module==cPredefinedModuleIndex && (glob_object>=PD_Arity2TupleTypeIndex && glob_object<=PD_Arity32TupleTypeIndex)
+addStrictnessToType strictPositions isStrict type=:(TAS ident=:{type_index={glob_object,glob_module}} args strictness) offset
+	# offset
+		=	checkType strictPositions isTuple offset
+	| isTuple && isStrict
+		# (args, offset,strictness)
+			=	addStrictness strictPositions args offset strictness 0
+		=	(TAS ident args strictness, offset)
+	// otherwise
+		=	(type, offset)
+	where
+		isTuple
+			= glob_module==cPredefinedModuleIndex && (glob_object>=PD_Arity2TupleTypeIndex && glob_object<=PD_Arity32TupleTypeIndex)
 addStrictnessToType strictPositions _ type offset
 	# offset
 		=	checkType strictPositions False offset
@@ -274,6 +294,8 @@ instance collectAttrVars TypeAttribute where
 instance collectAttrVars Type where
 	collectAttrVars (TA _ types) collect
 		=	collectAttrVars types collect
+	collectAttrVars (TAS _ types _) collect
+		=	collectAttrVars types collect
 	collectAttrVars (type1 --> type2) collect
 		=	collectAttrVars type1 (collectAttrVars type2 collect)
 	collectAttrVars (TArrow1 type) collect
@@ -316,28 +338,54 @@ DictionaryToClassInfo iclModuleIndex iclModule dclModules :==
 	}
 
 dictionariesToClasses :: DictionaryToClassInfo SymbolType -> SymbolType
-dictionariesToClasses info type=:{st_args, st_arity, st_context=[]}
+dictionariesToClasses info type=:{st_args, st_args_strictness, st_arity, st_context=[]}
 	# (reversedTypes, reversedContexts)
 		=	dictionaryArgsToClasses info st_args ([], [])
+	# n_contexts = length reversedContexts
+	# new_st_args_strictness = remove_first_n_strictness_values n_contexts st_args_strictness
+		with
+			remove_first_n_strictness_values 0 s
+				= s
+			remove_first_n_strictness_values _ NotStrict
+				= NotStrict
+			remove_first_n_strictness_values n (Strict s)
+				| n<32
+					 = Strict (((s>>1) bitand 0x7fffffff)>>(n-1))
+					 = NotStrict
+			remove_first_n_strictness_values n (StrictList s l)
+				| n<32
+					# s2=case l of
+							Strict s -> s
+							StrictList s _ -> s
+							NotStrict -> 0
+					# s=(((s>>1) bitand 0x7fffffff)>>(n-1)) bitor (s2<<(32-n))
+					= StrictList s (remove_first_n_strictness_values n l)
+					= remove_first_n_strictness_values (n-32) l
 	=	{type & st_args = reverse reversedTypes, st_context = reverse reversedContexts,
-				st_arity = st_arity - length reversedContexts}
+				st_arity = st_arity - n_contexts, st_args_strictness=new_st_args_strictness}
 
 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)
+where
+	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, [dictionary_to_context klass args : reversedContexts])
+				No
+					->	([type : reversedTypes], reversedContexts)
+	dictionaryArgToClass info type=:{at_type=TAS typeSymbol args _} (reversedTypes, reversedContexts)
+		=	case typeToClass info typeSymbol of
+				Yes klass
+					->	(reversedTypes, [dictionary_to_context klass args : reversedContexts])
+				No
+					->	([type : reversedTypes], reversedContexts)
+	dictionaryArgToClass _ type (reversedTypes, reversedContexts)
+		=	([type : reversedTypes], reversedContexts)
+	
+	dictionary_to_context klass args
+		=	{tc_class = klass, tc_types = [at_type \\ {at_type} <- args], tc_var = nilPtr}
 
 typeToClass :: DictionaryToClassInfo TypeSymbIdent -> Optional (Global DefinedSymbol)
 typeToClass info {type_name, type_arity, type_index={glob_module, glob_object}}