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
......
This diff is collapsed.
......@@ -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]
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment