4 files changed, 273 insertions, 43 deletions

diff --git a/backendC/CleanCompilerSources/backend.c b/backendC/CleanCompilerSources/backend.c
index c375a1d..74e2b3b 100644
--- a/backendC/CleanCompilerSources/backend.c
+++ b/backendC/CleanCompilerSources/backend.c
@@ -731,6 +731,7 @@ BESpecialArrayFunctionSymbol (BEArrayFunKind arrayFunKind, int functionIndex, in
 
 			newTypeAlt->type_alt_lhs	= BENormalTypeNode (newFunctionSymbol, lhsArgs);
 			newTypeAlt->type_alt_rhs	= rhs;
+			newTypeAlt->type_alt_strict_positions	= NULL;
 
 			newIdent->ident_symbol	= newFunctionSymbol;
 			newIdent->ident_name	= functionName;
@@ -820,6 +821,7 @@ CreateLocallyDefinedFunction (int index, char ** abcCode, TypeArgs lhsArgs, Type
 	typeAlt->type_alt_attr_equations	= NULL; /* used in PrintType */
 	typeAlt->type_alt_lhs	= BENormalTypeNode (functionSymbol, lhsArgs);
 	typeAlt->type_alt_rhs	= rhsType;
+	typeAlt->type_alt_strict_positions	= NULL;
 
 	BERule (functionIndex, BEIsNotACaf, typeAlt, ruleAlt);
 	
@@ -1509,6 +1511,7 @@ BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs, BEUniVarEquations attributeEquation
 
 	alt->type_alt_type_context		= NULL;	/* used in PrintType */
 	alt->type_alt_attr_equations	= attributeEquations; /* used in PrintType */
+	alt->type_alt_strict_positions	= NULL;
 
 	return (alt);
 } /* BETypeAlt */
@@ -3381,6 +3384,57 @@ BEExportFunction (int dclFunctionIndex, int iclFunctionIndex)
 	dclDef->sdef_dcl_icl	= iclDef;
 } /* BEExportFunction */
 
+void
+BEStrictPositions (int functionIndex, int *bits, int **positions)
+{
+	BEModuleP			module;
+	SymbolP				functionSymbol;
+	SymbDef				functionDefinition;
+	ImpRules			rule;
+	TypeAlts			ruleType;
+	StrictPositionsP	strict_positions;
+
+	Assert ((unsigned int) main_dcl_module_n < gBEState.be_nModules);
+	module	= &gBEState.be_modules [main_dcl_module_n];
+
+	Assert ((unsigned int) functionIndex < module->bem_nFunctions);
+	functionSymbol	= &module->bem_functions [functionIndex];
+
+	Assert (functionSymbol->symb_kind == definition);
+	functionDefinition	= functionSymbol->symb_def;
+
+	Assert (functionDefinition->sdef_kind == IMPRULE);
+	rule	= functionDefinition->sdef_rule;
+
+	ruleType	= rule->rule_type;
+	Assert (ruleType != NULL);
+
+	strict_positions	= ruleType->type_alt_strict_positions;
+
+	Assert (strict_positions != NULL);
+
+	*bits		= strict_positions->sp_size;
+	*positions	= strict_positions->sp_bits;
+} /* BEStrictPositions */
+
+int
+BECopyInts  (int cLength, int *ints, int *cleanArray)
+{
+    int	cleanLength, truncate;
+
+	cleanLength	= cleanArray [-2];
+
+	truncate	= cleanLength < cLength;
+	if (truncate)
+		cLength	= cleanLength;
+
+	memcpy (cleanArray, ints, cLength * sizeof (int));
+
+	Assert (!truncate);
+
+	return (!truncate);
+} /* BECopyInts */
+
 static void
 CheckBEEnumTypes (void)
 {
@@ -3623,6 +3677,17 @@ BEInit (int argc)
 } /* BEInit */
 
 void
+BECloseFiles (void)
+{
+	if (StdErrorReopened)
+		fclose (StdError);
+	StdErrorReopened = False;
+	if (StdOutReopened)
+		fclose (StdOut);
+	StdOutReopened = False;
+} /* BECloseFiles */
+
+void
 BEFree (BackEnd backEnd)
 {
 	Assert (backEnd == (BackEnd) &gBEState);
@@ -3633,10 +3698,7 @@ BEFree (BackEnd backEnd)
 	Assert (gBEState.be_initialised);
 	gBEState.be_initialised	= False;
 
-	if (StdErrorReopened)
-		fclose (StdError);
-	if (StdOutReopened)
-		fclose (StdOut);
+	BECloseFiles ();
 } /* BEFree */
 
 // temporary hack
