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 ...@@ -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) (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 } 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_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_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 }) (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_contexts, type_heaps) = substitute type_contexts type_heaps (_, inst_attr_env, type_heaps) = substitute attr_env 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 (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) = (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 where
...@@ -361,7 +360,7 @@ where ...@@ -361,7 +360,7 @@ where
-> (free_vars, type_var_heap) -> (free_vars, type_var_heap)
build_type_subst {bind_src,bind_dst} type_heaps 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 ... // RWS ...
/* /*
FIXME: this is a patch for the following incorrect function type (in a dcl module) FIXME: this is a patch for the following incorrect function type (in a dcl module)
...@@ -382,10 +381,10 @@ where ...@@ -382,10 +381,10 @@ where
substitue_arg_type at=:{at_type = TFA type_vars type} (was_ok, type_heaps) 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) # (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)) = ({ new_at & at_type = TFA fresh_type_vars new_at.at_type}, (was_ok, type_heaps))
substitue_arg_type 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)) = (type, (was_ok, type_heaps))
build_var_subst var (free_vars, type_var_heap) build_var_subst var (free_vars, type_var_heap)
...@@ -2267,7 +2266,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m ...@@ -2267,7 +2266,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
(instance_types, icl_common, dcl_modules, hp_var_heap, hp_type_heaps, cs) (instance_types, icl_common, dcl_modules, hp_var_heap, hp_type_heaps, cs)
= checkIclInstances main_dcl_module_n icl_common dcl_modules hp_var_heap hp_type_heaps cs = checkIclInstances main_dcl_module_n icl_common dcl_modules hp_var_heap hp_type_heaps cs
heaps = { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap } heaps = { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap }
e_info = { ef_type_defs = icl_common.com_type_defs, ef_selector_defs = icl_common.com_selector_defs, ef_class_defs = icl_common.com_class_defs, e_info = { ef_type_defs = icl_common.com_type_defs, ef_selector_defs = icl_common.com_selector_defs, ef_class_defs = icl_common.com_class_defs,
......
...@@ -33,11 +33,10 @@ class expandSynTypes a :: !Int !{#CommonDefs} !a !*ExpandTypeState -> (!Bool,!a, ...@@ -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 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 Type,AType,TypeContext,AttrInequality,CaseType
instance substitute [a] | substitute a special a=AType; a=AttrInequality; a=TypeContext instance substitute [a] | substitute a special a=AType; a=TypeContext; a=AttrInequality
instance substitute (a,b) | substitute a & substitute b special a=[AType],b=AType
class removeAnnotations a :: !a -> (!Bool, !a) class removeAnnotations a :: !a -> (!Bool, !a)
......
...@@ -261,10 +261,12 @@ where ...@@ -261,10 +261,12 @@ where
= type_heaps = type_heaps
substitute_rhs rem_annots rhs_type 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 # (_, rhs_type) = removeAnnotations rhs_type
= substitute rhs_type type_heaps # (_,type,heaps) = substitute rhs_type 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 :: !{#.CommonDefs} !.Int !.TypeRhs !*ExpandTypeState -> .ExpandTypeState
collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap} collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap}
...@@ -290,119 +292,167 @@ where ...@@ -290,119 +292,167 @@ where
has_been_collected (VI_ExpandedType _) = True has_been_collected (VI_ExpandedType _) = True
has_been_collected _ = False has_been_collected _ = False
class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps) class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps)
instance substitute AType instance substitute AType
where where
substitute atype=:{at_attribute,at_type} heaps substitute atype=:{at_attribute,at_type} heaps
# ((at_attribute,at_type), heaps) = substitute (at_attribute,at_type) heaps # (changed_attribute, at_attribute_r, heaps) = substitute at_attribute heaps
= ({ atype & at_attribute = at_attribute, at_type = at_type }, 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 instance substitute TypeAttribute
where where
substitute (TA_Var {av_ident, av_info_ptr}) heaps=:{th_attrs} substitute (TA_Var {av_info_ptr}) heaps=:{th_attrs}
#! av_info = sreadPtr av_info_ptr th_attrs = case sreadPtr av_info_ptr th_attrs of
= case av_info of
AVI_Attr attr AVI_Attr attr
-> (attr, heaps) -> (True, attr, heaps)
_ _
-> (TA_Multi, heaps) -> (True, TA_Multi, heaps)
substitute (TA_RootVar {av_info_ptr}) heaps=:{th_attrs} substitute (TA_RootVar {av_info_ptr}) heaps=:{th_attrs}
#! av_info = sreadPtr av_info_ptr th_attrs = case sreadPtr av_info_ptr th_attrs of
= case av_info of
AVI_Attr attr AVI_Attr attr
-> (attr, heaps) -> (True, attr, heaps)
_ _
-> (TA_Multi, heaps) -> (True, TA_Multi, heaps)
substitute TA_None heaps substitute TA_None heaps
= (TA_Multi, heaps) = (True, TA_Multi, heaps)
substitute attr heaps substitute attr heaps
= (attr, heaps) = (False, 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)
instance substitute Type instance substitute Type
where where
substitute tv=:(TV {tv_info_ptr}) heaps=:{th_vars} substitute tv=:(TV {tv_info_ptr}) heaps=:{th_vars}
# (tv_info, th_vars) = readPtr tv_info_ptr 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 = case tv_info of
TVI_Type type TVI_Type type
-> (type, heaps) -> (True, type, heaps)
_ _
-> (tv, heaps) -> (False, tv, heaps)
substitute (arg_type --> res_type) heaps substitute type=:(arg_type --> res_type) heaps
# ((arg_type, res_type), heaps) = substitute (arg_type, res_type) heaps # (changed_arg_type, arg_type_r, heaps) = substitute arg_type heaps
= (arg_type --> res_type, heaps) # (changed_res_type, res_type_r, heaps) = substitute res_type heaps
substitute (TArrow1 arg_type) heaps | changed_arg_type
# (arg_type, heaps) = substitute arg_type heaps | changed_res_type
= (TArrow1 arg_type, heaps) = (True, arg_type_r --> res_type_r, heaps)
substitute (TA cons_id cons_args) heaps = (True, arg_type_r --> res_type, heaps)
# (cons_args, heaps) = substitute cons_args heaps | changed_res_type
= (TA cons_id cons_args, heaps) = (True, arg_type --> res_type_r, heaps)
substitute (TAS cons_id cons_args strictness) heaps = (False, type, heaps)
# (cons_args, heaps) = substitute cons_args heaps substitute type=:(TA cons_id cons_args) heaps
= (TAS cons_id cons_args strictness, heaps) # (changed, cons_args_r, heaps) = substitute cons_args heaps
substitute (CV type_var :@: types) heaps=:{th_vars} | 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 # (tv_info, th_vars) = readPtr type_var.tv_info_ptr th_vars
heaps = {heaps & th_vars = th_vars} heaps & th_vars = th_vars
(types, heaps) = substitute types heaps (changed, types_r, heaps) = substitute types heaps
= case tv_info of | changed
TVI_Type type = case tv_info of
# (ok, simplified_type) = simplifyAndCheckTypeApplication type types TVI_Type s_type
| ok # (ok, simplified_type) = simplifyAndCheckTypeApplication s_type types_r
-> (simplified_type, heaps) | ok
// otherwise -> (True, simplified_type, heaps)
// this will lead to a kind check error later on // this will lead to a kind check error later on
-> (CV type_var :@: types, heaps) -> (True, CV type_var :@: types_r, heaps)
-> (CV type_var :@: types, 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 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 instance substitute AttributeVar
where where
substitute av=:{av_info_ptr} heaps=:{th_attrs} substitute av=:{av_info_ptr} heaps=:{th_attrs}
#! av_info = sreadPtr av_info_ptr th_attrs = case sreadPtr av_info_ptr th_attrs of
= case av_info of
AVI_Attr (TA_Var attr_var) AVI_Attr (TA_Var attr_var)
-> (attr_var, heaps) -> (True, attr_var, heaps)
_ _
-> (av, heaps) -> (False, av, heaps)
instance substitute AttrInequality instance substitute AttrInequality
where where
substitute {ai_demanded,ai_offered} heaps substitute {ai_demanded,ai_offered} heaps
# ((ai_demanded, ai_offered), heaps) = substitute (ai_demanded, ai_offered) heaps # (changed_ai_demanded, ai_demanded_r, heaps) = substitute ai_demanded heaps
= ({ai_demanded = ai_demanded, ai_offered = ai_offered}, 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 instance substitute CaseType
where where
substitute {ct_pattern_type, ct_result_type, ct_cons_types} heaps substitute {ct_pattern_type, ct_result_type, ct_cons_types} heaps
# (ct_pattern_type, heaps) = substitute ct_pattern_type heaps # (changed_pattern_type, pattern_type_r, heaps) = substitute ct_pattern_type heaps
(ct_result_type, heaps) = substitute ct_result_type heaps (changed_result_type, result_type_r, heaps) = substitute ct_result_type heaps
(ct_cons_types, heaps) = substitute ct_cons_types heaps (changed_cons_types, cons_types_r, heaps) = substitute ct_cons_types heaps
= ({ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, | changed_pattern_type
ct_cons_types = ct_cons_types}, heaps) | 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) class removeAnnotations a :: !a -> (!Bool, !a)
......
...@@ -328,10 +328,10 @@ where ...@@ -328,10 +328,10 @@ where
where where
fresh_context :: !TypeContext !*TypeHeaps -> (TypeContext,*TypeHeaps) fresh_context :: !TypeContext !*TypeHeaps -> (TypeContext,*TypeHeaps)
fresh_context tc=:{tc_types} type_heaps fresh_context tc=:{tc_types} type_heaps
# (tc_types, type_heaps) = substitute tc_types type_heaps # (changed_tc_types, tc_types, type_heaps) = substitute tc_types type_heaps
// (tc_var, var_heap) = newPtr VI_Empty var_heap | changed_tc_types
// = ({ tc & tc_types = tc_types, tc_var = tc_var }, (var_heap, type_heaps)) = ({tc & tc_types = tc_types}, type_heaps)
= ({ tc & tc_types = tc_types }, type_heaps) = (tc, type_heaps)
is_unboxed_array:: [Type] PredefinedSymbols -> Bool is_unboxed_array:: [Type] PredefinedSymbols -> Bool
is_unboxed_array [TA {type_index={glob_module,glob_object},type_arity} _ : _] predef_symbols is_unboxed_array [TA {type_index={glob_module,glob_object},type_arity} _ : _] predef_symbols
...@@ -851,7 +851,7 @@ where ...@@ -851,7 +851,7 @@ where
= type_var_heap <:= (tv_info_ptr, TVI_Type type) = type_var_heap <:= (tv_info_ptr, TVI_Type type)
subst_context_and_generate_super_classes class_context (super_classes, type_heaps) 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 | containsContext super_class super_classes
= (super_classes, type_heaps) = (super_classes, type_heaps)
= generate_super_classes super_class ([super_class : super_classes], type_heaps) = generate_super_classes super_class ([super_class : super_classes], type_heaps)
...@@ -1090,7 +1090,7 @@ where ...@@ -1090,7 +1090,7 @@ where
# {tc_class=TCClass {glob_object={ds_index},glob_module}} = tc2 # {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] {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 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 = find_super_instance tc1 super_instances (size class_members) address glob_module class_dictionary.ds_index defs type_heaps
where where
find_super_instance :: !TypeContext ![TypeContext] !Index ![(Int, Global DefinedSymbol)] !Index !Index !{#CommonDefs} !*TypeHeaps 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 ...@@ -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_args = free_vars_to_bound_vars tfi_args
= ( App {app_symb = app_symb, app_args = app_args, app_info_ptr = nilPtr}, ti) = ( 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 generate_case_function_with_pattern_argument :: !Int !ExprInfoPtr !Expression FunDef .ConsClasses [.Bool] !SymbIdent ![FreeVar] !*TransformInfo
-> (!Expression,!*TransformInfo) -> (!Expression,!*TransformInfo)
generate_case_function_with_pattern_argument fun_index case_info_ptr generate_case_function_with_pattern_argument fun_index case_info_ptr
...@@ -1051,7 +1050,7 @@ generate_case_function_with_pattern_argument fun_index case_info_ptr ...@@ -1051,7 +1050,7 @@ generate_case_function_with_pattern_argument fun_index case_info_ptr
, fi_local_vars = [] , fi_local_vars = []
, fi_dynamics = [] , fi_dynamics = []
, fi_properties = outer_fun_def.fun_info.fi_properties , fi_properties = outer_fun_def.fun_info.fi_properties
} }
} }
# cc_args_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_args & used <- used_mask | used ] # cc_args_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_args & used <- used_mask | used ]
cc_linear_bits_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_linear_bits & used <- used_mask | used ] cc_linear_bits_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_linear_bits & used <- used_mask | used ]
...@@ -1089,8 +1088,8 @@ determine_case_function_type fun_arity ct_result_type arg_types st_attr_env ti=: ...@@ -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 # (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 (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 } ti_type_heaps = { ti_type_heaps & th_vars = th_vars }
(fresh_arg_types, ti_type_heaps) = substitute arg_types 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 (_, fresh_result_type, ti_type_heaps) = substitute ct_result_type ti_type_heaps
fun_type = fun_type =
{ st_vars = fresh_type_vars { st_vars = fresh_type_vars
, st_args = fresh_arg_types , st_args = fresh_arg_types
...@@ -1467,8 +1466,8 @@ generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_i ...@@ -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] das_AVI_Attr_TA_TempVar_info_ptrs = [st_attr_vars]
ti_type_heaps = {ti_type_heaps & th_attrs = th_attrs, th_vars = th_vars} ti_type_heaps = {ti_type_heaps & th_attrs = th_attrs, th_vars = th_vars}
// | False-!->("before substitute", st_args, "->", st_result) = undef // | False-!->("before substitute", st_args, "->", st_result) = undef
# ((st_args,st_result), ti_type_heaps) # (_, st_args, ti_type_heaps) = substitute st_args ti_type_heaps
= substitute (st_args,st_result) ti_type_heaps # (_, st_result, ti_type_heaps) = substitute st_result ti_type_heaps
// | False-!->("after substitute", st_args, "->", st_result) = undef // | False-!->("after substitute", st_args, "->", st_result) = undef
// determine args... // determine args...
# das = { das_vars = [] # das = { das_vars = []
...@@ -1791,9 +1790,9 @@ where ...@@ -1791,9 +1790,9 @@ where
= mapSt bind_to_fresh_type_variable st_vars th_vars = mapSt bind_to_fresh_type_variable st_vars th_vars
(fresh_st_attr_vars, th_attrs) (fresh_st_attr_vars, th_attrs)
= mapSt bind_to_fresh_attr_variable 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 } = 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 = 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, = (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) 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 ...@@ -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} das=:{das_arg_types, das_subst, das_type_heaps, das_predef}
# (ws_arg_type, das_arg_types) = das_arg_types![prod_index] # (ws_arg_type, das_arg_types) = das_arg_types![prod_index]
# {ats_types=[arg_type:_]} = ws_arg_type # {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 = substitute class_type das_type_heaps
class_atype = { empty_atype & at_type = int_class_type } class_atype = { empty_atype & at_type = int_class_type }
type_input type_input
...@@ -2014,9 +2013,9 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr ...@@ -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)) = 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 # (free_vars_and_types,das_type_heaps) = mapSt subFVT free_vars_and_types das_type_heaps
with with
subFVT (fv,ty) th subFVT (fv,ty) type_heaps
# (ty`,th`) = substitute ty th # (_, ty`,type_heaps) = substitute ty type_heaps
= ((fv,ty`),th`) = ((fv,ty`),type_heaps)
# ws_ats_types = [ { empty_atype & at_type = at_type } \\ (_, at_type) <- free_vars_and_types] # 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) } # 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 ...@@ -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 // 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] das_AVI_Attr_TA_TempVar_info_ptrs = [st_attr_vars:das_AVI_Attr_TA_TempVar_info_ptrs]
// prepare for substitute calls // prepare for substitute calls
((st_args, st_result), das_type_heaps) (_, st_args, das_type_heaps) = substitute st_args {das_type_heaps & th_vars = th_vars, th_attrs = th_attrs}