bug fix

frontend/convertDynamics.icl

@@ -48,11 +48,13 @@ where
 			= convert_groups (inc group_nr) groups global_type_instances (foldSt (convert_function group_nr global_type_instances) group.group_members fun_defs_and_ci)
 
 	convert_function group_nr global_type_instances fun (fun_defs, ci)
-		#! fun_def = fun_defs.[fun]
-		# {fun_body, fun_type, fun_info} = fun_def
-		  (fun_body, ci) = convert_dynamics_in_body {cinp_glob_type_inst = global_type_instances, cinp_group_index = group_nr} fun_body fun_type ci
-		= ({fun_defs & [fun] = { fun_def & fun_body = fun_body, fun_info = { fun_info & fi_local_vars = ci.ci_new_variables ++ fun_info.fi_local_vars }}},
-			{ ci & ci_new_variables = [] }) ---> ("convert_function", ci.ci_new_variables ++ fun_info.fi_local_vars)
+		# (fun_def, fun_defs) = fun_defs![fun]
+		  {fun_body, fun_type, fun_info} = fun_def
+		| isEmpty fun_info.fi_dynamics
+			= (fun_defs, ci)
+			# (fun_body, ci) = convert_dynamics_in_body {cinp_glob_type_inst = global_type_instances, cinp_group_index = group_nr} fun_body fun_type ci
+			= ({fun_defs & [fun] = { fun_def & fun_body = fun_body, fun_info = { fun_info & fi_local_vars = ci.ci_new_variables ++ fun_info.fi_local_vars }}},
+				{ ci & ci_new_variables = [] })
 
 	convert_dynamics_in_body global_type_instances (TransformedBody {tb_args,tb_rhs}) (Yes {st_args}) ci
 		# vars_with_types = bindVarsToTypes tb_args st_args []
@@ -295,17 +297,16 @@ where
 	
 		  /***  convert the elements of this pattern  ***/
 
-		  x_i_bind = { bind_src = opened_dynamic.opened_dynamic_expr,  bind_dst = dp_var }
-		  (a_ij_binds, ci) = createVariables dp_type_patterns_vars [] ci
-	 	  (type_code, ci) = convertTypecode cinp dp_type_code ci
-	 	  (dp_rhs,    ci) = convertDynamics cinp bound_vars this_default dp_rhs ci
+		  (a_ij_binds, ci)	= createVariables dp_type_patterns_vars [] ci
+	 	  (type_code, ci)	= convertTypecode cinp dp_type_code ci
+	 	  (dp_rhs, ci)		= convertDynamics cinp bound_vars this_default dp_rhs ci
 	
 		  /***  recursively convert the other patterns  ***/
 
-		  (binds, ci) = convert_other_patterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci
+		  (binds, ci)		= convert_other_patterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci
 
-	
 		  /***  generate the expression  ***/
+
 	 	  (unify_symb, ci) 		= getSymbol PD_unify SK_Function 2 ci
 		  (twotuple, ci) 		= getTupleSymbol 2 ci
 		  (let_info_ptr, ci) 	= let_ptr ci
@@ -313,10 +314,11 @@ where
 		  (default_expr, ci) 	= toExpression this_default ci
 		  (unify_result_var, ci)	= newVariable "result" VI_Empty ci
 		  unify_result_fv 			= varToFreeVar unify_result_var 1
-		  (unify_bool_var,   ci)	= newVariable "unify_bool" VI_Empty ci
+		  (unify_bool_var, ci)		= newVariable "unify_bool" VI_Empty ci
 		  unify_bool_fv 			= varToFreeVar unify_bool_var 1
 
-		  (let_binds, ci) = bind_indirection_var ind_var unify_result_var twotuple ci
+		  (let_binds, ci) 		= bind_indirection_var ind_var unify_result_var twotuple ci
+		  a_ij_binds			= add_x_i_bind opened_dynamic.opened_dynamic_expr dp_var a_ij_binds
 
 		  let_expr = Let {	let_strict = False,
 		  					let_binds = [{ bind_src = App { app_symb = unify_symb,  app_args = [opened_dynamic.opened_dynamic_type, type_code],  app_info_ptr = nilPtr },
@@ -330,7 +332,7 @@ where
 												case_ident		= No,
 												case_info_ptr	= case_info_ptr	},
 		  					let_info_ptr = let_info_ptr	}
-		= ([x_i_bind : a_ij_binds ++ binds],  let_expr,  { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]})
+		= (a_ij_binds ++ binds,  let_expr,  { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]})
 	where
 		bind_indirection_var var=:{var_info_ptr} unify_result_var twotuple ci=:{ci_var_heap,ci_new_variables}
 			# (VI_Indirection ref_count, ci_var_heap) = readPtr var_info_ptr ci_var_heap
