fix tail recursion modulo cons optimisation

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

2 files changed, 49 insertions, 36 deletions

diff --git a/backendC/CleanCompilerSources/codegen.c b/backendC/CleanCompilerSources/codegen.c
index 6043417..83100f4 100644
--- a/backendC/CleanCompilerSources/codegen.c
+++ b/backendC/CleanCompilerSources/codegen.c
@@ -591,6 +591,10 @@ int lazy_tuple_recursion=0;
 int call_code_generator_again;
 #endif
 
+#if TAIL_CALL_MODULO_CONS_OPTIMIZATION
+extern int does_tail_call_modulo_cons (NodeP node_p,NodeDefP node_defs);
+#endif
+
 int function_called_only_curried_or_lazy_with_one_return=0;
 
 #if 0
@@ -794,16 +798,12 @@ static void CodeRule (ImpRuleP rule)
 	struct saved_case_node_id_ref_counts *saved_case_node_id_ref_counts_p; 
 
 # if TAIL_CALL_MODULO_CONS_OPTIMIZATION
-	extern int does_tail_call_modulo_cons (NodeP node_p,NodeDefP node_defs);
+	if (OptimizeTailCallModuloCons && rule->rule_alts->alt_kind==Contractum && (rule->rule_mark & RULE_TAIL_MODULO_CONS_ENTRY_MASK)){
+		tail_call_modulo_cons=1;
 
-	if (OptimizeTailCallModuloCons && rule->rule_alts->alt_kind==Contractum){
-		tail_call_modulo_cons=does_tail_call_modulo_cons (rule->rule_alts->alt_rhs_root,rule->rule_alts->alt_rhs_defs);
-
-		if (tail_call_modulo_cons){
-			if (ListOptimizations)
-				printf ("Optimize tail call modulo cons of %s\n",rule_sdef->sdef_ident->ident_name);				
-			call_code_generator_again=1;
-		}
+		if (ListOptimizations)
+			printf ("Optimize tail call modulo cons of %s\n",rule_sdef->sdef_ident->ident_name);				
+		call_code_generator_again=1;
 	} else
 		tail_call_modulo_cons=0;
 # endif
@@ -950,12 +950,12 @@ static void CodeRule (ImpRuleP rule)
 		if (rule->rule_mark & RULE_CALL_VIA_LAZY_SELECTIONS_ONLY){
 			int tuple_result_arity;
 			StateS result_state_struct[1];
-#if SELECTORS_FIRST
+# if SELECTORS_FIRST
 			LabDef reduce_error_label;
-#endif
+# endif
 
 			tuple_result_arity=rule->rule_type->type_alt_rhs->type_node_arity;
-#if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION
+# if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION
 			if (tail_call_modulo_tuple_cons){
 				int i,n;
 				
@@ -964,13 +964,13 @@ static void CodeRule (ImpRuleP rule)
 					if (global_same_select_vector & (1<<i))
 						--tuple_result_arity;
 			}
-#endif	
+# endif	
 
 			GenFunctionDescriptorForLazyTupleRecursion (rule_sdef,tuple_result_arity);
 						
 			result_state_struct[0]=OnAState;
 			
-#if SELECTORS_FIRST
+# if SELECTORS_FIRST
 			{
 			LabDef d_lab,n_lab;
 			int a_size,b_size;
@@ -1006,9 +1006,9 @@ static void CodeRule (ImpRuleP rule)
 			*/
 			ReduceError = &reduce_error_label;
 			}
-#else
+# else
 			ReduceError = &empty_lab;
-#endif
+# endif
 
 			ea_lab.lab_post=2;
 		
@@ -1025,7 +1025,7 @@ static void CodeRule (ImpRuleP rule)
 			else
 				ReduceError = &cycle_lab;
 			
-#if SELECTORS_FIRST
+# if SELECTORS_FIRST
 			if (rule_sdef->sdef_arity!=0){
 				int n;
 				
@@ -1040,7 +1040,7 @@ static void CodeRule (ImpRuleP rule)
 					
 				GenPopA (tuple_result_arity);
 			}
-#endif
+# endif
 
 			CurrentAltLabel.lab_pref = s_pref;
 			if (rule->rule_mark & RULE_UNBOXED_LAZY_CALL)
@@ -1208,6 +1208,13 @@ void CodeGeneration (ImpMod imod, char *fname)
 			create_result_state_database (imod->im_rules);
 #endif
 
+#if TAIL_CALL_MODULO_CONS_OPTIMIZATION
+			if (OptimizeTailCallModuloCons)
+				for_l (rule,imod->im_rules,rule_next)
+					if (rule->rule_alts->alt_kind==Contractum && does_tail_call_modulo_cons (rule->rule_alts->alt_rhs_root,rule->rule_alts->alt_rhs_defs))
+						rule->rule_mark |= RULE_TAIL_MODULO_CONS_ENTRY_MASK;
+#endif
+
 			update_function_p=&first_update_function;
 			for_l (rule,imod->im_rules,rule_next)
 				if (rule->rule_root->node_symbol->symb_def->sdef_over_arity==0){
diff --git a/backendC/CleanCompilerSources/codegen3.c b/backendC/CleanCompilerSources/codegen3.c
index 06c15ef..522f78e 100644
--- a/backendC/CleanCompilerSources/codegen3.c
+++ b/backendC/CleanCompilerSources/codegen3.c
@@ -1365,7 +1365,7 @@ static Bool ExamineRootNodeOnACycle (NodeId rhsid,Node rhsroot,int *asp_p,StateS
 #if TAIL_CALL_MODULO_CONS_OPTIMIZATION
 extern int tail_call_modulo_cons;
 
-static void generate_code_for_tail_call_modulo_cons (NodeP node_p,NodeId node_def_id,NodeP root_node,NodeP push_node,int asp,int bsp,struct code_gen_node_ids *code_gen_node_ids_p)
+static void generate_code_for_tail_call_modulo_cons (NodeP node_p,NodeId node_def_id,NodeP root_node,NodeP push_node,int asp,int bsp,MovedNodeIdP *moved_node_ids_p,struct code_gen_node_ids *code_gen_node_ids_p)
 {
 	LabDef name;
 	int a_size,b_size;
@@ -1443,6 +1443,11 @@ static void generate_code_for_tail_call_modulo_cons (NodeP node_p,NodeId node_de
 			n_a_fill_bits=0;
 			n_b_fill_bits=0;
 
+			if (a_size>0)
+				a_bits|=1;
+			else
+				b_bits|=1;
+
 			arg_p=root_node->node_arguments;
 			node_arity=root_node->node_arity;
 			node_id_list=push_node->node_node_ids;
@@ -1452,7 +1457,7 @@ static void generate_code_for_tail_call_modulo_cons (NodeP node_p,NodeId node_de
 																
 				DetermineSizeOfState (arg_p->arg_state,&arg_a_size,&arg_b_size); 
 				
-				if (arg_n==0 || !(arg_p->arg_node->node_kind==NodeIdNode && arg_p->arg_node->node_node_id==node_id_list->nidl_node_id)){
+				if (!(arg_p->arg_node->node_kind==NodeIdNode && arg_p->arg_node->node_node_id==node_id_list->nidl_node_id)){
 					a_bits |= (~((~0)<<arg_a_size))<<a_size;
 					b_bits |= (~((~0)<<arg_b_size))<<b_size;
 
@@ -1464,7 +1469,7 @@ static void generate_code_for_tail_call_modulo_cons (NodeP node_p,NodeId node_de
 				a_size+=arg_a_size;
 				b_size+=arg_b_size;
 				node_id_list=node_id_list->nidl_next;
-			}
+			}				
 
 			for (n=0; n<a_size; ++n)
 				bits[n]='0' + ((a_bits>>n) & 1);
@@ -1519,6 +1524,16 @@ static void generate_code_for_tail_call_modulo_cons (NodeP node_p,NodeId node_de
 		GenPopB	(bsp);
 		GenRtn (1,0,OnAState);
 	}
+	{
+		MovedNodeIdP moved_node_ids;
+		
+		moved_node_ids=*moved_node_ids_p;
+		
+		while (moved_node_ids!=NULL){
+			moved_node_ids->mnid_node_id->nid_a_index_=moved_node_ids->mnid_a_stack_offset;
+			moved_node_ids=moved_node_ids->mnid_next;
+		}
+	}
 }
 
 static int is_tail_call_module_cons_node (NodeP node_p)
@@ -2016,7 +2031,6 @@ int CodeRhsNodeDefs
 		}
 #endif
 
-
 #if TAIL_CALL_MODULO_CONS_OPTIMIZATION
 		if (OptimizeTailCallModuloCons && root_node->node_kind==NormalNode){
 			if ((root_node->node_symbol->symb_kind==cons_symb && root_node->node_arity==2) ||
@@ -2059,17 +2073,14 @@ int CodeRhsNodeDefs
 									node_p=node_p->node_arguments->arg_node;
 								}
 								
-								if (!(node_def_id->nid_mark & ON_A_CYCLE_MASK) && is_tail_call_module_cons_node (node_p)){
+								if (!(node_def_id->nid_mark & ON_A_CYCLE_MASK) && is_tail_call_module_cons_node (node_p)
+									&& (node_p->node_symbol->symb_def->sdef_rule->rule_mark & RULE_TAIL_MODULO_CONS_ENTRY_MASK))
+								{
 									*last_node_def_h=NULL;
 									CodeSharedNodeDefs (defs,NULL,&asp,&bsp,&code_gen_node_ids);
 									*last_node_def_h=last_node_def_p;
 
-									generate_code_for_tail_call_modulo_cons (node_p,node_def_id,root_node,push_node,asp,bsp,&code_gen_node_ids);
-
-									while (moved_node_ids!=NULL){
-										moved_node_ids->mnid_node_id->nid_a_index_=moved_node_ids->mnid_a_stack_offset;
-										moved_node_ids=moved_node_ids->mnid_next;
-									}
+									generate_code_for_tail_call_modulo_cons (node_p,node_def_id,root_node,push_node,asp,bsp,&moved_node_ids,&code_gen_node_ids);
 
 									return 0;
 								}
@@ -2088,7 +2099,7 @@ int CodeRhsNodeDefs
 							node_p=node_p->node_arguments->arg_node;
 						}
 
-						if (is_tail_call_module_cons_node (node_p)){
+						if (is_tail_call_module_cons_node (node_p) && (node_p->node_symbol->symb_def->sdef_rule->rule_mark & RULE_TAIL_MODULO_CONS_ENTRY_MASK)){
 							NodeP old_arg_node_p;
 							
 							node_id_p=NewNodeId (NULL);
@@ -2099,12 +2110,7 @@ int CodeRhsNodeDefs
 							arg_p2->arg_node=NewNodeIdNode (node_id_p);
 
 							CodeSharedNodeDefs (defs,NULL,&asp,&bsp,&code_gen_node_ids);
-							generate_code_for_tail_call_modulo_cons (node_p,node_id_p,root_node,push_node_p,asp,bsp,&code_gen_node_ids);
-
-							while (moved_node_ids!=NULL){
-								moved_node_ids->mnid_node_id->nid_a_index_=moved_node_ids->mnid_a_stack_offset;
-								moved_node_ids=moved_node_ids->mnid_next;
-							}
+							generate_code_for_tail_call_modulo_cons (node_p,node_id_p,root_node,push_node_p,asp,bsp,&moved_node_ids,&code_gen_node_ids);
 							
 							arg_p2->arg_node=old_arg_node_p;