From 13edf629d3614e4dde7261f5c19f9f44db80509d Mon Sep 17 00:00:00 2001 From: johnvg Date: Thu, 28 Feb 2002 15:39:12 +0000 Subject: compare record states when comparing strictness improve adding arguments to higher order functions git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@1035 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d --- backendC/CleanCompilerSources/statesgen.c | 211 ++++++++++++++++-------------- 1 file changed, 112 insertions(+), 99 deletions(-) (limited to 'backendC') diff --git a/backendC/CleanCompilerSources/statesgen.c b/backendC/CleanCompilerSources/statesgen.c index 8837f33..5615e47 100644 --- a/backendC/CleanCompilerSources/statesgen.c +++ b/backendC/CleanCompilerSources/statesgen.c @@ -96,6 +96,8 @@ int FirstStateIsStricter (StateS offered_state,StateS demanded_state) return 1; else if (offered_state.state_type==ArrayState && demanded_state.state_type==ArrayState) return 1; + else if (offered_state.state_type==RecordState && demanded_state.state_type==RecordState) + return 1; else return 0; } @@ -340,8 +342,6 @@ static void GenRecordState (SymbDef sdef) SetRecordState (&sdef->sdef_record_state, sdef, sdef->sdef_cons_arity); fieldstates=sdef->sdef_record_state.state_record_arguments; -/* rectype->type_constructors->cl_constructor->type_node_state = sdef->sdef_record_state; */ - strict_record=0; for_li (fields,i,rectype->type_fields,fl_next){ @@ -395,7 +395,6 @@ static void GenRecordState (SymbDef sdef) return; else StaticMessage (True, "%S", "%s cyclic strict field dependencies are not allowed", CurrentSymbol, sdef->sdef_ident->ident_name); - } static void GenResultStatesOfLazyFields (SymbDef sdef) @@ -3318,8 +3317,6 @@ static int create_new_function_with_more_arguments (NodeP node_p,int determine_n struct type_node *rhs_type_node_p; SymbolP new_function_symbol; SymbDef rule_sdef; - NodeP function_node_p2; - ArgP *arg_h; int n_extra_function_arguments,n; rule_sdef=function_symbol_p->symb_def; @@ -3348,33 +3345,47 @@ static int create_new_function_with_more_arguments (NodeP node_p,int determine_n node_p->node_symbol=new_function_symbol; } else node_p->node_symbol=function_node_p->node_symbol; - - function_node_p2=node_p->node_arguments->arg_node; - node_p->node_arguments=node_p->node_arguments->arg_next; - - while (function_node_p2!=function_node_p){ - ArgP second_arg_p; - - second_arg_p=function_node_p2->node_arguments->arg_next; - - second_arg_p->arg_next=node_p->node_arguments; - node_p->node_arguments=second_arg_p; - - function_node_p2=function_node_p2->node_arguments->arg_node; - } - - arg_h=&function_node_p->node_arguments; - while (*arg_h!=NULL) - arg_h=&(*arg_h)->arg_next; - - *arg_h=node_p->node_arguments; - node_p->node_arguments=function_node_p->node_arguments; - - node_p->node_arity=function_node_p->node_arity+n_extra_arguments; - - return 1; - } + } else + return 0; + } else + return 0; + /* 26-6-2000: added DEFRULE and SYSRULE case */ + } else if (function_symbol_p->symb_def->sdef_kind==DEFRULE || function_symbol_p->symb_def->sdef_kind==SYSRULE){ + if (function_node_p->node_arity + n_extra_arguments <= function_symbol_p->symb_def->sdef_arity){ + node_p->node_symbol=function_node_p->node_symbol; + } else + return 0; + } else + return 0; + + { + NodeP function_node_p2; + ArgP *arg_h; + + function_node_p2=node_p->node_arguments->arg_node; + node_p->node_arguments=node_p->node_arguments->arg_next; + + while (function_node_p2!=function_node_p){ + ArgP second_arg_p; + + second_arg_p=function_node_p2->node_arguments->arg_next; + + second_arg_p->arg_next=node_p->node_arguments; + node_p->node_arguments=second_arg_p; + + function_node_p2=function_node_p2->node_arguments->arg_node; } + + arg_h=&function_node_p->node_arguments; + while (*arg_h!=NULL) + arg_h=&(*arg_h)->arg_next; + + *arg_h=node_p->node_arguments; + node_p->node_arguments=function_node_p->node_arguments; + + node_p->node_arity=function_node_p->node_arity+n_extra_arguments; + + return 1; } } else if (function_symbol_p->symb_kind==if_symb && function_node_p->node_arity==3){ NodeP apply_node_p; @@ -3672,83 +3683,85 @@ static void CollectSharedAndAnnotatedNodesInRhs (NodeS **root_p,NodeDefS **defs_ while (root_node->node_kind==NormalNode && ((root_node->node_symbol->symb_kind==apply_symb && create_new_function_with_more_arguments (root_node,0)) || (root_node->node_symbol->symb_kind==definition && root_node->node_symbol->symb_def->sdef_kind==IMPRULE))) - { - ImpRuleP imp_rule_p; - - imp_rule_p=root_node->node_symbol->symb_def->sdef_rule; - - if ((imp_rule_p->rule_mark & RULE_LAMBDA_FUNCTION_MASK) && - root_node->node_symbol->symb_def->sdef_arity==root_node->node_arity && - imp_rule_p->rule_alts->alt_next==NULL -# ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS - && ! (imp_rule_p->rule_alts->alt_rhs_root->node_kind==SwitchNode || - imp_rule_p->rule_alts->alt_rhs_root->node_kind==GuardNode || - imp_rule_p->rule_alts->alt_rhs_root->node_kind==IfNode) -# endif - ) - { - ArgP call_arg_p,lhs_arg_p; + { + if (root_node->node_symbol->symb_def->sdef_kind==IMPRULE){ + ImpRuleP imp_rule_p; - for_l (lhs_arg_p,imp_rule_p->rule_alts->alt_lhs_root->node_arguments,arg_next) - if (lhs_arg_p->arg_node->node_kind!=NodeIdNode || - lhs_arg_p->arg_node->node_node_id->nid_refcount==-1 || - lhs_arg_p->arg_node->node_node_id->nid_node!=NULL) - { - break; - } + imp_rule_p=root_node->node_symbol->symb_def->sdef_rule; - if (lhs_arg_p==NULL){ - NodeP new_root_node; -/* - PrintRuleNode (root_node,False,StdOut); - FPrintF (StdOut,"\n"); - PrintRuleAlt (imp_rule_p->rule_alts,StdOut); -*/ - for_ll (call_arg_p,lhs_arg_p,root_node->node_arguments,imp_rule_p->rule_alts->alt_lhs_root->node_arguments,arg_next,arg_next){ - NodeP call_node_p; - NodeIdP lhs_node_id_p,call_node_id_p; - - lhs_node_id_p=lhs_arg_p->arg_node->node_node_id; + if ((imp_rule_p->rule_mark & RULE_LAMBDA_FUNCTION_MASK) && + root_node->node_symbol->symb_def->sdef_arity==root_node->node_arity && + imp_rule_p->rule_alts->alt_next==NULL + # ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + && ! (imp_rule_p->rule_alts->alt_rhs_root->node_kind==SwitchNode || + imp_rule_p->rule_alts->alt_rhs_root->node_kind==GuardNode || + imp_rule_p->rule_alts->alt_rhs_root->node_kind==IfNode) + # endif + ) + { + ArgP call_arg_p,lhs_arg_p; + + for_l (lhs_arg_p,imp_rule_p->rule_alts->alt_lhs_root->node_arguments,arg_next) + if (lhs_arg_p->arg_node->node_kind!=NodeIdNode || + lhs_arg_p->arg_node->node_node_id->nid_refcount==-1 || + lhs_arg_p->arg_node->node_node_id->nid_node!=NULL) + { + break; + } - call_node_p=call_arg_p->arg_node; - if (call_node_p->node_kind==NodeIdNode) - call_node_id_p=call_node_p->node_node_id; - else { - NodeDefP new_node_def_p; + if (lhs_arg_p==NULL){ + NodeP new_root_node; + /* + PrintRuleNode (root_node,False,StdOut); + FPrintF (StdOut,"\n"); + PrintRuleAlt (imp_rule_p->rule_alts,StdOut); + */ + for_ll (call_arg_p,lhs_arg_p,root_node->node_arguments,imp_rule_p->rule_alts->alt_lhs_root->node_arguments,arg_next,arg_next){ + NodeP call_node_p; + NodeIdP lhs_node_id_p,call_node_id_p; - call_node_id_p=NewNodeId (NULL); - call_node_id_p->nid_refcount=1; - call_node_id_p->nid_ref_count_copy_=1; - call_node_id_p->nid_exp_=NULL; - - call_node_id_p->nid_node=call_node_p; + lhs_node_id_p=lhs_arg_p->arg_node->node_node_id; + + call_node_p=call_arg_p->arg_node; + if (call_node_p->node_kind==NodeIdNode) + call_node_id_p=call_node_p->node_node_id; + else { + NodeDefP new_node_def_p; + + call_node_id_p=NewNodeId (NULL); + call_node_id_p->nid_refcount=1; + call_node_id_p->nid_ref_count_copy_=1; + call_node_id_p->nid_exp_=NULL; + + call_node_id_p->nid_node=call_node_p; + + new_node_def_p = NewNodeDef (call_node_id_p,call_node_p); + new_node_def_p->def_next=*defs_p; + *defs_p=new_node_def_p; + } - new_node_def_p = NewNodeDef (call_node_id_p,call_node_p); - new_node_def_p->def_next=*defs_p; - *defs_p=new_node_def_p; + call_node_id_p->nid_mark &= ~SHARED_NODES_COLLECTED_MASK; + if (call_node_id_p->nid_refcount<0) + call_node_id_p->nid_refcount -= -2-lhs_node_id_p->nid_refcount; + else + call_node_id_p->nid_refcount += -2-lhs_node_id_p->nid_refcount; + + lhs_node_id_p->nid_forward_node_id=call_node_id_p; } - call_node_id_p->nid_mark &= ~SHARED_NODES_COLLECTED_MASK; - if (call_node_id_p->nid_refcount<0) - call_node_id_p->nid_refcount -= -2-lhs_node_id_p->nid_refcount; - else - call_node_id_p->nid_refcount += -2-lhs_node_id_p->nid_refcount; - - lhs_node_id_p->nid_forward_node_id=call_node_id_p; - } - - copy_rhs_node_defs_and_root (imp_rule_p->rule_alts,&new_root_node,defs_p); + copy_rhs_node_defs_and_root (imp_rule_p->rule_alts,&new_root_node,defs_p); /* - PrintRuleNode (new_root_node,False,StdOut); - FPrintF (StdOut,"\n"); - PrintNodeDefs (*defs_p,False,StdOut); - FPrintF (StdOut,"\n"); - FPrintF (StdOut,"\n"); + PrintRuleNode (new_root_node,False,StdOut); + FPrintF (StdOut,"\n"); + PrintNodeDefs (*defs_p,False,StdOut); + FPrintF (StdOut,"\n"); + FPrintF (StdOut,"\n"); */ - root_node=new_root_node; - *root_p=new_root_node; - - continue; + root_node=new_root_node; + *root_p=new_root_node; + + continue; + } } } break; -- cgit v1.2.3