now the same type unification algorithm is used for inlining dictionaries

and the other producers


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

1 files changed, 8 insertions, 75 deletions

diff --git a/frontend/trans.icl b/frontend/trans.icl
index e556f74..9623c98 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -1323,36 +1323,13 @@ where
 				[linear_bit : new_linear_bits], [cons_arg /* was cActive*/ : new_cons_args], type_heaps, symbol_heap, fun_defs, fun_heap,
 				writeVarInfo fv_info_ptr (VI_Variable fv_name new_info_ptr) var_heap)
 
-		determine_arg (PR_Class class_app free_vars class_type) {fv_info_ptr,fv_name} prod_index _
-					  (vars, arg_types, result_type, type_vars, new_linear_bits, new_cons_args, type_heaps=:{th_vars}, symbol_heap, fun_defs, fun_heap, var_heap)
-/*
+		determine_arg (PR_Class class_app free_vars class_type) {fv_info_ptr,fv_name} prod_index (_,(_, _, ro))
+					  (vars, arg_types, result_type, type_vars, new_linear_bits, new_cons_args, type_heaps, symbol_heap, fun_defs, fun_heap, var_heap)
 			# (arg_type, arg_types) = arg_types![prod_index]
 			  empty_atype = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE }
-			| False--->("determine_arg", class_type, getTypeVars class_type, arg_type, type_vars)
-				= undef
-			# (unbounded_type_vars, th_vars)
+			  (unbounded_type_vars, type_heaps)
 			  		= createBindingsForUnifiedTypes { empty_atype & at_type = class_type } (hd arg_type)
-			  										((getTypeVars class_type)++type_vars) th_vars
-			  (arg_types, type_heaps) = substituteArr { arg_types & [prod_index] = repeatn (length free_vars) empty_atype} { type_heaps & th_vars = th_vars }
-			  (result_type, type_heaps) = substitute result_type type_heaps
-			= ( mapAppend (\{var_info_ptr,var_name} 
-							-> { fv_name = var_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = 0 })
-						  free_vars vars
-			  , arg_types
-			  , result_type
-			  , unbounded_type_vars
-			  , mapAppend (\_ -> True) free_vars new_linear_bits
-			  , mapAppend (\_ -> cActive) free_vars new_cons_args
-			  , type_heaps
-			  , symbol_heap
-			  , fun_defs
-			  , fun_heap
-			  , writeVarInfo fv_info_ptr (VI_Dictionary class_app.app_symb class_app.app_args class_type) var_heap
-			  )
-*/
-			# (arg_type, arg_types) = arg_types![prod_index]
-			  type_heaps = bind_class_types (hd arg_type).at_type class_type type_heaps
-			  empty_atype = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE }
+			  										((getTypeVars class_type)++type_vars) ro.ro_common_defs type_heaps
 			  (arg_types, type_heaps) = substituteArr { arg_types & [prod_index] = repeatn (length free_vars) empty_atype} type_heaps
 			  (result_type, type_heaps) = substitute result_type type_heaps
 			= ( mapAppend (\{var_info_ptr,var_name} 
@@ -1360,7 +1337,7 @@ where
 						  free_vars vars
 			  , arg_types
 			  , result_type
-			  , type_vars
+			  , unbounded_type_vars
 			  , mapAppend (\_ -> True) free_vars new_linear_bits
 			  , mapAppend (\_ -> cActive) free_vars new_cons_args
 			  , type_heaps
@@ -1369,7 +1346,6 @@ where
 			  , fun_heap
 			  , writeVarInfo fv_info_ptr (VI_Dictionary class_app.app_symb class_app.app_args class_type) var_heap
 			  )
-
 		determine_arg producer {fv_info_ptr,fv_name} prod_index ((linear_bit, _),(ti_cons_args, consumer_body_rhs, ro))
 						(vars, arg_types, result_type, type_vars, new_linear_bits, new_cons_args, type_heaps=:{th_vars, th_attrs}, symbol_heap, fun_defs, fun_heap, var_heap)
 			# symbol = get_producer_symbol producer
@@ -1500,35 +1476,6 @@ where
 			= foldr (\atype1 atype2->{at_attribute=TA_None, at_annotation=AN_None, at_type=atype1-->atype2})
 					st_result (drop (nr_of_applied_args-nr_context_args) st_args)
 
-		bind_class_types (TA _ context_types) (TA _ instance_types) type_heaps=:{th_vars}
-			# th_vars = bind_context_types context_types instance_types th_vars
-			= { type_heaps & th_vars = th_vars }
-		where
-			bind_context_types [ctype : atypes] [itype : types] th_vars
-				= bind_context_types atypes types (bind_type ctype.at_type itype.at_type th_vars)
-			bind_context_types [] [] th_vars
-				= th_vars
-		bind_class_types _ _ th_vars
-			= th_vars
-			
-		bind_type (TV {tv_info_ptr}) type type_var_heap
-			= type_var_heap <:= (tv_info_ptr, TVI_Type type)
-		bind_type (TA {type_name} arg_types1) (TA _ arg_types2) type_var_heap
-			| length arg_types1 == length arg_types2
-				= bind_types arg_types1 arg_types2 type_var_heap
-				= abort ("bind_type (trans.icl)" ---> (type_name, arg_types1, arg_types2))
-		bind_type (CV {tv_info_ptr} :@: arg_types1) (TA type_cons arg_types2) type_var_heap
-			# type_arity = type_cons.type_arity - length arg_types1
-			  type_var_heap = type_var_heap <:= (tv_info_ptr, TVI_Type (TA {type_cons & type_arity = type_arity} (take type_arity arg_types2)))
-			= bind_types arg_types1 (drop type_arity arg_types2) type_var_heap
-		bind_type _ _ type_var_heap
-			= type_var_heap
-		
-		bind_types [type1 : types1] [type2 : types2] type_var_heap
-			= bind_types types1 types2 (bind_type type1.at_type type2.at_type type_var_heap)
-		bind_types [] [] type_var_heap
-			= type_var_heap
-
 	new_variables [] var_heap
 		= ([], var_heap)
 	new_variables [form=:{fv_name,fv_info_ptr}:forms] var_heap
@@ -1558,13 +1505,6 @@ where
 			= max fun_info.fi_group_index current_max
 			# (FI_Function generated_function) = sreadPtr fun_ptr fun_heap
 			= max generated_function.gf_fun_def.fun_info.fi_group_index current_max
-/*
-	max_group_index_of_producer (PR_GeneratedFunction { symb_kind = SK_GeneratedFunction fun_ptr _} _ _)
-								current_max fun_defs fun_heap cons_args
-		# (FI_Function generated_function) = sreadPtr fun_ptr fun_heap
-		  fun_def = generated_function.gf_fun_def
-		= max fun_def.fun_info.fi_group_index current_max
-*/
 	max_group_index_of_producer prod current_max fun_defs fun_heap cons_args
 		= abort ("trans.icl: max_group_index_of_producer" ---> prod)
 
@@ -1623,7 +1563,7 @@ createBindingsForUnifiedTypes type_1 type_2 all_type_vars common_defs type_heaps
 							-> bind_and_unify_types root_1 root_2 common_defs type_heaps
 	bind_and_unify_types (TV tv_1) type common_defs type_heaps=:{th_vars}
 		| not (is_non_variable_type type)
-			= abort "compiler error in trans.icl: assertion failed (1) XXX"
+			= abort ("compiler error in trans.icl: assertion failed (1) XXX"--->type)
 		# th_vars = bind_variable_to_type tv_1 type th_vars
 		= { type_heaps & th_vars = th_vars }
 	bind_and_unify_types type (TV tv_1) common_defs type_heaps=:{th_vars}
@@ -1776,11 +1716,11 @@ transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_
 	  					(update_instance_info app_symb.symb_kind instances { ti & ti_fun_heap = ti_fun_heap, ti_trace = False })
 	  			  app_symb = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr fun_index, symb_arity = length new_args}
 				  (app_symb, app_args, extra_args) = complete_application app_symb fun_arity new_args extra_args
