Commit 6981a426 authored by johnvg@science.ru.nl's avatar johnvg@science.ru.nl
Browse files

mark polymorphic instances of Array, UList and UTSList with SP_GenerateRecordInstances

parent 758e8e4a
......@@ -3391,16 +3391,10 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
++ reverse rev_special_defs
++ gen_funs
)
# cs = { cs & cs_predef_symbols=cs_predef_symbols,cs_error = cs_error}
#! mod_index_of_std_array = cs.cs_predef_symbols.[PD_StdArray].pds_def
# cs & cs_predef_symbols=cs_predef_symbols, cs_error=cs_error
# (com_member_defs, com_instance_defs, dcl_functions, cs)
= case mod_index_of_std_array==mod_index of
False
-> (com_member_defs, com_instance_defs, dcl_functions, cs)
True
-> adjust_instance_types_of_array_functions_in_std_array_dcl mod_index
com_member_defs com_instance_defs dcl_functions cs
= adjust_instance_types_of_std_array_and_std_list_functions mod_index com_member_defs com_instance_defs dcl_functions cs
#! dcl_mod = {dcl_mod & dcl_functions = dcl_functions,
dcl_specials = { ir_from = nr_of_dcl_functions_and_instances,
ir_to = nr_of_dcl_funs_insts_and_specs },
......@@ -3414,22 +3408,32 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
dcl_modules = { dcl_modules & [mod_index] = dcl_mod }
= (dcl_modules, heaps, cs)
where
adjust_instance_types_of_array_functions_in_std_array_dcl array_mod_index class_members class_instances fun_types cs=:{cs_predef_symbols}
#! nr_of_instances = size class_instances
# ({pds_def}, cs_predef_symbols) = cs_predef_symbols![PD_ArrayClass]
(offset_table, class_members, cs_predef_symbols) = arrayFunOffsetToPD_IndexTable class_members cs_predef_symbols
(class_instances, fun_types, cs_predef_symbols)
= iFoldSt (adjust_instance_types_of_array_functions array_mod_index pds_def offset_table) 0 nr_of_instances
(class_instances, fun_types, cs_predef_symbols)
= (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols })
adjust_instance_types_of_std_array_and_std_list_functions mod_index class_members class_instances fun_types cs=:{cs_predef_symbols}
| mod_index == cs_predef_symbols.[PD_StdArray].pds_def
#! nr_of_instances = size class_instances
# ({pds_def}, cs_predef_symbols) = cs_predef_symbols![PD_ArrayClass]
(offset_table, class_members, cs_predef_symbols) = arrayFunOffsetToPD_IndexTable class_members cs_predef_symbols
(class_instances, fun_types, cs_predef_symbols)
= iFoldSt (adjust_instance_types_of_array_functions mod_index pds_def offset_table) 0 nr_of_instances
(class_instances, fun_types, cs_predef_symbols)
= (class_members, class_instances, fun_types, {cs & cs_predef_symbols = cs_predef_symbols})
| mod_index == cs_predef_symbols.[PD_StdStrictLists].pds_def
#! n_of_instances = size class_instances
# (class_instances, cs_predef_symbols)
= iFoldSt (adjust_instances_of__SystemStrictLists_module mod_index) 0 n_of_instances (class_instances, cs_predef_symbols)
= (class_members, class_instances, fun_types, {cs & cs_predef_symbols = cs_predef_symbols})
= (class_members, class_instances, fun_types, cs)
where
adjust_instance_types_of_array_functions :: .Index !Index !{#.Index} !Int !*(!u:{# ClassInstance},!*{# FunType},!v:{#PredefinedSymbol})
-> (!u:{# ClassInstance},!*{# FunType},!v:{#PredefinedSymbol})
adjust_instance_types_of_array_functions :: Index !Index !{#Index} !Int !*(!*{#ClassInstance},!*{#FunType},!v:{#PredefinedSymbol})
-> (!*{#ClassInstance},!*{#FunType},!v:{#PredefinedSymbol})
adjust_instance_types_of_array_functions array_mod_index array_class_index offset_table inst_index (class_instances, fun_types, predef_symbols)
# ({ins_class_index={gi_module,gi_index},ins_type,ins_members}, class_instances) = class_instances![inst_index]
| gi_module == array_mod_index && gi_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols
# fun_types = iFoldSt (make_instance_strict ins_members offset_table) 0 (size ins_members) fun_types
= (class_instances, fun_types, predef_symbols)
| is_polymorphic_unboxed_array_instance_type ins_type.it_types predef_symbols
# class_instances & [inst_index].ins_specials = SP_GenerateRecordInstances
= (class_instances, fun_types, predef_symbols)
= (class_instances, fun_types, predef_symbols)
= (class_instances, fun_types, predef_symbols)
make_instance_strict :: !{#ClassInstanceMember} !{#Index} !Int !*{# FunType} -> *{# FunType}
......@@ -3439,6 +3443,25 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
(Yes symbol_type) = inst_def.ft_type
= {instance_defs & [cim_index] = {inst_def & ft_type = makeElemTypeOfArrayFunctionStrict inst_def.ft_type ins_offset offset_table}}
is_polymorphic_unboxed_array_instance_type [TA {type_index={glob_object,glob_module}} _, TV _ : _] predef_symbols
= glob_module == predef_symbols.[PD_PredefinedModule].pds_def && glob_object == predef_symbols.[PD_UnboxedArrayType].pds_def
is_polymorphic_unboxed_array_instance_type _ _
= False
adjust_instances_of__SystemStrictLists_module :: !Index !Int !*(!*{#ClassInstance},!v:{#PredefinedSymbol})
-> (!*{#ClassInstance},!v:{#PredefinedSymbol})
adjust_instances_of__SystemStrictLists_module strict_lists_mod_index inst_index (class_instances, predef_symbols)
# ({ins_class_index={gi_module,gi_index},ins_type={it_types}}, class_instances) = class_instances![inst_index]
| gi_module==strict_lists_mod_index
&& (gi_index==predef_symbols.[PD_UListClass].pds_def || gi_index==predef_symbols.[PD_UTSListClass].pds_def)
= case it_types of
[TV _]
# class_instances & [inst_index].ins_specials = SP_GenerateRecordInstances
-> (class_instances, predef_symbols)
_
-> (class_instances, predef_symbols)
= (class_instances, predef_symbols)
checkPredefinedDclModule :: !NumberSet ![Int] !(IntKeyHashtable SolvedImports) !Int !Bool !LargeBitvect !Bool
!(Module (CollectedDefinitions ClassInstance)) !Index !*ExplImpInfos !*{#DclModule} !*{#*{#FunDef}} !*Heaps !*CheckState
-> (!(!Int,!Index,![FunType]), !(!*ExplImpInfos,!*{#DclModule},!*{#*{#FunDef}},!*Heaps,!*CheckState))
......
......@@ -1464,6 +1464,8 @@ checkSpecialTypeVars (SP_ParsedSubstitutions env) cs
= (SP_ParsedSubstitutions env, cs)
checkSpecialTypeVars SP_None cs
= (SP_None, cs)
checkSpecialTypeVars SP_GenerateRecordInstances cs
= (SP_GenerateRecordInstances, cs)
checkFunSpecialTypeVars :: !FunSpecials !*CheckState -> (!FunSpecials, !*CheckState)
checkFunSpecialTypeVars (FSP_ParsedSubstitutions env) cs
......@@ -1501,6 +1503,8 @@ checkSpecialTypes mod_index (SP_ParsedSubstitutions envs) type_defs modules heap
= (SP_Substitutions specials, ots.ots_type_defs, ots.ots_modules, heaps, cs)
checkSpecialTypes mod_index SP_None type_defs modules heaps cs
= (SP_None, type_defs, modules, heaps, cs)
checkSpecialTypes mod_index SP_GenerateRecordInstances type_defs modules heaps cs
= (SP_GenerateRecordInstances, type_defs, modules, heaps, cs)
checkFunSpecialTypes :: !Index !FunSpecials !v:{#CheckedTypeDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (!FunSpecials,!x:{#CheckedTypeDef},!w:{#DclModule},!.TypeHeaps,!.CheckState), [u v <= w, v u <= x];
......
......@@ -304,7 +304,8 @@ where
get_specials :: Specials -> [Special]
get_specials (SP_ContextTypes specials) = specials
get_specials SP_None = []
get_specials SP_None = []
get_specials SP_GenerateRecordInstances = []
adjust_type_attributes :: !{#CommonDefs} ![Type] ![Type] !*Coercions !*TypeHeaps -> (Bool, !*Coercions, !*TypeHeaps)
adjust_type_attributes defs act_types form_types coercion_env type_heaps
......@@ -795,6 +796,8 @@ where
= match defs (t1,ts1) (t2,ts2) type_heaps
match defs [] [] type_heaps
= (True, type_heaps)
match defs _ _ type_heaps // in case of a kind error
= (False, type_heaps)
instance match ConsVariable
where
......@@ -1029,7 +1032,7 @@ where
= [(index, new_ptrs ++ ptrs) : dict_types]
= [(new_index, new_ptrs) : dt]
selectFromDictionary dict_mod dict_index member_index defs
selectFromDictionary dict_mod dict_index member_index defs
# (RecordType {rt_fields}) = defs.[dict_mod].com_type_defs.[dict_index].td_rhs
{ fs_ident, fs_index } = rt_fields.[member_index]
= { glob_module = dict_mod, glob_object = { ds_ident = fs_ident, ds_index = fs_index, ds_arity = 1 }}
......@@ -1060,7 +1063,7 @@ where
# index = -1 - cim_index
= (EI_Instance {glob_module=glob_module, glob_object={ds_ident=cim_ident, ds_arity=n_class_exprs, ds_index=index}} class_exprs,
heaps_and_ptrs)
adjust_member_application defs contexts {me_ident,me_offset,me_class={glob_module,glob_object}} (CA_Context tc) class_exprs (heaps=:{hp_type_heaps}, ptrs)
adjust_member_application defs contexts {me_offset,me_class={glob_module,glob_object}} (CA_Context tc) class_exprs (heaps=:{hp_type_heaps}, ptrs)
# (class_context, address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps
# {class_dictionary={ds_index,ds_ident}} = defs.[glob_module].com_class_defs.[glob_object]
selector = selectFromDictionary glob_module ds_index me_offset defs
......
......@@ -342,6 +342,7 @@ cNameLocationDependent :== True
| SP_Substitutions ![SpecialSubstitution]
| SP_ContextTypes ![Special]
| SP_TypeOffset !Int // index in SP_Substitutions for specialized instance
| SP_GenerateRecordInstances // for unboxed arrays and lists
| SP_None
:: FunSpecials
......
......@@ -313,7 +313,7 @@ where
(<<<) file (BasicPatterns type patterns) = file <<< " " <<<patterns
(<<<) file (AlgebraicPatterns type patterns) = file <<< patterns
(<<<) file (DynamicPatterns patterns) = file <<< patterns
(<<<) file (OverloadedListPatterns type decons_expr patterns) = file <<< decons_expr <<< " " <<< patterns
(<<<) file (OverloadedListPatterns type decons_expr patterns) = file <<< ' ' <<< decons_expr <<< ' ' <<< patterns
(<<<) file (NewTypePatterns type patterns) = file <<< patterns
(<<<) file NoPattern = file
......@@ -412,7 +412,7 @@ where
= file <<< "DictionariesFunction " <<< dictionaries <<< expr <<< expr_type
(<<<) file ExprToBeRemoved = file <<< "** ExprToBeRemoved **"
(<<<) file expr = abort ("<<< (Expression)" )
instance <<< LetBind
where
(<<<) file {lb_dst, lb_src}
......@@ -673,6 +673,10 @@ where
= file <<< " = " <<< data
(<<<) file (RecordType record)
= file <<< " = " <<< '{' <<< record <<< '}'
(<<<) file (ExtensibleAlgType data)
= file <<< " = " <<< data <<< " | .."
(<<<) file (AlgConses data _)
= file <<< " | " <<< data
(<<<) file _
= file
......
......@@ -5059,11 +5059,12 @@ where
instance <<< Specials
where
(<<<) file spec = case spec of
SP_None -> file <<< "SP_None"
(SP_ParsedSubstitutions _) -> file <<< "SP_ParsedSubstitutions"
(SP_Substitutions _) -> file <<< "SP_Substitutions"
(SP_ContextTypes l) -> file <<< "(SP_ContextTypes: " <<< l <<< ")"
(SP_TypeOffset _) -> file <<< "SP_TypeOffset"
SP_None -> file <<< "SP_None"
SP_GenerateRecordInstances -> file <<< "SP_GenerateRecordInstances"
instance <<< Special
where
......
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