Commit c5b5b1a0 authored by John van Groningen's avatar John van Groningen
Browse files

fix code generation for irrefutable matches of constructors with dictionaries.

the frontend of the compiler assumes the MatchNode yields a tuple without dictionaries,
so after adding the dictionaries the tuple selectors select incorrect values.
it would be better to fix this in the frontend, but it is easier in the backend,
therefore the code generator computes the number of dictionaries by subtracting
the arity of the result of the match node from the arity of the constructor,
and pops the dictionaries from the stack.
parent 77961787
......@@ -2448,7 +2448,7 @@ static SymbDef create_match_function_sdef (void)
return match_function_sdef;
}
SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,int strict_constructor)
SymbDef create_match_function (SymbolP constructor_symbol,int result_arity,int n_dictionaries,int strict_constructor)
{
SymbDef match_function_sdef;
Symbol match_function_symbol;
......@@ -2467,7 +2467,7 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,
constructor_node_node_id->nid_refcount=-2;
constructor_node_node_id->nid_node=NULL;
if (strict_constructor){
if (strict_constructor || n_dictionaries!=0){
struct arg **rhs_arg_p,*lhs_arg;
StateP constructor_arg_state_p;
#if STRICT_LISTS
......@@ -2477,27 +2477,29 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,
NodeIdListElementP *last_node_id_p;
ArgP arg1,arg2;
if (strict_constructor){
#if STRICT_LISTS
if (constructor_symbol->symb_kind==cons_symb && (constructor_symbol->symb_head_strictness>1 || constructor_symbol->symb_tail_strictness)){
if (constructor_symbol->symb_head_strictness>1){
if (constructor_symbol->symb_head_strictness==4)
head_and_tail_states[0]=*constructor_symbol->symb_state_p;
if (constructor_symbol->symb_kind==cons_symb && (constructor_symbol->symb_head_strictness>1 || constructor_symbol->symb_tail_strictness)){
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[0]=StrictState;
head_and_tail_states[1]=LazyState;
constructor_arg_state_p=head_and_tail_states;
} 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;
constructor_arg_state_p=constructor_symbol->symb_def->sdef_constructor->cl_state_p;
}
rhs_root=NewNode (TupleSymbol,NULL,constructor_arity);
rhs_root=NewNode (TupleSymbol,NULL,result_arity);
rhs_arg_p=&rhs_root->node_arguments;
arg2=NewArgument (rhs_root);
......@@ -2507,32 +2509,81 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,
push_node=CompAllocType (NodeS);
push_node->node_kind=PushNode;
push_node->node_arity=constructor_arity;
push_node->node_arity=result_arity+n_dictionaries;
push_node->node_arguments=arg1;
push_node->node_record_symbol=constructor_symbol;
push_node->node_number=0; /* if !=0 then unique */
last_node_id_p=&push_node->node_node_ids;
for (n=0; n<constructor_arity; ++n){
struct arg *lhs_arg,*rhs_arg;
struct node_id *arg_node_id;
if (strict_constructor){
for (n=0; n<n_dictionaries; ++n){
struct arg *lhs_arg,*rhs_arg;
struct node_id *arg_node_id;
arg_node_id=NewNodeId (NULL);
arg_node_id->nid_refcount=-2;
arg_node_id->nid_lhs_state_p_=constructor_arg_state_p;
arg_node_id=NewNodeId (NULL);
arg_node_id->nid_refcount=-1;
arg_node_id->nid_lhs_state_p_=constructor_arg_state_p;
rhs_arg=NewArgument (NewNodeIdNode (arg_node_id));
rhs_arg->arg_state=LazyState;
*last_node_id_p=CompAllocType (NodeIdListElementS);
(*last_node_id_p)->nidl_node_id=arg_node_id;
last_node_id_p=&(*last_node_id_p)->nidl_next;
*last_node_id_p=CompAllocType (NodeIdListElementS);
(*last_node_id_p)->nidl_node_id=arg_node_id;
last_node_id_p=&(*last_node_id_p)->nidl_next;
++constructor_arg_state_p;
}
*rhs_arg_p=rhs_arg;
rhs_arg_p=&rhs_arg->arg_next;
for (n=0; n<result_arity; ++n){
struct arg *lhs_arg,*rhs_arg;
struct node_id *arg_node_id;
arg_node_id=NewNodeId (NULL);
arg_node_id->nid_refcount=-2;
arg_node_id->nid_lhs_state_p_=constructor_arg_state_p;
rhs_arg=NewArgument (NewNodeIdNode (arg_node_id));
rhs_arg->arg_state=LazyState;
++constructor_arg_state_p;
*last_node_id_p=CompAllocType (NodeIdListElementS);
(*last_node_id_p)->nidl_node_id=arg_node_id;
last_node_id_p=&(*last_node_id_p)->nidl_next;
*rhs_arg_p=rhs_arg;
rhs_arg_p=&rhs_arg->arg_next;
++constructor_arg_state_p;
}
} else {
for (n=0; n<n_dictionaries; ++n){
struct arg *lhs_arg,*rhs_arg;
struct node_id *arg_node_id;
arg_node_id=NewNodeId (NULL);
arg_node_id->nid_refcount=-1;
arg_node_id->nid_lhs_state_p_=&LazyState;
*last_node_id_p=CompAllocType (NodeIdListElementS);
(*last_node_id_p)->nidl_node_id=arg_node_id;
last_node_id_p=&(*last_node_id_p)->nidl_next;
}
for (n=0; n<result_arity; ++n){
struct arg *lhs_arg,*rhs_arg;
struct node_id *arg_node_id;
arg_node_id=NewNodeId (NULL);
arg_node_id->nid_refcount=-2;
arg_node_id->nid_lhs_state_p_=&LazyState;
rhs_arg=NewArgument (NewNodeIdNode (arg_node_id));
rhs_arg->arg_state=LazyState;
*last_node_id_p=CompAllocType (NodeIdListElementS);
(*last_node_id_p)->nidl_node_id=arg_node_id;
last_node_id_p=&(*last_node_id_p)->nidl_next;
*rhs_arg_p=rhs_arg;
rhs_arg_p=&rhs_arg->arg_next;
}
}
*rhs_arg_p=NULL;
......@@ -2557,7 +2608,7 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,
case_node->node_kind=CaseNode;
case_node->node_symbol=constructor_symbol;
case_node->node_arity=constructor_arity;
case_node->node_arity=result_arity;
case_node->node_arguments=NewArgument (rhs_root);
case_node->node_su.su_u.u_case=CompAllocType (CaseNodeContentsS);
case_node->node_strict_node_ids=NULL;
......@@ -2593,7 +2644,7 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,
return match_function_sdef;
}
SymbDef create_select_and_match_function (SymbolP constructor_symbol,int strict_constructor)
SymbDef create_select_and_match_function (SymbolP constructor_symbol,int n_dictionaries,int strict_constructor)
{
SymbDef match_function_sdef;
Symbol match_function_symbol;
......@@ -2628,20 +2679,47 @@ SymbDef create_select_and_match_function (SymbolP constructor_symbol,int strict_
push_node=CompAllocType (NodeS);
push_node->node_kind=PushNode;
push_node->node_arity=1;
push_node->node_arity=1+n_dictionaries;
push_node->node_arguments=arg1;
push_node->node_record_symbol=constructor_symbol;
push_node->node_number=0; /* if !=0 then unique */
push_node->node_node_ids=CompAllocType (NodeIdListElementS);
push_node->node_node_ids->nidl_node_id=node_id;
push_node->node_node_ids->nidl_next=NULL;
if (n_dictionaries==0){
push_node->node_node_ids=CompAllocType (NodeIdListElementS);
push_node->node_node_ids->nidl_node_id=node_id;
push_node->node_node_ids->nidl_next=NULL;
} else {
NodeIdListElementP *last_node_id_p;
int n;
last_node_id_p=&push_node->node_node_ids;
for (n=0; n<n_dictionaries; ++n){
struct arg *lhs_arg,*rhs_arg;
struct node_id *arg_node_id;
arg_node_id=NewNodeId (NULL);
arg_node_id->nid_refcount=-1;
if (strict_constructor)
arg_node_id->nid_lhs_state_p_=&constructor_symbol->symb_def->sdef_constructor->cl_state_p[n];
else
arg_node_id->nid_lhs_state_p_=&LazyState;
*last_node_id_p=CompAllocType (NodeIdListElementS);
(*last_node_id_p)->nidl_node_id=arg_node_id;
last_node_id_p=&(*last_node_id_p)->nidl_next;
}
*last_node_id_p=CompAllocType (NodeIdListElementS);
(*last_node_id_p)->nidl_node_id=node_id;
(*last_node_id_p)->nidl_next=NULL;
}
lhs_function_arg=NewArgument (NewNodeIdNode (constructor_node_node_id));
lhs_function_arg->arg_state=StrictState;
if (strict_constructor)
node_id->nid_lhs_state_p_=&constructor_symbol->symb_def->sdef_constructor->cl_state_p[0];
node_id->nid_lhs_state_p_=&constructor_symbol->symb_def->sdef_constructor->cl_state_p[n_dictionaries];
else
node_id->nid_lhs_state_p_=&LazyState;
......@@ -2684,12 +2762,23 @@ SymbDef create_select_and_match_function (SymbolP constructor_symbol,int strict_
TypeNode type_node;
StateP lhs_type_root_state_p;
type_node=constructor_symbol->symb_def->sdef_constructor->cl_constructor->type_node_arguments->type_arg_node;
if (n_dictionaries==0)
type_node=constructor_symbol->symb_def->sdef_constructor->cl_constructor->type_node_arguments->type_arg_node;
else {
struct type_arg *type_arg;
int n;
type_arg=constructor_symbol->symb_def->sdef_constructor->cl_constructor->type_node_arguments;
for (n=0; n<n_dictionaries; ++n)
type_arg=type_arg->type_arg_next;
type_node=type_arg->type_arg_node;
}
lhs_type_root_state_p=&match_imp_rule->rule_state_p[-1];
if (!(type_node->type_node_is_var || type_node->type_node_symbol->symb_kind==apply_symb)
&& !IsLazyState (constructor_symbol->symb_def->sdef_constructor->cl_state_p[0]))
&& !IsLazyState (constructor_symbol->symb_def->sdef_constructor->cl_state_p[n_dictionaries]))
{
*lhs_type_root_state_p=constructor_symbol->symb_def->sdef_constructor->cl_state_p[0];
*lhs_type_root_state_p=constructor_symbol->symb_def->sdef_constructor->cl_state_p[n_dictionaries];
} else
lhs_type_root_state_p->state_kind=StrictRedirection;
lhs_root->node_state=*lhs_type_root_state_p;
......
......@@ -115,8 +115,8 @@ extern SymbDef CreateUpdateFunction (ArgS *record_arg,ArgS *first_field_arg,Node
);
extern SymbDef create_select_function (Symbol selector_symbol,int selector_kind);
extern SymbDef create_match_function (struct symbol *constructor_symbol,int constructor_arity,int strict_constructor);
extern SymbDef create_select_and_match_function (struct symbol *constructor_symbol,int strict_constructor);
extern SymbDef create_match_function (struct symbol *constructor_symbol,int result_arity,int n_dictionaries,int strict_constructor);
extern SymbDef create_select_and_match_function (struct symbol *constructor_symbol,int n_dictionaries,int strict_constructor);
extern void ReduceArgumentToHnf (NodeId node_id,StateS state,int offset,struct saved_nid_state **save_states_p);
extern void BindArgs (Args args,int ara,int arb);
......
......@@ -6,9 +6,6 @@
Version: 1.2
*/
#pragma segment codegen2
#pragma options (!macsbug_names)
#define FASTER_STRICT_IF /* also in statesgen.c */
#define DO_LAZY_SELECTORS_FROM_BOXED_STRICT_RECORDS
#define FREE_STRICT_LHS_TUPLE_ELEMENTS 1 /* also in codegen1.c */
......@@ -54,7 +51,7 @@ char notused_string[] = "notused";
SymbDef ApplyDef,IfDef,SeqDef;
unsigned NewLabelNr,new_not_eq_z_label_n;
StateS StrictOnAState;
static StateS UnderEvalState,ProcIdState;
......@@ -4155,19 +4152,25 @@ LabDef selector_m_error_lab = {NULL,"",False,"selector_m_error",0};
void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p)
{
int symbol_arity_eq_one;
int node_arity_eq_one,n_dictionaries;
Symbol symbol;
BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p);
symbol=node->node_symbol;
if (symbol->symb_kind==definition && symbol->symb_def->sdef_kind==CONSTRUCTOR && symbol->symb_def->sdef_arity==1)
symbol_arity_eq_one=1;
else
symbol_arity_eq_one=0;
if (symbol->symb_kind==definition && symbol->symb_def->sdef_kind==CONSTRUCTOR){
n_dictionaries = symbol->symb_def->sdef_arity - node->node_arity;
if (node->node_arity==1)
node_arity_eq_one=1;
else
node_arity_eq_one=0;
} else {
n_dictionaries=0;
node_arity_eq_one=0;
}
if (IsSimpleState (node->node_state) && !(symbol_arity_eq_one && !IsLazyState (node->node_state))){
if (IsSimpleState (node->node_state) && !(node_arity_eq_one && !IsLazyState (node->node_state))){
int n_arguments,strict_constructor;
LabDef name,codelab;
SymbDef new_match_sdef;
......@@ -4178,8 +4181,8 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
if (symbol->symb_def->sdef_strict_constructor)
strict_constructor=1;
else
if (symbol->symb_def->sdef_type->type_nr_of_constructors==1){
if (symbol_arity_eq_one){
if (symbol->symb_def->sdef_type->type_nr_of_constructors==1 && n_dictionaries==0){
if (node_arity_eq_one){
LabDef sellab, nsellab;
BuildLazyTupleSelectorLabel (&nsellab,1,1);
......@@ -4204,14 +4207,14 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
}
}
if (!symbol_arity_eq_one){
if (!node_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);
new_match_sdef=create_match_function (symbol,node->node_arity,n_dictionaries,strict_constructor);
} else
new_match_sdef=create_select_and_match_function (symbol,strict_constructor);
new_match_sdef=create_select_and_match_function (symbol,n_dictionaries,strict_constructor);
ConvertSymbolToDandNLabel (&name,&codelab,new_match_sdef);
......@@ -4295,7 +4298,7 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
#endif
}
if (symbol_arity_eq_one){
if (node_arity_eq_one){
demanded_state_array=&node->node_state;
demanded_state_arity=1;
} else {
......@@ -4316,6 +4319,22 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
*asp_p -= 1-a_size;
*bsp_p += b_size;
if (n_dictionaries!=0){
int dictionaries_asize,dictionaries_bsize;
DetermineSizeOfStates (n_dictionaries,constructor_args_state_p,&dictionaries_asize,&dictionaries_bsize);
GenPopA (dictionaries_asize);
GenPopB (dictionaries_bsize);
*asp_p -= dictionaries_asize;
*bsp_p -= dictionaries_bsize;
a_size-=dictionaries_asize;
b_size-=dictionaries_bsize;
constructor_args_state_p=&constructor_args_state_p[n_dictionaries];
arity-=n_dictionaries;
}
AdjustTuple (a_size,b_size,asp_p,bsp_p,arity,demanded_state_array,constructor_args_state_p,a_size,b_size);
} else
#if STRICT_LISTS
......@@ -4354,7 +4373,38 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
#endif
{
*asp_p-=1;
UnpackTuple (*asp_p,asp_p,bsp_p,True,demanded_state_arity,demanded_state_array);
if (n_dictionaries==0)
UnpackTuple (*asp_p,asp_p,bsp_p,True,demanded_state_arity,demanded_state_array);
else {
int arity,aselmts,oldaframesize,locasp,asize,maxasize;
StateP argstates;
/* untested code, probably not used because dictionaries are strict */
GenReplArgs (symbol->symb_def->sdef_arity,symbol->symb_def->sdef_arity);
GenPopA (n_dictionaries);
arity=demanded_state_arity;
argstates=demanded_state_array;
aselmts = 0;
locasp = arity;
asize = 0;
maxasize = arity;
AddStateSizesAndMaxFrameSizes (arity, argstates, &maxasize, &asize,bsp_p);
InitAStackConversions (maxasize+1, &oldaframesize);
EvaluateAndMoveArguments (arity,argstates,&locasp,&aselmts);
GenAStackConversions (locasp,aselmts);
FreeAFrameSpace (oldaframesize);
*asp_p += aselmts;
}
}
}
}
......
Markdown is supported
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