-	  			= (build_application { app & app_symb = app_symb, app_args = app_args } extra_args, ti)
+	  			= transformApplication { app & app_symb = app_symb, app_args = app_args } extra_args ro ti
 	  			# (FI_Function {gf_fun_index, gf_fun_def}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
 				  app_symb = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr gf_fun_index, symb_arity = length new_args}
 				  (app_symb, app_args, extra_args) = complete_application app_symb gf_fun_def.fun_arity new_args extra_args
-	  			= (build_application { app & app_symb = app_symb, app_args = app_args } extra_args, {ti & ti_fun_heap = ti_fun_heap })
+	  			= transformApplication { app & app_symb = app_symb, app_args = app_args } extra_args ro {ti & ti_fun_heap = ti_fun_heap }
 			= (build_application { app & app_symb = app_symb, app_args = app_args } extra_args, ti)
 		= (build_application { app & app_symb = app_symb, app_args = app_args } extra_args, ti)
 where
@@ -1792,13 +1732,6 @@ where
 			= { ti & ti_instances = { ti_instances & [fun_index] = instances } }
 		# (FI_Function fun_info, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
 		= { ti & ti_fun_heap = ti_fun_heap <:= (fun_def_ptr, FI_Function { fun_info & gf_instance_info = instances })}
-/*
-	update_instance_info (SK_Function {glob_object}) instances ti=:{ti_instances}
-		 = { ti & ti_instances = { ti_instances & [glob_object] = instances } }
-	update_instance_info (SK_GeneratedFunction fun_def_ptr _) instances ti=:{ti_fun_heap}
-		# (FI_Function fun_info, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
-		= { ti & ti_fun_heap = ti_fun_heap <:= (fun_def_ptr, FI_Function { fun_info & gf_instance_info = instances })}
-*/
 
 	complete_application symb form_arity args []
 		= (symb, args, [])