Commit 616e33c0 authored by johnvg@science.ru.nl's avatar johnvg@science.ru.nl

remove old overlapping instance test, change find instance algorithm, first...

remove old overlapping instance test, change find instance algorithm, first determine if an instance exists that only has type constructors as root types (monomorphic root), if so try to find the instance in this group, otherwise try the other instances (polymorphic root)
parent 893c83ef
......@@ -8,3 +8,5 @@ from overloading import ::ClassInstanceInfo,::InstanceTree(..)
from checksupport import ::ErrorAdmin
check_if_class_instances_overlap :: !*ClassInstanceInfo !{#CommonDefs} !*TypeVarHeap !*ErrorAdmin -> (!*ClassInstanceInfo,!*TypeVarHeap,!*ErrorAdmin)
:: SortedInstances = SI_Node ![Global Index] !SortedInstances !SortedInstances | SI_Empty
......@@ -5,6 +5,8 @@ import syntax,compare_types,utilities,checksupport
from expand_types import simplifyAndCheckTypeApplication
from overloading import ::ClassInstanceInfo,::InstanceTree(..)
:: SortedInstances = SI_Node ![Global Index] !SortedInstances !SortedInstances | SI_Empty
check_if_class_instances_overlap :: !*ClassInstanceInfo !{#CommonDefs} !*TypeVarHeap !*ErrorAdmin -> (!*ClassInstanceInfo,!*TypeVarHeap,!*ErrorAdmin)
check_if_class_instances_overlap class_instances common_defs tvh error_admin
= check_class_instances_of_modules 0 class_instances common_defs tvh error_admin
......@@ -16,8 +18,6 @@ check_class_instances_of_modules module_n class_instances common_defs tvh error_
= check_class_instances_of_modules (module_n+1) class_instances common_defs tvh error_admin
= (class_instances,tvh,error_admin)
:: SortedInstances = SI_Node ![Global Index] !SortedInstances !SortedInstances | SI_Empty
check_class_instances_of_module :: !Int !Int !*ClassInstanceInfo !{#CommonDefs} !*TypeVarHeap !*ErrorAdmin -> (!*ClassInstanceInfo,!*TypeVarHeap,!*ErrorAdmin)
check_class_instances_of_module class_n module_n class_instances common_defs tvh error_admin
| class_n<size class_instances.[module_n]
......@@ -29,6 +29,11 @@ check_class_instances_of_module class_n module_n class_instances common_defs tvh
(tvh,error_admin) = check_if_sorted_instances_overlap normal_instances common_defs tvh error_admin
(tvh,error_admin) = check_if_sorted_instances_overlap default_instances common_defs tvh error_admin
(tvh,error_admin) = check_if_other_instances_overlap normal_instances default_instances other_instances common_defs tvh error_admin
(instance_tree,error_admin) = add_sorted_instances_to_instance_tree default_instances common_defs IT_Empty error_admin
(instance_tree,error_admin) = add_instances_to_instance_tree other_instances common_defs instance_tree error_admin
class_instances & [module_n].[class_n] = IT_Trees normal_instances instance_tree
= check_class_instances_of_module (class_n+1) module_n class_instances common_defs tvh error_admin
= (class_instances,tvh,error_admin)
......@@ -37,6 +42,7 @@ classify_and_sort_instances :: !InstanceTree !SortedInstances !SortedInstances !
classify_and_sort_instances (IT_Node instance_index=:{glob_module,glob_object} left right) normal_instances default_instances other_instances common_defs tvh
#! {ins_type={it_types},ins_specials} = common_defs.[glob_module].com_instance_defs.[glob_object]
| ins_specials=:SP_GenerateRecordInstances
# (default_instances,tvh) = add_to_sorted_instances instance_index it_types default_instances common_defs tvh
= classify_and_sort_left_and_right_instances left right normal_instances default_instances other_instances common_defs tvh
# (is_normal_instance,tvh) = instance_root_types_specified it_types common_defs tvh
| is_normal_instance
......@@ -108,6 +114,39 @@ check_if_sorted_instances_overlap (SI_Node [instance_index=:{glob_module,glob_ob
check_if_sorted_instances_overlap SI_Empty common_defs tvh error_admin
= (tvh,error_admin)
add_sorted_instances_to_instance_tree :: !SortedInstances !{#CommonDefs} !*InstanceTree !*ErrorAdmin -> (!*InstanceTree,!*ErrorAdmin)
add_sorted_instances_to_instance_tree (SI_Node instances left right) common_defs instance_tree error_admin
# (instance_tree,error_admin) = add_instances_to_instance_tree instances common_defs instance_tree error_admin
# (instance_tree,error_admin) = add_sorted_instances_to_instance_tree left common_defs instance_tree error_admin
= add_sorted_instances_to_instance_tree right common_defs instance_tree error_admin
add_sorted_instances_to_instance_tree SI_Empty common_defs instance_tree error_admin
= (instance_tree,error_admin)
add_instances_to_instance_tree :: ![Global Int] !{#CommonDefs} !*InstanceTree !*ErrorAdmin -> (!*InstanceTree,!*ErrorAdmin)
add_instances_to_instance_tree [instance_index=:{glob_module,glob_object}:instances] common_defs instance_tree error_admin
#! it_types = common_defs.[glob_module].com_instance_defs.[glob_object].ins_type.it_types
# (instance_tree,error_admin) = insert_instance_in_tree it_types glob_module glob_object common_defs instance_tree error_admin
= add_instances_to_instance_tree instances common_defs instance_tree error_admin
add_instances_to_instance_tree [] common_defs instance_tree error_admin
= (instance_tree,error_admin)
insert_instance_in_tree :: ![Type] !Index !Index !{#CommonDefs} !*InstanceTree !*ErrorAdmin -> (!*InstanceTree,!*ErrorAdmin)
insert_instance_in_tree ins_types new_ins_module new_ins_index common_defs (IT_Node ins=:{glob_object,glob_module} it_less it_greater) error_admin
#! {ins_type={it_types}} = common_defs.[glob_module].com_instance_defs.[glob_object]
# cmp = compareInstances ins_types it_types // to do: use compare that expands synonym types
| cmp == Smaller
# (it_less,error_admin) = insert_instance_in_tree ins_types new_ins_module new_ins_index common_defs it_less error_admin
= (IT_Node ins it_less it_greater, error_admin)
| cmp == Greater
# (it_greater,error_admin) = insert_instance_in_tree ins_types new_ins_module new_ins_index common_defs it_greater error_admin
= (IT_Node ins it_less it_greater, error_admin)
| ins.glob_object==new_ins_index && ins.glob_module==new_ins_module
= (IT_Node ins it_less it_greater, error_admin)
# error_admin = overlapping_instance_error new_ins_module new_ins_index ins common_defs error_admin
= (IT_Node ins it_less it_greater, error_admin)
insert_instance_in_tree ins_types new_ins_module new_ins_index common_defs IT_Empty error_admin
= (IT_Node {glob_object = new_ins_index,glob_module = new_ins_module} IT_Empty IT_Empty, error_admin)
check_if_instances_overlap :: ![Global Index] ![([Type],Global Index)] !{#CommonDefs} !*TypeVarHeap !*ErrorAdmin
-> (![([Type],Global Index)],!*TypeVarHeap,!*ErrorAdmin)
check_if_instances_overlap [instance_index=:{glob_module,glob_object}:instances] previous_instances common_defs tvh error_admin
......
......@@ -20,3 +20,5 @@ instance == BasicType, TypeVar, AttributeVar, AttrInequality, TypeSymbIdent, Def
instance < MemberDef
smallerOrEqual :: !Type !Type -> CompareValue
compareInstances :: ![Type] ![Type] -> CompareValue
......@@ -169,7 +169,6 @@ where
instance =< SymbIdent
where
(=<) {symb_kind=symb_kind1} {symb_kind=symb_kind2} = symb_kind1 =< symb_kind2
instance =< App
where
......@@ -202,7 +201,7 @@ where
| s1 < s2
= Smaller
= Greater
instance =< Expression
where
(=<) expr1 expr2
......@@ -354,3 +353,77 @@ where
instance < MemberDef
where
(<) md1 md2 = md1.me_ident.id_name < md2.me_ident.id_name
(CAND) infix 3 :: !(!CompareValue, ![(Ident,Ident)]) (CompareValue, [(Ident,Ident)]) -> (CompareValue, [(Ident,Ident)])
(CAND) (cv1,vlist1) cl2
| cv1 == Equal
= case cl2 of
(cv2,vlist2)
| cv2 == Equal
-> compare_and_add_variables vlist1 vlist2
-> (cv2,[])
= (cv1,[])
compare_and_add_variables :: ![(Ident,Ident)] ![(Ident,Ident)] -> (!CompareValue,![(Ident,Ident)])
compare_and_add_variables vlist1 []
= (Equal, vlist1)
compare_and_add_variables vlist1 [v2=:(v2a,v2b):vlist2]
# (cv,not_found) = compare_variable vlist1 v2a v2b
| cv==Equal
| not_found
= compare_and_add_variables (vlist1++[v2]) vlist2
= compare_and_add_variables vlist1 vlist2
= (cv, [])
compare_variable :: ![(Ident,Ident)] !Ident !Ident -> (!CompareValue,!Bool)
compare_variable [(v1a,v1b):vlist1] v2a v2b
| v1a==v2a
| v1b==v2b
= (Equal,False)
= (Smaller,False)
| v1b==v2b
= (Greater,False)
= compare_variable vlist1 v2a v2b
compare_variable [] v2a v2b
= (Equal,True)
compareInstances :: ![Type] ![Type] -> CompareValue
compareInstances types1 types2
# (cv, vlist) = compare_lists types1 types2
= cv
where
compare_lists [type1:types1] [type2:types2]
= compareInstanceTypes type1 type2 CAND compare_lists types1 types2
compare_lists [] []
= (Equal, [])
compare_lists [] types
= (Smaller, [])
compare_lists types []
= (Greater, [])
compareInstanceTypes (TA tc1 a1) (TA tc2 a2) = (tc1 =< tc2,[]) CAND compareArguments a1 a2
compareInstanceTypes (TA tc1 a1) (TAS tc2 a2 _) = (tc1 =< tc2,[]) CAND compareArguments a1 a2
compareInstanceTypes (TAS tc1 a1 _) (TA tc2 a2) = (tc1 =< tc2,[]) CAND compareArguments a1 a2
compareInstanceTypes (TAS tc1 a1 _) (TAS tc2 a2 _) = (tc1 =< tc2,[]) CAND compareArguments a1 a2
compareInstanceTypes t1 t2
| equal_constructor t1 t2
= compare_arguments t1 t2
| less_constructor t1 t2
= (Smaller, [])
= (Greater, [])
where
compare_arguments (TB tb1) (TB tb2) = (tb1 =< tb2, [])
compare_arguments (t1a --> t1r) (t2a --> t2r) = compareInstanceTypes t1a.at_type t2a.at_type CAND compareInstanceTypes t1r.at_type t2r.at_type
compare_arguments (TArrow1 t1) (TArrow1 t2) = compareInstanceTypes t1.at_type t2.at_type
compare_arguments (TV tv1) (TV tv2) = (Equal, [(tv1.tv_ident,tv2.tv_ident)])
compare_arguments type1 type2 = (Equal, [])
compareArguments [{at_type=type1}:types1] [{at_type=type2}:types2]
= compareInstanceTypes type1 type2 CAND compareArguments types1 types2
compareArguments [] []
= (Equal, [])
compareArguments [] types
= (Smaller, [])
compareArguments types []
= (Greater, [])
......@@ -41,7 +41,7 @@ set_hte_mark hte_mark ht = {ht & hte_mark=hte_mark}
instance =< IdentClass
where
(=<) (IC_Instance types1) (IC_Instance types2)
= compare_types types1 types2
= compareInstances types1 types2
(=<) (IC_InstanceMember types1) (IC_InstanceMember types2)
= compare_types types1 types2
(=<) (IC_GenericCase type1) (IC_GenericCase type2)
......
......@@ -2,10 +2,14 @@ definition module overloading
import StdEnv
import syntax, typesupport
from check_instances import ::SortedInstances
:: InstanceTree = IT_Node !(Global Index) !InstanceTree !InstanceTree | IT_Empty
:: InstanceTree
= IT_Node !(Global Index) !InstanceTree !InstanceTree
| IT_Empty
| IT_Trees !SortedInstances !InstanceTree
:: ClassInstanceInfo :== {# {! .InstanceTree}}
:: ClassInstanceInfo :== {# .{! .InstanceTree}}
:: ArrayInstance =
{ ai_record :: !TypeSymbIdent
......
......@@ -4,6 +4,7 @@ import StdEnv,StdOverloadedList,compare_types
import syntax, type, expand_types, utilities, unitype, predef, checktypes
import genericsupport, type_io_common
from check_instances import ::SortedInstances(..)
:: LocalTypePatternVariable =
{ ltpv_var :: !Int
......@@ -311,9 +312,45 @@ where
# rs_state = {rs_state & rs_type_heaps=rs_type_heaps}
= mapSt (reduce_any_context info) instantiated_context rs_state
find_instance :: [Type] !InstanceTree {#CommonDefs} *TypeHeaps *Coercions -> *(Global Int,[TypeContext],Bool,*TypeHeaps,*Coercions)
find_instance co_types (IT_Node this_inst_index=:{glob_object,glob_module} left right) defs type_heaps coercion_env
# (left_index, types, uni_ok, type_heaps, coercion_env) = find_instance co_types left defs type_heaps coercion_env
find_instance :: [Type] !InstanceTree {#CommonDefs} *TypeHeaps !*Coercions -> *(!Global Int,![TypeContext],!Bool,!*TypeHeaps,!*Coercions)
find_instance co_types (IT_Trees sorted_instances instance_tree) defs type_heaps coercion_env
# (found, instances, type_heaps) = find_instance_group co_types sorted_instances defs type_heaps
| found
= find_root_monomorphic_instance_in_group co_types instances defs type_heaps coercion_env
= find_root_polymorphic_instance co_types instance_tree defs type_heaps coercion_env
find_instance_group :: [Type] !SortedInstances !{#CommonDefs} !*TypeHeaps -> *(!Bool,![Global Int],!*TypeHeaps)
find_instance_group co_types (SI_Node instances=:[this_inst_index=:{glob_object,glob_module}:_] left right) defs type_heaps
#! {it_types} = defs.[glob_module].com_instance_defs.[glob_object].ins_type
# (compare_value, type_heaps) = compare_instance_root_types it_types co_types defs type_heaps
| compare_value==Equal
= (True, instances, type_heaps)
| compare_value==Greater
= find_instance_group co_types left defs type_heaps
| compare_value==Smaller
= find_instance_group co_types right defs type_heaps
= (False, [], type_heaps)
find_instance_group co_types SI_Empty defs type_heaps
= (False, [], type_heaps)
find_root_monomorphic_instance_in_group :: [Type] ![Global Index] {#CommonDefs} *TypeHeaps *Coercions -> *(Global Int,[TypeContext],Bool,*TypeHeaps,*Coercions)
find_root_monomorphic_instance_in_group co_types [this_inst_index=:{glob_object,glob_module}:instances] defs type_heaps coercion_env
# {ins_type={it_types,it_context}, ins_specials} = defs.[glob_module].com_instance_defs.[glob_object]
(matched, type_heaps) = match defs it_types co_types type_heaps
| matched
# (subst_context, type_heaps) = fresh_contexts it_context type_heaps
(uni_ok, coercion_env, type_heaps) = adjust_type_attributes defs co_types it_types coercion_env type_heaps
(spec_inst, type_heaps) = trySpecializedInstances subst_context (get_specials ins_specials) type_heaps
| FoundObject spec_inst
= (spec_inst, [], uni_ok, type_heaps, coercion_env)
= (this_inst_index, subst_context, uni_ok, type_heaps, coercion_env)
= find_root_monomorphic_instance_in_group co_types instances defs type_heaps coercion_env
find_root_monomorphic_instance_in_group co_types [] defs heaps coercion_env
= (ObjectNotFound, [], True, heaps, coercion_env)
find_root_polymorphic_instance :: [Type] !InstanceTree {#CommonDefs} *TypeHeaps *Coercions -> *(Global Int,[TypeContext],Bool,*TypeHeaps,*Coercions)
find_root_polymorphic_instance co_types (IT_Node this_inst_index=:{glob_object,glob_module} left right) defs type_heaps coercion_env
# (left_index, types, uni_ok, type_heaps, coercion_env) = find_root_polymorphic_instance co_types left defs type_heaps coercion_env
| FoundObject left_index
= (left_index, types, uni_ok, type_heaps, coercion_env)
# {ins_type={it_types,it_context}, ins_specials} = defs.[glob_module].com_instance_defs.[glob_object]
......@@ -325,8 +362,8 @@ where
| FoundObject spec_inst
= (spec_inst, [], uni_ok, type_heaps, coercion_env)
= (this_inst_index, subst_context, uni_ok, type_heaps, coercion_env)
= find_instance co_types right defs type_heaps coercion_env
find_instance co_types IT_Empty defs heaps coercion_env
= find_root_polymorphic_instance co_types right defs type_heaps coercion_env
find_root_polymorphic_instance co_types IT_Empty defs heaps coercion_env
= (ObjectNotFound, [], True, heaps, coercion_env)
get_specials :: Specials -> [Special]
......@@ -650,7 +687,7 @@ where
# (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args arg_type.at_type type_heaps
-> try_to_unbox expanded_type defs (predef_symbols, type_heaps)
_
-> (TE, No, (predef_symbols, type_heaps))
-> (TE, No, (predef_symbols, type_heaps))
try_to_unbox type _ predef_symbols_type_heaps
= (TE, No, predef_symbols_type_heaps)
......@@ -659,43 +696,80 @@ where
# (left_index,predef_symbols) = find_unboxed_array_instance element_type left defs predef_symbols
| FoundObject left_index
= (left_index,predef_symbols)
= case defs.[glob_module].com_instance_defs.[glob_object].ins_type.it_types of
[TA {type_index={glob_module,glob_object}} _,instance_element_type:_]
| is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols
-> case (element_type,instance_element_type) of
(TB bt1,TB bt2)
| bt1==bt2
-> (this_inst_index,predef_symbols)
(TA {type_index=ti1} [_],TA {type_index=ti2} [_]) // for array elements
| ti1==ti2
-> (this_inst_index,predef_symbols)
_
-> find_unboxed_array_instance element_type right defs predef_symbols
_
-> find_unboxed_array_instance element_type right defs predef_symbols
find_unboxed_array_instance co_types IT_Empty defs predef_symbols
| unboxed_array_instance_type_matches defs.[glob_module].com_instance_defs.[glob_object].ins_type.it_types element_type predef_symbols
= (this_inst_index,predef_symbols)
= find_unboxed_array_instance element_type right defs predef_symbols
find_unboxed_array_instance element_type IT_Empty defs predef_symbols
= (ObjectNotFound,predef_symbols)
find_unboxed_array_instance element_type (IT_Trees sorted_instances instances) defs predef_symbols
# (index,predef_symbols) = find_sorted_unboxed_array_instance element_type sorted_instances defs predef_symbols
| FoundObject index
= (index,predef_symbols)
= find_unboxed_array_instance element_type instances defs predef_symbols
where
find_sorted_unboxed_array_instance element_type (SI_Node instances left right) defs predef_symbols
# (left_index,predef_symbols) = find_sorted_unboxed_array_instance element_type left defs predef_symbols
| FoundObject left_index
= (left_index,predef_symbols)
# (inst_index,predef_symbols) = find_unboxed_array_instance_in_list element_type instances defs predef_symbols
| FoundObject left_index
= (inst_index,predef_symbols)
= find_sorted_unboxed_array_instance element_type right defs predef_symbols
find_sorted_unboxed_array_instance element_type SI_Empty defs predef_symbols
= (ObjectNotFound,predef_symbols)
find_unboxed_array_instance_in_list element_type [this_inst_index=:{glob_object,glob_module}:instances] defs predef_symbols
| unboxed_array_instance_type_matches defs.[glob_module].com_instance_defs.[glob_object].ins_type.it_types element_type predef_symbols
= (this_inst_index,predef_symbols)
= find_unboxed_array_instance_in_list element_type instances defs predef_symbols
find_unboxed_array_instance_in_list element_type [] defs predef_symbols
= (ObjectNotFound,predef_symbols)
unboxed_array_instance_type_matches [TA {type_index={glob_module,glob_object}} _,TB bt1:_] (TB bt2) predef_symbols
= is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols && bt1==bt2
unboxed_array_instance_type_matches [TA {type_index={glob_module,glob_object}} _,TA {type_index=ti1} [_]:_] (TA {type_index=ti2} [_]) predef_symbols
// for array elements
= is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols && ti1==ti2
unboxed_array_instance_type_matches _ _ _
= False
find_unboxed_list_instance :: Type !InstanceTree {#CommonDefs} -> Global Int
find_unboxed_list_instance element_type (IT_Node this_inst_index=:{glob_object,glob_module} left right) defs
# left_index = find_unboxed_list_instance element_type left defs
| FoundObject left_index
= left_index
= case defs.[glob_module].com_instance_defs.[glob_object].ins_type.it_types of
[instance_element_type]
-> case (element_type,instance_element_type) of
(TB bt1,TB bt2)
| bt1==bt2
-> this_inst_index
(TA {type_index=ti1} [_],TA {type_index=ti2} [_]) // for array elements
| ti1==ti2
-> this_inst_index
_
-> find_unboxed_list_instance element_type right defs
_
-> find_unboxed_list_instance element_type right defs
find_unboxed_list_instance co_types IT_Empty defs
| unboxed_list_instance_type_matches defs.[glob_module].com_instance_defs.[glob_object].ins_type.it_types element_type
= this_inst_index
= find_unboxed_list_instance element_type right defs
find_unboxed_list_instance element_type IT_Empty defs
= ObjectNotFound
find_unboxed_list_instance element_type (IT_Trees sorted_instances instances) defs
# index = find_sorted_unboxed_list_instance element_type sorted_instances defs
| FoundObject index
= index
= find_unboxed_list_instance element_type instances defs
where
find_sorted_unboxed_list_instance element_type (SI_Node instances left right) defs
# left_index = find_sorted_unboxed_list_instance element_type left defs
| FoundObject left_index
= left_index
# inst_index = find_unboxed_list_instance_in_list element_type instances defs
| FoundObject left_index
= inst_index
= find_sorted_unboxed_list_instance element_type right defs
find_sorted_unboxed_list_instance element_type SI_Empty defs
= ObjectNotFound
find_unboxed_list_instance_in_list element_type [this_inst_index=:{glob_object,glob_module}:instances] defs
| unboxed_list_instance_type_matches defs.[glob_module].com_instance_defs.[glob_object].ins_type.it_types element_type
= this_inst_index
= find_unboxed_list_instance_in_list element_type instances defs
find_unboxed_list_instance_in_list element_type [] defs
= ObjectNotFound
unboxed_list_instance_type_matches [TB bt1] (TB bt2) = bt1==bt2
unboxed_list_instance_type_matches [TA {type_index=ti1} [_]] (TA {type_index=ti2} [_]) = ti1==ti2 // for array elements
unboxed_list_instance_type_matches _ _ = False
look_up_array_or_list_instance :: !TypeSymbIdent ![ArrayInstance] -> Optional ArrayInstance
look_up_array_or_list_instance record []
......@@ -780,7 +854,7 @@ is_predefined_symbol mod_index symb_index predef_index predef_symbols
# {pds_def,pds_module} = predef_symbols.[predef_index]
= mod_index == pds_module && symb_index == pds_def
addLocalTCInstance :: Int (([LocalTypePatternVariable], *VarHeap)) -> (VarInfoPtr, ([LocalTypePatternVariable], *VarHeap))
addLocalTCInstance :: Int ([LocalTypePatternVariable], *VarHeap) -> (VarInfoPtr, ([LocalTypePatternVariable], *VarHeap))
addLocalTCInstance var_number (instances=:[inst : insts], ltp_var_heap)
# cmp = var_number =< inst.ltpv_var
| cmp == Equal
......@@ -922,6 +996,99 @@ consVariableToType (TempQCV temp_var_id)
consVariableToType (TempQCDV temp_var_id)
= TempQDV temp_var_id
compare_instance_root_types :: ![Type] ![Type] !{#CommonDefs} !*TypeHeaps -> (!CompareValue,!*TypeHeaps)
compare_instance_root_types [t1 : ts1] [t2 : ts2] defs type_heaps
# (compare_value, type_heaps) = compare_root_types t1 t2 defs type_heaps
| compare_value==Equal
= compare_instance_root_types ts1 ts2 defs type_heaps
= (compare_value, type_heaps)
compare_instance_root_types [] [] defs type_heaps
= (Equal, type_heaps)
compare_root_types :: !Type !Type !{#CommonDefs} !*TypeHeaps -> (!Int,!*TypeHeaps)
compare_root_types type1=:(TA {type_index=type_index1} cons_args1) type2=:(TA {type_index=type_index2} cons_args2) defs type_heaps
#! {td_rhs,td_args,td_attribute} = defs.[type_index1.glob_module].com_type_defs.[type_index1.glob_object]
| td_rhs=:SynType _
= compare_root_types_syn_type1 td_rhs td_args td_attribute cons_args1 type2 defs type_heaps
#! {td_rhs,td_args} = defs.[type_index2.glob_module].com_type_defs.[type_index2.glob_object]
| td_rhs=:SynType _
= compare_root_types_syn_type2 type1 td_rhs td_args td_attribute cons_args2 defs type_heaps
#! compare_value = compare_root_types_TAs type_index1 cons_args1 type_index2 cons_args2
= (compare_value,type_heaps)
compare_root_types (TA {type_index=type_index1} cons_args1) type2=:(TAS {type_index=type_index2} cons_args2 _) defs type_heaps
#! {td_rhs,td_args,td_attribute} = defs.[type_index1.glob_module].com_type_defs.[type_index1.glob_object]
| td_rhs=:SynType _
= compare_root_types_syn_type1 td_rhs td_args td_attribute cons_args1 type2 defs type_heaps
#! compare_value = compare_root_types_TAs type_index1 cons_args1 type_index2 cons_args2
= (compare_value,type_heaps)
compare_root_types (TA {type_index=type_index1} cons_args1) type2 defs type_heaps
#! {td_rhs,td_args,td_attribute} = defs.[type_index1.glob_module].com_type_defs.[type_index1.glob_object]
| td_rhs=:SynType _
= compare_root_types_syn_type1 td_rhs td_args td_attribute cons_args1 type2 defs type_heaps
= (Smaller,type_heaps)
compare_root_types (TAS {type_index=type_index1} cons_args1 _) (TAS {type_index=type_index2} cons_args2 _) defs type_heaps
#! compare_value = compare_root_types_TAs type_index1 cons_args1 type_index2 cons_args2
= (compare_value,type_heaps)
compare_root_types type1=:(TAS {type_index=type_index1} cons_args1 _) (TA {type_index=type_index2} cons_args2) defs type_heaps
#! {td_rhs,td_args,td_attribute} = defs.[type_index2.glob_module].com_type_defs.[type_index2.glob_object]
| td_rhs=:SynType _
= compare_root_types_syn_type2 type1 td_rhs td_args td_attribute cons_args2 defs type_heaps
#! compare_value = compare_root_types_TAs type_index1 cons_args1 type_index2 cons_args2
= (compare_value,type_heaps)
compare_root_types type1 (TA {type_index=type_index2} cons_args2) defs type_heaps
#! {td_rhs,td_args,td_attribute} = defs.[type_index2.glob_module].com_type_defs.[type_index2.glob_object]
| td_rhs=:SynType _
= compare_root_types_syn_type2 type1 td_rhs td_args td_attribute cons_args2 defs type_heaps
= (Greater,type_heaps)
compare_root_types (TB type1) (TB type2) defs type_heaps
| equal_constructor type1 type2
= (Equal,type_heaps)
| less_constructor type1 type2
= (Smaller,type_heaps)
= (Greater,type_heaps)
compare_root_types type1 type2 defs type_heaps
| equal_constructor type1 type2
= (Equal,type_heaps)
| less_constructor type1 type2
= (Smaller,type_heaps)
= (Greater,type_heaps)
compare_root_types_syn_type1 (SynType {at_type=type1=:TV _}) td_args td_attribute args1 type2 defs type_heaps
# (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args args1 type1 type_heaps
= compare_root_types expanded_type type2 defs type_heaps
compare_root_types_syn_type1 (SynType {at_type=type1=:(CV _ :@: _)}) td_args td_attribute args1 type2 defs type_heaps
# (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args args1 type1 type_heaps
= compare_root_types expanded_type type2 defs type_heaps
compare_root_types_syn_type1 (SynType {at_type=type1}) td_args td_attribute args1 type2 defs type_heaps
= compare_root_types type1 type2 defs type_heaps
compare_root_types_syn_type2 type1 (SynType {at_type=type2=:TV _}) td_args td_attribute args2 defs type_heaps
# (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args args2 type2 type_heaps
= compare_root_types type1 expanded_type defs type_heaps
compare_root_types_syn_type2 type1 (SynType {at_type=type2=:(CV _ :@: _)}) td_args td_attribute args2 defs type_heaps
# (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args args2 type2 type_heaps
= compare_root_types type1 expanded_type defs type_heaps
compare_root_types_syn_type2 type1 (SynType {at_type=type2}) td_args td_attribute args2 defs type_heaps
= compare_root_types type1 type2 defs type_heaps
compare_root_types_TAs :: !(Global Int) ![AType] !(Global Int) ![AType] -> CompareValue
compare_root_types_TAs type_index1 args1 type_index2 args2
| type_index1.glob_module==type_index2.glob_module
| type_index1.glob_object==type_index2.glob_object
# n_args1 = length args1
# n_args2 = length args1
| n_args1==n_args2
= Equal
| n_args1<n_args2
= Smaller
= Greater
| type_index1.glob_object<type_index2.glob_object
= Smaller
= Greater
| type_index1.glob_module<type_index2.glob_module
= Smaller
= Greater
trySpecializedInstances :: [TypeContext] [Special] *TypeHeaps -> (!Global Index,!*TypeHeaps)
trySpecializedInstances type_contexts [] type_heaps
= (ObjectNotFound, type_heaps)
......
......@@ -2576,44 +2576,25 @@ where
update_instances_of_class common_defs mod_index ins_index (error, class_instances, type_var_heap, td_infos)
#!{ins_class_index={gi_module,gi_index},ins_type={it_types},ins_pos} = common_defs.[mod_index].com_instance_defs.[ins_index]
(instances, class_instances) = class_instances![gi_module,gi_index]
(error, instances) = insert it_types ins_index mod_index common_defs error instances
instances = insert ins_index mod_index instances
class_instances = {class_instances & [gi_module,gi_index]=instances}
(error, type_var_heap, td_infos)
= check_types_of_instances ins_pos common_defs gi_module gi_index it_types (error, type_var_heap, td_infos)
= (error, class_instances, type_var_heap, td_infos)
where
insert :: ![Type] !Index !Index !{# CommonDefs } !*ErrorAdmin !*InstanceTree -> (!*ErrorAdmin, !*InstanceTree)
insert ins_types new_ins_index new_ins_module modules error IT_Empty
= (error, IT_Node {glob_object = new_ins_index,glob_module = new_ins_module} IT_Empty IT_Empty)
insert ins_types new_ins_index new_ins_module modules error (IT_Node ins=:{glob_object,glob_module} it_less it_greater)
#! {ins_type={it_types}} = modules.[glob_module].com_instance_defs.[glob_object]
# cmp = ins_types =< it_types
| cmp == Smaller
# (error, it_less) = insert ins_types new_ins_index new_ins_module modules error it_less
= (error, IT_Node ins it_less it_greater)
| cmp == Greater
# (error, it_greater) = insert ins_types new_ins_index new_ins_module modules error it_greater
= (error, IT_Node ins it_less it_greater)
| ins.glob_object==new_ins_index && ins.glob_module==new_ins_module
= (error, IT_Node ins it_less it_greater)
# cmp = check_unboxed_arrays ins_types it_types
| cmp == Smaller
# (error, it_less) = insert ins_types new_ins_index new_ins_module modules error it_less
= (error, IT_Node ins it_less it_greater)
| cmp == Greater
# (error, it_greater) = insert ins_types new_ins_index new_ins_module modules error it_greater
= (error, IT_Node ins it_less it_greater)
= (checkError ins_types " instance is overlapping" error, IT_Node ins it_less it_greater)
where
check_unboxed_arrays [TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=elem_type1}]] [TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=elem_type2}]]
| elem_type1=:(TV _) || elem_type2=:(TV _)
= Equal
# cmp = elem_type1 =< elem_type2
| cmp <> Equal
= cmp
= check_unboxed_arrays [elem_type1] [elem_type2]
check_unboxed_arrays _ _
= Equal
insert :: !Index !Index !*InstanceTree -> *InstanceTree
insert new_ins_index new_ins_module IT_Empty
= IT_Node {glob_object = new_ins_index,glob_module = new_ins_module} IT_Empty IT_Empty
insert new_ins_index new_ins_module (IT_Node ins=:{glob_module,glob_object} it_less it_greater)
| new_ins_module==glob_module
| new_ins_index<glob_object
= IT_Node ins (insert new_ins_index new_ins_module it_less) it_greater
| new_ins_index>glob_object
= IT_Node ins it_less (insert new_ins_index new_ins_module it_greater)
= IT_Node ins it_less it_greater
| new_ins_module<glob_module
= IT_Node ins (insert new_ins_index new_ins_module it_less) it_greater
= IT_Node ins it_less (insert new_ins_index new_ins_module it_greater)
check_types_of_instances ins_pos common_defs class_module class_index types state
# {class_cons_vars} = common_defs.[class_module].com_class_defs.[class_index]
......