@@ -340,6 +342,11 @@ where
 						{ ci & ci_var_heap = ci_var_heap, ci_new_variables = [ ind_fv : ci_new_variables ]})
 				= ([], {ci & ci_var_heap = ci_var_heap})
 
+		add_x_i_bind bind_src bind_dst=:{fv_count} binds
+			| fv_count > 0
+				= [ { bind_src = bind_src, bind_dst = bind_dst } : binds ]
+				= binds
+
 	convert_other_patterns :: ConversionInput BoundVariables DefaultExpression Int OpenedDynamic AType !(Optional Expression) ![DynamicPattern] !*ConversionInfo
 			-> (Env Expression FreeVar, *ConversionInfo)
 	convert_other_patterns _ _ _ _ _ _  No  []  ci

frontend/trans.icl

@@ -196,7 +196,7 @@ not_an_unsafe_pattern (cc, _, ai) = (cc, False, ai)
 
 instance consumerRequirements BoundVar
 where
-	consumerRequirements {var_info_ptr} _ ai=:{ai_var_heap}
+	consumerRequirements {var_name,var_info_ptr} _ ai=:{ai_var_heap}
 		# (var_info, ai_var_heap) = readPtr var_info_ptr ai_var_heap
 		= continuation var_info { ai & ai_var_heap=ai_var_heap }
 	  where
@@ -206,6 +206,8 @@ where
 			#! ref_count = ai_cur_ref_counts.[arg_position] 
 			   ai_cur_ref_counts = { ai_cur_ref_counts & [arg_position]=min (ref_count+1) 2 }
 			= (temp_var, False, { ai & ai_cur_ref_counts=ai_cur_ref_counts })
+		continuation var_info ai=:{ai_cur_ref_counts}
+			=  abort ("consumerRequirements" ---> (var_name <<- var_info))
 //		continuation vi ai
 //			= (cPassive, ai)
 
@@ -224,7 +226,7 @@ instance consumerRequirements Expression where
 					{ ai & ai_next_var = new_next_var, ai_next_var_of_fun = new_ai_next_var_of_fun, ai_var_heap = ai_var_heap }
 		= consumerRequirements let_expr common_defs ai // XXX why not not_an_unsafe_pattern
 		where
-			init_variables [{bind_dst={fv_count, fv_info_ptr}} : binds] ai_next_var ai_next_var_of_fun ai_var_heap
+			init_variables [{bind_dst={fv_name, fv_count, fv_info_ptr}} : binds] ai_next_var ai_next_var_of_fun ai_var_heap
 /* Sjaak ... */
 				| fv_count > 0
 					= init_variables binds (inc ai_next_var) (inc ai_next_var_of_fun)
@@ -1561,7 +1563,7 @@ where
 		
 transformApplication :: !App ![Expression] !ReadOnlyTI !*TransformInfo -> *(!Expression,!*TransformInfo)
 transformApplication app=:{app_symb=symb=:{symb_kind = SK_Function {glob_module, glob_object},symb_arity}, app_args} extra_args
-	ro ti=:{ti_cons_args,ti_instances,ti_fun_defs}
+			ro ti=:{ti_cons_args,ti_instances,ti_fun_defs}
 	| glob_module == cIclModIndex
 		| glob_object < size ti_cons_args
 			#! cons_class = ti_cons_args.[glob_object]
