Commit 2389ad52 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Bug fix: caching combined with omitted type and class definitions

parent a8d7972b
...@@ -2,5 +2,9 @@ definition module analtypes ...@@ -2,5 +2,9 @@ definition module analtypes
import checksupport, typesupport import checksupport, typesupport
analTypeDefs :: !{#CommonDefs} !NumberSet !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) partionateAndExpandTypes :: !NumberSet !Index !*CommonDefs !*{#DclModule} !*TypeHeaps !*ErrorAdmin
-> (!TypeGroups, !*{# CommonDefs}, !*TypeDefInfos, !*CommonDefs, !*{#DclModule}, !*TypeHeaps, !*ErrorAdmin)
:: TypeGroups :== [[GlobalIndex]]
analyseTypeDefs :: !{#CommonDefs} !TypeGroups !*TypeDefInfos !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin)
...@@ -3,6 +3,217 @@ implementation module analtypes ...@@ -3,6 +3,217 @@ implementation module analtypes
import StdEnv import StdEnv
import syntax, checksupport, checktypes, check, typesupport, utilities, analunitypes //, RWSDebug import syntax, checksupport, checktypes, check, typesupport, utilities, analunitypes //, RWSDebug
/*
:: TypeGroup =
{ tg_number :: !Int
, tg_members :: ![GlobalIndex]
}
*/
:: TypeGroups :== [[GlobalIndex]]
:: PartitioningInfo =
{ pi_marks :: !.{# .{# Int}}
, pi_type_defs :: !.{# .{# CheckedTypeDef}}
, pi_type_def_infos :: !.TypeDefInfos
, pi_next_num :: !Int
, pi_next_group_num :: !Int
, pi_groups :: !TypeGroups
, pi_deps :: ![GlobalIndex]
, pi_error :: !.ErrorAdmin
}
cNotPartitionated :== -1
cChecking :== -1
partionateAndExpandTypes :: !NumberSet !Index !*CommonDefs !*{#DclModule} !*TypeHeaps !*ErrorAdmin
-> (!TypeGroups, !*{# CommonDefs}, !*TypeDefInfos, !*CommonDefs, !*{#DclModule}, !*TypeHeaps, !*ErrorAdmin)
partionateAndExpandTypes used_module_numbers main_dcl_module_index icl_common=:{com_type_defs,com_class_defs} dcl_modules type_heaps error
#! nr_of_modules = size dcl_modules
#! nr_of_types_in_icl_mod = size com_type_defs - size com_class_defs
# (dcl_type_defs, dcl_modules, new_type_defs, new_marks, type_def_infos)
= copy_type_defs_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod nr_of_modules (com_type_defs, dcl_modules)
pi = {pi_marks = new_marks, pi_type_defs = new_type_defs, pi_type_def_infos = type_def_infos,
pi_next_num = 0, pi_deps = [], pi_next_group_num = 0, pi_groups = [], pi_error = error }
{pi_error,pi_groups,pi_type_defs,pi_type_def_infos} = iFoldSt partionate_type_defs 0 nr_of_modules pi
| not pi_error.ea_ok
# (icl_type_defs, type_defs) = replace pi_type_defs main_dcl_module_index dcl_type_defs
(dcl_modules, common_defs) = update_modules_and_create_commondefs used_module_numbers type_defs nr_of_modules dcl_modules
= (reverse pi_groups, common_defs, pi_type_def_infos, {icl_common & com_type_defs = icl_type_defs }, dcl_modules, type_heaps, pi_error)
# (type_defs, dcl_type_defs, type_heaps, error)
= foldSt (expand_synonym_types_of_group main_dcl_module_index) pi_groups (pi_type_defs, dcl_type_defs, type_heaps, pi_error)
(icl_type_defs, type_defs) = replace type_defs main_dcl_module_index dcl_type_defs
(dcl_modules, common_defs) = update_modules_and_create_commondefs used_module_numbers type_defs nr_of_modules dcl_modules
= (reverse pi_groups, common_defs, pi_type_def_infos, {icl_common & com_type_defs = icl_type_defs}, dcl_modules, type_heaps, error)
where
copy_type_defs_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod nr_of_modules (icl_type_defs, dcl_modules)
# type_defs = { {} \\ nr_of_types <- [0..nr_of_modules] }
marks = { {} \\ nr_of_types <- [0..nr_of_modules] }
type_def_infos = { {} \\ nr_of_types <- [0..nr_of_modules] }
= iFoldSt (copy_type_def_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod) 0 nr_of_modules
(icl_type_defs, dcl_modules, type_defs, marks, type_def_infos)
where
copy_type_def_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod module_index
(icl_type_defs, dcl_modules, type_defs, marks, type_def_infos)
| inNumberSet module_index used_module_numbers
# ({com_type_defs,com_class_defs}, dcl_modules) = dcl_modules![module_index].dcl_common
| module_index == main_dcl_module_index
= ( { type_def \\ type_def <-: com_type_defs }, dcl_modules, { type_defs & [module_index] = icl_type_defs },
{ marks & [module_index] = createArray nr_of_types_in_icl_mod cNotPartitionated },
{ type_def_infos & [module_index] = createArray nr_of_types_in_icl_mod EmptyTypeDefInfo })
# nr_of_types = size com_type_defs - size com_class_defs
= ( icl_type_defs, dcl_modules, { type_defs & [module_index] = { type_def \\ type_def <-: com_type_defs }},
{ marks & [module_index] = createArray nr_of_types cNotPartitionated },
{ type_def_infos & [module_index] = createArray nr_of_types EmptyTypeDefInfo })
= (icl_type_defs, dcl_modules, type_defs, marks,type_def_infos)
partionate_type_defs mod_index pi=:{pi_marks}
#! nr_of_typedefs_to_be_examined = size pi_marks.[mod_index]
= iFoldSt (partitionate_type_def mod_index) 0 nr_of_typedefs_to_be_examined pi
where
partitionate_type_def module_index type_index pi=:{pi_marks}
# mark = pi_marks.[module_index, type_index]
| mark == cNotPartitionated
# (_, pi) = partitionateTypeDef {gi_module = module_index, gi_index = type_index} pi
= pi
= pi
expand_synonym_types_of_group main_dcl_module_index group_members (type_defs, main_dcl_type_defs, type_heaps, error)
= foldSt (expand_synonym_type main_dcl_module_index) group_members (type_defs, main_dcl_type_defs, type_heaps, error)
where
expand_synonym_type main_dcl_module_index gi=:{gi_module,gi_index} (type_defs, main_dcl_type_defs, type_heaps, error)
# (td=:{td_rhs,td_attribute}, type_defs) = type_defs![gi_module, gi_index]
= case td_rhs of
SynType type
# (opt_type, type_defs, type_heaps, error)
= try_to_expand_synonym_type (newPosition td.td_name td.td_pos) type td_attribute (type_defs, type_heaps, error)
-> case opt_type of
Yes type
# type_defs = { type_defs & [gi_module, gi_index] = { td & td_rhs = SynType type}}
-> try_to_expand_synonym_type_in_main_dcl main_dcl_module_index gi (type_defs, main_dcl_type_defs, type_heaps, error)
No
-> (type_defs, main_dcl_type_defs, type_heaps, error)
_
-> (type_defs, main_dcl_type_defs, type_heaps, error)
try_to_expand_synonym_type pos type=:{at_type = TA {type_name,type_index={glob_object,glob_module}} types} attribute (type_defs, type_heaps, error)
# (used_td=:{td_rhs}, type_defs) = type_defs![glob_module, glob_object]
= case td_rhs of
SynType {at_type}
# (ok, subst_rhs, type_heaps) = substituteType used_td.td_attribute attribute used_td.td_args types at_type type_heaps
| ok
-> (Yes {type & at_type = subst_rhs }, type_defs, type_heaps, error)
# error = popErrorAdmin (typeSynonymError used_td.td_name "kind conflict in argument of type synonym" (pushErrorAdmin pos error))
-> (No, type_defs, type_heaps, error)
_
-> (No, type_defs, type_heaps, error)
try_to_expand_synonym_type pos type attribute (type_defs, type_heaps, error)
= (No, type_defs, type_heaps, error)
try_to_expand_synonym_type_in_main_dcl main_dcl_module_index {gi_module,gi_index} (type_defs, main_dcl_type_defs, type_heaps, error)
| main_dcl_module_index == main_dcl_module_index && gi_index < size main_dcl_type_defs
# (td=:{td_rhs,td_attribute,td_name,td_pos}, main_dcl_type_defs) = main_dcl_type_defs![gi_index]
= case td_rhs of
SynType type
# (opt_type, type_defs, type_heaps, error)
= try_to_expand_synonym_type (newPosition td_name td_pos) type td_attribute (type_defs, type_heaps, error)
-> case opt_type of
Yes type
-> (type_defs, { main_dcl_type_defs & [gi_index] = { td & td_rhs = SynType type}}, type_heaps, error)
No
-> (type_defs, main_dcl_type_defs, type_heaps, error)
_
-> (type_defs, main_dcl_type_defs, type_heaps, error)
= (type_defs, main_dcl_type_defs, type_heaps, error)
update_modules_and_create_commondefs used_module_numbers type_defs nr_of_modules dcl_modules
# (arbitrary_value_for_initializing, dcl_modules) = dcl_modules![0].dcl_common
initial_common_defs = createArray nr_of_modules arbitrary_value_for_initializing
= iFoldSt (copy_commondefs_and_adjust_type_defs used_module_numbers type_defs) 0 nr_of_modules (dcl_modules, initial_common_defs)
where
copy_commondefs_and_adjust_type_defs used_module_numbers type_defs module_index (dcl_modules, common_defs)
| inNumberSet module_index used_module_numbers
# (dcl_module=:{dcl_common}, dcl_modules) = dcl_modules![module_index]
dcl_common = { dcl_common & com_type_defs = type_defs.[module_index]}
= ({ dcl_modules & [module_index] = { dcl_module & dcl_common = dcl_common }}, { common_defs & [module_index] = dcl_common })
= (dcl_modules, common_defs)
// # (dcl_common, dcl_modules) = dcl_modules![module_index].dcl_common
// = (dcl_modules, { common_defs & [module_index] = dcl_common })
// ---> ("update_modules_and_create_commondefs", module_index)
partitionateTypeDef gi=:{gi_module,gi_index} pi=:{pi_type_defs}
# ({td_name,td_pos,td_used_types}, pi) = pi!pi_type_defs.[gi_module].[gi_index]
pi = push_on_dep_stack gi pi
(min_dep, pi) = foldSt visit_type td_used_types (cMAXINT, pi)
= try_to_close_group gi min_dep pi
where
visit_type gi=:{gi_module,gi_index} (min_dep, pi=:{pi_marks})
#! mark = pi_marks.[gi_module].[gi_index]
| mark == cNotPartitionated
# (ldep, pi) = partitionateTypeDef gi pi
= (min min_dep ldep, pi)
= (min min_dep mark, pi)
push_on_dep_stack type_index=:{gi_module,gi_index} pi=:{pi_deps,pi_marks,pi_next_num}
= { pi & pi_deps = [type_index : pi_deps], pi_marks = { pi_marks & [gi_module].[gi_index] = pi_next_num }, pi_next_num = inc pi_next_num }
try_to_close_group this_type=:{gi_module,gi_index} ldep pi=:{pi_deps,pi_marks,pi_next_group_num,pi_groups,pi_type_defs,pi_error,pi_type_def_infos}
#! my_mark = pi_marks.[gi_module].[gi_index]
| (ldep == cMAXINT || ldep == my_mark)
# (pi_deps, group_members) = close_group this_type pi_deps []
(reorganised_group_members, pi_marks, pi_type_defs, pi_error) = check_cyclic_type_defs group_members [] pi_marks pi_type_defs pi_error
pi_type_def_infos = update_type_def_infos pi_next_group_num reorganised_group_members group_members pi_type_def_infos
= (cMAXINT, { pi & pi_marks = pi_marks, pi_deps = pi_deps, pi_next_group_num = inc pi_next_group_num, pi_error = pi_error,
pi_type_defs = pi_type_defs, pi_type_def_infos = pi_type_def_infos,
pi_groups = [reorganised_group_members : pi_groups ]})
// ---> ("try_to_close_group", reorganised_group_members, group_members)
= (min my_mark ldep, pi)
where
close_group first_type [td : tds] group
| first_type == td
= (tds, [td : group])
= close_group first_type tds [td : group]
check_cyclic_type_defs tds group marks type_defs error
= foldSt check_cyclic_type_def tds (group, marks, type_defs, error)
where
check_cyclic_type_def td=:{gi_module,gi_index} (group, marks, typedefs, error)
# (mark, marks) = marks![gi_module,gi_index]
# ({td_name,td_pos,td_used_types,td_rhs}, typedefs) = typedefs![gi_module].[gi_index]
| mark == cChecking
= (group, marks, typedefs, typeSynonymError td_name "cyclic dependency between type synonyms" error)
| mark < cMAXINT
| is_synonym_type td_rhs
# marks = { marks & [gi_module,gi_index] = cChecking }
error = pushErrorAdmin (newPosition td_name td_pos) error
(group, marks, typedefs, error) = check_cyclic_type_defs td_used_types [td : group] marks typedefs error
error = popErrorAdmin error
= (group, { marks & [gi_module,gi_index] = cMAXINT }, typedefs, error)
= ([td : group], { marks & [gi_module,gi_index] = cMAXINT }, typedefs, error)
= (group, marks, typedefs, error)
is_synonym_type (SynType _) = True
is_synonym_type td_rhs = False
update_type_def_infos group_nr group_members tds type_def_infos
# (_, type_def_infos) = foldSt (update_type_def_info group_nr group_members) tds (0, type_def_infos)
= type_def_infos
where
update_type_def_info group_nr group_members {gi_module,gi_index} (index_in_group, type_def_infos)
# (info, type_def_infos) = type_def_infos![gi_module,gi_index]
= (inc index_in_group,
{ type_def_infos & [gi_module,gi_index] = { info & tdi_group_nr = group_nr, tdi_index_in_group = index_in_group, tdi_group = group_members}})
typeSynonymError type_symb msg error
= checkError type_symb msg error
:: UnifyKindsInfo = :: UnifyKindsInfo =
{ uki_kind_heap ::!.KindHeap { uki_kind_heap ::!.KindHeap
, uki_error ::!.ErrorAdmin , uki_error ::!.ErrorAdmin
...@@ -71,40 +282,6 @@ where ...@@ -71,40 +282,6 @@ where
unify_kinds kind1 kind2 uni_info=:{uki_error} unify_kinds kind1 kind2 uni_info=:{uki_error}
= { uni_info & uki_error = kindError kind1 kind2 uki_error } = { uni_info & uki_error = kindError kind1 kind2 uki_error }
/*
unifyKinds :: !KindInfo !KindInfo !*UnifyKindsInfo -> *UnifyKindsInfo
unifyKinds (KI_Indirection kind1) kind2 uni_info=:{uki_kind_heap}
= unifyKinds kind1 kind2 uni_info
unifyKinds kind1 (KI_Indirection kind2) uni_info=:{uki_kind_heap}
= unifyKinds kind1 kind2 uni_info
unifyKinds (KI_Var info_ptr1) kind=:(KI_Var info_ptr2) uni_info=:{uki_kind_heap}
| info_ptr1 == info_ptr2
= uni_info
= { uni_info & uki_kind_heap = writePtr info_ptr1 (KI_Indirection kind) uki_kind_heap }
unifyKinds k1=:(KI_Var info_ptr1) kind uni_info=:{uki_kind_heap,uki_error}
| contains_kind_ptr info_ptr1 uki_kind_heap kind
= { uni_info & uki_error = kindError k1 kind uki_error }
= { uni_info & uki_kind_heap = writePtr info_ptr1 (KI_Indirection kind) uki_kind_heap }
where
contains_kind_ptr info_ptr uki_kind_heap (KI_Arrow kinds)
= any (contains_kind_ptr info_ptr uki_kind_heap) kinds
contains_kind_ptr info_ptr uki_kind_heap (KI_Indirection kind_info)
= contains_kind_ptr info_ptr uki_kind_heap kind_info
contains_kind_ptr info_ptr uki_kind_heap (KI_Var kind_info_ptr)
= info_ptr1 == kind_info_ptr
contains_kind_ptr info_ptr uki_kind_heap (KI_Const)
= False
unifyKinds kind k1=:(KI_Var info_ptr1) uni_info
= unifyKinds k1 kind uni_info
unifyKinds kind1=:(KI_Arrow kinds1) kind2=:(KI_Arrow kinds2) uni_info=:{uki_error}
| length kinds1 == length kinds2
= foldr2 unifyKinds uni_info kinds1 kinds2
= { uni_info & uki_error = kindError kind1 kind2 uki_error }
unifyKinds KI_Const KI_Const uni_info
= uni_info
unifyKinds kind1 kind2 uni_info=:{uki_error}
= { uni_info & uki_error = kindError kind1 kind2 uki_error }
*/
class toKindInfo a :: !a -> KindInfo class toKindInfo a :: !a -> KindInfo
...@@ -128,18 +305,11 @@ where ...@@ -128,18 +305,11 @@ where
{ con_top_var_binds :: ![KindInfoPtr] { con_top_var_binds :: ![KindInfoPtr]
, con_var_binds :: ![VarBind] , con_var_binds :: ![VarBind]
} }
:: AnalState = :: AnalState =
{ as_td_infos :: !.TypeDefInfos { as_td_infos :: !.TypeDefInfos
, as_heaps :: !.TypeHeaps , as_heaps :: !.TypeHeaps
, as_kind_heap :: !.KindHeap , as_kind_heap :: !.KindHeap
, as_check_marks :: !.{# .{# Int}}
, as_next_num :: !Int
, as_deps :: ![Global Index]
// , as_groups :: ![[Global Index]]
, as_next_group_num :: !Int
, as_error :: !.ErrorAdmin , as_error :: !.ErrorAdmin
} }
...@@ -156,7 +326,7 @@ combineCoercionProperties prop1 prop2 :== (prop1 bitor prop2) bitand cIsNonCoerc ...@@ -156,7 +326,7 @@ combineCoercionProperties prop1 prop2 :== (prop1 bitor prop2) bitand cIsNonCoerc
combineHyperstrictness prop1 prop2 :== (prop1 bitand prop2) bitand cIsHyperStrict combineHyperstrictness prop1 prop2 :== (prop1 bitand prop2) bitand cIsHyperStrict
class analTypes type :: !Bool !{#CommonDefs} ![KindInfoPtr] !type !(!Conditions, !*AnalState) class analTypes type :: !Bool !{#CommonDefs} ![KindInfoPtr] !type !(!Conditions, !*AnalState)
-> (!Int, !KindInfo, TypeProperties, !(!Conditions, !*AnalState)) -> (!KindInfo, !TypeProperties, !(!Conditions, !*AnalState))
cDummyBool :== False cDummyBool :== False
...@@ -175,46 +345,37 @@ where ...@@ -175,46 +345,37 @@ where
(kind_info, as_kind_heap) = readPtr kind_info_ptr as_kind_heap (kind_info, as_kind_heap) = readPtr kind_info_ptr as_kind_heap
(kind_info, as_kind_heap) = skipIndirections kind_info as_kind_heap (kind_info, as_kind_heap) = skipIndirections kind_info as_kind_heap
| isEmpty form_tvs | isEmpty form_tvs
= (cMAXINT, kind_info, cIsHyperStrict, (conds, { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap })) = (kind_info, cIsHyperStrict, (conds, { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap }))
= (cMAXINT, kind_info, cIsHyperStrict, ({ conds & con_var_binds = [{vb_var = kind_info_ptr, vb_vars = form_tvs } : con_var_binds] }, = (kind_info, cIsHyperStrict, ({ conds & con_var_binds = [{vb_var = kind_info_ptr, vb_vars = form_tvs } : con_var_binds] },
{ as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap })) { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap }))
instance analTypes Type instance analTypes Type
where where
analTypes has_root_attr modules form_tvs (TV tv) conds_as analTypes has_root_attr modules form_tvs (TV tv) conds_as
= analTypes has_root_attr modules form_tvs tv conds_as = analTypes has_root_attr modules form_tvs tv conds_as
analTypes has_root_attr modules form_tvs type=:(TA {type_index={glob_module,glob_object},type_arity} types) conds_as analTypes has_root_attr modules form_tvs type=:(TA {type_name,type_index={glob_module,glob_object},type_arity} types) (conds, as)
# (ldep, (conds, as)) = anal_type_def modules glob_module glob_object conds_as # form_type_arity = modules.[glob_module].com_type_defs.[glob_object].td_arity
{td_arity} = modules.[glob_module].com_type_defs.[glob_object]
({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object] ({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object]
kind = if (td_arity == type_arity) KI_Const (KI_Arrow [ toKindInfo tk \\ tk <- drop type_arity tdi_kinds ]) kind = if (form_type_arity == type_arity) KI_Const (KI_Arrow [ toKindInfo tk \\ tk <- drop type_arity tdi_kinds ])
| ldep < cMAXINT /* hence we have a recursive type application */ // ---> ("analTypes", toString kind) | tdi_properties bitand cIsAnalysed == 0
# (ldep2, type_props, conds_as) # (type_properties, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as)
= anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as) = (kind, type_properties, conds_as)
= (min ldep ldep2, kind, type_props, conds_as) # (type_properties, conds_as) = anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as)
# (ldep2, type_props, conds_as) = (kind, type_properties, conds_as)
= anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as)
// ---> (types, tdi_kinds)
= (min ldep ldep2, kind, condCombineTypeProperties has_root_attr type_props tdi_properties, conds_as)
where where
anal_types_of_rec_type_cons modules form_tvs [] _ conds_as anal_types_of_rec_type_cons modules form_tvs [] _ conds_as
= (cMAXINT, cIsHyperStrict, conds_as) = (cIsHyperStrict, conds_as)
anal_types_of_rec_type_cons modules form_tvs [type : types] [(KindVar kind_info_ptr) : tvs] conds_as anal_types_of_rec_type_cons modules form_tvs [type : types] [(KindVar kind_info_ptr) : tvs] conds_as
# (ldep, type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules [ kind_info_ptr : form_tvs ] type conds_as # (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules [ kind_info_ptr : form_tvs ] type conds_as
(kind, as_kind_heap) = readPtr kind_info_ptr as_kind_heap (kind, as_kind_heap) = readPtr kind_info_ptr as_kind_heap
{uki_kind_heap, uki_error} = unifyKinds type_kind kind {uki_kind_heap = as_kind_heap, uki_error = as_error} {uki_kind_heap, uki_error} = unifyKinds type_kind kind {uki_kind_heap = as_kind_heap, uki_error = as_error}
| is_type_var type | is_type_var type
# (min_dep, other_type_props, conds_as) = # (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
anal_types_of_rec_type_cons modules form_tvs types tvs (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error }) (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (min ldep min_dep, combineTypeProperties type_props other_type_props, conds_as) = (combineTypeProperties type_props other_type_props, conds_as)
# (min_dep, other_type_props, conds_as) = # (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
anal_types_of_rec_type_cons modules form_tvs types tvs ({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error }) = (combineTypeProperties type_props other_type_props, conds_as)
# (min_dep, other_type_props, conds_as) =
anal_types_of_rec_type_cons modules form_tvs types tvs
({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (min ldep min_dep, combineTypeProperties type_props other_type_props, conds_as)
where where
is_type_var {at_type = TV _} is_type_var {at_type = TV _}
= True = True
...@@ -222,46 +383,39 @@ where ...@@ -222,46 +383,39 @@ where
= False = False
anal_types_of_type_cons modules form_tvs [] _ conds_as anal_types_of_type_cons modules form_tvs [] _ conds_as
= (cMAXINT, cIsHyperStrict, conds_as) = (cIsHyperStrict, conds_as)
anal_types_of_type_cons modules form_tvs [type : types] [tk : tks] conds_as anal_types_of_type_cons modules form_tvs [type : types] [tk : tks] conds_as
# (ldep, type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as # (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
{uki_kind_heap, uki_error} = unifyKinds type_kind (toKindInfo tk) {uki_kind_heap = as_kind_heap, uki_error = as_error} {uki_kind_heap, uki_error} = unifyKinds type_kind (toKindInfo tk) {uki_kind_heap = as_kind_heap, uki_error = as_error}
(min_dep, other_type_props, conds_as) as = { as & as_kind_heap = uki_kind_heap, as_error = uki_error }
= anal_types_of_type_cons modules form_tvs types tks (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error }) (other_type_props, conds_as) = anal_types_of_type_cons modules form_tvs types tks (conds, as)
= (min ldep min_dep, combineTypeProperties type_props other_type_props, conds_as) = (combineTypeProperties type_props other_type_props, conds_as)
anal_types_of_type_cons modules form_tvs types tks conds_as anal_types_of_type_cons modules form_tvs types tks conds_as
= abort ("anal_types_of_type_cons (analtypes.icl)" ---> (types, tks)) = abort ("anal_types_of_type_cons (analtypes.icl)" ---> (types, tks))
anal_type_def modules module_index type_index (conds, as=:{as_check_marks})
#! mark = as_check_marks.[module_index].[type_index]
| mark == AS_NotChecked
# (mark, ({con_var_binds,con_top_var_binds}, as)) = analTypeDef modules module_index type_index as
= (mark, ({con_top_var_binds = con_top_var_binds ++ conds.con_top_var_binds, con_var_binds = con_var_binds ++ conds.con_var_binds}, as))
= (mark, (conds, as))
analTypes has_root_attr modules form_tvs (arg_type --> res_type) conds_as analTypes has_root_attr modules form_tvs (arg_type --> res_type) conds_as
# (arg_ldep, arg_kind, arg_type_props, conds_as) = analTypes has_root_attr modules form_tvs arg_type conds_as # (arg_kind, arg_type_props, conds_as) = analTypes has_root_attr modules form_tvs arg_type conds_as
(res_ldep, res_kind, res_type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs res_type conds_as (res_kind, res_type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs res_type conds_as
{uki_kind_heap, uki_error} = unifyKinds res_kind KI_Const (unifyKinds arg_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error}) {uki_kind_heap, uki_error} = unifyKinds res_kind KI_Const (unifyKinds arg_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error})
type_props = if has_root_attr type_props = if has_root_attr
(combineCoercionProperties arg_type_props res_type_props bitor cIsNonCoercible) (combineCoercionProperties arg_type_props res_type_props bitor cIsNonCoercible)
(combineCoercionProperties arg_type_props res_type_props) (combineCoercionProperties arg_type_props res_type_props)
= (min arg_ldep res_ldep, KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error })) = (KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error }))
analTypes has_root_attr modules form_tvs (CV tv :@: types) conds_as analTypes has_root_attr modules form_tvs (CV tv :@: types) conds_as
# (ldep1, type_kind, cv_props, conds_as) = analTypes has_root_attr modules form_tvs tv conds_as # (type_kind, cv_props, conds_as) = analTypes has_root_attr modules form_tvs tv conds_as
(ldep2, type_kinds, is_non_coercible, (conds, as=:{as_kind_heap,as_error})) = check_type_list modules form_tvs types conds_as (type_kinds, is_non_coercible, (conds, as=:{as_kind_heap,as_error})) = check_type_list modules form_tvs types conds_as
{uki_kind_heap, uki_error} = unifyKinds type_kind (KI_Arrow type_kinds) {uki_kind_heap = as_kind_heap, uki_error = as_error} {uki_kind_heap, uki_error} = unifyKinds type_kind (KI_Arrow type_kinds) {uki_kind_heap = as_kind_heap, uki_error = as_error}
type_props = if (is_non_coercible || has_root_attr) cIsNonCoercible (cv_props bitand cIsNonCoercible) type_props = if (is_non_coercible || has_root_attr) cIsNonCoercible (cv_props bitand cIsNonCoercible)
= (min ldep1 ldep2, KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error })) = (KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error }))
where where
check_type_list modules form_tvs [] conds_as check_type_list modules form_tvs [] conds_as
= (cMAXINT, [], False, conds_as) = ([], False, conds_as)
check_type_list modules form_tvs [type : types] conds_as check_type_list modules form_tvs [type : types] conds_as
# (ldep1, tk, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as # (tk, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
{uki_kind_heap, uki_error} = unifyKinds tk KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error} {uki_kind_heap, uki_error} = unifyKinds tk KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error}
(ldep2, tks, is_non_coercible, conds_as) = check_type_list modules form_tvs types (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error }) (tks, is_non_coercible, conds_as) = check_type_list modules form_tvs types (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (min ldep1 ldep2, [tk : tks], is_non_coercible || (type_props bitand cIsNonCoercible <> 0), conds_as) = ([tk : tks], is_non_coercible || (type_props bitand cIsNonCoercible <> 0), conds_as)
analTypes has_root_attr modules form_tvs (TFA vars type) (conds, as=:{as_heaps,as_kind_heap}) analTypes has_root_attr modules form_tvs (TFA vars type) (conds, as=:{as_heaps,as_kind_heap})
# (th_vars, as_kind_heap) = new_local_kind_variables vars (as_heaps.th_vars, as_kind_heap) # (th_vars, as_kind_heap) = new_local_kind_variables vars (as_heaps.th_vars, as_kind_heap)
= analTypes has_root_attr modules form_tvs type (conds, { as & as_heaps = { as_heaps & th_vars = th_vars}, as_kind_heap = as_kind_heap}) = analTypes has_root_attr modules form_tvs type (conds, { as & as_heaps = { as_heaps & th_vars = th_vars}, as_kind_heap = as_kind_heap})
...@@ -275,25 +429,17 @@ where ...@@ -275,25 +429,17 @@ where
# (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap
= ( type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr)) = ( type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr))
analTypes has_root_attr modules form_tvs type conds_as analTypes has_root_attr modules form_tvs type conds_as
= (cMAXINT, KI_Const, cIsHyperStrict, conds_as) = (KI_Const, cIsHyperStrict, conds_as)
/*
analTypesOfConstructor :: !Index !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !Bool !Index !Level !TypeAttribute !Conditions !*TypeSymbols !*TypeInfo !*CheckState
-> *(!TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState)
*/
analTypesOfConstructor modules cons_defs [{ds_index}:conses] (conds, as=:{as_heaps,as_kind_heap}) analTypesOfConstructor modules cons_defs [{ds_index}:conses] (conds, as=:{as_heaps,as_kind_heap})
# {cons_exi_vars,cons_type} = cons_defs.[ds_index] # {cons_exi_vars,cons_type} = cons_defs.[ds_index ]
(coercible, th_vars, as_kind_heap) = new_local_kind_variables cons_exi_vars (as_heaps.th_vars, as_kind_heap) (coercible, th_vars, as_kind_heap) = new_local_kind_variables cons_exi_vars (as_heaps.th_vars, as_kind_heap)
(cons_ldep, cons_properties, conds_as) = anal_types_of_cons modules cons_type.st_args (cons_properties, conds_as) = anal_types_of_cons modules cons_type.st_args
(conds, { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap }) (conds, { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap })
(conses_ldep, other_properties, conds_as) = analTypesOfConstructor modules cons_defs conses conds_as (other_properties, conds_as) = analTypesOfConstructor modules cons_defs conses conds_as
properties = combineTypeProperties cons_properties other_properties properties = combineTypeProperties cons_properties other_properties
= (min cons_ldep conses_ldep, if coercible properties (properties bitor cIsNonCoercible), conds_as) = (if coercible properties (properties bitor cIsNonCoercible), conds_as)
where where
/*
check_types_of_cons :: ![AType] !Bool !Index !Level ![TypeVar] !TypeAttribute ![AttrInequality] !Conditions !*TypeSymbols !*TypeInfo !*CheckState
-> *(![AType], ![[ATypeVar]], ![AttrInequality], !TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState)
*/
new_local_kind_variables :: [ATypeVar] !(!*TypeVarHeap,!*KindHeap) -> (!Bool,!*TypeVarHeap,!*KindHeap) new_local_kind_variables :: [ATypeVar] !(!*TypeVarHeap,!*KindHeap) -> (!Bool,!*TypeVarHeap,!*KindHeap)
new_local_kind_variables td_args (type_var_heap, as_kind_heap) new_local_kind_variables td_args (type_var_heap, as_kind_heap)
= foldSt new_kind td_args (True, type_var_heap, as_kind_heap) = foldSt new_kind td_args (True, type_var_heap, as_kind_heap)
...@@ -308,15 +454,15 @@ where ...@@ -308,15 +454,15 @@ where
is_not_a_variable attr = True is_not_a_variable attr = True
anal_types_of_cons modules [] conds_as anal_types_of_cons modules [] conds_as
= (cMAXINT, cIsHyperStrict, conds_as) = (cIsHyperStrict, conds_as)
anal_types_of_cons modules [type : types] conds_as anal_types_of_cons modules [type : types] conds_as
# (ldep1, other_type_props, conds_as) = anal_types_of_cons modules types conds_as # (other_type_props, conds_as) = anal_types_of_cons modules types conds_as
(ldep2, type_kind, cv_props, (conds, as=:{as_kind_heap, as_error})) = analTypes cDummyBool modules [] type conds_as (type_kind, cv_props, (conds, as=:{as_kind_heap, as_error})) = analTypes cDummyBool