diff options
Diffstat (limited to 'backendC/CleanCompilerSources')
19 files changed, 1136 insertions, 384 deletions
diff --git a/backendC/CleanCompilerSources/backend.c b/backendC/CleanCompilerSources/backend.c index ae4c7f1..8a77f8f 100644 --- a/backendC/CleanCompilerSources/backend.c +++ b/backendC/CleanCompilerSources/backend.c @@ -41,6 +41,9 @@ BEGetVersion (int *current, int *oldestDefinition, int *oldestImplementation) *oldestImplementation = kBEVersionOldestImplementation; } +#if STRICT_LISTS + PolyList unboxed_record_cons_list,unboxed_record_decons_list; +#endif extern PolyList UserDefinedArrayFunctions; /* typechecker.c */ extern StdOutReopened, StdErrorReopened; /* cocl.c */ @@ -494,10 +497,11 @@ BEFunctionSymbol (int functionIndex, int moduleIndex) Assert ((unsigned int) functionIndex < module->bem_nFunctions); functionSymbol = &module->bem_functions [functionIndex]; - Assert (functionSymbol->symb_kind == definition + Assert (functionSymbol->symb_kind == definition || functionSymbol->symb_kind == cons_symb || functionSymbol->symb_kind == nil_symb || (moduleIndex == kPredefinedModuleIndex && functionSymbol->symb_kind != erroneous_symb)); - functionSymbol->symb_def->sdef_isused = True; + if (functionSymbol->symb_kind!=cons_symb && functionSymbol->symb_kind!=nil_symb) + functionSymbol->symb_def->sdef_isused = True; return (functionSymbol); } /* BEFunctionSymbol */ @@ -978,10 +982,10 @@ BEConstructorSymbol (int constructorIndex, int moduleIndex) if (constructorSymbol->symb_kind == erroneous_symb) return (constructorSymbol); - Assert (constructorSymbol->symb_kind == definition + Assert (constructorSymbol->symb_kind == definition || constructorSymbol->symb_kind == cons_symb || (moduleIndex == kPredefinedModuleIndex && constructorSymbol->symb_kind != erroneous_symb)); - if (moduleIndex != kPredefinedModuleIndex) + if (moduleIndex != kPredefinedModuleIndex && constructorSymbol->symb_kind!=cons_symb) constructorSymbol->symb_def->sdef_isused = True; return (constructorSymbol); @@ -1036,8 +1040,14 @@ BELiteralSymbol (BESymbKind kind, CleanString value) return (symbol); } /* BELiteralSymbol */ +# define nid_ref_count_sign nid_scope + #if STRICT_LISTS -void BEPredefineListConstructorSymbol(int arity,int constructorIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness) +static SymbolS unboxed_list_symbols[Nr_Of_Predef_Types][2]; + +static SymbolP strict_list_cons_symbols[8]; + +void BEPredefineListConstructorSymbol (int constructorIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness) { BEModuleP module; SymbolP symbol_p; @@ -1045,21 +1055,21 @@ void BEPredefineListConstructorSymbol(int arity,int constructorIndex,int moduleI Assert (moduleIndex == kPredefinedModuleIndex); Assert ((unsigned int) moduleIndex < gBEState.be_nModules); - module = &gBEState.be_modules [moduleIndex]; + module = &gBEState.be_modules [moduleIndex]; Assert ((unsigned int) constructorIndex < module->bem_nConstructors); symbol_p=module->bem_constructors [constructorIndex]; - - Assert (symbol_p->symb_kind == erroneous_symb); symbol_p->symb_kind = symbolKind; - symbol_p->symb_arity = arity; symbol_p->symb_head_strictness=head_strictness; symbol_p->symb_tail_strictness=tail_strictness; + + if (symbolKind==BEConsSymb && head_strictness<4) + strict_list_cons_symbols[(head_strictness<<1)+tail_strictness]=symbol_p; } -void BEPredefineListTypeSymbol(int typeIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness) +void BEPredefineListTypeSymbol (int typeIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness) { BEModuleP module; SymbolP symbol_p; @@ -1067,19 +1077,207 @@ void BEPredefineListTypeSymbol(int typeIndex,int moduleIndex,BESymbKind symbolKi Assert (moduleIndex == kPredefinedModuleIndex); Assert ((unsigned int) moduleIndex < gBEState.be_nModules); - module = &gBEState.be_modules [moduleIndex]; + module = &gBEState.be_modules [moduleIndex]; Assert ((unsigned int) typeIndex < module->bem_nTypes); symbol_p=module->bem_types [typeIndex]; - Assert (symbol_p->symb_kind == erroneous_symb); - - symbol_p->symb_kind = symbolKind; - symbol_p->symb_arity = 1; + symbol_p->symb_kind = symbolKind; + symbol_p->symb_arity = 1; symbol_p->symb_head_strictness=head_strictness; symbol_p->symb_tail_strictness=tail_strictness; } + +void BEAdjustStrictListConsInstance (int functionIndex,int moduleIndex) +{ + SymbolP symbol_p; + + symbol_p=&gBEState.be_modules[moduleIndex].bem_functions[functionIndex]; + + if (symbol_p->symb_kind==definition){ + TypeNode element_type_p,list_type_p; + SymbDef sdef; + TypeArgs type_args_p; + + sdef=symbol_p->symb_def; + type_args_p=sdef->sdef_rule_type->rule_type_rule->type_alt_lhs->type_node_arguments; + element_type_p=type_args_p->type_arg_node; + list_type_p=type_args_p->type_arg_next->type_arg_node; + + Assert (list_type_p->type_node_is_var==0); + Assert (list_type_p->type_node_symbol->symb_kind==list_type); + + symbol_p->symb_head_strictness=list_type_p->type_node_symbol->symb_head_strictness; + symbol_p->symb_tail_strictness=list_type_p->type_node_symbol->symb_tail_strictness; + + if (list_type_p->type_node_symbol->symb_head_strictness==3){ + int element_symbol_kind; + struct unboxed_cons *unboxed_cons_p; + + Assert (element_type_p->type_node_is_var==0); + + element_symbol_kind=element_type_p->type_node_symbol->symb_kind; + + symbol_p->symb_head_strictness=4; + + unboxed_cons_p=ConvertAllocType (struct unboxed_cons); + + unboxed_cons_p->unboxed_cons_sdef_p=sdef; + + if (element_symbol_kind < Nr_Of_Predef_Types) + unboxed_cons_p->unboxed_cons_state_p = unboxed_list_symbols[element_symbol_kind][symbol_p->symb_tail_strictness].symb_state_p; + else if (element_symbol_kind==definition && element_type_p->type_node_symbol->symb_def->sdef_kind==RECORDTYPE){ + PolyList new_unboxed_record_cons_element; + SymbDef record_sdef; + + record_sdef=element_type_p->type_node_symbol->symb_def; + record_sdef->sdef_isused=True; + sdef->sdef_isused=True; + unboxed_cons_p->unboxed_cons_state_p = &record_sdef->sdef_record_state; + + new_unboxed_record_cons_element=ConvertAllocType (struct poly_list); + new_unboxed_record_cons_element->pl_elem = sdef; + new_unboxed_record_cons_element->pl_next = unboxed_record_cons_list; + unboxed_record_cons_list = new_unboxed_record_cons_element; + + sdef->sdef_module=NULL; + } else + unboxed_cons_p->unboxed_cons_state_p = &StrictState; + + symbol_p->symb_unboxed_cons_p=unboxed_cons_p; + } + } else { + Assert (symbol_p->symb_kind==definition); + + debug_message ("BEAdjustStrictListInstance: !(symbol_p->symb_kind==definition) %d %d %d\n",functionIndex,moduleIndex,symbol_p->symb_kind); + + symbol_p->symb_head_strictness=0; + symbol_p->symb_tail_strictness=0; + } + + symbol_p->symb_kind = cons_symb; + /* symbol_p->symb_arity = 2; no symb_arity for cons_symb, because symb_state_p is used of this union */ +} + +void BEAdjustUnboxedListDeconsInstance (int functionIndex,int moduleIndex) +{ + SymbolP symbol_p,cons_symbol_p; + SymbDefP sdef_p; + TypeNode element_type_p,list_type_p; + PolyList new_unboxed_record_decons_element; + + symbol_p=&gBEState.be_modules[moduleIndex].bem_functions[functionIndex]; + + Assert (symbol_p->symb_kind==definition); + sdef_p=symbol_p->symb_def; + + list_type_p=sdef_p->sdef_rule_type->rule_type_rule->type_alt_lhs->type_node_arguments->type_arg_node; + element_type_p=list_type_p->type_node_arguments->type_arg_node; + + Assert (list_type_p->type_node_is_var==0); + Assert (list_type_p->type_node_symbol->symb_kind==list_type); + Assert (list_type_p->type_node_symbol->symb_head_strictness==3); + Assert (element_type_p->type_node_symbol->symb_def->sdef_kind==RECORDTYPE); + + cons_symbol_p=ConvertAllocType (SymbolS); + + cons_symbol_p->symb_kind = cons_symb; + cons_symbol_p->symb_head_strictness=4; + cons_symbol_p->symb_tail_strictness=list_type_p->type_node_symbol->symb_tail_strictness; + cons_symbol_p->symb_state_p=&element_type_p->type_node_symbol->symb_def->sdef_record_state; + + sdef_p->sdef_unboxed_cons_symbol=cons_symbol_p; + + new_unboxed_record_decons_element=ConvertAllocType (struct poly_list); + new_unboxed_record_decons_element->pl_elem = sdef_p; + new_unboxed_record_decons_element->pl_next = unboxed_record_decons_list; + unboxed_record_decons_list = new_unboxed_record_decons_element; +} + +void BEAdjustOverloadedNilFunction (int functionIndex,int moduleIndex) +{ + SymbolP symbol_p; + + symbol_p=&gBEState.be_modules[moduleIndex].bem_functions[functionIndex]; + + symbol_p->symb_head_strictness=1; + symbol_p->symb_tail_strictness=0; + + symbol_p->symb_kind = nil_symb; +} + +BESymbolP BEOverloadedConsSymbol (int constructorIndex,int moduleIndex,int deconsIndex,int deconsModuleIndex) +{ + BEModuleP module,decons_module; + SymbolP constructor_symbol,decons_symbol,list_type_symbol; + TypeNode list_type,element_type; + + Assert ((unsigned int) deconsModuleIndex < gBEState.be_nModules); + decons_module = &gBEState.be_modules [deconsModuleIndex]; + + Assert ((unsigned int) deconsIndex < decons_module->bem_nFunctions); + decons_symbol = &decons_module->bem_functions [deconsIndex]; + + Assert (decons_symbol->symb_kind==definition); + + list_type=decons_symbol->symb_def->sdef_rule_type->rule_type_rule->type_alt_lhs->type_node_arguments->type_arg_node; + element_type=list_type->type_node_arguments->type_arg_node; + + Assert ((unsigned int) moduleIndex < gBEState.be_nModules); + module = &gBEState.be_modules [moduleIndex]; + + Assert ((unsigned int) constructorIndex < module->bem_nConstructors); + constructor_symbol = module->bem_constructors [constructorIndex]; + + Assert (constructor_symbol->symb_kind==definition + || (moduleIndex==kPredefinedModuleIndex && constructor_symbol->symb_kind!=erroneous_symb)); + + if (moduleIndex != kPredefinedModuleIndex) + constructor_symbol->symb_def->sdef_isused = True; + + list_type_symbol=list_type->type_node_symbol; + + if (constructor_symbol->symb_head_strictness==1 && list_type_symbol->symb_head_strictness<4) + constructor_symbol=strict_list_cons_symbols[(list_type_symbol->symb_head_strictness<<1)+list_type_symbol->symb_tail_strictness]; + + if (list_type_symbol->symb_head_strictness==3){ + int element_symbol_kind; + + Assert (element_type->type_node_is_var==0); + + element_symbol_kind=element_type->type_node_symbol->symb_kind; + + if (element_symbol_kind<Nr_Of_Predef_Types) + constructor_symbol=&unboxed_list_symbols[element_symbol_kind][list_type_symbol->symb_tail_strictness]; + else if (element_symbol_kind==definition && element_type->type_node_symbol->symb_def->sdef_kind==RECORDTYPE) + constructor_symbol=decons_symbol->symb_def->sdef_unboxed_cons_symbol; + } + + return constructor_symbol; +} + +BENodeP BEOverloadedPushNode (int arity,BESymbolP symbol,BEArgP arguments,BENodeIdListP nodeIds,BENodeP decons_node) +{ + NodeP push_node; + + push_node = ConvertAllocType (NodeS); + + push_node->node_kind = PushNode; + push_node->node_arity = arity; + push_node->node_arguments = arguments; + push_node->node_push_symbol = symbol; + push_node->node_decons_node = decons_node; + push_node->node_node_ids = nodeIds; + push_node->node_number = 0; + + Assert (arguments->arg_node->node_kind == NodeIdNode); + Assert (arguments->arg_node->node_node_id->nid_ref_count_sign == -1); + + arguments->arg_node->node_node_id->nid_refcount++; + + return push_node; +} #endif void @@ -1460,9 +1658,6 @@ static int gCurrentScope = 0; static NodeIdRefCountListP gRefCountLists [kMaxScope]; static NodeIdRefCountListP gRefCountList; -# define nid_ref_count_sign nid_scope - - static void AddRefCount (NodeIdP nodeId) { @@ -1731,7 +1926,11 @@ BEPushNode (int arity, BESymbolP symbol, BEArgP arguments, BENodeIdListP nodeIds pushNode->node_kind = PushNode; pushNode->node_arity = arity; pushNode->node_arguments = arguments; +#if STRICT_LISTS + pushNode->node_push_symbol = symbol; +#else pushNode->node_record_symbol= symbol; +#endif pushNode->node_node_ids = nodeIds; pushNode->node_number = 0; /* @@ -1748,6 +1947,7 @@ BEPushNode (int arity, BESymbolP symbol, BEArgP arguments, BENodeIdListP nodeIds */ Assert (arguments->arg_node->node_kind == NodeIdNode); Assert (arguments->arg_node->node_node_id->nid_ref_count_sign == -1); + arguments->arg_node->node_node_id->nid_refcount++; return (pushNode); @@ -3229,6 +3429,62 @@ BEArg (CleanString arg) } } /* BEArg */ +#if STRICT_LISTS +static void init_unboxed_list_symbols (void) +{ + StateP array_state_p,strict_array_state_p,unboxed_array_state_p; + int i; + + for (i=0; i<Nr_Of_Predef_Types; ++i){ + SymbolP symbol_p; + + symbol_p=&unboxed_list_symbols[i][0]; + symbol_p->symb_kind=cons_symb; + symbol_p->symb_head_strictness=4; + symbol_p->symb_tail_strictness=0; + symbol_p->symb_state_p=&BasicSymbolStates[i]; + symbol_p->symb_next=NULL; + + symbol_p=&unboxed_list_symbols[i][1]; + symbol_p->symb_kind=cons_symb; + symbol_p->symb_head_strictness=4; + symbol_p->symb_tail_strictness=1; + symbol_p->symb_state_p=&BasicSymbolStates[i]; + symbol_p->symb_next=NULL; + } + + array_state_p=ConvertAllocType (StateS); + array_state_p->state_type = ArrayState; + array_state_p->state_arity = 1; + array_state_p->state_array_arguments = ConvertAllocType (StateS); + array_state_p->state_mark = 0; + SetUnaryState (&array_state_p->state_array_arguments[0],OnA,UnknownObj); + + unboxed_list_symbols[array_type][0].symb_state_p=array_state_p; + unboxed_list_symbols[array_type][1].symb_state_p=array_state_p; + + strict_array_state_p=ConvertAllocType (StateS); + strict_array_state_p->state_type = ArrayState; + strict_array_state_p->state_arity = 1; + strict_array_state_p->state_array_arguments = ConvertAllocType (StateS); + strict_array_state_p->state_mark = 0; + strict_array_state_p->state_array_arguments[0] = StrictState; + + unboxed_list_symbols[strict_array_type][0].symb_state_p=strict_array_state_p; + unboxed_list_symbols[strict_array_type][1].symb_state_p=strict_array_state_p; + + unboxed_array_state_p=ConvertAllocType (StateS); + unboxed_array_state_p->state_type = ArrayState; + unboxed_array_state_p->state_arity = 1; + unboxed_array_state_p->state_array_arguments = ConvertAllocType (StateS); + unboxed_array_state_p->state_mark = STATE_UNBOXED_ARRAY_MASK; + unboxed_array_state_p->state_array_arguments [0] = StrictState; + + unboxed_list_symbols[unboxed_array_type][0].symb_state_p=unboxed_array_state_p; + unboxed_list_symbols[unboxed_array_type][1].symb_state_p=unboxed_array_state_p; +} +#endif + BackEnd BEInit (int argc) { @@ -3256,6 +3512,10 @@ BEInit (int argc) #endif UserDefinedArrayFunctions = NULL; +#if STRICT_LISTS + unboxed_record_cons_list=NULL; + unboxed_record_decons_list=NULL; +#endif InitPredefinedSymbols (); @@ -3266,6 +3526,10 @@ BEInit (int argc) InitCoding (); InitInstructions (); +#if STRICT_LISTS + init_unboxed_list_symbols(); +#endif + CheckBEEnumTypes (); gBEState.be_argv = ConvertAlloc ((argc+1) * sizeof (char *)); diff --git a/backendC/CleanCompilerSources/backend.h b/backendC/CleanCompilerSources/backend.h index 5fd7b01..81aba78 100644 --- a/backendC/CleanCompilerSources/backend.h +++ b/backendC/CleanCompilerSources/backend.h @@ -209,13 +209,28 @@ Clean (BEBoolSymbol :: Bool BackEnd -> (BESymbolP, BackEnd)) BESymbolP BELiteralSymbol (BESymbKind kind, CleanString value); Clean (BELiteralSymbol :: BESymbKind String BackEnd -> (BESymbolP, BackEnd)) -/* -void BEPredefineListConstructorSymbol (int arity, int constructorIndex, int moduleIndex, BESymbKind symbolKind,int head_strictness,int tail_strictness); -Clean (BEPredefineListConstructorSymbol :: Int Int Int BESymbKind Int Int BackEnd -> BackEnd) + +void BEPredefineListConstructorSymbol (int constructorIndex, int moduleIndex, BESymbKind symbolKind,int head_strictness,int tail_strictness); +Clean (BEPredefineListConstructorSymbol :: Int Int BESymbKind Int Int BackEnd -> BackEnd) void BEPredefineListTypeSymbol (int typeIndex, int moduleIndex, BESymbKind symbolKind,int head_strictness,int tail_strictness); Clean (BEPredefineListTypeSymbol :: Int Int BESymbKind Int Int BackEnd -> BackEnd) -*/ + +void BEAdjustStrictListConsInstance (int functionIndex, int moduleIndex); +Clean (BEAdjustStrictListConsInstance :: Int Int BackEnd -> BackEnd) + +void BEAdjustUnboxedListDeconsInstance (int functionIndex, int moduleIndex); +Clean (BEAdjustUnboxedListDeconsInstance :: Int Int BackEnd -> BackEnd) + +void BEAdjustOverloadedNilFunction (int functionIndex,int moduleIndex); +Clean (BEAdjustOverloadedNilFunction :: Int Int BackEnd -> BackEnd) + +BESymbolP BEOverloadedConsSymbol (int constructorIndex,int moduleIndex,int deconsIndex,int deconsModuleIndex); +Clean (BEOverloadedConsSymbol :: Int Int Int Int BackEnd -> (BESymbolP,BackEnd)) + +BENodeP BEOverloadedPushNode (int arity,BESymbolP symbol,BEArgP arguments,BENodeIdListP nodeIds,BENodeP decons_node); +Clean (BEOverloadedPushNode :: Int BESymbolP BEArgP BENodeIdListP BENodeP BackEnd -> (BENodeP, BackEnd)) + void BEPredefineConstructorSymbol (int arity, int constructorIndex, int moduleIndex, BESymbKind symbolKind); Clean (BEPredefineConstructorSymbol :: Int Int Int BESymbKind BackEnd -> BackEnd) diff --git a/backendC/CleanCompilerSources/backendsupport.c b/backendC/CleanCompilerSources/backendsupport.c index f57016f..c73991f 100644 --- a/backendC/CleanCompilerSources/backendsupport.c +++ b/backendC/CleanCompilerSources/backendsupport.c @@ -67,6 +67,29 @@ fatal_backend_error (char *s) Debugger (); } +void debug_message (const char *format,...) +{ + va_list ap; + + va_start (ap,format); + vfprintf (StdError,format,ap); + va_end (ap); + +#ifdef _MAC_ + { + FILE *f; + + f=fopen ("DebugMessages","a"); + if (f!=NULL){ + va_start (ap,format); + vfprintf (f,format,ap); + va_end (ap); + fclose (f); + } + } +#endif +} + #if 1 /* Memory management diff --git a/backendC/CleanCompilerSources/backendsupport.h b/backendC/CleanCompilerSources/backendsupport.h index f9ce867..ee127a0 100644 --- a/backendC/CleanCompilerSources/backendsupport.h +++ b/backendC/CleanCompilerSources/backendsupport.h @@ -13,6 +13,7 @@ extern void AssertionFailed (char *conditionString, char *file, int line); # define Assert(condition) {if (!(condition)) AssertionFailed ("!(" #condition ")", __FILE__, __LINE__);} extern void fatal_backend_error (char *s); +extern void debug_message (const char *format,...); /* Memory management diff --git a/backendC/CleanCompilerSources/codegen.c b/backendC/CleanCompilerSources/codegen.c index 6109d4a..4ecc4cc 100644 --- a/backendC/CleanCompilerSources/codegen.c +++ b/backendC/CleanCompilerSources/codegen.c @@ -1191,7 +1191,9 @@ void CodeGeneration (ImpMod imod, char *fname) GenerateCodeForLazyTupleSelectorEntries (LazyTupleSelectors); GenerateCodeForLazyArrayFunctionEntries(); - +#if STRICT_LISTS + GenerateCodeForLazyUnboxedRecordListFunctions(); +#endif WriteLastNewlineToABCFile(); CloseABCFile (fname); diff --git a/backendC/CleanCompilerSources/codegen1.c b/backendC/CleanCompilerSources/codegen1.c index 69bd411..264a9fc 100644 --- a/backendC/CleanCompilerSources/codegen1.c +++ b/backendC/CleanCompilerSources/codegen1.c @@ -93,6 +93,17 @@ LabDef match_error_lab = {NULL, "", False, "_match_error", 0}; LabDef conss_lab = {NULL, "", False, "_Conss", 0}; LabDef consts_lab = {NULL, "", False, "_Consts", 0}; LabDef conssts_lab = {NULL, "", False, "_Conssts", 0}; + +LabDef unboxed_cons_labels[][2] = { + /*IntObj*/ {{NULL, "", False, "_Consi", 0}, {NULL, "", False, "_Consits", 0}}, + /*BoolObj*/ {{NULL, "", False, "_Consb", 0}, {NULL, "", False, "_Consbts", 0}}, + /*CharObj*/ {{NULL, "", False, "_Consc", 0}, {NULL, "", False, "_Conscts", 0}}, + /*RealObj*/ {{NULL, "", False, "_Consr", 0}, {NULL, "", False, "_Consrts", 0}}, + /*FileObj*/ {{NULL, "", False, "_Consf", 0}, {NULL, "", False, "_Consfts", 0}} + }; + +LabDef unboxed_cons_array_label = {NULL, "", False, "_Consa", 0}; + #endif #ifdef CLEAN2 LabDef select_with_dictionary_lab = {NULL, "", False, "_select_with_dictionary", 0}; @@ -688,7 +699,7 @@ static void CopyEntry (int offset, int *sp, int offframe []) GenPushA (*sp-offset); else GenPushB (*sp-offset); - (*sp)++; + ++ *sp; UpdateFrame (offframe, *sp, offframe[offset], offframe); } @@ -1107,46 +1118,109 @@ static void GenLazyFieldSelectorEntry (SymbDef field_def,StateS recstate,int tot } } -static void GenLazyArrayFunction (SymbDef arr_fun_def) +static void GenUnboxedRecordApplyAndNodeEntries (SymbDef fun_def,int n_result_nodes_on_a_stack,int *a_size_p,int *b_size_p) { LabDef ealab; int asize,bsize,maxasize; - RuleTypes af_type; + RuleTypes rule_type; int arity; asize = 0; bsize = 0; maxasize = 0; - af_type = arr_fun_def->sdef_rule_type; - arity = arr_fun_def->sdef_arity; + rule_type = fun_def->sdef_rule_type; + arity = fun_def->sdef_arity; - MakeSymbolLabel (&CurrentAltLabel,NULL,no_pref,arr_fun_def,0); + MakeSymbolLabel (&CurrentAltLabel,NULL,no_pref,fun_def,0); ealab = CurrentAltLabel; ealab.lab_pref = ea_pref; - AddStateSizesAndMaxFrameSizes (arity,af_type->rule_type_state_p,&maxasize,&asize,&bsize); + AddStateSizesAndMaxFrameSizes (arity,rule_type->rule_type_state_p,&maxasize,&asize,&bsize); - if ((arr_fun_def->sdef_mark & SDEF_USED_CURRIED_MASK) || DoDescriptors || DoParallel) - GenArrayFunctionDescriptor (arr_fun_def,&CurrentAltLabel,arity); + if ((fun_def->sdef_mark & SDEF_USED_CURRIED_MASK) || DoDescriptors || DoParallel) + GenArrayFunctionDescriptor (fun_def,&CurrentAltLabel,arity); if (DoTimeProfiling) - GenPB (arr_fun_def->sdef_ident->ident_name); + GenPB (fun_def->sdef_ident->ident_name); - if (arr_fun_def->sdef_mark & SDEF_USED_CURRIED_MASK) - ApplyEntry (af_type->rule_type_state_p,arity,&ealab,!(arr_fun_def->sdef_mark & SDEF_USED_LAZILY_MASK)); + if (fun_def->sdef_mark & SDEF_USED_CURRIED_MASK) + ApplyEntry (rule_type->rule_type_state_p,arity,&ealab,!(fun_def->sdef_mark & SDEF_USED_LAZILY_MASK)); - if (arr_fun_def->sdef_mark & SDEF_USED_LAZILY_MASK) - NodeEntry (af_type->rule_type_state_p,arity,&ealab,arr_fun_def); + if (fun_def->sdef_mark & SDEF_USED_LAZILY_MASK) + NodeEntry (rule_type->rule_type_state_p,arity,&ealab,fun_def); - EvalArgsEntry (af_type->rule_type_state_p,arr_fun_def,maxasize,&ealab,0); + EvalArgsEntry (rule_type->rule_type_state_p,fun_def,maxasize,&ealab,n_result_nodes_on_a_stack); + + *a_size_p=asize; + *b_size_p=bsize; +} - CallArrayFunction (arr_fun_def,False,&af_type->rule_type_state_p[-1]); +#if STRICT_LISTS +extern PolyList unboxed_record_cons_list,unboxed_record_decons_list; - if (DoTimeProfiling) - GenPE(); +void GenerateCodeForLazyUnboxedRecordListFunctions (void) +{ + PolyList unboxed_record_cons_elem,unboxed_record_decons_elem; + + for_l (unboxed_record_cons_elem,unboxed_record_cons_list,pl_next){ + SymbDef fun_def; + + fun_def=unboxed_record_cons_elem->pl_elem; + if (fun_def->sdef_mark & (SDEF_USED_LAZILY_MASK | SDEF_USED_CURRIED_MASK)){ + int a_size,b_size; + TypeArgs type_node_arguments_p; + LabDef unboxed_record_cons_lab; + int tail_strict; + + GenUnboxedRecordApplyAndNodeEntries (fun_def,1,&a_size,&b_size); + + type_node_arguments_p=fun_def->sdef_rule_type->rule_type_rule->type_alt_lhs->type_node_arguments; + tail_strict=type_node_arguments_p->type_arg_next->type_arg_node->type_node_symbol->symb_tail_strictness; + + unboxed_record_cons_lab.lab_mod=NULL; + unboxed_record_cons_lab.lab_pref=tail_strict ? "r_Cons#!" : "r_Cons#"; + unboxed_record_cons_lab.lab_issymbol=False; + unboxed_record_cons_lab.lab_name=type_node_arguments_p->type_arg_node->type_node_symbol->symb_def->sdef_ident->ident_name; + unboxed_record_cons_lab.lab_post='\0'; + + GenFillR (&unboxed_record_cons_lab,a_size,b_size,a_size,0,0,ReleaseAndFill,True); + + GenRtn (1,0,OnAState); + + if (DoTimeProfiling) + GenPE(); + } + } + + for_l (unboxed_record_decons_elem,unboxed_record_decons_list,pl_next){ + SymbDef fun_def; + + fun_def=unboxed_record_decons_elem->pl_elem; + if (fun_def->sdef_mark & (SDEF_USED_LAZILY_MASK | SDEF_USED_CURRIED_MASK)){ + int a_size,b_size; + StateP result_state_p; + + GenUnboxedRecordApplyAndNodeEntries (fun_def,0,&a_size,&b_size); + + result_state_p=&fun_def->sdef_rule_type->rule_type_state_p[-1]; + + DetermineSizeOfState (*result_state_p,&a_size,&b_size); + + if (b_size==0) + GenReplArgs (a_size,a_size); + else + GenReplRArgs (a_size,b_size); + + GenRtn (a_size,b_size,*result_state_p); + + if (DoTimeProfiling) + GenPE(); + } + } } +#endif extern PolyList UserDefinedArrayFunctions; @@ -1154,20 +1228,36 @@ void GenerateCodeForLazyArrayFunctionEntries (void) { PolyList next_fun; - for (next_fun = UserDefinedArrayFunctions; next_fun; next_fun = next_fun -> pl_next) - { SymbDef fun_def = ((Symbol) next_fun -> pl_elem) -> symb_def; - if (fun_def ->sdef_mark & (SDEF_USED_LAZILY_MASK | SDEF_USED_CURRIED_MASK)) - GenLazyArrayFunction (fun_def); + for (next_fun = UserDefinedArrayFunctions; next_fun; next_fun = next_fun -> pl_next){ + SymbDef arr_fun_def; + + arr_fun_def = ((Symbol)next_fun->pl_elem)->symb_def; + + if (arr_fun_def ->sdef_mark & (SDEF_USED_LAZILY_MASK | SDEF_USED_CURRIED_MASK)){ + int a_size,b_size; + + GenUnboxedRecordApplyAndNodeEntries (arr_fun_def,0,&a_size,&b_size); + + CallArrayFunction (arr_fun_def,False,&arr_fun_def->sdef_rule_type->rule_type_state_p[-1]); + + if (DoTimeProfiling) + GenPE(); + } } } -void GenerateCodeForConstructorsAndRecords (Symbol symbs) +void GenerateCodeForConstructorsAndRecords (Symbol symbols) { - for ( ; symbs; symbs = symbs->symb_next){ - if (symbs->symb_kind==definition){ + Symbol symbol_p; +#if STRICT_LISTS + PolyList unboxed_record_cons_element; +#endif + + for_l (symbol_p,symbols,symb_next){ + if (symbol_p->symb_kind==definition){ SymbDef def; - def = symbs->symb_def; + def = symbol_p->symb_def; if (def->sdef_module==CurrentModule){ if (def->sdef_kind==TYPE){ @@ -1194,6 +1284,21 @@ void GenerateCodeForConstructorsAndRecords (Symbol symbs) } } } + +#if STRICT_LISTS + for_l (unboxed_record_cons_element,unboxed_record_cons_list,pl_next){ + SymbDef cons_instance_sdef,record_sdef; + TypeArgs type_node_arguments_p; + int tail_strict; + + cons_instance_sdef=unboxed_record_cons_element->pl_elem; + type_node_arguments_p=cons_instance_sdef->sdef_rule_type->rule_type_rule->type_alt_lhs->type_node_arguments; + record_sdef=type_node_arguments_p->type_arg_node->type_node_symbol->symb_def; + tail_strict=type_node_arguments_p->type_arg_next->type_arg_node->type_node_symbol->symb_tail_strictness; + + GenUnboxedConsRecordDescriptor (record_sdef,tail_strict); + } +#endif } Bool NodeEntry (StateS *const function_state_p,int arity,Label ealab,SymbDef rootsymb) @@ -3195,8 +3300,16 @@ static int generate_code_for_switch_node (NodeP node,int asp,int bsp,struct esc GenJmp (&case_label); matches_always=1; } else { - GenEqDesc (&cons_lab,case_node->node_arity,asp-a_index); - GenJmpTrue (&case_label); +#if STRICT_LISTS + if (symbol->symb_head_strictness==1 || symbol->symb_head_strictness>=3){ + GenEqDesc (&nil_lab,0,asp-a_index); + GenJmpFalse (&case_label); + } else +#endif + { + GenEqDesc (&cons_lab,case_node->node_arity,asp-a_index); + GenJmpTrue (&case_label); + } } break; case nil_symb: @@ -3289,8 +3402,12 @@ static int generate_code_for_switch_node (NodeP node,int asp,int bsp,struct esc GenJmpTrue (&case_label); } else error_in_function ("generate_code_for_switch_node"); - } else - error_in_function ("generate_code_for_switch_node"); + } else { + static char s[256]; + + sprintf (s,"generate_code_for_switch_node %d %d",(int)symbol->symb_kind,(int)symbol); + error_in_function (s); + } } ++NewLabelNr; @@ -3423,6 +3540,36 @@ int unused_node_id_ (NodeId node_id) return False; } +#if STRICT_LISTS +static void repl_overloaded_cons_arguments (NodeP node_p,int *asp_p,int *bsp_p,SavedNidStateS **save_states_p,AbNodeIdsP ab_node_ids_p) +{ + CodeGenNodeIdsS code_gen_node_ids; + LabDef apply_label; + + code_gen_node_ids.saved_nid_state_l=save_states_p; + code_gen_node_ids.free_node_ids=ab_node_ids_p->free_node_ids; + code_gen_node_ids.moved_node_ids_l=NULL; + code_gen_node_ids.a_node_ids=ab_node_ids_p->a_node_ids; + code_gen_node_ids.b_node_ids=ab_node_ids_p->b_node_ids; + code_gen_node_ids.doesnt_fail=0; + + Build (node_p->node_decons_node,asp_p,bsp_p,&code_gen_node_ids); + + *asp_p -= 2; + + ab_node_ids_p->free_node_ids=code_gen_node_ids.free_node_ids; + ab_node_ids_p->a_node_ids=code_gen_node_ids.a_node_ids; + ab_node_ids_p->b_node_ids=code_gen_node_ids.b_node_ids; + + GenDAStackLayout (2); + MakeSymbolLabel (&apply_label,ApplyDef->sdef_module,s_pref,ApplyDef, 0); + GenJsr (&apply_label); + GenOAStackLayout (1); + + GenReplArgs (2,2); +} +#endif + static int generate_code_for_push_node (NodeP node,int asp,int bsp,struct esc *esc_p,NodeDefs defs,StateP result_state_p, SavedNidStateS **save_states_p,AbNodeIdsP ab_node_ids_p) { @@ -3563,9 +3710,14 @@ static int generate_code_for_push_node (NodeP node,int asp,int bsp,struct esc *e if (unused_node_id (node_id_p)){ if (node_id_p->nid_a_index==asp){ - if (b_size==0) + if (b_size==0){ +#if STRICT_LISTS + if (node->node_push_symbol->symb_kind==cons_symb && (node->node_push_symbol->symb_head_strictness & 1)){ + repl_overloaded_cons_arguments (node,&asp,&bsp,save_states_p,ab_node_ids_p); + } else +#endif GenReplArgs (a_size,a_size); - else + } else GenReplRArgs (a_size,b_size); if (ab_node_ids.a_node_ids!=NULL && ab_node_ids.a_node_ids->nidl_node_id==node_id_p) @@ -3585,9 +3737,17 @@ static int generate_code_for_push_node (NodeP node,int asp,int bsp,struct esc *e --asp; } else { - if (b_size==0) + if (b_size==0){ +#if STRICT_LISTS + if (node->node_push_symbol->symb_kind==cons_symb && (node->node_push_symbol->symb_head_strictness & 1)){ + GenPushA (asp-node_id_p->nid_a_index); + ++asp; + + repl_overloaded_cons_arguments (node,&asp,&bsp,save_states_p,ab_node_ids_p); + } else +#endif GenPushArgs (asp-node_id_p->nid_a_index,a_size,a_size); - else + } else GenPushRArgs (asp-node_id_p->nid_a_index,a_size,b_size); GenBuildh (&nil_lab,0); @@ -3595,9 +3755,17 @@ static int generate_code_for_push_node (NodeP node,int asp,int bsp,struct esc *e GenPopA (1); } } else { - if (b_size==0) + if (b_size==0){ +#if STRICT_LISTS + if (node->node_push_symbol->symb_kind==cons_symb && (node->node_push_symbol->symb_head_strictness & 1)){ + GenPushA (asp-node_id_p->nid_a_index); + ++asp; + + repl_overloaded_cons_arguments (node,&asp,&bsp,save_states_p,ab_node_ids_p); + } else +#endif GenPushArgs (asp-node_id_p->nid_a_index,a_size,a_size); - else +} else GenPushRArgs (asp-node_id_p->nid_a_index,a_size,b_size); } diff --git a/backendC/CleanCompilerSources/codegen1.h b/backendC/CleanCompilerSources/codegen1.h index a93e19d..78e58cd 100644 --- a/backendC/CleanCompilerSources/codegen1.h +++ b/backendC/CleanCompilerSources/codegen1.h @@ -17,7 +17,7 @@ extern LabDef cycle_lab, reserve_lab, type_error_lab, indirection_lab, ind_lab, hnf_lab, cons_lab, nil_lab, tuple_lab, empty_lab, add_arg_lab, match_error_lab, #if STRICT_LISTS - conss_lab,consts_lab,conssts_lab, + conss_lab,consts_lab,conssts_lab,unboxed_cons_labels[][2],unboxed_cons_array_label, #endif #ifdef CLEAN2 select_with_dictionary_lab, update_with_dictionary_lab, @@ -100,7 +100,9 @@ extern Bool ConvertExternalToInternalCall (int arity,StateS *const ext_function_ Bool skip_entry,int intasp,int intbsp,Label ealab,Label extlab,Bool root_node_needed); extern void GenerateCodeForLazyTupleSelectorEntries (Bool *selectors); extern void GenerateCodeForLazyArrayFunctionEntries (void); - +#if STRICT_LISTS +void GenerateCodeForLazyUnboxedRecordListFunctions (void); +#endif extern int next_update_function_n,next_match_function_n; extern ImpRuleS *first_update_function,**update_function_p; diff --git a/backendC/CleanCompilerSources/codegen2.c b/backendC/CleanCompilerSources/codegen2.c index b5372fe..e2bb39b 100644 --- a/backendC/CleanCompilerSources/codegen2.c +++ b/backendC/CleanCompilerSources/codegen2.c @@ -2744,6 +2744,30 @@ static void fill_strict_if_node (Node node,int *asp_p,int *bsp_p,CodeGenNodeIdsP } #endif +#if STRICT_LISTS +#include "backendsupport.h" + +LabDef *unboxed_cons_label (SymbolP cons_symbol_p) +{ + static LabDef unboxed_record_cons_lab; + + 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_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; + unboxed_record_cons_lab.lab_post='\0'; + + return &unboxed_record_cons_lab; + } else if (cons_symbol_p->symb_unboxed_cons_state_p->state_type==ArrayState){ + return &unboxed_cons_array_label; + } else + error_in_function ("unboxed_cons_label"); +} +#endif + static void FillNormalNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p) { Symbol symb; @@ -2782,6 +2806,140 @@ static void FillNormalNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_i } return; 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){ + FillSymbol (node,symb->symb_unboxed_cons_sdef_p,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + return; + } else { + int lazy_fill; + + if (node->node_arity==2){ + lazy_fill=IsLazyState (node->node_state); + + if (lazy_fill){ + int has_unevaluated_strict_arg; + + has_unevaluated_strict_arg=0; + + if (symb->symb_head_strictness>1){ + NodeP arg_node_p; + + arg_node_p=node->node_arguments->arg_node; + if (arg_node_p->node_kind!=NodeIdNode){ + if (arg_node_p->node_kind==NormalNode && + (BETWEEN (int_denot,real_denot,arg_node_p->node_symbol->symb_kind) || arg_node_p->node_symbol->symb_kind==string_denot)) + ; + else + if (IsLazyState (arg_node_p->node_state)) + has_unevaluated_strict_arg=1; + } else + if (IsLazyState (arg_node_p->node_node_id->nid_state)) + has_unevaluated_strict_arg=1; + } + + if (symb->symb_tail_strictness){ + NodeP arg_node_p; + + arg_node_p=node->node_arguments->arg_next->arg_node; + if (arg_node_p->node_kind!=NodeIdNode){ + if (IsLazyState (arg_node_p->node_state)) + has_unevaluated_strict_arg=1; + } else + if (IsLazyState (arg_node_p->node_node_id->nid_state)) + has_unevaluated_strict_arg=1; + } + + if (!has_unevaluated_strict_arg){ + if (symb->symb_head_strictness>1){ + NodeP arg_node_p; + StateP element_state_p; + + if (symb->symb_head_strictness==4) + element_state_p=symb->symb_unboxed_cons_state_p; + else + element_state_p=&StrictState; + + arg_node_p=node->node_arguments->arg_node; + if (arg_node_p->node_kind==NormalNode && + (BETWEEN (int_denot,real_denot,arg_node_p->node_symbol->symb_kind) || arg_node_p->node_symbol->symb_kind==string_denot)) + { + arg_node_p->node_state=*element_state_p; + } + + node->node_arguments->arg_state=*element_state_p; + } + + if (symb->symb_tail_strictness) + node->node_arguments->arg_next->arg_state=StrictState; + + lazy_fill=0; + } + } + } else + lazy_fill=0; + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + { + LabDef *strict_cons_lab_p,strict_cons_lab; + int a_size,b_size; + + if (symb->symb_head_strictness==4){ + 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; + } else + strict_cons_lab_p=unboxed_cons_label (symb); + + DetermineSizeOfArguments (node->node_arguments,&a_size,&b_size); + } else { + if (symb->symb_head_strictness>1){ + if (symb->symb_tail_strictness) + strict_cons_lab_p=&conssts_lab; + else + strict_cons_lab_p=&conss_lab; + } else + strict_cons_lab_p=&consts_lab; + + a_size=node->node_arity; + b_size=0; + } + + if (lazy_fill){ + LabDef n_strict_cons_lab; + + n_strict_cons_lab = *strict_cons_lab_p; + n_strict_cons_lab.lab_pref = n_pref; + + if (update_node_id==NULL){ + *asp_p+=1-a_size; + GenBuild (strict_cons_lab_p,a_size,&n_strict_cons_lab); + } else { + GenFill (strict_cons_lab_p,a_size,&n_strict_cons_lab,*asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? PartialFill : NormalFill); + *asp_p-=a_size; + } + } else { + if (update_node_id==NULL){ + *asp_p+=1-a_size; + if (symb->symb_head_strictness==4) + GenBuildR (strict_cons_lab_p,a_size,b_size,0,0,True); + else + GenBuildh (node->node_arity==2 ? &cons_lab : strict_cons_lab_p,a_size); + } else { + if (symb->symb_head_strictness==4) + GenFillR (strict_cons_lab_p,a_size,b_size,*asp_p+a_size-update_node_id->nid_a_index,0,0,node->node_state.state_kind==SemiStrict ? ReleaseAndFill : NormalFill,True); + else + GenFillh (strict_cons_lab_p,a_size,*asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? ReleaseAndFill : NormalFill); + *asp_p-=a_size; + } + } + *bsp_p-=b_size; + } + return; + } + } +#endif BuildLazyArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); if (update_node_id==NULL){ *asp_p+=1-node->node_arity; @@ -2793,12 +2951,18 @@ static void FillNormalNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_i } return; case nil_symb: +#if STRICT_LISTS + if (symb->symb_head_strictness & 1){ + BuildArg (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + GenPopA (1); + --*asp_p; + } +#endif if (update_node_id==NULL){ *asp_p+=1; - GenBuildh (&nil_lab,node->node_arity); + GenBuildh (&nil_lab,0); } else - GenFillh (&nil_lab,node->node_arity,*asp_p-update_node_id->nid_a_index, - node->node_state.state_kind == SemiStrict ? ReleaseAndFill : NormalFill); + GenFillh (&nil_lab,0,*asp_p-update_node_id->nid_a_index,node->node_state.state_kind == SemiStrict ? ReleaseAndFill : NormalFill); return; case string_denot: GenBuildString (symb->symb_val); @@ -3773,6 +3937,12 @@ 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){ + GenEqDesc (&nil_lab,0,0); + GenNotB(); + } else +#endif GenEqDesc (&cons_lab,2,0); break; case definition: @@ -3877,8 +4047,8 @@ static #else void #endif - compute_bits_and_remove_unused_arguments (NodeP node,char bits[],unsigned int argument_overwrite_bits, - int *a_size_p,int *b_size_p,int *n_a_fill_bits_p,int *n_b_fill_bits_p) + compute_bits_and_remove_unused_arguments_for_strict_node (NodeP node,char bits[],unsigned int argument_overwrite_bits, + int *a_size_p,int *b_size_p,int *n_a_fill_bits_p,int *n_b_fill_bits_p) { unsigned int a_bits,b_bits,a_size,b_size,n,arg_n; int n_a_fill_bits,n_b_fill_bits,node_arity; @@ -3948,15 +4118,95 @@ static #endif } + +static +#if GENERATE_CODE_AGAIN + ArgP +#else + void +#endif + compute_bits_and_remove_unused_arguments (NodeP node,char bits[],unsigned int argument_overwrite_bits,unsigned int *n_args_p) +{ + unsigned int arg_n; + int node_arity,n_args; + ArgS **arg_l; +#if GENERATE_CODE_AGAIN + ArgP removed_args,*removed_args_l; + + removed_args_l=&removed_args; +#endif + + arg_l=&node->node_arguments; + node_arity=node->node_arity; + + n_args=0; + + for (arg_n=0; arg_n<node_arity; ++arg_n){ + ArgP arg_p; + + arg_p=*arg_l; + if (argument_overwrite_bits & (1<<arg_n)){ + bits[arg_n+1]='1'; + arg_l=&(arg_p->arg_next); + ++n_args; + } else { + bits[arg_n+1]='0'; + *arg_l=arg_p->arg_next; +#if GENERATE_CODE_AGAIN + *removed_args_l=arg_p; + removed_args_l=&arg_p->arg_next; +#endif + } + } + + bits[arg_n+1]='\0'; + *n_args_p=n_args; + +#if GENERATE_CODE_AGAIN + *removed_args_l=NULL; + + return removed_args; +#endif +} + +static void fill_strict_unique_node (NodeP node,NodeP update_node,char bits[],LabDef *label_p,NodeIdP free_unique_node_id,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + int a_size,b_size,n_a_fill_bits,n_b_fill_bits; +#if GENERATE_CODE_AGAIN + ArgP removed_args= +#endif + compute_bits_and_remove_unused_arguments_for_strict_node (node,bits,update_node->node_arguments->arg_occurrence, + &a_size,&b_size,&n_a_fill_bits,&n_b_fill_bits); + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + +#if GENERATE_CODE_AGAIN + if (call_code_generator_again) + restore_removed_arguments (&node->node_arguments,removed_args,update_node->node_arguments->arg_occurrence,node->node_arity); +#endif + + if (a_size+b_size>2) + GenFill2R (label_p,a_size,b_size,*asp_p-free_unique_node_id->nid_a_index,bits); + else + GenFill1R (label_p,a_size,b_size,*asp_p-free_unique_node_id->nid_a_index,bits); + + *asp_p-=n_a_fill_bits; + *bsp_p-=n_b_fill_bits; + + GenPushA (*asp_p-free_unique_node_id->nid_a_index); + *asp_p+=1; + + decrement_reference_count_of_node_id (free_unique_node_id,&code_gen_node_ids_p->free_node_ids); +} + static void FillUniqueNodeWithNode (NodeP update_node,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) { - unsigned int argument_overwrite_bits,n_args,node_arity,arg_n; + unsigned int n_args,node_arity; char bits[MaxNodeArity+2]; NodeIdP free_unique_node_id; NodeP node,push_node; LabDef name,*label_p; SymbolP symbol; - ArgS **arg_l; node=update_node->node_arguments->arg_node; push_node=update_node->node_node; @@ -3981,35 +4231,10 @@ static void FillUniqueNodeWithNode (NodeP update_node,int *asp_p,int *bsp_p,Code bits[0]='1'; if (sdef->sdef_strict_constructor){ - int a_size,b_size,n_a_fill_bits,n_b_fill_bits; -#if GENERATE_CODE_AGAIN - ArgP removed_args= -#endif - compute_bits_and_remove_unused_arguments (node,bits,update_node->node_arguments->arg_occurrence, - &a_size,&b_size,&n_a_fill_bits,&n_b_fill_bits); - - BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); - -#if GENERATE_CODE_AGAIN - if (call_code_generator_again) - restore_removed_arguments (&node->node_arguments,removed_args,update_node->node_arguments->arg_occurrence,node->node_arity); -#endif - ConvertSymbolToKLabel (&name,sdef); - if (a_size+b_size>2) - GenFill2R (&name,a_size,b_size,*asp_p-free_unique_node_id->nid_a_index,bits); - else - GenFill1R (&name,a_size,b_size,*asp_p-free_unique_node_id->nid_a_index,bits); - - *asp_p-=n_a_fill_bits; - *bsp_p-=n_b_fill_bits; - - GenPushA (*asp_p-free_unique_node_id->nid_a_index); - *asp_p+=1; - - decrement_reference_count_of_node_id (free_unique_node_id,&code_gen_node_ids_p->free_node_ids); - + fill_strict_unique_node (node,update_node,bits,&name,free_unique_node_id,asp_p,bsp_p,code_gen_node_ids_p); + return; } else { ConvertSymbolToConstructorDLabel (&name,sdef); @@ -4017,46 +4242,16 @@ static void FillUniqueNodeWithNode (NodeP update_node,int *asp_p,int *bsp_p,Code } break; case RECORDTYPE: - { - int a_size,b_size,n_a_fill_bits,n_b_fill_bits; -#if GENERATE_CODE_AGAIN - ArgP removed_args; -#endif if (push_node->node_record_symbol==node->node_symbol && push_node->node_arity==node_arity) bits[0]='0'; else bits[0]='1'; -#if GENERATE_CODE_AGAIN - removed_args= -#endif - compute_bits_and_remove_unused_arguments (node,bits,update_node->node_arguments->arg_occurrence, - &a_size,&b_size,&n_a_fill_bits,&n_b_fill_bits); - - BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); - -#if GENERATE_CODE_AGAIN - if (call_code_generator_again) - restore_removed_arguments (&node->node_arguments,removed_args,update_node->node_arguments->arg_occurrence,node->node_arity); -#endif - ConvertSymbolToRLabel (&name,sdef); - - if (a_size+b_size>2) - GenFill2R (&name,a_size,b_size,*asp_p-free_unique_node_id->nid_a_index,bits); - else - GenFill1R (&name,a_size,b_size,*asp_p-free_unique_node_id->nid_a_index,bits); - - *asp_p-=n_a_fill_bits; - *bsp_p-=n_b_fill_bits; - - GenPushA (*asp_p-free_unique_node_id->nid_a_index); - *asp_p+=1; - - decrement_reference_count_of_node_id (free_unique_node_id,&code_gen_node_ids_p->free_node_ids); + fill_strict_unique_node (node,update_node,bits,&name,free_unique_node_id,asp_p,bsp_p,code_gen_node_ids_p); + return; - } case IMPRULE: case DEFRULE: case SYSRULE: @@ -4135,6 +4330,51 @@ static void FillUniqueNodeWithNode (NodeP update_node,int *asp_p,int *bsp_p,Code case cons_symb: node_arity=2; +#if STRICT_LISTS + if (symbol->symb_head_strictness>1 || symbol->symb_tail_strictness){ + SymbolP pattern_symbol_p; + + pattern_symbol_p=push_node->node_push_symbol; + if (pattern_symbol_p->symb_kind==cons_symb && push_node->node_arity==node_arity + && ((pattern_symbol_p->symb_head_strictness<3 && symbol->symb_head_strictness<3) + || (pattern_symbol_p->symb_head_strictness==4 && symbol->symb_head_strictness==4 + && pattern_symbol_p->symb_tail_strictness==symbol->symb_tail_strictness + && EqualState (*pattern_symbol_p->symb_state_p,*symbol->symb_unboxed_cons_state_p)))) + bits[0]='0'; + else + bits[0]='1'; + + if (symbol->symb_head_strictness==4){ + LabDef *strict_cons_lab_p; + + strict_cons_lab_p=unboxed_cons_label (symbol); + + fill_strict_unique_node (node,update_node,bits,strict_cons_lab_p,free_unique_node_id,asp_p,bsp_p,code_gen_node_ids_p); + } else { +#if GENERATE_CODE_AGAIN + ArgP removed_args= +#endif + compute_bits_and_remove_unused_arguments (node,bits,update_node->node_arguments->arg_occurrence,&n_args); + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + +#if GENERATE_CODE_AGAIN + if (call_code_generator_again) + restore_removed_arguments (&node->node_arguments,removed_args,update_node->node_arguments->arg_occurrence,node_arity); +#endif + GenFill1 (&cons_lab,node_arity,*asp_p-free_unique_node_id->nid_a_index,bits); + + *asp_p-=n_args; + + GenPushA (*asp_p-free_unique_node_id->nid_a_index); + *asp_p+=1; + + decrement_reference_count_of_node_id (free_unique_node_id,&code_gen_node_ids_p->free_node_ids); + } + return; + } +#endif + if (push_node->node_record_symbol->symb_kind==cons_symb && push_node->node_arity==node_arity) bits[0]='0'; else @@ -4157,42 +4397,11 @@ static void FillUniqueNodeWithNode (NodeP update_node,int *asp_p,int *bsp_p,Code return; } - arg_l=&node->node_arguments; - - argument_overwrite_bits=update_node->node_arguments->arg_occurrence; - - n_args=0; - #if GENERATE_CODE_AGAIN { - ArgP removed_args,*removed_args_l; - - removed_args_l=&removed_args; + ArgP removed_args= #endif - - for (arg_n=0; arg_n<node_arity; ++arg_n){ - ArgP arg_p; - - arg_p=*arg_l; - if (argument_overwrite_bits & (1<<arg_n)){ - bits[arg_n+1]='1'; - arg_l=&(arg_p->arg_next); - ++n_args; - } else { - bits[arg_n+1]='0'; - *arg_l=arg_p->arg_next; -#if GENERATE_CODE_AGAIN - *removed_args_l=arg_p; - removed_args_l=&arg_p->arg_next; -#endif - } - } - -#if GENERATE_CODE_AGAIN - *removed_args_l=NULL; -#endif - - bits[arg_n+1]='\0'; + compute_bits_and_remove_unused_arguments (node,bits,update_node->node_arguments->arg_occurrence,&n_args); BuildLazyArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); diff --git a/backendC/CleanCompilerSources/codegen2.h b/backendC/CleanCompilerSources/codegen2.h index 34bc210..a6eb383 100644 --- a/backendC/CleanCompilerSources/codegen2.h +++ b/backendC/CleanCompilerSources/codegen2.h @@ -15,6 +15,8 @@ extern int ObjectSizes []; #define IsOnACycle(nodenum) (nodenum < 0) #define IsOnBStack(state) (! IsSimpleState (state) || (state).state_kind == OnB) +extern LabDef *unboxed_cons_label (SymbolP cons_symbol_p); + extern void ScanInlineFile (char *fname); extern Bool EqualState (StateS st1, StateS st2); diff --git a/backendC/CleanCompilerSources/codegen3.c b/backendC/CleanCompilerSources/codegen3.c index ba675c8..b5e6b83 100644 --- a/backendC/CleanCompilerSources/codegen3.c +++ b/backendC/CleanCompilerSources/codegen3.c @@ -711,6 +711,8 @@ static int CodeRhsNodeDefsAndRestoreNodeIdStates (Node root_node,NodeDefs defs,i return need_next_alternative; } +#define BETWEEN(l,h,v) ((unsigned)((v)-(l)) <= (unsigned)((h)-(l))) + static void CodeNormalRootNode (Node root,NodeId rootid,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p,StateS resultstate) { Symbol rootsymb; @@ -750,9 +752,71 @@ static void CodeNormalRootNode (Node root,NodeId rootid,int asp,int bsp,CodeGenN } return; case cons_symb: +#if STRICT_LISTS + if (rootsymb->symb_head_strictness>1 || rootsymb->symb_tail_strictness){ + if (rootsymb->symb_head_strictness==4 && root->node_arity<2){ + CodeRootSymbolApplication (root,rootid,rootsymb->symb_unboxed_cons_sdef_p,asp,bsp,code_gen_node_ids_p,resultstate); + return; + } else { + LabDef *strict_cons_lab_p; + int a_size; + + BuildArgs (root->node_arguments,&asp,&bsp,code_gen_node_ids_p); + + if (rootsymb->symb_head_strictness==4){ + int b_size; + + strict_cons_lab_p=unboxed_cons_label (rootsymb); + + DetermineSizeOfArguments (root->node_arguments,&a_size,&b_size); + GenFillR (strict_cons_lab_p,a_size,b_size,asp,0,0,ReleaseAndFill,True); + bsp-=b_size; + } else { + if (rootsymb->symb_head_strictness>1){ + if (rootsymb->symb_tail_strictness) + strict_cons_lab_p=&conssts_lab; + else + strict_cons_lab_p=&conss_lab; + } else + strict_cons_lab_p=&consts_lab; + + a_size=root->node_arity; + GenFillh (root->node_arity==2 ? &cons_lab : strict_cons_lab_p,a_size,asp,ReleaseAndFill); + } + + asp-=a_size; + + GenPopA (asp); + GenPopB (bsp); + GenRtn (1,0,OnAState); + return; + } + } +#endif FillRhsRoot (&cons_lab, root, asp, bsp,code_gen_node_ids_p); return; case nil_symb: +#if STRICT_LISTS + if (rootsymb->symb_head_strictness & 1){ + BuildArg (root->node_arguments,&asp,&bsp,code_gen_node_ids_p); + GenPopA (1); + --asp; + + if (resultstate.state_kind==StrictRedirection){ + GenPopA (asp); + GenPopB (bsp); + GenBuildh (&nil_lab,0); + } else { + GenFillh (&nil_lab,0,asp,ReleaseAndFill); + + GenPopA (asp); + GenPopB (bsp); + } + GenRtn (1,0,OnAState); + return; + } +#endif + FillRhsRoot (&nil_lab, root, asp, bsp,code_gen_node_ids_p); return; case apply_symb: @@ -1255,11 +1319,21 @@ static Bool ExamineRootNodeOnACycle (NodeId rhsid,Node rhsroot,int *asp_p,StateS #if TAIL_CALL_MODULO_CONS_OPTIMIZATION extern int tail_call_modulo_cons; -static void generate_code_for_tail_call_modulo_cons (NodeP node_p,NodeId node_def_id,NodeP root_node,NodeP push_node, +static void generate_code_for_tail_call_modulo_cons (NodeP node_p,NodeId node_def_id,NodeP root_node, +#if STRICT_LISTS + NodeP fill_unique_node, +#else + NodeP push_node, +#endif int asp,int bsp,struct code_gen_node_ids *code_gen_node_ids_p) { LabDef name; int a_size,b_size; +#if STRICT_LISTS + NodeP push_node; + + push_node=fill_unique_node->node_node; +#endif ConvertSymbolToLabel (&name,node_p->node_symbol->symb_def); @@ -1302,7 +1376,11 @@ static void generate_code_for_tail_call_modulo_cons (NodeP node_p,NodeId node_de DetermineSizeOfArguments (root_node->node_arguments,&asize,&bsize); +#if STRICT_LISTS + if (asize+bsize>2 && push_node!=NULL && push_node->node_push_size>=asize+bsize){ +#else if (asize+bsize>2 && push_node!=NULL && push_node->node_line>=asize+bsize){ +#endif NodeIdListElementP node_id_list; char bits[MaxNodeArity+2]; unsigned int a_bits,b_bits,a_size,b_size,n,arg_n; @@ -1921,14 +1999,23 @@ int CodeRhsNodeDefs if (node_p!=NULL){ NodeIdP node_def_id; +#if STRICT_LISTS + NodeP fill_unique_node; + + fill_unique_node=NULL; +#else NodeP push_node; - - node_def_id=last_node_def_p->def_id; - + push_node=NULL; - +#endif + node_def_id=last_node_def_p->def_id; + if (node_p->node_kind==FillUniqueNode){ +#if STRICT_LISTS + fill_unique_node=node_p; +#else push_node=node_p->node_node; +#endif node_p=node_p->node_arguments->arg_node; } @@ -1936,9 +2023,11 @@ int CodeRhsNodeDefs *last_node_def_h=NULL; CodeSharedNodeDefs (defs,NULL,&asp,&bsp,&code_gen_node_ids); *last_node_def_h=last_node_def_p; - +#if STRICT_LISTS + generate_code_for_tail_call_modulo_cons (node_p,node_def_id,root_node,fill_unique_node,asp,bsp,&code_gen_node_ids); +#else generate_code_for_tail_call_modulo_cons (node_p,node_def_id,root_node,push_node,asp,bsp,&code_gen_node_ids); - +#endif while (moved_node_ids!=NULL){ moved_node_ids->mnid_node_id->nid_a_index_=moved_node_ids->mnid_a_stack_offset; moved_node_ids=moved_node_ids->mnid_next; @@ -1949,14 +2038,25 @@ int CodeRhsNodeDefs } } } else { - NodeP node_p,push_node_p; + NodeP node_p; NodeIdP node_id_p; +#if STRICT_LISTS + NodeP fill_unique_node_p; + + fill_unique_node_p=NULL; +#else + NodeP push_node_p; - node_p=arg_p2->arg_node; push_node_p=NULL; +#endif + node_p=arg_p2->arg_node; if (node_p->node_kind==FillUniqueNode){ +#if STRICT_LISTS + fill_unique_node_p=node_p->node_node; +#else push_node_p=node_p->node_node; +#endif node_p=node_p->node_arguments->arg_node; } @@ -1971,9 +2071,11 @@ int CodeRhsNodeDefs arg_p2->arg_node=NewNodeIdNode (node_id_p); CodeSharedNodeDefs (defs,NULL,&asp,&bsp,&code_gen_node_ids); - +#if STRICT_LISTS + generate_code_for_tail_call_modulo_cons (node_p,node_id_p,root_node,fill_unique_node_p,asp,bsp,&code_gen_node_ids); +#else generate_code_for_tail_call_modulo_cons (node_p,node_id_p,root_node,push_node_p,asp,bsp,&code_gen_node_ids); - +#endif while (moved_node_ids!=NULL){ moved_node_ids->mnid_node_id->nid_a_index_=moved_node_ids->mnid_a_stack_offset; moved_node_ids=moved_node_ids->mnid_next; @@ -1995,8 +2097,8 @@ int CodeRhsNodeDefs !(IsSemiStrictState (root_node->node_state) || IsSimpleState (root_node->node_state)) ){ int a_size,b_size,n,tuple_arity; - ArgP tuple_element_p; /* + ArgP tuple_element_p; unsigned long result_and_call_same_select_vector; result_and_call_same_select_vector=0; diff --git a/backendC/CleanCompilerSources/comparser_2.c b/backendC/CleanCompilerSources/comparser_2.c index c784f16..64a0eab 100644 --- a/backendC/CleanCompilerSources/comparser_2.c +++ b/backendC/CleanCompilerSources/comparser_2.c @@ -132,11 +132,11 @@ InitParser (void) NilSymbol->symb_tail_strictness=0; StrictListSymbol= NewSymbol (list_type); - StrictListSymbol->symb_head_strictness=1; + StrictListSymbol->symb_head_strictness=2; StrictListSymbol->symb_tail_strictness=0; UnboxedListSymbol= NewSymbol (list_type); - UnboxedListSymbol->symb_head_strictness=2; + UnboxedListSymbol->symb_head_strictness=3; UnboxedListSymbol->symb_tail_strictness=0; TailStrictListSymbol= NewSymbol (list_type); @@ -144,19 +144,19 @@ InitParser (void) TailStrictListSymbol->symb_tail_strictness=1; StrictTailStrictListSymbol= NewSymbol (list_type); - StrictTailStrictListSymbol->symb_head_strictness=1; + StrictTailStrictListSymbol->symb_head_strictness=2; StrictTailStrictListSymbol->symb_tail_strictness=1; UnboxedTailStrictListSymbol= NewSymbol (list_type); - UnboxedTailStrictListSymbol->symb_head_strictness=2; + UnboxedTailStrictListSymbol->symb_head_strictness=3; UnboxedTailStrictListSymbol->symb_tail_strictness=1; StrictConsSymbol= NewSymbol (cons_symb); - StrictConsSymbol->symb_head_strictness=1; + StrictConsSymbol->symb_head_strictness=2; StrictConsSymbol->symb_tail_strictness=0; UnboxedConsSymbol= NewSymbol (cons_symb); - UnboxedConsSymbol->symb_head_strictness=2; + UnboxedConsSymbol->symb_head_strictness=3; UnboxedConsSymbol->symb_tail_strictness=0; TailStrictConsSymbol= NewSymbol (cons_symb); @@ -164,19 +164,19 @@ InitParser (void) TailStrictConsSymbol->symb_tail_strictness=1; StrictTailStrictConsSymbol= NewSymbol (cons_symb); - StrictTailStrictConsSymbol->symb_head_strictness=1; + StrictTailStrictConsSymbol->symb_head_strictness=2; StrictTailStrictConsSymbol->symb_tail_strictness=1; UnboxedTailStrictConsSymbol= NewSymbol (cons_symb); - UnboxedTailStrictConsSymbol->symb_head_strictness=2; + UnboxedTailStrictConsSymbol->symb_head_strictness=3; UnboxedTailStrictConsSymbol->symb_tail_strictness=1; StrictNilSymbol = NewSymbol (nil_symb); - StrictNilSymbol->symb_head_strictness=1; + StrictNilSymbol->symb_head_strictness=2; StrictNilSymbol->symb_tail_strictness=0; UnboxedNilSymbol = NewSymbol (nil_symb); - UnboxedNilSymbol->symb_head_strictness=2; + UnboxedNilSymbol->symb_head_strictness=3; UnboxedNilSymbol->symb_tail_strictness=0; TailStrictNilSymbol = NewSymbol (nil_symb); @@ -184,11 +184,11 @@ InitParser (void) TailStrictNilSymbol->symb_tail_strictness=1; StrictTailStrictNilSymbol = NewSymbol (nil_symb); - StrictTailStrictNilSymbol->symb_head_strictness=1; + StrictTailStrictNilSymbol->symb_head_strictness=2; StrictTailStrictNilSymbol->symb_tail_strictness=1; UnboxedTailStrictNilSymbol = NewSymbol (nil_symb); - UnboxedTailStrictNilSymbol->symb_head_strictness=2; + UnboxedTailStrictNilSymbol->symb_head_strictness=3; UnboxedTailStrictNilSymbol->symb_tail_strictness=1; #endif diff --git a/backendC/CleanCompilerSources/compiledefines.h b/backendC/CleanCompilerSources/compiledefines.h index b7d762d..a49163b 100644 --- a/backendC/CleanCompilerSources/compiledefines.h +++ b/backendC/CleanCompilerSources/compiledefines.h @@ -18,6 +18,6 @@ #define WRITE_DCL_MODIFICATION_TIME 1 -#define STRICT_LISTS 0 +#define STRICT_LISTS 1 #undef KARBON
\ No newline at end of file diff --git a/backendC/CleanCompilerSources/instructions.c b/backendC/CleanCompilerSources/instructions.c index 12ec681..dafb606 100644 --- a/backendC/CleanCompilerSources/instructions.c +++ b/backendC/CleanCompilerSources/instructions.c @@ -151,8 +151,6 @@ static Bool DescriptorNeeded (SymbDef sdef) ((DoParallel || DoDescriptors) && (sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK))); } -/* extern Ident StdArrayId; */ - static void GenLabel (Label label) { if (label->lab_issymbol){ @@ -160,8 +158,6 @@ static void GenLabel (Label label) char *module_name; def=label->lab_symbol; -/* module_name = def->sdef_arfun<NoArrayFun ? StdArrayId->ident_name : label->lab_mod; */ - module_name = label->lab_mod; if (module_name!=NULL) @@ -192,7 +188,6 @@ static void GenDescriptorOrNodeEntryLabel (Label label) char *module_name; def=label->lab_symbol; - module_name = label->lab_mod; if (module_name!=NULL) @@ -544,6 +539,8 @@ enum { #define IeqI_b "eqI_b" #define IeqR_b "eqR_b" +#define InotB "notB" + #define IpushB "pushB" #define IpushI "pushI" #define IpushC "pushC" @@ -931,6 +928,11 @@ void EqBasic (ObjectKind obj, SymbValue val, int offset) } } +void GenNotB (void) +{ + put_instruction (InotB); +} + void PushBasicFromAOnB (ObjectKind kind,int offset) { switch (kind){ @@ -2752,11 +2754,50 @@ void GenRecordDescriptor (SymbDef sdef) GenABStackElems (recstate); - DetermineSizeOfState (recstate,&asize,&bsize); + DetermineSizeOfState (recstate,&asize,&bsize); FPrintF (OutFile, " %d %d \"%s\"",asize,bsize,name); } +#ifdef STRICT_LISTS +void GenUnboxedConsRecordDescriptor (SymbDef sdef,int tail_strict) +{ + int asize,bsize; + char *name,*unboxed_record_cons_prefix; + StateS tuple_state,tuple_arguments_state[2]; + + name = sdef->sdef_ident->ident_name; + + unboxed_record_cons_prefix=tail_strict ? "r_Cons#!" : "r_Cons#"; + + if (sdef->sdef_exported || ExportLocalLabels){ + put_directive_ (Dexport); + FPrintF (OutFile, "e_%s_%s%s",CurrentModule,unboxed_record_cons_prefix,name); + put_directive_ (Drecord); + FPrintF (OutFile, "e_%s_%s%s ",CurrentModule,unboxed_record_cons_prefix,name); + } else if (DoDebug){ + put_directive_ (Drecord); + FPrintF (OutFile, "%s%s ",unboxed_record_cons_prefix,name); + } else { + put_directive_ (Drecord); + FPrintF (OutFile, "%s%u ",unboxed_record_cons_prefix,sdef->sdef_number); + } + + tuple_state.state_type=TupleState; + tuple_state.state_arity=2; + tuple_state.state_tuple_arguments=tuple_arguments_state; + + tuple_arguments_state[0] = sdef->sdef_record_state; + tuple_arguments_state[1] = LazyState; + + GenABStackElems (tuple_state); + + DetermineSizeOfState (tuple_state,&asize,&bsize); + + FPrintF (OutFile,tail_strict ? " %d %d \"[#%s!]\"" : " %d %d \"[#%s]\"",asize,bsize,name); +} +#endif + void GenStrictConstructorDescriptor (SymbDef sdef,StateP constructor_arg_state_p) { int asize,bsize,state_arity,arg_n; diff --git a/backendC/CleanCompilerSources/instructions.h b/backendC/CleanCompilerSources/instructions.h index fc3790b..c140d80 100644 --- a/backendC/CleanCompilerSources/instructions.h +++ b/backendC/CleanCompilerSources/instructions.h @@ -17,6 +17,7 @@ void IsString (SymbValue val); void PushBasic (ObjectKind obj, SymbValue val); void EqBasic (ObjectKind obj, SymbValue val, int offset); +void GenNotB(void); void PushBasicFromAOnB (ObjectKind kind,int offset); void GenPushD_a (int a_offset); @@ -165,6 +166,9 @@ void GenFunctionDescriptorForLazyTupleRecursion (SymbDef sdef,int tuple_result_a void GenLazyRecordDescriptorAndExport (SymbDef sdef); void GenFieldSelectorDescriptor (SymbDef sdef,int has_gc_apply_entry); void GenRecordDescriptor (SymbDef sdef); +#ifdef STRICT_LISTS +void GenUnboxedConsRecordDescriptor (SymbDef sdef,int tail_strict); +#endif void GenStrictConstructorDescriptor (SymbDef sdef,StateP constructor_arg_state_p); void GenArrayFunctionDescriptor (SymbDef arr_fun_def, Label desclab, int arity); diff --git a/backendC/CleanCompilerSources/optimisations.c b/backendC/CleanCompilerSources/optimisations.c index f0ffede..5b17f44 100644 --- a/backendC/CleanCompilerSources/optimisations.c +++ b/backendC/CleanCompilerSources/optimisations.c @@ -1552,7 +1552,7 @@ static void optimise_normal_node (Node node) if ((BETWEEN (int_denot,real_denot,symbol->symb_kind) || symbol->symb_kind==string_denot # if STRICT_LISTS - || (BETWEEN (tuple_symb,nil_symb,symbol->symb_kind) && !(symbol->symb_kind==cons_symb && (symbol->symb_head_strictness || symbol->symb_tail_strictness))) + || (BETWEEN (tuple_symb,nil_symb,symbol->symb_kind) && !(symbol->symb_kind==cons_symb && (symbol->symb_head_strictness>1 || symbol->symb_tail_strictness))) # else || BETWEEN (tuple_symb,nil_symb,symbol->symb_kind) # endif @@ -1759,7 +1759,11 @@ static NodeP replace_node_by_unique_fill_node (NodeP node,NodeP push_node,int no node->node_arguments=arg_p; node->node_arity=1; +#if STRICT_LISTS + push_node->node_push_size=node_size; +#else push_node->node_line=node_size; +#endif --push_node->node_arguments->arg_node->node_node_id->nid_refcount; push_node->node_number=1; @@ -1910,8 +1914,20 @@ static Bool try_insert_constructor_update_node (NodeP node,FreeUniqueNodeIdsP *f } case cons_symb: #if STRICT_LISTS - if ((node->node_symbol->symb_head_strictness || node->node_symbol->symb_tail_strictness) && IsLazyStateKind (node->node_state.state_kind)) - return False; + if (node->node_symbol->symb_head_strictness>1 || node->node_symbol->symb_tail_strictness){ + if (!IsLazyStateKind (node->node_state.state_kind) && !(node->node_symbol->symb_head_strictness & 1) && node->node_arity==2){ + if (node->node_symbol->symb_head_strictness!=4) + return insert_unique_fill_node (node,f_node_ids,2,0); + else { + int a_size,b_size; + + DetermineSizeOfArguments (node->node_arguments,&a_size,&b_size); + + return insert_unique_fill_node (node,f_node_ids,a_size,b_size); + } + } else + return False; + } else #endif return insert_unique_fill_node (node,f_node_ids,2,0); case tuple_symb: @@ -2429,6 +2445,11 @@ static FreeUniqueNodeIdsP check_unique_push_node (NodeP node,FreeUniqueNodeIdsP { NodeIdP node_id_p; +# if STRICT_LISTS + if (node->node_symbol->symb_kind==cons_symb && (node->node_symbol->symb_head_strictness & 1)) + return f_node_ids; +#endif + node_id_p=node->node_arguments->arg_node->node_node_id; if (switch_node_id_refcount==-1 && (node_id_p->nid_mark & NID_EXTRA_REFCOUNT_MASK)==0){ diff --git a/backendC/CleanCompilerSources/sa.c b/backendC/CleanCompilerSources/sa.c index 054e9e8..7e27750 100644 --- a/backendC/CleanCompilerSources/sa.c +++ b/backendC/CleanCompilerSources/sa.c @@ -2193,7 +2193,7 @@ static Exp ConvertNode (Node node, NodeId nid) break; case cons_symb: #if STRICT_LISTS - if (node->node_symbol->symb_head_strictness){ + if (node->node_symbol->symb_head_strictness>1){ e->e_fun = node->node_symbol->symb_tail_strictness ? strict_tail_strict_cons_sym : strict_cons_sym; break; } else if (node->node_symbol->symb_tail_strictness){ @@ -2503,7 +2503,7 @@ static Exp convert_pattern (SymbolP symbol_p,int arity,NodeIdListElementP node_i break; case cons_symb: #if STRICT_LISTS - if (symbol_p->symb_head_strictness){ + if (symbol_p->symb_head_strictness>1){ e->e_fun = symbol_p->symb_tail_strictness ? strict_tail_strict_cons_sym : strict_cons_sym; break; } else if (symbol_p->symb_tail_strictness){ @@ -5126,7 +5126,7 @@ static void FindStrictPropertiesOfFunction (Fun *f) if (! IsAnalysableFun (f)) return; - + max_depth_reached = False; max_time_reached = False; CurrentName = f->fun_symbol->sdef_ident->ident_name; diff --git a/backendC/CleanCompilerSources/statesgen.c b/backendC/CleanCompilerSources/statesgen.c index 81ee8de..e78ab50 100644 --- a/backendC/CleanCompilerSources/statesgen.c +++ b/backendC/CleanCompilerSources/statesgen.c @@ -1193,6 +1193,10 @@ void ExamineTypesAndLhsOfSymbolDefinition (SymbDef def) } } +#if STRICT_LISTS +extern PolyList unboxed_record_cons_list,unboxed_record_decons_list; +#endif + void ExamineTypesAndLhsOfSymbols (Symbol symbs) { next_def_number = 1; @@ -1203,6 +1207,16 @@ void ExamineTypesAndLhsOfSymbols (Symbol symbs) symbs=symbs->symb_next; } +#if STRICT_LISTS + { + PolyList unboxed_record_cons_elem,unboxed_record_decons_elem; + + for_l (unboxed_record_cons_elem,unboxed_record_cons_list,pl_next) + ExamineTypesAndLhsOfSymbolDefinition (unboxed_record_cons_elem->pl_elem); + for_l (unboxed_record_decons_elem,unboxed_record_decons_list,pl_next) + ExamineTypesAndLhsOfSymbolDefinition (unboxed_record_decons_elem->pl_elem); + } +#endif } extern PolyList UserDefinedArrayFunctions; @@ -1740,8 +1754,11 @@ static Bool NodeInAStrictContext (Node node,StateS demanded_state,int local_scop case cons_symb: #if STRICT_LISTS if (node->node_arity==2){ - if (rootsymb->symb_head_strictness) - parallel = DetermineStrictArgContext (node->node_arguments,StrictState,local_scope); + if (rootsymb->symb_head_strictness>1) + if (rootsymb->symb_head_strictness==4) + parallel = DetermineStrictArgContext (node->node_arguments,*rootsymb->symb_unboxed_cons_state_p,local_scope); + else + parallel = DetermineStrictArgContext (node->node_arguments,StrictState,local_scope); if (rootsymb->symb_tail_strictness) parallel = DetermineStrictArgContext (node->node_arguments->arg_next,StrictState,local_scope); } @@ -1749,6 +1766,11 @@ static Bool NodeInAStrictContext (Node node,StateS demanded_state,int local_scop if (ShouldDecrRefCount) DecrRefCountCopiesOfArgs (node->node_arguments IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); case nil_symb: +#if STRICT_LISTS + if (rootsymb->symb_head_strictness & 1) + parallel = DetermineStrictArgContext (node->node_arguments,StrictState,local_scope); +#endif + SetUnaryState (&node->node_state, StrictOnA, ListObj); break; case apply_symb: @@ -2589,30 +2611,30 @@ static void DetermineStatesOfNodeAndDefs (Node root_node,NodeDefs node_defs,Stat # ifdef REUSE_UNIQUE_NODES if (symbol->symb_kind==cons_symb && (node_id_state_p->state_mark & STATE_UNIQUE_MASK) && case_alt_node_p->node_arity==2){ NodeIdP node_id_p; + StateP element_state_p; node_id_p=node_ids->nidl_node_id; node_id_p->nid_ref_count_copy=node_id_p->nid_refcount; - +# if STRICT_LISTS + if (symbol->symb_head_strictness>1) + if (symbol->symb_head_strictness==4) + element_state_p=symbol->symb_state_p; + else + element_state_p=&StrictState; + else +# endif + element_state_p=&LazyState; + if ((node_id_state_p->state_mark & STATE_UNIQUE_TYPE_ARGUMENTS_MASK) && (node_id_state_p->state_unq_type_args & 1)){ StateP unique_state_p; unique_state_p=CompAllocType (StateS); -# if STRICT_LISTS - if (symbol->symb_head_strictness) - *unique_state_p=StrictState; - else -# endif - *unique_state_p=LazyState; + *unique_state_p=*element_state_p; unique_state_p->state_mark |= STATE_UNIQUE_MASK; node_id_p->nid_lhs_state_p_=unique_state_p; } else -# if STRICT_LISTS - if (symbol->symb_head_strictness) - node_id_p->nid_lhs_state_p_=&StrictState; - else -# endif - node_id_p->nid_lhs_state_p_=&LazyState; + node_id_p->nid_lhs_state_p_=element_state_p; node_ids=node_ids->nidl_next; @@ -2629,6 +2651,7 @@ static void DetermineStatesOfNodeAndDefs (Node root_node,NodeDefs node_defs,Stat else # endif *unique_state_p=LazyState; + unique_state_p->state_mark |= STATE_UNIQUE_MASK; if ((node_id_state_p->state_mark & STATE_UNIQUE_TYPE_ARGUMENTS_MASK) && (node_id_state_p->state_unq_type_args & 1)){ unique_state_p->state_mark |= STATE_UNIQUE_TYPE_ARGUMENTS_MASK; @@ -2661,11 +2684,11 @@ static void DetermineStatesOfNodeAndDefs (Node root_node,NodeDefs node_defs,Stat } else # endif # if STRICT_LISTS - if (symbol->symb_kind==cons_symb && (symbol->symb_head_strictness || symbol->symb_tail_strictness) && case_alt_node_p->node_arity==2){ + if (symbol->symb_kind==cons_symb && (symbol->symb_head_strictness>1 || symbol->symb_tail_strictness) && case_alt_node_p->node_arity==2){ NodeIdP node_id_p; node_id_p=node_ids->nidl_node_id; - node_id_p->nid_lhs_state_p_= symbol->symb_head_strictness ? &StrictState : &LazyState; + node_id_p->nid_lhs_state_p_= symbol->symb_head_strictness>1 ? (symbol->symb_head_strictness==4 ? symbol->symb_state_p : &StrictState) : &LazyState; node_id_p->nid_ref_count_copy=node_id_p->nid_refcount; node_id_p=node_ids->nidl_next->nidl_node_id; diff --git a/backendC/CleanCompilerSources/syntaxtr.t b/backendC/CleanCompilerSources/syntaxtr.t index 6259035..3b58edb 100644 --- a/backendC/CleanCompilerSources/syntaxtr.t +++ b/backendC/CleanCompilerSources/syntaxtr.t @@ -4,8 +4,6 @@ #include "compiledefines.h" -#define D 0 - #define class class_is_keyword #define new new_is_keyword @@ -77,33 +75,6 @@ typedef enum { erroneous_symb } SymbKind; -#if D - -STRUCT (state,State){ - union { - struct { - StateKind arg_kind; /* for SimpleState */ - ObjectKind arg_object; - } state_arg; - struct state * state_args; /* for TupleState and ArrayState */ - struct record_state_descr * state_rs; /* for RecordState */ - }; - short state_arity; - unsigned char state_type; /* StateType */ - unsigned char state_mark; -}; - -#define state_kind state_arg.arg_kind -#define state_object state_arg.arg_object - -#define state_record_symbol state_rs->rs_symb -#define state_record_arguments state_rs->rs_args -#define state_record_desc state_rs -#define state_tuple_arguments state_args -#define state_array_arguments state_args - -#else - STRUCT (state,State){ union { struct state * sd_args; /* for TupleState and ArrayState */ @@ -126,7 +97,6 @@ STRUCT (state,State){ # define state_record_desc state_descr.sd_rs # define state_tuple_arguments state_descr.sd_args # define state_array_arguments state_descr.sd_args -#endif typedef struct state *States; @@ -157,8 +127,19 @@ typedef union symb_value { struct symbol_type * val_type; /* for cons_symb, nil_symb apply_symbol ? */ struct symbol * val_symb; /* for field_symbol_list */ struct overloaded_instance * val_instance; +#if STRICT_LISTS + struct state * val_state_p; /* element state for unboxed list cons in lhs */ + struct unboxed_cons * val_unboxed_cons_p; /* state and symbol definition for unboxed list cons in rhs */ +#endif } SymbValue; +#if STRICT_LISTS +struct unboxed_cons { + struct state * unboxed_cons_state_p; + struct symbol_def * unboxed_cons_sdef_p; +}; +#endif + STRUCT (symbol,Symbol) { SymbValue symb_val; Symbol symb_next; @@ -169,8 +150,13 @@ STRUCT (symbol,Symbol) { }; #if STRICT_LISTS -# define symb_head_strictness symb_infix_priority /* 0=lazy,1=strict,2=unboxed */ +# define symb_head_strictness symb_infix_priority /* 0=lazy,1=overloaded,2=strict,3=unboxed overloaded,4=unboxed*/ # define symb_tail_strictness symb_infix_assoc /* 0=lazy,1=strict */ + +# define symb_state_p symb_val.val_state_p +# define symb_unboxed_cons_p symb_val.val_unboxed_cons_p +# define symb_unboxed_cons_state_p symb_val.val_unboxed_cons_p->unboxed_cons_state_p +# define symb_unboxed_cons_sdef_p symb_val.val_unboxed_cons_p->unboxed_cons_sdef_p #endif #define symb_ident symb_val.val_ident @@ -289,141 +275,6 @@ typedef struct { struct _exp; -#if D - -extern void error (void); - -#define UNION_FIELD(type,field,field_i,field_n)\ - inline type const &field (void){ return field_i!=field_n ? error(),_##field : _##field; };\ - inline type &field##_ (void){ field_i=field_n; return _##field; } - -#define UNION2(i,t1,f1,t2,f2)\ - union {\ - t1 _##f1;\ - t2 _##f2;\ - };\ - UNION_FIELD(t1,f1,i,1);\ - UNION_FIELD(t2,f2,i,2) - -#define UNION4(i,t1,f1,t2,f2,t3,f3,t4,f4)\ - union {\ - t1 _##f1;\ - t2 _##f2;\ - t3 _##f3;\ - t4 _##f4;\ - };\ - UNION_FIELD(t1,f1,i,1);\ - UNION_FIELD(t2,f2,i,2);\ - UNION_FIELD(t3,f3,i,3);\ - UNION_FIELD(t4,f4,i,4) - -STRUCT (node_id,NodeId){ -private: - unsigned int nid_u1:4; - unsigned int nid_u2:4; - unsigned int nid_u3:4; - unsigned int nid_u4:4; - unsigned int nid_u5:4; -public: - node_id (void) { - nid_u1=0; - nid_u2=0; - nid_u3=0; - nid_u4=0; - nid_u5=0; - }; - - Ident nid_ident; - unsigned short nid_mark; - unsigned short nid_mark2; - int nid_refcount; - int nid_number; - - UNION4 (nid_u1, - struct node_id * ,nid_forward_node_id, - struct type_cell * ,nid_type, - Index ,nid_index, - struct node_id_ref_count_list * ,nid_node_id_ref_count_element /* pattern_match: graph */ - ); - #define nid_forward_node_id nid_forward_node_id() - #define nid_forward_node_id_ nid_forward_node_id_() - #define nid_type nid_type() - #define nid_type_ nid_type_() - #define nid_index nid_index() - #define nid_index_ nid_index_() - #define nid_node_id_ref_count_element nid_node_id_ref_count_element() - #define nid_node_id_ref_count_element_ nid_node_id_ref_count_element_() - - union { - struct { - union { - struct node * s1_subst_node; - struct node_id * s1_subst_node_id; - struct reference_info * s1_ref_info; - }; - int s1_ref_count_copy; - } nid_s1; - StateS _nid_state; - }; - - inline struct node *const &nid_subst_node (void){ return nid_u4!=1 ? error(),nid_s1.s1_subst_node : nid_s1.s1_subst_node; }; - inline struct node * &nid_subst_node_ (void){ nid_u4=1; return nid_s1.s1_subst_node; } - #define nid_subst_node nid_subst_node() - #define nid_subst_node_ nid_subst_node_() - - inline struct node_id *const &nid_subst_node_id (void){ return (nid_u4!=2 || nid_u5!=1) ? error(),nid_s1.s1_subst_node_id : nid_s1.s1_subst_node_id; }; - inline struct node_id * &nid_subst_node_id_ (void){ nid_u4=2; return nid_s1.s1_subst_node_id; } - #define nid_subst_node_id nid_subst_node_id() - #define nid_subst_node_id_ nid_subst_node_id_() - - inline struct reference_info *const &nid_ref_info (void){ return (nid_u4!=3 || nid_u5!=1) ? error(),nid_s1.s1_ref_info : nid_s1.s1_ref_info; }; - inline struct reference_info * &nid_ref_info_ (void){ nid_u4=3; return nid_s1.s1_ref_info; } - #define nid_reference_info nid_ref_info() - #define nid_reference_info_ nid_ref_info_() - - inline int const &nid_ref_count_copy (void){ return nid_u5!=1 ? error(),nid_s1.s1_ref_count_copy : nid_s1.s1_ref_count_copy; }; - inline int &nid_ref_count_copy_ (void){ nid_u5=1; return nid_s1.s1_ref_count_copy; } - inline int &nid_ref_count_copy__ (void){ return nid_u5!=1 ? error(),nid_s1.s1_ref_count_copy : nid_s1.s1_ref_count_copy; }; - #define nid_ref_count_copy nid_ref_count_copy() - #define nid_ref_count_copy_ nid_ref_count_copy_() - #define nid_ref_count_copy__ nid_ref_count_copy__() - - inline StateS const &nid_state (void){ return (nid_u4!=4 || nid_u5!=2) ? error(),_nid_state : _nid_state; }; - inline StateS &nid_state_ (void){ nid_u4=4; nid_u5=2; return _nid_state; } - inline StateS &nid_state__ (void){ return (nid_u4!=4 || nid_u5!=2) ? error(),_nid_state : _nid_state; }; - #define nid_state nid_state() - #define nid_state_ nid_state_() - #define nid_state__ nid_state__() - - int nid_scope; - struct node * nid_node; - - UNION2(nid_u2, - struct _exp * ,nid_exp, - struct node_id* ,nid_lhs_tuple_node_id - ); - #define nid_exp nid_exp() - #define nid_exp_ nid_exp_() - #define nid_lhs_tuple_node_id nid_lhs_tuple_node_id() - #define nid_lhs_tuple_node_id_ nid_lhs_tuple_node_id_() - - UNION2(nid_u3, - NodeDefs ,nid_node_def, /* only for rhs */ - struct state * ,nid_lhs_state_p /* only for lhs */ - ); - #define nid_node_def nid_node_def() - #define nid_node_def_ nid_node_def_() - #define nid_lhs_state_p nid_lhs_state_p() - #define nid_lhs_state_p_ nid_lhs_state_p_() -}; - -#define nid_a_index nid_index.index_a /* codegen2,instructions */ -#define nid_a_index_ nid_index_.index_a /* codegen2,instructions */ -#define nid_b_index nid_index.index_b /* codegen2,instructions */ -#define nid_b_index_ nid_index_.index_b /* codegen2,instructions */ - -#else - STRUCT (node_id,NodeId){ Ident nid_ident; unsigned short nid_mark; @@ -499,7 +350,6 @@ STRUCT (node_id,NodeId){ #define nid_exp_ nid_exp #define nid_lhs_state_p_ nid_lhs_state_p #define nid_reference_info_ nid_reference_info -#endif /* Masks for nid_mark */ @@ -630,7 +480,7 @@ STRUCT (node,Node){ struct recursive_call * u_recursive_call; /* typechecker */ struct overloaded_function *u_overloaded_application; /* typechecker */ } s_u; - int s_line; /* size for PushNode */ + int s_line; /* size for PushNode if not STRICT_LISTS) */ } su_s; struct { struct node_def * u_node_defs; /* for CaseNode,DefaultNode and GuardNode */ @@ -644,6 +494,15 @@ STRUCT (node,Node){ struct node_def * scope_node_defs; struct imp_rule * scope_imp_rules; } su_scope; /* for ScopeNode */ +#if STRICT_LISTS + struct { + SymbolP push_symbol; + union { + NodeP pu_decons_node; /* if overloaded push */ + int pu_size; /* if unique non overloaded push */ + } push_pu; + } su_push; /* for PushNode */ +#endif } node_su; short node_arity; @@ -687,6 +546,12 @@ STRUCT (node,Node){ #define node_scope_node_defs node_su.su_scope.scope_node_defs #define node_scope_imp_rules node_su.su_scope.scope_imp_rules +#if STRICT_LISTS +# define node_push_symbol node_su.su_push.push_symbol +# define node_decons_node node_su.su_push.push_pu.pu_decons_node +# define node_push_size node_su.su_push.push_pu.pu_size +#endif + #define node_then_observer_list node_contents.contents_if->if_then_observer_list #define node_else_observer_list node_contents.contents_if->if_else_observer_list @@ -911,7 +776,9 @@ STRUCT (symbol_def,SymbDef){ StateS typeinfo_record_state; struct { FieldList fieldinfo_sel_field; +#ifndef CLEAN2 Node fieldinfo_sel_node; +#endif int fieldinfo_sel_field_number; } sdef_fieldinfo; struct constructor_list * typeinfo_constructor; /* for CONSTRUCTOR */ @@ -926,7 +793,12 @@ STRUCT (symbol_def,SymbDef){ union { struct _fun * u3_sa_fun; /* sa.c */ +#ifdef CLEAN2 + SymbolP u3_unboxed_cons_symbol; /* backend.c */ +#endif +#ifndef CLEAN2 unsigned u3_instantiation_depth; +#endif } sdef_u3; struct symbol_def * sdef_dcl_icl; /* to dcl if sdef_exported, to icl if sdef_main_dcl */ @@ -1011,6 +883,9 @@ STRUCT (symbol_def,SymbDef){ #define sdef_instantiation_depth sdef_u3.u3_instantiation_depth #define sdef_sa_fun sdef_u3.u3_sa_fun +#ifdef CLEAN2 + #define sdef_unboxed_cons_symbol sdef_u3.u3_unboxed_cons_symbol +#endif #define sdef_next_scc sdef_u1.u1_next_scc #define sdef_subst_symbol sdef_u1.u1_subst_symbol /* macros */ diff --git a/backendC/CleanCompilerSources/typeconv_2.c b/backendC/CleanCompilerSources/typeconv_2.c index f4a82be..63f4090 100644 --- a/backendC/CleanCompilerSources/typeconv_2.c +++ b/backendC/CleanCompilerSources/typeconv_2.c @@ -478,9 +478,9 @@ static void PrintNode (TypeNode node, Bool brackets, Bool strict_context, Bool p case list_type: FPutC ('[', StdListTypes); #if STRICT_LISTS - if (node->type_node_symbol->symb_head_strictness==1) + if (node->type_node_symbol->symb_head_strictness==2) FPutC ('!', StdListTypes); - else if (node->type_node_symbol->symb_head_strictness==2) + else if (node->type_node_symbol->symb_head_strictness==3 || node->type_node_symbol->symb_head_strictness==4) FPutC ('#', StdListTypes); #endif PrintArguments (node -> type_node_arguments, ',', cDontPrintBrackets, cNotInAStrictContext, NULL); |