diff options
| -rw-r--r-- | frontend/classify.icl | 17 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/trans.icl | 10 |
3 files changed, 20 insertions, 9 deletions
diff --git a/frontend/classify.icl b/frontend/classify.icl index 2ccb8ec..86e8f68 100644 --- a/frontend/classify.icl +++ b/frontend/classify.icl @@ -1376,14 +1376,14 @@ get_linearity_info cc_linear_bits (AlgebraicPatterns _ algebraic_patterns) var_h get_linearity_info cc_linear_bits (OverloadedListPatterns _ _ algebraic_patterns) var_heap = get_linearity_info_of_patterns cc_linear_bits algebraic_patterns var_heap get_linearity_info cc_linear_bits _ var_heap - = ([], var_heap) + = ([!!], var_heap) get_linearity_info_of_patterns cc_linear_bits algebraic_patterns var_heap - = mapSt (get_linearity_info_of_pattern cc_linear_bits) algebraic_patterns var_heap + = mapStStrictR (get_linearity_info_of_pattern cc_linear_bits) algebraic_patterns var_heap where get_linearity_info_of_pattern cc_linear_bits {ap_vars} var_heap # (var_indices, var_heap) = mapSt get_var_index ap_vars var_heap - = ([if (index==cNope) True (cc_linear_bits!!$index) \\ index<-var_indices], var_heap) + = ([#if (index==cNope) True (cc_linear_bits!!$index) \\ index<-var_indices!], var_heap) get_var_index {fv_info_ptr} var_heap # (vi, var_heap) = readPtr fv_info_ptr var_heap @@ -1397,6 +1397,17 @@ set_linearity_info fun fun_index fun_cons_class fun_ref_counts group_strictness cc_args = add_unused_args fun fun_index fun_cons_class.cc_args fun_ref_counts group_strictness = { fun_cons_class & cc_args = cc_args } +mapStStrictR f l s :== map_st l s +where + map_st [x : xs] s + # (x, s) = f x s + (xs, s) = map_st xs s + #! s = s + = ([!x : xs!], s) + map_st [] s + #! s = s + = ([!!], s) + foldComponentMembersSt op l st :== fold_ComponentMembers_st l st where fold_ComponentMembers_st (ComponentMember a as) st diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 86290e4..37d020a 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -893,7 +893,7 @@ cNotVarNumber :== -1 { aci_params :: ![FreeVar] , aci_opt_unfolder :: !(Optional SymbIdent) , aci_free_vars :: !Optional [BoundVar] - , aci_linearity_of_patterns :: ![[Bool]] + , aci_linearity_of_patterns :: ![![#Bool!]!] , aci_safe :: !Bool } diff --git a/frontend/trans.icl b/frontend/trans.icl index e992280..824acd7 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -530,7 +530,7 @@ where match_and_instantiate linearities cons_index app_args (AlgebraicPatterns _ algebraicPatterns) case_default ro ti = match_and_instantiate_algebraic_type linearities cons_index app_args algebraicPatterns case_default ro ti where - match_and_instantiate_algebraic_type [linearity:linearities] cons_index app_args + match_and_instantiate_algebraic_type [!linearity:linearities!] cons_index app_args [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] case_default ro ti | cons_index.glob_module == glob_module && cons_index.glob_object == ds_index # {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[ds_index] @@ -541,7 +541,7 @@ where match_and_instantiate linearities cons_index app_args (OverloadedListPatterns (OverloadedList _ _ _ _) _ algebraicPatterns) case_default ro ti = match_and_instantiate_overloaded_list linearities cons_index app_args algebraicPatterns case_default ro ti where - match_and_instantiate_overloaded_list [linearity:linearities] cons_index=:{glob_module=cons_glob_module,glob_object=cons_ds_index} app_args + match_and_instantiate_overloaded_list [!linearity:linearities!] cons_index=:{glob_module=cons_glob_module,glob_object=cons_ds_index} app_args [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] case_default ro ti | equal_list_contructor glob_module ds_index cons_glob_module cons_ds_index @@ -587,7 +587,7 @@ where match_and_instantiate_overloaded_cons cons_function_type linearities app_args (AlgebraicPatterns _ algebraicPatterns) case_default ro ti = match_and_instantiate_overloaded_cons_boxed_match linearities app_args algebraicPatterns case_default ro ti where - match_and_instantiate_overloaded_cons_boxed_match [linearity:linearities] app_args + match_and_instantiate_overloaded_cons_boxed_match [!linearity:linearities!] app_args [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] case_default ro ti | glob_module==cPredefinedModuleIndex @@ -603,7 +603,7 @@ where match_and_instantiate_overloaded_cons cons_function_type linearities app_args (OverloadedListPatterns _ _ algebraicPatterns) case_default ro ti = match_and_instantiate_overloaded_cons_overloaded_match linearities app_args algebraicPatterns case_default ro ti where - match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args + match_and_instantiate_overloaded_cons_overloaded_match [!linearity:linearities!] app_args [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] case_default ro ti | glob_module==cPredefinedModuleIndex @@ -644,7 +644,7 @@ where (body_strictness,ti_fun_defs,ti_fun_heap) = body_strict ap_expr ap_vars ro ti.ti_fun_defs ti.ti_fun_heap ti = {ti & ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap} unfoldables = [ (arg_is_strict i body_strictness || ((not (arg_is_strict i cons_type_args_strictness))) && linear) || in_normal_form app_arg - \\ linear <- linearity & app_arg <- app_args & i <- [0..]] + \\ linear <|- linearity & app_arg <- app_args & i <- [0..]] unfoldable_args = filterWith unfoldables zipped_ap_vars_and_args not_unfoldable = map not unfoldables ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr (VI_Expression arg)) unfoldable_args ti.ti_var_heap |