Commit 96c1b6b7 authored by John van Groningen's avatar John van Groningen
Browse files

add optimizations for generic bimap,

add bimap instances for standard generic types to compiler
parent 247ba963
......@@ -24,7 +24,30 @@ import compilerSwitches
fg_fun_index :: !Index,
fg_group_index :: !Index,
fg_funs :: ![FunDef],
fg_groups :: ![Group]
fg_groups :: ![Group],
fg_bimap_functions :: !BimapFunctions
}
:: BimapFunctions = {
bimap_id_function :: !FunctionIndexAndIdent,
bimap_fromto_function :: !FunctionIndexAndIdent,
bimap_tofrom_function :: !FunctionIndexAndIdent,
bimap_to_function :: !FunctionIndexAndIdent,
bimap_from_function :: !FunctionIndexAndIdent,
bimap_arrow_function :: !FunctionIndexAndIdent,
bimap_arrow_arg_id_function :: !FunctionIndexAndIdent,
bimap_arrow_res_id_function :: !FunctionIndexAndIdent,
bimap_from_Bimap_function :: !FunctionIndexAndIdent,
bimap_PAIR_function :: !FunctionIndexAndIdent,
bimap_EITHER_function :: !FunctionIndexAndIdent,
bimap_OBJECT_function :: !FunctionIndexAndIdent,
bimap_CONS_function :: !FunctionIndexAndIdent,
bimap_FIELD_function :: !FunctionIndexAndIdent
}
:: FunctionIndexAndIdent = {
fii_index :: !Index,
fii_ident :: Ident
}
:: *GenericState =
......@@ -121,15 +144,15 @@ convertGenerics main_dcl_module_n used_module_numbers modules groups funs td_inf
where
convert_generics :: !*GenericState -> (![IndexRange], !*GenericState)
convert_generics gs
#! (iso_range, gs) = buildGenericRepresentations gs
#! (iso_range, bimap_functions, gs) = buildGenericRepresentations gs
#! (ok, gs) = gs!gs_error.ea_ok
| not ok = ([], gs)
#! gs = buildClasses gs
#! (ok, gs) = gs!gs_error.ea_ok
| not ok = ([], gs)
#! (instance_range, gs) = convertGenericCases gs
#! (instance_range, gs) = convertGenericCases bimap_functions gs
#! (ok, gs) = gs!gs_error.ea_ok
| not ok = ([], gs)
......@@ -183,25 +206,43 @@ where
// generic representation is built for each type argument of
// generic cases of the current module
buildGenericRepresentations :: !*GenericState -> (!IndexRange, !*GenericState)
buildGenericRepresentations :: !*GenericState -> (!IndexRange,!BimapFunctions,!*GenericState)
buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups}
#! (size_funs, gs_funs) = usize gs_funs
#! size_groups = size gs_groups
#! ({com_gencase_defs}, gs_modules) = gs_modules ! [gs_main_module]
#! gs = { gs & gs_modules = gs_modules, gs_funs = gs_funs, gs_groups = gs_groups }
funs_and_groups = {fg_fun_index=size_funs, fg_group_index=size_groups, fg_funs=[], fg_groups=[]}
# undefined_function_and_ident = {fii_index = -1,fii_ident = undef}
bimap_functions = {
bimap_id_function = undefined_function_and_ident,
bimap_fromto_function = undefined_function_and_ident,
bimap_tofrom_function = undefined_function_and_ident,
bimap_to_function = undefined_function_and_ident,
bimap_from_function = undefined_function_and_ident,
bimap_arrow_function = undefined_function_and_ident,
bimap_arrow_arg_id_function = undefined_function_and_ident,
bimap_arrow_res_id_function = undefined_function_and_ident,
bimap_from_Bimap_function = undefined_function_and_ident,
bimap_PAIR_function = undefined_function_and_ident,
bimap_EITHER_function = undefined_function_and_ident,
bimap_OBJECT_function = undefined_function_and_ident,
bimap_CONS_function = undefined_function_and_ident,
bimap_FIELD_function = undefined_function_and_ident
}
funs_and_groups = {fg_fun_index=size_funs, fg_group_index=size_groups, fg_funs=[], fg_groups=[],fg_bimap_functions= bimap_functions}
#! (funs_and_groups, gs)
= foldArraySt on_gencase com_gencase_defs (funs_and_groups, gs)
# {fg_fun_index,fg_funs=new_funs,fg_groups=new_groups} = funs_and_groups
# {fg_fun_index,fg_funs=new_funs,fg_groups=new_groups,fg_bimap_functions} = funs_and_groups
# {gs_funs, gs_groups} = gs
#! gs_funs = arrayPlusRevList gs_funs new_funs
#! gs_groups = arrayPlusRevList gs_groups new_groups
#! range = {ir_from = size_funs, ir_to = fg_fun_index}
= (range, {gs & gs_funs = gs_funs, gs_groups = gs_groups})
= (range, fg_bimap_functions, {gs & gs_funs = gs_funs, gs_groups = gs_groups})
where
on_gencase index
......@@ -218,7 +259,7 @@ where
TransformedBody _
// does not need a generic representation
-> (funs_and_groups, gs)
GeneratedBody
// needs a generic representation
-> case type_def.td_rhs of
......@@ -236,7 +277,7 @@ where
No
#! (gen_type_rep, funs_and_groups, gs)
= buildGenericTypeRep type_def_gi funs_and_groups gs
#! td_info = {td_info & tdi_gen_rep = Yes gen_type_rep}
# {gs_td_infos} = gs
#! gs_td_infos = {gs_td_infos & [glob_module, glob_object] = td_info}
......@@ -246,7 +287,7 @@ where
on_gencase _ _ st = st
:: ConsInfo = {ci_cons_info :: DefinedSymbol, ci_field_infos :: [DefinedSymbol]}
buildGenericTypeRep :: !GlobalIndex /*type def index*/ !FunsAndGroups !*GenericState -> (!GenericTypeRep,!FunsAndGroups,!*GenericState)
buildGenericTypeRep type_index funs_and_groups
gs=:{gs_modules, gs_predefs, gs_main_module, gs_error, gs_td_infos, gs_exprh, gs_varh, gs_genh, gs_avarh, gs_tvarh}
......@@ -293,9 +334,9 @@ buildGenericTypeRep type_index funs_and_groups
//========================================================================================
convertATypeToGenTypeStruct :: !Ident !Position !PredefinedSymbols !AType (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
-> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convertATypeToGenTypeStruct ident pos predefs type st
= convert type st
= convert type st
where
convert {at_type=TA type_symb args, at_attribute} st
= convert_type_app type_symb at_attribute args st
......@@ -303,14 +344,11 @@ where
= convert_type_app type_symb at_attribute args st
convert {at_type=(CV tv) :@: args} st
#! (args, st) = mapSt convert args st
= (GTSAppVar tv args, st)
= (GTSAppVar tv args, st)
convert {at_type=x --> y} st
#! (x, st) = convert x st
#! (y, st) = convert y st
//= (GTSAppCons (KindArrow [KindConst, KindConst]) [x,y], st)
= (GTSArrow x y, st)
= (GTSArrow x y, st)
convert {at_type=TV tv} st
= (GTSVar tv, st)
convert {at_type=TB _} st
......@@ -338,10 +376,58 @@ where
#! (args, st) = mapSt convert args (modules, td_infos, heaps, error)
-> (GTSAppCons kind args, st)
// the structure type of a genric type can often be simplified
convert_bimap_AType_to_GenTypeStruct :: !AType !Position !PredefinedSymbols (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convert_bimap_AType_to_GenTypeStruct type pos predefs st
= convert type st
where
convert {at_type=TA type_symb args, at_attribute} st
= convert_type_app type_symb at_attribute args st
convert {at_type=TAS type_symb args _, at_attribute} st
= convert_type_app type_symb at_attribute args st
convert {at_type=(CV tv) :@: args} st
#! (args, st) = mapSt convert args st
= (GTSAppVar tv args, st)
convert {at_type=x --> y} st
#! (x, st) = convert x st
#! (y, st) = convert y st
= (GTSArrow x y, st)
convert {at_type=TV tv} st
= (GTSVar tv, st)
convert {at_type=TB _} st
= (GTSAppCons KindConst [], st)
convert {at_type=type} (modules, td_infos, heaps, error)
# error = reportError predefined_idents.[PD_GenericBimap] pos ("can not build generic representation for this type", type) error
= (GTSE, (modules, td_infos, heaps, error))
convert_type_app {type_index} attr args (modules, td_infos, heaps, error)
# (type_def, modules) = modules![type_index.glob_module].com_type_defs.[type_index.glob_object]
= case type_def.td_rhs of
SynType atype
# (expanded_type, th) = expandSynonymType type_def attr args heaps.hp_type_heaps
-> convert {at_type = expanded_type, at_attribute = attr}
(modules, td_infos, {heaps & hp_type_heaps = th}, error)
_
#! {pds_module, pds_def} = predefs.[PD_UnboxedArrayType]
| type_index.glob_module == pds_module && type_index.glob_object == pds_def
&& (case args of [{at_type=TB _}] -> True; _ -> False)
-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
# {pds_module, pds_def} = predefs.[PD_TypeBimap]
| type_index.glob_module == pds_module && type_index.glob_object == pds_def
&& case args of [_,_] -> True; _ -> False
#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
#! (args, st) = mapSt convert args (modules, td_infos, heaps, error)
-> (GTSAppBimap kind args, st)
#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
#! (args, st) = mapSt convert args (modules, td_infos, heaps, error)
-> (GTSAppCons kind args, st)
// the structure type of a generic type can often be simplified
// because bimaps for types not containing generic variables are indentity bimaps
simplifyStructOfGenType :: ![TypeVar] !GenTypeStruct !*Heaps -> (!GenTypeStruct, !*Heaps)
simplifyStructOfGenType gvars type heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}
simplify_bimap_GenTypeStruct :: ![TypeVar] !GenTypeStruct !*Heaps -> (!GenTypeStruct, !*Heaps)
simplify_bimap_GenTypeStruct gvars type heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}
#! th_vars = foldSt mark_type_var gvars th_vars
#! (type, th_vars) = simplify type th_vars
#! th_vars = foldSt clear_type_var gvars th_vars
......@@ -352,46 +438,75 @@ where
simplify (GTSAppCons kind=:(KindArrow kinds) args) st
# formal_arity = length kinds
# actual_arity = length args
# (contains_gen_vars, st) = occurs_list args st
# contains_gen_vars = occurs_list args st
| formal_arity == actual_arity && not contains_gen_vars
= (GTSAppConsBimapKindConst, st)
# (args, st) = mapSt simplify args st
= (GTSAppCons kind args, st)
simplify t=:(GTSAppBimap KindConst []) st
= (t, st)
simplify (GTSAppBimap kind=:(KindArrow kinds) args) st
# formal_arity = length kinds
# actual_arity = length args
# contains_gen_vars = occurs_list args st
| formal_arity == actual_arity && not contains_gen_vars
= (GTSAppConsBimapKindConst, st)
| otherwise
# (args, st) = mapSt simplify args st
=(GTSAppCons kind args, st)
= (GTSAppBimap kind args, st)
simplify (GTSArrow x y) st
# (x, st) = simplify x st
# (y, st) = simplify y st
= (GTSArrow x y, st)
# contains_gen_vars = occurs2 x y st
| not contains_gen_vars
= (GTSAppConsBimapKindConst, st)
# (x, st) = simplify x st
# (y, st) = simplify y st
= (GTSArrow x y, st)
simplify (GTSAppVar tv args) st
# (args, st) = mapSt simplify args st
= (GTSAppVar tv args, st)
simplify t=:(GTSVar tv) st
= (t, st)
simplify t st
= abort "invalid generic type structure\n"
simplify (GTSPair x y) st
# (x, st) = simplify x st
# (y, st) = simplify y st
= (GTSPair x y, st)
simplify (GTSEither x y) st
# (x, st) = simplify x st
# (y, st) = simplify y st
= (GTSEither x y, st)
simplify (GTSCons cons_info_ds x) st
# (x, st) = simplify x st
= (GTSCons cons_info_ds x, st)
simplify (GTSField field_info_ds x) st
# (x, st) = simplify x st
= (GTSField field_info_ds x, st)
simplify (GTSObject type_info_ds x) st
# (x, st) = simplify x st
= (GTSObject type_info_ds x, st)
occurs (GTSAppCons _ args) st = occurs_list args st
occurs (GTSAppVar tv args) st = occurs_list [GTSVar tv: args] st
occurs (GTSAppBimap _ args) st = occurs_list args st
occurs (GTSAppVar tv args) st = occurs (GTSVar tv) st || occurs_list args st
occurs (GTSVar tv) st = type_var_occurs tv st
occurs (GTSArrow x y) st = occurs_list [x,y] st
occurs (GTSArrow x y) st = occurs2 x y st
occurs (GTSPair x y) st = occurs2 x y st
occurs (GTSEither x y) st = occurs2 x y st
occurs (GTSCons _ arg) st = occurs arg st
occurs (GTSField _ arg) st = occurs arg st
occurs (GTSObject _ arg) st = occurs arg st
occurs GTSE st = (False, st)
occurs GTSE st = False
occurs_list [] st = (False, st)
occurs2 x y st
= occurs x st || occurs y st
occurs_list [] st
= False
occurs_list [x:xs] st
# (x, st) = occurs x st
# (xs, st) = occurs_list xs st
= (x || xs, st)
= occurs x st || occurs_list xs st
type_var_occurs tv th_vars
# (tv_info, th_vars) = readPtr tv.tv_info_ptr th_vars
= case tv_info of
TVI_Empty = (False, th_vars)
TVI_Used = (True, th_vars)
_ = abort "invalid type var info"
---> ("type var is not empty", tv, tv_info)
= case sreadPtr tv.tv_info_ptr th_vars of
TVI_Empty = False
TVI_Used = True
mark_type_var tv=:{tv_info_ptr} th_vars
# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
......@@ -422,7 +537,7 @@ where
# type = build_sum_type cons_args
# type = SwitchGenericInfo (GTSObject type_info type) type
= (type, st)
build_type
build_type
{td_rhs=RecordType {rt_constructor}, td_ident, td_pos}
type_info [{ci_cons_info, ci_field_infos}]
(modules, td_infos, heaps, error)
......@@ -454,14 +569,14 @@ where
build_prod_type types
= listToBin build_pair build_unit types
where
build_pair x y = GTSAppCons (KindArrow [KindConst, KindConst]) [x, y]
build_pair x y = GTSPair x y
build_unit = GTSAppCons KindConst []
build_sum_type :: [GenTypeStruct] -> GenTypeStruct
build_sum_type types
= listToBin build_either build_void types
where
build_either x y = GTSAppCons (KindArrow [KindConst, KindConst]) [x, y]
build_either x y = GTSEither x y
build_void = abort "sanity check: no alternatives in a type\n"
/*
......@@ -600,8 +715,8 @@ where
, td_conses_expr
// TODO: module_name_expr
]
predefs heaps
predefs heaps
# fun = makeFunction ds_ident ds_index group_index [] body_expr No main_module_index td_pos
= (fun, heaps)
......@@ -786,15 +901,15 @@ buildConversionIso type_def=:{td_ident, td_pos} from_fun to_fun
main_dcl_module_n predefs funs_and_groups heaps error
#! (from_expr, heaps) = buildFunApp main_dcl_module_n from_fun [] heaps
#! (to_expr, heaps) = buildFunApp main_dcl_module_n to_fun [] heaps
#! (iso_expr, heaps) = build_iso to_expr from_expr heaps
#! (iso_expr, heaps) = build_bimap_record to_expr from_expr predefs heaps
#! ident = makeIdent ("iso" +++ td_ident.id_name)
#! (def_sym, funs_and_groups) = buildFunAndGroup ident [] iso_expr No main_dcl_module_n td_pos funs_and_groups
= (def_sym, funs_and_groups, heaps, error)
//---> ("buildConversionIso", td_ident, let (_,_,fs,_) = funs_and_groups in hd fs)
where
build_iso to_expr from_expr heaps
= buildPredefConsApp PD_ConsBimap [to_expr, from_expr] predefs heaps
build_bimap_record to_expr from_expr predefs heaps
= buildPredefConsApp PD_ConsBimap [to_expr, from_expr] predefs heaps
// conversion from type to generic
buildConversionTo ::
......@@ -931,7 +1046,7 @@ buildConversionFrom
| not error.ea_ok
# (def_sym, funs_and_groups)
= (buildFunAndGroup fun_name [] EE No main_module_index td_pos funs_and_groups)
= (def_sym, funs_and_groups, heaps, error)
= (def_sym, funs_and_groups, heaps, error)
//---> ("buildConversionFrom failed", td_ident)
# (def_sym, funs_and_groups)
= (buildFunAndGroup fun_name [arg_var] body_expr No main_module_index td_pos funs_and_groups)
......@@ -993,7 +1108,7 @@ where
#! (left_def_syms, right_def_syms) = splitAt ((length def_symbols) /2) def_symbols
#! (left_expr, left_var, heaps, error)
= build_sum is_record type_def_mod left_def_syms heaps error
#! (right_expr, right_var, heaps, error)
#! (right_expr, right_var, heaps, error)
= build_sum is_record type_def_mod right_def_syms heaps error
#! (case_expr, var, heaps) =
build_case_either left_var left_expr right_var right_expr predefs heaps
......@@ -1014,14 +1129,14 @@ where
build_prod is_record expr [cons_arg_var] heaps
#! (arg_expr, var, heaps) = SwitchGenericInfo
(case is_record of True -> build_case_field cons_arg_var expr predefs heaps; False -> (expr, cons_arg_var, heaps))
(if is_record (build_case_field cons_arg_var expr predefs heaps) (expr, cons_arg_var, heaps))
(expr, cons_arg_var, heaps)
= (arg_expr, var, heaps)
build_prod is_record expr cons_arg_vars heaps
#! (left_vars, right_vars) = splitAt ((length cons_arg_vars) /2) cons_arg_vars
#! (expr, left_var, heaps) = build_prod is_record expr left_vars heaps
#! (expr, right_var, heaps) = build_prod is_record expr right_vars heaps
#! (expr, left_var, heaps) = build_prod is_record expr left_vars heaps
#! (case_expr, var, heaps) = build_case_pair left_var right_var expr predefs heaps
= (case_expr, var, heaps)
......@@ -1109,7 +1224,7 @@ buildClasses gs=:{gs_modules, gs_main_module}
= build_modules 0 ([], [], num_classes, num_members) {gs & gs_modules = gs_modules}
// obtain common definitions again because com_gencase_defs are updated
#! (common_defs, gs_modules) = gs_modules ! [gs_main_module]
#! (common_defs, gs_modules) = gs_modules ! [gs_main_module]
# common_defs =
{ common_defs
& com_class_defs = arrayPlusRevList com_class_defs classes
......@@ -1448,8 +1563,8 @@ where
//****************************************************************************************
// Convert generic cases
//****************************************************************************************
convertGenericCases :: !*GenericState -> (!IndexRange, !*GenericState)
convertGenericCases
convertGenericCases :: !BimapFunctions !*GenericState -> (!IndexRange, !*GenericState)
convertGenericCases bimap_functions
gs=:{gs_main_module, gs_used_modules, gs_predefs, gs_funs, gs_groups, gs_modules, gs_dcl_modules, gs_td_infos,
gs_avarh, gs_tvarh, gs_varh, gs_genh, gs_exprh,
gs_error}
......@@ -1463,14 +1578,14 @@ convertGenericCases
#! (first_fun_index, gs_funs) = usize gs_funs
#! first_group_index = size gs_groups
#! fun_info = {fg_fun_index=first_fun_index, fg_group_index=first_group_index, fg_funs=[], fg_groups=[]}
#! fun_info = {fg_fun_index=first_fun_index, fg_group_index=first_group_index, fg_funs=[], fg_groups=[], fg_bimap_functions=bimap_functions}
#! (main_common_defs, gs_modules) = gs_modules ! [gs_main_module]
#! main_module_instances = main_common_defs.com_instance_defs
#! first_instance_index = size main_module_instances
#! instance_info = (first_instance_index, [])
#! (gs_modules, gs_dcl_modules, (fun_info, instance_info, gs_funs, gs_td_infos, heaps, gs_error))
= convert_modules 0 gs_modules gs_dcl_modules (fun_info, instance_info, gs_funs, gs_td_infos, heaps, gs_error)
......@@ -1560,7 +1675,7 @@ where
#! (dcl_functions, heaps)
= update_dcl_function fun_index gencase fun_type dcl_functions heaps
#! (fun_info, fun_defs, td_infos, modules, heaps, error)
#! (fun_info, fun_defs, td_infos, modules, heaps, error)
= update_icl_function_if_needed
module_index
fun_index gencase fun_type
......@@ -1773,8 +1888,8 @@ where
#! fun_defs = {fun_defs & [fun_index] = fun}
-> (funs_and_groups, fun_defs, td_infos, modules, heaps, error)
GeneratedBody // derived case
#! (TransformedBody {tb_args, tb_rhs}, td_infos, modules, heaps, error)
= buildGenericCaseBody gs_main_module gencase st gs_predefs td_infos modules heaps error
#! (TransformedBody {tb_args, tb_rhs}, funs_and_groups, td_infos, modules, heaps, error)
= buildGenericCaseBody gs_main_module gencase st gs_predefs funs_and_groups td_infos modules heaps error
# {fg_group_index,fg_groups} = funs_and_groups
#! fun = makeFunction fun_ident fun_index fg_group_index tb_args tb_rhs (Yes st) gs_main_module gc_pos
#! fun_defs = {fun_defs & [fun_index] = fun}
......@@ -1841,25 +1956,17 @@ where
fresh_symbol_type st heaps=:{hp_type_heaps}
# (fresh_st, hp_type_heaps) = freshSymbolType st hp_type_heaps
= (fresh_st, {heaps & hp_type_heaps = hp_type_heaps})
buildGenericCaseBody ::
!Index // current icl module
!GenericCaseDef
!SymbolType // type of the instance function
!PredefinedSymbols
!*TypeDefInfos
!*{#CommonDefs}
!*Heaps
!*ErrorAdmin
-> ( !FunctionBody
, !*TypeDefInfos
, !*{#CommonDefs}
, !*Heaps
, !*ErrorAdmin
)
buildGenericCaseBody main_module_index gc=:{gc_ident, gc_pos, gc_generic, gc_type_cons=TypeConsSymb {type_ident,type_index}} st predefs td_infos modules heaps error
// get all the data we need
!FunsAndGroups !*TypeDefInfos !*{#CommonDefs} !*Heaps !*ErrorAdmin
-> (!FunctionBody,
!FunsAndGroups, !*TypeDefInfos,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)
buildGenericCaseBody main_module_index gc=:{gc_ident, gc_pos, gc_generic, gc_type_cons=TypeConsSymb {type_ident,type_index}} st predefs
funs_and_groups td_infos modules heaps error
#! (gen_def, modules)
= modules ! [gc_generic.gi_module].com_generic_defs.[gc_generic.gi_index]
#! (td_info=:{tdi_gen_rep}, td_infos)
......@@ -1881,16 +1988,16 @@ buildGenericCaseBody main_module_index gc=:{gc_ident, gc_pos, gc_generic, gc_typ
# (generic_info_var, heaps) = build_generic_info_arg heaps
#! arg_vars = SwitchGenericInfo [generic_info_var:arg_vars] arg_vars
#! (adaptor_expr, (modules, td_infos, heaps, error))
= build_adaptor_expr gc gen_def gen_type_rep (modules, td_infos, heaps, error)
#! (specialized_expr, (td_infos, heaps, error))
= build_specialized_expr gc gtr_type td_args generated_arg_exprs (td_infos, heaps, error)
#! (adaptor_expr, funs_and_groups, modules, td_infos, heaps, error)
= build_adaptor_expr gc gen_def gen_type_rep funs_and_groups modules td_infos heaps error
#! (specialized_expr, funs_and_groups, td_infos, heaps, error)
= build_specialized_expr gc gtr_type td_args generated_arg_exprs funs_and_groups td_infos heaps error
#! body_expr
= build_body_expr adaptor_expr specialized_expr original_arg_exprs
= (TransformedBody {tb_args=arg_vars, tb_rhs=body_expr}, td_infos, modules, heaps, error)
= (TransformedBody {tb_args=arg_vars, tb_rhs=body_expr}, funs_and_groups, td_infos, modules, heaps, error)
where
build_generic_info_arg heaps=:{hp_var_heap}
......@@ -1912,29 +2019,28 @@ where
// adaptor that converts a function for the generic representation into a
// function for the type itself
build_adaptor_expr {gc_ident, gc_pos} {gen_type, gen_vars, gen_info_ptr} {gtr_iso} (modules, td_infos, heaps, error)
build_adaptor_expr {gc_ident, gc_pos} {gen_type, gen_vars, gen_info_ptr} {gtr_iso} funs_and_groups modules td_infos heaps error
#! (var_kinds, heaps) = get_var_kinds gen_info_ptr heaps
#! non_gen_var_kinds = drop (length gen_vars) var_kinds
#! non_gen_vars = gen_type.st_vars -- gen_vars
#! (gen_env, heaps)
= build_gen_env gtr_iso gen_vars heaps
#! (non_gen_env, heaps)
= build_non_gen_env non_gen_vars non_gen_var_kinds heaps
#! (non_gen_env, funs_and_groups, heaps)
= build_non_gen_env non_gen_vars non_gen_var_kinds funs_and_groups heaps
#! spec_env = gen_env ++ non_gen_env
#! curried_gen_type = curry_symbol_type gen_type
#! (struct_gen_type, (modules, td_infos, heaps, error)) = convertATypeToGenTypeStruct
bimap_ident gc_pos predefs curried_gen_type (modules, td_infos, heaps, error)
#! (struct_gen_type, heaps) = simplifyStructOfGenType gen_vars struct_gen_type heaps
#! (bimap_expr, (td_infos, heaps, error))
= specializeGeneric {gi_module=bimap_module,gi_index=bimap_index} struct_gen_type spec_env bimap_ident gc_pos main_module_index predefs (td_infos, heaps, error)
#! (struct_gen_type, (modules, td_infos, heaps, error))
= convert_bimap_AType_to_GenTypeStruct curried_gen_type gc_pos predefs (modules, td_infos, heaps, error)
#! (struct_gen_type, heaps) = simplify_bimap_GenTypeStruct gen_vars struct_gen_type heaps
#! adaptor_expr
= buildRecordSelectionExpr bimap_expr PD_map_from 1 predefs
= (adaptor_expr, (modules, td_infos, heaps, error))
#! (adaptor_expr, funs_and_groups, heaps, error)
= specialize_generic_from_bimap {gi_module=bimap_module,gi_index=bimap_index} struct_gen_type spec_env bimap_ident gc_pos main_module_index predefs
funs_and_groups heaps error
= (adaptor_expr, funs_and_groups, modules, td_infos, heaps, error)
where
{pds_module = bimap_module, pds_def=bimap_index} = predefs.[PD_GenericBimap]
bimap_ident = predefined_idents.[PD_GenericBimap]
......@@ -1953,39 +2059,49 @@ where
build_iso_expr gen_var heaps
#! (expr, heaps) = buildFunApp main_module_index gtr_iso [] heaps
= ((gen_var, expr), heaps)
build_non_gen_env :: ![TypeVar] ![TypeKind] !*Heaps -> (![(!TypeVar, !Expression)], !*Heaps)
build_non_gen_env non_gen_vars kinds heaps
= zipWithSt build_bimap_expr non_gen_vars kinds heaps
build_non_gen_env :: ![TypeVar] ![TypeKind] FunsAndGroups !*Heaps -> (![(!TypeVar, !Expression)], !FunsAndGroups, !*Heaps)