diff --git a/backendC/CleanCompilerSources/backend.h b/backendC/CleanCompilerSources/backend.h
index 8f80be5..d690ce8 100644
--- a/backendC/CleanCompilerSources/backend.h
+++ b/backendC/CleanCompilerSources/backend.h
@@ -1,7 +1,7 @@
 /* version info */
 
 // increment this for every release
-# define	kBEVersionCurrent				0x02000215
+# define	kBEVersionCurrent				0x02000216
 
 // change this to the same value as kBEVersionCurrent if the new release is
 // not upward compatible (for example when a function is added)
@@ -9,7 +9,7 @@
 
 // change this to the same value as kBEVersionCurrent if the new release is
 // not downward compatible (for example when a function is removed)
-# define	kBEVersionOldestImplementation	0x02000215
+# define	kBEVersionOldestImplementation	0x02000216
 
 
 # define	kBEDebug	1
@@ -178,6 +178,9 @@ Clean (BEGetVersion :: (Int, Int, Int))
 BackEnd BEInit (int argc);
 Clean (BEInit :: Int UWorld -> (BackEnd, UWorld))
 
+void BECloseFiles (void);
+Clean (BECloseFiles :: BackEnd -> BackEnd)
+
 void BEFree (BackEnd backEnd);
 Clean (BEFree :: BackEnd UWorld -> UWorld)
 