@@ -1587,9 +1589,17 @@ transformApplication app=:{app_symb=symb=:{symb_kind = SK_Function {glob_module,
 /* ... Sjaak */
 				
 // XXX linear_bits field has to be added for generated functions
-transformApplication app=:{app_symb={symb_kind = SK_GeneratedFunction fun_def_ptr _}} extra_args ro ti=:{ti_fun_heap}
-	# (FI_Function {gf_fun_def,gf_instance_info,gf_cons_args}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
-	= transformFunctionApplication gf_fun_def gf_instance_info gf_cons_args app extra_args ro { ti & ti_fun_heap = ti_fun_heap }
+/* Sjaak ... */
+transformApplication app=:{app_symb={symb_name,symb_kind = SK_GeneratedFunction fun_def_ptr fun_index}} extra_args
+			ro ti=:{ti_cons_args,ti_instances,ti_fun_defs,ti_fun_heap}
+	| fun_index < size ti_cons_args
+		#! cons_class = ti_cons_args.[fun_index]
+		   instances = ti_instances.[fun_index]
+		   fun_def = ti_fun_defs.[fun_index]
+		= transformFunctionApplication fun_def instances cons_class app extra_args ro ti
+		# (FI_Function {gf_fun_def,gf_instance_info,gf_cons_args}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
+		= transformFunctionApplication gf_fun_def gf_instance_info gf_cons_args app extra_args ro { ti & ti_fun_heap = ti_fun_heap }
+/* ... Sjaak  */
 transformApplication app [] ro ti
 	= (App app, ti)
 transformApplication app extra_args ro ti
@@ -1790,14 +1800,15 @@ where
 					(foldSt (transform_function common_defs imported_funs) group_members
 						{ ti & ti_fun_defs = ti_fun_defs, ti_type_heaps = ti_type_heaps, ti_var_heap = ti_var_heap })
 			= (groups, imported_types, collected_imports, ti)
+
 	transform_function common_defs imported_funs fun ti=:{ti_fun_defs}
 		#! fun_def = ti_fun_defs.[fun]
 		# {fun_body = TransformedBody tb} = fun_def
-		  ro =	{	ro_imported_funs = imported_funs
-				,	ro_common_defs = common_defs
-				,	ro_root_case_mode = case tb of {{tb_rhs=Case _} -> RootCase; _ -> NotRootCase}
-				,	ro_fun = fun_def_to_symb_ident fun fun_def
-				,	ro_fun_args = tb.tb_args
+		  ro =	{	ro_imported_funs	= imported_funs
+				,	ro_common_defs 		= common_defs
+				,	ro_root_case_mode	= case tb of {{tb_rhs=Case _} -> RootCase; _ -> NotRootCase}
+				,	ro_fun				= fun_def_to_symb_ident fun fun_def
+				,	ro_fun_args			= tb.tb_args
 				}
 		  (fun_rhs, ti) = transform tb.tb_rhs ro ti
 		= { ti & ti_fun_defs = {ti.ti_fun_defs & [fun] = { fun_def & fun_body = TransformedBody { tb & tb_rhs = fun_rhs }}}}

frontend/transform.icl

@@ -1247,13 +1247,14 @@ where
 					= collect_variables_in_binds binds collected_binds free_vars cos
 					= (collected_binds, free_vars, cos)
 		
-			examine_reachable_binds bind_found [bind=:{bind_dst={fv_info_ptr},bind_src} : binds] collected_binds free_vars cos
+			examine_reachable_binds bind_found [bind=:{bind_dst=fv=:{fv_info_ptr},bind_src} : binds] collected_binds free_vars cos
 				# (bind_found, binds, collected_binds, free_vars, cos) = examine_reachable_binds bind_found binds collected_binds free_vars cos
 				#! var_info = sreadPtr fv_info_ptr cos.cos_var_heap
 				# (VI_Count count is_global) = var_info
 				| count > 0
 					# (bind_src, free_vars, cos) = collectVariables bind_src free_vars cos
-					= (True, binds, [ { bind & bind_src = bind_src } : collected_binds ], free_vars, cos)
+/* Sjaak */
+					= (True, binds, [ { bind_dst = { fv & fv_count = count }, bind_src = bind_src } : collected_binds ], free_vars, cos)
 					= (bind_found, [bind : binds], collected_binds, free_vars, cos)
 			examine_reachable_binds bind_found [] collected_binds free_vars cos
 				= (bind_found, [], collected_binds, free_vars, cos)

frontend/typesupport.dcl

@@ -5,7 +5,7 @@ import checksupport, StdCompare
 from unitype import Coercions, CoercionTree, AttributePartition
 
 // MW: this switch is used to en(dis)able the fusion algorithm
-SwitchFusion fuse dont_fuse :== fuse
+SwitchFusion fuse dont_fuse :== dont_fuse
 
 errorHeading :: !String !*ErrorAdmin -> *ErrorAdmin
 

frontend/typesupport.icl

@@ -4,7 +4,7 @@ import StdEnv, StdCompare
 import syntax, parse, check, unitype, utilities, RWSDebug
 
 // MW: this switch is used to en(dis)able the fusion algorithm
-SwitchFusion fuse dont_fuse :== fuse
+SwitchFusion fuse dont_fuse :== dont_fuse
 
 ::	Store	:== Int