Commit 81e9fe7f authored by John van Groningen's avatar John van Groningen

implement (and fix) just constructor selections

parent 2715690e
......@@ -2236,10 +2236,9 @@ where
= beTupleSelectNode ds_arity n (convertExpr expr)
convertExpr (MatchExpr {glob_module, glob_object={ds_index,ds_arity}} 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)
&& (let pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex in
pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_OverloadedConsSymbol ||
pd_cons_index==PD_UnboxedJustSymbol || pd_cons_index==PD_OverloadedJustSymbol)
= 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)
......
......@@ -2923,15 +2923,6 @@ SymbDef create_match_function (SymbolP constructor_symbol,int result_arity,int n
constructor_arg_state_p=head_and_tail_states;
} else
#endif
if (constructor_symbol->symb_kind==just_symb && constructor_symbol->symb_head_strictness>OVERLOADED_CONS){
if (constructor_symbol->symb_head_strictness==UNBOXED_CONS)
head_and_tail_states[0]=*constructor_symbol->symb_state_p;
else
head_and_tail_states[0]=StrictState;
constructor_arg_state_p=head_and_tail_states;
} else
constructor_arg_state_p=constructor_symbol->symb_def->sdef_constructor->cl_state_p;
}
......@@ -3152,9 +3143,15 @@ SymbDef create_select_and_match_function (SymbolP constructor_symbol,int n_dicti
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[n_dictionaries];
else
if (strict_constructor){
if (constructor_symbol->symb_kind==just_symb){
if (constructor_symbol->symb_head_strictness==UNBOXED_CONS)
node_id->nid_lhs_state_p_=constructor_symbol->symb_state_p;
else
node_id->nid_lhs_state_p_=&StrictState;
} else
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;
rhs_root=push_node;
......@@ -3195,26 +3192,38 @@ SymbDef create_select_and_match_function (SymbolP constructor_symbol,int n_dicti
{
TypeNode type_node;
StateP lhs_type_root_state_p;
if (n_dictionaries==0)
type_node=constructor_symbol->symb_def->sdef_constructor->cl_constructor_arguments->type_arg_node;
else {
struct type_arg *type_arg;
int n;
type_arg=constructor_symbol->symb_def->sdef_constructor->cl_constructor_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->ts_kind==apply_type_symb)
&& !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[n_dictionaries];
} else
lhs_type_root_state_p->state_kind=StrictRedirection;
if (constructor_symbol->symb_kind==just_symb){
if (strict_constructor){
if (constructor_symbol->symb_head_strictness==UNBOXED_CONS)
*lhs_type_root_state_p=*constructor_symbol->symb_state_p;
else
*lhs_type_root_state_p=StrictState;
} else
lhs_type_root_state_p->state_kind=StrictRedirection;
} else {
if (n_dictionaries==0)
type_node=constructor_symbol->symb_def->sdef_constructor->cl_constructor_arguments->type_arg_node;
else {
struct type_arg *type_arg;
int n;
type_arg=constructor_symbol->symb_def->sdef_constructor->cl_constructor_arguments;
for (n=0; n<n_dictionaries; ++n)
type_arg=type_arg->type_arg_next;
type_node=type_arg->type_arg_node;
}
if (!(type_node->type_node_is_var || type_node->type_node_symbol->ts_kind==apply_type_symb)
&& !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[n_dictionaries];
} else
lhs_type_root_state_p->state_kind=StrictRedirection;
}
lhs_root->node_state=*lhs_type_root_state_p;
if (IsSimpleState (*lhs_type_root_state_p)){
......
......@@ -3397,7 +3397,7 @@ static int lazy_fill_for_cons_in_lazy_context (Node node)
NodeP arg_node_p;
StateP element_state_p;
if (symb->symb_head_strictness==4)
if (symb->symb_head_strictness==UNBOXED_CONS)
element_state_p=symb->symb_unboxed_cons_state_p;
else
element_state_p=&StrictState;
......@@ -3440,7 +3440,7 @@ static int lazy_fill_for_just_in_lazy_context (Node node)
if (IsLazyState (arg_node_p->node_node_id->nid_state))
return 1;
if (symb->symb_head_strictness==4)
if (symb->symb_head_strictness==UNBOXED_CONS)
element_state_p=symb->symb_unboxed_cons_state_p;
else
element_state_p=&StrictState;
......@@ -3501,7 +3501,7 @@ static void FillNormalNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_i
case cons_symb:
#if STRICT_LISTS
if (symb->symb_head_strictness>1 || symb->symb_tail_strictness){
if (symb->symb_head_strictness==4 && node->node_arity<2){
if (symb->symb_head_strictness==UNBOXED_CONS && node->node_arity<2){
FillSymbol (node,symb->symb_unboxed_cons_sdef_p,asp_p,bsp_p,update_node_id,code_gen_node_ids_p);
return;
} else {
......@@ -3516,7 +3516,7 @@ static void FillNormalNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_i
BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p);
if (symb->symb_head_strictness==4){
if (symb->symb_head_strictness==UNBOXED_CONS){
if (lazy_fill){
MakeSymbolLabel (&strict_cons_lab,symb->symb_unboxed_cons_sdef_p->sdef_module,d_pref,symb->symb_unboxed_cons_sdef_p,0);
strict_cons_lab_p=&strict_cons_lab;
......@@ -3553,12 +3553,12 @@ static void FillNormalNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_i
} else {
if (update_node_id==NULL){
*asp_p+=1-a_size;
if (symb->symb_head_strictness==4)
if (symb->symb_head_strictness==UNBOXED_CONS)
GenBuildhr (strict_cons_lab_p,a_size,b_size);
else
GenBuildh (node->node_arity==2 ? &cons_lab : strict_cons_lab_p,a_size);
} else {
if (symb->symb_head_strictness==4)
if (symb->symb_head_strictness==UNBOXED_CONS)
GenFillR (strict_cons_lab_p,a_size,b_size,*asp_p-update_node_id->nid_a_index,0,0,node->node_state.state_kind==SemiStrict ? ReleaseAndFill : NormalFill,True);
else
GenFillh (node->node_arity==2 ? &cons_lab : strict_cons_lab_p,a_size,*asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? ReleaseAndFill : NormalFill);
......@@ -3597,7 +3597,7 @@ static void FillNormalNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_i
return;
case just_symb:
if (symb->symb_head_strictness>1){
if (symb->symb_head_strictness==4 && node->node_arity<1){
if (symb->symb_head_strictness==UNBOXED_CONS && node->node_arity<1){
FillSymbol (node,symb->symb_unboxed_cons_sdef_p,asp_p,bsp_p,update_node_id,code_gen_node_ids_p);
return;
} else {
......@@ -3612,7 +3612,7 @@ static void FillNormalNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_i
BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p);
if (symb->symb_head_strictness==4){
if (symb->symb_head_strictness==UNBOXED_CONS){
if (lazy_fill){
MakeSymbolLabel (&strict_just_lab,symb->symb_unboxed_cons_sdef_p->sdef_module,d_pref,symb->symb_unboxed_cons_sdef_p,0);
strict_just_lab_p=&strict_just_lab;
......@@ -3643,12 +3643,12 @@ static void FillNormalNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_i
} else {
if (update_node_id==NULL){
*asp_p+=1-a_size;
if (symb->symb_head_strictness==4)
if (symb->symb_head_strictness==UNBOXED_CONS)
GenBuildhr (strict_just_lab_p,a_size,b_size);
else
GenBuildh (node->node_arity==1 ? &just_lab : strict_just_lab_p,a_size);
} else {
if (symb->symb_head_strictness==4)
if (symb->symb_head_strictness==UNBOXED_CONS)
GenFillR (strict_just_lab_p,a_size,b_size,*asp_p-update_node_id->nid_a_index,0,0,node->node_state.state_kind==SemiStrict ? ReleaseAndFill : NormalFill,True);
else
GenFillh (node->node_arity==1 ? &just_lab : strict_just_lab_p,a_size,*asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? ReleaseAndFill : NormalFill);
......@@ -4663,7 +4663,7 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
#endif
new_match_sdef=create_match_function (symbol,node->node_arity,n_dictionaries,strict_constructor);
} else {
if (symbol->symb_kind==just_symb && symbol->symb_head_strictness>1)
if (symbol->symb_kind==just_symb && symbol->symb_head_strictness>OVERLOADED_CONS)
strict_constructor=1;
new_match_sdef=create_select_and_match_function (symbol,n_dictionaries,strict_constructor);
}
......@@ -4700,7 +4700,7 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
switch (symbol->symb_kind){
case cons_symb:
#if STRICT_LISTS
if (symbol->symb_head_strictness==1 || symbol->symb_head_strictness>=3){
if (symbol->symb_head_strictness==OVERLOADED_CONS || symbol->symb_head_strictness>=UNBOXED_OVERLOADED_CONS){
GenEqDesc (&nil_lab,0,0);
GenNotB();
} else
......@@ -4708,7 +4708,7 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
GenEqDesc (&cons_lab,2,0);
break;
case just_symb:
if (symbol->symb_head_strictness==1){
if (symbol->symb_head_strictness==OVERLOADED_CONS || symbol->symb_head_strictness>=UNBOXED_OVERLOADED_CONS){
GenEqDesc (&nothing_lab,0,0);
GenNotB();
} else
......@@ -4797,11 +4797,11 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
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
if (symbol->symb_kind==cons_symb && (symbol->symb_head_strictness>1 || symbol->symb_tail_strictness)){
if (symbol->symb_kind==cons_symb && (symbol->symb_head_strictness>OVERLOADED_CONS || symbol->symb_tail_strictness)){
StateS head_and_tail_states[2];
if (symbol->symb_head_strictness>1){
if (symbol->symb_head_strictness==4)
if (symbol->symb_head_strictness>OVERLOADED_CONS){
if (symbol->symb_head_strictness==UNBOXED_CONS)
head_and_tail_states[0]=*symbol->symb_state_p;
else
head_and_tail_states[0]=StrictState;
......@@ -4813,7 +4813,7 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
else
head_and_tail_states[1]=LazyState;
if (symbol->symb_head_strictness==4){
if (symbol->symb_head_strictness==UNBOXED_CONS){
DetermineSizeOfState (head_and_tail_states[0],&a_size,&b_size);
++a_size;
......@@ -4830,20 +4830,21 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
}
} else
#endif
if (symbol->symb_kind==just_symb && symbol->symb_head_strictness>1){
if (symbol->symb_kind==just_symb && symbol->symb_head_strictness>OVERLOADED_CONS){
StateS value_state;
if (symbol->symb_head_strictness==4){
if (symbol->symb_head_strictness==UNBOXED_CONS){
value_state=*symbol->symb_state_p;
DetermineSizeOfState (value_state,&a_size,&b_size);
GenReplRArgs (a_size,b_size);
*asp_p += a_size;
*asp_p += a_size-1;
*bsp_p += b_size;
AdjustTuple (a_size,b_size,asp_p,bsp_p,1,demanded_state_array,&value_state,a_size,b_size);
} else {
GenReplArg (1,0);
GenReplArg (1,1);
*asp_p -= 1;
value_state=StrictState;
AdjustTuple (1,0,asp_p,bsp_p,1,demanded_state_array,&value_state,1,0);
......
......@@ -3914,7 +3914,7 @@ static void ExamineSymbolApplication (struct node *node)
symbol=node->node_symbol;
if (symbol->symb_kind!=definition){
if (symbol->symb_kind==cons_symb && symbol->symb_head_strictness==4){
if (symbol->symb_kind==cons_symb && symbol->symb_head_strictness==UNBOXED_CONS){
if (node->node_arity<2)
symbol->symb_unboxed_cons_sdef_p->sdef_mark |= SDEF_USED_CURRIED_MASK;
else {
......@@ -3935,8 +3935,8 @@ static void ExamineSymbolApplication (struct node *node)
unboxed_cons_array_mark |= mark;
}
}
} else if (symbol->symb_kind==just_symb && symbol->symb_head_strictness==4){
if (node->node_arity<2)
} else if (symbol->symb_kind==just_symb && symbol->symb_head_strictness==UNBOXED_CONS){
if (node->node_arity<1)
symbol->symb_unboxed_cons_sdef_p->sdef_mark |= SDEF_USED_CURRIED_MASK;
else {
StateP unboxed_cons_state_p;
......
......@@ -2561,8 +2561,8 @@ static Exp ConvertNode (Node node, NodeId nid)
Symbol symbol;
symbol=node->node_symbol;
if (symbol->symb_kind==definition && symbol->symb_def->sdef_kind==CONSTRUCTOR &&
symbol->symb_def->sdef_arity==1)
if ((symbol->symb_kind==definition && symbol->symb_def->sdef_kind==CONSTRUCTOR && symbol->symb_def->sdef_arity==1) ||
symbol->symb_kind==just_symb)
{
Exp selexp;
......
......@@ -111,18 +111,18 @@ make_overloaded_list expr_heap cs
# overloaded_list=OverloadedList stdStrictLists_index decons_index nil_index
= (overloaded_list,decons_expr,expr_heap,cs)
get_unboxed_maybe_indices_and_decons_u_symb_ident :: *CheckState -> (!Index,!Index,!Index,!SymbIdent,!*CheckState)
get_unboxed_maybe_indices_and_decons_u_symb_ident cs=:{cs_predef_symbols,cs_x}
get_unboxed_maybe_indices_and_from_just_u_symb_ident :: *CheckState -> (!Index,!Index,!Index,!SymbIdent,!*CheckState)
get_unboxed_maybe_indices_and_from_just_u_symb_ident cs=:{cs_predef_symbols,cs_x}
# (stdStrictMaybes_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictMaybes].pds_def
(nothing_u_index,cs_predef_symbols)=cs_predef_symbols![PD_nothing_u].pds_def
(from_just_u_index,cs_predef_symbols)=cs_predef_symbols![PD_from_just_u].pds_def
decons_u_ident = predefined_idents.[PD_from_just_u]
app_symb = {symb_ident=decons_u_ident,symb_kind=SK_OverloadedFunction {glob_object=from_just_u_index,glob_module=stdStrictMaybes_index}}
from_just_u_ident = predefined_idents.[PD_from_just_u]
app_symb = {symb_ident=from_just_u_ident,symb_kind=SK_OverloadedFunction {glob_object=from_just_u_index,glob_module=stdStrictMaybes_index}}
cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictMaybes
= (stdStrictMaybes_index,from_just_u_index,nothing_u_index,app_symb,cs)
make_unboxed_maybe expr_heap cs
# (stdStrictMaybes_index,from_just_u_index,nothing_u_index,app_symb,cs) = get_unboxed_maybe_indices_and_decons_u_symb_ident cs
# (stdStrictMaybes_index,from_just_u_index,nothing_u_index,app_symb,cs) = get_unboxed_maybe_indices_and_from_just_u_symb_ident cs
# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
# decons_expr = App {app_symb=app_symb,app_args=[],app_info_ptr=new_info_ptr}
# unboxed_maybe=UnboxedMaybe stdStrictMaybes_index from_just_u_index nothing_u_index
......@@ -2247,6 +2247,7 @@ transfromPatternIntoBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_mo
record_var record_bind position var_store expr_heap e_info cs
_
| ds_arity == 1
# (src_expr,expr_heap,cs) = add_from_just_call_for_overloaded_maybe glob_module ds_index src_expr expr_heap cs
# (binds, var_store, expr_heap, e_info, cs)
= transfromPatternIntoBind mod_index def_level (hd args) (MatchExpr cons_symbol src_expr)
position var_store expr_heap e_info cs
......@@ -2292,6 +2293,7 @@ transfromPatternIntoStrictBind mod_index def_level (AP_Algebraic cons_symbol=:{g
-> (lazy_binds,src_bind,var_store,expr_heap,e_info,cs)
_
| ds_arity == 1
# (src_expr,expr_heap,cs) = add_from_just_call_for_overloaded_maybe glob_module ds_index src_expr expr_heap cs
# (binds, var_store, expr_heap, e_info, cs)
= transfromPatternIntoBind mod_index def_level (hd args) (MatchExpr cons_symbol src_expr)
position var_store expr_heap e_info cs
......@@ -2388,6 +2390,7 @@ adjust_match_expression (Var var) expr_heap
adjust_match_expression match_expr expr_heap
= (match_expr, expr_heap)
add_decons_call_for_overloaded_lists :: !Int !Int !Expression !*ExpressionHeap !*CheckState -> (!Expression,!*ExpressionHeap,!*CheckState)
add_decons_call_for_overloaded_lists glob_module ds_index src_expr expr_heap cs
| glob_module==cPredefinedModuleIndex
# pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex
......@@ -2406,8 +2409,15 @@ add_decons_call_for_overloaded_lists glob_module ds_index src_expr expr_heap cs
# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
# decons_expr = App {app_symb=app_symb,app_args=[src_expr],app_info_ptr=new_info_ptr}
= (decons_expr,expr_heap,cs)
= (src_expr,expr_heap,cs)
= (src_expr,expr_heap,cs)
add_from_just_call_for_overloaded_maybe :: !Int !Int !Expression !*ExpressionHeap !*CheckState -> (!Expression,!*ExpressionHeap,!*CheckState)
add_from_just_call_for_overloaded_maybe glob_module ds_index src_expr expr_heap cs
| glob_module==cPredefinedModuleIndex
# pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex
| pd_cons_index==PD_UnboxedJustSymbol
# (_,_,_,app_symb,cs) = get_unboxed_maybe_indices_and_decons_u_symb_ident cs
# (_,_,_,app_symb,cs) = get_unboxed_maybe_indices_and_from_just_u_symb_ident cs
# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
# decons_u_expr = App {app_symb=app_symb,app_args=[src_expr],app_info_ptr=new_info_ptr}
= (decons_u_expr,expr_heap,cs)
......
......@@ -2233,10 +2233,10 @@ where
requirements ti (MatchExpr {glob_object={ds_arity,ds_index,ds_ident},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)
&& (let pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex in
pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_OverloadedConsSymbol ||
pd_cons_index==PD_UnboxedJustSymbol || pd_cons_index==PD_OverloadedJustSymbol)
// expr is a decons or from_just
= requirements ti expr reqs_ts
# cp = CP_Expression expr
({tst_result,tst_args,tst_attr_env}, ts) = standardLhsConstructorType cp ds_index glob_module ti ts
......
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