diff options
| -rw-r--r-- | backend/backendconvert.icl | 12 | ||||
| -rw-r--r-- | backendC/CleanCompilerSources/codegen1.c | 23 | ||||
| -rw-r--r-- | backendC/CleanCompilerSources/codegen2.c | 47 | ||||
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 35 | ||||
| -rw-r--r-- | frontend/type.icl | 28 |
5 files changed, 122 insertions, 23 deletions
diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl index 23ab64d..73475dd 100644 --- a/backend/backendconvert.icl +++ b/backend/backendconvert.icl @@ -1866,7 +1866,17 @@ where convertExpr (TupleSelect {ds_arity} n expr) = beTupleSelectNode ds_arity n (convertExpr expr) convertExpr (MatchExpr {glob_module, glob_object={ds_index,ds_arity}} expr) - = beMatchNode ds_arity (beConstructorSymbol glob_module ds_index) (convertExpr expr) + | glob_module==cPredefinedModuleIndex + && (let + pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex + in + pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_OverloadedConsSymbol) + = case expr of + App {app_args=[src_expr],app_symb={symb_kind=SK_Function {glob_module=decons_module,glob_object=deconsindex}}} + -> beMatchNode ds_arity (beOverloadedConsSymbol glob_module ds_index decons_module deconsindex) (convertExpr src_expr) + _ + -> convertExpr expr + = beMatchNode ds_arity (beConstructorSymbol glob_module ds_index) (convertExpr expr) convertExpr (Conditional {if_cond=cond, if_then, if_else=Yes else}) = beIfNode (convertExpr cond) (convertExpr if_then) (convertExpr else) diff --git a/backendC/CleanCompilerSources/codegen1.c b/backendC/CleanCompilerSources/codegen1.c index 2ff6fe5..7e20ee0 100644 --- a/backendC/CleanCompilerSources/codegen1.c +++ b/backendC/CleanCompilerSources/codegen1.c @@ -2374,6 +2374,9 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity, if (strict_constructor){ struct arg **rhs_arg_p,*lhs_arg; StateP constructor_arg_state_p; +#if STRICT_LISTS + StateS head_and_tail_states[2]; +#endif lhs_function_arg=NewArgument (constructor_node); lhs_function_arg->arg_state=StrictState; @@ -2381,6 +2384,26 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity, rhs_root=NewNode (TupleSymbol,NULL,constructor_arity); rhs_arg_p=&rhs_root->node_arguments; +#if STRICT_LISTS + if (constructor_symbol->symb_kind==cons_symb && constructor_symbol->symb_head_strictness>1 || constructor_symbol->symb_tail_strictness){ + constructor_symbol->symb_def->sdef_constructor->cl_state_p; + + if (constructor_symbol->symb_head_strictness>1){ + if (constructor_symbol->symb_head_strictness==4) + head_and_tail_states[0]=*constructor_symbol->symb_state_p; + else + head_and_tail_states[0]=StrictState; + } else + head_and_tail_states[0]=LazyState; + + if (constructor_symbol->symb_tail_strictness) + head_and_tail_states[1]=StrictState; + else + head_and_tail_states[1]=LazyState; + + constructor_arg_state_p=head_and_tail_states; + } else +#endif constructor_arg_state_p=constructor_symbol->symb_def->sdef_constructor->cl_state_p; for_l (lhs_arg,constructor_node->node_arguments,arg_next){ diff --git a/backendC/CleanCompilerSources/codegen2.c b/backendC/CleanCompilerSources/codegen2.c index abac86a..00cc491 100644 --- a/backendC/CleanCompilerSources/codegen2.c +++ b/backendC/CleanCompilerSources/codegen2.c @@ -2754,7 +2754,7 @@ LabDef *unboxed_cons_label (SymbolP cons_symbol_p) if (cons_symbol_p->symb_unboxed_cons_state_p->state_type==SimpleState && BETWEEN (IntObj,FileObj,cons_symbol_p->symb_unboxed_cons_state_p->state_object)) return &unboxed_cons_labels[cons_symbol_p->symb_unboxed_cons_state_p->state_object-IntObj][cons_symbol_p->symb_tail_strictness]; else if (cons_symbol_p->symb_unboxed_cons_state_p->state_type==RecordState){ - unboxed_record_cons_lab.lab_mod=NULL; + unboxed_record_cons_lab.lab_mod=ExportLocalLabels ? CurrentModule : NULL; unboxed_record_cons_lab.lab_pref=cons_symbol_p->symb_tail_strictness ? "r_Cons#!" : "r_Cons#"; unboxed_record_cons_lab.lab_issymbol=False; unboxed_record_cons_lab.lab_name=cons_symbol_p->symb_unboxed_cons_state_p->state_record_symbol->sdef_ident->ident_name; @@ -3901,9 +3901,13 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe } } - if (!symbol_arity_eq_one) + if (!symbol_arity_eq_one){ +#if STRICT_LISTS + if (symbol->symb_kind==cons_symb && symbol->symb_head_strictness>1 || symbol->symb_tail_strictness) + strict_constructor=1; +#endif new_match_sdef=create_match_function (symbol,node->node_arity,strict_constructor); - else + } else new_match_sdef=create_select_and_match_function (symbol,strict_constructor); ConvertSymbolToDandNLabel (&name,&codelab,new_match_sdef); @@ -4009,7 +4013,42 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe *bsp_p += b_size; AdjustTuple (a_size,b_size,asp_p,bsp_p,arity,demanded_state_array,constructor_args_state_p,a_size,b_size); - } else { + } else +#if STRICT_LISTS + if (symbol->symb_kind==cons_symb && (symbol->symb_head_strictness>1 || symbol->symb_tail_strictness)){ + StateS head_and_tail_states[2]; + + if (symbol->symb_head_strictness>1){ + if (symbol->symb_head_strictness==4) + head_and_tail_states[0]=*symbol->symb_state_p; + else + head_and_tail_states[0]=StrictState; + } else + head_and_tail_states[0]=LazyState; + + if (symbol->symb_tail_strictness) + head_and_tail_states[1]=StrictState; + else + head_and_tail_states[1]=LazyState; + + if (symbol->symb_head_strictness==4){ + DetermineSizeOfState (head_and_tail_states[0],&a_size,&b_size); + ++a_size; + + GenReplRArgs (a_size,b_size); + *asp_p -= 1-a_size; + *bsp_p += b_size; + + AdjustTuple (a_size,b_size,asp_p,bsp_p,2,demanded_state_array,head_and_tail_states,a_size,b_size); + } else { + GenReplArgs (2,2); + *asp_p -= 1-2; + + AdjustTuple (2,0,asp_p,bsp_p,2,demanded_state_array,head_and_tail_states,2,0); + } + } else +#endif + { *asp_p-=1; UnpackTuple (*asp_p,asp_p,bsp_p,True,demanded_state_arity,demanded_state_array); } diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index c46ae3e..e27a602 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -58,9 +58,9 @@ get_unboxed_list_indices_and_decons_u_ident :: *CheckState -> (!Index,!Index,!In get_unboxed_list_indices_and_decons_u_ident cs=:{cs_predef_symbols,cs_x} # (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def # (cons_u_index,cs_predef_symbols)=cs_predef_symbols![PD_cons_u].pds_def + # (nil_u_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_u].pds_def # (decons_u_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons_u] # decons_u_index=decons_u_symbol.pds_def - # (nil_u_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_u].pds_def # cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists} = (stdStrictLists_index,cons_u_index,decons_u_index,nil_u_index,predefined_idents.[PD_decons_u],cs) @@ -71,18 +71,18 @@ make_unboxed_list type_symbol expr_heap cs # decons_expr = App {app_symb={symb_name=decons_u_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_u_index,glob_module=stdStrictLists_index}},app_args=[],app_info_ptr=new_info_ptr} = (unboxed_list,decons_expr,expr_heap,cs) -get_unboxed_tail_strict_list_indices_and_decons_u_ident :: *CheckState -> (!Index,!Index,!Index,!Index,!Ident,!*CheckState); -get_unboxed_tail_strict_list_indices_and_decons_u_ident cs=:{cs_predef_symbols,cs_x} +get_unboxed_tail_strict_list_indices_and_decons_uts_ident :: *CheckState -> (!Index,!Index,!Index,!Index,!Ident,!*CheckState); +get_unboxed_tail_strict_list_indices_and_decons_uts_ident cs=:{cs_predef_symbols,cs_x} # (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def # (cons_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_cons_uts].pds_def + # (nil_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_uts].pds_def # (decons_uts_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons_uts] # decons_uts_index=decons_uts_symbol.pds_def - # (nil_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_uts].pds_def # cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists} = (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,predefined_idents.[PD_decons_uts],cs) make_unboxed_tail_strict_list type_symbol expr_heap cs - # (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,decons_uts_ident,cs) = get_unboxed_tail_strict_list_indices_and_decons_u_ident cs + # (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,decons_uts_ident,cs) = get_unboxed_tail_strict_list_indices_and_decons_uts_ident cs # unboxed_list=UnboxedTailStrictList type_symbol stdStrictLists_index decons_uts_index nil_uts_index # (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap # decons_expr = App {app_symb={symb_name=decons_uts_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_uts_index,glob_module=stdStrictLists_index}},app_args=[],app_info_ptr=new_info_ptr} @@ -92,9 +92,9 @@ get_overloaded_list_indices_and_decons_ident :: *CheckState -> (!Index,!Index,!I get_overloaded_list_indices_and_decons_ident cs=:{cs_predef_symbols,cs_x} # (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def # (cons_index,cs_predef_symbols)=cs_predef_symbols![PD_cons].pds_def + # (nil_index,cs_predef_symbols)=cs_predef_symbols![PD_nil].pds_def # (decons_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons] # decons_index=decons_symbol.pds_def - # (nil_index,cs_predef_symbols)=cs_predef_symbols![PD_nil].pds_def # cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists} = (stdStrictLists_index,cons_index,decons_index,nil_index,predefined_idents.[PD_decons],cs) @@ -1808,7 +1808,28 @@ transfromPatternIntoBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_mo position var_store expr_heap e_info cs -> (opt_var_bind ++ binds, var_store, expr_heap, e_info, cs) # (tuple_cons, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex ds_arity) PD_PredefinedModule STE_Constructor ds_arity cs - (match_var, match_bind, var_store, expr_heap) + # (src_expr,expr_heap,cs) = add_decons_call_for_overloaded_lists src_expr expr_heap cs + with + add_decons_call_for_overloaded_lists src_expr expr_heap cs + | glob_module==cPredefinedModuleIndex + # pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex + | pd_cons_index==PD_UnboxedConsSymbol + # (stdStrictLists_index,_,decons_u_index,_,decons_u_ident,cs) = get_unboxed_list_indices_and_decons_u_ident cs + # (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap + # decons_u_expr = App {app_symb={symb_name=decons_u_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_u_index,glob_module=stdStrictLists_index}},app_args=[src_expr],app_info_ptr=new_info_ptr} + = (decons_u_expr,expr_heap,cs) + | pd_cons_index==PD_UnboxedTailStrictConsSymbol + # (stdStrictLists_index,_,decons_uts_index,_,decons_uts_ident,cs) = get_unboxed_tail_strict_list_indices_and_decons_uts_ident cs + # (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap + # decons_uts_expr = App {app_symb={symb_name=decons_uts_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_uts_index,glob_module=stdStrictLists_index}},app_args=[src_expr],app_info_ptr=new_info_ptr} + = (decons_uts_expr,expr_heap,cs) + | pd_cons_index==PD_OverloadedConsSymbol + # (stdStrictLists_index,_,decons_index,_,decons_ident,cs) = get_overloaded_list_indices_and_decons_ident cs + # (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap + # decons_expr = App {app_symb={symb_name=decons_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_index,glob_module=stdStrictLists_index}},app_args=[src_expr],app_info_ptr=new_info_ptr} + = (decons_expr,expr_heap,cs) + = (src_expr,expr_heap,cs) + # (match_var, match_bind, var_store, expr_heap) = bind_match_expr (MatchExpr cons_symbol src_expr) opt_var_bind position var_store expr_heap -> transform_sub_patterns mod_index def_level args tuple_cons.glob_object 0 match_var match_bind position var_store expr_heap e_info cs diff --git a/frontend/type.icl b/frontend/type.icl index e5d91ab..ab6f71f 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -1547,17 +1547,23 @@ where attributedBasicType {box=type} ts=:{ts_attr_store} = ({ at_annotation = AN_None, at_attribute = TA_TempVar ts_attr_store, at_type = type}, {ts & ts_attr_store = inc ts_attr_store}) - requirements ti (MatchExpr {glob_object={ds_arity, ds_index},glob_module} expr) (reqs, ts) - # cp = CP_Expression expr - ({tst_result,tst_args,tst_attr_env}, ts) = standardLhsConstructorType cp ds_index glob_module ds_arity ti ts - (e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr (reqs, ts) - reqs = { reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions, - req_type_coercions = [{ tc_demanded = tst_result, tc_offered = e_type, tc_position = cp, tc_coercible = True } : reqs.req_type_coercions ] } - ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr tst_result.at_attribute ts.ts_expr_heap } - | ds_arity<>1 - # tuple_type = MakeTypeSymbIdent { glob_object = PD_Arity2TupleTypeIndex+(ds_arity-2), glob_module = cPredefinedModuleIndex } predefined_idents.[PD_Arity2TupleType+(ds_arity-2)] ds_arity - = ({ at_type = TA tuple_type tst_args, at_attribute = TA_Unique, at_annotation = AN_None }, No, (reqs, ts)) - = ( hd tst_args, No, (reqs, ts)) + requirements ti (MatchExpr {glob_object={ds_arity, ds_index},glob_module} expr) reqs_ts=:(reqs, ts) + | glob_module==cPredefinedModuleIndex + && (let + pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex + in + pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_OverloadedConsSymbol) + = requirements ti expr reqs_ts + # cp = CP_Expression expr + ({tst_result,tst_args,tst_attr_env}, ts) = standardLhsConstructorType cp ds_index glob_module ds_arity ti ts + (e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr (reqs, ts) + reqs = { reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions, + req_type_coercions = [{ tc_demanded = tst_result, tc_offered = e_type, tc_position = cp, tc_coercible = True } : reqs.req_type_coercions ] } + ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr tst_result.at_attribute ts.ts_expr_heap } + | ds_arity<>1 + # tuple_type = MakeTypeSymbIdent { glob_object = PD_Arity2TupleTypeIndex+(ds_arity-2), glob_module = cPredefinedModuleIndex } predefined_idents.[PD_Arity2TupleType+(ds_arity-2)] ds_arity + = ({ at_type = TA tuple_type tst_args, at_attribute = TA_Unique, at_annotation = AN_None }, No, (reqs, ts)) + = ( hd tst_args, No, (reqs, ts)) requirements _ (AnyCodeExpr _ _ _) (reqs, ts) # (fresh_v, ts) = freshAttributedVariable ts |