Commit 5f0679df authored by John van Groningen's avatar John van Groningen
Browse files

add seq

parent f36dcd61
...@@ -583,8 +583,13 @@ BEBindSpecialFunction (BESpecialIdentIndex index, int functionIndex, int moduleI ...@@ -583,8 +583,13 @@ BEBindSpecialFunction (BESpecialIdentIndex index, int functionIndex, int moduleI
Assert ((unsigned int) functionIndex < module->bem_nFunctions); Assert ((unsigned int) functionIndex < module->bem_nFunctions);
functionSymbol = &module->bem_functions [functionIndex]; functionSymbol = &module->bem_functions [functionIndex];
if (functionSymbol->symb_kind == definition) if (functionSymbol->symb_kind == definition){
*gSpecialIdents [index] = functionSymbol->symb_def->sdef_ident; *gSpecialIdents [index] = functionSymbol->symb_def->sdef_ident;
if (index==BESpecialIdentSeq && moduleIndex!=main_dcl_module_n){
functionSymbol->symb_kind=seq_symb;
}
}
} /* BEBindSpecialFunction */ } /* BEBindSpecialFunction */
extern SymbDefP special_types[]; /* defined in statesgen */ extern SymbDefP special_types[]; /* defined in statesgen */
...@@ -3630,7 +3635,6 @@ CheckBEEnumTypes (void) ...@@ -3630,7 +3635,6 @@ CheckBEEnumTypes (void)
Assert (apply_symb == BEApplySymb); Assert (apply_symb == BEApplySymb);
Assert (if_symb == BEIfSymb); Assert (if_symb == BEIfSymb);
Assert (fail_symb == BEFailSymb); Assert (fail_symb == BEFailSymb);
Assert (all_symb == BEAllSymb);
Assert (select_symb == BESelectSymb); Assert (select_symb == BESelectSymb);
Assert (Nr_Of_Predef_FunsOrConses == BENrOfPredefFunsOrConses); Assert (Nr_Of_Predef_FunsOrConses == BENrOfPredefFunsOrConses);
Assert (definition == BEDefinition); Assert (definition == BEDefinition);
...@@ -3787,6 +3791,11 @@ BEInit (int argc) ...@@ -3787,6 +3791,11 @@ BEInit (int argc)
gSpecialIdents [BESpecialIdentAnd] = &AndId; gSpecialIdents [BESpecialIdentAnd] = &AndId;
gSpecialIdents [BESpecialIdentOr] = &OrId; gSpecialIdents [BESpecialIdentOr] = &OrId;
PreludeId = Identifier ("Prelude");
seq_id = NULL;
gSpecialIdents[BESpecialIdentPrelude] = &PreludeId;
gSpecialIdents[BESpecialIdentSeq] = &seq_id;
UserDefinedArrayFunctions = NULL; UserDefinedArrayFunctions = NULL;
#if STRICT_LISTS #if STRICT_LISTS
unboxed_record_cons_list=NULL; unboxed_record_cons_list=NULL;
......
...@@ -166,6 +166,7 @@ Clean (::BESpecialIdentIndex :== Int) ...@@ -166,6 +166,7 @@ Clean (::BESpecialIdentIndex :== Int)
enum { enum {
BESpecialIdentStdMisc, BESpecialIdentAbort, BESpecialIdentUndef, BESpecialIdentStdMisc, BESpecialIdentAbort, BESpecialIdentUndef,
BESpecialIdentStdBool, BESpecialIdentAnd, BESpecialIdentOr, BESpecialIdentStdBool, BESpecialIdentAnd, BESpecialIdentOr,
BESpecialIdentPrelude, BESpecialIdentSeq,
BESpecialIdentCount BESpecialIdentCount
}; };
......
...@@ -13,7 +13,7 @@ SymbolP BasicTypeSymbols [Nr_Of_Basic_Types], ...@@ -13,7 +13,7 @@ SymbolP BasicTypeSymbols [Nr_Of_Basic_Types],
ApplyTypeSymbol, TrueSymbol, FalseSymbol, ApplyTypeSymbol, TrueSymbol, FalseSymbol,
TupleSymbol, ListSymbol, ConsSymbol, NilSymbol, TupleSymbol, ListSymbol, ConsSymbol, NilSymbol,
SelectSymbols [MaxNodeArity], ApplySymbol, IfSymbol, FailSymbol, AllSymbol, SelectSymbols [MaxNodeArity], ApplySymbol, IfSymbol, FailSymbol,
EmptyTypeSymbol, EmptyTypeSymbol,
TupleTypeSymbols [MaxNodeArity]; TupleTypeSymbols [MaxNodeArity];
...@@ -452,11 +452,6 @@ NewRuleAlt (void) ...@@ -452,11 +452,6 @@ NewRuleAlt (void)
return (alt); return (alt);
} /* NewRuleAlt */ } /* NewRuleAlt */
TypeNode NewEmptyTypeNode (void)
{
return NewTypeNode (NoAnnot, NoAttr, EmptyTypeSymbol, NIL, 0);
} /* NewEmptyTypeNode */
struct p_at_node_tree { struct p_at_node_tree {
NodeP annoted_node; NodeP annoted_node;
NodeP at_node; NodeP at_node;
......
...@@ -78,8 +78,6 @@ extern char *CopyString (char *to, char *from, int *rest_size); ...@@ -78,8 +78,6 @@ extern char *CopyString (char *to, char *from, int *rest_size);
extern char BasicTypeIds []; extern char BasicTypeIds [];
#define ConvertBasicTypeToChar(type_symb) BasicTypeIds [(type_symb) -> symb_kind] #define ConvertBasicTypeToChar(type_symb) BasicTypeIds [(type_symb) -> symb_kind]
extern TypeNode NewEmptyTypeNode (void);
extern IdentP DetermineNewSymbolId (char *prefix, TypeNode inst_type, TableKind table); extern IdentP DetermineNewSymbolId (char *prefix, TypeNode inst_type, TableKind table);
extern IdentP gArrayIdents []; extern IdentP gArrayIdents [];
...@@ -88,7 +86,7 @@ extern SymbolP BasicTypeSymbols [], ...@@ -88,7 +86,7 @@ extern SymbolP BasicTypeSymbols [],
ArraySymbols [], ArraySymbols [],
TrueSymbol, FalseSymbol, TupleSymbol, ListSymbol, ConsSymbol, NilSymbol, TrueSymbol, FalseSymbol, TupleSymbol, ListSymbol, ConsSymbol, NilSymbol,
ApplySymbol, ApplyTypeSymbol, SelectSymbols[], ApplySymbol, ApplyTypeSymbol, SelectSymbols[],
FailSymbol, IfSymbol, AllSymbol, EmptyTypeSymbol; FailSymbol, IfSymbol;
#if STRICT_LISTS #if STRICT_LISTS
extern SymbolP extern SymbolP
StrictListSymbol, StrictConsSymbol, StrictNilSymbol, StrictListSymbol, StrictConsSymbol, StrictNilSymbol,
......
...@@ -16,6 +16,7 @@ extern Ident DynamicId; ...@@ -16,6 +16,7 @@ extern Ident DynamicId;
#if SA_RECOGNIZES_ABORT_AND_UNDEF #if SA_RECOGNIZES_ABORT_AND_UNDEF
extern Ident StdMiscId,abort_id,undef_id; extern Ident StdMiscId,abort_id,undef_id;
#endif #endif
extern Ident PreludeId,seq_id,system_seq_id;
extern Symbol StartSymbol, UnboxedArrayClassSymbols [], UnboxedArrayFunctionSymbols []; extern Symbol StartSymbol, UnboxedArrayClassSymbols [], UnboxedArrayFunctionSymbols [];
extern SymbDef scc_dependency_list,ArrayFunctionDefs[], StdArrayAbortDef; extern SymbDef scc_dependency_list,ArrayFunctionDefs[], StdArrayAbortDef;
......
...@@ -110,6 +110,8 @@ Ident AnnotatedId, ListId, TupleId, ConsId, NilId, ApplyId, SelectId, ...@@ -110,6 +110,8 @@ Ident AnnotatedId, ListId, TupleId, ConsId, NilId, ApplyId, SelectId,
Ident StdMiscId,abort_id,undef_id; Ident StdMiscId,abort_id,undef_id;
#endif #endif
Ident PreludeId,seq_id,system_seq_id;
Symbol StartSymbol; Symbol StartSymbol;
SymbDef ArrayFunctionDefs [NoArrayFun],StdArrayAbortDef; SymbDef ArrayFunctionDefs [NoArrayFun],StdArrayAbortDef;
...@@ -203,6 +205,8 @@ void InitChecker (void) ...@@ -203,6 +205,8 @@ void InitChecker (void)
StdMiscId = PutStringInHashTable ("StdMisc",ModuleIdTable); StdMiscId = PutStringInHashTable ("StdMisc",ModuleIdTable);
#endif #endif
system_seq_id = PutStringInHashTable ("seq", SymbolIdTable);
/* Predefined Array functions */ /* Predefined Array functions */
ArrayFunctionIds[CreateArrayFun] = PutStringInHashTable ("createArray", SymbolIdTable); ArrayFunctionIds[CreateArrayFun] = PutStringInHashTable ("createArray", SymbolIdTable);
......
...@@ -51,7 +51,7 @@ char else_symb[] = "else"; ...@@ -51,7 +51,7 @@ char else_symb[] = "else";
char then_symb[] = "then"; char then_symb[] = "then";
char notused_string[] = "notused"; char notused_string[] = "notused";
SymbDef ApplyDef,IfDef; SymbDef ApplyDef,IfDef,SeqDef;
unsigned NewLabelNr,new_not_eq_z_label_n; unsigned NewLabelNr,new_not_eq_z_label_n;
...@@ -3266,6 +3266,58 @@ static void FillNormalNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_i ...@@ -3266,6 +3266,58 @@ static void FillNormalNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_i
} }
return; return;
} }
case seq_symb:
if (node->node_arity==2){
if (IsLazyState (node->node_state)){
FillSymbol (node,SeqDef,asp_p,bsp_p,update_node_id,code_gen_node_ids_p);
} else {
int old_asp,old_bsp;
old_asp=*asp_p;
old_bsp=*bsp_p;
BuildArg (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p);
GenPopA (*asp_p-old_asp);
GenPopA (*bsp_p-old_bsp);
*asp_p=old_asp;
*bsp_p=old_bsp;
if (update_node_id==NULL){
ArgP arg2_arg;
arg2_arg=node->node_arguments->arg_next;
if (arg2_arg->arg_node->node_kind!=NodeIdNode){
Build (arg2_arg->arg_node,asp_p,bsp_p,code_gen_node_ids_p);
} else {
NodeId arg_node_id;
arg_node_id=arg2_arg->arg_node->node_node_id;
#if BOXED_RECORDS
arg_node_id->nid_mark2 |= NID_RECORD_USED_BY_NON_SELECTOR_OR_UPDATES;
#endif
if (CopyNodeIdArgument (arg2_arg->arg_state,arg_node_id,asp_p,bsp_p))
ChangeEvalStatusKindToStrictOnA (arg_node_id,code_gen_node_ids_p->saved_nid_state_l);
decrement_reference_count_of_node_id (arg_node_id,&code_gen_node_ids_p->free_node_ids);
}
} else
FillNodeOnACycle (node->node_arguments->arg_next->arg_node,asp_p,bsp_p,update_node_id,code_gen_node_ids_p);
}
} else {
LabDef name;
ConvertSymbolToConstructorDLabel (&name,SeqDef);
BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p);
if (update_node_id==NULL){
*asp_p+=1-node->node_arity;
GenBuildPartialFunctionh (&name,node->node_arity);
} else {
GenFillh (&name,node->node_arity,*asp_p-update_node_id->nid_a_index,NormalFill);
*asp_p-=node->node_arity;
}
}
return;
default: default:
if (symb->symb_kind<Nr_Of_Basic_Types){ if (symb->symb_kind<Nr_Of_Basic_Types){
if (update_node_id==NULL){ if (update_node_id==NULL){
...@@ -6480,6 +6532,9 @@ void InitCoding (void) ...@@ -6480,6 +6532,9 @@ void InitCoding (void)
IfDef=MakeNewSymbolDefinition ("system", IfId, 3, DEFRULE); IfDef=MakeNewSymbolDefinition ("system", IfId, 3, DEFRULE);
IfDef->sdef_number=0; IfDef->sdef_number=0;
SeqDef=MakeNewSymbolDefinition ("system", system_seq_id, 2, DEFRULE);
SeqDef->sdef_number=0;
InitBasicDescriptor (UnknownObj, "_", SizeOfAStackElem); InitBasicDescriptor (UnknownObj, "_", SizeOfAStackElem);
#if ABSTRACT_OBJECT #if ABSTRACT_OBJECT
InitBasicDescriptor (AbstractObj, "_", SizeOfAStackElem); InitBasicDescriptor (AbstractObj, "_", SizeOfAStackElem);
......
...@@ -102,7 +102,7 @@ void build_and_cleanup (Node node,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen ...@@ -102,7 +102,7 @@ void build_and_cleanup (Node node,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen
#define CONSTRUCTOR_R_PREF k_pref #define CONSTRUCTOR_R_PREF k_pref
extern char *Co_Wtype,*Co_Wspine,else_symb[],then_symb[],notused_string[]; extern char *Co_Wtype,*Co_Wspine,else_symb[],then_symb[],notused_string[];
extern SymbDef ApplyDef,IfDef; extern SymbDef ApplyDef,IfDef,SeqDef;
extern StateS StrictOnAState; extern StateS StrictOnAState;
void FillSelectSymbol (StateKind result_state_kind,int arity,int argnr,Args arg,int *asp_p,int *bsp_p, void FillSelectSymbol (StateKind result_state_kind,int arity,int argnr,Args arg,int *asp_p,int *bsp_p,
......
...@@ -724,6 +724,8 @@ static void CodeRootSelection (Node root, NodeId rootid,int asp,int bsp,CodeGenN ...@@ -724,6 +724,8 @@ static void CodeRootSelection (Node root, NodeId rootid,int asp,int bsp,CodeGenN
} }
} }
static int CodeRootNode (Node root,NodeId rootid,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p,StateS resultstate,struct esc *esc_p);
static int CodeRhsNodeDefsAndRestoreNodeIdStates (Node root_node,NodeDefs defs,int asp,int bsp,StateS resultstate,struct esc *esc_p, static int CodeRhsNodeDefsAndRestoreNodeIdStates (Node root_node,NodeDefs defs,int asp,int bsp,StateS resultstate,struct esc *esc_p,
NodeIdListElementP a_node_ids,NodeIdListElementP b_node_ids, NodeIdListElementP a_node_ids,NodeIdListElementP b_node_ids,
NodeIdListElementP free_node_ids,int doesnt_fail) NodeIdListElementP free_node_ids,int doesnt_fail)
...@@ -972,6 +974,25 @@ static void CodeNormalRootNode (Node root,NodeId rootid,int asp,int bsp,CodeGenN ...@@ -972,6 +974,25 @@ static void CodeNormalRootNode (Node root,NodeId rootid,int asp,int bsp,CodeGenN
} else } else
GenRtn (1,1,resultstate); GenRtn (1,1,resultstate);
return; return;
case seq_symb:
if (root->node_arity==2){
int old_asp,old_bsp;
old_asp=asp;
old_bsp=bsp;
BuildArg (root->node_arguments,&asp,&bsp,code_gen_node_ids_p);
GenPopA (asp-old_asp);
GenPopB (bsp-old_bsp);
/* asp=old_asp; bsp=old_bsp; */
CodeRootNode (root->node_arguments->arg_next->arg_node,rootid,old_asp,old_bsp,code_gen_node_ids_p,resultstate,NULL);
} else {
LabDef name;
ConvertSymbolToDLabel (&name,SeqDef);
FillRhsRoot (&name, root, asp, bsp,code_gen_node_ids_p);
}
return;
default: default:
if (rootsymb->symb_kind < Nr_Of_Basic_Types) if (rootsymb->symb_kind < Nr_Of_Basic_Types)
FillRhsRoot (&BasicDescriptors[rootsymb->symb_kind], root, asp, bsp,code_gen_node_ids_p); FillRhsRoot (&BasicDescriptors[rootsymb->symb_kind], root, asp, bsp,code_gen_node_ids_p);
......
...@@ -193,8 +193,6 @@ InitParser (void) ...@@ -193,8 +193,6 @@ InitParser (void)
ApplySymbol = NewSymbol (apply_symb); ApplySymbol = NewSymbol (apply_symb);
FailSymbol = NewSymbol (fail_symb); FailSymbol = NewSymbol (fail_symb);
AllSymbol = NewSymbol (all_symb);
EmptyTypeSymbol = NewSymbol (empty_type);
clear_p_at_node_tree(); clear_p_at_node_tree();
} /* InitParser */ } /* InitParser */
...@@ -3717,7 +3717,7 @@ void GenSystemImports (void) ...@@ -3717,7 +3717,7 @@ void GenSystemImports (void)
GenImpDesc ("e_system_dAP"); GenImpDesc ("e_system_dAP");
GenImpLab_node_entry ("e_system_nAP","e_system_eaAP"); GenImpLab_node_entry ("e_system_nAP","e_system_eaAP");
GenImpLab ("e_system_sAP"); GenImpLab ("e_system_sAP");
GenImpDesc (nil_lab.lab_name); GenImpDesc (nil_lab.lab_name);
GenImpDesc (cons_lab.lab_name); GenImpDesc (cons_lab.lab_name);
#if STRICT_LISTS #if STRICT_LISTS
...@@ -3743,6 +3743,12 @@ void GenSystemImports (void) ...@@ -3743,6 +3743,12 @@ void GenSystemImports (void)
FPrintF (OutFile,N_PREFIX "%s.%d " EA_PREFIX "%s.%d",glob_selr,selnum,glob_selr,selnum); FPrintF (OutFile,N_PREFIX "%s.%d " EA_PREFIX "%s.%d",glob_selr,selnum,glob_selr,selnum);
} }
#endif #endif
if (SeqDef!=NULL && (SeqDef->sdef_mark & (SDEF_USED_LAZILY_MASK | SDEF_USED_CURRIED_MASK))){
GenImpDesc ("e_system_dseq");
GenImpLab_node_entry ("e_system_nseq","e_system_easeq");
}
GenImpLab ("_driver"); GenImpLab ("_driver");
} }
} }
......
...@@ -3347,6 +3347,15 @@ static void ExamineSymbolApplication (struct node *node) ...@@ -3347,6 +3347,15 @@ static void ExamineSymbolApplication (struct node *node)
symbol->symb_unboxed_cons_sdef_p->sdef_mark |= SDEF_USED_CURRIED_MASK; symbol->symb_unboxed_cons_sdef_p->sdef_mark |= SDEF_USED_CURRIED_MASK;
else if (IsLazyState (node->node_state)) else if (IsLazyState (node->node_state))
symbol->symb_unboxed_cons_sdef_p->sdef_mark |= SDEF_USED_LAZILY_MASK; symbol->symb_unboxed_cons_sdef_p->sdef_mark |= SDEF_USED_LAZILY_MASK;
} else if (symbol->symb_kind==seq_symb){
if (node->node_arity!=2)
SeqDef->sdef_mark |= SDEF_USED_CURRIED_MASK;
else {
if (IsLazyState (node->node_state))
SeqDef->sdef_mark |= SDEF_USED_LAZILY_MASK;
else
SeqDef->sdef_mark |= SDEF_USED_STRICTLY_MASK;
}
} }
return; return;
} }
......
...@@ -2164,7 +2164,9 @@ static void InitNode (Node node) ...@@ -2164,7 +2164,9 @@ static void InitNode (Node node)
static void InitAlternative (RuleAltS *alt) static void InitAlternative (RuleAltS *alt)
{ {
#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS
NodeDefs nds; NodeDefs nds;
#endif
InitNode (alt->alt_lhs_root); InitNode (alt->alt_lhs_root);
...@@ -2337,6 +2339,20 @@ static Exp ConvertNode (Node node, NodeId nid) ...@@ -2337,6 +2339,20 @@ static Exp ConvertNode (Node node, NodeId nid)
} }
break; break;
} }
case seq_symb:
if (node->node_arity==2){
e->e_kind = Dep;
e->e_args = NewExpArgs (2);
e->e_sym = 2;
e->e_args[0] = ConvertNode (node->node_arguments->arg_node,NULL);
e->e_args[1] = ConvertNode (node->node_arguments->arg_next->arg_node,NULL);
if (nid)
nid->nid_exp_ = e;
return e;
}
default: default:
e = & top; e = & top;
if (nid) if (nid)
......
...@@ -2124,6 +2124,17 @@ static Bool NodeInAStrictContext (Node node,StateS demanded_state,int local_scop ...@@ -2124,6 +2124,17 @@ static Bool NodeInAStrictContext (Node node,StateS demanded_state,int local_scop
} }
break; break;
} }
case seq_symb:
node->node_state=demanded_state;
if (node->node_arity==2){
parallel = DetermineStrictArgContext (node->node_arguments,StrictState,local_scope);
parallel = DetermineStrictArgContext (node->node_arguments->arg_next,demanded_state,local_scope);
} else {
if (ShouldDecrRefCount)
DecrRefCountCopiesOfArgs (node->node_arguments IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope));
node->node_state = StrictState;
}
break;
default: default:
if (rootsymb->symb_kind < Nr_Of_Predef_Types){ if (rootsymb->symb_kind < Nr_Of_Predef_Types){
node->node_state = BasicSymbolStates [rootsymb->symb_kind]; node->node_state = BasicSymbolStates [rootsymb->symb_kind];
......
...@@ -72,7 +72,7 @@ typedef enum { ...@@ -72,7 +72,7 @@ typedef enum {
#endif #endif
Nr_Of_Predef_Types, Nr_Of_Predef_Types,
tuple_symb, cons_symb, nil_symb, tuple_symb, cons_symb, nil_symb,
apply_symb, if_symb, fail_symb, all_symb, apply_symb, if_symb, fail_symb, seq_symb,
select_symb, select_symb,
Nr_Of_Predef_FunsOrConses, Nr_Of_Predef_FunsOrConses,
definition, newsymbol, instance_symb, empty_symbol, field_symbol_list, definition, newsymbol, instance_symb, empty_symbol, field_symbol_list,
......
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