Skip to content

GitLab

Commit 5501e944 authored by johnvg@science.ru.nl's avatar johnvg@science.ru.nl
Browse files

implement unboxed arrays and lists of newtypes

parent 44ef1bf1
Hide whitespace changes
Inline Side-by-side
frontend/overloading.icl
View file @ 5501e944
......@@ -223,7 +223,7 @@ where
rc_types = tc_types, rc_red_contexts = appls }, rcs_constraints_contexts = constraints }, rs_state)
# {rs_predef_symbols, rs_error,rs_special_instances, rs_type_heaps} = rs_state
(rcs_class_context, rs_special_instances, (rs_predef_symbols, rs_type_heaps), rs_error)
= check_unboxed_array_or_list_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs
= check_unboxed_array_or_list_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs class_instances
rs_special_instances rs_predef_symbols rs_type_heaps rs_error
rs_state & rs_predef_symbols=rs_predef_symbols, rs_special_instances=rs_special_instances,rs_type_heaps=rs_type_heaps, rs_error=rs_error
= ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, rs_state)
......@@ -453,17 +453,20 @@ where
reduce_TC_contexts defs type_code_class cons_args rtcs_state
= mapSt (\{at_type} -> reduce_tc_context defs type_code_class at_type) cons_args rtcs_state
check_unboxed_array_or_list_type :: Int Int GlobalIndex {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs}
check_unboxed_array_or_list_type :: Int Int GlobalIndex {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} InstanceTree
*SpecialInstances *PredefinedSymbols *TypeHeaps *ErrorAdmin
-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
check_unboxed_array_or_list_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs
check_unboxed_array_or_list_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs class_instances
rs_special_instances rs_predef_symbols rs_type_heaps rs_error
| is_predefined_global_symbol ins_class_index PD_ArrayClass rs_predef_symbols && is_unboxed_array tc_types rs_predef_symbols
= check_unboxed_array_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
= check_unboxed_array_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs class_instances
rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
| is_predefined_global_symbol ins_class_index PD_UListClass rs_predef_symbols
= check_unboxed_list_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
= check_unboxed_list_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs class_instances
rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
| is_predefined_global_symbol ins_class_index PD_UTSListClass rs_predef_symbols
= check_unboxed_tail_strict_list_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
= check_unboxed_tail_strict_list_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs class_instances
rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
where
is_predefined_global_symbol :: !GlobalIndex !Int !PredefinedSymbols -> Bool
is_predefined_global_symbol {gi_module,gi_index} predef_index predef_symbols
......@@ -476,20 +479,28 @@ where
is_unboxed_array _ predef_symbols
= False
check_unboxed_array_type :: Int Int GlobalIndex {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
check_unboxed_array_type :: Int Int GlobalIndex {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} InstanceTree
*SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
check_unboxed_array_type main_dcl_module_n ins_module ins_class_index ins_members types=:[ _, elem_type :_] class_members defs special_instances predef_symbols_type_heaps error
# (unboxable, opt_record, predef_symbols_type_heaps) = try_to_unbox elem_type defs predef_symbols_type_heaps
| unboxable
= case opt_record of
Yes record
# (ins_members, special_instances) = add_record_to_array_instances record class_members special_instances
-> ({ rc_class_index = ins_class_index, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
special_instances, predef_symbols_type_heaps, error)
No
-> ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
special_instances, predef_symbols_type_heaps, error)
= ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
check_unboxed_array_type main_dcl_module_n ins_module ins_class_index ins_members types=:[ _, elem_type :_] class_members defs class_instances
special_instances predef_symbols_type_heaps error
# (unboxed_type, opt_record, predef_symbols_type_heaps) = try_to_unbox elem_type defs predef_symbols_type_heaps
= case opt_record of
Yes record
# (ins_members, special_instances) = add_record_to_array_instances record class_members special_instances
-> ({rc_class_index = ins_class_index, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types},
special_instances, predef_symbols_type_heaps, error)
No
| not unboxed_type=:TE
# (predef_symbols,type_heaps) = predef_symbols_type_heaps
# ({glob_module,glob_object},predef_symbols) = find_unboxed_array_instance unboxed_type class_instances defs predef_symbols
| glob_module <> NotFound
# {ins_members,ins_class_index} = defs.[glob_module].com_instance_defs.[glob_object]
-> ({rc_class_index=ins_class_index, rc_inst_module=glob_module, rc_inst_members=ins_members, rc_types=types, rc_red_contexts=[]},
special_instances, (predef_symbols,type_heaps), error)
-> ({rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types},
special_instances, (predef_symbols,type_heaps), unboxError "Array" elem_type error)
-> ({rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types},
special_instances, predef_symbols_type_heaps, unboxError "Array" elem_type error)
where
add_record_to_array_instances :: !TypeSymbIdent !{#DefinedSymbol} !*SpecialInstances -> (!{#ClassInstanceMember},!*SpecialInstances)
......@@ -503,20 +514,27 @@ where
-> (inst.ai_members, { special_instances & si_next_array_member_index = si_next_array_member_index + size members,
si_array_instances = [ inst : si_array_instances ] })
check_unboxed_list_type :: Int Int GlobalIndex {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
check_unboxed_list_type :: Int Int GlobalIndex {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} InstanceTree
*SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
check_unboxed_list_type main_dcl_module_n ins_module ins_class_index ins_members types=:[elem_type:_] class_members defs special_instances predef_symbols_type_heaps error
# (unboxable, opt_record, predef_symbols_type_heaps) = try_to_unbox elem_type defs predef_symbols_type_heaps
| unboxable
= case opt_record of
Yes record
# (ins_members, special_instances) = add_record_to_list_instances record class_members special_instances
-> ({ rc_class_index = ins_class_index, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
special_instances, predef_symbols_type_heaps, error)
No
-> ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
check_unboxed_list_type main_dcl_module_n ins_module ins_class_index ins_members types=:[elem_type:_] class_members defs class_instances
special_instances predef_symbols_type_heaps error
# (unboxed_type, opt_record, predef_symbols_type_heaps) = try_to_unbox elem_type defs predef_symbols_type_heaps
= case opt_record of
Yes record
# (ins_members, special_instances) = add_record_to_list_instances record class_members special_instances
-> ({rc_class_index = ins_class_index, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types},
special_instances, predef_symbols_type_heaps, error)
No
| not unboxed_type=:TE
# {glob_module,glob_object} = find_unboxed_list_instance unboxed_type class_instances defs
| glob_module <> NotFound
# {ins_members,ins_class_index} = defs.[glob_module].com_instance_defs.[glob_object]
-> ({rc_class_index=ins_class_index, rc_inst_module=glob_module, rc_inst_members=ins_members, rc_types=types, rc_red_contexts=[]},
special_instances, predef_symbols_type_heaps, error)
= ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
-> ({rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types},
special_instances, predef_symbols_type_heaps, unboxError "UList" elem_type error)
-> ({rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types},
special_instances, predef_symbols_type_heaps, unboxError "UList" elem_type error)
where
add_record_to_list_instances :: !TypeSymbIdent !{# DefinedSymbol} !*SpecialInstances -> (!{#ClassInstanceMember},!*SpecialInstances)
......@@ -530,20 +548,27 @@ where
-> (inst.ai_members, { special_instances & si_next_array_member_index = si_next_array_member_index + size members,
si_list_instances = [ inst : si_list_instances ] })
check_unboxed_tail_strict_list_type :: Int Int GlobalIndex {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
check_unboxed_tail_strict_list_type :: Int Int GlobalIndex {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} InstanceTree
*SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
check_unboxed_tail_strict_list_type main_dcl_module_n ins_module ins_class_index ins_members types=:[elem_type:_] class_members defs special_instances predef_symbols_type_heaps error
# (unboxable, opt_record, predef_symbols_type_heaps) = try_to_unbox elem_type defs predef_symbols_type_heaps
| unboxable
= case opt_record of
Yes record
# (ins_members, special_instances) = add_record_to_tail_strict_list_instances record class_members special_instances
-> ({ rc_class_index = ins_class_index, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
special_instances, predef_symbols_type_heaps, error)
No
-> ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
check_unboxed_tail_strict_list_type main_dcl_module_n ins_module ins_class_index ins_members types=:[elem_type:_] class_members defs class_instances
special_instances predef_symbols_type_heaps error
# (unboxed_type, opt_record, predef_symbols_type_heaps) = try_to_unbox elem_type defs predef_symbols_type_heaps
= case opt_record of
Yes record
# (ins_members, special_instances) = add_record_to_tail_strict_list_instances record class_members special_instances
-> ({rc_class_index = ins_class_index, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types},
special_instances, predef_symbols_type_heaps, error)
No
| not unboxed_type=:TE
# {glob_module,glob_object} = find_unboxed_list_instance unboxed_type class_instances defs
| glob_module <> NotFound
# {ins_members,ins_class_index} = defs.[glob_module].com_instance_defs.[glob_object]
-> ({rc_class_index=ins_class_index, rc_inst_module=glob_module, rc_inst_members=ins_members, rc_types=types, rc_red_contexts=[]},
special_instances, predef_symbols_type_heaps, error)
= ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
-> ({rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types},
special_instances, predef_symbols_type_heaps, unboxError "UTSList" elem_type error)
-> ({rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types},
special_instances, predef_symbols_type_heaps, unboxError "UTSList" elem_type error)
where
add_record_to_tail_strict_list_instances :: !TypeSymbIdent !{#DefinedSymbol} !*SpecialInstances -> (!{#ClassInstanceMember},!*SpecialInstances)
......@@ -557,27 +582,74 @@ where
-> (inst.ai_members, { special_instances & si_next_array_member_index = si_next_array_member_index + size members,
si_tail_strict_list_instances = [ inst : si_tail_strict_list_instances ] })
try_to_unbox :: Type !{#CommonDefs} (!*PredefinedSymbols, !*TypeHeaps) -> (!Bool, !Optional TypeSymbIdent, !(!*PredefinedSymbols, !*TypeHeaps))
try_to_unbox (TB _) _ predef_symbols_type_heaps
= (True, No, predef_symbols_type_heaps)
try_to_unbox (TA type_symb=:{type_index={glob_module,glob_object},type_arity} type_args) defs (predef_symbols, type_heaps)
try_to_unbox :: Type !{#CommonDefs} (!*PredefinedSymbols, !*TypeHeaps) -> (!Type, !Optional TypeSymbIdent, !(!*PredefinedSymbols, !*TypeHeaps))
try_to_unbox type=:(TB _) _ predef_symbols_type_heaps
= (type, No, predef_symbols_type_heaps)
try_to_unbox type=:(TA type_symb=:{type_index={glob_module,glob_object},type_arity} type_args) defs (predef_symbols, type_heaps)
# {td_arity,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object]
= case td_rhs of
RecordType _
-> (True, (Yes type_symb), (predef_symbols, type_heaps))
-> (TE, Yes type_symb, (predef_symbols, type_heaps))
AbstractType _
#! unboxable =
is_predefined_symbol glob_module glob_object PD_LazyArrayType predef_symbols ||
is_predefined_symbol glob_module glob_object PD_StrictArrayType predef_symbols ||
is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols
-> (unboxable, No, (predef_symbols, type_heaps))
| is_predefined_symbol glob_module glob_object PD_LazyArrayType predef_symbols ||
is_predefined_symbol glob_module glob_object PD_StrictArrayType predef_symbols ||
is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols
-> (type, No, (predef_symbols, type_heaps))
-> (TE, No, (predef_symbols, type_heaps))
SynType {at_type}
# (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps
-> try_to_unbox expanded_type defs (predef_symbols, type_heaps)
NewType {ds_index}
# {cons_type={st_args=[arg_type:_]}} = defs.[glob_module].com_cons_defs.[ds_index];
# (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)
_
-> (False, No, (predef_symbols, type_heaps))
-> (TE, No, (predef_symbols, type_heaps))
try_to_unbox type _ predef_symbols_type_heaps
= (False, No, predef_symbols_type_heaps)
= (TE, No, predef_symbols_type_heaps)
find_unboxed_array_instance :: Type !InstanceTree {#CommonDefs} *PredefinedSymbols -> *(!Global Int,!*PredefinedSymbols)
find_unboxed_array_instance element_type (IT_Node this_inst_index=:{glob_object,glob_module} left right) defs predef_symbols
# (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
= (ObjectNotFound,predef_symbols)
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
= ObjectNotFound
look_up_array_or_list_instance :: !TypeSymbIdent ![ArrayInstance] -> Optional ArrayInstance
look_up_array_or_list_instance record []
......
Supports Markdown
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