Skip to content

GitLab

C
compiler
Commit 0950b075 authored by johnvg@science.ru.nl's avatar johnvg@science.ru.nl
Browse files
Options

Merge remote-tracking branch 'origin/master' into itask

parents 480e16e5 28dd227f
Hide whitespace changes
Inline Side-by-side
Showing with 573 additions and 694 deletions
frontend/generics1.icl
View file @ 0950b075
......@@ -82,12 +82,6 @@ FIELD_NewType_Mask:==8;
:: PredefinedSymbolsData = !{psd_predefs_a :: !{#PredefinedSymbol}, psd_generic_newtypes::!Int}
:: TypeVarInfo
| TVI_Iso !DefinedSymbol !DefinedSymbol
| TVI_BimapExpr !Bool !Expression !Expression // Expression corresponding to the type var during generic specialization
| TVI_Exprs ![((GlobalIndex,[Int]), Expression)] // List of expressions corresponding to the type var during generic specialization
| TVI_SimpleBimapArgExpr !Expression
:: *GenericState =
{ gs_modules :: !*Modules
, gs_exprh :: !*ExpressionHeap
......@@ -458,8 +452,7 @@ where
(modules, td_infos, {heaps & hp_type_heaps = th}, error)
_
#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
| type_index.glob_module == pds_module
&& type_index.glob_object == pds_def
| type_index.glob_module == pds_module && type_index.glob_object == pds_def
-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
| otherwise
#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
......@@ -493,21 +486,33 @@ where
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
= 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)
_
AbstractType _
#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
| type_index.glob_module == pds_module
&& type_index.glob_object == pds_def
| type_index.glob_module == pds_module && type_index.glob_object == pds_def
-> (BGTSAppCons KindConst [], (modules, td_infos, heaps, error))
| otherwise
#! ({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)
-> (BGTSAppCons kind args, st)
AlgType alts
# n_args = length args
| n_args>0 && type_def.td_arity==n_args
# (can_generate_bimap_to_or_from,modules,heaps)
= can_generate_simple_bimap_to_or_from_for_this_algebraic_type type_def.td_args alts type_index.glob_module modules heaps
| can_generate_bimap_to_or_from
#! (tdi_kinds,td_infos) = td_infos![type_index.glob_module,type_index.glob_object].tdi_kinds
#! (args, st) = mapSt convert args (modules, td_infos, heaps, error)
-> (BGTSAppConsSimpleType {gi_module=type_index.glob_module,gi_index=type_index.glob_object} (KindArrow tdi_kinds) args, st)
-> convert_type_app_to_BGTSAppCons type_index args modules td_infos heaps error
_
-> convert_type_app_to_BGTSAppCons type_index args modules td_infos heaps error
convert_type_app_to_BGTSAppCons type_index args modules td_infos heaps error
#! ({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)
= (BGTSAppCons kind args, st)
convert_generic_function_type_to_BimapGenTypeStruct :: !AType !Position !Ident !PredefinedSymbolsData (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (BimapGenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
......@@ -543,7 +548,6 @@ where
AbstractType _
#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
| glob_module == pds_module && glob_object == pds_def
&& (case args of [{at_type=TB _}] -> True; _ -> False)
-> (BGTSAppCons KindConst [], (modules, td_infos, heaps, error))
AlgType alts
# n_args = length args
......@@ -2684,6 +2688,14 @@ is_gen_cons_without_instances (TA {type_index={glob_module,glob_object}} []) {ps
is_gen_cons_without_instances _ predefs
= False
:: TypeVarInfo
| TVI_Iso !DefinedSymbol !DefinedSymbol
| TVI_BimapExpr !Bool !Expression // Expression corresponding to the type var during generic specialization
| TVI_Exprs ![((GlobalIndex,[Int]), Expression)] // List of expressions corresponding to the type var during generic specialization
| TVI_SimpleBimapArgExpr !Expression
| TVI_BimapArgExprs !Expression !Expression
| TVI_BimapCopiedArgExprs !Bool !Expression !Bool !Expression
buildGenericCaseBody ::
!Index // current icl module
!Position !TypeCons !Ident !Int !GlobalIndex
......@@ -2723,14 +2735,14 @@ buildGenericCaseBody main_module_index gc_pos (TypeConsSymb {type_ident,type_ind
# (gtr_type, heaps) = simplify_bimap_GenTypeStruct [atv_variable \\ {atv_variable} <- td_args] gtr_type st.ss_heaps
# st & ss_heaps = heaps
#! bimap_spec_env = [(atv_variable, TVI_BimapExpr False bimap_a_b_expr bimap_b_a_expr) \\ {atv_variable} <- td_args & [bimap_a_b_expr,bimap_b_a_expr] <- generated_arg_exprss]
#! bimap_spec_env = [(atv_variable, TVI_BimapArgExprs bimap_a_b_expr bimap_b_a_expr) \\ {atv_variable} <- td_args & [bimap_a_b_expr,bimap_b_a_expr] <- generated_arg_exprss]
# {ss_modules=modules,ss_funs_and_groups=funs_and_groups,ss_heaps=heaps,ss_error=error} = st
# heaps = set_tvs bimap_spec_env heaps
# bimap_info = {bi_gen_ident=gc_ident,bi_gen_pos=gc_pos,bi_gen_index=gcf_generic,bi_main_module_index=main_module_index,bi_predefs=predefs}
# (body_expr,funs_and_groups,modules,heaps,error)
= build_bimap td_rhs gtr_type type_index original_arg_exprs bimap_info funs_and_groups modules heaps error
= build_bimap td_rhs gtr_type type_index original_arg_exprs gc_ident gc_pos gcf_generic bimap_spec_env main_module_index predefs
funs_and_groups modules heaps error
# heaps = clear_tvs bimap_spec_env heaps
# st & ss_modules=modules,ss_funs_and_groups=funs_and_groups,ss_heaps=heaps,ss_error=error
......@@ -2775,11 +2787,11 @@ where
#! (generated_arg_exprss, generated_arg_vars, heaps)
= mapY2St buildVarExprs
[[mkDepName dep_name atv_variable \\ dep_name <- dep_names] \\ {atv_variable} <- td_args]
heaps
heaps
#! (original_arg_exprs, original_arg_vars, heaps)
= buildVarExprs
[ "x" +++ toString n \\ n <- [1 .. gen_type.st_arity]]
heaps
= buildVarExprs
[ "x" +++ toString n \\ n <- [1 .. gen_type.st_arity]]
heaps
= (generated_arg_exprss, original_arg_exprs, flatten generated_arg_vars ++ original_arg_vars, heaps)
where
mkDepName (ident, gvars, index) atv
......@@ -2852,14 +2864,14 @@ where
curry_symbol_type {st_args, st_result}
= foldr (\x y -> makeAType (x --> y) TA_Multi) st_result st_args
build_gen_env :: !DefinedSymbol !DefinedSymbol ![TypeVar] !*Heaps -> (![(!TypeVar, !TypeVarInfo)], !*Heaps)
build_gen_env :: !DefinedSymbol !DefinedSymbol ![TypeVar] !*Heaps -> (![(TypeVar, TypeVarInfo)], !*Heaps)
build_gen_env gtr_to gtr_from gen_vars heaps
= mapSt build_iso_expr gen_vars heaps
where
build_iso_expr gen_var heaps
= ((gen_var, TVI_Iso gtr_to gtr_from), heaps)
build_non_gen_env :: ![TypeVar] ![TypeKind] FunsAndGroups !*Heaps -> (![(!TypeVar, !TypeVarInfo)], !FunsAndGroups, !*Heaps)
build_non_gen_env :: ![TypeVar] ![TypeKind] FunsAndGroups !*Heaps -> (![(TypeVar, TypeVarInfo)], !FunsAndGroups, !*Heaps)
build_non_gen_env non_gen_vars kinds funs_and_groups heaps
= zipWithSt2 build_bimap_expr non_gen_vars kinds funs_and_groups heaps
where
......@@ -2867,11 +2879,11 @@ where
build_bimap_expr non_gen_var KindConst funs_and_groups heaps
# (expr, funs_and_groups, heaps)
= bimap_id_expression main_module_index predefs funs_and_groups heaps
= ((non_gen_var, TVI_BimapExpr True expr expr), funs_and_groups, heaps)
= ((non_gen_var, TVI_BimapExpr True expr), funs_and_groups, heaps)
build_bimap_expr non_gen_var kind funs_and_groups heaps
#! (expr, heaps)
= buildGenericApp bimap_module bimap_index bimap_ident kind [] heaps
= ((non_gen_var, TVI_BimapExpr False expr expr), funs_and_groups, heaps)
= buildGenericApp bimap_module bimap_index bimap_ident kind [] heaps
= ((non_gen_var, TVI_BimapExpr False expr), funs_and_groups, heaps)
buildGenericCaseBody main_module_index gc_pos gc_type_cons gc_ident generic_info_index gcf_generic predefs st
# error = reportError gc_ident.id_name gc_pos "cannot specialize to this type" st.ss_error
= (TransformedBody {tb_args=[], tb_rhs=EE}, {st & ss_error=error})
......@@ -2888,7 +2900,7 @@ build_simple_bimap td_args (AlgType alts) type_index generated_arg_exprss [origi
th_vars = set_arg_exprs td_args generated_arg_exprss hp_type_heaps.th_vars
heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}
(alg_patterns,modules,heaps) = build_bimap_alg_patterns alts type_index.glob_module modules heaps
(case_expr,heaps) = build_bimap_alg_case {gi_module=type_index.glob_module,gi_index=type_index.glob_object} original_arg_expr alg_patterns heaps
(case_expr,heaps) = build_bimap_alg_case {gi_module=type_index.glob_module,gi_index=type_index.glob_object} original_arg_expr alg_patterns False heaps
{hp_type_heaps} = heaps
th_vars = remove_type_argument_numbers td_args hp_type_heaps.th_vars
heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}
......@@ -2933,62 +2945,85 @@ where
bi_gen_ident :: !Ident,
bi_gen_pos :: !Position,
bi_gen_index :: !GlobalIndex,
bi_bimap_exprs :: ![(TypeVar,TypeVarInfo)],
bi_main_module_index :: !Index,
bi_predefs :: !PredefinedSymbolsData
}
build_bimap :: TypeRhs BimapGenTypeStruct (Global Index) [Expression] !BimapInfo !FunsAndGroups !*Modules !*Heaps !*ErrorAdmin
-> (!Expression,!FunsAndGroups,!*Modules,!*Heaps,!*ErrorAdmin)
build_bimap (AlgType alts) (BGTSAlgebraic algebraic_gen_type) type_index [original_arg_expr] bimap_info funs_and_groups modules heaps error
# (alg_patterns,funs_and_groups,modules,heaps,error)
= build_bimap_alg_patterns alts algebraic_gen_type type_index.glob_module bimap_info funs_and_groups modules heaps error
(case_expr,heaps) = build_bimap_alg_case {gi_module=type_index.glob_module,gi_index=type_index.glob_object} original_arg_expr alg_patterns heaps
= (case_expr,funs_and_groups,modules,heaps,error)
:: *BimapState = {
bs_funs_and_groups :: !FunsAndGroups,
bs_modules :: !*Modules,
bs_heaps :: !*Heaps,
bs_error :: !*ErrorAdmin
}
build_bimap :: TypeRhs BimapGenTypeStruct (Global Index) [Expression] !Ident !Position !GlobalIndex ![(TypeVar,TypeVarInfo)] !Index !PredefinedSymbolsData
!FunsAndGroups !*Modules !*Heaps !*ErrorAdmin
-> (!Expression,!FunsAndGroups,!*Modules,!*Heaps,!*ErrorAdmin)
build_bimap td_rhs gtr_type type_index original_arg_exprs gc_ident gc_pos gcf_generic bimap_spec_env main_module_index predefs
funs_and_groups modules heaps error
# bi = {bi_gen_ident=gc_ident,bi_gen_pos=gc_pos,bi_gen_index=gcf_generic,bi_bimap_exprs=bimap_spec_env,bi_main_module_index=main_module_index,bi_predefs=predefs}
bs = {bs_funs_and_groups=funs_and_groups,bs_modules=modules,bs_heaps=heaps,bs_error=error}
(case_expr,bs) = build_bimap td_rhs gtr_type type_index original_arg_exprs bi bs
= (case_expr,bs.bs_funs_and_groups,bs.bs_modules,bs.bs_heaps,bs.bs_error)
where
build_bimap_alg_patterns :: [DefinedSymbol] [[BimapGenTypeStruct]] Int !BimapInfo !FunsAndGroups !*Modules *Heaps !*ErrorAdmin
-> (![AlgebraicPattern],!FunsAndGroups,!*Modules,!*Heaps,!*ErrorAdmin)
build_bimap_alg_patterns [cons_ds:alts] [constuctor_gen_type:constuctor_gen_types] type_module_n bimap_info funs_and_groups modules heaps error
# (vars,args,funs_and_groups,modules,heaps,error) = build_bimap_for_constructor cons_ds constuctor_gen_type type_module_n bimap_info funs_and_groups modules heaps error
(alg_pattern,heaps) = build_alg_pattern cons_ds vars args type_module_n heaps
(alg_patterns,funs_and_groups,modules,heaps,error) = build_bimap_alg_patterns alts constuctor_gen_types type_module_n bimap_info funs_and_groups modules heaps error
= ([alg_pattern:alg_patterns],funs_and_groups,modules,heaps,error)
build_bimap_alg_patterns [] [] type_module_n bimap_info funs_and_groups modules heaps error
= ([],funs_and_groups,modules,heaps,error)
build_bimap (RecordType {rt_constructor}) (BGTSRecord record_gen_type) type_index [original_arg_expr] bimap_info funs_and_groups modules heaps error
# (vars,args,funs_and_groups,modules,heaps,error)
= build_bimap_for_constructor rt_constructor record_gen_type type_index.glob_module bimap_info funs_and_groups modules heaps error
(alg_pattern,heaps) = build_alg_pattern rt_constructor vars args type_index.glob_module heaps
(case_expr,heaps) = build_bimap_alg_case {gi_module=type_index.glob_module,gi_index=type_index.glob_object} original_arg_expr [alg_pattern] heaps
= (case_expr,funs_and_groups,modules,heaps,error)
build_bimap (NewType newtype_constructor) newtype_gen_type type_index [original_arg_expr] bimap_info funs_and_groups modules heaps error
# (vars,args,funs_and_groups,modules,heaps,error)
= build_bimap_for_constructor newtype_constructor [newtype_gen_type] type_index.glob_module bimap_info funs_and_groups modules heaps error
(alg_pattern,heaps) = build_newtype_pattern newtype_constructor vars args type_index.glob_module heaps
(case_expr,heaps) = build_bimap_newtype_case {gi_module=type_index.glob_module,gi_index=type_index.glob_object} original_arg_expr [alg_pattern] heaps
= (case_expr,funs_and_groups,modules,heaps,error)
build_bimap_for_constructor :: DefinedSymbol [BimapGenTypeStruct] Int !BimapInfo !FunsAndGroups !*Modules *Heaps !*ErrorAdmin
-> (![FreeVar],![Expression],!FunsAndGroups,!*Modules,!*Heaps,!*ErrorAdmin)
build_bimap_for_constructor cons_ds=:{ds_arity} constuctor_gen_type type_module_n bimap_info funs_and_groups modules heaps error
build_bimap :: TypeRhs BimapGenTypeStruct (Global Index) [Expression] !BimapInfo !BimapState -> (!Expression,BimapState)
build_bimap (AlgType alts) (BGTSAlgebraic algebraic_gen_type) type_index [original_arg_expr] bi bs
# (alg_patterns,bs) = build_bimap_alg_patterns alts algebraic_gen_type type_index.glob_module bi bs
(case_expr,heaps) = build_bimap_alg_case {gi_module=type_index.glob_module,gi_index=type_index.glob_object} original_arg_expr alg_patterns False bs.bs_heaps
bs & bs_heaps=heaps
= (case_expr,bs)
where
build_bimap_alg_patterns :: [DefinedSymbol] [[BimapGenTypeStruct]] Int !BimapInfo !BimapState -> (![AlgebraicPattern],!BimapState)
build_bimap_alg_patterns [cons_ds:alts] [constuctor_gen_type:constuctor_gen_types] type_module_n bi bs
# (vars,args,bs) = build_bimap_for_constructor cons_ds constuctor_gen_type type_module_n bi bs
(alg_pattern,heaps) = build_alg_pattern cons_ds vars args type_module_n bs.bs_heaps
bs & bs_heaps=heaps
(alg_patterns,bs) = build_bimap_alg_patterns alts constuctor_gen_types type_module_n bi bs
= ([alg_pattern:alg_patterns],bs)
build_bimap_alg_patterns [] [] type_module_n bi bs
= ([],bs)
build_bimap (RecordType {rt_constructor}) (BGTSRecord record_gen_type) type_index [original_arg_expr] bi bs
# (vars,args,bs) = build_bimap_for_constructor rt_constructor record_gen_type type_index.glob_module bi bs
(alg_pattern,heaps) = build_alg_pattern rt_constructor vars args type_index.glob_module bs.bs_heaps
(case_expr,heaps) = build_bimap_alg_case {gi_module=type_index.glob_module,gi_index=type_index.glob_object} original_arg_expr [alg_pattern] False heaps
bs & bs_heaps=heaps
= (case_expr,bs)
build_bimap (NewType newtype_constructor) newtype_gen_type type_index [original_arg_expr] bi bs
# (vars,args,bs) = build_bimap_for_constructor newtype_constructor [newtype_gen_type] type_index.glob_module bi bs
(alg_pattern,heaps) = build_newtype_pattern newtype_constructor vars args type_index.glob_module bs.bs_heaps
(case_expr,heaps) = build_bimap_newtype_case {gi_module=type_index.glob_module,gi_index=type_index.glob_object} original_arg_expr [alg_pattern] heaps
bs & bs_heaps=heaps
= (case_expr,bs)
build_bimap_for_constructor :: DefinedSymbol [BimapGenTypeStruct] Int !BimapInfo !BimapState
-> (![FreeVar],![Expression],!BimapState)
build_bimap_for_constructor cons_ds=:{ds_arity} constuctor_gen_type type_module_n bi bs
# arg_names = ["x" +++ toString k \\ k <- [1..ds_arity]]
(var_exprs, vars, heaps) = buildVarExprs arg_names heaps
(args,funs_and_groups,heaps,error) = bimaps_with_arg constuctor_gen_type var_exprs bimap_info funs_and_groups heaps error
= (vars,args,funs_and_groups,modules,heaps,error)
where
bimaps_with_arg :: [BimapGenTypeStruct] [Expression] !BimapInfo !FunsAndGroups !*Heaps !*ErrorAdmin -> (![Expression],!FunsAndGroups,!*Heaps,!*ErrorAdmin)
bimaps_with_arg [gen_type_arg:gen_type_args] [var_expr:var_exprs] bimap_info=:bi funs_and_groups heaps error
# (args,funs_and_groups,heaps,error) = bimaps_with_arg gen_type_args var_exprs bimap_info funs_and_groups heaps error
| is_bimap_id gen_type_arg heaps
= ([var_expr:args],funs_and_groups,heaps,error)
# (bimap_expr,funs_and_groups,heaps,error)
= specialize_generic_bimap_expr bi.bi_gen_index gen_type_arg bi.bi_gen_ident bi.bi_gen_pos bi.bi_main_module_index bi.bi_predefs funs_and_groups heaps error
= case bimap_expr of
App app=:{app_args}
-> ([App {app & app_args=app_args++[var_expr]}:args],funs_and_groups,heaps,error)
bimap_expr
-> ([bimap_expr @ [var_expr]:args],funs_and_groups,heaps,error)
bimaps_with_arg [] [] bimap_info funs_and_groups heaps error
= ([],funs_and_groups,heaps,error)
(var_exprs, vars, heaps) = buildVarExprs arg_names bs.bs_heaps
bs & bs_heaps=heaps
(args,bs) = bimap_to_with_args constuctor_gen_type var_exprs bi bs
= (vars,args,bs)
bimap_to_with_args :: [BimapGenTypeStruct] [Expression] !BimapInfo !BimapState -> (![Expression],BimapState)
bimap_to_with_args [gen_type_arg:gen_type_args] [arg:args] bi bs
# (args,bs) = bimap_to_with_args gen_type_args args bi bs
| is_bimap_id gen_type_arg bs.bs_heaps
= ([arg:args],bs)
# (bimap_expr,bs) = bimap_to_with_arg gen_type_arg arg bi bs
= ([bimap_expr:args],bs)
bimap_to_with_args [] [] bi bs
= ([],bs)
bimap_from_with_args :: [BimapGenTypeStruct] [Expression] !BimapInfo !BimapState -> (![Expression],BimapState)
bimap_from_with_args [gen_type_arg:gen_type_args] [arg:args] bi bs=:{bs_heaps}
# (args,bs) = bimap_from_with_args gen_type_args args bi bs
| is_bimap_id gen_type_arg bs_heaps
= ([arg:args],bs)
# (arg,bs) = bimap_from_with_arg gen_type_arg arg bi bs
= ([arg:args],bs)
bimap_from_with_args [] [] bi bs
= ([],bs)
// convert generic type contexts into normal type contexts
......@@ -3655,156 +3690,6 @@ add_FIELD_info_args generic_info field_def record_info_ds arg_exprs main_module_
# (arg_exprs,heaps) = add_FIELD_info_args generic_info field_def record_info_ds arg_exprs main_module_index heaps
= ([record_info_expr : arg_exprs],heaps)
specialize_generic_bimap ::
!GlobalIndex // generic index
!BimapGenTypeStruct // type to specialize to
![(TypeVar, TypeVarInfo)] // specialization environment
!Ident // generic/generic case
!Position // of generic case
!Index // main_module index
!PredefinedSymbolsData
!FunsAndGroups !*Heaps !*ErrorAdmin
-> (!Expression,
!FunsAndGroups,!*Heaps,!*ErrorAdmin)
specialize_generic_bimap gen_index type spec_env gen_ident gen_pos main_module_index predefs funs_and_groups heaps error
#! heaps = set_tvs spec_env heaps
#! (expr, funs_and_groups, heaps, error)
= specialize_generic_bimap_expr gen_index type gen_ident gen_pos main_module_index predefs funs_and_groups heaps error
#! heaps = clear_tvs spec_env heaps
= (expr, funs_and_groups, heaps, error)
specialize_generic_bimap_expr ::
!GlobalIndex // generic index
!BimapGenTypeStruct // type to specialize to
!Ident // generic/generic case
!Position // of generic case
!Index // main_module index
!PredefinedSymbolsData
!FunsAndGroups !*Heaps !*ErrorAdmin
-> (!Expression,
!FunsAndGroups,!*Heaps,!*ErrorAdmin)
specialize_generic_bimap_expr gen_index type gen_ident gen_pos main_module_index predefs funs_and_groups heaps error
#! (expr, (funs_and_groups, heaps, error))
= specialize_f type (funs_and_groups, heaps, error)
= (expr, funs_and_groups, heaps, error)
where
specialize_f (BGTSAppCons KindConst []) (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f (BGTSAppCons kind arg_types) st
#! (arg_exprs, st) = specialize_f_args arg_types st
= build_generic_app kind arg_exprs gen_index gen_ident st
specialize_f (BGTSAppVar tv arg_types) st
#! (arg_exprs, st) = specialize_f_args arg_types st
#! (expr, st) = specialize_f_type_var tv st
= (expr @ arg_exprs, st)
specialize_f (BGTSVar tv) st
= specialize_f_type_var tv st
specialize_f (BGTSArrow x y) st=:(_,heaps,_)
| is_bimap_id x heaps
#! (y, st) = specialize_f y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_from_expression [y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
| is_bimap_id y heaps
#! (x, st) = specialize_b x st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_to_expression [x] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
#! (x, st) = specialize_b x st
#! (y, st) = specialize_f y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_tofrom_expression [x,y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_f BGTSAppConsBimapKindConst (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps
= (expr ,(funs_and_groups, heaps, error))
specialize_f type (funs_and_groups, heaps, error)
#! error = reportError gen_ident.id_name gen_pos "cannot specialize " error
= (EE, (funs_and_groups, heaps, error))
specialize_f_args [arg_type:arg_types] st
# (f_arg_expr,st) = specialize_f arg_type st
(b_arg_expr,st) = specialize_b arg_type st
(arg_exprs,st) = specialize_f_args arg_types st
= ([f_arg_expr,b_arg_expr:arg_exprs],st)
specialize_f_args [] st
= ([],st)
specialize_b (BGTSAppCons KindConst []) (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_b (BGTSAppCons kind arg_types) st
#! (arg_exprs, st) = specialize_b_args arg_types st
= build_generic_app kind arg_exprs gen_index gen_ident st
specialize_b (BGTSAppVar tv arg_types) st
#! (arg_exprs, st) = specialize_b_args arg_types st
#! (expr, st) = specialize_b_type_var tv st
= (expr @ arg_exprs, st)
specialize_b (BGTSVar tv) st
= specialize_b_type_var tv st
specialize_b (BGTSArrow x y) st=:(_,heaps,_)
| is_bimap_id x heaps
#! (y, st) = specialize_b y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_from_expression [y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
| is_bimap_id y heaps
#! (x, st) = specialize_f x st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_to_expression [x] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
#! (x, st) = specialize_f x st
#! (y, st) = specialize_b y st
# (funs_and_groups, heaps, error) = st
(expr, funs_and_groups, heaps)
= bimap_tofrom_expression [x,y] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
specialize_b BGTSAppConsBimapKindConst (funs_and_groups, heaps, error)
# (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps
= (expr ,(funs_and_groups, heaps, error))
specialize_b type (funs_and_groups, heaps, error)
#! error = reportError gen_ident.id_name gen_pos "cannot specialize " error
= (EE, (funs_and_groups, heaps, error))
specialize_b_args [arg_type:arg_types] st
# (b_arg_expr,st) = specialize_b arg_type st
(f_arg_expr,st) = specialize_f arg_type st
(arg_exprs,st) = specialize_b_args arg_types st
= ([b_arg_expr,f_arg_expr:arg_exprs],st)
specialize_b_args [] st
= ([],st)
specialize_f_type_var tv=:{tv_info_ptr} (funs_and_groups, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
# (expr, th_vars) = readPtr tv_info_ptr th_vars
# heaps = {heaps & hp_type_heaps = {th & th_vars = th_vars}}
= case expr of
TVI_BimapExpr _ expr _
-> (expr, (funs_and_groups, heaps, error))
TVI_Iso to_ds _
# (expr,heaps) = buildFunApp main_module_index to_ds [] heaps
-> (expr, (funs_and_groups, heaps, error))
specialize_b_type_var tv=:{tv_info_ptr} (funs_and_groups, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
# (expr, th_vars) = readPtr tv_info_ptr th_vars
# heaps = {heaps & hp_type_heaps = {th & th_vars = th_vars}}
= case expr of
TVI_BimapExpr _ _ expr
-> (expr, (funs_and_groups, heaps, error))
TVI_Iso _ from_ds
# (expr,heaps) = buildFunApp main_module_index from_ds [] heaps
-> (expr, (funs_and_groups, heaps, error))
build_generic_app kind arg_exprs gen_index gen_ident (funs_and_groups, heaps, error)
#! (expr, heaps)
= buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs heaps
= (expr, (funs_and_groups, heaps, error))
adapt_with_specialized_generic_bimap ::
!GlobalIndex // generic index
!BimapGenTypeStruct // type to specialize to
......@@ -3821,12 +3706,13 @@ adapt_with_specialized_generic_bimap ::
adapt_with_specialized_generic_bimap gen_index type spec_env gen_ident gen_pos arg_exprs specialized_expr main_module_index predefs
funs_and_groups modules heaps error
#! heaps = set_tvs spec_env heaps
#! (adapted_arg_exprs, arg_exprs, type, st)
= adapt_args arg_exprs type (funs_and_groups, modules, heaps, error)
#! (body_expr, (funs_and_groups, modules, heaps, error))
= adapt_result arg_exprs type specialized_expr adapted_arg_exprs st
# heaps = clear_tvs spec_env heaps
= (body_expr, funs_and_groups, modules, heaps, error)
# bs = {bs_funs_and_groups=funs_and_groups,bs_modules=modules,bs_heaps=heaps,bs_error=error}
#! (adapted_arg_exprs, arg_exprs, type, bs)
= adapt_args arg_exprs type bs
#! (body_expr, bs)
= adapt_result arg_exprs type specialized_expr adapted_arg_exprs bs
# heaps = clear_tvs spec_env bs.bs_heaps
= (body_expr, bs.bs_funs_and_groups, bs.bs_modules, heaps, bs.bs_error)
where
adapt_args [arg_expr:arg_exprs] (BGTSArrow arg_type args_type) st
# (adapted_arg_expr,st)
......@@ -3837,14 +3723,15 @@ where
adapt_args arg_exprs args_type st
= ([],arg_exprs,args_type,st)
adapt_arg arg_type arg_expr st=:(_,_,heaps,_)
| is_bimap_id arg_type heaps
= (arg_expr,st)
= specialize_to_with_arg arg_type arg_expr st
adapt_arg arg_type arg_expr bs=:{bs_heaps}
| is_bimap_id arg_type bs_heaps
= (arg_expr,bs)
# bi = {bi_gen_ident=gen_ident,bi_gen_pos=gen_pos,bi_gen_index=gen_index,bi_bimap_exprs=[],bi_main_module_index=main_module_index,bi_predefs=predefs}
= bimap_to_with_arg arg_type arg_expr bi bs
adapt_result arg_exprs type specialized_expr adapted_arg_exprs st=:(_,_,heaps,_)
| is_bimap_id type heaps
= (build_body_expr specialized_expr adapted_arg_exprs arg_exprs,st)
adapt_result arg_exprs type specialized_expr adapted_arg_exprs bs=:{bs_heaps}
| is_bimap_id type bs_heaps
= (build_body_expr specialized_expr adapted_arg_exprs arg_exprs,bs)
with
build_body_expr specialized_expr [] []
= specialized_expr
......@@ -3859,461 +3746,402 @@ where
= case adapted_arg_exprs of
[] -> specialized_expr
_ -> specialized_expr @ adapted_arg_exprs
# bi = {bi_gen_ident=gen_ident,bi_gen_pos=gen_pos,bi_gen_index=gen_index,bi_bimap_exprs=[],bi_main_module_index=main_module_index,bi_predefs=predefs}
= case arg_exprs of
[]
-> specialize_from_with_arg type specialized_expr_with_adapted_args st
-> bimap_from_with_arg type specialized_expr_with_adapted_args bi bs
_
# (adapted_expr,st)
= specialize_from_with_arg type specialized_expr_with_adapted_args st
-> (adapted_expr @ arg_exprs, st)
# (adapted_expr,bs)
= bimap_from_with_arg type specialized_expr_with_adapted_args bi bs
-> (adapted_expr @ arg_exprs, bs)
bimap_to_with_arg :: BimapGenTypeStruct Expression BimapInfo *BimapState -> *(Expression,*BimapState)
bimap_to_with_arg (BGTSVar tv=:{tv_info_ptr}) arg bi=:{bi_main_module_index} bs=:{bs_heaps=heaps=:{hp_type_heaps=th=:{th_vars}}}
# (expr, th_vars) = readPtr tv_info_ptr th_vars
# heaps & hp_type_heaps = {th & th_vars = th_vars}
# (expr,heaps) = bimap_to_tvi_expr_with_arg expr tv_info_ptr arg bi_main_module_index heaps
= (expr, {bs & bs_heaps=heaps})
bimap_to_with_arg (BGTSAppConsSimpleType type_symbol_n kind arg_types) arg bi st
= bimap_to_simple_type type_symbol_n kind arg_types [arg] bi st
bimap_to_with_arg type arg bi st
# (adaptor_expr,st) = bimap_to type bi st
= (adaptor_expr @ [arg],st)
bimap_from_with_arg :: BimapGenTypeStruct Expression BimapInfo *BimapState -> *(Expression,*BimapState)
bimap_from_with_arg (BGTSVar tv=:{tv_info_ptr}) arg {bi_main_module_index} bs=:{bs_heaps=heaps=:{hp_type_heaps=th=:{th_vars}},bs_error}
# (expr, th_vars) = readPtr tv_info_ptr th_vars
# heaps & hp_type_heaps = {th & th_vars = th_vars}
# (expr,heaps) = bimap_from_tvi_expr_with_arg expr tv_info_ptr arg bi_main_module_index heaps
= (expr, {bs & bs_heaps=heaps})
bimap_from_with_arg (BGTSAppConsSimpleType type_symbol_n kind arg_types) arg bi st
= bimap_from_simple_type type_symbol_n kind arg_types [arg] bi st
bimap_from_with_arg type arg bi st
# (adaptor_expr,st) = bimap_from type bi st
= (adaptor_expr @ [arg],st)
bimap_to :: !BimapGenTypeStruct !BimapInfo !*BimapState -> *(!Expression,!*BimapState)
bimap_to (BGTSAppCons KindConst []) bi=:{bi_main_module_index,bi_predefs} bs
# (expr, funs_and_groups, heaps) = bimap_id_expression bi_main_module_index bi_predefs bs.bs_funs_and_groups bs.bs_heaps