Commit 8bff232d authored by John van Groningen's avatar John van Groningen
Browse files

in substitute use original type (instead of copy) if possible,

to reduce memory usage of the compiler
parent c07d1216
......@@ -338,15 +338,14 @@ instantiateTypes old_type_vars old_attr_vars types type_contexts attr_env {ss_en
(new_attr_vars, th_attrs) = foldSt build_attr_var_subst ss_attrs ([], th_attrs)
type_heaps = foldSt build_type_subst ss_environ { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
(new_ss_context, type_heaps) = substitute ss_context type_heaps
(_, new_ss_context, type_heaps) = substitute ss_context type_heaps
(inst_vars, th_vars) = foldSt determine_free_var old_type_vars (new_type_vars, type_heaps.th_vars)
(inst_attr_vars, th_attrs) = foldSt build_attr_var_subst old_attr_vars (new_attr_vars, type_heaps.th_attrs)
(inst_types, (ok2, type_heaps)) = mapSt substitue_arg_type types (True, { type_heaps & th_vars = th_vars, th_attrs = th_attrs })
// (ok2, inst_types, type_heaps) = substitute types { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
(inst_contexts, type_heaps) = substitute type_contexts type_heaps
(inst_attr_env, type_heaps) = substitute attr_env type_heaps
(_, inst_contexts, type_heaps) = substitute type_contexts type_heaps
(_, inst_attr_env, type_heaps) = substitute attr_env type_heaps
(special_subst_list, th_vars) = mapSt adjust_special_subst special_subst_list type_heaps.th_vars
= (inst_vars, inst_attr_vars, inst_types, new_ss_context ++ inst_contexts, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars }, error)
where
......@@ -361,7 +360,7 @@ where
-> (free_vars, type_var_heap)
build_type_subst {bind_src,bind_dst} type_heaps
# (bind_src, type_heaps) = substitute bind_src type_heaps
# (_, bind_src, type_heaps) = substitute bind_src type_heaps
// RWS ...
/*
FIXME: this is a patch for the following incorrect function type (in a dcl module)
......@@ -382,10 +381,10 @@ where
substitue_arg_type at=:{at_type = TFA type_vars type} (was_ok, type_heaps)
# (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps)
(new_at, type_heaps) = substitute {at & at_type = type} type_heaps
(_, new_at, type_heaps) = substitute {at & at_type = type} type_heaps
= ({ new_at & at_type = TFA fresh_type_vars new_at.at_type}, (was_ok, type_heaps))
substitue_arg_type type (was_ok, type_heaps)
# (type, type_heaps) = substitute type type_heaps
# (_, type, type_heaps) = substitute type type_heaps
= (type, (was_ok, type_heaps))
build_var_subst var (free_vars, type_var_heap)
......
......@@ -33,11 +33,10 @@ class expandSynTypes a :: !Int !{#CommonDefs} !a !*ExpandTypeState -> (!Bool,!a,
instance expandSynTypes (a,b) | expandSynTypes a & expandSynTypes b special a=[AType],b=AType
class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps)
instance substitute Type,AType,TypeContext,AttrInequality,CaseType
instance substitute [a] | substitute a special a=AType; a=AttrInequality; a=TypeContext
instance substitute (a,b) | substitute a & substitute b special a=[AType],b=AType
instance substitute [a] | substitute a special a=AType; a=TypeContext; a=AttrInequality
class removeAnnotations a :: !a -> (!Bool, !a)
......
......@@ -261,10 +261,12 @@ where
= type_heaps
substitute_rhs rem_annots rhs_type type_heaps
| (rem_annots bitand RemoveAnnotationsMask)<>0
| rem_annots bitand RemoveAnnotationsMask<>0
# (_, rhs_type) = removeAnnotations rhs_type
= substitute rhs_type type_heaps
= substitute rhs_type type_heaps
# (_,type,heaps) = substitute rhs_type type_heaps
= (type,heaps)
# (_,type,heaps) = substitute rhs_type type_heaps
= (type,heaps)
collect_imported_constructors :: !{#.CommonDefs} !.Int !.TypeRhs !*ExpandTypeState -> .ExpandTypeState
collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap}
......@@ -290,119 +292,167 @@ where
has_been_collected (VI_ExpandedType _) = True
has_been_collected _ = False
class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps)
instance substitute AType
where
substitute atype=:{at_attribute,at_type} heaps
# ((at_attribute,at_type), heaps) = substitute (at_attribute,at_type) heaps
= ({ atype & at_attribute = at_attribute, at_type = at_type }, heaps)
# (changed_attribute, at_attribute_r, heaps) = substitute at_attribute heaps
# (changed_type, at_type_r, heaps) = substitute at_type heaps
| changed_attribute
| changed_type
= (True, {at_attribute = at_attribute_r, at_type = at_type_r}, heaps)
= (True, {atype & at_attribute = at_attribute_r}, heaps)
| changed_type
= (True, {atype & at_type = at_type_r}, heaps)
= (False, atype, heaps)
instance substitute TypeAttribute
where
substitute (TA_Var {av_ident, av_info_ptr}) heaps=:{th_attrs}
#! av_info = sreadPtr av_info_ptr th_attrs
= case av_info of
substitute (TA_Var {av_info_ptr}) heaps=:{th_attrs}
= case sreadPtr av_info_ptr th_attrs of
AVI_Attr attr
-> (attr, heaps)
-> (True, attr, heaps)
_
-> (TA_Multi, heaps)
-> (True, TA_Multi, heaps)
substitute (TA_RootVar {av_info_ptr}) heaps=:{th_attrs}
#! av_info = sreadPtr av_info_ptr th_attrs
= case av_info of
= case sreadPtr av_info_ptr th_attrs of
AVI_Attr attr
-> (attr, heaps)
-> (True, attr, heaps)
_
-> (TA_Multi, heaps)
-> (True, TA_Multi, heaps)
substitute TA_None heaps
= (TA_Multi, heaps)
= (True, TA_Multi, heaps)
substitute attr heaps
= (attr, heaps)
instance substitute (a,b) | substitute a & substitute b
where
substitute (x,y) heaps
# (x, heaps) = substitute x heaps
(y, heaps) = substitute y heaps
= ((x,y), heaps)
instance substitute [a] | substitute a
where
substitute [] heaps
= ( [], heaps)
substitute [t:ts] heaps
# (t, heaps) = substitute t heaps
( ts, heaps) = substitute ts heaps
= ([t:ts], heaps)
instance substitute TypeContext
where
substitute tc=:{tc_types} heaps
# (tc_types, heaps) = substitute tc_types heaps
= ({ tc & tc_types = tc_types }, heaps)
= (False, attr, heaps)
instance substitute Type
where
substitute tv=:(TV {tv_info_ptr}) heaps=:{th_vars}
# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
heaps = {heaps & th_vars = th_vars}
heaps & th_vars = th_vars
= case tv_info of
TVI_Type type
-> (type, heaps)
-> (True, type, heaps)
_
-> (tv, heaps)
substitute (arg_type --> res_type) heaps
# ((arg_type, res_type), heaps) = substitute (arg_type, res_type) heaps
= (arg_type --> res_type, heaps)
substitute (TArrow1 arg_type) heaps
# (arg_type, heaps) = substitute arg_type heaps
= (TArrow1 arg_type, heaps)
substitute (TA cons_id cons_args) heaps
# (cons_args, heaps) = substitute cons_args heaps
= (TA cons_id cons_args, heaps)
substitute (TAS cons_id cons_args strictness) heaps
# (cons_args, heaps) = substitute cons_args heaps
= (TAS cons_id cons_args strictness, heaps)
substitute (CV type_var :@: types) heaps=:{th_vars}
-> (False, tv, heaps)
substitute type=:(arg_type --> res_type) heaps
# (changed_arg_type, arg_type_r, heaps) = substitute arg_type heaps
# (changed_res_type, res_type_r, heaps) = substitute res_type heaps
| changed_arg_type
| changed_res_type
= (True, arg_type_r --> res_type_r, heaps)
= (True, arg_type_r --> res_type, heaps)
| changed_res_type
= (True, arg_type --> res_type_r, heaps)
= (False, type, heaps)
substitute type=:(TA cons_id cons_args) heaps
# (changed, cons_args_r, heaps) = substitute cons_args heaps
| changed
= (True, TA cons_id cons_args_r, heaps)
= (False, type, heaps)
substitute type=:(TAS cons_id cons_args strictness) heaps
# (changed, cons_args_r, heaps) = substitute cons_args heaps
| changed
= (True, TAS cons_id cons_args_r strictness, heaps)
= (False, type, heaps)
substitute type=:(CV type_var :@: types) heaps=:{th_vars}
# (tv_info, th_vars) = readPtr type_var.tv_info_ptr th_vars
heaps = {heaps & th_vars = th_vars}
(types, heaps) = substitute types heaps
heaps & th_vars = th_vars
(changed, types_r, heaps) = substitute types heaps
| changed
= case tv_info of
TVI_Type type
# (ok, simplified_type) = simplifyAndCheckTypeApplication type types
TVI_Type s_type
# (ok, simplified_type) = simplifyAndCheckTypeApplication s_type types_r
| ok
-> (simplified_type, heaps)
// otherwise
-> (True, simplified_type, heaps)
// this will lead to a kind check error later on
-> (CV type_var :@: types, heaps)
-> (CV type_var :@: types, heaps)
-> (True, CV type_var :@: types_r, heaps)
_
-> (True, CV type_var :@: types_r, heaps)
= case tv_info of
TVI_Type s_type
# (ok, simplified_type) = simplifyAndCheckTypeApplication s_type types
| ok
-> (True, simplified_type, heaps)
// this will lead to a kind check error later on
-> (False, type, heaps)
_
-> (False, type, heaps)
substitute type=:(TArrow1 arg_type) heaps
# (changed, arg_type_r, heaps) = substitute arg_type heaps
| changed
= (True, TArrow1 arg_type_r, heaps)
= (False, type, heaps)
substitute type heaps
= (type, heaps)
= (False, type, heaps)
instance substitute [a] | substitute a
where
substitute lt=:[t:ts] heaps
# (changed_t, t_r, heaps) = substitute t heaps
(changed_ts, ts_r, heaps) = substitute ts heaps
| changed_t
| changed_ts
= (True, [t_r:ts_r], heaps)
= (True, [t_r:ts], heaps)
| changed_ts
= (True, [t:ts_r], heaps)
= (False, lt, heaps)
substitute [] heaps
= (False, [], heaps)
instance substitute TypeContext
where
substitute tc=:{tc_types} heaps
# (changed_tc_types, tc_types_r, heaps) = substitute tc_types heaps
| changed_tc_types
= (True, {tc & tc_types = tc_types_r}, heaps)
= (False, tc, heaps)
instance substitute AttributeVar
where
substitute av=:{av_info_ptr} heaps=:{th_attrs}
#! av_info = sreadPtr av_info_ptr th_attrs
= case av_info of
= case sreadPtr av_info_ptr th_attrs of
AVI_Attr (TA_Var attr_var)
-> (attr_var, heaps)
-> (True, attr_var, heaps)
_
-> (av, heaps)
-> (False, av, heaps)
instance substitute AttrInequality
where
substitute {ai_demanded,ai_offered} heaps
# ((ai_demanded, ai_offered), heaps) = substitute (ai_demanded, ai_offered) heaps
= ({ai_demanded = ai_demanded, ai_offered = ai_offered}, heaps)
# (changed_ai_demanded, ai_demanded_r, heaps) = substitute ai_demanded heaps
(changed_ai_offered, ai_offered_r, heaps) = substitute ai_offered heaps
| changed_ai_demanded
| changed_ai_offered
= (True, {ai_demanded = ai_demanded_r, ai_offered = ai_offered_r}, heaps)
= (True, {ai_demanded = ai_demanded_r, ai_offered = ai_offered}, heaps)
| changed_ai_offered
= (True, {ai_demanded = ai_demanded, ai_offered = ai_offered_r}, heaps)
= (False, {ai_demanded = ai_demanded, ai_offered = ai_offered}, heaps)
instance substitute CaseType
where
substitute {ct_pattern_type, ct_result_type, ct_cons_types} heaps
# (ct_pattern_type, heaps) = substitute ct_pattern_type heaps
(ct_result_type, heaps) = substitute ct_result_type heaps
(ct_cons_types, heaps) = substitute ct_cons_types heaps
= ({ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type,
ct_cons_types = ct_cons_types}, heaps)
# (changed_pattern_type, pattern_type_r, heaps) = substitute ct_pattern_type heaps
(changed_result_type, result_type_r, heaps) = substitute ct_result_type heaps
(changed_cons_types, cons_types_r, heaps) = substitute ct_cons_types heaps
| changed_pattern_type
| changed_result_type
| changed_cons_types
= (True, {ct_pattern_type=pattern_type_r, ct_result_type=result_type_r, ct_cons_types=cons_types_r}, heaps)
= (True, {ct_pattern_type=pattern_type_r, ct_result_type=result_type_r, ct_cons_types=ct_cons_types}, heaps)
| changed_cons_types
= (True, {ct_pattern_type=pattern_type_r, ct_result_type=ct_result_type, ct_cons_types=cons_types_r}, heaps)
= (True, {ct_pattern_type=pattern_type_r, ct_result_type=ct_result_type, ct_cons_types=ct_cons_types}, heaps)
| changed_result_type
| changed_cons_types
= (True, {ct_pattern_type=ct_pattern_type, ct_result_type=result_type_r, ct_cons_types=cons_types_r}, heaps)
= (True, {ct_pattern_type=ct_pattern_type, ct_result_type=result_type_r, ct_cons_types=ct_cons_types}, heaps)
| changed_cons_types
= (True, {ct_pattern_type=ct_pattern_type, ct_result_type=ct_result_type, ct_cons_types=cons_types_r}, heaps)
= (False, {ct_pattern_type=ct_pattern_type, ct_result_type=ct_result_type, ct_cons_types=ct_cons_types}, heaps)
class removeAnnotations a :: !a -> (!Bool, !a)
......
......@@ -328,10 +328,10 @@ where
where
fresh_context :: !TypeContext !*TypeHeaps -> (TypeContext,*TypeHeaps)
fresh_context tc=:{tc_types} type_heaps
# (tc_types, type_heaps) = substitute tc_types type_heaps
// (tc_var, var_heap) = newPtr VI_Empty var_heap
// = ({ tc & tc_types = tc_types, tc_var = tc_var }, (var_heap, type_heaps))
= ({ tc & tc_types = tc_types }, type_heaps)
# (changed_tc_types, tc_types, type_heaps) = substitute tc_types type_heaps
| changed_tc_types
= ({tc & tc_types = tc_types}, type_heaps)
= (tc, type_heaps)
is_unboxed_array:: [Type] PredefinedSymbols -> Bool
is_unboxed_array [TA {type_index={glob_module,glob_object},type_arity} _ : _] predef_symbols
......@@ -851,7 +851,7 @@ where
= type_var_heap <:= (tv_info_ptr, TVI_Type type)
subst_context_and_generate_super_classes class_context (super_classes, type_heaps)
# (super_class, type_heaps) = substitute class_context type_heaps
# (_, super_class, type_heaps) = substitute class_context type_heaps
| containsContext super_class super_classes
= (super_classes, type_heaps)
= generate_super_classes super_class ([super_class : super_classes], type_heaps)
......@@ -1090,7 +1090,7 @@ where
# {tc_class=TCClass {glob_object={ds_index},glob_module}} = tc2
{class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index]
th_vars = foldr2 (\{tv_info_ptr} type -> writePtr tv_info_ptr (TVI_Type type)) th_vars class_args tc2.tc_types
(super_instances, type_heaps) = substitute class_context { type_heaps & th_vars = th_vars }
(_, super_instances, type_heaps) = substitute class_context {type_heaps & th_vars = th_vars}
= find_super_instance tc1 super_instances (size class_members) address glob_module class_dictionary.ds_index defs type_heaps
where
find_super_instance :: !TypeContext ![TypeContext] !Index ![(Int, Global DefinedSymbol)] !Index !Index !{#CommonDefs} !*TypeHeaps
......
......@@ -997,7 +997,6 @@ generate_case_function fun_index case_info_ptr new_expr outer_fun_def outer_cons
app_args = free_vars_to_bound_vars tfi_args
= ( App {app_symb = app_symb, app_args = app_args, app_info_ptr = nilPtr}, ti)
generate_case_function_with_pattern_argument :: !Int !ExprInfoPtr !Expression FunDef .ConsClasses [.Bool] !SymbIdent ![FreeVar] !*TransformInfo
-> (!Expression,!*TransformInfo)
generate_case_function_with_pattern_argument fun_index case_info_ptr
......@@ -1089,8 +1088,8 @@ determine_case_function_type fun_arity ct_result_type arg_types st_attr_env ti=:
# (type_variables, th_vars) = getTypeVars [ct_result_type:arg_types] ti_type_heaps.th_vars
(fresh_type_vars, th_vars) = mapSt bind_to_fresh_type_variable type_variables th_vars
ti_type_heaps = { ti_type_heaps & th_vars = th_vars }
(fresh_arg_types, ti_type_heaps) = substitute arg_types ti_type_heaps
(fresh_result_type, ti_type_heaps) = substitute ct_result_type ti_type_heaps
(_, fresh_arg_types, ti_type_heaps) = substitute arg_types ti_type_heaps
(_, fresh_result_type, ti_type_heaps) = substitute ct_result_type ti_type_heaps
fun_type =
{ st_vars = fresh_type_vars
, st_args = fresh_arg_types
......@@ -1467,8 +1466,8 @@ generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_i
das_AVI_Attr_TA_TempVar_info_ptrs = [st_attr_vars]
ti_type_heaps = {ti_type_heaps & th_attrs = th_attrs, th_vars = th_vars}
// | False-!->("before substitute", st_args, "->", st_result) = undef
# ((st_args,st_result), ti_type_heaps)
= substitute (st_args,st_result) ti_type_heaps
# (_, st_args, ti_type_heaps) = substitute st_args ti_type_heaps
# (_, st_result, ti_type_heaps) = substitute st_result ti_type_heaps
// | False-!->("after substitute", st_args, "->", st_result) = undef
// determine args...
# das = { das_vars = []
......@@ -1791,9 +1790,9 @@ where
= mapSt bind_to_fresh_type_variable st_vars th_vars
(fresh_st_attr_vars, th_attrs)
= mapSt bind_to_fresh_attr_variable st_attr_vars th_attrs
([fresh_st_result:fresh_st_args], ti_type_heaps)
(_, [fresh_st_result:fresh_st_args], ti_type_heaps)
= substitute [st_result:st_args] { ti_type_heaps & th_vars = th_vars, th_attrs = th_attrs }
(fresh_st_attr_env, ti_type_heaps)
(_, fresh_st_attr_env, ti_type_heaps)
= substitute st_attr_env ti_type_heaps
= (Yes { symbol_type & st_vars = fresh_st_vars, st_attr_vars = fresh_st_attr_vars, st_args = fresh_st_args,
st_result = fresh_st_result, st_attr_env = fresh_st_attr_env}, ti_type_heaps)
......@@ -1981,7 +1980,7 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr
das=:{das_arg_types, das_subst, das_type_heaps, das_predef}
# (ws_arg_type, das_arg_types) = das_arg_types![prod_index]
# {ats_types=[arg_type:_]} = ws_arg_type
(int_class_type, das_type_heaps)
(_, int_class_type, das_type_heaps)
= substitute class_type das_type_heaps
class_atype = { empty_atype & at_type = int_class_type }
type_input
......@@ -2014,9 +2013,9 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr
= abort ("sanity check nr 93 in module trans failed\n"--->(class_atype,"\n", arg_type))
# (free_vars_and_types,das_type_heaps) = mapSt subFVT free_vars_and_types das_type_heaps
with
subFVT (fv,ty) th
# (ty`,th`) = substitute ty th
= ((fv,ty`),th`)
subFVT (fv,ty) type_heaps
# (_, ty`,type_heaps) = substitute ty type_heaps
= ((fv,ty`),type_heaps)
# ws_ats_types = [ { empty_atype & at_type = at_type } \\ (_, at_type) <- free_vars_and_types]
# ws_arg_type` = {ats_types= ws_ats_types, ats_strictness = first_n_strict (length free_vars_and_types) }
......@@ -2057,8 +2056,8 @@ determine_arg producer (Yes {st_args, st_args_strictness, st_result, st_attr_var
// because types in Cases and Lets should not use TA_TempVar's
das_AVI_Attr_TA_TempVar_info_ptrs = [st_attr_vars:das_AVI_Attr_TA_TempVar_info_ptrs]
// prepare for substitute calls
((st_args, st_result), das_type_heaps)
= substitute (st_args, st_result) { das_type_heaps & th_vars = th_vars, th_attrs = th_attrs }
(_, st_args, das_type_heaps) = substitute st_args {das_type_heaps & th_vars = th_vars, th_attrs = th_attrs}
(_, st_result, das_type_heaps) = substitute st_result das_type_heaps
nr_of_applied_args = symbol_arity
(application_type, attr_env, das_next_attr_nr)
= build_application_type st_arity (length st_context) st_result st_args nr_of_applied_args [] das_next_attr_nr
......@@ -4169,11 +4168,6 @@ get_fun_def_and_cons_args (SK_GeneratedFunction fun_info_ptr fun_index) cons_arg
= (gf_fun_def, gf_cons_args, cons_args, fun_defs, fun_heap)
//@ <<<
/*
instance <<< Group where
(<<<) file {group_members}
= file <<< "Group: " <<< group_members
*/
instance <<< RootCaseMode where
(<<<) file mode = case mode of NotRootCase -> file <<< "NotRootCase"; RootCase -> file <<< "RootCase"; RootCaseOfZombie -> file <<< "RootCaseOfZombie";
......@@ -4459,7 +4453,7 @@ copy_dictionary_variable app_symb app_args class_type ci cs
substitute_class_types class_types No
= (class_types, No)
substitute_class_types class_types (Yes type_heaps)
# (new_class_types, type_heaps) = substitute class_types type_heaps
# (_, new_class_types, type_heaps) = substitute class_types type_heaps
= (new_class_types, Yes type_heaps)
instance copy DynamicExpr
......@@ -4536,7 +4530,7 @@ where
= ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, cs)
substitute_EI_DictionaryType (EI_DictionaryType class_type) (Yes type_heaps)
# (new_class_type, type_heaps) = substitute class_type type_heaps
# (_, new_class_type, type_heaps) = substitute class_type type_heaps
= (EI_DictionaryType new_class_type, Yes type_heaps)
substitute_EI_DictionaryType x opt_type_heaps
= (x, opt_type_heaps)
......@@ -4684,12 +4678,16 @@ substitute_let_or_case_type expr_info No
substitute_let_or_case_type (EI_Extended extensions expr_info) yes_type_heaps
# (new_expr_info, yes_type_heaps) = substitute_let_or_case_type expr_info yes_type_heaps
= (EI_Extended extensions new_expr_info, yes_type_heaps)
substitute_let_or_case_type (EI_CaseType case_type) (Yes type_heaps)
# (new_case_type, type_heaps) = substitute case_type type_heaps
substitute_let_or_case_type expr_info=:(EI_CaseType case_type) (Yes type_heaps)
# (changed, new_case_type, type_heaps) = substitute case_type type_heaps
| changed
= (EI_CaseType new_case_type, Yes type_heaps)
substitute_let_or_case_type (EI_LetType let_type) (Yes type_heaps)
# (new_let_type, type_heaps) = substitute let_type type_heaps
= (expr_info, Yes type_heaps)
substitute_let_or_case_type expr_info=:(EI_LetType let_type) (Yes type_heaps)
# (changed, new_let_type, type_heaps) = substitute let_type type_heaps
| changed
= (EI_LetType new_let_type, Yes type_heaps)
= (expr_info, Yes type_heaps)
instance copy CasePatterns
where
......
......@@ -584,13 +584,17 @@ where
# (info, expr_heap) = readPtr expr_ptr expr_heap
= case info of
EI_CaseType case_type
# (case_type, type_heaps) = substitute case_type type_heaps
-> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type))
# (changed, case_type_r, type_heaps) = substitute case_type type_heaps
| changed
-> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type_r))
-> (type_heaps, expr_heap)
EI_LetType let_type
# (let_type, type_heaps) = substitute let_type type_heaps
-> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type))
# (changed, let_type_r, type_heaps) = substitute let_type type_heaps
| changed
-> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type_r))
-> (type_heaps, expr_heap)
EI_DictionaryType dict_type
# (dict_type, type_heaps) = substitute dict_type type_heaps
# (_, dict_type, type_heaps) = substitute dict_type type_heaps
-> (type_heaps, expr_heap <:= (expr_ptr, EI_DictionaryType dict_type))
class bindInstances a :: !a !a !*TypeVarHeap -> *TypeVarHeap
......@@ -640,7 +644,7 @@ instance bindInstances AType
substituteType :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !Type !*TypeHeaps -> (!Type, !*TypeHeaps)
substituteType form_root_attribute act_root_attribute form_type_args act_type_args orig_type type_heaps
# type_heaps = bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps
(expanded_type, type_heaps) = substitute orig_type type_heaps
(_, expanded_type, type_heaps) = substitute orig_type type_heaps
= (expanded_type, clearBindingsOfTypeVarsAndAttributes form_root_attribute form_type_args type_heaps)
bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps
......
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