@@ -541,6 +544,11 @@ Clean (BEDefineImportedObjsAndLibs :: BEStringListP BEStringListP BackEnd -> Bac
 void BESetMainDclModuleN (int main_dcl_module_n_parameter);
 Clean (BESetMainDclModuleN :: Int BackEnd -> BackEnd)
 
+void BEStrictPositions (int functionIndex, int *bits, int **positions);
+Clean (BEStrictPositions :: Int BackEnd -> (Int, Int, BackEnd))
+
+int BECopyInts  (int cLength, int *ints, int *cleanArray);
+
 // temporary hack
 void BEDeclareDynamicTypeSymbol (int typeIndex, int moduleIndex);
 Clean (BEDeclareDynamicTypeSymbol :: Int Int BackEnd -> BackEnd)
diff --git a/backendC/CleanCompilerSources/sa.c b/backendC/CleanCompilerSources/sa.c
index 4a75d97..ea8deab 100644
--- a/backendC/CleanCompilerSources/sa.c
+++ b/backendC/CleanCompilerSources/sa.c
@@ -2849,50 +2849,182 @@ static void ConvertStateInfoToStrictInfos (TypeAlts rule_type_alts, unsigned ari
 		InitStrictInfo (result, HnfStrict);
 }
 
-static void UpdateStateInfoWithStrictInfo (TypeNode node, StrictInfo *s,Bool *strict_added_p,Bool *warning)
+#if CLEAN2
+
+/*
+	Encoding for strictness information:
+
+	The strictness information that is found by the strictness
+	analyser is encoded in a bit string. There are two encodings
+
+	compact (but fragile):
+		0 a (s)*     trailing zeros are removed
+
+	robust (but long):
+		1 a (w s t)*
+
+		a	any strictness added
+		()* repeated for each argument position, recursively
+			for strict (after sa) tuples
+		w	argument was strict
+		s	argument strictness added
+		t	argument is tuple
+
+	Example:
+				f ::  ! a   (   a,   [a]) -> a // before sa
+				f ::  ! a ! ( ! a,   [a]) -> a // after sa
+
+	compact		0 1   0   1   1    0	=> 01011 (trailing zeros removed)
+
+	robust		1 1  100 011 010  000   => 11100011010000
+
+	The bit string is represented by a bit count and an array of
+	ints (each 32 bits), where the least significant bit of an int
+	is the first bit in the bit string.
+*/
+
+#define StrictPositionsRobustEncoding 1
+
+#define kMaxStrictPositions 1024
+
+#if StrictPositionsRobustEncoding
+# define	kBitsPerStrictPosition 3
+#else
+# define	kBitsPerStrictPosition 1
+# endif
+
+#define kMaxStrictBits (2+kMaxStrictPositions*kBitsPerStrictPosition)
+#define kBitsPerInt (sizeof (int)*8)
+#define ceilingdiv(a, b) (((a)+(b)-1)/(b)) /* ceiling (a/b) */
+#define bits2ints(n) ceilingdiv(n, kBitsPerInt)
+
+static int strict_positions_last_one;
+static StrictPositionsP strict_positions;
+
+
+static void StrictPositionsClear (void)
 {
-	Bool is_strict_annotated;
-#ifndef SHOW_STRICT_EXPORTED_TUPLE_ELEMENTS
-	Bool local_strict_added;
+	int	i, sizeInts;
+
+	if (strict_positions == NULL)
+	{
+		int	sizeBytes;
 
-	local_strict_added = False;
+		sizeInts = bits2ints(kMaxStrictPositions);
+		sizeBytes = sizeof (StrictPositionsS) + (sizeInts-1) * sizeof (int);
+		strict_positions = CompAlloc (sizeBytes);
+
+		strict_positions->sp_size = 0;
+	}
+
+	sizeInts = bits2ints (strict_positions->sp_size);
+	for (i = 0; i < sizeInts; i++)
+		strict_positions->sp_bits[i]	= 0;
+
+	strict_positions->sp_size = 0;
+	strict_positions_last_one = 0;
+}
+
+static void StrictPositionsAddBit (Bool bit)
+{
+	int size;
+	StrictPositionsP positions;
+
+	positions = strict_positions;
+	size = positions->sp_size;
+
+	if (bit)
+	{
+		Assume (size < kMaxStrictPositions, "too many strict positions", "AddStrictPositions");
+
+		positions->sp_bits [size/kBitsPerInt] |= 1 << (size % kBitsPerInt);
+		strict_positions_last_one = size+1;
+	}
+
+	positions->sp_size = size+1;
+}
+
+
+static StrictPositionsP StrictPositionsCopy (void)
+{
+	StrictPositionsP positions;
+	int sizeBits;
+
+#if StrictPositionsRobustEncoding
+	sizeBits = strict_positions->sp_size;
+#else
+	sizeBits = strict_positions_last_one;
 #endif
 
+	Assume (size < kMaxStrictPositions, "too many strict positions", "StrictPositionsToInts");
+
+	if (sizeBits == 0)
+	{
+		static StrictPositionsS no_strict_postions = {0, {0}};
+
+		positions = &no_strict_postions;
+	}
+	else
+	{
+		int	sizeInts, sizeBytes;
+
+		sizeInts = bits2ints(sizeBits);
+		sizeBytes = sizeof (StrictPositionsS) + (sizeInts-1) * sizeof (int);
+		positions = CompAlloc (sizeBytes);
+		memcpy (positions, strict_positions, sizeBytes);
+	}
+
+	return positions;
+}
+
+#define StrictPositionsStrictAdded(is_strict) StrictPositionsAddBit (is_strict)
+
+#if StrictPositionsRobustEncoding
+# define StrictPositionsWasStrict(is_strict_annotated) StrictPositionsAddBit (is_strict_annotated)
+# define StrictPositionsType(is_tuple) StrictPositionsAddBit (is_tuple)
+#else
+# define StrictPositionsWasStrict(is_strict_annotated)
+# define StrictPositionsType(is_tuple)
+#endif
+
+#endif /* CLEAN2 */
+
+static void UpdateStateInfoWithStrictInfo (TypeNode node, StrictInfo *s,Bool *strict_added_p,Bool *warning)
+{
+	Bool is_strict_annotated, is_strict, is_tuple, strict_added;
+
 	is_strict_annotated = node->type_node_annotation==StrictAnnot;
-	
-	if (IsTupleInfo (s)){
+	is_tuple = IsTupleInfo (s);
+	is_strict = (is_tuple ? GetTupleStrictKind (s) : GetStrictKind (s, 0)) != NotStrict;
+	strict_added = !is_strict_annotated && is_strict;
+
+#if CLEAN2
+	StrictPositionsWasStrict (is_strict_annotated);
+	StrictPositionsStrictAdded (strict_added);
+	StrictPositionsType (is_tuple);
+#endif
+
+	if (strict_added) {
+		node->type_node_annotation=StrictAnnot;
+		*strict_added_p = True;
+	}
+
+	if (is_strict_annotated && !is_strict && StrictChecks)
+		*warning = True;
+
+	if (is_tuple && (is_strict || is_strict_annotated)){
 		unsigned	arity = s->strict_arity;
 		unsigned	i;
 		TypeArgs	args  = node->type_node_arguments;
-		
-		if (GetTupleStrictKind (s) == NotStrict){
-			if (StrictChecks && is_strict_annotated)
-				*warning = True;
-			return;
-		}
-		
-		if (! is_strict_annotated){
-			node->type_node_annotation=StrictAnnot;
-			*strict_added_p = True;
-		}
-		
-		for (i = 0; i < arity; i++, args = args->type_arg_next)
-#ifdef SHOW_STRICT_EXPORTED_TUPLE_ELEMENTS
-			UpdateStateInfoWithStrictInfo (args->type_arg_node,&GetTupleInfo (s,i),strict_added_p,warning);
-#else
-			UpdateStateInfoWithStrictInfo (args->type_arg_node,&GetTupleInfo (s,i),&local_strict_added,warning);
-#endif
-	} else {
-#if 0
-		printf ("%d %d %d\n",GetStrictKind (s, 0),GetStrictKind (s, 1),GetStrictKind (s, 2));
+
+		for (i = 0; i < arity; i++, args = args->type_arg_next) {
+#ifndef SHOW_STRICT_EXPORTED_TUPLE_ELEMENTS
+			Bool local_strict_added;
+
+			local_strict_added = False;
+			strict_added_p = &local_strict_added;
 #endif
-		if (GetStrictKind (s, 0) != NotStrict){
-			if (!is_strict_annotated){
-				node->type_node_annotation=StrictAnnot;
-				*strict_added_p = True;
-			}
-		} else if (StrictChecks && GetStrictKind (s, 0) == NotStrict && is_strict_annotated){
-			*warning = True;
+			UpdateStateInfoWithStrictInfo (args->type_arg_node,&GetTupleInfo (s,i),strict_added_p,warning);
 		}
 	}
 }
@@ -2908,8 +3040,26 @@ static void UpdateStateInfosWithStrictInfos (TypeAlts rule, unsigned arity, Stri
 	/* do the arguments */
 	args = rule->type_alt_lhs->type_node_arguments;
 
-	for (i = 0; i < arity; i++, args = args->type_arg_next)
+#if CLEAN2
+	StrictPositionsClear ();
+	StrictPositionsAddBit (StrictPositionsRobustEncoding);
+	StrictPositionsAddBit (False);
+#endif
+
+	for (i = 0; i < arity; i++, args = args->type_arg_next) {
 		UpdateStateInfoWithStrictInfo (args->type_arg_node,&strict_args[i], strict_added, warning);
+	}
+
+#if CLEAN2
+	if (*strict_added)
+	{
+		Assume (strict_positions->sp_size > 2, "not enough bits", "UpdateStateInfosWithStrictInfos");
+		Assume (strict_positions_last_one > 2, "not enough bits", "UpdateStateInfosWithStrictInfos");
+		strict_positions->sp_bits [0] |= 1 << 1;
+	}
+
+	rule->type_alt_strict_positions = StrictPositionsCopy ();
+#endif
 
 	/* the result has no sense at the moment */	
 }
diff --git a/backendC/CleanCompilerSources/syntax_tree_types.h b/backendC/CleanCompilerSources/syntax_tree_types.h
index ad6cebc..24e1987 100644
--- a/backendC/CleanCompilerSources/syntax_tree_types.h
+++ b/backendC/CleanCompilerSources/syntax_tree_types.h
@@ -427,16 +427,26 @@ typedef struct uni_var_equats
 	struct uni_var_equats *	uve_next;
 } * UniVarEquations;
 
+#if CLEAN2
+STRUCT (strict_positions, StrictPositions)
+{
+	int sp_size;		/* size in bits */
+	int sp_bits [1];	/* variable size */
+};
+#endif
+
 typedef struct type_alt
 {
 	TypeNode				type_alt_lhs;
 	TypeNode				type_alt_rhs;
 	UniVarEquations			type_alt_attr_equations;
 	TypeContext				type_alt_type_context;
-	
 	struct uni_var_admin *	type_alt_attr_vars;
 
 	unsigned				type_alt_line;
+#ifdef CLEAN2
+	StrictPositionsP		type_alt_strict_positions;
+#endif
 } TypeAlt;
 
 typedef struct cons_var_list