diff options
97 files changed, 48806 insertions, 0 deletions
diff --git a/backendC/CleanCompilerSources/MAIN_CLM.d b/backendC/CleanCompilerSources/MAIN_CLM.d new file mode 100644 index 0000000..8a85421 --- /dev/null +++ b/backendC/CleanCompilerSources/MAIN_CLM.d @@ -0,0 +1,3 @@ +#if ((defined (__MWERKS__) && !defined (__INTEL__)) || defined (__MRC__)) /* && !defined (MAKE_MPW_TOOL) */ +# define MAIN_CLM +#endif diff --git a/backendC/CleanCompilerSources/apple_main.c b/backendC/CleanCompilerSources/apple_main.c new file mode 100644 index 0000000..2734724 --- /dev/null +++ b/backendC/CleanCompilerSources/apple_main.c @@ -0,0 +1,405 @@ + +#include <stdio.h> +#include <unix.h> +#include <SIOUX.h> + +#include <quickdraw.h> +#include <fonts.h> +#include <events.h> +#include <windows.h> +#include <memory.h> +#include <resources.h> +#include <menus.h> +#include <OSUtils.h> +#include "AppleEvents.h" +#include "Gestalt.h" +#include "AERegistry.h" + +#include "system.h" +#include "path_cache.h" +#include "compiler.h" + +extern void clear_inline_cache (void); + +#undef BACKGROUND +#define MW_DEBUG 0 + +#ifndef BACKGROUND +# undef NO_REDIRECT_STDFILES +# undef STDIO_WINDOW +#endif + +#define LINKER +#define CODE_GENERATOR +#undef PROFILE + +#if 1 + +#define kSleepMax 50000 + +static Boolean gAppleEventsFlag, gQuitFlag; +static long gSleepVal; + +static pascal OSErr DoAEOpenApplication (AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent,long refCon) +{ + return noErr; +} + +static pascal OSErr DoAEOpenDocuments (AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent, long refCon) +{ + return errAEEventNotHandled; +} + +static pascal OSErr DoAEPrintDocuments (AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent,long refCon) +{ + return errAEEventNotHandled; +} + +static pascal OSErr DoAEQuitApplication (AppleEvent *theAppleEvent,AppleEvent *replyAppleEvent,long refCon) +{ + gQuitFlag = true; + return noErr; +} + +#include <string.h> + +extern int CallCompiler (int argc,char **argv); + +#ifdef CODE_GENERATOR +# ifdef __cplusplus + extern "C" { int generate_code (int,char **); } + extern int generate_code68 (int,char **); +# else + extern int generate_code (int,char **); + extern int generate_code68__FiPPc (int,char **); + #define generate_code68 generate_code68__FiPPc +# endif +#endif + +#ifdef LINKER +# ifdef __cplusplus + extern "C" { int link_application_argc_argv (int,char **); } +# else + extern int link_application_argc_argv (int,char **); +# endif +#endif + +char return_error_string[200]; + +int do_command (char *command) +{ + char *p,*(argv[257]); + int argc,result; + int redirect_stdout,redirect_stderr; + + result=0; + + redirect_stdout=0; + redirect_stderr=0; + + argc=0; + p=command; + + while (*p==' ' || *p=='\t') + ++p; + + while (*p!='\0' && argc<256){ + if (*p=='>' || *p=='„'){ + int redirection_char; + char *file_name; + + redirection_char=*p; + + ++p; + while (*p==' ' || *p=='\t') + ++p; + if (*p=='\0') + break; + + if (*p=='\''){ + char c,*d_p; + + ++p; + file_name=p; + + d_p=p; + + c=*p; + while (!(c=='\'' && p[1]!='\'') && c!='\0'){ + *d_p++=c; + if (c=='\'') + ++p; + c=*++p; + } + + if (*p=='\0'){ + *d_p='\0'; + break; + } + + *d_p='\0'; + ++p; + } else { + file_name=p; + + while (*p!=' ' && *p!='\t' && *p!='\0') + ++p; + if (*p!='\0') + *p++='\0'; + } + + if (redirection_char=='>' && redirect_stdout==0){ +#ifndef NO_REDIRECT_STDFILES + freopen (file_name,"w",stdout); + redirect_stdout=1; +#endif + } else if (redirection_char=='„' && redirect_stderr==0){ +#ifndef NO_REDIRECT_STDFILES + freopen (file_name,"w",stderr); + redirect_stderr=1; +#endif + } + + if (*p=='\0') + break; + + while (*p==' ' || *p=='\t') + ++p; + continue; + } + + if (*p=='\''){ + char c,*d_p; + + ++p; + argv[argc]=p; + + d_p=p; + + c=*p; + while (!(c=='\'' && p[1]!='\'') && c!='\0'){ + *d_p++=c; + if (c=='\'') + ++p; + c=*++p; + } + + if (*p=='\0'){ + *d_p='\0'; + break; + } + + ++argc; + *d_p='\0'; + ++p; + } else { + argv[argc++]=p; + while (*p!=' ' && *p!='\t' && *p!='\0') + ++p; + + if (*p!='\0') + *p++='\0'; + } + + while (*p==' ' || *p=='\t') + ++p; + } + argv[argc]=NULL; + +/* { + int n; + + for (n=0; n<argc; ++n) + printf ("%d %s\n",n,argv[n]); + } +*/ + + if (argc>0){ + if (!strcmp (argv[0],"cocl")){ + if (argc>=2 && !strcmp ("-clear_cache",argv[1])){ + result=CallCompiler (argc-2,&argv[2]); + clear_path_cache(); + clear_inline_cache(); + FreePathList(); + } else + result=CallCompiler (argc-1,&argv[1]); + } +#ifdef CODE_GENERATOR + else if (!strcmp (argv[0],"cg")) + result=generate_code (argc,&argv[0]); + else if (!strcmp (argv[0],"cg68")) + result=generate_code68 (argc,&argv[0]); +#endif +#ifdef LINKER + else if (!strcmp (argv[0],"linker")) + result=link_application_argc_argv (argc,&argv[0]); +#endif + else if (!strcmp (argv[0],"clear_cache")){ + clear_path_cache(); + clear_inline_cache(); + FreePathList(); + } else { + result=-1; + strcpy (return_error_string,"unknown command"); + } + } + + if (redirect_stdout) + fclose (stdout); + + if (redirect_stderr) + fclose (stderr); + + return result; +} + +static char script_string[16001]; + +static pascal OSErr do_script_apple_event (AppleEvent *apple_event,AppleEvent *replyAppleEvent,long refCon) +{ + DescType returned_type; + long actual_size; + int error; + + error=AEGetParamPtr (apple_event,keyDirectObject,'TEXT',&returned_type,&script_string,sizeof (script_string),&actual_size); + + if (error==noErr && actual_size<=16000){ + int return_error_string_length; + + script_string[actual_size]='\0'; + return_error_string[0]='\0'; + +#if !MW_DEBUG + error=do_command (script_string); +#endif + + return_error_string_length=strlen (return_error_string); + if (return_error_string_length!=0){ + AEPutParamPtr (replyAppleEvent,keyErrorString,typeChar,return_error_string,return_error_string_length); + } + } + + return error; +} + +static void InitAppleEventsStuff (void) +{ + OSErr retCode; + + if (!gAppleEventsFlag) + return; + + retCode = AEInstallEventHandler (kCoreEventClass,kAEOpenApplication,NewAEEventHandlerProc (DoAEOpenApplication),0,false); + + if (retCode==noErr) + retCode = AEInstallEventHandler (kCoreEventClass,kAEOpenDocuments,NewAEEventHandlerProc (DoAEOpenDocuments),0,false); + + if (retCode==noErr) + retCode = AEInstallEventHandler (kCoreEventClass,kAEPrintDocuments,NewAEEventHandlerProc (DoAEPrintDocuments),0,false); + + if (retCode==noErr) + retCode = AEInstallEventHandler (kCoreEventClass,kAEQuitApplication,NewAEEventHandlerProc (DoAEQuitApplication),0,false); + + if (retCode==noErr) + retCode = AEInstallEventHandler (kAEMiscStandards,kAEDoScript,NewAEEventHandlerProc (do_script_apple_event),0,false); + + if (retCode!=noErr) + DebugStr("\pInstall event handler failed"); +} + +static void do_high_level_event (EventRecord *theEventRecPtr) +{ +#if MW_DEBUG + script_string[0]=0; +#endif + + AEProcessAppleEvent (theEventRecPtr); + +#if MW_DEBUG + if (script_string[0]){ + do_command (script_string); + script_string[0]=0; + } +#endif + +} + +extern short InstallConsole (short fd); + +#ifdef PROFILE +# include <Profiler.h> +#endif + +int /*clean_compiler_*/ main (void) +{ + OSErr retCode; + long gestResponse; + EventRecord mainEventRec; + Boolean eventFlag; + + SetApplLimit (GetApplLimit() - 200*1024); + + InitGraf (&qd.thePort); + InitFonts(); + FlushEvents (everyEvent,0); + +#ifndef BACKGROUND + InitWindows(); + InitCursor(); + InitMenus(); +#endif + + _fcreator='3PRM'; + + gQuitFlag = false; + gSleepVal = kSleepMax; + + retCode = Gestalt(gestaltAppleEventsAttr,&gestResponse); + if (retCode==noErr && (gestResponse & (1<<gestaltAppleEventsPresent))!=0) + gAppleEventsFlag = true; + else + gAppleEventsFlag = false; + +#ifdef STDIO_WINDOW + SIOUXSettings.autocloseonquit=1; + SIOUXSettings.showstatusline=0; + SIOUXSettings.asktosaveonclose=0; + + printf ("\n"); +#endif + +#if !defined (BACKGROUND) && !defined (STDIO_WINDOW) + fclose (stdout); + fclose (stderr); +#endif + + InitAppleEventsStuff(); + +#ifdef PROFILE + if (ProfilerInit(/*collectSummary*/collectDetailed,bestTimeBase,10000,10)!=0) + return 0; +#endif + + while (!gQuitFlag) { + eventFlag = WaitNextEvent (everyEvent,&mainEventRec,gSleepVal,nil); + +#ifdef STDIO_WINDOW + if (SIOUXHandleOneEvent (&mainEventRec)) + continue; +#endif + if (mainEventRec.what==keyDown) + break; + + if (mainEventRec.what==kHighLevelEvent) + do_high_level_event (&mainEventRec); + } + +#ifdef PROFILE + ProfilerDump ("\pProfile"); + ProfilerTerm(); +#endif + + return 1; +} + +#endif diff --git a/backendC/CleanCompilerSources/backend.c b/backendC/CleanCompilerSources/backend.c new file mode 100644 index 0000000..630f19d --- /dev/null +++ b/backendC/CleanCompilerSources/backend.c @@ -0,0 +1,2683 @@ + +#define CODE_INLINE_FLAG +#define DYNAMIC_TYPE 1 + +# include "system.h" +# include "compiledefines.h" +# include "syntaxtr.t" +# include "codegen_types.h" +# include "statesgen.h" +# include "codegen.h" +# include "codegen2.h" +# include "instructions.h" +# include "sizes.h" +# include "set_scope_numbers.h" + +# include "scanner.h" /* InitScanner, ScanInitIdentStringTable */ +# include "checker.h" /* scc_dependency_list, ClearOpenDefinitionModules, AddOpenDefinitionModule */ +# include "comsupport.h" /* CurrentModule */ +# include "buildtree.h" /* TupleSymbol, ApplySymbol */ + +# include "backendsupport.h" +# define Clean(ignore) + +# include "dynamics.h" + +# include "backend.h" + +# include <limits.h> + +void +BEGetVersion (int *current, int *oldestDefinition, int *oldestImplementation) +{ + *current = kBEVersionCurrent; + *oldestDefinition = kBEVersionOldestDefinition; + *oldestImplementation = kBEVersionOldestImplementation; +} + + +extern PolyList UserDefinedArrayFunctions; /* typechecker.c */ +extern StdOutReopened, StdErrorReopened; /* cocl.c */ + +/* + Strings + ======= +*/ +static char * +ConvertCleanString (CleanString string) +{ + int length; + char *copy; + + length = string->length; + copy = ConvertAlloc (length+1); + strncpy (copy, string->chars, length); + copy [length] = '\0'; + + return (copy); +} /* ConvertCleanString */ + +/* + Counting routines +*/ + +static short +CountTypeArgs (BETypeArgP args) +{ + short n; + + n = 0; + for (; args != NULL; args = args->type_arg_next) + n++; + + return (n); +} /* CountTypeArgs */ + +static short +CountArgs (BEArgP args) +{ + short n; + + n = 0; + for (; args != NULL; args = args->arg_next) + n++; + + return (n); +} /* CountArgs */ + +/* + BE routines +*/ +STRUCT (be_module, BEModule) +{ + char *bem_name; + Bool bem_isSystemModule; + + unsigned int bem_nFunctions; + SymbolP bem_functions; + unsigned int bem_nConstructors; + + unsigned int bem_nTypes; + SymbolP *bem_types; + + SymbolP *bem_constructors; + + unsigned int bem_nFields; + SymbolP bem_fields; +}; + +STRUCT (be_icl_module, BEIcl) +{ + ImpMod beicl_module; + BEModuleS beicl_dcl_module; + + // +++ remove this (build deps list separately) + SymbDefP *beicl_depsP; + unsigned int beicl_previousAncestor; +}; + +STRUCT (be_state, BEState) +{ + Bool be_initialised; + + char **be_argv; + int be_argc; + int be_argi; + + BEModuleP be_modules; + + BEIclS be_icl; + unsigned int be_nModules; + + SymbolP be_allSymbols; + SymbolP be_dontCareSymbol; + SymbolP be_dictionarySelectFunSymbol; + SymbolP be_dictionaryUpdateFunSymbol; +}; + +static BEStateS gBEState = {False /* ... */}; + +/* +++ dynamic allocation */ +# define kMaxNumberOfNodeIds 1000 + +STRUCT (be_locally_generated_function_info, BELocallyGeneratedFunction) +{ + char *lgf_name; + int lgf_arity; +}; + +static BELocallyGeneratedFunctionS gLocallyGeneratedFunctions[] = {{"_dictionary_select", 3}, {"_dictionary_update", 4}}; +# define kDictionarySelect 0 +# define kDictionaryUpdate 1 + +// +++ put in gBEState +static NodeIdP gCurrentNodeIds [kMaxNumberOfNodeIds]; +static SymbolP gBasicSymbols [Nr_Of_Predef_FunsOrConses]; +static SymbolP gTupleSelectSymbols [MaxNodeArity]; + +static int number_of_node_ids=0; + +static IdentP +Identifier (char *name) +{ + IdentP ident; + + ident = ConvertAllocType (IdentS); + ident->ident_name = name; + + return (ident); +} /* Identifier */ + +static SymbolP +PredefinedSymbol (SymbKind symbolKind, int arity) +{ + SymbolP symbol; + + symbol = ConvertAllocType (SymbolS); + + symbol->symb_kind = symbolKind; + symbol->symb_arity = arity; + + return (symbol); +} /* PredefinedSymbol */ + +static SymbolP +AllocateSymbols (int nSymbols, SymbolP otherSymbols) +{ + int i; + SymbolP symbols; + + if (nSymbols > 0) + { + symbols = (SymbolP) ConvertAlloc (nSymbols * sizeof (SymbolS)); + + for (i = 0; i < nSymbols; i++) + { + symbols [i].symb_kind = erroneous_symb; + symbols [i].symb_next = &symbols [i+1]; + } + symbols [nSymbols-1].symb_next = otherSymbols; + } + else + symbols = otherSymbols; + + return (symbols); +} /* AllocateSymbols */ + +static void +InitPredefinedSymbols (void) +{ + int i; + + gBasicSymbols [int_type] = PredefinedSymbol (int_type, 0); + gBasicSymbols [bool_type] = PredefinedSymbol (bool_type, 0); + gBasicSymbols [char_type] = PredefinedSymbol (char_type, 0); + gBasicSymbols [real_type] = PredefinedSymbol (real_type, 0); + gBasicSymbols [file_type] = PredefinedSymbol (file_type, 0); + gBasicSymbols [world_type] = PredefinedSymbol (world_type, 0); +#if DYNAMIC_TYPE + gBasicSymbols [dynamic_type]= PredefinedSymbol (dynamic_type, 0); +#endif + gBasicSymbols [array_type] = PredefinedSymbol (array_type, 1); + gBasicSymbols [strict_array_type] = PredefinedSymbol (strict_array_type, 1); + gBasicSymbols [unboxed_array_type] = PredefinedSymbol (unboxed_array_type, 1); + + gBasicSymbols [fun_type] = PredefinedSymbol (fun_type, 2); + + + ApplySymbol = PredefinedSymbol (apply_symb, 2); + gBasicSymbols [apply_symb] = ApplySymbol; + + TupleSymbol = PredefinedSymbol (tuple_symb, 2); /* arity doesn't matter */ + gBasicSymbols [tuple_symb] = TupleSymbol; + gBasicSymbols [tuple_type] = PredefinedSymbol (tuple_type, 2); + + gBasicSymbols [if_symb] = PredefinedSymbol (if_symb, 3); + gBasicSymbols [fail_symb] = PredefinedSymbol (fail_symb, 0); + + gBasicSymbols [nil_symb] = PredefinedSymbol (nil_symb, 0); + gBasicSymbols [cons_symb] = PredefinedSymbol (cons_symb, 2); + + for (i = 0; i < MaxNodeArity; i++) + gTupleSelectSymbols [i] = NULL; + +} /* InitPredefinedSymbols */ + +static void +AddUserDefinedArrayFunction (SymbolP functionSymbol) +{ + PolyList elem; + + elem = ConvertAllocType (struct poly_list); + + elem->pl_elem = functionSymbol; + elem->pl_next = UserDefinedArrayFunctions; + UserDefinedArrayFunctions = elem; +} /* AddUserDefinedArrayFunction */ + +static void +DeclareModule (int moduleIndex, char *name, Bool isSystemModule, int nFunctions, + int nTypes, int nConstructors, int nFields) +{ + BEModuleP module; + SymbolP symbols, allSymbols; + + allSymbols = gBEState.be_allSymbols; + + allSymbols = AllocateSymbols (nFunctions + nTypes + nConstructors + nFields, allSymbols); + + Assert ((unsigned int) moduleIndex < gBEState.be_nModules); + module = &gBEState.be_modules [moduleIndex]; + + module->bem_name = name; + module->bem_isSystemModule = isSystemModule; + + symbols = allSymbols; + + module->bem_nFunctions = (unsigned int) nFunctions; + module->bem_functions = symbols; + symbols += nFunctions; + + module->bem_nTypes = (unsigned int) nTypes; +// module->bem_types = symbols; + { + /* +++ do this lazily */ + int i; + + module->bem_types = (SymbolP *) ConvertAlloc (nTypes * sizeof (SymbolP)); + + for (i = 0; i < nTypes; i++) + { + module->bem_types [i] = &symbols [i]; + } + } + { + /* +++ change this */ + int i; + for (i = 0; i < nTypes; i++) + { + SymbDef newSymbDef; + + newSymbDef = ConvertAllocType (SymbDefS); + newSymbDef->sdef_isused = False; + symbols [i].symb_def = newSymbDef; + } + } + symbols += nTypes; + + module->bem_nConstructors = (unsigned int) nConstructors; +// module->bem_constructors = symbols; + { + /* +++ do this lazily */ + int i; + + module->bem_constructors = (SymbolP *) ConvertAlloc (nConstructors * sizeof (SymbolP)); + + for (i = 0; i < nConstructors; i++) + { + module->bem_constructors [i] = &symbols [i]; + } + } + symbols += nConstructors; + + module->bem_nFields = (unsigned int) nFields; + module->bem_fields = symbols; + symbols += nFields; + + gBEState.be_allSymbols = allSymbols; +} /* DeclareModule */ + +void +BEDeclareIclModule (CleanString name, int nFunctions, int nTypes, int nConstructors, int nFields) +{ + int i; + char *cName; + SymbolP moduleNameSymbol; + ImpMod iclModule; + BEIclP icl; + + cName = ConvertCleanString (name); + + moduleNameSymbol = ConvertAllocType (SymbolS); + moduleNameSymbol->symb_ident = Identifier (cName); + + Assert (strcmp (gBEState.be_modules [kIclModuleIndex].bem_name, cName) == 0); + + icl = &gBEState.be_icl; + + icl->beicl_module = ConvertAllocType (ImpRepr); + icl->beicl_dcl_module = gBEState.be_modules [kIclModuleIndex]; + icl->beicl_previousAncestor = UINT_MAX; + scc_dependency_list = NULL; + icl->beicl_depsP = &scc_dependency_list; + + nFunctions += ArraySize (gLocallyGeneratedFunctions); + DeclareModule (kIclModuleIndex, cName, False, nFunctions, nTypes, nConstructors, nFields); + + iclModule = icl->beicl_module; + iclModule->im_name = moduleNameSymbol; + iclModule->im_def_module = NULL; + iclModule->im_rules = NULL; + iclModule->im_start = NULL; + iclModule->im_symbols = gBEState.be_allSymbols; +# if IMPORT_OBJ_AND_LIB + iclModule->im_imported_objs = NULL; + iclModule->im_imported_libs = NULL; +# endif + + CurrentModule = cName; + + for (i = 0; i < ArraySize (gLocallyGeneratedFunctions); i++) + { + static void DeclareFunctionC (char *name, int arity, int functionIndex, unsigned int ancestor); + BELocallyGeneratedFunctionP locallyGeneratedFunction; + + locallyGeneratedFunction = &gLocallyGeneratedFunctions [i]; + + DeclareFunctionC (locallyGeneratedFunction->lgf_name, locallyGeneratedFunction->lgf_arity, nFunctions-ArraySize(gLocallyGeneratedFunctions)+i, UINT_MAX); + } + + /* +++ hack */ + { + static BESymbolP CreateDictionarySelectFunSymbol (void); + static BESymbolP CreateDictionaryUpdateFunSymbol (void); + + gBEState.be_dictionarySelectFunSymbol = CreateDictionarySelectFunSymbol (); + gBEState.be_dictionaryUpdateFunSymbol = CreateDictionaryUpdateFunSymbol (); + } +} /* BEDeclareIclModule */ + +void +BEDeclareDclModule (int moduleIndex, CleanString name, int isSystemModule, int nFunctions, int nTypes, int nConstructors, int nFields) +{ + char *cName; + SymbolP moduleNameSymbol; + DefMod dclModule; + + cName = ConvertCleanString (name); + + moduleNameSymbol = ConvertAllocType (SymbolS); + moduleNameSymbol->symb_ident = Identifier (cName); + + DeclareModule (moduleIndex, cName, isSystemModule, nFunctions, nTypes, nConstructors, nFields); + + dclModule = ConvertAllocType (DefRepr); + dclModule->dm_name = moduleNameSymbol; + dclModule->dm_system_module = isSystemModule; + dclModule->dm_symbols = gBEState.be_allSymbols; /* ??? too many symbols? */ + + if (moduleIndex != kIclModuleIndex) + AddOpenDefinitionModule (moduleNameSymbol, dclModule); +} /* BEDeclareDclModule */ + +void +BEDeclarePredefinedModule (int nTypes, int nConstructors) +{ + char *cName; + + cName = "_predef"; + + DeclareModule (kPredefinedModuleIndex, cName, False, 0, nTypes, nConstructors, 0); +} /* BEDeclarePredefinedModule */ + +void +BEDeclareModules (int nModules) +{ + Assert (gBEState.be_modules == NULL); + + gBEState.be_nModules = (unsigned int) nModules; + gBEState.be_modules = (BEModuleP) ConvertAlloc (nModules * sizeof (BEModuleS)); +} /* BEDeclareModules */ + +BESymbolP +BEFunctionSymbol (int functionIndex, int moduleIndex) +{ + BEModuleP module; + SymbolP functionSymbol; + + Assert ((unsigned int) moduleIndex < gBEState.be_nModules); + module = &gBEState.be_modules [moduleIndex]; + + Assert ((unsigned int) functionIndex < module->bem_nFunctions); + functionSymbol = &module->bem_functions [functionIndex]; + Assert (functionSymbol->symb_kind == definition + || (moduleIndex == kPredefinedModuleIndex && functionSymbol->symb_kind != erroneous_symb)); + + functionSymbol->symb_def->sdef_isused = True; + + return (functionSymbol); +} /* BEFunctionSymbol */ + +static void +GetArrayFunctionType (SymbDefP sdef, TypeNode *elementTypeP, TypeNode *arrayTypeP) +{ + TypeAlt *typeAlt; + + typeAlt = sdef->sdef_rule_type->rule_type_rule; + + switch (sdef->sdef_arfun) + { + case BEArraySelectFun: + case BEUnqArraySelectFun: + case BE_UnqArraySelectFun: + case BE_UnqArraySelectNextFun: + case BE_UnqArraySelectLastFun: + break; + case BEArrayUpdateFun: + case BE_ArrayUpdateFun: + Assert (typeAlt->type_alt_lhs->type_node_arity == 3); + *elementTypeP = typeAlt->type_alt_lhs->type_node_arguments->type_arg_next->type_arg_next->type_arg_node; + *arrayTypeP = typeAlt->type_alt_lhs->type_node_arguments->type_arg_node; + break; + default: + *elementTypeP = NULL; + *arrayTypeP = NULL; + break; + } +} /* GetArrayFunctionType */ + +BESymbolP +BESpecialArrayFunctionSymbol (BEArrayFunKind arrayFunKind, int functionIndex, int moduleIndex) +{ + Bool isSpecialArrayFunction; + BEModuleP module; + SymbolP functionSymbol; + SymbDefP sdef; + SymbDefP originalsdef; + TypeAlt *typeAlt; + TypeNode elementType, arrayType; + + Assert ((unsigned int) moduleIndex < gBEState.be_nModules); + module = &gBEState.be_modules [moduleIndex]; + + Assert ((unsigned int) functionIndex < module->bem_nFunctions); + functionSymbol = &module->bem_functions [functionIndex]; + Assert (functionSymbol->symb_kind == definition + || (moduleIndex == kPredefinedModuleIndex && functionSymbol->symb_kind != erroneous_symb)); + + originalsdef = functionSymbol->symb_def; + + typeAlt = originalsdef->sdef_rule_type->rule_type_rule; + isSpecialArrayFunction = False; + switch (arrayFunKind) + { + case BEArraySelectFun: + Assert (originalsdef->sdef_arfun == BEArraySelectFun || originalsdef->sdef_arfun == BEUnqArraySelectFun); + break; + case BE_UnqArraySelectFun: + case BE_UnqArraySelectLastFun: + Assert (typeAlt->type_alt_lhs->type_node_arity == 2); + elementType = typeAlt->type_alt_rhs; + arrayType = typeAlt->type_alt_lhs->type_node_arguments->type_arg_node; + + isSpecialArrayFunction = True; + Assert (originalsdef->sdef_arfun == BEArraySelectFun); + break; + case BE_ArrayUpdateFun: + isSpecialArrayFunction = True; + elementType = typeAlt->type_alt_lhs->type_node_arguments->type_arg_next->type_arg_next->type_arg_node; + arrayType = typeAlt->type_alt_lhs->type_node_arguments->type_arg_node; + /* fall through! */ + case BEArrayUpdateFun: + Assert (originalsdef->sdef_arfun == BEArrayUpdateFun); + break; + default: + Assert (False); + break; + } + + if (isSpecialArrayFunction) + { + SymbolP previousFunctionSymbol; + Bool allreadyCreated; + + previousFunctionSymbol = functionSymbol; + functionSymbol = functionSymbol->symb_next; + + allreadyCreated = False; + if (functionSymbol != NULL && functionSymbol->symb_kind == definition) + { + sdef = functionSymbol->symb_def; + allreadyCreated = sdef->sdef_arfun == (ArrayFunKind) arrayFunKind; + if (!allreadyCreated && arrayFunKind == BE_UnqArraySelectLastFun && sdef->sdef_arfun == BE_UnqArraySelectFun) + { + previousFunctionSymbol = functionSymbol; + functionSymbol = functionSymbol->symb_next; + + if (functionSymbol != NULL && functionSymbol->symb_kind == definition) + { + sdef = functionSymbol->symb_def; + allreadyCreated = sdef->sdef_arfun == (ArrayFunKind) arrayFunKind; + } + } + } + + if (!allreadyCreated) + { + char *functionName, *functionPrefix; + TypeAlt *newTypeAlt; + IdentP newIdent; + SymbDefP newsdef; + SymbolP newFunctionSymbol; + RuleTypes newRuleType; + TypeArgs lhsArgs; + TypeNode rhs; + + newFunctionSymbol = ConvertAllocType (SymbolS); + newsdef = ConvertAllocType (SymbDefS); + newIdent = ConvertAllocType (IdentS); + + newTypeAlt = ConvertAllocType (TypeAlt); + + newTypeAlt->type_alt_type_context = NULL; /* used in PrintType */ + newTypeAlt->type_alt_attr_equations = NULL; /* used in PrintType */ + + Assert (!arrayType->type_node_is_var); + switch (arrayType->type_node_symbol->symb_kind) + { + case strict_array_type: + case unboxed_array_type: + elementType->type_node_annotation = StrictAnnot; + break; + case array_type: + break; + default: + Assert (False); + break; + } + + switch (arrayFunKind) + { + case BE_UnqArraySelectFun: + rhs = BENormalTypeNode (gBasicSymbols [tuple_type], + BETypeArgs (elementType, BETypeArgs (arrayType, NULL))); + lhsArgs = BETypeArgs (arrayType, BETypeArgs (BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [int_type], NULL)), NULL)); + functionPrefix = "_uselectf"; + break; + case BE_UnqArraySelectLastFun: + { + struct clean_string rName = {1, 'r'}; + TypeNode rType; + + rType = BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&rName)); + rhs = BENormalTypeNode (gBasicSymbols [tuple_type], + BETypeArgs (elementType, BETypeArgs (rType, NULL))); + lhsArgs = BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [tuple_type], + BETypeArgs (arrayType, BETypeArgs (rType, NULL)))), + BETypeArgs (BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [int_type], NULL)), NULL)); + functionPrefix = "_uselectl"; + break; + } + case BE_ArrayUpdateFun: + { + struct clean_string rName = {1, 'r'}; + TypeNode rType; + + rType = BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&rName)); + rhs = rType; + lhsArgs = BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [tuple_type], + BETypeArgs (arrayType, BETypeArgs (rType, NULL)))), + BETypeArgs (BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [int_type], NULL)), + BETypeArgs (elementType, + NULL))); + functionPrefix = "_updatei"; + break; + } + default: + Assert (False); + break; + } + + functionName = ConvertAlloc (strlen (functionPrefix) + 1 + strlen (originalsdef->sdef_ident->ident_name) + 1); + strcpy (functionName, functionPrefix); + strcat (functionName, ";"); + strcat (functionName, originalsdef->sdef_ident->ident_name); + + newTypeAlt->type_alt_lhs = BENormalTypeNode (newFunctionSymbol, lhsArgs); + newTypeAlt->type_alt_rhs = rhs; + + newIdent->ident_symbol = newFunctionSymbol; + newIdent->ident_name = functionName; + + newRuleType = ConvertAllocType (struct rule_type); + newRuleType->rule_type_rule = newTypeAlt; + + newsdef->sdef_ident = newIdent; + newsdef->sdef_module = gBEState.be_icl.beicl_module->im_name->symb_def->sdef_module; /* phew! */ + newsdef->sdef_over_arity = 0; + newsdef->sdef_isused = True; + newsdef->sdef_exported = False; + newsdef->sdef_arity = newTypeAlt->type_alt_lhs->type_node_arity; + newsdef->sdef_arfun = arrayFunKind; + newsdef->sdef_kind = SYSRULE; + newsdef->sdef_rule_type = newRuleType; + newsdef->sdef_ident = newIdent; + newsdef->sdef_mark = 0; + + newFunctionSymbol->symb_kind = definition; + newFunctionSymbol->symb_def = newsdef; + + functionSymbol = previousFunctionSymbol->symb_next; + previousFunctionSymbol->symb_next = newFunctionSymbol; + newFunctionSymbol->symb_next = functionSymbol; + + AddUserDefinedArrayFunction (newFunctionSymbol); + + functionSymbol = newFunctionSymbol; + } + + } + + return (functionSymbol); +} /* BESpecialArrayFunctionSymbol */ + +static SymbolP +CreateLocallyDefinedFunction (int index, char ** abcCode, TypeArgs lhsArgs, TypeNode rhsType) +{ + int i, arity, functionIndex; + NodeP lhs; + BEStringListP instructions, *instructionsP; + BECodeBlockP codeBlock; + RuleAltP ruleAlt; + SymbolP functionSymbol; + TypeAlt *typeAlt; + ArgP args; + + functionIndex = gBEState.be_modules[kIclModuleIndex].bem_nFunctions - ArraySize (gLocallyGeneratedFunctions) + index; + functionSymbol = BEFunctionSymbol (functionIndex, kIclModuleIndex); + functionSymbol->symb_def->sdef_isused = False; + + instructionsP = &instructions; + for (i = 0; abcCode [i] != NULL; i++) + { + BEStringListP string; + + string = ConvertAllocType (struct string_list); + + string->sl_string = abcCode [i]; + string->sl_next = instructions; + + *instructionsP = string; + instructionsP = &string->sl_next; + } + *instructionsP = NULL; + + codeBlock = BEAbcCodeBlock (False, instructions); + + lhs = BENormalNode (functionSymbol, NULL); + arity = CountTypeArgs (lhsArgs); + + args = NULL; + for (i = 0; i < arity; i++) + args = BEArgs (BENodeIdNode (BEWildCardNodeId (), NULL), args); + + lhs->node_arguments = args; + lhs->node_arity = arity; + + Assert (arity == functionSymbol->symb_def->sdef_arity); + + ruleAlt = BECodeAlt (0, NULL, lhs, codeBlock); + + typeAlt = ConvertAllocType (TypeAlt); + + typeAlt->type_alt_type_context = NULL; /* used in PrintType */ + typeAlt->type_alt_attr_equations = NULL; /* used in PrintType */ + typeAlt->type_alt_lhs = BENormalTypeNode (functionSymbol, lhsArgs); + typeAlt->type_alt_rhs = rhsType; + + BERule (functionIndex, BEIsNotACaf, typeAlt, ruleAlt); + + return (functionSymbol); +} /* CreateLocallyDefinedFunction */ + +static BESymbolP +CreateDictionarySelectFunSymbol (void) +{ + TypeNode rhsType; + TypeArgs lhsArgs; + struct clean_string aName = {1, 'a'}; + + /* selectl :: !((a e) Int -> e) !(!a e, !r) !Int -> (e, !r) */ + /* select _ _ _ = code */ + static char *abcCode[] = { + "push_a 1", + "push_a 1", + "build e_system_dAP 2 e_system_nAP", + "buildI_b 0", + "push_a 1", + "update_a 1 2", + "update_a 0 1", + "pop_a 1", + "build e_system_dAP 2 e_system_nAP", + "push_a 3", + "push_a 1", + "update_a 1 2", + "update_a 0 1", + "pop_a 1", + "update_a 1 4", + "update_a 0 3", + "pop_a 3", + "pop_b 1", + NULL + }; + + /* actual type simplified to !a !(!a,!a) !Int -> (a,!a) */ + lhsArgs = BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)), + BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [tuple_type], + BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)), + BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)), + NULL)))), + BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [int_type], NULL)), + NULL))); + rhsType = BENormalTypeNode (gBasicSymbols [tuple_type], + BETypeArgs (BEVarTypeNode (&aName), BETypeArgs (BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)), NULL))); + + return (CreateLocallyDefinedFunction (kDictionarySelect, abcCode, lhsArgs, rhsType)); +} /* CreateDictionarySelectFunSymbol */ + +static BESymbolP +CreateDictionaryUpdateFunSymbol (void) +{ + TypeNode rhsType; + TypeArgs lhsArgs; + struct clean_string aName = {1, 'a'}; + + /* updatei :: !(*(a .e) -> *(!Int -> *(.e -> .(a .e)))) !(!*(a .e), !*r) !Int .e -> *r // !(!.(a .e), !*r) */ + /* updatei _ _ _ _ = code */ + static char *abcCode[] = { + " push_a 1", + " push_a 1", + " build _Nil 0 _hnf", + " update_a 0 4", + " pop_a 1", + ".d 2 0", + " jsr e_system_sAP", + ".o 1 0", + " buildI_b 0", + " push_a 1", + " update_a 1 2", + " update_a 0 1", + " pop_a 1", + " pop_b 1", + ".d 2 0", + " jsr e_system_sAP", + ".o 1 0", + " push_a 4", + " push_a 1", + " update_a 1 2", + " update_a 0 1", + " pop_a 1", + " build _Nil 0 _hnf", + " update_a 0 6", + " pop_a 1", + ".d 2 0", + " jsr e_system_sAP", + ".o 1 0", + " update_a 3 4", + " pop_a 4", + NULL + }; + + /* actual type simplified to !a !(!a,!a) !Int a -> a */ + lhsArgs = BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)), + BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [tuple_type], + BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)), + BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)), + NULL)))), + BETypeArgs ( + BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [int_type], NULL)), + BETypeArgs ( + BEVarTypeNode (&aName), + NULL)))); + + rhsType = BEVarTypeNode (&aName); + + return (CreateLocallyDefinedFunction (kDictionaryUpdate, abcCode, lhsArgs, rhsType)); +} /* CreateDictionaryUpdateFunSymbol */ + +BESymbolP +BEDictionarySelectFunSymbol (void) +{ + gBEState.be_dictionarySelectFunSymbol->symb_def->sdef_isused = True; + + return (gBEState.be_dictionarySelectFunSymbol); +} /* BEDictionarySelectFunSymbol */ + +BESymbolP +BEDictionaryUpdateFunSymbol (void) +{ + gBEState.be_dictionaryUpdateFunSymbol->symb_def->sdef_isused = True; + + return (gBEState.be_dictionaryUpdateFunSymbol); +} /* BEDictionaryUpdateFunSymbol */ + +BESymbolP +BETypeSymbol (int typeIndex, int moduleIndex) +{ + BEModuleP module; + SymbolP typeSymbol; + + if ((unsigned int) moduleIndex >= gBEState.be_nModules) + Assert ((unsigned int) moduleIndex < gBEState.be_nModules); + module = &gBEState.be_modules [moduleIndex]; + + Assert ((unsigned int) typeIndex < module->bem_nTypes); + typeSymbol = module->bem_types [typeIndex]; +/* Assert (typeSymbol->symb_kind == definition + || (moduleIndex == kPredefinedModuleIndex && typeSymbol->symb_kind != erroneous_symb)); +*/ + if (moduleIndex == kIclModuleIndex) + typeSymbol->symb_def->sdef_isused = True; + + return (typeSymbol); +} /* BETypeSymbol */ + +BESymbolP +BEDontCareDefinitionSymbol (void) +{ + SymbolP symbol; + + symbol = gBEState.be_dontCareSymbol; + if (symbol == NULL) + { + SymbDefP symbDef; + + symbDef = ConvertAllocType (SymbDefS); + symbDef->sdef_kind = ABSTYPE; + + symbDef->sdef_ident = Identifier ("_Don'tCare"); /* +++ name */ + + symbol = ConvertAllocType (SymbolS); + symbol->symb_kind = definition; + symbol->symb_def = symbDef; + + gBEState.be_dontCareSymbol = symbol; + } + + return (symbol); +} /* BEDontCareDefinitionSymbol */ + +BESymbolP +BEConstructorSymbol (int constructorIndex, int moduleIndex) +{ + BEModuleP module; + SymbolP constructorSymbol; + + Assert ((unsigned int) moduleIndex < gBEState.be_nModules); + module = &gBEState.be_modules [moduleIndex]; + + Assert ((unsigned int) constructorIndex < module->bem_nConstructors); + constructorSymbol = module->bem_constructors [constructorIndex]; + + /* RWS +++ hack for record constructors, remove this */ + if (constructorSymbol->symb_kind == erroneous_symb) + return (constructorSymbol); + + Assert (constructorSymbol->symb_kind == definition + || (moduleIndex == kPredefinedModuleIndex && constructorSymbol->symb_kind != erroneous_symb)); + + if (moduleIndex != kPredefinedModuleIndex) + constructorSymbol->symb_def->sdef_isused = True; + + return (constructorSymbol); +} /* BEConstructorSymbol */ + +BESymbolP +BEFieldSymbol (int fieldIndex, int moduleIndex) +{ + BEModuleP module; + SymbolP fieldSymbol; + + Assert ((unsigned int) moduleIndex < gBEState.be_nModules); + module = &gBEState.be_modules [moduleIndex]; + + Assert ((unsigned int) fieldIndex < module->bem_nFields); + fieldSymbol = &module->bem_fields [fieldIndex]; + Assert (fieldSymbol->symb_kind == definition); + + fieldSymbol->symb_def->sdef_isused = True; + + return (fieldSymbol); +} /* BEFieldSymbol */ + +BESymbolP +BEBoolSymbol (int value) +{ +/* JVG: */ + if (value) + return TrueSymbol; + else + return FalseSymbol; +/* + SymbolP symbol; + + symbol = ConvertAllocType (SymbolS); + symbol->symb_kind = bool_denot; + symbol->symb_bool = value; + + return (symbol); +*/ +} /* BEBoolSymbol */ + +BESymbolP +BELiteralSymbol (BESymbKind kind, CleanString value) +{ + SymbolP symbol; + + symbol = ConvertAllocType (SymbolS); + symbol->symb_kind = kind; + symbol->symb_int = ConvertCleanString (value); + + return (symbol); +} /* BELiteralSymbol */ + +void +BEPredefineConstructorSymbol (int arity, int constructorIndex, int moduleIndex, BESymbKind symbolKind) +{ + BEModuleP module; + + Assert (moduleIndex == kPredefinedModuleIndex); + + Assert ((unsigned int) moduleIndex < gBEState.be_nModules); + module = &gBEState.be_modules [moduleIndex]; + + Assert ((unsigned int) constructorIndex < module->bem_nConstructors); + Assert (module->bem_constructors [constructorIndex]->symb_kind == erroneous_symb); + + module->bem_constructors [constructorIndex]->symb_kind = symbolKind; + module->bem_constructors [constructorIndex]->symb_arity = arity; +} /* BEPredefineConstructorSymbol */ + +void +BEPredefineTypeSymbol (int arity, int typeIndex, int moduleIndex, BESymbKind symbolKind) +{ + BEModuleP module; + + Assert (moduleIndex == kPredefinedModuleIndex); + + Assert ((unsigned int) moduleIndex < gBEState.be_nModules); + module = &gBEState.be_modules [moduleIndex]; + + Assert ((unsigned int) typeIndex < module->bem_nTypes); + Assert (module->bem_types [typeIndex]->symb_kind == erroneous_symb); + + module->bem_types [typeIndex]->symb_kind = symbolKind; + module->bem_types [typeIndex]->symb_arity = arity; +} /* BEPredefineTypeSymbol */ + +BESymbolP +BEBasicSymbol (BESymbKind kind) +{ + Assert (gBasicSymbols [kind] != NULL); + + return (gBasicSymbols [kind]); +} /* BEBasicSymbol */ + +BETypeNodeP +BEVarTypeNode (CleanString name) +{ + TypeNode node; + + node = ConvertAllocType (struct type_node); + + node->type_node_is_var = True; + node->type_node_tv = BETypeVar (name); + node->type_node_arity = 0; + node->type_node_annotation = NoAnnot; + node->type_node_attribute = NoUniAttr; + + return (node); +} /* BEVarTypeNode */ + +BETypeNodeP +BENormalTypeNode (BESymbolP symbol, BETypeArgP args) +{ + TypeNode node; + + node = ConvertAllocType (struct type_node); + + node->type_node_is_var = False; + node->type_node_arity = CountTypeArgs (args); + node->type_node_annotation = NoAnnot; + node->type_node_attribute = NoUniAttr; + node->type_node_symbol = symbol; + node->type_node_arguments = args; + + return (node); +} /* BENormalTypeNode */ + +BETypeNodeP +BEAttributeTypeNode (BEAttribution attribution, BETypeNodeP typeNode) +{ + Assert (typeNode->type_node_attribute == NoUniAttr); + typeNode->type_node_attribute = (AttributeKind) attribution; + + return (typeNode); +} /* BEAttributeTypeNode */ + +BETypeNodeP +BEAnnotateTypeNode (BEAnnotation annotation, BETypeNodeP typeNode) +{ + Assert (typeNode->type_node_annotation == NoAnnot); + typeNode->type_node_annotation = (Annotation) annotation; + + return (typeNode); +} /* BEAnnotateTypeNode */ + +BETypeArgP +BENoTypeArgs (void) +{ + return (NULL); +} /* BENoTypeArgs */ + +BETypeArgP +BETypeArgs (BETypeNodeP node, BETypeArgP nextArgs) +{ + TypeArgs arg; + + arg = ConvertAllocType (TypeArg); + + arg->type_arg_node = node; + arg->type_arg_next = nextArgs; + + return (arg); +} /* BETypeArgs */ + +BETypeAltP +BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs) +{ + TypeAlt *alt; + + alt = ConvertAllocType (struct type_alt); + + alt->type_alt_lhs = lhs; + alt->type_alt_rhs = rhs; + + alt->type_alt_type_context = NULL; /* used in PrintType */ + alt->type_alt_attr_equations = NULL; /* used in PrintType */ + + return (alt); +} /* BETypeAlt */ + +static Node +GenerateApplyNodes (Node root, int offarity, int demarity) +{ + if (offarity > demarity) + { + int i; + Args lastarg, nextarg; + + if (demarity != 0) + { + for (i=1, lastarg = root->node_arguments; i < demarity; i++) + lastarg = lastarg->arg_next; + + nextarg = lastarg->arg_next; + lastarg->arg_next = NULL; + } + else + { + nextarg = root->node_arguments; + root->node_arguments = NULL; + } + root->node_arity = (short) demarity; + + for (i=demarity+1; i<=offarity; i++) + { + Args arg; + + arg = BEArgs (root, nextarg); + + nextarg = nextarg->arg_next; + arg->arg_next->arg_next = NULL; + + root = BENormalNode (gBasicSymbols [apply_symb], arg); + } + } + + return (root); +} /* GenerateApplyNodes */ + +BENodeP +BENormalNode (BESymbolP symbol, BEArgP args) +{ + NodeP node; + + node = ConvertAllocType (NodeS); + + node->node_annotation = NoAnnot; + node->node_kind = NormalNode; + node->node_symbol = symbol; + node->node_arity = CountArgs (args); + node->node_arguments = args; + + /* +++ hackerdiehack */ + if (symbol->symb_kind == definition) + node = GenerateApplyNodes (node, node->node_arity, symbol->symb_def->sdef_arity); + + return (node); +} /* BENormalNode */ + +BENodeP +BEMatchNode (int arity, BESymbolP symbol, BENodeP node) +{ + NodeP matchNode; + + if (symbol->symb_kind == tuple_symb) + return (node); + + matchNode = ConvertAllocType (NodeS); + + matchNode->node_annotation = NoAnnot; + matchNode->node_kind = MatchNode; + matchNode->node_symbol = symbol; + matchNode->node_arity = arity; + matchNode->node_arguments = BEArgs (node, NULL); + + return (matchNode); +} /* BEMatchNode */ + +BENodeP +BETupleSelectNode (int arity, int index, BENodeP node) +{ + SymbolP symbol; + NodeP select; + + if ((symbol = gTupleSelectSymbols [arity-1]) == NULL) + { + symbol = ConvertAllocType (SymbolS); + + symbol->symb_kind = select_symb; + symbol->symb_arity = arity; + + gTupleSelectSymbols [arity-1] = symbol; + } + + select = ConvertAllocType (NodeS); + + select->node_annotation = NoAnnot; + select->node_kind = NormalNode; + select->node_symbol = symbol; + select->node_arity = index+1; + select->node_arguments = BEArgs (node, NULL); + + return (select); +} /* BETupleSelectNode */ + +BENodeP +BEIfNode (BENodeP cond, BENodeP then, BENodeP elsje) +{ + NodeP node; + + node = ConvertAllocType (NodeS); + + node->node_annotation = NoAnnot; + node->node_kind = NormalNode; + node->node_symbol = gBasicSymbols [if_symb]; + node->node_arguments = BEArgs (cond, BEArgs (then, (BEArgs (elsje, NULL)))); + node->node_arity = 3; + + return (node); +} /* BEIfNode */ + +BENodeP +BEGuardNode (BENodeP cond, BENodeDefP thenNodeDefs, BEStrictNodeIdP thenStricts, BENodeP then, BENodeDefP elseNodeDefs, BEStrictNodeIdP elseStricts, BENodeP elsje) +{ + NodeP node; + struct if_node_contents *thenElseInfo; + + thenElseInfo = ConvertAllocType (struct if_node_contents); + + thenElseInfo->if_then_node_defs = thenNodeDefs; + thenElseInfo->if_then_rules = NIL; + thenElseInfo->if_then_strict_node_ids = thenStricts; + thenElseInfo->if_else_node_defs = elseNodeDefs; + thenElseInfo->if_else_rules = NIL; + thenElseInfo->if_else_strict_node_ids = elseStricts; + + node = ConvertAllocType (NodeS); + + node->node_annotation = NoAnnot; + node->node_kind = IfNode; + node->node_contents.contents_if = thenElseInfo; + node->node_arguments = BEArgs (cond, BEArgs (then, (BEArgs (elsje, NULL)))); + + return (node); +} /* BEGuardNode */ + +BENodeP +BESelectorNode (BESelectorKind selectorKind, BESymbolP fieldSymbol, BEArgP args) +{ + NodeP node; + + Assert (CountArgs (args) == 1); + + node = ConvertAllocType (NodeS); + + node->node_annotation = NoAnnot; + node->node_kind = SelectorNode; + node->node_symbol = fieldSymbol; + node->node_arity = selectorKind; + node->node_arguments = args; + + return (node); +} /* BESelectorNode */ + +BENodeP +BEUpdateNode (BEArgP args) +{ + NodeP node; + SymbolP recordSymbol; + + Assert (CountArgs (args) == 2); + Assert (args->arg_next->arg_node->node_kind == SelectorNode); + Assert (args->arg_next->arg_node->node_arity == BESelector); + + recordSymbol = args->arg_next->arg_node->node_symbol->symb_def->sdef_type->type_lhs->ft_symbol; + + node = ConvertAllocType (NodeS); + + node->node_annotation = NoAnnot; + node->node_kind = UpdateNode; + node->node_symbol = recordSymbol; + node->node_arity = 2; + node->node_arguments = args; + + return (node); +} /* BEUpdateNode */ + +BENodeP +BENodeIdNode (BENodeIdP nodeId, BEArgP args) +{ + NodeP node; + + node = ConvertAllocType (NodeS); + + node->node_annotation = NoAnnot; + node->node_kind = NodeIdNode; + node->node_node_id = nodeId; + node->node_arity = CountArgs (args); + node->node_arguments = args; + + return (node); +} /* BENodeIdNode */ + +BEArgP +BENoArgs (void) +{ + return (NULL); +} /* BENoArgs */ + +BEArgP +BEArgs (BENodeP node, BEArgP nextArgs) +{ + ArgP arg; + + arg = ConvertAllocType (ArgS); + + arg->arg_node = node; + arg->arg_next = nextArgs; + + return (arg); +} /* BEArgs */ + + +# define nid_ref_count_sign nid_scope + +void +BEDeclareNodeId (int sequenceNumber, int lhsOrRhs, CleanString name) +{ + IdentP newIdent; + NodeIdP newNodeId; + + Assert (sequenceNumber < kMaxNumberOfNodeIds); + + /* +++ ifdef DEBUG */ + if (sequenceNumber>=number_of_node_ids){ + int i; + + for (i=number_of_node_ids; i<=sequenceNumber; ++i) + gCurrentNodeIds[i] = NULL; + + number_of_node_ids=sequenceNumber+1; + } + /* endif DEBUG */ + + Assert (gCurrentNodeIds [sequenceNumber] == NULL); + + /* +++ share idents ??? */ + newIdent = ConvertAllocType (IdentS); + newIdent->ident_name = ConvertCleanString (name); + + newNodeId = ConvertAllocType (NodeIdS); + newNodeId->nid_ident = newIdent; + + newNodeId->nid_node_def = NULL; + newNodeId->nid_forward_node_id = NULL; + newNodeId->nid_node = NULL; + newNodeId->nid_state.state_kind = 0; + newNodeId->nid_mark = 0; + newNodeId->nid_mark2 = 0; + newNodeId->nid_ref_count_sign = lhsOrRhs==BELhsNodeId ? -1 : 1; + newNodeId->nid_refcount = 0; +/* RWS test ... */ + newNodeId->nid_ref_count_copy = 0; +/* ... test */ + + gCurrentNodeIds [sequenceNumber] = newNodeId; +} /* BEDeclareNodeId */ + +BENodeIdP +BENodeId (int sequenceNumber) +{ + NodeIdP nodeId; + + Assert ((unsigned)sequenceNumber < (unsigned)kMaxNumberOfNodeIds); + + /* +++ ifdef DEBUG */ + if (sequenceNumber>=number_of_node_ids){ + int i; + + for (i=number_of_node_ids; i<=sequenceNumber; ++i) + gCurrentNodeIds[i] = NULL; + + number_of_node_ids=sequenceNumber+1; + } + /* endif DEBUG */ + + nodeId = gCurrentNodeIds [sequenceNumber]; + + Assert (nodeId != NULL); + + nodeId->nid_refcount += nodeId->nid_ref_count_sign; + + return (nodeId); +} /* BENodeId */ + +BENodeIdP +BEWildCardNodeId (void) +{ + NodeIdP newNodeId; + + /* +++ share wild card nodeids ??? */ + + newNodeId = ConvertAllocType (NodeIdS); + + newNodeId->nid_ident = NULL; + newNodeId->nid_node_def = NULL; + newNodeId->nid_forward_node_id = NULL; + newNodeId->nid_node = NULL; + newNodeId->nid_state.state_kind = 0; + newNodeId->nid_mark = 0; + newNodeId->nid_mark2 = 0; + newNodeId->nid_ref_count_sign = 0; + newNodeId->nid_refcount = -1; + + return (newNodeId); +} /* BEWildCardNodeId */ + +BENodeDefP +BENodeDef (int sequenceNumber, BENodeP node) +{ + NodeIdP nodeId; + NodeDefP nodeDef; + + Assert ((unsigned)sequenceNumber < (unsigned)kMaxNumberOfNodeIds); + + /* +++ ifdef DEBUG */ + if (sequenceNumber>=number_of_node_ids){ + int i; + + for (i=number_of_node_ids; i<=sequenceNumber; ++i) + gCurrentNodeIds[i] = NULL; + + number_of_node_ids=sequenceNumber+1; + } + /* endif DEBUG */ + + nodeDef = ConvertAllocType (NodeDefS); + + nodeId = gCurrentNodeIds [sequenceNumber]; + + Assert (nodeId != NULL); + Assert (nodeId->nid_node == NULL); + nodeId->nid_node_def = nodeDef; + nodeId->nid_node = node; + + nodeDef->def_id = nodeId; + nodeDef->def_node = node; + /* ifdef DEBUG */ + nodeDef->def_next = NULL; + /* endif DEBUG */ + + return (nodeDef); +} /* BENodeDef */ + +BENodeDefP +BENodeDefs (BENodeDefP nodeDef, BENodeDefP nodeDefs) +{ + Assert (nodeDef->def_next == NULL); + + nodeDef->def_next = nodeDefs; + + return (nodeDef); +} /* BENodeDefs */ + +BENodeDefP +BENoNodeDefs (void) +{ + return (NULL); +} /* BENoNodeDefs */ + +BEStrictNodeIdP +BEStrictNodeId (BENodeIdP nodeId) +{ + StrictNodeId strictNodeId; + + strictNodeId = ConvertAllocType (struct strict_node_id); + strictNodeId->snid_mark = 0; + strictNodeId->snid_node_id = nodeId; + + /* +++ remove this hack */ + nodeId->nid_refcount--; + + /* ifdef DEBUG */ + strictNodeId->snid_next = NULL; + /* endif */ + + return (strictNodeId); +} /* BEStrictNodeId */ + +BEStrictNodeIdP +BEStrictNodeIds (BEStrictNodeIdP strictNodeId, BEStrictNodeIdP strictNodeIds) +{ + Assert (strictNodeId->snid_next == NULL); + + strictNodeId->snid_next = strictNodeIds; + + return (strictNodeId); +} /* BEStrictNodeIds */ + +BEStrictNodeIdP +BENoStrictNodeIds (void) +{ + return (NULL); +} /* BENoStrictNodeIds */ + +BERuleAltP +BERuleAlt (int line, BENodeDefP lhsDefs, BENodeP lhs, BENodeDefP rhsDefs, BEStrictNodeIdP rhsStrictNodeIds, BENodeP rhs) +{ + RuleAltP alt; + + alt = ConvertAllocType (RuleAltS); + + alt->alt_lhs_root = lhs; + alt->alt_lhs_defs = lhsDefs; + alt->alt_rhs_root = rhs; + alt->alt_rhs_defs = rhsDefs; + alt->alt_line = line; + alt->alt_kind = Contractum; + alt->alt_strict_node_ids = rhsStrictNodeIds; + + /* +++ ifdef DEBUG */ + alt->alt_next = NULL; + number_of_node_ids=0; + /* endif DEBUG */ + + set_scope_numbers (alt); + + return (alt); +} /* BERuleAlt */ + +BERuleAltP +BECodeAlt (int line, BENodeDefP lhsDefs, BENodeP lhs, BECodeBlockP codeBlock) +{ + RuleAltP alt; + + alt = ConvertAllocType (RuleAltS); + + alt->alt_lhs_root = lhs; + alt->alt_lhs_defs = lhsDefs; + alt->alt_rhs_code = codeBlock; + alt->alt_rhs_defs = NULL; + alt->alt_line = line; + alt->alt_kind = ExternalCall; + alt->alt_strict_node_ids = NULL; + + /* +++ ifdef DEBUG */ + alt->alt_next = NULL; + number_of_node_ids=0; + /* endif DEBUG */ + +# ifdef CODE_INLINE_FLAG + /* RWS +++ move to code generator ??? */ + if (codeBlock->co_is_abc_code && codeBlock->co_is_inline) + { + char *functionName, *instructionLine; + Instructions instruction; + + Assert (lhs->node_kind == NormalNode); + Assert (lhs->node_symbol->symb_kind == definition); + functionName = lhs->node_symbol->symb_def->sdef_ident->ident_name; + + /* .inline <name> */ + instructionLine = ConvertAlloc (sizeof (".inline ") + strlen (functionName)); + strcpy (instructionLine, ".inline "); + strcat (instructionLine, functionName); + + instruction = ConvertAllocType (Instruction); + instruction->instr_this = instructionLine; + instruction->instr_next = codeBlock->co_instr; + codeBlock->co_instr = instruction; + + for (; instruction->instr_next != NULL; instruction = instruction->instr_next) + /* find last element */; + instruction = instruction->instr_next = ConvertAllocType (Instruction); + + instruction->instr_this = ".end"; + instruction->instr_next = NULL; + } +# endif + + return (alt); +} /* BECodeAlt */ + +BERuleAltP +BERuleAlts (BERuleAltP alt, BERuleAltP alts) +{ + Assert (alt->alt_next == NULL); + + alt->alt_next = alts; + + return (alt); +} /* BERuleAlts*/ + +BERuleAltP +BENoRuleAlts (void) +{ + return (NULL); +} /* BENoRuleAlts */ + +static void +DeclareFunctionC (char *name, int arity, int functionIndex, unsigned int ancestor) +{ + SymbDefP newSymbDef; + Ident newIdent; + SymbolP functions; + BEIcl icl; + BEModule module; + + icl = &gBEState.be_icl; + + module = &gBEState.be_modules [kIclModuleIndex]; + functions = module->bem_functions; + Assert (functions != NULL); + + Assert (icl->beicl_previousAncestor >= ancestor); + icl->beicl_previousAncestor = ancestor; + + Assert (functionIndex < module->bem_nFunctions); + newSymbDef = ConvertAllocType (SymbDefS); + + newSymbDef->sdef_kind = IMPRULE; + newSymbDef->sdef_mark = 0; + newSymbDef->sdef_over_arity = 0; + newSymbDef->sdef_arity = arity; + newSymbDef->sdef_module = module->bem_name; + newSymbDef->sdef_ancestor = ancestor; + newSymbDef->sdef_arfun = NoArrayFun; + newSymbDef->sdef_next_scc = NULL; + newSymbDef->sdef_exported = False; + newSymbDef->sdef_dcl_icl = NULL; + newSymbDef->sdef_isused = 0; + newSymbDef->sdef_no_sa = False; + + newSymbDef->sdef_nr_of_lifted_nodeids = 0; /* used in PrintType */ + newSymbDef->sdef_line = 0; /* used in PrintType */ + + *icl->beicl_depsP = newSymbDef; + icl->beicl_depsP = &newSymbDef->sdef_next_scc; + newSymbDef->sdef_arfun = NoArrayFun; + + newIdent = ConvertAllocType (IdentS); + + newIdent->ident_name = name; + newIdent->ident_symbol = &functions [functionIndex]; + + newSymbDef->sdef_ident = newIdent; + + Assert (functions [functionIndex].symb_kind == erroneous_symb); + functions [functionIndex].symb_kind = definition; + functions [functionIndex].symb_def = newSymbDef; + + + /* +++ ugly */ + if (strcmp (newIdent->ident_name, "Start") == 0) + { + Assert (icl->beicl_module->im_start == NULL); + icl->beicl_module->im_start = newSymbDef; + } +} /* DeclareFunctionC */ + +void +BEDeclareFunction (CleanString name, int arity, int functionIndex, int ancestor) +{ + /* +++ ugly */ + if (strncmp (name->chars, "Start;", 6) == 0) + name->length = 5; + + DeclareFunctionC (ConvertCleanString (name), arity, functionIndex, ancestor); +} /* BEDeclareFunction */ + +BEImpRuleP +BERules (BEImpRuleP rule, BEImpRuleP rules) +{ + Assert (rule->rule_next == NULL); + + rule->rule_next = rules; + + return (rule); +} /* BERules */ + +BEImpRuleP +BENoRules (void) +{ + return (NULL); +} /* BENoRules */ + +BEImpRuleP +BERule (int functionIndex, int isCaf, BETypeAltP type, BERuleAltP alts) +{ + SymbDefP functionDef; + SymbolP functionSymbol; + ImpRuleP rule; + BEModule module; + + rule = ConvertAllocType (ImpRuleS); + + module = &gBEState.be_modules [kIclModuleIndex]; + functionSymbol = &module->bem_functions [functionIndex]; + functionDef = functionSymbol->symb_def; + functionDef->sdef_rule = rule; + + rule->rule_type = type; + rule->rule_alts = alts; + rule->rule_mark = isCaf ? RULE_CAF_MASK : 0; + + rule->rule_root = alts->alt_lhs_root; + + /* ifdef DEBUG */ + rule->rule_next = NULL; + /* endif DEBUG */ + + return (rule); +} /* BERule */ + +void +BEDeclareRuleType (int functionIndex, int moduleIndex, CleanString name) +{ + IdentP newIdent; + SymbDefP newSymbDef; + SymbolP functions; + BEModuleP module; + + module = &gBEState.be_modules [moduleIndex]; + + Assert ((unsigned int) functionIndex < module->bem_nFunctions); + + functions = module->bem_functions; + + Assert (functions != NULL); + Assert (functions [functionIndex].symb_kind == erroneous_symb); + + if (module->bem_isSystemModule) + /* for inline code */ + newIdent = PutStringInHashTable (ConvertCleanString (name), SymbolIdTable); + else + { + newIdent = ConvertAllocType (IdentS); + newIdent->ident_name = ConvertCleanString (name); + } + + newIdent->ident_symbol = &functions [functionIndex]; + + newSymbDef = ConvertAllocType (SymbDefS); + newSymbDef->sdef_kind = NEWDEFINITION; + newSymbDef->sdef_exported = False; + newSymbDef->sdef_module = module->bem_name; + newSymbDef->sdef_ident = newIdent; + newSymbDef->sdef_isused = 0; + newSymbDef->sdef_line = 0; /* used in PrintSymbolOfIdent */ + + functions [functionIndex].symb_kind = definition; + functions [functionIndex].symb_def = newSymbDef; + +} /* BEDeclareRuleType */ + +void +BEDefineRuleType (int functionIndex, int moduleIndex, BETypeAltP typeAlt) +{ + SymbolP functionSymbol; + SymbDef sdef; + RuleTypes ruleType; + BEModule module; + + ruleType = ConvertAllocType (struct rule_type); + ruleType->rule_type_rule = typeAlt; + + module = &gBEState.be_modules [moduleIndex]; + functionSymbol = &module->bem_functions [functionIndex]; + + sdef = functionSymbol->symb_def; + Assert (sdef->sdef_kind == NEWDEFINITION); + sdef->sdef_over_arity = 0; + sdef->sdef_arity = typeAlt->type_alt_lhs->type_node_arity; + sdef->sdef_arfun = NoArrayFun; + sdef->sdef_kind = module->bem_isSystemModule ? SYSRULE : DEFRULE; + sdef->sdef_rule_type = ruleType; +} /* BEDefineRuleType */ + +void +BEAdjustArrayFunction (BEArrayFunKind arrayFunKind, int functionIndex, int moduleIndex) +{ + SymbolP functionSymbol; + SymbDef sdef; + BEModule module; + + module = &gBEState.be_modules [moduleIndex]; + functionSymbol = &module->bem_functions [functionIndex]; + + sdef = functionSymbol->symb_def; + + Assert (sdef->sdef_kind == DEFRULE || (moduleIndex == kIclModuleIndex && sdef->sdef_kind == IMPRULE)); + sdef->sdef_arfun = arrayFunKind; + sdef->sdef_mark = 0; + + if (sdef->sdef_kind == DEFRULE && moduleIndex == kIclModuleIndex) + { + AddUserDefinedArrayFunction (functionSymbol); + sdef->sdef_kind = SYSRULE; + } +} /* BEAdjustArrayFunction */ + +BETypeP +BETypes (BETypeP type, BETypeP types) +{ + Assert (type->type_next == NULL); + + type->type_next = types; + + return (type); +} /* BETypes */ + +BETypeP +BENoTypes (void) +{ + return (NULL); +} /* BENoTypes */ + +void +BEDeclareType (int typeIndex, int moduleIndex, CleanString name) +{ + SymbDefP newSymbDef; + Ident newIdent; + SymbolP *types; + BEModuleP module; + module = &gBEState.be_modules [moduleIndex]; + + Assert ((unsigned int) typeIndex < module->bem_nTypes); + Assert (module->bem_types [typeIndex]->symb_kind == erroneous_symb); + + types = module->bem_types; + Assert (types != NULL); + + newIdent = ConvertAllocType (IdentS); + newIdent->ident_name = ConvertCleanString (name); + newIdent->ident_symbol = types [typeIndex]; +/* RWS change this + newSymbDef = ConvertAllocType (SymbDefS); +*/ + newSymbDef = types [typeIndex]->symb_def; + Assert (newSymbDef != NULL); + + newSymbDef->sdef_kind = NEWDEFINITION; + newSymbDef->sdef_exported = False; + newSymbDef->sdef_dcl_icl = NULL; + newSymbDef->sdef_isused = 0; + + newSymbDef->sdef_module = module->bem_name; + newSymbDef->sdef_ident = newIdent; + + types [typeIndex]->symb_kind = definition; + types [typeIndex]->symb_def = newSymbDef; +} /* BEDeclareType */ + +BETypeVarP +BETypeVar (CleanString name) +{ + IdentP ident; + TypeVar typeVar; + + ident = ConvertAllocType (IdentS); + typeVar = ConvertAllocType (struct type_var); + + ident->ident_name = ConvertCleanString (name); + ident->ident_tv = typeVar; + + typeVar->tv_ident = ident; + typeVar->tv_argument_nr = 0; /* ??? */ + + return (typeVar); +} /* BETypeVar */ + +BETypeVarListP +BETypeVars (BETypeVarP typeVar, BETypeVarListP typeVarList) +{ + TypeVarList typeVarListElement; + + typeVarListElement = ConvertAllocType (struct type_var_list); + typeVarListElement->tvl_elem = typeVar; + typeVarListElement->tvl_next = typeVarList; + + return (typeVarListElement); +} /* BETypeVars */ + +BETypeVarListP +BENoTypeVars (void) +{ + return (NULL); +} /* BENoTypeVars */ + +BEFlatTypeP +BEFlatType (BESymbolP symbol, BETypeVarListP arguments) +{ + FlatType flatType; + int i; + + flatType = ConvertAllocType (struct flat_type); + + flatType->ft_symbol = symbol; + flatType->ft_arguments = arguments; + i = 0; + for (; arguments != NULL; arguments=arguments->tvl_next) + i++; + flatType->ft_arity = i; + + flatType->ft_cons_vars = NULL; /* used in PrintType */ + + return (flatType); +} /* BEFlatType */ + +void +BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors) +{ + Types type; + SymbDefP sdef; + int nConstructors; + + type = ConvertAllocType (struct type); + /* ifdef DEBUG */ + type->type_next = NULL; + /* endif */ + + type->type_lhs = lhs; + type->type_line = 0; /* ??? */ + type->type_constructors = constructors; + + nConstructors = 0; + for (; constructors != NULL; constructors = constructors->cl_next) + { + SymbDef cdef; + + Assert (!constructors->cl_constructor->type_node_is_var); + Assert (constructors->cl_constructor->type_node_symbol->symb_kind == definition); + + cdef = constructors->cl_constructor->type_node_symbol->symb_def; + Assert (cdef->sdef_type == NULL); + cdef->sdef_type = type; + + nConstructors++; + } + + type->type_nr_of_constructors = nConstructors; + + Assert (type->type_lhs->ft_symbol->symb_kind == definition); + sdef = type->type_lhs->ft_symbol->symb_def; + Assert (sdef->sdef_kind == NEWDEFINITION); + sdef->sdef_over_arity = 0; + sdef->sdef_kind = TYPE; + sdef->sdef_type = type; +} /* BEAlgebraicType */ + +void +BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, BEFieldListP fields) +{ + int nFields; + Types type; + SymbDefP sdef; + BEConstructorListP constructor; + + type = ConvertAllocType (struct type); + /* ifdef DEBUG */ + type->type_next = NULL; + /* endif */ + + constructor = ConvertAllocType (struct constructor_list); + + constructor->cl_next = NULL; + constructor->cl_constructor = constructorType; + + type->type_lhs = lhs; + type->type_line = 0; /* ??? */ + type->type_constructors = constructor; + type->type_fields = fields; + + nFields = 0; + for (; fields != NULL; fields = fields->fl_next) + { + SymbDef fdef; + + Assert (fields->fl_symbol->symb_kind == definition); + + fdef = fields->fl_symbol->symb_def; + Assert (fdef->sdef_type == NULL); + fdef->sdef_type = type; + fdef->sdef_sel_field_number = nFields++; + } + + type->type_nr_of_constructors = 0; + + Assert (type->type_lhs->ft_symbol->symb_kind == definition); + sdef = type->type_lhs->ft_symbol->symb_def; + Assert (sdef->sdef_kind == NEWDEFINITION); + sdef->sdef_over_arity = 0; + sdef->sdef_cons_arity = constructorType->type_node_arity; + sdef->sdef_checkstatus = TypeChecked; + sdef->sdef_kind = RECORDTYPE; + sdef->sdef_type = type; + sdef->sdef_arity = constructorType->type_node_arity; + + // +++ change this + { + int i; + BEModuleP module; + + module = &gBEState.be_modules [moduleIndex]; + + for (i = 0; i < module->bem_nConstructors; i++) + if (module->bem_constructors [i] == constructorType->type_node_symbol) + break; + + Assert (i < module->bem_nConstructors); + module->bem_constructors [i] = type->type_lhs->ft_symbol; + } +} /* BERecordType */ + +void +BEAbsType (BEFlatTypeP lhs) +{ + AbsTypes absType; + SymbDefP sdef; + + absType = ConvertAllocType (struct abs_type); + /* ifdef DEBUG */ + absType->abs_next = NULL; + /* endif */ + + absType->abs_graph = lhs; + absType->abs_line = 0; /* ??? */ + + Assert (lhs->ft_symbol->symb_kind == definition); + sdef = lhs->ft_symbol->symb_def; + Assert (sdef->sdef_kind == NEWDEFINITION); + sdef->sdef_over_arity = 0; + sdef->sdef_checkstatus = TypeChecked; + sdef->sdef_kind = ABSTYPE; + sdef->sdef_abs_type = absType; + +} /* BEAbsType */ + +BEConstructorListP +BEConstructors (BEConstructorListP constructor, BEConstructorListP constructors) +{ + Assert (constructor->cl_next == NULL); + + constructor->cl_next = constructors; + + return (constructor); +} /* BEConstructors */ + +BEConstructorListP +BENoConstructors (void) +{ + return (NULL); +} /* BENoConstructors */ + +BEConstructorListP +BEConstructor (BETypeNodeP type) +{ + ConstructorList constructor; + SymbDef sdef; + + Assert (!type->type_node_is_var); + Assert (type->type_node_symbol->symb_kind == definition); + + sdef = type->type_node_symbol->symb_def; + + constructor = ConvertAllocType (struct constructor_list); + + /* ifdef DEBUG */ + constructor->cl_next = NULL; + /* endif */ + constructor->cl_constructor = type; + + sdef->sdef_kind = CONSTRUCTOR; + sdef->sdef_constructor = constructor; + sdef->sdef_arity = type->type_node_arity; + sdef->sdef_over_arity = 0; + /* ifdef DEBUG */ + sdef->sdef_type = NULL; + /* endif */ + + return (constructor); +} /* BEConstructor */ + +void +BEDeclareField (int fieldIndex, int moduleIndex, CleanString name) +{ + SymbDefP newSymbDef; + Ident newIdent; + SymbolP fields; + BEModuleP module; + + module = &gBEState.be_modules [moduleIndex]; + Assert ((unsigned) fieldIndex < module->bem_nFields); + Assert (module->bem_fields [fieldIndex].symb_kind == erroneous_symb); + + fields = module->bem_fields; + Assert (fields != NULL); + + newIdent = ConvertAllocType (IdentS); + newIdent->ident_name = ConvertCleanString (name); + newIdent->ident_symbol = &fields [fieldIndex]; + + newSymbDef = ConvertAllocType (SymbDefS); + newSymbDef->sdef_kind = NEWDEFINITION; + newSymbDef->sdef_exported = False; + newSymbDef->sdef_module = module->bem_name; + newSymbDef->sdef_ident = newIdent; + newSymbDef->sdef_isused = 0; + + fields [fieldIndex].symb_kind = definition; + fields [fieldIndex].symb_def = newSymbDef; +} /* BEDeclareField */ + +BEFieldListP +BEField (int fieldIndex, int moduleIndex, BETypeNodeP type) +{ + SymbDef sdef; + SymbolP fields; + BEModuleP module; + FieldList field; + + module = &gBEState.be_modules [moduleIndex]; + Assert ((unsigned) fieldIndex < module->bem_nFields); + Assert (module->bem_fields [fieldIndex].symb_kind == definition); + + fields = module->bem_fields; + Assert (fields != NULL); + + field = ConvertAllocType (struct field_list); + + /* ifdef DEBUG */ + field->fl_next = NULL; + /* endif */ + field->fl_symbol = &fields [fieldIndex]; + field->fl_type = type; + + sdef = fields [fieldIndex].symb_def; + + sdef->sdef_kind = FIELDSELECTOR; + sdef->sdef_sel_field = field; + sdef->sdef_arity = 1; + sdef->sdef_over_arity = 0; + sdef->sdef_mark = 0; + /* ifdef DEBUG */ + sdef->sdef_type = NULL; + /* endif */ + + return (field); +} /* BEField */ + +BEFieldListP +BEFields (BEFieldListP field, BEFieldListP fields) +{ + Assert (field->fl_next == NULL); + + field->fl_next = fields; + + return (field); +} /* BEFields */ + +BEFieldListP +BENoFields (void) +{ + return (NULL); +} /* BENoFields */ + +void +BEDeclareConstructor (int constructorIndex, int moduleIndex, CleanString name) +{ + SymbDefP newSymbDef; + Ident newIdent; + SymbolP *constructors; + BEModuleP module; + + module = &gBEState.be_modules [moduleIndex]; + Assert ((unsigned) constructorIndex < module->bem_nConstructors); + Assert (module->bem_constructors [constructorIndex]->symb_kind == erroneous_symb); + + constructors = module->bem_constructors; + Assert (constructors != NULL); + + newIdent = ConvertAllocType (IdentS); + newIdent->ident_name = ConvertCleanString (name); + newIdent->ident_symbol = constructors [constructorIndex]; + + newSymbDef = ConvertAllocType (SymbDefS); + newSymbDef->sdef_kind = NEWDEFINITION; + newSymbDef->sdef_exported = False; + newSymbDef->sdef_module = module->bem_name; + newSymbDef->sdef_ident = newIdent; + newSymbDef->sdef_isused = 0; + newSymbDef->sdef_no_sa = False; + + constructors [constructorIndex]->symb_kind = definition; + constructors [constructorIndex]->symb_def = newSymbDef; +} /* BEDeclareConstructor */ + +void +BEDefineRules (BEImpRuleP rules) +{ + gBEState.be_icl.beicl_module->im_rules = rules; +} /* BEDefineRules */ + +void +BEDefineImportedObjsAndLibs (BEStringListP objs, BEStringListP libs) +{ + gBEState.be_icl.beicl_module->im_imported_objs = objs; + gBEState.be_icl.beicl_module->im_imported_libs = libs; +} /* BEDefineRules */ + +BEStringListP +BEString (CleanString cleanString) +{ + struct string_list *string; + + string = ConvertAllocType (struct string_list); + + string->sl_string = ConvertCleanString (cleanString); + /* ifdef DEBUG */ + string->sl_next = NULL; + /* endif */ + + return (string); +} /* BEString */ + +BEStringListP +BEStrings (BEStringListP string, BEStringListP strings) +{ + Assert (string->sl_next == NULL); + + string->sl_next = strings; + + return (string); +} /* BEStringList*/ + +BEStringListP +BENoStrings (void) +{ + return (NULL); +} /* BENoStrings */ + +BECodeBlockP +BEAbcCodeBlock (int inlineFlag, BEStringListP instructions) +{ + CodeBlock codeBlock; + + codeBlock = ConvertAllocType (CodeBlockS); + + codeBlock->co_instr = (Instructions) instructions; + codeBlock->co_is_abc_code = True; + codeBlock->co_is_inline = inlineFlag; + + return (codeBlock); +} /* BEAbcCodeBlock */ + +BECodeBlockP +BEAnyCodeBlock (BECodeParameterP inParams, BECodeParameterP outParams, BEStringListP instructions) +{ + CodeBlock codeBlock; + + codeBlock = ConvertAllocType (CodeBlockS); + + codeBlock->co_instr = (Instructions) instructions; + codeBlock->co_is_abc_code = False; + codeBlock->co_parin = inParams; + codeBlock->co_parout = outParams; + + return (codeBlock); +} /* BEAnyCodeBlock */ + +BECodeParameterP +BECodeParameter (CleanString location, BENodeIdP nodeId) +{ + Parameters parameter; + + parameter = ConvertAllocType (struct parameter); + + parameter->par_kind = 0; + parameter->par_node_id = nodeId; + parameter->par_loc = Identifier (ConvertCleanString (location)); + + /* ifdef DEBUG */ + parameter->par_next = NULL; + /* endif */ + + return (parameter); +} /* BECodeParameter */ + +BECodeParameterP +BECodeParameters (BECodeParameterP parameter, BECodeParameterP parameters) +{ + Assert (parameter->par_next == NULL); + + parameter->par_next = parameters; + + return (parameter); +} /* BECodeParameters */ + +BECodeParameterP +BENoCodeParameters (void) +{ + return (NULL); +} /* BENoCodeParameters */ + +static void +RemoveSpecialArrayFunctionsFromSymbolList (SymbolP *symbolH) +{ + SymbolP symbolP; + + while ((symbolP = *symbolH) != NULL) + { + SymbDefP sdef; + + sdef = symbolP->symb_def; + + if (symbolP->symb_kind == definition && sdef->sdef_kind == IMPRULE && sdef->sdef_arfun != NoArrayFun) + *symbolH = symbolP->symb_next; + else + symbolH = &symbolP->symb_next; + } +} /* RemoveSpecialArrayFunctionsFromSymbolList */ + +int +BEGenerateCode (CleanString outputFile) +{ + char *outputFileName; + ImpRule rule; + + if (CompilerError) + return False; + + // RemoveSpecialArrayFunctionsFromSymbolList (&gBEState.be_icl.beicl_module->im_symbols); + + /* +++ hack */ + rule = gBEState.be_dictionarySelectFunSymbol->symb_def->sdef_rule; + rule->rule_next = gBEState.be_icl.beicl_module->im_rules; + gBEState.be_icl.beicl_module->im_rules = rule; + + rule = gBEState.be_dictionaryUpdateFunSymbol->symb_def->sdef_rule; + rule->rule_next = gBEState.be_icl.beicl_module->im_rules; + gBEState.be_icl.beicl_module->im_rules = rule; + + outputFileName = ConvertCleanString (outputFile); + CodeGeneration (gBEState.be_icl.beicl_module, outputFileName); + + return (!CompilerError); +} /* BEGenerateCode */ + +void +BEExportType (int dclTypeIndex, int iclTypeIndex) +{ + BEModuleP dclModule, iclModule; + SymbolP typeSymbol; + SymbDefP iclDef, dclDef; + + iclModule = &gBEState.be_modules [kIclModuleIndex]; + + Assert ((unsigned int) iclTypeIndex < iclModule->bem_nTypes); + typeSymbol = iclModule->bem_types [iclTypeIndex]; + Assert (typeSymbol->symb_kind == definition); + + iclDef = typeSymbol->symb_def; + iclDef->sdef_exported = True; + + dclModule = &gBEState.be_icl.beicl_dcl_module; + + /* +++ remove -1 hack */ + if (dclTypeIndex == -1) + dclDef = iclDef; + else + { + Assert ((unsigned int) dclTypeIndex < dclModule->bem_nTypes); + typeSymbol = dclModule->bem_types [dclTypeIndex]; + Assert (typeSymbol->symb_kind == definition); + dclDef = typeSymbol->symb_def; + } + Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0); + + iclDef->sdef_dcl_icl = dclDef; + dclDef->sdef_dcl_icl = iclDef; +} /* BEExportType */ + +void +BESwapTypes (int frm, int to) +{ + BEModuleP module; + SymbolP save; + + module = &gBEState.be_modules [kIclModuleIndex]; + + Assert ((unsigned int) frm < module->bem_nTypes); + Assert ((unsigned int) to < module->bem_nTypes); + + save = module->bem_types [frm]; + module->bem_types [frm] = module->bem_types [to]; + module->bem_types [to] = save; +} /* BESwapTypes */ + +void +BEExportConstructor (int dclConstructorIndex, int iclConstructorIndex) +{ + BEModuleP dclModule, iclModule; + SymbolP constructorSymbol; + SymbDefP iclDef, dclDef; + + iclModule = &gBEState.be_modules [kIclModuleIndex]; + + Assert ((unsigned int) iclConstructorIndex < iclModule->bem_nConstructors); + constructorSymbol = iclModule->bem_constructors [iclConstructorIndex]; + Assert (constructorSymbol->symb_kind == definition); + + iclDef = constructorSymbol->symb_def; + iclDef->sdef_exported = True; + + if (0) + { + dclModule = &gBEState.be_icl.beicl_dcl_module; + + Assert ((unsigned int) dclConstructorIndex < dclModule->bem_nConstructors); + constructorSymbol = dclModule->bem_constructors [dclConstructorIndex]; + Assert (constructorSymbol->symb_kind == definition); + dclDef = constructorSymbol->symb_def; + + Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0); + } + else + dclDef = iclDef; + + iclDef->sdef_dcl_icl = dclDef; + dclDef->sdef_dcl_icl = iclDef; +} /* BEExportConstructor */ + +void +BEExportField (int dclFieldIndex, int iclFieldIndex) +{ + BEModuleP dclModule, iclModule; + SymbolP fieldSymbol; + SymbDefP iclDef, dclDef; + + iclModule = &gBEState.be_modules [kIclModuleIndex]; + + Assert ((unsigned int) iclFieldIndex < iclModule->bem_nFields); + fieldSymbol = &iclModule->bem_fields [iclFieldIndex]; + Assert (fieldSymbol->symb_kind == definition); + + iclDef = fieldSymbol->symb_def; + iclDef->sdef_exported = True; + + /* +++ remove -1 hack */ + if (dclFieldIndex == -1) + dclDef = iclDef; + else + { + dclModule = &gBEState.be_icl.beicl_dcl_module; + + Assert ((unsigned int) dclFieldIndex < dclModule->bem_nFields); + fieldSymbol = &dclModule->bem_fields [dclFieldIndex]; + Assert (fieldSymbol->symb_kind == definition); + dclDef = fieldSymbol->symb_def; + } + + Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0); + + iclDef->sdef_dcl_icl = dclDef; + dclDef->sdef_dcl_icl = iclDef; +} /* BEExportField */ + +void +BEExportFunction (int dclFunctionIndex, int iclFunctionIndex) +{ + BEModuleP dclModule, iclModule; + SymbolP functionSymbol; + SymbDefP iclDef, dclDef; + + iclModule = &gBEState.be_modules [kIclModuleIndex]; + + Assert ((unsigned int) iclFunctionIndex < iclModule->bem_nFunctions); + functionSymbol = &iclModule->bem_functions [iclFunctionIndex]; + Assert (functionSymbol->symb_kind == definition); + + iclDef = functionSymbol->symb_def; + iclDef->sdef_exported = True; + + dclModule = &gBEState.be_icl.beicl_dcl_module; + + Assert ((unsigned int) dclFunctionIndex < dclModule->bem_nFunctions); + functionSymbol = &dclModule->bem_functions [dclFunctionIndex]; + Assert (functionSymbol->symb_kind == definition); + dclDef = functionSymbol->symb_def; + + Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0); + + iclDef->sdef_dcl_icl = dclDef; + dclDef->sdef_dcl_icl = iclDef; +} /* BEExportFunction */ + +static void +CheckBEEnumTypes (void) +{ + /* Annotation */ + Assert (NoAnnot == BENoAnnot); + Assert (StrictAnnot == BEStrictAnnot); + + /* Annotation */ + Assert (NoUniAttr == BENoUniAttr); + Assert (NotUniqueAttr == BENotUniqueAttr); + Assert (UniqueAttr == BEUniqueAttr); + Assert (ExistsAttr == BEExistsAttr); + Assert (UniqueVariable == BEUniqueVariable); + Assert (FirstUniVarNumber == BEFirstUniVarNumber); + + /* SymbKind */ + Assert (int_type == BEIntType); + Assert (bool_type == BEBoolType); + Assert (char_type == BECharType); + Assert (real_type == BERealType); + Assert (file_type == BEFileType); + Assert (string_type == BEStringType); + Assert (world_type == BEWorldType); + Assert (procid_type == BEProcIdType); + Assert (redid_type == BERedIdType); + Assert (Nr_Of_Basic_Types == BENrOfBasicTypes); + Assert (int_denot == BEIntDenot); + Assert (bool_denot == BEBoolDenot); + Assert (char_denot == BECharDenot); + Assert (real_denot == BERealDenot); + Assert (Nr_Of_Basic_Denots == BENrOfBasicDenots); + Assert (string_denot == BEStringDenot); + Assert (fun_type == BEFunType); + Assert (array_type == BEArrayType); + Assert (strict_array_type == BEStrictArrayType); + Assert (unboxed_array_type == BEUnboxedArrayType); + Assert (list_type == BEListType); + Assert (tuple_type == BETupleType); + Assert (empty_type == BEEmptyType); +#if DYNAMIC_TYPE + Assert (dynamic_type == BEDynamicType); +#endif + Assert (Nr_Of_Predef_Types == BENrOfPredefTypes); + Assert (tuple_symb == BETupleSymb); + Assert (cons_symb == BEConsSymb); + Assert (nil_symb == BENilSymb); + Assert (apply_symb == BEApplySymb); + Assert (if_symb == BEIfSymb); + Assert (fail_symb == BEFailSymb); + Assert (all_symb == BEAllSymb); + Assert (select_symb == BESelectSymb); + Assert (Nr_Of_Predef_FunsOrConses == BENrOfPredefFunsOrConses); + Assert (definition == BEDefinition); + Assert (newsymbol == BENewSymbol); + Assert (instance_symb == BEInstanceSymb); + Assert (empty_symbol == BEEmptySymbol); + Assert (field_symbol_list == BEFieldSymbolList); + Assert (erroneous_symb == BEErroneousSymb); + + /* ArrayFunKind */ + Assert (CreateArrayFun == BECreateArrayFun); + Assert (ArraySelectFun == BEArraySelectFun); + Assert (UnqArraySelectFun == BEUnqArraySelectFun); + Assert (ArrayUpdateFun == BEArrayUpdateFun); + Assert (ArrayReplaceFun == BEArrayReplaceFun); + Assert (ArraySizeFun == BEArraySizeFun); + Assert (UnqArraySizeFun == BEUnqArraySizeFun); + Assert (_CreateArrayFun == BE_CreateArrayFun); + Assert (_UnqArraySelectFun == BE_UnqArraySelectFun); + Assert (_UnqArraySelectNextFun == BE_UnqArraySelectNextFun); + Assert (_UnqArraySelectLastFun == BE_UnqArraySelectLastFun); + Assert (_ArrayUpdateFun == BE_ArrayUpdateFun); + Assert (NoArrayFun == BENoArrayFun); + + /* SelectorKind */ + Assert (1 == BESelector); + Assert (SELECTOR_U == BESelector_U); + Assert (SELECTOR_F == BESelector_F); + Assert (SELECTOR_L == BESelector_L); + Assert (SELECTOR_N == BESelector_N); +} /* CheckBEEnumTypes */ + +void +BEArg (CleanString arg) +{ + Assert (gBEState.be_argi < gBEState.be_argc); + + gBEState.be_argv [gBEState.be_argi++] = ConvertCleanString (arg); + + // +++ ugly + if (gBEState.be_argi == gBEState.be_argc) + { + char *dummy; + extern Bool ParseCommandArgs (int argc, char **argv, char **file_name_p, char **output_file_name_p); + + (void) ParseCommandArgs (gBEState.be_argc, gBEState.be_argv, &dummy, &dummy); + + /* FatalCompError ("backend", "BEInit", "FatalCompError in backend"); */ + /* ErrorInCompiler ("backend", "BEInit", "ErrorInCompiler in backend"); */ + /* StaticMessage (True, "<backend>", "StaticMessage (True) in backend"); */ + /* StaticMessage (False, "<backend>", "StaticMessage (False) in backend"); */ + /* *(int*)0L= 17; */ + } +} /* BEArg */ + +BackEnd +BEInit (int argc) +{ + Assert (!gBEState.be_initialised); + + CheckBEEnumTypes (); + + CurrentPhase = "Back End"; + CurrentModule = "<unknown module>"; + CurrentExt = ""; + + gBEState.be_argv = ConvertAlloc ((argc+1) * sizeof (char *)); + gBEState.be_argv [argc] = NULL; + gBEState.be_argc = argc; + gBEState.be_argi = 0; + + InitStorage (); + /* +++ remove symbol table from backend */ + ScanInitIdentStringTable (); + InitScanner (); /* for inlining */ + DeltaBId = Identifier ("StdBool"); + ApplyId = Identifier ("AP"); + ListId = Identifier ("List"); + TupleId = Identifier ("Tuple"); + ConsId = Identifier ("[:]"); + NilId = Identifier ("[]"); + SelectId = Identifier ("_Select"); + IfId = Identifier ("if"); + FailId = Identifier ("_Fail"); +#if DYNAMIC_TYPE + DynamicId = Identifier ("Dynamic"); +#endif + + UserDefinedArrayFunctions = NULL; + + InitPredefinedSymbols (); + + ClearOpenDefinitionModules (); + + InitStatesGen (); + InitCoding (); + InitInstructions (); + + gBEState.be_modules = NULL; + gBEState.be_allSymbols = NULL; + gBEState.be_dontCareSymbol = NULL; + gBEState.be_dictionarySelectFunSymbol = NULL; + gBEState.be_dictionaryUpdateFunSymbol = NULL; + + gBEState.be_initialised = True; + + return ((BackEnd) &gBEState); +} /* BEInit */ + +void +BEFree (BackEnd backEnd) +{ + Assert (backEnd == (BackEnd) &gBEState); + + FreeConvertBuffers (); + CompFree (); + + Assert (gBEState.be_initialised); + gBEState.be_initialised = False; + + if (StdErrorReopened) + fclose (StdError); + if (StdOutReopened) + fclose (StdOut); +} /* BEFree */ diff --git a/backendC/CleanCompilerSources/backend.dcl b/backendC/CleanCompilerSources/backend.dcl new file mode 100644 index 0000000..48ad039 --- /dev/null +++ b/backendC/CleanCompilerSources/backend.dcl @@ -0,0 +1,298 @@ +definition module backend; + +from StdString import String; + +:: *UWorld :== Int; +:: *BackEnd; // :== Int; +:: BESymbolP; // :== Int; +:: BETypeNodeP; // :== Int; +:: BETypeArgP; // :== Int; +:: BETypeAltP; // :== Int; +:: BENodeP; // :== Int; +:: BEArgP; // :== Int; +:: BERuleAltP; // :== Int; +:: BEImpRuleP; // :== Int; +:: BETypeP; // :== Int; +:: BEFlatTypeP; // :== Int; +:: BETypeVarP; // :== Int; +:: BETypeVarListP; // :== Int; +:: BEConstructorListP; // :== Int; +:: BEFieldListP; // :== Int; +:: BENodeIdP; // :== Int; +:: BENodeDefP; // :== Int; +:: BEStrictNodeIdP; // :== Int; +:: BECodeParameterP; // :== Int; +:: BECodeBlockP; // :== Int; +:: BEStringListP; // :== Int; +:: BEAnnotation :== Int; +:: BEAttribution :== Int; +:: BESymbKind :== Int; +:: BEArrayFunKind :== Int; +:: BESelectorKind :== Int; +:: BEUpdateKind :== Int; +BEGetVersion :: (!Int,!Int,!Int); +// void BEGetVersion(int* current,int* oldestDefinition,int* oldestImplementation); +BEInit :: !Int !UWorld -> (!BackEnd,!UWorld); +// BackEnd BEInit(int argc); +BEFree :: !BackEnd !UWorld -> UWorld; +// void BEFree(BackEnd backEnd); +BEArg :: !String !BackEnd -> BackEnd; +// void BEArg(CleanString arg); +BEDeclareModules :: !Int !BackEnd -> BackEnd; +// void BEDeclareModules(int nModules); +BEDeclarePredefinedSymbols :: !Int !Int !BackEnd -> BackEnd; +// void BEDeclarePredefinedSymbols(int nConstructors,int nTypes); +BESpecialArrayFunctionSymbol :: !BEArrayFunKind !Int !Int !BackEnd -> (!BESymbolP,!BackEnd); +// BESymbolP BESpecialArrayFunctionSymbol(BEArrayFunKind arrayFunKind,int functionIndex,int moduleIndex); +BEDictionarySelectFunSymbol :: !BackEnd -> (!BESymbolP,!BackEnd); +// BESymbolP BEDictionarySelectFunSymbol(); +BEDictionaryUpdateFunSymbol :: !BackEnd -> (!BESymbolP,!BackEnd); +// BESymbolP BEDictionaryUpdateFunSymbol(); +BEFunctionSymbol :: !Int !Int !BackEnd -> (!BESymbolP,!BackEnd); +// BESymbolP BEFunctionSymbol(int functionIndex,int moduleIndex); +BEConstructorSymbol :: !Int !Int !BackEnd -> (!BESymbolP,!BackEnd); +// BESymbolP BEConstructorSymbol(int constructorIndex,int moduleIndex); +BEFieldSymbol :: !Int !Int !BackEnd -> (!BESymbolP,!BackEnd); +// BESymbolP BEFieldSymbol(int fieldIndex,int moduleIndex); +BETypeSymbol :: !Int !Int !BackEnd -> (!BESymbolP,!BackEnd); +// BESymbolP BETypeSymbol(int typeIndex,int moduleIndex); +BEDontCareDefinitionSymbol :: !BackEnd -> (!BESymbolP,!BackEnd); +// BESymbolP BEDontCareDefinitionSymbol(); +BEBoolSymbol :: !Bool !BackEnd -> (!BESymbolP,!BackEnd); +// BESymbolP BEBoolSymbol(int value); +BELiteralSymbol :: !BESymbKind !String !BackEnd -> (!BESymbolP,!BackEnd); +// BESymbolP BELiteralSymbol(BESymbKind kind,CleanString value); +BEPredefineConstructorSymbol :: !Int !Int !Int !BESymbKind !BackEnd -> BackEnd; +// void BEPredefineConstructorSymbol(int arity,int constructorIndex,int moduleIndex,BESymbKind symbolKind); +BEPredefineTypeSymbol :: !Int !Int !Int !BESymbKind !BackEnd -> BackEnd; +// void BEPredefineTypeSymbol(int arity,int typeIndex,int moduleIndex,BESymbKind symbolKind); +BEBasicSymbol :: !Int !BackEnd -> (!BESymbolP,!BackEnd); +// BESymbolP BEBasicSymbol(BESymbKind kind); +BEVarTypeNode :: !String !BackEnd -> (!BETypeNodeP,!BackEnd); +// BETypeNodeP BEVarTypeNode(CleanString name); +BETypeVars :: !BETypeVarP !BETypeVarListP !BackEnd -> (!BETypeVarListP,!BackEnd); +// BETypeVarListP BETypeVars(BETypeVarP typeVar,BETypeVarListP typeVarList); +BENoTypeVars :: !BackEnd -> (!BETypeVarListP,!BackEnd); +// BETypeVarListP BENoTypeVars(); +BENormalTypeNode :: !BESymbolP !BETypeArgP !BackEnd -> (!BETypeNodeP,!BackEnd); +// BETypeNodeP BENormalTypeNode(BESymbolP symbol,BETypeArgP args); +BEAnnotateTypeNode :: !BEAnnotation !BETypeNodeP !BackEnd -> (!BETypeNodeP,!BackEnd); +// BETypeNodeP BEAnnotateTypeNode(BEAnnotation annotation,BETypeNodeP typeNode); +BEAttributeTypeNode :: !BEAttribution !BETypeNodeP !BackEnd -> (!BETypeNodeP,!BackEnd); +// BETypeNodeP BEAttributeTypeNode(BEAttribution attribution,BETypeNodeP typeNode); +BENoTypeArgs :: !BackEnd -> (!BETypeArgP,!BackEnd); +// BETypeArgP BENoTypeArgs(); +BETypeArgs :: !BETypeNodeP !BETypeArgP !BackEnd -> (!BETypeArgP,!BackEnd); +// BETypeArgP BETypeArgs(BETypeNodeP node,BETypeArgP nextArgs); +BETypeAlt :: !BETypeNodeP !BETypeNodeP !BackEnd -> (!BETypeAltP,!BackEnd); +// BETypeAltP BETypeAlt(BETypeNodeP lhs,BETypeNodeP rhs); +BENormalNode :: !BESymbolP !BEArgP !BackEnd -> (!BENodeP,!BackEnd); +// BENodeP BENormalNode(BESymbolP symbol,BEArgP args); +BEMatchNode :: !Int !BESymbolP !BENodeP !BackEnd -> (!BENodeP,!BackEnd); +// BENodeP BEMatchNode(int arity,BESymbolP symbol,BENodeP node); +BETupleSelectNode :: !Int !Int !BENodeP !BackEnd -> (!BENodeP,!BackEnd); +// BENodeP BETupleSelectNode(int arity,int index,BENodeP node); +BEIfNode :: !BENodeP !BENodeP !BENodeP !BackEnd -> (!BENodeP,!BackEnd); +// BENodeP BEIfNode(BENodeP cond,BENodeP then,BENodeP elsje); +BEGuardNode :: !BENodeP !BENodeDefP !BEStrictNodeIdP !BENodeP !BENodeDefP !BEStrictNodeIdP !BENodeP !BackEnd -> (!BENodeP,!BackEnd); +// BENodeP BEGuardNode(BENodeP cond,BENodeDefP thenNodeDefs,BEStrictNodeIdP thenStricts,BENodeP then,BENodeDefP elseNodeDefs,BEStrictNodeIdP elseStricts,BENodeP elsje); +BESelectorNode :: !BESelectorKind !BESymbolP !BEArgP !BackEnd -> (!BENodeP,!BackEnd); +// BENodeP BESelectorNode(BESelectorKind selectorKind,BESymbolP fieldSymbol,BEArgP args); +BEUpdateNode :: !BEArgP !BackEnd -> (!BENodeP,!BackEnd); +// BENodeP BEUpdateNode(BEArgP args); +BENodeIdNode :: !BENodeIdP !BEArgP !BackEnd -> (!BENodeP,!BackEnd); +// BENodeP BENodeIdNode(BENodeIdP nodeId,BEArgP args); +BENoArgs :: !BackEnd -> (!BEArgP,!BackEnd); +// BEArgP BENoArgs(); +BEArgs :: !BENodeP !BEArgP !BackEnd -> (!BEArgP,!BackEnd); +// BEArgP BEArgs(BENodeP node,BEArgP nextArgs); +BERuleAlt :: !Int !BENodeDefP !BENodeP !BENodeDefP !BEStrictNodeIdP !BENodeP !BackEnd -> (!BERuleAltP,!BackEnd); +// BERuleAltP BERuleAlt(int line,BENodeDefP lhsDefs,BENodeP lhs,BENodeDefP rhsDefs,BEStrictNodeIdP lhsStrictNodeIds,BENodeP rhs); +BERuleAlts :: !BERuleAltP !BERuleAltP !BackEnd -> (!BERuleAltP,!BackEnd); +// BERuleAltP BERuleAlts(BERuleAltP alt,BERuleAltP alts); +BENoRuleAlts :: !BackEnd -> (!BERuleAltP,!BackEnd); +// BERuleAltP BENoRuleAlts(); +BEDeclareNodeId :: !Int !Int !String !BackEnd -> BackEnd; +// void BEDeclareNodeId(int sequenceNumber,int lhsOrRhs,CleanString name); +BENodeId :: !Int !BackEnd -> (!BENodeIdP,!BackEnd); +// BENodeIdP BENodeId(int sequenceNumber); +BEWildCardNodeId :: !BackEnd -> (!BENodeIdP,!BackEnd); +// BENodeIdP BEWildCardNodeId(); +BENodeDef :: !Int !BENodeP !BackEnd -> (!BENodeDefP,!BackEnd); +// BENodeDefP BENodeDef(int sequenceNumber,BENodeP node); +BENoNodeDefs :: !BackEnd -> (!BENodeDefP,!BackEnd); +// BENodeDefP BENoNodeDefs(); +BENodeDefs :: !BENodeDefP !BENodeDefP !BackEnd -> (!BENodeDefP,!BackEnd); +// BENodeDefP BENodeDefs(BENodeDefP nodeDef,BENodeDefP nodeDefs); +BEStrictNodeId :: !BENodeIdP !BackEnd -> (!BEStrictNodeIdP,!BackEnd); +// BEStrictNodeIdP BEStrictNodeId(BENodeIdP nodeId); +BENoStrictNodeIds :: !BackEnd -> (!BEStrictNodeIdP,!BackEnd); +// BEStrictNodeIdP BENoStrictNodeIds(); +BEStrictNodeIds :: !BEStrictNodeIdP !BEStrictNodeIdP !BackEnd -> (!BEStrictNodeIdP,!BackEnd); +// BEStrictNodeIdP BEStrictNodeIds(BEStrictNodeIdP strictNodeId,BEStrictNodeIdP strictNodeIds); +BERule :: !Int !Int !BETypeAltP !BERuleAltP !BackEnd -> (!BEImpRuleP,!BackEnd); +// BEImpRuleP BERule(int functionIndex,int isCaf,BETypeAltP type,BERuleAltP alts); +BEDeclareRuleType :: !Int !Int !String !BackEnd -> BackEnd; +// void BEDeclareRuleType(int functionIndex,int moduleIndex,CleanString name); +BEDefineRuleType :: !Int !Int !BETypeAltP !BackEnd -> BackEnd; +// void BEDefineRuleType(int functionIndex,int moduleIndex,BETypeAltP typeAlt); +BEAdjustArrayFunction :: !BEArrayFunKind !Int !Int !BackEnd -> BackEnd; +// void BEAdjustArrayFunction(BEArrayFunKind arrayFunKind,int functionIndex,int moduleIndex); +BENoRules :: !BackEnd -> (!BEImpRuleP,!BackEnd); +// BEImpRuleP BENoRules(); +BERules :: !BEImpRuleP !BEImpRuleP !BackEnd -> (!BEImpRuleP,!BackEnd); +// BEImpRuleP BERules(BEImpRuleP rule,BEImpRuleP rules); +BETypes :: !BETypeP !BETypeP !BackEnd -> (!BETypeP,!BackEnd); +// BETypeP BETypes(BETypeP type,BETypeP types); +BENoTypes :: !BackEnd -> (!BETypeP,!BackEnd); +// BETypeP BENoTypes(); +BEFlatType :: !BESymbolP !BETypeVarListP !BackEnd -> (!BEFlatTypeP,!BackEnd); +// BEFlatTypeP BEFlatType(BESymbolP symbol,BETypeVarListP arguments); +BEAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd; +// void BEAlgebraicType(BEFlatTypeP lhs,BEConstructorListP constructors); +BERecordType :: !Int !BEFlatTypeP !BETypeNodeP !BEFieldListP !BackEnd -> BackEnd; +// void BERecordType(int moduleIndex,BEFlatTypeP lhs,BETypeNodeP constructorType,BEFieldListP fields); +BEAbsType :: !BEFlatTypeP !BackEnd -> BackEnd; +// void BEAbsType(BEFlatTypeP lhs); +BEConstructors :: !BEConstructorListP !BEConstructorListP !BackEnd -> (!BEConstructorListP,!BackEnd); +// BEConstructorListP BEConstructors(BEConstructorListP constructor,BEConstructorListP constructors); +BENoConstructors :: !BackEnd -> (!BEConstructorListP,!BackEnd); +// BEConstructorListP BENoConstructors(); +BEConstructor :: !BETypeNodeP !BackEnd -> (!BEConstructorListP,!BackEnd); +// BEConstructorListP BEConstructor(BETypeNodeP type); +BEDeclareField :: !Int !Int !String !BackEnd -> BackEnd; +// void BEDeclareField(int fieldIndex,int moduleIndex,CleanString name); +BEField :: !Int !Int !BETypeNodeP !BackEnd -> (!BEFieldListP,!BackEnd); +// BEFieldListP BEField(int fieldIndex,int moduleIndex,BETypeNodeP type); +BEFields :: !BEFieldListP !BEFieldListP !BackEnd -> (!BEFieldListP,!BackEnd); +// BEFieldListP BEFields(BEFieldListP field,BEFieldListP fields); +BENoFields :: !BackEnd -> (!BEFieldListP,!BackEnd); +// BEFieldListP BENoFields(); +BEDeclareConstructor :: !Int !Int !String !BackEnd -> BackEnd; +// void BEDeclareConstructor(int constructorIndex,int moduleIndex,CleanString name); +BETypeVar :: !String !BackEnd -> (!BETypeVarP,!BackEnd); +// BETypeVarP BETypeVar(CleanString name); +BEDeclareType :: !Int !Int !String !BackEnd -> BackEnd; +// void BEDeclareType(int typeIndex,int moduleIndex,CleanString name); +BEDeclareFunction :: !String !Int !Int !Int !BackEnd -> BackEnd; +// void BEDeclareFunction(CleanString name,int arity,int functionIndex,int ancestor); +BECodeAlt :: !Int !BENodeDefP !BENodeP !BECodeBlockP !BackEnd -> (!BERuleAltP,!BackEnd); +// BERuleAltP BECodeAlt(int line,BENodeDefP lhsDefs,BENodeP lhs,BECodeBlockP codeBlock); +BEString :: !String !BackEnd -> (!BEStringListP,!BackEnd); +// BEStringListP BEString(CleanString cleanString); +BEStrings :: !BEStringListP !BEStringListP !BackEnd -> (!BEStringListP,!BackEnd); +// BEStringListP BEStrings(BEStringListP string,BEStringListP strings); +BENoStrings :: !BackEnd -> (!BEStringListP,!BackEnd); +// BEStringListP BENoStrings(); +BECodeParameter :: !String !BENodeIdP !BackEnd -> (!BECodeParameterP,!BackEnd); +// BECodeParameterP BECodeParameter(CleanString location,BENodeIdP nodeId); +BECodeParameters :: !BECodeParameterP !BECodeParameterP !BackEnd -> (!BECodeParameterP,!BackEnd); +// BECodeParameterP BECodeParameters(BECodeParameterP parameter,BECodeParameterP parameters); +BENoCodeParameters :: !BackEnd -> (!BECodeParameterP,!BackEnd); +// BECodeParameterP BENoCodeParameters(); +BEAbcCodeBlock :: !Bool !BEStringListP !BackEnd -> (!BECodeBlockP,!BackEnd); +// BECodeBlockP BEAbcCodeBlock(int inline,BEStringListP instructions); +BEAnyCodeBlock :: !BECodeParameterP !BECodeParameterP !BEStringListP !BackEnd -> (!BECodeBlockP,!BackEnd); +// BECodeBlockP BEAnyCodeBlock(BECodeParameterP inParams,BECodeParameterP outParams,BEStringListP instructions); +BEDeclareIclModule :: !String !Int !Int !Int !Int !BackEnd -> BackEnd; +// void BEDeclareIclModule(CleanString name,int nFunctions,int nTypes,int nConstructors,int nFields); +BEDeclareDclModule :: !Int !String !Bool !Int !Int !Int !Int !BackEnd -> BackEnd; +// void BEDeclareDclModule(int moduleIndex,CleanString name,int systemModule,int nFunctions,int nTypes,int nConstructors,int nFields); +BEDeclarePredefinedModule :: !Int !Int !BackEnd -> BackEnd; +// void BEDeclarePredefinedModule(int nTypes,int nConstructors); +BEDefineRules :: !BEImpRuleP !BackEnd -> BackEnd; +// void BEDefineRules(BEImpRuleP rules); +BEGenerateCode :: !String !BackEnd -> (!Bool,!BackEnd); +// int BEGenerateCode(CleanString outputFile); +BEExportType :: !Int !Int !BackEnd -> BackEnd; +// void BEExportType(int dclTypeIndex,int iclTypeIndex); +BESwapTypes :: !Int !Int !BackEnd -> BackEnd; +// void BESwapTypes(int frm,int to); +BEExportConstructor :: !Int !Int !BackEnd -> BackEnd; +// void BEExportConstructor(int dclConstructorIndex,int iclConstructorIndex); +BEExportField :: !Int !Int !BackEnd -> BackEnd; +// void BEExportField(int dclTypeIndex,int iclTypeIndex); +BEExportFunction :: !Int !Int !BackEnd -> BackEnd; +// void BEExportFunction(int dclFunctionIndex,int iclFunctionIndex); +BEDefineImportedObjsAndLibs :: !BEStringListP !BEStringListP !BackEnd -> BackEnd; +// void BEDefineImportedObjsAndLibs(BEStringListP objs,BEStringListP libs); +kBEVersionCurrent:==0x02000203; +kBEVersionOldestDefinition:==0x02000203; +kBEVersionOldestImplementation:==0x02000203; +kBEDebug:==1; +kIclModuleIndex:==0; +kPredefinedModuleIndex:==1; +BENoAnnot:==0; +BEStrictAnnot:==1; +BENoUniAttr:==0; +BENotUniqueAttr:==1; +BEUniqueAttr:==2; +BEExistsAttr:==3; +BEUniqueVariable:==4; +BEFirstUniVarNumber:==5; +BEIntType:==0; +BEBoolType:==1; +BECharType:==2; +BERealType:==3; +BEFileType:==4; +BEStringType:==5; +BEWorldType:==6; +BEProcIdType:==7; +BERedIdType:==8; +BENrOfBasicTypes:==9; +BEIntDenot:==10; +BEBoolDenot:==11; +BECharDenot:==12; +BERealDenot:==13; +BENrOfBasicDenots:==14; +BEStringDenot:==15; +BEFunType:==16; +BEArrayType:==17; +BEStrictArrayType:==18; +BEUnboxedArrayType:==19; +BEListType:==20; +BETupleType:==21; +BEEmptyType:==22; +BEDynamicType:==23; +BENrOfPredefTypes:==24; +BETupleSymb:==25; +BEConsSymb:==26; +BENilSymb:==27; +BEApplySymb:==28; +BEIfSymb:==29; +BEFailSymb:==30; +BEAllSymb:==31; +BESelectSymb:==32; +BENrOfPredefFunsOrConses:==33; +BEDefinition:==34; +BENewSymbol:==35; +BEInstanceSymb:==36; +BEEmptySymbol:==37; +BEFieldSymbolList:==38; +BEErroneousSymb:==39; +BECreateArrayFun:==0; +BEArraySelectFun:==1; +BEUnqArraySelectFun:==2; +BEArrayUpdateFun:==3; +BEArrayReplaceFun:==4; +BEArraySizeFun:==5; +BEUnqArraySizeFun:==6; +BE_CreateArrayFun:==7; +BE_UnqArraySelectFun:==8; +BE_UnqArraySelectNextFun:==9; +BE_UnqArraySelectLastFun:==10; +BE_ArrayUpdateFun:==11; +BENoArrayFun:==12; +BESelectorDummy:==0; +BESelector:==1; +BESelector_U:==2; +BESelector_F:==3; +BESelector_L:==4; +BESelector_N:==5; +BEUpdateDummy:==0; +BEUpdate:==1; +BEUpdate_U:==2; +BELhsNodeId:==0; +BERhsNodeId:==1; +BEIsNotACaf:==0; +BEIsACaf:==1; diff --git a/backendC/CleanCompilerSources/backend.h b/backendC/CleanCompilerSources/backend.h new file mode 100644 index 0000000..8445908 --- /dev/null +++ b/backendC/CleanCompilerSources/backend.h @@ -0,0 +1,424 @@ +/* version info */ + +# define kBEVersionCurrent 0x02000203 +# define kBEVersionOldestDefinition 0x02000203 +# define kBEVersionOldestImplementation 0x02000203 + +# define kBEDebug 1 + +/* pointer types */ + +Clean (:: *UWorld :== Int) + +typedef struct BackEnd *BackEnd; +Clean (:: *BackEnd :== Int) + +typedef struct symbol *BESymbolP; +Clean (:: BESymbolP :== Int) + +typedef struct type_node *BETypeNodeP; +Clean (:: BETypeNodeP :== Int) + +typedef struct type_arg *BETypeArgP; +Clean (:: BETypeArgP :== Int) + +typedef struct type_alt *BETypeAltP; +Clean (:: BETypeAltP :== Int) + +typedef struct node *BENodeP; +Clean (:: BENodeP :== Int) + +typedef struct arg *BEArgP; +Clean (:: BEArgP :== Int) + +typedef struct rule_alt *BERuleAltP; +Clean (:: BERuleAltP :== Int) + +typedef struct imp_rule *BEImpRuleP; +Clean (:: BEImpRuleP :== Int) + +typedef struct type *BETypeP; +Clean (:: BETypeP :== Int) + +typedef struct flat_type *BEFlatTypeP; +Clean (:: BEFlatTypeP :== Int) + +typedef struct type_var *BETypeVarP; +Clean (:: BETypeVarP :== Int) + +typedef struct type_var_list *BETypeVarListP; +Clean (:: BETypeVarListP :== Int) + +typedef struct constructor_list *BEConstructorListP; +Clean (:: BEConstructorListP :== Int) + +typedef struct field_list *BEFieldListP; +Clean (:: BEFieldListP :== Int) + +typedef struct node_id *BENodeIdP; +Clean (:: BENodeIdP :== Int) + +typedef struct node_def *BENodeDefP; +Clean (:: BENodeDefP :== Int) + +typedef struct strict_node_id *BEStrictNodeIdP; +Clean (:: BEStrictNodeIdP :== Int) + +typedef struct parameter *BECodeParameterP; +Clean (:: BECodeParameterP :== Int) + +typedef struct code_block *BECodeBlockP; +Clean (:: BECodeBlockP :== Int) + +typedef struct string_list *BEStringListP; +Clean (:: BEStringListP :== Int) + +/* constants */ +# define kIclModuleIndex 0 +# define kPredefinedModuleIndex 1 + +/* enum types */ +typedef int BEAnnotation; +Clean (:: BEAnnotation :== Int) +enum { + BENoAnnot, BEStrictAnnot +}; + +typedef int BEAttribution; +Clean (:: BEAttribution :== Int) +enum { + BENoUniAttr, BENotUniqueAttr, BEUniqueAttr, BEExistsAttr, BEUniqueVariable, BEFirstUniVarNumber +}; + +typedef int BESymbKind; +Clean (:: BESymbKind :== Int) +enum { + BEIntType, BEBoolType, BECharType, BERealType, + BEFileType, BEStringType, BEWorldType, BEProcIdType, + BERedIdType, + BENrOfBasicTypes, + + BEIntDenot, BEBoolDenot, BECharDenot, BERealDenot, + BENrOfBasicDenots, + + BEStringDenot, + BEFunType, BEArrayType, BEStrictArrayType, BEUnboxedArrayType, BEListType, BETupleType, BEEmptyType, + BEDynamicType, + BENrOfPredefTypes, + + BETupleSymb, BEConsSymb, BENilSymb, + BEApplySymb, BEIfSymb, BEFailSymb, BEAllSymb, + BESelectSymb, + BENrOfPredefFunsOrConses, + + BEDefinition, BENewSymbol, BEInstanceSymb, BEEmptySymbol, BEFieldSymbolList, + BEErroneousSymb +}; + +typedef int BEArrayFunKind; +Clean (::BEArrayFunKind :== Int) +enum { + BECreateArrayFun, BEArraySelectFun, BEUnqArraySelectFun, BEArrayUpdateFun, + BEArrayReplaceFun, BEArraySizeFun, BEUnqArraySizeFun, + BE_CreateArrayFun,BE_UnqArraySelectFun,BE_UnqArraySelectNextFun,BE_UnqArraySelectLastFun, + BE_ArrayUpdateFun, + BENoArrayFun +}; + +typedef int BESelectorKind; +Clean (::BESelectorKind :== Int) +enum { + BESelectorDummy, BESelector, BESelector_U, BESelector_F, BESelector_L, BESelector_N +}; + +typedef int BEUpdateKind; +Clean (::BEUpdateKind :== Int) +enum { + BEUpdateDummy, BEUpdate, BEUpdate_U +}; + + +/* functions */ + +void BEGetVersion (int *current, int *oldestDefinition, int *oldestImplementation); +Clean (BEGetVersion :: (Int, Int, Int)) + +BackEnd BEInit (int argc); +Clean (BEInit :: Int UWorld -> (BackEnd, UWorld)) + +void BEFree (BackEnd backEnd); +Clean (BEFree :: BackEnd UWorld -> UWorld) + +void BEArg (CleanString arg); +Clean (BEArg :: String BackEnd -> BackEnd) + +void BEDeclareModules (int nModules); +Clean (BEDeclareModules :: Int BackEnd -> BackEnd) + +void BEDeclarePredefinedSymbols (int nConstructors, int nTypes); +Clean (BEDeclarePredefinedSymbols :: Int Int BackEnd -> BackEnd) + +BESymbolP BESpecialArrayFunctionSymbol (BEArrayFunKind arrayFunKind, int functionIndex, int moduleIndex); +Clean (BESpecialArrayFunctionSymbol :: BEArrayFunKind Int Int BackEnd -> (BESymbolP, BackEnd)) + +BESymbolP BEDictionarySelectFunSymbol (void); +Clean (BEDictionarySelectFunSymbol :: BackEnd -> (BESymbolP, BackEnd)) + +BESymbolP BEDictionaryUpdateFunSymbol (void); +Clean (BEDictionaryUpdateFunSymbol :: BackEnd -> (BESymbolP, BackEnd)) + +BESymbolP BEFunctionSymbol (int functionIndex, int moduleIndex); +Clean (BEFunctionSymbol :: Int Int BackEnd -> (BESymbolP, BackEnd)) + +BESymbolP BEConstructorSymbol (int constructorIndex, int moduleIndex); +Clean (BEConstructorSymbol :: Int Int BackEnd -> (BESymbolP, BackEnd)) + +BESymbolP BEFieldSymbol (int fieldIndex, int moduleIndex); +Clean (BEFieldSymbol :: Int Int BackEnd -> (BESymbolP, BackEnd)) + +BESymbolP BETypeSymbol (int typeIndex, int moduleIndex); +Clean (BETypeSymbol :: Int Int BackEnd -> (BESymbolP, BackEnd)) + +BESymbolP BEDontCareDefinitionSymbol (void); +Clean (BEDontCareDefinitionSymbol :: BackEnd -> (BESymbolP, BackEnd)) + +BESymbolP BEBoolSymbol (int value); +Clean (BEBoolSymbol :: Bool BackEnd -> (BESymbolP, BackEnd)) + +BESymbolP BELiteralSymbol (BESymbKind kind, CleanString value); +Clean (BELiteralSymbol :: BESymbKind String BackEnd -> (BESymbolP, BackEnd)) + +void BEPredefineConstructorSymbol (int arity, int constructorIndex, int moduleIndex, BESymbKind symbolKind); +Clean (BEPredefineConstructorSymbol :: Int Int Int BESymbKind BackEnd -> BackEnd) + +void BEPredefineTypeSymbol (int arity, int typeIndex, int moduleIndex, BESymbKind symbolKind); +Clean (BEPredefineTypeSymbol :: Int Int Int BESymbKind BackEnd -> BackEnd) + +BESymbolP BEBasicSymbol (BESymbKind kind); +Clean (BEBasicSymbol :: Int BackEnd -> (BESymbolP, BackEnd)) + +BETypeNodeP BEVarTypeNode (CleanString name); +Clean (BEVarTypeNode :: String BackEnd -> (BETypeNodeP, BackEnd)) + +BETypeVarListP BETypeVars (BETypeVarP typeVar, BETypeVarListP typeVarList); +Clean (BETypeVars :: BETypeVarP BETypeVarListP BackEnd -> (BETypeVarListP, BackEnd)) + +BETypeVarListP BENoTypeVars (void); +Clean (BENoTypeVars :: BackEnd -> (BETypeVarListP, BackEnd)) + +BETypeNodeP BENormalTypeNode (BESymbolP symbol, BETypeArgP args); +Clean (BENormalTypeNode :: BESymbolP BETypeArgP BackEnd -> (BETypeNodeP, BackEnd)) + +BETypeNodeP BEAnnotateTypeNode (BEAnnotation annotation, BETypeNodeP typeNode); +Clean (BEAnnotateTypeNode :: BEAnnotation BETypeNodeP BackEnd -> (BETypeNodeP, BackEnd)) + +BETypeNodeP BEAttributeTypeNode (BEAttribution attribution, BETypeNodeP typeNode); +Clean (BEAttributeTypeNode :: BEAttribution BETypeNodeP BackEnd -> (BETypeNodeP, BackEnd)) + +BETypeArgP BENoTypeArgs (void); +Clean (BENoTypeArgs :: BackEnd -> (BETypeArgP, BackEnd)) + +BETypeArgP BETypeArgs (BETypeNodeP node, BETypeArgP nextArgs); +Clean (BETypeArgs :: BETypeNodeP BETypeArgP BackEnd -> (BETypeArgP, BackEnd)) + +BETypeAltP BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs); +Clean (BETypeAlt :: BETypeNodeP BETypeNodeP BackEnd -> (BETypeAltP, BackEnd)) + +BENodeP BENormalNode (BESymbolP symbol, BEArgP args); +Clean (BENormalNode :: BESymbolP BEArgP BackEnd -> (BENodeP, BackEnd)) + +BENodeP BEMatchNode (int arity, BESymbolP symbol, BENodeP node); +Clean (BEMatchNode :: Int BESymbolP BENodeP BackEnd -> (BENodeP, BackEnd)) + +BENodeP BETupleSelectNode (int arity, int index, BENodeP node); +Clean (BETupleSelectNode :: Int Int BENodeP BackEnd -> (BENodeP, BackEnd)) + +BENodeP BEIfNode (BENodeP cond, BENodeP then, BENodeP elsje); +Clean (BEIfNode :: BENodeP BENodeP BENodeP BackEnd -> (BENodeP, BackEnd)) + +BENodeP BEGuardNode (BENodeP cond, BENodeDefP thenNodeDefs, BEStrictNodeIdP thenStricts, BENodeP then, BENodeDefP elseNodeDefs, BEStrictNodeIdP elseStricts, BENodeP elsje); +Clean (BEGuardNode :: BENodeP BENodeDefP BEStrictNodeIdP BENodeP BENodeDefP BEStrictNodeIdP BENodeP BackEnd -> (BENodeP, BackEnd)) + +BENodeP BESelectorNode (BESelectorKind selectorKind, BESymbolP fieldSymbol, BEArgP args); +Clean (BESelectorNode :: BESelectorKind BESymbolP BEArgP BackEnd -> (BENodeP, BackEnd)) + +BENodeP BEUpdateNode (BEArgP args); +Clean (BEUpdateNode :: BEArgP BackEnd -> (BENodeP, BackEnd)) + +BENodeP BENodeIdNode (BENodeIdP nodeId, BEArgP args); +Clean (BENodeIdNode :: BENodeIdP BEArgP BackEnd -> (BENodeP, BackEnd)) + +BEArgP BENoArgs (void); +Clean (BENoArgs :: BackEnd -> (BEArgP, BackEnd)) + +BEArgP BEArgs (BENodeP node, BEArgP nextArgs); +Clean (BEArgs :: BENodeP BEArgP BackEnd -> (BEArgP, BackEnd)) + +BERuleAltP BERuleAlt (int line, BENodeDefP lhsDefs, BENodeP lhs, BENodeDefP rhsDefs, BEStrictNodeIdP lhsStrictNodeIds, BENodeP rhs); +Clean (BERuleAlt :: Int BENodeDefP BENodeP BENodeDefP BEStrictNodeIdP BENodeP BackEnd -> (BERuleAltP, BackEnd)) + +BERuleAltP BERuleAlts (BERuleAltP alt, BERuleAltP alts); +Clean (BERuleAlts :: BERuleAltP BERuleAltP BackEnd -> (BERuleAltP, BackEnd)) + +BERuleAltP BENoRuleAlts (void); +Clean (BENoRuleAlts :: BackEnd -> (BERuleAltP, BackEnd)) + +# define BELhsNodeId 0 +# define BERhsNodeId 1 +void BEDeclareNodeId (int sequenceNumber, int lhsOrRhs, CleanString name); +Clean (BEDeclareNodeId :: Int Int String BackEnd -> BackEnd) + +BENodeIdP BENodeId (int sequenceNumber); +Clean (BENodeId :: Int BackEnd -> (BENodeIdP, BackEnd)) + +BENodeIdP BEWildCardNodeId (void); +Clean (BEWildCardNodeId :: BackEnd -> (BENodeIdP, BackEnd)) + +BENodeDefP BENodeDef (int sequenceNumber, BENodeP node); +Clean (BENodeDef :: Int BENodeP BackEnd -> (BENodeDefP, BackEnd)) + +BENodeDefP BENoNodeDefs (void); +Clean (BENoNodeDefs :: BackEnd -> (BENodeDefP, BackEnd)) + +BENodeDefP BENodeDefs (BENodeDefP nodeDef, BENodeDefP nodeDefs); +Clean (BENodeDefs :: BENodeDefP BENodeDefP BackEnd -> (BENodeDefP, BackEnd)) + +BEStrictNodeIdP BEStrictNodeId (BENodeIdP nodeId); +Clean (BEStrictNodeId :: BENodeIdP BackEnd -> (BEStrictNodeIdP, BackEnd)) + +BEStrictNodeIdP BENoStrictNodeIds (void); +Clean (BENoStrictNodeIds :: BackEnd -> (BEStrictNodeIdP, BackEnd)) + +BEStrictNodeIdP BEStrictNodeIds (BEStrictNodeIdP strictNodeId, BEStrictNodeIdP strictNodeIds); +Clean (BEStrictNodeIds :: BEStrictNodeIdP BEStrictNodeIdP BackEnd -> (BEStrictNodeIdP, BackEnd)) + +# define BEIsNotACaf 0 +# define BEIsACaf 1 +BEImpRuleP BERule (int functionIndex, int isCaf, BETypeAltP type, BERuleAltP alts); +Clean (BERule :: Int Int BETypeAltP BERuleAltP BackEnd -> (BEImpRuleP, BackEnd)) + +void BEDeclareRuleType (int functionIndex, int moduleIndex, CleanString name); +Clean (BEDeclareRuleType :: Int Int String BackEnd -> BackEnd) + +void BEDefineRuleType (int functionIndex, int moduleIndex, BETypeAltP typeAlt); +Clean (BEDefineRuleType :: Int Int BETypeAltP BackEnd -> BackEnd) + +void BEAdjustArrayFunction (BEArrayFunKind arrayFunKind, int functionIndex, int moduleIndex); +Clean (BEAdjustArrayFunction :: BEArrayFunKind Int Int BackEnd -> BackEnd) + +BEImpRuleP BENoRules (void); +Clean (BENoRules :: BackEnd -> (BEImpRuleP, BackEnd)) + +BEImpRuleP BERules (BEImpRuleP rule, BEImpRuleP rules); +Clean (BERules :: BEImpRuleP BEImpRuleP BackEnd -> (BEImpRuleP, BackEnd)) + +BETypeP BETypes (BETypeP type, BETypeP types); +Clean (BETypes :: BETypeP BETypeP BackEnd -> (BETypeP, BackEnd)) + +BETypeP BENoTypes (void); +Clean (BENoTypes :: BackEnd -> (BETypeP, BackEnd)) + +BEFlatTypeP BEFlatType (BESymbolP symbol, BETypeVarListP arguments); +Clean (BEFlatType :: BESymbolP BETypeVarListP BackEnd -> (BEFlatTypeP, BackEnd)) + +void BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors); +Clean (BEAlgebraicType:: BEFlatTypeP BEConstructorListP BackEnd -> BackEnd) + +void BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, BEFieldListP fields); +Clean (BERecordType :: Int BEFlatTypeP BETypeNodeP BEFieldListP BackEnd -> BackEnd) + +void BEAbsType (BEFlatTypeP lhs); +Clean (BEAbsType :: BEFlatTypeP BackEnd -> BackEnd) + +BEConstructorListP BEConstructors (BEConstructorListP constructor, BEConstructorListP constructors); +Clean (BEConstructors:: BEConstructorListP BEConstructorListP BackEnd -> (BEConstructorListP, BackEnd)) + +BEConstructorListP BENoConstructors (void); +Clean (BENoConstructors:: BackEnd -> (BEConstructorListP, BackEnd)) + +BEConstructorListP BEConstructor (BETypeNodeP type); +Clean (BEConstructor:: BETypeNodeP BackEnd -> (BEConstructorListP, BackEnd)) + +void BEDeclareField (int fieldIndex, int moduleIndex, CleanString name); +Clean (BEDeclareField :: Int Int String BackEnd -> BackEnd) + +BEFieldListP BEField (int fieldIndex, int moduleIndex, BETypeNodeP type); +Clean (BEField :: Int Int BETypeNodeP BackEnd -> (BEFieldListP, BackEnd)) + +BEFieldListP BEFields (BEFieldListP field, BEFieldListP fields); +Clean (BEFields:: BEFieldListP BEFieldListP BackEnd -> (BEFieldListP, BackEnd)) + +BEFieldListP BENoFields (void); +Clean (BENoFields:: BackEnd -> (BEFieldListP, BackEnd)) + +void BEDeclareConstructor (int constructorIndex, int moduleIndex, CleanString name); +Clean (BEDeclareConstructor:: Int Int String BackEnd -> BackEnd) + +BETypeVarP BETypeVar (CleanString name); +Clean (BETypeVar:: String BackEnd -> (BETypeVarP, BackEnd)) + +void BEDeclareType (int typeIndex, int moduleIndex, CleanString name); +Clean (BEDeclareType:: Int Int String BackEnd -> BackEnd) + +void BEDeclareFunction (CleanString name, int arity, int functionIndex, int ancestor); +Clean (BEDeclareFunction :: String Int Int Int BackEnd -> BackEnd) + +BERuleAltP BECodeAlt (int line, BENodeDefP lhsDefs, BENodeP lhs, BECodeBlockP codeBlock); +Clean (BECodeAlt:: Int BENodeDefP BENodeP BECodeBlockP BackEnd -> (BERuleAltP, BackEnd)) + +BEStringListP BEString (CleanString cleanString); +Clean (BEString:: String BackEnd -> (BEStringListP, BackEnd)) + +BEStringListP BEStrings (BEStringListP string, BEStringListP strings); +Clean (BEStrings:: BEStringListP BEStringListP BackEnd -> (BEStringListP, BackEnd)) + +BEStringListP BENoStrings (void); +Clean (BENoStrings:: BackEnd -> (BEStringListP, BackEnd)) + +BECodeParameterP BECodeParameter (CleanString location, BENodeIdP nodeId); +Clean (BECodeParameter:: String BENodeIdP BackEnd -> (BECodeParameterP, BackEnd)) + +BECodeParameterP BECodeParameters (BECodeParameterP parameter, BECodeParameterP parameters); +Clean (BECodeParameters:: BECodeParameterP BECodeParameterP BackEnd -> (BECodeParameterP, BackEnd)) + +BECodeParameterP BENoCodeParameters (void); +Clean (BENoCodeParameters:: BackEnd -> (BECodeParameterP, BackEnd)) + +BECodeBlockP BEAbcCodeBlock (int inline, BEStringListP instructions); +Clean (BEAbcCodeBlock:: Bool BEStringListP BackEnd -> (BECodeBlockP, BackEnd)) + +BECodeBlockP BEAnyCodeBlock (BECodeParameterP inParams, BECodeParameterP outParams, BEStringListP instructions); +Clean (BEAnyCodeBlock:: BECodeParameterP BECodeParameterP BEStringListP BackEnd -> (BECodeBlockP, BackEnd)) + +void BEDeclareIclModule (CleanString name, int nFunctions, int nTypes, int nConstructors, int nFields); +Clean (BEDeclareIclModule :: String Int Int Int Int BackEnd -> BackEnd) + +void BEDeclareDclModule (int moduleIndex, CleanString name, int systemModule, int nFunctions, int nTypes, int nConstructors, int nFields); +Clean (BEDeclareDclModule :: Int String Bool Int Int Int Int BackEnd -> BackEnd) + +void BEDeclarePredefinedModule (int nTypes, int nConstructors); +Clean (BEDeclarePredefinedModule :: Int Int BackEnd -> BackEnd) + +void BEDefineRules (BEImpRuleP rules); +Clean (BEDefineRules :: BEImpRuleP BackEnd -> BackEnd) + +int BEGenerateCode (CleanString outputFile); +Clean (BEGenerateCode :: String BackEnd -> (Bool, BackEnd)) + +void BEExportType (int dclTypeIndex, int iclTypeIndex); +Clean (BEExportType :: Int Int BackEnd -> BackEnd) + +void BESwapTypes (int frm, int to); +Clean (BESwapTypes :: Int Int BackEnd -> BackEnd) + +void BEExportConstructor (int dclConstructorIndex, int iclConstructorIndex); +Clean (BEExportConstructor :: Int Int BackEnd -> BackEnd) + +void BEExportField (int dclTypeIndex, int iclTypeIndex); +Clean (BEExportField :: Int Int BackEnd -> BackEnd) + +void BEExportFunction (int dclFunctionIndex, int iclFunctionIndex); +Clean (BEExportFunction :: Int Int BackEnd -> BackEnd) + +void BEDefineImportedObjsAndLibs (BEStringListP objs, BEStringListP libs); +Clean (BEDefineImportedObjsAndLibs :: BEStringListP BEStringListP BackEnd -> BackEnd) diff --git a/backendC/CleanCompilerSources/backend.icl b/backendC/CleanCompilerSources/backend.icl new file mode 100644 index 0000000..4771e55 --- /dev/null +++ b/backendC/CleanCompilerSources/backend.icl @@ -0,0 +1,670 @@ +implementation module backend; + +from StdString import String; + +:: *UWorld :== Int; +:: *BackEnd :== Int; +:: BESymbolP :== Int; +:: BETypeNodeP :== Int; +:: BETypeArgP :== Int; +:: BETypeAltP :== Int; +:: BENodeP :== Int; +:: BEArgP :== Int; +:: BERuleAltP :== Int; +:: BEImpRuleP :== Int; +:: BETypeP :== Int; +:: BEFlatTypeP :== Int; +:: BETypeVarP :== Int; +:: BETypeVarListP :== Int; +:: BEConstructorListP :== Int; +:: BEFieldListP :== Int; +:: BENodeIdP :== Int; +:: BENodeDefP :== Int; +:: BEStrictNodeIdP :== Int; +:: BECodeParameterP :== Int; +:: BECodeBlockP :== Int; +:: BEStringListP :== Int; +:: BEAnnotation :== Int; +:: BEAttribution :== Int; +:: BESymbKind :== Int; +:: BEArrayFunKind :== Int; +:: BESelectorKind :== Int; +:: BEUpdateKind :== Int; + +BEGetVersion :: (!Int,!Int,!Int); +BEGetVersion = code { + ccall BEGetVersion ":VIII" +} +// void BEGetVersion(int* current,int* oldestDefinition,int* oldestImplementation); + +BEInit :: !Int !UWorld -> (!BackEnd,!UWorld); +BEInit a0 a1 = code { + ccall BEInit "I:I:I" +} +// BackEnd BEInit(int argc); + +BEFree :: !BackEnd !UWorld -> UWorld; +BEFree a0 a1 = code { + ccall BEFree "I:V:I" +} +// void BEFree(BackEnd backEnd); + +BEArg :: !String !BackEnd -> BackEnd; +BEArg a0 a1 = code { + ccall BEArg "S:V:I" +} +// void BEArg(CleanString arg); + +BEDeclareModules :: !Int !BackEnd -> BackEnd; +BEDeclareModules a0 a1 = code { + ccall BEDeclareModules "I:V:I" +} +// void BEDeclareModules(int nModules); + +BEDeclarePredefinedSymbols :: !Int !Int !BackEnd -> BackEnd; +BEDeclarePredefinedSymbols a0 a1 a2 = code { + ccall BEDeclarePredefinedSymbols "II:V:I" +} +// void BEDeclarePredefinedSymbols(int nConstructors,int nTypes); + +BESpecialArrayFunctionSymbol :: !BEArrayFunKind !Int !Int !BackEnd -> (!BESymbolP,!BackEnd); +BESpecialArrayFunctionSymbol a0 a1 a2 a3 = code { + ccall BESpecialArrayFunctionSymbol "III:I:I" +} +// BESymbolP BESpecialArrayFunctionSymbol(BEArrayFunKind arrayFunKind,int functionIndex,int moduleIndex); + +BEDictionarySelectFunSymbol :: !BackEnd -> (!BESymbolP,!BackEnd); +BEDictionarySelectFunSymbol a0 = code { + ccall BEDictionarySelectFunSymbol ":I:I" +} +// BESymbolP BEDictionarySelectFunSymbol(); + +BEDictionaryUpdateFunSymbol :: !BackEnd -> (!BESymbolP,!BackEnd); +BEDictionaryUpdateFunSymbol a0 = code { + ccall BEDictionaryUpdateFunSymbol ":I:I" +} +// BESymbolP BEDictionaryUpdateFunSymbol(); + +BEFunctionSymbol :: !Int !Int !BackEnd -> (!BESymbolP,!BackEnd); +BEFunctionSymbol a0 a1 a2 = code { + ccall BEFunctionSymbol "II:I:I" +} +// BESymbolP BEFunctionSymbol(int functionIndex,int moduleIndex); + +BEConstructorSymbol :: !Int !Int !BackEnd -> (!BESymbolP,!BackEnd); +BEConstructorSymbol a0 a1 a2 = code { + ccall BEConstructorSymbol "II:I:I" +} +// BESymbolP BEConstructorSymbol(int constructorIndex,int moduleIndex); + +BEFieldSymbol :: !Int !Int !BackEnd -> (!BESymbolP,!BackEnd); +BEFieldSymbol a0 a1 a2 = code { + ccall BEFieldSymbol "II:I:I" +} +// BESymbolP BEFieldSymbol(int fieldIndex,int moduleIndex); + +BETypeSymbol :: !Int !Int !BackEnd -> (!BESymbolP,!BackEnd); +BETypeSymbol a0 a1 a2 = code { + ccall BETypeSymbol "II:I:I" +} +// BESymbolP BETypeSymbol(int typeIndex,int moduleIndex); + +BEDontCareDefinitionSymbol :: !BackEnd -> (!BESymbolP,!BackEnd); +BEDontCareDefinitionSymbol a0 = code { + ccall BEDontCareDefinitionSymbol ":I:I" +} +// BESymbolP BEDontCareDefinitionSymbol(); + +BEBoolSymbol :: !Bool !BackEnd -> (!BESymbolP,!BackEnd); +BEBoolSymbol a0 a1 = code { + ccall BEBoolSymbol "I:I:I" +} +// BESymbolP BEBoolSymbol(int value); + +BELiteralSymbol :: !BESymbKind !String !BackEnd -> (!BESymbolP,!BackEnd); +BELiteralSymbol a0 a1 a2 = code { + ccall BELiteralSymbol "IS:I:I" +} +// BESymbolP BELiteralSymbol(BESymbKind kind,CleanString value); + +BEPredefineConstructorSymbol :: !Int !Int !Int !BESymbKind !BackEnd -> BackEnd; +BEPredefineConstructorSymbol a0 a1 a2 a3 a4 = code { + ccall BEPredefineConstructorSymbol "IIII:V:I" +} +// void BEPredefineConstructorSymbol(int arity,int constructorIndex,int moduleIndex,BESymbKind symbolKind); + +BEPredefineTypeSymbol :: !Int !Int !Int !BESymbKind !BackEnd -> BackEnd; +BEPredefineTypeSymbol a0 a1 a2 a3 a4 = code { + ccall BEPredefineTypeSymbol "IIII:V:I" +} +// void BEPredefineTypeSymbol(int arity,int typeIndex,int moduleIndex,BESymbKind symbolKind); + +BEBasicSymbol :: !Int !BackEnd -> (!BESymbolP,!BackEnd); +BEBasicSymbol a0 a1 = code { + ccall BEBasicSymbol "I:I:I" +} +// BESymbolP BEBasicSymbol(BESymbKind kind); + +BEVarTypeNode :: !String !BackEnd -> (!BETypeNodeP,!BackEnd); +BEVarTypeNode a0 a1 = code { + ccall BEVarTypeNode "S:I:I" +} +// BETypeNodeP BEVarTypeNode(CleanString name); + +BETypeVars :: !BETypeVarP !BETypeVarListP !BackEnd -> (!BETypeVarListP,!BackEnd); +BETypeVars a0 a1 a2 = code { + ccall BETypeVars "II:I:I" +} +// BETypeVarListP BETypeVars(BETypeVarP typeVar,BETypeVarListP typeVarList); + +BENoTypeVars :: !BackEnd -> (!BETypeVarListP,!BackEnd); +BENoTypeVars a0 = code { + ccall BENoTypeVars ":I:I" +} +// BETypeVarListP BENoTypeVars(); + +BENormalTypeNode :: !BESymbolP !BETypeArgP !BackEnd -> (!BETypeNodeP,!BackEnd); +BENormalTypeNode a0 a1 a2 = code { + ccall BENormalTypeNode "II:I:I" +} +// BETypeNodeP BENormalTypeNode(BESymbolP symbol,BETypeArgP args); + +BEAnnotateTypeNode :: !BEAnnotation !BETypeNodeP !BackEnd -> (!BETypeNodeP,!BackEnd); +BEAnnotateTypeNode a0 a1 a2 = code { + ccall BEAnnotateTypeNode "II:I:I" +} +// BETypeNodeP BEAnnotateTypeNode(BEAnnotation annotation,BETypeNodeP typeNode); + +BEAttributeTypeNode :: !BEAttribution !BETypeNodeP !BackEnd -> (!BETypeNodeP,!BackEnd); +BEAttributeTypeNode a0 a1 a2 = code { + ccall BEAttributeTypeNode "II:I:I" +} +// BETypeNodeP BEAttributeTypeNode(BEAttribution attribution,BETypeNodeP typeNode); + +BENoTypeArgs :: !BackEnd -> (!BETypeArgP,!BackEnd); +BENoTypeArgs a0 = code { + ccall BENoTypeArgs ":I:I" +} +// BETypeArgP BENoTypeArgs(); + +BETypeArgs :: !BETypeNodeP !BETypeArgP !BackEnd -> (!BETypeArgP,!BackEnd); +BETypeArgs a0 a1 a2 = code { + ccall BETypeArgs "II:I:I" +} +// BETypeArgP BETypeArgs(BETypeNodeP node,BETypeArgP nextArgs); + +BETypeAlt :: !BETypeNodeP !BETypeNodeP !BackEnd -> (!BETypeAltP,!BackEnd); +BETypeAlt a0 a1 a2 = code { + ccall BETypeAlt "II:I:I" +} +// BETypeAltP BETypeAlt(BETypeNodeP lhs,BETypeNodeP rhs); + +BENormalNode :: !BESymbolP !BEArgP !BackEnd -> (!BENodeP,!BackEnd); +BENormalNode a0 a1 a2 = code { + ccall BENormalNode "II:I:I" +} +// BENodeP BENormalNode(BESymbolP symbol,BEArgP args); + +BEMatchNode :: !Int !BESymbolP !BENodeP !BackEnd -> (!BENodeP,!BackEnd); +BEMatchNode a0 a1 a2 a3 = code { + ccall BEMatchNode "III:I:I" +} +// BENodeP BEMatchNode(int arity,BESymbolP symbol,BENodeP node); + +BETupleSelectNode :: !Int !Int !BENodeP !BackEnd -> (!BENodeP,!BackEnd); +BETupleSelectNode a0 a1 a2 a3 = code { + ccall BETupleSelectNode "III:I:I" +} +// BENodeP BETupleSelectNode(int arity,int index,BENodeP node); + +BEIfNode :: !BENodeP !BENodeP !BENodeP !BackEnd -> (!BENodeP,!BackEnd); +BEIfNode a0 a1 a2 a3 = code { + ccall BEIfNode "III:I:I" +} +// BENodeP BEIfNode(BENodeP cond,BENodeP then,BENodeP elsje); + +BEGuardNode :: !BENodeP !BENodeDefP !BEStrictNodeIdP !BENodeP !BENodeDefP !BEStrictNodeIdP !BENodeP !BackEnd -> (!BENodeP,!BackEnd); +BEGuardNode a0 a1 a2 a3 a4 a5 a6 a7 = code { + ccall BEGuardNode "IIIIIII:I:I" +} +// BENodeP BEGuardNode(BENodeP cond,BENodeDefP thenNodeDefs,BEStrictNodeIdP thenStricts,BENodeP then,BENodeDefP elseNodeDefs,BEStrictNodeIdP elseStricts,BENodeP elsje); + +BESelectorNode :: !BESelectorKind !BESymbolP !BEArgP !BackEnd -> (!BENodeP,!BackEnd); +BESelectorNode a0 a1 a2 a3 = code { + ccall BESelectorNode "III:I:I" +} +// BENodeP BESelectorNode(BESelectorKind selectorKind,BESymbolP fieldSymbol,BEArgP args); + +BEUpdateNode :: !BEArgP !BackEnd -> (!BENodeP,!BackEnd); +BEUpdateNode a0 a1 = code { + ccall BEUpdateNode "I:I:I" +} +// BENodeP BEUpdateNode(BEArgP args); + +BENodeIdNode :: !BENodeIdP !BEArgP !BackEnd -> (!BENodeP,!BackEnd); +BENodeIdNode a0 a1 a2 = code { + ccall BENodeIdNode "II:I:I" +} +// BENodeP BENodeIdNode(BENodeIdP nodeId,BEArgP args); + +BENoArgs :: !BackEnd -> (!BEArgP,!BackEnd); +BENoArgs a0 = code { + ccall BENoArgs ":I:I" +} +// BEArgP BENoArgs(); + +BEArgs :: !BENodeP !BEArgP !BackEnd -> (!BEArgP,!BackEnd); +BEArgs a0 a1 a2 = code { + ccall BEArgs "II:I:I" +} +// BEArgP BEArgs(BENodeP node,BEArgP nextArgs); + +BERuleAlt :: !Int !BENodeDefP !BENodeP !BENodeDefP !BEStrictNodeIdP !BENodeP !BackEnd -> (!BERuleAltP,!BackEnd); +BERuleAlt a0 a1 a2 a3 a4 a5 a6 = code { + ccall BERuleAlt "IIIIII:I:I" +} +// BERuleAltP BERuleAlt(int line,BENodeDefP lhsDefs,BENodeP lhs,BENodeDefP rhsDefs,BEStrictNodeIdP lhsStrictNodeIds,BENodeP rhs); + +BERuleAlts :: !BERuleAltP !BERuleAltP !BackEnd -> (!BERuleAltP,!BackEnd); +BERuleAlts a0 a1 a2 = code { + ccall BERuleAlts "II:I:I" +} +// BERuleAltP BERuleAlts(BERuleAltP alt,BERuleAltP alts); + +BENoRuleAlts :: !BackEnd -> (!BERuleAltP,!BackEnd); +BENoRuleAlts a0 = code { + ccall BENoRuleAlts ":I:I" +} +// BERuleAltP BENoRuleAlts(); + +BEDeclareNodeId :: !Int !Int !String !BackEnd -> BackEnd; +BEDeclareNodeId a0 a1 a2 a3 = code { + ccall BEDeclareNodeId "IIS:V:I" +} +// void BEDeclareNodeId(int sequenceNumber,int lhsOrRhs,CleanString name); + +BENodeId :: !Int !BackEnd -> (!BENodeIdP,!BackEnd); +BENodeId a0 a1 = code { + ccall BENodeId "I:I:I" +} +// BENodeIdP BENodeId(int sequenceNumber); + +BEWildCardNodeId :: !BackEnd -> (!BENodeIdP,!BackEnd); +BEWildCardNodeId a0 = code { + ccall BEWildCardNodeId ":I:I" +} +// BENodeIdP BEWildCardNodeId(); + +BENodeDef :: !Int !BENodeP !BackEnd -> (!BENodeDefP,!BackEnd); +BENodeDef a0 a1 a2 = code { + ccall BENodeDef "II:I:I" +} +// BENodeDefP BENodeDef(int sequenceNumber,BENodeP node); + +BENoNodeDefs :: !BackEnd -> (!BENodeDefP,!BackEnd); +BENoNodeDefs a0 = code { + ccall BENoNodeDefs ":I:I" +} +// BENodeDefP BENoNodeDefs(); + +BENodeDefs :: !BENodeDefP !BENodeDefP !BackEnd -> (!BENodeDefP,!BackEnd); +BENodeDefs a0 a1 a2 = code { + ccall BENodeDefs "II:I:I" +} +// BENodeDefP BENodeDefs(BENodeDefP nodeDef,BENodeDefP nodeDefs); + +BEStrictNodeId :: !BENodeIdP !BackEnd -> (!BEStrictNodeIdP,!BackEnd); +BEStrictNodeId a0 a1 = code { + ccall BEStrictNodeId "I:I:I" +} +// BEStrictNodeIdP BEStrictNodeId(BENodeIdP nodeId); + +BENoStrictNodeIds :: !BackEnd -> (!BEStrictNodeIdP,!BackEnd); +BENoStrictNodeIds a0 = code { + ccall BENoStrictNodeIds ":I:I" +} +// BEStrictNodeIdP BENoStrictNodeIds(); + +BEStrictNodeIds :: !BEStrictNodeIdP !BEStrictNodeIdP !BackEnd -> (!BEStrictNodeIdP,!BackEnd); +BEStrictNodeIds a0 a1 a2 = code { + ccall BEStrictNodeIds "II:I:I" +} +// BEStrictNodeIdP BEStrictNodeIds(BEStrictNodeIdP strictNodeId,BEStrictNodeIdP strictNodeIds); + +BERule :: !Int !Int !BETypeAltP !BERuleAltP !BackEnd -> (!BEImpRuleP,!BackEnd); +BERule a0 a1 a2 a3 a4 = code { + ccall BERule "IIII:I:I" +} +// BEImpRuleP BERule(int functionIndex,int isCaf,BETypeAltP type,BERuleAltP alts); + +BEDeclareRuleType :: !Int !Int !String !BackEnd -> BackEnd; +BEDeclareRuleType a0 a1 a2 a3 = code { + ccall BEDeclareRuleType "IIS:V:I" +} +// void BEDeclareRuleType(int functionIndex,int moduleIndex,CleanString name); + +BEDefineRuleType :: !Int !Int !BETypeAltP !BackEnd -> BackEnd; +BEDefineRuleType a0 a1 a2 a3 = code { + ccall BEDefineRuleType "III:V:I" +} +// void BEDefineRuleType(int functionIndex,int moduleIndex,BETypeAltP typeAlt); + +BEAdjustArrayFunction :: !BEArrayFunKind !Int !Int !BackEnd -> BackEnd; +BEAdjustArrayFunction a0 a1 a2 a3 = code { + ccall BEAdjustArrayFunction "III:V:I" +} +// void BEAdjustArrayFunction(BEArrayFunKind arrayFunKind,int functionIndex,int moduleIndex); + +BENoRules :: !BackEnd -> (!BEImpRuleP,!BackEnd); +BENoRules a0 = code { + ccall BENoRules ":I:I" +} +// BEImpRuleP BENoRules(); + +BERules :: !BEImpRuleP !BEImpRuleP !BackEnd -> (!BEImpRuleP,!BackEnd); +BERules a0 a1 a2 = code { + ccall BERules "II:I:I" +} +// BEImpRuleP BERules(BEImpRuleP rule,BEImpRuleP rules); + +BETypes :: !BETypeP !BETypeP !BackEnd -> (!BETypeP,!BackEnd); +BETypes a0 a1 a2 = code { + ccall BETypes "II:I:I" +} +// BETypeP BETypes(BETypeP type,BETypeP types); + +BENoTypes :: !BackEnd -> (!BETypeP,!BackEnd); +BENoTypes a0 = code { + ccall BENoTypes ":I:I" +} +// BETypeP BENoTypes(); + +BEFlatType :: !BESymbolP !BETypeVarListP !BackEnd -> (!BEFlatTypeP,!BackEnd); +BEFlatType a0 a1 a2 = code { + ccall BEFlatType "II:I:I" +} +// BEFlatTypeP BEFlatType(BESymbolP symbol,BETypeVarListP arguments); + +BEAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd; +BEAlgebraicType a0 a1 a2 = code { + ccall BEAlgebraicType "II:V:I" +} +// void BEAlgebraicType(BEFlatTypeP lhs,BEConstructorListP constructors); + +BERecordType :: !Int !BEFlatTypeP !BETypeNodeP !BEFieldListP !BackEnd -> BackEnd; +BERecordType a0 a1 a2 a3 a4 = code { + ccall BERecordType "IIII:V:I" +} +// void BERecordType(int moduleIndex,BEFlatTypeP lhs,BETypeNodeP constructorType,BEFieldListP fields); + +BEAbsType :: !BEFlatTypeP !BackEnd -> BackEnd; +BEAbsType a0 a1 = code { + ccall BEAbsType "I:V:I" +} +// void BEAbsType(BEFlatTypeP lhs); + +BEConstructors :: !BEConstructorListP !BEConstructorListP !BackEnd -> (!BEConstructorListP,!BackEnd); +BEConstructors a0 a1 a2 = code { + ccall BEConstructors "II:I:I" +} +// BEConstructorListP BEConstructors(BEConstructorListP constructor,BEConstructorListP constructors); + +BENoConstructors :: !BackEnd -> (!BEConstructorListP,!BackEnd); +BENoConstructors a0 = code { + ccall BENoConstructors ":I:I" +} +// BEConstructorListP BENoConstructors(); + +BEConstructor :: !BETypeNodeP !BackEnd -> (!BEConstructorListP,!BackEnd); +BEConstructor a0 a1 = code { + ccall BEConstructor "I:I:I" +} +// BEConstructorListP BEConstructor(BETypeNodeP type); + +BEDeclareField :: !Int !Int !String !BackEnd -> BackEnd; +BEDeclareField a0 a1 a2 a3 = code { + ccall BEDeclareField "IIS:V:I" +} +// void BEDeclareField(int fieldIndex,int moduleIndex,CleanString name); + +BEField :: !Int !Int !BETypeNodeP !BackEnd -> (!BEFieldListP,!BackEnd); +BEField a0 a1 a2 a3 = code { + ccall BEField "III:I:I" +} +// BEFieldListP BEField(int fieldIndex,int moduleIndex,BETypeNodeP type); + +BEFields :: !BEFieldListP !BEFieldListP !BackEnd -> (!BEFieldListP,!BackEnd); +BEFields a0 a1 a2 = code { + ccall BEFields "II:I:I" +} +// BEFieldListP BEFields(BEFieldListP field,BEFieldListP fields); + +BENoFields :: !BackEnd -> (!BEFieldListP,!BackEnd); +BENoFields a0 = code { + ccall BENoFields ":I:I" +} +// BEFieldListP BENoFields(); + +BEDeclareConstructor :: !Int !Int !String !BackEnd -> BackEnd; +BEDeclareConstructor a0 a1 a2 a3 = code { + ccall BEDeclareConstructor "IIS:V:I" +} +// void BEDeclareConstructor(int constructorIndex,int moduleIndex,CleanString name); + +BETypeVar :: !String !BackEnd -> (!BETypeVarP,!BackEnd); +BETypeVar a0 a1 = code { + ccall BETypeVar "S:I:I" +} +// BETypeVarP BETypeVar(CleanString name); + +BEDeclareType :: !Int !Int !String !BackEnd -> BackEnd; +BEDeclareType a0 a1 a2 a3 = code { + ccall BEDeclareType "IIS:V:I" +} +// void BEDeclareType(int typeIndex,int moduleIndex,CleanString name); + +BEDeclareFunction :: !String !Int !Int !Int !BackEnd -> BackEnd; +BEDeclareFunction a0 a1 a2 a3 a4 = code { + ccall BEDeclareFunction "SIII:V:I" +} +// void BEDeclareFunction(CleanString name,int arity,int functionIndex,int ancestor); + +BECodeAlt :: !Int !BENodeDefP !BENodeP !BECodeBlockP !BackEnd -> (!BERuleAltP,!BackEnd); +BECodeAlt a0 a1 a2 a3 a4 = code { + ccall BECodeAlt "IIII:I:I" +} +// BERuleAltP BECodeAlt(int line,BENodeDefP lhsDefs,BENodeP lhs,BECodeBlockP codeBlock); + +BEString :: !String !BackEnd -> (!BEStringListP,!BackEnd); +BEString a0 a1 = code { + ccall BEString "S:I:I" +} +// BEStringListP BEString(CleanString cleanString); + +BEStrings :: !BEStringListP !BEStringListP !BackEnd -> (!BEStringListP,!BackEnd); +BEStrings a0 a1 a2 = code { + ccall BEStrings "II:I:I" +} +// BEStringListP BEStrings(BEStringListP string,BEStringListP strings); + +BENoStrings :: !BackEnd -> (!BEStringListP,!BackEnd); +BENoStrings a0 = code { + ccall BENoStrings ":I:I" +} +// BEStringListP BENoStrings(); + +BECodeParameter :: !String !BENodeIdP !BackEnd -> (!BECodeParameterP,!BackEnd); +BECodeParameter a0 a1 a2 = code { + ccall BECodeParameter "SI:I:I" +} +// BECodeParameterP BECodeParameter(CleanString location,BENodeIdP nodeId); + +BECodeParameters :: !BECodeParameterP !BECodeParameterP !BackEnd -> (!BECodeParameterP,!BackEnd); +BECodeParameters a0 a1 a2 = code { + ccall BECodeParameters "II:I:I" +} +// BECodeParameterP BECodeParameters(BECodeParameterP parameter,BECodeParameterP parameters); + +BENoCodeParameters :: !BackEnd -> (!BECodeParameterP,!BackEnd); +BENoCodeParameters a0 = code { + ccall BENoCodeParameters ":I:I" +} +// BECodeParameterP BENoCodeParameters(); + +BEAbcCodeBlock :: !Bool !BEStringListP !BackEnd -> (!BECodeBlockP,!BackEnd); +BEAbcCodeBlock a0 a1 a2 = code { + ccall BEAbcCodeBlock "II:I:I" +} +// BECodeBlockP BEAbcCodeBlock(int inline,BEStringListP instructions); + +BEAnyCodeBlock :: !BECodeParameterP !BECodeParameterP !BEStringListP !BackEnd -> (!BECodeBlockP,!BackEnd); +BEAnyCodeBlock a0 a1 a2 a3 = code { + ccall BEAnyCodeBlock "III:I:I" +} +// BECodeBlockP BEAnyCodeBlock(BECodeParameterP inParams,BECodeParameterP outParams,BEStringListP instructions); + +BEDeclareIclModule :: !String !Int !Int !Int !Int !BackEnd -> BackEnd; +BEDeclareIclModule a0 a1 a2 a3 a4 a5 = code { + ccall BEDeclareIclModule "SIIII:V:I" +} +// void BEDeclareIclModule(CleanString name,int nFunctions,int nTypes,int nConstructors,int nFields); + +BEDeclareDclModule :: !Int !String !Bool !Int !Int !Int !Int !BackEnd -> BackEnd; +BEDeclareDclModule a0 a1 a2 a3 a4 a5 a6 a7 = code { + ccall BEDeclareDclModule "ISIIIII:V:I" +} +// void BEDeclareDclModule(int moduleIndex,CleanString name,int systemModule,int nFunctions,int nTypes,int nConstructors,int nFields); + +BEDeclarePredefinedModule :: !Int !Int !BackEnd -> BackEnd; +BEDeclarePredefinedModule a0 a1 a2 = code { + ccall BEDeclarePredefinedModule "II:V:I" +} +// void BEDeclarePredefinedModule(int nTypes,int nConstructors); + +BEDefineRules :: !BEImpRuleP !BackEnd -> BackEnd; +BEDefineRules a0 a1 = code { + ccall BEDefineRules "I:V:I" +} +// void BEDefineRules(BEImpRuleP rules); + +BEGenerateCode :: !String !BackEnd -> (!Bool,!BackEnd); +BEGenerateCode a0 a1 = code { + ccall BEGenerateCode "S:I:I" +} +// int BEGenerateCode(CleanString outputFile); + +BEExportType :: !Int !Int !BackEnd -> BackEnd; +BEExportType a0 a1 a2 = code { + ccall BEExportType "II:V:I" +} +// void BEExportType(int dclTypeIndex,int iclTypeIndex); + +BESwapTypes :: !Int !Int !BackEnd -> BackEnd; +BESwapTypes a0 a1 a2 = code { + ccall BESwapTypes "II:V:I" +} +// void BESwapTypes(int frm,int to); + +BEExportConstructor :: !Int !Int !BackEnd -> BackEnd; +BEExportConstructor a0 a1 a2 = code { + ccall BEExportConstructor "II:V:I" +} +// void BEExportConstructor(int dclConstructorIndex,int iclConstructorIndex); + +BEExportField :: !Int !Int !BackEnd -> BackEnd; +BEExportField a0 a1 a2 = code { + ccall BEExportField "II:V:I" +} +// void BEExportField(int dclTypeIndex,int iclTypeIndex); + +BEExportFunction :: !Int !Int !BackEnd -> BackEnd; +BEExportFunction a0 a1 a2 = code { + ccall BEExportFunction "II:V:I" +} +// void BEExportFunction(int dclFunctionIndex,int iclFunctionIndex); + +BEDefineImportedObjsAndLibs :: !BEStringListP !BEStringListP !BackEnd -> BackEnd; +BEDefineImportedObjsAndLibs a0 a1 a2 = code { + ccall BEDefineImportedObjsAndLibs "II:V:I" +} +// void BEDefineImportedObjsAndLibs(BEStringListP objs,BEStringListP libs); +kBEVersionCurrent:==0x02000203; +kBEVersionOldestDefinition:==0x02000203; +kBEVersionOldestImplementation:==0x02000203; +kBEDebug:==1; +kIclModuleIndex:==0; +kPredefinedModuleIndex:==1; +BENoAnnot:==0; +BEStrictAnnot:==1; +BENoUniAttr:==0; +BENotUniqueAttr:==1; +BEUniqueAttr:==2; +BEExistsAttr:==3; +BEUniqueVariable:==4; +BEFirstUniVarNumber:==5; +BEIntType:==0; +BEBoolType:==1; +BECharType:==2; +BERealType:==3; +BEFileType:==4; +BEStringType:==5; +BEWorldType:==6; +BEProcIdType:==7; +BERedIdType:==8; +BENrOfBasicTypes:==9; +BEIntDenot:==10; +BEBoolDenot:==11; +BECharDenot:==12; +BERealDenot:==13; +BENrOfBasicDenots:==14; +BEStringDenot:==15; +BEFunType:==16; +BEArrayType:==17; +BEStrictArrayType:==18; +BEUnboxedArrayType:==19; +BEListType:==20; +BETupleType:==21; +BEEmptyType:==22; +BEDynamicType:==23; +BENrOfPredefTypes:==24; +BETupleSymb:==25; +BEConsSymb:==26; +BENilSymb:==27; +BEApplySymb:==28; +BEIfSymb:==29; +BEFailSymb:==30; +BEAllSymb:==31; +BESelectSymb:==32; +BENrOfPredefFunsOrConses:==33; +BEDefinition:==34; +BENewSymbol:==35; +BEInstanceSymb:==36; +BEEmptySymbol:==37; +BEFieldSymbolList:==38; +BEErroneousSymb:==39; +BECreateArrayFun:==0; +BEArraySelectFun:==1; +BEUnqArraySelectFun:==2; +BEArrayUpdateFun:==3; +BEArrayReplaceFun:==4; +BEArraySizeFun:==5; +BEUnqArraySizeFun:==6; +BE_CreateArrayFun:==7; +BE_UnqArraySelectFun:==8; +BE_UnqArraySelectNextFun:==9; +BE_UnqArraySelectLastFun:==10; +BE_ArrayUpdateFun:==11; +BENoArrayFun:==12; +BESelectorDummy:==0; +BESelector:==1; +BESelector_U:==2; +BESelector_F:==3; +BESelector_L:==4; +BESelector_N:==5; +BEUpdateDummy:==0; +BEUpdate:==1; +BEUpdate_U:==2; +BELhsNodeId:==0; +BERhsNodeId:==1; +BEIsNotACaf:==0; +BEIsACaf:==1; diff --git a/backendC/CleanCompilerSources/backendsupport.c b/backendC/CleanCompilerSources/backendsupport.c new file mode 100644 index 0000000..55975b4 --- /dev/null +++ b/backendC/CleanCompilerSources/backendsupport.c @@ -0,0 +1,138 @@ +# include "system.h" +# include "comsupport.h" +# include "backendsupport.h" + + +/* + Utilities + ========= +*/ +# ifdef _WINDOWS_ +# undef _WINDOWS_ +# include <windows.h> +# define Debugger() DebugBreak(); +# else +# define Debugger() { * (int *) NULL = 0; } +# endif + +void +AssertionFailed (char *conditionString, char *file, int line) +{ + FPrintF (StdError, "Error in backend: File %s, Line %d (%s)\n", file, line, conditionString); + + Debugger (); +} /* AssertionFailed */ + +/* + Memory management + ================= +*/ + +static enum {kMemoryInitClear, kMemoryInitSet} gMemoryInit = kMemoryInitSet; + +# define kConvertBufferSize (32 * 1024) + +typedef struct convert_buffer ConvertBufferS, *ConvertBufferP; + +struct convert_buffer +{ + ConvertBufferP cb_next; + char cb_memory [kConvertBufferSize]; +}; + +static void +InvalidateMemory (void *memory, size_t size) +{ + char value, *p; + int i; + + switch (gMemoryInit) + { + case kMemoryInitClear: + value = 0; + break; + case kMemoryInitSet: + value = ~0; + break; + default: + Assert (False); + break; + } + + p = memory; + for (i = 0; i < size; i++) + *p++ = value; +} /* InvalidateMemory */ + +static ConvertBufferP gFirstBuffer = NULL, gCurrentBuffer = NULL; +static char *gMemory; +static long gBytesLeft = 0; + +static void +AllocConvertBuffer (void) +{ + ConvertBufferP newBuffer; + + newBuffer = (ConvertBufferP) malloc (sizeof (ConvertBufferS)); + + if (newBuffer == NULL) + FatalCompError ("backendsupport.c", "AllocConvertBuffer", "out of memory"); + + if (gFirstBuffer == NULL) + gCurrentBuffer = gFirstBuffer = newBuffer; + else + gCurrentBuffer = gCurrentBuffer->cb_next = newBuffer; + + gCurrentBuffer->cb_next = NULL; + + gBytesLeft = kConvertBufferSize; + gMemory = gCurrentBuffer->cb_memory; + + InvalidateMemory (gMemory, kConvertBufferSize); + + if (gFirstBuffer == NULL) + gFirstBuffer = gCurrentBuffer; +} /* AllocConvertBuffer */ + +void +FreeConvertBuffers (void) +{ + ConvertBufferP buffer; + + buffer = gFirstBuffer; + + while (buffer != NULL) + { + ConvertBufferP nextBuffer; + + nextBuffer = buffer->cb_next; + + InvalidateMemory (buffer, sizeof (ConvertBufferS)); + free (buffer); + + buffer = nextBuffer; + } + + gFirstBuffer = NULL; + gCurrentBuffer = NULL; + gBytesLeft = NULL; +} /* FreeConvertBuffers */ + +void * +ConvertAlloc (SizeT size) +{ + void *memory; + + size = (size+3) & ~3; + + if (size > gBytesLeft) + AllocConvertBuffer (); + + Assert (size <= gBytesLeft); + + memory = gMemory; + gBytesLeft -= size; + gMemory += size; + + return ((void *) memory); +} /* ConvertAlloc */ diff --git a/backendC/CleanCompilerSources/backendsupport.h b/backendC/CleanCompilerSources/backendsupport.h new file mode 100644 index 0000000..a4ce716 --- /dev/null +++ b/backendC/CleanCompilerSources/backendsupport.h @@ -0,0 +1,22 @@ +/* + Clean string + ============ +*/ +typedef struct clean_string {int length; char chars [1]; } *CleanString; + +/* + Debugging + ========= +*/ + +extern void AssertionFailed (char *conditionString, char *file, int line); +# define Assert(condition) {if (!(condition)) AssertionFailed ("!(" #condition ")", __FILE__, __LINE__);} + +/* + Memory management + ================= +*/ +extern void FreeConvertBuffers (void); +extern void *ConvertAlloc (SizeT size); +# define ConvertAllocType(t) ((t*) ConvertAlloc (SizeOf (t))) +# define ArraySize(array) ((unsigned) (sizeof (array) / sizeof (array[0])))
\ No newline at end of file diff --git a/backendC/CleanCompilerSources/buildtree.c b/backendC/CleanCompilerSources/buildtree.c new file mode 100644 index 0000000..61b6a74 --- /dev/null +++ b/backendC/CleanCompilerSources/buildtree.c @@ -0,0 +1,633 @@ +# include "types.t" +# include "syntaxtr.t" +# include "comsupport.h" +# include "sizes.h" +# include "buildtree.h" +# include "checker.h" +# include "scanner.h" + +SymbolP BasicTypeSymbols [Nr_Of_Basic_Types], + ArraySymbols [NrOfArrayInstances], + + ApplyTypeSymbol, TrueSymbol, FalseSymbol, + TupleSymbol, ListSymbol, ConsSymbol, NilSymbol, + SelectSymbols [MaxNodeArity], ApplySymbol, IfSymbol, FailSymbol, AllSymbol, + EmptyTypeSymbol, + TupleTypeSymbols [MaxNodeArity]; + +char BasicTypeIds [] = BASIC_TYPE_IDS_STRING; + +IdentP gArrayIdents [NrOfArrayInstances]; + +RuleTypes +NewRuleType (TypeAlts type_alt, unsigned line_nr) +{ + RuleTypes rule_type = CompAllocType (struct rule_type); + + rule_type->rule_type_rule = type_alt; + rule_type->rule_type_line = line_nr; + rule_type->rule_type_root = type_alt->type_alt_lhs; + + return rule_type; + +} /* NewRuleType */ + +TypeArgs +NewTypeArgument (TypeNode pattern) +{ + TypeArgs newarg; + + newarg = CompAllocType (TypeArg); + + newarg->type_arg_node = pattern; + newarg->type_arg_next = NIL; + + return (newarg); +} /* NewTypeArgument */ + +Args +NewArgument (NodeP node) +{ + Args newarg; + + newarg = CompAllocType (ArgS); + + newarg->arg_node = node; + newarg->arg_occurrence = NotUsed; + newarg->arg_next = NIL; + + return (newarg); +} /* NewArgument */ + +NodeIdP +NewNodeId (IdentP nid) +{ + NodeIdP newnid; + + newnid = CompAllocType (struct node_id); + + newnid->nid_ident = nid; + newnid->nid_refcount = 0; + newnid->nid_ref_count_copy = 0; + newnid->nid_forward_node_id = NIL; + newnid->nid_node_def = NIL; + newnid->nid_node = NIL; + newnid->nid_scope = 0; + newnid->nid_mark = 0; + newnid->nid_mark2 = 0; + + return (newnid); +} /* NewNodeId */ + +static StrictNodeIdP +NewStrict (StrictNodeIdP next) +{ + StrictNodeIdP strictNodeId; + + strictNodeId = CompAllocType (StrictNodeIdS); + +#ifdef OBSERVE_ARRAY_SELECTS_IN_PATTERN + strictNodeId->snid_array_select_in_pattern=0; +#endif + strictNodeId->snid_next = next; + + return (strictNodeId); +} /* NewStrict */ + +StrictNodeIdP +NewStrictNodeId (NodeId nodeId, StrictNodeIdP next) +{ + StrictNodeIdP strictNodeId; + + strictNodeId = NewStrict (next); + + strictNodeId->snid_mark = 0; + strictNodeId->snid_node_id = nodeId; + + return (strictNodeId); +} /* NewStrictNodeId */ + +StrictNodeIdP +NewStrictIdent (Ident ident, StrictNodeIdP next) +{ + StrictNodeIdP strictNodeId; + + strictNodeId = NewStrict (next); + + strictNodeId->snid_mark = STRICT_NODE_ID_IDENT_MASK; + strictNodeId->snid_ident = ident; + + return (strictNodeId); +} /* NewStrictIdent */ + +TypeVar +NewTypeVar (IdentP nid) +{ + TypeVar newnid; + + newnid = CompAllocType (struct type_var); + + newnid->tv_ident = nid; + newnid->tv_refcount = 0; + newnid->tv_argument_nr = 0; + newnid->tv_type = NIL; + newnid->tv_imp_tv = NIL; + newnid->tv_overvar_arity = 0; + newnid->tv_mark = 0; + + return (newnid); +} + +UniVar +NewUniVar (IdentP id) +{ + UniVar new_uni_var; + + new_uni_var = CompAllocType (struct uni_var); + + new_uni_var->uv_ident = id; + new_uni_var->uv_mark = 0; + new_uni_var->uv_number = 0; + new_uni_var->uv_next_uni_var = NULL; + new_uni_var->uv_equations = NULL; + + return (new_uni_var); +} + +NodeP +NewNodeIdNode (NodeIdP node_id) +{ + NodeP node = CompAllocType (struct node); + + node->node_annotation = NoAnnot; + node->node_number = 0; + node->node_kind = NodeIdNode; + node->node_node_id = node_id; + node->node_arguments = NIL; + node->node_arity = 0; + + node->node_line=-1; + + return (node); +} /* NewNodeIdNode */ + +TypeNode +NewTypeNode (Annotation annot, AttributeKind attr, SymbolP symb, TypeArgs args, int arity) +{ + TypeNode node; + + node = CompAllocType (struct type_node); + + node->type_node_annotation = annot; + node->type_node_attribute = attr; + node->type_node_is_var = False; + node->type_node_arguments = args; + node->type_node_symbol = symb; + node->type_node_arity = arity; + + if (arity > MaxNodeArity) + StaticMessage (True, "<type node>", "\"%S\" %s", symb, "Too many arguments (> 32)"); +#if 0 + node->type_node_state.state_arity = 1; + node->type_node_state.state_kind = OnA; + node->type_node_state.state_object = UnknownObj; + node->type_node_state.state_type = SimpleState; + node->type_node_state.state_mark = 0; +#endif + return (node); +} /* NewTypeNode */ + +TypeNode +NewTypeVarNode (TypeVar type_var, Annotation annot, AttributeKind attrib) +{ + TypeNode node; + + node = CompAllocType (struct type_node); + + node->type_node_is_var = True; + node->type_node_tv = type_var; + node->type_node_arguments = NIL; + node->type_node_annotation = annot; + node->type_node_attribute = attrib; +#if 0 + node->type_node_state.state_arity = 1; + node->type_node_state.state_kind = OnA; + node->type_node_state.state_object = UnknownObj; + node->type_node_state.state_type = SimpleState; + node->type_node_state.state_mark = 0; +#endif + return (node); +} /* NewTypeVarNode */ + +NodeP +NewSelectorNode (SymbolP symb, Args args, int arity) +{ + NodeP node; + + node = CompAllocType (struct node); + + node->node_annotation = NoAnnot; + node->node_number = 0; + node->node_kind = SelectorNode; + node->node_arguments = args; + node->node_symbol = symb; + node->node_arity = arity; + + node->node_line=-1; + + return (node); +} /* NewSelectorNode */ + +NodeP +NewNodeByKind (NodeKind nodeKind, SymbolP symb, Args args, int arity) +{ + NodeP node; + + node = CompAllocType (struct node); + + node->node_annotation = NoAnnot; + node->node_number = 0; + node->node_kind = nodeKind; + node->node_arguments = args; + node->node_symbol = symb; + node->node_arity = arity; + + if (arity > MaxNodeArity) + StaticMessage (True, "<node>", "\"%S\" %s", symb, "Too many arguments (> 32)"); + + node->node_line=-1; + + return (node); +} /* NewNodeByKind */ + +NodeP +NewNode (SymbolP symb, Args args, int arity) +{ + return (NewNodeByKind (NormalNode, symb, args, arity)); +} /* NewNode */ + +NodeP +NewUpdateNode (SymbolP symb, Args args, int arity) +{ + return (NewNodeByKind (UpdateNode, symb, args, arity)); +} /* NewUpdateNode */ + +NodeP +NewIdentifierNode (IdentP ident, Args args, int arity) +{ + NodeP node; + + node = NewNodeByKind (IdentNode, NIL, args, arity); + node->node_ident = ident; + + return (node); +} /* NewIdentifierNode */ + +NodeP +NewApplyNode (NodeP function_node, Args args, int arity) +{ + NodeP node; + + node = NewNodeByKind (ApplyNode, NIL, args, arity); + node->node_node = function_node; + + return (node); +} /* NewApplyNode */ + +NodeP +NewIfNode (void) +{ + NodeP node; + struct if_node_contents *then_else_info; + + node = CompAllocType (struct node); + then_else_info = CompAllocType (struct if_node_contents); + + node->node_annotation = NoAnnot; + node->node_number = 0; + node->node_kind = IfNode; + + node->node_contents.contents_if=then_else_info; + + then_else_info->if_then_node_defs = NIL; + then_else_info->if_then_rules = NIL; + then_else_info->if_then_strict_node_ids = NIL; + then_else_info->if_else_node_defs = NIL; + then_else_info->if_else_rules = NIL; + then_else_info->if_else_strict_node_ids = NIL; + + node->node_line=-1; + + return (node); +} /* NewIfNode */ + +NodeP +NewSelectNode (SymbolP selectSymbol, NodeIdP selectId, int arity) +{ + Args selectArg; + + selectArg = NewArgument (NewNodeIdNode (selectId)); + + return (NewNode (selectSymbol, selectArg, arity)); +} /* NewSelectNode */ + +NodeP +NewScopeNode (NodeP node, NodeDefP node_defs,ImpRuleS *imp_rules) +{ + struct node *sc_node; + + sc_node=CompAllocType (struct node); + + sc_node->node_kind=ScopeNode; + sc_node->node_annotation=NoAnnot; + sc_node->node_node=node; + sc_node->node_scope_node_defs=node_defs; + sc_node->node_scope_imp_rules=imp_rules; + sc_node->node_arguments=NULL; + sc_node->node_arity=0; + + return sc_node; +} /* NewScopeNode */ + +NodeDefs +NewNodeDefinition (NodeIdP nid, NodeP node) +{ + NodeDefs def; + + def = CompAllocType (NodeDefS); + + def->def_mark = 0; + def->def_id = nid; + def->def_node = node; + + return (def); +} /* NewNodeDefinition */ + +NodeIdP +FreshNodeId (NodeP node, NodeDefs **node_defs_h) +{ + NodeIdP nodeId; + NodeDefs def; + + nodeId = NewNodeId (NIL); + + def = NewNodeDefinition (nodeId, node); + + **node_defs_h = def; + *node_defs_h = &def->def_next; + + return (nodeId); +} /* FreshNodeId */ + +SymbolP +NewSymbol (SymbKind symbolKind) +{ + SymbolP symbol; + + symbol = CompAllocType (SymbolS); + + symbol->symb_kind = symbolKind; + symbol->symb_infix = False; + + return (symbol); +} /* NewSymbol */ + +NodeP +NewIntNode (int value) +{ + char buffer [10], *valueString; + SymbolP symbol; + NodeP node; + int length; + + sprintf (buffer, "%d", value); + length = strlen (buffer); + + valueString = (char *) CompAlloc (length+1); + strcpy (valueString, buffer); + + symbol = NewSymbol (int_denot); + symbol->symb_int = valueString; + + node = NewNormalNode (symbol, NIL, 0); + + return (node); +} /* NewIntNode */ + +SymbolP +NewTupleTypeSymbol (int arity) +{ + SymbolP tuple; + + if ((tuple =TupleTypeSymbols [arity-1]) == NIL) + { + TupleTypeSymbols [arity-1] = tuple = NewSymbol (tuple_type); + tuple -> symb_arity = arity; + } + + return tuple; + +} /* NewTupleTypeSymbol */ + +SymbolP +NewSelectSymbol (int arity) +{ + SymbolP select; + + if ((select = SelectSymbols [arity-1]) == NIL) + { + select = NewSymbol (select_symb); + select->symb_arity = arity; + SelectSymbols [arity-1] = select; + } + + return (select); +} /* NewSelectSymbol */ + +ImpRules +NewImpRule (unsigned line_number,TypeAlts typeAlternative,NodeP rule_root) +{ + ImpRules impRule; + + impRule = CompAllocType (ImpRuleS); + + impRule->rule_alts = NIL; + impRule->rule_root = rule_root; + impRule->rule_line = line_number; + impRule->rule_type = typeAlternative; + impRule->rule_depend_functions=NIL; + + impRule->rule_mark = 0; + impRule->rule_next = NIL; + + return impRule; +} /* NewImpRule */ + +ImpRules +NewRule (unsigned line_number,TypeAlts typeAlternative,NodeP rule_root, ScopeP scope) +{ + ImpRules impRule; + + impRule = NewImpRule (line_number, typeAlternative, rule_root); + + *(scope->sc_rulesP) = impRule; + scope->sc_rulesP = &impRule->rule_next; + + return (impRule); +} /* NewRule */ + +RuleAltP +NewRuleAlt (void) +{ + RuleAltP alt; + + alt = CompAllocType (RuleAltS); + + alt->alt_kind = Contractum; + alt->alt_lhs_root = NIL; + alt->alt_lhs_defs = NIL; + alt->alt_lifted_node_ids = NIL; + alt->alt_rhs_defs = NIL; + alt->alt_strict_node_ids = NIL; + alt->alt_next = NIL; + alt->alt_local_imp_rules = NIL; + alt->alt_line = 0; + + return (alt); +} /* NewRuleAlt */ + +TypeNode NewEmptyTypeNode (void) +{ + return NewTypeNode (NoAnnot, NoAttr, EmptyTypeSymbol, NIL, 0); +} /* NewEmptyTypeNode */ + +struct p_at_node_tree { + NodeP annoted_node; + NodeP at_node; + struct p_at_node_tree * left; + struct p_at_node_tree * right; +}; + +static struct p_at_node_tree *p_at_node_tree; + +void clear_p_at_node_tree (void) +{ + p_at_node_tree=NULL; +} + +static NodeP reorder_bits (NodeP node) +{ + unsigned long n,m; + + n=(long)node; + + m=n & 0x000ffffL; + n= (m<<16) | ((n^m)>>16); + m=n & 0x00ff00ffL; + n= (m<<8) | ((n^m)>>8); + m=n & 0x0f0f0f0fL; + n= (m<<4) | ((n^m)>>4); + + return (NodeP)n; +} + +void store_p_at_node (NodeP annoted_node,NodeP at_node) +{ + struct p_at_node_tree *tree_node,**tree_node_p; + + /* without reordering the tree becomes a list */ + annoted_node=reorder_bits (annoted_node); + + tree_node_p=&p_at_node_tree; + while ((tree_node=*tree_node_p)!=NULL) + if (annoted_node < tree_node->annoted_node) + tree_node_p=&tree_node->left; + else + tree_node_p=&tree_node->right; + + tree_node=CompAllocType (struct p_at_node_tree); + + tree_node->annoted_node=annoted_node; + tree_node->at_node=at_node; + tree_node->left=NULL; + tree_node->right=NULL; + + *tree_node_p=tree_node; +} + +NodeP *get_p_at_node_p (NodeP annoted_node) +{ + struct p_at_node_tree *tree_node; + + annoted_node=reorder_bits (annoted_node); + + tree_node=p_at_node_tree; + while (tree_node!=NULL) + if (annoted_node < tree_node->annoted_node) + tree_node=tree_node->left; + else if (annoted_node > tree_node->annoted_node) + tree_node=tree_node->right; + else + return &tree_node->at_node; + + ErrorInCompiler (NULL,"get_p_at_node_p",NULL); + + return NULL; +} + +NodeP get_p_at_node (NodeP annoted_node) +{ + NodeP *node_p; + + node_p=get_p_at_node_p (annoted_node); + + if (node_p!=NULL) + return *node_p; + else + return NULL; +} + +unsigned import_system_functions, import_system_array_functions; + +#ifndef CLEAN2 +IdentP +UseArrayFunctionId (ArrayFunKind kind) +{ + if (import_system_array_functions == 0) + import_system_array_functions = gCurrentToken.lineNumber; + + return (ArrayFunctionIds [kind]); +} /* UseArrayFunctionId */ +#endif + +static IdentP EnumFunctionIds [NoEnumFun]; + +void +InitialiseEnumFunctionIds (void) +{ + EnumFunctionIds [FromEnumFun] = PutStringInHashTable (kFromPrefix, SymbolIdTable); + EnumFunctionIds [FromThenEnumFun] = PutStringInHashTable (kFromThenPrefix, SymbolIdTable); + EnumFunctionIds [FromToEnumFun] = PutStringInHashTable (kFromToPrefix, SymbolIdTable); + EnumFunctionIds [FromThenToEnumFun] = PutStringInHashTable (kFromThenToPrefix, SymbolIdTable); + EnumFunctionIds [MinusEnumFun] = PutStringInHashTable ("_minus", SymbolIdTable); + EnumFunctionIds [LessThanEqEnumFun] = PutStringInHashTable ("_lteq", SymbolIdTable); + EnumFunctionIds [IncEnumFun] = PutStringInHashTable ("inc", SymbolIdTable); + EnumFunctionIds [DecEnumFun] = PutStringInHashTable ("dec", SymbolIdTable); +} /* InitialiseEnumFunctionIds */ + +#ifndef CLEAN2 +IdentP +UseEnumFunctionId (EnumFunKind kind) +{ + if (import_system_functions == 0) + import_system_functions = gCurrentToken.lineNumber; + + return (EnumFunctionIds [kind]); +} /* UseEnumFunctionId */ +#endif + +IdentP +EnumFunctionId (EnumFunKind kind) +{ + return (EnumFunctionIds [kind]); +} /* UseEnumFunctionId */ diff --git a/backendC/CleanCompilerSources/buildtree.h b/backendC/CleanCompilerSources/buildtree.h new file mode 100644 index 0000000..d91ef3b --- /dev/null +++ b/backendC/CleanCompilerSources/buildtree.h @@ -0,0 +1,133 @@ + +typedef enum +{ + LazyArrayInstance, StrictArrayInstance, UnboxedArrayInstance, NrOfArrayInstances +} ArrayInstance; + +typedef enum +{ + NoQuantifier, AllQuantifier, ExistQuantifier, ExistAttributeQuantifier +} Quantifier; + +typedef enum +{ + /* defining symbol */ + kUnknownRuleAlternativeKind, /* ':==', '=:', '=>' or '=' */ + kUnknownFunctionAlternativeKind, /* '=>' or '=' */ + kFunctionAlternativeKind, /* '=' */ + kExplicitFunctionAlternativeKind, /* '=>' */ + kCAFAlternativeKind, /* '=:' */ + kArrowAlternativeKind /* '->' */ +} RuleAltKind; + +STRUCT (scope, Scope) +{ + ImpRules *sc_rulesP; + + ImpRule sc_rule; + + RuleAlts *sc_altP; + Symbol sc_ruleSymbol; + RuleAltKind sc_altKind; + + NodeDefP *sc_nodeDefsP; + NodeDefP *sc_firstNodeDefP; + int sc_scopeMask; + + StrictNodeIdP *sc_strictDefsP; +}; + +extern Args NewArgument (NodeP pattern); +extern NodeP NewNode (SymbolP symb, Args args, int arity); +extern NodeP NewIfNode (void); +extern NodeP NewSelectorNode (SymbolP symb, Args args, int arity); +extern NodeP NewNodeIdNode (NodeIdP node_id); +extern NodeP NewApplyNode (NodeP function_node, Args args, int arity); +extern NodeP NewUpdateNode (SymbolP symb,Args args,int arity); +extern NodeP NewIdentifierNode (IdentP ident, Args args, int arity); +extern NodeP NewNodeByKind (NodeKind nodeKind, SymbolP symb, Args args, int arity); +# define NewNormalNode(symb, args, arity) NewNodeByKind (NormalNode, (symb), (args), (arity)) +# define NewRecordNode(symb, args, arity) NewNodeByKind (RecordNode, (symb), (args), (arity)) +# define NewMatchNode(symb, args, arity) NewNodeByKind (MatchNode, (symb), (args), (arity)) +# define NewCons(element) NewNormalNode (ConsSymbol, element, 2) +# define NewNil() NewNormalNode (NilSymbol, NIL, 0) +# define NewFalse() NewNormalNode (FalseSymbol, NIL, 0) +# define NewTrue() NewNormalNode (TrueSymbol, NIL, 0) +extern NodeP NewIntNode (int value); +extern ImpRules NewRule (unsigned line_number, TypeAlts typeAlternative, NodeP rule_root, ScopeP scope); + +extern NodeIdP NewNodeId (IdentP nid); +extern StrictNodeIdP NewStrictNodeId (NodeIdP node_id, StrictNodeIdP next); +extern StrictNodeIdP NewStrictIdent (Ident ident, StrictNodeIdP next); +extern TypeVar NewTypeVar (IdentP nid); +extern UniVar NewUniVar (IdentP nid); +extern NodeDefs NewNodeDefinition (NodeIdP nid, NodeP node); +extern SymbolP NewSymbol (SymbKind symbolKind); +extern TypeNode NewTypeNode (Annotation annot, AttributeKind attr, SymbolP symb, TypeArgs args, int arity); +extern TypeArgs NewTypeArgument (TypeNode pattern); +extern TypeNode NewTypeVarNode (TypeVar node_id,Annotation annot, AttributeKind attr); + +extern RuleTypes NewRuleType (TypeAlts type_alt, unsigned line_nr); + +extern NodeP NewSelectNode (SymbolP selectSymbol, NodeIdP selectId, int arity); +extern NodeP NewScopeNode (NodeP node, NodeDefP node_defs,ImpRuleS *imp_rules); +extern NodeIdP BuildSelect (NodeP node, NodeDefs **node_defs_p); +extern NodeIdP BuildSelectors (NodeP pattern, NodeP node, NodeDefs **node_defs_p); + +extern SymbolP NewSelectSymbol (int arity); +extern SymbolP NewTupleTypeSymbol (int arity); +extern SymbolP NewListFunctionSymbol (void); + +extern ImpRules NewImpRule (unsigned line_number,TypeAlts typeAlternative,NodeP rule_root); +extern RuleAltP NewRuleAlt (void); + +extern NodeIdP FreshNodeId (NodeP node, NodeDefs **node_defs_h); + +extern TypeArgs ConvertFieldsToTypeArguments (FieldList fields); + +extern char *CopyString (char *to, char *from, int *rest_size); + +extern char BasicTypeIds []; +#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 gArrayIdents []; + +extern SymbolP BasicTypeSymbols [], + ArraySymbols [], + TrueSymbol, FalseSymbol, TupleSymbol, ListSymbol, ConsSymbol, NilSymbol, + ApplySymbol, ApplyTypeSymbol, SelectSymbols[], + FailSymbol, IfSymbol, AllSymbol, EmptyTypeSymbol; + +extern SymbolP TupleTypeSymbols []; +IdentP UseArrayFunctionId (ArrayFunKind kind); +void InitialiseEnumFunctionIds (void); + +typedef enum { + FromEnumFun, FromThenEnumFun, FromToEnumFun, FromThenToEnumFun, + IncEnumFun, DecEnumFun, MinusEnumFun, LessThanEqEnumFun, + NoEnumFun +} EnumFunKind; +IdentP EnumFunctionId (EnumFunKind kind); +IdentP UseEnumFunctionId (EnumFunKind kind); + + +extern unsigned import_system_functions, import_system_array_functions; + +void clear_p_at_node_tree (void); +void store_p_at_node (NodeP annoted_node,NodeP at_node); +NodeP *get_p_at_node_p (NodeP annoted_node); +NodeP get_p_at_node (NodeP annoted_node); + +# define kCasePrefix "_case" +# define kLambdaPrefix "_lambda" +# define kArrayGeneratorPrefix "_array" +# define kListGeneratorPrefix "_list" +# define kFromPrefix "_from" +# define kFromThenPrefix "_from_then" +# define kFromToPrefix "_from_to" +# define kFromThenToPrefix "_from_then_to" + diff --git a/backendC/CleanCompilerSources/cginterface.t b/backendC/CleanCompilerSources/cginterface.t new file mode 100644 index 0000000..1f5bd48 --- /dev/null +++ b/backendC/CleanCompilerSources/cginterface.t @@ -0,0 +1,16 @@ + +typedef enum { MAC_II, SUN_3, MAC_I, MAC_IISANE, MAC_CURRENT = 100 } target_machine_type; + +/* code generator flags */ +#define ASSEMBLY 1 +#define KEEP_ABC 2 +#define STACK_CHECKS 4 +#define DO_PARALLEL 8 +#define CHECK_INDICES 16 + +/* application and linker flags */ +#define SHOW_BASIC_ONLY 1 +#define SHOW_GARBAGE_COLLECTIONS 2 +#define SHOW_STACK_SIZE 4 +#define SHOW_EXECUTION_TIME 8 + diff --git a/backendC/CleanCompilerSources/checker.h b/backendC/CleanCompilerSources/checker.h new file mode 100644 index 0000000..6380ec4 --- /dev/null +++ b/backendC/CleanCompilerSources/checker.h @@ -0,0 +1,39 @@ + +#define BIT(n) ((BITVECT) 1 << n) +#define ALLBITSCLEAR ((BITVECT) 0) +#define ALLBITSSET (~ALLBITSCLEAR) +#define BITTEST(v,n) (((BITVECT) v >> n) & ((BITVECT) 1)) +#define TCONS_BIT_NR 31 + +extern Ident AnnotatedId, ListId, TupleId, ConsId, NilId, ApplyId, SelectId, IfId, FailId, DeltaBId, + AndId, OrId, StdArrayId, ArrayFunctionIds [], ArrayId, StrictArrayId, UnboxedArrayId, ArrayClassId; +#ifdef CLEAN2 +extern Ident DynamicId; +#endif + +extern Symbol StartSymbol, UnboxedArrayClassSymbols [], UnboxedArrayFunctionSymbols []; +extern SymbDef scc_dependency_list,ArrayFunctionDefs[], StdArrayAbortDef; +extern char * CurrentDefModule; + +extern int rule_count; +extern SymbDef *scc_dependency_list_p; + +SymbDef BuildNewSymbolDefinition (Ident sid,int arity,SDefKind kind,unsigned line_nr); +SymbDef MakeNewSymbolDefinition (char * module, Ident name, int arity, SDefKind kind); +SymbDef NewSymbolDefinition (Symbol symb, int arity, Bool maybedefined, unsigned line_nr); +char *ConvertSymbolToString (Symbol symb); +ImpMod ParseAndCheckImplementationModule (char *name); +void ReadInlineCode (void); +void InitChecker (void); +void GenDependencyList (void); +NodeDefs NewNodeDef (NodeId nid, Node node); +void GenerateApplyNodesForFullyCurriedApplication (Node node, Node function_node); + +void DetermineRuleComponent (ImpRules rule,SymbDef sdef); +NodeP DetermineGraphRulesComponent (NodeP node,unsigned *ancest); +NodeP RemoveAliasNodeIdInDetermineComponent (NodeP node); + +#ifdef CLEAN2 +void ClearOpenDefinitionModules (void); +void AddOpenDefinitionModule (SymbolP moduleNameSymbol, DefMod definitionModule); +#endif diff --git a/backendC/CleanCompilerSources/checker_2.c b/backendC/CleanCompilerSources/checker_2.c new file mode 100644 index 0000000..3502cc2 --- /dev/null +++ b/backendC/CleanCompilerSources/checker_2.c @@ -0,0 +1,243 @@ +/* + Authors: Sjaak Smetsers & John van Groningen + Version: 1.2 +*/ + +#pragma segment checker + +#define COMPLEX_ABSTYPES +#define MOVE_LIFTED_CONSTANTS +#define OPTIMIZE_APPLIES +#define MOVE_MORE_LIFTED_CONSTANTS +#define MOVE_CURRIED_APPLICATIONS +#define MOVE_FUNCTIONS_IN_LAMBDAS + +#include "types.t" +#include "system.h" +#include "syntaxtr.t" +#include "comsupport.h" +#include "sizes.h" +#include "scanner.h" +#include "buildtree.h" +#include "comparser.h" +#include "statesgen.h" +#include "codegen_types.h" +#include "codegen1.h" +#include "codegen2.h" +#include "instructions.h" +#include "typechecker.h" +#include "transform.h" +#include "checksupport.h" +#include "checktypedefs.h" +#include "overloading.h" +#include "settings.h" +#include "checker.h" +#include "macros.h" +#ifdef MOVE_FUNCTIONS_IN_LAMBDAS +# include "optimise_lambda.h" +#endif +#ifdef applec +# include <types.h> +#endif + +#undef DEBUG_REF_COUNT + +#ifdef DEBUG_REF_COUNT +# define IF_DEBUG_REF_COUNT(a) a +# include "dbprint.h" +#else +# define IF_DEBUG_REF_COUNT(a) +#endif + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) + +struct def_list { + Symbol mod_name; + Bool mod_undereval; + DefMod mod_body; + struct def_list * mod_next; +}; + +typedef struct def_list *DefModList,DefModElem; + +static DefModList OpenDefinitionModules; + +void GenDependencyList (void) +{ + DefModList def_mod; + + for_l (def_mod,OpenDefinitionModules,mod_next) + GenDepend (def_mod->mod_body->dm_name->symb_ident->ident_name +#if WRITE_DCL_MODIFICATION_TIME + ,def_mod->mod_body->dm_modification_time +#endif + ); +} + +void ReadInlineCode (void) +{ + DefModList d_mod; + + for_l (d_mod,OpenDefinitionModules,mod_next){ + DefMod def_mod; + + def_mod=d_mod->mod_body; + if (def_mod->dm_system_module){ + Symbol symbol; + + for_l (symbol,def_mod->dm_symbols,symb_next) + if (symbol->symb_kind==definition){ + SymbDef sdef; + + sdef=symbol->symb_def; + if (sdef->sdef_kind==SYSRULE && sdef->sdef_mark & SDEF_USED_STRICTLY_MASK) + break; + } + + if (symbol!=NULL) + /* Get the inline instructions of all the rules that are defined in this module */ + ScanInlineFile (d_mod->mod_name->symb_ident->ident_name); + } + } +} + + +Ident AnnotatedId, ListId, TupleId, ConsId, NilId, ApplyId, SelectId, +#ifdef CLEAN2 + DynamicId, +#endif + DeltaBId, IfId, FailId, AndId, OrId, + StdArrayId, ArrayFunctionIds [NoArrayFun]; + +Symbol StartSymbol; + +SymbDef ArrayFunctionDefs [NoArrayFun],StdArrayAbortDef; + +SymbDef scc_dependency_list; +SymbDef *scc_dependency_list_p; + +SymbDef MakeNewSymbolDefinition (char * module, Ident name, int arity, SDefKind kind) +{ + SymbDef def; + + def = CompAllocType (SymbDefS); + + def->sdef_module = module; + def->sdef_ident = name; + def->sdef_arity = arity; + def->sdef_kind = kind; + def->sdef_line = 0; + + def->sdef_mark=0; + def->sdef_over_arity=0; + + def->sdef_exported=False; + def->sdef_main_dcl=False; + def->sdef_infix=False; + + def->sdef_arfun = NoArrayFun; + + return def; +} + +static NodeDefs FreeDefs; + +NodeDefs NewNodeDef (NodeId nid,Node node) +{ + NodeDefs new; + + if (FreeDefs){ + new = FreeDefs; + FreeDefs = FreeDefs->def_next; + } else + new = CompAllocType (NodeDefS); + + new->def_id = nid; + new->def_node = node; + new->def_mark = 0; + + return new; +} + +static Ident SystemFunctionsId,StdArrayAbortId; + +void InitChecker (void) +{ + FreeDefs=NIL; + free_ldefs=NULL; +#ifndef CLEAN2 + free_depend_macros=NULL; +#endif + AnnotatedId = PutStringInHashTable ("_annotated", SymbolIdTable); + ListId = PutStringInHashTable ("[...]", SymbolIdTable); + TupleId = PutStringInHashTable ("(...)", SymbolIdTable); + ConsId = PutStringInHashTable ("[...|...]", SymbolIdTable); + NilId = PutStringInHashTable ("[]", SymbolIdTable); + ApplyId = PutStringInHashTable ("AP", SymbolIdTable); + SelectId = PutStringInHashTable ("_Select", SymbolIdTable); + +#ifdef CLEAN2 + DynamicId = PutStringInHashTable ("Dynamic", SymbolIdTable); +#endif + + /* hack RWS */ + IfId = PutStringInHashTable ("if ", SymbolIdTable); + IfId->ident_name = "if"; + + FailId = PutStringInHashTable ("_Fail", SymbolIdTable); + + StartSymbol = NewSymbol (newsymbol); + StartSymbol -> symb_ident = PutStringInHashTable ("Start", SymbolIdTable); + + AndId = PutStringInHashTable ("&&", SymbolIdTable); + OrId = PutStringInHashTable ("||", SymbolIdTable); + + SystemFunctionsId = PutStringInHashTable ("StdEnum", ModuleIdTable); + DeltaBId = PutStringInHashTable ("StdBool", ModuleIdTable); + StdArrayId = PutStringInHashTable ("_SystemArray", ModuleIdTable); + + /* Predefined Array functions */ + + StdArrayAbortId = PutStringInHashTable ("_abortArray", SymbolIdTable); + ArrayFunctionIds[CreateArrayFun] = PutStringInHashTable ("createArray", SymbolIdTable); + ArrayFunctionIds[UnqArraySelectFun] = PutStringInHashTable ("uselect", SymbolIdTable); + ArrayFunctionIds[ArrayReplaceFun] = PutStringInHashTable ("replace", SymbolIdTable); + ArrayFunctionIds[UnqArraySizeFun] = PutStringInHashTable ("usize", SymbolIdTable); + ArrayFunctionIds[ArrayUpdateFun] = PutStringInHashTable ("update", SymbolIdTable); + ArrayFunctionIds[ArraySelectFun] = PutStringInHashTable ("select", SymbolIdTable); + ArrayFunctionIds[ArraySizeFun] = PutStringInHashTable ("size", SymbolIdTable); + ArrayFunctionIds[_CreateArrayFun] = PutStringInHashTable ("_createArrayc", SymbolIdTable); + ArrayFunctionIds[_UnqArraySelectFun]= PutStringInHashTable ("_uselectf", SymbolIdTable); + ArrayFunctionIds[_UnqArraySelectNextFun]= PutStringInHashTable ("_uselectn", SymbolIdTable); + ArrayFunctionIds[_UnqArraySelectLastFun]= PutStringInHashTable ("_uselectl", SymbolIdTable); + ArrayFunctionIds[_ArrayUpdateFun]= PutStringInHashTable ("_updatei", SymbolIdTable); + + FunTypeClass.tac_uniprop = ALLBITSCLEAR; + FunTypeClass.tac_possign = BIT(1); + FunTypeClass.tac_negsign = BIT(0); + + GeneralTypeClass.tac_uniprop = ALLBITSSET; + GeneralTypeClass.tac_possign = ALLBITSSET; + GeneralTypeClass.tac_negsign = ALLBITSCLEAR; + + OpenDefinitionModules = NIL; +} + +#ifdef CLEAN2 + void ClearOpenDefinitionModules (void) + { + OpenDefinitionModules = NULL; + } + + void AddOpenDefinitionModule (SymbolP moduleNameSymbol, DefMod definitionModule) + { + DefModList openModule; + + openModule = CompAllocType (DefModElem); + openModule->mod_name = moduleNameSymbol; + openModule->mod_body = definitionModule; + openModule->mod_next = OpenDefinitionModules; + + OpenDefinitionModules = openModule; + } +#endif diff --git a/backendC/CleanCompilerSources/checksupport.c b/backendC/CleanCompilerSources/checksupport.c new file mode 100644 index 0000000..1c8b655 --- /dev/null +++ b/backendC/CleanCompilerSources/checksupport.c @@ -0,0 +1,435 @@ + +#include "types.t" +#include "syntaxtr.t" +#include "comsupport.h" +#include "scanner.h" +#include "checksupport.h" +#include "overloading.h" +#include "settings.h" +#include "buildtree.h" +#include "checker.h" +#include <ctype.h> + +char + *Earity = "used with wrong arity", + *Ecyclicsyn = "cyclic dependencies between synonym types", + *EwrongdefS = "differs from the symbol of the first rule alternative", + *Einfix_imp_def = "infix specification in the impl module conflicts with the def module", + *EImplandDef1 = "definition in the impl module conflicts with the def module", + *EImplandDef5 = "should have a type specification in the implementation rule", + *Enodeid2 = "multiply defined", + *Enodeid3 = "not defined"; + +static char + *Etuple = "tuples without type checking not allowed"; + +unsigned RuleCount,TypeSymbolCount; +SymbDef StackTop; + + +char *ConvertSymbolKindToString (SymbKind skind) +{ + switch (skind) + { + case int_type: return ReservedWords [(int) intsym]; + case bool_type: return ReservedWords [(int) boolsym]; + case char_type: return ReservedWords [(int) charsym]; + case string_type: return ReservedWords [(int) stringsym]; + case real_type: return ReservedWords [(int) realsym]; + case file_type: return ReservedWords [(int) filesym]; + case array_type: return ReservedWords [(int) arraysym]; + case strict_array_type: return ReservedWords [(int) strictarraysym]; + case unboxed_array_type:return ReservedWords [(int) unboxedarraysym]; + case world_type: return ReservedWords [(int) worldsym]; + case procid_type: return ReservedWords [(int) procidsym]; + case redid_type: return ReservedWords [(int) redidsym]; + case fun_type: return ReservedWords [(int) applysym]; + case list_type: return ListId -> ident_name; + case tuple_type: return TupleId -> ident_name; +#ifdef CLEAN2 + case dynamic_type: return DynamicId -> ident_name; +#endif + default: return ReservedWords [errorsym]; + } + +} /* ConvertSymbolKindToString */ + +static void PrintString (char * string, File file, int length, int * const max_length_p) +{ + if (*max_length_p >= length) + { char del = string [length]; + + *max_length_p -= length; + + if (del != '\0') + { string [length] = '\0'; + FPutS (string, file); + string [length] = del; + } + else + FPutS (string, file); + } + else if (*max_length_p >= 0) + { *max_length_p = -1; + FPutS ("(...)", file); + } + + } /* PrintString */ + +static void PrintChar (char c, File file, int * const max_length_p) +{ + if (*max_length_p > 0) + { --*max_length_p; + FPutC (c, file); + } + else if (*max_length_p == 0) + { *max_length_p = -1; + FPutS ("(...)", file); + } + +} /* PrintChar */ + +static char *PrintTypesOfSymbol (char *type_repr, File file, ModuleInfo module_info, int * const max_length_p); + +static char *FindTypeName (int type_number, TypeConversionTable types) +{ + TypeConversionTable next_type; + + for (next_type = types; next_type; next_type = next_type -> tct_next) + { if (next_type -> tct_number == type_number) + return next_type -> tct_type_symbol -> sdef_ident ->ident_name; + } + Assume (False, "checksupport", "FindTypeName"); + return ""; + +} /* FindTypeName */ + +static char *PrintArgumentsOfType (char *type_repr, File file, ModuleInfo module_info, int * const max_length_p) +{ + for (; ; ++type_repr) + { type_repr = PrintTypesOfSymbol (type_repr,file, module_info, max_length_p); + if (*type_repr == cTypeLastArg) + break; + else + PrintChar ('(', file, max_length_p); + } + return ++type_repr; + +} /* PrintArgumentsOfType */ + +static void PrintName (char *name, char *name_end, unsigned line_nr, File file) +{ + if (*name == '_') + { char *name_tail; + + for (name_tail = name + 1; name_tail != name_end; name_tail++) + if (isdigit (*name_tail)) + break; + + if (strncmp (name, kCasePrefix, name_tail - name) == 0) + FPutS ("<case expression>", file); + else if (strncmp (name, kLambdaPrefix, name_tail - name) == 0) + FPutS ("<lambda expression>", file); + else if (strncmp (name, kListGeneratorPrefix, name_tail - name) == 0) + FPutS ("<list comprehension>", file); + else if (strncmp (name, kArrayGeneratorPrefix, name_tail - name) == 0) + FPutS ("<array comprehension>", file); + else + { FPutS (name, file); + return; + } + FPrintF (file, " [line: %u]", line_nr); + } + else + { for (; name != name_end; name++) + { if (*name != '.') + { +/* if (*name == ':') + FPutC (' ', file); + else +*/ FPutC (*name, file); + } + } + } + +} /* PrintName */ + +static char *PrintTypesOfSymbol (char *type_repr, File file, ModuleInfo module_info, int * const max_length_p) +{ + char first_char = * type_repr; + if (islower (first_char)) + { if (first_char == 'l') + { PrintChar ('[', file, max_length_p); + if (*(++type_repr) == cTypeFirstArg) + type_repr = PrintArgumentsOfType (++type_repr, file, module_info, max_length_p); + PrintChar (']', file, max_length_p); + return type_repr; + } + else if (first_char == 't') + { int tuparity; + + ++type_repr; + + Assume (isdigit (*type_repr),"checksupport","PrintTypesOfSymbol"); + tuparity = strtol (type_repr, & type_repr, 10); + + PrintChar ('(', file, max_length_p); + + if (*type_repr == cTypeFirstArg) + { type_repr = PrintArgumentsOfType (++type_repr, file, module_info, max_length_p); + PrintChar (')', file, max_length_p); + } + else + { for (; tuparity>1; tuparity--) + PrintString ("_,", file, 2, max_length_p); + PrintString ("_)", file, 2, max_length_p); + } + + return type_repr; + } + else if (first_char == 'a') + { PrintChar ('{', file, max_length_p); + if (*(++type_repr) == cTypeFirstArg) + type_repr = PrintArgumentsOfType (++type_repr, file, module_info, max_length_p); + PrintChar ('}', file, max_length_p); + return type_repr; + } + else if (first_char == 'd') + { PrintString ("<default>", file, 9, max_length_p); + return ++type_repr; + } + else if (first_char == 'h') + { PrintString ("-> (", file, 4, max_length_p); + ++type_repr; + if (*type_repr==cTypeFirstArg) + type_repr = PrintArgumentsOfType (type_repr+1, file, module_info, max_length_p); + + PrintChar (')', file, max_length_p); + return type_repr; + } + else if (first_char == 'u') + { int type_number; + char *type_name; + + ++type_repr; + + Assume (isdigit (*type_repr),"checksupport","PrintTypesOfSymbol"); + type_number = strtol (type_repr, & type_repr, 10); + + type_name = FindTypeName (type_number, module_info -> mi_type_table); + + PrintString (type_name, file, strlen (type_name), max_length_p); + + if (*type_repr == cTypeFirstArg) + { PrintChar ('(', file, max_length_p); + type_repr = PrintArgumentsOfType (++type_repr, file, module_info, max_length_p); + PrintChar (')', file, max_length_p); + } + + return type_repr; + } + else + { int symbkind; + char *symbol_string; + for (symbkind = int_type; symbkind < Nr_Of_Basic_Types; symbkind++) + { if (BasicTypeIds [symbkind] == first_char) + break; + } + + Assume (symbkind < Nr_Of_Basic_Types,"checksupport","PrintTypesOfSymbol"); + symbol_string = ConvertSymbolKindToString ((SymbKind) symbkind); + + PrintString (symbol_string, file, strlen (symbol_string), max_length_p); + return ++type_repr; + } + } + else if (first_char == '!') + { PrintString ("{!", file, 2, max_length_p); + if (*(++type_repr) == cTypeFirstArg) + type_repr = PrintArgumentsOfType (++type_repr, file, module_info, max_length_p); + PrintChar ('}', file, max_length_p); + return type_repr; + } + else if (first_char == '#') + { PrintString ("{#", file, 2, max_length_p); + if (*(++type_repr) == cTypeFirstArg) + type_repr = PrintArgumentsOfType (++type_repr, file, module_info, max_length_p); + PrintChar ('}', file, max_length_p); + return type_repr; + } + else if (first_char == cTypeFirstArg) + { char *type_end; + for (type_end = ++type_repr; *type_end != cTypeLastArg; type_end++) + ; + + PrintString (type_repr, file, type_end - type_repr, max_length_p); + + return ++type_end; + } + else + { char *type_end; + for (type_end = type_repr; *type_end != cTypeDelimiter && *type_end != '\0' && *type_end != cTypeFirstArg && *type_end != cTypeLastArg; type_end++) + if (*type_end == '.') + type_end++; + + PrintString (type_repr, file, type_end - type_repr, max_length_p); + + if (*type_end == cTypeFirstArg) + { PrintChar ('(', file, max_length_p); + type_end = PrintArgumentsOfType (++type_end, file, module_info, max_length_p); + PrintChar (')', file, max_length_p); + } + return type_end; + } + +} /* PrintTypesOfSymbol */ + +#define _ANALYSE_IDENT_ +#define MAX_SYMBOL_EXTENSION_SIZE 40 + +void PrintSymbolOfIdent (Ident sid, unsigned line_nr, File file) +{ + char *next_char,*name; + int print_length = MAX_SYMBOL_EXTENSION_SIZE; +#ifdef _ANALYSE_IDENT_ + + name = sid -> ident_name; + + if (*name == cTypeDelimiter) + { for (next_char = name + 1; *next_char == cTypeDelimiter; next_char++) + ; + if (*next_char == '\0') + { FPutS (name, file); + return; + } + else + next_char--; + } + else + { for (next_char = name; *next_char != cTypeDelimiter && *next_char != '\0'; next_char++) + if (*next_char == '.') + { next_char++; + if (*next_char == '\0') + break; + } + } + + PrintName (name, next_char, line_nr, file); + + if ((*next_char) == cTypeDelimiter && next_char[1] != '\0') + { next_char++; + + if (isdigit (* next_char)) + { char *end_name; + + for (end_name = next_char + 1; *end_name != cTypeDelimiter && *end_name != '\0'; end_name++) + ; + + if (line_nr > 0) + { FPrintF (file, " [line: %u]", line_nr); + if (*end_name == '\0') + return; + } + else + { FPutC (cTypeDelimiter, file); + + PrintName (next_char, end_name, line_nr, file); + + if (*end_name == '\0') + return; + } + + next_char = end_name + 1; + } + + FPutS (" (", file); + + next_char = PrintTypesOfSymbol (next_char, file, sid -> ident_mod_info, & print_length); + + for (; *next_char == cTypeDelimiter; ) + { FPutC (',', file); + next_char = PrintTypesOfSymbol (++next_char, file, sid -> ident_mod_info, & print_length); + } + + FPutC (')', file); + } + +#else + + FPutS (name, file); + +#endif +} + +void CheckWarningOrError2 (Bool error,char *msg1,char *msg2,char *msg3) +{ + StaticMessage (error,"%S","%s,%s %s",CurrentSymbol,msg1,msg2,msg3); +} + +void CheckError (char *msg1,char *msg2) +{ + StaticMessage (True,"%S","%s %s",CurrentSymbol,msg1,msg2); +} + +void CheckNodeError (char *msg1,char *msg2,NodeP node_p) +{ + if (node_p->node_line>=0){ + unsigned old_CurrentLine; + + old_CurrentLine=CurrentLine; + + CurrentLine=node_p->node_line; + StaticMessage (True,"%S","%s %s",CurrentSymbol,msg1,msg2); + + CurrentLine=old_CurrentLine; + } else + StaticMessage (True,"%S","%s %s",CurrentSymbol,msg1,msg2); +} + +void CheckNodeSymbolError (struct symbol *symbol,char *msg,NodeP node_p) +{ + if (node_p->node_line>=0){ + unsigned old_CurrentLine; + + old_CurrentLine=CurrentLine; + + CurrentLine=node_p->node_line; + StaticMessage (True,"%S","%S %s",CurrentSymbol,symbol,msg); + + CurrentLine=old_CurrentLine; + } else + StaticMessage (True,"%S","%S %s",CurrentSymbol,symbol,msg); +} + +void CheckSymbolError (struct symbol *symbol,char *msg) +{ + StaticMessage (True,"%S","%S %s",CurrentSymbol,symbol,msg); +} + +void CheckWarning (char *msg1,char *msg2) +{ + StaticMessage (False,"%S","%s %s",CurrentSymbol,msg1,msg2); +} + +void CheckWarningOrError (Bool error,char *msg1,char *msg2) +{ + StaticMessage (error,"%S","%s %s",CurrentSymbol,msg1,msg2); +} + +void CheckSymbolWarning (struct symbol *symbol,char *msg) +{ + StaticMessage (False,"%S","%S %s",CurrentSymbol,symbol,msg); +} + +void CheckSymbolWarningOrError (Bool error,struct symbol *symbol,char *msg) +{ + StaticMessage (error,"%S","%S %s",CurrentSymbol,symbol,msg); +} + +extern Ident TupleId; + +void TupleError (void) +{ + CheckError (TupleId->ident_name,Etuple); +} + diff --git a/backendC/CleanCompilerSources/checksupport.h b/backendC/CleanCompilerSources/checksupport.h new file mode 100644 index 0000000..bb70209 --- /dev/null +++ b/backendC/CleanCompilerSources/checksupport.h @@ -0,0 +1,39 @@ + +#define cTypeDelimiter ';' +#define cTypeFirstArg '<' +#define cTypeLastArg '>' + +extern char *ConvertSymbolKindToString (SymbKind skind); + +extern void CheckError (char *msg1,char *msg2); +extern void CheckNodeError (char *msg1,char *msg2,NodeP node_p); +extern void CheckNodeSymbolError (struct symbol *symbol,char *msg,NodeP node_p); +extern void CheckSymbolError (struct symbol *symbol,char *msg); +extern void CheckWarning (char *msg1,char *msg2); +extern void CheckSymbolWarning (struct symbol *symbol,char *msg); +extern void CheckWarningOrError (Bool error,char *msg1,char *msg2); +extern void CheckWarningOrError2 (Bool error,char *msg1,char *msg2,char *msg3); +extern void CheckSymbolWarningOrError (Bool error,struct symbol *symbol,char *msg); +extern void TupleError (void); + +extern char *Earity,*Enodeid3,*Ecyclicsyn,*Enodeid2,*EwrongdefS,*Einfix_imp_def, + *EImplandDef1,*EImplandDef5; + +extern unsigned RuleCount,TypeSymbolCount; +extern SymbDef StackTop; + +#define PushOnDepStack(sdef) \ + sdef->sdef_parent=StackTop; \ + StackTop=sdef + +#define PopFromDepStack(sdef) \ + sdef=StackTop; \ + StackTop=sdef->sdef_parent; \ + sdef->sdef_parent=NULL + +#define IsOnDepStack(sdef) ((sdef)->sdef_parent!=NULL) + +#define NameOfSymbol(symb) ((symb)->symb_def ->sdef_ident->ident_name) + +extern void PrintSymbolOfIdent (Ident sid,unsigned line_nr,File file); + diff --git a/backendC/CleanCompilerSources/checktypedefs.h b/backendC/CleanCompilerSources/checktypedefs.h new file mode 100644 index 0000000..1ad34b3 --- /dev/null +++ b/backendC/CleanCompilerSources/checktypedefs.h @@ -0,0 +1,83 @@ +/* + + Version 1.0 10/06/1994 + + Author: Sjaak Smetsers + +*/ + +/* + global type defintions +*/ + +/* LAST +typedef enum +{ + AlgebraicType, SynonymType, FunctionType, ClassType + +} TypeDefKind; + +typedef struct instance_list +{ + SymbDef il_symbol; + unsigned long il_basic_instances; + struct instance_list * il_next; + +} * InstanceList; +*/ + +typedef enum +{ AlgebraicType, SynonymType, FunctionType, ClassType +} TypeDefKind; + + +/* + global variables +*/ + +extern TypeArgClass FunTypeClass, GeneralTypeClass; + +/* + global functions +*/ + +extern void CheckInstances (Instance instances); + +extern void AdjustFixitiesAndPrioritiesOfInstances (ClassInstance instances); + +extern void CheckTypesImpOfRules (ImpRules imp_rules); +extern void CheckTypesOfDefRules (RuleTypes def_rules); + +extern void CheckAbsTypes (AbsTypes abstr); +extern void CheckSynonymTypes (SynTypes syn_type); +extern void CheckTypes (Types types); +extern void CheckTypeVars (TypeVarList lhs_vars); +extern void CheckTypeClasses (ClassDefinition classes, Bool check_icl_file); + +extern Symbol MarkTypeClasses (ClassDefinition classes, Symbol all_symbols); +extern Symbol MarkTypeClassInstances (ClassInstance instances, Symbol all_symbols, char * def_mod_name); + +extern void CollectInstancesOfTypeClasses (ClassInstance instances); +extern void CheckInstancesInIclFile (ClassInstance instances); + +extern Symbol CheckInstancesInDclFile (ClassInstance instances, Symbol all_symbols, Bool is_def_mod); + +extern void CheckOverloadedRules (Overloaded overrules); + +extern void ExpandSymbolTypes (Symbol imp_symbols); + +extern void VerifyTypeDefinitions (SymbDef type1,SymbDef type2); +extern void VerifyRuleTypes (TypeAlts type1,TypeAlts type2, Bool check_exported_instances); +extern Bool VerifySymbDefs (SymbDef dcl_sdef, SymbDef icl_sdef); +extern Bool VerifyTypeGraphs (TypeNode root1,TypeNode root2); +extern Bool VerifyLhsOfTypes (FlatType lhs1, FlatType lhs2); + +extern void CheckExportedInstances (DefMod def); +extern void CollectBasicClassInstances (Symbol symbs, Bool is_icl_file); +extern void CollectBasicClassInstancesOfEmptyClasses (Symbol all_symbols); + +extern void VerifyTypeClasses (SymbDef dcl_symb, SymbDef icl_symb); +extern void VerifyInstances (ClassInstance dcl_instance, SymbDef icl_sdef); + +extern void InitCheckTypeDefs (void); +extern void ExitCheckTypeDefs (void); diff --git a/backendC/CleanCompilerSources/checktypedefs_2.c b/backendC/CleanCompilerSources/checktypedefs_2.c new file mode 100644 index 0000000..beb51ce --- /dev/null +++ b/backendC/CleanCompilerSources/checktypedefs_2.c @@ -0,0 +1,27 @@ +/* + Version 1.0 26/08/1994 + + Author: Sjaak Smetsers +*/ + +#pragma segment checktypedefs + +#define COMPLEX_ABSTYPES + +#include "types.t" +#include "syntaxtr.t" +#include "comsupport.h" +#include "scanner.h" +#include "comparser.h" +#include "buildtree.h" +#include "statesgen.h" +#include "settings.h" +#include "sizes.h" + +#include "checker.h" +#include "checksupport.h" +#include "checktypedefs.h" +#include "overloading.h" +#include "typechecker.h" + +TypeArgClass GeneralTypeClass,FunTypeClass; diff --git a/backendC/CleanCompilerSources/cmdline.h b/backendC/CleanCompilerSources/cmdline.h new file mode 100644 index 0000000..4d84b9c --- /dev/null +++ b/backendC/CleanCompilerSources/cmdline.h @@ -0,0 +1,19 @@ +/************************************************************************ + * * + * Concurrent Clean Simulator: cmdline.h * + * ============================================ * + * * + * * + * Author: Eric Nocker * + * At: Department of Computer Science * + * University of Nijmegen * + * Date: Januari 1991 * + * * + ***********************************************************************/ + + +extern Bool DoMainCommand (void); + +extern Bool InCommandInterpreter; + +/* END of cmdline.h */ diff --git a/backendC/CleanCompilerSources/cocl.c b/backendC/CleanCompilerSources/cocl.c new file mode 100644 index 0000000..b423459 --- /dev/null +++ b/backendC/CleanCompilerSources/cocl.c @@ -0,0 +1,349 @@ + +#include "compiledefines.h" +#include "system.h" +#include <ctype.h> +#include "comsupport.h" +#include "settings.h" +#include "compiler.h" +#include "version.h" + +#include "MAIN_CLM.d" + +/* for interrupts in comsupport.c */ +Bool InCommandInterpreter = False; + +static char usage[]= + "Usage: \'cocl [options] [-o file] file\'\n" + "Options: [-v] [-w] [-tc] [-d] [-sl] [-p] [-sa] [-lt] [-lset] [-lat] [-lattr]"; + +static void Usage (void) +{ + FPutS (usage, StdError); + FPutC ('\n', StdError); +} + +static Bool GetInt (char *s, int *i) +{ + int j; + char *cp; + + for (j = 0, cp = s; *cp; cp++) + { if (!isdigit (*cp)) + return False; + + j = (10 * j) + (*cp - '0'); + } + *i = j; + return True; +} + +static Bool SetStrictOption (char *opt) +{ int i; + + if (strcmp (opt, "w") == 0) + DoStrictWarning = False; + else if (strcmp (opt, "wa") == 0) + DoStrictAllWarning = True; + else if (strcmp (opt, "c") == 0) + DoStrictCheck = True; + else if (strcmp (opt, "sa") == 0) + StrictDoAnnots = True; + else if (opt[0] == 'd') + { if (GetInt (opt+1, &i)) + StrictDepth = i; + else + return False; + } + else + return False; + + return True; +} + +char *path_parameter; +#ifdef _SUN_ +extern int use_clean_system_files; +#endif + +#ifdef CLEAN2 + int StdOutReopened,StdErrorReopened; + + /* Windows: + static int myfreopen (char *fileName, char *mode, FILE *oldFile) + { + FILE *newFile; + + newFile=freopen (fileName,mode,oldFile); + if (newFile == NULL) + return False; + + return True; + } + + static int myfreopen (char *fileName, char *mode, FILE *oldFile) + { + FILE *newFile; + FILE tmpFile; + + newFile=fopen (fileName,mode); + if (newFile == NULL) + return False; + + tmpFile = *oldFile; + *oldFile = *newFile; + *newFile = tmpFile; + } + # define freopen myfreopen + */ +#endif + +#ifdef CLEAN2 +Bool ParseCommandArgs (int argc, char **argv, char **file_name_p, char **output_file_name_p) +#else +Bool CallCompiler (int argc, char **argv) +#endif +{ + char *fname,*output_file_name; + int i; +#ifdef OS2 + extern int window_application; + + window_application=0; +#endif + + fname = NULL; + output_file_name=NULL; + + path_parameter=NULL; +#ifdef _SUN_ + use_clean_system_files=0; +#endif + + DoWarning = True; + DoVerbose = False; + DoCode = True; + DoDebug = False; + DoStrictnessAnalysis = True; + DoStackLayout = True /* False */; + DoParallel = False; + DoShowAttributes = True; + DoListTypes = False; + DoListAllTypes = False; + DoListStrictTypes = False; + + DoStrictCheck = False; + DoStrictWarning = True; + DoStrictAllWarning = False; + + DoProfiling=False; + DoTimeProfiling=False; + DoReuseUniqueNodes=False; + + StrictDoAnnots = False; + StrictDepth = 10;/* 8; */ + + FunctionMayFailIsError = False; + NotUsedIsError = False; + FunctionNotUsedIsError = False; + +#ifdef CLEAN2 + StdErrorReopened = False; + StdOutReopened = False; +#endif + + for (i = 0; i < argc; i++){ + if (argv[i][0] == '-' || argv[i][0] == '+'){ + char *argv_i; + + argv_i=argv[i]; + + if (strcmp (argv_i, "-v") == 0) + DoVerbose = True; + else if (strcmp (argv_i, "-w") == 0){ + DoWarning = False; + DoStrictWarning = False; + } else if (strcmp (argv_i, "-d") == 0) + DoDebug = True; + else if (strcmp (argv_i, "-c") == 0) + DoCode = False; + else if (strcmp (argv_i, "-p") == 0) +#ifdef OS2 + window_application=1; +#else + DoParallel = True; +#endif +#ifdef _SUN_ + else if (strcmp (argv_i, "-csf")==0) + use_clean_system_files=1; +#endif + else if (strcmp (argv_i, "-sl") == 0) + DoStackLayout = True; + else if (strcmp (argv_i, "-sa") == 0) + DoStrictnessAnalysis = False; + else if (strcmp (argv_i, "-lattr") == 0) + DoShowAttributes = False; + else if (strcmp (argv_i, "-lt") == 0) + DoListTypes = True; + else if (strcmp (argv_i, "-lset") == 0) + DoListStrictTypes = True; + else if (strcmp (argv_i, "-lat") == 0) + DoListAllTypes = True; + else if (strcmp (argv_i,"-ou") == 0) + DoReuseUniqueNodes=True; + else if (strcmp (argv_i,"-pm") == 0) + DoProfiling=True; + else if (strcmp (argv_i,"-pt") == 0) + DoTimeProfiling=True; + else if (strcmp (argv_i,"-wmt") == 0) + WriteModificationTimes=True; + else if (strcmp (argv_i,"-emf") == 0) + FunctionMayFailIsError=True; + else if (strcmp (argv_i,"-enu") ==0) + NotUsedIsError=True; + else if (strcmp (argv_i,"-efnu") ==0) + FunctionNotUsedIsError=True; + else if (strcmp (argv_i,"-desc") ==0) + DoDescriptors=True; + else if (strcmp (argv_i,"-exl") ==0) + ExportLocalLabels=True; + else if (strncmp (argv_i, "-sa", 3) == 0){ + if (!SetStrictOption (argv[i]+3)){ + CmdError ("unknown flag %s", argv[i]); + Usage (); + return False; + } + } else if (strcmp (argv_i, "-o") == 0){ + if (++i < argc) + output_file_name = argv[i]; + else { + CmdError ("no output file given to option -o"); + return False; + } + } else if (strcmp (argv_i, "-P") == 0){ + if (++i < argc) + path_parameter = argv[i]; + else { + CmdError ("no path list given to option -P"); + return False; + } + } else if (strcmp (argv_i, "-RE") == 0){ + if (++i < argc){ + freopen (argv[i],"w",StdError); +#ifdef CLEAN2 + StdErrorReopened = True; +#endif + } else { + CmdError ("file name expected after -RE"); + return False; + } + } else if (strcmp (argv_i, "-RAE") == 0){ + if (++i < argc){ + freopen (argv[i],"aw",StdError); +#ifdef CLEAN2 + StdErrorReopened = True; +#endif + } else { + CmdError ("file name expected after -RAE"); + return False; + } + } else if (strcmp (argv_i, "-RO") == 0){ + if (++i < argc){ + freopen (argv[i],"w",StdOut); +#ifdef CLEAN2 + StdOutReopened = True; +#endif + } else { + CmdError ("file name expected after -RO"); + return False; + } + } else if (strcmp (argv_i, "-RAO") == 0){ + if (++i < argc){ + freopen (argv[i],"aw",StdOut); +#ifdef CLEAN2 + StdOutReopened = True; +#endif + } else { + CmdError ("file name expected after -RAO"); + return False; + } + } else { + CmdError ("unknown flag %s", argv_i); + Usage (); + return False; + } + } else { + /* process (non-flag) argument */ + if (fname){ + CmdError ("only one input file allowed"); + return False; + } + fname = argv[i]; + } + } + +#ifdef CLEAN2 + *file_name_p=fname; + *output_file_name_p=output_file_name; + + #ifdef _MAC_ + GetInitialPathList(); + #endif + + InitCompiler(); + + return True; + } + /* + Bool CallCompiler (int argc, char **argv) + { + char *fname, *output_file_name; + + if (!ParseCommandArgs (argc,argv,&fname,&output_file_name)) + return False; + */ +#else + + if (fname) + return Compile (fname,output_file_name); + else if (DoVerbose){ + FPrintF (StdOut, "\nConcurrent Clean Compiler (Version %d.%d)\n\n", VERSION / 1000, VERSION % 1000); + return True; + } else { + CmdError ("no input file given"); + Usage (); + return False; + } +} + +#if ! defined (MAIN_CLM) +int main (int argc, char *argv[]) +{ +#ifdef OS2 + { + int length; + extern char clean_lib_directory[]; + + length=strlen (argv[0]); + + if (length<=128){ + strcpy (clean_lib_directory,argv[0]); + + while (length>0){ + --length; + if (clean_lib_directory[length]=='\\'){ + clean_lib_directory[length]=0; + break; + } + } + } else + clean_lib_directory[0]='\0'; + } +#endif + if (CallCompiler (argc-1, & argv[1])) + return 0; + else + return 1; +} +#endif + +#endif diff --git a/backendC/CleanCompilerSources/codegen.c b/backendC/CleanCompilerSources/codegen.c new file mode 100644 index 0000000..e85fc5e --- /dev/null +++ b/backendC/CleanCompilerSources/codegen.c @@ -0,0 +1,1201 @@ + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) + +#define SHARE_UPDATE_CODE 0 /* also in codegen1.c */ +#define SELECTORS_FIRST 1 /* also in codegen2.c */ + +#include "system.h" +#include "syntaxtr.t" +#include "comsupport.h" +#include "checker.h" +#include "settings.h" +#include "sa.h" +#include "statesgen.h" +#include "typechecker.h" +#include "codegen_types.h" +#include "codegen1.h" +#include "codegen2.h" +#include "codegen3.h" +#include "instructions.h" +#include "codegen.h" +#include "optimisations.h" +#include "pattern_match.h" +#if SHARE_UPDATE_CODE +# include "result_state_database.h" +#endif +# if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION +#include "tuple_tail_recursion.h" +# endif + +static char *ECodeBlock = "incorrect number of output parameters"; + +static Parameters CalculateOffsetsOfParameters (Parameters params,States resultstates,int statearity,int *asp_p,int *bsp_p); + +static Parameters CalculateOffsetsOfParameter (Parameters param,StateS resultstate,int *asp_p,int *bsp_p) +{ + if (IsSimpleState (resultstate)){ + if (param->par_node_id!=NULL) + param->par_node_id->nid_state_=resultstate; + + if (resultstate.state_kind==OnB){ + if (param->par_node_id) + param->par_node_id->nid_b_index_=*bsp_p; + *bsp_p -= ObjectSizes [resultstate.state_object]; + } else { + if (param->par_node_id) + param->par_node_id->nid_a_index_=*asp_p; + *asp_p -= 1; + } + + return param->par_next; + } else { + if (resultstate.state_type==ArrayState){ + if (param->par_node_id) + param->par_node_id->nid_a_index_=*asp_p; + *asp_p -= 1; + + return param->par_next; + } else + return CalculateOffsetsOfParameters (param,resultstate.state_tuple_arguments,resultstate.state_arity,asp_p,bsp_p); + } +} + +static Parameters CalculateOffsetsOfParameters (Parameters params,States resultstates,int statearity,int *asp_p,int *bsp_p) +{ + int arity; + + for (arity=0; arity<statearity; arity++){ + if (params) + params = CalculateOffsetsOfParameter (params,resultstates[arity],asp_p,bsp_p); + else { + StaticMessage (True,CurrentAltLabel.lab_symbol->sdef_ident->ident_name,ECodeBlock); + break; + } + } + + return params; +} + +static void GenCodeBlock (CodeBlock code, int asp, int bsp, StateS resultstate) +{ + int newasp,newbsp,asize,bsize; + + DetermineSizeOfState (resultstate,&newasp,&newbsp); + + if (code->co_is_abc_code){ + GenInstructions (code->co_instr); + GenRtn (newasp, newbsp, resultstate); + } else { + Parameters nextparam; + + asize = newasp; + bsize = newbsp; + + if (IsSimpleState (resultstate)) + nextparam = CalculateOffsetsOfParameter (code->co_parout,resultstate,&asize,&bsize); + else { + switch (resultstate.state_type){ + case TupleState: + nextparam = CalculateOffsetsOfParameters (code->co_parout,resultstate.state_tuple_arguments, + resultstate.state_arity,&asize,&bsize); + break; + case RecordState: + nextparam = CalculateOffsetsOfParameters (code->co_parout,resultstate.state_record_arguments, + resultstate.state_arity,&asize,&bsize); + break; + case ArrayState: + if (code->co_parout->par_node_id!=NULL) + code->co_parout->par_node_id->nid_state_=resultstate; + code->co_parout->par_node_id->nid_a_index_=asize; + asize -= 1; + nextparam=code->co_parout->par_next; + break; + } + } + + if (nextparam) + StaticMessage (True,CurrentAltLabel.lab_symbol->sdef_ident->ident_name, ECodeBlock); + + GenParameters (True, code->co_parin, asp, bsp); + GenInstructions (code->co_instr); + GenOStackLayoutOfState (newasp, newbsp, resultstate); + GenParameters (False, code->co_parout, newasp, newbsp); + GenRtn (newasp, newbsp, resultstate); + } +} + +static Bool CodeRuleAlt (RuleAlts alt,int asp,int bsp,unsigned int altnr,StateS resultstate) +{ + struct label esclab; + struct esc esc; + struct ab_node_ids ab_node_ids; + + ab_node_ids.a_node_ids=NULL; + ab_node_ids.b_node_ids=NULL; +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + ab_node_ids.free_node_ids=NULL; +#endif + + esc.esc_asp=asp; + esc.esc_bsp=bsp; + esc.esc_label=&esclab; + + MakeSymbolLabel (&esclab,CurrentAltLabel.lab_mod,s_pref,CurrentAltLabel.lab_symbol,altnr+1); + + LhsComment (altnr, asp, bsp); + + bind_arguments (alt->alt_lhs_root->node_arguments,asp,bsp,&ab_node_ids); + MatchArgs (alt->alt_lhs_root->node_arguments,asp,bsp,asp,bsp,&ab_node_ids); + + if (alt->alt_kind==Contractum) + return generate_code_for_root_node (alt->alt_rhs_root,asp,bsp,&esc,alt->alt_rhs_defs,&resultstate,NULL,&ab_node_ids); + else { + GenCodeBlock (alt->alt_rhs_code,asp,bsp,resultstate); + return False; + } + +#ifdef _FRAMECHECK_ + if (MaxAFrameSize !=0 || MaxBFrameSize != 0 || OfferedAFrame != InitOfferedAFrame) + ErrorInCompiler ("codegen2.c", "CodeRuleAlt","inconsistent stack frames"); +#endif +} + +static void MoveArgumentFromAToB (StateS argstate,int index,int *current_asp_p,int *old_asp_p,int *dest_asp_p) +{ + if (IsSimpleState (argstate)){ + if (argstate.state_kind==OnB) + PushBasicFromAOnB ((ObjectKind)(argstate.state_object),*current_asp_p-index); + else if (argstate.state_kind!=Undefined) + PutInAFrames (index,dest_asp_p); + } else { + int arity; + + arity = argstate.state_arity; + + switch (argstate.state_type){ + case TupleState: + { + int locindex,i; + States argstates; + + argstates = argstate.state_tuple_arguments; + + if (*old_asp_p==index) + --*old_asp_p; + + *old_asp_p += arity; + locindex = *old_asp_p; + + for (i=arity-1; i>=0; --i) + MoveArgumentFromAToB (argstates [i],locindex-i,current_asp_p,old_asp_p,dest_asp_p); + break; + } + case RecordState: + { + int asize,bsize,a_index,element_n; + + DetermineSizeOfStates (arity,argstate.state_record_arguments,&asize,&bsize); + + if (*current_asp_p==index){ + GenReplRArgs (asize,bsize); + *current_asp_p += asize-1; + } else { + GenPushRArgs (*current_asp_p-index,asize,bsize); + *current_asp_p += asize; + } + + a_index=*current_asp_p; + for (element_n=asize-1; element_n>=0; --element_n) + PutInAFrames (a_index-element_n,dest_asp_p); + break; + } + case ArrayState: + GenPushArray (*current_asp_p-index); + *current_asp_p += 1; + PutInAFrames (*current_asp_p,dest_asp_p); + break; + } + } +} + +static void MoveStateArgumentsFromAToB (int n_states,StateP state_p,int index,int *current_asp_p,int *old_asp_p,int *dest_asp_p) +{ + int i; + + for (i=n_states-1; i>=0; --i) + MoveArgumentFromAToB (state_p[i],index-i,current_asp_p,old_asp_p,dest_asp_p); +} + +static void EvaluateArgument (StateS argstate,int *asp_p,int index) +{ + if (!IsLazyState (argstate)){ + switch (argstate.state_type){ + case SimpleState: + case RecordState: + case ArrayState: + GenJsrEval (*asp_p-index); + break; + case TupleState: + { + int i,arity,locasp; + + arity = argstate.state_arity; + + if (*asp_p-index > 0){ + GenPushA (*asp_p-index); + GenJsrEval (0); + GenReplArgs (arity,arity); + } else { + GenJsrEval (0); + GenReplArgs (arity,arity); + --*asp_p; + } + *asp_p += arity; + locasp = *asp_p; + + for (i=arity-1; i>=0; i--) + EvaluateArgument (argstate.state_tuple_arguments[i],asp_p,locasp-i); + break; + } + } + } +} + +static void EvaluateStateArguments (int n_states,StateP state_p,int *asp_p,int index) +{ + int i; + + for (i=n_states-1; i>=0; i--) + EvaluateArgument (state_p[i],asp_p,index-i); +} + +void EvaluateAndMoveArguments (int arity,StateP argstates,int *locasp_p,int *aselmts_p) +{ + int i,index; + + index=*locasp_p; + + for (i=arity-1; i>=0; i--) + EvaluateArgument (argstates[i],locasp_p, arity-i); + + for (i=arity-1; i>=0; i--) + MoveArgumentFromAToB (argstates[i],arity-i,locasp_p,&index,aselmts_p); +} + +void EvaluateAndMoveStateArguments (int state_arity,StateP states,int oldasp,int maxassize) +{ + int oldaframesize,arity,newasp,i; + + arity = oldasp; + newasp = 0; + + InitAStackConversions (arity + maxassize + 1,&oldaframesize); + + for (i=state_arity-1; i>=0; i--) + EvaluateArgument (states[i],&oldasp,state_arity-i); + + for (i=state_arity-1; i>=0; i--) + MoveArgumentFromAToB (states[i],state_arity-i,&oldasp,&arity,&newasp); + + GenAStackConversions (oldasp,newasp); + + FreeAFrameSpace (oldaframesize); +} + +static void EvaluateArgumentIfNecesary (StateS argstate,int *asp_p,int index,struct state *state_p) +{ + if (!IsLazyState (argstate)){ + switch (argstate.state_type){ + case SimpleState: + case RecordState: + case ArrayState: + if (IsLazyState (*state_p)) + GenJsrEval (*asp_p-index); + break; + case TupleState: + { + int i,arity,locasp; + + arity = argstate.state_arity; + + if (*asp_p-index > 0){ + GenPushA (*asp_p-index); + if (IsLazyState (*state_p)) + GenJsrEval (0); + GenReplArgs (arity,arity); + } else { + if (IsLazyState (*state_p)) + GenJsrEval (0); + GenReplArgs (arity,arity); + --*asp_p; + } + *asp_p += arity; + locasp = *asp_p; + + if (state_p->state_type==TupleState){ + for (i=arity-1; i>=0; i--) + EvaluateArgumentIfNecesary (argstate.state_tuple_arguments[i],asp_p,locasp-i,&state_p->state_tuple_arguments[i]); + } else + for (i=arity-1; i>=0; i--) + EvaluateArgument (argstate.state_tuple_arguments[i],asp_p,locasp-i); + break; + } + } + } +} + +static void EvaluateArgumentsForFunctionWithOneCall (int n_states,StateP arg_state_p,int *asp_p,int index,ArgP call_arg) +{ + if (call_arg==NULL) + EvaluateStateArguments (n_states,arg_state_p,asp_p,index); + else + if (n_states>0){ + EvaluateArgumentsForFunctionWithOneCall (n_states-1,arg_state_p+1,asp_p,index-1,call_arg->arg_next); + EvaluateArgumentIfNecesary (*arg_state_p,asp_p,index,state_of_node_or_node_id (call_arg->arg_node)); + } +} + +static void EvaluateAndMoveArgumentsForFunctionWithOneCall (StateS *const function_state_p,int oldasp,int maxassize,struct node *call_node) +{ + int oldaframesize,arity,newasp; + + arity = oldasp; + newasp = 0; + + InitAStackConversions (arity + maxassize + 1, &oldaframesize); + + EvaluateArgumentsForFunctionWithOneCall (arity,function_state_p,&oldasp,arity,call_node->node_arguments); + + MoveStateArgumentsFromAToB (arity,function_state_p,arity,&oldasp,&arity,&newasp); + + GenAStackConversions (oldasp,newasp); + + FreeAFrameSpace (oldaframesize); +} + +void EvalArgsEntry (StateS *const function_state_p,SymbDef rule_sdef,int maxasize,Label ea_lab,int n_result_nodes_on_a_stack) +{ + int asp; + + asp=rule_sdef->sdef_arity; + + GenOAStackLayout (asp+n_result_nodes_on_a_stack); + + if (DoTimeProfiling) + GenPN(); + GenLabelDefinition (ea_lab); + + if (rule_sdef->sdef_kind==IMPRULE && (rule_sdef->sdef_rule->rule_mark & RULE_LAZY_CALL_NODE_MASK)) + EvaluateAndMoveArgumentsForFunctionWithOneCall (function_state_p,asp,maxasize,rule_sdef->sdef_rule->rule_lazy_call_node); + else + EvaluateAndMoveStateArguments (asp,function_state_p,asp,maxasize); +} + +static void EvaluateArgumentsForFunctionWithUnboxedArguments (int n_states,StateP arg_state_p,int *asp_p,int index,ArgP call_arg) +{ + if (n_states==0) + return; + else { + if (call_arg->arg_state.state_type==SimpleState && call_arg->arg_state.state_kind==OnB) + EvaluateArgumentsForFunctionWithUnboxedArguments (n_states-1,arg_state_p+1,asp_p,index,call_arg->arg_next); + else { + EvaluateArgumentsForFunctionWithUnboxedArguments (n_states-1,arg_state_p+1,asp_p,index-1,call_arg->arg_next); + EvaluateArgumentIfNecesary (*arg_state_p,asp_p,index,!IsLazyState (call_arg->arg_state) ? &call_arg->arg_state : state_of_node_or_node_id (call_arg->arg_node)); + } + } +} + +static void MoveArgumentsToBStack (StateS src_state,StateS dest_state, + int a_index,int *current_asp_p,int *old_asp_p,int *dest_asp_p, + int b_index,int *current_bsp_p,int *dest_bsp_p) +{ + if (IsSimpleState (dest_state)){ + if (dest_state.state_kind==OnB){ + if (src_state.state_type==SimpleState && src_state.state_kind==OnB) + PutInBFrames (b_index,dest_bsp_p,ObjectSizes[dest_state.state_object]); + else { + PushBasicFromAOnB ((ObjectKind)(dest_state.state_object),*current_asp_p-a_index); + *current_bsp_p+=ObjectSizes[dest_state.state_object]; + PutInBFrames (*current_bsp_p,dest_bsp_p,ObjectSizes[dest_state.state_object]); + } + } else if (dest_state.state_kind!=Undefined) + PutInAFrames (a_index,dest_asp_p); + } else { + switch (dest_state.state_type){ + case TupleState: + { + int tuple_a_index,i,arity; + States dest_states; + + arity = dest_state.state_arity; + dest_states = dest_state.state_tuple_arguments; + + if (*old_asp_p==a_index) + --*old_asp_p; + + *old_asp_p += arity; + + tuple_a_index = *old_asp_p; + for (i=arity-1; i>=0; --i) + MoveArgumentsToBStack (LazyState,dest_states[i],tuple_a_index-i,current_asp_p,old_asp_p,dest_asp_p,-1000,current_bsp_p,dest_bsp_p); + break; + } + case RecordState: + { + int asize,bsize,record_a_index,element_n,arity; + + arity = dest_state.state_arity; + + DetermineSizeOfStates (arity,dest_state.state_record_arguments,&asize,&bsize); + + if (*current_asp_p==a_index){ + GenReplRArgs (asize,bsize); + *current_asp_p += asize-1; + } else { + GenPushRArgs (*current_asp_p-a_index,asize,bsize); + *current_asp_p += asize; + } + *current_bsp_p += bsize; + + record_a_index=*current_asp_p; + for (element_n=asize-1; element_n>=0; --element_n) + PutInAFrames (record_a_index-element_n,dest_asp_p); + + PutInBFrames (*current_bsp_p,dest_bsp_p,bsize); + break; + } + case ArrayState: + if (src_state.state_type==ArrayState) + PutInAFrames (a_index,dest_asp_p); + else { + GenPushArray (*current_asp_p-a_index); + ++*current_asp_p; + PutInAFrames (*current_asp_p,dest_asp_p); + } + break; + } + } +} + +static void MoveArgumentsForFunctionWithUnboxedArguments (int n_states,StateP state_p,ArgP call_arg, + int a_index,int *current_asp_p,int *old_asp_p,int *dest_asp_p, + int b_index,int *current_bsp_p,int *dest_bsp_p) +{ + if (n_states==0) + return; + else { + int next_a_index,next_b_index; + + if (call_arg->arg_state.state_type==SimpleState && call_arg->arg_state.state_kind==OnB){ + next_a_index=a_index; + next_b_index=b_index-ObjectSizes[call_arg->arg_state.state_object]; + } else { + next_a_index=a_index-1; + next_b_index=b_index; + } + MoveArgumentsForFunctionWithUnboxedArguments (n_states-1,state_p+1,call_arg->arg_next, + next_a_index,current_asp_p,old_asp_p,dest_asp_p, + next_b_index,current_bsp_p,dest_bsp_p); + MoveArgumentsToBStack (call_arg->arg_state,*state_p,a_index,current_asp_p,old_asp_p,dest_asp_p,b_index,current_bsp_p,dest_bsp_p); + } +} + +static void EvalArgsEntryUnboxed (ImpRuleP rule_p,SymbDef rule_sdef,int strict_a_size,int strict_b_size,int maxasize,Label ea_lab,int n_result_nodes_on_a_stack) +{ + int args_a_size,args_b_size,old_a_frame_size,old_b_frame_size,init_a_stack_size; + int old_asp,old_bsp,new_asp,new_bsp; + StateP function_state_p; + NodeP call_node_p; + + function_state_p=rule_p->rule_state_p; + call_node_p=rule_p->rule_lazy_call_node; + + DetermineSizeOfArguments (call_node_p->node_arguments,&args_a_size,&args_b_size); + + init_a_stack_size=args_a_size + n_result_nodes_on_a_stack; + GenOStackLayout (init_a_stack_size,args_b_size,call_node_p->node_arguments); + + if (DoTimeProfiling) + GenPN(); + GenLabelDefinition (ea_lab); + + InitStackConversions (init_a_stack_size+maxasize+1,strict_b_size+1,&old_a_frame_size,&old_b_frame_size); + + old_asp=args_a_size; + old_bsp=args_b_size; + EvaluateArgumentsForFunctionWithUnboxedArguments (rule_sdef->sdef_arity,function_state_p,&old_asp,args_a_size,call_node_p->node_arguments); + + new_asp=0; + new_bsp=0; + MoveArgumentsForFunctionWithUnboxedArguments (rule_sdef->sdef_arity,function_state_p,call_node_p->node_arguments, + args_a_size,&old_asp,&args_a_size,&new_asp,args_b_size,&old_bsp,&new_bsp); + + GenAStackConversions (old_asp,new_asp); + GenBStackConversions (old_bsp,new_bsp); + + FreeAFrameSpace (old_a_frame_size); + FreeBFrameSpace (old_b_frame_size); +} + +#if TAIL_CALL_MODULO_CONS_OPTIMIZATION +int tail_call_modulo_cons; +#endif +#if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION +int tail_call_modulo_tuple_cons; +unsigned long global_same_select_vector; +#endif +#if OPTIMIZE_LAZY_TUPLE_RECURSION +int lazy_tuple_recursion=0; +#endif + +#if GENERATE_CODE_AGAIN +int call_code_generator_again; +#endif + +int function_called_only_curried_or_lazy_with_one_return=0; + +#if 0 +# include "dbprint.h" +#endif + +static void CodeRule (ImpRuleP rule) +{ + Bool jmp_to_eval_args_entry,root_node_needed; + int asize,bsize,maxasize,a_stack_size_of_strict_entry; + StateS resultstate; + SymbDef rule_sdef; + LabDef ea_lab; + int init_a_stack_top,init_b_stack_top,rule_may_fail; + +# if 0 + PrintImpRule (rule,4,StdOut); +# endif + + CurrentSymbol=rule->rule_root->node_symbol; + CurrentLine=rule->rule_alts->alt_line; + + resultstate = rule->rule_root->node_state; + rule_sdef = CurrentSymbol->symb_def; + + ConvertSymbolToLabel (&CurrentAltLabel,rule_sdef); + + if (rule_sdef->sdef_exported){ + GenExportStrictAndEaEntry (rule_sdef); + } else if (!(rule_sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK | SDEF_USED_STRICTLY_MASK))) + return; + + GenFunctionDescriptorAndExportNodeAndDescriptor (rule_sdef); + + if (DoTimeProfiling) + GenPB (rule_sdef->sdef_ident->ident_name); + + if (rule_sdef->sdef_exported && rule_sdef->sdef_calledwithrootnode && ExpectsResultNode (resultstate)) + MakeSymbolLabel (&ea_lab,CurrentModule,ea_pref,rule_sdef,0); + else + MakeSymbolLabel (&ea_lab,NULL,ea_pref,rule_sdef,0); + + asize = 0; + bsize = 0; + maxasize = 0; + AddStateSizesAndMaxFrameSizesOfArguments (rule->rule_root->node_arguments,&maxasize,&asize,&bsize); + + function_called_only_curried_or_lazy_with_one_return=0; + + if (!(rule_sdef->sdef_mark & SDEF_USED_STRICTLY_MASK) && + ( (rule_sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK))==SDEF_USED_CURRIED_MASK + || (rule_sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK))==SDEF_USED_LAZILY_MASK) + && !rule_sdef->sdef_returnsnode && rule->rule_alts->alt_kind==Contractum && !(rule->rule_mark & RULE_CAF_MASK)) + { + NodeP node_p; + + node_p=rule->rule_alts->alt_rhs_root; + + while (node_p->node_kind==PushNode || node_p->node_kind==SwitchNode){ + if (node_p->node_kind==PushNode) + node_p=node_p->node_arguments->arg_next->arg_node; + else + if (node_p->node_arguments->arg_next==NULL) + node_p=node_p->node_arguments->arg_node->node_arguments->arg_node; + else + break; + } + + if (node_p->node_kind==NormalNode){ + if (node_p->node_symbol->symb_kind==tuple_symb || + (node_p->node_symbol->symb_kind==definition && node_p->node_symbol->symb_def->sdef_kind==RECORDTYPE) || + (unsigned)(node_p->node_symbol->symb_kind-int_denot) <= (unsigned)(real_denot-int_denot)) + function_called_only_curried_or_lazy_with_one_return=1; + } else { + if (node_p->node_kind==SelectorNode || node_p->node_kind==UpdateNode) + function_called_only_curried_or_lazy_with_one_return=1; + } + } + + if (rule_sdef->sdef_mark & SDEF_USED_CURRIED_MASK) + ApplyEntry (rule->rule_state_p,rule_sdef->sdef_arity,&ea_lab,!(rule_sdef->sdef_mark & SDEF_USED_LAZILY_MASK)); + + if (rule_sdef->sdef_mark & SDEF_USED_LAZILY_MASK) + if (rule->rule_mark & RULE_UNBOXED_LAZY_CALL){ + int args_a_size,args_b_size; + + DetermineSizeOfArguments (rule->rule_lazy_call_node->node_arguments,&args_a_size,&args_b_size); + jmp_to_eval_args_entry = NodeEntryUnboxed (rule->rule_state_p,rule->rule_lazy_call_node,args_a_size,args_b_size,&ea_lab,rule_sdef); + } else + jmp_to_eval_args_entry = NodeEntry (rule->rule_state_p,rule_sdef->sdef_arity,&ea_lab,rule_sdef); + else + jmp_to_eval_args_entry = False; + + init_a_stack_top = asize; + init_b_stack_top = bsize; + + root_node_needed = ! (IsOnBStack (resultstate) || + (IsSimpleState (resultstate) && resultstate.state_kind==StrictRedirection)); + + a_stack_size_of_strict_entry=root_node_needed ? init_a_stack_top+1 : init_a_stack_top; + + CurrentAltLabel.lab_pref = s_pref; + CurrentAltLabel.lab_post = 0; + + if (rule_sdef->sdef_exported){ + Bool ext_label_needed; + LabDef extlab; + + extlab = CurrentAltLabel; + extlab.lab_post = 0; + CurrentAltLabel.lab_mod = NULL; + + if (rule_sdef->sdef_dcl_icl!=NULL){ + switch (rule_sdef->sdef_dcl_icl->sdef_kind){ + case DEFRULE: + case SYSRULE: + ext_label_needed = ConvertExternalToInternalCall (rule_sdef->sdef_arity, + rule_sdef->sdef_dcl_icl->sdef_rule_type->rule_type_state_p,rule->rule_state_p, + jmp_to_eval_args_entry,init_a_stack_top, init_b_stack_top, &ea_lab, &extlab, root_node_needed); + break; + case INSTANCE: + ext_label_needed=True; + break; + default: + ErrorInCompiler ("codegen.c","CodeRule","unknown kind of rewrite rule"); + break; + } + } else + ext_label_needed=True; + + EvalArgsEntry (rule->rule_state_p,rule_sdef,maxasize,&ea_lab,root_node_needed ? 1 : 0); + + if (ext_label_needed){ + GenOStackLayoutOfStates (a_stack_size_of_strict_entry,init_b_stack_top,rule_sdef->sdef_arity,rule->rule_state_p); + GenLabelDefinition (&extlab); + } + } else if (rule_sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK)) + if (rule->rule_mark & RULE_UNBOXED_LAZY_CALL) + EvalArgsEntryUnboxed (rule,rule_sdef,asize,bsize,maxasize,&ea_lab,root_node_needed ? 1 : 0); + else + EvalArgsEntry (rule->rule_state_p,rule_sdef,maxasize,&ea_lab,root_node_needed ? 1 : 0); + + if ((rule->rule_mark & RULE_CAF_MASK) && ! (rule->rule_alts->alt_rhs_root->node_kind==NormalNode && + (unsigned)(rule->rule_alts->alt_rhs_root->node_symbol->symb_kind-int_denot) <= (unsigned)(real_denot-int_denot))) + { + LabDef caf_label,local_label; + int a_size,b_size; + + GenOStackLayoutOfStates (a_stack_size_of_strict_entry,init_b_stack_top,rule_sdef->sdef_arity,rule->rule_state_p); + GenLabelDefinition (&CurrentAltLabel); + + MakeSymbolLabel (&caf_label,NULL,caf_pref,rule_sdef,0); + MakeLabel (&local_label,m_symb,NewLabelNr++,no_pref); + + DetermineSizeOfState (resultstate,&a_size,&b_size); + + GenTestCaf (&caf_label); + GenJmpFalse (&local_label); + + GenPushCaf (&caf_label,a_size,b_size); + + if (root_node_needed){ + GenFillFromA (0,1,NormalFill); + GenPopA (1); + } + GenRtn (a_size,b_size,resultstate); + + GenCaf (&caf_label,a_size,b_size); + + GenLabelDefinition (&local_label); + + ++CurrentAltLabel.lab_post; + + GenDStackLayoutOfStates (a_stack_size_of_strict_entry,init_b_stack_top,rule_sdef->sdef_arity,rule->rule_state_p); + GenJsr (&CurrentAltLabel); + GenOStackLayoutOfState (a_size,b_size,resultstate); + + GenFillCaf (&caf_label,a_size,b_size); + GenRtn (a_size,b_size,resultstate); + } + +#if 0 + if (rule_sdef->sdef_exported || rule_sdef->sdef_mark & SDEF_USED_STRICTLY_MASK || rule->rule_mark & RULE_CAF_MASK){ +#endif + + if (!function_called_only_curried_or_lazy_with_one_return){ + GenOStackLayoutOfStates (a_stack_size_of_strict_entry,init_b_stack_top,rule_sdef->sdef_arity,rule->rule_state_p); + GenLabelDefinition (&CurrentAltLabel); + } + +#if 0 + } +#endif + +#if GENERATE_CODE_AGAIN + call_code_generator_again=0; + + { + struct saved_node_id_ref_counts *saved_node_id_ref_counts_p; + struct saved_case_node_id_ref_counts *saved_case_node_id_ref_counts_p; + +# if TAIL_CALL_MODULO_CONS_OPTIMIZATION + extern int does_tail_call_modulo_cons (NodeP node_p,NodeDefP node_defs); + + if (OptimizeTailCallModuloCons && rule->rule_alts->alt_kind==Contractum){ + tail_call_modulo_cons=does_tail_call_modulo_cons (rule->rule_alts->alt_rhs_root,rule->rule_alts->alt_rhs_defs); + + if (tail_call_modulo_cons){ + if (ListOptimizations) + printf ("Optimize tail call modulo cons of %s\n",rule_sdef->sdef_ident->ident_name); + call_code_generator_again=1; + } + } else + tail_call_modulo_cons=0; +# endif + +# if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION + tail_call_modulo_tuple_cons=0; + if (rule->rule_alts->alt_kind==Contractum){ + int has_tuple_tail_call; + + global_same_select_vector=(unsigned long)-1l; + has_tuple_tail_call=0; + + if (roots_are_tuples_or_calls_to_this_function_and_compute_same_select_vector (rule->rule_alts->alt_rhs_root,rule->rule_alts->alt_rhs_defs,rule_sdef,&global_same_select_vector,&has_tuple_tail_call) && + has_tuple_tail_call!=0) + { + /* printf ("%x\n",global_same_select_vector); */ + + rule->rule_mark |= RULE_CALL_VIA_LAZY_SELECTIONS_ONLY; + tail_call_modulo_tuple_cons=1; + } + } +# endif + +# if OPTIMIZE_LAZY_TUPLE_RECURSION + if (rule->rule_mark & RULE_CALL_VIA_LAZY_SELECTIONS_ONLY) + call_code_generator_again=1; +# endif + + if (call_code_generator_again){ + struct saved_case_node_id_ref_counts **saved_case_node_id_ref_counts_h; + + saved_node_id_ref_counts_p=save_lhs_node_id_ref_counts (rule->rule_alts->alt_lhs_root,NULL); + saved_case_node_id_ref_counts_h=&saved_case_node_id_ref_counts_p; + saved_case_node_id_ref_counts_p=NULL; + saved_node_id_ref_counts_p=save_rhs_node_id_ref_counts (rule->rule_alts->alt_rhs_root,rule->rule_alts->alt_rhs_defs, + saved_node_id_ref_counts_p,&saved_case_node_id_ref_counts_h); + } +#endif + + rule_may_fail=CodeRuleAlt (rule->rule_alts,init_a_stack_top,init_b_stack_top,CurrentAltLabel.lab_post,resultstate); + + if (function_called_only_curried_or_lazy_with_one_return){ + StateS *function_state_p; + + function_state_p=rule->rule_state_p; + + if (IsSimpleState (function_state_p[-1])){ + if (function_state_p[-1].state_kind==OnB){ + if (rule_sdef->sdef_mark & SDEF_USED_LAZILY_MASK) + FillBasicFromB (function_state_p[-1].state_object, 0, 0, ReleaseAndFill); + else + BuildBasicFromB (function_state_p[-1].state_object,0); + + GenPopB (ObjectSizes [function_state_p[-1].state_object]); + GenRtn (1,0,OnAState); + } + } else { + int asize, bsize; + + DetermineSizeOfState (function_state_p[-1], &asize, &bsize); + + if (rule_sdef->sdef_mark & SDEF_USED_LAZILY_MASK){ + switch (function_state_p[-1].state_type){ + case TupleState: + BuildTuple (asize,bsize,asize,bsize,function_state_p[-1].state_arity, + function_state_p[-1].state_tuple_arguments,asize, bsize, 0, ReleaseAndFill,False); + break; + case RecordState: + BuildRecord (function_state_p[-1].state_record_symbol,asize, bsize, asize, bsize, + asize, bsize, 0, ReleaseAndFill, False); + break; + case ArrayState: + GenFillArray (0, 1, ReleaseAndFill); + break; + } + GenPopA (asize); + } else { + switch (function_state_p[-1].state_type){ + case TupleState: + BuildTuple (asize, bsize, asize, bsize, function_state_p[-1].state_arity, + function_state_p[-1].state_tuple_arguments,asize,bsize, asize,NormalFill,True); + break; + case RecordState: + BuildRecord (function_state_p[-1].state_record_symbol,asize, bsize, asize, bsize, + asize, bsize, asize, NormalFill,True); + break; + case ArrayState: + GenBuildArray (0); + break; + } +#if UPDATE_POP + GenUpdatePopA (0, asize); +#else + GenUpdateA (0, asize); + GenPopA (asize); +#endif + } + + GenPopB (bsize); + GenRtn (1,0,OnAState); + } + + function_called_only_curried_or_lazy_with_one_return=0; + } + + if (rule_may_fail){ + ++CurrentAltLabel.lab_post; + + CurrentLine=rule->rule_alts->alt_line; + StaticMessage (FunctionMayFailIsError, "%S", "function may fail", CurrentSymbol); + + MatchError (asize,bsize,rule_sdef,root_node_needed,0); + } + +#if GENERATE_CODE_AGAIN + if (call_code_generator_again) + restore_node_id_ref_counts (saved_node_id_ref_counts_p,saved_case_node_id_ref_counts_p); + } +#endif + +#if TAIL_CALL_MODULO_CONS_OPTIMIZATION + if (tail_call_modulo_cons) + tail_call_modulo_cons=2; +#endif +#if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION + if (tail_call_modulo_tuple_cons) + tail_call_modulo_tuple_cons=2; +#endif + +#if GENERATE_CODE_AGAIN + if ( +# if TAIL_CALL_MODULO_CONS_OPTIMIZATION + tail_call_modulo_cons || +# endif + (rule->rule_mark & RULE_CALL_VIA_LAZY_SELECTIONS_ONLY)){ +# if 0 + PrintImpRule (rule,4,StdOut); +# endif + call_code_generator_again=0; + + CurrentAltLabel.lab_post=2; + +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if (rule->rule_mark & RULE_CALL_VIA_LAZY_SELECTIONS_ONLY){ + int tuple_result_arity; + StateS result_state_struct[1]; +#if SELECTORS_FIRST + LabDef reduce_error_label; +#endif + + tuple_result_arity=rule->rule_type->type_alt_rhs->type_node_arity; +#if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION + if (tail_call_modulo_tuple_cons){ + int i,n; + + n=tuple_result_arity; + for (i=0; i<n; ++i) + if (global_same_select_vector & (1<<i)) + --tuple_result_arity; + } +#endif + + GenFunctionDescriptorForLazyTupleRecursion (rule_sdef,tuple_result_arity); + + result_state_struct[0]=OnAState; + +#if SELECTORS_FIRST + { + LabDef d_lab,n_lab; + int a_size,b_size; + + ConvertSymbolToDandNLabel (&d_lab,&n_lab,rule_sdef); + + d_lab.lab_post = n_lab.lab_post = 3; + + if (rule->rule_mark & RULE_UNBOXED_LAZY_CALL){ + DetermineSizeOfArguments (rule->rule_lazy_call_node->node_arguments,&a_size,&b_size); + } else { + a_size=rule_sdef->sdef_arity; + b_size=0; + } + b_size+=a_size; + a_size=tuple_result_arity; + + if (b_size!=0) + GenNodeEntryDirectiveUnboxed (a_size,b_size,&d_lab,NULL); + else + GenNodeEntryDirective (a_size,&d_lab,NULL); + + GenOAStackLayout (0); + GenLabelDefinition (&n_lab); + GenDAStackLayout (0); + GenJmp (ReduceError); + + reduce_error_label=n_lab; + /* + reduce_error_label = CurrentAltLabel; + reduce_error_label.lab_pref="n"; + reduce_error_label.lab_post=3; + */ + ReduceError = &reduce_error_label; + } +#else + ReduceError = &empty_lab; +#endif + + ea_lab.lab_post=2; + + if (rule->rule_mark & RULE_UNBOXED_LAZY_CALL){ + int args_a_size,args_b_size; + + DetermineSizeOfArguments (rule->rule_lazy_call_node->node_arguments,&args_a_size,&args_b_size); + NodeEntryUnboxed (&result_state_struct[1],rule->rule_lazy_call_node,args_a_size + tuple_result_arity,args_b_size,&ea_lab,rule_sdef); + } else + NodeEntry (&result_state_struct[1],rule_sdef->sdef_arity + tuple_result_arity,&ea_lab,rule_sdef); + + if (DoParallel) + ReduceError = &reserve_lab; + else + ReduceError = &cycle_lab; + +#if SELECTORS_FIRST + if (rule_sdef->sdef_arity!=0){ + int n; + + for (n=tuple_result_arity; n!=0; --n) + GenPushA (tuple_result_arity-1); + + for (n=0; n<rule_sdef->sdef_arity; ++n) + GenUpdateA (n+tuple_result_arity+tuple_result_arity,n+tuple_result_arity); + + for (n=0; n<tuple_result_arity; ++n) + GenUpdateA (n,n+tuple_result_arity+rule_sdef->sdef_arity); + + GenPopA (tuple_result_arity); + } +#endif + + CurrentAltLabel.lab_pref = s_pref; + if (rule->rule_mark & RULE_UNBOXED_LAZY_CALL) + EvalArgsEntryUnboxed (rule,rule_sdef,asize,bsize,maxasize,&ea_lab,tuple_result_arity); + else + EvalArgsEntry (rule->rule_state_p,rule_sdef,maxasize,&ea_lab,tuple_result_arity); + + GenOStackLayoutOfStates (a_stack_size_of_strict_entry + tuple_result_arity,init_b_stack_top,rule_sdef->sdef_arity,rule->rule_state_p); + + init_a_stack_top += tuple_result_arity; + lazy_tuple_recursion=1; + } else +#endif + GenOStackLayoutOfStates (a_stack_size_of_strict_entry,init_b_stack_top,rule_sdef->sdef_arity,rule->rule_state_p); + + CurrentAltLabel.lab_pref = s_pref; + GenLabelDefinition (&CurrentAltLabel); + + if (CodeRuleAlt (rule->rule_alts,init_a_stack_top,init_b_stack_top,CurrentAltLabel.lab_post,resultstate)){ + ++CurrentAltLabel.lab_post; + + CurrentLine=rule->rule_alts->alt_line; + MatchError (asize,bsize,rule_sdef,root_node_needed,1); + } + +#if OPTIMIZE_LAZY_TUPLE_RECURSION + lazy_tuple_recursion=0; +#endif + } +#endif + + if (DoTimeProfiling) + GenPE(); +} + +void CodeGeneration (ImpMod imod, char *fname) +{ + if (! CompilerError){ + int DoStrictnessAnalysis_and_init_ok; + CurrentPhase = NULL; + +#if 0 + PrintRules (imod->im_rules); +#endif + + DetermineSharedAndAnnotatedNodes (imod->im_rules,&imod->im_symbols); + ExitOnInterrupt(); + + GenerateStatesForRecords (imod->im_symbols); + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + { + ImpRuleP rule_p; + + for_l (rule_p,imod->im_rules,rule_next) + transform_patterns_to_case_and_guard_nodes (rule_p->rule_alts); + } +#endif +#if 0 + PrintRules (imod->im_rules); +#endif + DoStrictnessAnalysis_and_init_ok = DoStrictnessAnalysis && init_strictness_analysis (imod); + + if (DoStrictnessAnalysis_and_init_ok){ + do_strictness_analysis(); + ExitOnInterrupt(); + } + + ExamineTypesAndLhsOfSymbols (imod->im_symbols); + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + { + ImpRuleP rule_p; + + for_l (rule_p,imod->im_rules,rule_next) + determine_failing_cases_and_adjust_ref_counts_of_rule (rule_p->rule_alts); + } +#endif + + optimise_strict_tuple_result_functions=DoStrictnessAnalysis; + + generate_states (imod->im_rules,True); + + if (DoStrictnessAnalysis_and_init_ok){ + ExitOnInterrupt(); + + finish_strictness_analysis(); + } + ExitOnInterrupt(); + + ListTypes (imod); + ExitOnInterrupt(); +#if 0 + PrintRules (imod->im_rules); +#endif + + optimise_strict_tuple_result_functions=0; + + OptimiseRules (imod->im_rules,imod->im_start); + ExitOnInterrupt(); +#if 0 + PrintRules (imod->im_rules); +#endif + if (DoCode){ + ImpRuleS *rule; + + Verbose ("Code generation"); + + if (!OpenABCFile (fname)){ + StaticMessage (True, "<open file>","Can't create abc file (disk full?)"); + return; + } + + InitFileInfo (imod); + + if (DoParallel) + ReduceError = &reserve_lab; + else + ReduceError = &cycle_lab; /* in sequential case we have no reservation mechanism */ + + GenDependencyList(); +#if IMPORT_OBJ_AND_LIB + { + struct string_list *sl; + + for_l (sl,imod->im_imported_objs,sl_next) + GenImpObj (sl->sl_string); + for_l (sl,imod->im_imported_libs,sl_next) + GenImpLib (sl->sl_string); + } +#endif + +#if WRITE_DCL_MODIFICATION_TIME + if (WriteModificationTimes){ + GenModuleDescriptor (imod->im_modification_time); + GenEndInfo(); + } else { + GenEndInfo(); + GenModuleDescriptor (imod->im_modification_time); + } +#else + GenEndInfo(); + GenModuleDescriptor(); +#endif + GenSystemImports(); + FileComment(); + ExitOnInterrupt(); + + ReadInlineCode (); + + CreateStackFrames(); + + ImportSymbols (imod->im_symbols); + + GenerateCodeForConstructorsAndRecords (imod->im_symbols); + + if (imod->im_start) + GenStart (imod->im_start); + ExitOnInterrupt (); + +#if SHARE_UPDATE_CODE + create_result_state_database (imod->im_rules); +#endif + + update_function_p=&first_update_function; + for_l (rule,imod->im_rules,rule_next) + if (rule->rule_root->node_symbol->symb_def->sdef_over_arity==0){ + CodeRule (rule); + + *update_function_p=NULL; + if (first_update_function){ + while (first_update_function){ + transform_patterns_to_case_and_guard_nodes (first_update_function->rule_alts); +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + determine_failing_cases_and_adjust_ref_counts_of_rule (first_update_function->rule_alts); +#endif + CodeRule (first_update_function); + + first_update_function=first_update_function->rule_next; + } + update_function_p=&first_update_function; + } + + ExitOnInterrupt (); + } + + GenerateCodeForLazyTupleSelectorEntries (LazyTupleSelectors); + GenerateCodeForLazyArrayFunctionEntries(); + + WriteLastNewlineToABCFile(); + + CloseABCFile (fname); +#ifdef _COMPSTATS_ + PrintCompStats(); +#endif + } + } +} diff --git a/backendC/CleanCompilerSources/codegen.h b/backendC/CleanCompilerSources/codegen.h new file mode 100644 index 0000000..7719a4d --- /dev/null +++ b/backendC/CleanCompilerSources/codegen.h @@ -0,0 +1,7 @@ + +void CodeGeneration (ImpMod imod, char *fname); +void EvalArgsEntry (StateS *const function_state_p,SymbDef rule_sdef,int maxasize,Label ea_lab,int n_result_nodes_on_a_stack); +void EvaluateAndMoveStateArguments (int state_arity,States states,int oldasp,int maxassize); +void EvaluateAndMoveArguments (int arity,StateP argstates,int *locasp_p,int *aselmts_p); + +extern int function_called_only_curried_or_lazy_with_one_return;
\ No newline at end of file diff --git a/backendC/CleanCompilerSources/codegen1.c b/backendC/CleanCompilerSources/codegen1.c new file mode 100644 index 0000000..869c679 --- /dev/null +++ b/backendC/CleanCompilerSources/codegen1.c @@ -0,0 +1,3738 @@ +/* + File: codegen1.c + Authors:Sjaak Smetsers & John van Groningen +*/ + +#pragma segment codegen1 + +#define SHARE_UPDATE_CODE 0 /* also in codegen.c */ +#define FREE_STRICT_LHS_TUPLE_ELEMENTS 1 /* also in codegen2.c */ +#define BIND_UNBOXED_LHS_TUPLE_AND_RECORD_ARGUMENTS_IN_BIND_ARGUMENTS 1 + +#include "system.h" + +#include "settings.h" +#include "syntaxtr.t" +#include "comsupport.h" +#include "sizes.h" +#include "checker.h" +#include "codegen_types.h" +#include "codegen1.h" +#include "sa.h" +#include "statesgen.h" +#include "transform.h" +#include "codegen.h" +#include "codegen2.h" +#include "codegen3.h" +#include "instructions.h" +#include "scanner.h" +#include "buildtree.h" +#include "pattern_match.h" +#if SHARE_UPDATE_CODE +# include "result_state_database.h" +#endif + +extern int VERSION; + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) + +#define RECORD_N_PREFIX c_pref +#define RECORD_D_PREFIX t_pref +#define CONSTRUCTOR_R_PREFIX k_pref + +static char c_pref[] = "c"; +static char t_pref[] = "t"; +static char k_pref[] = "k"; +static char r_pref[] = "r"; + +char no_pref[] = ""; +char d_pref[] = "d"; +char n_pref[] = "n"; + +char ea_pref[] = "ea"; +char l_pref[] = "l"; +char s_pref[] = "s"; + +char caf_pref[] = "c"; + +char glob_sel[] = "_S"; +char m_symb[] = "m"; + +#ifdef THUNK_LIFT_SELECTORS +char glob_selr[]= "_Sr"; +#endif + +char channel_code[] = "_channel_code"; +char hnf_reducer_code[] = "_hnf_reducer"; +char ext_hnf_reducer_code[] = "_HnfReducer"; +char ext_nf_reducer_code[] = "_NfReducer"; +char nf_reducer_code[] = "_nf_reducer"; + +static char loc_sel[] = "t"; + +/* + Each label is represented by 4 items, namely, a module name,a prefix (which is a string), the actual name and a postfix + (which is a number). Only the third item is always present; all the others are optional (their absence is indicated by resp. + 'NULL', 'no_pref' and 'no_num'). +*/ + +LabDef cycle_lab = {NULL, "", False, "_cycle_in_spine", 0}; +LabDef reserve_lab = {NULL, "", False, "_reserve", 0}; +LabDef type_error_lab = {NULL, "", False, "_type_error", 0}; +LabDef indirection_lab = {NULL, "", False, "_indirection", 0}; +LabDef ind_lab = {NULL, "", False, "_ind", 0}; +LabDef hnf_lab = {NULL, "", False, "_hnf", 0}; +LabDef cons_lab = {NULL, "", False, "_Cons", 0}; +LabDef nil_lab = {NULL, "", False, "_Nil", 0}; +LabDef tuple_lab = {NULL, "", False, "_Tuple", 0}; +LabDef empty_lab = {NULL, "", False, "_", 0}; +LabDef add_arg_lab = {NULL, "", False, "_add_arg", 0}; +LabDef match_error_lab = {NULL, "", False, "_match_error", 0}; +#ifdef CLEAN2 +LabDef select_with_dictionary_lab = {NULL, "", False, "_select_with_dictionary", 0}; +LabDef update_with_dictionary_lab = {NULL, "", False, "_update_with_dictionary", 0}; +#endif + +LabDef CurrentAltLabel; /* Containing the name of the next rule alternative */ +Label ReduceError; + + +static void error_in_function (char *m) +{ + ErrorInCompiler ("codegen1.c",m,""); +} + +void MakeLabel (Label lab, char *name, unsigned num, char *pref) +{ + lab->lab_issymbol = False; + lab->lab_name = name; + lab->lab_post = num; + lab->lab_pref = pref; +} + +void MakeSymbolLabel (Label lab, char *mod, char *pref,SymbDef sdef, unsigned num) +{ + lab->lab_mod = mod; + lab->lab_pref = pref; + lab->lab_issymbol = True; + lab->lab_symbol = sdef; + lab->lab_post = num; +} + +void ConvertSymbolToLabel (LabDef *slab,SymbDef sdef) +{ + char *modname; + + if (sdef->sdef_module==CurrentModule){ + if (sdef->sdef_exported) + modname = CurrentModule; + else + modname = NULL; + } else + modname = sdef->sdef_module; + + MakeSymbolLabel (slab,modname,no_pref,sdef, 0); +} + +void ConvertSymbolToDLabel (LabDef *slab,SymbDef sdef) +{ + char *modname; + + if (sdef->sdef_module==CurrentModule){ + if (sdef->sdef_exported) + modname = CurrentModule; + else + modname = NULL; + } else + modname = sdef->sdef_module; + + MakeSymbolLabel (slab,modname,d_pref,sdef,0); +} + +void ConvertSymbolToConstructorDLabel (LabDef *slab,SymbDef sdef) +{ + char *modname; + + if (!sdef->sdef_exported && sdef->sdef_module==CurrentModule && !ExportLocalLabels) + modname = NULL; + else + modname = sdef->sdef_module; + + MakeSymbolLabel (slab,modname,d_pref,sdef,0); +} + +void ConvertSymbolToDandNLabel (LabDef *d_lab,LabDef *n_lab,SymbDef sdef) +{ + char *modname; + + if (sdef->sdef_module==CurrentModule){ + if (sdef->sdef_exported) + modname = CurrentModule; + else + modname = NULL; + } else + modname = sdef->sdef_module; + + MakeSymbolLabel (d_lab,modname,d_pref,sdef,0); + + *n_lab = *d_lab; + n_lab->lab_pref = n_pref; +} + +void ConvertSymbolToConstructorDandNLabel (LabDef *d_lab,LabDef *n_lab,SymbDef sdef) +{ + char *modname; + + if (!sdef->sdef_exported && sdef->sdef_module==CurrentModule && !(ExportLocalLabels && (sdef->sdef_mark & SDEF_USED_CURRIED_MASK)!=0)) + modname = NULL; + else + modname = sdef->sdef_module; + + MakeSymbolLabel (d_lab,modname,d_pref,sdef,0); + + *n_lab = *d_lab; + n_lab->lab_pref = n_pref; + + if (modname==NULL && ExportLocalLabels) + n_lab->lab_mod = CurrentModule; +} + +void ConvertSymbolToRecordDandNLabel (LabDef *d_lab,LabDef *n_lab,SymbDef sdef) +{ + char *modname; + + if (!sdef->sdef_exported && sdef->sdef_module==CurrentModule) + modname = NULL; + else + modname = sdef->sdef_module; + + MakeSymbolLabel (d_lab,modname,RECORD_D_PREFIX,sdef,0); + + *n_lab = *d_lab; + n_lab->lab_pref = RECORD_N_PREFIX; + + if (modname==NULL && ExportLocalLabels) + n_lab->lab_mod = CurrentModule; +} + +void ConvertSymbolToKLabel (LabDef *slab,SymbDef sdef) +{ + char *modname; + + if (!sdef->sdef_exported && sdef->sdef_module==CurrentModule && !ExportLocalLabels) + modname = NULL; + else + modname = sdef->sdef_module; + + MakeSymbolLabel (slab,modname,CONSTRUCTOR_R_PREFIX,sdef,0); +} + +void ConvertSymbolToRLabel (LabDef *slab,SymbDef sdef) +{ + char *modname; + + if (!sdef->sdef_exported && sdef->sdef_module==CurrentModule && !ExportLocalLabels) + modname = NULL; + else + modname = sdef->sdef_module; + + MakeSymbolLabel (slab,modname,r_pref,sdef,0); +} + +void BuildLazyTupleSelectorLabel (Label slab, int arity, int argnr) +{ + if (argnr > NrOfGlobalSelectors){ + LazyTupleSelectors [argnr - NrOfGlobalSelectors- 1] = True; + MakeLabel (slab,loc_sel,argnr,n_pref); + } else + MakeLabel (slab,glob_sel,argnr,n_pref); +} + +#if defined (THUNK_LIFT_SELECTORS) +void BuildLazyTupleSelectorAndRemoveLabel (Label slab,int arity,int argnr) +{ + if (argnr > NrOfGlobalSelectors){ + error_in_function ("BuildLazyTupleSelectorAndRemoveLabel"); + } else + MakeLabel (slab,glob_selr,argnr,n_pref); +} +#endif + +void FileComment (void) +{ + if (DoDebug) + FPrintF (OutFile, "\n||\tConcurrent Clean Code Generator (Version %d.%d)",VERSION / 1000, VERSION % 1000); +} + +void PrintNodeId (NodeId nid) +{ + if (nid && nid->nid_ident && nid->nid_ident->ident_name) + FPrintF (OutFile, "%s", nid->nid_ident->ident_name); + else + FPrintF (OutFile, "_"); +} + +void PrintComment (void) +{ + FPrintF (OutFile, "\n\t\t\t||\t"); +} + +void LhsComment (unsigned int altnr, int asp, int bsp) +{ + if (DoDebug){ + PrintComment (); +#if 1 + FPrintF (OutFile,"Match code, stacksizes A: %d B: %d",asp,bsp); +#else + FPrintF (OutFile,"Match code for alternative %d, stacksizes A: %d B: %d",altnr, asp, bsp); +#endif + } +} + +void StrictIdComment (NodeId id) +{ + if (DoDebug){ + PrintComment (); + PrintNodeId (id); + FPrintF (OutFile, ": strict annotated"); + } +} + +void NodeDefComment (NodeDefs nd, char *msg) +{ + if (DoDebug){ + PrintComment (); + FPrintF (OutFile, "Node definition "); + PrintNodeId (nd->def_id); + + if (nd->def_node && (nd->def_node->node_kind==NormalNode || nd->def_node->node_kind==SelectorNode)){ + FPrintF (OutFile, ": "); + PrintSymbol (nd->def_node->node_symbol, OutFile); + } + FPrintF (OutFile, " (%s)", msg); + } +} + +void ContractumComment (int asp, int bsp) +{ + if (DoDebug){ + PrintComment (); + FPrintF (OutFile,"Building the contractum, Stacksizes A: %d B: %d",asp, bsp); + } +} + +void RedirectionComment (NodeId nid) +{ + if (DoDebug){ + PrintComment(); + FPrintF (OutFile, "Redirecting the root to: "); + PrintNodeId (nid); + } +} + +void ArgComment (Args arg) +{ + if (DoDebug){ + Node arg_node; + + arg_node=arg->arg_node; + + PrintComment(); + + if (arg_node->node_kind==NodeIdNode){ + PrintNodeId (arg_node->node_node_id); + + if (arg_node->node_node_id->nid_node){ + Node node; + + node=arg_node->node_node_id->nid_node; + + if (node->node_kind==NormalNode || node->node_kind==SelectorNode){ + FPrintF (OutFile, ": "); + PrintSymbol (node->node_symbol, OutFile); + } + } + } else if (arg_node->node_kind==NormalNode || arg_node->node_kind==SelectorNode) + PrintSymbol (arg->arg_node->node_symbol, OutFile); + } +} + +void NodeIdComment (NodeId node_id) +{ + if (DoDebug){ + PrintComment(); + + PrintNodeId (node_id); + + if (node_id->nid_node){ + Node node; + + node=node_id->nid_node; + + if (node->node_kind==NormalNode || node->node_kind==SelectorNode){ + FPrintF (OutFile, ": "); + PrintSymbol (node->node_symbol, OutFile); + } + } + } +} + +void TypeArgComment (TypeArgs arg) +{ + if (DoDebug){ + if (arg->type_arg_node->type_node_is_var){ + if (arg->type_arg_node->type_node_tv){ + TypeVar type_var; + + PrintComment(); + + type_var=arg->type_arg_node->type_node_tv; + if (type_var && type_var->tv_ident && type_var->tv_ident->ident_name) + FPrintF (OutFile, "%s", type_var->tv_ident->ident_name); + else + FPrintF (OutFile, "_"); + } + } else { + PrintComment(); + PrintSymbol (arg->type_arg_node->type_node_symbol,OutFile); + } + } +} + +void ParComment (Args arg) +{ + if (DoDebug){ + PrintComment (); +/* if (arg->arg_id) + PrintNodeId (arg->arg_id); + else + PrintSymbol (arg->arg_pattern->node_symbol,OutFile); +*/ + FPrintF (OutFile, ": parallel subgraph"); + } +} + +void DetermineSizeOfStates (int arity, States states, int *asize, int *bsize) +{ + *asize=0; + *bsize=0; + + for (; arity; arity--) + AddSizeOfState (states [arity-1], asize, bsize); +} + +static void AddSizeOfStates (int arity, States states, int *asize, int *bsize) +{ + for (; arity; arity--) + AddSizeOfState (states [arity-1], asize, bsize); +} + +void DetermineSizeOfState (StateS state, int *asize, int *bsize) +{ + *asize=0; + *bsize=0; + AddSizeOfState (state,asize,bsize); +} + +void AddSizeOfState (StateS state, int *asize, int *bsize) +{ + if (IsSimpleState (state)){ + if (state.state_kind == OnB) + *bsize += ObjectSizes [state.state_object]; + else if (state.state_kind != Undefined) + *asize += SizeOfAStackElem; + } else { + switch (state.state_type){ + case RecordState: + AddSizeOfStates (state.state_arity, state.state_record_arguments, asize, bsize); + break; + case TupleState: + AddSizeOfStates (state.state_arity, state.state_tuple_arguments, asize, bsize); + break; + case ArrayState: + *asize += SizeOfAStackElem; + break; + } + } +} + +void AddStateSizesAndMaxFrameSizes (int arity,States states,int *maxasize,int *asize,int *bsize) +{ + for (arity--; arity>=0; arity--) + AddStateSizeAndMaxFrameSize (states [arity], maxasize, asize, bsize); +} + +void AddStateSizeAndMaxFrameSize (StateS state,int *maxasize,int *asize,int *bsize) +{ + if (IsSimpleState (state)){ + if (state.state_kind == OnB) + (*bsize) += ObjectSizes [state.state_object]; + else if (state.state_kind != Undefined){ + (*asize) += SizeOfAStackElem; + (*maxasize) += SizeOfAStackElem; + } + } else { + switch (state.state_type){ + case RecordState: + AddStateSizesAndMaxFrameSizes (state.state_arity,state.state_record_arguments,maxasize,asize,bsize); + break; + case TupleState: + (*maxasize) += state.state_arity; + AddStateSizesAndMaxFrameSizes (state.state_arity,state.state_tuple_arguments,maxasize,asize,bsize); + break; + case ArrayState: + (*asize) += SizeOfAStackElem; + (*maxasize) += SizeOfAStackElem; + break; + } + } +} + +void AddStateSizesAndMaxFrameSizesOfArguments (Args args,int *maxasize,int *asize,int *bsize) +{ + for (; args!=NULL; args=args->arg_next) + AddStateSizeAndMaxFrameSize (args->arg_state,maxasize,asize,bsize); +} + +/* The layout of the A and B stack frames are computed compile time. */ + +static int *OfferedAFrame, *DefAFrame, *OfferedBFrame, *DefBFrame, + *InitOfferedAFrame, *InitDemandedAFrame, *InitDefAFrame, + *InitOfferedBFrame, *InitDemandedBFrame, *InitDefBFrame; + +int *DemandedAFrame,*DemandedBFrame,CurrentAFrameSize,CurrentBFrameSize; + +/* + CreateStackFrames, InitStackConversions, PutInBFrames and PutInAFrames + are routines which manipulate the stack frame administration. The latter + is used for a rather efficient way of converting one frame to another. + At the end of this part the main routine called 'GenStackConversions' + is given which generates ABC code for the requested conversion. +*/ + +#define AFRAMESIZE 1000 +#define BFRAMESIZE 2000 + +void CreateStackFrames (void) +{ + CurrentAFrameSize = 0; + CurrentBFrameSize = 0; + + OfferedAFrame = InitOfferedAFrame = (int*)CompAlloc ((SizeT) (AFRAMESIZE * SizeOf (int))); + DemandedAFrame = InitDemandedAFrame = (int*)CompAlloc ((SizeT) (AFRAMESIZE * SizeOf (int))); + DefAFrame = InitDefAFrame = (int*)CompAlloc ((SizeT) (AFRAMESIZE * SizeOf (int))); + OfferedBFrame = InitOfferedBFrame = (int*)CompAlloc ((SizeT) (BFRAMESIZE * SizeOf (int))); + DemandedBFrame = InitDemandedBFrame = (int*)CompAlloc ((SizeT) (BFRAMESIZE * SizeOf (int))); + DefBFrame = InitDefBFrame = (int*)CompAlloc ((SizeT) (BFRAMESIZE * SizeOf (int))); +} + +int *AllocTempDemandedAFrame (int size) +{ + if (OfferedAFrame + size > InitOfferedAFrame + AFRAMESIZE) + FatalCompError ("codegen", "ReserveAFrameSpace", "stack frame too big"); + + return DemandedAFrame + CurrentAFrameSize; +} + +int *AllocTempDemandedBFrame (int size) +{ + if (OfferedBFrame + size > InitOfferedBFrame + AFRAMESIZE) + FatalCompError ("codegen", "ReserveBFrameSpace", "stack frame too big"); + + return DemandedBFrame + CurrentBFrameSize; +} + +static void ReserveAFrameSpace (int size, int *oldsize) +{ + if (OfferedAFrame + size > InitOfferedAFrame + AFRAMESIZE) + FatalCompError ("codegen", "ReserveAFrameSpace","stack frame too big"); + + DemandedAFrame += CurrentAFrameSize; + OfferedAFrame += CurrentAFrameSize; + DefAFrame += CurrentAFrameSize; + + *oldsize = CurrentAFrameSize; + CurrentAFrameSize = size; +} + +void FreeAFrameSpace (int previoussize) +{ + CurrentAFrameSize = previoussize; + DemandedAFrame -= previoussize; + OfferedAFrame -= previoussize; + DefAFrame -= previoussize; +} + +void ReserveBFrameSpace (int size, int *oldsize) +{ + if ( OfferedBFrame + size > InitOfferedBFrame + BFRAMESIZE) + FatalCompError ("codegen","ReserveBFrameSpace","stack frame too big"); + + DemandedBFrame += CurrentBFrameSize; + OfferedBFrame += CurrentBFrameSize; + DefBFrame += CurrentBFrameSize; + + *oldsize = CurrentBFrameSize; + CurrentBFrameSize = size; +} + +void FreeBFrameSpace (int previoussize) +{ + CurrentBFrameSize = previoussize; + DemandedBFrame -= previoussize; + OfferedBFrame -= previoussize; + DefBFrame -= previoussize; +} + +void InitStackFrame (int offframe[],int defframe [],int max) +{ + int i; + + for (i=0; i<max; i++){ + offframe [i] = max; + defframe [i] = i; + } +} + +void InitStackConversions (int maxa,int maxb,int *oldamax_p,int *oldbmax_p) +{ + ReserveAFrameSpace (maxa,oldamax_p); + ReserveBFrameSpace (maxb,oldbmax_p); + + DemandedAFrame [0] = 0; + InitStackFrame (OfferedAFrame, DefAFrame, CurrentAFrameSize); + InitStackFrame (OfferedBFrame, DefBFrame, CurrentBFrameSize); +} + +void InitAStackConversions (int maxa,int *oldamax_p) +{ + ReserveAFrameSpace (maxa,oldamax_p); + InitStackFrame (OfferedAFrame, DefAFrame, CurrentAFrameSize); +} + +void ExitStackConversions (int oldamax, int oldbmax) +{ + FreeAFrameSpace (oldamax); + FreeBFrameSpace (oldbmax); +} + +#ifdef _FRAMECHECK_ + static void UpdateAFrame (int frame[], int offset, int index) + { + if (offset >= CurrentAFrameSize || offset < 0 || index >= CurrentAFrameSize || index < 0) + ErrorInCompiler ("codegen1.c", "UpdateAFrame","index out of range"); + else + frame [offset] = index; + } + + static void UpdateBFrame (int frame[], int offset, int index) + { + if (offset >= CurrentBFrameSize || offset < 0 || index >= CurrentBFrameSize || index < 0) + ErrorInCompiler ("codegen1.c", "UpdateBFrame","index out of range"); + else + frame [offset] = index; + } +#else + +#define UpdateAFrame(frame,offset,index) ((frame)[offset] = (index)) +#define UpdateBFrame(frame,offset,index) ((frame)[offset] = (index)) + +#endif + +void PutInBFrames (int bsp, int *b_ind, int size) +{ + int j; + + *b_ind += size; + + for (j=0; j<size; j++){ + UpdateBFrame (OfferedBFrame, bsp-j, bsp-j); + UpdateBFrame (DemandedBFrame, (*b_ind)-j, bsp-j); + } +} + +void PutInAFrames (int asp, int *a_ind) +{ + ++ *a_ind; + + UpdateAFrame (OfferedAFrame,asp,asp); + UpdateAFrame (DemandedAFrame,*a_ind,asp); +} + +#ifdef _FRAMECHECK_ + static void UpdateFrame (int frame[],int offset,int index, int offframe[]) + { + if (offframe == OfferedAFrame) + UpdateAFrame (frame,offset,index); + else + UpdateBFrame (frame,offset,index); + } +#else + +# define UpdateFrame(frame,offset,index,offframe) ((frame)[offset] = (index)) + +#endif + +static void CopyEntry (int offset, int *sp, int offframe []) +{ + if (offframe == OfferedAFrame) + GenPushA (*sp-offset); + else + GenPushB (*sp-offset); + (*sp)++; + UpdateFrame (offframe, *sp, offframe[offset], offframe); +} + +static void UpdateEntry (int srcoffset, int dstoffset, int sp, int offframe []) +{ + if (offframe == OfferedAFrame) + GenUpdateA (sp-srcoffset, sp-dstoffset); + else + GenUpdateB (sp-srcoffset, sp-dstoffset); + UpdateFrame (offframe, dstoffset, offframe [srcoffset], offframe); +} + +static void FillHole (int sp,int offframe[],int demframe [],int defframe [],int offsize,int demsize) +{ + do { + if (sp > demsize) + return; + else { + int newdef; + + newdef = defframe [demframe[sp]]; + UpdateEntry (newdef, sp, offsize, offframe); + UpdateFrame (defframe, demframe[sp], sp, offframe); + sp = newdef; + } + } while (offframe[sp] != demframe[sp]); +} + +static void GenStackConversions (int *sp,int demsize,int offframe[],int demframe[],int defframe[],int hole) +{ + int mysp; + Bool topused; + + topused = False; + + for (mysp = 1; mysp <= *sp; mysp++){ + if (offframe [mysp] == hole) /* Indicating a hole */ + FillHole (mysp, offframe, demframe, defframe,*sp, demsize); + } + + for (;mysp <= demsize; mysp++){ + int olddef; + + olddef = defframe [demframe [mysp]]; + CopyEntry (olddef, sp, offframe); + if (offframe [olddef] != demframe [olddef]){ + UpdateFrame (defframe, demframe [mysp], mysp, offframe); + FillHole (olddef, offframe, demframe, defframe, *sp, demsize); + } + } + + for (mysp = 1; mysp <= demsize; mysp++){ + if (offframe [mysp] != demframe [mysp]){ + if (topused) + UpdateEntry (mysp, *sp, *sp, offframe); + else { + topused = True; + CopyEntry (mysp, sp, offframe); + } + UpdateFrame (defframe, offframe [mysp], *sp, offframe); + FillHole (mysp, offframe, demframe, defframe, *sp, demsize); + } + } +} + +void GenAStackConversions (int sp,int demsize) +{ + GenStackConversions (&sp,demsize,OfferedAFrame,DemandedAFrame,DefAFrame,CurrentAFrameSize); + GenPopA (sp-demsize); +} + +void GenBStackConversions (int sp,int demsize) +{ + GenStackConversions (&sp,demsize,OfferedBFrame,DemandedBFrame,DefBFrame,CurrentBFrameSize); + GenPopB (sp-demsize); +} + +/* End of the stack frame conversion routines */ + +static void JmpEvalArgsEntry (int args_asp,Label ea_lab) +{ + GenDAStackLayout (args_asp); + if (DoTimeProfiling) + GenPN(); + GenJmp (ea_lab); +} + +static void CallEvalArgsEntry (int args_a_size,StateP function_state_p,int result_asize,int result_bsize,Label ea_lab) +{ + GenDAStackLayout (args_a_size); + GenJsr (ea_lab); + GenOStackLayoutOfState (result_asize,result_bsize,function_state_p[-1]); +} + +static void CallEvalArgsEntryUnboxed (int args_a_size,int args_b_size,ArgP arguments,StateP function_state_p,int result_asize,int result_bsize,Label ea_lab) +{ + GenDStackLayout (args_a_size,args_b_size,arguments); + GenJsr (ea_lab); + GenOStackLayoutOfState (result_asize,result_bsize,function_state_p[-1]); +} + +static void GenerateConstructorDescriptorAndFunction (ConstructorList constructor) +{ + Symbol constructor_symbol; + SymbDef constructor_def; + + constructor_symbol=constructor->cl_constructor->type_node_symbol; + constructor_def=constructor_symbol->symb_def; + + if (constructor_def->sdef_kind==CONSTRUCTOR && constructor_def->sdef_strict_constructor){ + GenStrictConstructorDescriptor (constructor_def,constructor->cl_state_p); + + if (constructor_def->sdef_exported || (constructor_def->sdef_mark & (SDEF_USED_LAZILY_MASK | SDEF_USED_CURRIED_MASK))){ + LabDef constructor_label,ealab,n_lab,d_lab; + int maxasize,asize,bsize; + int asp,bsp,arity; + + asp = constructor_def->sdef_arity; + bsp = 0; + arity = asp; + + ConvertSymbolToLabel (&CurrentAltLabel,constructor_def); + + if (constructor_def->sdef_exported) + GenExportEaEntry (constructor_def); + + GenConstructorFunctionDescriptorAndExportNodeAndDescriptor (constructor_def); + + if (DoTimeProfiling) + GenPB (constructor_def->sdef_ident->ident_name); + + MakeSymbolLabel (&ealab,constructor_def->sdef_exported ? CurrentModule : NULL,ea_pref,constructor_def,0); + + if (constructor_def->sdef_exported || (constructor_def->sdef_mark & SDEF_USED_CURRIED_MASK)){ + CurrentAltLabel.lab_pref = l_pref; + + if (DoTimeProfiling) + GenPL(); + + GenOAStackLayout (2); + GenLabelDefinition (&CurrentAltLabel); + + GenPushArgs (0,arity-1,arity-1); + GenUpdateA (arity,arity-1); + GenCreate (-1); + GenUpdateA (0,arity+1); + GenPopA (1); + JmpEvalArgsEntry (arity+1,&ealab); + } + + ConvertSymbolToConstructorDandNLabel (&d_lab,&n_lab,constructor_def); + + GenNodeEntryDirective (arity,&d_lab,&ealab); + GenOAStackLayout (1); + GenLabelDefinition (&n_lab); + GenPushNode (ReduceError,asp); + + GenOAStackLayout (arity+1); + if (DoTimeProfiling) + GenPN(); + GenLabelDefinition (&ealab); + + asize=0; + bsize=0; + maxasize=0; + + AddStateSizesAndMaxFrameSizes (arity,constructor->cl_state_p,&maxasize,&asize,&bsize); + + EvaluateAndMoveStateArguments (arity,constructor->cl_state_p,asp,maxasize); + + ConvertSymbolToKLabel (&constructor_label,constructor_def); + + GenFillR (&constructor_label,asize,bsize,asize,0,0,ReleaseAndFill,True); + + GenRtn (1,0,OnAState); + + if (DoTimeProfiling) + GenPE(); + } + } else + GenConstructorDescriptorAndExport (constructor_def); +} + +static void GenLazyRecordEntry (SymbDef rdef) +{ + LabDef record_label,d_label; + States argstates; + int asp,bsp,arity; + int maxasize,asize,bsize; + + argstates = rdef->sdef_record_state.state_record_arguments; + + asp = rdef->sdef_cons_arity; + bsp = 0; + arity = asp; + + ConvertSymbolToRecordDandNLabel (&d_label,&CurrentAltLabel,rdef); + + if (rdef->sdef_exported) + GenExportEaEntry (rdef); + + if (DoTimeProfiling) + GenPB (rdef->sdef_ident->ident_name); + + GenLazyRecordDescriptorAndExport (rdef); + + GenNodeEntryDirective (arity,&d_label,NULL); + + GenOAStackLayout (1); + GenLabelDefinition (&CurrentAltLabel); + GenPushNode (ReduceError,asp); + + asize=0; + bsize=0; + maxasize=0; + + AddStateSizesAndMaxFrameSizes (arity,argstates,&maxasize,&asize,&bsize); + + EvaluateAndMoveStateArguments (arity,argstates,asp,maxasize); + + ConvertSymbolToRLabel (&record_label, rdef); + + GenFillR (&record_label,asize,bsize,asize,0,0,ReleaseAndFill,True); + + GenRtn (1,0,OnAState); + + if (DoTimeProfiling) + GenPE(); +} + +void DetermineFieldSizeAndPosition (int fieldnr,int *asize,int *bsize,int *apos,int *bpos,States argstates) +{ + int i; + + *asize = *bsize = *apos = *bpos = 0; + + for (i=0; i < fieldnr; i++) + AddSizeOfState (argstates [i], apos, bpos); + + AddSizeOfState (argstates [i], asize, bsize); +} + +static void GenLazyFieldSelectorEntry (SymbDef field_def,StateS recstate,int tot_a_size,int tot_b_size) +{ + if (field_def->sdef_exported || field_def->sdef_mark & SDEF_USED_LAZILY_MASK){ + LabDef newealab,loclab,ealab,d_lab,n_lab; + Bool update_root_node; + int fieldnr,apos,bpos,asize,bsize; + StateS offfieldstate,demfieldstate; + char *record_name; + LabDef *ea_label_p; + int node_directive_arity; + + fieldnr = field_def->sdef_sel_field_number; + + offfieldstate = recstate.state_record_arguments [fieldnr]; + demfieldstate = field_def->sdef_sel_field->fl_state; + + DetermineFieldSizeAndPosition (fieldnr,&asize,&bsize,&apos,&bpos,recstate.state_record_arguments); + + ConvertSymbolToLabel (&CurrentAltLabel,field_def); + + if (field_def->sdef_exported) + GenExportFieldSelector (field_def); + + GenFieldSelectorDescriptor (field_def,IsSimpleState (offfieldstate)); + + if (DoTimeProfiling) + GenPB (field_def->sdef_ident->ident_name); + + update_root_node = ! ExpectsResultNode (offfieldstate); + + record_name=field_def->sdef_type->type_lhs->ft_symbol->symb_def->sdef_ident->ident_name; + + if (field_def->sdef_calledwithrootnode){ + ealab = CurrentAltLabel; + ealab.lab_pref = ea_pref; + + if (update_root_node){ + newealab = ealab; + newealab.lab_mod = CurrentModule; + ealab.lab_mod = NULL; + ea_label_p=&newealab; + } else + ea_label_p=&ealab; + } else if (field_def->sdef_returnsnode) + ea_label_p=&empty_lab; + else + ea_label_p=NULL; + + node_directive_arity = IsSimpleState (offfieldstate) ? (offfieldstate.state_kind!=OnB ? -4 : -3) : field_def->sdef_arity; + + ConvertSymbolToDandNLabel (&d_lab,&n_lab,field_def); + + GenFieldNodeEntryDirective (node_directive_arity,&d_lab,ea_label_p,record_name); + + GenOAStackLayout (1); + GenFieldLabelDefinition (&n_lab,record_name); + + GenPushNode (ReduceError,field_def->sdef_arity); + + if (field_def->sdef_calledwithrootnode){ + if (update_root_node){ + MakeLabel (&loclab, m_symb,NewLabelNr++,no_pref); + GenOAStackLayout (field_def->sdef_arity); + if (DoTimeProfiling) + GenPN(); + GenLabelDefinition (&loclab); + } else { + GenOAStackLayout (field_def->sdef_arity+1); + if (DoTimeProfiling) + GenPN(); + GenFieldLabelDefinition (&ealab,record_name); + } + } + + GenJsrEval (0); + + if (IsSimpleState (offfieldstate) && offfieldstate.state_kind==OnB && !DoTimeProfiling){ + LabDef gc_apply_label; + + gc_apply_label=CurrentAltLabel; + gc_apply_label.lab_pref = l_pref; + + GenOAStackLayout (2); + GenFieldLabelDefinition (&gc_apply_label,record_name); + } + + GenPushRArgB (0, tot_a_size, tot_b_size, bpos + 1, bsize); + GenReplRArgA (tot_a_size, tot_b_size, apos + 1, asize); + + if (IsSimpleState (offfieldstate)){ + if (offfieldstate.state_kind==OnB){ + FillBasicFromB (offfieldstate.state_object, 0, 0, ReleaseAndFill); + GenPopB (ObjectSizes [offfieldstate.state_object]); + GenRtn (1,0,OnAState); + } else { + if (IsLazyState (offfieldstate)){ + if (ExpectsResultNode (demfieldstate)) + GenJmpEvalUpdate (); + else { + GenJsrEval (0); + GenFillFromA (0, 1, ReleaseAndFill); + GenPopA (1); + GenRtn (1,0, OnAState); + } + } else { + GenFillFromA (0, 1, ReleaseAndFill); + GenPopA (1); + GenRtn (1,0,OnAState); + } + } + } else { + switch (offfieldstate.state_type){ + case TupleState: + BuildTuple (asize,bsize,asize,bsize, + offfieldstate.state_arity,offfieldstate.state_tuple_arguments, + asize,bsize,0,ReleaseAndFill,False); + break; + case ArrayState: + GenFillArray (0,1,ReleaseAndFill); + break; +#ifdef ADD_ARGUMENTS_TO_HIGHER_ORDER_FUNCTIONS + case RecordState: + BuildRecord (offfieldstate.state_record_symbol,asize,bsize,asize,bsize, + asize,bsize,0,ReleaseAndFill,False); + break; +#endif + } + GenPopA (asize); + GenPopB (bsize); + GenRtn (1,0,OnAState); + } + + if (field_def->sdef_calledwithrootnode && update_root_node){ + GenOAStackLayout (field_def->sdef_arity + 1); + if (DoTimeProfiling) + GenPN(); + GenFieldLabelDefinition (&newealab,record_name); + GenDAStackLayout (field_def->sdef_arity); + if (DoTimeProfiling) + GenPN(); + GenJmp (&loclab); + } + + if (DoTimeProfiling) + GenPE(); + + /* generate apply entry for the garbage collector: */ + if (IsSimpleState (offfieldstate)){ + LabDef gc_apply_label; + + gc_apply_label=CurrentAltLabel; + gc_apply_label.lab_pref = l_pref; + + if (offfieldstate.state_kind==OnB){ + if (DoTimeProfiling){ + GenOAStackLayout (2); + GenFieldLabelDefinition (&gc_apply_label,record_name); + + GenPushRArgB (0,tot_a_size,tot_b_size,bpos+1,bsize); + GenReplRArgA (tot_a_size,tot_b_size,apos+1, asize); + + FillBasicFromB (offfieldstate.state_object,0,0,ReleaseAndFill); + GenPopB (ObjectSizes [offfieldstate.state_object]); + GenRtn (1,0, OnAState); + } + } else { + GenOAStackLayout (1); + GenFieldLabelDefinition (&gc_apply_label,record_name); + + GenReplRArgA (tot_a_size, tot_b_size, apos + 1, asize); + GenRtn (1,0, OnAState); + } + } + } +} + +static void GenLazyArrayFunction (SymbDef arr_fun_def) +{ + LabDef ealab; + int asize,bsize,maxasize; + RuleTypes af_type; + int arity; + + asize = 0; + bsize = 0; + maxasize = 0; + + af_type = arr_fun_def->sdef_rule_type; + arity = arr_fun_def->sdef_arity; + + MakeSymbolLabel (&CurrentAltLabel,NULL,no_pref,arr_fun_def,0); + + ealab = CurrentAltLabel; + ealab.lab_pref = ea_pref; + + AddStateSizesAndMaxFrameSizes (arity,af_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 (DoTimeProfiling) + GenPB (arr_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 (arr_fun_def->sdef_mark & SDEF_USED_LAZILY_MASK) + NodeEntry (af_type->rule_type_state_p,arity,&ealab,arr_fun_def); + + EvalArgsEntry (af_type->rule_type_state_p,arr_fun_def,maxasize,&ealab,0); + + CallArrayFunction (arr_fun_def,False,&af_type->rule_type_state_p[-1]); + + if (DoTimeProfiling) + GenPE(); +} + +extern PolyList UserDefinedArrayFunctions; + +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); + } +} + +void GenerateCodeForConstructorsAndRecords (Symbol symbs) +{ + for ( ; symbs; symbs = symbs->symb_next){ + if (symbs->symb_kind==definition){ + SymbDef def; + + def = symbs->symb_def; + + if (def->sdef_module==CurrentModule){ + if (def->sdef_kind==TYPE){ + ConstructorList alt; + + for_l (alt,def->sdef_type->type_constructors,cl_next) + GenerateConstructorDescriptorAndFunction (alt); + } else if (def->sdef_kind==RECORDTYPE){ + FieldList fields; + int asize, bsize; + ConstructorList constructor; + + constructor = def->sdef_type->type_constructors; + DetermineSizeOfState (def->sdef_record_state, &asize, &bsize); + + GenRecordDescriptor (def); + + if (def->sdef_strict_constructor && (def->sdef_exported || (def->sdef_mark & SDEF_USED_LAZILY_MASK))) + GenLazyRecordEntry (def); + + for_l (fields,constructor->cl_fields,fl_next) + GenLazyFieldSelectorEntry (fields->fl_symbol->symb_def,def->sdef_record_state, asize, bsize); + } + } + } + } +} + +Bool NodeEntry (StateS *const function_state_p,int arity,Label ealab,SymbDef rootsymb) +{ + Bool update_root_node; + LabDef newealab,loclab,d_lab,n_lab,*ea_label_in_node_directive; + + ConvertSymbolToDandNLabel (&d_lab,&n_lab,rootsymb); + + d_lab.lab_post = n_lab.lab_post = CurrentAltLabel.lab_post; + + update_root_node = ! ExpectsResultNode (function_state_p[-1]); + + if (update_root_node && DoTimeProfiling && !function_called_only_curried_or_lazy_with_one_return) + GenPD(); + + if (rootsymb->sdef_calledwithrootnode){ + if (update_root_node){ + newealab = *ealab; + newealab.lab_mod = CurrentModule; + ea_label_in_node_directive=&newealab; + } else + ea_label_in_node_directive=ealab; + } else if (rootsymb->sdef_returnsnode) + ea_label_in_node_directive=&empty_lab; + else + ea_label_in_node_directive=NULL; + + GenNodeEntryDirective (arity,&d_lab,ea_label_in_node_directive); + + GenOAStackLayout (1); + GenLabelDefinition (&n_lab); + GenPushNode (ReduceError,arity); + + if (! update_root_node) + return True; + + if (rootsymb->sdef_calledwithrootnode){ + MakeLabel (&loclab, m_symb, NewLabelNr++, no_pref); + GenOAStackLayout (arity); + if (DoTimeProfiling) + GenPN(); + GenLabelDefinition (&loclab); + } + + if (IsSimpleState (function_state_p[-1])){ + if (function_state_p[-1].state_kind==OnB){ +#if SHARE_UPDATE_CODE + int result,label_number; +#endif + if (function_called_only_curried_or_lazy_with_one_return) + return False; + + CallEvalArgsEntry (arity,function_state_p,0,ObjectSizes [function_state_p[-1].state_object],ealab); + +#if SHARE_UPDATE_CODE + result=get_label_number_from_result_state_database (type,1,&label_number); + + if (result==2){ + LabDef update_label; + + MakeLabel (&update_label,"u",label_number,no_pref); + GenStackLayoutOfState (DemStackDir,0,ObjectSizes [function_state_p[-1].state_object],function_state_p[-1]); + GenJmp (&update_label); + } else { + if (result==1){ + LabDef update_label; + + MakeLabel (&update_label,"u",label_number,no_pref); + GenOStackLayoutOfState (0,ObjectSizes [function_state_p[-1].state_object],function_state_p[-1]); + GenLabelDefinition (&update_label); + } +#endif + + FillBasicFromB (function_state_p[-1].state_object, 0, 0, ReleaseAndFill); + GenPopB (ObjectSizes [function_state_p[-1].state_object]); + GenRtn (1,0,OnAState); + +#if SHARE_UPDATE_CODE + } +#endif + } else if (function_state_p[-1].state_kind==StrictRedirection || function_state_p[-1].state_kind==LazyRedirection){ + CallEvalArgsEntry (arity,function_state_p,1,0,ealab); + GenFillFromA (0, 1, ReleaseAndFill); + GenPopA (1); + GenRtn (1,0,OnAState); + } + } else { + int asize, bsize; +#if SHARE_UPDATE_CODE + int result,label_number; +#endif + + if (function_called_only_curried_or_lazy_with_one_return) + return False; + + DetermineSizeOfState (function_state_p[-1], &asize, &bsize); + CallEvalArgsEntry (arity,function_state_p,asize,bsize,ealab); + +#if SHARE_UPDATE_CODE + result=get_label_number_from_result_state_database (type,1,&label_number); + + if (result==2){ + LabDef update_label; + + MakeLabel (&update_label,"u",label_number,no_pref); + GenStackLayoutOfState (DemStackDir,asize,bsize,function_state_p[-1]); + GenJmp (&update_label); + } else { + if (result==1){ + LabDef update_label; + + MakeLabel (&update_label,"u",label_number,no_pref); + GenOStackLayoutOfState (asize,bsize,function_state_p[-1]); + GenLabelDefinition (&update_label); + } +#endif + + switch (function_state_p[-1].state_type){ + case TupleState: + BuildTuple (asize,bsize,asize,bsize,function_state_p[-1].state_arity, + function_state_p[-1].state_tuple_arguments,asize, bsize, 0, ReleaseAndFill,False); + break; + case RecordState: + BuildRecord (function_state_p[-1].state_record_symbol,asize,bsize,asize,bsize, + asize,bsize,0,ReleaseAndFill,False); + break; + case ArrayState: + GenFillArray (0, 1, ReleaseAndFill); + break; + } + GenPopA (asize); + GenPopB (bsize); + + GenRtn (1,0,OnAState); +#if SHARE_UPDATE_CODE + } +#endif + } + + if (rootsymb->sdef_calledwithrootnode){ + GenOAStackLayout (arity + 1); + GenLabelDefinition (&newealab); + GenDAStackLayout (arity); + if (DoTimeProfiling) + GenPN(); + GenJmp (&loclab); + } + + return False; +} + +Bool NodeEntryUnboxed (StateS *const function_state_p,NodeP call_node_p,int args_a_size,int args_b_size,Label ealab,SymbDef rootsymb) +{ + Bool update_root_node; + LabDef newealab,loclab,d_lab,n_lab,*ea_label_in_node_directive; + + ConvertSymbolToDandNLabel (&d_lab,&n_lab,rootsymb); + + d_lab.lab_post = n_lab.lab_post = CurrentAltLabel.lab_post; + + update_root_node = ! ExpectsResultNode (function_state_p[-1]); + + if (update_root_node && DoTimeProfiling && !function_called_only_curried_or_lazy_with_one_return) + GenPD(); + + if (rootsymb->sdef_calledwithrootnode){ + /* jmp_eval_upd not yet implemented for closures with unboxed elements */ + if (args_b_size!=0){ + ea_label_in_node_directive=&empty_lab; + } else { + if (update_root_node){ + newealab = *ealab; + newealab.lab_mod = CurrentModule; + ea_label_in_node_directive=&newealab; + } else + ea_label_in_node_directive=ealab; + } + } else if (rootsymb->sdef_returnsnode) + ea_label_in_node_directive=&empty_lab; + else + ea_label_in_node_directive=NULL; + + if (args_b_size!=0) + GenNodeEntryDirectiveUnboxed (args_a_size,args_b_size,&d_lab,ea_label_in_node_directive); + else + GenNodeEntryDirective (args_a_size,&d_lab,ea_label_in_node_directive); + + GenOAStackLayout (1); + GenLabelDefinition (&n_lab); + if (args_b_size!=0) + GenPushNodeU (ReduceError,args_a_size,args_b_size); + else + GenPushNode (ReduceError,args_a_size); + + if (! update_root_node) + return True; + + if (args_b_size==0 && rootsymb->sdef_calledwithrootnode){ + MakeLabel (&loclab, m_symb, NewLabelNr++, no_pref); + GenOAStackLayout (args_a_size); + if (DoTimeProfiling) + GenPN(); + GenLabelDefinition (&loclab); + } + + if (IsSimpleState (function_state_p[-1])){ + if (function_state_p[-1].state_kind==OnB){ +# if SHARE_UPDATE_CODE + int result,label_number; +# endif + if (function_called_only_curried_or_lazy_with_one_return) + return False; + + CallEvalArgsEntryUnboxed (args_a_size,args_b_size,call_node_p->node_arguments,function_state_p,0,ObjectSizes [function_state_p[-1].state_object],ealab); + +# if SHARE_UPDATE_CODE + result=get_label_number_from_result_state_database (type,1,&label_number); + + if (result==2){ + LabDef update_label; + + MakeLabel (&update_label,"u",label_number,no_pref); + GenStackLayoutOfState (DemStackDir,0,ObjectSizes [function_state_p[-1].state_object],function_state_p[-1]); + GenJmp (&update_label); + } else { + if (result==1){ + LabDef update_label; + + MakeLabel (&update_label,"u",label_number,no_pref); + GenOStackLayoutOfState (0,ObjectSizes [function_state_p[-1].state_object],function_state_p[-1]); + GenLabelDefinition (&update_label); + } +# endif + + FillBasicFromB (function_state_p[-1].state_object, 0, 0, ReleaseAndFill); + GenPopB (ObjectSizes [function_state_p[-1].state_object]); + GenRtn (1,0,OnAState); + +# if SHARE_UPDATE_CODE + } +# endif + } else if (function_state_p[-1].state_kind==StrictRedirection || function_state_p[-1].state_kind==LazyRedirection){ + CallEvalArgsEntryUnboxed (args_a_size,args_b_size,call_node_p->node_arguments,function_state_p,1,0,ealab); + GenFillFromA (0, 1, ReleaseAndFill); + GenPopA (1); + GenRtn (1,0,OnAState); + } + } else { + int asize, bsize; +# if SHARE_UPDATE_CODE + int result,label_number; +# endif + + if (function_called_only_curried_or_lazy_with_one_return) + return False; + + DetermineSizeOfState (function_state_p[-1], &asize, &bsize); + CallEvalArgsEntryUnboxed (args_a_size,args_b_size,call_node_p->node_arguments,function_state_p,asize,bsize,ealab); + +# if SHARE_UPDATE_CODE + result=get_label_number_from_result_state_database (type,1,&label_number); + + if (result==2){ + LabDef update_label; + + MakeLabel (&update_label,"u",label_number,no_pref); + GenStackLayoutOfState (DemStackDir,asize,bsize,function_state_p[-1]); + GenJmp (&update_label); + } else { + if (result==1){ + LabDef update_label; + + MakeLabel (&update_label,"u",label_number,no_pref); + GenOStackLayoutOfState (asize,bsize,function_state_p[-1]); + GenLabelDefinition (&update_label); + } +# endif + + switch (function_state_p[-1].state_type){ + case TupleState: + BuildTuple (asize,bsize,asize,bsize,function_state_p[-1].state_arity, + function_state_p[-1].state_tuple_arguments,asize, bsize, 0, ReleaseAndFill,False); + break; + case RecordState: + BuildRecord (function_state_p[-1].state_record_symbol,asize,bsize,asize,bsize, + asize,bsize,0,ReleaseAndFill,False); + break; + case ArrayState: + GenFillArray (0, 1, ReleaseAndFill); + break; + } + GenPopA (asize); + GenPopB (bsize); + + GenRtn (1,0,OnAState); +# if SHARE_UPDATE_CODE + } +# endif + } + + if (args_b_size==0 && rootsymb->sdef_calledwithrootnode){ + GenOAStackLayout (args_a_size + 1); + GenLabelDefinition (&newealab); + GenDAStackLayout (args_a_size); + if (DoTimeProfiling) + GenPN(); + GenJmp (&loclab); + } + + return False; +} + +void ApplyEntry (StateS *const function_state_p,int arity,Label ea_lab,int ea_label_follows) +{ + CurrentAltLabel.lab_pref = l_pref; + + if (arity==0){ + GenOAStackLayout (1); + GenLabelDefinition (&CurrentAltLabel); + GenHalt(); + return; + } + + if (DoTimeProfiling){ + if ((!IsSimpleState (function_state_p[-1]) || function_state_p[-1].state_kind==OnB) && !function_called_only_curried_or_lazy_with_one_return) + GenPLD(); + else + GenPL(); + } + + GenOAStackLayout (2); + GenLabelDefinition (&CurrentAltLabel); + + if (IsSimpleState (function_state_p[-1])){ + if (function_state_p[-1].state_kind==OnB){ +#if SHARE_UPDATE_CODE + int result,label_number; +#endif + GenReplArgs (arity-1,arity-1); + + if (function_called_only_curried_or_lazy_with_one_return) + return; + + CallEvalArgsEntry (arity,function_state_p,0,ObjectSizes [function_state_p[-1].state_object],ea_lab); + +#if SHARE_UPDATE_CODE +# if 1 + result=get_label_number_from_result_state_database (&function_state_p[-1],2,&label_number); +# else + result=get_label_number_from_result_state_database (type,2,&label_number); +# endif + if (result==2){ + LabDef update_label; + + MakeLabel (&update_label,"v",label_number,no_pref); + GenStackLayoutOfState (DemStackDir,0,ObjectSizes [function_state_p[-1].state_object],function_state_p[-1]); + GenJmp (&update_label); + } else { + if (result==1){ + LabDef update_label; + + MakeLabel (&update_label,"v",label_number,no_pref); + GenOStackLayoutOfState (0,ObjectSizes [function_state_p[-1].state_object],function_state_p[-1]); + GenLabelDefinition (&update_label); + } +#endif + + BuildBasicFromB (function_state_p[-1].state_object,0); + + GenPopB (ObjectSizes [function_state_p[-1].state_object]); + GenRtn (1,0,OnAState); +#if SHARE_UPDATE_CODE + } +#endif + } else if (function_state_p[-1].state_kind == StrictRedirection || function_state_p[-1].state_kind == LazyRedirection){ + GenReplArgs (arity-1, arity-1); + if (!ea_label_follows) + JmpEvalArgsEntry (arity,ea_lab); + } else { + GenPushArgs (0, arity-1, arity-1); + GenUpdateA (arity, arity-1); + GenCreate (-1); + GenUpdateA (0, arity+1); + GenPopA (1); + if (!ea_label_follows) + JmpEvalArgsEntry (arity+1,ea_lab); + } + } else { + int asize, bsize; +#if SHARE_UPDATE_CODE + int result,label_number; +#endif + GenReplArgs (arity-1, arity-1); + + if (function_called_only_curried_or_lazy_with_one_return) + return; + + DetermineSizeOfState (function_state_p[-1], &asize, &bsize); + CallEvalArgsEntry (arity,function_state_p,asize,bsize,ea_lab); + +#if SHARE_UPDATE_CODE +# if 1 + result=get_label_number_from_result_state_database (&function_state_p[-1],2,&label_number); +# else + result=get_label_number_from_result_state_database (type,2,&label_number); +# endif + if (result==2){ + LabDef update_label; + + MakeLabel (&update_label,"v",label_number,no_pref); + GenStackLayoutOfState (DemStackDir,asize,bsize,function_state_p[-1]); + GenJmp (&update_label); + } else { + if (result==1){ + LabDef update_label; + + MakeLabel (&update_label,"v",label_number,no_pref); + GenOStackLayoutOfState (asize,bsize,function_state_p[-1]); + GenLabelDefinition (&update_label); + } +#endif + switch (function_state_p[-1].state_type){ + case TupleState: + BuildTuple (asize, bsize, asize, bsize, function_state_p[-1].state_arity, + function_state_p[-1].state_tuple_arguments,asize,bsize, asize,NormalFill,True); + break; + case RecordState: + BuildRecord (function_state_p[-1].state_record_symbol,asize, bsize, asize, bsize, + asize, bsize, asize, NormalFill,True); + break; + case ArrayState: + GenBuildArray (0); + break; + } +#if UPDATE_POP + GenUpdatePopA (0, asize); +#else + GenUpdateA (0, asize); + GenPopA (asize); +#endif + GenPopB (bsize); + GenRtn (1,0,OnAState); +#if SHARE_UPDATE_CODE + } +#endif + } +} + +static void GenExternalLabel (int n_states,StateS *const function_state_p,int asp,int bsp,Label extlab) +{ + if (IsOnBStack (function_state_p[-1]) || + (IsSimpleState (function_state_p[-1]) && function_state_p[-1].state_kind==StrictRedirection)) + GenOStackLayoutOfStates (asp,bsp,n_states,function_state_p); + else + GenOStackLayoutOfStates (asp+1,bsp,n_states,function_state_p); + GenLabelDefinition (extlab); +} + +static void CoerceArgsFromExtToInt (int n_args,StateP ext_arg_state_p,StateP int_arg_state_p,int aindex,int bindex, + int *asp_p,int *bsp_p,int *a_ind_p,int *b_ind_p) +{ + if (n_args>0){ + int asize, bsize; + + DetermineSizeOfState (*ext_arg_state_p,&asize,&bsize); + + CoerceArgsFromExtToInt (n_args-1,ext_arg_state_p+1,int_arg_state_p+1,aindex-asize, bindex-bsize,asp_p,bsp_p,a_ind_p,b_ind_p); + + CoerceArgumentUsingStackFrames (*int_arg_state_p,*ext_arg_state_p,aindex, bindex,asp_p,bsp_p,a_ind_p,b_ind_p,asize,bsize); + } +} + +/* + When a function is exported to another module it may happen that + the exported type differs from the type in the implementation module. + This can be the case when one or more instances of abstract types + are appearing in the exported type specification. In order to bring + the external calls into agreement with the inter call a special entry + is generated. +*/ + +Bool ConvertExternalToInternalCall (int arity,StateS *const ext_function_state_p,StateS *const int_function_state_p, + Bool skip_entry,int intasp,int intbsp,Label ealab,Label extlab,Bool root_node_needed) +{ + int arg_n,asp,bsp,asize,bsize,oldamax,oldbmax,a_ind,b_ind; + Bool adjust_arg,adjust_result,all_args_lazy; + + adjust_arg = False; + all_args_lazy = True; + + adjust_result = ! EqualState (ext_function_state_p[-1],int_function_state_p[-1]); + + for (arg_n=0; arg_n<arity; ++arg_n){ + if (!IsLazyState (ext_function_state_p[arg_n])) + all_args_lazy = False; + + if (!EqualState (ext_function_state_p[arg_n],int_function_state_p[arg_n])) + adjust_arg = True; + } + + asp=0; + bsp=0; + asize=0; + bsize=0; + a_ind=0; + b_ind=0; + + if (! (adjust_arg || adjust_result)) + return True; + + if (all_args_lazy){ + if (adjust_result){ + if (skip_entry) + JmpEvalArgsEntry (root_node_needed ? arity+1 : arity, ealab); + + if (DoTimeProfiling) + GenPD(); + + GenExternalLabel (arity,ext_function_state_p,arity,0,extlab); + + DetermineSizeOfState (int_function_state_p[-1], &asize, &bsize); + CallEvalArgsEntry (root_node_needed ? arity+1 : arity,int_function_state_p,asize,bsize,ealab); + RedirectResultAndReturn (asize,bsize,asize,bsize,int_function_state_p[-1],ext_function_state_p[-1],asize,bsize); + return False; + } else { + GenExternalLabel (arity,ext_function_state_p,arity,0,extlab); + + if (DoTimeProfiling){ + GenPD(); + JmpEvalArgsEntry (root_node_needed ? arity+1 : arity,ealab); + } + + return False; + } + } else { + if (skip_entry) + JmpEvalArgsEntry (root_node_needed ? arity+1 : arity, ealab); + + if (adjust_arg){ + int maxasize; + + maxasize=0; + + for (arg_n=0; arg_n<arity; ++arg_n){ + AddSizeOfState (ext_function_state_p[arg_n],&asp,&bsp); + AddStateSizeAndMaxFrameSize (int_function_state_p[arg_n],&maxasize,&asize,&bsize); + } +/* + if (adjust_result && DoTimeProfiling) + GenPD(); +*/ + GenExternalLabel (arity,ext_function_state_p,asp,bsp,extlab); + InitStackConversions (asp+maxasize+1, bsp+bsize+1, &oldamax, &oldbmax); + + CoerceArgsFromExtToInt (arity,ext_function_state_p,int_function_state_p,asp,bsp,&asp,&bsp,&a_ind,&b_ind); + + GenAStackConversions (asp,a_ind); + GenBStackConversions (bsp,b_ind); + + ExitStackConversions (oldamax, oldbmax); + } else { +/* + if (adjust_result && DoTimeProfiling) + GenPD(); +*/ + GenExternalLabel (arity,ext_function_state_p,intasp,intbsp,extlab); + } + /* now we call the internal strict entry */ + + GenDStackLayoutOfStates (root_node_needed ? intasp+1 : intasp,intbsp,arity,int_function_state_p); + + if (adjust_result){ + GenJsr (&CurrentAltLabel); + + DetermineSizeOfState (int_function_state_p[-1], &asize, &bsize); + GenOStackLayoutOfState (asize, bsize, int_function_state_p[-1]); + RedirectResultAndReturn (asize,bsize,asize,bsize,int_function_state_p[-1],ext_function_state_p[-1],asize,bsize); + } else { + if (DoTimeProfiling) + GenPT(); + GenJmp (&CurrentAltLabel); + } + + return False; + } +} + +static char g_pref[] = "g"; + +static void GenerateCodeForLazyTupleSelectorEntry (int argnr) +{ + LabDef sellab,easellab,descriptor_label; + + BuildLazyTupleSelectorLabel (&sellab, MaxNodeArity, argnr); + GenSelectorDescriptor (&sellab,g_pref); + + easellab = sellab; + easellab.lab_pref = ea_pref; + + descriptor_label=sellab; + descriptor_label.lab_pref=d_pref; + GenNodeEntryDirectiveForLabelWithoutSymbol (-1,&descriptor_label,&easellab); + + GenOAStackLayout (1); + GenLabelDefinition (&sellab); + GenPushNode (ReduceError, 1); + GenJsrEval (0); + GenGetNodeArity (0); + GenPushArgNr (argnr); + GenPushArgB (0); + GenJsrEval (0); + GenFillFromA (0, 2, ReleaseAndFill); + GenPopA (2); + GenRtn (1,0,OnAState); + + GenOAStackLayout (1); + sellab.lab_pref = g_pref; + GenLabelDefinition (&sellab); + GenGetNodeArity (0); + GenPushArgNr (argnr); + GenPushArgB (0); +#if UPDATE_POP + GenUpdatePopA (0, 1); +#else + GenUpdateA (0, 1); + GenPopA (1); +#endif + GenRtn (1,0,OnAState); + + GenOAStackLayout (2); + GenLabelDefinition (&easellab); + GenPushArg (0,1,1); + GenPushA (2); + GenKeep (1,0); + GenFill (& ind_lab, -2, & indirection_lab, 2, PartialFill); + GenKeep (1,0); +#if UPDATE_POP + GenUpdatePopA (0, 1); +#else + GenUpdateA (0, 1); + GenPopA (1); +#endif + GenJsrEval (0); + GenGetNodeArity (0); + GenPushArgNr (argnr); + GenPushArgB (0); +#if UPDATE_POP + GenUpdatePopA (0, 1); +#else + GenUpdateA (0, 1); + GenPopA (1); +#endif + GenJmpEvalUpdate(); +} + +void GenerateCodeForLazyTupleSelectorEntries (Bool *selectors) +{ + int i; + + for (i = NrOfGlobalSelectors; i < MaxNodeArity; i++) + if (selectors[i - NrOfGlobalSelectors]) + GenerateCodeForLazyTupleSelectorEntry (i+1); +} + +#define allocate_function_state(arity) (((StateP)(CompAlloc (sizeof(StateS)*((arity)+1))))+1) + +#define UPDATE_NODE_IN_STRICT_ENTRY 0 + +static StateP create_function_state_for_update_function (StateS record_state,int n_arguments) +{ + StateP function_state_p; + int arg_n; + + function_state_p = allocate_function_state (n_arguments); + + for (arg_n=0; arg_n<n_arguments; ++arg_n) + function_state_p[arg_n]=LazyState; + +#if UPDATE_NODE_IN_STRICT_ENTRY + function_state_p[-1]=StrictState; +#else + function_state_p[-1]=record_state; +#endif + + return function_state_p; +} + +static StateP create_function_state_for_match_function (void) +{ + StateP function_state_p; + + function_state_p = allocate_function_state (1); + + function_state_p[0]=StrictState; + function_state_p[-1]=StrictState; + + return function_state_p; +} + +int next_update_function_n,next_match_function_n; + +ImpRuleP first_update_function,*update_function_p; + +ImpRuleP create_simple_imp_rule (NodeP lhs_root,NodeP rhs_root,SymbDefP function_sdef) +{ + ImpRuleS *imp_rule; + RuleAltS *rule_alt; + + rule_alt=CompAllocType (RuleAltS); + rule_alt->alt_lhs_root=lhs_root; + rule_alt->alt_lhs_defs=NULL; + rule_alt->alt_rhs_root=rhs_root; + rule_alt->alt_rhs_defs=NULL; + rule_alt->alt_strict_node_ids=NULL; + rule_alt->alt_next=NULL; + rule_alt->alt_line=0; + rule_alt->alt_kind=Contractum; + + imp_rule = CompAllocType (ImpRuleS); + imp_rule->rule_alts = rule_alt; + imp_rule->rule_root = lhs_root; + imp_rule->rule_mark = 0; + imp_rule->rule_line = 0; + imp_rule->rule_type = NULL; + + function_sdef->sdef_rule=imp_rule; + + return imp_rule; +} + +SymbDef CreateUpdateFunction (ArgS *record_arg,ArgS *first_field_arg,Node node) +{ + static char update_function_name[16]; + SymbDef update_function_sdef; + Ident update_function_ident; + Symbol update_function_symbol; + ArgS *previous_arg,*arg; + Node lhs_root,rhs_root; + int n_arguments; + ImpRuleS *update_imp_rule; + StateS record_state; + + sprintf (update_function_name,"_upd%d",next_update_function_n); + ++next_update_function_n; + + n_arguments=node->node_arity; + + update_function_ident=PutStringInHashTable (update_function_name,SymbolIdTable); + update_function_sdef=MakeNewSymbolDefinition (CurrentModule,update_function_ident,n_arguments,IMPRULE); + + update_function_sdef->sdef_number=next_def_number++; + update_function_sdef->sdef_isused=True; + update_function_sdef->sdef_mark |= SDEF_USED_LAZILY_MASK; + +#if UPDATE_NODE_IN_STRICT_ENTRY + update_function_sdef->sdef_returnsnode=True; + update_function_sdef->sdef_calledwithrootnode=True; +#else + update_function_sdef->sdef_returnsnode=False; + update_function_sdef->sdef_calledwithrootnode=False; +#endif + + update_function_symbol=NewSymbol (definition); + update_function_symbol->symb_def=update_function_sdef; + + { + NodeId record_node_id; + ArgS *lhs_record_arg,*rhs_record_arg,**lhs_arg_p,**rhs_arg_p; + + record_node_id=NewNodeId (NULL); + record_node_id->nid_refcount=-1; + + record_state=node->node_symbol->symb_def->sdef_record_state; + + lhs_record_arg=NewArgument (NewNodeIdNode (record_node_id)); + lhs_record_arg->arg_state=LazyState; + rhs_record_arg=NewArgument (NewNodeIdNode (record_node_id)); + rhs_record_arg->arg_state=record_state; + + lhs_root=NewNode (update_function_symbol,lhs_record_arg,n_arguments); +#if UPDATE_NODE_IN_STRICT_ENTRY + lhs_root->node_state=StrictState; +#else + lhs_root->node_state=record_state; +#endif + + rhs_root=NewUpdateNode (node->node_symbol,rhs_record_arg,n_arguments); +#if UPDATE_NODE_IN_STRICT_ENTRY + rhs_root->node_state=StrictState; +#else + rhs_root->node_state=record_state; +#endif + rhs_root->node_number=0; + + lhs_arg_p=&lhs_record_arg->arg_next; + rhs_arg_p=&rhs_record_arg->arg_next; + + previous_arg=record_arg; + for_l (arg,first_field_arg,arg_next){ + ArgS *rhs_arg,*lhs_arg,*field_value_arg; + NodeId arg_node_id; + int field_number; + Node field_node; + StateS *state_p; + + field_node=arg->arg_node; + field_number=field_node->node_symbol->symb_def->sdef_sel_field_number; + + arg_node_id=NewNodeId (NULL); + arg_node_id->nid_refcount=-2; + + lhs_arg=NewArgument (NewNodeIdNode (arg_node_id)); + lhs_arg->arg_state=LazyState; + field_value_arg=NewArgument (NewNodeIdNode (arg_node_id)); + state_p=&record_state.state_record_arguments [field_number]; + field_value_arg->arg_state=*state_p; + + rhs_arg=NewArgument (NewSelectorNode (field_node->node_symbol,field_value_arg,1)); + rhs_arg->arg_state=*state_p; + + *lhs_arg_p=lhs_arg; + *rhs_arg_p=rhs_arg; + + lhs_arg_p=&lhs_arg->arg_next; + rhs_arg_p=&rhs_arg->arg_next; + + field_node->node_arguments->arg_next=NULL; + + previous_arg->arg_next=arg; + previous_arg=arg; + } + previous_arg->arg_next=NULL; + + *lhs_arg_p=NULL; + *rhs_arg_p=NULL; + } + + update_imp_rule=create_simple_imp_rule (lhs_root,rhs_root,update_function_sdef); + + update_imp_rule->rule_state_p = create_function_state_for_update_function (record_state,n_arguments); + + *update_function_p=update_imp_rule; + update_function_p=&update_imp_rule->rule_next; + + return update_function_sdef; +} + +#define R4(r,f1,f2,f3,f4) (r).f1;(r).f2;(r).f3;(r).f4 +#define U5(r,f1,f2,f3,f4,f5) (r)->f1;(r)->f2;(r)->f3;(r)->f4;(r)->f5 + +SymbDef create_select_function (Symbol selector_symbol,int selector_kind) +{ + static char select_function_name[16]; + SymbDef select_function_sdef; + Ident select_function_ident; + Symbol select_function_symbol; + NodeP lhs_root,rhs_root; + ImpRuleS *update_imp_rule; + SymbDef selector_sdef; + ArgP lhs_record_arg,rhs_record_arg; + NodeIdP record_node_id; + StateP tuple_state_arguments,function_state_p,record_state_p,arg_state_p; + StateS selector_arg_state; + int fieldnr; + + selector_sdef=selector_symbol->symb_def; + + sprintf (select_function_name,"_sel%d",next_update_function_n); + ++next_update_function_n; + + select_function_ident=PutStringInHashTable (select_function_name,SymbolIdTable); + select_function_sdef=MakeNewSymbolDefinition (CurrentModule,select_function_ident,1,IMPRULE); + + U5 (select_function_sdef, sdef_number=next_def_number++, + sdef_isused=True, + sdef_mark |= SDEF_USED_LAZILY_MASK, + sdef_returnsnode=False, + sdef_calledwithrootnode=False); + + select_function_symbol=NewSymbol (definition); + select_function_symbol->symb_def=select_function_sdef; + + record_state_p=&selector_sdef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state; + fieldnr = selector_sdef->sdef_sel_field_number; + + record_node_id=NewNodeId (NULL); + record_node_id->nid_refcount=-2; + + tuple_state_arguments=CompAllocArray (2,StateS); + tuple_state_arguments[0]=record_state_p->state_record_arguments[fieldnr]; + if (selector_kind<SELECTOR_L){ + tuple_state_arguments[1]=*record_state_p; + arg_state_p=record_state_p; + } else { + StateP selector_arg_tuple_args; + + tuple_state_arguments[1]=StrictState; + + selector_arg_tuple_args=CompAllocArray (2,StateS); + selector_arg_tuple_args[0]=*record_state_p; + selector_arg_tuple_args[1]=StrictState; + + selector_arg_state.state_type=TupleState; + selector_arg_state.state_arity=2; + selector_arg_state.state_mark=0; + selector_arg_state.state_tuple_arguments=selector_arg_tuple_args; + arg_state_p=&selector_arg_state; + } + + lhs_record_arg=NewArgument (NewNodeIdNode (record_node_id)); + lhs_record_arg->arg_state=*arg_state_p; + + lhs_root=NewNode (select_function_symbol,lhs_record_arg,1); + R4 (lhs_root->node_state, state_type=TupleState, + state_arity=2, + state_mark=0, + state_tuple_arguments=tuple_state_arguments); + + rhs_record_arg=NewArgument (NewNodeIdNode (record_node_id)); + rhs_record_arg->arg_state=*arg_state_p; + + rhs_root=NewSelectorNode (selector_symbol,rhs_record_arg,selector_kind); + + R4 (rhs_root->node_state, state_type=TupleState, + state_arity=2, + state_mark=0, + state_tuple_arguments=tuple_state_arguments); + + rhs_root->node_number=0; + + update_imp_rule=create_simple_imp_rule (lhs_root,rhs_root,select_function_sdef); + + function_state_p = allocate_function_state (1); + function_state_p[0]=*arg_state_p; + + R4 (function_state_p[-1], state_type=TupleState, + state_arity=2, + state_mark=0, + state_tuple_arguments=tuple_state_arguments); + + update_imp_rule->rule_state_p=function_state_p; + + *update_function_p=update_imp_rule; + update_function_p=&update_imp_rule->rule_next; + + return select_function_sdef; +} + +static SymbDef create_match_function_sdef (void) +{ + char match_function_name[16]; + Ident match_function_ident; + SymbDef match_function_sdef; + + sprintf (match_function_name,"_match%d",next_match_function_n); + ++next_match_function_n; + + match_function_ident=PutStringInHashTable (match_function_name,SymbolIdTable); + match_function_sdef=MakeNewSymbolDefinition (CurrentModule,match_function_ident,1,IMPRULE); + + U5 (match_function_sdef, sdef_number=next_def_number++, + sdef_isused=True, + sdef_mark |= SDEF_USED_LAZILY_MASK, + sdef_returnsnode=True, + sdef_calledwithrootnode=True); + + return match_function_sdef; +} + +SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,int strict_constructor) +{ + SymbDef match_function_sdef; + Symbol match_function_symbol; + struct arg *lhs_function_arg,**lhs_arg_p; + int n; + struct node *lhs_root,*rhs_root,*constructor_node; + ImpRuleS *match_imp_rule; + + match_function_sdef=create_match_function_sdef(); + + match_function_symbol=NewSymbol (definition); + match_function_symbol->symb_def=match_function_sdef; + + constructor_node=NewNode (constructor_symbol,NULL,constructor_arity); + + lhs_arg_p=&constructor_node->node_arguments; + + for (n=0; n<constructor_arity; ++n){ + struct arg *lhs_arg; + struct node_id *arg_node_id; + + arg_node_id=NewNodeId (NULL); + arg_node_id->nid_refcount=-1; + + lhs_arg=NewArgument (NewNodeIdNode (arg_node_id)); + lhs_arg->arg_state=LazyState; + + *lhs_arg_p=lhs_arg; + lhs_arg_p=&lhs_arg->arg_next; + } + + *lhs_arg_p=NULL; + + if (strict_constructor){ + struct arg **rhs_arg_p,*lhs_arg; + StateP constructor_arg_state_p; + + lhs_function_arg=NewArgument (constructor_node); + lhs_function_arg->arg_state=StrictState; + + rhs_root=NewNode (TupleSymbol,NULL,constructor_arity); + rhs_arg_p=&rhs_root->node_arguments; + + constructor_arg_state_p=constructor_symbol->symb_def->sdef_constructor->cl_state_p; + + for_l (lhs_arg,constructor_node->node_arguments,arg_next){ + struct arg *rhs_arg; + struct node_id *node_id; + + node_id=lhs_arg->arg_node->node_node_id; + --node_id->nid_refcount; + + rhs_arg=NewArgument (NewNodeIdNode (node_id)); + rhs_arg->arg_state=LazyState; + + *rhs_arg_p=rhs_arg; + rhs_arg_p=&rhs_arg->arg_next; + + lhs_arg->arg_state=*constructor_arg_state_p++; + } + + *rhs_arg_p=NULL; + } else { + struct node_id *constructor_node_node_id; + + constructor_node_node_id=NewNodeId (NULL); + constructor_node_node_id->nid_refcount=-2; + + constructor_node_node_id->nid_node=constructor_node; + + lhs_function_arg=NewArgument (NewNodeIdNode (constructor_node_node_id)); + lhs_function_arg->arg_state=StrictState; + + rhs_root=NewNodeIdNode (constructor_node_node_id); + } + + lhs_root=NewNode (match_function_symbol,lhs_function_arg,1); + lhs_root->node_state=StrictState; + + rhs_root->node_state=StrictState; + rhs_root->node_number=0; + + match_imp_rule=create_simple_imp_rule (lhs_root,rhs_root,match_function_sdef); + + match_imp_rule->rule_state_p = create_function_state_for_match_function(); + + *update_function_p=match_imp_rule; + update_function_p=&match_imp_rule->rule_next; + + return match_function_sdef; +} + +SymbDef create_select_and_match_function (SymbolP constructor_symbol,int strict_constructor) +{ + SymbDef match_function_sdef; + Symbol match_function_symbol; + ArgP lhs_function_arg,lhs_arg; + NodeP lhs_root,rhs_root,constructor_node; + NodeIdP node_id; + ImpRuleS *match_imp_rule; + + match_function_sdef=create_match_function_sdef(); + + match_function_symbol=NewSymbol (definition); + match_function_symbol->symb_def=match_function_sdef; + + node_id=NewNodeId (NULL); + node_id->nid_refcount=-2; + + lhs_arg=NewArgument (NewNodeIdNode (node_id)); + constructor_node=NewNode (constructor_symbol,lhs_arg,1); + + if (strict_constructor) + lhs_arg->arg_state=constructor_symbol->symb_def->sdef_constructor->cl_state_p[0]; + else + lhs_arg->arg_state=LazyState; + + lhs_function_arg=NewArgument (constructor_node); + lhs_function_arg->arg_state=StrictState; + + lhs_root=NewNode (match_function_symbol,lhs_function_arg,1); + lhs_root->node_state=StrictState; + + rhs_root=NewNodeIdNode (node_id); + rhs_root->node_state=StrictState; + rhs_root->node_number=0; + + match_imp_rule=create_simple_imp_rule (lhs_root,rhs_root,match_function_sdef); + + match_imp_rule->rule_state_p = create_function_state_for_match_function(); + + { + TypeNode type_node; + StateP lhs_type_root_state_p; + + type_node=constructor_symbol->symb_def->sdef_constructor->cl_constructor->type_node_arguments->type_arg_node; + lhs_type_root_state_p=&match_imp_rule->rule_state_p[-1]; + if (!(type_node->type_node_is_var || type_node->type_node_symbol->symb_kind==apply_symb) + && !IsLazyState (constructor_symbol->symb_def->sdef_constructor->cl_state_p[0])) + { + *lhs_type_root_state_p=constructor_symbol->symb_def->sdef_constructor->cl_state_p[0]; + } else + lhs_type_root_state_p->state_kind=StrictRedirection; + lhs_root->node_state=*lhs_type_root_state_p; + + if (IsSimpleState (*lhs_type_root_state_p)){ + if (lhs_type_root_state_p->state_kind==OnA || lhs_type_root_state_p->state_kind==StrictOnA){ + match_function_sdef->sdef_calledwithrootnode = True; + match_function_sdef->sdef_returnsnode = True; + } else if (lhs_type_root_state_p->state_kind==StrictRedirection){ + match_function_sdef->sdef_calledwithrootnode = False; + match_function_sdef->sdef_returnsnode = True; + } else { + match_function_sdef->sdef_calledwithrootnode = False; + match_function_sdef->sdef_returnsnode = False; + } + } else { + match_function_sdef->sdef_calledwithrootnode = False; + match_function_sdef->sdef_returnsnode = False; + } + } + + *update_function_p=match_imp_rule; + update_function_p=&match_imp_rule->rule_next; + + return match_function_sdef; +} + +struct update { + int a_from_offset; + int a_to_offset; + int a_size; + int b_from_offset; + int b_to_offset; + int b_size; +}; + +#if BIND_UNBOXED_LHS_TUPLE_AND_RECORD_ARGUMENTS_IN_BIND_ARGUMENTS /* added 9-4-1999 */ +void bind_tuple_and_record_arguments (ArgP arguments,NodeId tuple_node_id,int a_offset,int b_offset, + NodeIdListElementS ***a_node_ids_h,NodeIdListElementS ***b_node_ids_h) +{ + NodeIdListElementS **a_node_ids_p,**b_node_ids_p; + ArgP arg_p; + + a_node_ids_p=*a_node_ids_h; + b_node_ids_p=*b_node_ids_h; + + for_l (arg_p,arguments,arg_next){ + if (arg_p->arg_node->node_kind==NodeIdNode){ + struct node_id *node_id; + + node_id=arg_p->arg_node->node_node_id; + + if (tuple_node_id!=NULL){ + node_id->nid_mark |= NID_STRICT_LHS_TUPLE_ELEMENT_MASK; + node_id->nid_lhs_tuple_node_id_=tuple_node_id; + } + + node_id->nid_a_index_ = a_offset; + node_id->nid_b_index_ = b_offset; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + node_id->nid_mark2 |= NID_LHS_PUSHED; + node_id->nid_state = *node_id->nid_lhs_state_p; +#endif + if (IsSimpleState (arg_p->arg_state)){ + if (arg_p->arg_state.state_kind==OnB){ + struct node_id_list_element *new_p_node_id; + + new_p_node_id=CompAllocType (struct node_id_list_element); + new_p_node_id->nidl_node_id=node_id; + + *b_node_ids_p=new_p_node_id; + b_node_ids_p=&new_p_node_id->nidl_next; + } else { + struct node_id_list_element *new_p_node_id; + + new_p_node_id=CompAllocType (struct node_id_list_element); + new_p_node_id->nidl_node_id=node_id; + + *a_node_ids_p=new_p_node_id; + a_node_ids_p=&new_p_node_id->nidl_next; + } + } else { + if (node_id->nid_node==NULL){ + int asize,bsize; + + DetermineSizeOfState (arg_p->arg_state, &asize, &bsize); + + if (asize!=0){ + struct node_id_list_element *new_p_node_id; + + new_p_node_id=CompAllocType (struct node_id_list_element); + new_p_node_id->nidl_node_id=node_id; + + *a_node_ids_p=new_p_node_id; + a_node_ids_p=&new_p_node_id->nidl_next; + } + + if (bsize!=0){ + struct node_id_list_element *new_p_node_id; + + new_p_node_id=CompAllocType (struct node_id_list_element); + new_p_node_id->nidl_node_id=node_id; + + *b_node_ids_p=new_p_node_id; + b_node_ids_p=&new_p_node_id->nidl_next; + } + } else { + NodeIdListElementS **a_node_ids_p_c,**b_node_ids_p_c; + + a_node_ids_p_c=a_node_ids_p; + b_node_ids_p_c=b_node_ids_p; + + bind_tuple_and_record_arguments (node_id->nid_node->node_arguments,node_id,a_offset,b_offset,&a_node_ids_p_c,&b_node_ids_p_c); + + a_node_ids_p=a_node_ids_p_c; + b_node_ids_p=b_node_ids_p_c; + } + } + } + else if (!IsSimpleState (arg_p->arg_state)){ + NodeIdListElementS **a_node_ids_p_c,**b_node_ids_p_c; + + a_node_ids_p_c=a_node_ids_p; + b_node_ids_p_c=b_node_ids_p; + + bind_tuple_and_record_arguments (arg_p->arg_node->node_arguments,tuple_node_id /* !!!, not NULL */,a_offset,b_offset,&a_node_ids_p_c,&b_node_ids_p_c); + + a_node_ids_p=a_node_ids_p_c; + b_node_ids_p=b_node_ids_p_c; + } + + if (IsSimpleState (arg_p->arg_state)){ + if (arg_p->arg_state.state_kind==OnB) + b_offset -= ObjectSizes [arg_p->arg_state.state_object]; + else + a_offset -= SizeOfAStackElem; + } else { + int asize,bsize; + + DetermineSizeOfState (arg_p->arg_state, &asize, &bsize); + a_offset -= asize; + b_offset -= bsize; + } + } + + *a_node_ids_h=a_node_ids_p; + *b_node_ids_h=b_node_ids_p; +} + +#else +static void set_lhs_tuple_node_ids (ArgS *args,NodeId node_id) +{ + ArgS *arg; + + for_l (arg,args,arg_next){ + Node arg_node; + + arg_node=arg->arg_node; + if (arg_node->node_kind==NodeIdNode){ + arg_node->node_node_id->nid_mark |= NID_STRICT_LHS_TUPLE_ELEMENT_MASK; + arg_node->node_node_id->nid_lhs_tuple_node_id_=node_id; + } else + set_lhs_tuple_node_ids (arg_node->node_arguments,node_id); + } +} +#endif + +void bind_arguments (ArgP arguments,int a_offset,int b_offset,AbNodeIdsP ab_node_ids_p) +{ + NodeIdListElementS **a_node_ids_p,**b_node_ids_p,*a_node_ids,*b_node_ids; + ArgP arg_p; + + a_node_ids=ab_node_ids_p->a_node_ids; + b_node_ids=ab_node_ids_p->b_node_ids; + + a_node_ids_p=&ab_node_ids_p->a_node_ids; + b_node_ids_p=&ab_node_ids_p->b_node_ids; + + for_l (arg_p,arguments,arg_next){ + if (arg_p->arg_node->node_kind==NodeIdNode){ + struct node_id *node_id; + + node_id=arg_p->arg_node->node_node_id; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + node_id->nid_mark2 |= NID_LHS_PUSHED; + node_id->nid_state = *node_id->nid_lhs_state_p; +#endif + node_id->nid_a_index_ = a_offset; + node_id->nid_b_index_ = b_offset; + + if (IsSimpleState (arg_p->arg_state)){ + if (arg_p->arg_state.state_kind==OnB){ + struct node_id_list_element *new_p_node_id; + + new_p_node_id=CompAllocType (struct node_id_list_element); + new_p_node_id->nidl_node_id=node_id; + + *b_node_ids_p=new_p_node_id; + b_node_ids_p=&new_p_node_id->nidl_next; + } else { + struct node_id_list_element *new_p_node_id; + + new_p_node_id=CompAllocType (struct node_id_list_element); + new_p_node_id->nidl_node_id=node_id; + + *a_node_ids_p=new_p_node_id; + a_node_ids_p=&new_p_node_id->nidl_next; + } + } else { + if (node_id->nid_node==NULL){ + int asize,bsize; + + DetermineSizeOfState (arg_p->arg_state, &asize, &bsize); + + if (asize!=0){ + struct node_id_list_element *new_p_node_id; + + new_p_node_id=CompAllocType (struct node_id_list_element); + new_p_node_id->nidl_node_id=node_id; + + *a_node_ids_p=new_p_node_id; + a_node_ids_p=&new_p_node_id->nidl_next; + } + + if (bsize!=0){ + struct node_id_list_element *new_p_node_id; + + new_p_node_id=CompAllocType (struct node_id_list_element); + new_p_node_id->nidl_node_id=node_id; + + *b_node_ids_p=new_p_node_id; + b_node_ids_p=&new_p_node_id->nidl_next; + } + } else +#if BIND_UNBOXED_LHS_TUPLE_AND_RECORD_ARGUMENTS_IN_BIND_ARGUMENTS /* added 9-4-1999 */ + { + NodeIdListElementS **a_node_ids_p_c,**b_node_ids_p_c; + + a_node_ids_p_c=a_node_ids_p; + b_node_ids_p_c=b_node_ids_p; + + bind_tuple_and_record_arguments (node_id->nid_node->node_arguments,node_id,a_offset,b_offset,&a_node_ids_p_c,&b_node_ids_p_c); + + a_node_ids_p=a_node_ids_p_c; + b_node_ids_p=b_node_ids_p_c; + } +#else + set_lhs_tuple_node_ids (node_id->nid_node->node_arguments,node_id); +#endif + } + } +#if BIND_UNBOXED_LHS_TUPLE_AND_RECORD_ARGUMENTS_IN_BIND_ARGUMENTS /* added 9-4-1999 */ + else if (!IsSimpleState (arg_p->arg_state)){ + NodeIdListElementS **a_node_ids_p_c,**b_node_ids_p_c; + + a_node_ids_p_c=a_node_ids_p; + b_node_ids_p_c=b_node_ids_p; + + bind_tuple_and_record_arguments (arg_p->arg_node->node_arguments,NULL,a_offset,b_offset,&a_node_ids_p_c,&b_node_ids_p_c); + + a_node_ids_p=a_node_ids_p_c; + b_node_ids_p=b_node_ids_p_c; + } +#endif + + if (IsSimpleState (arg_p->arg_state)){ + if (arg_p->arg_state.state_kind==OnB) + b_offset -= ObjectSizes [arg_p->arg_state.state_object]; + else + a_offset -= SizeOfAStackElem; + } else { + int asize,bsize; + + DetermineSizeOfState (arg_p->arg_state, &asize, &bsize); + a_offset -= asize; + b_offset -= bsize; + } + } + + *a_node_ids_p=a_node_ids; + *b_node_ids_p=b_node_ids; +} + +void ReduceArgumentToHnf (NodeIdP node_id,StateS state,int offset,SavedNidStateS **ifrule) +{ + if (IsSimpleState (state) && state.state_kind==OnA){ + GenJsrEval (offset); + state.state_kind = StrictOnA; + + if (ifrule && node_id){ + save_node_id_state (node_id,ifrule); + node_id->nid_state_ = state; + } + } + + if (ifrule==NULL && node_id!=NULL) + node_id->nid_state_=state; +} + +static void MatchLhsNode (NodeP node,StateS demstate,int aindex,int bindex,int asp,int bsp,struct ab_node_ids *ab_node_ids_p); + +void MatchArgs (Args args,int aindex,int bindex,int asp,int bsp,struct ab_node_ids *ab_node_ids_p) +{ + for (; args; args=args->arg_next){ + Node arg_node; + int asize, bsize; + + arg_node=args->arg_node; + + if (arg_node->node_kind!=NodeIdNode){ + ReduceArgumentToHnf (NULL,args->arg_state,asp-aindex,NULL); + MatchLhsNode (arg_node,args->arg_state,aindex,bindex,asp,bsp,ab_node_ids_p); + } else { + NodeId node_id; + + node_id=arg_node->node_node_id; + arg_node=node_id->nid_node; + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (arg_node!=NULL){ + ReduceArgumentToHnf (node_id,args->arg_state,asp-aindex,NULL); + MatchLhsNode (arg_node,args->arg_state,aindex,bindex,asp,bsp,ab_node_ids_p); + } else +#endif + { + node_id->nid_state_=args->arg_state; + } + } + + DetermineSizeOfState (args->arg_state,&asize,&bsize); + aindex -= asize; + bindex -= bsize; + } +} + +static void MatchLhsNode (NodeP node,StateS demstate,int aindex,int bindex,int asp,int bsp,struct ab_node_ids *ab_node_ids_p) +{ + Symbol symb; + + symb = node->node_symbol; + + switch (symb->symb_kind){ + case tuple_symb: + if (!IsSimpleState (demstate)){ +#if !BIND_UNBOXED_LHS_TUPLE_AND_RECORD_ARGUMENTS_IN_BIND_ARGUMENTS + bind_arguments (node->node_arguments,aindex,bindex,ab_node_ids_p); +#endif + MatchArgs (node->node_arguments,aindex,bindex,asp,bsp,ab_node_ids_p); + return; + } + break; + case definition: + { + SymbDef def; + + def = symb->symb_def; + if (def->sdef_kind==RECORDTYPE){ + if (demstate.state_type==RecordState){ +#if !BIND_UNBOXED_LHS_TUPLE_AND_RECORD_ARGUMENTS_IN_BIND_ARGUMENTS + bind_arguments (node->node_arguments,aindex,bindex,ab_node_ids_p); +#endif + MatchArgs (node->node_arguments,aindex,bindex,asp,bsp,ab_node_ids_p); + return; + } + } + } + } + error_in_function ("MatchLhsNode"); +} + +/* + static void BindArgs (Args args,int ara,int arb) + { + for (; args; args = args->arg_next){ + if (IsSimpleState (args->arg_state)){ + if (args->arg_state.state_kind==OnB){ + if (args->arg_node->node_kind==NodeIdNode) + args->arg_node->node_node_id->nid_b_index = arb; + arb -= ObjectSizes [args->arg_state.state_object]; + } else { + if (args->arg_node->node_kind==NodeIdNode) + args->arg_node->node_node_id->nid_a_index = ara; + ara -= SizeOfAStackElem; + } + } else { + int asize,bsize; + + if (args->arg_node->node_kind==NodeIdNode){ + args->arg_node->node_node_id->nid_a_index = ara; + args->arg_node->node_node_id->nid_b_index = arb; + } + + DetermineSizeOfState (args->arg_state, &asize, &bsize); + ara -= asize; + arb -= bsize; + } + } + } +*/ + +static void jump_false_to_next_alternative (LabDef *esclabel,int remove_a,int remove_b) +{ + if (remove_a==0 && remove_b==0) + GenJmpFalse (esclabel); + else { + LabDef to; + + MakeLabel (&to,m_symb,NewLabelNr++,no_pref); + GenJmpTrue (&to); + + GenPopA (remove_a); + GenPopB (remove_b); + GenJmp (esclabel); + GenLabelDefinition (&to); + } +} + +static void CheckSymbol (Label symblab,int arity,int stackpos,int remove_a,int remove_b,Label esclabel) +{ + GenEqDesc (symblab, arity, stackpos); + + jump_false_to_next_alternative (esclabel,remove_a,remove_b); +} + +static void GenNoMatchOnApplies (void) +{ + GenDumpString ("Runtime Error: left-hand-side application encountered\\n"); + GenHalt (); +} + +static void GenNoMatchOnIfs (void) +{ + GenDumpString ("Runtime Error: left-hand-side application of IF encountered\\n"); + GenHalt (); +} + +#ifdef GENERATE_RECORD_STATES_DURING_MATCH +static void SetArgumentStates (Args args, States argstates) +{ + int i; + + for (i = 0; args ; args = args->arg_next, i++) + args->arg_state = argstates [i]; +} +#endif + +void MatchError (int aselmts,int bselmts,SymbDef sdef,Bool root_node_needed,int string_already_generated) +{ + GenLabelDefinition (&CurrentAltLabel); + + CurrentAltLabel.lab_pref = no_pref; + CurrentAltLabel.lab_post = 0; + + if (sdef->sdef_exported) + CurrentAltLabel.lab_mod = CurrentModule; + + GenNoMatchError (sdef,root_node_needed ? aselmts+1 : aselmts,bselmts,string_already_generated); + + if (sdef->sdef_exported) + CurrentAltLabel.lab_mod = NULL; +} + +static char case_symb[] = "case"; + +static int generate_int_char_or_bool_match (struct arg *first_arg,int *matches_always_p) +{ + struct arg *arg; + int case_number; + + case_number=0; + for_l (arg,first_arg,arg_next){ + struct node *case_node; + struct symbol *symbol; + + case_node=arg->arg_node; + + switch (case_node->node_kind){ + case CaseNode: + { + LabDef case_label; + + symbol=case_node->node_symbol; + + MakeLabel (&case_label,case_symb,NewLabelNr,no_pref); + + if (symbol->symb_kind < Nr_Of_Predef_Types){ + if (symbol->symb_kind==bool_denot && case_number==1){ + GenJmp (&case_label); + *matches_always_p=1; + } else { + EqBasic (BasicSymbolStates [symbol->symb_kind].state_object,symbol->symb_val,0); + GenJmpTrue (&case_label); + } + } else + error_in_function ("generate_int_char_or_bool_match"); + + ++NewLabelNr; + break; + } + case DefaultNode: + return 1; + default: + error_in_function ("generate_int_char_or_bool_match"); + } + + ++case_number; + } + + return 0; +} + +static int generate_constructor_match (ArgP first_arg,int *matches_always_p) +{ + ArgP arg; + int case_number; + + for (arg=first_arg,case_number=0; arg!=NULL; arg=arg->arg_next,++case_number){ + struct node *case_node; + struct symbol *symbol; + + case_node=arg->arg_node; + + switch (case_node->node_kind){ + case DefaultNode: + return 1; + case CaseNode: + { + LabDef case_label; + + symbol=case_node->node_symbol; + + MakeLabel (&case_label,case_symb,NewLabelNr,no_pref); + ++NewLabelNr; + + if (symbol->symb_kind==definition){ + LabDef symbol_label; + SymbDef sdef; + + sdef=symbol->symb_def; + + if (sdef->sdef_kind==CONSTRUCTOR && sdef->sdef_type->type_nr_of_constructors==case_number+1){ + GenJmp (&case_label); + *matches_always_p=1; + } else { + if (sdef->sdef_kind==CONSTRUCTOR && sdef->sdef_strict_constructor && sdef->sdef_arity==case_node->node_arity){ + ConvertSymbolToKLabel (&symbol_label,sdef); + GenEqD_b (&symbol_label,0); + } else { + ConvertSymbolToConstructorDLabel (&symbol_label,sdef); + GenEqD_b (&symbol_label,case_node->node_arity); + } + GenJmpTrue (&case_label); + } + break; + } + } + default: + error_in_function ("generate_constructor_match"); + } + } + + return 0; +} + +#if 0 +extern char *node_id_name (NodeId node_id); +#endif + +#if FREE_STRICT_LHS_TUPLE_ELEMENTS +static void add_node_id_or_tuple_node_ids_to_list (NodeIdP node_id,NodeIdP push_node_id_p,NodeIdListElementS **free_node_ids_l) +{ + if (! (node_id->nid_node!=NULL && !IsSimpleState (node_id->nid_state))){ +#if defined (TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS) + if (!(node_id->nid_refcount<0 && (node_id->nid_mark2 & NID_LHS_PUSHED)==0)) +#endif + add_node_id_to_list (node_id,free_node_ids_l); + } else { + ArgP arg_p; + + for_l (arg_p,node_id->nid_node->node_arguments,arg_next){ + NodeP arg_node_p; + + arg_node_p=arg_p->arg_node; + if (arg_node_p->node_kind==NodeIdNode){ + NodeIdP node_id_p; + + node_id_p=arg_node_p->node_node_id; + if (node_id_p->nid_refcount==-1 && node_id!=push_node_id_p) +#if defined (TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS) + if (!(node_id_p->nid_refcount<0 && (node_id_p->nid_mark2 & NID_LHS_PUSHED)==0)) +#endif + add_node_id_or_tuple_node_ids_to_list (node_id_p,push_node_id_p,free_node_ids_l); + } + } + } +} +#endif + +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH +void set_local_reference_counts_and_add_free_node_ids (NodeP case_node,NodeIdListElementS **free_node_ids_l) +{ + NodeIdRefCountListP node_id_ref_count_elem; + NodeIdP push_node_id_p; + + if (case_node->node_arguments->arg_node->node_kind==PushNode) + push_node_id_p=case_node->node_arguments->arg_node->node_arguments->arg_node->node_node_id; + else + push_node_id_p=NULL; + + for_l (node_id_ref_count_elem,case_node->node_node_id_ref_counts,nrcl_next){ + int local_ref_count; + NodeIdP node_id; + + node_id=node_id_ref_count_elem->nrcl_node_id; + local_ref_count=node_id_ref_count_elem->nrcl_ref_count; + +# if 0 + printf ("global_to_local_ %s %d %d ",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_elem->nrcl_ref_count); +# endif + + if (local_ref_count==-1 && node_id!=push_node_id_p){ + if (unused_node_id_(node_id)){ +#if FREE_STRICT_LHS_TUPLE_ELEMENTS +# if 0 + printf ("global_to_local__ %s %d %d %d ",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_elem->nrcl_ref_count,node_id->nid_a_index); +# endif + + add_node_id_or_tuple_node_ids_to_list (node_id,push_node_id_p,free_node_ids_l); +#else + if (! (node_id->nid_node!=NULL && !IsSimpleState (node_id->nid_state))) + add_node_id_to_list (node_id,free_node_ids_l); +#endif + } + } + + node_id_ref_count_elem->nrcl_ref_count=node_id->nid_refcount - local_ref_count; + node_id->nid_refcount = local_ref_count; + } + +# if 0 + printf ("\n"); +# endif +} +#endif + +static int generate_code_for_switch_node (NodeP node,int asp,int bsp,struct esc *esc_p,StateP result_state_p, + SavedNidStateS **save_states_p,AbNodeIdsP ab_node_ids_p) +{ + int has_default,need_next_alternative,matches_always; + unsigned int first_case_label_number,case_number; + struct node_id *node_id; + struct arg *arg,*first_arg; + int a_index,b_index; + struct esc esc,old_esc; + int match_b_stack_top_element; + LabDef esc_case_label; + + node_id=node->node_node_id; + a_index=node_id->nid_a_index; + b_index=node_id->nid_b_index; + +#if 0 + ReduceArgumentToHnf (node_id,node->node_state,asp-a_index,save_states_p); +#else + if (node_id->nid_state.state_type!=SimpleState || node_id->nid_state.state_kind==OnB){ + node->node_state=node_id->nid_state; + } else + ReduceArgumentToHnf (node_id,node->node_state,asp-a_index,save_states_p); +#endif + + first_case_label_number=NewLabelNr; + + esc=*esc_p; + + need_next_alternative=0; + matches_always=0; + has_default=0; + + first_arg=node->node_arguments; + match_b_stack_top_element=0; + + if (first_arg->arg_node->node_kind==CaseNode && first_arg->arg_next!=NULL && first_arg->arg_next->arg_node->node_kind==CaseNode){ + if (node->node_state.state_type==SimpleState && (node->node_state.state_kind==OnA || node->node_state.state_kind==StrictOnA)){ + int first_case_symbol_kind; + Symbol symbol; + + symbol=first_arg->arg_node->node_symbol; + first_case_symbol_kind=symbol->symb_kind; + + if (first_case_symbol_kind==int_denot || first_case_symbol_kind==char_denot || first_case_symbol_kind==bool_denot){ + PushBasicFromAOnB (BasicSymbolStates [first_case_symbol_kind].state_object,asp-a_index); + match_b_stack_top_element=1; + + has_default=generate_int_char_or_bool_match (first_arg,&matches_always); + } + else if (first_case_symbol_kind==definition){ + SymbDef sdef; + + sdef=symbol->symb_def; + if (sdef->sdef_kind==CONSTRUCTOR){ + Symbol next_case_node_symbol; + SymbDef next_sdef; + + next_case_node_symbol=first_arg->arg_next->arg_node->node_symbol; + + if (! (next_case_node_symbol->symb_kind==definition && (next_sdef=next_case_node_symbol->symb_def, + next_sdef->sdef_kind==CONSTRUCTOR && next_sdef->sdef_type->type_nr_of_constructors==2))) + { + GenPushD_a (asp-a_index); + match_b_stack_top_element=1; + + has_default=generate_constructor_match (first_arg,&matches_always); + } + } + } + } + } + +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + ++node_id->nid_refcount; + + for_l (arg,node->node_arguments,arg_next){ + NodeIdRefCountListP *node_id_ref_count_elem_h,node_id_ref_count_elem_p; + struct node *case_node; + + case_node=arg->arg_node; + + node_id_ref_count_elem_h=&case_node->node_node_id_ref_counts; + + while ((node_id_ref_count_elem_p=*node_id_ref_count_elem_h)!=NULL){ + if (node_id_ref_count_elem_p->nrcl_node_id->nid_refcount==-1 && node_id_ref_count_elem_p->nrcl_ref_count==-1) + *node_id_ref_count_elem_h=node_id_ref_count_elem_p->nrcl_next; + else + node_id_ref_count_elem_h=&node_id_ref_count_elem_p->nrcl_next; + } + } + + --node_id->nid_refcount; +#endif + + if (!match_b_stack_top_element) + for (arg=first_arg,case_number=0; arg!=NULL; arg=arg->arg_next,++case_number){ + struct node *case_node; + struct symbol *symbol; + + case_node=arg->arg_node; + + switch (case_node->node_kind){ + case CaseNode: + { + LabDef case_label; + + symbol=case_node->node_symbol; + + MakeLabel (&case_label,case_symb,NewLabelNr,no_pref); + + switch (symbol->symb_kind){ + case definition: + { + LabDef symbol_label; + SymbDef sdef; + + sdef=symbol->symb_def; + if (sdef->sdef_kind==RECORDTYPE || (sdef->sdef_kind==CONSTRUCTOR + && sdef->sdef_type->type_nr_of_constructors==case_number+1)) + { + if (case_number==0 && arg->arg_next==NULL){ + SavedNidStateP saved_node_id_states; + int need_next_alternative; + + saved_node_id_states=NULL; + + ++node_id->nid_refcount; +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + { + NodeIdListElementP old_free_node_ids; + + old_free_node_ids=ab_node_ids_p->free_node_ids; + set_local_reference_counts_and_add_free_node_ids (case_node,&ab_node_ids_p->free_node_ids); +#else + set_local_reference_counts (case_node); +#endif + need_next_alternative= + generate_code_for_root_node + (case_node->node_arguments->arg_node,asp,bsp,&esc, + case_node->node_node_defs,result_state_p,&saved_node_id_states ,ab_node_ids_p); + + set_global_reference_counts (case_node); +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + ab_node_ids_p->free_node_ids=old_free_node_ids; + } +#endif + + --node_id->nid_refcount; + + restore_saved_node_id_states (saved_node_id_states); + return need_next_alternative; + } + + GenJmp (&case_label); + matches_always=1; + } else { + if (sdef->sdef_kind==CONSTRUCTOR && sdef->sdef_strict_constructor + && sdef->sdef_arity==case_node->node_arity) + { + ConvertSymbolToKLabel (&symbol_label,sdef); + GenEqDesc (&symbol_label,0,asp-a_index); + } else { + ConvertSymbolToConstructorDLabel (&symbol_label,sdef); + GenEqDesc (&symbol_label,case_node->node_arity,asp-a_index); + } + GenJmpTrue (&case_label); + } + break; + } + case cons_symb: + if (case_number==1){ + GenJmp (&case_label); + matches_always=1; + } else { + GenEqDesc (&cons_lab,case_node->node_arity,asp-a_index); + GenJmpTrue (&case_label); + } + break; + case nil_symb: + if (case_number==1){ + GenJmp (&case_label); + matches_always=1; + } else { + GenEqDesc (&nil_lab,case_node->node_arity,asp-a_index); + GenJmpTrue (&case_label); + } + break; + case tuple_symb: + if (case_number==0 && arg->arg_next==NULL){ + SavedNidStateP saved_node_id_states; + int need_next_alternative; + + saved_node_id_states=NULL; + + ++node_id->nid_refcount; +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + { + NodeIdListElementP old_free_node_ids; + + old_free_node_ids=ab_node_ids_p->free_node_ids; + set_local_reference_counts_and_add_free_node_ids (case_node,&ab_node_ids_p->free_node_ids); +#else + set_local_reference_counts (case_node); +#endif + + need_next_alternative= + generate_code_for_root_node + (case_node->node_arguments->arg_node,asp,bsp,&esc, + case_node->node_node_defs,result_state_p,&saved_node_id_states ,ab_node_ids_p); + + set_global_reference_counts (case_node); +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + ab_node_ids_p->free_node_ids=old_free_node_ids; + } +#endif + --node_id->nid_refcount; + + restore_saved_node_id_states (saved_node_id_states); + return need_next_alternative; + } +#if defined (TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS) + if (!(arg->arg_next->arg_node->node_kind==DefaultNode)) +#endif + GenJmp (&case_label); + matches_always=1; + break; + case apply_symb: + case if_symb: + error_in_function ("generate_code_for_switch_node"); + return 0; + case string_denot: + if (IsSimpleState (node->node_state)){ + GenPushArray (asp-a_index); + IsString (symbol->symb_val); + } else { + GenPushA (asp-a_index); + IsString (symbol->symb_val); + } + GenJmpTrue (&case_label); + break; + default: + if (symbol->symb_kind < Nr_Of_Predef_Types){ + ObjectKind denot_type; + + denot_type = BasicSymbolStates [symbol->symb_kind].state_object; + + if (node->node_state.state_object==denot_type){ + if (symbol->symb_kind==bool_denot && case_number==1){ + GenJmp (&case_label); + matches_always=1; + } else { + if (node->node_state.state_kind==OnB) + EqBasic (denot_type,symbol->symb_val,bsp-b_index); + else + IsBasic (denot_type,symbol->symb_val,asp-a_index); + + GenJmpTrue (&case_label); + } + break; + } else if (node->node_state.state_object==UnknownObj +#if ABSTRACT_OBJECT + || node->node_state.state_object==AbstractObj +#endif + ){ + IsBasic (denot_type,symbol->symb_val,asp-a_index); + GenJmpTrue (&case_label); + } else + error_in_function ("generate_code_for_switch_node"); + } else + error_in_function ("generate_code_for_switch_node"); + } + + ++NewLabelNr; + break; + } + case DefaultNode: + has_default=1; + break; + default: + error_in_function ("generate_code_for_switch_node"); + } + } + + if (has_default){ + MakeLabel (&esc_case_label,case_symb,NewLabelNr,no_pref); + ++NewLabelNr; + + if (!matches_always){ + if (match_b_stack_top_element) + GenPopB (1); + GenJmp (&esc_case_label); + } + + old_esc=esc; + + esc.esc_asp=asp; + esc.esc_bsp=bsp; + esc.esc_label=&esc_case_label; + } else + if (/* !has_default && */ !matches_always){ + int n_pop_a; + + need_next_alternative=1; + + n_pop_a=asp-esc.esc_asp; + + if (n_pop_a>0) + GenPopA (n_pop_a); + else if (n_pop_a<0){ + int offset; + + GenBuildh (&nil_lab,0); + + offset=0; + while (++n_pop_a!=0) + GenPushA (offset++); + } + + if (match_b_stack_top_element) + GenPopB (bsp+1-esc.esc_bsp); + else + GenPopB (bsp-esc.esc_bsp); + + GenJmp (esc.esc_label); + } + + for_l (arg,node->node_arguments,arg_next){ + struct node *case_node; + LabDef case_label; + SavedNidStateP saved_node_id_states; + + case_node=arg->arg_node; + + MakeLabel (&case_label,case_symb,first_case_label_number,no_pref); + ++first_case_label_number; + + GenLabelDefinition (&case_label); + + saved_node_id_states=NULL; + + ++node_id->nid_refcount; +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + { + NodeIdListElementP old_free_node_ids; + + old_free_node_ids=ab_node_ids_p->free_node_ids; + set_local_reference_counts_and_add_free_node_ids (case_node,&ab_node_ids_p->free_node_ids); +#else + set_local_reference_counts (case_node); +#endif + + if (case_node->node_kind==CaseNode){ + if (match_b_stack_top_element) + GenPopB (1); + + if (generate_code_for_root_node + (case_node->node_arguments->arg_node,asp,bsp,&esc,case_node->node_node_defs, + result_state_p,&saved_node_id_states,ab_node_ids_p) && !has_default) + { + need_next_alternative=1; + } + } else { + if (generate_code_for_root_node + (case_node->node_arguments->arg_node,asp,bsp,&old_esc,case_node->node_node_defs, + result_state_p,&saved_node_id_states,ab_node_ids_p)) + { + need_next_alternative=1; + } + } + + set_global_reference_counts (case_node); +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + ab_node_ids_p->free_node_ids=old_free_node_ids; + } +#endif + --node_id->nid_refcount; + + restore_saved_node_id_states (saved_node_id_states); + } + + return need_next_alternative; +} + +/* #define unused_node_id(node_id) ((node_id)->nid_refcount!=-1 ? (node_id)->nid_refcount==0 : unused_node_id_ (node_id)) */ + +int unused_node_id_ (NodeId node_id) +{ + if (!(node_id->nid_mark & NID_STRICT_LHS_TUPLE_ELEMENT_MASK)) + return True; + + node_id=node_id->nid_lhs_tuple_node_id; + + while (node_id->nid_refcount==-1){ + if (!(node_id->nid_mark & NID_STRICT_LHS_TUPLE_ELEMENT_MASK)) + return True; + + node_id=node_id->nid_lhs_tuple_node_id; + } + + return False; +} + +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) +{ + NodeIdP node_id_p; + struct node_id_list_element *arg_node_id_list; + int a_index,b_index; + struct arg *arguments; + int a_size,b_size; + int a_remove,b_remove; + int source_a_index,source_b_index; + int update_stack_size; + struct ab_node_ids ab_node_ids; + struct update updates[MaxNodeArity]; + + ab_node_ids=*ab_node_ids_p; + + arguments=node->node_arguments; + + node_id_p=arguments->arg_node->node_node_id; + +#if defined (TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS) + if (!IsSimpleState (node_id_p->nid_state) && node_id_p->nid_refcount<0 && node_id_p->nid_node!=NULL){ + for_l (arg_node_id_list,node->node_node_ids,nidl_next){ + NodeIdP arg_node_id; + + arg_node_id=arg_node_id_list->nidl_node_id; + arg_node_id->nid_mark2 |= NID_LHS_PUSHED; + arg_node_id->nid_state = *arg_node_id->nid_lhs_state_p; + } + + return generate_code_for_root_node (arguments->arg_next->arg_node,asp,bsp,esc_p,defs,result_state_p,save_states_p,&ab_node_ids); + } +#endif + + a_size=0; + b_size=0; + + a_remove=0; + b_remove=0; + + for_l (arg_node_id_list,node->node_node_ids,nidl_next){ + NodeIdP arg_node_id; + + arg_node_id=arg_node_id_list->nidl_node_id; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + arg_node_id->nid_mark2 |= NID_LHS_PUSHED; + arg_node_id->nid_state = *arg_node_id->nid_lhs_state_p; +#endif + + if (arg_node_id->nid_refcount==-1){ + if (IsSimpleState (arg_node_id->nid_state)){ + if (arg_node_id->nid_state.state_kind==OnB) + b_remove += ObjectSizes [arg_node_id->nid_state.state_object]; + else + a_remove += SizeOfAStackElem; + } else + AddSizeOfState (arg_node_id->nid_state,&a_remove,&b_remove); + } + + if (IsSimpleState (arg_node_id->nid_state)){ + if (arg_node_id->nid_state.state_kind==OnB) + b_size += ObjectSizes [arg_node_id->nid_state.state_object]; + else + a_size += SizeOfAStackElem; + } else { + /* added 6-8-1999 */ +#if defined (TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS) + arg_node_id->nid_node=NULL; +#endif + /* */ + AddSizeOfState (arg_node_id->nid_state,&a_size,&b_size); + } + } + + +#if FREE_STRICT_LHS_TUPLE_ELEMENTS /* added 26-4-2000 */ + { + NodeIdListElementP removed_free_node_id_p,*removed_free_node_id_h; + + removed_free_node_id_p=NULL; +#endif + + if (!IsSimpleState (node_id_p->nid_state)){ + int a_size,b_size; + + DetermineSizeOfState (node_id_p->nid_state,&a_size,&b_size); + + if (unused_node_id (node_id_p) && (a_size==0 || node_id_p->nid_a_index==asp) && (b_size==0 || node_id_p->nid_b_index==bsp)){ + asp-=a_size; + bsp-=b_size; + + if (ab_node_ids.a_node_ids!=NULL && ab_node_ids.a_node_ids->nidl_node_id==node_id_p) + ab_node_ids.a_node_ids=ab_node_ids.a_node_ids->nidl_next; + + if (ab_node_ids.b_node_ids!=NULL && ab_node_ids.b_node_ids->nidl_node_id==node_id_p) + ab_node_ids.b_node_ids=ab_node_ids.b_node_ids->nidl_next; + } else { + int a_offset,b_offset; + + a_offset=(asp-node_id_p->nid_a_index)+a_size-1; + while (a_size){ + GenPushA (a_offset); + --a_size; + } + + b_offset=(bsp-node_id_p->nid_b_index)+b_size-1; + while (b_size){ + GenPushB (b_offset); + --b_size; + } + + node_id_p->nid_node=NULL; /* to prevent codegen2 from using a_index and b_index of elements */ + } + } else { +#ifdef REUSE_UNIQUE_NODES + if (node->node_number!=0){ + if (b_size==0) + GenPushArgsU (asp-node_id_p->nid_a_index,a_size,a_size); + else + GenPushRArgsU (asp-node_id_p->nid_a_index,a_size,b_size); + } +# ifdef DESTRUCTIVE_RECORD_UPDATES + else if (node->node_record_symbol->symb_kind==definition && + node->node_record_symbol->symb_def->sdef_kind==RECORDTYPE && + (node_id_p->nid_mark2 & NID_HAS_REFCOUNT_WITHOUT_UPDATES)!=0 && + node_id_p->nid_number==-2) + { + node_id_p->nid_number=-1; + if (b_size==0) + GenPushArgsU (asp-node_id_p->nid_a_index,a_size,a_size); + else + GenPushRArgsU (asp-node_id_p->nid_a_index,a_size,b_size); + } +# endif + else { +#endif + + if (unused_node_id (node_id_p)){ + if (node_id_p->nid_a_index==asp){ + if (b_size==0) + GenReplArgs (a_size,a_size); + 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) + ab_node_ids.a_node_ids=ab_node_ids.a_node_ids->nidl_next; + +#if FREE_STRICT_LHS_TUPLE_ELEMENTS /* added 26-4-2000 */ + removed_free_node_id_h=&ab_node_ids.free_node_ids; + + while ((removed_free_node_id_p=*removed_free_node_id_h)!=NULL){ + if (removed_free_node_id_p->nidl_node_id==node_id_p){ + *removed_free_node_id_h=removed_free_node_id_p->nidl_next; + break; + } + removed_free_node_id_h=&removed_free_node_id_p->nidl_next; + } +#endif + + --asp; + } else { + if (b_size==0) + GenPushArgs (asp-node_id_p->nid_a_index,a_size,a_size); + else + GenPushRArgs (asp-node_id_p->nid_a_index,a_size,b_size); + + GenBuildh (&nil_lab,0); + GenUpdateA (0,1+a_size+asp-node_id_p->nid_a_index); + GenPopA (1); + } + } else { + if (b_size==0) + GenPushArgs (asp-node_id_p->nid_a_index,a_size,a_size); + else + GenPushRArgs (asp-node_id_p->nid_a_index,a_size,b_size); + } + +#ifdef REUSE_UNIQUE_NODES + } +#endif + } + + asp+=a_size; + bsp+=b_size; + + source_a_index=asp; + source_b_index=bsp; + + a_index = source_a_index-a_remove; + b_index = source_b_index-b_remove; + + update_stack_size=0; + + { + struct node_id_list_element **a_node_ids_p,**b_node_ids_p,*a_node_ids,*b_node_ids; + + a_node_ids=ab_node_ids.a_node_ids; + b_node_ids=ab_node_ids.b_node_ids; + + a_node_ids_p=&ab_node_ids.a_node_ids; + b_node_ids_p=&ab_node_ids.b_node_ids; + + for_l (arg_node_id_list,node->node_node_ids,nidl_next){ + int asize,bsize; + struct node_id *arg_node_id; + + arg_node_id=arg_node_id_list->nidl_node_id; + + DetermineSizeOfState (arg_node_id->nid_state,&asize,&bsize); + + arg_node_id->nid_a_index_ = a_index; + arg_node_id->nid_b_index_ = b_index; + + if (arg_node_id->nid_refcount==-1){ + source_a_index -= asize; + source_b_index -= bsize; + + continue; + } + + if (IsSimpleState (arg_node_id->nid_state) || arg_node_id->nid_node==NULL){ + struct node_id_list_element *new_p_node_id; + + if (asize!=0){ + new_p_node_id=CompAllocType (struct node_id_list_element); + new_p_node_id->nidl_node_id=arg_node_id; + + *a_node_ids_p=new_p_node_id; + a_node_ids_p=&new_p_node_id->nidl_next; + } + + if (bsize!=0){ + new_p_node_id=CompAllocType (struct node_id_list_element); + new_p_node_id->nidl_node_id=arg_node_id; + + *b_node_ids_p=new_p_node_id; + b_node_ids_p=&new_p_node_id->nidl_next; + } + } + + if (a_index!=source_a_index || b_index!=source_b_index){ + struct update *update_p; + + update_p=&updates[update_stack_size++]; + + update_p->a_from_offset=source_a_index; + update_p->a_to_offset=a_index; + update_p->a_size=asize; + update_p->b_from_offset=source_b_index; + update_p->b_to_offset=b_index; + update_p->b_size=bsize; + } + + a_index -= asize; + b_index -= bsize; + source_a_index -= asize; + source_b_index -= bsize; + } + + *a_node_ids_p=a_node_ids; + *b_node_ids_p=b_node_ids; + } + + while (update_stack_size!=0){ + struct update *update_p; + int to,from,size; + + update_p=&updates[--update_stack_size]; + + size=update_p->a_size; + from=update_p->a_from_offset; + to=update_p->a_to_offset; + while (size!=0){ + --size; + GenUpdateA (asp-(from-size),asp-(to-size)); + } + + size=update_p->b_size; + from=update_p->b_from_offset; + to=update_p->b_to_offset; + while (size!=0){ + --size; + GenUpdateB (bsp-(from-size),bsp-(to-size)); + } + } + + GenPopA (a_remove); + GenPopB (b_remove); + + asp-=a_remove; + bsp-=b_remove; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + { + int r; + + r=generate_code_for_root_node (arguments->arg_next->arg_node,asp,bsp,esc_p,defs,result_state_p,save_states_p,&ab_node_ids); + +#if FREE_STRICT_LHS_TUPLE_ELEMENTS /* added 26-4-2000 */ + if (removed_free_node_id_p!=NULL) + *removed_free_node_id_h=removed_free_node_id_p; +#endif + for_l (arg_node_id_list,node->node_node_ids,nidl_next){ + NodeIdP arg_node_id; + + arg_node_id=arg_node_id_list->nidl_node_id; + + arg_node_id->nid_mark2 &= ~NID_LHS_PUSHED; + } + + return r; + } +#else + return generate_code_for_root_node (arguments->arg_next->arg_node,asp,bsp,esc_p,defs,result_state_p,save_states_p,&ab_node_ids); +#endif + +#if FREE_STRICT_LHS_TUPLE_ELEMENTS /* added 26-4-2000 */ + } +#endif +} + +int generate_code_for_root_node (NodeP node,int asp,int bsp,struct esc *esc_p,NodeDefP defs,StateP result_state_p, + SavedNidStateS **save_states_p,AbNodeIdsP ab_node_ids_p) +{ + switch (node->node_kind){ + case SwitchNode: + return generate_code_for_switch_node (node,asp,bsp,esc_p,result_state_p,save_states_p,ab_node_ids_p); + case PushNode: + return generate_code_for_push_node (node,asp,bsp,esc_p,defs,result_state_p,save_states_p,ab_node_ids_p); + case GuardNode: + while (node->node_kind==GuardNode){ + SavedNidStateP saved_node_id_states; + ArgP arguments; + int fail_label_number; + LabDef fail_label; + struct esc guard_esc; + + fail_label_number=NewLabelNr++; + MakeLabel (&fail_label,"fail",fail_label_number,no_pref); + + arguments=node->node_arguments; + + saved_node_id_states=NULL; + + guard_esc.esc_asp=asp; + guard_esc.esc_bsp=bsp; + guard_esc.esc_label=&fail_label; + +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + { + NodeIdListElement old_free_node_ids; + + old_free_node_ids=ab_node_ids_p->free_node_ids; +#endif + generate_code_for_root_node (arguments->arg_node,asp,bsp,&guard_esc,defs,result_state_p,&saved_node_id_states,ab_node_ids_p); + +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + ab_node_ids_p->free_node_ids=old_free_node_ids; + } +#endif + + restore_saved_node_id_states (saved_node_id_states); + + GenLabelDefinition (&fail_label); + + defs=node->node_node_defs; + node=arguments->arg_next->arg_node; + } + + return generate_code_for_root_node (node,asp,bsp,esc_p,defs,result_state_p,save_states_p,ab_node_ids_p); + default: + { + NodeP else_node; + + else_node=node; + while (else_node->node_kind==IfNode) + else_node=else_node->node_arguments->arg_next->arg_next->arg_node; + + return CodeRhsNodeDefs (node,defs,asp,bsp,save_states_p,*result_state_p,esc_p,ab_node_ids_p->a_node_ids, + ab_node_ids_p->b_node_ids, +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + ab_node_ids_p->free_node_ids, +#else + NULL, +#endif + !(else_node->node_kind==NormalNode && else_node->node_symbol->symb_kind==fail_symb)); + } + } +} diff --git a/backendC/CleanCompilerSources/codegen1.h b/backendC/CleanCompilerSources/codegen1.h new file mode 100644 index 0000000..d388317 --- /dev/null +++ b/backendC/CleanCompilerSources/codegen1.h @@ -0,0 +1,125 @@ + +struct esc { + int esc_asp; + int esc_bsp; + struct label * esc_label; +}; + +extern char d_pref[],s_pref[],n_pref[],l_pref[],no_pref[],ea_pref[],caf_pref[], + glob_sel[],m_symb[]; +#ifdef THUNK_LIFT_SELECTORS +extern char glob_selr[]; +#endif + +extern char channel_code [],ext_nf_reducer_code[],nf_reducer_code[],hnf_reducer_code[],ext_hnf_reducer_code[]; + +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, +#ifdef CLEAN2 + select_with_dictionary_lab, update_with_dictionary_lab, +#endif + CurrentAltLabel; + +extern Label ReduceError; + +#define ExpectsResultNode(state) ((state).state_type==SimpleState && (state).state_kind>StrictRedirection) + +#define IsSimpleState(state) ((state).state_type==SimpleState) + +extern void FileComment (void); + +extern void PrintNodeId (NodeId nid); + +extern void PrintComment (void); +extern void LhsComment (unsigned int altnr, int asp, int bsp); +extern void StrictIdComment (NodeId id); +extern void NodeDefComment (NodeDefs nd, char *msg); +extern void ContractumComment (int asp, int bsp); +extern void RedirectionComment (NodeId nid); +extern void ArgComment (Args arg); +extern void NodeIdComment (NodeId node_id); +extern void TypeArgComment (TypeArgs arg); +extern void ParComment (Args arg); + +extern void InitStackFrame (int offframe[], int defframe [], int max); +extern void InitStackConversions (int maxa, int maxb, int *oldamax, int *oldbmax); +extern void InitAStackConversions (int maxa,int *oldamax_p); +extern void ExitStackConversions (int oldamax, int oldbmax); +extern void GenAStackConversions (int sp,int demsize); +extern void GenBStackConversions (int sp,int demsize); + +extern int *DemandedAFrame,*DemandedBFrame,CurrentAFrameSize,CurrentBFrameSize; + +extern void FreeAFrameSpace (int previoussize); +extern void ReserveBFrameSpace (int size, int *oldsize); +extern void FreeBFrameSpace (int previoussize); +extern int *AllocTempDemandedAFrame (int size); +extern int *AllocTempDemandedBFrame (int size); +extern void CreateStackFrames (void); +extern void PutInBFrames (int bsp, int *b_ind, int size); +extern void PutInAFrames (int asp, int *a_ind); + +extern void MakeLabel (Label lab, char *name, unsigned num, char *pref); +extern void MakeSymbolLabel (Label lab, char *mod, char *pref,SymbDef sdef, unsigned num); + +extern void ConvertSymbolToLabel (LabDef *slab,SymbDef sdef); +extern void ConvertSymbolToDLabel (LabDef *slab,SymbDef sdef); +extern void ConvertSymbolToKLabel (LabDef *slab,SymbDef sdef); +extern void ConvertSymbolToRLabel (LabDef *slab,SymbDef sdef); +extern void ConvertSymbolToDandNLabel (LabDef *d_lab,LabDef *n_lab,SymbDef sdef); +extern void ConvertSymbolToConstructorDLabel (LabDef *slab,SymbDef sdef); +extern void ConvertSymbolToConstructorDandNLabel (LabDef *d_lab,LabDef *n_lab,SymbDef sdef); +extern void ConvertSymbolToRecordDandNLabel (LabDef *d_lab,LabDef *n_lab,SymbDef sdef); + +extern void BuildLazyTupleSelectorLabel (Label slab,int arity,int argnr); +#if defined (THUNK_LIFT_SELECTORS) +extern void BuildLazyTupleSelectorAndRemoveLabel (Label slab,int arity,int argnr); +#endif + +extern void DetermineSizeOfStates (int arity, States states, int *asize, int *bsize); +extern void DetermineSizeOfState (StateS state, int *asize, int *bsize); +extern void AddSizeOfState (StateS state, int *asize, int *bsize); + +extern void AddStateSizeAndMaxFrameSize (StateS state, int *maxasize,int *asize, int *bsize); +extern void AddStateSizesAndMaxFrameSizes (int arity, States states,int *maxasize, int *asize, int *bsize); +extern void AddStateSizesAndMaxFrameSizesOfArguments (Args args,int *maxasize, int *asize, int *bsize); +extern void DetermineFieldSizeAndPosition (int fieldnr, int *asize, int *bsize,int *apos, int *bpos, States argstates); + +extern void GenerateCodeForConstructorsAndRecords (Symbol symbs); +extern void GenerateStatesForRecords (Symbol symbs); + +extern Bool NodeEntry (StateS *const function_state_p,int arity,Label ealab,SymbDef rootsymb); +extern Bool NodeEntryUnboxed (StateS *const function_state_p,NodeP call_node_p,int args_a_size,int args_b_size,Label ealab,SymbDef rootsymb); +extern void ApplyEntry (StateS *const function_state_p,int arity,Label ealab,int ea_label_follows); + +extern Bool ConvertExternalToInternalCall (int arity,StateS *const ext_function_state_p,StateS *const int_function_state_p, + Bool skip_entry,int intasp,int intbsp,Label ealab,Label extlab,Bool root_node_needed); +extern void GenerateCodeForLazyTupleSelectorEntries (Bool *selectors); +extern void GenerateCodeForLazyArrayFunctionEntries (void); + +extern int next_update_function_n,next_match_function_n; + +extern ImpRuleS *first_update_function,**update_function_p; +extern SymbDef CreateUpdateFunction (ArgS *record_arg,ArgS *first_field_arg,Node node); +#if U_RECORD_SELECTORS +extern SymbDef create_select_function (Symbol selector_symbol,int selector_kind); +#endif +extern SymbDef create_match_function (struct symbol *constructor_symbol,int constructor_arity,int strict_constructor); +extern SymbDef create_select_and_match_function (struct symbol *constructor_symbol,int strict_constructor); + +extern void ReduceArgumentToHnf (NodeId node_id,StateS state,int offset,struct saved_nid_state **save_states_p); +extern void BindArgs (Args args,int ara,int arb); +extern void MatchArgs (Args args,int aindex,int bindex,int asp,int bsp,struct ab_node_ids *ab_node_ids_p); + +extern void MatchError (int aselmts,int bselmts,SymbDef sdef,Bool root_node_needed,int string_already_generated); + +extern int generate_code_for_root_node + (struct node *node,int asp,int bsp,struct esc *esc_p,NodeDefs defs, + struct state *result_state_p,struct saved_nid_state **save_states_p ,struct ab_node_ids *ab_node_ids_p); + +extern ImpRuleS *create_simple_imp_rule (struct node *lhs_root,struct node *rhs_root,SymbDefP function_sdef); + +#define unused_node_id(node_id) ((node_id)->nid_refcount!=-1 ? (node_id)->nid_refcount==0 : unused_node_id_ (node_id)) +extern int unused_node_id_ (NodeId node_id); + diff --git a/backendC/CleanCompilerSources/codegen2.c b/backendC/CleanCompilerSources/codegen2.c new file mode 100644 index 0000000..4dcfd77 --- /dev/null +++ b/backendC/CleanCompilerSources/codegen2.c @@ -0,0 +1,5441 @@ +/* + (Concurrent) Clean Compiler: Code Generator + + Authors: Sjaak Smetsers & John van Groningen + At: University of Nijmegen, department of computing science + Version: 1.2 +*/ + +#pragma segment codegen2 +#pragma options (!macsbug_names) + +#define FASTER_STRICT_IF /* also in statesgen.c */ +#define DO_LAZY_SELECTORS_FROM_BOXED_STRICT_RECORDS +#define FREE_STRICT_LHS_TUPLE_ELEMENTS 1 /* also in codegen1.c */ +#define SELECTORS_FIRST 1 /* also in codegen.c */ + +#include "system.h" +#include "syntaxtr.t" +#include "comsupport.h" + +#include "settings.h" +#include "sizes.h" +#include "checker.h" +#include "codegen_types.h" +#include "codegen.h" +#include "codegen1.h" +#include "codegen2.h" +#include "sa.h" +#include "statesgen.h" +#include "transform.h" +#include "instructions.h" +#include "typechecker.h" +#include "optimisations.h" +#include "buildtree.h" + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) +#define for_li(v,i,l,n) for(v=(l),i=0;v!=NULL;v=v->n,++i) +#define for_ll(v1,v2,l1,l2,n1,n2) for(v1=(l1),v2=(l2);v1!=NULL;v1=v1->n1,v2=v2->n2) +#define for_la(v1,v2,l1,l2,n1) for(v1=(l1),v2=(l2);v1!=NULL;v1=v1->n1,++v2) + +static void error_in_function (char *m) +{ + ErrorInCompiler ("codegen2.c",m,""); +} + +char *Co_Wtype = "incorrect type"; +char *Co_Wspine = "non-terminating rule specified"; + +char else_symb[] = "else"; +char then_symb[] = "then"; +char notused_string[] = "notused"; + +SymbDef ApplyDef,IfDef; + +unsigned NewLabelNr; + +StateS StrictOnAState; +static StateS UnderEvalState,ProcIdState; + +StateS OnAState; + +Bool LazyTupleSelectors [MaxNodeArity-NrOfGlobalSelectors]; + +LabDef BasicDescriptors [NrOfObjects]; +int ObjectSizes [NrOfObjects]; + +static void InitBasicDescriptor (ObjectKind kind,char *name,int size) +{ + BasicDescriptors[kind].lab_mod = NULL; + BasicDescriptors[kind].lab_pref = no_pref; + BasicDescriptors[kind].lab_issymbol = False; + BasicDescriptors[kind].lab_name = name; + BasicDescriptors[kind].lab_post = 0; + ObjectSizes[kind] = size; +} + +Bool EqualState (StateS st1,StateS st2) +{ + if (IsSimpleState (st1) && IsSimpleState (st2)) + return st1.state_kind==st2.state_kind; + + switch (st1.state_type){ + case RecordState: + return st2.state_type==RecordState; + case TupleState: + if (st2.state_type==TupleState && st1.state_arity==st2.state_arity){ + int i; + + for (i=0; i<st1.state_arity; i++) + if (!EqualState (st1.state_tuple_arguments[i],st2.state_tuple_arguments[i])) + return False; + + return True; + } else + return False; + case ArrayState: + return st2.state_type==ArrayState; + default: + return False; + } +} + +/* int InitAStackTop,InitBStackTop; */ + +void NewEmptyNode (int *asp_p,int nrargs) +{ + GenCreate (nrargs); + *asp_p += SizeOfAStackElem; +} + +void save_node_id_state (NodeId node_id,SavedNidStateS **saved_nid_state_l) +{ + SavedNidStateP new_saved_state; + + new_saved_state=CompAllocType (SavedNidStateS); + + new_saved_state->save_state=node_id->nid_state; + new_saved_state->save_node_id=node_id; + + new_saved_state->save_next=*saved_nid_state_l; + *saved_nid_state_l=new_saved_state; +} + +void restore_saved_node_id_states (SavedNidStateP saved_node_id_states) +{ + while (saved_node_id_states){ + saved_node_id_states->save_node_id->nid_state_=saved_node_id_states->save_state; + saved_node_id_states=saved_node_id_states->save_next; + } +} + +static Bool CopyArgument (StateS demstate,StateS offstate,int aindex,int bindex,int *asp_p,int *bsp_p,int offasize,int offbsize,Bool newnode); + +static void GenProcIdCalculation (Node node,Annotation annot,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + if (annot==ParallelAtAnnot){ + Node procidnode; + + procidnode=get_p_at_node (node); + if (procidnode->node_kind!=NodeIdNode) + Build (procidnode,asp_p,bsp_p,code_gen_node_ids_p); + else { + int asize,bsize; + NodeId nid; + + nid=procidnode->node_node_id; + + DetermineSizeOfState (nid->nid_state,&asize,&bsize); + CopyArgument (ProcIdState,nid->nid_state,nid->nid_a_index,nid->nid_b_index,asp_p,bsp_p,asize,bsize,False); + } + } else { + GenNewP(); + ++*bsp_p; + } +} + +static void GenRedIdCalculation (Node redidnode,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + if (redidnode){ + if (redidnode->node_kind!=NodeIdNode) + Build (redidnode,asp_p,bsp_p,code_gen_node_ids_p); + else { + int asize,bsize; + NodeId nid; + + nid=redidnode->node_node_id; + + DetermineSizeOfState (nid->nid_state,&asize, &bsize); + CopyArgument (ProcIdState,nid->nid_state,nid->nid_a_index,nid->nid_b_index,asp_p,bsp_p,asize, bsize, False); + } + } else + GenPushReducerId (-1); +} + +static char *GetReducerCode (Annotation annot) +{ + switch (annot) + { case ParallelAnnot: + case ParallelAtAnnot: + return ext_hnf_reducer_code; + case ParallelNFAnnot: + return ext_nf_reducer_code; + default: + return ""; + } +} + +void UnpackRecord (int aindex,int *asp_p,int *bsp,Bool removeroot,int arity,States argstates) +{ + int asize,bsize; + + DetermineSizeOfStates (arity, argstates, & asize, & bsize); + + if (removeroot) + GenReplRArgs (asize, bsize); + else + GenPushRArgs (*asp_p - aindex, asize , bsize); + *asp_p += asize; + *bsp += bsize; +} + +static void UnpackArrayOnTopOfStack (void) +{ + GenPushArray (0); +#if UPDATE_POP + GenUpdatePopA (0,1); +#else + GenUpdateA (0,1); + GenPopA (1); +#endif +} + +void UnpackArray (int aindex, int *asp_p, Bool removeroot) +{ + if (removeroot){ + GenPushArray (0); +#if UPDATE_POP + GenUpdatePopA (0,1); +#else + GenUpdateA (0,1); + GenPopA (1); +#endif + } else + GenPushArray (*asp_p - aindex); + + *asp_p += SizeOfAStackElem; +} + +Coercions CoerceStateKind (StateKind dem_state_kind, StateKind off_state_kind) +{ + if (dem_state_kind==Undefined) + error_in_function ("CoerceStateKind"); + + switch (off_state_kind){ + case OnB: + if (dem_state_kind == OnB) + return BToB; + else + return BToA; + case OnA: + case SemiStrict: + case LazyRedirection: + if (dem_state_kind == OnA) + return AToA; + else + return Reduce; + case StrictOnA: + if (dem_state_kind == OnB) + return AToB; + else + return AToA; + case StrictRedirection: + if (dem_state_kind == OnB) + return AToB; + else if (dem_state_kind == StrictRedirection) + return AToA; + else + return AToRoot; + case Parallel: + if (dem_state_kind == OnA) + return AToA; + else + StaticMessage (False, "","parallel annotation in strict context ignored"); + return Reduce; + case UnderEval: + if (dem_state_kind == OnA) + return MayBecomeCyclicSpine; + else + return CyclicSpine; + default: + error_in_function ("CoerceStateKind"); + return AToA; + } +} + +Bool TypeErrorFound, CycleErrorFound; + +void GenReduceError (void) +{ + GenDAStackLayout (0); + GenJsr (&cycle_lab); + GenOAStackLayout (0); + + CycleErrorFound = True; +} + +Coercions CoerceSimpleStateArgument (StateS demstate,StateKind offkind,int aindex,int *asp_p,Bool leaveontop, Bool *ontop) +{ + Coercions c; + + /* Examine the argument states to see whether it has to be reduced */ + + if (IsSimpleState (demstate)) + c = CoerceStateKind (demstate.state_kind, offkind); + else + c = CoerceStateKind (StrictOnA, offkind); + + switch (c){ + case Reduce: + if (leaveontop){ + GenPushA (*asp_p - aindex); + GenJsrEval (0); + *asp_p += SizeOfAStackElem; + *ontop = True; + } else { + GenJsrEval (*asp_p - aindex); + *ontop = False; + } + break; + case MayBecomeCyclicSpine: + GenCreate (-1); + *asp_p += SizeOfAStackElem; + *ontop = True; + break; + case CyclicSpine: + GenReduceError (); + StaticMessage (False,CurrentAltLabel.lab_symbol->sdef_ident->ident_name,Co_Wspine); + *ontop = False; + break; + default: + *ontop = False; + break; + } + + return c; +} + +static StateKind AdjustStateKind (StateKind statekind, Coercions c) +{ + switch (c){ + case Reduce: + return StrictOnA; + case MayBecomeCyclicSpine: + return OnA; + default: + return statekind; + } +} + +static void CoerceArgumentsUsingStackFrames (int arity,States demstates,States offstates,int aindex,int bindex, + int *asp_p, int *bsp, int *anext, int *bnext, int asize, int bsize); + +void CoerceArgumentUsingStackFrames (StateS demstate, StateS offstate,int aindex,int bindex,int *asp_p,int *bsp, + int *anext,int *bnext,int asize,int bsize) +{ + if (IsSimpleState (demstate) && demstate.state_kind==Undefined) + return; + + if (IsSimpleState (offstate)){ + Coercions c; + Bool ontop; + StateKind offkind; + + ontop = False; + offkind = offstate.state_kind; + + c = CoerceSimpleStateArgument (demstate, offkind, aindex, asp_p, False, &ontop); + offkind = AdjustStateKind (offkind, c); + + Assume (! ontop,"codegen","CoerceArgumentUsingStackFrames"); + + if (IsSimpleState (demstate)){ + switch (CoerceStateKind (demstate.state_kind, offkind)){ + case AToA: + case AToRoot: + PutInAFrames (aindex, anext); + return; + case AToB: + PushBasicFromAOnB (demstate.state_object, *asp_p - aindex); + *bsp += ObjectSizes [demstate.state_object]; + PutInBFrames (*bsp, bnext, ObjectSizes [demstate.state_object]); + return; + case BToA: + ++*asp_p; + BuildBasicFromB (offstate.state_object,*bsp - bindex); + PutInAFrames (*asp_p, anext); + return; + case BToB: + PutInBFrames (bindex, bnext, ObjectSizes [demstate.state_object]); + return; + default: + ; + } + } else { + switch (demstate.state_type){ + case TupleState: + /* + A tuple is demanded whereas a node is offered. + Each argument is converted to its demanded state. Note that + the offered state of each argument after pushing it on + the stack is 'OnAState'. + */ + { + int i,arity,index; + States argstates; + + arity = demstate.state_arity; + argstates = demstate.state_tuple_arguments; + + GenPushArgs (*asp_p - aindex, arity, arity); + *asp_p += arity; + index = *asp_p; + + for (i=arity-1; i>=0; i--) + CoerceArgumentUsingStackFrames (argstates [i], OnAState,index-i, 0, asp_p, bsp, anext, bnext, 1, 0); + break; + } + case RecordState: + { + int asize,bsize,arity; + States argstates; + + arity = demstate.state_arity; + argstates = demstate.state_record_arguments; + + DetermineSizeOfStates (arity, argstates, &asize, &bsize); + GenPushRArgs (*asp_p - aindex, asize , bsize); + *asp_p += asize; + *bsp += bsize; + CoerceArgumentsUsingStackFrames (arity, argstates, argstates,*asp_p,*bsp, asp_p, bsp, anext, bnext, asize, bsize); + break; + } + case ArrayState: + GenPushArray (*asp_p-aindex); + *asp_p += 1; + PutInAFrames (*asp_p, anext); + break; + } + } + } else if (IsSimpleState (demstate)){ + switch (offstate.state_type){ + case TupleState: + BuildTuple (aindex, bindex, *asp_p, *bsp,offstate.state_arity, offstate.state_tuple_arguments, + asize,bsize,*asp_p,NormalFill,True); + *asp_p += SizeOfAStackElem; + break; + case RecordState: + BuildRecord (offstate.state_record_symbol,aindex, bindex, *asp_p, *bsp, + asize,bsize,*asp_p,NormalFill,True); + *asp_p += SizeOfAStackElem; + break; + case ArrayState: + GenBuildArray (*asp_p-aindex); + ++*asp_p; + break; + } + PutInAFrames (*asp_p, anext); + } else { + switch (offstate.state_type){ + case TupleState: + CoerceArgumentsUsingStackFrames + (demstate.state_arity, demstate.state_tuple_arguments, + offstate.state_tuple_arguments, aindex, bindex, asp_p, bsp, anext, bnext, + asize, bsize); + break; + case RecordState: + CoerceArgumentsUsingStackFrames + (demstate.state_arity,demstate.state_record_arguments, + offstate.state_record_arguments, aindex, bindex, asp_p, bsp, anext, bnext, + asize, bsize); + break; + case ArrayState: + PutInAFrames (aindex, anext); + break; + } + } +} + +static void CoerceArgumentsUsingStackFrames (int arity, StateS demstates[], StateS offstates[],int aindex, int bindex, + int *asp_p, int *bsp, int *anext, int *bnext,int asize, int bsize) +{ + int i; + + aindex -= asize; + bindex -= bsize; + + for (i=arity-1; i>=0; i--){ + int asize,bsize; + + DetermineSizeOfState (offstates[i],&asize, &bsize); + aindex += asize; + bindex += bsize; + + CoerceArgumentUsingStackFrames (demstates [i],offstates [i],aindex,bindex,asp_p,bsp,anext,bnext,asize,bsize); + } +} + +void AdjustTuple (int localasp,int localbsp,int *asp_p,int *bsp_p,int arity,StateS demstates[],StateS offstates[],int asize,int bsize) +{ + int a_ind,b_ind,dummy,oldamax,oldbmax,newamax,newbmax; + + a_ind=0; + b_ind=0; + dummy = 0, + + newamax = localasp + 1 + arity; + newbmax = localbsp + 1; + AddStateSizesAndMaxFrameSizes (arity, demstates, &newamax, &dummy, &newbmax); + + InitStackConversions (newamax, newbmax, &oldamax, &oldbmax); + + CoerceArgumentsUsingStackFrames (arity, demstates, offstates, localasp, localbsp, + &localasp, &localbsp, &a_ind, &b_ind, asize, bsize); + + GenAStackConversions (localasp,a_ind); + GenBStackConversions (localbsp,b_ind); + + ExitStackConversions (oldamax, oldbmax); + + *asp_p += a_ind-asize; + *bsp_p += b_ind-bsize; +} + +void UnpackTuple (int aindex,int *asp_p,int *bsp_p,Bool removeroot,int arity,StateS argstates[]) +{ + int aselmts,oldaframesize,locasp,asize,maxasize; + + aselmts = 0; + locasp = arity; + asize = 0; + maxasize = arity; + + if (removeroot) + GenReplArgs (arity, arity); + else + GenPushArgs (*asp_p- aindex, arity, arity); + + AddStateSizesAndMaxFrameSizes (arity, argstates, &maxasize, &asize,bsp_p); + + InitAStackConversions (maxasize+1, &oldaframesize); + + EvaluateAndMoveArguments (arity,argstates,&locasp,&aselmts); + + GenAStackConversions (locasp,aselmts); + + FreeAFrameSpace (oldaframesize); + *asp_p += aselmts; +} + +static void MoveArgumentsFromBToA (int arity,States argstates,int aindex,int bindex,int asp_p,int bsp,int asize,int bsize) +{ + int i; + + aindex -= asize; + bindex -= bsize; + + for (i=arity-1; i>=0; i--){ + DetermineSizeOfState (argstates[i],&asize, &bsize); + aindex += asize; + bindex += bsize; + + PackArgument (argstates[i], aindex, bindex, asp_p, bsp, asize, bsize); + + asp_p++; + } +} + +void BuildTuple (int aindex,int bindex,int asp_p,int bsp,int arity, + States argstates,int asize,int bsize,int rootindex,FillKind fkind,Bool newnode) +{ + MoveArgumentsFromBToA (arity, argstates, aindex, bindex, asp_p, bsp, asize, bsize); + if (newnode) + GenBuildh (&tuple_lab,arity); + else + GenFillh (&tuple_lab,arity,arity+asp_p-rootindex,fkind); +} + +void BuildRecord (SymbDef record_sdef,int aindex,int bindex,int asp,int bsp,int asize,int bsize,int rootindex,FillKind fkind,Bool newnode) +{ + LabDef record_lab; + + ConvertSymbolToRLabel (&record_lab,record_sdef); + + if (newnode) + GenBuildR (&record_lab,asize,bsize,asp-aindex,bsp-bindex,False); + else + GenFillR (&record_lab,asize,bsize,asp-rootindex,asp-aindex,bsp-bindex,fkind,False); +} + +void PackArgument (StateS argstate,int aindex,int bindex,int asp,int bsp,int offasize,int offbsize) +{ + if (IsSimpleState (argstate)){ + if (argstate.state_kind==OnB) + BuildBasicFromB (argstate.state_object,bsp - bindex); + else + GenPushA (asp - aindex); + } else { + switch (argstate.state_type){ + case TupleState: + BuildTuple (aindex, bindex, asp, bsp,argstate.state_arity, argstate.state_tuple_arguments, + offasize,offbsize,asp,NormalFill,True); + return; + case RecordState: + BuildRecord (argstate.state_record_symbol,aindex, bindex, asp, bsp, + offasize,offbsize,asp,NormalFill,True); + return; + case ArrayState: + GenBuildArray (asp - aindex); + return; + } + } +} + +void CoerceArgumentOnTopOfStack (int *asp_p,int *bsp_p,StateS argstate,StateS nodestate,int asize,int bsize) +{ + if (IsSimpleState (argstate) && argstate.state_kind==Undefined){ + GenPopA (asize); + *asp_p-=asize; + GenPopB (bsize); + *bsp_p-=bsize; + } else if (IsSimpleState (nodestate)){ + if (IsSimpleState (argstate)){ + Coercions c; + + c = CoerceStateKind (argstate.state_kind, nodestate.state_kind); + + if (c==Reduce){ + GenJsrEval (0); + c = CoerceStateKind (argstate.state_kind, StrictOnA); + } + switch (c){ + case AToB: + PushBasicFromAOnB (argstate.state_object, 0); + *bsp_p+=ObjectSizes [argstate.state_object]; + GenPopA (1); + *asp_p-=1; + return; + case BToA: + ++*asp_p; + BuildBasicFromB (nodestate.state_object,0); + GenPopB (bsize); + *bsp_p-=bsize; + return; + case AToA: + case AToRoot: + return; + case BToB: + return; + default: + ; + } + } else { + if (CoerceStateKind (StrictOnA, nodestate.state_kind)==Reduce) + GenJsrEval (0); + + switch (argstate.state_type){ + case TupleState: /* a tuple is demanded but not offered */ + *asp_p-=1; + UnpackTuple (*asp_p,asp_p,bsp_p,True,argstate.state_arity, argstate.state_tuple_arguments); + break; + case RecordState: + *asp_p-=1; + UnpackRecord (*asp_p,asp_p,bsp_p,True,argstate.state_arity,argstate.state_record_arguments); + break; + case ArrayState: + UnpackArrayOnTopOfStack(); + break; + } + } + } else if (IsSimpleState (argstate)){ + /* a tuple or record is offered but not demanded */ + + switch (nodestate.state_type){ + case TupleState: + BuildTuple (*asp_p,*bsp_p,*asp_p,*bsp_p,nodestate.state_arity,nodestate.state_tuple_arguments, + asize,bsize,*asp_p,NormalFill,True); + *asp_p+=1; + break; + case RecordState: + BuildRecord (nodestate.state_record_symbol,*asp_p,*bsp_p,*asp_p,*bsp_p, + asize,bsize,*asp_p,NormalFill,True); + *asp_p+=1; + break; + case ArrayState: + GenBuildArray (0); + ++*asp_p; + break; + } +#if UPDATE_POP + GenUpdatePopA (0,asize); +#else + GenUpdateA (0,asize); + GenPopA (asize); +#endif + *asp_p-=asize; + GenPopB (bsize); + *bsp_p-=bsize; + } else { + if (argstate.state_type==TupleState) + AdjustTuple (asize,bsize,asp_p,bsp_p,argstate.state_arity, + argstate.state_tuple_arguments, nodestate.state_tuple_arguments,asize, bsize); + } +} + +#define HasBeenReduced(c) ((c)==Reduce) + +static void CopyArguments (States demstates,States offstates,int arity,int aindex,int bindex,int *asp_p,int *bsp,int aszie,int bsize); + +static Bool CopyArgument (StateS demstate,StateS offstate,int aindex,int bindex,int *asp_p,int *bsp_p,int offasize,int offbsize,Bool newnode) +{ + if (IsSimpleState (demstate) && demstate.state_kind==Undefined) + return False; + + if (IsSimpleState (offstate)){ + Bool leftontop; + Coercions c; + StateKind offkind; + + offkind = offstate.state_kind; + + c = CoerceSimpleStateArgument (demstate, offkind, aindex, asp_p, True, &leftontop); + offkind = AdjustStateKind (offkind, c); + + if (IsSimpleState (demstate)){ + StateKind demkind; + + demkind = demstate.state_kind; + switch (CoerceStateKind (demkind, offkind)){ + case AToB: + PushBasicFromAOnB (demstate.state_object, *asp_p - aindex); + *bsp_p += ObjectSizes [demstate.state_object]; + if (leftontop){ + GenPopA (1); + *asp_p -= SizeOfAStackElem; + } + break; + case BToA: + if (newnode){ + ++*asp_p; + BuildBasicFromB (offstate.state_object,*bsp_p - bindex); + } else + FillBasicFromB (offstate.state_object,*bsp_p - bindex,0,NormalFill); + break; + case BToB: + PushBasicOnB (demstate.state_object, *bsp_p - bindex); + *bsp_p += ObjectSizes [demstate.state_object]; + break; + case AToA: + case AToRoot: + if (leftontop){ + if (!newnode) + GenFillFromA (0, 1, NormalFill); + } else { + if (newnode){ + GenPushA (*asp_p - aindex); + *asp_p += SizeOfAStackElem; + } else + GenFillFromA (*asp_p - aindex, 0, NormalFill); + } + break; + default: + break; + } + } else { + if (leftontop) + *asp_p -= SizeOfAStackElem; + switch (demstate.state_type){ + case TupleState: + UnpackTuple (aindex, asp_p,bsp_p,leftontop, demstate.state_arity,demstate.state_tuple_arguments); + break; + case RecordState: + UnpackRecord (aindex, asp_p,bsp_p,leftontop, demstate.state_arity,demstate.state_record_arguments); + break; + case ArrayState: + UnpackArray (aindex, asp_p, leftontop); + break; + } + } + return HasBeenReduced (c); + } + else if (IsSimpleState (demstate)){ + switch (offstate.state_type){ + case TupleState: + BuildTuple (aindex, bindex, *asp_p, *bsp_p,offstate.state_arity, offstate.state_tuple_arguments, + offasize, offbsize, *asp_p, NormalFill,newnode); + if (newnode) + *asp_p += SizeOfAStackElem; + break; + case RecordState: + BuildRecord (offstate.state_record_symbol, aindex, bindex, *asp_p, *bsp_p, + offasize, offbsize, *asp_p, NormalFill, newnode); + if (newnode) + *asp_p += SizeOfAStackElem; + break; + case ArrayState: + if (newnode){ + GenBuildArray (*asp_p - aindex); + ++*asp_p; + } else + GenFillArray (*asp_p - aindex, 0, NormalFill); + break; + } + return False; /** to indicate that the offered object has not been changed **/ + } else { + switch (offstate.state_type){ + case TupleState: + CopyArguments (demstate.state_tuple_arguments, + offstate.state_tuple_arguments, demstate.state_arity, + aindex, bindex, asp_p, bsp_p, offasize, offbsize); + break; + case RecordState: + CopyArguments (demstate.state_record_arguments, + offstate.state_record_arguments, demstate.state_arity, + aindex, bindex, asp_p, bsp_p, offasize, offbsize); + break; + case ArrayState: + GenPushA (*asp_p - aindex); + *asp_p += SizeOfAStackElem; + break; + } + return False; + } +} + +static void CopyArguments (States demstates,States offstates,int arity,int aindex,int bindex,int *asp_p,int *bsp_p,int asize,int bsize) +{ + int i; + + aindex-= asize; + bindex -= bsize; + + for (i=arity-1; i>=0; i--){ + DetermineSizeOfState (offstates[i],&asize, &bsize); + aindex += asize; + bindex += bsize; + CopyArgument (demstates[i],offstates[i],aindex,bindex,asp_p,bsp_p,asize,bsize,True); + } +} + +static void CreateParallelCode (NodeDefs nds,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + switch (nds->def_node->node_annotation){ + case ParallelAnnot: + case ParallelAtAnnot: + case ParallelNFAnnot: + if (nds->def_id->nid_mark & ON_A_CYCLE_MASK){ + /* the channel has already been created */ + GenSendGraph (GetReducerCode (nds->def_node->node_annotation), 0,*asp_p-nds->def_id->nid_a_index); + GenPopA (1); + *asp_p -= SizeOfAStackElem; + } else { + GenProcIdCalculation (nds->def_node,nds->def_node->node_annotation,asp_p,bsp_p,code_gen_node_ids_p); + GenCreateChannel (channel_code); + --*bsp_p; + GenSendGraph (GetReducerCode (nds->def_node->node_annotation), 1, 0); + GenUpdateA (0, 1); + GenPopA (1); + } + break; + case InterleavedAnnot: + GenNewInterleavedReducer (*asp_p-nds->def_id->nid_a_index, hnf_reducer_code); + break; + case ContinueAnnot: + if (get_p_at_node (nds->def_node)){ + GenRedIdCalculation (get_p_at_node (nds->def_node),asp_p,bsp_p,code_gen_node_ids_p); + SetContinueOnReducer (*asp_p-nds->def_id->nid_a_index); + } else + SetContinue (*asp_p-nds->def_id->nid_a_index); + break; + case ContInterleavedAnnot: + GenNewContInterleavedReducer (*asp_p-nds->def_id->nid_a_index); + break; + case WaitAnnot: + GenSetRedId (*asp_p-nds->def_id->nid_a_index); + break; + case InterleavedNFAnnot: + GenNewInterleavedReducer (*asp_p-nds->def_id->nid_a_index, nf_reducer_code); + break; + } +} + +void ChangeEvalStatusKindToStrictOnA (NodeId node_id,SavedNidStateS **saved_nid_state_l) +{ + if (!IsSimpleState (node_id->nid_state)) + error_in_function ("ChangeEvalStatusKindToStrictOnA"); + + if (saved_nid_state_l) + save_node_id_state (node_id,saved_nid_state_l); + + node_id->nid_state__.state_kind = StrictOnA; +} + +static void ChangeEvalStatusKind (NodeId noid, StateKind state) +{ + if (noid){ + if (!IsSimpleState (noid->nid_state)) + error_in_function ("ChangeEvalStatusKind"); + noid->nid_state__.state_kind = state; + } +} + +static void ReduceSemiStrictNodes (const NodeDefs nds,int asp) +{ + NodeDefs nd; + int has_parallel_state; + + has_parallel_state=0; + + for_l (nd,nds,def_next){ + if (IsSimpleState (nd->def_id->nid_state)){ + switch (nd->def_id->nid_state.state_kind){ + case SemiStrict: + if (nd->def_node->node_state.state_mark & STATE_PARALLEL_MASK){ + has_parallel_state=1; + continue; + } + + ChangeEvalStatusKind (nd->def_id, StrictOnA); + /* evaluate strict annotated */ + GenJsrEval (asp - nd->def_id->nid_a_index); + break; + case Parallel: + StaticMessage (False, "","parallel annotation ignored(?)"); + break; + } + } + } + + if (has_parallel_state) + for_l (nd,nds,def_next){ + if (IsSimpleState (nd->def_id->nid_state)){ + if (nd->def_id->nid_state.state_kind==SemiStrict){ + ChangeEvalStatusKind (nd->def_id, StrictOnA); + /* evaluate strict annotated */ + GenJsrEval (asp - nd->def_id->nid_a_index); + } + } + } +} + +void BuildOrFillLazyFieldSelector (SymbDef selector_sdef,StateKind result_state_kind,int *asp_p,NodeId update_node_id) +{ + LabDef nsellab,dsellab; + char *record_name; + int fill_arity; + SymbDef record_sdef; + StateS *field_result_state_p; + + ConvertSymbolToDandNLabel (&dsellab,&nsellab,selector_sdef); + + record_sdef=selector_sdef->sdef_type->type_lhs->ft_symbol->symb_def; + record_name=record_sdef->sdef_ident->ident_name; + + field_result_state_p=&record_sdef->sdef_record_state.state_record_arguments [selector_sdef->sdef_sel_field_number]; + fill_arity= IsSimpleState (*field_result_state_p) ? (field_result_state_p->state_kind!=OnB ? -4 : -3) : 1; + + /* we use a negative arity to indicate lazy selectors */ + if (update_node_id==NULL) + GenBuildFieldSelector (&dsellab,&nsellab,record_name,fill_arity); + else { + GenFillFieldSelector (&dsellab,&nsellab,record_name,fill_arity,*asp_p-update_node_id->nid_a_index,result_state_kind==SemiStrict ? PartialFill : NormalFill); + *asp_p-=1; + } +} + +void ReplaceRecordOnTopOfStackByField (int *asp_p,int *bsp_p,int apos,int bpos,int asize,int bsize,int rec_a_size,int rec_b_size) +{ + int i; + + rec_a_size -= asize; + rec_b_size -= bsize; + + for (i = asize - 1; i >= 0; i--) +#if UPDATE_POP + if (i==0) + GenUpdatePopA (apos,rec_a_size); + else +#endif + GenUpdateA (apos + i, rec_a_size + i); + + for (i = bsize - 1; i >= 0; i--) +#if UPDATE_POP + if (i==0) + GenUpdatePopB (bpos,rec_b_size); + else +#endif + GenUpdateB (bpos + i, rec_b_size + i); + +#if UPDATE_POP + if (asize==0) +#endif + GenPopA (rec_a_size); + *asp_p-=rec_a_size; + +#if UPDATE_POP + if (bsize==0) +#endif + GenPopB (rec_b_size); + + *bsp_p-=rec_b_size; +} + +#define ResultIsNotInRootNormalForm(state) (IsLazyState (state) ||\ + IsSimpleState (state) && (state).state_kind == LazyRedirection) + +void add_node_id_to_list (struct node_id *node_id,NodeIdListElementS **node_ids_l) +{ + NodeIdListElementP free_node_id; + + free_node_id=CompAllocType (NodeIdListElementS); + free_node_id->nidl_node_id=node_id; + + free_node_id->nidl_next=*node_ids_l; + *node_ids_l=free_node_id; +} + +#if 0 +# include "dbprint.h" +#endif + +#if FREE_STRICT_LHS_TUPLE_ELEMENTS +static void add_node_id_or_tuple_node_ids_to_list (NodeIdP node_id,NodeIdListElementS **free_node_ids_l) +{ + if (! (node_id->nid_node!=NULL && !IsSimpleState (node_id->nid_state))) + add_node_id_to_list (node_id,free_node_ids_l); + else { + ArgP arg_p; + + for_l (arg_p,node_id->nid_node->node_arguments,arg_next){ + NodeP arg_node_p; + + arg_node_p=arg_p->arg_node; + if (arg_node_p->node_kind==NodeIdNode){ + NodeIdP node_id_p; + + node_id_p=arg_node_p->node_node_id; + if (node_id_p->nid_refcount==-1) + add_node_id_or_tuple_node_ids_to_list (node_id_p,free_node_ids_l); + } + } + } +} +#endif + +void decrement_reference_count_of_node_id (struct node_id *node_id,NodeIdListElementS **free_node_ids_l) +{ + int ref_count; + +#if 0 + printf ("decrement_reference_count_of_node_id "); + DPrintNodeId (node_id,StdOut); + printf ("\n"); +#endif + + ref_count=node_id->nid_refcount; + + if (ref_count>0){ + if (--ref_count==0) + add_node_id_to_list (node_id,free_node_ids_l); + + node_id->nid_refcount=ref_count; + } else if (ref_count<-1){ + ++ref_count; + node_id->nid_refcount=ref_count; + + if (ref_count==-1){ +#if FREE_STRICT_LHS_TUPLE_ELEMENTS + if (unused_node_id_(node_id)) + add_node_id_or_tuple_node_ids_to_list (node_id,free_node_ids_l); +#else + if (! (node_id->nid_node!=NULL && !IsSimpleState (node_id->nid_state)) && unused_node_id_(node_id)){ +# if 0 + printf ("add to free_node_ids list "); + DPrintNodeId (node_id,StdOut); + printf ("\n"); +# endif + add_node_id_to_list (node_id,free_node_ids_l); + } +#endif + } + } +} + +void DetermineFieldSizeAndPositionAndRecordSize + (int fieldnr,int *asize_p,int *bsize_p,int *apos_p,int *bpos_p,int *rec_asize_p,int *rec_bsize_p,StateS *record_state_p) +{ + int i; + + DetermineFieldSizeAndPosition (fieldnr,asize_p,bsize_p,apos_p,bpos_p,record_state_p->state_record_arguments); + + *rec_asize_p = *asize_p + *apos_p; + *rec_bsize_p = *bsize_p + *bpos_p; + + for (i=fieldnr+1; i<record_state_p->state_arity; ++i) + AddSizeOfState (record_state_p->state_record_arguments[i],rec_asize_p,rec_bsize_p); +} + +int get_a_index_of_unpacked_lhs_node (ArgS *arg) +{ + while (arg!=NULL){ + int a_size,b_size; + + DetermineSizeOfState (arg->arg_state,&a_size,&b_size); + + if (a_size==0) + arg=arg->arg_next; + else { + Node arg_node; + + arg_node=arg->arg_node; + + if (arg_node->node_kind==NodeIdNode){ + NodeId node_id; + node_id=arg->arg_node->node_node_id; + + if (a_size!=0){ + if (node_id->nid_refcount<0 && node_id->nid_state.state_type!=SimpleState && node_id->nid_node!=NULL) + arg=node_id->nid_node->node_arguments; + else + return node_id->nid_a_index; + } + } else + arg=arg_node->node_arguments; + } + } + + return 0; +} + +int get_b_index_of_unpacked_lhs_node (ArgS *arg) +{ + while (arg!=NULL){ + int a_size,b_size; + + DetermineSizeOfState (arg->arg_state,&a_size,&b_size); + + if (b_size==0) + arg=arg->arg_next; + else { + Node arg_node; + + arg_node=arg->arg_node; + + if (arg_node->node_kind==NodeIdNode){ + NodeId node_id; + + node_id=arg->arg_node->node_node_id; + + if (node_id->nid_refcount<0 && node_id->nid_state.state_type!=SimpleState && node_id->nid_node!=NULL) + arg=node_id->nid_node->node_arguments; + else + return node_id->nid_b_index; + } else + arg=arg_node->node_arguments; + } + } + + return 0; +} + +Bool CopyNodeIdArgument (StateS demstate,NodeId node_id,int *asp_p,int *bsp_p) +{ + int a_size,b_size,a_index,b_index; + + DetermineSizeOfState (node_id->nid_state,&a_size,&b_size); + + a_index=node_id->nid_a_index; + b_index=node_id->nid_b_index; + + if (node_id->nid_refcount<0 && node_id->nid_state.state_type!=SimpleState && node_id->nid_node!=NULL){ + ArgS *args; + + args=node_id->nid_node->node_arguments; + + if (a_size!=0) + a_index=get_a_index_of_unpacked_lhs_node (args); + if (b_size!=0) + b_index=get_b_index_of_unpacked_lhs_node (args); + } + + return CopyArgument (demstate,node_id->nid_state,a_index,b_index,asp_p,bsp_p,a_size,b_size,True); +} + +static void FillOrReduceFieldSelection (Node node,SymbDef seldef,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p) +{ + Node arg_node; + Args arg; + int fieldnr; + + arg = node->node_arguments; + fieldnr = seldef->sdef_sel_field_number; + + arg_node=arg->arg_node; + + if (node->node_arity>=SELECTOR_U){ + if (IsLazyState (node->node_state)){ + SymbDef new_select_sdef; + LabDef name,codelab; + + BuildArg (arg,asp_p,bsp_p,code_gen_node_ids_p); + + new_select_sdef=create_select_function (node->node_symbol,node->node_arity); + + ConvertSymbolToDandNLabel (&name,&codelab,new_select_sdef); + + if (update_node_id==NULL) + GenBuild (&name,1,&codelab); + else { + GenFill (&name,1,&codelab,*asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? PartialFill : NormalFill); + --*asp_p; + } + } else { + if (arg_node->node_kind!=NodeIdNode){ + int asize,bsize,aindex,bindex; + StateP record_state_p; + + BuildArg (arg,asp_p,bsp_p,code_gen_node_ids_p); + + record_state_p=&seldef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state; + + DetermineFieldSizeAndPosition (fieldnr,&asize,&bsize,&aindex,&bindex,record_state_p->state_record_arguments); + + if (node->node_arity<SELECTOR_L){ + int n; + + for (n=0; n<asize; ++n) + GenPushA (aindex+asize-1); + *asp_p+=asize; + + for (n=0; n<bsize; ++n) + GenPushB (bindex+bsize-1); + *bsp_p+=bsize; + } else { + int record_a_size,record_b_size; + + DetermineSizeOfState (*record_state_p,&record_a_size,&record_b_size); + ReplaceRecordOnTopOfStackByField (asp_p,bsp_p,aindex,bindex,asize,bsize,record_a_size,record_b_size); + } + } else { + int a_size,b_size,apos,bpos,record_a_size,record_b_size,n; + StateS tuple_state,tuple_state_arguments[2],*record_state_p; + NodeId arg_node_id; + + arg_node_id=arg_node->node_node_id; + + record_state_p=&seldef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state; + + DetermineFieldSizeAndPositionAndRecordSize (fieldnr,&a_size,&b_size,&apos,&bpos,&record_a_size,&record_b_size,record_state_p); + + CopyNodeIdArgument (*record_state_p,arg_node_id,asp_p,bsp_p); + + for (n=0; n<a_size; ++n) + GenPushA (apos+a_size-1); + *asp_p+=a_size; + + for (n=0; n<b_size; ++n) + GenPushB (bpos+b_size-1); + *bsp_p+=b_size; + + tuple_state.state_type=TupleState; + tuple_state.state_arity=2; + tuple_state.state_tuple_arguments=tuple_state_arguments; + + tuple_state_arguments[0]=record_state_p->state_record_arguments[fieldnr]; + tuple_state_arguments[1]=*record_state_p; + + CoerceArgumentOnTopOfStack (asp_p,bsp_p,tuple_state,node->node_state,record_a_size+a_size,record_b_size+b_size); + + decrement_reference_count_of_node_id (arg_node_id,&code_gen_node_ids_p->free_node_ids); + } + } + return; + } + + if (arg_node->node_kind!=NodeIdNode){ + if (IsLazyState (node->node_state)){ + BuildArg (arg,asp_p,bsp_p,code_gen_node_ids_p); + +#ifdef DO_LAZY_SELECTORS_FROM_BOXED_STRICT_RECORDS + if (!ResultIsNotInRootNormalForm (arg_node->node_state) && update_node_id==NULL){ + int asize,bsize,apos,bpos,tot_asize,tot_bsize; + StateP record_state_p,field_state_p; + + record_state_p=&seldef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state; + + if (record_state_p->state_type!=RecordState) + error_in_function ("FillOrReduceFieldSelection"); + + DetermineFieldSizeAndPositionAndRecordSize (fieldnr,&asize,&bsize,&apos,&bpos,&tot_asize,&tot_bsize,record_state_p); + + GenPushRArgB (0,tot_asize,tot_bsize,bpos+1,bsize); + GenReplRArgA (tot_asize,tot_bsize,apos+1,asize); + + *asp_p -= 1-asize; + *bsp_p += bsize; + + field_state_p=&record_state_p->state_record_arguments [fieldnr]; + CoerceArgumentOnTopOfStack (asp_p,bsp_p,node->node_state,*field_state_p,asize,bsize); + + if (node->node_state.state_kind==OnA && !ResultIsNotInRootNormalForm (*field_state_p)) + node->node_state.state_kind=StrictOnA; + } else +#endif + + BuildOrFillLazyFieldSelector (seldef,node->node_state.state_kind,asp_p,update_node_id); + } else { + int asize,bsize,apos,bpos,tot_asize,tot_bsize; + + Build (arg_node,asp_p,bsp_p,code_gen_node_ids_p); + + DetermineFieldSizeAndPositionAndRecordSize (fieldnr,&asize,&bsize,&apos,&bpos,&tot_asize,&tot_bsize,&arg->arg_state); + CoerceArgumentOnTopOfStack (asp_p,bsp_p,arg->arg_state,arg_node->node_state,tot_asize,tot_bsize); + + ReplaceRecordOnTopOfStackByField (asp_p,bsp_p,apos,bpos,asize,bsize,tot_asize,tot_bsize); + CoerceArgumentOnTopOfStack (asp_p,bsp_p,node->node_state,arg->arg_state.state_record_arguments[fieldnr],asize,bsize); + } + } else { + StateS recstate; + NodeId arg_node_id; + + arg_node_id=arg_node->node_node_id; + + recstate=arg_node_id->nid_state; + + if (recstate.state_type==RecordState){ + int a_size,b_size,apos,bpos,record_a_index,record_b_index; + StateP field_state_p; + + DetermineFieldSizeAndPosition (fieldnr,&a_size,&b_size,&apos,&bpos,recstate.state_record_arguments); + + if (arg_node_id->nid_refcount<0 && arg_node_id->nid_node!=NULL){ + ArgS *args; + + args=arg_node_id->nid_node->node_arguments; + record_a_index=get_a_index_of_unpacked_lhs_node (args); + record_b_index=get_b_index_of_unpacked_lhs_node (args); + } else { + record_a_index=arg_node_id->nid_a_index; + record_b_index=arg_node_id->nid_b_index; + } + + field_state_p=&recstate.state_record_arguments[fieldnr]; + + if (update_node_id==NULL){ + CopyArgument (node->node_state,*field_state_p,record_a_index-apos,record_b_index-bpos,asp_p,bsp_p,a_size,b_size,True); + } else { + int locasp; + + locasp = *asp_p; + + GenPushA (*asp_p-update_node_id->nid_a_index); + *asp_p+=1; + + CopyArgument (node->node_state,*field_state_p,record_a_index-apos,record_b_index-bpos,asp_p,bsp_p,a_size,b_size,False); + + GenPopA (*asp_p-locasp); + *asp_p=locasp; + } + +#ifdef DO_LAZY_SELECTORS_FROM_BOXED_STRICT_RECORDS + if (node->node_state.state_type==SimpleState && node->node_state.state_kind==OnA && !ResultIsNotInRootNormalForm (*field_state_p)) + node->node_state.state_kind=StrictOnA; +#endif + decrement_reference_count_of_node_id (arg_node_id,&code_gen_node_ids_p->free_node_ids); + } else if (IsLazyState (node->node_state)){ +#ifdef DO_LAZY_SELECTORS_FROM_BOXED_STRICT_RECORDS + if ((recstate.state_kind==StrictOnA || recstate.state_kind==StrictRedirection) && update_node_id==NULL){ + int asize,bsize,apos,bpos,tot_asize,tot_bsize,recindex; + StateP record_state_p,field_state_p; + + recindex = arg_node_id->nid_a_index; + record_state_p=&seldef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state; + + if (record_state_p->state_type!=RecordState) + error_in_function ("FillOrReduceFieldSelection"); + + DetermineFieldSizeAndPositionAndRecordSize (fieldnr,&asize,&bsize,&apos,&bpos,&tot_asize,&tot_bsize,record_state_p); + + GenPushRArgB (*asp_p-recindex,tot_asize,tot_bsize,bpos+1,bsize); + GenPushRArgA (*asp_p-recindex,tot_asize,tot_bsize,apos+1,asize); + + *asp_p+=asize; + *bsp_p+=bsize; + + field_state_p=&record_state_p->state_record_arguments [fieldnr]; + CoerceArgumentOnTopOfStack (asp_p,bsp_p,node->node_state,*field_state_p,asize,bsize); + + if (node->node_state.state_kind==OnA && !ResultIsNotInRootNormalForm (*field_state_p)) + node->node_state.state_kind=StrictOnA; + + decrement_reference_count_of_node_id (arg_node_id,&code_gen_node_ids_p->free_node_ids); + } else +#endif + { + BuildArg (arg,asp_p,bsp_p,code_gen_node_ids_p); + + BuildOrFillLazyFieldSelector (seldef,node->node_state.state_kind,asp_p,update_node_id); + } + } else { + int a_size,b_size,apos, bpos, tot_asize, tot_bsize,recindex; + + /* the selector is strict but the record is not */ + + recindex = arg_node_id->nid_a_index; + + DetermineFieldSizeAndPositionAndRecordSize (fieldnr,&a_size,&b_size,&apos, &bpos,&tot_asize,&tot_bsize,&arg->arg_state); + + if (ResultIsNotInRootNormalForm (recstate)){ + GenJsrEval (*asp_p-recindex); + ChangeEvalStatusKindToStrictOnA (arg_node_id,code_gen_node_ids_p->saved_nid_state_l); + + recstate.state_kind = StrictOnA; + } + + GenPushRArgB (*asp_p-recindex, tot_asize, tot_bsize, bpos+1,b_size); + GenPushRArgA (*asp_p-recindex, tot_asize, tot_bsize, apos+1,a_size); + + *asp_p+=a_size; + *bsp_p+=b_size; + + recstate = arg->arg_state.state_record_arguments [fieldnr]; + CoerceArgumentOnTopOfStack (asp_p,bsp_p, node->node_state, recstate,a_size,b_size); + + decrement_reference_count_of_node_id (arg_node_id,&code_gen_node_ids_p->free_node_ids); + } + } +} + +void FillSelectSymbol (StateKind result_state_kind,int arity,int argnr,Args arg,int *asp_p,int *bsp_p, + NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p) +{ + LabDef sellab, nsellab; + + BuildLazyTupleSelectorLabel (&nsellab,arity,argnr); + + BuildArg (arg,asp_p,bsp_p,code_gen_node_ids_p); + + sellab = nsellab; + sellab.lab_pref = d_pref; + + /* we use a negative arity to indicate lazy selectors */ + if (update_node_id==NULL) + GenBuild (&sellab,-1,&nsellab); + else { + GenFill (&sellab,-1,&nsellab,*asp_p-update_node_id->nid_a_index,result_state_kind==SemiStrict ? PartialFill : NormalFill); + *asp_p-=1; + } +} + +#if defined (THUNK_LIFT_SELECTORS) +void FillSelectAndRemoveSymbol (StateKind result_state_kind,int arity,int argnr,Args arg,int *asp_p,int *bsp_p, + NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p) +{ + LabDef sellab, nsellab; + + BuildLazyTupleSelectorAndRemoveLabel (&nsellab,arity,argnr); + + BuildArg (arg,asp_p,bsp_p,code_gen_node_ids_p); + + sellab = nsellab; + sellab.lab_pref = d_pref; + + /* we use a negative arity to indicate lazy selectors */ + if (update_node_id==NULL) + GenBuild (&sellab,-1,&nsellab); + else { + GenFill (&sellab,-1,&nsellab,*asp_p-update_node_id->nid_a_index,result_state_kind==SemiStrict ? PartialFill : NormalFill); + *asp_p-=1; + } +} +#endif + +#if OPTIMIZE_LAZY_TUPLE_RECURSION +extern int lazy_tuple_recursion; +extern void update_tuple_element_node (StateP state_p,int tuple_element_a_index,int *asp_p,int *bsp_p); +#endif + +static void FillOrReduceSelectSymbol (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p) +{ + Args arg; + int argnr; + + arg = node->node_arguments; + argnr = node->node_arity; + + if (arg->arg_node->node_kind!=NodeIdNode){ + if (IsLazyState (node->node_state)) + FillSelectSymbol (node->node_state.state_kind,node->node_symbol->symb_arity,argnr,arg,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + else { + Node argnode; + int asize,bsize; + + argnode = arg->arg_node; + + DetermineSizeOfState (argnode->node_state, &asize, &bsize); + Build (argnode,asp_p,bsp_p,code_gen_node_ids_p); + CoerceArgumentOnTopOfStack (asp_p,bsp_p,arg->arg_state,argnode->node_state, asize, bsize); + } + } else { + StateS tupstate; + NodeId arg_node_id; + + /* the tuple is shared */ + + arg_node_id=arg->arg_node->node_node_id; +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if ((arg_node_id->nid_mark2 & NID_CALL_VIA_LAZY_SELECTIONS_ONLY) && update_node_id==NULL){ + int select_node_index; + + select_node_index=arg_node_id->nid_a_index-argnr; + + GenPushA (*asp_p-select_node_index); + ++*asp_p; + + return; + } +#endif + + tupstate = arg_node_id->nid_state; + + if (IsSimpleState (tupstate)){ + if (IsLazyState (node->node_state)){ + /* added 10-8-1999 */ + if (!IsLazyStateKind (tupstate.state_kind)){ + GenPushArg (*asp_p-arg_node_id->nid_a_index,node->node_symbol->symb_arity,argnr); + *asp_p+=1; + + decrement_reference_count_of_node_id (arg_node_id,&code_gen_node_ids_p->free_node_ids); + } else + /* */ +#if defined (THUNK_LIFT_SELECTORS) + if (arg_node_id->nid_refcount>0 && (arg_node_id->nid_node_def->def_mark & NODE_DEF_SELECT_AND_REMOVE_MASK)!=0) + FillSelectAndRemoveSymbol (node->node_state.state_kind,node->node_symbol->symb_arity,argnr,arg,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + else +#endif + FillSelectSymbol (node->node_state.state_kind,node->node_symbol->symb_arity,argnr,arg,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + } else { + int arity,tupindex; + StateS selectstate; + + /* the selector is strict but the tuple is not */ + + arity = arg->arg_state.state_arity; + tupindex = arg_node_id->nid_a_index; + selectstate = arg->arg_state.state_tuple_arguments[argnr-1]; + + if (ResultIsNotInRootNormalForm (tupstate)){ + GenJsrEval (*asp_p-tupindex); + ChangeEvalStatusKindToStrictOnA (arg_node_id,code_gen_node_ids_p->saved_nid_state_l); + tupstate.state_kind = StrictOnA; + } + +#if defined (THUNK_LIFT_SELECTORS) + if (node->node_number!=0){ + char bits[MaxNodeArity+2]; + int n; + + GenPushArgsU (*asp_p-tupindex,arity,argnr); + if (argnr>1) + GenPopA (argnr-1); + + *asp_p+=1; + + for (n=0; n<=arity; ++n) + bits[n]='0'; + bits[arity+1]='\0'; + + bits[argnr]='1'; + + GenBuildh (&nil_lab,0); + + if (arity<=2) + GenFill1 (&tuple_lab,arity,*asp_p+1-tupindex,bits); + else + GenFill2 (&tuple_lab,arity,*asp_p+1-tupindex,bits); + } else { + GenPushArg (*asp_p-tupindex,arity,argnr); + *asp_p+=1; + } +#else + + GenPushArg (*asp_p-tupindex,arity,argnr); + *asp_p+=1; +#endif + if (!ResultIsNotInRootNormalForm (selectstate)) + GenJsrEval (0); + + CoerceArgumentOnTopOfStack (asp_p,bsp_p,selectstate,tupstate,1,0); + +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if (update_node_id!=NULL) + update_tuple_element_node (&selectstate,update_node_id->nid_a_index,asp_p,bsp_p); +#endif + decrement_reference_count_of_node_id (arg_node_id,&code_gen_node_ids_p->free_node_ids); + } + } else { + int a_size,b_size,i,argasize,argbsize,a_index,b_index; + StateS selectstate; + + a_size=0; + b_size=0; + + for (i=0; i<argnr-1; i++) + AddSizeOfState (tupstate.state_tuple_arguments[i],&a_size,&b_size); + + if (IsSimpleState (arg->arg_state)) + selectstate = arg->arg_state; + else + selectstate = arg->arg_state.state_tuple_arguments[i]; + + DetermineSizeOfState (tupstate.state_tuple_arguments[i],&argasize, &argbsize); + + a_index=arg_node_id->nid_a_index; + b_index=arg_node_id->nid_b_index; + + if (arg_node_id->nid_refcount<0 && arg_node_id->nid_node!=NULL){ + ArgP args; + + args=arg_node_id->nid_node->node_arguments; + a_index=get_a_index_of_unpacked_lhs_node (args); + b_index=get_b_index_of_unpacked_lhs_node (args); + } + + if (update_node_id==NULL) + CopyArgument (selectstate,tupstate.state_tuple_arguments[i], + a_index - a_size,b_index - b_size,asp_p,bsp_p, argasize, argbsize, True); + else { + int locasp; + + locasp = *asp_p; + + GenPushA (*asp_p-update_node_id->nid_a_index); + ++*asp_p; + + CopyArgument (selectstate,tupstate.state_tuple_arguments[i], + a_index - a_size,b_index - b_size,asp_p,bsp_p, argasize, argbsize, False); + + GenPopA (*asp_p-locasp); + *asp_p=locasp; + } + + decrement_reference_count_of_node_id (arg_node_id,&code_gen_node_ids_p->free_node_ids); + } + } +} + +void DetermineArrayElemDescr (StateS elemstate,Label lab) +{ + if (elemstate.state_type==SimpleState) + *lab = BasicDescriptors [elemstate.state_object]; + else if (elemstate.state_type==RecordState){ + ConvertSymbolToRLabel (lab,elemstate.state_record_symbol); + } else + *lab = BasicDescriptors [UnknownObj]; +} + +#define UNUSED_NODE_ID_INDEX 30000 + +#if 0 +#include "dbprint.h" +#endif + +void cleanup_stack + (int *asp_p,int *bsp_p,int a_size,int b_size,NodeIdListElementS **a_node_ids_l,NodeIdListElementS **b_node_ids_l, + NodeIdListElementS **free_node_ids_l,MovedNodeIdP *moved_node_ids_l,int compact_stack_ok) +{ + NodeIdListElementP p_node_ids; + int asp,bsp; + int n_a_elements_popped; + + if (DoDebug){ + PrintComment (); + FPrintF (OutFile,compact_stack_ok ? "Remove unused stack elements" : "Remove unused stack elements without moving"); + } + + asp=*asp_p; + bsp=*bsp_p; + + n_a_elements_popped=0; + +#if 0 + printf ("cleanup_stack a_node_ids "); + for_l (p_node_ids,*a_node_ids_l,nidl_next){ + DPrintNodeId (p_node_ids->nidl_node_id,StdOut); + printf (" "); + } + printf ("\n"); +#endif + +#if 0 + printf ("cleanup_stack b_node_ids "); + for_l (p_node_ids,*b_node_ids_l,nidl_next){ + DPrintNodeId (p_node_ids->nidl_node_id,StdOut); + printf (" "); + } + printf ("\n"); +#endif + + p_node_ids=*a_node_ids_l; + while (p_node_ids!=NULL && p_node_ids->nidl_node_id->nid_a_index==UNUSED_NODE_ID_INDEX){ +#if 0 + printf ("cleanup_stack00 "); + printf ("%s ",CurrentAltLabel.lab_symbol->sdef_ident->ident_name); + DPrintNodeId (p_node_ids->nidl_node_id,StdOut); + printf ("\n"); +#endif + p_node_ids=p_node_ids->nidl_next; + } + + if (p_node_ids!=NULL && p_node_ids->nidl_node_id->nid_a_index==asp && (unused_node_id (p_node_ids->nidl_node_id))){ + int n_a_elements,n_b_elements; + + n_a_elements=0; + n_b_elements=0; + + do { +#if 0 + printf ("cleanup_stack01 "); + printf ("%s ",CurrentAltLabel.lab_symbol->sdef_ident->ident_name); + DPrintNodeId (p_node_ids->nidl_node_id,StdOut); + printf ("\n"); +#endif + + AddSizeOfState (p_node_ids->nidl_node_id->nid_state,&n_a_elements,&n_b_elements); + /* free p_node_ids */ + + p_node_ids=p_node_ids->nidl_next; + while (p_node_ids!=NULL && p_node_ids->nidl_node_id->nid_a_index==UNUSED_NODE_ID_INDEX){ +#if 0 + printf ("cleanup_stack02 "); + printf ("%s ",CurrentAltLabel.lab_symbol->sdef_ident->ident_name); + DPrintNodeId (p_node_ids->nidl_node_id,StdOut); + printf ("\n"); +#endif + p_node_ids=p_node_ids->nidl_next; + } + + } while (p_node_ids!=NULL && p_node_ids->nidl_node_id->nid_a_index==asp-n_a_elements && (unused_node_id (p_node_ids->nidl_node_id))); + + *a_node_ids_l=p_node_ids; + + n_a_elements_popped=n_a_elements; + } + + p_node_ids=*b_node_ids_l; + if (p_node_ids!=NULL && (unused_node_id (p_node_ids->nidl_node_id)) && p_node_ids->nidl_node_id->nid_b_index==bsp){ + int n_a_elements,n_b_elements; + + n_a_elements=0; + n_b_elements=0; + + do { + AddSizeOfState (p_node_ids->nidl_node_id->nid_state,&n_a_elements,&n_b_elements); + /* free p_node_ids */ + p_node_ids=p_node_ids->nidl_next; + } while (p_node_ids!=NULL && (unused_node_id (p_node_ids->nidl_node_id)) && p_node_ids->nidl_node_id->nid_b_index==bsp-n_b_elements); + + *b_node_ids_l=p_node_ids; + + if (n_b_elements!=0){ + int i; + + for (i=b_size-1; i>=0; --i) +#if UPDATE_POP + if (i==0) + GenUpdatePopB (0,n_b_elements); + else +#endif + GenUpdateB (i,i+n_b_elements); + +#if UPDATE_POP + if (b_size==0) +#endif + GenPopB (n_b_elements); + + *bsp_p-=n_b_elements; + } + } + + if (compact_stack_ok){ + NodeIdListElementP free_node_id,keep_node_ids; + int node_id_a_size,node_id_b_size; + int free_size,used_size,move_free_size,move_used_size; + + node_id_a_size=0; + node_id_b_size=0; + + asp=*asp_p-n_a_elements_popped; + + for_l (free_node_id,*free_node_ids_l,nidl_next){ + struct node_id *node_id; + + node_id=free_node_id->nidl_node_id; + + if (node_id->nid_a_index < asp) + AddSizeOfState (node_id->nid_state,&node_id_a_size,&node_id_b_size); + } + + free_size=0; + used_size=0; + + move_free_size=0; + move_used_size=0; + keep_node_ids=NULL; + + + p_node_ids=*a_node_ids_l; + + while (p_node_ids!=NULL && p_node_ids->nidl_node_id->nid_a_index==UNUSED_NODE_ID_INDEX){ +#if 0 + printf ("cleanup_stack03 "); + printf ("%s ",CurrentAltLabel.lab_symbol->sdef_ident->ident_name); + DPrintNodeId (p_node_ids->nidl_node_id,StdOut); + printf ("\n"); +#endif + p_node_ids=p_node_ids->nidl_next; + } + +#if 0 + printf ("cleanup_stack1 "); + printf ("%s\n",CurrentAltLabel.lab_symbol->sdef_ident->ident_name); + + if (p_node_ids!=NULL && p_node_ids->nidl_node_id->nid_a_index!=asp){ + printf ("asp=%d nid_a_index=%d ",asp,p_node_ids->nidl_node_id->nid_a_index); + DPrintNodeId (p_node_ids->nidl_node_id,StdOut); + printf ("\n"); + } +#endif + + while (p_node_ids!=NULL && p_node_ids->nidl_node_id->nid_a_index==asp){ + int element_a_size,element_b_size; + struct node_id *node_id; + + node_id=p_node_ids->nidl_node_id; + DetermineSizeOfState (node_id->nid_state,&element_a_size,&element_b_size); + +#if 0 + DPrintNodeId (node_id,StdOut); + printf ("\n"); +#endif + + if (unused_node_id (node_id)){ + free_size+=element_a_size; + } else { + if (free_size+used_size > node_id_a_size+node_id_a_size) + break; + + used_size+=element_a_size; + } + + asp-=element_a_size; + + p_node_ids=p_node_ids->nidl_next; + while (p_node_ids!=NULL && p_node_ids->nidl_node_id->nid_a_index==UNUSED_NODE_ID_INDEX){ +#if 0 + printf ("cleanup_stack11 "); + printf ("%s ",CurrentAltLabel.lab_symbol->sdef_ident->ident_name); + DPrintNodeId (p_node_ids->nidl_node_id,StdOut); + printf ("\n"); +#endif + p_node_ids=p_node_ids->nidl_next; + } + + if (free_size>=used_size){ + move_free_size=free_size; + move_used_size=used_size; + keep_node_ids=p_node_ids; + } + } + + if (move_free_size!=0){ + NodeIdListElementP reversed_node_ids; + int move_a_offset; + int source_asp,dest_asp; + + move_a_offset=move_free_size; + + source_asp=*asp_p-n_a_elements_popped-(move_free_size+move_used_size); + dest_asp=source_asp; + + reversed_node_ids=NULL; + p_node_ids=*a_node_ids_l; + + while (p_node_ids!=keep_node_ids){ + NodeIdListElementP next_p_node_ids; + + next_p_node_ids=p_node_ids->nidl_next; + p_node_ids->nidl_next=reversed_node_ids; + reversed_node_ids=p_node_ids; + p_node_ids=next_p_node_ids; + } + + while (reversed_node_ids!=NULL){ + NodeIdListElementP next_reversed_node_ids; + int element_a_size,element_b_size; + MovedNodeIdP new_moved_node_id; + struct node_id *node_id; + + node_id=reversed_node_ids->nidl_node_id; + + if (node_id->nid_a_index!=UNUSED_NODE_ID_INDEX){ + DetermineSizeOfState (node_id->nid_state,&element_a_size,&element_b_size); + + new_moved_node_id=CompAllocType (MovedNodeIdS); + new_moved_node_id->mnid_node_id=node_id; + new_moved_node_id->mnid_a_stack_offset=node_id->nid_a_index; + + new_moved_node_id->mnid_next=*moved_node_ids_l; + *moved_node_ids_l=new_moved_node_id; + +#if 0 + printf ("cleanup_stack2 "); + DPrintNodeId (node_id,StdOut); + printf ("\n"); +#endif + + if (unused_node_id (node_id)){ + source_asp+=element_a_size; + + node_id->nid_a_index_=UNUSED_NODE_ID_INDEX; + } else { + int n; + + for (n=element_a_size; n!=0; --n){ + ++source_asp; + ++dest_asp; + GenUpdateA (*asp_p+a_size-source_asp,*asp_p+a_size-dest_asp); + } + + node_id->nid_a_index_=dest_asp; + } + } + + next_reversed_node_ids=reversed_node_ids->nidl_next; + reversed_node_ids->nidl_next=p_node_ids; + p_node_ids=reversed_node_ids; + reversed_node_ids=next_reversed_node_ids; + } + + *a_node_ids_l=p_node_ids; +/* *a_node_ids_l=keep_node_ids; */ + + n_a_elements_popped+=move_a_offset; + } + } + + if (n_a_elements_popped!=0){ + int i; + + for (i=a_size-1; i>=0; --i) +#if UPDATE_POP + if (i==0) + GenUpdatePopA (0,n_a_elements_popped); + else +#endif + GenUpdateA (i,i+n_a_elements_popped); + +#if UPDATE_POP + if (a_size==0) +#endif + GenPopA (n_a_elements_popped); + + *asp_p-=n_a_elements_popped; + } + + { + NodeIdListElementP free_node_id; + int nil_on_stack; + + nil_on_stack=0; + asp=*asp_p; + + for_l (free_node_id,*free_node_ids_l,nidl_next){ + struct node_id *node_id; + + node_id=free_node_id->nidl_node_id; + +#if 0 + printf ("cleanup_stack3 "); + DPrintNodeId (node_id,StdOut); + printf ("\n"); +#endif + + if (node_id->nid_a_index < asp){ + int node_id_a_size,node_id_b_size,a_index; + + DetermineSizeOfState (node_id->nid_state,&node_id_a_size,&node_id_b_size); + + if (node_id_a_size>0){ + a_index=asp+a_size-node_id->nid_a_index; + + NodeIdComment (node_id); + + while (node_id_a_size>0){ + if (!nil_on_stack){ + GenBuildh (&nil_lab,0); + nil_on_stack=1; + } + + GenUpdateA (0,1+a_index); + + ++a_index; + --node_id_a_size; + } + } + } + } + *free_node_ids_l=free_node_id; + + if (nil_on_stack) + GenPopA (1); + } +} + +static void SubSizeOfState (StateS state,int *a_offset_p,int *b_offset_p); + +static void SubSizeOfStates (int arity,States states,int *a_offset_p,int *b_offset_p) +{ + for (; arity; arity--) + SubSizeOfState (states [arity-1],a_offset_p,b_offset_p); +} + +static void SubSizeOfState (StateS state,int *a_offset_p,int *b_offset_p) +{ + if (IsSimpleState (state)){ + if (state.state_kind==OnB) + *b_offset_p -= ObjectSizes [state.state_object]; + else if (state.state_kind != Undefined) + *a_offset_p -= 1; + } else { + switch (state.state_type){ + case RecordState: + SubSizeOfStates (state.state_arity,state.state_record_arguments,a_offset_p,b_offset_p); + break; + case TupleState: + SubSizeOfStates (state.state_arity,state.state_tuple_arguments,a_offset_p,b_offset_p); + break; + case ArrayState: + *a_offset_p -= 1; + break; + } + } +} + +static void SubSizeOfArguments (ArgS *args,int *a_offset_p,int *b_offset_p) +{ + ArgS *arg; + + for_l (arg,args,arg_next) + SubSizeOfState (arg->arg_state,a_offset_p,b_offset_p); +} + +void DetermineSizeOfArguments (ArgS *args,int *a_offset_p,int *b_offset_p) +{ + ArgS *arg; + + *a_offset_p=0; + *b_offset_p=0; + + for_l (arg,args,arg_next) + AddSizeOfState (arg->arg_state,a_offset_p,b_offset_p); +} + +static void BuildLazyArgs (Args args,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p); +static Bool BuildNonParArgs (Args args,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p); +static void BuildParArgs (ArgS* args,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p); +static void ReorderParallelAndNonParallelArgsWithResultNode (Args args,int *asize_p,int *bsize_p); + +#define BETWEEN(l,h,v) ((unsigned)((v)-(l)) <= (unsigned)((h)-(l))) + +static int ChangeArgumentNodeStatesIfStricter (Args offered_args,States demanded_states) +{ + StateP demanded_state_p; + ArgP arg_p; + + for_la (arg_p,demanded_state_p,offered_args,demanded_states,arg_next){ + Node arg_node; + int node_kind; + + arg_node=arg_p->arg_node; + + node_kind=arg_node->node_kind; + if (node_kind!=NodeIdNode){ + if (node_kind==NormalNode && (BETWEEN (int_denot,real_denot,arg_node->node_symbol->symb_kind) || arg_node->node_symbol->symb_kind==string_denot)) + ; + else + if (!FirstStateIsStricter (arg_node->node_state,*demanded_state_p)) + return 1; + } else + if (!FirstStateIsStricter (arg_node->node_node_id->nid_state,*demanded_state_p)) + return 1; + } + + for_la (arg_p,demanded_state_p,offered_args,demanded_states,arg_next){ + Node arg_node; + + arg_node=arg_p->arg_node; + if (arg_node->node_kind==NormalNode && + (BETWEEN (int_denot,real_denot,arg_node->node_symbol->symb_kind) || arg_node->node_symbol->symb_kind==string_denot) + ){ + arg_node->node_state=*demanded_state_p; + } + + arg_p->arg_state=*demanded_state_p; + } + + return 0; +} + +void BuildArgsWithNewResultNode (Args args,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p,int *a_size_p,int *b_size_p) +{ + BuildNonParArgs (args,asp_p,bsp_p,code_gen_node_ids_p); + NewEmptyNode (asp_p,-1); + BuildParArgs (args,asp_p,bsp_p,code_gen_node_ids_p); + ReorderParallelAndNonParallelArgsWithResultNode (args,a_size_p,b_size_p); +} + +void BuildArgsWithResultNodeOnStack (Args args,NodeIdP free_unique_node_id,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p,int *a_size_p,int *b_size_p) +{ + BuildNonParArgs (args,asp_p,bsp_p,code_gen_node_ids_p); + 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); + BuildParArgs (args,asp_p,bsp_p,code_gen_node_ids_p); + ReorderParallelAndNonParallelArgsWithResultNode (args,a_size_p,b_size_p); +} + +#if OPTIMIZE_LAZY_TUPLE_RECURSION +extern LabDef d_indirection_lab,n_indirection_lab; +#endif + +static void FillSymbol (Node node,SymbDef sdef,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p) +{ + LabDef name; + int symbarity; + + symbarity = sdef->sdef_kind==RECORDTYPE ? sdef->sdef_cons_arity : sdef->sdef_arity; + + if (symbarity==node->node_arity){ + switch (sdef->sdef_kind){ + case IMPRULE: + case DEFRULE: + case SYSRULE: + if (IsLazyState (node->node_state)){ + LabDef codelab; + + ConvertSymbolToDandNLabel (&name,&codelab,sdef); + + if (sdef->sdef_kind==IMPRULE && (sdef->sdef_rule->rule_mark & RULE_UNBOXED_LAZY_CALL)){ + int a_size,b_size; + +#ifndef OPTIMIZE_LAZY_TUPLE_RECURSION + if (update_node_id!=NULL) + error_in_function ("FillSymbol"); +#endif + + DetermineSizeOfArguments (node->node_arguments,&a_size,&b_size); + + if (b_size!=0) + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + else + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if (update_node_id!=NULL){ + if (a_size+b_size<=2){ + if (b_size!=0){ + GenFillU (&name,a_size,b_size,&codelab,*asp_p-update_node_id->nid_a_index); + *bsp_p -= b_size; + } else + GenFill (&name,a_size,&codelab,*asp_p-update_node_id->nid_a_index,NormalFill); + *asp_p-=a_size; + + GenPushA (*asp_p-update_node_id->nid_a_index); + *asp_p+=1; + } else { + if (b_size!=0) + GenBuildU (&name,a_size,b_size,&codelab); + else + GenBuild (&name,a_size,&codelab); + *asp_p += 1-a_size; + *bsp_p -= b_size; + + GenFill (&d_indirection_lab,-2,&n_indirection_lab,*asp_p-update_node_id->nid_a_index,NormalFill); + --*asp_p; + } + } else +#endif + { + *asp_p += 1-a_size; + *bsp_p -= b_size; + + if (b_size!=0) + GenBuildU (&name,a_size,b_size,&codelab); + else + GenBuild (&name,a_size,&codelab); + } + return; + } + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + if (update_node_id==NULL){ + *asp_p += 1-symbarity; + GenBuild (&name,symbarity,&codelab); + } else { +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if ((update_node_id->nid_mark & ON_A_CYCLE_MASK)!=0 || symbarity<=2){ + GenFill (&name,symbarity,&codelab,*asp_p-update_node_id->nid_a_index,PartialFill); + *asp_p-=symbarity; + } else { + GenBuild (&name,symbarity,&codelab); + *asp_p+=1-symbarity; + GenFill (&d_indirection_lab,-2,&n_indirection_lab,*asp_p-update_node_id->nid_a_index,NormalFill); + --*asp_p; + } +#else + GenFill (&name,symbarity,&codelab,*asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? PartialFill : NormalFill); + *asp_p -= symbarity; +#endif + } + } else { + int newnode,a_size,b_size; + + ConvertSymbolToLabel (&name,sdef); + + newnode=False; + + if (update_node_id==NULL && ExpectsResultNode (node->node_state)){ + BuildArgsWithNewResultNode (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p,&a_size,&b_size); + + *asp_p-=a_size; + *bsp_p-=b_size; + + if (! (sdef->sdef_kind==SYSRULE + && sdef->sdef_ident->ident_instructions!=NULL + && *sdef->sdef_ident->ident_instructions!='\0' + && *sdef->sdef_ident->ident_instructions!='.')) + { + cleanup_stack (asp_p,bsp_p,a_size,b_size,&code_gen_node_ids_p->a_node_ids,&code_gen_node_ids_p->b_node_ids, + &code_gen_node_ids_p->free_node_ids,code_gen_node_ids_p->moved_node_ids_l, + code_gen_node_ids_p->doesnt_fail); + } + CallFunction (&name,sdef,True,node); + + AddSizeOfState (node->node_state,asp_p,bsp_p); + + return; + } + + DetermineSizeOfArguments (node->node_arguments,&a_size,&b_size); + + if (update_node_id!=NULL && update_node_id->nid_a_index!=*asp_p){ + GenPushA (*asp_p-update_node_id->nid_a_index); + *asp_p += SizeOfAStackElem; + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + *asp_p-=a_size+1; /* changed 20-7-1999, was a_size */ + *bsp_p-=b_size; + + if (! (sdef->sdef_kind==SYSRULE + && sdef->sdef_ident->ident_instructions!=NULL + && *sdef->sdef_ident->ident_instructions!='\0' + && *sdef->sdef_ident->ident_instructions!='.')) + { + cleanup_stack (asp_p,bsp_p,a_size+1,b_size,&code_gen_node_ids_p->a_node_ids,&code_gen_node_ids_p->b_node_ids, + &code_gen_node_ids_p->free_node_ids,code_gen_node_ids_p->moved_node_ids_l, + code_gen_node_ids_p->doesnt_fail); + } + + CallFunction (&name,sdef,True,node); + + AddSizeOfState (node->node_state,asp_p,bsp_p); + + GenPopA (1); + *asp_p-=1; + } else { + if (newnode) + ++a_size; + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + *asp_p-=a_size; + *bsp_p-=b_size; + + if (! (sdef->sdef_kind==SYSRULE + && sdef->sdef_ident->ident_instructions!=NULL + && *sdef->sdef_ident->ident_instructions!='\0' + && *sdef->sdef_ident->ident_instructions!='.')) + { + cleanup_stack (asp_p,bsp_p,a_size,b_size,&code_gen_node_ids_p->a_node_ids,&code_gen_node_ids_p->b_node_ids, + &code_gen_node_ids_p->free_node_ids,code_gen_node_ids_p->moved_node_ids_l, + code_gen_node_ids_p->doesnt_fail); + } + + CallFunction (&name,sdef,True,node); + + AddSizeOfState (node->node_state,asp_p,bsp_p); + } + } + return; + case CONSTRUCTOR: + if (sdef->sdef_strict_constructor){ + int lazy_fill; + + ConvertSymbolToLabel (&name,sdef); + + lazy_fill=IsLazyState (node->node_state); + + if (lazy_fill) + lazy_fill=ChangeArgumentNodeStatesIfStricter (node->node_arguments,sdef->sdef_constructor->cl_state_p); + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + if (lazy_fill){ + LabDef reclab, contlab; + + ConvertSymbolToConstructorDandNLabel (&reclab,&contlab,sdef); + + if (update_node_id==NULL){ + *asp_p+=1-symbarity; + GenBuild (&reclab,symbarity,&contlab); + } else { +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if ((update_node_id->nid_mark & ON_A_CYCLE_MASK)!=0 || symbarity<=2){ + GenFill (&reclab,symbarity,&contlab,*asp_p-update_node_id->nid_a_index,ReleaseAndFill); + *asp_p-=symbarity; + } else { + GenBuild (&reclab,symbarity,&contlab); + *asp_p+=1-symbarity; + GenFill (&d_indirection_lab,-2,&n_indirection_lab,*asp_p-update_node_id->nid_a_index,NormalFill); + --*asp_p; + } +#else + GenFill (&reclab,symbarity,&contlab,*asp_p-update_node_id->nid_a_index, + node->node_state.state_kind==SemiStrict ? ReleaseAndFill : NormalFill); + *asp_p-=symbarity; +#endif + } + } else { + int asize,bsize; + LabDef record_label; + + DetermineSizeOfArguments (node->node_arguments,&asize,&bsize); + + ConvertSymbolToKLabel (&record_label,sdef); + + *asp_p-=asize; + *bsp_p-=bsize; + + if (update_node_id==NULL){ + GenBuildR (&record_label,asize,bsize,0,0,True); + *asp_p+=1; + } else { + GenFillR (&record_label,asize,bsize,*asp_p+asize-update_node_id->nid_a_index,0,0,node->node_state.state_kind==SemiStrict ? ReleaseAndFill : NormalFill,True); + } + } + } else { + ConvertSymbolToConstructorDLabel (&name,sdef); + + BuildLazyArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + if (update_node_id==NULL){ + *asp_p+=1-node->node_arity; + GenBuildh (&name,node->node_arity); + } else { + GenFillh (&name,node->node_arity,*asp_p-update_node_id->nid_a_index, + node->node_state.state_kind==SemiStrict ? ReleaseAndFill : NormalFill); + *asp_p-=node->node_arity; + } + } + return; + case RECORDTYPE: + ConvertSymbolToLabel (&name,sdef); + + if (IsSimpleState (node->node_state)){ + LabDef record_label; + int lazy_fill; + + lazy_fill=sdef->sdef_strict_constructor && IsLazyState (node->node_state); + + if (lazy_fill) + lazy_fill=ChangeArgumentNodeStatesIfStricter (node->node_arguments,sdef->sdef_record_state.state_record_arguments); + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + if (lazy_fill){ + LabDef contlab; + + ConvertSymbolToRecordDandNLabel (&record_label,&contlab,sdef); + + if (update_node_id==NULL){ + *asp_p+=1-symbarity; + GenBuild (&record_label,symbarity,&contlab); + } else { +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if ((update_node_id->nid_mark & ON_A_CYCLE_MASK)!=0 || symbarity<=2){ + GenFill (&record_label,symbarity,&contlab,*asp_p-update_node_id->nid_a_index,ReleaseAndFill); + *asp_p-=symbarity; + } else { + GenBuild (&record_label,symbarity,&contlab); + *asp_p+=1-symbarity; + GenFill (&d_indirection_lab,-2,&n_indirection_lab,*asp_p-update_node_id->nid_a_index,NormalFill); + --*asp_p; + } +#else + GenFill (&record_label,symbarity,&contlab,*asp_p-update_node_id->nid_a_index, + node->node_state.state_kind==SemiStrict ? ReleaseAndFill : NormalFill); + *asp_p-=symbarity; +#endif + } + } else { + int asize,bsize; + + ConvertSymbolToRLabel (&record_label,sdef); + + DetermineSizeOfArguments (node->node_arguments,&asize,&bsize); + + *asp_p-=asize; + *bsp_p-=bsize; + + if (update_node_id==NULL){ + *asp_p+=1; + GenBuildR (&record_label,asize,bsize,0,0,True); + } else { + GenFillR (&record_label,asize,bsize,*asp_p+asize-update_node_id->nid_a_index,0,0,node->node_state.state_kind==SemiStrict ? ReleaseAndFill : NormalFill,True); + } + } + } else + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + return; + default: + if (update_node_id==NULL) + NewEmptyNode (asp_p,-1); + return; + } + } else { + if (sdef->sdef_kind==CONSTRUCTOR) + ConvertSymbolToConstructorDLabel (&name,sdef); + else + ConvertSymbolToDLabel (&name,sdef); + + /* Symbol has too few arguments */ + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + if (update_node_id==NULL){ + *asp_p+=1-node->node_arity; + GenBuildh (&name,node->node_arity); + } else { + GenFillh (&name,node->node_arity,*asp_p-update_node_id->nid_a_index,NormalFill); + *asp_p-=node->node_arity; + } + } +} + +void GenTypeError (void) +{ + GenDAStackLayout (0); + GenJsr (&type_error_lab); + GenOAStackLayout (0); + + TypeErrorFound = True; +} + +static void decrement_reference_count_of_node_ids_in_graph (Node node,NodeIdListElementS **free_node_ids_l) +{ + if (node->node_kind!=NodeIdNode){ + struct arg *arg; + + for_l (arg,node->node_arguments,arg_next) + decrement_reference_count_of_node_ids_in_graph (arg->arg_node,free_node_ids_l); + } else + decrement_reference_count_of_node_id (node->node_node_id,free_node_ids_l); +} + +static void increment_reference_count_of_node_ids_in_graph (Node node) +{ + if (node->node_kind!=NodeIdNode){ + struct arg *arg; + + for_l (arg,node->node_arguments,arg_next) + increment_reference_count_of_node_ids_in_graph (arg->arg_node); + } else { + struct node_id *node_id; + int ref_count; + + node_id=node->node_node_id; + ref_count=node_id->nid_refcount; + + if (ref_count>=0) + node_id->nid_refcount=ref_count+1; + else + node_id->nid_refcount=ref_count-1; + } +} + +#ifdef FASTER_STRICT_IF + +static void build_strict_then_or_else (Node then_or_else_node,Node else_node,int *asp_p,int *bsp_p, + CodeGenNodeIdsP code_gen_node_ids_p,StateS result_state) +{ + if (then_or_else_node->node_kind!=NodeIdNode){ + SavedNidStateP saved_node_id_states; + struct code_gen_node_ids code_gen_node_ids; + MovedNodeIdP moved_node_ids; + int a_size,b_size; + + saved_node_id_states=NULL; + moved_node_ids=NULL; + + code_gen_node_ids.free_node_ids=code_gen_node_ids_p->free_node_ids; + code_gen_node_ids.saved_nid_state_l=&saved_node_id_states; + code_gen_node_ids.doesnt_fail=False; + code_gen_node_ids.moved_node_ids_l=&moved_node_ids; + code_gen_node_ids.a_node_ids=code_gen_node_ids_p->a_node_ids; + code_gen_node_ids.b_node_ids=code_gen_node_ids_p->b_node_ids; + + if (else_node!=NULL) + decrement_reference_count_of_node_ids_in_graph (else_node,&code_gen_node_ids.free_node_ids); + + Build (then_or_else_node,asp_p,bsp_p,&code_gen_node_ids); + + if (else_node!=NULL) + increment_reference_count_of_node_ids_in_graph (else_node); + + restore_saved_node_id_states (saved_node_id_states); + + DetermineSizeOfState (then_or_else_node->node_state,&a_size,&b_size); + CoerceArgumentOnTopOfStack (asp_p,bsp_p,result_state,then_or_else_node->node_state,a_size,b_size); + } else { + NodeId nid; + int a_size,b_size; + + nid=then_or_else_node->node_node_id; + DetermineSizeOfState (nid->nid_state,&a_size,&b_size); + CopyArgument (result_state,nid->nid_state,nid->nid_a_index,nid->nid_b_index,asp_p,bsp_p,a_size,b_size,True); + } +} + +static void fill_strict_if_node (Node node,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + StateS condition_result_state; + LabDef else_label,endif_label; + Args arguments,then_arg,else_arg; + int else_asp,else_bsp; + + arguments = node->node_arguments; + + SetUnaryState (&condition_result_state,OnB,BoolObj); + EvaluateCondition (arguments->arg_node,asp_p,bsp_p,code_gen_node_ids_p,condition_result_state); + + MakeLabel (&else_label,"else",NewLabelNr,no_pref); + MakeLabel (&endif_label,"endif",NewLabelNr++,no_pref); + + GenJmpFalse (&else_label); + + then_arg=arguments->arg_next; + else_arg=then_arg->arg_next; + + else_asp=*asp_p; + else_bsp=*bsp_p; + + build_strict_then_or_else (then_arg->arg_node,else_arg->arg_node,asp_p,bsp_p,code_gen_node_ids_p,node->node_state); + + GenJmp (&endif_label); + + GenLabelDefinition (&else_label); + + build_strict_then_or_else (else_arg->arg_node,NULL,&else_asp,&else_bsp,code_gen_node_ids_p,node->node_state); + + if (else_asp!=*asp_p || else_bsp!=*bsp_p){ + int a_size,b_size; + + DetermineSizeOfState (node->node_state,&a_size,&b_size); + + if (else_asp>*asp_p){ + int difference,i; + + difference=else_asp - *asp_p; + for (i=a_size-1; i>=0; --i) +#if UPDATE_POP + if (i==0) + GenUpdatePopA (0,difference); + else +#endif + GenUpdateA (i,i+difference); + +#if UPDATE_POP + if (a_size==0) +#endif + GenPopA (difference); + } else if (else_asp<*asp_p){ + int difference,i; + + difference=*asp_p - else_asp; + + if (difference>a_size){ + int n; + + GenBuildh (&nil_lab,0); + + n=(difference-a_size)-1; + + for (i=0; i<n; ++i) + GenPushA (i); + + for (i=a_size-1; i>=0; --i) + GenPushA (difference-1); + + if (a_size>0){ + GenBuildh (&nil_lab,0); + + for (i=0; i<a_size; ++i) + GenUpdateA (0,difference+i); + + GenPopA (1); + } + } else { + for (i=difference-1; i>=0; --i) + GenPushA (difference-1); + + if (difference<a_size){ + GenBuildh (&nil_lab,0); + + for (i=difference; i<a_size; ++i){ + GenUpdateA (i+difference+1,i+1); + GenUpdateA (0,i+difference+1); + } + GenPopA (1); + } + } + } + + if (else_bsp>*bsp_p){ + int difference,i; + + difference=else_bsp - *bsp_p; + for (i=b_size-1; i>=0; --i) +#if UPDATE_POP + if (i==0) + GenUpdatePopB (0,difference); + else +#endif + GenUpdateB (i,i+difference); +#if UPDATE_POP + if (b_size==0) +#endif + GenPopB (difference); + } else if (else_bsp<*bsp_p){ + int difference,i; + SymbValue sv; + + sv.val_int="0"; + + difference=*bsp_p - else_bsp; + + if (difference>b_size){ + int n; + + PushBasic (IntObj,sv); + + n=(difference-b_size)-1; + + for (i=0; i<n; ++i) + GenPushB (i); + + for (i=b_size-1; i>=0; --i) + GenPushB (difference-1); + + if (b_size>0){ + PushBasic (IntObj,sv); + + for (i=0; i<b_size; ++i) + GenUpdateB (0,difference+i); + + GenPopB (1); + } + } else { + for (i=difference-1; i>=0; --i) + GenPushB (difference-1); + + if (difference<b_size){ + PushBasic (IntObj,sv); + + for (i=difference; i<b_size; ++i){ + GenUpdateB (i+difference+1,i+1); + GenUpdateB (0,i+difference+1); + } + GenPopB (1); + } + } + } + } + + { + int result_a_size,result_b_size; + + DetermineSizeOfState (node->node_state,&result_a_size,&result_b_size); + + if (code_gen_node_ids_p->a_node_ids!=NULL){ + int asp_without_result; + NodeIdListElementP a_node_ids,a_node_id_p; + + asp_without_result=*asp_p-result_a_size; + a_node_ids=code_gen_node_ids_p->a_node_ids; + + /* JVG: changed 28-10-1999 */ + a_node_id_p=a_node_ids; + while (a_node_id_p!=NULL && a_node_id_p->nidl_node_id->nid_a_index>asp_without_result) + if (a_node_id_p->nidl_node_id->nid_a_index!=UNUSED_NODE_ID_INDEX){ + a_node_id_p=a_node_id_p->nidl_next; + a_node_ids=a_node_id_p; + } else + a_node_id_p=a_node_id_p->nidl_next; + /* + while (a_node_ids!=NULL && + a_node_ids->nidl_node_id->nid_a_index>asp_without_result && a_node_ids->nidl_node_id->nid_a_index!=UNUSED_NODE_ID_INDEX) + { + a_node_ids=a_node_ids->nidl_next; + } + */ + code_gen_node_ids_p->a_node_ids=a_node_ids; + } + + if (code_gen_node_ids_p->b_node_ids!=NULL){ + int bsp_without_result; + NodeIdListElementP b_node_ids,b_node_id_p; + + bsp_without_result=*bsp_p-result_b_size; + b_node_ids=code_gen_node_ids_p->b_node_ids; + + /* JVG: changed 28-10-1999 */ + b_node_id_p=b_node_ids; + while (b_node_id_p!=NULL && b_node_id_p->nidl_node_id->nid_b_index>bsp_without_result) + if (b_node_id_p->nidl_node_id->nid_b_index!=UNUSED_NODE_ID_INDEX){ + b_node_id_p=b_node_id_p->nidl_next; + b_node_ids=b_node_id_p; + } else + b_node_id_p=b_node_id_p->nidl_next; + /* + while (b_node_ids!=NULL && + b_node_ids->nidl_node_id->nid_b_index>bsp_without_result && b_node_ids->nidl_node_id->nid_b_index!=UNUSED_NODE_ID_INDEX) + { + b_node_ids=b_node_ids->nidl_next; + } + */ + code_gen_node_ids_p->b_node_ids=b_node_ids; + } + } + + GenLabelDefinition (&endif_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; + + symb = node->node_symbol; + + switch (symb->symb_kind){ + case definition: + FillSymbol (node,symb->symb_def,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + return; + case select_symb: + FillOrReduceSelectSymbol (node,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + return; + case apply_symb: + FillSymbol (node,ApplyDef,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + return; + case if_symb: +#ifdef FASTER_STRICT_IF + if (node->node_arity==3 && !IsLazyState (node->node_state) && update_node_id==NULL) + fill_strict_if_node (node,asp_p,bsp_p,code_gen_node_ids_p); + else +#endif + FillSymbol (node,IfDef,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + return; + case tuple_symb: + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + if (IsSimpleState (node->node_state)){ + if (update_node_id==NULL){ + *asp_p+=1-node->node_arity; + GenBuildh (&tuple_lab,node->node_arity); + } else { + GenFillh (&tuple_lab,node->node_arity,*asp_p-update_node_id->nid_a_index, + node->node_state.state_kind == SemiStrict ? ReleaseAndFill : NormalFill); + *asp_p-=node->node_arity; + } + } + return; + case cons_symb: + BuildLazyArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + if (update_node_id==NULL){ + *asp_p+=1-node->node_arity; + GenBuildh (&cons_lab,node->node_arity); + } else { + GenFillh (&cons_lab, node->node_arity,*asp_p-update_node_id->nid_a_index, + node->node_state.state_kind == SemiStrict ? ReleaseAndFill : NormalFill); + *asp_p-=node->node_arity; + } + return; + case nil_symb: + if (update_node_id==NULL){ + *asp_p+=1; + GenBuildh (&nil_lab,node->node_arity); + } else + GenFillh (&nil_lab,node->node_arity,*asp_p-update_node_id->nid_a_index, + node->node_state.state_kind == SemiStrict ? ReleaseAndFill : NormalFill); + return; + case string_denot: + GenBuildString (symb->symb_val); + *asp_p+=1; + if (IsSimpleState (node->node_state)){ + if (update_node_id==NULL){ + GenBuildh (&BasicDescriptors[ArrayObj],1); + } else { + GenFillh (&BasicDescriptors[ArrayObj],1,*asp_p-update_node_id->nid_a_index,ReleaseAndFill); + *asp_p-=1; + } + } + return; + default: + if (symb->symb_kind<Nr_Of_Basic_Types){ + if (update_node_id==NULL){ + *asp_p+=1; + GenBuildh (&BasicDescriptors[symb->symb_kind],0); + } else + GenFillh (&BasicDescriptors[symb->symb_kind],0,*asp_p-update_node_id->nid_a_index, + node->node_state.state_kind == SemiStrict ? ReleaseAndFill : NormalFill); + } else { + ObjectKind denottype; + + denottype = (symb->symb_kind < Nr_Of_Predef_Types) + ? BasicSymbolStates [symb->symb_kind].state_object + : UnknownObj; + + if (node->node_state.state_object==denottype || + node->node_state.state_object==UnknownObj || denottype==UnknownObj +#if ABSTRACT_OBJECT + || node->node_state.state_object==AbstractObj || denottype==AbstractObj +#endif + ) + { + if (node->node_state.state_kind==OnB){ + *bsp_p += ObjectSizes [denottype]; + PushBasic (denottype, symb->symb_val); + } else { + if (update_node_id==NULL){ + *asp_p+=1; + BuildBasic (denottype,symb->symb_val); + } else { + FillBasic (denottype,symb->symb_val,*asp_p-update_node_id->nid_a_index, + node->node_state.state_kind == SemiStrict ? ReleaseAndFill : NormalFill); + } + } + } else { + StaticMessage (False,CurrentAltLabel.lab_symbol->sdef_ident->ident_name,Co_Wtype); + GenTypeError(); + } + } + } +} + +void RemoveSelectorsFromUpdateNode (ArgS *previous_arg,ArgS *arg) +{ + while (arg!=NULL){ + ArgS *field_arg; + + field_arg=arg->arg_node->node_arguments; + + previous_arg->arg_next=field_arg; + previous_arg=field_arg; + + arg=arg->arg_next; + } + previous_arg->arg_next=NULL; +} + +void UpdateNodeAndAddSelectorsToUpdateNode + (ArgS *record_arg,ArgS *first_field_arg,StateS *field_states,int record_a_size,int record_b_size,int *asp_p,int *bsp_p) +{ + ArgS *arg,*previous_arg; + int a_offset,b_offset,arg_a_offset,arg_b_offset,previous_field_number; + + a_offset=0; + b_offset=0; + arg_a_offset=record_a_size; + arg_b_offset=record_b_size; + + previous_field_number=0; + + previous_arg=record_arg; + for_l (arg,first_field_arg,arg_next){ + int field_number,arg_a_size,arg_b_size; + Node field_node; + + field_node=arg->arg_node; + field_node->node_arguments->arg_next=NULL; + + field_number=field_node->node_symbol->symb_def->sdef_sel_field_number; + + while (field_number!=previous_field_number){ + AddSizeOfState (field_states[previous_field_number],&a_offset,&b_offset); + ++previous_field_number; + } + + DetermineSizeOfState (field_states[field_number],&arg_a_size,&arg_b_size); + + while (arg_a_size){ + GenUpdateA (arg_a_offset,a_offset); + ++arg_a_offset; + ++a_offset; + --arg_a_size; + } + + while (arg_b_size){ + GenUpdateB (arg_b_offset,b_offset); + ++arg_b_offset; + ++b_offset; + --arg_b_size; + } + + ++previous_field_number; + + previous_arg->arg_next=arg; + previous_arg=arg; + } + previous_arg->arg_next=NULL; + + if (arg_a_offset!=record_a_size){ + a_offset=record_a_size; + while (a_offset>0){ + --a_offset; + --arg_a_offset; +#if UPDATE_POP + if (a_offset==0) + GenUpdatePopA (a_offset,arg_a_offset); + else +#endif + GenUpdateA (a_offset,arg_a_offset); + } +#if UPDATE_POP + if (record_a_size==0) +#endif + GenPopA (arg_a_offset); + + *asp_p -= arg_a_offset; + } + + if (arg_b_offset!=record_b_size){ + b_offset=record_b_size; + while (b_offset>0){ + --b_offset; + --arg_b_offset; +#if UPDATE_POP + if (b_offset==0) + GenUpdatePopB (b_offset,arg_b_offset); + else +#endif + GenUpdateB (b_offset,arg_b_offset); + } +#if UPDATE_POP + if (record_b_size==0) +#endif + GenPopB (arg_b_offset); + *bsp_p -= arg_b_offset; + } +} + +#ifdef DESTRUCTIVE_RECORD_UPDATES +void compute_bits_and_add_selectors_to_update_node + (ArgS *record_arg,ArgS *first_field_arg,StateS *field_states,int record_a_size,int record_b_size, + char bits[],int *n_a_fill_bits_p,int *n_b_fill_bits_p) +{ + ArgP arg,previous_arg; + int a_offset,b_offset,previous_field_number; + unsigned int a_bits,b_bits,n,arg_n,n_args; + int n_a_fill_bits,n_b_fill_bits; + + a_bits=0; + b_bits=0; + n_a_fill_bits=0; + n_b_fill_bits=0; + + a_offset=0; + b_offset=0; + + previous_field_number=0; + + previous_arg=record_arg; + for_l (arg,first_field_arg,arg_next){ + int field_number,arg_a_size,arg_b_size; + Node field_node; + + field_node=arg->arg_node; + field_node->node_arguments->arg_next=NULL; + + field_number=field_node->node_symbol->symb_def->sdef_sel_field_number; + + while (field_number!=previous_field_number){ + AddSizeOfState (field_states[previous_field_number],&a_offset,&b_offset); + ++previous_field_number; + } + + DetermineSizeOfState (field_states[field_number],&arg_a_size,&arg_b_size); + + a_bits |= (~((~0)<<arg_a_size))<<a_offset; + b_bits |= (~((~0)<<arg_b_size))<<b_offset; + + n_a_fill_bits+=arg_a_size; + n_b_fill_bits+=arg_b_size; + + a_offset+=arg_a_size; + b_offset+=arg_b_size; + + ++previous_field_number; + + previous_arg->arg_next=arg; + previous_arg=arg; + } + previous_arg->arg_next=NULL; + + bits[0]='0'; + + for (n=0; n<record_a_size; ++n){ + if (a_bits & (1<<n)) + bits[n+1]='1'; + else + bits[n+1]='0'; + } + + for (n=0; n<record_b_size; ++n){ + if (b_bits & (1<<n)) + bits[n+record_a_size+1]='1'; + else + bits[n+record_a_size+1]='0'; + } + + bits[record_a_size+record_b_size+1]='\0'; + + *n_a_fill_bits_p=n_a_fill_bits; + *n_b_fill_bits_p=n_b_fill_bits; +} +#endif + +static void FillUpdateNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p) +{ + ArgS *record_arg,*first_field_arg; + int record_a_size,record_b_size; + + record_arg=node->node_arguments; + first_field_arg=record_arg->arg_next; + + RemoveSelectorsFromUpdateNode (record_arg,first_field_arg); + + if (IsSimpleState (node->node_state)){ + int n_arguments; + LabDef name,codelab; + SymbDef new_update_sdef; + struct node *record_node; +#if DESTRUCTIVE_RECORD_UPDATES + int update_immediately; + StateP record_node_id_state_p; + + record_node=record_arg->arg_node; + + if (node->node_state.state_kind==StrictOnA){ + update_immediately=1; + record_node_id_state_p=&node->node_symbol->symb_def->sdef_record_state; + } else { + update_immediately=0; + + if (record_node->node_kind==NodeIdNode){ + record_node_id_state_p=&record_node->node_node_id->nid_state; + + if (record_node_id_state_p->state_type==RecordState){ + update_immediately=1; + + if (record_node_id_state_p->state_record_symbol->sdef_strict_constructor){ + StateS *record_states; + + record_states=record_node_id_state_p->state_record_arguments; + + if (!FieldArgumentNodeStatesAreStricter (record_arg->arg_next,first_field_arg,record_states)) + update_immediately=0; + else { + ArgP node_arg,field_arg; + + for_ll (node_arg,field_arg,record_arg->arg_next,first_field_arg,arg_next,arg_next){ + Node arg_node; + int field_number; + + field_number=field_arg->arg_node->node_symbol->symb_def->sdef_sel_field_number; + + arg_node=node_arg->arg_node; + if (arg_node->node_kind==NormalNode && + (BETWEEN (int_denot,real_denot,arg_node->node_symbol->symb_kind) || arg_node->node_symbol->symb_kind==string_denot)) + { + arg_node->node_state=record_states[field_number]; + } + + node_arg->arg_state=record_states[field_number]; + } + } + } + } + } + } + + if (update_immediately){ + if (node->node_state.state_kind==StrictOnA && record_node->node_kind==NodeIdNode){ + NodeIdP record_node_id; + + record_node_id=record_node->node_node_id; + + if ((record_node_id->nid_state.state_mark & STATE_UNIQUE_MASK)!=0 && + (record_node_id->nid_mark2 & NID_HAS_REFCOUNT_WITHOUT_UPDATES)!=0 && + record_node_id->nid_number== -1 && + record_node_id->nid_state.state_type==SimpleState && + record_node_id->nid_state.state_kind==StrictOnA && + update_node_id==NULL) + { + int n_a_fill_bits,n_b_fill_bits; + char bits[MaxNodeArity+2]; + LabDef record_lab; + + BuildArgs (record_arg->arg_next,asp_p,bsp_p,code_gen_node_ids_p); + + DetermineSizeOfState (*record_node_id_state_p,&record_a_size,&record_b_size); + + compute_bits_and_add_selectors_to_update_node (record_arg,first_field_arg, + record_node_id_state_p->state_record_arguments,record_a_size,record_b_size, + bits,&n_a_fill_bits,&n_b_fill_bits); + + ConvertSymbolToRLabel (&record_lab,record_node_id_state_p->state_record_symbol); + + if (record_a_size+record_b_size>2) + GenFill2R (&record_lab,record_a_size,record_b_size,*asp_p-record_node_id->nid_a_index,bits); + else + GenFill1R (&record_lab,record_a_size,record_b_size,*asp_p-record_node_id->nid_a_index,bits); + + *asp_p-=n_a_fill_bits; + *bsp_p-=n_b_fill_bits; + + GenPushA (*asp_p-record_node_id->nid_a_index); + *asp_p+=1; + + decrement_reference_count_of_node_id (record_node_id,&code_gen_node_ids_p->free_node_ids); + + return; + } + } + + record_arg->arg_state=*record_node_id_state_p; + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + DetermineSizeOfState (*record_node_id_state_p,&record_a_size,&record_b_size); + + UpdateNodeAndAddSelectorsToUpdateNode (record_arg,first_field_arg, + record_node_id_state_p->state_record_arguments,record_a_size,record_b_size,asp_p,bsp_p); + + if (update_node_id==NULL){ + BuildRecord (record_node_id_state_p->state_record_symbol,*asp_p,*bsp_p,*asp_p,*bsp_p,record_a_size,record_b_size, + 0,node->node_state.state_kind==SemiStrict ? PartialFill : NormalFill,True); + *asp_p+=1; + GenUpdateA (0,record_a_size); + } else + BuildRecord (record_node_id_state_p->state_record_symbol,*asp_p,*bsp_p,*asp_p,*bsp_p,record_a_size,record_b_size, + *asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? PartialFill : NormalFill,False); + + GenPopA (record_a_size); + *asp_p-=record_a_size; + GenPopB (record_b_size); + *bsp_p-=record_b_size; + + return; + } +#else + record_node=record_arg->arg_node; + if (record_node->node_kind==NodeIdNode){ + StateP record_node_id_state_p; + + record_node_id_state_p=&record_node->node_node_id->nid_state; + + if (record_node_id_state_p->state_type==SimpleState && record_node_id_state_p->state_kind==StrictOnA) + record_node_id_state_p=&node->node_symbol->symb_def->sdef_record_state; + + if (record_node_id_state_p->state_type==RecordState){ + int update_immediately; + + update_immediately=1; + + if (record_node_id_state_p->state_record_symbol->sdef_strict_constructor){ + StateP record_states; + + record_states=record_node_id_state_p->state_record_arguments; + + if (!FieldArgumentNodeStatesAreStricter (record_arg->arg_next,first_field_arg,record_states)) + update_immediately=0; + else { + ArgP node_arg,field_arg; + + for_ll (node_arg,field_arg,record_arg->arg_next,first_field_arg,arg_next,arg_next){ + Node arg_node; + int field_number; + + field_number=field_arg->arg_node->node_symbol->symb_def->sdef_sel_field_number; + + arg_node=node_arg->arg_node; + if (arg_node->node_kind==NormalNode && + (BETWEEN (int_denot,real_denot,arg_node->node_symbol->symb_kind) || arg_node->node_symbol->symb_kind==string_denot)) + { + arg_node->node_state=record_states[field_number]; + } + + node_arg->arg_state=record_states[field_number]; + } + } + } + + if (update_immediately){ + record_arg->arg_state=*record_node_id_state_p; + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + DetermineSizeOfState (*record_node_id_state_p,&record_a_size,&record_b_size); + + UpdateNodeAndAddSelectorsToUpdateNode (record_arg,first_field_arg, + record_node_id_state_p->state_record_arguments,record_a_size,record_b_size,asp_p,bsp_p); + + if (update_node_id==NULL){ + BuildRecord (record_node_id_state_p->state_record_symbol,*asp_p,*bsp_p,*asp_p,*bsp_p,record_a_size,record_b_size, + 0,node->node_state.state_kind==SemiStrict ? PartialFill : NormalFill,True); + *asp_p+=1; + GenUpdateA (0,record_a_size); + } else + BuildRecord (record_node_id_state_p->state_record_symbol,*asp_p,*bsp_p,*asp_p,*bsp_p,record_a_size,record_b_size, + *asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? PartialFill : NormalFill,False); + + GenPopA (record_a_size); + *asp_p-=record_a_size; + GenPopB (record_b_size); + *bsp_p-=record_b_size; + + return; + } + } + } +#endif + + n_arguments=node->node_arity; + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + new_update_sdef=CreateUpdateFunction (record_arg,first_field_arg,node); + + ConvertSymbolToDandNLabel (&name,&codelab,new_update_sdef); + + if (update_node_id==NULL){ + GenBuild (&name,n_arguments,&codelab); + *asp_p+=1-n_arguments; + } else { + GenFill (&name,n_arguments,&codelab,*asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? PartialFill : NormalFill); + *asp_p-=n_arguments; + } + } else { + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + DetermineSizeOfState (node->node_state,&record_a_size,&record_b_size); + + UpdateNodeAndAddSelectorsToUpdateNode (record_arg,first_field_arg, + node->node_state.state_record_arguments,record_a_size,record_b_size,asp_p,bsp_p); + } +} + +static LabDef selector_m_error_lab = {NULL,"",False,"selector_m_error",0}; + +void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p) +{ + int symbol_arity_eq_one; + Symbol symbol; + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + symbol=node->node_symbol; + + if (symbol->symb_kind==definition && symbol->symb_def->sdef_kind==CONSTRUCTOR && symbol->symb_def->sdef_arity==1) + symbol_arity_eq_one=1; + else + symbol_arity_eq_one=0; + + if (IsSimpleState (node->node_state) && !(symbol_arity_eq_one && !IsLazyState (node->node_state))){ + int n_arguments,strict_constructor; + LabDef name,codelab; + SymbDef new_match_sdef; + + strict_constructor=0; + + if (symbol->symb_kind==definition && symbol->symb_def->sdef_kind==CONSTRUCTOR){ + if (symbol->symb_def->sdef_strict_constructor) + strict_constructor=1; + else + if (symbol->symb_def->sdef_type->type_nr_of_constructors==1){ + if (symbol_arity_eq_one){ + LabDef sellab, nsellab; + + BuildLazyTupleSelectorLabel (&nsellab,1,1); + + sellab = nsellab; + sellab.lab_pref = d_pref; + + if (update_node_id==NULL){ + GenBuild (&sellab,-1,&nsellab); + } else { + GenFill (&sellab,-1,&nsellab,*asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? PartialFill : NormalFill); + *asp_p-=1; + } + } else + if (update_node_id!=NULL){ + GenFillFromA (0,*asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? PartialFill : NormalFill); + GenPopA (1); + *asp_p-=1; + } + + return; + } + } + + if (!symbol_arity_eq_one) + new_match_sdef=create_match_function (symbol,node->node_arity,strict_constructor); + else + new_match_sdef=create_select_and_match_function (symbol,strict_constructor); + + ConvertSymbolToDandNLabel (&name,&codelab,new_match_sdef); + + n_arguments=1; + + if (update_node_id==NULL){ + GenBuild (&name,n_arguments,&codelab); + } else { + GenFill (&name,n_arguments,&codelab,*asp_p-update_node_id->nid_a_index,node->node_state.state_kind==SemiStrict ? PartialFill : NormalFill); + *asp_p-=1; + } + } else { + struct state *demanded_state_array; + int demanded_state_arity; + int a_size,b_size; + struct arg *argument; + struct symbol *symbol; + int branch; + + argument = node->node_arguments; + + DetermineSizeOfState (argument->arg_state,&a_size,&b_size); + + if (CoerceStateKind (StrictOnA,argument->arg_state.state_kind)==Reduce) + GenJsrEval (0); + + symbol=node->node_symbol; + + branch=1; + + switch (symbol->symb_kind){ + case cons_symb: + GenEqDesc (&cons_lab,2,0); + break; + case definition: + { + SymbDef sdef; + + sdef=symbol->symb_def; + + if (sdef->sdef_kind==CONSTRUCTOR){ + if (sdef->sdef_type->type_nr_of_constructors==1){ + branch=0; + } else { + LabDef symbol_label; + + if (sdef->sdef_strict_constructor){ + ConvertSymbolToKLabel (&symbol_label,sdef); + GenEqDesc (&symbol_label,0,0); + } else { + ConvertSymbolToConstructorDLabel (&symbol_label,sdef); + GenEqDesc (&symbol_label,node->node_arity,0); + } + } + break; + } + } + default: + error_in_function ("FillMatchNode"); + } + + if (branch){ +#if 1 + GenExitFalse (&selector_m_error_lab); +#else + LabDef local_label; + + MakeLabel (&local_label,m_symb,NewLabelNr++,no_pref); + GenJmpTrue (&local_label); + + GenJmp (&selector_m_error_lab); + + GenLabelDefinition (&local_label); +#endif + } + + if (symbol_arity_eq_one){ + demanded_state_array=&node->node_state; + demanded_state_arity=1; + } else { + demanded_state_array=node->node_state.state_tuple_arguments; + demanded_state_arity=node->node_state.state_arity; + } + + if (symbol->symb_kind==definition && symbol->symb_def->sdef_kind==CONSTRUCTOR && symbol->symb_def->sdef_strict_constructor){ + StateP constructor_args_state_p; + int a_size,b_size,arity; + + arity=symbol->symb_def->sdef_arity; + + constructor_args_state_p=symbol->symb_def->sdef_constructor->cl_state_p; + DetermineSizeOfStates (arity,constructor_args_state_p,&a_size,&b_size); + + GenReplRArgs (a_size,b_size); + *asp_p -= 1-a_size; + *bsp_p += b_size; + + AdjustTuple (a_size,b_size,asp_p,bsp_p,arity,demanded_state_array,constructor_args_state_p,a_size,b_size); + } else { + *asp_p-=1; + UnpackTuple (*asp_p,asp_p,bsp_p,True,demanded_state_arity,demanded_state_array); + } + } +} + +#ifdef REUSE_UNIQUE_NODES +# if GENERATE_CODE_AGAIN +extern int call_code_generator_again; + +static void restore_removed_arguments (ArgP *arg_h,ArgP removed_args,unsigned int argument_overwrite_bits,int node_arity) +{ + int arg_n; + ArgP not_removed_args; + + not_removed_args=*arg_h; + + for (arg_n=0; arg_n<node_arity; ++arg_n){ + if (argument_overwrite_bits & (1<<arg_n)){ + *arg_h=not_removed_args; + arg_h=¬_removed_args->arg_next; + not_removed_args=not_removed_args->arg_next; + } else { + *arg_h=removed_args; + arg_h=&removed_args->arg_next; + removed_args=removed_args->arg_next; + } + } +} +# 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, + 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; + 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; + + a_bits=0; + b_bits=0; + a_size=0; + b_size=0; + n_a_fill_bits=0; + n_b_fill_bits=0; + + for (arg_n=0; arg_n<node_arity; ++arg_n){ + ArgP arg_p; + int arg_a_size,arg_b_size; + + arg_p=*arg_l; + + DetermineSizeOfState (arg_p->arg_state,&arg_a_size,&arg_b_size); + + if (argument_overwrite_bits & (1<<arg_n)){ + a_bits |= (~((~0)<<arg_a_size))<<a_size; + b_bits |= (~((~0)<<arg_b_size))<<b_size; + + n_a_fill_bits+=arg_a_size; + n_b_fill_bits+=arg_b_size; + + arg_l=&arg_p->arg_next; + } else { + *arg_l=arg_p->arg_next; +#if GENERATE_CODE_AGAIN + *removed_args_l=arg_p; + removed_args_l=&arg_p->arg_next; +#endif + } + + a_size+=arg_a_size; + b_size+=arg_b_size; + } +#if GENERATE_CODE_AGAIN + *removed_args_l=NULL; +#endif + + for (n=0; n<a_size; ++n) + bits[n+1]='0' + ((a_bits>>n) & 1); + + for (n=0; n<b_size; ++n) + bits[n+a_size+1]='0' + ((b_bits>>n) & 1); + + bits[a_size+b_size+1]='\0'; + + *a_size_p=a_size; + *b_size_p=b_size; + *n_a_fill_bits_p=n_a_fill_bits; + *n_b_fill_bits_p=n_b_fill_bits; + +#if GENERATE_CODE_AGAIN + return removed_args; +#endif +} + +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; + 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; + free_unique_node_id=push_node->node_arguments->arg_node->node_node_id; + + symbol=node->node_symbol; + + switch (symbol->symb_kind){ + case definition: + { + SymbDef sdef; + + sdef=node->node_symbol->symb_def; + + node_arity=node->node_arity; + + switch (sdef->sdef_kind){ + case CONSTRUCTOR: + if (push_node->node_record_symbol==node->node_symbol && push_node->node_arity==node_arity) + bits[0]='0'; + else + 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); + + return; + } else { + ConvertSymbolToConstructorDLabel (&name,sdef); + label_p=&name; + } + 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); + + return; + } + case IMPRULE: + case DEFRULE: + case SYSRULE: + if (IsLazyState (node->node_state)){ + LabDef codelab; + + ConvertSymbolToDandNLabel (&name,&codelab,sdef); + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + if (sdef->sdef_kind==IMPRULE && (sdef->sdef_rule->rule_mark & RULE_UNBOXED_LAZY_CALL)){ + int a_size,b_size; + + DetermineSizeOfArguments (node->node_arguments,&a_size,&b_size); + + if (a_size+b_size>node->node_arity){ + *asp_p += 1-a_size; + *bsp_p -= b_size; + if (b_size!=0) + GenBuildU (&name,a_size,b_size,&codelab); + else + GenBuild (&name,a_size,&codelab); + } else { + if (b_size!=0){ + GenFillU (&name,a_size,b_size,&codelab,*asp_p-free_unique_node_id->nid_a_index); + *bsp_p -= b_size; + } else + GenFill (&name,a_size,&codelab,*asp_p-free_unique_node_id->nid_a_index,NormalFill); + *asp_p-=a_size; + + GenPushA (*asp_p-free_unique_node_id->nid_a_index); + *asp_p+=1; + } + } else { + GenFill (&name,node->node_arity,&codelab,*asp_p-free_unique_node_id->nid_a_index,NormalFill); + *asp_p-=node->node_arity; + + 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; + } else { + int a_size,b_size; + + ConvertSymbolToLabel (&name,sdef); + + BuildArgsWithResultNodeOnStack (node->node_arguments,free_unique_node_id,asp_p,bsp_p,code_gen_node_ids_p,&a_size,&b_size); + + *asp_p-=a_size; + *bsp_p-=b_size; + + if (! (sdef->sdef_kind==SYSRULE + && sdef->sdef_ident->ident_instructions!=NULL + && *sdef->sdef_ident->ident_instructions!='\0' + && *sdef->sdef_ident->ident_instructions!='.')) + { + cleanup_stack (asp_p,bsp_p,a_size,b_size,&code_gen_node_ids_p->a_node_ids,&code_gen_node_ids_p->b_node_ids, + &code_gen_node_ids_p->free_node_ids,code_gen_node_ids_p->moved_node_ids_l, + code_gen_node_ids_p->doesnt_fail); + } + + CallFunction (&name,sdef,True,node); + + AddSizeOfState (node->node_state,asp_p,bsp_p); + + return; + } + default: + error_in_function ("FillUniqueNodeWithNode"); + return; + } + break; + } + case cons_symb: + node_arity=2; + + if (push_node->node_record_symbol->symb_kind==cons_symb && push_node->node_arity==node_arity) + bits[0]='0'; + else + bits[0]='1'; + + label_p=&cons_lab; + break; + case tuple_symb: + node_arity=node->node_arity; + + if (push_node->node_record_symbol->symb_kind==tuple_symb && push_node->node_arity==node_arity) + bits[0]='0'; + else + bits[0]='1'; + + label_p=&tuple_lab; + break; + default: + error_in_function ("FillUniqueNodeWithNode"); + 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; +#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'; + + BuildLazyArgs (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 + + if (node_arity<=2) + GenFill1 (label_p,node_arity,*asp_p-free_unique_node_id->nid_a_index,bits); + else + GenFill2 (label_p,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); +} +#endif + +#if ! OPTIMIZE_LAZY_TUPLE_RECURSION +static +#endif +void FillNodeOnACycle (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p) +{ + switch (node->node_kind){ + case NormalNode: + FillNormalNode (node,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + break; + case SelectorNode: + FillOrReduceFieldSelection (node,node->node_symbol->symb_def,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + break; + case UpdateNode: + FillUpdateNode (node,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + break; + case MatchNode: + FillMatchNode (node,asp_p,bsp_p,update_node_id,code_gen_node_ids_p); + break; + default: + error_in_function ("FillNodeOnACycle"); + } +} + +void Build (Node node,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + switch (node->node_kind){ + case NormalNode: + FillNormalNode (node,asp_p,bsp_p,NULL,code_gen_node_ids_p); + break; + case SelectorNode: + FillOrReduceFieldSelection (node,node->node_symbol->symb_def,asp_p,bsp_p,NULL,code_gen_node_ids_p); + break; + case UpdateNode: + FillUpdateNode (node,asp_p,bsp_p,NULL,code_gen_node_ids_p); + break; + case MatchNode: + FillMatchNode (node,asp_p,bsp_p,NULL,code_gen_node_ids_p); + break; +#ifdef REUSE_UNIQUE_NODES + case FillUniqueNode: + FillUniqueNodeWithNode (node,asp_p,bsp_p,code_gen_node_ids_p); + break; +#endif + default: + error_in_function ("Build"); + } +} + +void build_and_cleanup (Node node,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + SymbDef sdef; + + sdef=NULL; + + if (node->node_kind==NormalNode){ + switch (node->node_symbol->symb_kind){ + case definition: + sdef=node->node_symbol->symb_def; + break; + case apply_symb: + sdef=ApplyDef; + break; +#ifndef FASTER_STRICT_IF + case if_symb: + sdef=IfDef; + break; +#endif + } + } + + if (sdef!=NULL){ + int sdef_kind; + + sdef_kind=sdef->sdef_kind; + + if ((sdef_kind==IMPRULE || sdef_kind==DEFRULE || sdef_kind==SYSRULE) && + sdef->sdef_arity==node->node_arity && !IsLazyState (node->node_state)) + { + LabDef name; + int a_size,b_size; + ArgP node_args; + + ConvertSymbolToLabel (&name,sdef); + + node_args=node->node_arguments; + DetermineSizeOfArguments (node_args,&a_size,&b_size); +#if 1 + if (ExpectsResultNode (node->node_state)) + BuildArgsWithNewResultNode (node_args,asp_p,bsp_p,code_gen_node_ids_p,&a_size,&b_size); + else +#else + if (ExpectsResultNode (node->node_state)){ + NewEmptyNode (asp_p,-1); + ++a_size; + } +#endif + BuildArgs (node_args,asp_p,bsp_p,code_gen_node_ids_p); + + *asp_p-=a_size; + *bsp_p-=b_size; + + cleanup_stack (asp_p,bsp_p,a_size,b_size,&code_gen_node_ids_p->a_node_ids,&code_gen_node_ids_p->b_node_ids, + &code_gen_node_ids_p->free_node_ids,code_gen_node_ids_p->moved_node_ids_l, + code_gen_node_ids_p->doesnt_fail); + + CallFunction (&name,sdef,True,node); + + AddSizeOfState (node->node_state,asp_p,bsp_p); + + return; + } + } + + Build (node,asp_p,bsp_p,code_gen_node_ids_p); +} + +void BuildArg (Args arg,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + NodeP node; + int asize,bsize; + + ArgComment (arg); + + node=arg->arg_node; + + if (node->node_kind!=NodeIdNode){ + Build (node,asp_p,bsp_p,code_gen_node_ids_p); + DetermineSizeOfState (node->node_state, &asize, &bsize); + CoerceArgumentOnTopOfStack (asp_p,bsp_p,arg->arg_state,node->node_state,asize,bsize); + } else { + NodeId arg_node_id; + + arg_node_id=node->node_node_id; + + if (CopyNodeIdArgument (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); + } +} + +static Bool LazyStates (StateS states[],int n_states) +{ + int n; + + for (n=0; n<n_states; ++n) + if (!IsLazyState (states[n])) + return False; + + return True; +} + +static Bool PushArgumentLater (StateS demstate,StateS offstate) +{ + if (demstate.state_type==SimpleState && demstate.state_kind==Undefined) + return False; + + if (offstate.state_type==SimpleState){ + Coercions c; + StateKind offkind; + + offkind = offstate.state_kind; + + if (demstate.state_type==SimpleState){ + c = CoerceStateKind (demstate.state_kind, offkind); + + if (c==Reduce || c==MayBecomeCyclicSpine || c==CyclicSpine) + return False; + else + return True; + } else { + c = CoerceStateKind (StrictOnA, offkind); + + if (c==Reduce || c==MayBecomeCyclicSpine || c==CyclicSpine) + return False; + + switch (demstate.state_type){ + case TupleState: + return LazyStates (demstate.state_tuple_arguments,demstate.state_arity); + case RecordState: + return LazyStates (demstate.state_record_arguments,demstate.state_arity); + case ArrayState: + return True; + } + } + } else if (demstate.state_type==SimpleState){ + switch (offstate.state_type){ + case TupleState: + /* + BuildTuple (aindex,bindex,*asp_p,*bsp_p,offstate.state_arity,offstate.state_tuple_arguments, + offasize,offbsize,*asp_p,NormalFill,newnode); + */ + return False; + case RecordState: + /* + BuildRecord (offstate.state_record_symbol,aindex,bindex,*asp_p,*bsp_p,offasize,offbsize,*asp_p,NormalFill,newnode); + */ + return False; + case ArrayState: + return True; + } + } else { + if (offstate.state_type!=demstate.state_type) + return False; + + switch (offstate.state_type){ + case TupleState: + { + int n,n_states; + + n_states=demstate.state_arity; + + for (n=0; n<n_states; ++n) + if (!PushArgumentLater (demstate.state_tuple_arguments[n],offstate.state_tuple_arguments[n])) + return False; + } + return True; + case RecordState: + { + int n,n_states; + + n_states=demstate.state_arity; + + for (n=0; n<n_states; ++n) + if (!PushArgumentLater (demstate.state_record_arguments[n],offstate.state_record_arguments[n])) + return False; + } + return True; + case ArrayState: + return True; + } + } + return False; +} + +static Bool BuildNonParArgs (Args args,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + Bool parallel; + + if (args==NULL) + return False; + + parallel = BuildNonParArgs (args->arg_next,asp_p,bsp_p,code_gen_node_ids_p); + + if (args->arg_state.state_mark & STATE_PARALLEL_MASK) + return True; + + { + Node node; + int asize,bsize; + + node=args->arg_node; + + if (node->node_kind!=NodeIdNode){ + if (node->node_kind==NormalNode){ + switch (node->node_symbol->symb_kind){ + case int_denot: + case bool_denot: + case char_denot: + case real_denot: + case string_denot: + args->arg_state.state_mark |= STATE_PARALLEL_MASK; + return True; + } + } + + ArgComment (args); + + Build (node,asp_p,bsp_p,code_gen_node_ids_p); + DetermineSizeOfState (node->node_state, &asize, &bsize); + CoerceArgumentOnTopOfStack (asp_p,bsp_p,args->arg_state, node->node_state, asize, bsize); + } else { + NodeId arg_node_id; + + arg_node_id=node->node_node_id; + + if (PushArgumentLater (args->arg_state,arg_node_id->nid_state)){ + args->arg_state.state_mark |= STATE_PARALLEL_MASK; + return True; + } else { + ArgComment (args); + + if (CopyNodeIdArgument (args->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); + } + } + } + + return parallel; +} + +#if 0 + static void PutArgInFrames (int *anext,int *bnext,int asp,int bsp,StateS state,int asize,int bsize) + { + if (IsSimpleState (state)){ + if (state.state_kind == OnB) + PutInBFrames (bsp, bnext, bsize); + else if (state.state_kind != Undefined) + PutInAFrames (asp, anext); + } else { + int i, arity; + + arity = state.state_arity; + + switch (state.state_type){ + case TupleState: + { States argstates = state.state_tuple_arguments; + asp -= asize; + bsp -= bsize; + for (i=arity-1; i>=0; i--){ + DetermineSizeOfState (argstates [i],&asize, &bsize); + asp += asize; + bsp += bsize; + PutArgInFrames (anext, bnext, asp, bsp, argstates [i], asize, bsize); + } + break; + } + case RecordState: + { States argstates = state.state_record_arguments; + asp -= asize; + bsp -= bsize; + for (i=arity-1; i>=0; i--){ + DetermineSizeOfState (argstates [i],&asize, &bsize); + asp += asize; + bsp += bsize; + PutArgInFrames (anext, bnext, asp, bsp, argstates [i], asize, bsize); + } + break; + } + case ArrayState: + PutInAFrames (asp, anext); + break; + } + } + } +#endif + +static void PutParAndNormalArgsInFrames (Args args,int *npar_a_offset_p,int *npar_b_offset_p,int *par_a_offset_p,int *par_b_offset_p,int *aind_p,int *bind_p) +{ + if (args!=NULL){ + int asize,bsize; + + PutParAndNormalArgsInFrames (args->arg_next,npar_a_offset_p,npar_b_offset_p,par_a_offset_p,par_b_offset_p,aind_p,bind_p); + + DetermineSizeOfState (args->arg_state,&asize,&bsize); + + if (args->arg_state.state_mark & STATE_PARALLEL_MASK){ + if (bsize!=0){ + *par_b_offset_p+=bsize; + PutInBFrames (*par_b_offset_p,bind_p,bsize); + } + while (asize!=0){ + ++*par_a_offset_p; + PutInAFrames (*par_a_offset_p,aind_p); + --asize; + } + } else { + if (bsize!=0){ + *npar_b_offset_p+=bsize; + PutInBFrames (*npar_b_offset_p,bind_p,bsize); + } + while (asize!=0){ + ++*npar_a_offset_p; + PutInAFrames (*npar_a_offset_p,aind_p); + --asize; + } + } + } +} + +static void ReorderParallelAndNonParallelArgsWithResultNode (Args args,int *asize_p,int *bsize_p) +{ + int par_a_size,par_b_size; + int npar_a_size,npar_b_size; + int asize,bsize; + int oldamax,oldbmax; + int aind,bind; + ArgS *arg; + + par_a_size=1; + par_b_size=0; + npar_a_size=0; + npar_b_size=0; + + for_l (arg,args,arg_next) + if (arg->arg_state.state_mark & STATE_PARALLEL_MASK) + AddSizeOfState (arg->arg_state,&par_a_size,&par_b_size); + else + AddSizeOfState (arg->arg_state,&npar_a_size,&npar_b_size); + + asize = par_a_size+npar_a_size; + bsize = par_b_size+npar_b_size; + + *asize_p=asize; + *bsize_p=bsize; + + if ((par_a_size==0 || npar_a_size==0) && (par_b_size==0 || npar_b_size==0)) + return; + + InitStackConversions (asize+2,bsize+2,&oldamax,&oldbmax); + + aind = 0; + bind = 0; + { + int npar_a_offset,npar_b_offset,par_a_offset,par_b_offset; + + npar_a_offset=0; + npar_b_offset=0; + par_a_offset=npar_a_size; + par_b_offset=npar_b_size; + + par_a_offset+=1; + PutInAFrames (par_a_offset,&aind); + + PutParAndNormalArgsInFrames (args,&npar_a_offset,&npar_b_offset,&par_a_offset,&par_b_offset,&aind,&bind); + } + + GenAStackConversions (asize,aind); + GenBStackConversions (bsize,bind); + + ExitStackConversions (oldamax,oldbmax); +} + +static void ReorderParallelAndNonParallelArgs (Args args) +{ + int par_a_size,par_b_size; + int npar_a_size,npar_b_size; + int asize,bsize; + int oldamax,oldbmax; + int aind,bind; + ArgS *arg; + + par_a_size=0; + par_b_size=0; + npar_a_size=0; + npar_b_size=0; + + for_l (arg,args,arg_next) + if (arg->arg_state.state_mark & STATE_PARALLEL_MASK) + AddSizeOfState (arg->arg_state,&par_a_size,&par_b_size); + else + AddSizeOfState (arg->arg_state,&npar_a_size,&npar_b_size); + + if ((par_a_size==0 || npar_a_size==0) && (par_b_size==0 || npar_b_size==0)) + return; + + asize = par_a_size+npar_a_size; + bsize = par_b_size+npar_b_size; + + InitStackConversions (asize+2,bsize+2,&oldamax,&oldbmax); + + aind = 0; + bind = 0; + { + int npar_a_offset,npar_b_offset,par_a_offset,par_b_offset; + + npar_a_offset=0; + npar_b_offset=0; + par_a_offset=npar_a_size; + par_b_offset=npar_b_size; + PutParAndNormalArgsInFrames (args,&npar_a_offset,&npar_b_offset,&par_a_offset,&par_b_offset,&aind,&bind); + } + + GenAStackConversions (asize,aind); + GenBStackConversions (bsize,bind); + + ExitStackConversions (oldamax,oldbmax); +} + +static void BuildParArgs (ArgS* args,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + if (args==NULL) + return; + + BuildParArgs (args->arg_next,asp_p,bsp_p,code_gen_node_ids_p); + + if (args->arg_state.state_mark & STATE_PARALLEL_MASK){ +/* ParComment (args); */ + BuildArg (args,asp_p,bsp_p,code_gen_node_ids_p); + } +} + +void BuildArgs (Args args,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + if (BuildNonParArgs (args,asp_p,bsp_p,code_gen_node_ids_p)){ + BuildParArgs (args,asp_p,bsp_p,code_gen_node_ids_p); + ReorderParallelAndNonParallelArgs (args); + } +} + +static void BuildLazyArgs (Args args,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + if (args==NULL) + return; + + BuildLazyArgs (args->arg_next,asp_p,bsp_p,code_gen_node_ids_p); + + BuildArg (args,asp_p,bsp_p,code_gen_node_ids_p); +} + +static void CreateCyclicExternalReducers (NodeDefs nds,int node_id_number,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + for (; nds && nds->def_id->nid_number==node_id_number; nds=nds->def_next){ + if (nds->def_node && (nds->def_id->nid_mark & ON_A_CYCLE_MASK) && HasExternalAnnot (nds->def_node)){ + NewEmptyNode (asp_p,-1); + + /* fill cycle and start reducer */ + + FillNodeOnACycle (nds->def_node,asp_p,bsp_p,nds->def_id,code_gen_node_ids_p); + + CreateParallelCode (nds,asp_p,bsp_p,code_gen_node_ids_p); + + ChangeEvalStatusKind (nds->def_id,OnA); + } + } +} + +#if OPTIMIZE_LAZY_TUPLE_RECURSION +extern NodeP tuple_result_p; + +static void generate_code_for_lazy_tuple_recursive_call (NodeP node,NodeIdP node_id_p,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + unsigned long result_and_call_same_select_vector; + NodeIdP first_tuple_call_node_id_p; + int n,arity,tuple_arity; + LabDef name,codelab; + NodeP fill_nodes; + SymbDef sdef; + + fill_nodes=node; + while (node->node_kind==FillUniqueNode) + node=node->node_arguments->arg_node; + + result_and_call_same_select_vector=0; + first_tuple_call_node_id_p=NULL; + + if (lazy_tuple_recursion){ + ArgP tuple_element_p; + + for_li (tuple_element_p,n,tuple_result_p->node_arguments,arg_next){ + NodeP node_p; + + node_p=tuple_element_p->arg_node; + + if (node_p->node_symbol->symb_kind==select_symb + && node_p->node_arguments->arg_node->node_kind==NodeIdNode + && n+1==node_p->node_arity + && (node_p->node_arguments->arg_node->node_node_id->nid_mark2 & NID_CALL_VIA_LAZY_SELECTIONS_ONLY) + ){ + NodeIdP tuple_call_node_id_p; + + tuple_call_node_id_p=node_p->node_arguments->arg_node->node_node_id; + if (first_tuple_call_node_id_p==NULL) + first_tuple_call_node_id_p=tuple_call_node_id_p; + + if (tuple_call_node_id_p==node_id_p) + result_and_call_same_select_vector |= (1<<n); + } + } + } + + tuple_arity=node->node_symbol->symb_def->sdef_rule->rule_type->type_alt_rhs->type_node_arity; + if (lazy_tuple_recursion){ + for (n=tuple_arity-1; n>=0; --n){ + if (result_and_call_same_select_vector & (1<<n)) + GenPushA (*asp_p - (tuple_arity-n)); + else { + if (fill_nodes!=node){ + NodeIdP free_unique_node_id; + + free_unique_node_id=fill_nodes->node_node->node_arguments->arg_node->node_node_id; + GenPushA (*asp_p-free_unique_node_id->nid_a_index); + + decrement_reference_count_of_node_id (free_unique_node_id,&code_gen_node_ids_p->free_node_ids); + + fill_nodes=fill_nodes->node_arguments->arg_node; + } else + GenCreate (-1); + } + ++*asp_p; + } +#if ! SELECTORS_FIRST + { + int offset; + + offset=tuple_arity-1; + for (n=tuple_arity-1; n>=0; --n){ + if (result_and_call_same_select_vector & (1<<n)){ + --offset; + } else { + GenPushA (offset); + ++*asp_p; + } + } + } +#endif + } else { + for (n=tuple_arity-1; n>=0; --n){ + GenCreate (-1); + ++*asp_p; + } +#if ! SELECTORS_FIRST + for (n=tuple_arity-1; n>=0; --n){ + GenPushA (tuple_arity-1); + ++*asp_p; + } +#endif + } + + + arity=node->node_arity; + + if (node->node_kind!=NormalNode || node->node_symbol->symb_kind!=definition || node->node_symbol->symb_def->sdef_kind!=IMPRULE + || arity!=node->node_symbol->symb_def->sdef_arity || !IsLazyState (node->node_state)) + error_in_function ("generate_code_for_lazy_tuple_recursive_call"); + + sdef=node->node_symbol->symb_def; + + ConvertSymbolToDandNLabel (&name,&codelab,sdef); + + codelab.lab_post=2; + name.lab_post=2; + + BuildArgs (node->node_arguments,asp_p,bsp_p,code_gen_node_ids_p); + + if (!lazy_tuple_recursion || first_tuple_call_node_id_p!=node_id_p){ + if (node->node_symbol->symb_def->sdef_rule->rule_mark & RULE_UNBOXED_LAZY_CALL){ + int a_size,b_size; + + DetermineSizeOfArguments (node->node_arguments,&a_size,&b_size); + +# if SELECTORS_FIRST + for (n=tuple_arity-1; n>=0; --n){ + GenPushA (a_size+tuple_arity-1); + ++*asp_p; + } +# endif + + if (b_size!=0) + GenBuildU (&name,a_size+tuple_arity,b_size,&codelab); + else + GenBuild (&name,arity+tuple_arity,&codelab); + + *bsp_p -= b_size; + *asp_p += 1-(a_size+tuple_arity); + } else { +# if SELECTORS_FIRST + for (n=tuple_arity-1; n>=0; --n){ + GenPushA (arity+tuple_arity-1); + ++*asp_p; + } +# endif + GenBuild (&name,arity+tuple_arity,&codelab); + *asp_p += 1-(arity+tuple_arity); + } + } else { + char bits[MaxNodeArity+2],*bits_p; + int n,n_updated_tuple_elements; + + bits_p=bits; +# if SELECTORS_FIRST + *bits_p++='1'; +# else + *bits_p++='0'; +# endif + n_updated_tuple_elements=0; + +# if SELECTORS_FIRST + for (n=0; n<tuple_arity; ++n) + if (result_and_call_same_select_vector & (1<<n)){ + *bits_p++ = '0'; + } else { + *bits_p++ = '1'; + ++n_updated_tuple_elements; + } +# endif + + if (node->node_symbol->symb_def->sdef_rule->rule_mark & RULE_UNBOXED_LAZY_CALL){ + int a_size,b_size; + + DetermineSizeOfArguments (node->node_arguments,&a_size,&b_size); +# if SELECTORS_FIRST + { + int offset; + + offset=tuple_arity-1; + for (n=tuple_arity-1; n>=0; --n){ + if (result_and_call_same_select_vector & (1<<n)){ + --offset; + } else { + GenPushA (a_size+offset); + ++*asp_p; + } + } + } +# endif + + for (n=0; n<a_size; ++n) + *bits_p++ = '1'; + +# if !SELECTORS_FIRST + for (n=0; n<tuple_arity; ++n) + if (result_and_call_same_select_vector & (1<<n)){ + *bits_p++ = '0'; + } else { + *bits_p++ = '1'; + ++n_updated_tuple_elements; + } +# endif + + for (n=0; n<b_size; ++n) + *bits_p++ = '1'; + + *bits_p++='\0'; + + if (b_size!=0) + GenFillcpU (&name,a_size+tuple_arity,b_size,&codelab,*asp_p,bits); + else + GenFillcp (&name,a_size+tuple_arity,&codelab,*asp_p,bits); + + *asp_p -= a_size+n_updated_tuple_elements; + *bsp_p -= b_size; + } else { +# if SELECTORS_FIRST + { + int offset; + + offset=tuple_arity-1; + for (n=tuple_arity-1; n>=0; --n){ + if (result_and_call_same_select_vector & (1<<n)){ + --offset; + } else { + GenPushA (arity+offset); + ++*asp_p; + } + } + } +# endif + + for (n=0; n<arity; ++n) + *bits_p++ = '1'; + +# if !SELECTORS_FIRST + for (n=0; n<tuple_arity; ++n) + if (result_and_call_same_select_vector & (1<<n)){ + *bits_p++ = '0'; + } else { + *bits_p++ = '1'; + ++n_updated_tuple_elements; + } +# endif + *bits_p++='\0'; + + GenFillcp (&name,arity+tuple_arity,&codelab,*asp_p,bits); + *asp_p -= arity+n_updated_tuple_elements; + } + + GenPushA (*asp_p); + ++*asp_p; + } + + { + int offset; + + offset=1; + for (n=0; n<tuple_arity; ++n){ + if (!lazy_tuple_recursion || !(result_and_call_same_select_vector & (1<<n))){ + LabDef sellab,nsellab; + + MakeLabel (&nsellab,"_Sel",0,n_pref); + + sellab = nsellab; + sellab.lab_pref = d_pref; + + GenPushA (0); + GenFill (&sellab,1,&nsellab,offset+1,NormalFill); + } + ++offset; + } + } +} +#endif + +static int FillNodeDefs (NodeDefs nds,int node_id_number,int *asp_p,int *bsp_p,NodeDefs *rest,CodeGenNodeIdsP code_gen_node_ids_p) +{ + int hasCyclicExternalReducer; + + hasCyclicExternalReducer=0; + + for (; nds!=NULL && nds->def_id->nid_number==node_id_number; nds=nds->def_next){ + Node node; + + node=nds->def_node; + + if (node==NULL){ + NodeId node_id; + + node_id=nds->def_id; + + /* we have a strict annotated left hand side nodeid */ + StrictIdComment (node_id); + + /* evaluate strict arg */ + if (node_id->nid_state.state_type==SimpleState) + ReduceArgumentToHnf (node_id,node_id->nid_state,*asp_p-node_id->nid_a_index,code_gen_node_ids_p->saved_nid_state_l); + } else { + struct state *result_state_p; + + result_state_p=&node->node_state; + + if (nds->def_id->nid_mark & ON_A_CYCLE_MASK){ + if (HasExternalAnnot (node)){ + hasCyclicExternalReducer=1; + continue; + } + + /* fill cycle */ + + FillNodeOnACycle (node,asp_p,bsp_p,nds->def_id,code_gen_node_ids_p); + } else { + int a_size,b_size; + + NodeDefComment (nds, "shared or annotated"); + +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if (nds->def_id->nid_mark2 & NID_CALL_VIA_LAZY_SELECTIONS_ONLY) + generate_code_for_lazy_tuple_recursive_call (node,nds->def_id,asp_p,bsp_p,code_gen_node_ids_p); + else +#endif + if (node->node_kind==TupleSelectorsNode){ + struct arg *arg; + struct node *tuple_node; + struct state *tuple_state_p; + + tuple_node=node->node_node; + + if (tuple_node->node_kind!=NodeIdNode){ + build_and_cleanup (tuple_node,asp_p,bsp_p,code_gen_node_ids_p); + tuple_state_p=&tuple_node->node_state; + } else { + NodeId node_id; + + node_id=tuple_node->node_node_id; + if (CopyNodeIdArgument (tuple_node->node_arguments->arg_state,node_id,asp_p,bsp_p)) + ChangeEvalStatusKindToStrictOnA (node_id,code_gen_node_ids_p->saved_nid_state_l); + + tuple_state_p=&tuple_node->node_arguments->arg_state; + + decrement_reference_count_of_node_id (node_id,&code_gen_node_ids_p->free_node_ids); + } + + arg=node->node_arguments; + if (arg->arg_node->node_kind==NodeIdNode){ + int a_offset,b_offset,i; + + DetermineSizeOfState (*tuple_state_p,&a_offset,&b_offset); + + if (tuple_state_p->state_type!=TupleState) + error_in_function ("FillNodeDefs"); + + for (i=tuple_state_p->state_arity-1; i>=0; --i){ + int a_size,b_size; + NodeId node_id; + + DetermineSizeOfState (tuple_state_p->state_tuple_arguments[i],&a_size,&b_size); + + a_offset-=a_size; + b_offset-=b_size; + + if (arg!=NULL && arg->arg_node->node_node_id->nid_number==i){ + node_id=arg->arg_node->node_node_id; + arg=arg->arg_next; + } else { + if (a_size==0 && b_size==0) + continue; + + node_id=NewNodeId (NULL); + add_node_id_to_list (node_id,&code_gen_node_ids_p->free_node_ids); + } + + node_id->nid_a_index_=*asp_p - a_offset; + node_id->nid_b_index_=*bsp_p - b_offset; + node_id->nid_state_ = tuple_state_p->state_tuple_arguments[i]; + + if (a_size!=0) + add_node_id_to_list (node_id,&code_gen_node_ids_p->a_node_ids); + if (b_size!=0) + add_node_id_to_list (node_id,&code_gen_node_ids_p->b_node_ids); + } + + if (arg!=NULL) + error_in_function ("FillNodeDefs"); + + continue; + } + } else if (node->node_kind==NodeIdNode){ + NodeId node_id; + + node_id=node->node_node_id; + + if ((node_id->nid_mark & NID_SHARED_SELECTION_NODE_ID)==0 && EqualState (node->node_arguments->arg_state,node->node_state)){ + int a_size,b_size; + + nds->def_id->nid_a_index_=node_id->nid_a_index; + nds->def_id->nid_b_index_=node_id->nid_b_index; + nds->def_id->nid_state_=node_id->nid_state; + + DetermineSizeOfState (node_id->nid_state,&a_size,&b_size); + + if (a_size!=0){ + NodeIdListElementP p_node_id; + + for_l (p_node_id,code_gen_node_ids_p->a_node_ids,nidl_next) + if (p_node_id->nidl_node_id==node_id){ + p_node_id->nidl_node_id=nds->def_id; + break; + } + } + + if (b_size!=0){ + NodeIdListElementP p_node_id; + + for_l (p_node_id,code_gen_node_ids_p->a_node_ids,nidl_next) + if (p_node_id->nidl_node_id==node_id){ + p_node_id->nidl_node_id=nds->def_id; + break; + } + } + + continue; + } else { + result_state_p=&node->node_arguments->arg_state; + +#ifdef DO_LAZY_SELECTORS_FROM_BOXED_STRICT_RECORDS + if (result_state_p->state_type==SimpleState && result_state_p->state_kind==OnA && !ResultIsNotInRootNormalForm (node_id->nid_state)) + result_state_p->state_kind=StrictOnA; +#endif + if (CopyNodeIdArgument (*result_state_p,node_id,asp_p,bsp_p)) + ChangeEvalStatusKindToStrictOnA (node_id,code_gen_node_ids_p->saved_nid_state_l); + + decrement_reference_count_of_node_id (node_id,&code_gen_node_ids_p->free_node_ids); + } + } else + build_and_cleanup (node,asp_p,bsp_p,code_gen_node_ids_p); + + /* IsLazyState (nds->def_node->node_state) ? build shared or annotated : build and reduce */ + + DetermineSizeOfState (*result_state_p,&a_size,&b_size); + + if (a_size!=0) + add_node_id_to_list (nds->def_id,&code_gen_node_ids_p->a_node_ids); + + if (b_size!=0) + add_node_id_to_list (nds->def_id,&code_gen_node_ids_p->b_node_ids); + + nds->def_id->nid_a_index_=*asp_p; + nds->def_id->nid_b_index_=*bsp_p; + } + + /* start reducer, and (if a node is filled) set eval status */ + if (IsSimpleState (*result_state_p) && result_state_p->state_kind==Parallel){ + if (!((nds->def_id->nid_mark & ON_A_CYCLE_MASK) && HasExternalAnnot (node))){ + CreateParallelCode (nds,asp_p,bsp_p,code_gen_node_ids_p); + /* start reducer */ + ChangeEvalStatusKind (nds->def_id, OnA); + } + } else + nds->def_id->nid_state_=*result_state_p; + } + } + + *rest = nds; + + return hasCyclicExternalReducer; +} + +Bool NodeOnACycleIsInRootNormalForm (Node node) +{ + Symbol symb; + + symb=node->node_symbol; + + switch (symb->symb_kind){ + case select_symb: + case apply_symb: + return False; + case if_symb: + return (node->node_arity!=3); + case definition: + { + SymbDef sdef; + + sdef=symb->symb_def; + + if (node->node_kind!=NormalNode) + return False; + + if (sdef->sdef_kind==RECORDTYPE) + if (!sdef->sdef_strict_constructor) + return True; + else + return False; + + if (sdef->sdef_arity==node->node_arity) + switch (sdef->sdef_kind){ + case CONSTRUCTOR: + if (sdef->sdef_strict_constructor) + return False; + case DEFRULE: + case SYSRULE: + case IMPRULE: + return False; + default: + return True; + } + + return True; + } + default: + return True; + } +} + +static void CreateCycleNodesAndChannels (NodeDefs nds,NodeDefs rootdef,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + for (; nds!=NULL; nds=nds->def_next){ + if (! nds->def_node || nds==rootdef){ + /* we have a strict annotated left hand side nodeid, or a root (with a node) */ + continue; + } else if (nds->def_id->nid_mark & ON_A_CYCLE_MASK){ + if (HasExternalAnnot (nds->def_node)){ + NodeDefComment (nds, "Cycle containing a channel"); + GenProcIdCalculation (nds->def_node,nds->def_node->node_annotation,asp_p,bsp_p,code_gen_node_ids_p); + GenCreateChannel (channel_code); + --*bsp_p; + nds->def_id->nid_state_=nds->def_node->node_state; + } else { + NodeDefComment (nds, "OnACycle"); + if (NodeOnACycleIsInRootNormalForm (nds->def_node)) + GenCreate (-1); + else + GenCreate (nds->def_node->node_arity); + nds->def_id->nid_state_=OnAState; + } + ++*asp_p; + nds->def_id->nid_a_index_=*asp_p; + } else + nds->def_id->nid_state_=UnderEvalState; + } +} + +void CodeSharedNodeDefs (NodeDefs nds, NodeDefs rootdef,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p) +{ + NodeDefs rest,new_rest; + + CreateCycleNodesAndChannels (nds, rootdef,asp_p,bsp_p,code_gen_node_ids_p); + + for (rest=nds; rest!=NULL; rest=new_rest){ + int hasCyclicExternalReducer; + + hasCyclicExternalReducer=FillNodeDefs (rest,rest->def_id->nid_number,asp_p,bsp_p,&new_rest,code_gen_node_ids_p); + + if (hasCyclicExternalReducer) + CreateCyclicExternalReducers (rest, rest->def_id->nid_number,asp_p,bsp_p,code_gen_node_ids_p); + } + + ReduceSemiStrictNodes (nds,*asp_p); +} + +#if 0 + static void BuildStackFrameEntry (Args arg,int *asp_p,int *bsp_p,int *a_ind,int *b_ind,CodeGenNodeIdsP code_gen_node_ids_p) + { + int asize, bsize; + Node pattern; + + pattern=arg->arg_node; + + if (pattern->node_kind!=NodeIdNode){ + Build (pattern,asp_p,bsp_p,code_gen_node_ids_p); + + DetermineSizeOfState (pattern->node_state, &asize, &bsize); + CoerceArgumentOnTopOfStack (asp_p,bsp_p,arg->arg_state,pattern->node_state,asize,bsize); + + DetermineSizeOfState (arg->arg_state,&asize,&bsize); + PutArgInFrames (a_ind,b_ind,*asp_p,*bsp_p,arg->arg_state,asize,bsize); + } else { + StateS offstate; + int aindex; + NodeId arg_node_id; + + arg_node_id=pattern->node_node_id; + offstate = arg_node_id->nid_state; + aindex = arg_node_id->nid_a_index; + + if (IsSimpleState (offstate)){ + Bool leftontop; + Coercions c; + + c = CoerceSimpleStateArgument (arg->arg_state,offstate.state_kind,aindex,asp_p,False, &leftontop); + offstate.state_kind = AdjustStateKind (offstate.state_kind, c); + + if (HasBeenReduced (c)) + ChangeEvalStatusKindToStrictOnA (arg_node_id,code_gen_node_ids_p->saved_nid_state_l); + + if (leftontop) + aindex = *asp_p; + } + + DetermineSizeOfState (offstate, &asize, &bsize); + + CoerceArgumentUsingStackFrames (arg->arg_state,offstate,aindex,arg_node_id->nid_b_index,asp_p,bsp_p,a_ind, b_ind, asize, bsize); + } + } + + static Bool BuildStackFrameEntries (Args args,int *asp_p,int *bsp_p,int *a_ind,int *b_ind,CodeGenNodeIdsP code_gen_node_ids_p) + { + int parallel; + + parallel = False; + + if (args){ + if (BuildStackFrameEntries (args->arg_next,asp_p,bsp_p, a_ind, b_ind,code_gen_node_ids_p)) + parallel = True; + if (args->arg_state.state_parallel) + parallel = True; + else + BuildStackFrameEntry (args,asp_p,bsp_p, a_ind, b_ind,code_gen_node_ids_p); + } + return parallel; + } + + static void BuildParallelStackFrameEntries (Args args,int *asp_p,int *bsp_p,int *a_ind,int *b_ind,CodeGenNodeIdsP code_gen_node_ids_p) + { + if (args){ + BuildParallelStackFrameEntries (args->arg_next,asp_p,bsp_p, a_ind, b_ind,code_gen_node_ids_p); + + if (args->arg_state.state_parallel){ + ParComment (args); + BuildStackFrameEntry (args, asp_p,bsp_p, a_ind, b_ind,code_gen_node_ids_p); + } + } + } + + static void CopyToNewFrame (int *demframe, int *newdemframe, int size, int *sp1, int *sp2) + { + int i, j, k; + + for (i = 0, j = *sp1, k = *sp2; i < size; i++, j--, k--) + newdemframe[k] = demframe[j]; + + *sp1 -= size; + *sp2 -= size; + } + + static void AdjustDemandedFrames (Args args) + { + int *newdemaframe, *newdembframe; + int asp, parasp, newasp, bsp, parbsp, newbsp, asize, bsize, parasize, parbsize; + Args arg; + + /* determine sizes of (non) parallel part */ + asize = bsize = parasize = parbsize = 0; + + for (arg = args; arg; arg = arg->arg_next){ + if (arg->arg_state.state_parallel) + AddSizeOfState (arg->arg_state, ¶size, &parbsize); + else + AddSizeOfState (arg->arg_state, &asize, &bsize); + } + + if (parasize == 0 && parbsize == 0) + return; + + /* allocate space for temporary stack frames */ + newdemaframe = AllocTempDemandedAFrame (CurrentAFrameSize); + newdembframe = AllocTempDemandedBFrame (CurrentBFrameSize); + + /* copy the arguments to the temporary frames */ + parasp = newasp = asize + parasize; + parbsp = newbsp = bsize + parbsize; + asp = asize; + bsp = bsize; + + for_l (arg,args,arg_next){ + int asize,bsize; + + DetermineSizeOfState (arg->arg_state, &asize, &bsize); + + if (arg->arg_state.state_parallel){ + CopyToNewFrame (DemandedAFrame, newdemaframe, asize, ¶sp, &newasp); + CopyToNewFrame (DemandedBFrame, newdembframe, bsize, &parbsp, &newbsp); + } else { + CopyToNewFrame (DemandedAFrame, newdemaframe, asize, &asp, &newasp); + CopyToNewFrame (DemandedBFrame, newdembframe, bsize, &bsp, &newbsp); + } + } + + /* copy the new frame */ + for (asp = 1; asp <= asize + parasize; asp++) + DemandedAFrame[asp] = newdemaframe[asp]; + for (bsp = 1; bsp <= bsize + parbsize; bsp++) + DemandedBFrame[bsp] = newdembframe[bsp]; + } + + static void BuildNewStackFrame (ArgS *args,int asp,int bsp,Bool result_node_necessary,CodeGenNodeIdsP code_gen_node_ids_p) + { + int a_ind, b_ind, oldamax, oldbmax, newamax, newbmax, dummy; + Args arg; + + a_ind = 0; + b_ind = 0; + dummy=0; + + newamax = asp + 2; + newbmax = bsp + 2; + + for_l (arg,args,arg_next) + AddStateSizeAndMaxFrameSize (arg->arg_state,& newamax, & dummy, & newbmax); + + InitStackConversions (newamax, newbmax, &oldamax, &oldbmax); + + if (result_node_necessary){ + NewEmptyNode (&asp, -1); + PutInAFrames (asp, &a_ind); + } + + TypeErrorFound = False; + CycleErrorFound = False; + + if (BuildStackFrameEntries (args, &asp, &bsp,&a_ind, &b_ind,code_gen_node_ids_p)){ + BuildParallelStackFrameEntries (args, &asp, &bsp,&a_ind, &b_ind,code_gen_node_ids_p); + AdjustDemandedFrames (args); + } + + if (! (TypeErrorFound || CycleErrorFound)){ + GenAStackConversions (asp,a_ind); + GenBStackConversions (bsp,b_ind); + } + + ExitStackConversions (oldamax, oldbmax); + } +#endif + +static void move_a_stack_pointer (int old_asp,int new_asp) +{ + if (old_asp<new_asp){ + int offset; + + offset=0; + GenBuildh (&nil_lab,0); + ++old_asp; + + while (old_asp<new_asp){ + GenPushA (offset); + ++offset; + ++old_asp; + } + } else + GenPopA (old_asp-new_asp); +} + +void UpdateStackPointers (int old_asp,int old_bsp,int new_asp,int new_bsp) +{ + move_a_stack_pointer (old_asp,new_asp); + + if (old_bsp<new_bsp){ + int offset; + SymbValue sv; + + offset=0; + sv.val_int="0"; + PushBasic (IntObj,sv); + ++old_bsp; + + while (old_bsp<new_bsp){ + GenPushB (offset); + ++offset; + ++old_bsp; + } + } else + GenPopB (old_bsp-new_bsp); +} + +static void AdjustStacksAndJumpToThenOrElseLabel + (Label truelab,Label falselab,Label next_label,int asp,int bsp,int bsize,int then_asp,int then_bsp,int else_asp,int else_bsp) +{ + if (then_asp==else_asp){ + move_a_stack_pointer (asp,then_asp); + then_asp = else_asp = asp; + } + if (then_bsp==else_bsp){ + if (bsp-bsize<then_bsp){ + int offset,n; + SymbValue sv; + + offset=0; + sv.val_int="0"; + PushBasic (IntObj,sv); + ++bsp; + + while (bsp-bsize<then_bsp){ + GenPushB (offset); + ++offset; + ++bsp; + } + ++offset; + + for (n=0; n<bsize; ++n) + GenUpdateB (n+offset,n); + } else { + UpdateBasic (bsize,bsize-1,bsp-then_bsp-bsize); + GenPopB (bsp-then_bsp-bsize); + } + then_bsp = else_bsp = bsp - bsize; + } + + if (asp==else_asp && bsp - else_bsp - bsize == 0){ +#if 1 + if (falselab==next_label && asp==then_asp && bsp-bsize==then_bsp){ + GenJmpTrue (truelab); + truelab->lab_mod=NULL; + } else +#endif + { + GenJmpFalse (falselab); + falselab->lab_mod=NULL; + + UpdateStackPointers (asp, bsp-bsize, then_asp, then_bsp); +#if 1 + if (truelab!=next_label) +#endif + { + GenJmp (truelab); + truelab->lab_mod=NULL; + } + } + } else if (asp==then_asp && bsp - then_bsp - bsize == 0){ +#if 1 + if (truelab==next_label && asp==else_asp && bsp-bsize==else_bsp){ + GenJmpTrue (falselab); + falselab->lab_mod=NULL; + } else +#endif + { + GenJmpTrue (truelab); + truelab->lab_mod=NULL; + + UpdateStackPointers (asp, bsp-bsize, else_asp, else_bsp); +#if 1 + if (falselab!=next_label) +#endif + { + GenJmp (falselab); + falselab->lab_mod=NULL; + } + } + } else { + LabDef loclab; + + MakeLabel (&loclab, m_symb, NewLabelNr++, no_pref); + GenJmpFalse (&loclab); + + UpdateStackPointers (asp, bsp-bsize, then_asp, then_bsp); + GenJmp (truelab); + truelab->lab_mod=NULL; + + GenLabelDefinition (&loclab); + UpdateStackPointers (asp, bsp-bsize, else_asp, else_bsp); + +#if 1 + if (falselab!=next_label) +#endif + { + GenJmp (falselab); + falselab->lab_mod=NULL; + } + } +} + +void EvaluateCondition (Node cond_node,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p,StateS resultstate) +{ + switch (cond_node->node_kind){ + case NodeIdNode: + { + NodeId nid; + int boolean_b_size; + + nid=cond_node->node_node_id; + CopyNodeIdArgument (resultstate,nid,asp_p,bsp_p); + + decrement_reference_count_of_node_id (nid,&code_gen_node_ids_p->free_node_ids); + + boolean_b_size = ObjectSizes [resultstate.state_object]; + *bsp_p-=boolean_b_size; + break; + } + case NormalNode: + case SelectorNode: + case MatchNode: + { + int asize,bsize,boolean_b_size; + + Build (cond_node,asp_p,bsp_p,code_gen_node_ids_p); + DetermineSizeOfState (cond_node->node_state,&asize,&bsize); + CoerceArgumentOnTopOfStack (asp_p,bsp_p,resultstate,cond_node->node_state,asize,bsize); + boolean_b_size = ObjectSizes [resultstate.state_object]; + *bsp_p-=boolean_b_size; + break; + } + case IfNode: + EvaluateCondition (cond_node->node_arguments->arg_node,asp_p,bsp_p,code_gen_node_ids_p,resultstate); + break; + default: + error_in_function ("EvaluateCondition"); + } +} + +static Bool IsBooleanValue (Node node, Bool *val) +{ + if (node->node_kind==NormalNode && node->node_symbol->symb_kind==bool_denot){ + *val = node->node_symbol->symb_bool; + return True; + } else + return False; +} + +void subtract_else_ref_counts (struct node_id_ref_count_list *else_node_id_ref_counts,NodeIdListElementS **free_node_ids_l) +{ + struct node_id_ref_count_list *else_node_id_ref_count; + + for_l (else_node_id_ref_count,else_node_id_ref_counts,nrcl_next){ + struct node_id *node_id; + int ref_count; + + node_id=else_node_id_ref_count->nrcl_node_id; + + ref_count=node_id->nid_refcount; + if (ref_count>=0){ + ref_count -= else_node_id_ref_count->nrcl_ref_count; + node_id->nid_refcount=ref_count; + + if (ref_count==0) + add_node_id_to_list (node_id,free_node_ids_l); + } else { + ref_count += else_node_id_ref_count->nrcl_ref_count; + node_id->nid_refcount=ref_count; + + if (ref_count==-1){ + if (! (node_id->nid_node!=NULL && !IsSimpleState (node_id->nid_state)) && unused_node_id_(node_id)) + add_node_id_to_list (node_id,free_node_ids_l); + } + } + } +} + +void add_else_ref_counts (struct node_id_ref_count_list *else_node_id_ref_counts) +{ + struct node_id_ref_count_list *else_node_id_ref_count; + + for_l (else_node_id_ref_count,else_node_id_ref_counts,nrcl_next){ + struct node_id *node_id; + + node_id=else_node_id_ref_count->nrcl_node_id; + if (node_id->nid_refcount>=0) + node_id->nid_refcount += else_node_id_ref_count->nrcl_ref_count; + else + node_id->nid_refcount -= else_node_id_ref_count->nrcl_ref_count; + } +} + +static void EvaluateThenOrElsePartOfCondition + (NodeDefs defs,Node node,int asp,int bsp,StateS resultstate, Label truelab, Label falselab,Label next_label, + int then_asp,int then_bsp,int else_asp,int else_bsp,NodeIdListElementP a_node_ids,NodeIdListElementP b_node_ids, + struct node_id_ref_count_list *else_node_id_ref_counts,NodeIdListElementP free_node_ids); + +void BranchOnCondition (Node condnode,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p, StateS resultstate, + Label truelab,Label falselab,Label next_label,int then_asp,int then_bsp,int else_asp,int else_bsp) +{ + switch (condnode->node_kind){ + case NodeIdNode: + case NormalNode: + case SelectorNode: + case MatchNode: + { + int boolean_b_size; + boolean_b_size = ObjectSizes [resultstate.state_object]; + AdjustStacksAndJumpToThenOrElseLabel (truelab,falselab,next_label,asp,bsp+boolean_b_size,boolean_b_size,then_asp,then_bsp,else_asp,else_bsp); + break; + } + case IfNode: + { + Bool bool; + Label thenlabel,elselabel; + LabDef thenlab,elselab; + int new_then_asp,new_then_bsp,new_else_asp,new_else_bsp; + Args condpart; + + new_then_asp = asp; + new_then_bsp = bsp, + new_else_asp = asp; + new_else_bsp = bsp; + condpart = condnode->node_arguments; + + if (IsBooleanValue (condpart->arg_next->arg_node,&bool)){ + if (bool){ + thenlabel = truelab; + new_then_asp = then_asp; + new_then_bsp = then_bsp; + } else { + thenlabel = falselab; + new_then_asp = else_asp; + new_then_bsp = else_bsp; + } + } else { + thenlabel = NULL; + MakeLabel (&thenlab, then_symb, NewLabelNr++, no_pref); + thenlab.lab_mod=notused_string; + } + + if (IsBooleanValue (condpart->arg_next->arg_next->arg_node,&bool)){ + if (bool){ + elselabel = truelab; + new_else_asp = then_asp; + new_else_bsp = then_bsp; + } else { + elselabel = falselab; + new_else_asp = else_asp; + new_else_bsp = else_bsp; + } + } else { + elselabel = NULL; + MakeLabel (&elselab, else_symb, NewLabelNr++, no_pref); + elselab.lab_mod=notused_string; + } + + BranchOnCondition (condpart->arg_node,asp,bsp,code_gen_node_ids_p,resultstate, + thenlabel ? thenlabel : &thenlab, elselabel ? elselabel : &elselab, + !thenlabel ? &thenlab : !elselabel ? &elselab : next_label, + new_then_asp, new_then_bsp, new_else_asp, new_else_bsp); + + if (!thenlabel){ + if (thenlab.lab_mod==NULL) + GenLabelDefinition (&thenlab); + + EvaluateThenOrElsePartOfCondition (condnode->node_then_node_defs, + condpart->arg_next->arg_node, asp,bsp,resultstate,truelab,falselab,!elselabel ? &elselab : next_label, + then_asp,then_bsp,else_asp,else_bsp,code_gen_node_ids_p->a_node_ids,code_gen_node_ids_p->b_node_ids, + condnode->node_else_node_id_ref_counts,code_gen_node_ids_p->free_node_ids); + } + + if (!elselabel){ + if (elselab.lab_mod==NULL) + GenLabelDefinition (&elselab); + + EvaluateThenOrElsePartOfCondition (condnode->node_else_node_defs, + condpart->arg_next->arg_next->arg_node,asp,bsp,resultstate,truelab,falselab,next_label, + then_asp,then_bsp,else_asp,else_bsp,code_gen_node_ids_p->a_node_ids,code_gen_node_ids_p->b_node_ids, + NULL,code_gen_node_ids_p->free_node_ids); + } + break; + } + default: + error_in_function ("BranchOnCondition"); + } +} + +static void EvaluateThenOrElsePartOfCondition + (NodeDefs defs,Node node,int asp,int bsp,StateS resultstate, Label truelab, Label falselab,Label next_label, + int then_asp,int then_bsp,int else_asp,int else_bsp,NodeIdListElementP a_node_ids,NodeIdListElementP b_node_ids, + struct node_id_ref_count_list *else_node_id_ref_counts,NodeIdListElementP free_node_ids) +{ + SavedNidStateP saved_node_id_states; + MovedNodeIdP moved_node_ids; + struct code_gen_node_ids code_gen_node_ids; + + saved_node_id_states=NULL; + moved_node_ids=NULL; + + if (else_node_id_ref_counts!=NULL) + subtract_else_ref_counts (else_node_id_ref_counts,&free_node_ids); + + code_gen_node_ids.free_node_ids=free_node_ids; + code_gen_node_ids.saved_nid_state_l=&saved_node_id_states; + code_gen_node_ids.doesnt_fail=False; + code_gen_node_ids.moved_node_ids_l=&moved_node_ids; + code_gen_node_ids.a_node_ids=a_node_ids; + code_gen_node_ids.b_node_ids=b_node_ids; + + CodeSharedNodeDefs (defs,NULL,&asp,&bsp,&code_gen_node_ids); + + EvaluateCondition (node,&asp,&bsp,&code_gen_node_ids,resultstate); + + BranchOnCondition (node,asp,bsp,&code_gen_node_ids,resultstate,truelab,falselab,next_label,then_asp,then_bsp,else_asp,else_bsp); + + restore_saved_node_id_states (saved_node_id_states); + + if (else_node_id_ref_counts!=NULL) + add_else_ref_counts (else_node_id_ref_counts); +} + +void InitCoding (void) +{ + int i; + + NewLabelNr = 1; + SetUnaryState (& StrictOnAState, StrictOnA, UnknownObj); + SetUnaryState (& OnAState, OnA, UnknownObj); + SetUnaryState (& UnderEvalState, UnderEval, UnknownObj); + SetUnaryState (& ProcIdState, OnB, ProcIdObj); + + ApplyDef=MakeNewSymbolDefinition ("system", ApplyId, 2, DEFRULE); + ApplyDef->sdef_number=0; + + IfDef=MakeNewSymbolDefinition ("system", IfId, 3, DEFRULE); + IfDef->sdef_number=0; + + InitBasicDescriptor (UnknownObj, "_", SizeOfAStackElem); +#if ABSTRACT_OBJECT + InitBasicDescriptor (AbstractObj, "_", SizeOfAStackElem); +#endif + InitBasicDescriptor (IntObj, "INT", SizeOfInt); + InitBasicDescriptor (BoolObj, "BOOL", SizeOfBool); + InitBasicDescriptor (CharObj, "CHAR", SizeOfChar); + InitBasicDescriptor (StringObj, "STRING", SizeOfAStackElem); + InitBasicDescriptor (RealObj, "REAL", SizeOfReal); + InitBasicDescriptor (FileObj, "FILE", SizeOfFile); + InitBasicDescriptor (ArrayObj, "ARRAY", SizeOfAStackElem); + InitBasicDescriptor (UnboxedArrayObj, "ARRAY", SizeOfAStackElem); + + InitBasicDescriptor (WorldObj, "WORLD", SizeOfAStackElem); + InitBasicDescriptor (ProcIdObj, "PROCID", SizeOfProcId); + InitBasicDescriptor (RedIdObj, "REDID", SizeOfInt); + + for (i=0; i<MaxNodeArity-NrOfGlobalSelectors; i++) + LazyTupleSelectors [i] = False; + + next_update_function_n=0; + next_match_function_n=0; +} diff --git a/backendC/CleanCompilerSources/codegen2.h b/backendC/CleanCompilerSources/codegen2.h new file mode 100644 index 0000000..34bc210 --- /dev/null +++ b/backendC/CleanCompilerSources/codegen2.h @@ -0,0 +1,115 @@ + +extern void bind_arguments (ArgS *arguments,int a_offset,int b_offset,struct ab_node_ids *ab_node_ids_p); + +typedef + enum + { NormalFill, ReleaseAndFill, PartialFill + } FillKind; + +extern StateS OnAState; +extern LabDef BasicDescriptors []; +extern unsigned NewLabelNr; +extern Bool LazyTupleSelectors []; +extern int ObjectSizes []; + +#define IsOnACycle(nodenum) (nodenum < 0) +#define IsOnBStack(state) (! IsSimpleState (state) || (state).state_kind == OnB) + +extern void ScanInlineFile (char *fname); + +extern Bool EqualState (StateS st1, StateS st2); +extern void DetermineSizeOfArguments (ArgS *args,int *a_offset_p,int *b_offset_p); +extern void BuildTuple (int aindex, int bindex, int asp, int bsp, int arity, + States argstates,int asize,int bsize,int rootindex,FillKind fkind,Bool newnode); + +extern void BuildRecord (SymbDef seldef, int aindex, int bindex, int asp, int bsp, + int asize, int bsize, int rootindex,FillKind fkind, Bool popargs); +extern void CoerceArgumentUsingStackFrames (StateS demstate, StateS offstate, + int aindex,int bindex,int *asp,int *bsp,int *anext,int *bnext,int asize,int bsize); +extern void DetermineArrayElemDescr (StateS elemstate, Label lab); +extern void InitCoding (void); + +/* extern int InitAStackTop, InitBStackTop; */ +extern Bool NeedNextAlternative; +extern void PackArgument (StateS argstate,int aindex,int bindex,int asp,int bsp,int offasize,int offbsize); + +extern void save_node_id_state (NodeId node_id,struct saved_nid_state **ifrule); +extern void restore_saved_node_id_states (struct saved_nid_state *saved_node_id_states); + +typedef enum { + AToA, AToB, BToA, BToB, Reduce,AToRoot, MayBecomeCyclicSpine, CyclicSpine +} Coercions; + +STRUCT (moved_node_id,MovedNodeId){ + struct node_id * mnid_node_id; + struct moved_node_id * mnid_next; + int mnid_a_stack_offset; +}; + +STRUCT (code_gen_node_ids,CodeGenNodeIds){ + struct saved_nid_state **saved_nid_state_l; + struct node_id_list_element *free_node_ids; + struct moved_node_id **moved_node_ids_l; + struct node_id_list_element *a_node_ids; + struct node_id_list_element *b_node_ids; + int doesnt_fail; +}; + +Coercions CoerceStateKind (StateKind dem_state_kind, StateKind off_state_kind); +void GenReduceError (void); +void UnpackTuple (int aindex,int *asp_p,int *bsp_p,Bool removeroot,int arity,StateS argstates[]); +void UnpackRecord (int aindex,int *asp_p,int *bsp,Bool removeroot,int arity,States argstates); +void UnpackArray (int aindex, int *asp_p, Bool removeroot); +void NewEmptyNode (int *asp_p,int nrargs); +void AdjustTuple (int localasp,int localbsp,int *asp_p,int *bsp_p,int arity,StateS demstates[],StateS offstates[],int asize,int bsize); +int get_a_index_of_unpacked_lhs_node (ArgS *arg); +int get_b_index_of_unpacked_lhs_node (ArgS *arg); +void decrement_reference_count_of_node_id (struct node_id *node_id,NodeIdListElementS **free_node_ids_l); + +void BuildArgs (Args args,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p); +void build_and_cleanup (Node node,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p); + +#define RECORD_N_PREF c_pref +#define RECORD_D_PREF t_pref +#define CONSTRUCTOR_R_PREF k_pref + +extern char *Co_Wtype,*Co_Wspine,else_symb[],then_symb[],notused_string[]; +extern SymbDef ApplyDef,IfDef; +extern StateS StrictOnAState; + +void FillSelectSymbol (StateKind result_state_kind,int arity,int argnr,Args arg,int *asp_p,int *bsp_p, + NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p); +void Build (Node node,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p); +Coercions CoerceSimpleStateArgument (StateS demstate,StateKind offkind,int aindex,int *asp_p,Bool leaveontop, Bool *ontop); +void subtract_else_ref_counts (struct node_id_ref_count_list *else_node_id_ref_counts,NodeIdListElementS **free_node_ids_l); +void add_else_ref_counts (struct node_id_ref_count_list *else_node_id_ref_counts); +void EvaluateCondition (Node cond_node,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p,StateS resultstate); +void DetermineFieldSizeAndPositionAndRecordSize + (int fieldnr,int *asize_p,int *bsize_p,int *apos_p,int *bpos_p,int *rec_asize_p,int *rec_bsize_p,StateS *record_state_p); +void CodeSharedNodeDefs (NodeDefs nds, NodeDefs rootdef,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p); +void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p); +void BranchOnCondition (Node condnode, int asp, int bsp,CodeGenNodeIdsP code_gen_node_ids_p, StateS resultstate, + Label truelab,Label falselab,Label next_label,int then_asp, int then_bsp, int else_asp, int else_bsp); +void GenTypeError (void); +void BuildArg (Args arg,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p); +Bool NodeOnACycleIsInRootNormalForm (Node node); +void UpdateStackPointers (int old_asp,int old_bsp,int new_asp,int new_bsp); +void UpdateNodeAndAddSelectorsToUpdateNode + (ArgS *record_arg,ArgS *first_field_arg,StateS *field_states,int record_a_size,int record_b_size,int *asp_p,int *bsp_p); +void RemoveSelectorsFromUpdateNode (ArgS *previous_arg,ArgS *arg); +void BuildOrFillLazyFieldSelector (SymbDef selector_sdef,StateKind result_state_kind,int *asp_p,NodeId update_node_id); +void CoerceArgumentOnTopOfStack (int *asp_p,int *bsp_p,StateS argstate,StateS nodestate,int asize,int bsize); +void ReplaceRecordOnTopOfStackByField (int *asp_p,int *bsp_p,int apos,int bpos,int asize,int bsize,int rec_a_size,int rec_b_size) ; +Bool CopyNodeIdArgument (StateS demstate,NodeId node_id,int *asp_p,int *bsp_p); + +void add_node_id_to_list (struct node_id *node_id,NodeIdListElementS **node_ids_l); +void BuildArgsWithNewResultNode (Args args,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p,int *a_size_p,int *b_size_p); +void BuildArgsWithResultNodeOnStack (Args args,NodeIdP free_unique_node_id,int *asp_p,int *bsp_p,CodeGenNodeIdsP code_gen_node_ids_p,int *a_size_p,int *b_size_p); +void cleanup_stack + (int *asp_p,int *bsp_p,int a_size,int b_size,NodeIdListElementS **a_node_ids_l,NodeIdListElementS **b_node_ids_l, + NodeIdListElementS **free_node_ids_l,MovedNodeIdP *moved_node_ids_l,int compact_stack_ok); + +void ChangeEvalStatusKindToStrictOnA (NodeId node_id,SavedNidStateS **saved_nid_state_l); +#if OPTIMIZE_LAZY_TUPLE_RECURSION +void FillNodeOnACycle (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGenNodeIdsP code_gen_node_ids_p); +#endif
\ No newline at end of file diff --git a/backendC/CleanCompilerSources/codegen3.c b/backendC/CleanCompilerSources/codegen3.c new file mode 100644 index 0000000..b055dd7 --- /dev/null +++ b/backendC/CleanCompilerSources/codegen3.c @@ -0,0 +1,2373 @@ +/* + File: codegen3.c + Authors: Sjaak Smetsers & John van Groningen +*/ + +#define FASTER_STRICT_IF /* also in statesgen.c */ +#define DO_LAZY_SELECTORS_FROM_BOXED_STRICT_RECORDS + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) +#define for_li(v,i,l,n) for(v=(l),i=0;v!=NULL;v=v->n,++i) +#define for_ll(v1,v2,l1,l2,n1,n2) for(v1=(l1),v2=(l2);v1!=NULL;v1=v1->n1,v2=v2->n2) + +#include "system.h" +#include "syntaxtr.t" +#include "comsupport.h" + +#include "codegen_types.h" +#include "codegen.h" +#include "codegen1.h" +#include "codegen2.h" + +#if GENERATE_CODE_AGAIN +struct saved_node_id_ref_counts { + NodeIdP snir_node_id; + int snir_ref_count; + struct saved_node_id_ref_counts * snir_next; +}; + +struct saved_case_node_id_ref_counts { + NodeIdRefCountListP scnir_nrcl; + int scnir_ref_count; + struct saved_case_node_id_ref_counts * scnir_next; +}; +#endif + +#include "codegen3.h" +#include "instructions.h" +#include "sizes.h" +#include "statesgen.h" +#include "settings.h" +#if TAIL_CALL_MODULO_CONS_OPTIMIZATION +# include "buildtree.h" +#endif +#if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION +# include "tuple_tail_recursion.h" +#endif + +static void error_in_function (char *m) +{ + ErrorInCompiler ("codegen3.c",m,""); +} + +static void UpdateAAndBStack (int aindex,int bindex,int asize,int bsize,int *asp_p,int *bsp_p) +{ + int i,asp,bsp; +#if UPDATE_POP + int a_popped,b_popped; + + a_popped=0; + b_popped=0; +#endif + asp=*asp_p; + bsp=*bsp_p; + + /* copy the values in the right order ! */ + if (aindex < asize){ + for (i=0; i<asize; i++) + GenUpdateA (asp - (aindex - i), asp - (asize - i)); + } else if (aindex > asize){ + for (i=asize - 1; i >= 0; i--) +#if UPDATE_POP + if (i==0){ + GenUpdatePopA (asp - aindex, asp - asize); + a_popped=1; + } else +#endif + GenUpdateA (asp - (aindex - i), asp - (asize - i)); + } + + if (bindex < bsize){ + for (i=0; i<bsize; i++) + GenUpdateB (bsp - (bindex - i), bsp - (bsize - i)); + } else if (bindex > bsize){ + for (i=bsize - 1; i >= 0; i--) +#if UPDATE_POP + if (i==0){ + GenUpdatePopB (bsp - bindex, bsp - bsize); + b_popped=1; + } else +#endif + GenUpdateB (bsp - (bindex - i), bsp - (bsize - i)); + } + +#if UPDATE_POP + if (!a_popped) +#endif + GenPopA (asp-asize); + + *asp_p=asize; + +#if UPDATE_POP + if (!b_popped) +#endif + GenPopB (bsp-bsize); + + *bsp_p=bsize; +} + +void RedirectResultAndReturn (int asp,int bsp,int source_a_index,int source_b_index,StateS offstate,StateS demstate,int offasize,int offbsize) +{ + if (IsSimpleState (offstate)){ + if (IsSimpleState (demstate)){ + switch (CoerceStateKind (demstate.state_kind, offstate.state_kind)){ + case Reduce: + if (demstate.state_kind==StrictRedirection){ +#if UPDATE_POP + GenUpdatePopA (asp-source_a_index, asp - 1); +#else + GenUpdateA (asp-source_a_index, asp - 1); + GenPopA (asp - 1); +#endif + GenPopB (bsp); + GenJmpEval (); + + return; + } else { + Coercions c; + + c=CoerceStateKind (demstate.state_kind,StrictOnA); + + if (c==AToA || c==AToRoot){ + GenPopB (bsp); + + if (source_a_index==0){ + GenPopA (asp); + GenJmpEval (); + + return; + } else { +#if UPDATE_POP + GenUpdatePopA (asp-source_a_index, asp - 1); +#else + GenUpdateA (asp-source_a_index, asp - 1); + GenPopA (asp - 1); +#endif + +#if ABSTRACT_OBJECT + if (demstate.state_object!=AbstractObj) + GenJmpEvalUpdate(); + else { + GenJsrEval (0); + GenFillFromA (0, 1, ReleaseAndFill); + GenPopA (1); + GenRtn (1,0, OnAState); + } +#else + GenJmpEvalUpdate(); +#endif + return; + } + } else { + GenPopB (bsp); + GenPopA (asp-source_a_index); + GenJsrEval (0); + PushBasicFromAOnB (demstate.state_object, 0); + GenPopA (source_a_index); + } + } + break; + case AToB: + GenPopB (bsp); + PushBasicFromAOnB (demstate.state_object, asp-source_a_index); + GenPopA (asp); + break; + case BToA: + GenPopA (asp); +#if STORE_STRICT_CALL_NODES + if (demstate.state_kind==StrictRedirection){ + BuildBasicFromB (offstate.state_object,bsp-source_b_index); + ++asp; + } else +#endif + FillBasicFromB (offstate.state_object,bsp-source_b_index,0,ReleaseAndFill); + GenPopB (bsp); + break; + case BToB: + { + int bsize; + + bsize = ObjectSizes [demstate.state_object]; + UpdateBasic (bsize,bsp-source_b_index,bsp-bsize); + GenPopA (asp); + GenPopB (bsp-bsize); + break; + } + case AToA: + case AToRoot: + GenPopB (bsp); + if (demstate.state_kind==StrictRedirection){ +#if UPDATE_POP + GenUpdatePopA (asp-source_a_index, asp-1); +#else + GenUpdateA (asp-source_a_index, asp-1); + GenPopA (asp-1); +#endif + } else { + GenFillFromA (asp-source_a_index, asp, ReleaseAndFill); + GenPopA (asp); + } + break; + case CyclicSpine: + GenReduceError (); + StaticMessage (False,CurrentAltLabel.lab_symbol->sdef_ident->ident_name,Co_Wspine); + break; + default: + error_in_function ("RedirectResultAndReturn"); + return; + } + } else { + GenPopB (bsp); + + switch (CoerceStateKind (StrictOnA, offstate.state_kind)){ + case Reduce: + GenJsrEval (asp-source_a_index); + default: +#if UPDATE_POP + GenUpdatePopA (asp-source_a_index, asp-1); +#else + GenUpdateA (asp-source_a_index, asp-1); + GenPopA (asp-1); +#endif + asp = 1; + + switch (demstate.state_type){ + case TupleState: + UnpackTuple (0,&asp,&bsp,True,demstate.state_arity,demstate.state_tuple_arguments); + break; + case RecordState: + UnpackRecord (0,&asp,&bsp,True,demstate.state_arity, demstate.state_record_arguments); + break; + case ArrayState: + UnpackArray (0,&asp,True); + break; + } + } + } + } else if (IsSimpleState (demstate)){ +#if 1 /*JVG 29-5-2000 for Clean 2.0*/ + if (demstate.state_kind==StrictRedirection){ + switch (offstate.state_type){ + case TupleState: + BuildTuple (source_a_index,source_b_index,asp,bsp, + offstate.state_arity, offstate.state_tuple_arguments, + offasize, offbsize, 0, ReleaseAndFill,True); + break; + case RecordState: + BuildRecord (offstate.state_record_symbol,source_a_index,source_b_index, asp, bsp, + offasize, offbsize, 0, ReleaseAndFill,True); + break; + case ArrayState: + GenBuildArray (asp-source_a_index); + ++asp; + } + GenUpdatePopA (0,asp); + GenPopB (bsp); + } else { +#endif + switch (offstate.state_type){ + case TupleState: + BuildTuple (source_a_index,source_b_index,asp,bsp, + offstate.state_arity, offstate.state_tuple_arguments, + offasize, offbsize, 0, ReleaseAndFill,False); + break; + case RecordState: + BuildRecord (offstate.state_record_symbol,source_a_index,source_b_index, asp, bsp, + offasize, offbsize, 0, ReleaseAndFill,False); + break; + case ArrayState: + GenFillArray (asp-source_a_index,asp,ReleaseAndFill); + } + GenPopA (asp); + GenPopB (bsp); +#if 1 /*JVG 29-5-2000 for Clean 2.0*/ + } +#endif + } else { + switch (demstate.state_type){ + case RecordState: + { + int asize, bsize; + + DetermineSizeOfStates (demstate.state_arity, demstate.state_record_arguments,&asize, &bsize); + UpdateAAndBStack (source_a_index,source_b_index, asize, bsize,&asp,&bsp); + break; + } + case TupleState: + if (EqualState (demstate, offstate)){ + int asize, bsize; + + DetermineSizeOfStates (demstate.state_arity,demstate.state_tuple_arguments,&asize, &bsize); + UpdateAAndBStack (source_a_index,source_b_index, asize, bsize,&asp,&bsp); + } else { + GenPopA (asp-source_a_index); + GenPopB (bsp-source_b_index); + asp = source_a_index; + bsp = source_b_index; + AdjustTuple (source_a_index,source_b_index, & asp, & bsp, + demstate.state_arity, + demstate.state_tuple_arguments, + offstate.state_tuple_arguments, offasize, offbsize); + } + break; + case ArrayState: +#if UPDATE_POP + GenUpdatePopA (asp-source_a_index, asp - 1); +#else + GenUpdateA (asp-source_a_index, asp - 1); + GenPopA (asp - 1); +#endif + GenPopB (bsp); + break; + } + } + + if (!function_called_only_curried_or_lazy_with_one_return){ + int asize,bsize; + + DetermineSizeOfState (demstate,&asize,&bsize); + GenRtn (asize, bsize, demstate); + } +} + +static void CodeRedirection (NodeId node_id,int asp,int bsp,StateS demstate,NodeIdListElementS **free_node_ids_l) +{ + int asize,bsize; + int a_index,b_index; + StateS offstate; + + offstate = node_id->nid_state; + + DetermineSizeOfState (offstate,&asize,&bsize); + RedirectionComment (node_id); + + if (node_id->nid_refcount<0 && node_id->nid_state.state_type!=SimpleState && node_id->nid_node!=NULL){ + if (asize!=0) + a_index=get_a_index_of_unpacked_lhs_node (node_id->nid_node->node_arguments); + else + a_index=0; + + if (bsize!=0) + b_index=get_b_index_of_unpacked_lhs_node (node_id->nid_node->node_arguments); + else + b_index=0; + } else { + a_index=node_id->nid_a_index; + b_index=node_id->nid_b_index; + } + + RedirectResultAndReturn (asp,bsp,a_index,b_index,offstate,demstate,asize,bsize); + + decrement_reference_count_of_node_id (node_id,free_node_ids_l); +} + +static void FillRhsRoot (Label name,Node root,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p) +{ + BuildArgs (root->node_arguments,&asp,&bsp,code_gen_node_ids_p); + + GenFillh (name,root->node_arity,asp,ReleaseAndFill); + asp-=root->node_arity; + + GenPopA (asp); + GenPopB (bsp); + GenRtn (1,0,OnAState); +} + +static void CreateSemiStrictRootNode (Label name,Label code,Node root,NodeId rootid,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p,StateS demstate) +{ + BuildArgs (root->node_arguments,&asp,&bsp,code_gen_node_ids_p); + + GenFill (name,root->node_arity,code,asp-rootid->nid_a_index, NormalFill); + asp-=root->node_arity; + + RedirectResultAndReturn (asp,bsp,rootid->nid_a_index,rootid->nid_b_index,rootid->nid_state, demstate, 1, 0); +} + +#define IsSemiStrictState(state) ((state).state_type==SimpleState && (state).state_kind==SemiStrict) + +static Bool NoTupleStateAdjustment (StateS st1,StateS st2) +{ + if (IsSimpleState (st1) && IsSimpleState (st2)) + return st1.state_kind==st2.state_kind || (st1.state_kind==OnA && st2.state_kind==StrictOnA); + + switch (st1.state_type){ + case RecordState: + return st2.state_type==RecordState; + case TupleState: + if (st2.state_type==TupleState && st1.state_arity==st2.state_arity){ + int i; + + for (i=0; i<st1.state_arity; i++) + if (!NoTupleStateAdjustment (st1.state_tuple_arguments[i],st2.state_tuple_arguments[i])) + return False; + + return True; + } else + return False; + case ArrayState: + return st2.state_type==ArrayState; + default: + return False; + } +} + +static Coercions DetermineResultAdjustment (StateS demstate, StateS offstate) +{ + if (IsSimpleState (offstate)){ + if (IsSimpleState (demstate)) + return CoerceStateKind (demstate.state_kind,offstate.state_kind); + else + return AToB; + } else if (IsSimpleState (demstate) || ! NoTupleStateAdjustment (demstate, offstate)) + return BToA; + else + return BToB; +} + +static Bool ResultNodeNecessary (Coercions moveact, StateS offstate) +{ + return (moveact == AToB && ! (IsSimpleState (offstate) && + (offstate.state_kind == StrictRedirection || + offstate.state_kind == LazyRedirection))); +} + +static void CodeRootSymbolApplication (Node root,NodeId rootid,SymbDef def,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p,StateS resultstate) +{ + LabDef name; + int symbarity; + + symbarity = def->sdef_kind==RECORDTYPE ? def->sdef_cons_arity : def->sdef_arity; + + if (symbarity==root->node_arity){ + SDefKind symbkind; + + symbkind = (SDefKind)def->sdef_kind; + + switch (symbkind){ + case IMPRULE: + case DEFRULE: + case SYSRULE: + if (IsSemiStrictState (root->node_state)){ + LabDef codelab; + + ConvertSymbolToDandNLabel (&name,&codelab,def); + + CreateSemiStrictRootNode (&name,&codelab,root,rootid,asp,bsp,code_gen_node_ids_p,resultstate); + } else { + Coercions moveact; + + ConvertSymbolToLabel (&name,def); + + moveact = DetermineResultAdjustment (resultstate, root->node_state); + + /* + removal of tail recursion only makes sence when we are sure + that at run-time after calling the rhs root function + it is not necessary to return to the calling function + */ + + if (moveact==AToB || moveact==BToA || moveact==AToRoot){ + int result_a_size,result_b_size,new_node; + int a_size,b_size; + + /* In this case no removal takes place */ + + new_node=ResultNodeNecessary (moveact,root->node_state); + if (new_node) + NewEmptyNode (&asp,-1); + + BuildArgs (root->node_arguments,&asp,&bsp,code_gen_node_ids_p); + + DetermineSizeOfArguments (root->node_arguments,&a_size,&b_size); + if (new_node) + ++a_size; + UpdateAAndBStack (asp,bsp,a_size,b_size,&asp,&bsp); + CallFunction (&name,def,True,root); + + DetermineSizeOfState (root->node_state,&result_a_size,&result_b_size); + + asp+=result_a_size-a_size; + bsp+=result_b_size-b_size; + + RedirectResultAndReturn (asp,bsp,asp,bsp,root->node_state,resultstate,result_a_size,result_b_size); + } else { + int a_size,b_size; + + /* BuildNewStackFrame (root->node_arguments,asp,bsp,ResultNodeNecessary (moveact,root->node_state),code_gen_node_ids_p); */ + + BuildArgs (root->node_arguments,&asp,&bsp,code_gen_node_ids_p); + DetermineSizeOfArguments (root->node_arguments,&a_size,&b_size); + UpdateAAndBStack (asp,bsp,a_size,b_size,&asp,&bsp); + + CallFunction (&name, def, False, root); + } + } + break; + case RECORDTYPE: + if (IsSemiStrictState (root->node_state)){ + LabDef codelab; + + if (def->sdef_strict_constructor){ + ConvertSymbolToRecordDandNLabel (&name,&codelab,def); + CreateSemiStrictRootNode (&name,&codelab,root,rootid,asp,bsp,code_gen_node_ids_p,resultstate); + } else { + ConvertSymbolToRLabel (&codelab,def); + + BuildArgs (root->node_arguments,&asp,&bsp,code_gen_node_ids_p); + + GenFillR (&codelab,root->node_arity,0,asp-rootid->nid_a_index,0,0,NormalFill,True); + asp-=root->node_arity; + + rootid->nid_state__.state_kind=StrictOnA; + + RedirectResultAndReturn (asp,bsp,rootid->nid_a_index,rootid->nid_b_index,rootid->nid_state, resultstate, 1, 0); + } + } else { + int a_size,b_size; + + BuildArgs (root->node_arguments,&asp,&bsp,code_gen_node_ids_p); + + DetermineSizeOfArguments (root->node_arguments,&a_size,&b_size); + + if (IsSimpleState (root->node_state)){ + LabDef codelab; + + ConvertSymbolToRLabel (&codelab,def); + GenFillR (&codelab,a_size,b_size,asp,0,0,ReleaseAndFill,False); + + GenPopA (asp); + GenPopB (bsp); + GenRtn (1,0,OnAState); + } else { + /*BuildNewStackFrame (root->node_arguments,asp,bsp,ResultNodeNecessary (BToB,root->node_state),code_gen_node_ids_p); */ + + UpdateAAndBStack (asp,bsp,a_size,b_size,&asp,&bsp); + + if (!function_called_only_curried_or_lazy_with_one_return){ + int asize,bsize; + + DetermineSizeOfState (resultstate, &asize, &bsize); + GenRtn (asize, bsize, resultstate); + } + } + } + break; + default: /* a USER or a TYPE constructor */ + if (def->sdef_kind==CONSTRUCTOR && def->sdef_strict_constructor && def->sdef_arity==root->node_arity){ + if (IsSemiStrictState (root->node_state)){ + LabDef codelab; + + ConvertSymbolToConstructorDandNLabel (&name,&codelab,def); + CreateSemiStrictRootNode (&name,&codelab,root,rootid,asp,bsp,code_gen_node_ids_p,resultstate); + } else { + LabDef record_label; + int asize,bsize; + + DetermineSizeOfArguments (root->node_arguments,&asize,&bsize); + BuildArgs (root->node_arguments, &asp, &bsp,code_gen_node_ids_p); + + ConvertSymbolToKLabel (&record_label,def); + + GenFillR (&record_label,asize,bsize,asp,0,0,ReleaseAndFill,False); + + GenPopA (asp); + GenPopB (bsp); + GenRtn (1,0, OnAState); + } + } else { + if (def->sdef_kind==CONSTRUCTOR) + ConvertSymbolToConstructorDLabel (&name,def); + else + ConvertSymbolToDLabel (&name,def); + FillRhsRoot (&name, root, asp, bsp,code_gen_node_ids_p); + } + break; + } + } else { + /* Symbol has too few arguments */ + if (def->sdef_kind==CONSTRUCTOR) + ConvertSymbolToConstructorDLabel (&name,def); + else + ConvertSymbolToDLabel (&name,def); + FillRhsRoot (&name, root, asp, bsp,code_gen_node_ids_p); + } +} + +static void CodeRootSelection (Node root, NodeId rootid,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p,StateS demstate) +{ + Args args; + int argnr; + + args=root->node_arguments; + argnr=root->node_arity; + + if (IsSemiStrictState (root->node_state)){ + FillSelectSymbol (SemiStrict,root->node_symbol->symb_arity,argnr,args,&asp,&bsp,rootid,code_gen_node_ids_p); + + RedirectResultAndReturn (asp,bsp,rootid->nid_a_index,rootid->nid_b_index,rootid->nid_state,demstate,1,0); + return; + } else { + Node arg_node; + int tuparity; + + tuparity = args->arg_state.state_arity; + + Assume (tuparity > 1, "codegen","CodeRootSelection"); + + arg_node=args->arg_node; + if (arg_node->node_kind!=NodeIdNode){ + StateS offstate; + + offstate= arg_node->node_state; + + Build (arg_node,&asp,&bsp,code_gen_node_ids_p); + + if (IsSimpleState (offstate)){ + GenPushArg (0, tuparity, argnr); + asp += 1; + + RedirectResultAndReturn (asp,bsp,asp,0,OnAState,demstate,1,0); + return; + } else { + int i,a_offset,b_offset,asize,bsize; + + a_offset=0; + b_offset=0; + for (i=0; i<argnr-1; ++i) + AddSizeOfState (offstate.state_tuple_arguments[i],&a_offset,&b_offset); + + DetermineSizeOfState (offstate.state_tuple_arguments[argnr-1],&asize,&bsize); + + RedirectResultAndReturn (asp,bsp,asp-a_offset,bsp-b_offset,offstate.state_tuple_arguments[argnr-1],demstate,asize,bsize); + return; + } + } else { + StateS offstate; + NodeId arg_node_id; + + arg_node_id=arg_node->node_node_id; + offstate = arg_node_id->nid_state; + + if (IsSimpleState (offstate)){ + Bool ontop; + + CoerceSimpleStateArgument (demstate, offstate.state_kind, arg_node_id->nid_a_index, & asp, False, & ontop); + + GenPushArg (asp - arg_node_id->nid_a_index, tuparity, argnr); + asp += 1; + RedirectResultAndReturn (asp, bsp, asp, 0, OnAState, demstate, 1, 0); + return; + } else { + int i,asize,bsize,aindex,bindex,tuple_a_index,tuple_b_index; + + aindex=0; + bindex=0; + for (i=0; i<argnr-1; i++) + AddSizeOfState (offstate.state_tuple_arguments[i],&aindex, &bindex); + + if (arg_node_id->nid_refcount<0 && arg_node_id->nid_node!=NULL){ + tuple_a_index=get_a_index_of_unpacked_lhs_node (arg_node_id->nid_node->node_arguments); + tuple_b_index=get_b_index_of_unpacked_lhs_node (arg_node_id->nid_node->node_arguments); + } else { + tuple_a_index=arg_node_id->nid_a_index, + tuple_b_index=arg_node_id->nid_b_index; + } + + DetermineSizeOfState (offstate.state_tuple_arguments[argnr-1],&asize,&bsize); + + aindex=tuple_a_index-aindex; + bindex=tuple_b_index-bindex; + + RedirectResultAndReturn (asp,bsp,aindex,bindex,offstate.state_tuple_arguments[argnr-1],demstate,asize,bsize); + } + } + } +} + +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, + struct node_id_ref_count_list *else_node_id_ref_counts,int doesnt_fail) +{ + SavedNidStateP saved_node_id_states; + NodeIdListElementP free_node_ids; + int need_next_alternative; + + saved_node_id_states=NULL; + free_node_ids=NULL; + + if (else_node_id_ref_counts!=NULL) + subtract_else_ref_counts (else_node_id_ref_counts,&free_node_ids); + + need_next_alternative=CodeRhsNodeDefs (root_node,defs,asp,bsp,&saved_node_id_states,resultstate,esc_p,a_node_ids,b_node_ids, + free_node_ids,doesnt_fail); + + restore_saved_node_id_states (saved_node_id_states); + + if (else_node_id_ref_counts!=NULL) + add_else_ref_counts (else_node_id_ref_counts); + + return need_next_alternative; +} + +static void CodeNormalRootNode (Node root,NodeId rootid,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p,StateS resultstate) +{ + Symbol rootsymb; + + rootsymb = root->node_symbol; + + ContractumComment (asp, bsp); + + switch (rootsymb->symb_kind){ + case definition: + CodeRootSymbolApplication (root,rootid,rootsymb->symb_def,asp,bsp,code_gen_node_ids_p,resultstate); + return; + case tuple_symb: + if (IsSemiStrictState (root->node_state)) + CreateSemiStrictRootNode (&tuple_lab,&hnf_lab,root,rootid,asp,bsp,code_gen_node_ids_p,resultstate); + else { + if (IsSimpleState (root->node_state)) + FillRhsRoot (&tuple_lab, root, asp, bsp,code_gen_node_ids_p); + else { + int asize,bsize; + + /* BuildNewStackFrame (root->node_arguments,asp,bsp,ResultNodeNecessary (BToB,root->node_state),code_gen_node_ids_p); */ + + { + int a_size,b_size; + + BuildArgs (root->node_arguments,&asp,&bsp,code_gen_node_ids_p); + DetermineSizeOfArguments (root->node_arguments,&a_size,&b_size); + UpdateAAndBStack (asp,bsp,a_size,b_size,&asp,&bsp); + } + + if (!function_called_only_curried_or_lazy_with_one_return){ + DetermineSizeOfState (resultstate, &asize, &bsize); + GenRtn (asize, bsize, resultstate); + } + } + } + return; + case cons_symb: + FillRhsRoot (&cons_lab, root, asp, bsp,code_gen_node_ids_p); + return; + case nil_symb: + FillRhsRoot (&nil_lab, root, asp, bsp,code_gen_node_ids_p); + return; + case apply_symb: + CodeRootSymbolApplication (root, rootid, ApplyDef, asp, bsp,code_gen_node_ids_p,resultstate); + return; + case if_symb: +#ifdef FASTER_STRICT_IF + if (root->node_arity==3 && !IsLazyState (root->node_state) && rootid==NULL){ + LabDef elselab,thenlab; + Args cond_arg,then_arg; + + cond_arg = root->node_arguments; + + EvaluateCondition (cond_arg->arg_node,&asp,&bsp,code_gen_node_ids_p,cond_arg->arg_state); + + MakeLabel (&elselab,else_symb,NewLabelNr,no_pref); + MakeLabel (&thenlab,then_symb,NewLabelNr++,no_pref); + + thenlab.lab_mod=notused_string; + + BranchOnCondition (cond_arg->arg_node,asp,bsp,code_gen_node_ids_p,cond_arg->arg_state,&thenlab,&elselab,&thenlab,asp,bsp,asp,bsp); + + then_arg=cond_arg->arg_next; + + if (thenlab.lab_mod==NULL) + GenLabelDefinition (&thenlab); + + CodeRhsNodeDefsAndRestoreNodeIdStates (then_arg->arg_node,NULL,asp,bsp,resultstate,NULL, + code_gen_node_ids_p->a_node_ids,code_gen_node_ids_p->b_node_ids,NULL,True); + + GenLabelDefinition (&elselab); + + CodeRhsNodeDefsAndRestoreNodeIdStates (then_arg->arg_next->arg_node,NULL,asp,bsp,resultstate,NULL, + code_gen_node_ids_p->a_node_ids,code_gen_node_ids_p->b_node_ids,NULL,True); + return; + } else +#endif + CodeRootSymbolApplication (root,rootid,IfDef,asp,bsp,code_gen_node_ids_p,resultstate); + return; + case select_symb: + CodeRootSelection (root, rootid, asp, bsp,code_gen_node_ids_p,resultstate); + return; + case fail_symb: + error_in_function ("CodeNormalRootNode"); +/* JumpToNextAlternative (asp, bsp); */ + return; + case string_denot: + GenPopA (asp); + GenPopB (bsp); + + GenBuildString (rootsymb->symb_val); + GenRtn (1, 0, OnAState); + return; + default: + if (rootsymb->symb_kind < Nr_Of_Basic_Types) + FillRhsRoot (&BasicDescriptors[rootsymb->symb_kind], root, asp, bsp,code_gen_node_ids_p); + else { + /* in case of a denotation: */ + + ObjectKind denottype; + + denottype = (rootsymb->symb_kind < Nr_Of_Predef_Types) + ? BasicSymbolStates [rootsymb->symb_kind].state_object + : UnknownObj; + + GenPopA (asp); + GenPopB (bsp); + + if (root->node_state.state_object == denottype){ + if (root->node_state.state_kind == OnB){ + PushBasic (denottype, rootsymb->symb_val); + if (!function_called_only_curried_or_lazy_with_one_return) + GenRtn (0, ObjectSizes [denottype], root->node_state); + } else { + FillBasic (denottype, rootsymb->symb_val,0, ReleaseAndFill); + if (!function_called_only_curried_or_lazy_with_one_return) + GenRtn (1, 0, OnAState); + } + } else { + StaticMessage (False,CurrentAltLabel.lab_symbol->sdef_ident->ident_name,Co_Wtype); + GenTypeError(); + GenRtn (0, 0, OnAState); + } + } + } +} + +static void PushField (StateS recstate,int fieldnr,int offset,int *asp_p,int *bsp_p,int *a_size_p,int *b_size_p) +{ + int apos,bpos,totasize,totbsize; + + DetermineFieldSizeAndPositionAndRecordSize (fieldnr,a_size_p,b_size_p,&apos,&bpos,&totasize,&totbsize,&recstate); + + GenPushRArgB (offset, totasize, totbsize, bpos+1, *b_size_p); + GenPushRArgA (offset, totasize, totbsize, apos+1, *a_size_p); + *bsp_p += *b_size_p; + *asp_p += *a_size_p; +} + +static void CodeRootFieldSelector (Node root,NodeId rootid,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p,StateS demstate) +{ + int fieldnr; + SymbDef seldef; + ArgP arg; + + arg = root->node_arguments; + seldef = root->node_symbol->symb_def; + fieldnr = seldef->sdef_sel_field_number; + + if (IsSemiStrictState (root->node_state)){ + BuildArg (arg,&asp,&bsp,code_gen_node_ids_p); + + if (root->node_arity>=SELECTOR_U){ + SymbDef new_select_sdef; + LabDef name,codelab; + + new_select_sdef=create_select_function (root->node_symbol,root->node_arity); + + ConvertSymbolToDandNLabel (&name,&codelab,new_select_sdef); + GenFill (&name,1,&codelab,asp-rootid->nid_a_index,PartialFill); + --asp; + } else + BuildOrFillLazyFieldSelector (root->node_symbol->symb_def,root->node_state.state_kind,&asp,rootid); + + RedirectResultAndReturn (asp,bsp,rootid->nid_a_index,rootid->nid_b_index,rootid->nid_state,demstate,1,0); + return; + } else { + int recarity; + Node arg_node; + + recarity = arg->arg_state.state_arity; + arg_node=arg->arg_node; + + if (arg_node->node_kind!=NodeIdNode){ + StateS offstate; + + offstate = arg_node->node_state; + Build (arg_node,&asp,&bsp,code_gen_node_ids_p); + + if (root->node_arity>=SELECTOR_U){ + int record_a_size,record_b_size,asize,bsize,aindex,bindex,offstate_a_size,offstate_b_size; + StateP record_state_p; + + record_state_p=&seldef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state; + + DetermineSizeOfState (offstate,&offstate_a_size,&offstate_b_size); + CoerceArgumentOnTopOfStack (&asp,&bsp,arg->arg_state,offstate,offstate_a_size,offstate_b_size); + + DetermineFieldSizeAndPositionAndRecordSize (fieldnr,&asize,&bsize,&aindex,&bindex,&record_a_size,&record_b_size,record_state_p); + + if (root->node_arity<SELECTOR_L){ + int n; + + for (n=0; n<asize; ++n) + GenPushA (aindex+asize-1); + asp+=asize; + + for (n=0; n<bsize; ++n) + GenPushB (bindex+bsize-1); + bsp+=bsize; + + RedirectResultAndReturn (asp,bsp,asp,bsp,root->node_state,demstate,record_a_size+asize,record_b_size+bsize); + } else { + ReplaceRecordOnTopOfStackByField (&asp,&bsp,aindex,bindex,asize,bsize,record_a_size,record_b_size); + DetermineSizeOfState (root->node_state,&offstate_a_size,&offstate_b_size); + RedirectResultAndReturn (asp,bsp,asp,bsp,root->node_state,demstate,offstate_a_size,offstate_b_size); + } + + return; + } + + if (offstate.state_type==RecordState){ + int apos,bpos,asize,bsize,aindex,bindex; + + DetermineFieldSizeAndPosition (fieldnr,&asize,&bsize,&apos,&bpos,offstate.state_record_arguments); + + aindex = asp-apos; + bindex = bsp-bpos; + RedirectResultAndReturn (asp, bsp, aindex, bindex,offstate.state_record_arguments[fieldnr], demstate, asize, bsize); + return; + } else { + int a_size,b_size; + + PushField (arg->arg_state, fieldnr, 0, & asp, & bsp,&a_size,&b_size); + RedirectResultAndReturn (asp,bsp,asp,bsp,arg->arg_state.state_record_arguments[fieldnr],demstate,a_size,b_size); + return; + } + } else { + StateS offstate; + NodeId arg_node_id; + + arg_node_id=arg_node->node_node_id; + + offstate = arg_node_id->nid_state; + + if (offstate.state_type==RecordState){ + int asize,bsize,aindex,bindex,record_a_index,record_b_index; + + DetermineFieldSizeAndPosition (fieldnr, &asize, &bsize, &aindex, &bindex,offstate.state_record_arguments); + + if (arg_node_id->nid_refcount<0 && arg_node_id->nid_node!=NULL){ + record_a_index=get_a_index_of_unpacked_lhs_node (arg_node_id->nid_node->node_arguments); + record_b_index=get_b_index_of_unpacked_lhs_node (arg_node_id->nid_node->node_arguments); + } else { + record_a_index=arg_node_id->nid_a_index, + record_b_index=arg_node_id->nid_b_index; + } + + if (root->node_arity>=SELECTOR_U){ + int record_a_size,record_b_size,n; + + GenPopA (asp-record_a_index); + asp=record_a_index; + GenPopB (bsp-record_b_index); + bsp=record_b_index; + + for (n=0; n<asize; ++n) + GenPushA (aindex+asize-1); + asp+=asize; + + for (n=0; n<bsize; ++n) + GenPushB (bindex+bsize-1); + bsp+=bsize; + + DetermineSizeOfState (offstate,&record_a_size,&record_b_size); + + RedirectResultAndReturn (asp,bsp,asp,bsp,root->node_state,demstate,record_a_size+asize,record_b_size+bsize); + return; + } + + aindex=record_a_index-aindex, + bindex=record_b_index-bindex; + + RedirectResultAndReturn (asp, bsp, aindex, bindex,offstate.state_record_arguments[fieldnr], demstate, asize, bsize); + return; + } else { + Bool ontop; + int a_size,b_size; + + if (root->node_arity>=SELECTOR_U){ + int asize,bsize,aindex,bindex,offered_a_size,offered_b_size; + StateP record_state_p; + + record_state_p=&seldef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state; + CopyNodeIdArgument (arg->arg_state,arg_node_id,&asp,&bsp); + + DetermineFieldSizeAndPosition (fieldnr,&asize,&bsize,&aindex,&bindex,record_state_p->state_record_arguments); + + if (root->node_arity<SELECTOR_L){ + int n; + + for (n=0; n<asize; ++n) + GenPushA (aindex+asize-1); + asp+=asize; + + for (n=0; n<bsize; ++n) + GenPushB (bindex+bsize-1); + bsp+=bsize; + } else { + int record_a_size,record_b_size; + + DetermineSizeOfState (*record_state_p,&record_a_size,&record_b_size); + ReplaceRecordOnTopOfStackByField (&asp,&bsp,aindex,bindex,asize,bsize,record_a_size,record_b_size); + } + + DetermineSizeOfState (root->node_state,&offered_a_size,&offered_b_size); + RedirectResultAndReturn (asp,bsp,asp,bsp,root->node_state,demstate,offered_a_size,offered_b_size); + return; + } + + CoerceSimpleStateArgument (demstate, offstate.state_kind,arg_node_id->nid_a_index,&asp,False,&ontop); + + PushField (arg->arg_state,fieldnr,asp-arg_node_id->nid_a_index,&asp,&bsp,&a_size,&b_size); + + RedirectResultAndReturn (asp, bsp, asp, bsp,arg->arg_state.state_record_arguments[fieldnr],demstate,a_size,b_size); + return; + } + } + } +} + +static void CodeRootMatchNode (Node root,NodeId rootid,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p,StateS demanded_state) +{ + if (IsSemiStrictState (root->node_state)){ + FillMatchNode (root,&asp,&bsp,rootid,code_gen_node_ids_p); + + RedirectResultAndReturn (asp,bsp,rootid->nid_a_index,rootid->nid_b_index,rootid->nid_state,demanded_state,1,0); + } else { + int a_size,b_size; + + FillMatchNode (root,&asp,&bsp,NULL,code_gen_node_ids_p); + + DetermineSizeOfState (root->node_state,&a_size,&b_size); + RedirectResultAndReturn (asp,bsp,asp,bsp,root->node_state,demanded_state,a_size,b_size); + } +} + +static void CodeRootUpdateNode (Node root,NodeId rootid,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p,StateS result_state) +{ + LabDef name; + SymbDef record_sdef; + + record_sdef=root->node_symbol->symb_def; + + ConvertSymbolToLabel (&name,record_sdef); + + if (IsSemiStrictState (root->node_state)){ + ArgS *record_arg,*first_field_arg; + int n_arguments; + LabDef name,codelab; + SymbDef new_update_sdef; + + record_arg=root->node_arguments; + first_field_arg=record_arg->arg_next; + + n_arguments=root->node_arity; + + RemoveSelectorsFromUpdateNode (record_arg,first_field_arg); + + BuildArgs (root->node_arguments,&asp,&bsp,code_gen_node_ids_p); + + new_update_sdef=CreateUpdateFunction (record_arg,first_field_arg,root); + + ConvertSymbolToDandNLabel (&name,&codelab,new_update_sdef); + + GenFill (&name,n_arguments,&codelab,asp-rootid->nid_a_index,NormalFill); + asp-=n_arguments; + + RedirectResultAndReturn (asp,bsp,rootid->nid_a_index,rootid->nid_b_index,rootid->nid_state,result_state,1,0); + } else { + ArgS *record_arg,*first_field_arg; + int record_a_size,record_b_size; + + record_arg=root->node_arguments; + first_field_arg=record_arg->arg_next; + + RemoveSelectorsFromUpdateNode (record_arg,first_field_arg); + + /* BuildNewStackFrame (record_arg,asp,bsp,False,code_gen_node_ids_p); */ + + { + int a_size,b_size; + + BuildArgs (record_arg,&asp,&bsp,code_gen_node_ids_p); + DetermineSizeOfArguments (record_arg,&a_size,&b_size); + UpdateAAndBStack (asp,bsp,a_size,b_size,&asp,&bsp); + } + + if (IsSimpleState (root->node_state)){ + LabDef record_label; + StateP record_state_p; + +/* error_in_function ("CodeRootUpdateNode"); */ + + record_state_p=&root->node_symbol->symb_def->sdef_record_state; + DetermineSizeOfState (*record_state_p,&record_a_size,&record_b_size); + + UpdateNodeAndAddSelectorsToUpdateNode (record_arg,first_field_arg, + record_state_p->state_record_arguments,record_a_size,record_b_size,&asp,&bsp); + + ConvertSymbolToRLabel (&record_label,record_sdef); + + GenFillR (&record_label,record_a_size,record_b_size,asp,0,0,ReleaseAndFill,False); + + GenPopA (asp); + GenPopB (bsp); + GenRtn (1,0, OnAState); + } else { + DetermineSizeOfState (result_state,&record_a_size,&record_b_size); + + UpdateNodeAndAddSelectorsToUpdateNode (record_arg,first_field_arg, + result_state.state_record_arguments,record_a_size,record_b_size,&asp,&bsp); + + if (!function_called_only_curried_or_lazy_with_one_return) + GenRtn (record_a_size,record_b_size,result_state); + } + } +} + +static int CodeRootNode (Node root,NodeId rootid,int asp,int bsp,CodeGenNodeIdsP code_gen_node_ids_p,StateS resultstate,struct esc *esc_p) +{ + switch (root->node_kind){ + case NormalNode: + CodeNormalRootNode (root, rootid, asp, bsp,code_gen_node_ids_p,resultstate); + return 0; + case SelectorNode: + CodeRootFieldSelector (root, rootid, asp, bsp,code_gen_node_ids_p,resultstate); + return 0; + case UpdateNode: + CodeRootUpdateNode (root, rootid, asp, bsp,code_gen_node_ids_p,resultstate); + return 0; + case MatchNode: + CodeRootMatchNode (root,rootid,asp,bsp,code_gen_node_ids_p,resultstate); + return 0; + case IfNode: + { + LabDef elselab,thenlab; + Args condpart,then_arg; + struct node *else_node; + + condpart = root->node_arguments; + + EvaluateCondition (condpart->arg_node,&asp,&bsp,code_gen_node_ids_p,condpart->arg_state); + + MakeLabel (&elselab, else_symb, NewLabelNr, no_pref); + MakeLabel (&thenlab, then_symb, NewLabelNr++, no_pref); + + thenlab.lab_mod=notused_string; + + BranchOnCondition (condpart->arg_node,asp,bsp,code_gen_node_ids_p,condpart->arg_state,&thenlab,&elselab,&thenlab,asp,bsp,asp,bsp); + + then_arg=condpart->arg_next; + + if (thenlab.lab_mod==NULL) + GenLabelDefinition (&thenlab); + + CodeRhsNodeDefsAndRestoreNodeIdStates (then_arg->arg_node,root->node_then_node_defs,asp,bsp,resultstate,esc_p, + code_gen_node_ids_p->a_node_ids,code_gen_node_ids_p->b_node_ids, + root->node_else_node_id_ref_counts, + True +/* + code_gen_node_ids_p->doesnt_fail +*/ + ); + + GenLabelDefinition (&elselab); + + else_node=then_arg->arg_next->arg_node; + + if (else_node->node_kind==NormalNode && else_node->node_symbol->symb_kind==fail_symb){ + UpdateStackPointers (asp,bsp,esc_p->esc_asp,esc_p->esc_bsp); + GenJmp (esc_p->esc_label); + + return 1; + } else + return CodeRhsNodeDefsAndRestoreNodeIdStates (else_node,root->node_else_node_defs,asp,bsp,resultstate,esc_p, + code_gen_node_ids_p->a_node_ids,code_gen_node_ids_p->b_node_ids, + NULL,code_gen_node_ids_p->doesnt_fail); + } + case NodeIdNode: + if (rootid==NULL){ + CodeRedirection (root->node_node_id,asp,bsp,resultstate,&code_gen_node_ids_p->free_node_ids); + return 0; + } + default: + error_in_function ("CodeRootNode"); + return 0; + } +} + +static Bool ExamineRootNodeOnACycle (NodeId rhsid,Node rhsroot,int *asp_p,StateS resultstate) +{ + rhsid->nid_state_=OnAState; + + if (IsSimpleState (resultstate)){ + if (resultstate.state_kind==OnB || resultstate.state_kind==StrictRedirection){ + NewEmptyNode (asp_p,rhsroot->node_arity); + rhsid->nid_a_index_=*asp_p; + } else { + if (rhsroot->node_arity<=2 || NodeOnACycleIsInRootNormalForm (rhsroot)){ + rhsid->nid_a_index_=0; + } else { + NewEmptyNode (asp_p,rhsroot->node_arity); + rhsid->nid_a_index_=*asp_p; + return True; + } + } + } else { + if (NodeOnACycleIsInRootNormalForm (rhsroot)) + NewEmptyNode (asp_p,-1); + else + NewEmptyNode (asp_p,rhsroot->node_arity); + rhsid->nid_a_index_=*asp_p; + } + return False; +} + +#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, + int asp,int bsp,struct code_gen_node_ids *code_gen_node_ids_p) +{ + LabDef name; + int a_size,b_size; + + ConvertSymbolToLabel (&name,node_p->node_symbol->symb_def); + + DetermineSizeOfArguments (node_p->node_arguments,&a_size,&b_size); + + if (push_node==NULL) + BuildArgsWithNewResultNode (node_p->node_arguments,&asp,&bsp,code_gen_node_ids_p,&a_size,&b_size); + else + BuildArgsWithResultNodeOnStack (node_p->node_arguments,push_node->node_arguments->arg_node->node_node_id,&asp,&bsp,code_gen_node_ids_p,&a_size,&b_size); + + asp-=a_size; + bsp-=b_size; + + cleanup_stack (&asp,&bsp,a_size,b_size,&code_gen_node_ids_p->a_node_ids,&code_gen_node_ids_p->b_node_ids, + &code_gen_node_ids_p->free_node_ids,code_gen_node_ids_p->moved_node_ids_l,code_gen_node_ids_p->doesnt_fail); + + node_def_id->nid_a_index_=asp+1; + node_def_id->nid_b_index_=bsp; + node_def_id->nid_state_=node_p->node_state; + + asp+=a_size; + bsp+=b_size; + + BuildArgs (root_node->node_arguments,&asp,&bsp,code_gen_node_ids_p); + + if (root_node->node_symbol->symb_kind==cons_symb){ + GenFillh (&cons_lab,root_node->node_arity,asp,ReleaseAndFill); + asp-=root_node->node_arity; + } else { + LabDef constructor_name; + + if (!root_node->node_symbol->symb_def->sdef_strict_constructor){ + ConvertSymbolToConstructorDLabel (&constructor_name,root_node->node_symbol->symb_def); + GenFillh (&constructor_name,root_node->node_arity,asp,ReleaseAndFill); + asp-=root_node->node_arity; + } else { + int asize,bsize; + + ConvertSymbolToKLabel (&constructor_name,root_node->node_symbol->symb_def); + + DetermineSizeOfArguments (root_node->node_arguments,&asize,&bsize); + + if (asize+bsize>2 && push_node!=NULL && push_node->node_line>=asize+bsize){ + NodeIdListElementP node_id_list; + char bits[MaxNodeArity+2]; + unsigned int a_bits,b_bits,a_size,b_size,n,arg_n; + int n_a_fill_bits,n_b_fill_bits,node_arity; + ArgP arg_p; + + a_bits=0; + b_bits=0; + a_size=0; + b_size=0; + n_a_fill_bits=0; + n_b_fill_bits=0; + + arg_p=root_node->node_arguments; + node_arity=root_node->node_arity; + node_id_list=push_node->node_node_ids; + + for (arg_n=0; arg_n<node_arity; ++arg_n){ + int arg_a_size,arg_b_size; + + DetermineSizeOfState (arg_p->arg_state,&arg_a_size,&arg_b_size); + + if (arg_n==0 || !(arg_p->arg_node->node_kind==NodeIdNode && arg_p->arg_node->node_node_id==node_id_list->nidl_node_id)){ + a_bits |= (~((~0)<<arg_a_size))<<a_size; + b_bits |= (~((~0)<<arg_b_size))<<b_size; + + n_a_fill_bits+=arg_a_size; + n_b_fill_bits+=arg_b_size; + } + + arg_p=arg_p->arg_next; + a_size+=arg_a_size; + b_size+=arg_b_size; + node_id_list=node_id_list->nidl_next; + } + + for (n=0; n<a_size; ++n) + bits[n]='0' + ((a_bits>>n) & 1); + + for (n=0; n<b_size; ++n) + bits[n+a_size]='0' + ((b_bits>>n) & 1); + + bits[a_size+b_size]='\0'; + + GenPushA (asp-node_def_id->nid_a_index); + GenFill3R (&constructor_name,asize,bsize,asp+1,bits); + } else + GenFillR (&constructor_name,asize,bsize,asp,0,0,ReleaseAndFill,True); + asp-=asize; + bsp-=bsize; + } + } + + if (tail_call_modulo_cons) + name.lab_post=2; + + if (tail_call_modulo_cons==2){ + GenKeep (asp,a_size-1); + ++asp; + UpdateAAndBStack (asp,bsp,a_size,b_size,&asp,&bsp); + --asp; + CallFunction (&name,node_p->node_symbol->symb_def,False,node_p); + } else { + CallFunction (&name,node_p->node_symbol->symb_def,True,node_p); + } + + asp-=a_size; + bsp-=b_size; + + DetermineSizeOfState (node_p->node_state,&a_size,&b_size); + + asp+=a_size; + bsp+=b_size; + + if (a_size!=0) + add_node_id_to_list (node_def_id,&code_gen_node_ids_p->a_node_ids); + + if (b_size!=0) + add_node_id_to_list (node_def_id,&code_gen_node_ids_p->b_node_ids); + + if (tail_call_modulo_cons<2){ + node_def_id->nid_a_index_=asp; + node_def_id->nid_b_index_=bsp; + node_def_id->nid_state_=node_p->node_state; + + GenPopA (asp); + GenPopB (bsp); + GenRtn (1,0,OnAState); + } +} + +static int is_tail_call_module_cons_node (NodeP node_p) +{ + if (node_p->node_kind==NormalNode && node_p->node_symbol->symb_kind==definition){ + SymbDef sdef; + + sdef=node_p->node_symbol->symb_def; + + if (sdef->sdef_kind==IMPRULE && sdef->sdef_arity==node_p->node_arity && !IsLazyState (node_p->node_state) && + ExpectsResultNode (node_p->node_state) && node_p->node_state.state_kind!=Parallel) + { + return 1; + } + } + return 0; +} +#endif + +#if OPTIMIZE_LAZY_TUPLE_RECURSION +extern int lazy_tuple_recursion; +NodeP tuple_result_p; + +LabDef d_indirection_lab = {NULL, "", False, "d_indirection", 0}; +LabDef n_indirection_lab = {NULL, "", False, "n_indirection", 0}; + +void update_tuple_element_node (StateP state_p,int tuple_element_a_index,int *asp_p,int *bsp_p) +{ + if (state_p->state_type==SimpleState){ + if (state_p->state_kind==StrictOnA){ + GenFillFromA (0,*asp_p-tuple_element_a_index,ReleaseAndFill); + GenPopA (1); + --*asp_p; + } else if (state_p->state_kind==OnB){ + int b_size; + + FillBasicFromB (state_p->state_object,0,*asp_p-tuple_element_a_index,NormalFill); + b_size=ObjectSizes [state_p->state_object]; + GenPopB (b_size); + *bsp_p-=b_size; + } else { + GenFill (&d_indirection_lab,-2,&n_indirection_lab,*asp_p-tuple_element_a_index,PartialFill); + --*asp_p; + } + } else + error_in_function ("update_tuple_element_node"); +} + +#if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION +extern int tail_call_modulo_tuple_cons; +extern unsigned long global_same_select_vector; +#endif + +static void fill_lazy_tuple_result_arguments (Args arg,int *asp_p,int *bsp_p,int tuple_element_n,int tuple_element_a_index,CodeGenNodeIdsP code_gen_node_ids_p) +{ + if (arg==NULL) + return; + else { + NodeP node; + int asize,bsize; + + fill_lazy_tuple_result_arguments (arg->arg_next,asp_p,bsp_p,tuple_element_n+1,tuple_element_a_index-1,code_gen_node_ids_p); + + ArgComment (arg); + + node=arg->arg_node; + +#if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION + if (node->node_kind==FillUniqueNode) + node=node->node_arguments->arg_node; + + if (tail_call_modulo_tuple_cons==2 && global_same_select_vector & (1<<tuple_element_n)){ + if (node->node_kind!=NodeIdNode){ + Build (node,asp_p,bsp_p,code_gen_node_ids_p); + DetermineSizeOfState (node->node_state, &asize, &bsize); + CoerceArgumentOnTopOfStack (asp_p,bsp_p,arg->arg_state,node->node_state,asize,bsize); + } else { + NodeId arg_node_id; + + arg_node_id=node->node_node_id; + + if (CopyNodeIdArgument (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 +#endif + if (node->node_kind!=NodeIdNode){ + NodeIdS update_node_id_struct; + + update_node_id_struct.nid_a_index=tuple_element_a_index; + + if (node->node_kind==NormalNode && node->node_symbol->symb_kind==select_symb && + node->node_arguments->arg_node->node_kind==NodeIdNode && + tuple_element_n+1==node->node_arity && + (node->node_arguments->arg_node->node_node_id->nid_mark2 & NID_CALL_VIA_LAZY_SELECTIONS_ONLY)) + { + ; + } else + FillNodeOnACycle (node,asp_p,bsp_p,&update_node_id_struct,code_gen_node_ids_p); + + GenPushA (*asp_p-tuple_element_a_index); + ++*asp_p; + + DetermineSizeOfState (node->node_state, &asize, &bsize); + CoerceArgumentOnTopOfStack (asp_p,bsp_p,arg->arg_state,node->node_state,asize,bsize); + } else { + NodeId arg_node_id; + + arg_node_id=node->node_node_id; + + if (arg_node_id->nid_state.state_type==SimpleState && arg_node_id->nid_state.state_kind!=OnB){ + if (CopyNodeIdArgument (arg->arg_state,arg_node_id,asp_p,bsp_p)) + ChangeEvalStatusKindToStrictOnA (arg_node_id,code_gen_node_ids_p->saved_nid_state_l); + } else + CopyNodeIdArgument (arg_node_id->nid_state,arg_node_id,asp_p,bsp_p); + + update_tuple_element_node (&arg_node_id->nid_state,tuple_element_a_index,asp_p,bsp_p); + + GenPushA (*asp_p-tuple_element_a_index); + ++*asp_p; + + decrement_reference_count_of_node_id (arg_node_id,&code_gen_node_ids_p->free_node_ids); + } + } +} +#endif + +#if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION +static void fill_strict_tuple_result_arguments (Args arg,ArgP *function_result_tuple_elements_p,int *asp_p,int *bsp_p,int tuple_element_n,int tuple_element_a_index,unsigned long result_and_call_same_select_vector,CodeGenNodeIdsP code_gen_node_ids_p) +{ + if (arg==NULL) + return; + else { + NodeP node; + int asize,bsize; + + --function_result_tuple_elements_p; + + fill_strict_tuple_result_arguments (arg->arg_next,function_result_tuple_elements_p,asp_p,bsp_p,tuple_element_n+1,tuple_element_a_index-1,result_and_call_same_select_vector,code_gen_node_ids_p); + + if (!(global_same_select_vector & (1<<tuple_element_n))){ + node=arg->arg_node; + + if (!(result_and_call_same_select_vector & (1<<tuple_element_n))){ + ArgComment (arg); + + if (node->node_kind==FillUniqueNode) + node=node->node_arguments->arg_node; + + if (node->node_kind!=NodeIdNode){ + NodeIdS update_node_id_struct; + + update_node_id_struct.nid_a_index=tuple_element_a_index; + + if (node->node_kind==NormalNode && node->node_symbol->symb_kind==select_symb && + node->node_arguments->arg_node->node_kind==NodeIdNode && + tuple_element_n+1==node->node_arity && + (node->node_arguments->arg_node->node_node_id->nid_mark2 & NID_CALL_VIA_LAZY_SELECTIONS_ONLY)) + { + ; + } else + FillNodeOnACycle (node,asp_p,bsp_p,&update_node_id_struct,code_gen_node_ids_p); + + GenKeep (*asp_p-tuple_element_a_index,*asp_p-(*function_result_tuple_elements_p)->arg_node->node_node_id->nid_a_index); + /* + GenPushA (*asp_p-tuple_element_a_index); + ++*asp_p; + + DetermineSizeOfState (node->node_state, &asize, &bsize); + CoerceArgumentOnTopOfStack (asp_p,bsp_p,arg->arg_state,node->node_state,asize,bsize); + */ + } else { + NodeId arg_node_id; + + arg_node_id=node->node_node_id; + + if (arg_node_id->nid_state.state_type==SimpleState && arg_node_id->nid_state.state_kind!=OnB){ + if (CopyNodeIdArgument (arg->arg_state,arg_node_id,asp_p,bsp_p)) + ChangeEvalStatusKindToStrictOnA (arg_node_id,code_gen_node_ids_p->saved_nid_state_l); + } else + CopyNodeIdArgument (arg_node_id->nid_state,arg_node_id,asp_p,bsp_p); + + update_tuple_element_node (&arg_node_id->nid_state,tuple_element_a_index,asp_p,bsp_p); + + GenKeep (*asp_p-tuple_element_a_index,*asp_p-(*function_result_tuple_elements_p)->arg_node->node_node_id->nid_a_index); + /* + GenPushA (*asp_p-tuple_element_a_index); + ++*asp_p; + */ + decrement_reference_count_of_node_id (arg_node_id,&code_gen_node_ids_p->free_node_ids); + } + } + } + } +} +#endif + +#if TAIL_CALL_MODULO_CONS_OPTIMIZATION || TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION +static void CallFunctionWithStackSizes (LabDef name,NodeP node_p,int a_size,int b_size,int no_tail_call) +{ + name.lab_post=2; + + if (name.lab_mod && name.lab_mod==CurrentModule) + name.lab_mod = NULL; + + name.lab_pref = s_pref; + + GenDStackLayout (a_size,b_size,node_p->node_arguments); + if (no_tail_call){ + GenJsr (&name); + } else + GenJmp (&name); +} +#endif + +int CodeRhsNodeDefs + (Node root_node,NodeDefs defs,int asp,int bsp,SavedNidStateS **saved_nid_state_l,StateS result_state, + struct esc *esc_p,NodeIdListElementP a_node_ids,NodeIdListElementP b_node_ids, + NodeIdListElementP free_node_ids,int doesnt_fail) +{ + int r; + MovedNodeIdP moved_node_ids; + struct code_gen_node_ids code_gen_node_ids; + + moved_node_ids=NULL; + + code_gen_node_ids.free_node_ids=free_node_ids; + code_gen_node_ids.saved_nid_state_l=saved_nid_state_l; + code_gen_node_ids.doesnt_fail=doesnt_fail; + code_gen_node_ids.moved_node_ids_l=&moved_node_ids; + code_gen_node_ids.a_node_ids=a_node_ids; + code_gen_node_ids.b_node_ids=b_node_ids; + + if (root_node->node_kind==NodeIdNode && defs==NULL){ + CodeRedirection (root_node->node_node_id, asp, bsp, result_state ,&free_node_ids); + return 0; + } + + if (root_node->node_kind==NodeIdNode && (root_node->node_node_id->nid_mark & ON_A_CYCLE_MASK)){ + NodeId root_node_id; + NodeDefs rootdef; + Bool large_lazy_root; + + root_node_id=root_node->node_node_id; + rootdef=root_node_id->nid_node_def; + + large_lazy_root=ExamineRootNodeOnACycle (root_node_id, rootdef->def_node, &asp, result_state); + + if (defs!=rootdef || defs->def_next || large_lazy_root){ + CodeSharedNodeDefs (defs,rootdef,&asp,&bsp,&code_gen_node_ids); + + RedirectResultAndReturn (asp,bsp,root_node_id->nid_a_index,0,StrictOnAState,result_state,0,0); + r=0; + } else { + r=CodeRootNode (rootdef->def_node,root_node_id,asp,bsp,&code_gen_node_ids,result_state,esc_p); + } + } else { +#if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION + if (root_node->node_kind==NormalNode && root_node->node_symbol->symb_kind==tuple_symb && defs!=NULL){ + NodeIdP tuple_call_node_id_p; + + if (is_tuple_tail_call_modulo_cons_root (root_node,&tuple_call_node_id_p) && + (tuple_call_node_id_p->nid_node->node_symbol->symb_def->sdef_rule->rule_mark & RULE_CALL_VIA_LAZY_SELECTIONS_ONLY)) + { + NodeDefP *last_node_def_h,last_node_def_p; + + last_node_def_h=&defs; + while ((last_node_def_p=*last_node_def_h)->def_next!=NULL && last_node_def_p->def_id!=tuple_call_node_id_p) + last_node_def_h=&last_node_def_p->def_next; + + if (last_node_def_p->def_next==NULL && last_node_def_p->def_id==tuple_call_node_id_p && + last_node_def_p->def_node->node_kind==TupleSelectorsNode && + last_node_def_p->def_node->node_arguments->arg_node->node_kind==NodeIdNode) + { + unsigned long result_and_call_same_select_vector; + int n,tuple_arity,result_tuple_arity; + int args_a_size,args_b_size; + ArgP tuple_element_p,function_result_tuple_element_p; + LabDef name; + SymbDef sdef; + NodeP node,tuple_node; + ArgP function_result_tuple_elements_a[MaxNodeArity],*function_result_tuple_elements,*function_result_tuple_elements_p; + + printf ("Tuple tail call modulo cons %s\n",tuple_call_node_id_p->nid_node->node_symbol->symb_def->sdef_ident->ident_name); + + function_result_tuple_elements_p=&function_result_tuple_elements_a[0]; + for_l (function_result_tuple_element_p,last_node_def_p->def_node->node_arguments,arg_next) + *function_result_tuple_elements_p++ = function_result_tuple_element_p; + function_result_tuple_elements=function_result_tuple_elements_p; + + result_and_call_same_select_vector=0; + + if (tail_call_modulo_tuple_cons==2) + for_li (tuple_element_p,n,root_node->node_arguments,arg_next){ + NodeP node_p; + + node_p=tuple_element_p->arg_node; + --function_result_tuple_elements_p; + + if (node_p->node_kind==NodeIdNode && node_p->node_node_id->nid_refcount>0 + && node_p->node_node_id==(*function_result_tuple_elements_p)->arg_node->node_node_id) + { + result_and_call_same_select_vector |= (1<<n); + } + } + + tuple_arity=root_node->node_arity; + result_tuple_arity=tuple_arity; + + for_li (function_result_tuple_element_p,n,last_node_def_p->def_node->node_arguments,arg_next){ + NodeIdP function_result_tuple_element_node_id_p; + + if (!(global_same_select_vector & (1<<(tuple_arity-1-n)))){ + if (result_and_call_same_select_vector & (1<<(tuple_arity-1-n))) + GenPushA (asp-1-n); + else + GenCreate (-1); + ++asp; + } else + --result_tuple_arity; + + function_result_tuple_element_node_id_p=function_result_tuple_element_p->arg_node->node_node_id; + + function_result_tuple_element_node_id_p->nid_a_index = asp; + function_result_tuple_element_node_id_p->nid_state = StrictOnAState; + } + + tuple_result_p=last_node_def_p->def_node; + + *last_node_def_h=NULL; + CodeSharedNodeDefs (defs,NULL,&asp,&bsp,&code_gen_node_ids); + *last_node_def_h=last_node_def_p; + + if (tail_call_modulo_tuple_cons==1) + for_li (function_result_tuple_element_p,n,last_node_def_p->def_node->node_arguments,arg_next){ + if (!(global_same_select_vector & (1<<(tuple_arity-1-n)))){ + GenPushA (asp-function_result_tuple_element_p->arg_node->node_node_id->nid_a_index); + ++asp; + } + } + + { + struct arg *arg; + struct state *tuple_state_p; + int a_offset,b_offset,i; + ArgP node_args; + + node=last_node_def_p->def_node; + + tuple_node=node->node_node; + + sdef=tuple_node->node_symbol->symb_def; + ConvertSymbolToLabel (&name,sdef); + + node_args=tuple_node->node_arguments; + DetermineSizeOfArguments (node_args,&args_a_size,&args_b_size); + + BuildArgs (node_args,&asp,&bsp,&code_gen_node_ids); + + + asp-=args_a_size; + bsp-=args_b_size; + if (tail_call_modulo_tuple_cons==1) + asp-=result_tuple_arity; + + cleanup_stack (&asp,&bsp,tail_call_modulo_tuple_cons==1 ? args_a_size+result_tuple_arity : args_a_size,args_b_size, + &code_gen_node_ids.a_node_ids,&code_gen_node_ids.b_node_ids,&code_gen_node_ids.free_node_ids, + code_gen_node_ids.moved_node_ids_l,code_gen_node_ids.doesnt_fail); + + + if (tail_call_modulo_tuple_cons==1){ + int n; + int result_tuple_a_size,result_tuple_b_size; + StateS new_result_state,element_states[MaxNodeArity]; + + tuple_state_p=&tuple_node->node_state; + new_result_state=*tuple_state_p; + + result_tuple_a_size=0; + result_tuple_b_size=0; + + for (n=0; n<root_node->node_arity; ++n) + if (global_same_select_vector & (1<<n)){ + element_states[n]=tuple_state_p->state_tuple_arguments[n]; + AddSizeOfState (element_states[n],&result_tuple_a_size,&result_tuple_b_size); + } else { + element_states[n]=OnAState; + ++result_tuple_a_size; + } + + + new_result_state.state_tuple_arguments=element_states; + + CallFunctionWithStackSizes (name,tuple_node,args_a_size+result_tuple_arity,args_b_size,True); + + GenOStackLayoutOfState (result_tuple_a_size,result_tuple_b_size,new_result_state); + +/* + AddSizeOfState (tuple_node->node_state,&asp,&bsp); +*/ + asp+=result_tuple_a_size; + bsp+=result_tuple_b_size; + + + arg=node->node_arguments; + + a_offset=result_tuple_a_size; + b_offset=result_tuple_b_size; + + if (new_result_state.state_type!=TupleState) + error_in_function ("CodeRhsNodeDefs"); + + for (i=new_result_state.state_arity-1; i>=0; --i){ + int a_size,b_size; + NodeId node_id; + + DetermineSizeOfState (new_result_state.state_tuple_arguments[i],&a_size,&b_size); + + a_offset-=a_size; + b_offset-=b_size; + + if (global_same_select_vector & (1<<i)){ + if (arg!=NULL && arg->arg_node->node_node_id->nid_number==i){ + node_id=arg->arg_node->node_node_id; + arg=arg->arg_next; + } else { + if (a_size==0 && b_size==0) + continue; + + node_id=NewNodeId (NULL); + add_node_id_to_list (node_id,&code_gen_node_ids.free_node_ids); + } + + node_id->nid_a_index_ = asp - a_offset; + node_id->nid_b_index_ = bsp - b_offset; + node_id->nid_state_ = new_result_state.state_tuple_arguments[i]; + + if (a_size!=0) + add_node_id_to_list (node_id,&code_gen_node_ids.a_node_ids); + if (b_size!=0) + add_node_id_to_list (node_id,&code_gen_node_ids.b_node_ids); + } else + if (arg!=NULL && arg->arg_node->node_node_id->nid_number==i) + arg=arg->arg_next; + } + + if (arg!=NULL) + error_in_function ("CodeRhsNodeDefs"); + } else { + asp+=args_a_size; + bsp+=args_b_size; + } + + } + + if (tail_call_modulo_tuple_cons==1){ + r=CodeRootNode (root_node,NULL,asp,bsp,&code_gen_node_ids,result_state,esc_p); +/* + fill_lazy_tuple_result_arguments (root_node->node_arguments,&asp,&bsp,0,tuple_arity,&code_gen_node_ids); + + UpdateAAndBStack (asp,bsp,args_a_size,args_b_size,&asp,&bsp); + + for (n=0; n<tuple_arity-1; ++n) + GenKeep (tuple_arity-2-n,tuple_arity-1); + + GenPopA (tuple_arity-1); + GenRtn (1,0,OnAState); + + r=0; +*/ + } else { + fill_strict_tuple_result_arguments (root_node->node_arguments,function_result_tuple_elements,&asp,&bsp,0,tuple_arity,result_and_call_same_select_vector,&code_gen_node_ids); + + args_a_size+=result_tuple_arity; + +/* ++asp; +*/ + UpdateAAndBStack (asp,bsp,args_a_size,args_b_size,&asp,&bsp); + + CallFunctionWithStackSizes (name,tuple_node,args_a_size,args_b_size,False); + + r=0; + } + + 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; + } + + return r; + } + } + } +#endif + + +#if TAIL_CALL_MODULO_CONS_OPTIMIZATION + if (OptimizeTailCallModuloCons && root_node->node_kind==NormalNode){ + if ((root_node->node_symbol->symb_kind==cons_symb && root_node->node_arity==2) || + (root_node->node_symbol->symb_kind==definition && root_node->node_symbol->symb_def->sdef_kind==CONSTRUCTOR && + root_node->node_arity==root_node->node_symbol->symb_def->sdef_arity)) + { + ArgP arg_p,arg_p2; + + arg_p2=NULL; + + for_l (arg_p,root_node->node_arguments,arg_next) + if (arg_p->arg_node->node_kind!=NodeIdNode) + if (arg_p2==NULL) + arg_p2=arg_p; + else + break; + + if (arg_p==NULL){ + if (arg_p2==NULL){ + if (defs!=NULL){ + NodeDefP *last_node_def_h,last_node_def_p; + NodeP node_p; + + last_node_def_h=&defs; + while ((last_node_def_p=*last_node_def_h)->def_next!=NULL) + last_node_def_h=&last_node_def_p->def_next; + + node_p=last_node_def_p->def_node; + + if (node_p!=NULL){ + NodeIdP node_def_id; + NodeP push_node; + + node_def_id=last_node_def_p->def_id; + + push_node=NULL; + + if (node_p->node_kind==FillUniqueNode){ + push_node=node_p->node_node; + node_p=node_p->node_arguments->arg_node; + } + + if (!(node_def_id->nid_mark & ON_A_CYCLE_MASK) && is_tail_call_module_cons_node (node_p)){ + *last_node_def_h=NULL; + CodeSharedNodeDefs (defs,NULL,&asp,&bsp,&code_gen_node_ids); + *last_node_def_h=last_node_def_p; + + generate_code_for_tail_call_modulo_cons (node_p,node_def_id,root_node,push_node,asp,bsp,&code_gen_node_ids); + + 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; + } + + return 0; + } + } + } + } else { + NodeP node_p,push_node_p; + NodeIdP node_id_p; + + node_p=arg_p2->arg_node; + push_node_p=NULL; + + if (node_p->node_kind==FillUniqueNode){ + push_node_p=node_p->node_node; + node_p=node_p->node_arguments->arg_node; + } + + if (is_tail_call_module_cons_node (node_p)){ + NodeP old_arg_node_p; + + node_id_p=NewNodeId (NULL); + + node_id_p->nid_refcount=1; + + old_arg_node_p=arg_p2->arg_node; + arg_p2->arg_node=NewNodeIdNode (node_id_p); + + CodeSharedNodeDefs (defs,NULL,&asp,&bsp,&code_gen_node_ids); + + generate_code_for_tail_call_modulo_cons (node_p,node_id_p,root_node,push_node_p,asp,bsp,&code_gen_node_ids); + + 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; + } + + arg_p2->arg_node=old_arg_node_p; + + return 0; + } + } + } + } + } +#endif + +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if (lazy_tuple_recursion && root_node->node_kind!=IfNode){ + if (root_node->node_kind==NormalNode && root_node->node_symbol->symb_kind==tuple_symb && + !(IsSemiStrictState (root_node->node_state) || IsSimpleState (root_node->node_state)) + ){ + int a_size,b_size,n,tuple_arity; + ArgP tuple_element_p; + /* + unsigned long result_and_call_same_select_vector; + + result_and_call_same_select_vector=0; + + for_li (tuple_element_p,n,root_node->node_arguments,arg_next){ + NodeP node_p; + + node_p=tuple_element_p->arg_node; + + if (node_p->node_symbol->symb_kind==select_symb + && node_p->node_arguments->arg_node->node_kind==NodeIdNode + && n+1==node_p->node_arity + && (node_p->node_arguments->arg_node->node_node_id->nid_mark2 & NID_CALL_VIA_LAZY_SELECTIONS_ONLY) + ) + result_and_call_same_select_vector |= (1<<n); + } + */ + tuple_result_p=root_node; + + CodeSharedNodeDefs (defs,NULL,&asp,&bsp,&code_gen_node_ids); + + fill_lazy_tuple_result_arguments (root_node->node_arguments,&asp,&bsp,0,root_node->node_arity,&code_gen_node_ids); + + tuple_arity=root_node->node_arity; + + a_size=tuple_arity; + b_size=0; + /* + DetermineSizeOfArguments (root_node->node_arguments,&a_size,&b_size); + */ +#if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION + if (tail_call_modulo_tuple_cons==0) + ++asp; + else if (tail_call_modulo_tuple_cons==2){ + ArgP arg_p; + int n; + + for_li (arg_p,n,root_node->node_arguments,arg_next){ + if (global_same_select_vector & (1<<n)){ + --tuple_arity; + --a_size; + AddSizeOfState (arg_p->arg_state,&a_size,&b_size); + } + } + } +#else + ++asp; +#endif + UpdateAAndBStack (asp,bsp,a_size,b_size,&asp,&bsp); + + for (n=0; n<tuple_arity-1; ++n) + GenKeep (tuple_arity-2-n,tuple_arity-1); + + GenPopA (tuple_arity-1); + +#if TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION + if (tail_call_modulo_tuple_cons==2){ + int n; + StateS new_result_state,element_states[MaxNodeArity]; + + new_result_state=result_state; + + for (n=0; n<root_node->node_arity; ++n) + if (global_same_select_vector & (1<<n)) + element_states[n]=result_state.state_tuple_arguments[n]; + else + element_states[n]=OnAState; + + new_result_state.state_tuple_arguments=element_states; + + GenRtn (a_size-(tuple_arity-1),b_size,new_result_state); + } else +#endif + GenRtn (1,0,OnAState); + + r=0; + } else if (root_node->node_kind==NormalNode && root_node->node_symbol->symb_kind==definition + && root_node->node_symbol->symb_def->sdef_kind==IMPRULE + && (root_node->node_symbol->symb_def->sdef_rule->rule_mark & RULE_CALL_VIA_LAZY_SELECTIONS_ONLY) + && root_node->node_symbol->symb_def->sdef_arity==root_node->node_arity + && !IsSemiStrictState (root_node->node_state)) + { + int a_size,b_size,tuple_arity,n; + SymbDef sdef; + LabDef name; + + CodeSharedNodeDefs (defs,NULL,&asp,&bsp,&code_gen_node_ids); + + sdef=root_node->node_symbol->symb_def; + tuple_arity=sdef->sdef_rule->rule_type->type_alt_rhs->type_node_arity; + + for (n=0; n<tuple_arity; ++n){ + GenPushA (asp-(n+1)); + ++asp; + } + + BuildArgs (root_node->node_arguments,&asp,&bsp,&code_gen_node_ids); + DetermineSizeOfArguments (root_node->node_arguments,&a_size,&b_size); + + UpdateAAndBStack (asp,bsp,a_size+tuple_arity,b_size,&asp,&bsp); + + ConvertSymbolToLabel (&name,sdef); + name.lab_post=2; + + if (name.lab_mod && name.lab_mod==CurrentModule) + name.lab_mod = NULL; + + name.lab_pref = s_pref; + + GenDStackLayout (a_size+tuple_arity,b_size,root_node->node_arguments); + GenJmp (&name); + + r=0; + } else { + error_in_function ("CodeRhsNodeDefs"); + r=0; + } + } else +#endif + { + CodeSharedNodeDefs (defs,NULL,&asp,&bsp,&code_gen_node_ids); + + r=CodeRootNode (root_node,NULL,asp,bsp,&code_gen_node_ids,result_state,esc_p); + } + } + + 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; + } + + return r; +} + +#if GENERATE_CODE_AGAIN +struct saved_node_id_ref_counts* save_lhs_node_id_ref_counts (NodeP node_p,struct saved_node_id_ref_counts *snir_p) +{ + if (node_p->node_kind==NodeIdNode){ + struct saved_node_id_ref_counts *new_snir_p; + + new_snir_p=CompAllocType (struct saved_node_id_ref_counts); + new_snir_p->snir_node_id=node_p->node_node_id; + new_snir_p->snir_ref_count=node_p->node_node_id->nid_refcount; + + new_snir_p->snir_next=snir_p; + snir_p=new_snir_p; + } else { + ArgP arg_p; + + for_l (arg_p,node_p->node_arguments,arg_next) + snir_p=save_lhs_node_id_ref_counts (arg_p->arg_node,snir_p); + } + + return snir_p; +} + +struct saved_node_id_ref_counts* save_rhs_node_id_ref_counts + (NodeP node_p,NodeDefP node_defs,struct saved_node_id_ref_counts *snir_p,struct saved_case_node_id_ref_counts ***scnirc_hl) +{ + NodeDefP node_def_p; + + switch (node_p->node_kind){ + case PushNode: + { + struct node_id_list_element *arg_node_id_list; + + for_l (arg_node_id_list,node_p->node_node_ids,nidl_next){ + struct saved_node_id_ref_counts *new_snir_p; + NodeIdP arg_node_id_p; + + arg_node_id_p=arg_node_id_list->nidl_node_id; + + new_snir_p=CompAllocType (struct saved_node_id_ref_counts); + new_snir_p->snir_node_id=arg_node_id_p; + new_snir_p->snir_ref_count=arg_node_id_p->nid_refcount; + + new_snir_p->snir_next=snir_p; + snir_p=new_snir_p; + } + + return save_rhs_node_id_ref_counts (node_p->node_arguments->arg_next->arg_node,node_defs,snir_p,scnirc_hl); + } + case SwitchNode: + { + ArgP arg_p; + + for_l (arg_p,node_p->node_arguments,arg_next){ + NodeP case_node_p; + NodeIdRefCountListP node_id_ref_count_elem_p; + + case_node_p=arg_p->arg_node; + + for_l (node_id_ref_count_elem_p,case_node_p->node_node_id_ref_counts,nrcl_next){ + struct saved_case_node_id_ref_counts *new_scnirc_p; + + new_scnirc_p=CompAllocType (struct saved_case_node_id_ref_counts); + new_scnirc_p->scnir_nrcl=node_id_ref_count_elem_p; + new_scnirc_p->scnir_ref_count=node_id_ref_count_elem_p->nrcl_ref_count; + + new_scnirc_p->scnir_next=NULL; + **scnirc_hl=new_scnirc_p; + *scnirc_hl=&new_scnirc_p->scnir_next; + } + + snir_p=save_rhs_node_id_ref_counts (case_node_p->node_arguments->arg_node,case_node_p->node_node_defs,snir_p,scnirc_hl); + } + break; + } + case GuardNode: + { + while (node_p->node_kind==GuardNode){ + snir_p=save_rhs_node_id_ref_counts (node_p->node_arguments->arg_node,node_defs,snir_p,scnirc_hl); + + node_defs=node_p->node_node_defs; + node_p=node_p->node_arguments->arg_next->arg_node; + } + + return save_rhs_node_id_ref_counts (node_p,node_defs,snir_p,scnirc_hl); + } + case IfNode: + snir_p=save_rhs_node_id_ref_counts (node_p->node_arguments->arg_next->arg_node,node_p->node_then_node_defs,snir_p,scnirc_hl); + snir_p=save_rhs_node_id_ref_counts (node_p->node_arguments->arg_next->arg_next->arg_node,node_p->node_else_node_defs,snir_p,scnirc_hl); + node_p=node_p->node_arguments->arg_node; + break; + } + + for_l (node_def_p,node_defs,def_next) + if (node_def_p->def_id!=NULL){ + struct saved_node_id_ref_counts *new_snir_p; + + new_snir_p=CompAllocType (struct saved_node_id_ref_counts); + new_snir_p->snir_node_id=node_def_p->def_id; + new_snir_p->snir_ref_count=node_def_p->def_id->nid_refcount; + + new_snir_p->snir_next=snir_p; + snir_p=new_snir_p; + + if (node_def_p->def_node->node_kind==TupleSelectorsNode){ + ArgP arg_p; + + for_l (arg_p,node_def_p->def_node->node_arguments,arg_next) + if (arg_p->arg_node->node_kind==NodeIdNode){ + NodeIdP tuple_element_node_id_p; + + tuple_element_node_id_p=arg_p->arg_node->node_node_id; + + new_snir_p=CompAllocType (struct saved_node_id_ref_counts); + new_snir_p->snir_node_id=tuple_element_node_id_p; + new_snir_p->snir_ref_count=tuple_element_node_id_p->nid_refcount; + + new_snir_p->snir_next=snir_p; + snir_p=new_snir_p; + } + } + } + + return snir_p; +} + +void restore_node_id_ref_counts (struct saved_node_id_ref_counts *snir_p,struct saved_case_node_id_ref_counts *scnir_p) +{ + while (snir_p!=NULL){ + snir_p->snir_node_id->nid_refcount=snir_p->snir_ref_count; + snir_p=snir_p->snir_next; + } + + while (scnir_p!=NULL){ + scnir_p->scnir_nrcl->nrcl_ref_count=scnir_p->scnir_ref_count; + scnir_p=scnir_p->scnir_next; + } +} +#endif + +#if TAIL_CALL_MODULO_CONS_OPTIMIZATION +static int tail_call_modulo_cons_call (NodeP node_p,NodeDefP node_defs) +{ + if (node_p->node_kind==NormalNode){ + SymbolP node_symbol_p; + + node_symbol_p=node_p->node_symbol; + if ((node_symbol_p->symb_kind==cons_symb && node_p->node_arity==2) || + (node_symbol_p->symb_kind==definition && node_symbol_p->symb_def->sdef_kind==CONSTRUCTOR && + node_p->node_arity==node_symbol_p->symb_def->sdef_arity)) + { + ArgP arg_p,arg_p2; + + arg_p2=NULL; + for_l (arg_p,node_p->node_arguments,arg_next) + if (arg_p->arg_node->node_kind!=NodeIdNode) + if (arg_p2==NULL) + arg_p2=arg_p; + else + break; + + if (arg_p==NULL){ + if (arg_p2==NULL){ + if (node_defs!=NULL){ + NodeDefP last_node_def_p; + NodeP node_def_node_p; + + last_node_def_p=node_defs; + while (last_node_def_p->def_next!=NULL) + last_node_def_p=last_node_def_p->def_next; + + node_def_node_p=last_node_def_p->def_node; + + if (node_def_node_p!=NULL){ + NodeIdP node_def_id; + + node_def_id=last_node_def_p->def_id; + + if (node_def_node_p->node_kind==FillUniqueNode) + node_def_node_p=node_def_node_p->node_arguments->arg_node; + + if (!(node_def_id->nid_mark & ON_A_CYCLE_MASK) && is_tail_call_module_cons_node (node_def_node_p)) + return 1; + } + } + } else { + NodeP node_p; + + node_p=arg_p2->arg_node; + if (node_p->node_kind==FillUniqueNode) + node_p=node_p->node_arguments->arg_node; + + if (is_tail_call_module_cons_node (node_p)) + return 1; + } + } + } + } + + return 0; +} + +int does_tail_call_modulo_cons (NodeP node_p,NodeDefP node_defs) +{ + switch (node_p->node_kind){ + case SwitchNode: + { + ArgP arg_p; + int r; + + r=0; + for_l (arg_p,node_p->node_arguments,arg_next) + if (does_tail_call_modulo_cons (arg_p->arg_node->node_arguments->arg_node,arg_p->arg_node->node_node_defs)) + r=1; + + return r; + } + case PushNode: + return does_tail_call_modulo_cons (node_p->node_arguments->arg_next->arg_node,node_defs); + case GuardNode: + { + int r; + + r=0; + while (node_p->node_kind==GuardNode){ + if (does_tail_call_modulo_cons (node_p->node_arguments->arg_node,node_defs)) + r=1; + + node_defs=node_p->node_node_defs; + node_p=node_p->node_arguments->arg_next->arg_node; + } + + if (does_tail_call_modulo_cons (node_p,node_defs)) + r=1; + + return r; + } + case IfNode: + { + int r; + ArgP then_arg_p; + NodeP else_node_p; + + r=0; + then_arg_p=node_p->node_arguments->arg_next; + + r=does_tail_call_modulo_cons (then_arg_p->arg_node,node_p->node_then_node_defs); + + else_node_p=then_arg_p->arg_next->arg_node; + + if (else_node_p->node_kind==NormalNode && else_node_p->node_symbol->symb_kind==fail_symb) + return r; + + if (does_tail_call_modulo_cons (else_node_p,node_p->node_else_node_defs)) + r=1; + + return r; + } + default: + return tail_call_modulo_cons_call (node_p,node_defs); + } + + return 0; +} +#endif diff --git a/backendC/CleanCompilerSources/codegen3.h b/backendC/CleanCompilerSources/codegen3.h new file mode 100644 index 0000000..69af6b1 --- /dev/null +++ b/backendC/CleanCompilerSources/codegen3.h @@ -0,0 +1,13 @@ + +extern void RedirectResultAndReturn (int asp,int bsp,int aindex,int bindex, + StateS offstate,StateS demstate,int offasize,int offbsize); + +extern int CodeRhsNodeDefs + (Node root_node,NodeDefs defs,int asp,int bsp,struct saved_nid_state **then_or_else,StateS resultstate,struct esc *esc_p, + struct node_id_list_element *a_node_ids,struct node_id_list_element *b_node_ids, + struct node_id_list_element *free_node_ids,int doesnt_fail); + +struct saved_node_id_ref_counts* save_lhs_node_id_ref_counts (NodeP node_p,struct saved_node_id_ref_counts *snir_p); +struct saved_node_id_ref_counts* save_rhs_node_id_ref_counts (NodeP node_p,NodeDefP node_defs, + struct saved_node_id_ref_counts *snir_p,struct saved_case_node_id_ref_counts ***scnirc_h); +void restore_node_id_ref_counts (struct saved_node_id_ref_counts *snir_p,struct saved_case_node_id_ref_counts *scnirc_p); diff --git a/backendC/CleanCompilerSources/codegen_types.h b/backendC/CleanCompilerSources/codegen_types.h new file mode 100644 index 0000000..145d43d --- /dev/null +++ b/backendC/CleanCompilerSources/codegen_types.h @@ -0,0 +1,58 @@ + +#define REUSE_UNIQUE_NODES +#define UPDATE_POP 1 +#define BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH 1 /* added 13-4-1999 */ +#define TAIL_CALL_MODULO_CONS_OPTIMIZATION 1 +#define OPTIMIZE_LAZY_TUPLE_RECURSION 1 + +#define TAIL_CALL_MODULO_TUPLE_CONS_OPTIMIZATION 0 +#undef THUNK_LIFT_SELECTORS + +#define GENERATE_CODE_AGAIN TAIL_CALL_MODULO_CONS_OPTIMIZATION || OPTIMIZE_LAZY_TUPLE_RECURSION + +/* node_id_list: used in PushNode and during code generation */ + +STRUCT (node_id_list_element,NodeIdListElement){ + struct node_id * nidl_node_id; + struct node_id_list_element * nidl_next; +}; + +STRUCT (node_id_ref_count_list,NodeIdRefCountList){ + struct node_id_ref_count_list * nrcl_next; + struct node_id * nrcl_node_id; + int nrcl_ref_count; +}; + +STRUCT (free_unique_node_ids,FreeUniqueNodeIds){ + struct node * fnid_push_node; + int fnid_node_size; + struct free_unique_node_ids * fnid_next; +}; + +STRUCT (ab_node_ids,AbNodeIds){ + struct node_id_list_element * a_node_ids; + struct node_id_list_element * b_node_ids; +#if BUILD_FREE_NODE_ID_LIST_DURING_PATTER_MATCH + struct node_id_list_element * free_node_ids; +#endif +}; + +STRUCT (saved_nid_state,SavedNidState){ + StateS save_state; + NodeId save_node_id; + struct saved_nid_state * save_next; +}; + +typedef struct label { + char *lab_mod; + char *lab_pref; + Bool lab_issymbol; + union{ + char *u_name; + SymbDef u_symbol; + } lab_u; + unsigned lab_post; +} *Label, LabDef; + +#define lab_name lab_u.u_name +#define lab_symbol lab_u.u_symbol diff --git a/backendC/CleanCompilerSources/comparser.h b/backendC/CleanCompilerSources/comparser.h new file mode 100644 index 0000000..0828db8 --- /dev/null +++ b/backendC/CleanCompilerSources/comparser.h @@ -0,0 +1,4 @@ +extern DefMod ParseDefMod (char *name, char *importingModule, char *importingExtension, unsigned importingLine); +extern ImpMod ParseImplMod (char *name); + +extern void InitParser (void); diff --git a/backendC/CleanCompilerSources/comparser_2.c b/backendC/CleanCompilerSources/comparser_2.c new file mode 100644 index 0000000..3a257ae --- /dev/null +++ b/backendC/CleanCompilerSources/comparser_2.c @@ -0,0 +1,130 @@ +/* + Ronny Wichers Schreur + University of Nijmegen +*/ + +# pragma segment comparser +# ifdef THINK_C +# pragma options (!macsbug_names) +# endif + +# undef PRINT_RULES_AFTER_PARSING +# undef STOP_AFTER_PARSING + +# undef H + +# include "types.t" +# include "syntaxtr.t" + +# include "comsupport.h" +# include "scanner.h" +# include "sizes.h" +# include "checker.h" +# include "statesgen.h" +# include "comparser.h" +# include "buildtree.h" +# include "comprehensions.h" +# include "settings.h" +# include "checksupport.h" + +# ifdef PRINT_RULES_AFTER_PARSING +# include "dbprint.h" +# endif + +static void *gSymbIdEnv; + +static IdentP gBasicTypeIdents [Nr_Of_Basic_Types], gIfIdent; + +static SymbolP +NewPredefinedTypeSymbol (SymbKind symbolKind, KeywordKind keyWordKind, IdentP *identPtr) +{ + char *symbolName; + SymbolP symbol; + IdentP ident; + + symbolName = ReservedWords [keyWordKind]; + symbol = NewSymbol (symbolKind); + + ident = PutStringInHashTable (symbolName, TypeSymbolIdTable); + ident->ident_symbol = symbol; + ident->ident_environ= (char*)gSymbIdEnv; + *identPtr = ident; + + return (symbol); +} /* NewPredefinedSymbol */ + +static SymbolP +NewPredefinedSymbol (SymbKind symbolKind, KeywordKind keyWordKind, IdentP *identPtr) +{ + char *symbolName; + SymbolP symbol; + IdentP ident; + + symbolName = ReservedWords [keyWordKind]; + symbol = NewSymbol (symbolKind); + + ident = PutStringInHashTable (symbolName, SymbolIdTable); + ident->ident_symbol = symbol; + ident->ident_environ= (char*)gSymbIdEnv; + *identPtr = ident; + + return (symbol); +} /* NewPredefinedSymbol */ + +void +InitParser (void) +{ + int i; + + ScanInitialise (); +#ifndef CLEAN2 + MakeErrorStructures (); + + gCurrentContext = NULL; + gNodeIdEnv = (char *) 1; + /* RWS, hack to avoid name space confusion bug */ + gAttributeEnv = (char *) (1 << 16); + + gAttrVarAdmin = NULL; +#endif + for (i = 0; i < MaxNodeArity; i++) + { SelectSymbols [i] = NULL; + TupleTypeSymbols [i] = NULL; + } + + BasicTypeSymbols [int_type] = NewPredefinedTypeSymbol (int_type, intsym, & gBasicTypeIdents [int_type]); + BasicTypeSymbols [bool_type] = NewPredefinedTypeSymbol (bool_type, boolsym, & gBasicTypeIdents [bool_type]); + BasicTypeSymbols [char_type] = NewPredefinedTypeSymbol (char_type, charsym, & gBasicTypeIdents [char_type]); + BasicTypeSymbols [string_type] = NewPredefinedTypeSymbol (string_type, stringsym, & gBasicTypeIdents [string_type]); + BasicTypeSymbols [real_type] = NewPredefinedTypeSymbol (real_type, realsym, & gBasicTypeIdents [real_type]); + BasicTypeSymbols [file_type] = NewPredefinedTypeSymbol (file_type, filesym, & gBasicTypeIdents [file_type]); + BasicTypeSymbols [world_type] = NewPredefinedTypeSymbol (world_type, worldsym, & gBasicTypeIdents [world_type]); + + ArraySymbols [LazyArrayInstance] = NewPredefinedTypeSymbol (array_type, arraysym, &gArrayIdents [LazyArrayInstance]); + ArraySymbols [StrictArrayInstance] = NewPredefinedTypeSymbol (strict_array_type, strictarraysym, &gArrayIdents [StrictArrayInstance]); + ArraySymbols [UnboxedArrayInstance] = NewPredefinedTypeSymbol (unboxed_array_type, unboxedarraysym, &gArrayIdents [UnboxedArrayInstance]); + + BasicTypeSymbols [procid_type] = NewPredefinedTypeSymbol (procid_type, procidsym, & gBasicTypeIdents [procid_type]); + + IfSymbol = NewPredefinedSymbol (if_symb, ifsym, &gIfIdent); + BasicTypeSymbols [redid_type] = NewPredefinedTypeSymbol (procid_type, procidsym, & gBasicTypeIdents [redid_type]); + ApplyTypeSymbol = NewSymbol (fun_type); + + TrueSymbol = NewSymbol (bool_denot); + TrueSymbol->symb_bool = True; + FalseSymbol = NewSymbol (bool_denot); + FalseSymbol->symb_bool = False; + + TupleSymbol = NewSymbol (tuple_symb); + ListSymbol = NewSymbol (list_type); + ConsSymbol = NewSymbol (cons_symb); + NilSymbol = NewSymbol (nil_symb); + ApplySymbol = NewSymbol (apply_symb); + FailSymbol = NewSymbol (fail_symb); + AllSymbol = NewSymbol (all_symb); + EmptyTypeSymbol = NewSymbol (empty_type); + + InitialiseEnumFunctionIds (); + + clear_p_at_node_tree(); +} /* InitParser */ diff --git a/backendC/CleanCompilerSources/compiledefines.h b/backendC/CleanCompilerSources/compiledefines.h new file mode 100644 index 0000000..2157bb8 --- /dev/null +++ b/backendC/CleanCompilerSources/compiledefines.h @@ -0,0 +1,19 @@ + +#define CLEAN2 + +#define SHORT_CLASS_NAMES +#define U_RECORD_SELECTORS 1 + +#define REMOVE_UNUSED_FUNCTIONS +#define OPTIMISE_STRICT_RHS_SELECTORS + +#define STORE_STRICT_CALL_NODES 1 +#define UNBOXED_CLOSURES 1 +#undef OBSERVE_ARRAY_SELECTS_IN_PATTERN + +#define ABSTRACT_OBJECT 1 /* bug fix */ + +#define TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +#define IMPORT_OBJ_AND_LIB 1 + +#define WRITE_DCL_MODIFICATION_TIME 1 diff --git a/backendC/CleanCompilerSources/compiler.c b/backendC/CleanCompilerSources/compiler.c new file mode 100644 index 0000000..fe3125f --- /dev/null +++ b/backendC/CleanCompilerSources/compiler.c @@ -0,0 +1,141 @@ + +#undef PROFILE + +#include "system.h" + +#include "settings.h" +#include "syntaxtr.t" +#include "comsupport.h" +#include "checker.h" +#include "compiler.h" +#include "codegen_types.h" +#include "codegen.h" +#include "statesgen.h" + +#ifdef _PROFILE_ +/* FROM profile IMPORT */ + extern DumpProfile (); +#endif + +#ifdef _STANDALONE_ +char *CurrentFilePath; +#endif + +static Bool RemoveExtension (char *name) +{ + int len; + + len = strlen (name); + + if (len>=4 && name[len-4]=='.'){ + name [len-4] = '\0'; + return True; + } else + return False; +} + +static void AddExtension (char *name) +{ + name [strlen (name)] = '.'; +} + +static void ExecCompiler (char *fname,char *output_file_name) +{ + ImpMod imod; + +/* PrintVersion (); */ + + if (fname){ +#ifdef _STANDALONE_ + Bool hadext; + char *p; + + CurrentFilePath = fname; + + hadext = RemoveExtension (CurrentFilePath); + + for (p=CurrentFilePath; *p!='\0'; ++p) +# if defined (_MAC_) || defined (_MACUSER_) + if (*p == ':') +# elif defined (_WINDOWS_) || defined (OS2) + if (*p == '\\') +# else + if (*p == '/') +# endif + fname = p+1; +#endif + + /* Parse and check */ + if (! (imod = ParseAndCheckImplementationModule (fname))) + return; + + /* Code generation */ + if (output_file_name!=NULL){ + Bool hadext; + + hadext = RemoveExtension (output_file_name); + +#ifdef DUMP_AND_RESTORE + if (gDumpAndRestore){ + if (!CompilerError) + CoclBackEnd (imod, output_file_name); + } else +#endif + CodeGeneration (imod,output_file_name); + + if (hadext) + AddExtension (output_file_name); + } else +#ifdef DUMP_AND_RESTORE + if (gDumpAndRestore){ + if (!CompilerError) + CoclBackEnd (imod, fname); + } else +#endif + CodeGeneration (imod, fname); + +#ifdef _STANDALONE_ + if (hadext) + AddExtension (CurrentFilePath); +#endif + } else + CmdError ("No source file specified"); +} + +#ifdef PROFILE +#include "profile.h" +#endif + +#ifdef _MAC_ + extern void GetInitialPathList (void); +#endif + +Bool Compile (char *fname,char *output_file_name) +{ +#ifdef PROFILE + InitProfile (900,300); + freopen ("Profile","w",stdout); +#endif + +#ifdef _MAC_ + GetInitialPathList(); +#endif + + if (setjmp (ExitEnv)==0){ + InitCompiler (); +#ifdef _MACUSER_ + ExecCompiler (fname,NULL); +#else + ExecCompiler (fname,output_file_name); +#endif + } else + CompilerError = True; + + ExitCompiler (); + +#ifdef PROFILE + DumpProfile(); +#endif + + return ! CompilerError; +} diff --git a/backendC/CleanCompilerSources/compiler.h b/backendC/CleanCompilerSources/compiler.h new file mode 100644 index 0000000..98424ef --- /dev/null +++ b/backendC/CleanCompilerSources/compiler.h @@ -0,0 +1,5 @@ + +extern Bool Compile (char *fname,char *ouput_file_name); +#ifdef _MAC_ + extern void FreePathList (void); +#endif diff --git a/backendC/CleanCompilerSources/comprehensions.h b/backendC/CleanCompilerSources/comprehensions.h new file mode 100644 index 0000000..9bb7c9c --- /dev/null +++ b/backendC/CleanCompilerSources/comprehensions.h @@ -0,0 +1,42 @@ +#define FASTER_ARRAY_COMPREHENSIONS + +typedef enum { + kGeneratorList,kGeneratorFrom,kGeneratorFromTo,kGeneratorFromThen,kGeneratorFromThenTo,kGeneratorArrayOnly +} GeneratorKind; + +extern int gGeneratorNumber; +extern int gListFunctionNumber; + +STRUCT (generator, Generator) +{ + GeneratorKind gen_kind; + Bool gen_arrayCombined; + int gen_array_index_n; + NodeP gen_array; + NodeP *gen_array_size_node_h; + NodeP gen_pattern; + union + { + NodeP val_list; + struct + { + ArgP fbt_from; + ArgP fbt_by; + ArgP fbt_to; + } val_fbt; + } val; +}; + +# define gen_list val.val_list +# define gen_from val.val_fbt.fbt_from +# define gen_by val.val_fbt.fbt_by +# define gen_to val.val_fbt.fbt_to + +# define kMaxParallelGenerators 16 + +extern unsigned ConvertGenerators (unsigned n, GeneratorS generators[],IdentP updatedArrayIdent,NodeP *arrayNodePtr, + int *const array_index_generator_n_p,NodeP result_node_p,NodeP guard_p,ScopeP scope); +extern void GenerateComprehensionFunction (ImpRules impRule, unsigned n, GeneratorS djennereeturs [], NodeP guard, + NodeP result_node_p,int array_index_generator_n, + NodeP *begin, NodeP end, NodeP **successP, unsigned line, NodeP *array); +extern NodeP ComputeNewArrayLength (unsigned n, GeneratorS generators [], ScopeP scope); diff --git a/backendC/CleanCompilerSources/comsupport.c b/backendC/CleanCompilerSources/comsupport.c new file mode 100644 index 0000000..a3e5201 --- /dev/null +++ b/backendC/CleanCompilerSources/comsupport.c @@ -0,0 +1,693 @@ +/* + (Concurrent) Clean Compiler: Support + ======================================== + + This module contains all the compiler supporting routines, + such as: the storage administration and the error handling + routines and some global variables containing the compiler + settings. + At the end of this module the version number of the compiler + is administered. + + Author: Sjaak Smetsers + At: University of Nijmegen, department of computing science + Version: 1.0 +*/ + +#include "system.h" +#include "sizes.h" +#include "cmdline.h" + +#include "settings.h" +#include "syntaxtr.t" +#include "comsupport.h" +#include "scanner.h" +#include "buildtree.h" +#include "comparser.h" +#include "checker.h" +#include "typechecker.h" +#include "statesgen.h" +#include "codegen_types.h" +#include "codegen1.h" +#include "codegen2.h" +#include "instructions.h" +#include "overloading.h" +#include "checksupport.h" +#include "dbprint.h" + +extern int VERSION; + +/* 'CurrentModule' contains the name of the module that is currently under examination. */ + +char *CurrentPhase, *CurrentModule, *CurrentExt; +unsigned CurrentLine; +Symbol CurrentSymbol; +Bool CompilerError; + +jmp_buf ExitEnv; + +char *OutName = (char *) NIL; +char *InName; + +/* The storage administration. */ + +unsigned long NrOfBytes; +unsigned NrOfLargeBlocks; + +static char *StartStorage, *FirstBlock, *LastBlock, *NextFreeMem; + +static void *AllocLarge (SizeT size) +{ + char **newblock; + + size = ReSize (size); + if ((newblock = (char **) Alloc ((unsigned long) size + SizeOf (char *), SizeOf (char)))!=NULL){ + *newblock = FirstBlock; + FirstBlock = (char *) newblock++; + NrOfBytes += size; + return (char *) newblock; + } else { + FatalCompError ("comsupport", "AllocLarge", "Insufficient Memory"); + + return (void *) Null; + } +} + +static Bool InitStorageFlag = True; + +void InitStorage (void) +{ + if (InitStorageFlag){ + char **newblock; + + if ((newblock = (char **) Alloc ((unsigned long) (MemBlockSize + (SizeT) (SizeOf (char *))), SizeOf (char)))!=NULL){ + *newblock = (char *) NIL; + StartStorage = LastBlock = FirstBlock = (char *) newblock; + NextFreeMem = SizeOf(char*)+(char*)newblock; + InitStorageFlag = False; + NrOfBytes = (unsigned long) (MemBlockSize + (SizeT) (SizeOf (char *))); + NrOfLargeBlocks = 0; + } else + FatalCompError ("comsupport", "InitStorage","Insufficient Memory"); + } +} + +#undef FILL_ALLOCATED_MEMORY_WITH_GARBAGE + +#ifdef FILL_ALLOCATED_MEMORY_WITH_GARBAGE +static unsigned char g_next_garbage_byte=0; +#endif + +void *CompAlloc (SizeT size) +{ + char *new_block; + + size = ReSize (size); + + if (size > KBYTE){ + NrOfLargeBlocks++; +#ifdef FILL_ALLOCATED_MEMORY_WITH_GARBAGE + { + void *m; + unsigned char *p,next_garbage_byte; + int i; + + m=AllocLarge (size); + + i=size; + p=m; + + next_garbage_byte=g_next_garbage_byte; + while (--i>=0) + *p++ = next_garbage_byte++; + g_next_garbage_byte=next_garbage_byte; + + return m; + } +#else + return AllocLarge (size); +#endif + } + + new_block=NextFreeMem; + + if (new_block-LastBlock+size > MemBlockSize+SizeOf(char*)){ + char **newblock; + + newblock = (char **) Alloc ((unsigned long) + (MemBlockSize + (SizeT) (sizeof (char *))), SizeOf (char)); + + if (newblock!=NULL){ + *((char **) LastBlock) = (char *) newblock; + LastBlock = (char *) newblock; + + *newblock = (char *) NIL; + new_block=LastBlock+SizeOf(char*); + + NrOfBytes += (unsigned long) (MemBlockSize + (SizeT) (SizeOf (char *))); + } else { +/* FPrintF (StdError,"Allocated %ld bytes\n",(long)NrOfBytes); */ + FatalCompError ("comsupport", "CompAlloc", "Insufficient Memory"); + } + } + + NextFreeMem = new_block+size; + +#ifdef FILL_ALLOCATED_MEMORY_WITH_GARBAGE + { + unsigned char *p,next_garbage_byte; + int i; + + i=size; + p=(unsigned char*)new_block; + + next_garbage_byte=g_next_garbage_byte; + while (--i>=0) + *p++ = next_garbage_byte++; + g_next_garbage_byte=next_garbage_byte; + } +#endif + + return (void *) new_block; +} + +static HeapDescr FreeHeapDescrList; + +HeapDescr TH_New (void) +{ + HeapDescr new_hd; + if (FreeHeapDescrList) + { new_hd = FreeHeapDescrList; + FreeHeapDescrList = FreeHeapDescrList -> hd_next; + } + else + new_hd = CompAllocType (struct heap_descr); + new_hd -> hd_start = NULL; + return new_hd; + +} /* TH_New */ + +void TH_Free (HeapDescr hd) +{ + char *next_block; + char *currentblock = hd -> hd_start; + + while (currentblock != NULL) + { next_block = *(char**) currentblock; + + Free (currentblock); + currentblock = next_block; + } + hd -> hd_next = FreeHeapDescrList; + FreeHeapDescrList = hd; + +} /* TH_Free */ + +void TH_Reset (HeapDescr hd) +{ + if (hd -> hd_start) + hd -> hd_end = hd -> hd_start; + else + { char **newblock = (char **) Alloc (TH_BlockSize + SizeOf (char *), SizeOf(char)); + + if (newblock == NULL){ +/* FPrintF (StdError,"Allocated %ld bytes\n",(long)NrOfBytes); */ + FatalCompError ("comsupport","TH_Reset","Insufficient Memory"); + } + *newblock = (char *) NIL; + hd -> hd_end = hd -> hd_start = (char *) newblock; + } + hd -> hd_free = hd -> hd_start + SizeOf (char *); + +} /* TH_Reset */ + +void *TH_Alloc (HeapDescr hd, SizeT size) +{ + if (size > 0){ + char *memory_block; + + size = ReSize (size); /* word allignment */ + + if (size > TH_BlockSize) /* too large to be handled by the temporary administration */ + return CompAlloc (size); + else if (hd -> hd_free + size > hd -> hd_end + (TH_BlockSize + SizeOf (char *))) + { + /* the current block if full so a new one has to be allocated */ + + if (*((char**) hd -> hd_end) == NULL) + { + char *new_block; + + /* the reference to the next heap block is NIL which implies that + a new block has to be allocated in the Memory of the compiler */ + + new_block = (char*)Alloc (TH_BlockSize + SizeOf (char *), SizeOf (char)); + if (new_block == NULL) + { +/* FPrintF (StdError,"Allocated %ld bytes\n",(long)NrOfBytes); + { + int n_blocks; + char *currentblock; + + n_blocks=0; + + for (currentblock=hd->hd_start; currentblock!=NULL; currentblock = *(char**) currentblock) + ++n_blocks; + + FPrintF (StdError,"Allocated %d blocks,%ld bytes\n",n_blocks,(long)n_blocks*(TH_BlockSize+SizeOf (char*))); + } +*/ + TH_Free (hd); + FatalCompError ("comsupport","TH_Alloc","Insufficient Memory"); + } + + *((char**) hd -> hd_end) = new_block; + hd -> hd_end = *((char **) hd -> hd_end); + *((char**) hd -> hd_end) = NULL; + } + else + hd -> hd_end = *((char **) hd -> hd_end); + + memory_block = hd -> hd_end + SizeOf(char*); + } + else + memory_block = hd -> hd_free; + + hd -> hd_free = memory_block + size; + + return memory_block; + } + else + return NULL; +} + +extern Bool CS_MemoryCheck (void * ptr); + +Bool CS_MemoryCheck (void * ptr) +{ + return (char *) ptr > StartStorage && (char *) ptr <= LastBlock + MemBlockSize; +} + +extern void finish_strictness_analysis (void); + +void CompFree (void) +{ + if (! InitStorageFlag){ + char *block; + + for (block = FirstBlock; block; ){ + char *next_block; + + next_block=*((char **) block); + Free (block); + block=next_block; + } + + finish_strictness_analysis(); + + InitStorageFlag = True; + } +} + +/* The environment to leave the compiler if a fatal error occurs */ + +void FatalCompError (char *mod, char *proc, char *mess) +{ + FPrintF (StdError,"Fatal Error in %s:%s \"%s\"\n", mod, proc, mess); + if (OpenedFile){ + if (ABCFileName){ + CompilerError = True; + CloseABCFile (ABCFileName); + } else + FClose (OpenedFile); + OpenedFile = (File) NIL; + } +#ifdef CLEAN2 + exit (1); +#else + longjmp (ExitEnv, 1); +#endif +} + +void PrintSymbol (Symbol symbol, File file) +{ + Ident symb_id; + unsigned line_nr; + + switch (symbol -> symb_kind) + { + case newsymbol: + case instance_symb: + symb_id = symbol -> symb_ident; + line_nr = 0; + break; + case definition: + symb_id = symbol -> symb_def -> sdef_ident; + line_nr = symbol -> symb_def -> sdef_line; + break; + case int_denot: + FPutS (symbol->symb_int, file); + return; + case bool_denot: + FPutS (symbol->symb_bool ? ReservedWords [truesym] : ReservedWords [falsesym], file); + return; + case char_denot: + FPutS (symbol->symb_char, file); + return; + case string_denot: + FPutS (symbol->symb_string, file); + return; + case real_denot: + FPutS (symbol->symb_real, file); + return; + case tuple_symb: + FPutS (TupleId -> ident_name, file); + return; + case cons_symb: + FPutS (ConsId -> ident_name, file); + return; + case nil_symb: + FPutS (NilId -> ident_name, file); + return; + case select_symb: + FPutS (SelectId -> ident_name, file); + return; + case apply_symb: + FPutS (ApplyId -> ident_name, file); + return; + case if_symb: + FPutS (IfId -> ident_name, file); + return; + case fail_symb: + FPutS (FailId -> ident_name, file); + return; + default: + FPutS (ConvertSymbolKindToString ((SymbKind)symbol -> symb_kind), file); + return; + } + + PrintSymbolOfIdent (symb_id, line_nr, file); + +} /* PrintSymbol */ + +#include <stdarg.h> + +static char *FindFormatSpecifier (char * format_string) +{ + for (; *format_string != '\0' && *format_string != '%'; format_string++) + ; + return format_string; + +} + +#ifdef GNU_C +void StaticMessage (Bool error, char *symbol_format1, char *message_format1, ...) +{ + char *format, format_spec; + char symbol_format [256], message_format [256]; + + va_list ap; + + strcpy (symbol_format, symbol_format1); + strcpy (message_format, message_format1); + + va_start (ap, message_format1); + +#else + +void StaticMessage (Bool error, char *symbol_format, char *message_format, ...) +{ + char *format, format_spec; + + va_list ap; + va_start (ap, message_format); + +#endif + + if (! (error || DoWarning)) + return; + +#ifdef MAKE_MPW_TOOL + FPutS ("### ",StdError); +#endif + + if (CurrentPhase){ + FPutS (CurrentPhase, StdError); + FPutS (error ? " error [" : " warning [", StdError); + } else + FPutS (error ? "Error [" : "Warning [", StdError); + +#ifdef MAKE_MPW_TOOL + FPutS ("File ",StdError); +#endif + + FPutS (CurrentModule, StdError); + FPutS (CurrentExt, StdError); + + if (CurrentLine > 0){ +#ifdef MAKE_MPW_TOOL + FPrintF (StdError, "; Line %u", CurrentLine); +#else + FPrintF (StdError, ",%u", CurrentLine); +#endif + } + +#ifdef MAKE_MPW_TOOL + FPutS ("] ", StdError); +#else + FPutC (',', StdError); +#endif + + for (format = symbol_format; ;) + { char *tail_format = FindFormatSpecifier (format); + + if (*tail_format == '\0') + { FPutS (format, StdError); + break; + } + else + { *tail_format = '\0'; + FPutS (format, StdError); + *tail_format = '%'; + format_spec = * (++tail_format); + + if (format_spec == '\0') + { FPutC ('%', StdError); + break; + } + else + { switch (format_spec) + { + case 's': + { char * message = va_arg (ap, char *); + if (message != NULL) + FPutS (message, StdError); + break; + } + case 'D': + { + SymbDef def = va_arg (ap, SymbDef); + PrintSymbolOfIdent (def->sdef_ident, def->sdef_line, StdError); + break; + } + case 'S': + PrintSymbol (va_arg (ap, Symbol), StdError); + break; + default: + FPutC ('%', StdError); + FPutC (format_spec, StdError); + break; + } + format = ++tail_format; + } + } + } + +#ifdef MAKE_MPW_TOOL + FPutS (": ", StdError); +#else + FPutS ("]: ", StdError); +#endif + + for (format = message_format; ;) + { char *tail_format = FindFormatSpecifier (format); + + if (*tail_format == '\0') + { FPutS (format, StdError); + break; + } + else + { *tail_format = '\0'; + FPutS (format, StdError); + *tail_format = '%'; + format_spec = * (++tail_format); + + if (format_spec == '\0') + { FPutC ('%', StdError); + break; + } + else + { switch (format_spec) + { + case 's': + { char * message = va_arg (ap, char *); + if (message != NULL) + FPutS (message, StdError); + break; + } + case 'd': + { int nr = va_arg (ap, int); + FPrintF (StdError, "%d", nr); + break; + } + case 'S': + PrintSymbol (va_arg (ap, Symbol), StdError); + break; + case 'N': + { Node node = va_arg (ap, Node); + int arg_nr = va_arg (ap, int); + PrintNodeSymbol (node, arg_nr, StdError); + break; + } + case 'T': + PrintTCType (va_arg (ap, struct type_cell *),NULL); + break; + case 'U': + { + struct type_cell *type,*sub_type; + + type=va_arg (ap, struct type_cell *); + sub_type=va_arg (ap, struct type_cell *); + PrintTCType (type,sub_type); + break; + } + default: + FPutC ('%', StdError); + FPutC (format_spec, StdError); + break; + } + format = ++tail_format; + } + } + } + + FPutC ('\n', StdError); + + va_end (ap); + + if (error) + CompilerError = True; +} + +void Verbose (char *msg) +{ + if (DoVerbose) + FPrintF (StdVerboseL, "%s \"%s%s\"\n", msg, CurrentModule, CurrentExt); +} + +void PrintVersion (void) +{ + if (DoVerbose) + FPrintF (StdVerboseL, "Concurrent Clean Compiler (Version %d.%d)\n", + VERSION / 1000, VERSION % 1000); +} + +static char Init[] = "Compiler initialization"; + +Bool InterruptFlag; +File OpenedFile; + +static void SetInterruptFlag (void) +{ + InterruptFlag = True; +} + +void ExitOnInterrupt (void) +{ + CheckInterrupt (); + if (InterruptFlag){ + if (OpenedFile){ + if (ABCFileName){ + CompilerError = True; + CloseABCFile (ABCFileName); + } else + FClose (OpenedFile); + OpenedFile = (File) NIL; + } +#ifdef _STANDALONE_ + if (InCommandInterpreter) + FPrintF (StdOut, "<interrupt>\n"); +#endif + longjmp (ExitEnv, 1); + } +} + +static void (*oldhandler) (); + +void InitCompiler (void) +{ + InterruptFlag = False; + OpenedFile = (File) NIL; + CompilerError = False; + InName = (char *) NIL; + /* Call all the initialization functions */ + /* InitStorage has to be called first */ + CurrentModule = Init; + CurrentExt = ""; + + FreeHeapDescrList = NULL; + + InitStorage (); + InitScanner (); + InitParser (); + InitChecker (); + InitTypeChecker (); + InitStatesGen (); + InitCoding (); + InitInstructions (); +#ifdef _COMPSTATS_ + InitDB (); +#endif + oldhandler = SetSignal (SetInterruptFlag); + +} /* InitCompiler */ + +void ExitCompiler (void) +{ + CompFree(); + SetSignal (oldhandler); + OutName = (char *) NIL; +} + +#ifdef _DEBUG_ + +void ErrorInCompiler (char *mod, char *proc, char *msg) +{ + if (CurrentModule!=NULL) + FPrintF (StdError,"Error in compiler while compiling %s.icl: Module %s, Function %s, \"%s\"\n",CurrentModule,mod,proc,msg); + else + FPrintF (StdError,"Error in compiler: Module %s, Function %s, \"%s\"\n",mod,proc,msg); + +#ifdef CLEAN2 + exit (1); +#endif +} + +void Assume (Bool cond, char *mod, char *proc) +{ + if (! cond) + ErrorInCompiler (mod, proc, "wrong assumption"); +} + +void AssumeError (char *mod, char *proc) +{ + ErrorInCompiler (mod, proc, "wrong assumption"); +} +#endif + +#if D +void error (void) +{ + printf ("error in compiler\n"); +} +#endif diff --git a/backendC/CleanCompilerSources/comsupport.h b/backendC/CleanCompilerSources/comsupport.h new file mode 100644 index 0000000..4eda41b --- /dev/null +++ b/backendC/CleanCompilerSources/comsupport.h @@ -0,0 +1,77 @@ + +#ifndef _COMSUPPORT_ +#define _COMSUPPORT_ + +#ifndef _THE__TYPES_ +#include "types.t" +#endif + +#ifndef _SYSTEM_ +#include "system.h" +#endif + +#define NoError 0 +#define ErrKind1 1 +#define ErrKind2 2 + +#define MINIMUM(a,b) (((a)<(b)) ? (a) : (b)) +#define MAXIMUM(a,b) (((a)>(b)) ? (a) : (b)) + +extern void StaticMessage (Bool error, char *symbol_format, char *message_format, ...); + +extern void PrintSymbol (struct symbol *symbol,File file); + +extern Bool CompilerError; +extern char *CurrentModule, *CurrentExt, *CurrentPhase, *CompilerVersion; + +extern struct symbol *CurrentSymbol; + +extern char *OutName, *InName; + +extern unsigned CurrentLine; + +extern File OpenedFile; + +extern jmp_buf ExitEnv; + +struct heap_descr { + char * hd_start; + char * hd_end; + char * hd_free; + struct heap_descr * hd_next; +}; + +typedef struct heap_descr * HeapDescr; + +#endif + +#define CompAllocType(t) ((t*)CompAlloc (SizeOf (t))) +#define CompAllocArray(s,t) ((t*)CompAlloc ((s)*SizeOf (t))) +extern void *CompAlloc (SizeT size); +extern void InitStorage (void); +extern void CompFree (void); + +#define TH_AllocType(hd,t) ((t*)TH_Alloc (hd,SizeOf (t))) +#define TH_AllocArray(hd,s,t) ((t*)TH_Alloc (hd,(s)*SizeOf (t))) + +extern void * TH_Alloc (HeapDescr hd, SizeT size); +extern void TH_Reset (HeapDescr hd); +extern void TH_Free (HeapDescr hd); +extern HeapDescr TH_New (void); + +extern Bool ArgParser (int argc, char *argv[]); +extern void FatalCompError (char *mod, char *proc, char *mess); + +extern void Verbose (char *msg); +extern void PrintVersion (void); +extern void InitSettings (void); +extern void ExitOnInterrupt (void); +extern void InitCompiler (void); +extern void ExitCompiler (void); + +#ifdef _DEBUG_ +extern void ErrorInCompiler (char *mod, char *proc, char *msg); +extern void Assume (Bool cond, char *mod, char *proc); +extern void AssumeError (char *mod, char *proc); +#define ifnot(cond) if(!(cond)) +#endif diff --git a/backendC/CleanCompilerSources/db_cmdline.h b/backendC/CleanCompilerSources/db_cmdline.h new file mode 100644 index 0000000..5ae830c --- /dev/null +++ b/backendC/CleanCompilerSources/db_cmdline.h @@ -0,0 +1,29 @@ + +extern void Dump_e (File f, Instruction *instr); +extern void Dump_e2 (File f, Instruction *instr); +extern void Dump_n (File f, Instruction *instr); +extern void Dump_l (File f, Instruction *instr); +extern void Dump_I (File f, Instruction *instr); +extern void Dump_B (File f, Instruction *instr); +extern void Dump_C (File f, Instruction *instr); +extern void Dump_S (File f, Instruction *instr); +extern void Dump_R (File f, Instruction *instr); +extern void Dump_s (File f, Instruction *instr); +extern void Dump_nn (File f, Instruction *instr); +extern void Dump_ln (File f, Instruction *instr); +extern void Dump_sn (File f, Instruction *instr); +extern void Dump_In (File f, Instruction *instr); +extern void Dump_Bn (File f, Instruction *instr); +extern void Dump_Cn (File f, Instruction *instr); +extern void Dump_Sn (File f, Instruction *instr); +extern void Dump_Rn (File f, Instruction *instr); +extern void Dump_nnn (File f, Instruction *instr); +extern void Dump_snn (File f, Instruction *instr); +extern void Dump_nll (File f, Instruction *instr); +extern void Dump_snln (File f, Instruction *instr); +extern void Dump_ccall (File f, Instruction *instr); + + +extern void DebugState (State s); + +/* END of db_cmdline.h" */ diff --git a/backendC/CleanCompilerSources/dbprint.c b/backendC/CleanCompilerSources/dbprint.c new file mode 100644 index 0000000..2e3fc36 --- /dev/null +++ b/backendC/CleanCompilerSources/dbprint.c @@ -0,0 +1,832 @@ + +#include "system.h" +#include "syntaxtr.t" +#include "comsupport.h" +#include "settings.h" +#include "sizes.h" +#include "checker.h" +#include "checksupport.h" +#include "overloading.h" +#include "dbprint.h" +#include "codegen_types.h" + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) + +#define PrintAnnotation(annot) + +#undef PRINT_alt_lifted_node_ids +#undef PRINT_NODE_ID_REF_COUNTS +#define PRINT_ALL_NODE_ID_ADDRESSES +#undef PRINT_NODE_LINE_NUMBERS +#define PRINT_NODE_ID_REF_COUNT + +static void PrintUnaryState (StateKind kind, ObjectKind obj, File file) +{ + switch (kind) + { case OnB: FPutS ("OnB ", file); break; + case OnA: FPutS ("OnA ", file); break; + case StrictOnA: FPutS ("StrictOnA ", file); break; + case SemiStrict: FPutS ("SemiStrict ", file); break; + case StrictRedirection: FPutS ("StrictRedirection ", file); break; + case Parallel: FPutS ("Parallel ", file); break; + case Undefined: FPutS ("Undefined ", file); break; + case UnderEval: FPutS ("UnderEval ", file); break; + } + switch (obj) + { case UnknownObj: FPutS ("???", file); break; + case IntObj: FPutS ("Int ", file); break; + case BoolObj: FPutS ("Bool ", file); break; + case CharObj: FPutS ("Char ", file); break; + case StringObj: FPutS ("String ", file); break; + case RealObj: FPutS ("Real ", file); break; + case FileObj: FPutS ("File ", file); break; + case TupleObj: FPutS ("Tuple ", file); break; + case ListObj: FPutS ("List ", file); break; + case ProcIdObj: FPutS ("ProcId ", file); break; + } +} + +static void PrintState (StateS state, File file) +{ + return; + + if (state.state_arity == 1) + PrintUnaryState (state.state_kind,state.state_object, file); +} + +void DPrintOccurrenceKind (OccurrenceKind kind, File file) +{ + switch (kind) + { case NotUsed: /* FPutS ("NotUsed", file); */ return; + case UniquelyUsed: FPutS ("<U> ", file); return; + case SelectivelyUsed: FPutS ("<S> ", file); return; + case MultiplyUsed: FPutS ("<M> ", file); return; + default: FPutS ("<?> ", file); return; + } + +} + +void DPrintNodeId (NodeId nid, File file) +{ + if (nid){ + if (nid->nid_ident){ + FPrintF (file, "%s",nid->nid_ident->ident_name); +#ifdef PRINT_ALL_NODE_ID_ADDRESSES + FPrintF (file, "@i_%lx", (long) nid); +#endif + } else + FPrintF (file, "i_%lx", (long) nid); + +#ifdef PRINT_NODE_ID_REF_COUNT + FPrintF (file, "<%d>", nid->nid_refcount); +#endif + } else + FPrintF (file," 00000000"); +} + +void DPrintNodeIdS (char *s,NodeId node_id,File file) +{ + FPrintF (file,"%s",s); + DPrintNodeId (node_id,file); + FPrintF (file,"\n"); +} + +static void DPrintTypeVar (TypeVar tv, Node follow, File file) +{ + if (tv){ + if (tv->tv_ident) + FPrintF (file, "%s",tv->tv_ident->ident_name); + else + FPrintF (file, "i_%lx", (long) tv); + FPrintF (file, "<%d>", tv->tv_refcount); + if (follow) + FPutS (" = ", file); + } +} + +static void PrintArgument (Args arg,Bool brackets,int n_leading_spaces,File file) +{ + PrintState (arg->arg_state, file); + + if (arg->arg_node->node_kind==NodeIdNode) + DPrintNodeId (arg->arg_node->node_node_id,file); + else { + /* DPrintOccurrenceKind (arg -> arg_occurrence); */ + PrintRuleNode (arg->arg_node,brackets,n_leading_spaces,file); + } +} + +static void print_spaces (int n_leading_spaces,File file) +{ + int n; + + for (n=0; n<n_leading_spaces; ++n) + FPutC (' ',file); +} + +static void PrintArguments (Args args, char separator, Bool brackets,int n_leading_spaces,File file) +{ + if (args!=NULL){ + PrintArgument (args,brackets,n_leading_spaces,file); + for (args = args -> arg_next; args; args = args -> arg_next){ + FPutC (separator, file); + if (separator=='\n') + print_spaces (n_leading_spaces,file); + PrintArgument (args, brackets,n_leading_spaces,file); + } + } +} + +void PrintRuleNode (Node node,Bool brackets,int n_leading_spaces,File file) +{ +/* + if (IsOnACycle (node -> node_number)) + FPutS ("<C>", file); + PrintState (node -> node_state,file); +*/ + switch (node -> node_kind){ + case NormalNode: + case PrefixNode: + { + Symbol node_symb = node->node_symbol; + + if (node_symb -> symb_kind == tuple_symb){ + FPutC ('(', file); + PrintArguments (node -> node_arguments, ',', False,n_leading_spaces,file); + FPutC (')', file); + } + else if (node_symb -> symb_kind == list_type) + { FPutC ('[', file); + PrintArguments (node -> node_arguments, ',', False,n_leading_spaces,file); + FPutC (']', file); + } + else if (node_symb -> symb_kind == nil_symb) + FPutS ("[]", file); + else if (node_symb -> symb_kind == cons_symb) + { FPutC ('[', file); + PrintArgument (node -> node_arguments, brackets,n_leading_spaces,file); + FPutC (':', file); + PrintArgument (node -> node_arguments -> arg_next, brackets,n_leading_spaces,file); + FPutC (']', file); + } else if (node_symb -> symb_kind==select_symb){ + FPutS ("_sel",file); + FPutC ('0'+node->node_arity,file); + FPutC (' ',file); + PrintArgument (node -> node_arguments,True,n_leading_spaces,file); + } else { + if (brackets && node -> node_arguments) + FPutC ('(', file); + + PrintSymbol (node_symb, file); + +#ifdef PRINT_NODE_LINE_NUMBERS + FPrintF (file,"#%d",node->node_line); +#endif + if (node_symb->symb_kind==definition && node_symb->symb_def->sdef_kind==IMPRULE && + (node_symb->symb_def->sdef_rule->rule_mark & RULE_INTERNAL_FUNCTION_MASK)) + { + FPrintF (file,"_%d",node_symb->symb_def->sdef_number); + } + + if (node -> node_arguments) + { FPutC (' ', file); + PrintArguments (node -> node_arguments,' ', True,n_leading_spaces,file); + if (brackets) + FPutC (')', file); + } + } + break; + } + case SelectorNode: + PrintArgument (node -> node_arguments, True,n_leading_spaces,file); + if (node->node_arity>1){ + FPutC ('!',file); + FPutC ('0'+node->node_arity,file); + } else + FPutC ('.',file); + PrintSymbol (node->node_symbol, file); + break; + case IfNode: + { + Args elsepart, thenpart, condpart; + + condpart = node -> node_arguments; + thenpart = condpart -> arg_next; + elsepart = thenpart -> arg_next; + + if (brackets) + FPutC ('(', file); + + FPutS ("IF ", file); + PrintArgument (condpart, True,n_leading_spaces,file); + + FPutC ('\n',file); + print_spaces (n_leading_spaces+4,file); +#if 1 +# ifdef PRINT_NODE_ID_REF_COUNTS + FPutS ("[ ", file); + { + NodeIdRefCountListP node_id_ref_count_elem; + + for_l (node_id_ref_count_elem,node->node_then_node_id_ref_counts,nrcl_next){ + DPrintNodeId (node_id_ref_count_elem->nrcl_node_id,file); + printf (" %d ",node_id_ref_count_elem->nrcl_ref_count); + } + } + FPutS ("]\n", file); + print_spaces (n_leading_spaces+4,file); +# else + if (node->node_then_strict_node_ids!=NULL){ + StrictNodeIdP strict_node_id; + + FPutS ("let! ", file); + + for_l (strict_node_id,node->node_then_strict_node_ids,snid_next){ + DPrintNodeId (strict_node_id->snid_node_id,file); + FPutS ("; ",file); + } + FPutC ('\n',file); + print_spaces (n_leading_spaces+4,file); + } +# endif +#endif + PrintArgument (thenpart, True,n_leading_spaces+4,file); + + if (node->node_then_node_defs!=NULL){ + FPutC ('\n',file); + print_spaces (n_leading_spaces+4,file); + FPutS ("{\n",file); + PrintNodeDefs (node->node_then_node_defs,n_leading_spaces+8,file); + print_spaces (n_leading_spaces+4,file); + FPutC ('}', file); + } + + FPutC ('\n',file); + print_spaces (n_leading_spaces+4,file); + +#if 1 +# ifdef PRINT_NODE_ID_REF_COUNTS + FPutS ("[ ", file); + { + NodeIdRefCountListP node_id_ref_count_elem; + + for_l (node_id_ref_count_elem,node->node_else_node_id_ref_counts,nrcl_next){ + DPrintNodeId (node_id_ref_count_elem->nrcl_node_id,file); + printf (" %d ",node_id_ref_count_elem->nrcl_ref_count); + } + } + FPutS ("]\n",file); + print_spaces (n_leading_spaces+4,file); +# else + if (node->node_else_strict_node_ids!=NULL){ + StrictNodeIdP strict_node_id; + + FPutS ("let! ", file); + + for (strict_node_id=node->node_else_strict_node_ids; strict_node_id!=NULL; strict_node_id=strict_node_id->snid_next){ + DPrintNodeId (strict_node_id->snid_node_id,file); + FPutS ("; ",file); + } + FPutC ('\n',file); + print_spaces (n_leading_spaces+4,file); + } +# endif +#endif + + PrintArgument (elsepart, True,n_leading_spaces+4,file); + + if (node->node_else_node_defs!=NULL){ + FPutC ('\n', file); + print_spaces (n_leading_spaces+4,file); + FPutS ("{\n",file); + PrintNodeDefs (node->node_else_node_defs,n_leading_spaces+8,file); + print_spaces (n_leading_spaces+4,file); + FPutS ("}\n", file); + print_spaces (n_leading_spaces,file); + } + + if (brackets) + FPutC (')', file); + break; + } + case NodeIdNode: + { + NodeId node_id; + + node_id=node->node_node_id; + + if (node_id->nid_ident){ + FPrintF (file, " %s<%d>",node_id->nid_ident->ident_name,node_id->nid_refcount); +#ifdef PRINT_ALL_NODE_ID_ADDRESSES + FPrintF (file, " i_%lx",(long) node_id); +#endif + } else + FPrintF (file, " i_%lx<%d>",(long) node_id,node_id->nid_refcount); + break; + } + case RecordNode: + if (brackets && node -> node_arguments) + FPutC ('(', file); + PrintSymbol (node->node_symbol, file); + if (node -> node_arguments){ + FPutC (' ', file); + PrintArguments (node -> node_arguments,' ', True,n_leading_spaces,file); + if (brackets) + FPutC (')', file); + } + break; + case IdentNode: + if (brackets && node -> node_arguments) + FPutC ('(', file); + + FPutC ('\"',file); + FPutS (node->node_ident->ident_name, file); + FPutC ('\"',file); + + if (node -> node_arguments){ + FPutC (' ', file); + PrintArguments (node -> node_arguments,' ', True,n_leading_spaces,file); + if (brackets) + FPutC (')', file); + } + break; + case UpdateNode: + { Args field = node -> node_arguments; + + FPutC ('{', file); + + PrintArgument (field, False,n_leading_spaces,file); + FPutS (" & ", file); + field = field -> arg_next; + PrintArgument (field, False,n_leading_spaces,file); + for (field = field -> arg_next; field; field = field -> arg_next) + { FPutC (',', file); + PrintArgument (field, False,n_leading_spaces,file); + } + + FPutC ('}', file); + break; + } + case MatchNode: + { + FPutS ("Match ",file); + PrintSymbol (node->node_symbol,file); + FPutC (' ',file); + PrintArgument (node->node_arguments,False,n_leading_spaces,file); + break; + } + case ApplyNode: + { + FPutS ("Apply ",file); + PrintRuleNode (node->node_node, False,n_leading_spaces,file); + FPutC (' ',file); + PrintArgument (node->node_arguments,False,n_leading_spaces,file); + break; + } + case SwitchNode: + FPutS ("Switch ",file); + DPrintNodeId (node->node_node_id,file); + FPutC ('\n',file); + print_spaces (n_leading_spaces,file); + PrintArguments (node->node_arguments,'\n',True,n_leading_spaces,file); + break; + case CaseNode: + FPutS ("Case: [ ",file); + { + NodeIdRefCountListP node_id_ref_count_elem; + + for_l (node_id_ref_count_elem,node->node_node_id_ref_counts,nrcl_next){ + DPrintNodeId (node_id_ref_count_elem->nrcl_node_id,file); + printf (" %d ",node_id_ref_count_elem->nrcl_ref_count); + } + } + FPutS ("]\n",file); + print_spaces (n_leading_spaces+4,file); + +#if 0 +# ifndef PRINT_NODE_ID_REF_COUNTS + if (node->node_strict_node_ids!=NULL){ + StrictNodeIdP strict_node_id; + + FPutS ("let! ", file); + + for_l (strict_node_id,node->node_strict_node_ids,snid_next){ + if (strict_node_id->snid_mark & STRICT_NODE_ID_IDENT_MASK){ + FPrintF (file, " %s",strict_node_id->snid_ident->ident_name); + } else { + DPrintNodeId (strict_node_id->snid_node_id,file); + FPutS ("; ",file); + } + } + FPutC ('\n',file); + print_spaces (n_leading_spaces+4,file); + } +# endif +#endif + PrintArgument (node->node_arguments,False,n_leading_spaces+4,file); + + if (node->node_node_defs!=NULL){ + FPutC ('\n', file); + print_spaces (n_leading_spaces,file); + FPutS ("{\n",file); + PrintNodeDefs (node->node_node_defs,n_leading_spaces+4,file); + print_spaces (n_leading_spaces,file); + FPutS ("}\n", file); + print_spaces (n_leading_spaces,file); + } + + break; + case DefaultNode: + FPutS ("Default: [ ",file); + { + NodeIdRefCountListP node_id_ref_count_elem; + + for_l (node_id_ref_count_elem,node->node_node_id_ref_counts,nrcl_next){ + DPrintNodeId (node_id_ref_count_elem->nrcl_node_id,file); + printf (" %d ",node_id_ref_count_elem->nrcl_ref_count); + } + } + FPutS ("]\n",file); + print_spaces (n_leading_spaces+4,file); + +#if 0 +# ifndef PRINT_NODE_ID_REF_COUNTS + if (node->node_strict_node_ids!=NULL){ + StrictNodeIdP strict_node_id; + + FPutS ("let! ", file); + + for_l (strict_node_id,node->node_strict_node_ids,snid_next){ + if (strict_node_id->snid_mark & STRICT_NODE_ID_IDENT_MASK){ + FPrintF (file, " %s",strict_node_id->snid_ident->ident_name); + } else { + DPrintNodeId (strict_node_id->snid_node_id,file); + FPutS ("; ",file); + } + } + FPutC ('\n',file); + print_spaces (n_leading_spaces+4,file); + } +# endif +#endif + PrintArgument (node->node_arguments,False,n_leading_spaces+4,file); + + if (node->node_node_defs!=NULL){ + FPutC ('\n', file); + print_spaces (n_leading_spaces,file); + FPutS ("{\n",file); + PrintNodeDefs (node->node_node_defs,n_leading_spaces+4,file); + print_spaces (n_leading_spaces,file); + FPutS ("}\n", file); + print_spaces (n_leading_spaces,file); + } + break; + case PushNode: + { + NodeIdListElementP node_id_list; + + FPutS ("Push ",file); + DPrintNodeId (node->node_arguments->arg_node->node_node_id,file); + FPutS ("[",file); + for_l (node_id_list,node->node_node_ids,nidl_next){ + DPrintNodeId (node_id_list->nidl_node_id,file); + if (node_id_list->nidl_next!=NULL) + FPutC (' ',file); + } + FPutS ("]",file); + FPutC ('\n',file); + print_spaces (n_leading_spaces,file); + PrintArgument (node->node_arguments->arg_next,True,n_leading_spaces,file); + break; + } + case GuardNode: + FPutS ("Guard ",file); + PrintArguments (node->node_arguments,'\n',True,n_leading_spaces,file); + break; + case TupleSelectorsNode: + FPutS ("TupleSelectors (",file); + PrintArguments (node->node_arguments,',',True,n_leading_spaces,file); + FPutS (") = ",file); + PrintRuleNode (node->node_node,True,n_leading_spaces,file); + break; + case ScopeNode: + FPutS ("ScopeNode ",file); + PrintRuleNode (node->node_node,True,n_leading_spaces,file); + if (node->node_arguments!=NULL){ + FPutS (" ScopeNodeArguments ",file); + PrintArguments (node->node_arguments,' ',True,n_leading_spaces,file); + } + break; + case FillUniqueNode: + FPutS ("FillUniqueNode ",file); + DPrintNodeId (node->node_node->node_arguments->arg_node->node_node_id,file); + FPutC (' ',file); + PrintArguments (node->node_arguments,' ',True,n_leading_spaces,file); + break; + default: + FPutC ('?',file); + FPrintF (file,"%d",(int)node->node_kind); + } +} + +void PrintNodeDef (NodeDefP def_p,int n_leading_spaces,File file) +{ + int n; + + /* FPrintF (file, "%d: ", (int) def_p->def_number); */ + + for (n=n_leading_spaces; n>0; --n) + FPutC (' ',file); + +/* if (def_p->def_has_lhs_pattern) + PrintRuleNode (def_p->def_pattern,False,n_leading_spaces,file); + else +*/ + DPrintNodeId (def_p -> def_id, file); + + if (def_p -> def_node){ + FPutS (" = ", file); + PrintRuleNode (def_p->def_node, False,n_leading_spaces,file); + } + + FPutS ("\n",file); +} + +void PrintNodeDefs (NodeDefs defs,int n_leading_spaces,File file) +{ + for ( ; defs!=NULL; defs=defs->def_next) + PrintNodeDef (defs,n_leading_spaces,file); +} + +STRUCT (lifted_node_id,LiftedNodeId){ + NodeId lnid_lifted_node_id; + NodeId lnid_lhs_node_id; + struct lifted_node_id * lnid_next; +}; + +void PrintRuleAlt (RuleAlts rulealt,int n_leading_spaces,File file) +{ + PrintRuleNode (rulealt->alt_lhs_root, False,n_leading_spaces,file); + +#ifdef PRINT_alt_lifted_node_ids + if (rulealt->alt_lifted_node_ids){ + LiftedNodeId lifted_node_id_p; + + FPutS (" <<",file); + for_l (lifted_node_id_p,rulealt->alt_lifted_node_ids,lnid_next){ + FPutC (' ',file); + DPrintNodeId (lifted_node_id_p->lnid_lhs_node_id,file); + FPutC (':',file); + DPrintNodeId (lifted_node_id_p->lnid_lifted_node_id,file); + } + FPutS (" >>",file); + } +#endif + + if (rulealt->alt_lhs_defs){ + FPutS ("\n", file); + PrintNodeDefs (rulealt -> alt_lhs_defs,4,file); + FPutS (" = ", file); + } else + FPutS ("\n = ", file); + + if (rulealt -> alt_kind==Contractum){ +#if 1 +# ifndef PRINT_NODE_ID_REF_COUNTS + if (rulealt->alt_strict_node_ids!=NULL){ + StrictNodeIdP strict_node_id; + + FPutS ("let! ", file); + + for_l (strict_node_id,rulealt->alt_strict_node_ids,snid_next){ + if (strict_node_id->snid_mark & STRICT_NODE_ID_IDENT_MASK){ + FPrintF (file, " %s",strict_node_id->snid_ident->ident_name); + } else { + DPrintNodeId (strict_node_id->snid_node_id,file); + FPutS ("; ",file); + } + } + FPutC ('\n',file); + print_spaces (n_leading_spaces,file); + } +# endif +#endif + + + PrintRuleNode (rulealt->alt_rhs_root, False,n_leading_spaces,file); + FPutS ("\n", file); + PrintNodeDefs (rulealt->alt_rhs_defs,4,file); + } else { +/* + FPutS (rulealt->alt_rhs_root->node_node_id->nid_ident->ident_name,file); +*/ + } +} + +static void PrintRuleAlts (RuleAlts rulealt,int n_leading_spaces,File file) +{ + for (; rulealt; rulealt = rulealt -> alt_next) + PrintRuleAlt (rulealt,n_leading_spaces,file); +} + +static void PrintTypeArguments (TypeArgs args, char separator, File file) +{ + if (args){ + PrintTypeNode (args->type_arg_node, file); + + for (args = args->type_arg_next; args; args = args->type_arg_next){ + FPutC (separator, file); + PrintTypeNode (args->type_arg_node, file); + } + } +} + +static char *PrintUniVars = "uvwxyz"; +#define NrOfPrintUniVars 6 + +void PrintTypeNode (TypeNode node, File file) +{ + if (node->type_node_annotation || node->type_node_annotation == StrictOnA) + FPutC ('!', file); + + if (node->type_node_attribute == UniqueAttr) + FPutC ('*', file); + else if (node->type_node_attribute > UniqueAttr) + { unsigned node_attr = node->type_node_attribute - UniqueAttr; + + if (node_attr < NrOfPrintUniVars) + { FPutC (PrintUniVars[node_attr], file); + FPutC (':', file); + } + else + FPrintF (file, "%u:", node_attr); + } + + if (node->type_node_is_var) + FPutS (node->type_node_tv->tv_ident->ident_name, file); + else if (node->type_node_symbol->symb_kind == tuple_type) + { FPutC ('(', file); + PrintTypeArguments (node->type_node_arguments, ',', file); + FPutC (')', file); + } + else if (node->type_node_symbol->symb_kind == list_type) + { FPutC ('[', file); + PrintTypeArguments (node->type_node_arguments,',', file); + FPutC (']', file); + } + else if (node->type_node_symbol->symb_kind >= array_type && + node->type_node_symbol->symb_kind <= unboxed_array_type) + { char *delim_chars = ":|#"; + char array_delim = delim_chars [node->type_node_symbol->symb_kind - array_type]; + FPutC ('{', file); + FPutC (array_delim, file); + PrintTypeArguments (node->type_node_arguments,',', file); + FPutC (array_delim, file); + FPutC ('}', file); + } + else if (node->type_node_symbol->symb_kind == apply_symb) + { FPutC ('(', file); + PrintTypeArguments (node -> type_node_arguments, ' ', file); + FPutC (')', file); + } else + { if (node->type_node_arguments) + FPutC ('(', file); + + PrintSymbol (node->type_node_symbol, file); + + if (node->type_node_arguments){ + FPutC (' ', file); + + PrintTypeArguments (node->type_node_arguments,' ', file); + + FPutC (')', file); + } + } +} + +static void PrintAttribute (AttributeKind attr, File file) +{ + if (attr == NotUniqueAttr) + return; + else if (attr == UniqueAttr) + FPutC ('*', file); + else + FPrintF (file, "%d", attr - UniqueAttr, file); + +} + +static void PrintTypeAttrEquations (UniVarEquations equs, File file) +{ + for (; equs; equs = equs -> uve_next) + { AttributeKindList next; + PrintAttribute (equs -> uve_demanded, file); + FPutC (':', file); + for (next = equs -> uve_offered; next; next = next -> akl_next) + { FPutC (' ', file); + PrintAttribute (next -> akl_elem, file); + } + } +} + +static void PrintTypeContext (TypeContext type_context, File file) +{ + SymbolList symbols; + + for (symbols = type_context -> tyco_symbols; symbols; symbols = symbols -> sl_next) + { PrintSymbol (symbols -> sl_symbol -> sdef_class -> cd_symbol, file); + FPutC (' ', file); + DPrintTypeVar (type_context -> tyco_variable, NULL, file); + } +} + +static void PrintTypeContexts (TypeContext type_contexts, File file) +{ + PrintTypeContext (type_contexts, file); + + for (type_contexts = type_contexts -> tyco_next; type_contexts; type_contexts = type_contexts -> tyco_next) + { FPutS (" & ", file); + PrintTypeContext (type_contexts, file); + } +} + +void PrintTypeAlt (TypeAlts type_alts, File file, Bool with_equats) +{ + TypeNode lhs_root = type_alts -> type_alt_lhs; + + PrintSymbol (lhs_root -> type_node_symbol, file); + FPutS (" :: ", file); + PrintTypeArguments (lhs_root -> type_node_arguments, ' ', file); + + FPutS (" -> ", file); + PrintTypeNode (type_alts -> type_alt_rhs, file); + if (type_alts -> type_alt_type_context) + { FPutS (" | ", file); + PrintTypeContexts (type_alts -> type_alt_type_context, file); + } + FPutC ('\n', file); + if (with_equats) + { PrintTypeAttrEquations (type_alts -> type_alt_attr_equations, file); + FPutC ('\n', file); + } +} + +void PrintImpRule (ImpRules rule,int n_leading_spaces,File file) +{ + /* + if (rule -> rule_type) + PrintTypeAlt (rule -> rule_type, file); + */ + + PrintRuleAlts (rule->rule_alts,n_leading_spaces,file); +} + +void PrintRules (ImpRules rules) +{ + ImpRuleS *rule; + + for_l (rule,rules,rule_next){ + PrintImpRule (rule,4,StdOut); + + if (rule->rule_next!=NULL) + FPutC ('\n',StdOut); + } +} + +#ifdef _COMPSTATS_ + +unsigned long + NrNodeCells, + NrArgCells, + NrTypeNodeCells, + NrTypeArgCells, + NrExpandedTypeNodeCells, + NrExpandedTypeArgCells, + NrNodeIdCells, + NrSymbolCells, + NrBasicNodes; + +void InitDB (void) +{ + NrArgCells = NrNodeCells = NrNodeIdCells =0; + NrTypeArgCells = NrTypeNodeCells =0; + NrExpandedTypeNodeCells = NrExpandedTypeArgCells = 0; + NrBasicNodes = NrSymbolCells = 0; +} + +extern unsigned long NrOfBytes; +void PrintCompStats (void, File file) +{ + FPutC('\n', file); + FPrintF (file, "Number of nodes: %lu\n", NrNodeCells); + FPrintF (file, "Number of arguments: %lu\n", NrArgCells); + FPrintF (file, "Number of type nodes: %lu\n", NrTypeNodeCells); + FPrintF (file, "Number of type arguments: %lu\n", NrTypeArgCells); + FPrintF (file, "Number of expanded type nodes: %lu\n", NrExpandedTypeNodeCells); + FPrintF (file, "Number of expanded type arguments: %lu\n", NrExpandedTypeArgCells); + FPrintF (file, "Number of nodeids: %lu\n", NrNodeIdCells); + FPrintF (file, "Number of symbols: %lu\n", NrSymbolCells); + FPrintF (file, "Number of basic nodes: %lu\n", NrBasicNodes); + FPrintF (file, "Total number of bytes: %lu\n", NrOfBytes); +} + +#endif diff --git a/backendC/CleanCompilerSources/dbprint.h b/backendC/CleanCompilerSources/dbprint.h new file mode 100644 index 0000000..e87800e --- /dev/null +++ b/backendC/CleanCompilerSources/dbprint.h @@ -0,0 +1,32 @@ + +#undef _COMPSTATS_ + +extern void PrintRuleNode (Node node,Bool brackets,int n_leading_spaces,File file); +extern void PrintRuleAlt (RuleAlts rulealt,int n_leading_spaces,File file); +extern void PrintNodeDef (NodeDefP def_p,int n_leading_spaces,File file); +extern void PrintNodeDefs (NodeDefs defs,int n_leading_spaces,File file); +extern void PrintImpRule (ImpRules rule,int n_leading_spaces,File file); +extern void PrintTypeNode (TypeNode node, File file); +extern void DPrintNodeId (NodeId nid, File file); +extern void DPrintNodeIdS (char *s,NodeId nid, File file); +extern void DPrintOccurrenceKind (OccurrenceKind kind, File file); +extern void PrintTypeAlt (TypeAlts type_alts, File file, Bool with_equats); + +extern void PrintRules (ImpRules rules); + +#ifdef _COMPSTATS_ +extern unsigned long + NrNodeCells, + NrArgCells, + NrTypeNodeCells, + NrTypeArgCells, + NrExpandedTypeNodeCells, + NrExpandedTypeArgCells, + NrNodeIdCells, + NrSymbolCells, + NrBasicNodes; + +extern void InitDB (void); + +extern void PrintCompStats (void); +#endif
\ No newline at end of file diff --git a/backendC/CleanCompilerSources/docommand.c b/backendC/CleanCompilerSources/docommand.c new file mode 100644 index 0000000..7e9a5db --- /dev/null +++ b/backendC/CleanCompilerSources/docommand.c @@ -0,0 +1,16 @@ +typedef struct clean_string {int length; char chars [1]; } *CleanString; + +# define Clean(ignore) +# include "docommand.h" +/* + Clean string + ============ +*/ + +extern int do_command (char *command); + +int +DoCommandNullTerminated (CleanString command) +{ + return (docommand (command->chars)); +} /* DoCommandNullTerminated */ diff --git a/backendC/CleanCompilerSources/docommand.dcl b/backendC/CleanCompilerSources/docommand.dcl new file mode 100644 index 0000000..9eca72d --- /dev/null +++ b/backendC/CleanCompilerSources/docommand.dcl @@ -0,0 +1,6 @@ +definition module docommand; + +from StdString import String; + +:: *DoCommandEnvironment :== Int; +DoCommandNullTerminated :: !String !DoCommandEnvironment -> (!Int,!DoCommandEnvironment); diff --git a/backendC/CleanCompilerSources/docommand.h b/backendC/CleanCompilerSources/docommand.h new file mode 100644 index 0000000..af05aa0 --- /dev/null +++ b/backendC/CleanCompilerSources/docommand.h @@ -0,0 +1,12 @@ +#pragma export on + +Clean (:: *DoCommandEnvironment :== Int) +/* Clean (DoCommand command :== DoCommandNullTerminated (command +++ "\0")) */ + +Clean (DoCommandNullTerminated :: String DoCommandEnvironment -> (Int, DoCommandEnvironment)) + +/* functions */ +int DoCommandNullTerminated (CleanString command); +Clean (DoCommandNullTerminated :: String DoCommandEnvironment -> (Int, DoCommandEnvironment)) + +#pragma export off diff --git a/backendC/CleanCompilerSources/docommand.icl b/backendC/CleanCompilerSources/docommand.icl new file mode 100644 index 0000000..d5a1901 --- /dev/null +++ b/backendC/CleanCompilerSources/docommand.icl @@ -0,0 +1,11 @@ +implementation module docommand; + +from StdString import String; + +:: *DoCommandEnvironment :== Int; + +DoCommandNullTerminated :: !String !DoCommandEnvironment -> (!Int,!DoCommandEnvironment); +DoCommandNullTerminated a0 a1 = code { + ccall DoCommandNullTerminated "S:I:I" +} +// int DoCommandNullTerminated(CleanString); diff --git a/backendC/CleanCompilerSources/dumprestore.c b/backendC/CleanCompilerSources/dumprestore.c new file mode 100644 index 0000000..d4f201a --- /dev/null +++ b/backendC/CleanCompilerSources/dumprestore.c @@ -0,0 +1,888 @@ +# include "system.h" +# include "syntaxtr.t" +# include "buildtree.h" + +# include "dumprestore.h" + +# ifdef DUMP_AND_RESTORE + +# include "comsupport.h" +# include "checker.h" + +# include "backendsupport.h" +# define Clean(ignore) +# include "backend.h" + + +Bool gDumpAndRestore = True; + +/* + Utilities + ========= +*/ +# define CopyContents(from, to) { *(to) = *(from);} + +/* + Memory management + ================= +*/ +static CleanString +ConvertCString (char *string) +{ + int length; + CleanString cleanString; + + length = strlen (string); + cleanString = (CleanString) CompAlloc (sizeof (CleanString) + length); + cleanString->length = length; + strncpy (cleanString->chars, string, length); + + return (cleanString); +} /* ConvertCString */ + +/* + Forward declarations + ==================== +*/ +static SymbDefP ConvertSymbDef (SymbDefP sdef); +static TypeNode ConvertTypeNode (TypeNode node); +static NodeP ConvertNode (NodeP node); +static NodeDefP ConvertNodeDefs (NodeDefP nodeDefs); +static int DefineLhsNode (NodeP node, int sequenceNumber); + +/* + Symbol + ====== +*/ + +static void +SetSymbolIndices (SymbolP symbol, int symbolIndex, int moduleIndex) +{ + unsigned int indices; + + Assert (0 <= moduleIndex && moduleIndex <= 0xFFFF); + Assert (0 <= symbolIndex && symbolIndex <= 0xFFFF); + Assert (symbol->symb_kind == definition); + + indices = symbolIndex | (moduleIndex << 16); + + symbol->symb_def->sdef_number = indices; +} /* SetSymbolIndices */ + +static void +GetSymbolIndices (SymbolP symbol, int *symbolIndexP, int *moduleIndexP) +{ + unsigned int indices; + + Assert (symbol->symb_kind == definition); + indices = (unsigned int) symbol->symb_def->sdef_number; + + *symbolIndexP = indices & 0xFFFF; + *moduleIndexP = (indices >> 16) & 0xFFFF; +} /* GetSymbolIndices */ + +static SymbolP +ConvertSymbol (SymbolP symbol) +{ + SymbolP copy; + int symbolIndex, moduleIndex; + + Assert (!IsConverted (symbol)); + switch (symbol->symb_kind) + { + case definition: + switch (symbol->symb_def->sdef_kind) + { + case ABSTYPE: + copy = BEDontCareDefinitionSymbol (); + break; + case TYPE: + case RECORDTYPE: + GetSymbolIndices (symbol, &symbolIndex, &moduleIndex); + copy = BETypeSymbol (symbolIndex, moduleIndex); + break; + case TYPESYN: + break; + case DEFRULE: + case IMPRULE: + case SYSRULE: /* +++ */ + GetSymbolIndices (symbol, &symbolIndex, &moduleIndex); + copy = BEFunctionSymbol (symbolIndex, moduleIndex); + break; + case CONSTRUCTOR: + GetSymbolIndices (symbol, &symbolIndex, &moduleIndex); + copy = BEConstructorSymbol (symbolIndex, moduleIndex); + break; + break; + case FIELDSELECTOR: + GetSymbolIndices (symbol, &symbolIndex, &moduleIndex); + copy = BEFieldSymbol (symbolIndex, moduleIndex); + break; + case MACRORULE: + break; + case OVERLOADEDRULE: + break; + case INSTANCE: + break; + case CLASS: + break; + case CLASSINSTANCE: + break; + case CLASSLIST: + break; + default: + Assert (False); + break; + } + break; + + /* literals */ + case int_denot: + case char_denot: + case real_denot: + case string_denot: + copy = BELiteralSymbol ((SymbKind) symbol->symb_kind, ConvertCString (symbol->symb_int)); + break; + + /* basic symbols +++ some of these should be moved to the predefined module */ + case int_type: + case bool_type: + case char_type: + case real_type: + case file_type: + case world_type: + case procid_type: + case redid_type: + case fun_type: + + case array_type: + case strict_array_type: + case unboxed_array_type: + + case tuple_type: + case tuple_symb: + copy = BEBasicSymbol ((SymbKind) symbol->symb_kind); + break; + + /* symbols from the predefined module */ + case list_type: + copy = BETypeSymbol (0, kPredefinedModuleIndex); + break; + case nil_symb: + copy = BEConstructorSymbol (0, kPredefinedModuleIndex); + break; + case cons_symb: + copy = BEConstructorSymbol (1, kPredefinedModuleIndex); + break; + + + default: + Assert (False); + break; + } + + return (copy); +} /* ConvertSymbol */ + +/* + TypeArg + ======= +*/ +static TypeArgs +ConvertTypeArgs (TypeArgs args) +{ + TypeArgs copy; + + if (args == NULL) + copy = BENoTypeArgs (); + else + copy = BETypeArgs (ConvertTypeNode (args->type_arg_node), ConvertTypeArgs (args->type_arg_next)); + + return (copy); +} /* ConvertTypeArgs */ + +/* + TypeNode + ======== +*/ +static TypeNode +ConvertTypeNode (TypeNode node) +{ + TypeNode copy; + + Assert (!IsConverted (node)); + + if (node->type_node_is_var) + { + Assert (node->type_node_arguments== NULL); + copy = BEVarTypeNode (ConvertCString (node->type_node_tv->tv_ident->ident_name)); + } + else + copy = BENormalTypeNode (ConvertSymbol (node->type_node_symbol), ConvertTypeArgs (node->type_node_arguments)); + + Assert (node->type_node_annotation == NoAnnot || node->type_node_annotation == StrictAnnot); + copy = BEAnnotateTypeNode (node->type_node_annotation, copy); + + return (copy); +} /* ConvertTypeNode */ + +/* + TypeAlt + ======= +*/ +static TypeAlt * +ConvertTypeAlt (TypeAlt *typeAlt) +{ + TypeAlt *copy; + + Assert (!IsConverted (typeAlt)); + + copy = BETypeAlt (ConvertTypeNode (typeAlt->type_alt_lhs), ConvertTypeNode (typeAlt->type_alt_rhs)); + + return (copy); +} /* ConvertTypeAlt */ + +/* + Arg + === +*/ +static ArgP +ConvertArgs (ArgP args) +{ + ArgP copy; + + if (args == NULL) + copy = BENoArgs (); + else + copy = BEArgs (ConvertNode (args->arg_node), ConvertArgs (args->arg_next)); + + return (copy); +} /* ConvertArgs */ + +/* + NodeIds +*/ + +static int +DefineNodeIds (NodeDefP nodeDef, int lhsOrRhs, int sequenceNumber) +{ + for ( ; nodeDef != NULL; nodeDef = nodeDef->def_next) + { + NodeIdP nodeId; + + nodeId = nodeDef->def_id; + nodeId->nid_scope = sequenceNumber; + + /* RWS ??? Assert (nodeId->nid_mark == 0); */ + + BEDeclareNodeId (sequenceNumber, lhsOrRhs, ConvertCString (nodeId->nid_ident->ident_name)); + sequenceNumber++; + } + return (sequenceNumber); +} /* DefineNodeIds */ + +static int +DefineLhsNodeId (NodeIdP nodeId, int sequenceNumber) +{ + Assert (nodeId->nid_refcount < 0); + Assert (nodeId->nid_node_def == NULL); + /* RWS ??? Assert (nodeId->nid_forward_node_id == NULL); */ + Assert (nodeId->nid_state.state_arity == 0); + Assert (nodeId->nid_state.state_kind == 0); + Assert (nodeId->nid_state.state_mark == 0); + Assert (nodeId->nid_state.state_object == 0); + Assert (nodeId->nid_state.state_type == 0); + + if (nodeId->nid_node == NULL) + { + nodeId->nid_scope = sequenceNumber; + BEDeclareNodeId (sequenceNumber, BELhsNodeId, ConvertCString (nodeId->nid_ident->ident_name)); + sequenceNumber++; + } + + return (sequenceNumber); +} /* DefineLhsNodeId */ + +static int +DefineLhsArgs (ArgP arg, int sequenceNumber) +{ + for ( ; arg != NULL; arg = arg->arg_next) + sequenceNumber = DefineLhsNode (arg->arg_node, sequenceNumber); + + return (sequenceNumber); +} /* DefineLhsArgs */ + +static int +DefineLhsNode (NodeP node, int sequenceNumber) +{ + switch (node->node_kind) + { + case NodeIdNode: + sequenceNumber = DefineLhsNodeId (node->node_node_id, sequenceNumber); + break; + case NormalNode: + break; + default: + Assert (False); + break; + } + + sequenceNumber = DefineLhsArgs (node->node_arguments, sequenceNumber); + + return (sequenceNumber); +} /* DefineLhsNode */ + +static NodeIdP +ConvertNodeId (NodeIdP nodeId) +{ + Assert (!IsConverted (nodeId)); + + return (BENodeId (nodeId->nid_scope)); +} /* ConvertNodeId*/ + + +/* + RuleAlt + ======= +*/ + +static RuleAlts +ConvertRuleAlt (RuleAltP alt) +{ + RuleAltP copy; + + int sequenceNumber; + + Assert (!IsConverted (alt)); + + Assert (alt->alt_kind == Contractum); + Assert (alt->alt_strict_node_ids == NULL); + + sequenceNumber = 0; + sequenceNumber = DefineNodeIds (alt->alt_lhs_defs, BELhsNodeId, sequenceNumber); + sequenceNumber = DefineNodeIds (alt->alt_rhs_defs, BERhsNodeId, sequenceNumber); + sequenceNumber = DefineLhsArgs (alt->alt_lhs_root->node_arguments, sequenceNumber); + + copy = BERuleAlt (alt->alt_line, ConvertNodeDefs (alt->alt_lhs_defs), ConvertNode (alt->alt_lhs_root), ConvertNodeDefs (alt->alt_rhs_defs), ConvertNode (alt->alt_rhs_root)); + + return (copy); +} /* ConvertRuleAlt */ + +static RuleAlts +ConvertRuleAlts (RuleAltP alts) +{ + RuleAltP copy; + + if (alts == NULL) + copy = BENoRuleAlts (); + else + copy = BERuleAlts (ConvertRuleAlt (alts), ConvertRuleAlts (alts->alt_next)); + + return (copy); +} /* ConvertRuleAlts */ + +/* + Node + ==== +*/ +static NodeP +ConvertNode (NodeP node) +{ + NodeP copy; + + Assert (node->node_annotation == NoAnnot); + switch (node->node_kind) + { + case NormalNode: + copy = BENormalNode (ConvertSymbol (node->node_symbol), ConvertArgs (node->node_arguments)); + break; + case NodeIdNode: + copy = BENodeIdNode (ConvertNodeId (node->node_node_id), ConvertArgs (node->node_arguments)); + break; + case SelectorNode: + copy = BESelectorNode (ConvertSymbol (node->node_symbol), ConvertArgs (node->node_arguments)); + break; + default: + Assert (False); + break; + } + + return (copy); +} /* ConvertNode */ + +/* + NodeDef + ======= +*/ +static NodeDefP +ConvertNodeDef (NodeDefP nodeDef) +{ + NodeDefP copy; + + Assert (nodeDef->def_mark == 0); + + copy = BENodeDef (nodeDef->def_id->nid_scope, ConvertNode (nodeDef->def_node)); + + return (copy); +} /* ConvertNodeDef */ + +static NodeDefP +ConvertNodeDefs (NodeDefP nodeDefs) +{ + if (nodeDefs == NULL) + return (BENoNodeDefs ()); + else + return (BENodeDefs (ConvertNodeDef (nodeDefs), ConvertNodeDefs (nodeDefs->def_next))); +} /* ConvertNodeDefs */ + +/* + ImpRule + ======= +*/ +static ImpRuleP +ConvertRule (ImpRuleP rule) +{ + ImpRuleP copy; + SymbolP functionSymbol; + int symbolIndex, moduleIndex; + + Assert (!IsConverted (rule)); + Assert (rule->rule_mark == RULE_CHECKED_MASK); + + functionSymbol = rule->rule_root->node_symbol; + + GetSymbolIndices (functionSymbol, &symbolIndex, &moduleIndex); + Assert (moduleIndex == kIclModuleIndex); + copy = BERule (symbolIndex, ConvertTypeAlt (rule->rule_type), ConvertRuleAlts (rule->rule_alts)); + + return (copy); +} /* ConvertRule */ + +static ImpRuleP +ConvertRules (ImpRuleP rules) +{ + ImpRuleP copy; + + if (rules == NULL) + copy = BENoRules (); + else + copy = BERules (ConvertRule (rules), ConvertRules (rules->rule_next)); + + return (copy); +} /* ConvertRules */ + +static void +DefineRuleType (int functionIndex, int moduleIndex, RuleTypes ruleType) +{ + SymbolP functionSymbol; + + Assert (!IsConverted (ruleType)); + + // +++ move to count + functionSymbol = ruleType->rule_type_root->type_node_symbol; + SetSymbolIndices (functionSymbol, functionIndex, moduleIndex); + + Assert (functionSymbol->symb_kind == definition); + + BEDeclareRuleType (functionIndex, moduleIndex, ConvertCString (functionSymbol->symb_def->sdef_ident->ident_name)); + BEDefineRuleType (functionIndex, moduleIndex, ConvertTypeAlt (ruleType->rule_type_rule)); +} /* DefineRuleType */ + +static void +DefineRuleTypes (SymbolP allSymbols, char *moduleName) +{ + SymbolP symbol; + + for (symbol = allSymbols; symbol != NULL; symbol = symbol->symb_next) + { + if (symbol->symb_kind == definition) + { + SymbDef sdef; + + sdef = symbol->symb_def; + if ((sdef->sdef_kind == DEFRULE || sdef->sdef_kind == SYSRULE) && sdef->sdef_isused + && sdef->sdef_module == moduleName) + { + int functionIndex, moduleIndex; + + GetSymbolIndices (symbol, &functionIndex, &moduleIndex); + DefineRuleType (functionIndex, moduleIndex, sdef->sdef_rule_type); + } + + } + } +} /* DefineRuleTypes */ + +static void +DeclareFunctions (SymbDefP sdefs) +{ + int i; + SymbDefP sdef; + + i = 0; + for (sdef = sdefs; sdef != NULL; sdef = sdef->sdef_next_scc) + { + Node root; + ImpRuleP rule; + Symbol symbol; + + Assert (sdef->sdef_kind == IMPRULE); + rule = sdef->sdef_rule; + + root = rule->rule_root; + Assert (root->node_kind == NormalNode); + symbol = root->node_symbol; + Assert (symbol->symb_kind == definition); + + SetSymbolIndices (symbol, i, kIclModuleIndex); + + Assert (sdef->sdef_kind == IMPRULE); + Assert (sdef->sdef_mark == 0); + Assert (sdef->sdef_over_arity == 0); +// Assert (!sdef->sdef_exported); + Assert (sdef->sdef_arfun == NoArrayFun); + + // +++ hack + if (sdef->sdef_exported) + sdef->sdef_ancestor = -sdef->sdef_ancestor-1; + + BEDeclareFunction (ConvertCString (sdef->sdef_ident->ident_name), sdef->sdef_arity, i, sdef->sdef_ancestor); + + i++; + } +} /* DeclareFunctions */ + +static TypeVar +ConvertTypeVar (TypeVar typeVar) +{ + return (BETypeVar (ConvertCString (typeVar->tv_ident->ident_name))); +} /* ConvertTypeVar */ + +static TypeVarList +ConvertTypeVarList (TypeVarList typeVarList) +{ + if (typeVarList == NULL) + return (BENoTypeVars ()); + else + return (BETypeVars (ConvertTypeVar (typeVarList->tvl_elem), ConvertTypeVarList (typeVarList->tvl_next))); +} /* ConvertTypeVarList */ + +static FlatType +ConvertFlatType (FlatType flatType) +{ + BEFlatType (ConvertSymbol (flatType->ft_symbol), ConvertTypeVarList (flatType->ft_arguments)); +} /* ConvertFlatType */ + +static void +SequenceTypesAndConstructors (Types types, int moduleIndex, int *nTypesP, int *nConstructorsP, int *nFieldsP) +{ + int typeIndex, constructorIndex, fieldIndex; + + typeIndex = 0; + constructorIndex = 0; + fieldIndex = 0; + + for (; types != NULL; types = types->type_next) + { + SymbolP typeSymbol; + ConstructorList constructor; + + typeSymbol = types->type_lhs->ft_symbol; + SetSymbolIndices (typeSymbol, typeIndex++, moduleIndex); + + if (types->type_nr_of_constructors == 0) + { + SymbolP constructorSymbol; + FieldList field; + + constructor = types->type_constructors; + + Assert (!constructor->cl_constructor->type_node_is_var); + Assert (constructor->cl_fields != NULL); + /* Assert (constructor->cl_next == NULL); ??? unitialised */ + constructorSymbol = constructor->cl_constructor->type_node_symbol; + + SetSymbolIndices (constructorSymbol, constructorIndex++, moduleIndex); + + for (field = types->type_fields; field != NULL; field = field->fl_next) + { + SymbolP fieldSymbol; + + fieldSymbol = field->fl_symbol; + + SetSymbolIndices (fieldSymbol, fieldIndex++, moduleIndex); + } + } + else + { + for (constructor = types->type_constructors; constructor != NULL; constructor = constructor->cl_next) + { + SymbolP constructorSymbol; + + Assert (!constructor->cl_constructor->type_node_is_var); + Assert (constructor->cl_fields == NULL); + constructorSymbol = constructor->cl_constructor->type_node_symbol; + + SetSymbolIndices (constructorSymbol, constructorIndex++, moduleIndex); + } + } + } + *nTypesP = typeIndex; + *nConstructorsP = constructorIndex; + *nFieldsP = fieldIndex; +} /* SequenceTypesAndConstructors */ + +static int +SequenceRuleTypes (SymbolP allSymbols, int moduleIndex, char *moduleName) +{ + int nRuleTypes; + SymbolP symbol; + + nRuleTypes = 0; + for (symbol = allSymbols; symbol != NULL; symbol = symbol->symb_next) + { + if (symbol->symb_kind == definition) + { + SymbDef sdef; + + sdef = symbol->symb_def; + if ((sdef->sdef_kind == DEFRULE || sdef->sdef_kind == SYSRULE) && sdef->sdef_isused + && sdef->sdef_module == moduleName) + { + SetSymbolIndices (symbol, nRuleTypes, moduleIndex); + nRuleTypes++; + } + + } + } + + return (nRuleTypes); +} /* SequenceRuleTypes */ + +static ConstructorList +ConvertConstructor (ConstructorList constructor) +{ + SymbolP constructorSymbol; + ConstructorList copy; + int constructorIndex, moduleIndex; + + Assert (!constructor->cl_constructor->type_node_is_var); + constructorSymbol = constructor->cl_constructor->type_node_symbol; + + GetSymbolIndices (constructorSymbol, &constructorIndex, &moduleIndex); + + BEDeclareConstructor (constructorIndex, moduleIndex, ConvertCString (constructorSymbol->symb_def->sdef_ident->ident_name)); + copy = BEConstructor (ConvertTypeNode (constructor->cl_constructor)); + + return (copy); +} /* ConvertConstructor */ + +static ConstructorList +ConvertConstructors (ConstructorList constructors) +{ + ConstructorList copy; + + if (constructors == NULL) + copy = BENoConstructors (); + else + copy = BEConstructors (ConvertConstructor (constructors), ConvertConstructors (constructors->cl_next)); + + return (copy); +} /* ConvertConstructors */ + +static FieldList +ConvertField (FieldList field) +{ + SymbolP fieldSymbol; + FieldList copy; + int fieldIndex, moduleIndex; + + fieldSymbol = field->fl_symbol; + + GetSymbolIndices (fieldSymbol, &fieldIndex, &moduleIndex); + + BEDeclareField (fieldIndex, moduleIndex, ConvertCString (fieldSymbol->symb_def->sdef_ident->ident_name)); + copy = BEField (fieldIndex, moduleIndex, ConvertTypeNode (field->fl_type)); + + return (copy); +} /* ConvertField */ + +static FieldList +ConvertFields (FieldList fields) +{ + FieldList copy; + + if (fields == NULL) + copy = BENoFields (); + else + copy = BEFields (ConvertField (fields), ConvertFields (fields->fl_next)); + + return (copy); +} /* ConvertFields */ + +static Types +ConvertType (Types type) +{ + SymbolP typeSymbol; + Types copy; + int typeIndex, moduleIndex; + + typeSymbol = type->type_lhs->ft_symbol; + GetSymbolIndices (typeSymbol, &typeIndex, &moduleIndex); + + Assert (typeSymbol->symb_kind == definition); + + BEDeclareType (typeIndex, moduleIndex, ConvertCString (typeSymbol->symb_def->sdef_ident->ident_name)); + + if (type->type_nr_of_constructors == 0) + copy = BERecordType (BEFlatType (BETypeSymbol (typeIndex, moduleIndex), NULL), ConvertTypeNode (type->type_constructors->cl_constructor), ConvertFields (type->type_fields)); + else + copy = BEAlgebraicType (BEFlatType (BETypeSymbol (typeIndex, moduleIndex), NULL), ConvertConstructors (type->type_constructors)); + + return (copy); +} /* ConvertType */ + +static Types +ConvertTypes (Types types) +{ + Types copy; + + if (types == NULL) + copy = BENoTypes (); + else + copy = BETypes (ConvertType (types), ConvertTypes (types->type_next)); + + return (copy); +} /* ConvertTypes */ + + +/* + ImpMod + ====== +*/ + +static void +ConvertIclModule (ImpMod module) +{ + SymbDefP sdef; + int nFunctions, nTypes, nConstructors, nFields; + +// Assert (module->im_def_module == NULL); +// Assert (module->im_main); + + nFunctions = 0; + for (sdef = scc_dependency_list; sdef != NULL; sdef = sdef->sdef_next_scc) + nFunctions++; + + SequenceTypesAndConstructors (module->im_types, kIclModuleIndex, &nTypes, &nConstructors, &nFields); + + BEDeclareIclModule (ConvertCString (module->im_name->symb_ident->ident_name), nFunctions, nTypes, nConstructors, nFields); + + ConvertTypes (module->im_types); + + DeclareFunctions (scc_dependency_list); + BEDefineRules (ConvertRules (module->im_rules)); +} /* ConvertIclModule */ + +/* + DefMod + ====== +*/ + +static int +CountDclModules (DefMod module, int moduleIndex) +{ + ImportList import; + + if ((int) module->dm_abs_types == 1) + return (moduleIndex); + + module->dm_abs_types = (void *) 1; + module->dm_syn_types = (void *) moduleIndex++; + + for (import = module->dm_imports; import != NULL; import = import->ilist_next) + moduleIndex = CountDclModules (import->ilist_def, moduleIndex); + + return (moduleIndex); +} /* CountDclModules */ + +static void +ConvertDclModule (DefMod module, SymbolP allSymbols) +{ + int moduleIndex, functionIndex, nTypes, nConstructors, nFields; + char *moduleName; + ImportList import; + + if ((unsigned int) module->dm_abs_types == 2) + return; + + Assert ((unsigned int) module->dm_abs_types == 1); + module->dm_abs_types = (void *) 2; + + for (import = module->dm_imports; import != NULL; import = import->ilist_next) + ConvertDclModule (import->ilist_def, allSymbols); + + moduleName = module->dm_name->symb_ident->ident_name; + moduleIndex = (int) module->dm_syn_types; + + functionIndex = SequenceRuleTypes (allSymbols, moduleIndex, moduleName); + + SequenceTypesAndConstructors (module->dm_types, moduleIndex, &nTypes, &nConstructors, &nFields); + + BEDeclareDclModule (moduleIndex, ConvertCString (module->dm_name->symb_ident->ident_name), False, + functionIndex, nTypes, nConstructors, nFields); + + + DefineRuleTypes (allSymbols, moduleName); + +# if 0 + functionIndex = 0; + functionIndex = DefineRuleTypes (moduleIndex, module->dm_rules, functionIndex); + functionIndex = DefineInstances (moduleIndex, module->dm_instances, functionIndex); +# endif + + ConvertTypes (module->dm_types); +} /* ConvertDclModule */ + +static void +ConvertModules (ImpMod module) +{ + int n; + ImportList import; + + n = 2; /* 2: icl + predef */ + for (import = module->im_imports; import != NULL; import = import->ilist_next) + n = CountDclModules (import->ilist_def, n); + + BEDeclareModules (n); + + // +++ temporary test + BEDeclarePredefinedModule (1, 2); + BEPredefineTypeSymbol (0, kPredefinedModuleIndex, list_type); + BEPredefineConstructorSymbol (0, kPredefinedModuleIndex, nil_symb); + BEPredefineConstructorSymbol (1, kPredefinedModuleIndex, cons_symb); + + for (import = module->im_imports; import != NULL; import = import->ilist_next) + ConvertDclModule (import->ilist_def, module->im_symbols); + + ConvertIclModule (module); +} /* ConvertModules */ + +void +CoclBackEnd (ImpMod module, char *outputFileName) +{ + BackEnd backEnd; + + backEnd = BEInit (0); + + ConvertModules (module); + + CompFree (); + InitStorage (); + + BEGenerateCode (ConvertCString (outputFileName)); + + BEFree (backEnd); +} /* CoclBackEnd */ + +# endif /* DUMP_AND_RESTORE */
\ No newline at end of file diff --git a/backendC/CleanCompilerSources/dumprestore.h b/backendC/CleanCompilerSources/dumprestore.h new file mode 100644 index 0000000..1bf6cc3 --- /dev/null +++ b/backendC/CleanCompilerSources/dumprestore.h @@ -0,0 +1,8 @@ +# undef DUMP_AND_RESTORE + +# ifdef DUMP_AND_RESTORE + +extern Bool gDumpAndRestore; +void CoclBackEnd (ImpMod modulem, char *outputFileName); + +# endif /* DUMP_AND_RESTORE */
\ No newline at end of file diff --git a/backendC/CleanCompilerSources/dynamics.h b/backendC/CleanCompilerSources/dynamics.h new file mode 100644 index 0000000..166c69d --- /dev/null +++ b/backendC/CleanCompilerSources/dynamics.h @@ -0,0 +1,7 @@ +# define type_code_constructor symbol +# define type_code_arg arg +# define type_code node + +typedef struct type_code TypeCodeS, *TypeCodeP; +typedef struct type_code_arg TypeCodeArgS, *TypeCodeArgP; +typedef struct type_code_constructor TypeCodeConstructor, *TypeCodeConstructorP; diff --git a/backendC/CleanCompilerSources/instructions.c b/backendC/CleanCompilerSources/instructions.c new file mode 100644 index 0000000..6616c8d --- /dev/null +++ b/backendC/CleanCompilerSources/instructions.c @@ -0,0 +1,3403 @@ +/* + (Concurrent) Clean Compiler: ABC instructions + Authors: Sjaak Smetsers & John van Groningen +*/ + +#pragma segment instructions + +#include "compiledefines.h" +#include "system.h" + +#include <ctype.h> + +#include "syntaxtr.t" +#include "checksupport.h" + +#include "settings.h" +#include "sizes.h" +#include "codegen_types.h" +#include "codegen1.h" +#include "codegen2.h" +#include "comsupport.h" +#include "instructions.h" +#include "statesgen.h" +#include "version.h" + +#define BINARY_ABC 0 +#undef MEMORY_PROFILING_WITH_N_STRING + +#define PutSOutFile(s) FPutS ((s),OutFile) +#define PutCOutFile(s) FPutC ((s),OutFile) + +static void error_in_function (char *m) +{ + ErrorInCompiler ("instructions.c",m,""); +} + +#ifdef _STANDALONE_ +/* also defined in project.c, only needed for stand alone compiler */ + +#define N_DoDebug 0 +#define N_DoReuseUniqueNodes 1 +#define N_DoParallel 2 + +#define N_NoDescriptors 3 +/* +#define N_NoMemoryProfiling 3 +*/ +#define N_DoStrictnessAnalysis 4 +#define N_NoTimeProfiling 5 + +#define N_ExportLocalLabels 6 +/* +#define N_DoVerbose 6 +*/ +#define N_DoWarning 7 +#define N_System 8 + +static void ConvertOptionsToString (CompilerOptions options,char *optstring) +{ + optstring[N_DoDebug] = DoDebug ? '1' : '0'; + optstring[N_DoReuseUniqueNodes] = !DoReuseUniqueNodes ? '1' : '0'; + optstring[N_DoParallel] = DoParallel ? '1' : '0'; + + optstring[N_NoDescriptors] = !DoDescriptors ? '1' : '0'; +/* + optstring[N_NoMemoryProfiling] = !DoProfiling ? '1' : '0'; +*/ + optstring[N_DoStrictnessAnalysis] = DoStrictnessAnalysis ? '1' : '0'; + + optstring[N_NoTimeProfiling] = !DoTimeProfiling ? '1' : '0'; + optstring[N_ExportLocalLabels] = ExportLocalLabels ? '1' : '0'; +/* + optstring[N_DoVerbose] = DoVerbose ? '1' : '0'; +*/ + optstring[N_DoWarning] = DoWarning ? '1' : '0'; + optstring[N_System] = '0'; + optstring[NR_OPTIONS] = '\0'; +} +#else +# define N_System 8 +# include "cginterface.t" +# include "project.h" +#endif + +#define D_PREFIX "d" +#define N_PREFIX "n" +#define L_PREFIX "l" + +#define EA_PREFIX "ea" +#define S_PREFIX "s" + +#define R_PREFIX "r" +#define RECORD_N_PREFIX "c" +#define RECORD_D_PREFIX "t" +#define CONSTRUCTOR_R_PREFIX "k" + +#define LOCAL_D_PREFIX "d" + +File OutFile; +char *ABCFileName; + +Bool OpenABCFile (char *fname) +{ + OutFile = FOpen (fname, abcFile, "w"); + + if (OutFile!=NULL){ +#if defined (THINK_C) || defined (POWER) + setvbuf ((FILE*) OutFile, NULL, _IOFBF, 8192); +#endif + OpenedFile = OutFile; + ABCFileName = fname; + return True; + } else + return False; +} + +void WriteLastNewlineToABCFile (void) +{ + FPutC ('\n',OutFile); +} + +void CloseABCFile (char *fname) +{ + if (OutFile){ +#ifdef THINK_C + int file_io_error; + + file_io_error=ferror (OutFile); +#endif + if (FClose (OutFile) != 0 +#ifdef THINK_C + || file_io_error +#endif + ){ + CompilerError = True; + CurrentLine = 0; + + StaticMessage (True, "<open file>", "Write error (disk full?)"); + } + if (CompilerError) + FDelete (fname, abcFile); + OpenedFile = (File) NIL; + } +} + +static Bool DescriptorNeeded (SymbDef sdef) +{ + return (sdef->sdef_exported || + (sdef->sdef_kind!=IMPRULE && sdef->sdef_kind!=SYSRULE) || + sdef->sdef_mark & SDEF_USED_CURRIED_MASK) || + ((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){ + SymbDef def; + 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) + FPrintF (OutFile,"e_%s_%s%s",module_name,label->lab_pref,def->sdef_ident->ident_name); + else if (DoDebug){ + if (def->sdef_kind==IMPRULE) + FPrintF (OutFile, "%s%s.%u",label->lab_pref,def->sdef_ident->ident_name,def->sdef_number); + else + FPrintF (OutFile, "%s%s",label->lab_pref,def->sdef_ident->ident_name); + } else if (def->sdef_number==0) + FPrintF (OutFile, "%s%s",label->lab_pref,def->sdef_ident->ident_name); + else if (label->lab_pref[0] == '\0') + FPrintF (OutFile,LOCAL_D_PREFIX "%u",def->sdef_number); + else + FPrintF (OutFile,"%s%u",label->lab_pref,def->sdef_number); + } else { + FPutS (label->lab_pref,OutFile); + FPutS (label->lab_name,OutFile); + } + if (label->lab_post!=0) + FPrintF (OutFile,".%u",label->lab_post); +} + +static void GenGetWL (int offset) +{ + FPrintF (OutFile, "\n\tgetWL %d", offset); +} + +static void GenPutWL (int offset) +{ + FPrintF (OutFile, "\n\tputWL %d", offset); +} + +static void GenRelease (void) +{ + FPutS ("\n\trelease", OutFile); +} + +static void TreatWaitListBeforeFill (int offset, FillKind fkind) +{ + if (DoParallel && fkind != NormalFill) + GenGetWL (offset); +} + +static void TreatWaitListAfterFill (int offset, FillKind fkind) +{ + if (DoParallel){ + switch (fkind){ + case ReleaseAndFill:GenRelease (); break; + case PartialFill: GenPutWL (offset); break; + default: break; + } + } +} + +#if !BINARY_ABC + +#define put_instructionb(a) put_instruction(I##a) +#define put_instruction_b(a) put_instruction_(I##a) +#define put_directive_b(a) put_directive_(D##a) +#define put_arguments_i_b(i1) FPrintF (OutFile,"%s",(i1)) +#define put_arguments_in_b(i1,n1) FPrintF (OutFile,"%s %d",(i1),(n1)) +#define put_arguments_n_b(n1) FPrintF (OutFile,"%d",(n1)) +#define put_arguments_nn_b(n1,n2) FPrintF (OutFile,"%d %d",(n1),(n2)) +#define put_arguments_nnn_b(n1,n2,n3) FPrintF (OutFile,"%d %d %d",(n1),(n2),(n3)) +#define put_arguments_nnnn_b(n1,n2,n3,n4) FPrintF (OutFile,"%d %d %d %d",(n1),(n2),(n3),(n4)) +#define put_arguments_nnnnn_b(n1,n2,n3,n4,n5) FPrintF (OutFile,"%d %d %d %d %d",(n1),(n2),(n3),(n4),(n5)) +#define put_arguments_n__b(n1) FPrintF (OutFile,"%d ",(n1)) +#define put_arguments_nn__b(n1,n2) FPrintF (OutFile,"%d %d ",(n1),(n2)) +#define put_arguments__n_b(n1) FPrintF (OutFile," %d",(n1)) +#define put_arguments__nn_b(n1,n2) FPrintF (OutFile," %d %d",(n1),(n2)) +#define put_arguments__n__b(n1) FPrintF (OutFile," %d ",(n1)) + +#else + +/* +#define put_instructionb(a) put_instruction_code(C##a) +#define put_instruction_b(a) put_instruction_code(C##a) +#define put_directive_b(a) put_instruction_code(C##a) +*/ + +#define put_instructionb(a) if (DoDebug) put_instruction(I##a); else put_instruction_code(C##a) +#define put_instruction_b(a) if (DoDebug) put_instruction_(I##a); else put_instruction_code(C##a) +#define put_directive_b(a) if (DoDebug) put_directive_(D##a); else put_instruction_code(C##a) + +static void put_n (long n) +{ + while (!(n>=-64 && n<=63)){ + FPutC (128+(n & 127),OutFile); + n=n>>7; + } + + FPutC (n+64,OutFile); +} + +static long integer_string_to_integer (char *s_p) +{ + long integer; + int minus_sign,last_char; + + minus_sign=0; + last_char=*s_p++; + if (last_char=='+' || last_char=='-'){ + if (last_char=='-') + minus_sign=!minus_sign; + last_char=*s_p++;; + } + + integer=last_char-'0'; + last_char=*s_p++;; + + while ((unsigned)(last_char-'0')<10u){ + integer*=10; + integer+=last_char-'0'; + last_char=*s_p++;; + } + + if (minus_sign) + integer=-integer; + + return integer; +} + +static void put_arguments_i_b (char *i1) +{ + if (DoDebug) + FPrintF (OutFile,"%s",(i1)); + else + put_n (integer_string_to_integer (i1)); +} + +static void put_arguments_in_b (char *i1,long n1) +{ + if (DoDebug) + FPrintF (OutFile,"%s %d",(i1),(n1)); + else { + put_n (integer_string_to_integer (i1)); + put_n (n1); + } +} + +static void put_arguments_n_b (long n1) +{ + if (DoDebug) + FPrintF (OutFile,"%d",(n1)); + else + put_n (n1); +} + +static void put_arguments_nn_b (long n1,long n2) +{ + if (DoDebug) + FPrintF (OutFile,"%d %d",(n1),(n2)); + else { + put_n (n1); + put_n (n2); + } +} + +static void put_arguments_nnn_b (long n1,long n2,long n3) +{ + if (DoDebug) + FPrintF (OutFile,"%d %d %d",(n1),(n2),(n3)); + else { + put_n (n1); + put_n (n2); + put_n (n3); + } +} + +static void put_arguments_nnnn_b (long n1,long n2,long n3,long n4) +{ + if (DoDebug) + FPrintF (OutFile,"%d %d %d %d",(n1),(n2),(n3),(n4)); + else { + put_n (n1); + put_n (n2); + put_n (n3); + put_n (n4); + } +} + +static void put_arguments_nnnnn_b (long n1,long n2,long n3,long n4,long n5) +{ + if (DoDebug) + FPrintF (OutFile,"%d %d %d %d %d",(n1),(n2),(n3),(n4),(n5)); + else { + put_n (n1); + put_n (n2); + put_n (n3); + put_n (n4); + put_n (n5); + } +} + +static void put_arguments_n__b (long n1) +{ + if (DoDebug) + FPrintF (OutFile,"%d ",(n1)); + else + put_n (n1); +} + +static void put_arguments__n_b (long n1) +{ + if (DoDebug) + FPrintF (OutFile," %d",(n1)); + else { + FPutC (' ',OutFile); + put_n (n1); + } +} + +static void put_arguments__n__b (long n1) +{ + if (DoDebug) + FPrintF (OutFile," %d ",(n1)); + else { + FPutC (' ',OutFile); + put_n (n1); + } +} + +static void put_arguments_nn__b (long n1,long n2) +{ + if (DoDebug) + FPrintF (OutFile,"%d %d ",(n1),(n2)); + else { + put_n (n1); + put_n (n2); + } +} + +static void put_arguments__nn_b (long n1,long n2) +{ + if (DoDebug) + FPrintF (OutFile," %d %d",(n1),(n2)); + else { + FPutC (' ',OutFile); + put_n (n1); + put_n (n2); + } +} + +enum { + Cbuild=136, + Cbuildh, + CbuildI, + CbuildB_b, + CbuildC_b, + CbuildI_b, + CbuildR_b, + CbuildF_b, + Ceq_desc, + CeqD_b, + CeqI_a, + CeqI_b, + Cfill, + Cfillh, + CfillI, + CfillB_b, + CfillC_b, + CfillF_b, + CfillI_b, + CfillR_b, + Cfill_a, + Cjmp, + Cjmp_false, + Cjmp_true, + Cjsr, + Cjsr_eval, + Cpop_a, + Cpop_b, + CpushB_a, + CpushC_a, + CpushI_a, + CpushF_a, + CpushR_a, + CpushD, + CpushI, + Cpush_a, + Cpush_b, + Cpush_arg, + Cpush_args, + Cpush_args_u, + Cpush_node, + Cpush_node_u, + Cpush_r_args, + Cpush_r_args_a, + Cpush_r_args_b, + Cpush_r_args_u, + Crepl_arg, + Crepl_args, + Crepl_r_args, + Crepl_r_args_a, + Crtn, + Cupdate_a, + Cupdate_b, + Cupdatepop_a, + Cupdatepop_b, + + Cd, + Co, + Cimpdesc, + Cimplab, + Cn +}; +#endif + +#define IbuildB "buildB" +#define IbuildC "buildC" +#define IbuildI "buildI" +#define IbuildR "buildR" +#define IbuildS "buildS" + +#define IbuildB_b "buildB_b" +#define IbuildC_b "buildC_b" +#define IbuildF_b "buildF_b" +#define IbuildI_b "buildI_b" +#define IbuildR_b "buildR_b" + +#define IfillB "fillB" +#define IfillC "fillC" +#define IfillI "fillI" +#define IfillR "fillR" +#define IfillS "fillS" + +#define IfillB_b "fillB_b" +#define IfillC_b "fillC_b" +#define IfillI_b "fillI_b" +#define IfillR_b "fillR_b" +#define IfillF_b "fillF_b" + +#define IeqB_a "eqB_a" +#define IeqC_a "eqC_a" +#define IeqI_a "eqI_a" +#define IeqR_a "eqR_a" +#define IeqS_a "eqS_a" + +#define IeqAC_a "eqAC_a" + +#define IeqB_b "eqB_b" +#define IeqC_b "eqC_b" +#define IeqI_b "eqI_b" +#define IeqR_b "eqR_b" + +#define IpushB "pushB" +#define IpushI "pushI" +#define IpushC "pushC" +#define IpushR "pushR" + +#define IpushD "pushD" + +#define IpushB_a "pushB_a" +#define IpushC_a "pushC_a" +#define IpushI_a "pushI_a" +#define IpushR_a "pushR_a" +#define IpushF_a "pushF_a" + +#define IpushD_a "pushD_a" + +#define Ipush_array "push_array" +#define Ipush_arraysize "push_arraysize" +#define Iselect "select" +#define Iupdate "update" +#define Ireplace "replace" + +#define Ipush_arg "push_arg" +#define Ipush_args "push_args" +#define Ipush_args_u "push_args_u" +#define Ipush_r_args "push_r_args" +#define Ipush_r_args_u "push_r_args_u" +#define Ipush_r_args_a "push_r_args_a" +#define Ipush_r_args_b "push_r_args_b" +#define Irepl_arg "repl_arg" +#define Irepl_args "repl_args" +#define Irepl_r_args "repl_r_args" +#define Irepl_r_args_a "repl_r_args_a" + +#define Ipush_node "push_node" +#define Ipush_node_u "push_node_u" + +#define Ifill "fill" +#define Ifillcp "fillcp" +#define Ifill_u "fill_u" +#define Ifillcp_u "fillcp_u" +#define Ifillh "fillh" +#define Ifill1 "fill1" +#define Ifill2 "fill2" + +#define Ibuild "build" +#define Ibuildh "buildh" +#define Ibuild_u "build_u" +#define IbuildAC "buildAC" + +#define Ifill_r "fill_r" +#define Ifill1_r "fill1_r" +#define Ifill2_r "fill2_r" +#define Ifill3_r "fill3_r" + +#define Ibuild_r "build_r" + +#define Ifill_a "fill_a" + +#define Ipush_a "push_a" +#define Ipush_b "push_b" + +#define Ijsr_eval "jsr_eval" + +#define Ipop_a "pop_a" +#define Ipop_b "pop_b" +#define Ieq_desc "eq_desc" +#define IeqD_b "eqD_b" + +#define Ijmp_false "jmp_false" +#define Ijmp_true "jmp_true" +#define Ijmp "jmp" +#define Ijsr "jsr" + +#define Icreate "create" +#define Iprint "print" + +#define Iupdate_a "update_a" +#define Iupdate_b "update_b" +#define Iupdatepop_a "updatepop_a" +#define Iupdatepop_b "updatepop_b" +#define Iupdate_b "update_b" +#define Ipop_a "pop_a" +#define Ipop_b "pop_b" + +#define Iget_node_arity "get_node_arity" +#define Iget_desc_arity "get_desc_arity" + +#define Ipush_arg_b "push_arg_b" + +#define Irtn "rtn" + +#define Ijmp_eval "jmp_eval" +#define Ijmp_eval_upd "jmp_eval_upd" + +#define Ihalt "halt" + +#define Itestcaf "testcaf" +#define Ipushcaf "pushcaf" +#define Ifillcaf "fillcaf" + +#define Iin "in" +#define Iout "out" + +static void put_instruction (char *instruction) +{ + FPutC ('\n',OutFile); + FPutC ('\t',OutFile); + FPutS (instruction,OutFile); +} + +static void put_instruction_ (char *instruction) +{ + FPutC ('\n',OutFile); + FPutC ('\t',OutFile); + FPutS (instruction,OutFile); + FPutC (' ',OutFile); +} + +static void put_instruction_code (int instruction_code) +{ + FPutC (instruction_code,OutFile); +} + +#define Dkeep "keep" +#define Dd "d" +#define Do "o" +#define Dimpdesc "impdesc" +#define Dimplab "implab" +#define Dexport "export" +#define Dn "n" +#define Dnu "nu" +#define Dn_string "n_string" +#define Ddesc "desc" +#define Ddescn "descn" +#define Ddescexp "descexp" +#define Drecord "record" +#define Dmodule "module" +#define Ddepend "depend" +#define Dcomp "comp" +#define Dcode "code" +#define Dstart "start" +#define Dstring "string" +#define Dcaf "caf" +#define Dendinfo "endinfo" + +#define Dpb "pb" +#define Dpd "pd" +#define Dpn "pn" +#define Dpl "pl" +#define Dpld "pld" +#define Dpt "pt" +#define Dpe "pe" + +static void put_directive (char *directive) +{ + FPutC ('\n',OutFile); + FPutC ('.',OutFile); + FPutS (directive,OutFile); +} + +static void put_directive_ (char *directive) +{ + FPutC ('\n',OutFile); + FPutC ('.',OutFile); + FPutS (directive,OutFile); + FPutC (' ',OutFile); +} + +static void put_first_directive_ (char *directive) +{ + FPutC ('.',OutFile); + FPutS (directive,OutFile); + FPutC (' ',OutFile); +} + +void BuildBasicFromB (ObjectKind kind,int b_offset) +{ + switch (kind){ + case IntObj: + case ProcIdObj: + case RedIdObj: + put_instruction_b (buildI_b); break; + case BoolObj: + put_instruction_b (buildB_b); break; + case CharObj: + put_instruction_b (buildC_b); break; + case RealObj: + put_instruction_b (buildR_b); break; + case FileObj: + put_instruction_b (buildF_b); break; + default: + error_in_function ("BuildBasicFromB"); + return; + } + + put_arguments_n_b (b_offset); +} + +void FillBasicFromB (ObjectKind kind, int boffs, int aoffs, FillKind fkind) +{ + TreatWaitListBeforeFill (aoffs, fkind); + switch (kind){ + case IntObj: + case ProcIdObj: /* we assume proc_id and red_id */ + case RedIdObj: /* to be integers */ + put_instruction_b (fillI_b); break; + case BoolObj: + put_instruction_b (fillB_b); break; + case CharObj: + put_instruction_b (fillC_b); break; + case RealObj: + put_instruction_b (fillR_b); break; + case FileObj: + put_instruction_b (fillF_b); break; + default: + error_in_function ("FillBasicFromB"); + return; + } + put_arguments_nn_b (boffs,aoffs); + TreatWaitListAfterFill (aoffs, fkind); +} + +void BuildBasic (ObjectKind obj,SymbValue val) +{ + switch (obj){ + case IntObj: + put_instruction_b (buildI); + put_arguments_i_b (val.val_int); + break; + case BoolObj: + put_instruction_ (IbuildB); + if (val.val_bool) + FPrintF (OutFile, "TRUE"); + else + FPrintF (OutFile, "FALSE"); + break; + case CharObj: + put_instruction_ (IbuildC); + FPrintF (OutFile, "%s", val.val_char); + break; + case RealObj: + put_instruction_ (IbuildR); + FPrintF (OutFile, "%s", val.val_real); + break; + case StringObj: + put_instruction_ (IbuildS); + FPrintF (OutFile, "%s", val.val_string); + break; + default: + error_in_function ("BuildBasic"); + return; + } +} + +void FillBasic (ObjectKind obj, SymbValue val, int offset, FillKind fkind) +{ + TreatWaitListBeforeFill (offset, fkind); + switch (obj){ + case IntObj: + put_instruction_b (fillI); + put_arguments_in_b (val.val_int,offset); + break; + case BoolObj: + put_instruction_ (IfillB); + if (val.val_bool) + FPrintF (OutFile, "TRUE %d", offset); + else + FPrintF (OutFile, "FALSE %d", offset); + break; + case CharObj: + put_instruction_ (IfillC); + FPrintF (OutFile, "%s %d", val.val_char, offset); + break; + case RealObj: + put_instruction_ (IfillR); + FPrintF (OutFile, "%s %d", val.val_real, offset); + break; + case StringObj: + put_instruction_ (IfillS); + FPrintF (OutFile, "%s %d", val.val_string, offset); + break; + default: + error_in_function ("FillBasic"); + return; + } + TreatWaitListAfterFill (offset, fkind); +} + +void IsBasic (ObjectKind obj, SymbValue val, int offset) +{ + switch (obj){ + case IntObj: + put_instruction_b (eqI_a); + put_arguments_in_b (val.val_int,offset); + break; + case BoolObj: + put_instruction_ (IeqB_a); + if (val.val_bool) + FPrintF (OutFile, "TRUE %d", offset); + else + FPrintF (OutFile, "FALSE %d", offset); + break; + case CharObj: + put_instruction_ (IeqC_a); + FPrintF (OutFile, "%s %d", val.val_char, offset); break; + case RealObj: + put_instruction_ (IeqR_a); + FPrintF (OutFile, "%s %d", val.val_real, offset); break; + case StringObj: + put_instruction_ (IeqS_a); + FPrintF (OutFile, "%s %d", val.val_string, offset); break; + default: + error_in_function ("IsBasic"); + return; + } +} + +void IsString (SymbValue val) +{ + put_instruction_ (IeqAC_a); + FPrintF (OutFile, "%s",val.val_string); +} + +void PushBasic (ObjectKind obj, SymbValue val) +{ + switch (obj){ + case IntObj: + put_instruction_b (pushI); + put_arguments_i_b (val.val_int); + break; + case BoolObj: + put_instruction_ (IpushB); + if (val.val_bool) + FPutS ("TRUE", OutFile); + else + FPutS ("FALSE", OutFile); + break; + case CharObj: + put_instruction_ (IpushC); + FPrintF (OutFile, "%s", val.val_char); break; + case RealObj: + put_instruction_ (IpushR); + FPrintF (OutFile, "%s", val.val_real); break; + default: + error_in_function ("PushBasic"); + return; + } +} + +void GenPushReducerId (int i) +{ + put_instruction_b (pushI); + put_arguments_n_b (i); +} + +void GenPushArgNr (int argnr) +{ + put_instruction_b (pushI); + put_arguments_n_b (argnr); +} + +void EqBasic (ObjectKind obj, SymbValue val, int offset) +{ + switch (obj){ + case IntObj: + put_instruction_b (eqI_b); + put_arguments_in_b (val.val_int,offset); + break; + case BoolObj: + put_instruction_ (IeqB_b); + if (val.val_bool) + FPrintF (OutFile, "TRUE %d", offset); + else + FPrintF (OutFile, "FALSE %d", offset); + break; + case CharObj: + put_instruction_ (IeqC_b); + FPrintF (OutFile, "%s %d", val.val_char, offset); break; + case RealObj: + put_instruction_ (IeqR_b); + FPrintF (OutFile, "%s %d", val.val_real, offset); break; + default: + error_in_function ("EqBasic"); + return; + } +} + +void PushBasicFromAOnB (ObjectKind kind,int offset) +{ + switch (kind){ + case IntObj: + case ProcIdObj: + case RedIdObj: + put_instruction_b (pushI_a); + break; + case BoolObj: + put_instruction_b (pushB_a); + break; + case CharObj: + put_instruction_b (pushC_a); + break; + case RealObj: + put_instruction_b (pushR_a); + break; + case FileObj: + put_instruction_b (pushF_a); + break; + default: + error_in_function ("PushBasicFromAOnB"); + return; + } + put_arguments_n_b (offset); +} + +void GenPushD_a (int a_offset) +{ + put_instruction_ (IpushD_a); + FPrintF (OutFile,"%d",a_offset); +} + +void PushBasicOnB (ObjectKind obj, int offset) +{ + int i; + + for (i = ObjectSizes[obj]; i > 0; i--) + GenPushB (offset + ObjectSizes[obj] - 1); +} + +void UpdateBasic (int size, int srcoffset, int dstoffset) +{ + if (srcoffset < dstoffset){ + int i; + + for (i=size-1; i >= 0; i--) + GenUpdateB (srcoffset+i, dstoffset+i); + } else if (srcoffset > dstoffset){ + int i; + + for (i=0; i < size; i++) + GenUpdateB (srcoffset+i, dstoffset+i); + } +} + +static Bool IsDirective (Instructions instruction, char *directive) +{ + char *s; + + s=instruction->instr_this; + while (isspace(*s)) + ++s; + if (*s!='.') + return False; + + for (; *directive; ++directive) + if (*directive!=*++s) + return False; + + return True; +} + +static Bool IsInlineFromCurrentModule (SymbDef def) +{ + RuleAlts alt; + Instructions instruction, next; + /* + if (def->sdef_kind!=IMPRULE) + return False; + */ + alt=def->sdef_rule->rule_alts; + + if (alt->alt_kind!=ExternalCall || !alt->alt_rhs_code->co_is_abc_code) + return False; + + instruction=alt->alt_rhs_code->co_instr; + + if (!IsDirective(instruction, "inline")) + return False; + + for (instruction=instruction->instr_next;(next=instruction->instr_next)!=NULL;instruction=next) + ; + + return (IsDirective(instruction, "end")); +} + +/* + For ABC to target machine code generation we supply the abc code + with special stack layout directives. The routines for doing this + are 'GenBStackElems', 'GenStackLayoutOfNode' and 'GenStackLayoutOfState'. +*/ + +static char BElems[] = BASIC_ELEMS_STRING; + +static void GenBStackElems (StateS state) +{ + if (IsSimpleState (state)){ + if (state.state_kind == OnB) + FPutC (BElems [(int) state.state_object], OutFile); + } else { + int arity; + States argstates; + + switch (state.state_type){ + case TupleState: + argstates = state.state_tuple_arguments; + break; + case RecordState: + argstates = state.state_record_arguments; + break; + case ArrayState: + return; + default: + error_in_function ("GenBStackElems"); + return; + } + for (arity=0; arity < state.state_arity; ++arity) + GenBStackElems (argstates[arity]); + } +} + +static void GenABStackElems (StateS state) +{ + if (IsSimpleState (state)){ + if (state.state_kind == OnB) + FPutC (BElems [(int) state.state_object], OutFile); + else + FPutC ('a', OutFile); + + } else { + int arity; + States argstates; + + switch (state.state_type){ + case TupleState: + argstates = state.state_tuple_arguments; + break; + case RecordState: + argstates = state.state_record_arguments; + break; + case ArrayState: + FPutC ('a', OutFile); + return; + default: + error_in_function ("GenABStackElems"); + return; + } + for (arity=0; arity < state.state_arity; arity++) + GenABStackElems (argstates[arity]); + } +} + +void GenDStackLayout (int asize,int bsize,Args fun_args) +{ + if (DoStackLayout){ + put_directive_b (d); + if (bsize > 0){ + put_arguments_nn__b (asize,bsize); + + while (fun_args!=NULL){ + GenBStackElems (fun_args->arg_state); + fun_args=fun_args->arg_next; + } + } else + put_arguments_nn_b (asize,0); + } +} + +void GenOStackLayout (int asize,int bsize,Args fun_args) +{ + if (DoStackLayout){ + put_directive_b (o); + if (bsize > 0){ + put_arguments_nn__b (asize,bsize); + + while (fun_args!=NULL){ + GenBStackElems (fun_args->arg_state); + fun_args=fun_args->arg_next; + } + } else + put_arguments_nn_b (asize,0); + } +} + +static void CallFunction2 (Label label, SymbDef def, Bool isjsr, StateS root_state, Args fun_args, int arity) +{ + int ain,aout,bin,bout; + Args arg; + + ain=0; + bin=0; + + if (fun_args != NULL){ + for (arg = fun_args; arg; arg = arg -> arg_next) + AddSizeOfState (arg -> arg_state, &ain, &bin); + } else + ain = arity; + DetermineSizeOfState (root_state, &aout, &bout); + + if (IsSimpleState (root_state) && (root_state.state_kind!=OnB && root_state.state_kind!=StrictRedirection)) + ain++; + + if (label->lab_mod && label->lab_mod==CurrentModule) + label->lab_mod = NULL; + + label->lab_pref = s_pref; + + if (def->sdef_kind==SYSRULE){ + char *instr; + + instr= def->sdef_ident->ident_instructions; + + if (instr && *instr!='\0'){ + char *tail; + + for (; *instr != '\0'; instr = tail){ + for (tail = instr; *tail != '\n'; tail++) + ; + *tail = '\0'; + FPrintF (OutFile, "\n%s", instr); + *tail++ = '\n'; + } + if (!isjsr) + GenRtn (aout, bout, root_state); + } else { + if (def->sdef_ident->ident_environ && instr==NULL) + { char *previous_module = CurrentModule; + char *previous_ext = CurrentExt; + + CurrentModule = def->sdef_module; + CurrentExt = GetFileExtension (abcFile); + + StaticMessage (False, "%D", "no inline code for this rule", def); + + CurrentModule = previous_module; + CurrentExt = previous_ext; + + def->sdef_ident->ident_environ = (char *) NIL; + } + GenDStackLayout (ain, bin, fun_args); + if (isjsr){ + GenJsr (label); + GenOStackLayoutOfState (aout, bout, root_state); + } else + GenJmp (label); + } + } else if (def->sdef_kind==IMPRULE && IsInlineFromCurrentModule (def)){ + Instructions instruction, last, first, next; + + instruction=def->sdef_rule->rule_alts->alt_rhs_code->co_instr; + instruction=instruction->instr_next; + first=instruction; + + last=NULL; + for (;(next=instruction->instr_next)!=NULL;instruction=next) + last=instruction; + + last->instr_next=NULL; + GenInstructions (first); + last->instr_next=instruction; + + if (!isjsr) + GenRtn (aout, bout, root_state); + } else { + GenDStackLayout (ain, bin, fun_args); + if (isjsr){ + GenJsr (label); + GenOStackLayoutOfState (aout, bout, root_state); + } else + GenJmp (label); + } +} + +void CallFunction (Label label, SymbDef def, Bool isjsr, Node root) +{ + if (def->sdef_arfun<NoArrayFun) + CallArrayFunction (def,isjsr,&root->node_state); + else + CallFunction2 (label, def, isjsr, root->node_state, root->node_arguments, root->node_arity); +} + +static void GenArraySize (Label elemdesc, int asize, int bsize) +{ + put_instruction_ (Ipush_arraysize); + GenLabel (elemdesc); + FPrintF (OutFile, " %d %d", asize, bsize); +} + +static void GenArraySelect (Label elemdesc, int asize, int bsize) +{ + put_instruction_ (Iselect); + GenLabel (elemdesc); + FPrintF (OutFile, " %d %d", asize, bsize); +} + +static void GenArrayUpdate (Label elemdesc, int asize, int bsize) +{ + put_instruction_ (Iupdate); + GenLabel (elemdesc); + FPrintF (OutFile, " %d %d", asize, bsize); +} + +static void GenArrayReplace (Label elemdesc, int asize, int bsize) +{ + put_instruction_ (Ireplace); + GenLabel (elemdesc); + FPrintF (OutFile, " %d %d", asize, bsize); +} + +extern Symbol UnboxedArrayFunctionSymbols []; + +static Label ApplyLabel; +static StateS ApplyState; + +extern SymbDef ApplyDef; /* from codegen2.c */ + +static void ApplyOperatorToArrayAndIndex (Bool is_jsr) +{ + GenPushA (0); + GenCreate (-1); + GenFillArray (3, 0, NormalFill); + + GenUpdateA (0, 2); + + BuildBasicFromB (IntObj,0); + + GenPopB (SizeOfInt); + + GenUpdateA (0, 4); + + GenPopA (2); + + CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2); + CallFunction2 (ApplyLabel, ApplyDef, is_jsr, ApplyState, NULL, 2); +} + +static void ApplyOperatorToArrayElem (int asize, int bsize, ObjectKind kind) +{ + if (asize==0){ + GenPushA (0); + + BuildBasicFromB (kind,0); + + GenUpdateA (0, 2); + GenPopB (bsize); + GenPopA (1); + } + + CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2); +} + +static void UnpackResultTuple (int asize,int bsize,ObjectKind kind) +{ + GenReplArgs (2, 2); + if (asize==0){ + PushBasicFromAOnB (kind, 0); + GenPopA (1); + } + GenPushArray (asize); + GenUpdateA (0,1+asize); + GenPopA (1); +} + +void CallArrayFunction (SymbDef array_def,Bool is_jsr,StateP node_state_p) +{ + LabDef elem_desc; + int asize, bsize; + Bool elem_is_lazy; + StateS array_state; + ArrayFunKind fkind; + StateP function_state_p; + + fkind = (ArrayFunKind)array_def->sdef_arfun; + function_state_p = array_def->sdef_rule_type->rule_type_state_p; + + if (function_state_p[0].state_type==SimpleState && function_state_p[0].state_object==UnknownObj){ + StateS elem_state; + + switch (fkind){ + case CreateArrayFun: + case _CreateArrayFun: + array_state=function_state_p[-1]; + break; + case _UnqArraySelectNextFun: + case _UnqArraySelectLastFun: + case _ArrayUpdateFun: + if (function_state_p[1].state_type==TupleState) + array_state=function_state_p[1].state_tuple_arguments[0]; + else + error_in_function ("CallArrayFunction"); + break; + default: + array_state=function_state_p[1]; + } + + elem_state = array_state.state_array_arguments [0]; + + if (array_state.state_type==ArrayState && (array_state.state_mark & STATE_UNBOXED_ARRAY_MASK)){ + if (ApplyLabel == NULL){ + ApplyLabel = CompAllocType (LabDef); + ConvertSymbolToLabel (ApplyLabel, ApplyDef); + } + + switch (fkind){ + case CreateArrayFun: + case _CreateArrayFun: + GenPushA (0); + BuildBasicFromB (IntObj,0); + GenPopB (SizeOfInt); + + GenUpdateA (0, 2); + GenPopA (1); + + CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2); + + if (fkind!=_CreateArrayFun) + CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2); + + GenPushArray (0); + GenUpdateA (0, 1); + GenPopA (1); + + break; + case ArraySelectFun: + if (elem_state.state_kind==StrictOnA) + ApplyOperatorToArrayAndIndex (is_jsr); + else { + ApplyOperatorToArrayAndIndex (True); + PushBasicFromAOnB (elem_state.state_object, 0); + GenPopA (1); + } + break; + case UnqArraySelectFun: +#ifdef OBSERVE_ARRAY_SELECTS_IN_PATTERN + DetermineSizeOfState (elem_state,&asize,&bsize); + ApplyOperatorToArrayAndIndex (True); + if (node_state_p->state_type==TupleState + && node_state_p->state_tuple_arguments[1].state_type==SimpleState + && node_state_p->state_tuple_arguments[1].state_kind==Undefined) + { + GenReplArg (2,1); + if (asize==0){ + PushBasicFromAOnB (elem_state.state_object,0); + GenPopA (1); + } + } else + UnpackResultTuple (asize,bsize,elem_state.state_object); + break; +#endif + case _UnqArraySelectFun: + DetermineSizeOfState (elem_state,&asize,&bsize); + ApplyOperatorToArrayAndIndex (True); + UnpackResultTuple (asize, bsize, elem_state.state_object); + break; + case _UnqArraySelectNextFun: + case _UnqArraySelectLastFun: + DetermineSizeOfState (elem_state,&asize,&bsize); + + GenCreate (-1); + GenFillArray (3, 0, NormalFill); + GenCreate (-1); + GenFillArray (3, 0, NormalFill); + GenBuildh (&tuple_lab,2); + + GenUpdateA (0, 2); + + BuildBasicFromB (IntObj,0); + + GenPopB (SizeOfInt); + + GenUpdateA (0, 4); + + GenPopA (2); + + CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2); + CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2); + + UnpackResultTuple (asize, bsize, elem_state.state_object); + break; + + case _ArrayUpdateFun: + DetermineSizeOfState (elem_state,&asize,&bsize); + + GenCreate (-1); + GenFillArray (3, 0, NormalFill); + GenCreate (-1); + GenFillArray (3, 0, NormalFill); + GenBuildh (&tuple_lab,2); + + GenUpdateA (0, 2); + + BuildBasicFromB (IntObj,0); + GenPopB (SizeOfInt); + + GenUpdateA (0, 4); + + GenPopA (2); + + CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2); + CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2); + + ApplyOperatorToArrayElem (asize, bsize, elem_state.state_object); + + GenPushArray (0); + GenUpdateA (0, 1); + GenPopA (1); + break; + case ArrayUpdateFun: + DetermineSizeOfState (elem_state,&asize,&bsize); + + ApplyOperatorToArrayAndIndex (True); + ApplyOperatorToArrayElem (asize,bsize,elem_state.state_object); + + GenPushArray (0); + GenUpdateA (0, 1); + GenPopA (1); + break; + case ArrayReplaceFun: + DetermineSizeOfState (elem_state,&asize,&bsize); + + ApplyOperatorToArrayAndIndex (True); + ApplyOperatorToArrayElem (asize,bsize,elem_state.state_object); + UnpackResultTuple (asize,bsize,elem_state.state_object); + break; + case ArraySizeFun: + GenCreate (-1); + GenFillArray (2, 0, NormalFill); + GenUpdateA (0, 2); + + GenPopA (1); + + CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2); + + PushBasicFromAOnB (IntObj, 0); + GenPopA (1); + break; + case UnqArraySizeFun: + GenCreate (-1); + GenFillArray (2, 0, NormalFill); + GenUpdateA (0, 2); + + GenPopA (1); + + CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2); + + UnpackResultTuple (0, SizeOfInt, IntObj); + + break; + + } + if (! is_jsr){ + DetermineSizeOfState (function_state_p[-1], & asize, & bsize); + GenRtn (asize,bsize,function_state_p[-1]); + } + return; + } + else + { GenPopA (1); + elem_desc = BasicDescriptors [UnknownObj]; + asize = 1; + bsize = 0; + elem_is_lazy = elem_state.state_type==SimpleState && elem_state.state_kind==OnA; + } + } else { + switch (fkind){ + case CreateArrayFun: + case _CreateArrayFun: + array_state = function_state_p[-1]; + break; + case _UnqArraySelectNextFun: + case _UnqArraySelectLastFun: + case _ArrayUpdateFun: + if (function_state_p[0].state_type==TupleState) + array_state=function_state_p[0].state_tuple_arguments[0]; + else + error_in_function ("CallArrayFunction"); + break; + default: + array_state = function_state_p[0]; + } + + if (array_state.state_type == ArrayState){ + StateS elem_state = array_state.state_array_arguments [0]; + DetermineArrayElemDescr (elem_state, & elem_desc); + DetermineSizeOfState (elem_state, & asize, & bsize); + elem_is_lazy = elem_state.state_type==SimpleState && elem_state.state_kind==OnA; + } else + error_in_function ("CallArrayFunction"); + } + + switch (fkind){ + case CreateArrayFun: + put_instruction_ ("create_array"); + GenLabel (&elem_desc); + FPrintF (OutFile," %d %d",asize,bsize); + break; + case _CreateArrayFun: + put_instruction_ ("create_array_"); + GenLabel (&elem_desc); + FPrintF (OutFile," %d %d",asize,bsize); + break; + case ArraySelectFun: + GenArraySelect (&elem_desc,asize,bsize); + if (elem_is_lazy){ + if (is_jsr) + GenJsrEval (0); + else { + GenJmpEval (); + return; + } + } + break; + case UnqArraySelectFun: +#ifdef OBSERVE_ARRAY_SELECTS_IN_PATTERN + if (! (node_state_p->state_type==TupleState + && node_state_p->state_tuple_arguments[1].state_type==SimpleState + && node_state_p->state_tuple_arguments[1].state_kind==Undefined)) + { + GenPushA (0); + } + GenArraySelect (&elem_desc,asize,bsize); + break; +#endif + case _UnqArraySelectFun: + GenPushA (0); + GenArraySelect (&elem_desc,asize,bsize); + break; + case _UnqArraySelectNextFun: + case _UnqArraySelectLastFun: + { + int record_or_array_a_size,record_or_array_b_size; + + if (node_state_p->state_type!=TupleState) + error_in_function ("CallArrayFunction"); + + DetermineSizeOfState (node_state_p->state_tuple_arguments[1],&record_or_array_a_size,&record_or_array_b_size); + + if (record_or_array_b_size>0){ + int i; + + GenPushB (record_or_array_b_size); + + for (i=record_or_array_b_size; i>=0; --i) + GenUpdateB (i,i+1); + + GenPopB (1); + } + + GenArraySelect (&elem_desc,asize,bsize); + break; + } + case _ArrayUpdateFun: + { + int i,result_a_size,result_b_size; + + DetermineSizeOfState (*node_state_p,&result_a_size,&result_b_size); + + if (asize!=0){ + for (i=0; i<asize; ++i) + GenPushA (result_a_size+asize); + + for (i=result_a_size-1; i>=0; --i) + GenUpdateA (i+asize+1,i+asize+1+asize); + + for (i=asize-1; i>=0; --i) + GenUpdateA (i,i+1+asize); + + GenPopA (asize); + } + + if (result_b_size!=0){ + int b_size_with_index; + + b_size_with_index=bsize+1; + + for (i=0; i<b_size_with_index; ++i) + GenPushB (result_b_size+b_size_with_index-1); + + for (i=result_b_size-1; i>=0; --i) + GenUpdateB (i+b_size_with_index,i+b_size_with_index+b_size_with_index); + + for (i=b_size_with_index-1; i>=0; --i) + GenUpdateB (i,i+b_size_with_index); + + GenPopB (b_size_with_index); + } + + GenArrayUpdate (&elem_desc,asize,bsize); + + for (i=0; i<result_a_size; ++i) + GenKeep (0,i+1); + + GenPopA (1); + + break; + } + case ArrayUpdateFun: + GenArrayUpdate (& elem_desc, asize, bsize); + break; + case ArrayReplaceFun: + GenArrayReplace (& elem_desc, asize, bsize); + break; + case ArraySizeFun: + GenArraySize (& elem_desc, asize, bsize); + break; + case UnqArraySizeFun: + GenPushA (0); + GenArraySize (& elem_desc, asize, bsize); + break; + } + + if (! is_jsr){ + DetermineSizeOfState (*node_state_p,&asize,&bsize); + GenRtn (asize,bsize,*node_state_p); + } +} + +void GenNewContext (Label contlab, int offset) +{ + FPrintF (OutFile, "\n\tset_entry "); + GenLabel (contlab); + FPrintF (OutFile, " %d", offset); +} + +void GenSetDefer (int offset) +{ + FPrintF (OutFile, "\n\tset_defer %d", offset); +} + +void GenReplArgs (int arity, int nrargs) +{ + if (nrargs > 0){ + put_instruction_b (repl_args); + put_arguments_nn_b (arity,nrargs); + } else + GenPopA (1); +} + +void GenReplArg (int arity, int argnr) +{ + put_instruction_b (repl_arg); + put_arguments_nn_b (arity,argnr); +} + +void GenPushArgs (int offset, int arity, int nrargs) +{ + if (nrargs > 0){ + put_instruction_b (push_args); + put_arguments_nnn_b (offset,arity,nrargs); + } +} + +void GenPushArgsU (int offset, int arity, int nrargs) +{ + if (nrargs > 0){ + put_instruction_b (push_args_u); + put_arguments_nnn_b (offset,arity,nrargs); + } +} + +void GenPushArg (int offset, int arity, int argnr) +{ + put_instruction_b (push_arg); + put_arguments_nnn_b (offset,arity,argnr); +} + +void GenPushRArgs (int offset, int nr_a_args, int nr_b_args) +{ + if (nr_a_args + nr_b_args > 0){ + put_instruction_b (push_r_args); + put_arguments_nnn_b (offset,nr_a_args,nr_b_args); + } +} + +void GenPushRArgsU (int offset,int n_a_args,int n_b_args) +{ + if (n_a_args + n_b_args > 0){ + put_instruction_b (push_r_args_u); + put_arguments_nnn_b (offset,n_a_args,n_b_args); + } +} + +void GenPushRArgA (int offset, int tot_nr_a_args, int tot_nr_b_args, int args_nr, int nr_a_args) +{ + if (nr_a_args > 0){ + put_instruction_b (push_r_args_a); + put_arguments_nnnnn_b (offset,tot_nr_a_args,tot_nr_b_args,args_nr,nr_a_args); + } +} + +void GenPushRArgB (int offset, int tot_nr_a_args, int tot_nr_b_args, int args_nr, int nr_b_args) +{ + if (nr_b_args > 0){ + put_instruction_b (push_r_args_b); + put_arguments_nnnnn_b (offset,tot_nr_a_args,tot_nr_b_args,args_nr,nr_b_args); + } +} + +void GenReplRArgs (int nr_a_args, int nr_b_args) +{ + if (nr_a_args + nr_b_args > 0){ + put_instruction_b (repl_r_args); + put_arguments_nn_b (nr_a_args,nr_b_args); + } else + GenPopA (1); +} + +void GenReplRArgA (int tot_nr_a_args, int tot_nr_b_args, int args_nr, int nr_a_args) +{ + if (nr_a_args > 0){ + put_instruction_b (repl_r_args_a); + put_arguments_nnnn_b (tot_nr_a_args,tot_nr_b_args,args_nr,nr_a_args); + } else + GenPopA (1); +} + +void GenPushNode (Label contlab, int arity) +{ + put_instruction_b (push_node); + GenLabel (contlab); + put_arguments__n_b (arity); +} + +void GenPushNodeU (Label contlab,int a_size,int b_size) +{ + put_instruction_b (push_node_u); + GenLabel (contlab); + put_arguments__nn_b (a_size,b_size); +} + +void GenFill (Label symblab, int arity,Label contlab, int offset, FillKind fkind) +{ + TreatWaitListBeforeFill (offset, fkind); + + put_instruction_b (fill); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + put_arguments__n__b (arity); + + GenLabel (contlab); + + put_arguments__n_b (offset); + + if (arity < 0) + arity = 1; + TreatWaitListAfterFill (offset-arity, fkind); +} + +void GenFillU (Label symblab,int a_size,int b_size,Label contlab,int offset) +{ + put_instruction_ (Ifill_u); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + FPrintF (OutFile," %d %d ",a_size,b_size); + + GenLabel (contlab); + + put_arguments__n_b (offset); +} + +void GenFillcp (Label symblab,int arity,Label contlab,int offset,char bits[]) +{ + put_instruction_b (fillcp); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + put_arguments__n__b (arity); + + GenLabel (contlab); + + put_arguments__n_b (offset); + + FPrintF (OutFile," %s",bits); +} + +void GenFillcpU (Label symblab,int a_size,int b_size,Label contlab,int offset,char bits[]) +{ + put_instruction_b (fillcp_u); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + FPrintF (OutFile," %d %d ",a_size,b_size); + + GenLabel (contlab); + + put_arguments__n_b (offset); + + FPrintF (OutFile," %s",bits); +} + +void GenFillh (Label symblab, int arity, int offset, FillKind fkind) +{ + TreatWaitListBeforeFill (offset, fkind); + + put_instruction_b (fillh); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + put_arguments__nn_b (arity,offset); + + if (arity < 0) + arity = 1; + TreatWaitListAfterFill (offset-arity, fkind); +} + +void GenFill1 (Label symblab,int arity,int offset,char bits[]) +{ + put_instruction_ (Ifill1); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + FPrintF (OutFile," %d %d %s",arity,offset,bits); +} + +void GenFill2 (Label symblab,int arity,int offset,char bits[]) +{ + put_instruction_ (Ifill2); + GenLabel (symblab); + FPrintF (OutFile," %d %d %s",arity,offset,bits); +} + +void GenBuild (Label symblab,int arity,Label contlab) +{ + put_instruction_b (build); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + put_arguments__n__b (arity); + + GenLabel (contlab); +} + +void GenBuildh (Label symblab,int arity) +{ + put_instruction_b (buildh); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + put_arguments__n_b (arity); +} + +void GenBuildU (Label symblab,int a_size,int b_size,Label contlab) +{ + put_instruction_ (Ibuild_u); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + FPrintF (OutFile," %d %d ",a_size,b_size); + + GenLabel (contlab); +} + +void GenBuildArray (int argoffset) +{ + GenPushA (argoffset); + GenBuildh (& BasicDescriptors [ArrayObj], 1); +} + +void GenBuildString (SymbValue val) +{ + put_instruction_ (IbuildAC); + FPrintF (OutFile, "%s", val.val_string); +} + +static void GenFieldLabel (Label label,char *record_name) +{ + SymbDef def; + + def = (SymbDef) label->lab_name; + + if (label->lab_mod) + FPrintF (OutFile,"e_%s_%s%s.%s", + label->lab_mod,label->lab_pref,record_name,def->sdef_ident->ident_name); + else if (DoDebug){ + if (def->sdef_kind==IMPRULE) + FPrintF (OutFile, "%s%s.%s.%u", + label->lab_pref,record_name,def->sdef_ident->ident_name,def->sdef_number); + else + FPrintF (OutFile, "%s%s.%s",label->lab_pref,record_name,def->sdef_ident->ident_name); + } else if (def->sdef_number==0) + FPrintF (OutFile, "%s%s",label->lab_pref,def->sdef_ident->ident_name); + else if (label->lab_pref[0] == '\0') + FPrintF (OutFile,LOCAL_D_PREFIX "%u",def->sdef_number); + else + FPrintF (OutFile,"%s%u",label->lab_pref,def->sdef_number); +} + +void GenBuildFieldSelector (Label symblab,Label contlab,char *record_name,int arity) +{ + put_instruction_b (build); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenFieldLabel (symblab,record_name); + else + FPutS (empty_lab.lab_name, OutFile); + + put_arguments__n__b (arity); + + GenFieldLabel (contlab,record_name); +} + +void GenFieldLabelDefinition (Label label,char *record_name) +{ + FPutS ("\n", OutFile); + GenFieldLabel (label,record_name); +} + +void GenFillFieldSelector (Label symblab,Label contlab,char *record_name,int arity,int offset,FillKind fkind) +{ + TreatWaitListBeforeFill (offset,fkind); + + put_instruction_b (fill); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenFieldLabel (symblab,record_name); + else + FPutS (empty_lab.lab_name, OutFile); + + put_arguments__n__b (arity); + + GenFieldLabel (contlab,record_name); + + put_arguments__n_b (offset); + + TreatWaitListAfterFill (offset-1,fkind); +} + +void GenFillR (Label symblab,int nr_a_args,int nr_b_args,int rootoffset,int a_offset,int b_offset,FillKind fkind,Bool pop_args) +{ + TreatWaitListBeforeFill (rootoffset, fkind); + + put_instruction_ (Ifill_r); + + if (! symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + if (nr_a_args==0) + a_offset=0; + if (nr_b_args==0) + b_offset=0; + + FPrintF (OutFile, " %d %d %d %d %d",nr_a_args,nr_b_args,rootoffset,a_offset,b_offset); + + if (pop_args){ + GenPopA (nr_a_args); + GenPopB (nr_b_args); + TreatWaitListAfterFill (rootoffset-nr_a_args, fkind); + } else + TreatWaitListAfterFill (rootoffset, fkind); +} + +void GenFill1R (Label symblab,int n_a_args,int n_b_args,int rootoffset,char bits[]) +{ + put_instruction_ (Ifill1_r); + + if (! symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + FPrintF (OutFile, " %d %d %d %s",n_a_args,n_b_args,rootoffset,bits); +} + +void GenFill2R (Label symblab,int n_a_args,int n_b_args,int rootoffset,char bits[]) +{ + put_instruction_ (Ifill2_r); + + if (! symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + FPrintF (OutFile, " %d %d %d %s",n_a_args,n_b_args,rootoffset,bits); +} + +void GenFill3R (Label symblab,int n_a_args,int n_b_args,int rootoffset,char bits[]) +{ + put_instruction_ (Ifill3_r); + + if (! symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + FPrintF (OutFile, " %d %d %d %s",n_a_args,n_b_args,rootoffset,bits); +} + +void GenBuildR (Label symblab,int nr_a_args,int nr_b_args,int a_offset,int b_offset,Bool pop_args) +{ + put_instruction_ (Ibuild_r); + + if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol)) + GenLabel (symblab); + else + FPutS (empty_lab.lab_name, OutFile); + + if (nr_a_args==0) + a_offset=0; + if (nr_b_args==0) + b_offset=0; + + FPrintF (OutFile, " %d %d %d %d",nr_a_args,nr_b_args,a_offset,b_offset); + + if (pop_args){ + if (nr_a_args>0){ + GenUpdateA (0,nr_a_args); + GenPopA (nr_a_args); + } + GenPopB (nr_b_args); + } +} + +void GenFillFromA (int src, int dst, FillKind fkind) +{ + if (src == dst) + return; + + TreatWaitListBeforeFill (dst, fkind); + put_instruction_b (fill_a); + put_arguments_nn_b (src,dst); + TreatWaitListAfterFill (dst, fkind); +} + +void GenFillArray (int argoffset, int rootoffset, FillKind fkind) +{ + GenPushA (argoffset); + GenFillh (&BasicDescriptors [ArrayObj], 1, rootoffset+1, fkind); +} + +void GenPushArray (int rootoffset) +{ + put_instruction_ (Ipush_array); + FPrintF (OutFile, "%d", rootoffset); +} + +void GenRtn (int asize, int bsize, StateS resultstate) +{ + GenDStackLayoutOfState (asize, bsize, resultstate); + put_instructionb (rtn); +} + +void GenPushA (int offset) +{ + if (offset<0) + error_in_function ("GenPushA"); + + put_instruction_b (push_a); + put_arguments_n_b (offset); +} + +void GenPushB (int offset) +{ + if (offset<0) + error_in_function ("GenPushB"); + + put_instruction_b (push_b); + put_arguments_n_b (offset); +} + +void GenJsrEval (int offset) +{ + put_instruction_b (jsr_eval); + put_arguments_n_b (offset); +} + +void GenJmpEval (void) +{ + put_instruction (Ijmp_eval); +} + +void GenPopA (int nr) +{ + if (nr > 0){ + put_instruction_b (pop_a); + put_arguments_n_b (nr); + } +} + +void GenPopB (int nr) +{ + if (nr > 0){ + put_instruction_b (pop_b); + put_arguments_n_b (nr); + } +} + +void GenEqDesc (Label symblab,int arity,int offset) +{ + put_instruction_b (eq_desc); + GenLabel (symblab); + put_arguments__nn_b (arity,offset); +} + +void GenEqD_b (Label symblab,int arity) +{ + put_instruction_b (eqD_b); + GenLabel (symblab); + put_arguments__n_b (arity); +} + +void GenExitFalse (Label to) +{ + put_instruction_ ("exit_false"); + GenLabel (to); +} + +void GenJmpFalse (Label to) +{ + put_instruction_b (jmp_false); + GenLabel (to); +} + +void GenJmpTrue (Label to) +{ + put_instruction_b (jmp_true); + GenLabel (to); +} + +void GenJmp (Label tolab) +{ + put_instruction_b (jmp); + GenLabel (tolab); +} + +void GenJsr (Label tolab) +{ + put_instruction_b (jsr); + GenLabel (tolab); +} + +void GenCreate (int arity) +{ + if (arity == -1) + put_instruction (Icreate); + else { + put_instruction_ (Icreate); + FPrintF (OutFile, "%d", arity); + } +} + +void GenDumpString (char *str) +{ + put_instruction_ (Iprint); + FPrintF (OutFile, "\"%s\"", str); + put_instruction (Ihalt); +} + +void GenLabelDefinition (Label lab) +{ + if (lab){ + FPutC ('\n', OutFile); + GenLabel (lab); + } +} + +void GenUpdateA (int src, int dst) +{ + if (src != dst){ + put_instruction_b (update_a); + put_arguments_nn_b (src,dst); + } +} + +void GenUpdatePopA (int src, int dst) +{ + if (src!=dst){ + if (dst!=0){ + put_instruction_b (updatepop_a); + put_arguments_nn_b (src,dst); + } else { + put_instruction_b (update_a); + put_arguments_nn_b (src,dst); + } + } else + if (dst > 0){ + put_instruction_b (pop_a); + put_arguments_n_b (dst); + } +} + +void GenUpdateB (int src, int dst) +{ + if (src != dst){ + put_instruction_b (update_b); + put_arguments_nn_b (src,dst); + } +} + +void GenUpdatePopB (int src, int dst) +{ + if (src!=dst){ + if (dst!=0){ + put_instruction_b (updatepop_b); + put_arguments_nn_b (src,dst); + } else { + put_instruction_b (update_b); + put_arguments_nn_b (src,dst); + } + } else + if (dst > 0) { + put_instruction_b (pop_b); + put_arguments_n_b (dst); + } +} + +void GenHalt (void) +{ + put_instruction (Ihalt); +} + +void GenSetRedId (int offset) +{ + FPrintF (OutFile, "\n\tset_red_id %d", offset); +} + +void GenNewParallelReducer (int offset, char *reducer_code) +{ + FPrintF (OutFile, "\n\tnew_ext_reducer %s %d", reducer_code, offset); +} + +void GenNewContInterleavedReducer (int offset) +{ + FPrintF (OutFile, "\n\tnew_int_reducer _cont_reducer %d", offset); + FPrintF (OutFile, "\n\tforce_cswitch", offset); +} + +void GenNewInterleavedReducer (int offset, char *reducer_code) +{ + FPrintF (OutFile, "\n\tnew_int_reducer %s %d", reducer_code, offset); +} + +void GenSendGraph (char *code, int graphoffs, int chanoffs) +{ + FPrintF (OutFile, "\n\tsend_graph %s %d %d", code, graphoffs, chanoffs); +} + +void GenCreateChannel (char *code) +{ + FPrintF (OutFile, "\n\tcreate_channel %s", code); +} + +void GenNewP (void) +{ + FPutS ("\n\tnewP", OutFile); +} + +void SetContinue (int offset) +{ + FPrintF (OutFile, "\n\tset_continue %d", offset); +} + +void SetContinueOnReducer (int offset) +{ + FPrintF (OutFile, "\n\tset_continue2 %d", offset); +} + +void GenGetNodeArity (int offset) +{ + put_instruction_ (Iget_node_arity); + FPrintF (OutFile, "%d", offset); +} + +static void GenGetDescArity (int offset) +{ + put_instruction_ (Iget_desc_arity); + FPrintF (OutFile, "%d", offset); +} + +void GenPushArgB (int offset) +{ + put_instruction_ (Ipush_arg_b); + FPrintF (OutFile, "%d", offset); +} + +void GenImport (SymbDef sdef) +{ + if (DoStackLayout){ + char *name; + + name = sdef->sdef_ident->ident_name; + + switch (sdef->sdef_kind){ + case DEFRULE: + case SYSRULE: + if (sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK)){ + put_directive_b (impdesc); + FPrintF (OutFile, "e_%s_" D_PREFIX "%s",sdef->sdef_module,name); + } + if (sdef->sdef_mark & SDEF_USED_STRICTLY_MASK && sdef->sdef_arfun==NoArrayFun){ + put_directive_b (implab); + FPrintF (OutFile,"e_%s_" S_PREFIX "%s",sdef->sdef_module,name); + } + break; + case FIELDSELECTOR: + if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){ + char *record_name; + + record_name = sdef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_ident->ident_name; + + put_directive_b (impdesc); + FPrintF (OutFile, "e_%s_" D_PREFIX "%s.%s",sdef->sdef_module,record_name,name); + + put_directive_b (implab); + + FPrintF (OutFile, "e_%s_" N_PREFIX "%s.%s",sdef->sdef_module,record_name,name); + + if (sdef->sdef_calledwithrootnode) + FPrintF (OutFile, " e_%s_" EA_PREFIX "%s.%s",sdef->sdef_module,record_name,name); + else if (sdef->sdef_returnsnode) + FPutS (" _",OutFile); + } + return; + case RECORDTYPE: + if (sdef->sdef_mark & (SDEF_USED_STRICTLY_MASK | SDEF_USED_LAZILY_MASK)){ + put_directive_b (impdesc); + FPrintF (OutFile, "e_%s_" R_PREFIX "%s",sdef->sdef_module,name); + } + + if (!sdef->sdef_strict_constructor) + return; + + if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){ + put_directive_b (impdesc); + FPrintF (OutFile, "e_%s_" RECORD_D_PREFIX "%s", sdef->sdef_module,name); + put_directive_b (implab); + FPrintF (OutFile, "e_%s_" RECORD_N_PREFIX "%s",sdef->sdef_module,name); + } + return; + case CONSTRUCTOR: + if (!sdef->sdef_strict_constructor) + return; + + if (sdef->sdef_mark & (SDEF_USED_STRICTLY_MASK | SDEF_USED_LAZILY_MASK)){ + put_directive_b (impdesc); + FPrintF (OutFile, "e_%s_" CONSTRUCTOR_R_PREFIX "%s",sdef->sdef_module,name); + } + if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){ + put_directive_b (impdesc); + FPrintF (OutFile, "e_%s_" D_PREFIX "%s", sdef->sdef_module,name); + } + break; + default: + return; + } + + if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){ + put_directive_b (implab); + FPrintF (OutFile, "e_%s_" N_PREFIX "%s",sdef->sdef_module,name); + if ((sdef->sdef_calledwithrootnode || sdef->sdef_returnsnode) && + !(sdef->sdef_kind==CONSTRUCTOR && !sdef->sdef_strict_constructor)) + { + if (sdef->sdef_calledwithrootnode) + FPrintF (OutFile, " e_%s_" EA_PREFIX "%s",sdef->sdef_module,name); + else + FPutS (" _",OutFile); + } + } + } +} + +void GenExportStrictAndEaEntry (SymbDef sdef) +{ + char *name; + + name = sdef->sdef_ident->ident_name; + + put_directive_ (Dexport); + FPrintF (OutFile, "e_%s_" S_PREFIX "%s", CurrentModule,name); + + if (sdef->sdef_calledwithrootnode){ + put_directive_ (Dexport); + FPrintF (OutFile, "e_%s_%s%s", CurrentModule, ea_pref, name); + } +} + +void GenExportFieldSelector (SymbDef sdef) +{ + char *name; + char *record_name; + + name = sdef->sdef_ident->ident_name; + + record_name=sdef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_ident->ident_name; + + put_directive_ (Dexport); + FPrintF (OutFile,"e_%s_" D_PREFIX "%s.%s",CurrentModule,record_name,name); + put_directive_ (Dexport); + FPrintF (OutFile,"e_%s_" N_PREFIX "%s.%s",CurrentModule,record_name,name); + + if (sdef->sdef_calledwithrootnode){ + put_directive_ (Dexport); + FPrintF (OutFile,"e_%s_" EA_PREFIX "%s.%s",CurrentModule,record_name,name); + } +} + +void GenExportEaEntry (SymbDef sdef) +{ + if (sdef->sdef_calledwithrootnode){ + put_directive_ (Dexport); + FPrintF (OutFile,"e_%s_" EA_PREFIX "%s",CurrentModule,sdef->sdef_ident->ident_name); + } +} + +void GenDAStackLayout (int asize) +{ + if (DoStackLayout){ + put_directive_b (d); + put_arguments_nn_b (asize,0); + } +} + +void GenOAStackLayout (int asize) +{ + if (DoStackLayout){ + put_directive_b (o); + put_arguments_nn_b (asize,0); + } +} + +void GenDStackLayoutOfStates (int asize,int bsize,int n_states,StateP state_p) +{ + if (DoStackLayout){ + put_directive_b (d); + if (bsize > 0){ + int i; + + put_arguments_nn__b (asize,bsize); + + for (i=0; i<n_states; ++i) + GenBStackElems (state_p[i]); + } else + put_arguments_nn_b (asize,0); + } +} + +void GenOStackLayoutOfStates (int asize,int bsize,int n_states,StateP state_p) +{ + if (DoStackLayout){ + put_directive_b (o); + if (bsize > 0){ + int i; + + put_arguments_nn__b (asize,bsize); + + for (i=0; i<n_states; ++i) + GenBStackElems (state_p[i]); + } else + put_arguments_nn_b (asize,0); + } +} + +void GenDStackLayoutOfState (int asize, int bsize, StateS resultstate) +{ + if (DoStackLayout){ + put_directive_b (d); + if (bsize > 0){ + put_arguments_nn__b (asize,bsize); + GenBStackElems (resultstate); + } else + put_arguments_nn_b (asize,0); + } +} + +void GenOStackLayoutOfState (int asize, int bsize, StateS resultstate) +{ + if (DoStackLayout){ + put_directive_b (o); + if (bsize > 0){ + put_arguments_nn__b (asize,bsize); + GenBStackElems (resultstate); + } else + put_arguments_nn_b (asize,0); + } +} + +void GenJmpEvalUpdate (void) +{ + put_instruction (Ijmp_eval_upd); +} + +void GenNodeEntryDirective (int arity,Label label,Label label2) +{ + if (DoStackLayout){ + put_directive_b (n); + put_arguments_n__b (arity); + + if (DescriptorNeeded (label->lab_symbol)) + GenLabel (label); + else + FPutS (empty_lab.lab_name, OutFile); + + if (label2){ + FPutC (' ', OutFile); + GenLabel (label2); + } +#ifdef MEMORY_PROFILING_WITH_N_STRING + if (DoProfiling && arity>=0 && !DoParallel){ + put_directive_ (Dn_string); + FPrintF (OutFile,"\"%s\"",label->lab_symbol->sdef_ident->ident_name); + } +#endif + } +} + +void GenNodeEntryDirectiveForLabelWithoutSymbol (int arity,Label label,Label label2) +{ + if (DoStackLayout){ + put_directive_b (n); + put_arguments_n__b (arity); + + GenLabel (label); + + if (label2){ + FPutC (' ', OutFile); + GenLabel (label2); + } + +#ifdef MEMORY_PROFILING_WITH_N_STRING + if (DoProfiling && arity>=0 && !DoParallel){ + put_directive_ (Dn_string); + FPrintF (OutFile,"\"%s\"",label->lab_name); + } +#endif + } +} + +void GenNodeEntryDirectiveUnboxed (int a_size,int b_size,Label label,Label label2) +{ + if (DoStackLayout){ + put_directive_ (Dnu); + FPrintF (OutFile,"%d %d ",a_size,b_size); + + if (DescriptorNeeded (label->lab_symbol)) + GenLabel (label); + else + FPutS (empty_lab.lab_name, OutFile); + + if (label2){ + FPutC (' ', OutFile); + GenLabel (label2); + } + +# ifdef MEMORY_PROFILING_WITH_N_STRING + if (DoProfiling && !DoParallel){ + put_directive_ (Dn_string); + FPrintF (OutFile,"\"%s\"",label->lab_symbol->sdef_ident->ident_name); + } +# endif + } +} + +void GenFieldNodeEntryDirective (int arity,Label label,Label label2,char *record_name) +{ + if (DoStackLayout){ + put_directive_b (n); + put_arguments_n__b (arity); + + if (DescriptorNeeded (label->lab_symbol)) + GenFieldLabel (label,record_name); + else + FPutS (empty_lab.lab_name, OutFile); + + if (label2){ + FPutC (' ', OutFile); + GenFieldLabel (label2,record_name); + } + } +} + +void GenConstructorDescriptorAndExport (SymbDef sdef) +{ + char *name; + LabDef *add_argument_label; + + name = sdef->sdef_ident->ident_name; + + if (sdef->sdef_arity>0) + add_argument_label=&add_arg_lab; + else + add_argument_label=&hnf_lab; + + if (sdef->sdef_exported || ExportLocalLabels){ + put_directive_ (Dexport); + FPrintF (OutFile, "e_%s_" D_PREFIX "%s",CurrentModule,name); + put_directive_ (Ddesc); + FPrintF (OutFile, "e_%s_" D_PREFIX "%s %s %s %d 0 \"%s\"", + CurrentModule, name, hnf_lab.lab_name, add_argument_label->lab_name, + sdef->sdef_arity, name); + } else if (DoDebug){ + put_directive_ (Ddesc); + FPrintF (OutFile, D_PREFIX "%s %s %s %d 0 \"%s\"", + name,hnf_lab.lab_name, add_argument_label->lab_name, sdef->sdef_arity, name); + } else { + put_directive_ (Ddesc); + FPrintF (OutFile, LOCAL_D_PREFIX "%u %s %s %d 0 \"%s\"", + sdef->sdef_number, hnf_lab.lab_name, add_argument_label->lab_name, + sdef->sdef_arity, name); + } +} + +void GenRecordDescriptor (SymbDef sdef) +{ + int asize,bsize; + char *name; + StateS recstate; + + name = sdef->sdef_ident->ident_name; + + if (sdef->sdef_exported || ExportLocalLabels){ + put_directive_ (Dexport); + FPrintF (OutFile, "e_%s_" R_PREFIX "%s",CurrentModule,name); + put_directive_ (Drecord); + FPrintF (OutFile, "e_%s_" R_PREFIX "%s ",CurrentModule,name); + } else if (DoDebug){ + put_directive_ (Drecord); + FPrintF (OutFile, R_PREFIX "%s ",name); + } else { + put_directive_ (Drecord); + FPrintF (OutFile, R_PREFIX "%u ",sdef->sdef_number); + } + + recstate = sdef->sdef_record_state; + + GenABStackElems (recstate); + + DetermineSizeOfState (recstate,&asize,&bsize); + + FPrintF (OutFile, " %d %d \"%s\"",asize,bsize,name); +} + +void GenStrictConstructorDescriptor (SymbDef sdef,StateP constructor_arg_state_p) +{ + int asize,bsize,state_arity,arg_n; + char *name; + + name = sdef->sdef_ident->ident_name; + + if (sdef->sdef_exported || ExportLocalLabels){ + put_directive_ (Dexport); + FPrintF (OutFile, "e_%s_" CONSTRUCTOR_R_PREFIX "%s",CurrentModule,name); + put_directive_ (Drecord); + FPrintF (OutFile, "e_%s_" CONSTRUCTOR_R_PREFIX "%s ",CurrentModule,name); + } else if (DoDebug){ + put_directive_ (Drecord); + FPrintF (OutFile, CONSTRUCTOR_R_PREFIX "%s ",name); + } else { + put_directive_ (Drecord); + FPrintF (OutFile, CONSTRUCTOR_R_PREFIX "%u ",sdef->sdef_number); + } + + FPutC ('d', OutFile); + + state_arity=sdef->sdef_arity; + asize = 0; + bsize = 0; + + for (arg_n=0; arg_n<state_arity; ++arg_n){ + GenABStackElems (*constructor_arg_state_p); + AddSizeOfState (*constructor_arg_state_p,&asize,&bsize); + ++constructor_arg_state_p; + } + + FPrintF (OutFile, " %d %d \"%s\"", asize, bsize, name); +} + +void GenArrayFunctionDescriptor (SymbDef arr_fun_def, Label desclab, int arity) +{ + LabDef descriptor_label; + char *name; + + name = arr_fun_def->sdef_ident->ident_name; + + descriptor_label=*desclab; + descriptor_label.lab_pref=d_pref; + + if (arr_fun_def->sdef_mark & SDEF_USED_CURRIED_MASK) + put_directive_ (Ddesc); + else + put_directive_ (Ddescn); + + GenLabel (&descriptor_label); + + FPutC (' ', OutFile); + GenLabel (&empty_lab); + FPutC (' ', OutFile); + + if (arr_fun_def->sdef_mark & SDEF_USED_CURRIED_MASK){ + LabDef lazylab; + + lazylab = *desclab; + lazylab.lab_pref = l_pref; + GenLabel (&lazylab); + } + + FPrintF (OutFile, " %d 0 \"%s\"", arity, name); +} + +void GenFunctionDescriptorAndExportNodeAndDescriptor (SymbDef sdef) +{ + Ident name_id; + char *name; + + if (!DescriptorNeeded (sdef)) + return; + + name_id = sdef->sdef_ident; + name = name_id->ident_name; + + if (sdef->sdef_exported){ + put_directive_ (Ddescexp); + FPrintF (OutFile, "e_%s_" D_PREFIX "%s e_%s_" N_PREFIX "%s e_%s_" L_PREFIX "%s ", + CurrentModule,name,CurrentModule,name,CurrentModule,name); + } else { + if (sdef->sdef_mark & SDEF_USED_CURRIED_MASK){ + put_directive_ (Ddesc); + + if (DoDebug) + FPrintF (OutFile, D_PREFIX "%s.%u ", name,sdef->sdef_number); + else + FPrintF (OutFile, LOCAL_D_PREFIX "%u ", sdef->sdef_number); + + if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){ + if (DoDebug) + FPrintF (OutFile,N_PREFIX "%s.%u ",name,sdef->sdef_number); + else + FPrintF (OutFile,N_PREFIX "%u ",sdef->sdef_number); + } else + FPrintF (OutFile, "%s ", hnf_lab.lab_name); + + if (DoDebug) + FPrintF (OutFile,L_PREFIX "%s.%u ",name,sdef->sdef_number); + else + FPrintF (OutFile,L_PREFIX "%u ",sdef->sdef_number); + } else { + put_directive_ (Ddescn); + + if (DoDebug) + FPrintF (OutFile, D_PREFIX "%s.%u ", name,sdef->sdef_number); + else + FPrintF (OutFile, LOCAL_D_PREFIX "%u ", sdef->sdef_number); + + if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){ + if (DoDebug) + FPrintF (OutFile,N_PREFIX "%s.%u ",name,sdef->sdef_number); + else + FPrintF (OutFile,N_PREFIX "%u ",sdef->sdef_number); + } else + FPrintF (OutFile, "%s ", hnf_lab.lab_name); + } + } + + FPrintF (OutFile, "%d 0 \"", sdef->sdef_arity); + PrintSymbolOfIdent (name_id, 0, OutFile); + FPutC ('\"',OutFile); +} + +void GenConstructorFunctionDescriptorAndExportNodeAndDescriptor (SymbDef sdef) +{ + Ident name_id; + char *name; + + if (!DescriptorNeeded (sdef)) + return; + + name_id = sdef->sdef_ident; + name = name_id->ident_name; + + if (sdef->sdef_exported){ + put_directive_ (Ddescexp); + FPrintF (OutFile, "e_%s_" D_PREFIX "%s e_%s_" N_PREFIX "%s e_%s_" L_PREFIX "%s ", + CurrentModule,name,CurrentModule,name,CurrentModule,name); + } else if (ExportLocalLabels && (sdef->sdef_mark & SDEF_USED_CURRIED_MASK)!=0){ + put_directive_ (Ddescexp); + if (DoDebug) + FPrintF (OutFile, "e_%s_" D_PREFIX "%s e_%s_" N_PREFIX "%s " L_PREFIX "%s ", + CurrentModule,name,CurrentModule,name,name); + else + FPrintF (OutFile, "e_%s_" D_PREFIX "%s e_%s_" N_PREFIX "%s " L_PREFIX "%u ", + CurrentModule,name,CurrentModule,name,sdef->sdef_number); + } else { + if (sdef->sdef_mark & SDEF_USED_CURRIED_MASK){ + put_directive_ (Ddesc); + + if (DoDebug) + FPrintF (OutFile, D_PREFIX "%s ",name); + else + FPrintF (OutFile, LOCAL_D_PREFIX "%u ", sdef->sdef_number); + + if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){ + if (DoDebug) + FPrintF (OutFile,N_PREFIX "%s ",name); + else + FPrintF (OutFile,N_PREFIX "%u ",sdef->sdef_number); + } else + FPrintF (OutFile, "%s ", hnf_lab.lab_name); + + if (DoDebug) + FPrintF (OutFile,L_PREFIX "%s ",name); + else + FPrintF (OutFile,L_PREFIX "%u ",sdef->sdef_number); + } else { + if (ExportLocalLabels){ + put_directive_ (Dexport); + FPrintF (OutFile,"e_%s_" N_PREFIX "%s",CurrentModule,name); + } + + put_directive_ (Ddescn); + + if (DoDebug) + FPrintF (OutFile, D_PREFIX "%s ", name); + else + FPrintF (OutFile, LOCAL_D_PREFIX "%u ", sdef->sdef_number); + + if (ExportLocalLabels) + FPrintF (OutFile,"e_%s_" N_PREFIX "%s ",CurrentModule,name); + else if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){ + if (DoDebug) + FPrintF (OutFile,N_PREFIX "%s ", name); + else + FPrintF (OutFile,N_PREFIX "%u ",sdef->sdef_number); + } else + FPrintF (OutFile, "%s ", hnf_lab.lab_name); + } + } + + FPrintF (OutFile, "%d 0 \"", sdef->sdef_arity); + PrintSymbolOfIdent (name_id, 0, OutFile); + FPutC ('\"',OutFile); +} + +#if OPTIMIZE_LAZY_TUPLE_RECURSION +void GenFunctionDescriptorForLazyTupleRecursion (SymbDef sdef,int tuple_result_arity) +{ + Ident name_id; + char *name; + + name_id = sdef->sdef_ident; + name = name_id->ident_name; + + put_directive_ (Ddescn); + + if (sdef->sdef_exported){ + FPrintF (OutFile,"e_%s_" D_PREFIX "%s.2 ",CurrentModule,name); + FPrintF (OutFile,"e_%s_" N_PREFIX "%s.2 ",CurrentModule,name); + } else if (DoDebug){ + FPrintF (OutFile,D_PREFIX "%s.%u.2 ",name,sdef->sdef_number); + FPrintF (OutFile,N_PREFIX "%s.%u.2 ",name,sdef->sdef_number); + } else { + FPrintF (OutFile,LOCAL_D_PREFIX "%u.2 ",sdef->sdef_number); + FPrintF (OutFile,N_PREFIX "%u.2 ",sdef->sdef_number); + } + + FPrintF (OutFile, "%d 0 \"",sdef->sdef_arity+tuple_result_arity); + PrintSymbolOfIdent (name_id,0,OutFile); + FPutC ('\"',OutFile); + +# if 1 + put_directive_ (Ddescn); + + if (sdef->sdef_exported){ + FPrintF (OutFile,"e_%s_" D_PREFIX "%s.3 ",CurrentModule,name); + FPrintF (OutFile,"e_%s_" N_PREFIX "%s.3 ",CurrentModule,name); + } else if (DoDebug){ + FPrintF (OutFile,D_PREFIX "%s.%u.3 ",name,sdef->sdef_number); + FPrintF (OutFile,N_PREFIX "%s.%u.3 ",name,sdef->sdef_number); + } else { + FPrintF (OutFile,LOCAL_D_PREFIX "%u.3 ",sdef->sdef_number); + FPrintF (OutFile,N_PREFIX "%u.3 ",sdef->sdef_number); + } + + FPrintF (OutFile, "%d 0 \"",sdef->sdef_arity+tuple_result_arity); + PrintSymbolOfIdent (name_id,0,OutFile); + FPutC ('\"',OutFile); +# endif +} +#endif + +void GenLazyRecordDescriptorAndExport (SymbDef sdef) +{ + char *name; + int arity; + + if (!DescriptorNeeded (sdef)) + return; + + name = sdef->sdef_ident->ident_name; + arity = sdef->sdef_cons_arity; + + if (sdef->sdef_exported){ + put_directive_ (Ddescexp); + FPrintF (OutFile, "e_%s_" RECORD_D_PREFIX "%s e_%s_" RECORD_N_PREFIX "%s _hnf %d 1 \"%s\"", + CurrentModule,name,CurrentModule,name,arity,name); + } else { + if (ExportLocalLabels){ + put_directive_ (Dexport); + FPrintF (OutFile,"e_%s_" RECORD_N_PREFIX "%s",CurrentModule,name); + } + + put_directive_ (Ddescn); + if (DoDebug){ + FPrintF (OutFile,RECORD_D_PREFIX "%s ",name); + if (ExportLocalLabels) + FPrintF (OutFile,"e_%s_" RECORD_N_PREFIX "%s ",CurrentModule,name); + else + FPrintF (OutFile,RECORD_N_PREFIX "%s ",name); + } else { + FPrintF (OutFile,RECORD_D_PREFIX "%u ",sdef->sdef_number); + if (ExportLocalLabels) + FPrintF (OutFile,"e_%s_" RECORD_N_PREFIX "%s ",CurrentModule,name); + else + FPrintF (OutFile,RECORD_N_PREFIX "%u ",sdef->sdef_number); + } + + FPrintF (OutFile, "%d 1 \"%s\"",arity,name); + } +} + +void GenFieldSelectorDescriptor (SymbDef sdef,int has_gc_apply_entry) +{ + char *name; + int arity; + + if (!DescriptorNeeded (sdef)) + return; + + name = sdef->sdef_ident->ident_name; + arity = (sdef->sdef_kind == RECORDTYPE) ? sdef->sdef_cons_arity : sdef->sdef_arity; + + put_directive_ (Ddesc); + if (sdef->sdef_exported){ + char *record_name; + + record_name=sdef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_ident->ident_name; + + if (has_gc_apply_entry) + FPrintF (OutFile, "e_%s_" D_PREFIX "%s.%s e_%s_" N_PREFIX "%s.%s e_%s_%s%s.%s %d 0 \"%s\"", + CurrentModule,record_name,name, + CurrentModule,record_name,name, + CurrentModule,l_pref,record_name,name, + arity, name); + else + FPrintF (OutFile, "e_%s_" D_PREFIX "%s.%s e_%s_" N_PREFIX "%s.%s _hnf %d 0 \"%s\"", + CurrentModule,record_name,name, + CurrentModule,record_name,name, + arity, name); + } else if ((sdef->sdef_mark & SDEF_USED_LAZILY_MASK) || has_gc_apply_entry){ + char *record_name; + + record_name = sdef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_ident->ident_name; + + if (DoDebug) + FPrintF (OutFile, D_PREFIX "%s.%s ",record_name,name); + else + FPrintF (OutFile, LOCAL_D_PREFIX "%u ", sdef->sdef_number); + + if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){ + if (DoDebug) + FPrintF (OutFile, N_PREFIX "%s.%s ",record_name,name); + else + FPrintF (OutFile, N_PREFIX "%u ",sdef->sdef_number); + } else + FPrintF (OutFile, "%s ", hnf_lab.lab_name); + + if (has_gc_apply_entry){ + if (DoDebug) + FPrintF (OutFile, "%s%s.%s ",l_pref,record_name,name); + else + FPrintF (OutFile, "%s%u ",l_pref,sdef->sdef_number); + } else + FPrintF (OutFile, "%s ", hnf_lab.lab_name); + + FPrintF (OutFile, "%d 0 \"%s\"", arity, name); + } else if (DoDebug){ + FPrintF (OutFile, D_PREFIX "%s %s %s %d 0 \"%s\"", name, hnf_lab.lab_name, + hnf_lab.lab_name, arity, name); + } else + FPrintF (OutFile, LOCAL_D_PREFIX "%u %s %s %d 0 \"%s\"", sdef->sdef_number, + hnf_lab.lab_name, hnf_lab.lab_name, arity, name); +} + +void GenModuleDescriptor ( +#if WRITE_DCL_MODIFICATION_TIME + FileTime file_time +#else + void +#endif + ) +{ + put_directive_ (Dmodule); + FPrintF (OutFile, "m_%s \"%s\"", CurrentModule,CurrentModule); + +#if WRITE_DCL_MODIFICATION_TIME + if (WriteModificationTimes){ + FPutC (' ',OutFile); + FPutC ('\"',OutFile); + FWriteFileTime (file_time,OutFile); + FPutC ('\"',OutFile); + } +#endif +} + +void GenDepend (char *modname +#if WRITE_DCL_MODIFICATION_TIME + ,FileTime file_time +#endif + ) +{ +#ifndef _STANDALONE_ + AddDependency (modname); +#endif + put_directive_ (Ddepend); + FPrintF (OutFile, "\"%s\"",modname); + +#if WRITE_DCL_MODIFICATION_TIME + if (WriteModificationTimes){ + FPutC (' ',OutFile); + FPutC ('\"',OutFile); + FWriteFileTime (file_time,OutFile); + FPutC ('\"',OutFile); + } +#endif +} + +void GenStart (SymbDef startsymb) +{ + if (startsymb->sdef_module == CurrentModule){ + int arity; + + arity = startsymb->sdef_arity; + startsymb->sdef_mark |= SDEF_USED_LAZILY_MASK; + + put_directive_ (Dexport); + FPrintF (OutFile, "__%s_Start", CurrentModule); + GenOAStackLayout (0); + + FPrintF (OutFile, "\n__%s_Start", CurrentModule); + + if (arity!=0){ + put_instruction_b (buildI); + put_arguments_n_b (65536l); + } + + put_instruction_b (build); + + if (startsymb->sdef_exported) + FPrintF (OutFile, "e_%s_" D_PREFIX "Start",CurrentModule); + else if (DoDebug){ + if (DoParallel) + FPrintF (OutFile, D_PREFIX "Start.%u",startsymb->sdef_number); + else + FPutS (empty_lab.lab_name, OutFile); + } else { + if (DoParallel) + FPrintF (OutFile, LOCAL_D_PREFIX "%u",startsymb->sdef_number); + else + FPutS (empty_lab.lab_name, OutFile); + } + + put_arguments__n__b (arity); + + if (startsymb->sdef_exported) + FPrintF (OutFile, "e_%s_" N_PREFIX "Start",CurrentModule); + else if (DoDebug) + FPrintF (OutFile, N_PREFIX "Start.%u",startsymb->sdef_number); + else + FPrintF (OutFile, N_PREFIX "%u",startsymb->sdef_number); + + GenDAStackLayout (1); + put_instruction_b (jmp); + FPutS ("_driver", OutFile); + } +} + +void GenSelectorDescriptor (Label sellab,char *g_pref) +{ + put_directive_ (Ddesc); + FPrintF (OutFile, D_PREFIX "%s.%d %s%s.%d %s%s.%d 1 0 \"%s.%d\"", + sellab->lab_name, sellab->lab_post, + sellab->lab_pref, sellab->lab_name, sellab->lab_post, + g_pref, sellab->lab_name, sellab->lab_post, + sellab->lab_name, sellab->lab_post); +} + +void InitFileInfo (ImpMod imod) +{ + char option_string[NR_OPTIONS+1]; + CompilerOptions opts; + SymbDef start_sdef; + + start_sdef=imod->im_start; + +#ifndef _STANDALONE_ + MakeOptionsFromCurrentOptions (& opts); +#endif + ConvertOptionsToString (opts,option_string); + + if (imod->im_def_module!=NULL && imod->im_def_module->dm_system_module) + option_string[N_System]='1'; + + put_first_directive_ (Dcomp); + FPrintF (OutFile, "%d %s", VERSION,option_string); +#ifndef _STANDALONE_ + AddVersionAndOptions (VERSION, opts); +#endif + put_directive_ (Dcode); + FPrintF (OutFile, "%7ld %7ld %7ld", (long) 0, (long) 0, (long) 0); + + put_directive_ (Dstart); + if (start_sdef!=NULL){ + FPrintF (OutFile, "__%s_Start",start_sdef->sdef_module); + } else + FPutS ("_nostart_", OutFile); +} + +void GenNoMatchError (SymbDef sdef,int asp,int bsp,int string_already_generated) +{ + Bool desc_needed; + + desc_needed = DescriptorNeeded (sdef); + + GenPopA (asp); + GenPopB (bsp); + + put_instruction_b (pushD); + FPrintF (OutFile, "m_%s", CurrentModule); + + put_instruction_b (pushD); + if (!desc_needed) + FPrintF (OutFile, "x_%u", sdef->sdef_number); + else if (sdef->sdef_exported) + FPrintF (OutFile, "e_%s_" D_PREFIX "%s", CurrentModule, sdef->sdef_ident->ident_name); + else if (DoDebug){ + if (sdef->sdef_kind==IMPRULE) + FPrintF (OutFile, D_PREFIX "%s.%u", sdef->sdef_ident->ident_name,sdef->sdef_number); + else + FPrintF (OutFile, D_PREFIX "%s", sdef->sdef_ident->ident_name); + } else + FPrintF (OutFile, LOCAL_D_PREFIX "%u", sdef->sdef_number); + + if (DoStackLayout){ + put_directive_b (d); + put_arguments_nn__b (0,2); + FPutS ("ii",OutFile); + } + + GenJmp (&match_error_lab); + + if (!desc_needed && !string_already_generated){ + put_directive_ (Dstring); + FPrintF (OutFile, "x_%u \"",sdef->sdef_number); + PrintSymbolOfIdent (sdef->sdef_ident, sdef->sdef_line,OutFile); + FPutS ("\"", OutFile); + } +} + +static void GenImpLab (char *label_name) +{ + put_directive_b (implab); + FPutS (label_name,OutFile); +} + +static void GenImpLab_node_entry (char *label_name,char *ea_label_name) +{ + put_directive_b (implab); + FPrintF (OutFile,"%s %s",label_name,ea_label_name); +} + +static void GenImpDesc (char *descriptor_name) +{ + put_directive_b (impdesc); + FPutS (descriptor_name,OutFile); +} + +void GenEndInfo (void) +{ + put_directive (Dendinfo); +} + +void GenSystemImports (void) +{ + if (DoStackLayout){ + /* system module labels and descriptors */ + + int selnum; + + if (DoParallel){ + GenImpLab (channel_code); + GenImpLab (hnf_reducer_code); + GenImpDesc (ext_hnf_reducer_code); + GenImpLab (nf_reducer_code); + GenImpDesc (ext_nf_reducer_code); + GenImpLab (reserve_lab.lab_name); + } + GenImpLab (cycle_lab.lab_name); + GenImpLab (type_error_lab.lab_name); + GenImpLab (hnf_lab.lab_name); + + GenImpDesc ("_ind"); + GenImpLab_node_entry (indirection_lab.lab_name,"_eaind"); + GenImpDesc ("e_system_dif"); + GenImpLab_node_entry ("e_system_nif","e_system_eaif"); + GenImpDesc ("e_system_dAP"); + GenImpLab_node_entry ("e_system_nAP","e_system_eaAP"); + + GenImpLab ("e_system_sif"); + GenImpLab ("e_system_sAP"); + GenImpDesc (cons_lab.lab_name); + GenImpDesc (nil_lab.lab_name); + GenImpDesc (tuple_lab.lab_name); + + for (selnum=1; selnum<=NrOfGlobalSelectors; ++selnum){ + put_directive_b (impdesc); + FPrintF (OutFile,D_PREFIX "%s.%d",glob_sel,selnum); + put_directive_b (implab); + FPrintF (OutFile,N_PREFIX "%s.%d " EA_PREFIX "%s.%d",glob_sel,selnum,glob_sel,selnum); + } +#ifdef THUNK_LIFT_SELECTORS + for (selnum=1; selnum<=NrOfGlobalSelectors; ++selnum){ + put_directive_b (impdesc); + FPrintF (OutFile,D_PREFIX "%s.%d",glob_selr,selnum); + put_directive_b (implab); + FPrintF (OutFile,N_PREFIX "%s.%d " EA_PREFIX "%s.%d",glob_selr,selnum,glob_selr,selnum); + } +#endif + GenImpLab ("_driver"); + } +} + +void GenParameters (Bool input, Parameters params, int asp, int bsp) +{ + int is_first_parameter; + + if (params==NULL) + return; + + if (input) + put_instruction_ (Iin); + else + put_instruction_ (Iout); + + is_first_parameter=1; + for (; params!=NULL; params=params->par_next){ + NodeId node_id; + + node_id=params->par_node_id; + if (!is_first_parameter) + FPutC (' ',OutFile); + if (IsSimpleState (node_id->nid_state) && node_id->nid_state.state_kind==OnB) + FPrintF (OutFile, "b%d:%s",bsp-node_id->nid_b_index,params->par_loc->ident_name); + else + FPrintF (OutFile, "a%d:%s",asp-node_id->nid_a_index,params->par_loc->ident_name); + is_first_parameter=0; + } +} + +void GenInstructions (Instructions ilist) +{ + for (; ilist; ilist = ilist->instr_next){ + char *instruction_name; + + instruction_name=ilist->instr_this; + + FPutC ('\n',OutFile); + if (instruction_name[0]==':') + FPutS (&instruction_name[1],OutFile); + else { + if (instruction_name[0]!='.') + FPutC ('\t',OutFile); + FPutS (instruction_name,OutFile); + } + } + if (!DoDebug) + FPutC ('\n',OutFile); +} + +void GenTestCaf (Label label) +{ + put_instruction_ (Itestcaf); + GenLabel (label); +} + +void GenPushCaf (Label label,int a_stack_size,int b_stack_size) +{ + put_instruction_ (Ipushcaf); + GenLabel (label); + FPrintF (OutFile," %d %d",a_stack_size,b_stack_size); +} + +void GenFillCaf (Label label,int a_stack_size,int b_stack_size) +{ + put_instruction_ (Ifillcaf); + GenLabel (label); + FPrintF (OutFile," %d %d",a_stack_size,b_stack_size); +} + +void GenCaf (Label label,int a_stack_size,int b_stack_size) +{ + put_directive_ (Dcaf); + GenLabel (label); + FPrintF (OutFile," %d %d",a_stack_size,b_stack_size); +} + +void GenPB (char *function_name) +{ + put_directive_ (Dpb); + FPrintF (OutFile,"\"%s\"",function_name); +} + +void GenPD (void) +{ + put_directive (Dpd); +} + +void GenPN (void) +{ + put_directive (Dpn); +} + +void GenPL (void) +{ + put_directive (Dpl); +} + +void GenPLD (void) +{ + put_directive (Dpld); +} + +void GenPT (void) +{ + put_directive (Dpt); +} + +void GenPE (void) +{ + put_directive (Dpe); +} + +void GenKeep (int a_offset1,int a_offset2) +{ + put_directive_ (Dkeep); + FPrintF (OutFile,"%d %d",a_offset1,a_offset2); +} + +#if IMPORT_OBJ_AND_LIB +void GenImpObj (char *obj_name) +{ + put_directive_ ("impobj"); + FPrintF (OutFile,"%s",obj_name); +} + +void GenImpLib (char *lib_name) +{ + put_directive_ ("implib"); + FPrintF (OutFile,"%s",lib_name); +} +#endif + +void InitInstructions (void) +{ + ABCFileName = NULL; + SetUnaryState (& ApplyState, StrictRedirection, UnknownObj); + ApplyLabel = NULL; +} diff --git a/backendC/CleanCompilerSources/instructions.h b/backendC/CleanCompilerSources/instructions.h new file mode 100644 index 0000000..423b07a --- /dev/null +++ b/backendC/CleanCompilerSources/instructions.h @@ -0,0 +1,216 @@ + +extern File OutFile; +extern char *ABCFileName; + +Bool OpenABCFile (char *fname); + +void CloseABCFile (char *fname); + +void BuildBasicFromB (ObjectKind kind,int b_offset); +void FillBasicFromB (ObjectKind kind, int boffs, int aoffs, FillKind fkind); +void BuildBasic (ObjectKind obj,SymbValue val); +void FillBasic (ObjectKind obj, SymbValue val, int offset, FillKind fkind); + +void IsBasic (ObjectKind obj, SymbValue val, int offset); +void IsString (SymbValue val); + +void PushBasic (ObjectKind obj, SymbValue val); + +void EqBasic (ObjectKind obj, SymbValue val, int offset); + +void PushBasicFromAOnB (ObjectKind kind,int offset); +void GenPushD_a (int a_offset); + +void PushBasicOnB (ObjectKind state, int offset); + +void UpdateBasic (int size, int srcoffset, int dstoffset); + +void CallFunction (Label label, SymbDef def, Bool isjsr, Node root); + +void CallArrayFunction (SymbDef def,Bool isjsr,StateP node_state_p); + +void GenNewContext (Label contlab, int offset); + +void GenPushArgs (int offset,int arity,int nrargs); +void GenPushArgsU (int offset,int arity,int nrargs); +void GenPushArg (int offset,int arity,int argnr); + +void GenPushRArgs (int offset,int nr_a_args,int nr_b_args); +void GenPushRArgsU (int offset,int n_a_args,int n_b_args); +void GenPushRArgA (int offset,int tot_nr_a_args,int tot_nr_b_args,int args_nr,int nr_a_args); +void GenPushRArgB (int offset,int tot_nr_a_args,int tot_nr_b_args,int args_nr,int nr_b_args); + +void GenReplArgs (int arity, int nrargs); +void GenReplArg (int arity, int argnr); + +void GenReplRArgs (int nr_a_args, int nr_b_args); +void GenReplRArgA (int tot_nr_a_args, int tot_nr_b_args, int args_nr, int nr_a_args); + +void GenPushNode (Label contlab, int arity); +void GenPushNodeU (Label contlab,int a_size,int b_size); + +void GenFill (Label symblab, int arity,Label contlab, int offset, FillKind fkind); +void GenFillcp (Label symblab,int arity,Label contlab,int offset,char bits[]); +void GenFillU (Label symblab,int a_size,int b_size,Label contlab,int offset); +void GenFillcpU (Label symblab,int a_size,int b_size,Label contlab,int offset,char bits[]); +void GenFillh (Label symblab, int arity,int offset, FillKind fkind); +void GenFill1 (Label symblab,int arity,int offset,char bits[]); +void GenFill2 (Label symblab, int arity,int offset,char bits[]); +void GenBuild (Label symblab,int arity,Label contlab); +void GenBuildh (Label symblab,int arity); +void GenBuildU (Label symblab,int a_size,int b_size,Label contlab); +void GenBuildArray (int argoffset); +void GenBuildString (SymbValue val); + +void GenBuildFieldSelector (Label symblab,Label contlab,char *record_name,int arity); +void GenFillFieldSelector (Label symblab,Label contlab,char *record_name,int arity,int offset,FillKind fkind); + +void GenFillFromA (int src, int dst, FillKind fkind); + +void GenFillR (Label symblab,int nr_a_args,int nr_b_args,int rootoffset,int a_offset,int b_offset,FillKind fkind,Bool pop_args); +void GenFill1R (Label symblab,int n_a_args,int n_b_args,int rootoffset,char bits[]); +void GenFill2R (Label symblab,int n_a_args,int n_b_args,int rootoffset,char bits[]); +void GenFill3R (Label symblab,int n_a_args,int n_b_args,int rootoffset,char bits[]); +void GenBuildR (Label symblab,int nr_a_args,int nr_b_args,int a_offset,int b_offset,Bool pop_args); + +void GenFillArray (int argoffset, int rootoffset, FillKind fkind); + +void GenPushArray (int offset); + +void GenRtn (int asize, int bsize, StateS resultstate); + +void GenPushA (int offset); +void GenPushB (int offset); + +void GenJsrEval (int offset); +void GenJmpEval (void); + +void GenPopA (int nr); +void GenPopB (int nr); + +void GenEqDesc (Label symblab, int arity, int offset); +void GenEqD_b (Label symblab,int arity); + +void GenExitFalse (Label to); +void GenJmpFalse (Label to); +void GenJmpTrue (Label to); + +void GenJmp (Label tolab); +void GenJsr (Label tolab); + +void GenCreate (int arity); + +void GenDumpString (char *str); + +void GenLabelDefinition (Label lab); + +void GenFieldLabelDefinition (Label label,char *record_name); + +void GenUpdateA (int src, int dst); +void GenUpdateB (int src, int dst); + +#ifdef UPDATE_POP +void GenUpdatePopA (int src, int dst); +void GenUpdatePopB (int src, int dst); +#endif + +void GenFillArray (int argoffset, int rootoffset, FillKind fkind); + +void GenPushArray (int rootoffset); + +void GenNewParallelReducer (int offset, char *reducer_code); + +void GenNewInterleavedReducer (int offset, char *reducer_code); + +void GenNewContInterleavedReducer (int offset); + +void GenSendGraph (char *code, int graphoffs, int chanoffs); +void GenCreateChannel (char *code); +void GenNewP (void); +void GenPushReducerId (int i); +void GenSetRedId (int offset); +void GenSetDefer (int offset); +void SetContinue (int offset); +void SetContinueOnReducer (int offset); +void GenImport (SymbDef sdef); +void GenExportRecord (SymbDef sdef); +void GenExportFieldSelector (SymbDef sdef); +void GenExportStrictAndEaEntry (SymbDef sdef); +void GenExportEaEntry (SymbDef sdef); + +void GenDAStackLayout (int asize); +void GenDStackLayoutOfStates (int asize,int bsize,int n_states,StateP state_p); +void GenDStackLayoutOfState (int asize, int bsize, StateS resultstate); + +void GenOAStackLayout (int asize); +void GenOStackLayoutOfStates (int asize,int bsize,int n_states,StateP state_p); +void GenOStackLayoutOfState (int asize, int bsize, StateS resultstate); + +void GenDStackLayout (int asize,int bsize,Args fun_args); +void GenOStackLayout (int asize,int bsize,Args fun_args); + +void GenNodeEntryDirective (int arity,Label label,Label label2); +void GenNodeEntryDirectiveForLabelWithoutSymbol (int arity,Label label,Label label2); +void GenNodeEntryDirectiveUnboxed (int a_size,int b_size,Label label,Label label2); +void GenFieldNodeEntryDirective (int arity, Label label, Label label2,char *record_name); +void GenConstructorDescriptorAndExport (SymbDef sdef); +void GenFunctionDescriptorAndExportNodeAndDescriptor (SymbDef sdef); +void GenConstructorFunctionDescriptorAndExportNodeAndDescriptor (SymbDef sdef); +#if OPTIMIZE_LAZY_TUPLE_RECURSION +void GenFunctionDescriptorForLazyTupleRecursion (SymbDef sdef,int tuple_result_arity); +#endif +void GenLazyRecordDescriptorAndExport (SymbDef sdef); +void GenFieldSelectorDescriptor (SymbDef sdef,int has_gc_apply_entry); +void GenRecordDescriptor (SymbDef sdef); +void GenStrictConstructorDescriptor (SymbDef sdef,StateP constructor_arg_state_p); +void GenArrayFunctionDescriptor (SymbDef arr_fun_def, Label desclab, int arity); + +#if defined(WRITE_DCL_MODIFICATION_TIME) && WRITE_DCL_MODIFICATION_TIME +void GenModuleDescriptor (FileTime file_time); +void GenDepend (char *modname,FileTime file_time); +#else +void GenModuleDescriptor (void); +void GenDepend (char *modname); +#endif +void GenEndInfo (void); +void GenSystemImports (void); +void GenStart (SymbDef startsymb); +void InitFileInfo (ImpMod imod); + +/* void GenFileInfo (void); */ + +void GenNoMatchError (SymbDef sdef,int asp,int bsp,int string_already_generated); + +void InitInstructions (void); + +void GenHalt (void); +void GenParameters (Bool input, Parameters params, int asp, int bsp); +void GenInstructions (Instructions ilist); + +void GenJmpEvalUpdate (void); + +void GenSelectorDescriptor (Label sellab,char *g_pref); +void GenGetNodeArity (int offset); +void GenPushArgNr (int argnr); +void GenPushArgB (int offset); + +void GenTestCaf (Label label); +void GenPushCaf (Label label,int a_stack_size,int b_stack_size); +void GenFillCaf (Label label,int a_stack_size,int b_stack_size); +void GenCaf (Label label,int a_stack_size,int b_stack_size); + +void GenPB (char *function_name); +void GenPD (void); +void GenPN (void); +void GenPL (void); +void GenPLD (void); +void GenPT (void); +void GenPE (void); + +void GenKeep (int a_offset1,int a_offset2); + +void WriteLastNewlineToABCFile (void); +#if IMPORT_OBJ_AND_LIB +void GenImpObj (char *obj_name); +void GenImpLib (char *lib_name); +#endif diff --git a/backendC/CleanCompilerSources/mac.h b/backendC/CleanCompilerSources/mac.h new file mode 100644 index 0000000..9b55823 --- /dev/null +++ b/backendC/CleanCompilerSources/mac.h @@ -0,0 +1,70 @@ +/******************************************************************************* + * MAC Dependencies * + ******************************************************************************/ + +#ifdef THINK_C + typedef int TwoBytesInt; + typedef long int FourBytesInt; + typedef unsigned TwoBytesUnsigned; + typedef unsigned long FourBytesUnsigned; + typedef short double EightBytesReal; +#else + typedef short TwoBytesInt; + typedef int FourBytesInt; + typedef unsigned short TwoBytesUnsigned; + typedef unsigned int FourBytesUnsigned; + typedef double EightBytesReal; +#endif +typedef float FourBytesReal; + +#define SizeT unsigned long +#define SizeOf(A) ((SizeT) sizeof (A)) + +#include <limits.h> +#define MAXUNSIGNED ULONG_MAX + +#define _VARARGS_ + +#include <string.h> +#include <stdlib.h> + +#ifdef THINK_C +# include <unix.h> +#else +# include <stdio.h> +#endif + +#include <setjmp.h> +#include <stdarg.h> + +typedef FILE *File; + +#ifdef THINK_C + /* special for MacIntosh command line support */ + extern void InitIO (void); + extern void GetPreferences (char *fname); +#else + void GetInitialPathList (void); + void FreePathList (void); +#endif + +#define StdOut stdout +#if defined (__MWERKS__) || defined (__MRC__) +#define StdError stderr +#else +#define StdError stdout +#endif +#define StdVerboseH stdout +#define StdVerboseL stdout +#define StdListTypes stdout + +#define FGetC(f) fgetc(f) +#define FGetS(s,n,f) fgets(s,n,f) +#define FPutC(c,f) fputc(c,f) + +extern int open_dcl_file_for_block_reading (char *fname,File *file_p); +extern int read_next_block_from_dcl_file (char *buffer); + +#if WRITE_DCL_MODIFICATION_TIME +extern int open_dcl_file_for_block_reading_with_file_time (char *file_name,File *file_p,unsigned long *file_time_p); +#endif
\ No newline at end of file diff --git a/backendC/CleanCompilerSources/mac_io.c b/backendC/CleanCompilerSources/mac_io.c new file mode 100644 index 0000000..e169074 --- /dev/null +++ b/backendC/CleanCompilerSources/mac_io.c @@ -0,0 +1,1088 @@ + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) + +#if defined (applec) || defined (__MWERKS__) || defined (__MRC__) +# define mpwc +#endif + +#ifdef MAKE_MPW_TOOL +# define NO_CLEAN_SYSTEM_FILES_FOLDERS +# define NEWBRIDGE +#endif + +#if defined (mpwc) /* && ! (defined (MAKE_MPW_TOOL) && !defined (MAIN_CLM)) */ +# define USE_PATH_CACHE 1 +#else +# define USE_PATH_CACHE 0 +#endif + +#include "compiledefines.h" +#ifndef _SYSTEM_ +# include "system.h" +#endif + +#if defined (POWER) +# define USE_SYSTEM_ALLOC 1 +#else +# define USE_SYSTEM_ALLOC 0 +#endif + +#include <stdio.h> +#ifndef mpwc +# include <pascal.h> +#endif +#include <Files.h> +#include <Memory.h> +#ifdef mpwc +# include <strings.h> +#endif +#include <Devices.h> +#include <Events.h> +#ifndef mpwc +# include <unix.h> +#endif +#if USE_PATH_CACHE +# include "path_cache.h" +#endif + +#undef FOLDER_DOES_NOT_EXIST_ERRORS + +static unsigned char *copy_c_to_p_string (char *c_string,char *p_string) +{ + char *s,*d,c; + + d=p_string+1; + s=c_string; + while (c=*s++, c!='\0') + *d++=c; + + *p_string=s-1-c_string; + + return (unsigned char*) p_string; +} + +static FileTime FindFileTime (char *fname,int wd_ref_num) +{ + int err; + FileParam fpb; + char p_string [256]; + + fpb.ioNamePtr=copy_c_to_p_string (fname,p_string); + fpb.ioFDirIndex=0; + fpb.ioFVersNum=0; + fpb.ioVRefNum=wd_ref_num; + +#ifdef mpwc + err = PBGetFInfoSync ((ParmBlkPtr)&fpb); +#else + err = PBGetFInfo (&fpb, 0); +#endif + + if (err) + return NoFile; + else + return fpb.ioFlMdDat; +} + +char *PATHLIST; + +#ifdef mpwc +struct path_list { + short path_wd_ref_num; + short path_clean_system_files_wd_ref_num; + struct path_list * path_next; +#if defined (__MWERKS__) || defined (__MRC__) + char path_name[]; +#else + char path_name[0]; +#endif +}; + +static struct path_list *path_list=NULL; + +static void add_directory_to_path_list (char *path_name,struct path_list **old_path_list_h) +{ + short wd_ref_num,clean_system_files_wd_ref_num; + struct path_list *new_path,**last_path_p; + int path_name_length; + char p_string [256]; + CInfoPBRec fpb; + WDPBRec wd_pb; + int err,root_path; + + root_path=0; + + if (path_name){ + char *p; + + for (p=path_name; *p!=':' && *p!='\0'; ++p) + ; + + if (*p=='\0'){ + root_path=1; + p[0]=':'; + p[1]='\0'; + } + } + + if (path_name) + fpb.hFileInfo.ioNamePtr=copy_c_to_p_string (path_name,p_string); + else + fpb.hFileInfo.ioNamePtr=(unsigned char*)"\001:"; + + fpb.hFileInfo.ioVRefNum=0; + fpb.hFileInfo.ioFDirIndex=0; + fpb.hFileInfo.ioDirID=0; + + err = PBGetCatInfoSync (&fpb); + + if (err!=0){ +#ifdef FOLDER_DOES_NOT_EXIST_ERRORS + if (path_name) + fprintf (stderr,"folder '%s' does not exist\n",path_name); +# ifdef ADD_NULL_PATH + else + fprintf (stderr,"folder ':' does not exist\n"); +# endif +#endif + return; + } + + wd_pb.ioNamePtr=fpb.hFileInfo.ioNamePtr; + wd_pb.ioWDProcID='ClCo'; + + wd_pb.ioVRefNum=0; + wd_pb.ioWDDirID=0; +/* + wd_pb.ioVRefNum=fpb.hFileInfo.ioVRefNum; + wd_pb.ioWDDirID=fpb.hFileInfo.ioDirID; +*/ + err = PBOpenWD (&wd_pb,0); + if (err!=0){ + if (path_name) + fprintf (stderr,"folder '%s' does not exist\n",path_name); +#ifdef ADD_NULL_PATH + else + fprintf (stderr,"folder ':' does not exist\n"); +#endif + return; + } + + wd_ref_num=wd_pb.ioVRefNum; + +#ifndef NO_CLEAN_SYSTEM_FILES_FOLDERS + if (path_name){ + if (root_path) + strcat (path_name,"Clean System Files"); + else + strcat (path_name,":Clean System Files"); + } else + path_name="Clean System Files"; + + fpb.hFileInfo.ioNamePtr=copy_c_to_p_string (path_name,p_string); + fpb.hFileInfo.ioVRefNum =0; + fpb.hFileInfo.ioFDirIndex=0; + fpb.hFileInfo.ioDirID=0; + + err = PBGetCatInfoSync (&fpb); + + if (err!=0){ + err = PBDirCreateSync ((HParamBlockRec*)&fpb); + + if (err!=0){ + fprintf (stderr,"cannot create folder '%s'\n",path_name); + + return; + } + } + + wd_pb.ioNamePtr=fpb.hFileInfo.ioNamePtr; + wd_pb.ioWDProcID='ClCo'; + + wd_pb.ioVRefNum=0; + wd_pb.ioWDDirID=0; +/* + wd_pb.ioVRefNum=fpb.hFileInfo.ioVRefNum; + wd_pb.ioWDDirID=fpb.hFileInfo.ioDirID; +*/ + err = PBOpenWD (&wd_pb,0); + if (err!=0){ + if (path_name) + fprintf (stderr,"folder '%s' does not exist\n",path_name); + return; + } + + clean_system_files_wd_ref_num=wd_pb.ioVRefNum; + + path_name_length=strlen (path_name)-strlen (":Clean System Files"); + if (path_name_length<0) + path_name_length=0; + path_name[path_name_length]='\0'; +#else + clean_system_files_wd_ref_num=0; + + if (path_name==NULL) + path_name=""; + + path_name_length=strlen (path_name); +#endif + + last_path_p=&path_list; + while (*last_path_p) + last_path_p=&(*last_path_p)->path_next; + + /* reuse memory from previous path_list */ + { + struct path_list *old_path_list_p; + + for (; (old_path_list_p=*old_path_list_h)!=NULL; old_path_list_h=&old_path_list_p->path_next){ + if (old_path_list_p->path_wd_ref_num==wd_ref_num && + old_path_list_p->path_clean_system_files_wd_ref_num==clean_system_files_wd_ref_num && + !strcmp (old_path_list_p->path_name,path_name)) + { + *old_path_list_h=old_path_list_p->path_next; + + old_path_list_p->path_next=NULL; + *last_path_p=old_path_list_p; + return; + } + } + } + + new_path=(struct path_list*)Alloc (1,sizeof (struct path_list)+1+path_name_length); + new_path->path_wd_ref_num=wd_ref_num; + new_path->path_clean_system_files_wd_ref_num=clean_system_files_wd_ref_num; + strcpy (new_path->path_name,path_name); + new_path->path_next=NULL; + + *last_path_p=new_path; +} +#endif + +extern char *path_parameter; + +void GetInitialPathList (void) +{ + char path[MAXPATHLEN]; + struct path_list *old_path_list; + char *s,*path_elem,*p; + int c; + + p = path_parameter; + + if (p==NULL){ + PATHLIST="\0"; + return; + } + + PATHLIST = p; + + old_path_list=path_list; + + path_list=NULL; + +#ifdef ADD_NULL_PATH + add_directory_to_path_list (NULL,&old_path_list); +#endif + + path_elem =PATHLIST; + + s=path_elem; + for (c = *s;;c = *s){ + if (c == ',' || c == '\0'){ + char *from_p,*dest_p; + + from_p=path_elem; + dest_p=path; + while (from_p<s) + *dest_p++ = *from_p++; + *dest_p = '\0'; + + add_directory_to_path_list (path,&old_path_list); + + if (c == '\0') + break; + + path_elem = ++s; + } else + ++s; + } +} + +void FreePathList (void) +{ + struct path_list *path,*next_path; + + path=path_list; + path_list=NULL; + + while (path!=NULL){ + next_path=path->path_next; + Free (path); + path=next_path; + } +} + +char *GetFileExtension (FileKind kind) +{ + switch (kind){ + case abcFile: return ".abc"; + case obj00File: return ".obj0"; + case obj20File: return ".obj1"; + case obj81File: return ".obj2"; + case iclFile: return ".icl"; + case dclFile: return ".dcl"; + case dumpFile: return ".dmp"; + case statFile: return ".stt"; + case stasFile: return ".str"; + case assFile: return ".a"; + case sunAssFile: return ".s"; + case helpFile: + case applFile: + case otherFile: + default: return ""; + } +} + +#ifdef NEWBRIDGE +extern char *clean_abc_path; /* imported from clm.c */ +#endif + +#if defined (mpwc) && WRITE_DCL_MODIFICATION_TIME + static Bool find_filepath_and_time (char *file_name,FileKind kind,char *path,FileTime *file_time_p) + { + char *file_extension; + struct path_list *path_elem; + + file_extension=GetFileExtension (kind); + + if (file_name[0]!=':'){ + strcpy (path,file_name); + strcat (path,file_extension); + +#if USE_PATH_CACHE + if (kind==dclFile){ + struct search_dcl_path_in_cache_result r; + + if (search_dcl_path_in_cache (file_name,&r)){ + strcpy (path,r.path); + +#ifndef NO_CLEAN_SYSTEM_FILES_FOLDERS + if (path[0]=='\0'){ + } else + strcat (path,":"); +#else + if (path[0]!='\0' && path[strlen (path)-1]!=':') + strcat (path,":"); +#endif + + strcat (path,file_name); + strcat (path,file_extension); + + *file_time_p=r.file_time; + + return True; + } + } +#endif + + for_l (path_elem,path_list,path_next){ + short wd_ref_num; + unsigned long file_time; + + wd_ref_num=path_elem->path_wd_ref_num; + + file_time=FindFileTime (path,wd_ref_num); + + if (file_time!=NoFile){ + strcpy (path,path_elem->path_name); + +#ifndef NO_CLEAN_SYSTEM_FILES_FOLDERS + if (path[0]=='\0'){ + } else + strcat (path,":"); +#else + if (path[0]!='\0' && path[strlen (path)-1]!=':') + strcat (path,":"); +#endif + + strcat (path,file_name); + strcat (path,file_extension); + +#if USE_PATH_CACHE + if (kind==dclFile) + cache_dcl_path (file_name,path_elem->path_wd_ref_num, + path_elem->path_clean_system_files_wd_ref_num,file_time,path_elem->path_name); +#endif + *file_time_p=file_time; + + return True; + } + } + } + + strcpy (path,file_name); + strcat (path,file_extension); + + { + unsigned long file_time; + + file_time=FindFileTime (path,0); + if (file_time==NoFile) + return False; + else { + *file_time_p=file_time; + return True; + } + } + } +#endif + +#ifdef mpwc + static Bool findfilepath (char *file_name,FileKind kind,char *path) + { + char *file_extension; + int in_clean_system_files_folder; + struct path_list *path_elem; + + switch (kind){ + case abcFile: + case obj00File: + case obj20File: + case obj81File: + in_clean_system_files_folder=1; + break; + default: + in_clean_system_files_folder=0; + } + + file_extension=GetFileExtension (kind); + + if (file_name[0]!=':'){ + strcpy (path,file_name); + strcat (path,file_extension); + +#if USE_PATH_CACHE + if (kind==dclFile){ + struct search_dcl_path_in_cache_result r; + + if (search_dcl_path_in_cache (file_name,&r)){ + strcpy (path,r.path); + +#ifndef NO_CLEAN_SYSTEM_FILES_FOLDERS + if (path[0]=='\0'){ + if (in_clean_system_files_folder) + strcpy (path,"Clean System Files:"); + } else + if (in_clean_system_files_folder) + strcat (path,":Clean System Files:"); + else + strcat (path,":"); +#else + if (path[0]!='\0' && path[strlen (path)-1]!=':') + strcat (path,":"); +#endif + + strcat (path,file_name); + strcat (path,file_extension); + + return True; + } + } +#endif + +#ifdef NEWBRIDGE + for (path_elem=(clean_abc_path!=NULL && !in_clean_system_files_folder && path_list!=NULL) + ? path_list->path_next + : path_list; + path_elem!=NULL; + path_elem=(clean_abc_path!=NULL && in_clean_system_files_folder) + ? NULL + : path_elem->path_next) + { +#else + for_l (path_elem,path_list,path_next){ +#endif + short wd_ref_num; + unsigned long file_time; + +#ifndef NO_CLEAN_SYSTEM_FILES_FOLDERS + if (in_clean_system_files_folder) + wd_ref_num=path_elem->path_clean_system_files_wd_ref_num; + else +#endif + wd_ref_num=path_elem->path_wd_ref_num; + + file_time=FindFileTime (path,wd_ref_num); + + if (file_time!=NoFile){ + strcpy (path,path_elem->path_name); + +#ifndef NO_CLEAN_SYSTEM_FILES_FOLDERS + if (path[0]=='\0'){ + if (in_clean_system_files_folder) + strcpy (path,"Clean System Files:"); + } else + if (in_clean_system_files_folder) + strcat (path,":Clean System Files:"); + else + strcat (path,":"); +#else + if (path[0]!='\0' && path[strlen (path)-1]!=':') + strcat (path,":"); +#endif + + strcat (path,file_name); + strcat (path,file_extension); + +#if USE_PATH_CACHE + if (kind==dclFile && !in_clean_system_files_folder) + cache_dcl_path (file_name,path_elem->path_wd_ref_num, + path_elem->path_clean_system_files_wd_ref_num,file_time,path_elem->path_name); +#endif + return True; + } + } +#ifdef NEWBRIDGE + return False; +#endif + } + + +#ifndef NO_CLEAN_SYSTEM_FILES_FOLDERS + if (in_clean_system_files_folder && file_name[0]!=':'){ + strcpy (path,":Clean System Files:"); + strcat (path, file_name); + } else +#endif + strcpy (path,file_name); + + strcat (path,file_extension); + + return FindFileTime (path,0); + } +#else + static Bool findfilepath (char *wname, FileKind kind, char *path) + { + char *s,*pathelem,c,*file_extension; + FILE *f; + + file_extension=GetFileExtension (kind); + + /* first try current directory */ + strcpy (path,wname); + strcat (path,file_extension); + + if (FindFileTime (path,0) != NoFile) + return True; + + pathelem = PATHLIST; + + s = pathelem; + for (c = *s;;c = *s){ + if (c == ',' || c == '\0'){ + char *from_p,*dest_p; + + from_p=path_elem; + dest_p=path; + while (from_p<s) + *dest_p++ = *from_p++; + *dest_p = '\0'; + + strcat (path, ":"); + strcat (path, wname); + strcat (path,file_extension); + + if (FindFileTime (path,0) != NoFile) + return True; + + /* if all else fails, exit the loop */ + if (c == '\0') + break; + + pathelem = ++s; + } else + ++s; + } + + /* if all else fails, return False, and the current name */ + strcpy (path,wname); + strcat (path,file_extension); + + return False; + } +#endif + +#if WRITE_DCL_MODIFICATION_TIME +File FOpenWithFileTime (char *file_name,FileKind kind, char *mode,FileTime *file_time_p) +{ + char path[MAXPATHLEN]; + Bool res; + + res=find_filepath_and_time (file_name, kind, path,file_time_p); + + if (res || mode[0] != 'r') + return (File) fopen (path, mode); + else + return NULL; +} +#endif + +File FOpen (char *file_name,FileKind kind, char *mode) +{ + char path[MAXPATHLEN]; + Bool res; + +#ifdef mpwc + if (mode[0]=='r'){ + findfilepath (file_name,kind,path); + return (File) fopen (path, mode); + } else { + char *p; + int full_path_name; + + for (p=file_name; *p!=':' && *p!='\0'; ++p) + ; + full_path_name = *p==':'; + + if (full_path_name){ + strcpy (path,file_name); + strcat (path,GetFileExtension (kind)); + return (File) fopen (path,mode); + } else { + res = findfilepath (file_name,dclFile, path); + if (!res) + res = findfilepath (file_name,iclFile, path); + + if (res){ + char *p,*after_last_colon; + + after_last_colon=NULL; + + p=path; + while (*p) + if (*p++==':') + after_last_colon=p; + + if (after_last_colon==NULL){ + after_last_colon=path; + *after_last_colon++=':'; + } +#ifndef NO_CLEAN_SYSTEM_FILES_FOLDERS + strcpy (after_last_colon,"Clean System Files:"); +#endif + strcat (after_last_colon,file_name); + strcat (after_last_colon,GetFileExtension (kind)); + + return (File) fopen (path, mode); + } else + return (File) Null; + } + } +#else + res=findfilepath (file_name, kind, path); + + if (res || mode[0] != 'r') + return (File) fopen (path, mode); + else + return (File) Null; +#endif +} + +#if USE_PATH_CACHE + +#define BUFFER_SIZE 1024 + +struct file_block { + int file_block_size; + struct file_block * file_block_next; + char file_block_data[BUFFER_SIZE]; +}; + +static int reading_from_cache; +File dcl_file; + +static struct file_block **next_file_block_l; + +#if WRITE_DCL_MODIFICATION_TIME +int open_dcl_file_for_block_reading_with_file_time (char *file_name,File *file_p,FileTime *file_time_p) +{ + char path[256]; + struct file_block **file_blocks_p; + + file_blocks_p=get_file_blocks_p_and_time_of_dcl_file (file_name,file_time_p); + + if (file_blocks_p && *file_blocks_p){ + reading_from_cache=1; + next_file_block_l=file_blocks_p; + *file_p=NULL; + return 1; + } else { + reading_from_cache=0; + + findfilepath (file_name,dclFile,path); + + file_blocks_p=get_file_blocks_p_and_time_of_dcl_file (file_name,file_time_p); + if (file_blocks_p==NULL){ + *file_p=NULL; + return 0; + } + next_file_block_l=file_blocks_p; + + dcl_file=(File) fopen (path,"rb"); + + *file_p=dcl_file; + if (dcl_file){ + setvbuf ((FILE*) dcl_file,NULL,_IOFBF,8192); + + return 1; + } else + return 0; + } +} +#endif + +int open_dcl_file_for_block_reading (char *file_name,File *file_p) +{ + char path[256]; + struct file_block **file_blocks_p; + + file_blocks_p=get_file_blocks_p_of_dcl_file (file_name); + + if (file_blocks_p && *file_blocks_p){ + reading_from_cache=1; + next_file_block_l=file_blocks_p; + *file_p=NULL; + return 1; + } else { + reading_from_cache=0; + + findfilepath (file_name,dclFile,path); + + file_blocks_p=get_file_blocks_p_of_dcl_file (file_name); + if (file_blocks_p==NULL){ + *file_p=NULL; + return 0; + } + next_file_block_l=file_blocks_p; + + dcl_file=(File) fopen (path,"rb"); + + *file_p=dcl_file; + if (dcl_file){ + setvbuf ((FILE*) dcl_file,NULL,_IOFBF,8192); + + return 1; + } else + return 0; + } +} + +int read_next_block_from_dcl_file (char *buffer) +{ + if (reading_from_cache){ + struct file_block *file_block_p; + + file_block_p=*next_file_block_l; + + if (file_block_p!=NULL){ + int n_chars; + + n_chars=file_block_p->file_block_size; + memcpy (buffer,file_block_p->file_block_data,n_chars); + + if (n_chars>0) + next_file_block_l=&file_block_p->file_block_next; + + return n_chars; + } else + return 0; + } else { + int n_chars_read; + + n_chars_read = FRead (buffer,1,1024l,dcl_file); + if (n_chars_read>0){ + struct file_block *new_file_block_p; + + new_file_block_p=(struct file_block*)Alloc (1,sizeof (struct file_block)); + + new_file_block_p->file_block_size=n_chars_read; + memcpy (new_file_block_p->file_block_data,buffer,n_chars_read); + new_file_block_p->file_block_next=NULL; + + *next_file_block_l=new_file_block_p; + next_file_block_l=&new_file_block_p->file_block_next; + } + + return n_chars_read; + } +} +#endif + +int FClose (File f) +{ + return fclose ((FILE *) f); +} + +extern int FDelete (char *fname, FileKind kind); + +int FDelete (char *fname, FileKind kind) +{ + char path[MAXPATHLEN]; + Bool res; + + res = findfilepath (fname, kind, path); + + if (res) + return remove (path); + else + return -1; +} + +#define OUTSIZE 2048 + +int FPrintF (File f, char *fmt, ...) +{ int n; + va_list args; + char outbuffer[OUTSIZE]; + + va_start (args, fmt); + + vsprintf (outbuffer, fmt, args); + + n = strlen (outbuffer); + if (n >= OUTSIZE) + { fputs ("FATAL ERROR: out buffer to small\n", stderr); + exit (1); + } + + va_end (args); + + return fputs (outbuffer, (FILE *) f); +} /* FPrintF */ + +size_t FWrite (void *ptr, size_t size, size_t count, File f) +{ + return fwrite (ptr, size, count, (FILE *) f); +} /* FWrite */ + +size_t FRead (void *ptr, size_t size, size_t count, File f) +{ + return fread (ptr, size, count, (FILE *) f); +} /* FRead */ + +int FPutS (char *s, File f) +{ + return fputs (s, (FILE *) f); +} /* FPutS */ + +int FSeek (File f, long offset, int origin) +{ + return fseek ((FILE *) f, offset, origin); +} /* FSeek */ + +long FTell (File f) +{ + return ftell ((FILE *) f); +} /* FTell */ + +FileTime FGetFileTime (char *fname, FileKind kind) +{ + char path[MAXPATHLEN]; + Bool res; + + res = findfilepath (fname, kind, path); + +/* FPrintF (StdOut, "timing %s\n", fname); */ + + if (res) + return FindFileTime (path,0); + else + return NoFile; +} /* FGetFileTime */ + +#ifdef WRITE_DCL_MODIFICATION_TIME +void FWriteFileTime (FileTime file_time,File f) +{ + DateTimeRec date_and_time; + + SecondsToDate (file_time,&date_and_time); + + fprintf (f,"%04d%02d%02d%02d%02d%02d", + date_and_time.year,date_and_time.month,date_and_time.day, + date_and_time.hour,date_and_time.minute,date_and_time.second); +} + +#endif + +Bool GetOptionsFromIclFile (char *fname, CompilerOptions *opts) +{ + return False; +} /* GetOptionsFromIclFile */ + +void DoError (char *fmt, ...) +{ va_list args; + + va_start (args, fmt); + + (void) vfprintf (stderr, fmt, args); + + va_end (args); +} /* DoError */ + +void DoFatalError (char *fmt, ...) +{ va_list args; + + va_start (args, fmt); + + fputs ("Fatal error: ", stderr); + (void) vfprintf (stderr, fmt, args); + va_end (args); + + exit (0); +} /* DoFatalError */ + + +void CmdError (char *errormsg,...) +{ va_list args; + + va_start (args, errormsg); + + fputs ("Command line error: ", stdout); + vfprintf (stdout, errormsg, args); + fputc ('\n', stdout); + + va_end (args); +} /* CmdError */ + +extern long GetMainModuleVolume (void); +long GetMainModuleVolume (void) +{ + return 0; +} /* GetMainModuleVolume */ + +static void Nothing (void) +{ +} /* Nothing */ + +static void (*interfunct) (void) = Nothing; + +void (*SetSignal (void (*f) (void))) (void) +{ void (*oldf) () = interfunct; + interfunct = f; + return oldf; +} /* SetSignal */ + +int CheckInterrupt () +{ +#ifndef mpwc + EventRecord the_Event; /* holds the event record */ + + GetNextEvent(everyEvent, &the_Event); + + if (the_Event.what == keyDown && the_Event.modifiers & cmdKey) + { + char c; + + c = (unsigned char) the_Event.message; + if (c == '.') + { (*interfunct) (); + return True; + } + } +#endif + return False; +} /* CheckInterrupt */ + +void *Alloc (unsigned long count, SizeT size) +{ + if (size!=1){ + if (count >= MAXUNSIGNED / size) + DoFatalError ("Allocate: severe memory allocation problem"); + count *= size; + } + +#if USE_SYSTEM_ALLOC + return (void *) NewPtr ((size_t) (count)); +#else + return (void *) malloc ((size_t) (count)); +#endif +} + +void Free (void *p) +{ +#if USE_SYSTEM_ALLOC + DisposePtr ((char*)p); +#else + free ((char *) p); +#endif +} + +typedef struct LaunchStruct { + char *pfName; + int param; + char LC[2]; + long extBlockLen; + int fFlags; + long launchFlags; +} *pLanchStruct; + +int System (char *file_name) +{ +#ifdef mpwc + return 0; +#else + struct LaunchStruct myLaunch; + HFileInfo myPb; + int error; + char *errmsg = "Could not launch %s\n"; + + CtoPstr (file_name); + + myPb.ioNamePtr=(StringPtr) file_name; + myPb.ioVRefNum=0; + myPb.ioFDirIndex=0; + myPb.ioDirID=0; + + error=PBGetCatInfo ((CInfoPBPtr) &myPb,0); + if (error) + { + PtoCstr (file_name); + DoError (errmsg, file_name); + return error; + } + + error=SetVol (Null,0); + if (error) + { + PtoCstr (file_name); + DoError (errmsg, file_name); + return error; + } + + myLaunch.pfName=file_name; + myLaunch.param=0; + myLaunch.LC[0]='L'; + myLaunch.LC[1]='C'; + myLaunch.extBlockLen=4; + myLaunch.fFlags=myPb.ioFlFndrInfo.fdFlags; + myLaunch.launchFlags=0xc0000000; + + asm + { + lea myLaunch,A0 + _Launch + move d0,error + } + + PtoCstr (file_name); + + if (error>=0) + return 0; + else + { DoError (errmsg, file_name); + return error; + } +#endif +} /* System */ + diff --git a/backendC/CleanCompilerSources/macros.h b/backendC/CleanCompilerSources/macros.h new file mode 100644 index 0000000..a9266f9 --- /dev/null +++ b/backendC/CleanCompilerSources/macros.h @@ -0,0 +1,8 @@ + +extern Node substitute_macro_in_rhs (Macro *macro_p,Node appl,int local_scope,NodeDefs **node_def_p,ImpRuleS ***imp_rule_p); +extern Node substitute_macro_in_lhs (RuleAltS *alt,Node appl,int local_scope,NodeDefs **node_def_p); +extern void CheckEqualMacros (RuleAltS *alt1,RuleAltS *alt2); + +extern struct local_def *AllocateLocalDef (void); + +extern struct local_def *free_ldefs; diff --git a/backendC/CleanCompilerSources/macros_2.c b/backendC/CleanCompilerSources/macros_2.c new file mode 100644 index 0000000..0a63a9b --- /dev/null +++ b/backendC/CleanCompilerSources/macros_2.c @@ -0,0 +1,17 @@ +/* + File: macros.c + Author: John van Groningen +*/ + +#include "types.t" +#include "system.h" +#include "syntaxtr.t" +#include "comsupport.h" +#include "sizes.h" +#include "buildtree.h" +#include "checksupport.h" +#include "macros.h" +#include "checktypedefs.h" + +struct local_def *free_ldefs; + diff --git a/backendC/CleanCompilerSources/macuser.h b/backendC/CleanCompilerSources/macuser.h new file mode 100644 index 0000000..6189474 --- /dev/null +++ b/backendC/CleanCompilerSources/macuser.h @@ -0,0 +1,66 @@ + +/******************************************************************************* + * * + * Mac User Interface Dependencies * + * * + ******************************************************************************/ + +extern int MACUSERVAR; +#define CheckVersion if (MACUSERVAR != VERSION) DoFatalError ("Wrong version number") + + +typedef int TwoBytesInt; +typedef long int FourBytesInt; +typedef unsigned TwoBytesUnsigned; +typedef unsigned long FourBytesUnsigned; +#ifdef applec +typedef double EightBytesReal; +#else +typedef short double EightBytesReal; +#endif +typedef float FourBytesReal; + + +#define SizeT unsigned long +#define SizeOf(A) ((SizeT) sizeof (A)) + +#include <limits.h> +#define MAXUNSIGNED ULONG_MAX + +/* +#define _SCREENFileS_ +*/ + +#define _CURMOV_ +#define _VARARGS_ + + +#include <string.h> +#include <stdlib.h> +#ifdef applec +# include <stdio.h> +#else +# include <unix.h> +#endif +#include <setjmp.h> +#include <stdarg.h> + + +/* +this type is not provided by LightSpeed C + +typedef unsigned long time_t; +*/ +typedef FILE *File; + + +# define FClose fclose +# define FPrintF fprintf +# define FPutC fputc +# define FPutS fputs +# define FWrite fwrite +# define FSeek fseek +# define FTell ftell +# define FGetC fgetc +# define FGetS fgets +# define FRead fread diff --git a/backendC/CleanCompilerSources/optimisations.c b/backendC/CleanCompilerSources/optimisations.c new file mode 100644 index 0000000..3d41f1d --- /dev/null +++ b/backendC/CleanCompilerSources/optimisations.c @@ -0,0 +1,3601 @@ +/* + File: optimisations.c + Author: John van Groningen +*/ + +#include "system.h" +#include "syntaxtr.t" +#include "comsupport.h" +#include "statesgen.h" +#include "checker.h" +#include "scanner.h" +#include "buildtree.h" +#include "optimisations.h" +#include "codegen_types.h" +#include "codegen1.h" +#include "codegen2.h" +#include "sa.h" +#include "settings.h" +#include "pattern_match.h" + +#define STRICT_STATE_FOR_LAZY_TUPLE_CONSTRUCTORS +#define UNTUPLE_STRICT_TUPLES /* also in statesgen.c */ +#define MOVE_TUPLE_RECORD_AND_ARRAY_RESULT_FUNCTION_ARGUMENT_IN_LAZY_CONTEXT_TO_NEW_FUNCTION +#define MOVE_APPLY_NODES_IN_LAZY_CONTEXT_TO_NEW_FUNCTION + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) +#define for_la(v1,v2,l1,l2,n) for(v1=(l1),v2=(l2);v1!=NULL;v1=v1->n,++v2) +#define for_li(v,i,l,n) for(v=(l),i=0;v!=NULL;v=v->n,++i) +#define for_l_l(v1,l1,n1,v2,l2,n2) for(v1=(l1),v2=(l2);v1!=NULL;v1=v1->n1,v2=v2->n2) +#define for_lla(v1,v2,v3,l1,l2,l3,n1,n2) for(v1=(l1),v2=(l2),v3=(l3);v1!=NULL;v1=v1->n1,v2=v2->n2,++v3) + +#define BETWEEN(l,h,v) ((unsigned)((v)-(l)) <= (unsigned)((h)-(l))) + +static void error_in_function (char *m) +{ + ErrorInCompiler ("optimisations.c",m,""); +} + +#define MAX_N_VERSIONS 3 + +static int function_changed; + +static int tuple_state_has_more_strictness (StateS *state_p,TypeNode type_node,StateS *function_state_p) +{ + StateS *arg_state_p,*function_arg_state_p; + TypeArg *type_arg; + + if (type_node->type_node_is_var || type_node->type_node_symbol->symb_kind!=tuple_type) + return 0; + + if (type_node->type_node_arity!=state_p->state_arity || type_node->type_node_symbol->symb_arity!=state_p->state_arity) + return 0; + + type_arg=type_node->type_node_arguments; + arg_state_p=state_p->state_tuple_arguments; + function_arg_state_p=function_state_p->state_tuple_arguments; + + while (type_arg!=NULL){ + switch (arg_state_p->state_type){ + case SimpleState: + if (! IsLazyStateKind (arg_state_p->state_kind)) + if (IsLazyState (*function_arg_state_p)) + return 1; + break; + case TupleState: + if (IsLazyState (*function_arg_state_p)) + return 1; + + if (function_arg_state_p->state_type==TupleState) + if (tuple_state_has_more_strictness (arg_state_p,type_arg->type_arg_node,function_arg_state_p)) + return 1; + break; + case ArrayState: + case RecordState: + if (IsLazyState (*function_arg_state_p)) + return 1; + break; + } + + type_arg=type_arg->type_arg_next; + ++arg_state_p; + ++function_arg_state_p; + } + + return 0; +} + +static int equal_strictness_in_types (TypeNode lazy_type_node,TypeNode strict_type_node) +{ + TypeArg *lazy_type_arg,*strict_type_arg; + + if (lazy_type_node->type_node_is_var || lazy_type_node->type_node_symbol->symb_kind!=tuple_type) + return 0; + + for_l_l (lazy_type_arg,lazy_type_node->type_node_arguments,type_arg_next, + strict_type_arg,strict_type_node->type_node_arguments,type_arg_next) + { + TypeNode lazy_type_arg_node,strict_type_arg_node; + + lazy_type_arg_node=lazy_type_arg->type_arg_node; + strict_type_arg_node=strict_type_arg->type_arg_node; + + if (lazy_type_arg_node->type_node_annotation==StrictAnnot != strict_type_arg_node->type_node_annotation==StrictAnnot) + return 0; + + if (!lazy_type_arg_node->type_node_is_var && lazy_type_arg_node->type_node_symbol->symb_kind==tuple_type) + if (!equal_strictness_in_types (lazy_type_arg_node,strict_type_arg_node)) + return 0; + } + + return 1; +} + +static int type_and_strictness_in_state_equals_type (TypeNode lazy_type_node,StateS *state_p,TypeNode strict_type_node) +{ + StateS *arg_state_p; + TypeArg *lazy_type_arg,*strict_type_arg; + + if (lazy_type_node->type_node_is_var || lazy_type_node->type_node_symbol->symb_kind!=tuple_type) + return 0; + + if (lazy_type_node->type_node_arity!=state_p->state_arity || lazy_type_node->type_node_symbol->symb_arity!=state_p->state_arity) + return 0; + + arg_state_p=state_p->state_tuple_arguments; + lazy_type_arg=lazy_type_node->type_node_arguments; + strict_type_arg=strict_type_node->type_node_arguments; + + while (lazy_type_arg!=NULL){ + TypeNode lazy_type_arg_node,strict_type_arg_node; + int strict; + + lazy_type_arg_node=lazy_type_arg->type_arg_node; + strict_type_arg_node=strict_type_arg->type_arg_node; + + strict = lazy_type_arg_node->type_node_annotation==StrictAnnot || !IsLazyState (*arg_state_p); + + if (strict != strict_type_arg_node->type_node_annotation==StrictAnnot) + return 0; + + if (!lazy_type_arg_node->type_node_is_var && lazy_type_arg_node->type_node_symbol->symb_kind==tuple_type) + if (arg_state_p->state_type==TupleState){ + if (!type_and_strictness_in_state_equals_type (lazy_type_arg_node,arg_state_p,strict_type_arg_node)) + return 0; + } else { + if (!equal_strictness_in_types (lazy_type_arg_node,strict_type_arg_node)) + return 0; + } + + ++arg_state_p; + lazy_type_arg=lazy_type_arg->type_arg_next; + strict_type_arg=strict_type_arg->type_arg_next; + } + + return 1; +} + +static void add_strictness_in_state_to_type (StateS *state_p,TypeNode type_node) +{ + StateS *arg_state_p; + TypeArg *type_arg; + + if (type_node->type_node_is_var || type_node->type_node_symbol->symb_kind!=tuple_type) + return; + + if (type_node->type_node_arity!=state_p->state_arity || type_node->type_node_symbol->symb_arity!=state_p->state_arity) + return; + + arg_state_p=state_p->state_tuple_arguments; + type_arg=type_node->type_node_arguments; + + while (type_arg!=NULL){ + TypeNode type_arg_node; + + type_arg_node=type_arg->type_arg_node; + + switch (arg_state_p->state_type){ + case SimpleState: + if (IsLazyStateKind (arg_state_p->state_kind)) + break; + case ArrayState: + case RecordState: + if (type_arg_node->type_node_annotation==NoAnnot) + type_arg_node->type_node_annotation=StrictAnnot; + break; + case TupleState: + if (type_arg_node->type_node_annotation==NoAnnot) + type_arg_node->type_node_annotation=StrictAnnot; + + if (!type_arg_node->type_node_is_var && type_arg_node->type_node_symbol->symb_kind==tuple_type) + add_strictness_in_state_to_type (arg_state_p,type_arg_node); + break; + } + + ++arg_state_p; + type_arg=type_arg->type_arg_next; + } +} + +static TypeNode copy_type (TypeNode old_type) +{ + TypeNode new_type; + + new_type=CompAllocType (struct type_node); + *new_type=*old_type; + +#if 0 + ConvertAnnotationToStateForTypeNode (new_type); +#endif + + if (!old_type->type_node_is_var){ + TypeArgs old_arg,*next_p; + + next_p=&new_type->type_node_arguments; + for_l (old_arg,old_type->type_node_arguments,type_arg_next){ + TypeArgs new_arg; + + new_arg=CompAllocType (TypeArg); + new_arg->type_arg_node=copy_type (old_arg->type_arg_node); + *next_p=new_arg; + next_p=&new_arg->type_arg_next; + } + + *next_p=NULL; + } + + return new_type; +} + +static TypeAlts copy_rule_type (TypeAlts old_rule_alt) +{ + TypeAlts new_rule_alt; + + new_rule_alt=CompAllocType (TypeAlt); + *new_rule_alt=*old_rule_alt; + + new_rule_alt->type_alt_lhs = copy_type (old_rule_alt->type_alt_lhs); + new_rule_alt->type_alt_rhs = copy_type (old_rule_alt->type_alt_rhs); + + return new_rule_alt; +} + +SymbolP copy_imp_rule_and_type (SymbDef old_sdef) +{ + SymbDef new_sdef; + ImpRuleP new_rule,old_rule; + Symbol new_symbol; + + new_sdef = CompAllocType (SymbDefS); + + new_symbol=NewSymbol (definition); + new_symbol->symb_def=new_sdef; + + *new_sdef = *old_sdef; + new_sdef->sdef_mark &= ~(SDEF_USED_STRICTLY_MASK | SDEF_USED_LAZILY_MASK | SDEF_USED_CURRIED_MASK | + SDEF_NEXT_IMP_RULE_VERSION_MASK | SDEF_HAS_IMP_RULE_VERSIONS_MASK); + new_sdef->sdef_exported=False; + new_sdef->sdef_sa_fun=NULL; + + new_rule = CompAllocType (ImpRuleS); + new_sdef->sdef_rule=new_rule; + + old_rule=old_sdef->sdef_rule; + + new_rule->rule_type=copy_rule_type (old_rule->rule_type); + new_rule->rule_type->type_alt_lhs->type_node_symbol=new_symbol; + + return new_symbol; +} + +static Node copy_node (Node old, Bool lhs); + +static NodeId copy_node_id (NodeId old_node_id) +{ + NodeId new_node_id; + + new_node_id = CompAllocType (NodeIdS); + + *new_node_id = *old_node_id; + + new_node_id->nid_mark &= ~SHARED_NODES_COLLECTED_MASK; + +#if OPTIMIZE_LAZY_TUPLE_RECURSION + new_node_id->nid_mark2 &= ~NID_CALL_VIA_LAZY_SELECTIONS_ONLY; +#endif + new_node_id->nid_ref_count_copy_=new_node_id->nid_refcount; + new_node_id->nid_exp_=NULL; + + old_node_id->nid_forward_node_id_ = new_node_id; + + return new_node_id; +} + +static NodeDefP copy_lhs_node_ids_of_node_defs (NodeDefs old_node_defs) +{ + NodeDefP old_def_p,first_p,*next_h; + + next_h=&first_p; + + for_l (old_def_p,old_node_defs,def_next){ + NodeDefs new_node_def; + + new_node_def = CompAllocType (NodeDefS); + + new_node_def->def_id = copy_node_id (old_def_p->def_id); + new_node_def->def_node = old_def_p->def_node; + new_node_def->def_mark = 0; + + *next_h=new_node_def; + next_h=&new_node_def->def_next; + } + + *next_h=NULL; + + return first_p; +} + +static NodeDefP copy_rhs_node_ids_of_node_defs (NodeDefs old_node_defs,NodeDefP **end_node_defs_h) +{ + NodeDefP old_def_p,first_p,*next_h; + + next_h=&first_p; + + for_l (old_def_p,old_node_defs,def_next){ + NodeDefs new_node_def; + NodeId new_node_id; + + if (old_def_p->def_node!=NULL) + new_node_id = copy_node_id (old_def_p->def_id); + else + new_node_id = old_def_p->def_id->nid_forward_node_id; + + new_node_def = CompAllocType (NodeDefS); + + new_node_def->def_id=new_node_id; + new_node_id->nid_node_def_=new_node_def; + new_node_def->def_mark=0; + + new_node_def->def_node = old_def_p->def_node; + *next_h=new_node_def; + next_h=&new_node_def->def_next; + } + + *next_h=NULL; + + if (end_node_defs_h!=NULL) + if (first_p==NULL) + *end_node_defs_h=NULL; + else + *end_node_defs_h=next_h; + + return first_p; +} + +static void copy_nodes_of_node_defs (NodeDefs node_defs,Bool lhs) +{ + NodeDefS *node_def; + + for_l (node_def,node_defs,def_next){ + if (node_def->def_node!=NULL) + node_def->def_node = copy_node (node_def->def_node,lhs); + node_def->def_id->nid_node=node_def->def_node; + } +} + +static StrictNodeIdP copy_strict_node_ids (StrictNodeIdP old_strict_node_ids) +{ + StrictNodeIdP old_p,first_p,*next_h; + + next_h=&first_p; + + for_l (old_p,old_strict_node_ids,snid_next){ + StrictNodeIdP new; + + new = CompAllocType (StrictNodeIdS); + + new->snid_mark = old_p->snid_mark; +#ifdef OBSERVE_ARRAY_SELECTS_IN_PATTERN + new->snid_array_select_in_pattern=old_p->snid_array_select_in_pattern; +#endif + new->snid_node_id = old_p->snid_node_id->nid_forward_node_id; + + *next_h = new; + next_h = &new->snid_next; + } + *next_h = NULL; + + return first_p; +} + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +static Node copy_root_node (Node old) +{ + if (old->node_kind==IfNode){ + struct if_node_contents *new_then_else_info,*old_then_else_info; + ArgS *previous_arg,*new_arg,*old_arg; + Node new; + + new = CompAllocType (NodeS); + + *new = *old; + + DetermineNodeState (new); + + new_then_else_info = CompAllocType (IfNodeContentsS); + + old_then_else_info = old->node_contents.contents_if; + new->node_contents.contents_if = new_then_else_info; + + new_then_else_info->if_then_rules = NULL; + new_then_else_info->if_else_rules = NULL; + + old_arg=old->node_arguments; + + new_arg = CompAllocType (ArgS); + new_arg->arg_node = copy_root_node (old_arg->arg_node); + new_arg->arg_state = LazyState; + new->node_arguments = new_arg; + previous_arg = new_arg; + + old_arg=old_arg->arg_next; + + new_then_else_info->if_then_node_defs=copy_rhs_node_ids_of_node_defs (old_then_else_info->if_then_node_defs,NULL); + + new_arg = CompAllocType (ArgS); + new_arg->arg_state = LazyState; + new_arg->arg_node = copy_root_node (old_arg->arg_node); + previous_arg->arg_next = new_arg; + previous_arg = new_arg; + + copy_nodes_of_node_defs (new_then_else_info->if_then_node_defs,False); + new_then_else_info->if_then_strict_node_ids=copy_strict_node_ids (old_then_else_info->if_then_strict_node_ids); + + new_then_else_info->if_else_node_defs=copy_rhs_node_ids_of_node_defs (old_then_else_info->if_else_node_defs,NULL); + + old_arg=old_arg->arg_next; + + new_arg = CompAllocType (ArgS); + new_arg->arg_state = LazyState; + new_arg->arg_node = copy_root_node (old_arg->arg_node); + previous_arg->arg_next = new_arg; + new_arg->arg_next=NULL; + + copy_nodes_of_node_defs (new_then_else_info->if_else_node_defs,False); + new_then_else_info->if_else_strict_node_ids=copy_strict_node_ids (old_then_else_info->if_else_strict_node_ids); + + new_then_else_info->if_local_scope=old_then_else_info->if_local_scope; + + return new; + } else if (old->node_kind==SwitchNode){ + Args *next,old_arg; + NodeP new; + + new = CompAllocType (NodeS); + *new = *old; + + { + NodeIdP old_node_id,new_node_id; + + old_node_id = old->node_node_id; + + new_node_id=old_node_id->nid_forward_node_id; + + if (new_node_id==NULL) + error_in_function ("copy_root_node"); + + new->node_node_id=new_node_id; + } + + next = &new->node_arguments; + for_l (old_arg,old->node_arguments,arg_next){ + NodeP case_node_p,new_case_node_p; + ArgP new_arg,case_node_arg_p,new_case_node_arg_p; + + new_arg = CompAllocType (ArgS); + new_arg->arg_state = LazyState; + + *next = new_arg; + next = &new_arg->arg_next; + + case_node_p=old_arg->arg_node; + + new_case_node_p = CompAllocType (NodeS); + *new_case_node_p = *case_node_p; + + new_arg->arg_node = new_case_node_p; + + new_case_node_arg_p=CompAllocType (ArgS); + new_case_node_arg_p->arg_state=LazyState; + + new_case_node_p->node_arguments=new_case_node_arg_p; + new_case_node_arg_p->arg_next=NULL; + + case_node_arg_p=case_node_p->node_arguments; + + new_case_node_p->node_su.su_u.u_case=CompAllocType (CaseNodeContentsS); + + if (case_node_p->node_kind==CaseNode){ + new_case_node_p->node_node_defs = copy_rhs_node_ids_of_node_defs (case_node_p->node_node_defs,NULL); + + if (case_node_arg_p->arg_node->node_kind==PushNode){ + ArgP push_node_arg_1,new_push_node_arg_1,new_push_node_arg_2; + NodeP push_node_arg_2_node,push_node,new_push_node; + NodeIdListElementP node_id_list,*new_node_id_list_p; + + push_node=case_node_arg_p->arg_node; + + new_push_node=CompAllocType (NodeS); + *new_push_node=*push_node; + + new_case_node_arg_p->arg_node=new_push_node; + push_node_arg_1=push_node->node_arguments; + + new_node_id_list_p=&new_push_node->node_node_ids; + + if (push_node_arg_1->arg_node->node_node_id->nid_node!=NULL){ + /* unboxable lhs tuple or record */ + for_l (node_id_list,push_node->node_node_ids,nidl_next){ + NodeIdListElementP new_node_id_list; + + new_node_id_list=CompAllocType (NodeIdListElementS); + + new_node_id_list->nidl_node_id=node_id_list->nidl_node_id->nid_forward_node_id; + + *new_node_id_list_p=new_node_id_list; + new_node_id_list_p=&new_node_id_list->nidl_next; + } + + } else { + for_l (node_id_list,push_node->node_node_ids,nidl_next){ + NodeIdListElementP new_node_id_list; + + new_node_id_list=CompAllocType (NodeIdListElementS); + + new_node_id_list->nidl_node_id=copy_node_id (node_id_list->nidl_node_id); + + *new_node_id_list_p=new_node_id_list; + new_node_id_list_p=&new_node_id_list->nidl_next; + } + } + + *new_node_id_list_p=NULL; + + push_node_arg_2_node=push_node_arg_1->arg_next->arg_node; + + new_push_node_arg_1=CompAllocType (ArgS); + new_push_node_arg_1->arg_state=LazyState; + + new_push_node_arg_2=CompAllocType (ArgS); + new_push_node_arg_2->arg_state=LazyState; + + new_push_node->node_arguments=new_push_node_arg_1; + new_push_node_arg_1->arg_next=new_push_node_arg_2; + new_push_node_arg_2->arg_next=NULL; + + copy_nodes_of_node_defs (new_case_node_p->node_node_defs,False); + new_push_node_arg_1->arg_node = copy_node (push_node_arg_1->arg_node,False); + new_push_node_arg_2->arg_node = copy_root_node (push_node_arg_2_node); + } else { + copy_nodes_of_node_defs (new_case_node_p->node_node_defs,False); + new_case_node_arg_p->arg_node = copy_root_node (case_node_arg_p->arg_node); + } + } else if (case_node_p->node_kind==DefaultNode){ + new_case_node_p->node_node_defs = copy_rhs_node_ids_of_node_defs (case_node_p->node_node_defs,NULL); + copy_nodes_of_node_defs (new_case_node_p->node_node_defs,False); + new_case_node_arg_p->arg_node = copy_root_node (case_node_arg_p->arg_node); + } else + error_in_function ("copy_root_node"); + + { + NodeIdRefCountListP node_id_ref_count_elem_p,new_node_id_ref_count_elem_p,*node_id_ref_count_elem_h; + + node_id_ref_count_elem_h=&new_case_node_p->node_node_id_ref_counts; + + for_l (node_id_ref_count_elem_p,case_node_p->node_node_id_ref_counts,nrcl_next){ + new_node_id_ref_count_elem_p=CompAllocType (NodeIdRefCountListS); + + *node_id_ref_count_elem_h=new_node_id_ref_count_elem_p; + new_node_id_ref_count_elem_p->nrcl_ref_count = node_id_ref_count_elem_p->nrcl_ref_count; + new_node_id_ref_count_elem_p->nrcl_node_id = node_id_ref_count_elem_p->nrcl_node_id->nid_forward_node_id; + + node_id_ref_count_elem_h=&new_node_id_ref_count_elem_p->nrcl_next; + } + *node_id_ref_count_elem_h=NULL; + } + { + StrictNodeIdP strict_node_id_p,new_strict_node_id,*strict_node_id_h; + + strict_node_id_h=&new_case_node_p->node_strict_node_ids; + + for_l (strict_node_id_p,case_node_p->node_strict_node_ids,snid_next){ + new_strict_node_id=CompAllocType (StrictNodeIdS); + new_strict_node_id->snid_mark=0; + + *strict_node_id_h=new_strict_node_id; + new_strict_node_id->snid_node_id = strict_node_id_p->snid_node_id->nid_forward_node_id; + + strict_node_id_h=&new_strict_node_id->snid_next; + } + + *strict_node_id_h=NULL; + } + } + + *next = NULL; + + return new; + } else if (old->node_kind==GuardNode){ + NodeP new; + ArgP arg_1,arg_2; + + new = CompAllocType (NodeS); + *new = *old; + + arg_1 = CompAllocType (ArgS); + arg_1->arg_state = LazyState; + + arg_2 = CompAllocType (ArgS); + arg_2->arg_state = LazyState; + + new->node_arguments=arg_1; + arg_1->arg_next=arg_2; + arg_2->arg_next=NULL; + + arg_1->arg_node = copy_root_node (old->node_arguments->arg_node); + + new->node_node_defs = copy_rhs_node_ids_of_node_defs (old->node_node_defs,NULL); + + arg_2->arg_node = copy_root_node (old->node_arguments->arg_next->arg_node); + + copy_nodes_of_node_defs (new->node_node_defs,False); + + { + StrictNodeIdP strict_node_id_p,new_strict_node_id,*strict_node_id_h; + + strict_node_id_h=&new->node_guard_strict_node_ids; + + for_l (strict_node_id_p,old->node_guard_strict_node_ids,snid_next){ + new_strict_node_id=CompAllocType (StrictNodeIdS); + new_strict_node_id->snid_mark=0; + + *strict_node_id_h=new_strict_node_id; + new_strict_node_id->snid_node_id = strict_node_id_p->snid_node_id->nid_forward_node_id; + + strict_node_id_h=&new_strict_node_id->snid_next; + } + + *strict_node_id_h=NULL; + } + + return new; + } else + return copy_node (old,False); +} +#endif + +static Node copy_node (Node old,Bool lhs) +{ + Node new; + + new = CompAllocType (NodeS); + + *new = *old; + + if (old->node_kind==NodeIdNode){ + NodeId old_nid,new_node_id; + + old_nid = old->node_node_id; + + if (lhs && old_nid->nid_node==NULL) + new_node_id=copy_node_id (old_nid); + else + new_node_id=old_nid->nid_forward_node_id; + + if (new_node_id==NULL) + error_in_function ("copy_node"); + + new->node_node_id=new_node_id; + + return new; + } +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + else if (old->node_kind==IfNode){ + struct if_node_contents *new_then_else_info,*old_then_else_info; + ArgS *previous_arg,*new_arg,*old_arg; + + DetermineNodeState (new); + + new_then_else_info = CompAllocType (IfNodeContentsS); + + old_then_else_info = old->node_contents.contents_if; + new->node_contents.contents_if = new_then_else_info; + + new_then_else_info->if_then_rules = NULL; + new_then_else_info->if_else_rules = NULL; + + old_arg=old->node_arguments; + + new_arg = CompAllocType (ArgS); + new_arg->arg_node = copy_node (old_arg->arg_node,lhs); + new_arg->arg_state = LazyState; + new->node_arguments = new_arg; + previous_arg = new_arg; + + old_arg=old_arg->arg_next; + + new_then_else_info->if_then_node_defs=copy_rhs_node_ids_of_node_defs (old_then_else_info->if_then_node_defs,NULL); + + new_arg = CompAllocType (ArgS); + new_arg->arg_state = LazyState; + new_arg->arg_node = copy_node (old_arg->arg_node,lhs); + previous_arg->arg_next = new_arg; + previous_arg = new_arg; + + copy_nodes_of_node_defs (new_then_else_info->if_then_node_defs,False); + new_then_else_info->if_then_strict_node_ids=copy_strict_node_ids (old_then_else_info->if_then_strict_node_ids); + + new_then_else_info->if_else_node_defs=copy_rhs_node_ids_of_node_defs (old_then_else_info->if_else_node_defs,NULL); + + old_arg=old_arg->arg_next; + + new_arg = CompAllocType (ArgS); + new_arg->arg_state = LazyState; + new_arg->arg_node = copy_node (old_arg->arg_node,lhs); + previous_arg->arg_next = new_arg; + new_arg->arg_next=NULL; + + copy_nodes_of_node_defs (new_then_else_info->if_else_node_defs,False); + new_then_else_info->if_else_strict_node_ids=copy_strict_node_ids (old_then_else_info->if_else_strict_node_ids); + + new_then_else_info->if_local_scope=old_then_else_info->if_local_scope; + + return new; + } +#endif + else if (!lhs) + DetermineNodeState (new); + + if (old->node_arguments!=NULL){ + Args *next,old_arg; + + next = &new->node_arguments; + for_l (old_arg,old->node_arguments,arg_next){ + Args new_arg; + + new_arg = CompAllocType (ArgS); + new_arg->arg_node = copy_node (old_arg->arg_node,lhs); + new_arg->arg_state = LazyState; + + *next = new_arg; + next = &new_arg->arg_next; + } + *next = NULL; + } + + return new; +} + +static void copy_alts (RuleAltP old_alts,RuleAlts *next_p,Symbol new_symbol) +{ + RuleAltP old; + + for_l (old,old_alts,alt_next){ + RuleAltP new; + + new = CompAllocType (RuleAltS); + + new->alt_lhs_defs=copy_lhs_node_ids_of_node_defs (old->alt_lhs_defs); + new->alt_lhs_root = copy_node (old->alt_lhs_root, True); + new->alt_lhs_root->node_symbol=new_symbol; + copy_nodes_of_node_defs (new->alt_lhs_defs,True); + + new->alt_rhs_defs=copy_rhs_node_ids_of_node_defs (old->alt_rhs_defs,NULL); +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + new->alt_rhs_root = copy_root_node (old->alt_rhs_root); +#else + new->alt_rhs_root = copy_node (old->alt_rhs_root, False); +#endif + copy_nodes_of_node_defs (new->alt_rhs_defs,False); + new->alt_strict_node_ids=copy_strict_node_ids (old->alt_strict_node_ids); + + new->alt_line = old->alt_line; + new->alt_kind = old->alt_kind; + + *next_p = new; + next_p = &new->alt_next; + } + *next_p = NULL; +} + +void copy_rhs_node_defs_and_root (RuleAltP old_alt_p,NodeP *new_root_node_h,NodeDefP *node_defs_p) +{ + NodeDefP new_node_defs,*end_node_defs_h; + + new_node_defs=copy_rhs_node_ids_of_node_defs (old_alt_p->alt_rhs_defs,&end_node_defs_h); + *new_root_node_h = copy_node (old_alt_p->alt_rhs_root,False); + copy_nodes_of_node_defs (new_node_defs,False); + + if (end_node_defs_h!=NULL){ + *end_node_defs_h=*node_defs_p; + *node_defs_p=new_node_defs; + } +} + +void copy_imp_rule_nodes (ImpRuleP old_rule_p,ImpRuleP new_rule_p) +{ + copy_alts (old_rule_p->rule_alts,&new_rule_p->rule_alts,new_rule_p->rule_type->type_alt_lhs->type_node_symbol); + new_rule_p->rule_line = old_rule_p->rule_line; + new_rule_p->rule_root = new_rule_p->rule_alts->alt_lhs_root; + new_rule_p->rule_mark = old_rule_p->rule_mark & (RULE_CAF_MASK | RULE_INTERNAL_FUNCTION_MASK | RULE_LAMBDA_FUNCTION_MASK); +} + +static ImpRules new_strict_result_rules; + +int optimise_tuple_result_function (Node node,StateS demanded_state) +{ + Symbol symbol; + TypeNode result_type; + Symbol new_function_symbol; + SymbDef sdef,new_sdef,last_version; + ImpRuleP new_rule_p; + + symbol=node->node_symbol; + sdef=symbol->symb_def; + + if (sdef->sdef_kind!=IMPRULE || sdef->sdef_over_arity!=0 || node->node_arity!=sdef->sdef_arity) + return 0; + + result_type=sdef->sdef_rule->rule_type->type_alt_rhs; + if (! tuple_state_has_more_strictness (&demanded_state,result_type,&sdef->sdef_rule->rule_state_p[-1])) + return 0; + + if (sdef->sdef_mark & SDEF_HAS_IMP_RULE_VERSIONS_MASK){ + while (sdef->sdef_mark & SDEF_NEXT_IMP_RULE_VERSION_MASK) + sdef=sdef->sdef_next_version; + last_version=sdef; + sdef=sdef->sdef_next_version; + } else + last_version=sdef; + + if (sdef->sdef_mark & SDEF_HAS_IMP_RULE_VERSIONS_MASK){ + SymbDef version; + int n_versions; + + version=sdef; + n_versions=0; + + do { + version=version->sdef_next_version; + ++n_versions; + + if (type_and_strictness_in_state_equals_type (result_type,&demanded_state,version->sdef_rule->rule_type->type_alt_rhs)){ + if (symbol!=version->sdef_rule->rule_type->type_alt_lhs->type_node_symbol){ + node->node_symbol=version->sdef_rule->rule_type->type_alt_lhs->type_node_symbol; + function_changed=1; + + return 1; + } + return 0; + } + } while (version->sdef_mark & SDEF_NEXT_IMP_RULE_VERSION_MASK); + + if (n_versions>=MAX_N_VERSIONS) + return 0; + } + + new_function_symbol = copy_imp_rule_and_type (sdef); + new_sdef=new_function_symbol->symb_def; + new_rule_p=new_sdef->sdef_rule; + + new_rule_p->rule_next_changed_function=sdef->sdef_rule; + + new_rule_p->rule_next=new_strict_result_rules; + new_strict_result_rules=new_rule_p; + + add_strictness_in_state_to_type (&demanded_state,new_rule_p->rule_type->type_alt_rhs); + +#if 0 + /* compute lhs->type_node_state for statesgen, recomputed after strictness analysis */ + + if (new_rule_type->type_alt_rhs->type_node_is_var || + new_rule_type->type_alt_rhs->type_node_symbol->symb_kind==apply_symb) + { + new_rule_type->type_alt_lhs->type_node_state = StrictState; + new_rule_type->type_alt_lhs->type_node_state.state_kind = StrictRedirection; + } else + ConvertTypeToState (new_rule_type->type_alt_rhs,&new_rule_type->type_alt_lhs->type_node_state,StrictOnA); +#else + new_rule_p->rule_state_p=NULL; +#endif + node->node_symbol=new_function_symbol; + function_changed=1; + + last_version->sdef_mark |= SDEF_NEXT_IMP_RULE_VERSION_MASK | SDEF_HAS_IMP_RULE_VERSIONS_MASK; + last_version->sdef_next_version=new_sdef; + new_sdef->sdef_next_version=sdef; + new_sdef->sdef_mark |= SDEF_HAS_IMP_RULE_VERSIONS_MASK; + + return 1; +} + +#if 0 +#include "dbprint.h" +#endif + +void generate_states (ImpRuleS *rules,int do_strictness_analysis) +{ + ImpRuleS *rule,*changed_functions,**last_changed_function_l,**rule_p; + + new_strict_result_rules=NULL; + changed_functions=NULL; + last_changed_function_l=&changed_functions; + + for (rule_p=&rules; (rule=*rule_p)!=NULL; rule_p=&rule->rule_next){ + function_changed=0; + + GenerateStatesForRule (rule); + + if (function_changed){ + *last_changed_function_l=rule; + last_changed_function_l=&rule->rule_next_changed_function; + *last_changed_function_l=NULL; + } + } + + do { + ImpRuleS *rule; + + while (new_strict_result_rules!=NULL){ + for_l (rule,new_strict_result_rules,rule_next){ + copy_imp_rule_nodes (rule->rule_next_changed_function,rule); +#if 0 + PrintRuleAlt (rule->rule_alts,4,StdOut); +#endif + } + + if (do_strictness_analysis) + if (StrictnessAnalysisConvertRules (new_strict_result_rules)){ + for_l (rule,new_strict_result_rules,rule_next) + StrictnessAnalysisForRule (rule->rule_root->node_symbol->symb_def); + + free_unused_sa_blocks(); + } else + do_strictness_analysis=0; + + for_l (rule,new_strict_result_rules,rule_next){ +#if 0 + rule->rule_type->type_alt_lhs->type_node_state = LazyState; +#endif + ExamineTypesAndLhsOfSymbolDefinition (rule->rule_root->node_symbol->symb_def); + } + + rule=new_strict_result_rules; + new_strict_result_rules=NULL; + + *rule_p=rule; + + while (rule!=NULL){ + SymbDef sdef; + + sdef=rule->rule_root->node_symbol->symb_def; + + function_changed=0; + + GenerateStatesForRule (rule); + + if (function_changed){ + *last_changed_function_l=rule; + last_changed_function_l=&rule->rule_next_changed_function; + *last_changed_function_l=NULL; + } + + rule_p=&rule->rule_next; + rule=*rule_p; + } + } + + while (new_strict_result_rules==NULL && changed_functions!=NULL){ + SymbDef sdef; + + rule=changed_functions; + + sdef=rule->rule_root->node_symbol->symb_def; + + reset_states_and_ref_count_copies (rule); + + ExamineTypesAndLhsOfImpRuleSymbolDefinitionAgain (sdef); + + function_changed=0; + + GenerateStatesForRule (rule); + + if (!function_changed) + changed_functions=changed_functions->rule_next_changed_function; + } + } while (changed_functions!=NULL || new_strict_result_rules!=NULL); +} + +static ImpRules new_rules; +static int next_function_n; + +static Symbol new_rule_symbol (char *function_name) +{ + SymbDef function_sdef; + Symbol function_symbol; + Ident function_ident; + + function_ident=PutStringInHashTable (function_name,SymbolIdTable); + function_sdef=MakeNewSymbolDefinition (CurrentModule,function_ident,0,IMPRULE); + + function_sdef->sdef_number=next_def_number++; + function_sdef->sdef_isused=True; + + function_sdef->sdef_mark |= SDEF_OPTIMISED_FUNCTION_MASK; + function_sdef->sdef_returnsnode=True; + function_sdef->sdef_calledwithrootnode=True; + + function_symbol=NewSymbol (definition); + function_symbol->symb_def=function_sdef; + + return function_symbol; +} + +#ifdef MOVE_APPLY_NODES_IN_LAZY_CONTEXT_TO_NEW_FUNCTION +static StateS apply_symb_function_states[3]; +static StateP apply_symb_function_state_p=NULL; + +static void init_apply_symb_function_state_p() +{ + SetUnaryState (&apply_symb_function_states[0],StrictRedirection,UnknownObj); + SetUnaryState (&apply_symb_function_states[1],StrictOnA,UnknownObj); + SetUnaryState (&apply_symb_function_states[2],OnA,UnknownObj); + apply_symb_function_state_p=&apply_symb_function_states[1]; +} +#endif + +#define cTypeDelimiter ';' + +static int compute_length_before_type_delimiter (char *fname) +{ + char *p; + unsigned int c; + + p=fname; + + --p; + do { + c=*++p; + } while (c!=cTypeDelimiter && c!='\0'); + + return p-fname; +} + +static char *append_n_chars (char *dest,const char *src,int length) +{ + while (length>0){ + *dest++ = *src++; + --length; + } + + return dest; +} + +#define allocate_function_state(arity) (((StateP)(CompAlloc (sizeof(StateS)*((arity)+1))))+1) + +#define MAX_N_FUNCTION_ARGUMENTS 32 + +static int add_n_new_arguments_for_local_function (ArgP arg_p,int n_arguments) +{ + for ( ; arg_p!=NULL; arg_p=arg_p->arg_next){ + NodeP arg_node_p; + + arg_node_p=arg_p->arg_node; + + if (arg_node_p->node_kind==NodeIdNode){ + if (arg_node_p->node_node_id->nid_mark & NID_LIFTED_BY_OPTIMISE){ + continue; + } else { + arg_node_p->node_node_id->nid_mark |= NID_LIFTED_BY_OPTIMISE; + arg_node_p->node_node_id->nid_forward_node_id=NULL; + + n_arguments=add_n_new_arguments_for_local_function (arg_p->arg_next,n_arguments); + + if (n_arguments>MAX_N_FUNCTION_ARGUMENTS) + arg_node_p->node_node_id->nid_mark &= ~NID_LIFTED_BY_OPTIMISE; + + return n_arguments; + } + } else if (arg_node_p->node_kind==NormalNode){ + switch (arg_node_p->node_symbol->symb_kind){ + case int_denot: + case bool_denot: + case char_denot: + case string_denot: + case real_denot: + continue; + } + } + + ++n_arguments; + } + + return n_arguments; +} + +static char *create_arguments_for_local_function (NodeP node_p,ArgS ***arg_h,ArgS ***lhs_arg_h,ArgS **rhs_arg_p,StateP arg_state_p,int *arity_p,char *function_name_p,char *end_function_name,int n_arguments) +{ + NodeIdP arg_node_id; + StateP call_state_p; + ArgP arg; + + if (function_name_p!=NULL && node_p->node_symbol->symb_kind==definition){ + int length_before_type_delimiter; + char *f_name; + + f_name=node_p->node_symbol->symb_def->sdef_ident->ident_name; + length_before_type_delimiter=compute_length_before_type_delimiter (f_name); + + if (function_name_p+2+length_before_type_delimiter < end_function_name){ + *function_name_p++='.'; + function_name_p=append_n_chars (function_name_p,f_name,length_before_type_delimiter); + } else + end_function_name=function_name_p; + } + + for_l (arg,node_p->node_arguments,arg_next){ + ArgP lhs_arg,rhs_arg; + NodeP arg_node; + + arg_node=arg->arg_node; + + if (arg_node->node_kind==NormalNode) + switch (arg_node->node_symbol->symb_kind){ + case int_denot: + case bool_denot: + case char_denot: + case string_denot: + case real_denot: + { + NodeP function_node; + ArgP new_arg; + + function_node=NewNode (arg_node->node_symbol,NULL,arg_node->node_arity); + function_node->node_state=LazyState; + function_node->node_number=0; + + new_arg=NewArgument (function_node); + new_arg->arg_state=LazyState; + *rhs_arg_p=new_arg; + rhs_arg_p=&new_arg->arg_next; + + ++arg_state_p; + continue; + } + case definition: + { + if ((arg_state_p->state_type==SimpleState && arg_state_p->state_kind==OnB) +#ifdef MOVE_TUPLE_RECORD_AND_ARRAY_RESULT_FUNCTION_ARGUMENT_IN_LAZY_CONTEXT_TO_NEW_FUNCTION + || arg_state_p->state_type==TupleState || arg_state_p->state_type==RecordState || arg_state_p->state_type==ArrayState +#endif + ){ + SymbDef sdef; + + sdef=arg_node->node_symbol->symb_def; + + if (arg_node->node_arity==(sdef->sdef_kind==RECORDTYPE ? sdef->sdef_cons_arity : sdef->sdef_arity)){ + Bool is_rule; + StateP function_state_p; + + switch (sdef->sdef_kind){ + case IMPRULE: + is_rule=True; + function_state_p=sdef->sdef_rule->rule_state_p; + break; + case DEFRULE: + case SYSRULE: + is_rule=True; + function_state_p=sdef->sdef_rule_type->rule_type_state_p; + break; + /* added 5-8-1999 */ + case RECORDTYPE: + if (sdef->sdef_strict_constructor){ + is_rule=True; + function_state_p=sdef->sdef_record_state.state_record_arguments; + } else + is_rule=False; + break; + /* */ + default: + is_rule=False; + } + + if (is_rule){ + Node function_node; + ArgP new_arg; + int new_n_arguments; + + new_n_arguments=add_n_new_arguments_for_local_function (arg_node->node_arguments,n_arguments-1); + + if (new_n_arguments>MAX_N_FUNCTION_ARGUMENTS) + break; + + n_arguments=new_n_arguments; + + function_node=NewNode (arg_node->node_symbol,NULL,arg_node->node_arity); + function_node->node_state=LazyState; + function_node->node_number=0; + + new_arg=NewArgument (function_node); + new_arg->arg_state=LazyState; + *rhs_arg_p=new_arg; + rhs_arg_p=&new_arg->arg_next; + + function_name_p = create_arguments_for_local_function (arg_node,arg_h,lhs_arg_h,&function_node->node_arguments, + function_state_p,arity_p,function_name_p,end_function_name,n_arguments); + + ++arg_state_p; + continue; + } + } + } + break; + } +#ifdef UNTUPLE_STRICT_TUPLES + case tuple_symb: + { + if (arg_state_p->state_type==TupleState){ + NodeP tuple_node; + ArgP new_arg; + int new_n_arguments; + + new_n_arguments=add_n_new_arguments_for_local_function (arg_node->node_arguments,n_arguments-1); + + if (new_n_arguments>MAX_N_FUNCTION_ARGUMENTS) + break; + + n_arguments=new_n_arguments; + + tuple_node=NewNode (arg_node->node_symbol,NULL,arg_node->node_arity); + tuple_node->node_state=LazyState; + tuple_node->node_number=0; + + new_arg=NewArgument (tuple_node); + new_arg->arg_state=LazyState; + *rhs_arg_p=new_arg; + rhs_arg_p=&new_arg->arg_next; + + function_name_p = create_arguments_for_local_function (arg_node,arg_h,lhs_arg_h,&tuple_node->node_arguments, + arg_state_p->state_tuple_arguments,arity_p,function_name_p,end_function_name,n_arguments); + + ++arg_state_p; + + continue; + } + break; + } +#endif +#ifdef MOVE_APPLY_NODES_IN_LAZY_CONTEXT_TO_NEW_FUNCTION + case apply_symb: + if (arg_state_p->state_type==SimpleState && (arg_state_p->state_kind==StrictOnA || arg_state_p->state_kind==StrictRedirection)){ + Node function_node; + ArgP new_arg; + int new_n_arguments; + + new_n_arguments=add_n_new_arguments_for_local_function (arg_node->node_arguments,n_arguments-1); + + if (new_n_arguments>MAX_N_FUNCTION_ARGUMENTS) + break; + + n_arguments=new_n_arguments; + + function_node=NewNode (arg_node->node_symbol,NULL,arg_node->node_arity); + function_node->node_state=LazyState; + function_node->node_number=0; + + new_arg=NewArgument (function_node); + new_arg->arg_state=LazyState; + *rhs_arg_p=new_arg; + rhs_arg_p=&new_arg->arg_next; + + if (apply_symb_function_state_p==NULL) + init_apply_symb_function_state_p(); + + function_name_p = create_arguments_for_local_function (arg_node,arg_h,lhs_arg_h,&function_node->node_arguments, + apply_symb_function_state_p,arity_p,function_name_p,end_function_name,n_arguments); + + ++arg_state_p; + continue; + } + break; +#endif +#ifdef THUNK_LIFT_SELECTORS + case select_symb: + { + NodeP tuple_node_p; + NodeDefP node_def_p; + + if (arg_node->node_arguments->arg_node->node_kind==NodeIdNode && + arg_node->node_arguments->arg_node->node_node_id->nid_refcount>0 && + IsLazyState ((tuple_node_p=(node_def_p=arg_node->node_arguments->arg_node->node_node_id->nid_node_def)->def_node)->node_state) && + tuple_node_p->node_kind==NormalNode && + tuple_node_p->node_symbol->symb_kind==definition && + (tuple_node_p->node_symbol->symb_def->sdef_kind==IMPRULE || + tuple_node_p->node_symbol->symb_def->sdef_kind==DEFRULE || + tuple_node_p->node_symbol->symb_def->sdef_kind==SYSRULE) && + tuple_node_p->node_arity==tuple_node_p->node_symbol->symb_def->sdef_arity) + { + Node function_node; + ArgP new_arg; + int new_n_arguments; + + new_n_arguments=add_n_new_arguments_for_local_function (arg_node->node_arguments,n_arguments-1); + + if (new_n_arguments>MAX_N_FUNCTION_ARGUMENTS) + break; + + n_arguments=new_n_arguments; + + function_node=NewNode (arg_node->node_symbol,NULL,arg_node->node_arity); + function_node->node_state=LazyState; + function_node->node_number=1; + + node_def_p->def_mark |= NODE_DEF_SELECT_AND_REMOVE_MASK; + + new_arg=NewArgument (function_node); + new_arg->arg_state=LazyState; + *rhs_arg_p=new_arg; + rhs_arg_p=&new_arg->arg_next; + + function_name_p = create_arguments_for_local_function (arg_node,arg_h,lhs_arg_h,&function_node->node_arguments, + &StrictState,arity_p,function_name_p,end_function_name,n_arguments); + + ++arg_state_p; + continue; + } + break; + } +#endif + } + + if (arg_node->node_kind==NodeIdNode && (arg_node->node_node_id->nid_mark & NID_LIFTED_BY_OPTIMISE) && arg_node->node_node_id->nid_forward_node_id!=NULL){ + arg_node_id=arg_node->node_node_id->nid_forward_node_id; + --arg_node_id->nid_refcount; + --arg_node_id->nid_ref_count_copy__; + } else { + arg_node_id=NewNodeId (NULL); + arg_node_id->nid_refcount=-2; + arg_node_id->nid_ref_count_copy__=-2; + + if (arg_node->node_kind==NodeIdNode){ + NodeIdP node_id; + + node_id=arg_node->node_node_id; + + node_id->nid_forward_node_id_=arg_node_id; + arg_node_id->nid_forward_node_id_=node_id; + node_id->nid_mark |= NID_LIFTED_BY_OPTIMISE; + arg_node_id->nid_mark |= NID_LIFTED_BY_OPTIMISE; + + if (node_id->nid_refcount<0){ + call_state_p=node_id->nid_lhs_state_p; + } else + call_state_p=&node_id->nid_node->node_state; + } else +#ifdef STRICT_STATE_FOR_LAZY_TUPLE_CONSTRUCTORS + if (arg_node->node_kind==NormalNode && BETWEEN (tuple_symb,nil_symb,arg_node->node_symbol->symb_kind) + && arg_node->node_state.state_type==SimpleState && arg_node->node_state.state_kind==OnA) + { + call_state_p=&StrictState; + } else +#endif + call_state_p=&arg_node->node_state; + + lhs_arg=NewArgument (NewNodeIdNode (arg_node_id)); + lhs_arg->arg_state=LazyState; + if (!IsLazyState (*call_state_p)){ + if (call_state_p->state_type==SimpleState && call_state_p->state_kind==OnB) + lhs_arg->arg_state=*call_state_p; + else if (call_state_p->state_type==ArrayState) + lhs_arg->arg_state=*call_state_p; + else + lhs_arg->arg_state.state_kind=StrictOnA; + } + + arg_node_id->nid_lhs_state_p_=&lhs_arg->arg_state; + + ++*arity_p; + + **lhs_arg_h=lhs_arg; + *lhs_arg_h=&lhs_arg->arg_next; + + **arg_h=arg; + *arg_h=&arg->arg_next; + } + + ++arg_state_p; + + rhs_arg=NewArgument (NewNodeIdNode (arg_node_id)); + rhs_arg->arg_state=LazyState; + *rhs_arg_p=rhs_arg; + rhs_arg_p=&rhs_arg->arg_next; + } + + *rhs_arg_p=NULL; + + return function_name_p; +} + +static void create_new_local_function (Node node,StateP function_state_p) +{ + static char function_name[64]; + Symbol function_symbol; + int n_arguments,function_arity; + ImpRuleS *imp_rule; + ArgS **lhs_arg_p,**arg_p; + Node lhs_root,rhs_root; + char *function_name_p,*end_function_name; + + n_arguments = add_n_new_arguments_for_local_function (node->node_arguments,0); + + if (n_arguments>MAX_N_FUNCTION_ARGUMENTS) + return; + + sprintf (function_name,"_f%d",next_function_n); + ++next_function_n; + + if (DoTimeProfiling || DoProfiling){ + char *f_name; + int length_before_type_delimiter; + + end_function_name=function_name+sizeof (function_name); + function_name_p=&function_name[strlen (function_name)]; + + f_name=CurrentSymbol->symb_def->sdef_ident->ident_name; + length_before_type_delimiter=compute_length_before_type_delimiter (f_name); + + if (function_name_p+2+length_before_type_delimiter < end_function_name){ + *function_name_p++='.'; + function_name_p=append_n_chars (function_name_p,f_name,length_before_type_delimiter); + } else + end_function_name=function_name_p; + } else { + function_name_p=NULL; + end_function_name=NULL; + } + + lhs_root=NewNode (NULL,NULL,0); +/* lhs_root->node_state=LazyState; */ + lhs_root->node_state=StrictState; + + rhs_root=NewNode (node->node_symbol,NULL,node->node_arity); + rhs_root->node_state=LazyState; + rhs_root->node_number=0; + + function_arity=0; + + lhs_arg_p=&lhs_root->node_arguments; + arg_p=&node->node_arguments; + + function_name_p = create_arguments_for_local_function (node,&arg_p,&lhs_arg_p,&rhs_root->node_arguments,function_state_p, + &function_arity,function_name_p,end_function_name,n_arguments); + + if (function_name_p!=NULL) + *function_name_p='\0'; + + function_symbol=new_rule_symbol (function_name); + lhs_root->node_symbol=function_symbol; + + *lhs_arg_p=NULL; + *arg_p=NULL; + + { + ArgP arg; + + for_l (arg,lhs_root->node_arguments,arg_next){ + NodeIdP lhs_node_id,rhs_node_id; + + lhs_node_id=arg->arg_node->node_node_id; + if (lhs_node_id->nid_mark & NID_LIFTED_BY_OPTIMISE){ + rhs_node_id=lhs_node_id->nid_forward_node_id; + lhs_node_id->nid_mark &= ~NID_LIFTED_BY_OPTIMISE; + rhs_node_id->nid_mark &= ~NID_LIFTED_BY_OPTIMISE; + } + } + } + + lhs_root->node_arity=function_arity; + function_symbol->symb_def->sdef_arity=function_arity; + + node->node_symbol=function_symbol; + node->node_arity=function_arity; + + imp_rule=create_simple_imp_rule (lhs_root,rhs_root,function_symbol->symb_def); + + { + StateP arg_state_p; + ArgP arg_p; + + arg_state_p=allocate_function_state (function_arity); + + imp_rule->rule_state_p=arg_state_p; + + arg_state_p[-1]=StrictState; + + for_l (arg_p,lhs_root->node_arguments,arg_next) + *arg_state_p++ = arg_p->arg_state; + } + + imp_rule->rule_next=new_rules; + new_rules=imp_rule; +} + +static void optimise_normal_node (Node node) +{ + Symbol symbol; + StateP function_state_p; + int arg_n; + + symbol=node->node_symbol; + + if (node->node_state.state_type!=SimpleState || node->node_state.state_kind!=OnA) + return; + + if (symbol->symb_kind!=definition){ +#ifndef STRICT_STATE_FOR_LAZY_TUPLE_CONSTRUCTORS + if (BETWEEN (int_denot,real_denot,symbol->symb_kind) || symbol->symb_kind==string_denot){ +#else + if ((BETWEEN (int_denot,real_denot,symbol->symb_kind) + || symbol->symb_kind==string_denot + || BETWEEN (tuple_symb,nil_symb,symbol->symb_kind) + ) && node->node_state.state_kind==OnA){ +#endif + node->node_state.state_kind=StrictOnA; + return; + } +#ifdef MOVE_APPLY_NODES_IN_LAZY_CONTEXT_TO_NEW_FUNCTION + else if (symbol->symb_kind==apply_symb){ + if (apply_symb_function_state_p==NULL) + init_apply_symb_function_state_p(); + function_state_p=apply_symb_function_state_p; + } else +#endif + return; + } +#ifdef MOVE_APPLY_NODES_IN_LAZY_CONTEXT_TO_NEW_FUNCTION + else +#endif + { + SymbDef sdef; + + sdef=symbol->symb_def; + + if (node->node_arity!=sdef->sdef_arity) + return; + + switch (sdef->sdef_kind){ + case IMPRULE: +# if OPTIMIZE_LAZY_TUPLE_RECURSION + if (sdef->sdef_rule->rule_mark & RULE_CALL_VIA_LAZY_SELECTIONS_ONLY) + return; +# endif + + function_state_p=sdef->sdef_rule->rule_state_p; + break; + case DEFRULE: + case SYSRULE: + function_state_p=sdef->sdef_rule_type->rule_type_state_p; + break; + /* added 5-8-1999 */ + case CONSTRUCTOR: + if (sdef->sdef_strict_constructor){ + function_state_p=sdef->sdef_constructor->cl_state_p; + break; + } else + return; + /* */ + default: + return; + } + } + + { + ArgP arg; + + arg=node->node_arguments; + + for (arg_n=0; arg_n<node->node_arity; ++arg_n){ + Node arg_node; + + arg_node=arg->arg_node; + if (arg_node->node_kind==NormalNode){ +#ifdef THUNK_LIFT_SELECTORS + NodeP tuple_node_p; +#endif + if (arg_node->node_symbol->symb_kind==definition){ + if ((function_state_p[arg_n].state_type==SimpleState && function_state_p[arg_n].state_kind==OnB) +#ifdef MOVE_TUPLE_RECORD_AND_ARRAY_RESULT_FUNCTION_ARGUMENT_IN_LAZY_CONTEXT_TO_NEW_FUNCTION + || function_state_p[arg_n].state_type==TupleState || function_state_p[arg_n].state_type==RecordState || function_state_p[arg_n].state_type==ArrayState +#endif + ){ + SymbDef sdef; + + unsigned kind; + + sdef=arg_node->node_symbol->symb_def; + kind=sdef->sdef_kind; + + if (arg_node->node_arity==(kind==RECORDTYPE ? sdef->sdef_cons_arity : sdef->sdef_arity)){ + if (kind==IMPRULE || kind==DEFRULE || kind==SYSRULE + /* added 5-8-1999 */ + || (kind==RECORDTYPE && sdef->sdef_strict_constructor) + /* */ + ) + break; + } + } + } +#ifdef UNTUPLE_STRICT_TUPLES + else if (arg_node->node_symbol->symb_kind==tuple_symb && function_state_p[arg_n].state_type==TupleState) + break; +#endif +#ifdef MOVE_APPLY_NODES_IN_LAZY_CONTEXT_TO_NEW_FUNCTION + else if (arg_node->node_symbol->symb_kind==apply_symb && function_state_p[arg_n].state_type==SimpleState && + (function_state_p[arg_n].state_kind==StrictOnA || function_state_p[arg_n].state_kind==StrictRedirection)) + break; +#endif +#ifdef THUNK_LIFT_SELECTORS + else if (arg_node->node_symbol->symb_kind==select_symb && + arg_node->node_arguments->arg_node->node_kind==NodeIdNode && + arg_node->node_arguments->arg_node->node_node_id->nid_refcount>0 && + IsLazyState ((tuple_node_p=arg_node->node_arguments->arg_node->node_node_id->nid_node_def->def_node)->node_state) && + tuple_node_p->node_kind==NormalNode && tuple_node_p->node_symbol->symb_kind==definition && + (tuple_node_p->node_symbol->symb_def->sdef_kind==IMPRULE || + tuple_node_p->node_symbol->symb_def->sdef_kind==DEFRULE || + tuple_node_p->node_symbol->symb_def->sdef_kind==SYSRULE) && + tuple_node_p->node_arity==tuple_node_p->node_symbol->symb_def->sdef_arity) + { + break; + } +#endif + } + + arg=arg->arg_next; + } + + if (arg!=NULL) + create_new_local_function (node,function_state_p); + } +} + +static int ChangeArgumentNodeStatesIfStricter (NodeP node_p,StateP demanded_states) +{ + ArgP offered_args; + StateP demanded_state_p; + + for_la (offered_args,demanded_state_p,node_p->node_arguments,demanded_states,arg_next){ + Node arg_node; + NodeKind node_kind; + + arg_node=offered_args->arg_node; + node_kind=(NodeKind)arg_node->node_kind; + + if (node_kind!=NodeIdNode){ + if (node_kind==NormalNode && + (BETWEEN (int_denot,real_denot,arg_node->node_symbol->symb_kind) || arg_node->node_symbol->symb_kind==string_denot) + ) + ; + else if (demanded_state_p->state_type==RecordState + && arg_node->node_state.state_type==SimpleState && arg_node->node_state.state_kind==StrictOnA + && node_kind==NormalNode && arg_node->node_symbol->symb_kind==definition && arg_node->node_symbol->symb_def->sdef_kind==RECORDTYPE + ) + ; + else + if (!FirstStateIsStricter (arg_node->node_state,*demanded_state_p)) + return 0; + } else { + struct node_id *node_id; + + node_id=arg_node->node_node_id; + if (node_id->nid_refcount<0){ + if (!FirstStateIsStricter (*node_id->nid_lhs_state_p,*demanded_state_p)) + return 0; + } else { + if (node_id->nid_node==NULL) + error_in_function ("ChangeArgumentNodeStatesIfStricter"); + + if (!FirstStateIsStricter (node_id->nid_node->node_state,*demanded_state_p)) + return 0; + } + } + } + + for_la (offered_args,demanded_state_p,node_p->node_arguments,demanded_states,arg_next){ + Node arg_node; + + arg_node=offered_args->arg_node; + if (arg_node->node_kind==NormalNode){ + if (BETWEEN (int_denot,real_denot,arg_node->node_symbol->symb_kind) || arg_node->node_symbol->symb_kind==string_denot) + arg_node->node_state=*demanded_state_p; + else if (demanded_state_p->state_type==RecordState + && arg_node->node_state.state_type==SimpleState && arg_node->node_state.state_kind==StrictOnA + && arg_node->node_symbol->symb_kind==definition && arg_node->node_symbol->symb_def->sdef_kind==RECORDTYPE) + { + arg_node->node_state=*demanded_state_p; + } + } + + offered_args->arg_state=*demanded_state_p; + } + + return 1; +} + +#ifdef REUSE_UNIQUE_NODES + +static NodeP replace_node_by_unique_fill_node (NodeP node,NodeP push_node,int node_size) +{ + NodeP node_copy; + ArgP arg_p; + + node_copy=CompAllocType (NodeS); + *node_copy=*node; + + arg_p=CompAllocType (ArgS); + arg_p->arg_node=node_copy; + arg_p->arg_next=NULL; + arg_p->arg_occurrence=-1; + + node->node_kind=FillUniqueNode; + node->node_node=push_node; + node->node_arguments=arg_p; + node->node_arity=1; + + push_node->node_line=node_size; + + --push_node->node_arguments->arg_node->node_node_id->nid_refcount; + push_node->node_number=1; + + return node_copy; +} + +static Bool insert_unique_fill_node (NodeP node,FreeUniqueNodeIdsP *f_node_ids,int node_a_size,int node_b_size) +{ + FreeUniqueNodeIdsP f_node_id; + NodeP push_node,node_copy; + ArgP node_copy_arg_p; + unsigned long argument_overwrite_bits; + NodeIdListElementP node_id_list; + unsigned int n,arity; + int node_size; + + node_size=node_a_size+node_b_size; + + arity=node->node_arity; + + f_node_id=*f_node_ids; + + if (f_node_id->fnid_node_size>=node_size) + *f_node_ids=f_node_id->fnid_next; + else { + FreeUniqueNodeIdsP prev_f_node_id; + + do { + prev_f_node_id=f_node_id; + f_node_id=f_node_id->fnid_next; + + if (f_node_id==NULL) + return False; + + } while (f_node_id->fnid_node_size<node_size); + + prev_f_node_id->fnid_next=f_node_id->fnid_next; + } + + push_node=f_node_id->fnid_push_node; + + node_copy=replace_node_by_unique_fill_node (node,push_node,f_node_id->fnid_node_size); + + { + int a_size1,b_size1,a_size2,b_size2; + int total_a_size2,total_b_size2; + + total_a_size2=0; + total_b_size2=0; + + for_l (node_id_list,push_node->node_node_ids,nidl_next){ +# ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + AddSizeOfState (*node_id_list->nidl_node_id->nid_lhs_state_p,&total_a_size2,&total_b_size2); +# else + AddSizeOfState (node_id_list->nidl_node_id->nid_state,&total_a_size2,&total_b_size2); +# endif + } + + argument_overwrite_bits=0; + node_copy_arg_p=node_copy->node_arguments; + node_id_list=push_node->node_node_ids; + + a_size1=0; + b_size1=0; + a_size2=0; + b_size2=0; + + for (n=0; n<arity; ++n){ + if (node_id_list!=NULL){ + NodeIdP node_id_p; + StateP arg_node_id_state_p; + + node_id_p=node_id_list->nidl_node_id; + + if (node_copy_arg_p->arg_node->node_kind==NodeIdNode && node_copy_arg_p->arg_node->node_node_id==node_id_list->nidl_node_id){ + int e_a_size1,e_b_size1,e_a_size2,e_b_size2; + + DetermineSizeOfState (node_copy_arg_p->arg_state,&e_a_size1,&e_b_size1); + +# ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + DetermineSizeOfState (*node_id_p->nid_lhs_state_p,&e_a_size2,&e_b_size2); +# else + DetermineSizeOfState (node_id_p->nid_state,&e_a_size2,&e_b_size2); +# endif + if (e_a_size1!=e_a_size2 || e_b_size1!=e_b_size2 || + ((e_a_size1 | e_a_size2)!=0 && a_size1!=a_size2) || + ((e_b_size1 | e_b_size2)!=0 && b_size1+node_a_size!=b_size2+total_a_size2)) + { + argument_overwrite_bits|=1<<n; + } else { + ++node_id_p->nid_refcount; + node_id_p->nid_mark |= NID_EXTRA_REFCOUNT_MASK; + } + } else + argument_overwrite_bits|=1<<n; + +# ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + arg_node_id_state_p=node_id_p->nid_lhs_state_p; +# else + arg_node_id_state_p=&node_id_p->nid_state; +# endif + AddSizeOfState (*arg_node_id_state_p,&a_size2,&b_size2); + + node_id_list=node_id_list->nidl_next; + } else + argument_overwrite_bits|=1<<n; + + AddSizeOfState (node_copy_arg_p->arg_state,&a_size1,&b_size1); + + node_copy_arg_p=node_copy_arg_p->arg_next; + } + } + + node->node_arguments->arg_occurrence=argument_overwrite_bits; + + return True; +} + +static Bool try_insert_constructor_update_node (NodeP node,FreeUniqueNodeIdsP *f_node_ids) +{ + if (node->node_state.state_type==SimpleState && node->node_state.state_kind!=SemiStrict){ + switch (node->node_symbol->symb_kind){ + case definition: + { + SymbDef sdef; + + sdef=node->node_symbol->symb_def; + switch (sdef->sdef_kind){ + case CONSTRUCTOR: + if (! (node->node_arity>0 && sdef->sdef_arity==node->node_arity)) + return False; + /* else */ + case RECORDTYPE: + if (!sdef->sdef_strict_constructor) + return insert_unique_fill_node (node,f_node_ids,node->node_arity,0); + else if (!IsLazyStateKind (node->node_state.state_kind)){ + 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; + } + + break; + } + case cons_symb: + return insert_unique_fill_node (node,f_node_ids,2,0); + case tuple_symb: + return insert_unique_fill_node (node,f_node_ids,node->node_arity,0); + } + } + + return False; +} + +static NodeP try_insert_function_update_node (NodeP node,FreeUniqueNodeIdsS **f_node_ids_l) +{ + if (!(node->node_state.state_type==SimpleState && node->node_state.state_kind==SemiStrict) && + (IsLazyState (node->node_state) ? node->node_arity<=2 : ExpectsResultNode (node->node_state)) && + node->node_symbol->symb_kind==definition) + { + SymbDef sdef; + + sdef=node->node_symbol->symb_def; + + if (node->node_arity==sdef->sdef_arity) + switch (sdef->sdef_kind){ + case IMPRULE: + case DEFRULE: + case SYSRULE: + { + FreeUniqueNodeIdsP f_node_id; + NodeP node_copy; + + f_node_id=*f_node_ids_l; + + if (f_node_id->fnid_node_size>=2) + *f_node_ids_l=f_node_id->fnid_next; + else { + FreeUniqueNodeIdsP prev_f_node_id; + + do { + prev_f_node_id=f_node_id; + f_node_id=f_node_id->fnid_next; + + if (f_node_id==NULL) + return node; + + } while (f_node_id->fnid_node_size<2); + + prev_f_node_id->fnid_next=f_node_id->fnid_next; + } + + node_copy=replace_node_by_unique_fill_node (node,f_node_id->fnid_push_node,f_node_id->fnid_node_size); + + return node_copy; + } + } + } + return node; +} + +#endif + +static void optimise_strict_constructor_in_lazy_context (NodeP node,FreeUniqueNodeIdsS **f_node_ids_l) +{ + Symbol symbol; + + symbol = node->node_symbol; + if (symbol->symb_kind==definition){ + SymbDef sdef; + + sdef=symbol->symb_def; + if (sdef->sdef_kind==CONSTRUCTOR){ + if (node->node_state.state_type==SimpleState && node->node_state.state_kind==OnA && sdef->sdef_arity==node->node_arity){ + if (!sdef->sdef_strict_constructor){ + node->node_state.state_kind=StrictOnA; + } else { + if (ChangeArgumentNodeStatesIfStricter (node,sdef->sdef_constructor->cl_state_p)){ + node->node_state.state_kind=StrictOnA; +#ifdef REUSE_UNIQUE_NODES + if (*f_node_ids_l!=NULL) + try_insert_constructor_update_node (node,f_node_ids_l); +#endif + } + } + } + } else if (sdef->sdef_kind==RECORDTYPE){ + if (node->node_state.state_type==SimpleState && node->node_state.state_kind==OnA){ + if (!sdef->sdef_strict_constructor){ + node->node_state.state_kind=StrictOnA; + } else { + if (ChangeArgumentNodeStatesIfStricter (node,sdef->sdef_record_state.state_record_arguments)){ + node->node_state.state_kind=StrictOnA; +#ifdef REUSE_UNIQUE_NODES + if (*f_node_ids_l!=NULL) + try_insert_constructor_update_node (node,f_node_ids_l); +#endif + } + } + } + } + } + else if (symbol->symb_kind==select_symb && node->node_arguments->arg_node->node_kind==NodeIdNode){ + NodeIdP node_id; + + node_id=node->node_arguments->arg_node->node_node_id; + if (node_id->nid_refcount>0){ + NodeP tuple_node; + + tuple_node=node_id->nid_node_def->def_node; + if (tuple_node->node_kind==TupleSelectorsNode){ + ArgP new_arg; + + new_arg=NewArgument (node); + new_arg->arg_next=tuple_node->node_arguments; + tuple_node->node_arguments=new_arg; + ++tuple_node->node_arity; + } else { + if (tuple_node->node_state.state_type==TupleState){ + if (! (tuple_node->node_kind==NodeIdNode && tuple_node->node_arguments->arg_state.state_type!=TupleState)){ + Node tuple_selectors_node; + + tuple_selectors_node=NewNodeByKind (TupleSelectorsNode,NULL,NewArgument (node),1); + tuple_selectors_node->node_state=tuple_node->node_state; + tuple_selectors_node->node_node=tuple_node; + tuple_selectors_node->node_number=0; + node_id->nid_node_def->def_node=tuple_selectors_node; + } + } else if (tuple_node->node_kind==NormalNode && tuple_node->node_symbol->symb_kind==select_symb){ + NodeP select2_node_p,tuple_node2_p; + NodeIdP node_id_p; + + select2_node_p=tuple_node->node_arguments->arg_node; + if (select2_node_p->node_kind==NodeIdNode){ + node_id_p=select2_node_p->node_node_id; + if (node_id_p->nid_refcount>0){ + tuple_node2_p=node_id_p->nid_node_def->def_node; + if (tuple_node2_p->node_kind==TupleSelectorsNode && tuple_node2_p->node_state.state_type==TupleState){ + int element_n; + + element_n=tuple_node->node_arity-1; + if (tuple_node2_p->node_state.state_tuple_arguments[element_n].state_type==TupleState){ + NodeP tuple_selectors_node; + + tuple_selectors_node=NewNodeByKind (TupleSelectorsNode,NULL,NewArgument (node),1); + tuple_selectors_node->node_state=tuple_node2_p->node_state.state_tuple_arguments[element_n]; + tuple_selectors_node->node_node=tuple_node; + tuple_selectors_node->node_number=1; + node_id->nid_node_def->def_node=tuple_selectors_node; + } + } + } + } + } + } + } + } +} + +#if OPTIMIZE_LAZY_TUPLE_RECURSION +static unsigned int current_rule_mark; +#endif + +static FreeUniqueNodeIdsP free_unique_node_id_list; + +static FreeUniqueNodeIdsP copy_free_unique_node_ids (FreeUniqueNodeIdsP f_node_ids) +{ + FreeUniqueNodeIdsP f_node_id,new_f_node_ids,*new_f_node_ids_l; + + new_f_node_ids_l=&new_f_node_ids; + + for_l (f_node_id,f_node_ids,fnid_next){ + FreeUniqueNodeIdsP next_f_node_id; + + if (free_unique_node_id_list!=NULL){ + next_f_node_id=free_unique_node_id_list; + free_unique_node_id_list=next_f_node_id->fnid_next; + } else + next_f_node_id=CompAllocType (FreeUniqueNodeIdsS); + + next_f_node_id->fnid_push_node=f_node_id->fnid_push_node; + next_f_node_id->fnid_node_size=f_node_id->fnid_node_size; + + *new_f_node_ids_l=next_f_node_id; + new_f_node_ids_l=&next_f_node_id->fnid_next; + } + *new_f_node_ids_l=NULL; + + return new_f_node_ids; +} + +static FreeUniqueNodeIdsS *free_free_unique_node_ids (FreeUniqueNodeIdsS *f_node_id) +{ + while (f_node_id!=NULL){ + FreeUniqueNodeIdsP next_f_node_id; + + next_f_node_id=f_node_id->fnid_next; + + f_node_id->fnid_next=free_unique_node_id_list; + free_unique_node_id_list=f_node_id; + + f_node_id=next_f_node_id; + } + + return f_node_id; +} + +static void optimise_then_or_else (NodeP node,NodeDefP node_defs,FreeUniqueNodeIdsP f_node_ids,int local_scope); + +static void optimise_then_and_else (NodeP if_node,FreeUniqueNodeIdsP f_node_ids,int local_scope) +{ + FreeUniqueNodeIdsP then_f_node_ids,else_f_node_ids; + ArgP then_arg; + + then_arg=if_node->node_arguments->arg_next; + +#ifdef REUSE_UNIQUE_NODES + then_f_node_ids=copy_free_unique_node_ids (f_node_ids); +#else + then_f_node_ids=NULL; +#endif + optimise_then_or_else (then_arg->arg_node,if_node->node_then_node_defs,then_f_node_ids,local_scope); + +#ifdef REUSE_UNIQUE_NODES + then_f_node_ids=free_free_unique_node_ids (then_f_node_ids); + else_f_node_ids=copy_free_unique_node_ids (f_node_ids); +#else + else_f_node_ids=NULL; +#endif + optimise_then_or_else (then_arg->arg_next->arg_node,if_node->node_else_node_defs,else_f_node_ids,local_scope); + +#ifdef REUSE_UNIQUE_NODES + else_f_node_ids=free_free_unique_node_ids (else_f_node_ids); +#endif +} + +static FreeUniqueNodeIdsP no_free_unique_node_ids=NULL; + +static void optimise_node_in_then_or_else (NodeP node,FreeUniqueNodeIdsS **f_node_ids_l,int local_scope) +{ + switch (node->node_kind){ + case NodeIdNode: + return; + case NormalNode: + { + ArgP arg; + +#ifdef REUSE_UNIQUE_NODES + if (*f_node_ids_l!=NULL && try_insert_constructor_update_node (node,f_node_ids_l)){ + unsigned int n,arity,argument_overwrite_bits; + NodeP fill_node; + + fill_node=node; + node=fill_node->node_arguments->arg_node; + + argument_overwrite_bits=fill_node->node_arguments->arg_occurrence; + arity=node->node_arity; + + n=0; + for_l (arg,node->node_arguments,arg_next){ + if (argument_overwrite_bits & (1<<n)) + optimise_node_in_then_or_else (arg->arg_node,f_node_ids_l,local_scope); + + ++n; + } + } else { +#endif + optimise_normal_node (node); + + for_l (arg,node->node_arguments,arg_next) + optimise_node_in_then_or_else (arg->arg_node,f_node_ids_l,local_scope); + +#ifdef REUSE_UNIQUE_NODES + if (*f_node_ids_l!=NULL) + node=try_insert_function_update_node (node,f_node_ids_l); + } +#endif + optimise_strict_constructor_in_lazy_context (node,f_node_ids_l); + + return; + } + case SelectorNode: + case MatchNode: + optimise_node_in_then_or_else (node->node_arguments->arg_node,f_node_ids_l,local_scope); + return; + case UpdateNode: + { + ArgP arg; + +#if DESTRUCTIVE_RECORD_UPDATES + arg=node->node_arguments; + if (arg->arg_node->node_kind==NodeIdNode && (arg->arg_node->node_node_id->nid_mark2 & NID_HAS_REFCOUNT_WITHOUT_UPDATES)!=0 + && arg->arg_node->node_node_id->nid_refcount==-2) + ++arg->arg_node->node_node_id->nid_number; +#endif + for_l (arg,node->node_arguments,arg_next) + optimise_node_in_then_or_else (arg->arg_node,f_node_ids_l,local_scope); + + return; + } + case IfNode: + optimise_then_and_else (node,*f_node_ids_l,node->node_if_scope+2); + + optimise_node_in_then_or_else (node->node_arguments->arg_node,&no_free_unique_node_ids,local_scope); + return; + case TupleSelectorsNode: + optimise_node_in_then_or_else (node->node_node,f_node_ids_l,local_scope); + return; + default: + error_in_function ("optimise_node_in_then_or_else"); + return; + } +} + +#if OPTIMIZE_LAZY_TUPLE_RECURSION +unsigned long global_result_and_call_same_select_vector; + +static void compute_same_select_vector (NodeP root_node) +{ + unsigned long same_select_vector; + ArgP tuple_element_p; + int n; + + same_select_vector=0; + + for_li (tuple_element_p,n,root_node->node_arguments,arg_next){ + NodeP node_p; + + node_p=tuple_element_p->arg_node; + + if (node_p->node_symbol->symb_kind==select_symb + && node_p->node_arguments->arg_node->node_kind==NodeIdNode + && n+1==node_p->node_arity + && (node_p->node_arguments->arg_node->node_node_id->nid_mark2 & NID_CALL_VIA_LAZY_SELECTIONS_ONLY) + ) + same_select_vector |= (1<<n); + } + + global_result_and_call_same_select_vector=same_select_vector; +} + +static FreeUniqueNodeIdsP insert_unique_fill_nodes_for_lazy_tuple_recursive_call (NodeP node,FreeUniqueNodeIdsP f_node_ids) +{ + int n,tuple_arity; + + tuple_arity=node->node_symbol->symb_def->sdef_rule->rule_type->type_alt_rhs->type_node_arity; + + for (n=tuple_arity-1; n>=0 && f_node_ids!=NULL; --n){ + if (!(global_result_and_call_same_select_vector & (1<<n))){ + FreeUniqueNodeIdsP f_node_id; + + if (f_node_ids->fnid_node_size>=2){ + f_node_id=f_node_ids; + f_node_ids=f_node_ids->fnid_next; + } else { + FreeUniqueNodeIdsP prev_f_node_id; + + f_node_id=f_node_ids; + do { + prev_f_node_id=f_node_id; + f_node_id=f_node_id->fnid_next; + + if (f_node_id==NULL) + break; + + } while (f_node_id->fnid_node_size<2); + + prev_f_node_id->fnid_next=f_node_id->fnid_next; + } + + replace_node_by_unique_fill_node (node,f_node_id->fnid_push_node,f_node_id->fnid_node_size); + } + } + + return f_node_ids; +} +#endif + +static void optimise_then_or_else (NodeP node,NodeDefP node_defs,FreeUniqueNodeIdsP f_node_ids,int local_scope) +{ + NodeDefP node_def; + +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if ((current_rule_mark & RULE_CALL_VIA_LAZY_SELECTIONS_ONLY) && node->node_kind==NormalNode && node->node_symbol->symb_kind==tuple_symb) + compute_same_select_vector (node); +#endif + + for_l (node_def,node_defs,def_next) + if (node_def->def_node){ +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if (node_def->def_id!=NULL && (node_def->def_id->nid_mark2 & NID_CALL_VIA_LAZY_SELECTIONS_ONLY)){ + ArgP arg; + NodeP node; + + node=node_def->def_node; + + optimise_normal_node (node); + + for_l (arg,node->node_arguments,arg_next) + optimise_node_in_then_or_else (arg->arg_node,&f_node_ids,local_scope); + + optimise_strict_constructor_in_lazy_context (node,&f_node_ids); + + if (f_node_ids!=NULL) + f_node_ids=insert_unique_fill_nodes_for_lazy_tuple_recursive_call (node,f_node_ids); + } else +#endif + optimise_node_in_then_or_else (node_def->def_node,&f_node_ids,local_scope); + } + +#ifdef REUSE_UNIQUE_NODES + if (node->node_kind==NormalNode){ + ArgP arg; + + optimise_normal_node (node); + +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if (node->node_symbol->symb_kind==tuple_symb && (current_rule_mark & RULE_CALL_VIA_LAZY_SELECTIONS_ONLY)){ + for_l (arg,node->node_arguments,arg_next){ + NodeP node; + + node=arg->arg_node; + + if (node->node_kind==NormalNode){ + ArgS *arg; + + optimise_normal_node (node); + + for_l (arg,node->node_arguments,arg_next) + optimise_node_in_then_or_else (arg->arg_node,&f_node_ids,local_scope); + + optimise_strict_constructor_in_lazy_context (node,&no_free_unique_node_ids); + } else + optimise_node_in_then_or_else (arg->arg_node,&f_node_ids,local_scope); + } + } else +#endif + for_l (arg,node->node_arguments,arg_next) + optimise_node_in_then_or_else (arg->arg_node,&f_node_ids,local_scope); + + optimise_strict_constructor_in_lazy_context (node,&no_free_unique_node_ids); + } else +#endif + optimise_node_in_then_or_else (node,&f_node_ids,local_scope); +} + +static void optimise_node (NodeP node,FreeUniqueNodeIdsS **f_node_ids_l) +{ + switch (node->node_kind){ + case NodeIdNode: + return; + case NormalNode: + { + ArgP arg; + +#ifdef REUSE_UNIQUE_NODES + if (*f_node_ids_l!=NULL && try_insert_constructor_update_node (node,f_node_ids_l)){ + unsigned int n,arity,argument_overwrite_bits; + NodeP fill_node; + + fill_node=node; + node=fill_node->node_arguments->arg_node; + + argument_overwrite_bits=fill_node->node_arguments->arg_occurrence; + arity=node->node_arity; + + n=0; + for_l (arg,node->node_arguments,arg_next){ + if (argument_overwrite_bits & (1<<n)) + optimise_node (arg->arg_node,f_node_ids_l); + + ++n; + } + } else { +#endif + optimise_normal_node (node); + + for_l (arg,node->node_arguments,arg_next) + optimise_node (arg->arg_node,f_node_ids_l); + +#ifdef REUSE_UNIQUE_NODES + if (*f_node_ids_l!=NULL) + node=try_insert_function_update_node (node,f_node_ids_l); + } +#endif + optimise_strict_constructor_in_lazy_context (node,f_node_ids_l); + + return; + } + case SelectorNode: + case MatchNode: + optimise_node (node->node_arguments->arg_node,f_node_ids_l); + return; + case UpdateNode: + { + ArgS *arg; + +#if DESTRUCTIVE_RECORD_UPDATES + arg=node->node_arguments; + if (arg->arg_node->node_kind==NodeIdNode && (arg->arg_node->node_node_id->nid_mark2 & NID_HAS_REFCOUNT_WITHOUT_UPDATES)!=0 + && arg->arg_node->node_node_id->nid_refcount==-2) + ++arg->arg_node->node_node_id->nid_number; +#endif + for_l (arg,node->node_arguments,arg_next) + optimise_node (arg->arg_node,f_node_ids_l); + + return; + } + case TupleSelectorsNode: + optimise_node (node->node_node,f_node_ids_l); + return; + default: + error_in_function ("optimise_node"); + } +} + +#ifdef REUSE_UNIQUE_NODES +static FreeUniqueNodeIdsP check_unique_push_node (NodeP node,FreeUniqueNodeIdsP f_node_ids,int switch_node_id_refcount) +{ + NodeIdP node_id_p; + + 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){ +# ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (node_id_p->nid_lhs_state_p->state_type==SimpleState && (node_id_p->nid_lhs_state_p->state_mark & STATE_UNIQUE_MASK)){ +# else + if (node_id_p->nid_state.state_type==SimpleState && (node_id_p->nid_state.state_mark & STATE_UNIQUE_MASK)){ +# endif + int a_size,b_size; + NodeIdListElementP arg_node_id_list; + + a_size=0; + b_size=0; + + for_l (arg_node_id_list,node->node_node_ids,nidl_next){ + NodeIdP arg_node_id; + StateP arg_node_id_state_p; + + arg_node_id=arg_node_id_list->nidl_node_id; +# ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + arg_node_id_state_p=arg_node_id->nid_lhs_state_p; +# else + arg_node_id_state_p=&arg_node_id->nid_state; +# endif + +#if DESTRUCTIVE_RECORD_UPDATES + arg_node_id->nid_mark2|=NID_HAS_REFCOUNT_WITHOUT_UPDATES; + arg_node_id->nid_number=arg_node_id->nid_refcount; +#endif + AddSizeOfState (*arg_node_id_state_p,&a_size,&b_size); + } + + if (a_size+b_size>0){ + FreeUniqueNodeIdsP f_node_id; + + f_node_id=CompAllocType (FreeUniqueNodeIdsS); + f_node_id->fnid_push_node=node; + f_node_id->fnid_node_size=a_size+b_size; + +#if 0 + printf ("Push unique node of size %d\n",a_size+b_size); +#endif + + f_node_id->fnid_next=f_node_ids; + return f_node_id; + } + } +#if DESTRUCTIVE_RECORD_UPDATES + else { + NodeIdListElementP arg_node_id_list; + + for_l (arg_node_id_list,node->node_node_ids,nidl_next){ + NodeIdP node_id; + + node_id=arg_node_id_list->nidl_node_id; + node_id->nid_mark2|=NID_HAS_REFCOUNT_WITHOUT_UPDATES; + node_id->nid_number=node_id->nid_refcount; + } + } +#endif + } else { + NodeIdListElementP arg_node_id_list; + + for_l (arg_node_id_list,node->node_node_ids,nidl_next){ + NodeIdP node_id; + + node_id=arg_node_id_list->nidl_node_id; + node_id->nid_mark |= NID_EXTRA_REFCOUNT_MASK; + } + } + return f_node_ids; +} + +static void optimise_root_node (NodeP node,NodeDefP node_defs,FreeUniqueNodeIdsP f_node_ids) +{ + switch (node->node_kind){ + case SwitchNode: + { + ArgP arg; + int switch_node_id_refcount; + NodeIdP switch_node_id_p; + + if (node_defs!=NULL) + error_in_function ("optimise_root_node"); + + switch_node_id_p=node->node_node_id; + + ++switch_node_id_p->nid_refcount; + switch_node_id_refcount=switch_node_id_p->nid_refcount; + + for_l (arg,node->node_arguments,arg_next){ + Node case_node; + + case_node=arg->arg_node; + if (case_node->node_kind==CaseNode || case_node->node_kind==DefaultNode){ + NodeP case_alt_node_p; + FreeUniqueNodeIdsP case_f_node_ids; + + case_f_node_ids=f_node_ids; + + case_alt_node_p=case_node->node_arguments->arg_node; + + set_local_reference_counts (case_node); + + if (case_alt_node_p->node_kind==PushNode){ +#ifdef REUSE_UNIQUE_NODES + if (DoReuseUniqueNodes){ + if (case_alt_node_p->node_arguments->arg_node->node_node_id!=switch_node_id_p) + error_in_function ("optimise_root_node"); + + case_f_node_ids=check_unique_push_node (case_alt_node_p,case_f_node_ids,switch_node_id_refcount); + } +#endif + case_alt_node_p=case_alt_node_p->node_arguments->arg_next->arg_node; + } + + optimise_root_node (case_alt_node_p,case_node->node_node_defs,case_f_node_ids); + + set_global_reference_counts (case_node); + } else + error_in_function ("optimise_root_node"); + } + + --switch_node_id_p->nid_refcount; + + return; + } + case GuardNode: + optimise_root_node (node->node_arguments->arg_node,node_defs,f_node_ids); + optimise_root_node (node->node_arguments->arg_next->arg_node,node->node_node_defs,f_node_ids); + return; + case IfNode: + optimise_then_and_else (node,f_node_ids,node->node_if_scope+2); + + optimise_root_node (node->node_arguments->arg_node,node_defs,NULL); + + return; + default: + { + NodeDefP def; + +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if ((current_rule_mark & RULE_CALL_VIA_LAZY_SELECTIONS_ONLY) && node->node_kind==NormalNode && node->node_symbol->symb_kind==tuple_symb) + compute_same_select_vector (node); +#endif + +#ifdef REUSE_UNIQUE_NODES + f_node_ids=copy_free_unique_node_ids (f_node_ids); +#else + f_node_ids=NULL; +#endif + + for_l (def,node_defs,def_next) + if (def->def_node){ +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if (def->def_id!=NULL && (def->def_id->nid_mark2 & NID_CALL_VIA_LAZY_SELECTIONS_ONLY)){ + ArgP arg; + NodeP node; + + node=def->def_node; + + optimise_normal_node (node); + + for_l (arg,node->node_arguments,arg_next) + optimise_node (arg->arg_node,&f_node_ids); + + optimise_strict_constructor_in_lazy_context (node,&f_node_ids); + + if (f_node_ids!=NULL) + f_node_ids=insert_unique_fill_nodes_for_lazy_tuple_recursive_call (node,f_node_ids); + } else +#endif + optimise_node (def->def_node,&f_node_ids); + } + + if (node->node_kind==NormalNode){ + ArgS *arg; + + optimise_normal_node (node); + +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if (node->node_symbol->symb_kind==tuple_symb && (current_rule_mark & RULE_CALL_VIA_LAZY_SELECTIONS_ONLY)){ + for_l (arg,node->node_arguments,arg_next){ + NodeP node; + + node=arg->arg_node; + + if (node->node_kind==NormalNode){ + ArgS *arg; + + optimise_normal_node (node); + + for_l (arg,node->node_arguments,arg_next) + optimise_node (arg->arg_node,&f_node_ids); + + optimise_strict_constructor_in_lazy_context (node,&no_free_unique_node_ids); + } else + optimise_node (node,&f_node_ids); + } + } else +#endif + for_l (arg,node->node_arguments,arg_next) + optimise_node (arg->arg_node,&f_node_ids); + + optimise_strict_constructor_in_lazy_context (node,&no_free_unique_node_ids); + } else + optimise_node (node,&f_node_ids); + +#ifdef REUSE_UNIQUE_NODES + f_node_ids=free_free_unique_node_ids (f_node_ids); +#endif + } + } +} +#endif + +static ImpRuleS *used_local_functions; + +static Bool IsObservedDef (NodeDefP def_p) +{ + NodeP node_p; + + node_p=def_p->def_node; + if (node_p==NULL || (node_p->node_annotation==StrictAnnot && (def_p->def_mark & NODE_DEF_OBSERVE_MASK))) + return True; + else + return False; +} + +static Bool IsStrictAnnotedAndNotParallelDef (NodeDefs def) +{ + Node node; + + node=def->def_node; + if (node==NULL || (node->node_annotation==StrictAnnot && !(node->node_state.state_mark & STATE_PARALLEL_MASK))) + return True; + else + return False; +} + +Bool HasExternalAnnot (Node node) +{ + if (node->node_annotation==NoAnnot) + return False; + + switch (node->node_annotation){ + case ParallelAnnot: + case ParallelAtAnnot: + case ParallelNFAnnot: + return True; + default: + return False; + } +} + +static Bool IsExternalNodeDef (NodeDefs def) +{ + if (def->def_node) + return HasExternalAnnot (def->def_node); + + return False; +} + +static Bool IsParallelNodeDef (NodeDefs def) +{ + if (def->def_node && def->def_node->node_annotation>StrictAnnot) + return True; + + return False; +} + +static Bool IsNotParStrictDef (NodeDefs def) +{ + if (def->def_node==NULL + || !(def->def_node->node_state.state_mark & STATE_PARALLEL_MASK) + || IsLazyState (def->def_node->node_state)) + return True; + else + return False; +} + +static Bool IsAnyNodeDef (NodeDefs def) +{ +#pragma unused(def) + + return True; +} + +static void ExamineSymbolApplication (struct node *node) +{ + Symbol symbol; + SymbDef sdef; + + symbol=node->node_symbol; + + if (symbol->symb_kind!=definition) + return; + + sdef=symbol->symb_def; + + if (sdef->sdef_kind==IMPRULE){ + if (sdef->sdef_arity!=node->node_arity){ + if (!sdef->sdef_exported){ + ImpRuleP rule_p; + + rule_p=sdef->sdef_rule; + if (sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK)){ + rule_p->rule_mark &= ~RULE_LAZY_CALL_NODE_MASK; + } else { + if (!(sdef->sdef_mark & (SDEF_USED_STRICTLY_MASK | SDEF_OPTIMISED_FUNCTION_MASK))){ + rule_p->rule_next_used_function=used_local_functions; + used_local_functions=rule_p; + } + + rule_p->rule_mark |= RULE_LAZY_CALL_NODE_MASK; + rule_p->rule_lazy_call_node = node; + } +#if STORE_STRICT_CALL_NODES + rule_p->rule_mark &= ~(RULE_STRICT_CALL_NODE_MASK | RULE_STRICT_CALL_NODE2_MASK); +#endif + } + sdef->sdef_mark |= SDEF_USED_CURRIED_MASK; + } else { + if (IsLazyState (node->node_state)){ + if (!sdef->sdef_exported){ + ImpRuleP rule_p; + + rule_p=sdef->sdef_rule; + if (sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK)){ + rule_p->rule_mark &= ~RULE_LAZY_CALL_NODE_MASK; + } else { + if (!(sdef->sdef_mark & (SDEF_USED_STRICTLY_MASK | SDEF_OPTIMISED_FUNCTION_MASK))){ + rule_p->rule_next_used_function=used_local_functions; + used_local_functions=rule_p; + } + + rule_p->rule_mark |= RULE_LAZY_CALL_NODE_MASK; + rule_p->rule_lazy_call_node = node; + } +#if STORE_STRICT_CALL_NODES + rule_p->rule_mark &= ~(RULE_STRICT_CALL_NODE_MASK | RULE_STRICT_CALL_NODE2_MASK); +#endif + } + sdef->sdef_mark |= SDEF_USED_LAZILY_MASK; + } else { + if (!(sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK | SDEF_USED_STRICTLY_MASK | SDEF_OPTIMISED_FUNCTION_MASK)) + && !sdef->sdef_exported) + { + sdef->sdef_rule->rule_next_used_function=used_local_functions; + used_local_functions=sdef->sdef_rule; + } + +#if STORE_STRICT_CALL_NODES + if (!sdef->sdef_exported){ + ImpRuleP rule_p; + + rule_p=sdef->sdef_rule; + if (sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK) || + ((sdef->sdef_mark & SDEF_USED_STRICTLY_MASK) && !(rule_p->rule_mark & RULE_STRICT_CALL_NODE_MASK))) + { + rule_p->rule_mark &= ~(RULE_STRICT_CALL_NODE_MASK | RULE_STRICT_CALL_NODE2_MASK); + } else { + if (!(rule_p->rule_mark & RULE_STRICT_CALL_NODE_MASK)){ + rule_p->rule_mark |= RULE_STRICT_CALL_NODE_MASK; + rule_p->rule_strict_call_node = node; + } else if (!(rule_p->rule_mark & RULE_STRICT_CALL_NODE2_MASK)){ + rule_p->rule_mark |= RULE_STRICT_CALL_NODE2_MASK; + rule_p->rule_strict_call_node2 = node; + } else { + rule_p->rule_mark &= ~(RULE_STRICT_CALL_NODE_MASK | RULE_STRICT_CALL_NODE2_MASK); + } + } + } +#endif + + sdef->sdef_mark |= SDEF_USED_STRICTLY_MASK; + } + } + } else { + if ((sdef->sdef_kind==RECORDTYPE ? sdef->sdef_cons_arity : sdef->sdef_arity) != node->node_arity) + sdef->sdef_mark |= SDEF_USED_CURRIED_MASK; + else + if (IsLazyState (node->node_state)) + sdef->sdef_mark |= SDEF_USED_LAZILY_MASK; + else + sdef->sdef_mark |= SDEF_USED_STRICTLY_MASK; + } +} + +static void ExamineSymbolApplicationOfSelectorOrUpdateNode (Symbol symb,StateS symbstate) +{ + SymbDef sdef; + + if (symb->symb_kind!=definition) + return; + + sdef = symb->symb_def; + + if (IsLazyState (symbstate)) + sdef->sdef_mark |= SDEF_USED_LAZILY_MASK; + else + sdef->sdef_mark |= SDEF_USED_STRICTLY_MASK; +} + +static void MarkDependentNodeDefs (NodeP node); + +static void MarkTupleSelectorsNode (NodeIdP node_id,NodeP tuple_node) +{ + if (tuple_node->node_arity==node_id->nid_refcount){ + struct arg *arg,**arg_pp; + int i,arity; + Node select_nodes[32]; + + if (tuple_node->node_number==1){ + if (tuple_node->node_node->node_kind==NodeIdNode) + tuple_node->node_node->node_arguments->arg_state=tuple_node->node_state; + else { + tuple_node->node_state=tuple_node->node_node->node_state; + + MarkDependentNodeDefs (tuple_node->node_node); + + return; + } + } + + arity=tuple_node->node_state.state_arity; + for (i=0; i<arity; ++i) + select_nodes[i]=NULL; + + for_l (arg,tuple_node->node_arguments,arg_next){ + int element_n; + Node select_node; + NodeId element_node_id; + struct arg *select_arg; + + select_node=arg->arg_node; + element_n=select_node->node_arity-1; + + if (select_nodes[element_n]!=NULL){ + element_node_id=select_nodes[element_n]->node_node_id; + element_node_id->nid_mark |= NID_SHARED_SELECTION_NODE_ID; + } else { + element_node_id=NewNodeId (NULL); + element_node_id->nid_number=element_n; + element_node_id->nid_node=select_node; + element_node_id->nid_scope = node_id->nid_scope; + select_nodes[element_n]=select_node; + } + + ++element_node_id->nid_refcount; + + select_node->node_kind=NodeIdNode; + select_node->node_node_id=element_node_id; + + select_node->node_state=tuple_node->node_state.state_tuple_arguments[element_n]; + select_arg=select_node->node_arguments; + + if (!IsSimpleState (select_arg->arg_state)) + select_arg->arg_state=select_arg->arg_state.state_tuple_arguments[element_n]; + } + + arg_pp=&tuple_node->node_arguments; + arg=tuple_node->node_arguments; + + for (i=arity-1; i>=0; --i) + if (select_nodes[i]!=NULL){ + arg->arg_node=select_nodes[i]; + *arg_pp=arg; + arg_pp=&arg->arg_next; + arg=arg->arg_next; + } + + *arg_pp=NULL; + } else if (tuple_node->node_number==1) + tuple_node->node_state=tuple_node->node_node->node_state; + + MarkDependentNodeDefs (tuple_node->node_node); +} + +static void MarkDependentNodeDefs (NodeP node) +{ + Args arg; + + switch (node->node_kind){ + case NodeIdNode: + { + NodeId node_id; + NodeDefS *def; + + node_id=node->node_node_id; + if (node_id->nid_refcount>0){ + def=node_id->nid_node_def; + + if (def && (def->def_mark & NODE_DEF_MARKED)==0 && def->def_node){ + def->def_mark |= NODE_DEF_MARKED; + + if (def->def_node->node_kind==TupleSelectorsNode) + MarkTupleSelectorsNode (node_id,def->def_node); + else + MarkDependentNodeDefs (def->def_node); + } + } + + return; + } + case NormalNode: + if (node->node_symbol->symb_kind==select_symb && node->node_arguments->arg_node->node_kind==NodeIdNode){ + NodeId node_id; + + node_id=node->node_arguments->arg_node->node_node_id; + if (node_id->nid_refcount>0){ + MarkDependentNodeDefs (node->node_arguments->arg_node); + ExamineSymbolApplication (node); + return; + } + } + + ExamineSymbolApplication (node); + break; + case MatchNode: + ExamineSymbolApplication (node); + break; + case SelectorNode: + if (node->node_symbol->symb_kind==definition){ + if (node->node_arity==1 && IsLazyState (node->node_state)) + node->node_symbol->symb_def->sdef_mark |= SDEF_USED_LAZILY_MASK; + else + node->node_symbol->symb_def->sdef_mark |= SDEF_USED_STRICTLY_MASK; + } + break; + case UpdateNode: + ExamineSymbolApplicationOfSelectorOrUpdateNode (node->node_symbol,node->node_state); + + arg=node->node_arguments; + MarkDependentNodeDefs (arg->arg_node); + + while ((arg=arg->arg_next)!=NULL) + MarkDependentNodeDefs (arg->arg_node->node_arguments->arg_node); + + return; + case IfNode: + break; +/* + MarkDependentNodeDefs (node->node_arguments->arg_node); + return; +*/ + case PushNode: + break; +#ifdef REUSE_UNIQUE_NODES + case FillUniqueNode: + break; +#endif + default: + error_in_function ("MarkDependentNodeDefs"); + } + + for_l (arg,node->node_arguments,arg_next) + MarkDependentNodeDefs (arg->arg_node); +} + +typedef Bool NodeDefFun (NodeDefs); + +static void MarkNodeDefsWithProperty +#ifdef applec + (NodeDefs defs, Bool (*node_def_function)()) +#else + (NodeDefs defs, NodeDefFun node_def_function) +#endif +{ + NodeDefS *def; + + for_l (def,defs,def_next) + if ((def->def_mark & NODE_DEF_MARKED)==0 && node_def_function (def)){ + def->def_mark |= NODE_DEF_MARKED; + if (def->def_node){ + if (def->def_node->node_kind==TupleSelectorsNode) + MarkTupleSelectorsNode (def->def_id,def->def_node); + else + MarkDependentNodeDefs (def->def_node); + } + } +} + +static NodeDefs *MoveMarkedNodeDefsToReorderedList (NodeDefs *def_p,NodeDefs *reordered_defs_p) +{ + NodeDefs def; + + while (def=*def_p,def!=NULL) + if ((def->def_mark & NODE_DEF_MARKED)!=0){ + *def_p=def->def_next; + *reordered_defs_p=def; + reordered_defs_p=&def->def_next; + } else + def_p=&def->def_next; + + return reordered_defs_p; +} + +static void ReorderNodeDefinitionsAndDetermineUsedEntries (NodeDefs *def_p,Node root) +{ + NodeDefs reordered_defs,*reordered_defs_p; + + while (root->node_kind==PushNode) + root=root->node_arguments->arg_next->arg_node; + + if (root->node_kind==SwitchNode){ + struct arg *arg; + + if (*def_p!=NULL) + error_in_function ("ReorderNodeDefinitionsAndDetermineUsedEntries"); + + for_l (arg,root->node_arguments,arg_next){ + if (arg->arg_node->node_kind!=CaseNode && arg->arg_node->node_kind!=DefaultNode) + error_in_function ("ReorderNodeDefinitionsAndDetermineUsedEntries"); + + ReorderNodeDefinitionsAndDetermineUsedEntries (&arg->arg_node->node_node_defs,arg->arg_node->node_arguments->arg_node); + } + + return; + } else if (root->node_kind==GuardNode){ + ReorderNodeDefinitionsAndDetermineUsedEntries (def_p,root->node_arguments->arg_node); + ReorderNodeDefinitionsAndDetermineUsedEntries (&root->node_node_defs,root->node_arguments->arg_next->arg_node); + return; + } + + reordered_defs_p=&reordered_defs; + + MarkNodeDefsWithProperty (*def_p,&IsObservedDef); + reordered_defs_p=MoveMarkedNodeDefsToReorderedList (def_p,reordered_defs_p); + + MarkNodeDefsWithProperty (*def_p,&IsStrictAnnotedAndNotParallelDef); + reordered_defs_p=MoveMarkedNodeDefsToReorderedList (def_p,reordered_defs_p); + + MarkNodeDefsWithProperty (*def_p,&IsExternalNodeDef); + reordered_defs_p=MoveMarkedNodeDefsToReorderedList (def_p,reordered_defs_p); + + MarkNodeDefsWithProperty (*def_p,&IsParallelNodeDef); + reordered_defs_p=MoveMarkedNodeDefsToReorderedList (def_p,reordered_defs_p); + + MarkNodeDefsWithProperty (*def_p,&IsNotParStrictDef); + reordered_defs_p=MoveMarkedNodeDefsToReorderedList (def_p,reordered_defs_p); + + MarkNodeDefsWithProperty (*def_p,&IsAnyNodeDef); + if (root->node_kind!=IfNode) + MarkDependentNodeDefs (root); + else + MarkDependentNodeDefs (root->node_arguments->arg_node); + reordered_defs_p=MoveMarkedNodeDefsToReorderedList (def_p,reordered_defs_p); + + *reordered_defs_p=NULL; + *def_p=reordered_defs; + + if (root->node_kind==IfNode){ + ReorderNodeDefinitionsAndDetermineUsedEntries (&root->node_then_node_defs,root->node_arguments->arg_next->arg_node); + ReorderNodeDefinitionsAndDetermineUsedEntries (&root->node_else_node_defs,root->node_arguments->arg_next->arg_next->arg_node); + } +} + +static NodeIdRefCountListP determine_then_or_else_ref_counts (NodeP node,NodeDefP node_defs,int local_scope); + +static NodeIdRefCountListP determine_then_else_ref_counts_of_graph (NodeP node,NodeIdRefCountListP node_id_ref_counts,int local_scope) +{ + switch (node->node_kind){ + case NodeIdNode: + { + NodeIdP node_id; + int node_id_scope; + + node_id=node->node_node_id; + + node_id_scope=node_id->nid_scope; + if (node_id_scope<0) + node_id_scope=-node_id_scope; + + if (node_id_scope<local_scope){ + if (!(node_id->nid_mark & NID_THEN_ELSE_NON_LOCAL_NODE_ID)){ + node_id->nid_mark |= NID_THEN_ELSE_NON_LOCAL_NODE_ID; + node_id_ref_counts=new_node_id_ref_count (node_id_ref_counts,node_id,1); + node_id->nid_node_id_ref_count_element_=node_id_ref_counts; + } else + ++node_id->nid_node_id_ref_count_element->nrcl_ref_count; + } + + return node_id_ref_counts; + } + case NormalNode: + case UpdateNode: + { + ArgP arg; + + for_l (arg,node->node_arguments,arg_next) + node_id_ref_counts=determine_then_else_ref_counts_of_graph (arg->arg_node,node_id_ref_counts,local_scope); + + return node_id_ref_counts; + } + case SelectorNode: + case MatchNode: + return determine_then_else_ref_counts_of_graph (node->node_arguments->arg_node,node_id_ref_counts,local_scope); +#ifdef REUSE_UNIQUE_NODES + case FillUniqueNode: + { + NodeP node_p; + ArgP arg_p; + unsigned long occurences; + int n; + + node_p=node->node_arguments->arg_node; + if (node_p->node_kind!=NormalNode) + error_in_function ("determine_then_else_ref_counts_of_graph"); + + n=0; + occurences=node->node_arguments->arg_occurrence; + + for_l (arg_p,node_p->node_arguments,arg_next){ + if (occurences & (1<<n)) + node_id_ref_counts=determine_then_else_ref_counts_of_graph (arg_p->arg_node,node_id_ref_counts,local_scope); + ++n; + } + + return node_id_ref_counts; + } +#endif + case IfNode: + { + ArgP cond_arg,then_arg; + NodeIdRefCountListP local_node_id_ref_count; + int new_local_scope; + + new_local_scope=node->node_if_scope+2; + + cond_arg=node->node_arguments; + + then_arg=cond_arg->arg_next; + + node->node_then_node_id_ref_counts= + determine_then_or_else_ref_counts (then_arg->arg_node,node->node_then_node_defs,new_local_scope); + node->node_else_node_id_ref_counts= + determine_then_or_else_ref_counts (then_arg->arg_next->arg_node,node->node_else_node_defs,new_local_scope); + + for_l (local_node_id_ref_count,node->node_then_node_id_ref_counts,nrcl_next){ + NodeIdP node_id; + int node_id_scope; + + node_id=local_node_id_ref_count->nrcl_node_id; + + node_id_scope=node_id->nid_scope; + if (node_id_scope<0) + node_id_scope=-node_id_scope; + + if (node_id_scope<local_scope){ + if (!(node_id->nid_mark & NID_THEN_ELSE_NON_LOCAL_NODE_ID)){ + node_id->nid_mark |= NID_THEN_ELSE_NON_LOCAL_NODE_ID; + node_id_ref_counts=new_node_id_ref_count (node_id_ref_counts,node_id,local_node_id_ref_count->nrcl_ref_count); + node_id->nid_node_id_ref_count_element_=node_id_ref_counts; + } else + node_id->nid_node_id_ref_count_element->nrcl_ref_count += local_node_id_ref_count->nrcl_ref_count; + } + } + + for_l (local_node_id_ref_count,node->node_else_node_id_ref_counts,nrcl_next){ + NodeIdP node_id; + int node_id_scope; + + node_id=local_node_id_ref_count->nrcl_node_id; + + node_id_scope=node_id->nid_scope; + if (node_id_scope<0) + node_id_scope=-node_id_scope; + + if (node_id_scope<local_scope){ + if (!(node_id->nid_mark & NID_THEN_ELSE_NON_LOCAL_NODE_ID)){ + node_id->nid_mark |= NID_THEN_ELSE_NON_LOCAL_NODE_ID; + node_id_ref_counts=new_node_id_ref_count (node_id_ref_counts,node_id,local_node_id_ref_count->nrcl_ref_count); + node_id->nid_node_id_ref_count_element_=node_id_ref_counts; + } else + node_id->nid_node_id_ref_count_element->nrcl_ref_count += local_node_id_ref_count->nrcl_ref_count; + } + } + + return determine_then_else_ref_counts_of_graph (cond_arg->arg_node,node_id_ref_counts,local_scope); + } + case TupleSelectorsNode: + return determine_then_else_ref_counts_of_graph (node->node_node,node_id_ref_counts,local_scope); + default: + error_in_function ("determine_then_else_ref_counts_of_graph"); + return node_id_ref_counts; + } +} + +static NodeIdRefCountListP determine_then_or_else_ref_counts (NodeP node,NodeDefP node_defs,int local_scope) +{ + NodeIdRefCountListP local_node_id_ref_counts,local_node_id_ref_count; + NodeDefP node_def; + + local_node_id_ref_counts=determine_then_else_ref_counts_of_graph (node,NULL,local_scope); + + for_l (node_def,node_defs,def_next) + if (node_def->def_node) + local_node_id_ref_counts=determine_then_else_ref_counts_of_graph (node_def->def_node,local_node_id_ref_counts,local_scope); + + for_l (local_node_id_ref_count,local_node_id_ref_counts,nrcl_next) + local_node_id_ref_count->nrcl_node_id->nid_mark &= ~NID_THEN_ELSE_NON_LOCAL_NODE_ID; + + return local_node_id_ref_counts; +} + +static void determine_then_else_ref_counts (NodeP node) +{ + switch (node->node_kind){ + case IfNode: + { + ArgP then_arg; + int local_scope; + + local_scope=node->node_if_scope+2; + + then_arg=node->node_arguments->arg_next; + + node->node_then_node_id_ref_counts=determine_then_or_else_ref_counts (then_arg->arg_node,node->node_then_node_defs,local_scope); + node->node_else_node_id_ref_counts=determine_then_or_else_ref_counts (then_arg->arg_next->arg_node,node->node_else_node_defs,local_scope); + + determine_then_else_ref_counts (node->node_arguments->arg_node); + return; + } + case GuardNode: + determine_then_else_ref_counts (node->node_arguments->arg_node); + determine_then_else_ref_counts (node->node_arguments->arg_next->arg_node); + return; + case SwitchNode: + { + ArgP arg; + + for_l (arg,node->node_arguments,arg_next){ + Node case_node; + + case_node=arg->arg_node; + if (case_node->node_kind==CaseNode || case_node->node_kind==DefaultNode){ + NodeP case_alt_node_p; + + case_alt_node_p=case_node->node_arguments->arg_node; + if (case_alt_node_p->node_kind==PushNode) + case_alt_node_p=case_alt_node_p->node_arguments->arg_next->arg_node; + + ++node->node_node_id->nid_refcount; + set_local_reference_counts (case_node); + + determine_then_else_ref_counts (case_alt_node_p); + + set_global_reference_counts (case_node); + --node->node_node_id->nid_refcount; + } else + error_in_function ("determine_then_else_ref_counts"); + } + return; + } + default: + return; + } +} + +#ifdef REUSE_UNIQUE_NODES +static void mark_shared_strict_tuple_or_record (ArgP arguments) +{ + ArgP arg_p; + + for_l (arg_p,arguments,arg_next){ + if (arg_p->arg_node->node_kind==NodeIdNode) + arg_p->arg_node->node_node_id->nid_mark |= NID_EXTRA_REFCOUNT_MASK; + } +} + +static void mark_shared_strict_tuple_and_record_elements (Args args,int ref_count_one) +{ + ArgP arg_p; + + for_l (arg_p,args,arg_next){ + Node arg_node; + int ref_count_one_for_arg; + + arg_node=arg_p->arg_node; + ref_count_one_for_arg=ref_count_one; + + if (arg_node->node_kind==NodeIdNode){ + NodeId node_id; + + node_id=arg_node->node_node_id; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS /* added 3-3-2000 */ + if (node_id->nid_refcount<-2 || (node_id->nid_mark & NID_EXTRA_REFCOUNT_MASK)) +#else + if (node_id->nid_refcount!=-1 || (node_id->nid_mark & NID_EXTRA_REFCOUNT_MASK)) +#endif + ref_count_one_for_arg=0; + +#if DESTRUCTIVE_RECORD_UPDATES + node_id->nid_mark2|=NID_HAS_REFCOUNT_WITHOUT_UPDATES; + node_id->nid_number=node_id->nid_refcount; +#endif + arg_node=arg_node->node_node_id->nid_node; + } + + if (arg_node!=NULL){ + Symbol symbol; + + symbol = arg_node->node_symbol; + + switch (symbol->symb_kind){ + case tuple_symb: + if (!IsSimpleState (arg_p->arg_state)){ + if (!ref_count_one_for_arg) + mark_shared_strict_tuple_or_record (arg_node->node_arguments); + + mark_shared_strict_tuple_and_record_elements (arg_node->node_arguments,ref_count_one_for_arg); + } + break; + case definition: + { + SymbDef def; + + def = symbol->symb_def; + if (def->sdef_kind==RECORDTYPE){ + if (arg_p->arg_state.state_type==RecordState){ + if (!ref_count_one_for_arg) + mark_shared_strict_tuple_or_record (arg_node->node_arguments); + + mark_shared_strict_tuple_and_record_elements (arg_node->node_arguments,ref_count_one_for_arg); + } + } + } + } + } + } +} +#endif + +static ImpRuleS **OptimiseRule (ImpRuleS *rule) +{ + SymbDef rule_sdef; + + CurrentSymbol = rule->rule_root->node_symbol; + + rule_sdef= CurrentSymbol->symb_def; + + if (rule_sdef->sdef_over_arity==0){ + RuleAlts alt; + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + transform_patterns_to_case_and_guard_nodes (rule->rule_alts); +#endif + + alt=rule->rule_alts; + CurrentLine = alt->alt_line; + + if (alt->alt_kind==Contractum){ +#ifdef REUSE_UNIQUE_NODES + if (DoReuseUniqueNodes) + mark_shared_strict_tuple_and_record_elements (alt->alt_lhs_root->node_arguments,1); +#endif +#if OPTIMIZE_LAZY_TUPLE_RECURSION + current_rule_mark=rule->rule_mark; +#endif + optimise_root_node (alt->alt_rhs_root,alt->alt_rhs_defs,NULL); + + ReorderNodeDefinitionsAndDetermineUsedEntries (&alt->alt_rhs_defs,alt->alt_rhs_root); + + determine_then_else_ref_counts (alt->alt_rhs_root); + } + + while (new_rules){ + ImpRuleP new_rule; + RuleAltP alt; + + new_rule=new_rules; + new_rules=new_rule->rule_next; + + alt=new_rule->rule_alts; + DetermineStatesOfRootNodeAndDefs (alt->alt_rhs_root,&alt->alt_rhs_defs,alt->alt_lhs_root->node_state,0); + ReorderNodeDefinitionsAndDetermineUsedEntries (&alt->alt_rhs_defs,alt->alt_rhs_root); + + new_rule->rule_next=rule->rule_next; + rule->rule_next=new_rule; + rule=new_rule; + } + } + + return &rule->rule_next; +} + +StateP state_of_node_or_node_id (NodeP node_p) +{ + if (node_p->node_kind!=NodeIdNode){ + return &node_p->node_state; + } else { + NodeIdP node_id; + + node_id=node_p->node_node_id; + if (node_id->nid_refcount<0) + return node_id->nid_lhs_state_p; + else + return &node_id->nid_node->node_state; + } +} + +void OptimiseRules (ImpRules rules,SymbDef start_sdef) +{ + ImpRuleS **rule_h; + + next_function_n=0; + new_rules=NULL; +#ifdef REUSE_UNIQUE_NODES + free_unique_node_id_list=NULL; +#endif + + used_local_functions=NULL; + + if (start_sdef!=NULL && !start_sdef->sdef_exported){ + used_local_functions=start_sdef->sdef_rule; + used_local_functions->rule_next_used_function=NULL; + } + + for (rule_h=&rules; *rule_h!=NULL; ) + if ((*rule_h)->rule_root->node_symbol->symb_def->sdef_exported) + rule_h=OptimiseRule (*rule_h); + else + rule_h=&(*rule_h)->rule_next; + + while (used_local_functions!=NULL){ + ImpRuleS *rule; + + rule=used_local_functions; + used_local_functions=used_local_functions->rule_next_used_function; + + OptimiseRule (rule); + } + +# ifdef THINK_C + if (!DoParallel) +# endif + { + ImpRuleP rule_p; + + for_l (rule_p,rules,rule_next){ + if ((rule_p->rule_mark & RULE_LAZY_CALL_NODE_MASK) && + !(rule_p->rule_root->node_symbol->symb_def->sdef_mark & SDEF_USED_CURRIED_MASK) && + !(rule_p->rule_mark & RULE_CAF_MASK)) + { + NodeP call_node_p; + + call_node_p=rule_p->rule_lazy_call_node; + if (call_node_p->node_number==0 && !(call_node_p->node_state.state_type==SimpleState && call_node_p->node_state.state_kind==SemiStrict)){ + StateP function_arg_state_p; + ArgP arg_p; + + rule_p->rule_mark |= RULE_UNBOXED_LAZY_CALL; + + for_la (arg_p,function_arg_state_p,call_node_p->node_arguments,rule_p->rule_state_p,arg_next){ + if (function_arg_state_p->state_type==SimpleState){ + if (function_arg_state_p->state_kind==OnB){ + StateP arg_state_p; + + arg_state_p=state_of_node_or_node_id (arg_p->arg_node); + if (arg_state_p->state_type==SimpleState && arg_state_p->state_kind==OnB){ + arg_p->arg_state=*arg_state_p; + continue; + } + } + } else if (function_arg_state_p->state_type==ArrayState){ + StateP arg_state_p; + + arg_state_p=state_of_node_or_node_id (arg_p->arg_node); + if (arg_state_p->state_type==ArrayState){ + arg_p->arg_state=*arg_state_p; + continue; + } + } + } + } + } + } + } + +#if STORE_STRICT_CALL_NODES + { + ImpRuleP rule_p; + + for_l (rule_p,rules,rule_next){ + if (rule_p->rule_mark & RULE_STRICT_CALL_NODE_MASK){ + ArgP arg_p1,arg_p2,lhs_arg_p; + StateP function_arg_state_p; + + if (rule_p->rule_mark & RULE_STRICT_CALL_NODE2_MASK) + arg_p2=rule_p->rule_strict_call_node2->node_arguments; + else + arg_p2=NULL; + + for_lla (arg_p1,lhs_arg_p,function_arg_state_p, + rule_p->rule_strict_call_node->node_arguments,rule_p->rule_alts->alt_lhs_root->node_arguments,rule_p->rule_state_p, + arg_next,arg_next) + { + if (function_arg_state_p->state_type==SimpleState && function_arg_state_p->state_kind==OnA){ + if (lhs_arg_p->arg_node->node_kind==NodeIdNode){ + StateP lhs_arg_state_p; + NodeIdP lhs_node_id_p; + + lhs_node_id_p=lhs_arg_p->arg_node->node_node_id; + lhs_arg_state_p=lhs_node_id_p->nid_lhs_state_p; + + if (lhs_arg_state_p->state_type==SimpleState && lhs_arg_state_p->state_kind==OnA){ + NodeP call_arg_node1,call_arg_node2; + StateP call_arg_state_p1,call_arg_state_p2; + + call_arg_node1=arg_p1->arg_node; + if (call_arg_node1->node_kind!=NodeIdNode){ + call_arg_state_p1=&call_arg_node1->node_state; + } else { + struct node_id *node_id; + + node_id=call_arg_node1->node_node_id; + if (node_id->nid_refcount<0){ + if (node_id==lhs_node_id_p) + call_arg_state_p1=NULL; + else + call_arg_state_p1=node_id->nid_lhs_state_p; + } else + call_arg_state_p1=&node_id->nid_node->node_state; + } + + if (call_arg_state_p1==NULL || !IsLazyState (*call_arg_state_p1)){ + if (arg_p2!=NULL){ + call_arg_node2=arg_p2->arg_node; + if (call_arg_node2->node_kind!=NodeIdNode){ + call_arg_state_p2=&call_arg_node2->node_state; + } else { + struct node_id *node_id; + + node_id=call_arg_node2->node_node_id; + if (node_id->nid_refcount<0){ + if (node_id==lhs_node_id_p) + call_arg_state_p2=NULL; + else + call_arg_state_p2=node_id->nid_lhs_state_p; + } else + call_arg_state_p2=&node_id->nid_node->node_state; + } + } else + call_arg_state_p2=NULL; + + if (call_arg_state_p1!=NULL || call_arg_state_p2!=NULL){ + if (call_arg_state_p2==NULL || !IsLazyState (*call_arg_state_p2)){ + if ((call_arg_state_p1==NULL || + (call_arg_state_p1->state_type==ArrayState || + (call_arg_state_p1->state_type==SimpleState && call_arg_state_p1->state_kind==OnB))) && + (call_arg_state_p2==NULL || + (call_arg_state_p2->state_type==ArrayState || + (call_arg_state_p2->state_type==SimpleState && call_arg_state_p2->state_kind==OnB)))) + { + StateP new_call_state_p; + + if (call_arg_state_p1!=NULL) + new_call_state_p = call_arg_state_p1; + else + new_call_state_p = call_arg_state_p2; + + *lhs_arg_state_p = *new_call_state_p; + *function_arg_state_p = *new_call_state_p; + + arg_p1->arg_state = *new_call_state_p; + + if (call_arg_node1->node_kind==NodeIdNode && + call_arg_node1->node_node_id->nid_refcount==1 && + call_arg_node1->node_node_id->nid_node->node_kind==NodeIdNode) + { + call_arg_node1->node_node_id->nid_node->node_arguments->arg_state = *new_call_state_p; + } + + if (arg_p2!=NULL){ + arg_p2->arg_state = *new_call_state_p; + + if (call_arg_node2->node_kind==NodeIdNode && + call_arg_node2->node_node_id->nid_refcount==1 && + call_arg_node2->node_node_id->nid_node->node_kind==NodeIdNode) + { + call_arg_node2->node_node_id->nid_node->node_arguments->arg_state = *new_call_state_p; + } + } + } else { + lhs_arg_state_p->state_kind=StrictOnA; + function_arg_state_p->state_kind=StrictOnA; + } + } + } + } + } + } + } + if (arg_p2!=NULL) + arg_p2=arg_p2->arg_next; + } + } + } + } +#endif +} diff --git a/backendC/CleanCompilerSources/optimisations.h b/backendC/CleanCompilerSources/optimisations.h new file mode 100644 index 0000000..206059d --- /dev/null +++ b/backendC/CleanCompilerSources/optimisations.h @@ -0,0 +1,7 @@ +void OptimiseRules (ImpRules rules,SymbDef start_sdef); +SymbolP copy_imp_rule_and_type (SymbDef old_sdef); +void copy_imp_rule_nodes (ImpRuleP old_rule_p,ImpRuleP new_rule_p); +int optimise_tuple_result_function (Node node,StateS demanded_state); +void generate_states (struct imp_rule *rules,int do_strictness_analysis); +StateP state_of_node_or_node_id (NodeP node_p); +void copy_rhs_node_defs_and_root (RuleAltP old_alt_p,NodeP *new_root_node_h,NodeDefP *node_defs_p); diff --git a/backendC/CleanCompilerSources/optimise_lambda.h b/backendC/CleanCompilerSources/optimise_lambda.h new file mode 100644 index 0000000..015d7f2 --- /dev/null +++ b/backendC/CleanCompilerSources/optimise_lambda.h @@ -0,0 +1 @@ +NodeP DetermineGraphRulesComponentAndOptimiseLambdas (NodeP root_p,unsigned int *ancest_p); diff --git a/backendC/CleanCompilerSources/overloading.h b/backendC/CleanCompilerSources/overloading.h new file mode 100644 index 0000000..c8113d5 --- /dev/null +++ b/backendC/CleanCompilerSources/overloading.h @@ -0,0 +1,103 @@ +/* + + Version 1.0 08/25/1994 + + Author: Sjaak Smetsers + +*/ + +/* + +typedef struct member_descriptor +{ + SymbDef md_class; + Symbol md_rule; + +} * MemberDescriptor; + +typedef struct member_item +{ + Bool mi_is_class; + union + { Overloaded mi_u_rule; + SymbDef mi_u_class; + } mi_union; + + struct member_item * mi_next; + +} * MemberItems; + +#define mi_rule mi_union.mi_u_rule +#define mi_class mi_union.mi_u_class + +*/ + +/* + Global variables +*/ + +extern unsigned NrOfOverloadedTypeVars, NrOfOverloadedRules, NrOfUntypedImpRules, + NrOfTypeClasses; + + +/* + Global functions +*/ + +extern int LengthOfPolyList (PolyList list); + +extern PolyList NewPolyListElem (void *elem, PolyList next, HeapDescr hd); + +extern Bool IsSubClass (SymbolList sub_tree, SymbolList whole_list); + +extern void DetermineClassesOfOverloadedTypeVariables (struct type_cell * type_inst); + +extern Bool TryToBindOverloadedTypeVariables (Node appl_node, SymbolList class_symbols, struct type_cell * type_inst); + +extern void CheckInstancesOfTypeClasses (Symbol symbs); + +extern void ConvertTypeClasses (void); + +extern void ConvertTypeContexts (TypeContext type_cont, struct type_cell * typeargs []); + +extern void SetOverloadedTypeVars (int over_arity, TypeContext type_cont, struct type_cell * over_vars []); + +extern void DetermineClassNumber (SymbDef class_symb); + +extern ClassInstance RetrieveSpecificInstance (ClassDefinition class, struct type_cell * inst_type); + +extern SymbDef CopySymbDef (SymbDef old); + +extern SymbDef NewEmptyRule (Symbol rule_symb, int arity, unsigned line); + +extern Bool EqualTypeClasses (int var_nr1, int var_nr2); + +extern void InitOverloading (void); + +extern void AddToInstanceList (ClassInstance class_instance, ClassDefinition class_def); + +extern FieldList RetrieveClassSelector (SymbolList class_symbols, SymbDef class_symbol); + +extern Types DetermineClassRecord (int nr_of_fields); + +extern Bool InstanceIsExported (struct type_cell * inst_types [], struct type_cell * over_vars [], TypeContext type_cont); + +extern struct type_cell * DetermineDefaultInstance (struct type_cell * over_var, Node over_appl_node); + +extern Bool EqualSymbolList (SymbolList class_symbols1, SymbolList class_symbols2); + +extern Bool ClassesHaveAGenericInstance (SymbolList classes); + +extern struct type_cell * DetermineGenericInstance (struct type_cell * over_var); + +extern SymbolList RebuildClassSymbolList (SymbolList class_symbs, void *alloc (SizeT size)); + +#define cTakeIclDef True +#define cDontTakeIclDef False + +extern void InsertSymbolInSymbolList (SymbolList *symbols, SymbDef new_symbol, Bool take_icl_def, void *alloc (SizeT size)); + +extern void ConvertClassSymbolTreeToList (SymbolList symbols, SymbolList * result_list, void *alloc (SizeT size)); + +extern void CreateRuleType (SymbDef icl_def, TypeAlts imp_type); + diff --git a/backendC/CleanCompilerSources/overloading_2.c b/backendC/CleanCompilerSources/overloading_2.c new file mode 100644 index 0000000..ed5a04e --- /dev/null +++ b/backendC/CleanCompilerSources/overloading_2.c @@ -0,0 +1,79 @@ +/* + Version 1.0 - 24 okt 1994 + + Author: Sjaak Smetsers +*/ + +#include "system.h" + +#include "settings.h" +#include "syntaxtr.t" +#include "comsupport.h" + +#include "scanner.h" +#include "comparser.h" +#include "sizes.h" +#include "checker.h" +#include "checksupport.h" +#include "transform.h" +#include "sa.h" +#include "statesgen.h" +#include "tctypes.t" +#include "typechecker.h" +#include "typechecker2.h" +#include "typeconv.h" +#include "tcsupport.h" +#include "refcountanal.h" +#include "overloading.h" +#include "buildtree.h" + +#ifdef _DEBUG_ + static char *OV = "overloading"; +#endif + +PolyList NewPolyListElem (void *elem, PolyList next, HeapDescr hd) +{ + PolyList new = TH_AllocType (hd, struct poly_list); + new -> pl_elem = elem; + new -> pl_next = next; + return new; + +} /* NewPolyListElem */ + +void InsertSymbolInSymbolList (SymbolList *symbols, SymbDef new_symbol, Bool take_icl_def, void *alloc (SizeT size)) +{ + SymbolList new_elem; + + for (; *symbols; symbols = & (*symbols) -> sl_next) + { int cmp = strcmp ((*symbols) -> sl_symbol -> sdef_ident -> ident_name, new_symbol -> sdef_ident -> ident_name); + if (cmp == 0) + return; + else if (cmp > 0) + break; + } + + new_elem = (SymbolListS *) alloc (SizeOf (SymbolListS)); + + if (take_icl_def && new_symbol -> sdef_main_dcl) + new_elem -> sl_symbol = new_symbol -> sdef_dcl_icl; + else + new_elem -> sl_symbol = new_symbol; + + new_elem -> sl_kind = SLK_Symbol; + new_elem -> sl_next = *symbols; + + *symbols = new_elem; + +} /* InsertSymbolInSymbolList */ + +void ConvertClassSymbolTreeToList (SymbolList symbols, SymbolList * result_list, void *alloc (SizeT size)) +{ + SymbolList next_symbol; + for (next_symbol = symbols; next_symbol -> sl_kind == SLK_TreeOfLists; next_symbol = next_symbol -> sl_next_tree) + ConvertClassSymbolTreeToList (next_symbol -> sl_next, result_list, alloc); + if (next_symbol -> sl_kind == SLK_ListNumber) + next_symbol = next_symbol -> sl_next; + for (; next_symbol; next_symbol = next_symbol -> sl_next) + InsertSymbolInSymbolList (result_list, next_symbol -> sl_symbol, cTakeIclDef, alloc); + +} /* ConvertClassSymbolTreeToList */ diff --git a/backendC/CleanCompilerSources/path_cache.c b/backendC/CleanCompilerSources/path_cache.c new file mode 100644 index 0000000..e2b0eef --- /dev/null +++ b/backendC/CleanCompilerSources/path_cache.c @@ -0,0 +1,178 @@ + +#include "compiledefines.h" +#include "system.h" + +#include <stdlib.h> +#include <stdio.h> +#include <string.h> + +#include "path_cache.h" + +struct path_cache_list { + char * pcache_path; + short pcache_wd_ref_num; + short pcache_clean_system_files_wd_ref_num; + FileTime pcache_dcl_time; + struct path_cache_list * pcache_next; + struct file_block * pcache_file_blocks; +#if defined (__MWERKS__) || defined (__MRC__) + char pcache_file_name[]; +#else + char pcache_file_name[0]; +#endif +}; + +#define BUFFER_SIZE 1024 + +struct file_block { + int file_block_size; + struct file_block * file_block_next; + char file_block_data[BUFFER_SIZE]; +}; + +static struct path_cache_list *path_cache [32]={ + NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL +}; + +static int simple_hash (char *name) +{ + int sum; + + sum=0; + + while (*name) + sum += *name++; + + return sum & 31; +} + +void cache_dcl_path (char *file_name,short wd_ref_num,short clean_system_files_wd_ref_num, + unsigned long file_time,char *path) +{ + int hash_value,file_name_length; + struct path_cache_list **pcache_elem_p,*new_pcache_elem; + + hash_value=simple_hash (file_name); + + for (pcache_elem_p=&path_cache[hash_value]; *pcache_elem_p; + pcache_elem_p=&(*pcache_elem_p)->pcache_next) + { + if (!strcmp ((*pcache_elem_p)->pcache_file_name,file_name)) + return; + } + + file_name_length=strlen (file_name); + + new_pcache_elem=(struct path_cache_list*)Alloc (sizeof (struct path_cache_list)+file_name_length+1,1); + + if (new_pcache_elem!=NULL){ + strcpy (new_pcache_elem->pcache_file_name,file_name); + new_pcache_elem->pcache_path=path; + new_pcache_elem->pcache_wd_ref_num=wd_ref_num; + new_pcache_elem->pcache_clean_system_files_wd_ref_num=clean_system_files_wd_ref_num; + new_pcache_elem->pcache_dcl_time=file_time; + new_pcache_elem->pcache_next=NULL; + new_pcache_elem->pcache_file_blocks=NULL; + + *pcache_elem_p=new_pcache_elem; + } +} + +int search_dcl_path_in_cache (char *file_name,struct search_dcl_path_in_cache_result *r) +{ + int hash_value; + struct path_cache_list **pcache_elem_p; + + hash_value=simple_hash (file_name); + + for (pcache_elem_p=&path_cache[hash_value]; *pcache_elem_p; + pcache_elem_p=&(*pcache_elem_p)->pcache_next) + { + if (!strcmp ((*pcache_elem_p)->pcache_file_name,file_name)){ + struct path_cache_list *pcache_elem; + + pcache_elem=*pcache_elem_p; + r->wd_ref_num=pcache_elem->pcache_wd_ref_num; + r->clean_system_files_wd_ref_num=pcache_elem->pcache_clean_system_files_wd_ref_num; + r->file_time=pcache_elem->pcache_dcl_time; + r->path=pcache_elem->pcache_path; + + return 1; + } + } + + return 0; +} + +#if WRITE_DCL_MODIFICATION_TIME +struct file_block **get_file_blocks_p_and_time_of_dcl_file (char *file_name,FileTime *file_time_p) +{ + int hash_value; + struct path_cache_list **pcache_elem_p; + + hash_value=simple_hash (file_name); + + for (pcache_elem_p=&path_cache[hash_value]; *pcache_elem_p; + pcache_elem_p=&(*pcache_elem_p)->pcache_next) + { + if (!strcmp ((*pcache_elem_p)->pcache_file_name,file_name)){ + struct path_cache_list *pcache_elem; + + pcache_elem=*pcache_elem_p; + *file_time_p=pcache_elem->pcache_dcl_time; + return &pcache_elem->pcache_file_blocks; + } + } + + return NULL; +} +#endif + +struct file_block **get_file_blocks_p_of_dcl_file (char *file_name) +{ + int hash_value; + struct path_cache_list **pcache_elem_p; + + hash_value=simple_hash (file_name); + + for (pcache_elem_p=&path_cache[hash_value]; *pcache_elem_p; + pcache_elem_p=&(*pcache_elem_p)->pcache_next) + { + if (!strcmp ((*pcache_elem_p)->pcache_file_name,file_name)) + return &(*pcache_elem_p)->pcache_file_blocks; + } + + return NULL; +} + +void clear_path_cache (void) +{ + int n; + + for (n=0; n<32; ++n){ + struct path_cache_list *pcache_elem,*next_pcache_elem; + + pcache_elem=path_cache[n]; + path_cache[n]=NULL; + + while (pcache_elem!=NULL){ + struct file_block *pcache_file_blocks,*next_pcache_file_block; + + next_pcache_elem=pcache_elem->pcache_next; + pcache_file_blocks=pcache_elem->pcache_file_blocks; + + Free (pcache_elem); + + while (pcache_file_blocks!=NULL){ + next_pcache_file_block=pcache_file_blocks->file_block_next; + Free (pcache_file_blocks); + pcache_file_blocks=next_pcache_file_block; + } + + pcache_elem=next_pcache_elem; + } + } +}
\ No newline at end of file diff --git a/backendC/CleanCompilerSources/path_cache.h b/backendC/CleanCompilerSources/path_cache.h new file mode 100644 index 0000000..68718a9 --- /dev/null +++ b/backendC/CleanCompilerSources/path_cache.h @@ -0,0 +1,18 @@ + +extern void cache_dcl_path (char *file_name,short wd_ref_num,short clean_system_files_wd_ref_num, + unsigned long file_time,char *path); + +struct search_dcl_path_in_cache_result { + short wd_ref_num; + short clean_system_files_wd_ref_num; + unsigned long file_time; + char * path; +}; + +extern int search_dcl_path_in_cache (char *file_name,struct search_dcl_path_in_cache_result *r); +extern struct file_block **get_file_blocks_p_of_dcl_file (char *file_name); +#if WRITE_DCL_MODIFICATION_TIME +extern struct file_block **get_file_blocks_p_and_time_of_dcl_file (char *file_name,FileTime *file_time_p); +#endif + +extern void clear_path_cache (void); diff --git a/backendC/CleanCompilerSources/pattern_match.c b/backendC/CleanCompilerSources/pattern_match.c new file mode 100644 index 0000000..7952e37 --- /dev/null +++ b/backendC/CleanCompilerSources/pattern_match.c @@ -0,0 +1,2005 @@ +/* + File: pattern_match.c + Author: John van Groningen +*/ + +#define DEBUG_OUTPUT 0 + +#if defined (applec) || defined (__MWERKS__) || defined (__MRC__) +# define __ppc__ +#endif + +#include <stdio.h> + +#include "types.t" +#include "syntaxtr.t" +#include "pattern_match.h" +#include "buildtree.h" +#include "comsupport.h" +#include "statesgen.h" +#include "settings.h" +#include "codegen_types.h" + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) + +static void error_in_function (char *m) +{ + ErrorInCompiler ("",m,""); +} + +#if DEBUG_OUTPUT +char *node_id_name (NodeId node_id) +{ + static char node_id_name_s[65]; + + if (node_id->nid_ident!=NULL && node_id->nid_ident->ident_name!=NULL) + return node_id->nid_ident->ident_name; + else { + sprintf (node_id_name_s,"i_%lx",(long)node_id); + return node_id_name_s; + } +} +#endif + +static NodeP new_switch_node (NodeIdP node_id,NodeP case_node,StateP state_p,NodeS ***root_l) +{ + NodeP switch_node; + + switch_node=CompAllocType (NodeS); + + switch_node->node_kind=SwitchNode; + switch_node->node_node_id=node_id; + switch_node->node_arity=1; + switch_node->node_arguments=NewArgument (case_node); + switch_node->node_state=*state_p; + +#if DEBUG_OUTPUT + printf ("dec %s %d\n",node_id_name (node_id),node_id->nid_refcount); +#endif + + --node_id->nid_refcount; + + **root_l=switch_node; + *root_l=&case_node->node_arguments->arg_node; + + return switch_node; +} + +static NodeP new_case_node (SymbolP symbol,int symbol_arity,NodeP node,NodeDefP **def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,StrictNodeIdP **strict_node_ids_l +#endif + ) +{ + NodeP case_node; + + case_node=CompAllocType (NodeS); + + case_node->node_kind=CaseNode; + case_node->node_symbol=symbol; + case_node->node_arity=symbol_arity; + case_node->node_arguments=NewArgument (node); + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + case_node->node_su.su_u.u_case=CompAllocType (CaseNodeContentsS); + case_node->node_strict_node_ids=NULL; +#endif + + case_node->node_node_id_ref_counts=NULL; + + case_node->node_node_defs=**def_l; + **def_l=NULL; + *def_l=&case_node->node_node_defs; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + case_node->node_strict_node_ids=**strict_node_ids_l; + **strict_node_ids_l=NULL; + *strict_node_ids_l=&case_node->node_strict_node_ids; +#endif + + return case_node; +} + +struct root_and_defs_l { + NodeP ** root_l; + NodeDefP ** def_l; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + StrictNodeIdP **strict_node_ids_l; + NodeDefP ** end_lhs_defs_l; +#endif +}; + +struct root_and_defs { + NodeP root; + NodeDefP defs; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + StrictNodeIdP strict_node_ids; +#endif +}; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +static void add_new_lhs_node_id_to_lhs_node_defs (NodeIdP node_id_p,struct root_and_defs_l *root_and_defs_lp) +{ + NodeDefP new_node_def_p; + + new_node_def_p=CompAllocType (NodeDefS); + + new_node_def_p->def_id=node_id_p; + new_node_def_p->def_mark=0; + new_node_def_p->def_node=node_id_p->nid_node; + + **root_and_defs_lp->end_lhs_defs_l=new_node_def_p; + *root_and_defs_lp->end_lhs_defs_l=&new_node_def_p->def_next; +} +#endif + +static NodeP new_switch_and_case_node (NodeIdP node_id,StateP state_p,SymbolP symbol,int symbol_arity,struct root_and_defs_l *root_and_defs_lp) +{ + NodeP case_node_p; + + case_node_p=new_case_node (symbol,symbol_arity,**root_and_defs_lp->root_l,root_and_defs_lp->def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + return new_switch_node (node_id,case_node_p,state_p,root_and_defs_lp->root_l); +} + +static NodeP new_default_node (NodeP node,NodeDefP node_defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,StrictNodeIdP strict_node_ids +#endif + ) +{ + NodeP default_node; + + default_node=CompAllocType (NodeS); + + default_node->node_kind=DefaultNode; + default_node->node_node_defs=node_defs; + default_node->node_arity=1; + default_node->node_arguments=NewArgument (node); + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + default_node->node_su.su_u.u_case=CompAllocType (CaseNodeContentsS); + default_node->node_strict_node_ids=strict_node_ids; +#endif + + default_node->node_node_id_ref_counts=NULL; + + return default_node; +} + +static NodeP new_push_node (Symbol symbol,int arity,ArgP arguments) +{ + NodeP push_node; + + push_node=CompAllocType (NodeS); + + push_node->node_kind=PushNode; + push_node->node_arity=arity; + push_node->node_arguments=arguments; + push_node->node_record_symbol=symbol; + push_node->node_number=0; /* if !=0 then unique */ + + return push_node; +} + +static NodeP new_guard_node (NodeP if_node,NodeP node,NodeDefP node_defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,StrictNodeIdP strict_node_ids +#endif + ) +{ + NodeP guard_node; + ArgP arg1,arg2; + + guard_node=CompAllocType (NodeS); + + guard_node->node_kind=GuardNode; + guard_node->node_node_defs=node_defs; + guard_node->node_arity=2; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + guard_node->node_guard_strict_node_ids=strict_node_ids; +#endif + + arg1=NewArgument (if_node); + arg2=NewArgument (node); + + guard_node->node_arguments=arg1; + arg1->arg_next=arg2; + + return guard_node; +} + +static void transform_normal_pattern_node (NodeP node,StateP state_p,NodeIdP node_id,struct root_and_defs_l *root_and_defs_lp); + +static void transform_pattern_arguments (SymbolP symbol,ArgP arguments,int arity,NodeIdP node_id,struct root_and_defs_l *root_and_defs_lp) +{ + NodeP push_node; + NodeIdListElementP *last_node_id_p; + ArgP arg,arg1,arg2; + + arg2=NewArgument (**root_and_defs_lp->root_l); + arg1=NewArgument (NULL); + arg1->arg_next=arg2; + + push_node=new_push_node (symbol,arity,arg1); + + **root_and_defs_lp->root_l=push_node; + *root_and_defs_lp->root_l=&arg2->arg_node; + + last_node_id_p=&push_node->node_node_ids; + + for_l (arg,arguments,arg_next){ + NodeIdP argument_node_id; + NodeP node; + + node=arg->arg_node; + if (node->node_kind==NormalNode){ + argument_node_id=NewNodeId (NULL); + argument_node_id->nid_refcount=-1; + + argument_node_id->nid_lhs_state_p_=&arg->arg_state; + + transform_normal_pattern_node (node,&arg->arg_state,argument_node_id,root_and_defs_lp); + } else { +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + NodeP argument_node_id_node; + + argument_node_id=node->node_node_id; + + argument_node_id->nid_lhs_state_p_=&arg->arg_state; + + argument_node_id_node=argument_node_id->nid_node; + if (argument_node_id_node){ + argument_node_id->nid_node=NULL; + transform_normal_pattern_node (argument_node_id_node,&arg->arg_state,argument_node_id,root_and_defs_lp); + } +#else + argument_node_id=node->node_node_id; + if (argument_node_id->nid_node) + transform_normal_pattern_node (argument_node_id->nid_node,&arg->arg_state,argument_node_id,root_and_defs_lp); +#endif + } + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + argument_node_id->nid_state_=arg->arg_state; +#endif + + *last_node_id_p=CompAllocType (NodeIdListElementS); + (*last_node_id_p)->nidl_node_id=argument_node_id; + last_node_id_p=&(*last_node_id_p)->nidl_next; + } + + *last_node_id_p=NULL; + + arg1->arg_node=NewNodeIdNode (node_id); +} + +static void transform_normal_pattern_node (NodeP node,StateP state_p,NodeIdP node_id,struct root_and_defs_l *root_and_defs_lp) +{ + SymbolP symbol; + NodeP switch_node,case_node; + NodeP **root_l; + NodeDefP **def_l; + + symbol=node->node_symbol; + root_l=root_and_defs_lp->root_l; + def_l=root_and_defs_lp->def_l; + + switch (symbol->symb_kind){ + case definition: + case_node=new_case_node (symbol,node->node_arity,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + + if (node->node_arity>0) + transform_pattern_arguments (symbol,node->node_arguments,node->node_arity,node_id,root_and_defs_lp); + + return; + case cons_symb: + case_node=new_case_node (symbol,2,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + transform_pattern_arguments (symbol,node->node_arguments,2,node_id,root_and_defs_lp); + return; + case nil_symb: + case_node=new_case_node (symbol,0,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + return; + case tuple_symb: + case_node=new_case_node (symbol,node->node_arity,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + transform_pattern_arguments (symbol,node->node_arguments,node->node_arity,node_id,root_and_defs_lp); + return; + case apply_symb: + case if_symb: + error_in_function ("transform_normal_pattern_node"); + return; + case string_denot: + case_node=new_case_node (symbol,0,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + return; + default: + if (symbol->symb_kind < Nr_Of_Basic_Types) + error_in_function ("transform_normal_pattern_node"); + else { +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (state_p->state_object==BasicSymbolStates [symbol->symb_kind].state_object){ +#endif + case_node=new_case_node (symbol,0,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + return; +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + } else if (state_p->state_object==UnknownObj +# if ABSTRACT_OBJECT + || state_p->state_object==AbstractObj +# endif + ){ + case_node=new_case_node (symbol,0,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + return; + } else + error_in_function ("transform_normal_pattern_node"); +#endif + } + } +} + +NodeIdRefCountListP new_node_id_ref_count (NodeIdRefCountListP node_id_ref_count_list,NodeIdP node_id,int ref_count) +{ + NodeIdRefCountListP new_node_id_ref_count_elem; + + new_node_id_ref_count_elem=CompAllocType (NodeIdRefCountListS); + + new_node_id_ref_count_elem->nrcl_next=node_id_ref_count_list; + new_node_id_ref_count_elem->nrcl_node_id=node_id; + new_node_id_ref_count_elem->nrcl_ref_count=ref_count; + + return new_node_id_ref_count_elem; +} + +static NodeIdRefCountListP *insert_new_node_id_ref_count (NodeIdRefCountListP *node_id_ref_count_p,NodeIdP node_id,int ref_count) +{ + NodeIdRefCountListP node_id_ref_count_elem; + + node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id,ref_count); + *node_id_ref_count_p=node_id_ref_count_elem; + + return &node_id_ref_count_elem->nrcl_next; +} + +static void remove_aliases_from_node_and_node_definitions (NodeP node_p,NodeDefP node_defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,StrictNodeIdP strict_node_ids +#endif + ); + +static void remove_aliases_from_node (NodeP node) +{ + switch (node->node_kind){ + case NodeIdNode: + { + NodeIdP node_id; + + node_id=node->node_node_id; + if (node_id->nid_mark & NID_ALIAS_MASK) + node->node_node_id=node_id->nid_forward_node_id; + + return; + } + case NormalNode: + case UpdateNode: + { + ArgP arg; + + for_l (arg,node->node_arguments,arg_next) + remove_aliases_from_node (arg->arg_node); + + return; + } + case SelectorNode: + case MatchNode: + remove_aliases_from_node (node->node_arguments->arg_node); + return; + case IfNode: + { + ArgP cond_arg,then_arg; + int local_scope; + + local_scope=node->node_if_scope+2; + + cond_arg=node->node_arguments; + then_arg=cond_arg->arg_next; + + remove_aliases_from_node_and_node_definitions (then_arg->arg_node,node->node_then_node_defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,node->node_then_strict_node_ids +#endif + ); + remove_aliases_from_node_and_node_definitions (then_arg->arg_next->arg_node,node->node_else_node_defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,node->node_else_strict_node_ids +#endif + ); + + remove_aliases_from_node (cond_arg->arg_node); + + return; + } + case PushNode: + { + NodeIdP node_id; + ArgP arguments; + + arguments=node->node_arguments; + + node_id=arguments->arg_node->node_node_id; + if (node_id->nid_mark & NID_ALIAS_MASK) + arguments->arg_node->node_node_id=node_id->nid_forward_node_id; + + remove_aliases_from_node (arguments->arg_next->arg_node); + return; + } + case SwitchNode: + { + NodeIdP node_id; + + node_id=node->node_node_id; + if (node_id->nid_mark & NID_ALIAS_MASK) + node->node_node_id=node_id->nid_forward_node_id; + + remove_aliases_from_node (node->node_arguments->arg_node); + return; + } + case CaseNode: + case DefaultNode: + remove_aliases_from_node_and_node_definitions (node->node_arguments->arg_node,node->node_node_defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,node->node_strict_node_ids +#endif + ); + return; + case TupleSelectorsNode: + remove_aliases_from_node (node->node_node); + return; + default: + error_in_function ("remove_aliases_from_node"); + } +} + +static void remove_aliases_from_node_and_node_definitions (NodeP node_p,NodeDefP node_defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,StrictNodeIdP strict_node_ids +#endif + ) +{ + NodeDefP node_def; + + remove_aliases_from_node (node_p); + + for_l (node_def,node_defs,def_next) + if (node_def->def_node) + remove_aliases_from_node (node_def->def_node); + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + { + StrictNodeIdP strict_node_id_p; + + for_l (strict_node_id_p,strict_node_ids,snid_next){ + NodeIdP node_id; + + node_id=strict_node_id_p->snid_node_id; + if (node_id->nid_mark & NID_ALIAS_MASK) + strict_node_id_p->snid_node_id=node_id->nid_forward_node_id; + } + } +#endif +} + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +static void transform_tuple_or_record_pattern_node (NodeP node,StateP state_p,NodeIdP node_id,struct root_and_defs_l *root_and_defs_lp); + +static void transform_tuple_or_record_pattern_arguments (SymbolP symbol,ArgP arguments,int arity,NodeIdP node_id,struct root_and_defs_l *root_and_defs_lp) +{ + NodeP push_node; + NodeIdListElementP *last_node_id_p; + ArgP arg,arg1,arg2; + + arg2=NewArgument (**root_and_defs_lp->root_l); + arg1=NewArgument (NULL); + arg1->arg_next=arg2; + + push_node=new_push_node (symbol,arity,arg1); + + **root_and_defs_lp->root_l=push_node; + *root_and_defs_lp->root_l=&arg2->arg_node; + + last_node_id_p=&push_node->node_node_ids; + + for_l (arg,arguments,arg_next){ + NodeIdP argument_node_id; + NodeP node; + + node=arg->arg_node; + if (node->node_kind==NormalNode){ + argument_node_id=NewNodeId (NULL); + argument_node_id->nid_refcount=-1; + + argument_node_id->nid_lhs_state_p_=&arg->arg_state; + + arg->arg_node=NewNodeIdNode (argument_node_id); + + if (node->node_symbol->symb_kind==tuple_symb || (node->node_symbol->symb_kind==definition && node->node_symbol->symb_def->sdef_kind==RECORDTYPE)){ + argument_node_id->nid_node=node; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + add_new_lhs_node_id_to_lhs_node_defs (argument_node_id,root_and_defs_lp); +#endif + transform_tuple_or_record_pattern_node (node,&arg->arg_state,argument_node_id,root_and_defs_lp); + } else + transform_normal_pattern_node (node,&arg->arg_state,argument_node_id,root_and_defs_lp); + } else { + argument_node_id=node->node_node_id; + + if (argument_node_id->nid_node){ + SymbolP argument_node_id_node_symbol; + + argument_node_id_node_symbol=argument_node_id->nid_node->node_symbol; + if (argument_node_id_node_symbol->symb_kind==tuple_symb || (argument_node_id_node_symbol->symb_kind==definition && argument_node_id_node_symbol->symb_def->sdef_kind==RECORDTYPE)){ +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + add_new_lhs_node_id_to_lhs_node_defs (argument_node_id,root_and_defs_lp); +#endif + transform_tuple_or_record_pattern_node (argument_node_id->nid_node,&arg->arg_state,argument_node_id,root_and_defs_lp); + } else { + NodeP argument_node_id_node; + + argument_node_id_node=argument_node_id->nid_node; + argument_node_id->nid_node=NULL; + transform_normal_pattern_node (argument_node_id_node,&arg->arg_state,argument_node_id,root_and_defs_lp); + } + } + } + + argument_node_id->nid_state_=arg->arg_state; + + *last_node_id_p=CompAllocType (NodeIdListElementS); + (*last_node_id_p)->nidl_node_id=argument_node_id; + last_node_id_p=&(*last_node_id_p)->nidl_next; + } + + *last_node_id_p=NULL; + + arg1->arg_node=NewNodeIdNode (node_id); +} + +static void transform_tuple_or_record_pattern_node (NodeP node,StateP state_p,NodeIdP node_id,struct root_and_defs_l *root_and_defs_lp) +{ + NodeP switch_node; + + switch_node=new_switch_and_case_node (node_id,state_p,node->node_symbol,node->node_arity,root_and_defs_lp); + transform_tuple_or_record_pattern_arguments (node->node_symbol,node->node_arguments,node->node_arity,node_id,root_and_defs_lp); +} + +static void insert_push_node (SymbolP symbol,ArgP arguments,int arity,NodeIdP node_id,NodeP **root_l) +{ + NodeP push_node; + NodeIdListElementP *last_node_id_p; + ArgP arg,arg1,arg2; + + arg2=NewArgument (**root_l); + arg1=NewArgument (NULL); + arg1->arg_next=arg2; + + push_node=new_push_node (symbol,arity,arg1); + + **root_l=push_node; + *root_l=&arg2->arg_node; + + last_node_id_p=&push_node->node_node_ids; + + for_l (arg,arguments,arg_next){ + NodeIdP argument_node_id; + NodeP node; + + node=arg->arg_node; + argument_node_id=node->node_node_id; + + argument_node_id->nid_state_=arg->arg_state; + + *last_node_id_p=CompAllocType (NodeIdListElementS); + (*last_node_id_p)->nidl_node_id=argument_node_id; + last_node_id_p=&(*last_node_id_p)->nidl_next; + } + + *last_node_id_p=NULL; + + arg1->arg_node=NewNodeIdNode (node_id); +} +#endif + +static void transform_argument (ArgP arg_p,struct root_and_defs_l *root_and_defs_lp) +{ + NodeP node; + + node=arg_p->arg_node; + + switch (node->node_kind){ + case NormalNode: +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (arg_p->arg_state.state_type==TupleState || arg_p->arg_state.state_type==RecordState){ + ArgP arg; + + for_l (arg,node->node_arguments,arg_next) + transform_argument (arg,root_and_defs_lp); + } else +#endif + { + NodeIdP node_id; + + node_id=NewNodeId (NULL); + node_id->nid_refcount=-1; + + node_id->nid_lhs_state_p_=&arg_p->arg_state; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (node->node_symbol->symb_kind==tuple_symb || + (node->node_symbol->symb_kind==definition && node->node_symbol->symb_def->sdef_kind==RECORDTYPE)) + { + node_id->nid_node=node; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + add_new_lhs_node_id_to_lhs_node_defs (node_id,root_and_defs_lp); +#endif + transform_tuple_or_record_pattern_node (node,&arg_p->arg_state,node_id,root_and_defs_lp); + } else +#endif + transform_normal_pattern_node (node,&arg_p->arg_state,node_id,root_and_defs_lp); + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + node_id->nid_state_=arg_p->arg_state; +#endif + arg_p->arg_node=NewNodeIdNode (node_id); + } + break; + case NodeIdNode: + { + NodeIdP node_id; + + node_id=node->node_node_id; + + if (node_id->nid_node!=NULL){ +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + SymbolP node_id_nid_node_symbol; + + node_id_nid_node_symbol=node_id->nid_node->node_symbol; + if (node_id_nid_node_symbol->symb_kind==tuple_symb || + (node_id_nid_node_symbol->symb_kind==definition && node_id_nid_node_symbol->symb_def->sdef_kind==RECORDTYPE)) + { +# ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + add_new_lhs_node_id_to_lhs_node_defs (node_id,root_and_defs_lp); +# endif + transform_tuple_or_record_pattern_node (node_id->nid_node,&arg_p->arg_state,node_id,root_and_defs_lp); + return; + } +#else + if (arg_p->arg_state.state_type==TupleState || arg_p->arg_state.state_type==RecordState){ + ArgP arg; + + for_l (arg,node_id->nid_node->node_arguments,arg_next) + transform_argument (arg,root_and_defs_lp); + } else +#endif + { + transform_normal_pattern_node (node_id->nid_node,&arg_p->arg_state,node_id,root_and_defs_lp); + + node_id->nid_node=NULL; + } + } +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + node_id->nid_lhs_state_p_=&arg_p->arg_state; +#else + node_id->nid_state_=arg_p->arg_state; +#endif + break; + } + default: + error_in_function ("transform_argument"); + } +} + +#if 0 +# include "dbprint.h" +#endif + +static void transform_and_merge_argument (ArgP arg_p,ArgP first_alt_arg_p,struct root_and_defs_l *root_and_defs_lp, + NodeIdRefCountListP **node_id_ref_count_list_h) +{ + NodeP node; + + node=arg_p->arg_node; + + switch (node->node_kind){ + case NormalNode: +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (arg_p->arg_state.state_type==TupleState || arg_p->arg_state.state_type==RecordState){ + ArgP tuple_arg_p,first_alt_tuple_arg_p; + + tuple_arg_p=node->node_arguments; + + if (first_alt_arg_p->arg_node->node_kind==NodeIdNode){ + NodeIdP first_alt_node_id; + + first_alt_node_id=first_alt_arg_p->arg_node->node_node_id; +#if 1 /* added 9-4-1999 */ + *node_id_ref_count_list_h = insert_new_node_id_ref_count (*node_id_ref_count_list_h,first_alt_node_id,-1); +#endif + if (first_alt_node_id->nid_node==NULL){ + first_alt_node_id->nid_node=node; + + for (; tuple_arg_p!=NULL; tuple_arg_p=tuple_arg_p->arg_next) + transform_argument (tuple_arg_p,root_and_defs_lp); + + return; + } else + first_alt_tuple_arg_p=first_alt_node_id->nid_node->node_arguments; + } else + first_alt_tuple_arg_p=first_alt_arg_p->arg_node->node_arguments; + + for (; tuple_arg_p!=NULL; tuple_arg_p=tuple_arg_p->arg_next,first_alt_tuple_arg_p=first_alt_tuple_arg_p->arg_next) + transform_and_merge_argument (tuple_arg_p,first_alt_tuple_arg_p,root_and_defs_lp,node_id_ref_count_list_h); + } else +#endif + { + NodeIdP first_alt_node_id; + + first_alt_node_id=first_alt_arg_p->arg_node->node_node_id; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (node->node_symbol->symb_kind==tuple_symb || + (node->node_symbol->symb_kind==definition && node->node_symbol->symb_def->sdef_kind==RECORDTYPE)) + { + if (first_alt_node_id->nid_node!=NULL){ + ArgP tuple_arg_p,first_alt_tuple_arg_p; + NodeP switch_node; + + switch_node=new_switch_and_case_node (first_alt_node_id,&arg_p->arg_state,node->node_symbol,node->node_arity,root_and_defs_lp); + + tuple_arg_p=node->node_arguments; + first_alt_tuple_arg_p=first_alt_node_id->nid_node->node_arguments; + + insert_push_node (node->node_symbol,first_alt_tuple_arg_p,node->node_arity,first_alt_node_id,root_and_defs_lp->root_l); + + for (; tuple_arg_p!=NULL; tuple_arg_p=tuple_arg_p->arg_next,first_alt_tuple_arg_p=first_alt_tuple_arg_p->arg_next) + transform_and_merge_argument (tuple_arg_p,first_alt_tuple_arg_p,root_and_defs_lp,node_id_ref_count_list_h); + } else { + first_alt_node_id->nid_node=node; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + add_new_lhs_node_id_to_lhs_node_defs (first_alt_node_id,root_and_defs_lp); +#endif + transform_tuple_or_record_pattern_node (node,&arg_p->arg_state,first_alt_node_id,root_and_defs_lp); + } + } else +#endif + { + transform_normal_pattern_node (node,&arg_p->arg_state,first_alt_node_id,root_and_defs_lp); +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + first_alt_node_id->nid_node=NULL; +#endif + } + /* JVG: added 4-10-95 */ + ++first_alt_node_id->nid_refcount; + /* */ + /* JVG: added 4 april 95 */ + *node_id_ref_count_list_h = insert_new_node_id_ref_count (*node_id_ref_count_list_h,first_alt_node_id,-2); + /* */ + } + return; + case NodeIdNode: + { + NodeId node_id; + + node_id=node->node_node_id; + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (arg_p->arg_state.state_type==TupleState || arg_p->arg_state.state_type==RecordState){ + if (node_id->nid_node==NULL){ + if (first_alt_arg_p->arg_node->node_kind==NodeIdNode){ + NodeId first_alt_node_id; + + first_alt_node_id=first_alt_arg_p->arg_node->node_node_id; +# if 1 /* added 8-4-1999 */ + *node_id_ref_count_list_h = insert_new_node_id_ref_count (*node_id_ref_count_list_h,first_alt_node_id,node_id->nid_refcount); +# else + first_alt_node_id->nid_refcount += node_id->nid_refcount+1; +# endif + node_id->nid_mark |= NID_ALIAS_MASK; + node_id->nid_forward_node_id_=first_alt_node_id; + } else { + NodeP node; + + node=first_alt_arg_p->arg_node; + node_id->nid_node=node; + first_alt_arg_p->arg_node=arg_p->arg_node; + +# ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + node_id->nid_state_=arg_p->arg_state; +# endif + } + } else { + ArgP tuple_arg_p,first_alt_tuple_arg_p; + + if (first_alt_arg_p->arg_node->node_kind==NodeIdNode){ + NodeIdP first_alt_node_id; + + first_alt_node_id=first_alt_arg_p->arg_node->node_node_id; +# if 1 /* added 20-4-1999 */ + *node_id_ref_count_list_h = insert_new_node_id_ref_count (*node_id_ref_count_list_h,first_alt_node_id,node_id->nid_refcount); +# else + first_alt_node_id->nid_refcount += node_id->nid_refcount+1; +# endif + node_id->nid_mark |= NID_ALIAS_MASK; + node_id->nid_forward_node_id_=first_alt_node_id; + + if (first_alt_node_id->nid_node==NULL){ + ArgP tuple_arg_p; + + first_alt_node_id->nid_node=node_id->nid_node; + + tuple_arg_p=node_id->nid_node->node_arguments; + + for (; tuple_arg_p!=NULL; tuple_arg_p=tuple_arg_p->arg_next) + transform_argument (tuple_arg_p,root_and_defs_lp); + + return; + } else { + tuple_arg_p=node_id->nid_node->node_arguments; + first_alt_tuple_arg_p=first_alt_node_id->nid_node->node_arguments; + } + } else { + tuple_arg_p=node_id->nid_node->node_arguments; + first_alt_tuple_arg_p=first_alt_arg_p->arg_node->node_arguments; + + node_id->nid_node=first_alt_arg_p->arg_node; + first_alt_arg_p->arg_node=arg_p->arg_node; +# ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + node_id->nid_state_=arg_p->arg_state; +# endif + } + + for (; tuple_arg_p!=NULL; tuple_arg_p=tuple_arg_p->arg_next,first_alt_tuple_arg_p=first_alt_tuple_arg_p->arg_next) + transform_and_merge_argument (tuple_arg_p,first_alt_tuple_arg_p,root_and_defs_lp,node_id_ref_count_list_h); + + return; + } + } else +#endif + { + NodeIdP first_alt_node_id; + + first_alt_node_id=first_alt_arg_p->arg_node->node_node_id; + + node_id->nid_mark |= NID_ALIAS_MASK; + node_id->nid_forward_node_id_=first_alt_node_id; + + if (node_id->nid_node!=NULL){ +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + SymbolP node_id_nid_node_symbol; + + node_id_nid_node_symbol=node_id->nid_node->node_symbol; + + if (node_id_nid_node_symbol->symb_kind==tuple_symb || + (node_id_nid_node_symbol->symb_kind==definition && node_id_nid_node_symbol->symb_def->sdef_kind==RECORDTYPE)) + { + if (first_alt_node_id->nid_node!=NULL){ + ArgP tuple_arg_p,first_alt_tuple_arg_p; + NodeP switch_node; + + switch_node=new_switch_and_case_node (first_alt_node_id,&arg_p->arg_state,first_alt_node_id->nid_node->node_symbol,first_alt_node_id->nid_node->node_arity,root_and_defs_lp); + + tuple_arg_p=node_id->nid_node->node_arguments; + first_alt_tuple_arg_p=first_alt_node_id->nid_node->node_arguments; + + insert_push_node (first_alt_node_id->nid_node->node_symbol,first_alt_tuple_arg_p,first_alt_node_id->nid_node->node_arity,first_alt_node_id,root_and_defs_lp->root_l); + + for (; tuple_arg_p!=NULL; tuple_arg_p=tuple_arg_p->arg_next,first_alt_tuple_arg_p=first_alt_tuple_arg_p->arg_next) + transform_and_merge_argument (tuple_arg_p,first_alt_tuple_arg_p,root_and_defs_lp,node_id_ref_count_list_h); + } else { + first_alt_node_id->nid_node=node_id->nid_node; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + add_new_lhs_node_id_to_lhs_node_defs (first_alt_node_id,root_and_defs_lp); +#endif + transform_tuple_or_record_pattern_node (node_id->nid_node,&arg_p->arg_state,first_alt_node_id,root_and_defs_lp); + } + ++first_alt_node_id->nid_refcount; + *node_id_ref_count_list_h = insert_new_node_id_ref_count (*node_id_ref_count_list_h,first_alt_node_id,node_id->nid_refcount-1); + return; + } else +#endif + { + transform_normal_pattern_node (node_id->nid_node,&arg_p->arg_state,node_id,root_and_defs_lp); +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + first_alt_node_id->nid_node=NULL; +#endif + } + } + + *node_id_ref_count_list_h = insert_new_node_id_ref_count (*node_id_ref_count_list_h,first_alt_node_id,node_id->nid_refcount); + } + return; + } + default: + error_in_function ("transform_and_merge_argument"); + } +} + +static NodeIdRefCountListP copy_node_id_ref_count_list (NodeIdRefCountListP node_id_ref_count_list) +{ + NodeIdRefCountListP node_id_ref_count_elem,new_node_id_ref_count_list,*new_node_id_ref_count_list_p; + + new_node_id_ref_count_list_p=&new_node_id_ref_count_list; + + for_l (node_id_ref_count_elem,node_id_ref_count_list,nrcl_next){ + NodeIdRefCountListP new_node_id_ref_count_elem; + NodeIdP node_id; + + node_id=node_id_ref_count_elem->nrcl_node_id; + + new_node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id,node_id->nid_refcount); + + *new_node_id_ref_count_list_p=new_node_id_ref_count_elem; + new_node_id_ref_count_list_p=&new_node_id_ref_count_elem->nrcl_next; + +#if DEBUG_OUTPUT + printf ("copy %s %d %d ",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_elem->nrcl_ref_count); +#endif + node_id->nid_refcount += node_id_ref_count_elem->nrcl_ref_count+1; + } + +#if DEBUG_OUTPUT + printf ("\n"); +#endif + + *new_node_id_ref_count_list_p=NULL; + + return new_node_id_ref_count_list; +} + +static void increment_ref_counts_of_node_id_ref_count_list (NodeIdRefCountListP node_id_ref_count_list) +{ + NodeIdRefCountListP node_id_ref_count_elem; + + for_l (node_id_ref_count_elem,node_id_ref_count_list,nrcl_next){ +#if DEBUG_OUTPUT + { + NodeIdP node_id; + + node_id=node_id_ref_count_elem->nrcl_node_id; + + printf ("increment %s %d %d ",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_elem->nrcl_ref_count); + } +#endif + node_id_ref_count_elem->nrcl_node_id->nid_refcount += node_id_ref_count_elem->nrcl_ref_count+1; + } + +#if DEBUG_OUTPUT + printf ("\n"); +#endif +} + +static void replace_global_ref_count_by_local_ref_count (NodeIdRefCountListP node_id_ref_count_list) +{ + NodeIdRefCountListP node_id_ref_count_elem; + + for_l (node_id_ref_count_elem,node_id_ref_count_list,nrcl_next){ + int local_ref_count; + NodeIdP node_id; + + node_id=node_id_ref_count_elem->nrcl_node_id; + local_ref_count=node_id_ref_count_elem->nrcl_ref_count; + +#if DEBUG_OUTPUT + printf ("global_to_local %s %d %d ",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_elem->nrcl_ref_count); +#endif + + node_id_ref_count_elem->nrcl_ref_count=node_id->nid_refcount - local_ref_count; + node_id->nid_refcount = local_ref_count; + } + +#if DEBUG_OUTPUT + printf ("\n"); +#endif +} + +void set_local_reference_counts (NodeP case_node) +{ + replace_global_ref_count_by_local_ref_count (case_node->node_node_id_ref_counts); +} + +static void replace_local_ref_count_by_global_ref_count (NodeIdRefCountListP node_id_ref_count_list) +{ + NodeIdRefCountListP node_id_ref_count_elem; + + for_l (node_id_ref_count_elem,node_id_ref_count_list,nrcl_next){ + int local_ref_count; + NodeIdP node_id; + + node_id=node_id_ref_count_elem->nrcl_node_id; + local_ref_count=node_id->nid_refcount; + +#if DEBUG_OUTPUT + printf ("local_to_global %s %d %d ",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_elem->nrcl_ref_count); +#endif + + node_id->nid_refcount = local_ref_count + node_id_ref_count_elem->nrcl_ref_count; + node_id_ref_count_elem->nrcl_ref_count=local_ref_count; + } + +#if DEBUG_OUTPUT + printf ("\n"); +#endif +} + +void set_global_reference_counts (NodeP case_node) +{ + replace_local_ref_count_by_global_ref_count (case_node->node_node_id_ref_counts); +} + +static NodeP merge_alternative_with_node (NodeP root,struct root_and_defs *root_and_defs_p,NodeIdRefCountListP node_id_ref_count_list); + + static void decrement_reference_count_of_switch_node_id (NodeIdP root_node_id,NodeIdRefCountListP node_id_ref_count_list) + { + NodeIdRefCountListP node_id_ref_count_elem; + + for_l (node_id_ref_count_elem,node_id_ref_count_list,nrcl_next) + if (node_id_ref_count_elem->nrcl_node_id==root_node_id){ +#if DEBUG_OUTPUT + printf ("inc %s %d %d\n",node_id_name (root_node_id),root_node_id->nid_refcount,node_id_ref_count_elem->nrcl_ref_count); +#endif + ++node_id_ref_count_elem->nrcl_ref_count; + break; + } + if (node_id_ref_count_elem==NULL){ + /* possibly less efficient code if this happens */ + } + } + + static void merge_alternative_with_switch_node (NodeP root,struct root_and_defs *root_and_defs_p,NodeIdRefCountListP node_id_ref_count_list) + { + NodeP default_node,node; + ArgP *arg_p,arg; + + node=root_and_defs_p->root; + + for (arg_p=&root->node_arguments; arg=*arg_p,arg!=NULL; arg_p=&arg->arg_next){ + NodeP case_node; + + case_node=arg->arg_node; + + switch (case_node->node_kind){ + case CaseNode: + break; + case DefaultNode: + ++root->node_node_id->nid_refcount; + replace_global_ref_count_by_local_ref_count (case_node->node_node_id_ref_counts); + + case_node->node_arguments->arg_node + = merge_alternative_with_node (case_node->node_arguments->arg_node,root_and_defs_p,node_id_ref_count_list); + + replace_local_ref_count_by_global_ref_count (case_node->node_node_id_ref_counts); + --root->node_node_id->nid_refcount; + return; + default: + error_in_function ("merge_alternative_with_switch_node"); + } + } + + ++root->node_node_id->nid_refcount; + + default_node=new_default_node (node,root_and_defs_p->defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_p->strict_node_ids +#endif + ); + default_node->node_node_id_ref_counts= node_id_ref_count_list; + + if (root->node_arguments->arg_next==NULL) /* only one case or default ? */ + root->node_arguments->arg_node->node_node_id_ref_counts=copy_node_id_ref_count_list (node_id_ref_count_list); + else + increment_ref_counts_of_node_id_ref_count_list (node_id_ref_count_list); + + *arg_p=NewArgument (default_node); + + remove_aliases_from_node_and_node_definitions (root_and_defs_p->root,root_and_defs_p->defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_p->strict_node_ids +#endif + ); + + --root->node_node_id->nid_refcount; + } + + static void merge_switch_alternative_with_switch_node (NodeP root,struct root_and_defs *root_and_defs_p,NodeIdRefCountListP node_id_ref_count_list) + { + ArgP *arg_p,arg; + NodeP case_node; + + for (arg_p=&root->node_arguments; arg=*arg_p,arg!=NULL; arg_p=&arg->arg_next){ + NodeP case_arg_node; + + case_arg_node=arg->arg_node; + + switch (case_arg_node->node_kind){ + case CaseNode: + break; + case DefaultNode: + ++root->node_node_id->nid_refcount; + replace_global_ref_count_by_local_ref_count (case_arg_node->node_node_id_ref_counts); + + case_arg_node->node_arguments->arg_node= merge_alternative_with_node + (case_arg_node->node_arguments->arg_node,root_and_defs_p,node_id_ref_count_list); + + replace_local_ref_count_by_global_ref_count (case_arg_node->node_node_id_ref_counts); + --root->node_node_id->nid_refcount; + return; + default: + error_in_function ("merge_switch_alternative_with_switch_node"); + } + } + + case_node=root_and_defs_p->root->node_arguments->arg_node; + + for (arg_p=&root->node_arguments; arg=*arg_p,arg!=NULL; arg_p=&arg->arg_next){ + NodeP case_arg_node; + + case_arg_node=arg->arg_node; + + switch (case_arg_node->node_kind){ + case CaseNode: + { + struct root_and_defs case_root_and_defs; + + if (case_arg_node->node_arity!=case_node->node_arity) + break; + else { + if (case_arg_node->node_symbol==case_node->node_symbol){ + if (case_node->node_symbol->symb_kind==real_denot){ + merge_alternative_with_switch_node (root,root_and_defs_p,node_id_ref_count_list); + return; + } + } else { + int symbol_kind; + + symbol_kind=case_node->node_symbol->symb_kind; + if (symbol_kind==int_denot || symbol_kind==char_denot || symbol_kind==string_denot){ + if (strcmp (case_arg_node->node_symbol->symb_int,case_node->node_symbol->symb_int)!=0) + break; + } else + break; + } + } + + decrement_reference_count_of_switch_node_id (root->node_node_id,node_id_ref_count_list); + ++root->node_node_id->nid_refcount; + + replace_global_ref_count_by_local_ref_count (case_arg_node->node_node_id_ref_counts); + + case_root_and_defs.root=case_node->node_arguments->arg_node; + case_root_and_defs.defs=case_node->node_node_defs; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + case_root_and_defs.strict_node_ids=case_node->node_strict_node_ids; +#endif + case_arg_node->node_arguments->arg_node = merge_alternative_with_node + (case_arg_node->node_arguments->arg_node,&case_root_and_defs,node_id_ref_count_list); + case_node->node_node_defs=NULL; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + case_node->node_strict_node_ids=NULL; +#endif + + replace_local_ref_count_by_global_ref_count (case_arg_node->node_node_id_ref_counts); + --root->node_node_id->nid_refcount; + + return; + } + } + } + + decrement_reference_count_of_switch_node_id (root->node_node_id,node_id_ref_count_list); + ++root->node_node_id->nid_refcount; + + case_node->node_node_id_ref_counts= node_id_ref_count_list; + + if (root->node_arguments->arg_next==NULL) /* only one case or default ? */ + root->node_arguments->arg_node->node_node_id_ref_counts=copy_node_id_ref_count_list (node_id_ref_count_list); + else + increment_ref_counts_of_node_id_ref_count_list (node_id_ref_count_list); + + *arg_p=NewArgument (case_node); + + remove_aliases_from_node_and_node_definitions (case_node,root_and_defs_p->defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_p->strict_node_ids +#endif + ); + + --root->node_node_id->nid_refcount; + } + +#define SEARCH_SWITCH 1 + +static NodeP merge_alternative_with_node (NodeP root,struct root_and_defs *root_and_defs_p,NodeIdRefCountListP node_id_ref_count_list) +{ + NodeP node; + + node=root_and_defs_p->root; + + switch (root->node_kind){ + case SwitchNode: + { + NodeIdP node_id; + struct root_and_defs root_and_defs; + + if (node->node_kind!=SwitchNode){ + merge_alternative_with_switch_node (root,root_and_defs_p,node_id_ref_count_list); + return root; + } + + root_and_defs=*root_and_defs_p; + + node_id=node->node_node_id; + + if (node_id->nid_mark & NID_ALIAS_MASK){ + node_id=node_id->nid_forward_node_id; + node->node_node_id=node_id; + } + +#if SEARCH_SWITCH + if (node_id!=root->node_node_id){ + NodeP next_switch_node,*next_switch_node_p,case_node; + NodeIdP next_node_id; + + next_switch_node=node; + do { + case_node=next_switch_node->node_arguments->arg_node; + next_switch_node_p=&case_node->node_arguments->arg_node; + next_switch_node=*next_switch_node_p; + + if (next_switch_node->node_kind==PushNode){ + next_switch_node_p=&next_switch_node->node_arguments->arg_next->arg_node; + next_switch_node=*next_switch_node_p; + } + + if (next_switch_node->node_kind!=SwitchNode) + break; + + next_node_id=next_switch_node->node_node_id; + + if (next_node_id->nid_mark & NID_ALIAS_MASK) + next_node_id=next_node_id->nid_forward_node_id; + } while (next_node_id!=root->node_node_id); + + if (next_switch_node->node_kind==SwitchNode && next_node_id==root->node_node_id){ + NodeP next_case_node,*node_p; + + next_case_node=next_switch_node->node_arguments->arg_node; + node_p=&next_case_node->node_arguments->arg_node; + + if ((*node_p)->node_kind==PushNode) + node_p=&(*node_p)->node_arguments->arg_next->arg_node; + + if (next_case_node->node_node_defs!=NULL){ + if (case_node->node_node_defs!=NULL) + error_in_function ("merge_alternative_with_node"); + + case_node->node_node_defs=next_case_node->node_node_defs; + next_case_node->node_node_defs=NULL; + } +# ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (next_case_node->node_strict_node_ids!=NULL){ + if (case_node->node_strict_node_ids!=NULL) + error_in_function ("merge_alternative_with_node"); + + case_node->node_strict_node_ids=next_case_node->node_strict_node_ids; + next_case_node->node_strict_node_ids=NULL; + } +# endif + + *next_switch_node_p=*node_p; + *node_p=node; + node=next_switch_node; + + next_switch_node->node_node_id=next_node_id; + node_id=next_node_id; + } + } +#endif + + root_and_defs.root=node; + + if (node_id==root->node_node_id) + merge_switch_alternative_with_switch_node (root,&root_and_defs,node_id_ref_count_list); + else + merge_alternative_with_switch_node (root,&root_and_defs,node_id_ref_count_list); + + return root; + } + case PushNode: + { + ArgP node_arguments,root_arguments; + NodeIdP node_id; + NodeIdListElementP root_node_id_list,node_id_list; + struct root_and_defs root_and_defs; + + root_and_defs=*root_and_defs_p; + + node_arguments=node->node_arguments; + root_arguments=root->node_arguments; + + if (node->node_kind!=PushNode) + error_in_function ("merge_alternative_with_node"); + + node_id=node_arguments->arg_node->node_node_id; + if (node_id->nid_mark & NID_ALIAS_MASK){ + node_id=node_id->nid_forward_node_id; + node_arguments->arg_node->node_node_id=node_id; + } + + if (root_arguments->arg_node->node_node_id!=node_id) + error_in_function ("merge_alternative_with_node"); + + root_node_id_list=root->node_node_ids; + node_id_list=node->node_node_ids; + + while (root_node_id_list!=NULL){ + NodeIdP node_id,root_node_id; + + root_node_id=root_node_id_list->nidl_node_id; + node_id=node_id_list->nidl_node_id; + + if (node_id!=root_node_id){ + node_id_ref_count_list=new_node_id_ref_count (node_id_ref_count_list,root_node_id,node_id->nid_refcount); + + node_id->nid_mark |= NID_ALIAS_MASK; + node_id->nid_forward_node_id_=root_node_id; + } + + root_node_id_list=root_node_id_list->nidl_next; + node_id_list=node_id_list->nidl_next; + } + + root_and_defs.root=node_arguments->arg_next->arg_node; + + root_arguments->arg_next->arg_node=merge_alternative_with_node + (root_arguments->arg_next->arg_node,&root_and_defs,node_id_ref_count_list); + + return root; + } + case GuardNode: + root->node_arguments->arg_next->arg_node=merge_alternative_with_node + (root->node_arguments->arg_next->arg_node,root_and_defs_p,node_id_ref_count_list); + + return root; + case IfNode: + { + NodeP else_node; + + else_node=root->node_arguments->arg_next->arg_next->arg_node; + while (else_node->node_kind==IfNode) + else_node=else_node->node_arguments->arg_next->arg_next->arg_node; + + if (else_node->node_kind==NormalNode && else_node->node_symbol->symb_kind==fail_symb){ + NodeP guard_node; + + increment_ref_counts_of_node_id_ref_count_list (node_id_ref_count_list); + + guard_node=new_guard_node (root,root_and_defs_p->root,root_and_defs_p->defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_p->strict_node_ids +#endif + ); + + remove_aliases_from_node_and_node_definitions (node,root_and_defs_p->defs +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_p->strict_node_ids +#endif + ); + + return guard_node; + } else + break; + } + } + + StaticMessage (False, "%S", "pattern will never match", CurrentSymbol); + + return root; +} + +static void merge_node_id_ref_count_lists (NodeIdRefCountListP *list1_p,NodeIdRefCountListP list2) +{ + while (list2!=NULL){ + NodeIdP node_id; + NodeIdRefCountListP next_list2,list1; + + node_id=list2->nrcl_node_id; + + while (list1=*list1_p,list1!=NULL && list1->nrcl_node_id<=node_id) + list1_p=&list1->nrcl_next; + + if (list1==NULL){ + *list1_p=list2; + return; + } + + next_list2=list2->nrcl_next; + + *list1_p=list2; + list2->nrcl_next=list1; + list1_p=&list2->nrcl_next; + + list2=next_list2; + } +} + +static void sort_node_id_ref_count_lists (NodeIdRefCountListP *list_p) +{ + NodeIdRefCountListP element1,element2,element3; + + element1=*list_p; + if (element1==NULL) + return; + + element2=element1->nrcl_next; + if (element2==NULL) + return; + + element3=element2->nrcl_next; + if (element3==NULL){ + if (element1->nrcl_node_id<=element2->nrcl_node_id) + return; + + *list_p=element2; + element2->nrcl_next=element1; + element1->nrcl_next=NULL; + } else { + NodeIdRefCountListP list2,end_list1,end_list2; + + list2=element2; + end_list1=element1; + end_list2=element2; + + element1=element3; + do { + end_list1->nrcl_next=element1; + end_list1=element1; + + element2=element1->nrcl_next; + if (element2==NULL) + break; + + end_list2->nrcl_next=element2; + end_list2=element2; + + element1=element2->nrcl_next; + } while (element1!=NULL); + + end_list1->nrcl_next=NULL; + end_list2->nrcl_next=NULL; + + sort_node_id_ref_count_lists (list_p); + sort_node_id_ref_count_lists (&list2); + + merge_node_id_ref_count_lists (list_p,list2); + } +} + +static void add_sorted_node_id_ref_count_list (NodeIdRefCountListP *node_id_ref_count_list1_p,NodeIdRefCountListP node_id_ref_count_list2) +{ + NodeIdRefCountListP node_id_ref_count_list1; + + while (node_id_ref_count_list2!=NULL){ + NodeIdP node_id; + + node_id=node_id_ref_count_list2->nrcl_node_id; + + while (node_id_ref_count_list1=*node_id_ref_count_list1_p,node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id<node_id) + node_id_ref_count_list1_p=&node_id_ref_count_list1->nrcl_next; + + if (node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id==node_id){ + +#if DEBUG_OUTPUT + printf ("add %s %d %d %d\n",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_list1->nrcl_ref_count,node_id_ref_count_list2->nrcl_ref_count); +#endif + + node_id_ref_count_list1->nrcl_ref_count += node_id_ref_count_list2->nrcl_ref_count+1; + node_id_ref_count_list1_p=&node_id_ref_count_list1->nrcl_next; + } else { + NodeIdRefCountListP new_node_id_ref_count_elem; + +#if DEBUG_OUTPUT + printf ("addnew %s %d %d\n",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_list2->nrcl_ref_count); +#endif + + new_node_id_ref_count_elem=new_node_id_ref_count (node_id_ref_count_list1,node_id_ref_count_list2->nrcl_node_id,node_id_ref_count_list2->nrcl_ref_count); + + *node_id_ref_count_list1_p=new_node_id_ref_count_elem; + node_id_ref_count_list1_p=&new_node_id_ref_count_elem->nrcl_next; + } + + node_id_ref_count_list2=node_id_ref_count_list2->nrcl_next; + } +} + +/* JVG added 16-2-2000 */ +static void add_sorted_node_id_ref_count_list_for_case (NodeIdRefCountListP *node_id_ref_count_list1_p,NodeIdRefCountListP node_id_ref_count_list2) +{ + NodeIdRefCountListP node_id_ref_count_list1; + + while (node_id_ref_count_list2!=NULL){ + NodeIdP node_id; + + node_id=node_id_ref_count_list2->nrcl_node_id; + + while (node_id_ref_count_list1=*node_id_ref_count_list1_p,node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id<node_id) + node_id_ref_count_list1_p=&node_id_ref_count_list1->nrcl_next; + + if (node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id==node_id){ + +#if DEBUG_OUTPUT + printf ("add %s %d %d %d\n",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_list1->nrcl_ref_count,node_id_ref_count_list2->nrcl_ref_count); +#endif + + node_id_ref_count_list1->nrcl_ref_count += node_id_ref_count_list2->nrcl_ref_count+1; + node_id_ref_count_list1_p=&node_id_ref_count_list1->nrcl_next; + } /* else do nothing*/ + + node_id_ref_count_list2=node_id_ref_count_list2->nrcl_next; + } +} +/**/ + +/* + static NodeIdRefCountListP merge_sorted_node_id_ref_count_lists + (NodeIdRefCountListP node_id_ref_count_list1,NodeIdRefCountListP node_id_ref_count_list2) + { + NodeIdRefCountListP node_id_ref_count_list,*node_id_ref_count_list_p; + + node_id_ref_count_list_p=&node_id_ref_count_list; + + while (node_id_ref_count_list2!=NULL){ + NodeIdP node_id; + + node_id=node_id_ref_count_list2->nrcl_node_id; + + while (node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id<node_id){ + NodeIdRefCountListP new_node_id_ref_count_elem; + + #if DEBUG_OUTPUT + { + char *node_id_name; + + node_id_name=""; + if (node_id_ref_count_list1->nrcl_node_id->nid_ident!=NULL && node_id_ref_count_list1->nrcl_node_id->nid_ident->ident_name!=NULL) + node_id_name=node_id_ref_count_list1->nrcl_node_id->nid_ident->ident_name; + + printf ("from1 %s %d %d\n",node_id_name,node_id_ref_count_list1->nrcl_node_id->nid_refcount,node_id_ref_count_list1->nrcl_ref_count); + } + #endif + + new_node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id_ref_count_list1->nrcl_node_id,node_id_ref_count_list1->nrcl_ref_count); + + *node_id_ref_count_list_p=new_node_id_ref_count_elem; + node_id_ref_count_list_p=&new_node_id_ref_count_elem->nrcl_next; + + node_id_ref_count_list1=node_id_ref_count_list1->nrcl_next; + } + + if (node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id==node_id){ + NodeIdRefCountListP new_node_id_ref_count_elem; + + #if DEBUG_OUTPUT + { + char *node_id_name; + + node_id_name=""; + if (node_id->nid_ident!=NULL && node_id->nid_ident->ident_name!=NULL) + node_id_name=node_id->nid_ident->ident_name; + + printf ("combine %s %d %d\n",node_id_name,node_id_ref_count_list1->nrcl_node_id->nid_refcount,node_id_ref_count_list2->nrcl_ref_count); + } + #endif + + new_node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id, + node_id_ref_count_list1->nrcl_ref_count+node_id_ref_count_list2->nrcl_ref_count+1); + + *node_id_ref_count_list_p=new_node_id_ref_count_elem; + node_id_ref_count_list_p=&new_node_id_ref_count_elem->nrcl_next; + + node_id_ref_count_list1=node_id_ref_count_list1->nrcl_next; + } else { + NodeIdRefCountListP new_node_id_ref_count_elem; + + #if DEBUG_OUTPUT + { + char *node_id_name; + + node_id_name=""; + if (node_id_ref_count_list2->nrcl_node_id->nid_ident!=NULL && node_id_ref_count_list2->nrcl_node_id->nid_ident->ident_name!=NULL) + node_id_name=node_id_ref_count_list2->nrcl_node_id->nid_ident->ident_name; + + printf ("from2 %s %d %d\n",node_id_name,node_id_ref_count_list2->nrcl_node_id->nid_refcount,node_id_ref_count_list2->nrcl_ref_count); + } + #endif + + new_node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id_ref_count_list2->nrcl_node_id,node_id_ref_count_list2->nrcl_ref_count); + + *node_id_ref_count_list_p=new_node_id_ref_count_elem; + node_id_ref_count_list_p=&new_node_id_ref_count_elem->nrcl_next; + } + + node_id_ref_count_list2=node_id_ref_count_list2->nrcl_next; + } + + while (node_id_ref_count_list1!=NULL){ + NodeIdRefCountListP new_node_id_ref_count_elem; + + #if DEBUG_OUTPUT + { + char *node_id_name; + + node_id_name=""; + if (node_id_ref_count_list1->nrcl_node_id->nid_ident!=NULL && node_id_ref_count_list1->nrcl_node_id->nid_ident->ident_name!=NULL) + node_id_name=node_id_ref_count_list1->nrcl_node_id->nid_ident->ident_name; + + printf ("from1 %s %d %d\n",node_id_name,node_id_ref_count_list1->nrcl_node_id->nid_refcount,node_id_ref_count_list1->nrcl_ref_count); + } + #endif + + new_node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id_ref_count_list1->nrcl_node_id,node_id_ref_count_list1->nrcl_ref_count); + + *node_id_ref_count_list_p=new_node_id_ref_count_elem; + node_id_ref_count_list_p=&new_node_id_ref_count_elem->nrcl_next; + + node_id_ref_count_list1=node_id_ref_count_list1->nrcl_next; + } + + *node_id_ref_count_list_p=NULL; + + return node_id_ref_count_list; + } +*/ + +static NodeIdRefCountListP duplicate_node_id_ref_count_list (NodeIdRefCountListP node_id_ref_count_list) +{ + NodeIdRefCountListP node_id_ref_count_elem,new_node_id_ref_count_list,*new_node_id_ref_count_list_p; + + new_node_id_ref_count_list_p=&new_node_id_ref_count_list; + + for (node_id_ref_count_elem=node_id_ref_count_list; node_id_ref_count_elem!=NULL; node_id_ref_count_elem=node_id_ref_count_elem->nrcl_next){ + NodeIdRefCountListP new_node_id_ref_count_elem; + + new_node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id_ref_count_elem->nrcl_node_id,node_id_ref_count_elem->nrcl_ref_count); + +#if DEBUG_OUTPUT + printf ("duplicate %s %d %d\n",node_id_name (node_id_ref_count_elem->nrcl_node_id),node_id_ref_count_elem->nrcl_node_id->nid_refcount,node_id_ref_count_elem->nrcl_ref_count); +#endif + + *new_node_id_ref_count_list_p=new_node_id_ref_count_elem; + new_node_id_ref_count_list_p=&new_node_id_ref_count_elem->nrcl_next; + } + + *new_node_id_ref_count_list_p=NULL; + + return new_node_id_ref_count_list; +} + +static int determine_failing_cases_and_adjust_ref_counts (NodeP node,NodeIdRefCountListP *node_id_ref_count_list_p) +{ + switch (node->node_kind){ + case SwitchNode: + { + ArgP arg; + int switch_may_fail,default_may_fail; + int node_id_ref_count_list_sorted; + + node_id_ref_count_list_sorted=0; + + for (arg=node->node_arguments; arg!=NULL; arg=arg->arg_next) + if (arg->arg_node->node_kind!=CaseNode) + break; + + default_may_fail=1; + + if (arg!=NULL){ + NodeP arg_node; + + arg_node=arg->arg_node; + + if (arg_node->node_kind!=DefaultNode) + error_in_function ("determine_failing_cases_and_adjust_ref_counts"); + + default_may_fail=determine_failing_cases_and_adjust_ref_counts (arg_node->node_arguments->arg_node,node_id_ref_count_list_p); + arg_node->node_number=default_may_fail; + + if (default_may_fail){ + /* NodeP default_rhs_node; */ + + sort_node_id_ref_count_lists (&arg_node->node_node_id_ref_counts); + + if (!node_id_ref_count_list_sorted){ + sort_node_id_ref_count_lists (node_id_ref_count_list_p); + node_id_ref_count_list_sorted=1; + } + + /* JVG: maybe incorrect, optimisation: find simple case which can not fail and set node_id_refcounts + default_rhs_node=arg_node->node_arguments->arg_node; + + if (default_rhs_node->node_kind==PushNode) + default_rhs_node=default_rhs_node->node_arguments->arg_next->arg_node; + + if (default_rhs_node->node_kind==SwitchNode && default_rhs_node->node_arguments->arg_next==NULL) + default_rhs_node->node_arguments->arg_node->node_node_id_ref_counts + = duplicate_node_id_ref_count_list (arg_node->node_node_id_ref_counts); + */ + + add_sorted_node_id_ref_count_list (&arg_node->node_node_id_ref_counts,*node_id_ref_count_list_p); + node_id_ref_count_list_p=&arg_node->node_node_id_ref_counts; + + /* + arg_node->node_node_id_ref_counts=merge_sorted_node_id_ref_count_lists (arg_node->node_node_id_ref_counts,*node_id_ref_count_list_p); + node_id_ref_count_list_p=&arg_node->node_node_id_ref_counts; + */ + } else + node_id_ref_count_list_p=&arg_node->node_node_id_ref_counts; + } + + switch_may_fail=1; + + /* to do: if non failing case for every constructor, default not reachable */ + +#if 1 /* added 8-4-1999 */ + if (node->node_arguments->arg_next==NULL && node->node_arguments->arg_node->node_kind==CaseNode + && (node->node_arguments->arg_node->node_symbol->symb_kind==tuple_symb + || (node->node_arguments->arg_node->node_symbol->symb_kind==definition && + node->node_arguments->arg_node->node_symbol->symb_def->sdef_kind==RECORDTYPE))) + { + int case_may_fail; + NodeP arg_node; + + arg_node=node->node_arguments->arg_node; + + case_may_fail=determine_failing_cases_and_adjust_ref_counts (arg_node->node_arguments->arg_node,node_id_ref_count_list_p); + + arg_node->node_number=case_may_fail; + + switch_may_fail=case_may_fail; + } else +#endif + + for_l (arg,node->node_arguments,arg_next){ + NodeP arg_node; + + arg_node=arg->arg_node; + + switch (arg_node->node_kind){ + case CaseNode: + { + int case_may_fail; + + case_may_fail=determine_failing_cases_and_adjust_ref_counts (arg_node->node_arguments->arg_node,node_id_ref_count_list_p); + + if (case_may_fail && node->node_arguments->arg_next!=NULL){ + /* NodeP case_rhs_node; */ + + sort_node_id_ref_count_lists (&arg_node->node_node_id_ref_counts); + + if (!node_id_ref_count_list_sorted){ + sort_node_id_ref_count_lists (node_id_ref_count_list_p); + node_id_ref_count_list_sorted=1; + } + + /* JVG: maybe incorrect, optimisation: find simple case which can not fail and set node_id_refcounts + case_rhs_node=arg_node->node_arguments->arg_node; + + if (case_rhs_node->node_kind==PushNode) + case_rhs_node=case_rhs_node->node_arguments->arg_next->arg_node; + + if (case_rhs_node->node_kind==SwitchNode && case_rhs_node->node_arguments->arg_next==NULL) + case_rhs_node->node_arguments->arg_node->node_node_id_ref_counts + = duplicate_node_id_ref_count_list (arg_node->node_node_id_ref_counts); + */ + + /* JVG changed 16-2-2000 + add_sorted_node_id_ref_count_list (&arg_node->node_node_id_ref_counts,*node_id_ref_count_list_p); + */ + add_sorted_node_id_ref_count_list_for_case (&arg_node->node_node_id_ref_counts,*node_id_ref_count_list_p); + /**/ + + /* + arg_node->node_node_id_ref_counts= + merge_sorted_node_id_ref_count_lists (arg_node->node_node_id_ref_counts,*node_id_ref_count_list_p); + */ + } + + arg_node->node_number=case_may_fail; + break; + } + case DefaultNode: + switch_may_fail=default_may_fail; + break; + default: + error_in_function ("determine_failing_cases_and_adjust_ref_counts"); + } + } + return switch_may_fail; + } + case PushNode: + return determine_failing_cases_and_adjust_ref_counts (node->node_arguments->arg_next->arg_node,node_id_ref_count_list_p); + case GuardNode: + return determine_failing_cases_and_adjust_ref_counts (node->node_arguments->arg_next->arg_node,node_id_ref_count_list_p); + case IfNode: + { + NodeP else_node; + + else_node=node->node_arguments->arg_next->arg_next->arg_node; + while (else_node->node_kind==IfNode) + else_node=else_node->node_arguments->arg_next->arg_next->arg_node; + + return else_node->node_kind==NormalNode && else_node->node_symbol->symb_kind==fail_symb; + } + default: + return False; + } +} + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +void determine_failing_cases_and_adjust_ref_counts_of_rule (RuleAltP first_alt) +{ + NodeIdRefCountListP node_id_ref_count_list; + + if (first_alt->alt_kind!=Contractum) + return; + + node_id_ref_count_list=NULL; + determine_failing_cases_and_adjust_ref_counts (first_alt->alt_rhs_root,&node_id_ref_count_list); + +# if 0 + PrintRuleAlt (first_alt,4,StdOut); +# endif +} +#endif + +#if 0 +#include "dbprint.h" +#endif + +void transform_patterns_to_case_and_guard_nodes (RuleAltP rule_alts) +{ + RuleAltP rule_alt,first_alt; + ArgP arg; + struct root_and_defs_l root_and_defs_l; + NodeP *node_p; + NodeDefP *def_p; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + StrictNodeIdP *strict_node_ids_p; + NodeDefP *end_lhs_defs_p; +#endif + + first_alt=rule_alts; + + if (first_alt->alt_kind!=Contractum) + return; + + node_p=&first_alt->alt_rhs_root; + def_p=&first_alt->alt_rhs_defs; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + strict_node_ids_p=&first_alt->alt_strict_node_ids; + end_lhs_defs_p=&first_alt->alt_lhs_defs; +#endif + + root_and_defs_l.root_l=&node_p; + root_and_defs_l.def_l=&def_p; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + root_and_defs_l.strict_node_ids_l=&strict_node_ids_p; + root_and_defs_l.end_lhs_defs_l=&end_lhs_defs_p; +#endif + + for_l (arg,first_alt->alt_lhs_root->node_arguments,arg_next) + transform_argument (arg,&root_and_defs_l); + + for_l (rule_alt,first_alt->alt_next,alt_next){ + ArgP arg,first_alt_arg; + NodeIdRefCountListP node_id_ref_count_list,*node_id_ref_count_list_p; + struct root_and_defs root_and_defs; + NodeP *node_p; + NodeDefP *def_p; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + StrictNodeIdP *strict_node_ids_p; +#endif + + node_p=&rule_alt->alt_rhs_root; + def_p=&rule_alt->alt_rhs_defs; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + strict_node_ids_p=&rule_alt->alt_strict_node_ids; +#endif + + arg=rule_alt->alt_lhs_root->node_arguments; + first_alt_arg=first_alt->alt_lhs_root->node_arguments; + + node_id_ref_count_list=NULL; + node_id_ref_count_list_p=&node_id_ref_count_list; + + root_and_defs_l.root_l=&node_p; + root_and_defs_l.def_l=&def_p; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + root_and_defs_l.strict_node_ids_l=&strict_node_ids_p; + root_and_defs_l.end_lhs_defs_l=&end_lhs_defs_p; +#endif + + for (; arg!=NULL; arg=arg->arg_next,first_alt_arg=first_alt_arg->arg_next) + transform_and_merge_argument (arg,first_alt_arg,&root_and_defs_l,&node_id_ref_count_list_p); + + CurrentLine=rule_alt->alt_line; + +#if DEBUG_OUTPUT + printf ("line %d\n",CurrentLine); +#endif + + root_and_defs.root=rule_alt->alt_rhs_root; + root_and_defs.defs=rule_alt->alt_rhs_defs; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + root_and_defs.strict_node_ids=rule_alt->alt_strict_node_ids; +#endif + + first_alt->alt_rhs_root=merge_alternative_with_node (first_alt->alt_rhs_root,&root_and_defs,node_id_ref_count_list); + } + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + *end_lhs_defs_p=NULL; +#endif + + first_alt->alt_next=NULL; + +#if 0 + PrintRuleAlt (first_alt,4,StdOut); +#endif + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + { + NodeIdRefCountListP node_id_ref_count_list; + + node_id_ref_count_list=NULL; + determine_failing_cases_and_adjust_ref_counts (first_alt->alt_rhs_root,&node_id_ref_count_list); + } + +# if 0 + PrintRuleAlt (first_alt,4,StdOut); +# endif +#endif +} diff --git a/backendC/CleanCompilerSources/pattern_match.h b/backendC/CleanCompilerSources/pattern_match.h new file mode 100644 index 0000000..dcedc57 --- /dev/null +++ b/backendC/CleanCompilerSources/pattern_match.h @@ -0,0 +1,7 @@ +extern void transform_patterns_to_case_and_guard_nodes (RuleAltS *alt); +extern void set_local_reference_counts (struct node *case_node); +extern void set_global_reference_counts (struct node *case_node); +extern struct node_id_ref_count_list *new_node_id_ref_count (struct node_id_ref_count_list *node_id_ref_count_list,struct node_id *node_id,int ref_count); +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +extern void determine_failing_cases_and_adjust_ref_counts_of_rule (RuleAltP first_alt); +#endif diff --git a/backendC/CleanCompilerSources/project.h b/backendC/CleanCompilerSources/project.h new file mode 100644 index 0000000..4ffad7f --- /dev/null +++ b/backendC/CleanCompilerSources/project.h @@ -0,0 +1,34 @@ + +extern Bool USE_ABCOPTIONS; +extern char ROOTNAME[FileNameMax]; +extern Bool ROOTSET; + +extern Bool MakeVerbose; + +extern void AddDependency (char *fname); +extern void AddABCInfo (unsigned nr_instr, unsigned nr_desc, unsigned nr_lab); +extern void AddVersionAndOptions (unsigned version, CompilerOptions options); +extern void AddStartLabel (char *label); + +extern void PrintProjectInfo (File f); +extern void TouchProjectFile (char *fname); +extern void TouchDependentProjectFiles (char *fname); +extern void SetOptionsOfProjectNode (char *fname, CompilerOptions options); +extern void SetCurrentProjectNode (char *fname); +extern void SetRootOfProject (char *fname); +extern void ConvertOptionsToString (CompilerOptions options, char *optstring); +extern void ConvertOptionStringToOptions (char *optstring, CompilerOptions *options); +extern void MakeOptionsFromCurrentOptions (CompilerOptions *options); + +extern void InitProject (void); + +extern Bool ProjectIsUpToDate (void); +/* extern Bool BringProjectUpToDate (target_machine_type target_machine); */ +extern Bool BuildApplication (target_machine_type target_machine, int cg_flags, + long h_size, long ab_size, long c_size, long app_size, int link_flags,Bool uptodatemsg); +extern Bool CompileModule (char *icl_file_name); +extern Bool GenerateAssemblyFileForModule (char *file_name,target_machine_type target_machine,int cg_flags); +extern void ResetProject (void); +extern void FreeProject (void); + +/* extern int MakeMirandaToClean (void); */ diff --git a/backendC/CleanCompilerSources/refcountanal.h b/backendC/CleanCompilerSources/refcountanal.h new file mode 100644 index 0000000..56daec7 --- /dev/null +++ b/backendC/CleanCompilerSources/refcountanal.h @@ -0,0 +1,14 @@ +/* + + Version 1.0 29/11/1994 + + Author: Sjaak Smetsers + +*/ + + + +#define _OBSERVATION_TYPES_ + +extern Bool DetermineRefCountInfoOfContractum (Node rhsroot, NodeId rhsrootid, StrictNodeIdP strict_ids, PolyList *observer_list); + diff --git a/backendC/CleanCompilerSources/result_state_database.c b/backendC/CleanCompilerSources/result_state_database.c new file mode 100644 index 0000000..d910db0 --- /dev/null +++ b/backendC/CleanCompilerSources/result_state_database.c @@ -0,0 +1,224 @@ +/* + File: result_state_database.c + Author: John van Groningen + At: University of Nijmegen +*/ + +#if defined (applec) || defined (__MWERKS__) || defined (__MRC__) +# define __ppc__ +#endif + +#include <stdio.h> + +#include "types.t" +#include "syntaxtr.t" +#include "comsupport.h" +#include "result_state_database.h" + +struct state_tree { + struct state_tree * stt_left; + struct state_tree * stt_right; + struct state * stt_state_p; + int stt_label_number; + int stt_label_defined; +}; + +static struct state_tree *state_tree; +static int next_update_label_number; + +static int compare_states (struct state *state1_p,struct state *state2_p) +{ + int r; + + r=state1_p->state_type - state2_p->state_type; + if (r!=0) + return r; + + switch (state1_p->state_type){ + case SimpleState: + r=state1_p->state_kind - state2_p->state_kind; + if (r!=0) + return r; + + return state1_p->state_object - state2_p->state_object; + case ArrayState: + return compare_states (state1_p->state_array_arguments,state2_p->state_array_arguments); + case TupleState: + { + int n; + + r=state1_p->state_arity - state2_p->state_arity; + if (r!=0) + return r; + + n=state1_p->state_arity; + + state1_p=state1_p->state_tuple_arguments; + state2_p=state2_p->state_tuple_arguments; + + while (n>0){ + r=compare_states (state1_p,state2_p); + if (r!=0) + return r; + + --n; + ++state1_p; + ++state2_p; + } + + return 0; + } + case RecordState: + { + struct symbol_def *sdef1,*sdef2; + + sdef1=state1_p->state_record_symbol; + sdef2=state2_p->state_record_symbol; + if (sdef1==sdef2) + return 0; + else + if (sdef1<sdef2) + return -1; + else + return 1; + } + default: + ErrorInCompiler ("compare_states","",""); + return -1; + } +} + +static void store_state_in_database (struct state *state_p) +{ + struct state_tree **state_node_h; + struct state_tree *state_node_p; + + state_node_h=&state_tree; + + while (state_node_p=*state_node_h,state_node_p!=NULL){ + int state_compare_result; + + state_compare_result=compare_states (state_p,state_node_p->stt_state_p); + + if (state_compare_result==0){ + if (state_node_p->stt_label_number==0){ + state_node_p->stt_label_number=next_update_label_number; + ++next_update_label_number; + } + + return; + } else + if (state_compare_result<0) + state_node_h=&state_node_p->stt_left; + else + state_node_h=&state_node_p->stt_right; + } + + state_node_p=CompAllocType (struct state_tree); + + state_node_p->stt_left=NULL; + state_node_p->stt_right=NULL; + state_node_p->stt_state_p=state_p; + state_node_p->stt_label_number=0; + state_node_p->stt_label_defined=0; + + *state_node_h=state_node_p; +} + +void create_result_state_database (struct imp_rule *imp_rules) +{ + struct imp_rule *rule; + + state_tree=NULL; + next_update_label_number=1; + + for (rule=imp_rules; rule; rule=rule->rule_next){ + TypeAlts type_alt; + struct state *state_p; + + if (rule->rule_root->node_symbol->symb_def->sdef_over_arity!=0) + continue; + + type_alt=rule->rule_type; + if (type_alt==NULL) + continue; + +#if 1 + state_p=&rule->rule_state_p[-1]; +#else + state_p=&type_alt->type_alt_lhs->type_node_state; +#endif + if (state_p->state_type==SimpleState){ + if (state_p->state_kind==OnB) + store_state_in_database (state_p); + } else + store_state_in_database (state_p); + } +} + +static int find_state_in_database (struct state *state_p,int mask,int *label_number_p) +{ + struct state_tree *state_node_p; + + state_node_p=state_tree; + + while (state_node_p!=NULL){ + int state_compare_result; + + state_compare_result=compare_states (state_p,state_node_p->stt_state_p); + + if (state_compare_result==0){ + if (state_node_p->stt_label_number==0) + return 0; + + *label_number_p=state_node_p->stt_label_number; + + if ((state_node_p->stt_label_defined & mask)==0){ + state_node_p->stt_label_defined|=mask; + return 1; + } else + return 2; + } else + if (state_compare_result<0) + state_node_p=state_node_p->stt_left; + else + state_node_p=state_node_p->stt_right; + } + + return 0; +} + +/* + get_label_number_from_result_state_database returns: + 0: no label (state occurs only once) + 1: label not yet defined + 2: label already defined +*/ + +#if 1 +int get_label_number_from_result_state_database (StateP result_state_p,int mask,int *label_number_p) +#else +int get_label_number_from_result_state_database (TypeAlts type_alt,int mask,int *label_number_p) +#endif +{ + struct state *state_p; + + *label_number_p=0; + +#if 1 + state_p=result_state_p; +#else + if (type_alt==NULL) + return 0; + + state_p=&type_alt->type_alt_lhs->type_node_state; +#endif + + if (state_p->state_type==SimpleState){ + if (state_p->state_kind==OnB) + return find_state_in_database (state_p,mask,label_number_p); + else + return 0; + } else + return find_state_in_database (state_p,mask,label_number_p); +} diff --git a/backendC/CleanCompilerSources/result_state_database.h b/backendC/CleanCompilerSources/result_state_database.h new file mode 100644 index 0000000..611b15b --- /dev/null +++ b/backendC/CleanCompilerSources/result_state_database.h @@ -0,0 +1,6 @@ +extern void create_result_state_database (struct imp_rule *imp_rules); +#if 1 +extern int get_label_number_from_result_state_database (StateP result_state_p,int mask,int *label_number_p); +#else +extern int get_label_number_from_result_state_database (TypeAlts type_alt,int mask,int *label_number_p); +#endif diff --git a/backendC/CleanCompilerSources/sa.c b/backendC/CleanCompilerSources/sa.c new file mode 100644 index 0000000..f26bf4e --- /dev/null +++ b/backendC/CleanCompilerSources/sa.c @@ -0,0 +1,5315 @@ +/* + Concurrent Clean Compiler: sa.c + =============================== + + This file contains the strictness analyser. It can handle tuples + as well as list strictness. The file is divided in the following + parts: + + General support, including a local storage allocator + Support for storage of strictness information + Operations on expressions + Converions for the internal representation of the syntax tree + The abstract reducer + Main (external) functions + Debugging support + + Author: Eric Nocker + At: Department of Computer Science + University of Nijmegen + Version: 0.9 + Date: Januari, 1995 +*/ + +#undef _DB_ +/* +#define CHECK_STACK_OVERFLOW +#define _DB_STACK_ +*/ + +#define DIVIDE_FUEL +#define SHOW_STRICT_EXPORTED_TUPLE_ELEMENTS +#define MORE_ANNOTS 1 + +#include "system.h" +#include "settings.h" +#include "sizes.h" +#include "syntaxtr.t" +#include "comsupport.h" +#include "checker.h" +#include "typechecker.h" +#include "sa.t" +#include "sa.h" +#ifdef _DB_TEST_ +# include "saprint.h" +#endif +#include "typechecker.h" +#include "tctypes.t" +#include "typeconv.h" +#include "statesgen.h" +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +#include "codegen_types.h" +#endif + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) + +#ifdef CHECK_STACK_OVERFLOW +char *min_stack; +int stack_source = 0; +#endif + +#if MORE_ANNOTS +# define MaxNrAnnots 100 +#else +# define MaxNrAnnots 10 /* the maximum nr of strict rhs annots */ +#endif + +typedef int MyBool; +#define MyFalse 0 +#define MyTrue 1 +#define MyMightBeTrue 2 +#define AreRelated 3 +#define False MyFalse +#define True MyTrue +#define MightBeTrue MyMightBeTrue + +Bool DoStrictExportChecks = False; +Bool DoStrictRelated = False; + +#define Bool MyBool + +static Bool StrictWarning = False; /* general warnings */ +static Bool StrictAllWarning = True; /* warnings per function */ +static Bool StrictChecks = False; /* warns for strange strictness */ +static Bool StrictExportChecks = False; /* do export checks */ + +static unsigned StrictFuel = 60; /* 20; */ /* amount of reductions to do */ + +static unsigned min_d; +static unsigned max_memuse; /* the maximum memory use */ + +static char *CurrentName; /* current function name */ + +#ifdef _DB_ +static Bool DBPrinting = False; +Exp infp, botmemp, topmemp; +#endif + +#ifdef _DB_ +Fun +#else +static Fun +#endif + * conssym, /* the cons id */ + * nilsym, /* the nil id */ + * apsym, /* the apply id */ + * if_sym, /* the if id */ + * true_sym, /* the true id */ + * false_sym, /* the false id */ + * selectsym[MaxNodeArity], /* the select ids */ + * tuplesym[MaxNodeArity], /* the tuple ids */ + * strict_sym[MaxNrAnnots], /* the strict ids */ + * fail_sym, /* the fail id */ + * inffunct_sym, /* the E2 id */ + * botmemfunct_sym; /* the E3 id */ + +static ExpRepr top; +static ExpRepr bottom; +static ExpRepr inf; +static ExpRepr botmem; +static ExpRepr topmem; + +/* +General Support +Containing: + + - Debugging options + The following debugging options are available: + _DB_ general option, should always be set for the others + _DB_RED_ set on if reductions should be traced + _DB_EQ_ set on if comparison on expressions should be traced + output of the tracing is sent to the file "uit". + + - Warnings Generation + + - Storage allocator + In principle the storage allocator is quite simple: it supports a + fast allocation by allocating some large blocks if necessary. With + the functions 'Freeze..' and 'UnFreeze..' a basic part of the + storage (used for the function table and syntax tree) can be frozen. + Unfreezing releases all the other memory. The function 'MemUse' can + be used for obtaining the current memory usage. + +*/ + +#ifdef _DB_ + File outfile; +# define Assume ProcAssume +# define Assume2 ProcAssume + static void ProcAssume (Bool cond, char *err, char *proc) + { + Bool stop = False; + + if (! cond) + { if (! stop) + FPrintF (StdError, "FATAL ERROR: %s in %s\n", err, proc); + else + DoFatalError ("%s in %s\n", err, proc); + } + } +#else +# ifdef _DB_TEST_ +# define Assume(A,B,C) +# define Assume2 ProcAssume + static void ProcAssume (Bool cond, char *err, char *proc) + { + Bool stop = False; + + if (! cond) + { if (! stop) + FPrintF (StdError, "FATAL ERROR: %s in %s\n", err, proc); + else + DoFatalError ("%s in %s\n", err, proc); + } + } +# else +# define Assume2(A,B,C) +# define Assume(A,B,C) +# endif +#endif + +/* +Warnings + Warnings can be given during or after the analysis. If after, some + warnings that would be given during the analysis should be collected + into one warning. This is indicated by 'depth_warning' and + 'mem_warning'. +*/ + +static void error_in_function (char *m) +{ + ErrorInCompiler ("sa.c",m,""); +} + +static Bool depth_warning; /* set True if a depth warning is given */ +static Bool mem_warning; /* set True if a memory warning is given */ +static Bool time_warning; /* set True if a time warning is given */ +static Bool export_warning; /* set True if an export warning is given */ +static Bool max_depth_reached; /* set True if max depth reached, no more + such warnings should be given */ +static Bool max_time_reached; /* set True if max time reached, no more + such warnings should be given */ +static Bool initialising = True; /* set True when building function table + this results in other warnings */ +static Bool instantiating = False; /* set True when copying an expression */ + +static void GiveStrictWarning (char *f, char *msg) +{ +#if 1 + CurrentLine=0; + if (f) + StaticMessage (False,"%s","%s",f,msg); + else + StaticMessage (False,"","%s",msg); +#else + if (f) + FPrintF (StdError, "Warning [%s%s,%s]: %s\n", CurrentModule, CurrentExt, f, msg); + else + FPrintF (StdError, "Warning [%s%s]: %s\n", CurrentModule, CurrentExt, msg); +#endif +} + +/******************************************************************************* + * The Storage Allocator for the strictness analysis * + ******************************************************************************/ + +static char *SA_store [NR_BLOCKS]; /* the memory blocks */ +static unsigned n_allocated_blocks = 0; /* the nr of allocated blocks */ +static unsigned usedblocks = 0; /* the nr of blocks in use */ +static char *high = Null; /* current end position in block */ +static char *free_pos = Null; /* current free position in block */ +static unsigned fblocks = 0; /* the freezed nr of blocks */ +static char *ffree = Null; /* the freezed free position */ + +static void NewBlock (void) +{ + if (usedblocks < n_allocated_blocks) + usedblocks ++; + else if (n_allocated_blocks < NR_BLOCKS && (BLOCK_SIZE * (n_allocated_blocks+1)) < StrictMemUse){ + if (! (free_pos = (char *) Alloc (BLOCK_SIZE, SizeOf (char)))) + return; + + SA_store[n_allocated_blocks] = free_pos; + + n_allocated_blocks++; + usedblocks++; + } else { + free_pos = (char *) Null; + return; + } + + free_pos = SA_store[usedblocks - 1]; + high = free_pos + BLOCK_SIZE; +} + +static jmp_buf SAEnv, SAEnv2, SAEnv3; + +#define SAllocType(t) ((t*)SAlloc(sizeof(t))) +#define SAllocArrayType(n,t) ((t*)SAlloc((n)*sizeof(t))) + +static char *SAlloc (unsigned n) +{ + /* be sure to return an even address */ + n = ReSize (n); + + if (free_pos!=NULL && free_pos + n < high){ + char *m; + + m=free_pos; + free_pos = m+n; + + return m; + } else + NewBlock (); + + if (free_pos!=NULL && free_pos + n < high){ + free_pos += n; + + return (free_pos - n); + } else { + if (initialising) + longjmp (SAEnv, 1); + + if (StrictAllWarning) + GiveStrictWarning (CurrentName, "out of memory (result approximated)"); + else + mem_warning = True; + + if (instantiating) + longjmp (SAEnv3, 1); + else + longjmp (SAEnv2, 1); + + return NULL; + } +} + +static void FreezeAlloc (void) +{ + ffree = free_pos; + fblocks = usedblocks; +} + +static void FreeUnFreezedBlocks (void) +{ + usedblocks = fblocks; + free_pos = ffree; + high = SA_store[fblocks-1] + BLOCK_SIZE; +} + +void free_unused_sa_blocks (void) +{ + int i; + + for (i=usedblocks; i<n_allocated_blocks; ++i){ + if (SA_store[i]!=NULL){ + Free ((void *) SA_store[i]); + SA_store[i]=NULL; + } + } + + n_allocated_blocks = usedblocks; +} + +static unsigned MemUse (void) +{ + long l; + + if (n_allocated_blocks==0) + return 0; + + if (! free_pos) + l = (long) (usedblocks-1) * BLOCK_SIZE; + else + l = (long) (usedblocks-1) * BLOCK_SIZE + ((long) free_pos - (long) SA_store[usedblocks-1]); + + return (unsigned) ((l-1) / KBYTE) + 1; +} + +static void FreeBlocks (void) +{ + unsigned i; + + for (i = 0; i < n_allocated_blocks; i++){ + if (SA_store[i]!=NULL){ + Free ((void *) SA_store[i]); + SA_store[i]=NULL; + } + } + + n_allocated_blocks = usedblocks = fblocks = 0; + free_pos = ffree = Null; +} + +#define NewExpArgs(n) SAllocArrayType(n,Exp) + +static Exp NewExp (ExpKind kind, unsigned sym, Bool hnf, unsigned arity) +{ + Exp e; + + e = SAllocType (ExpRepr); + + e->e_kind = kind; + e->e_sym = sym; + e->e_hnf = hnf; + e->e_spechnf= hnf; + e->e_hasind = False; + e->e_red = False; + e->e_mark = False; + e->e_mark2 = False; + e->e_imark = False; + e->e_fwd = Null; + e->e_deps = Null; + + if (arity == 0) + e->e_args = NULL; + else + e->e_args = NewExpArgs (arity); + +#ifdef _DB_ + e->e_mmark = False; + e->e_dmark = False; + e->e_shared = False; + e->e_add = 0; +#endif + + return e; +} + +static Exp NewValueExp (Fun *fun, Bool hnf, unsigned arity) +{ + Exp e; + + e = SAllocType (ExpRepr); + + e->e_kind = Value; + e->e_fun = fun; + e->e_hnf = hnf; + e->e_spechnf= hnf; + e->e_hasind = False; + e->e_red = False; + e->e_mark = False; + e->e_mark2 = False; + e->e_imark = False; + e->e_fwd = Null; + e->e_deps = Null; + + if (arity == 0) + e->e_args = NULL; + else + e->e_args = NewExpArgs (arity); + +#ifdef _DB_ + e->e_mmark = False; + e->e_dmark = False; + e->e_shared = False; + e->e_add = 0; +#endif + + return e; +} + +#define NewTop() (NewExp (Top, 0, True, 0)) + +static void InitExp (Exp e, ExpKind kind, unsigned sym, Bool hnf) +{ + e->e_kind = kind; + e->e_sym = sym; + e->e_hnf = hnf; + e->e_spechnf= hnf; + e->e_hasind = False; + e->e_red = False; + e->e_mark = False; + e->e_mark2 = False; + e->e_imark = False; + e->e_fwd = Null; + e->e_deps = Null; + +#ifdef _DB_ + e->e_mmark = False; + e->e_dmark = False; + e->e_shared = False; + e->e_add = 0; +#endif +} + +static void InitValueExp (Exp e,Fun *fun,Bool hnf) +{ + e->e_kind = Value; + e->e_fun = fun; + e->e_hnf = hnf; + e->e_spechnf= hnf; + e->e_hasind = False; + e->e_red = False; + e->e_mark = False; + e->e_mark2 = False; + e->e_imark = False; + e->e_fwd = Null; + e->e_deps = Null; + +#ifdef _DB_ + e->e_mmark = False; + e->e_dmark = False; + e->e_shared = False; + e->e_add = 0; +#endif +} + +static unsigned start_fuel; + +static void SetStartFuel (void) +{ + start_fuel = StrictFuel; +} + +static Bool OutOfFuel (void) +{ + if (start_fuel == 0) + return True; + + --start_fuel; + return False; +} + +/* Operations on StrictInfos and contexts */ + +static StrictKind MaxStrict (StrictKind s1, StrictKind s2) +{ + if (s1 < s2) + return s2; + else + return s1; +} + +static Context SimpleContext (Context context, StrictKind kind, Bool spec) +{ + if (! context) + context = SAllocType (ContextRepr); + + context->context_arity = 1; + context->context_speculative = spec; + context->context_kind = kind; + context->context_args = NULL; + + return context; +} + +static Context NewSimpleContext (StrictKind kind, Bool spec) +{ + Context context; + + context = SAllocType (ContextRepr); + + context->context_arity = 1; + context->context_speculative = spec; + context->context_kind = kind; + context->context_args = NULL; + + return context; +} + +static Context StrictInfoToContext (StrictInfo *s, Context curcontext, Bool resultinfo) +{ + Context context; + + if (! resultinfo && curcontext->context_kind == NotStrict) + return curcontext; + + if (IsTupleInfo (s)){ + StrictKind info_kind = GetTupleStrictKind (s); + + if (info_kind == NotStrict){ + if (resultinfo) + return curcontext; + + context = SAllocType (ContextRepr); + context->context_arity = 1; + context->context_speculative = curcontext->context_speculative; + context->context_kind = NotStrict; + context->context_args = (Context *) Null; + } + else { + unsigned i, n; + Bool has_strict_arg = False; + Context subcontext; + + n = s->strict_arity; + + context = SAllocType (ContextRepr); + context->context_arity = s->strict_arity; + context->context_speculative = curcontext->context_speculative; + context->context_kind = HnfStrict; + context->context_args = SAllocArrayType (n,Context); + + for (i = 0; i < n; i++) + { if (! resultinfo) + subcontext = curcontext; + else if (curcontext->context_arity > 1) + subcontext = curcontext->context_args[i]; + else + subcontext = NewSimpleContext (NotStrict, curcontext->context_speculative); + + context->context_args[i] = StrictInfoToContext (& GetTupleInfo (s, i), subcontext, resultinfo); + if (context->context_args[i]->context_kind != NotStrict) + has_strict_arg = True; + } + + if (! has_strict_arg) + context->context_arity = 1; + } + } + else { + StrictKind info_kind = GetStrictKind (s, ContextToIndex (curcontext->context_kind)); + + if (resultinfo){ + if (info_kind <= curcontext->context_kind) + return curcontext; + + context = SAllocType (ContextRepr); + context->context_arity = 1; + context->context_speculative = curcontext->context_speculative; + context->context_kind = info_kind; + context->context_args = NULL; + } else { + if (info_kind == curcontext->context_kind && curcontext->context_arity == 1) + return curcontext; + + context = SAllocType (ContextRepr); + context->context_arity = 1; + context->context_speculative = curcontext->context_speculative; + context->context_kind = info_kind; + context->context_args = NULL; + } + } + + return context; +} + +static Context CopyContext (Context curcontext) +{ + Context context; + + if (! curcontext || curcontext->context_kind == NotStrict) + return NULL; + + context = SAllocType (ContextRepr); + context->context_arity = curcontext->context_arity; + context->context_speculative = False; + context->context_kind = curcontext->context_kind; + + if (context->context_arity > 1){ + unsigned i, n; + + n = context->context_arity; + context->context_args = SAllocArrayType (n,Context); + + for (i = 0; i < n; i++) + context->context_args[i] = CopyContext (curcontext->context_args[i]); + } else + context->context_args = NULL; + + return context; +} + +/* Operations on expressions */ + +static void InitValues (void) +{ + static ExpRepr botmem1; + static ExpRepr botmem2; + static Exp infargs[2]; + static Exp botmem1args[2]; + static Exp botmem2args[2]; + static Exp botmemargs[2]; + static ExpRepr topmem1; + static ExpRepr topmem2; + static Exp topmem1args[2]; + static Exp topmemargs[2]; + +#ifdef _DB_ + infp = & inf; + botmemp = & botmem; + topmemp = & topmem; +#endif + + InitValueExp (&inf, conssym, True); + inf.e_args = infargs; + inf.e_args[0] = & top; + inf.e_args[1] = & inf; + + InitValueExp (&topmem1, nilsym, True); + InitValueExp (&topmem2, conssym, True); + + InitExp (&topmem, Lub, 2, True); + + topmem.e_kind = Top; + topmem.e_args = topmemargs; + topmem.e_args[0] = & topmem1; + topmem.e_args[1] = & topmem2; + + topmem2.e_args = topmem1args; + topmem2.e_args[0] = & top; + topmem2.e_args[1] = & topmem; + + InitValueExp (&botmem1, conssym, True); + InitValueExp (&botmem2, conssym, True); + + InitExp (&botmem, Lub, 2, True); + + botmem.e_args = botmemargs; + botmem.e_args[0] = & botmem1; + botmem.e_args[1] = & botmem2; + + botmem1.e_args = botmem1args; + botmem1.e_args[0] = & top; + botmem1.e_args[1] = & botmem; + + botmem2.e_args = botmem2args; + botmem2.e_args[0] = & bottom; + botmem2.e_args[1] = & topmem; +} + +static void RemoveMark (Exp e) +{ + unsigned n,i; + + if (! e->e_mark) + return; + + e->e_mark = False; + switch (e->e_kind){ + case Top: + case Bottom: + case FunValue: + return; + case Ind: + RemoveMark (e->e_args[0]); + return; + case Argument: + return; + case Value: + n = e->e_fun->fun_arity; + break; + case Dep: + case Lub: + n = e->e_sym; + break; + default: + Assume (False, "unknown case", "RemoveMark"); + return; + } + + for (i = 0; i < n; i++) + RemoveMark (e->e_args[i]); +} + +static Exp InstantiateExp2 (Exp e) +{ + unsigned arity, i; + Exp new_e; + + if (e->e_mark) + return e->e_fwd; + + e->e_mark = True; + switch (e->e_kind){ + case Top: + new_e = NewTop(); + e->e_fwd = new_e; + break; + case Dep: + { + unsigned j; + Exp arg_e; + + arity = e->e_sym; + new_e = NewExp (Dep, e->e_sym, e->e_hnf, arity); + e->e_fwd = new_e; + for (i = 0, j = 0; i < arity; i++){ + arg_e = InstantiateExp2 (e->e_args[i]); + if (arg_e->e_kind == Bottom){ + e->e_fwd = & bottom; + new_e = & bottom; + return new_e; + } else if (arg_e->e_kind == Top) /* || arg_e->e_hnf) */ + /* simply skip it */ + ; + else { + new_e->e_args[j] = arg_e; + j++; + } + } + if (j == 0){ + new_e = NewTop(); + e->e_fwd = new_e; + } else + new_e->e_sym = j; + break; + } + case Bottom: + e->e_fwd = & bottom; + new_e = & bottom; + break; + case FunValue: + e->e_mark = False; + e->e_fwd = e; + new_e = e; + break; + case Ind: + new_e = NewExp (Ind, 0, False, 1); + e->e_fwd = new_e; + new_e->e_args[0] = e->e_args[0]; + break; + case Argument: +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + Assume2 (e->e_args[0] != Null, "argument not bound", "InstantiateExp"); +#endif + e->e_fwd = new_e = e->e_args[0]; +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + e->e_args[0] = NULL; +#endif + break; + case Value: + arity = e->e_fun->fun_arity; + new_e = NewValueExp (e->e_fun, e->e_hnf, arity); + e->e_fwd = new_e; + for (i = 0; i < arity; i++) + new_e->e_args[i] = InstantiateExp2 (e->e_args[i]); + break; + case Lub: + arity = e->e_sym; + new_e = NewExp (Lub, e->e_sym, True, arity); + e->e_fwd = new_e; + for (i = 0; i < arity; i++) + new_e->e_args[i] = InstantiateExp2 (e->e_args[i]); + break; + default: + Assume (False, "unknown case", "InstantiateExp"); + return ⊤ + } + + return new_e; +} + +static Exp InstantiateExp (Exp e) +{ + Exp new_e; + + instantiating = True; + + if (setjmp (SAEnv3) != 0){ + RemoveMark (e); + instantiating = False; + longjmp (SAEnv2, 1); + } + + new_e = InstantiateExp2 (e); + RemoveMark (e); + instantiating = False; + + return new_e; +} + +/* + During (Ext)LtExp2 a the addresses in Val/Dep expressions are determined for + which an AreRelated relation exists + + the Bool CheckAreRelated should be (un)set before(after) LtExp is called +*/ + +static Bool CheckAreRelated = False; +static Exp *s_exp1, *s_exp2, *q_exp; + +/* JVG */ +#define MAX_LT_EXP2_CALLS 100000 +static long lt_exp2_max_n_calls; +/* */ + +static Bool LtExp2 (Exp e1, Exp e2) +{ + unsigned n, i; + +#ifdef CHECK_STACK_OVERFLOW + char x; + + if (&x < min_stack) + { printf ("Stack overflow in LtExp\n"); +#ifdef _DB_ + FPrintF (outfile, "Stack overflow in LtExp\n"); +#endif + return False; + } +#endif + if (e1 == e2) + return True; + + if (e1->e_mark || e2->e_mark) + return MightBeTrue; + + if (e2->e_kind == Top) + return True; + + /* JVG */ + if (++lt_exp2_max_n_calls >= MAX_LT_EXP2_CALLS) + return MightBeTrue; + /* */ + + switch (e1->e_kind){ + case Bottom: + return True; + case Top: + return False; + case FunValue: + if (e2->e_kind == FunValue && e1->e_fun==e2->e_fun) + return True; + else + break; + case Ind: + e1->e_mark = True; + if (LtExp2 (e1->e_args[0], e2)){ + e1->e_mark = False; + return True; + } + e1->e_mark = False; + break; + case Value: + case Dep: + { + int s_index; + + s_index = -1; + + if (e1->e_kind==Value){ + if (e1->e_kind!=e2->e_kind || e1->e_fun!=e2->e_fun) + break; + + n = e1->e_fun->fun_arity; + } else { + if (e1->e_kind!=e2->e_kind || e1->e_sym!=e2->e_sym) + break; + + n = e1->e_sym; + } + + e1->e_mark = True; + e2->e_mark = True; + + for (i = 0; i < n; i++){ + Bool b; + + b = LtExp2 (e1->e_args[i], e2->e_args[i]); + switch (b){ + case True: + continue; + case MightBeTrue: + e1->e_mark = False; + e2->e_mark = False; + return MightBeTrue; + case False: + case AreRelated: + if (CheckAreRelated && s_index < 0){ + s_index = i; + continue; + } else { + e1->e_mark = False; + e2->e_mark = False; + return False; + } + } + } + e1->e_mark = False; + e2->e_mark = False; + if (s_index >= 0){ + s_exp1 = & e1->e_args[s_index]; + s_exp2 = & e2->e_args[s_index]; + return AreRelated; + } else + return True; + } + case Lub: + e1->e_mark = True; + n = e1->e_sym; + for (i = 0; i < n; i++){ + Bool b; + + b = LtExp2 (e1->e_args[i], e2); + if (b != True){ + e1->e_mark = False; + return b; + } + } + e1->e_mark = False; + return True; + default: + Assume (False, "illegal case", "LtExp"); + return False; + } + + /* check if e2 is a lub or Ind */ + if (e2->e_kind == Lub){ + Bool result; + + result = False; + e2->e_mark = True; + n = e2->e_sym; + + for (i = 0; i < n; i++){ + Bool b; + + b = LtExp2 (e1, e2->e_args[i]); + if (b == True){ + e2->e_mark = False; + return b; + } else if (b == MightBeTrue) + result = MightBeTrue; + } + e2->e_mark = False; + return result; + } else if (e2->e_kind == Ind){ + e2->e_mark = True; + + if (LtExp2 (e1, e2->e_args[0])){ + e2->e_mark = False; + return True; + } + e2->e_mark = False; + } + + return False; +} + +#ifdef _DB_ +#undef Bool +Bool IsInAPath (Exp e1, Exp e2, APath p) +#define Bool MyBool +#else +static Bool IsInAPath (Exp e1, Exp e2, APath p) +#endif +{ + for ( ; p; p = p->ap_next){ + if (e1 == p->ap_e1 && e2 == p->ap_e2) + return True; + } + return False; +} + +#ifdef _DB_ +APath AddToAPath (Exp e1, Exp e2, APath p) +#else +static APath AddToAPath (Exp e1, Exp e2, APath p) +#endif +{ + APath new; + + new = SAllocType (APathRepr); + + new->ap_e1 = e1; + new->ap_e2 = e2; + new->ap_next = p; + return new; +} + +static Bool EqExp2 (Exp e1, Exp e2) +{ + unsigned n, i; + + if (e1 == e2) + return True; + + if (e1->e_mark) + return MightBeTrue; + + switch (e1->e_kind) + { + case Bottom: + if (e2->e_kind == Bottom) + return True; + else + return False; + case Top: + if (e2->e_kind == Top) + return True; + else + return False; + case FunValue: + if (e2->e_kind == FunValue && e1->e_fun==e2->e_fun) + return True; + else + return False; + case Argument: + return False; + case Ind: + return (e2->e_kind == Ind && e1->e_args[0] == e2->e_args[0]); + case Value: + case Dep: + if (e1->e_kind!=e2->e_kind) + return False; + + if (e1->e_kind == Value){ + if (e1->e_fun != e2->e_fun) + return False; + + n = e1->e_fun->fun_arity; + } else { + if (e1->e_sym != e2->e_sym) + return False; + + n = e1->e_sym; + } + + e1->e_mark = True; + + for (i = 0; i < n; i++) + { Bool b = EqExp2 (e1->e_args[i], e2->e_args[i]); + if (b != True) + { e1->e_mark = False; + return b; + } + } + e1->e_mark = False; + return True; + case Lub: + if (e2->e_kind != Lub || e1->e_sym != e2->e_sym) + return False; + e1->e_mark = True; + n = e1->e_sym; + for (i = 0; i < n; i++) + { Bool b = EqExp2 (e1->e_args[i], e2->e_args[i]); +/* JVG added: */ + if (b!=True) +/**/ + { e1->e_mark = False; + return b; + } + } + e1->e_mark = False; + return True; + default: + Assume (False, "illegal case", "EqExp"); + return False; + } +} /* EqExp2 */ + +static Bool ExtEqExp2 (Exp e1, Exp e2, APath p) +{ + unsigned n, i; + APath newp; + + if (e1 == e2) + return True; + + if (IsInAPath (e1, e2, p)) + return True; + + if (e1->e_mark && e2->e_mark) + return False; + + newp = AddToAPath (e1, e2, p); + + switch (e1->e_kind){ + case Bottom: + if (e2->e_kind == Bottom) + return True; + else + return False; + case Top: + if (e2->e_kind == Top) + return True; + else + return False; + case FunValue: + if (e2->e_kind == FunValue && e1->e_fun==e2->e_fun) + return True; + else + return False; + case Argument: + return False; + case Ind: + return (e2->e_kind == Ind && e1->e_args[0] == e2->e_args[0]); + case Value: + case Dep: + if (e1->e_kind != e2->e_kind) + return False; + + if (e1->e_kind == Value){ + if (e1->e_fun != e2->e_fun) + return False; + + n = e1->e_fun->fun_arity; + } else { + if (e1->e_sym != e2->e_sym) + return False; + + n = e1->e_sym; + } + + e1->e_mark = True; + e2->e_mark = True; + + for (i = 0; i < n; i++) + { if (! ExtEqExp2 (e1->e_args[i], e2->e_args[i], newp)) + { e1->e_mark = False; + e2->e_mark = False; + return False; + } + } + e1->e_mark = False; + e2->e_mark = False; + return True; + case Lub: + if (e2->e_kind != Lub || e1->e_sym != e2->e_sym) + return False; + e1->e_mark = True; + e2->e_mark = True; + n = e1->e_sym; + for (i = 0; i < n; i++) + { if (! ExtEqExp2 (e1->e_args[i], e2->e_args[i], newp)) + { e1->e_mark = False; + e2->e_mark = False; + return False; + } + } + e1->e_mark = False; + e2->e_mark = False; + return True; + default: + Assume (False, "unknown case", "ExtEqExp2"); + return False; + } +} /* ExtEqExp2 */ + +#ifdef _DB_ +#undef Bool +static Bool EqExp (Exp e1, Exp e2) +#define Bool MyBool +#else +static Bool EqExp (Exp e1, Exp e2) +#endif /* _DB_ */ +{ + Bool b; + + b = EqExp2 (e1, e2); + + if (b == MightBeTrue && StrictDoExtEq){ + b = ExtEqExp2 (e1, e2, (APath) Null); + Assume (! ContainsMark (e1), "e1 is marked", "EqExp (Ext)"); + Assume (! ContainsMark (e2), "e2 is marked", "EqExp (Ext)"); + } + else + { Assume (! ContainsMark (e1), "e1 is marked", "EqExp"); + } + + if (b == True) + return True; + else + return False; +} + +static Bool ExtLtExp2 (Exp e1, Exp e2, APath p) +{ + if (e1 == e2) + return True; + if (e1->e_kind == Bottom || e2->e_kind == Top) + return True; + if (e1->e_kind == Top || e2->e_kind == Bottom) + return False; + + if (IsInAPath (e1, e2, p)) + return True; + + switch (e1->e_kind){ + case FunValue: + if (e2->e_kind == FunValue && e1->e_fun == e2->e_fun) + return True; + else + break; + case Ind: + { + APath newp; + + newp = AddToAPath (e1, e2, p); + if (ExtLtExp2 (e1->e_args[0], e2, newp)) + return True; + else + break; + } + case Value: + case Dep: + { + unsigned n, i; + int s_index; + APath newp; + + if (e1->e_kind != e2->e_kind) + break; + + if (e1->e_kind==Value){ + if (e1->e_fun != e2->e_fun) + break; + n=e1->e_fun->fun_arity; + } else { + if (e1->e_sym != e2->e_sym) + break; + n=e1->e_sym; + } + + s_index = -1; + + newp = AddToAPath (e1, e2, p); + for (i = 0; i < n; i++){ + Bool b = ExtLtExp2 (e1->e_args[i], e2->e_args[i], newp); + switch (b){ + case True: + continue; + case False: + case AreRelated: + if (CheckAreRelated && s_index < 0){ + s_index = i; + continue; + } + return False; + } + } + if (s_index >= 0){ + s_exp1 = & e1->e_args[s_index]; + s_exp2 = & e2->e_args[s_index]; + return AreRelated; + } else + return True; + + return True; + } + case Lub: + { + unsigned n, i; + APath newp; + + n = e1->e_sym; + newp = AddToAPath (e1, e2, p); + + for (i = 0; i < n; i++){ + Bool b = ExtLtExp2 (e1->e_args[i], e2, newp); + if (b != True) + return False; + } + return True; + } + default: + Assume (False, "illegal case", "LtExp"); + return False; + } + + /* check if e2 is a lub */ + if (e2->e_kind == Lub){ + unsigned n, i; + APath newp; + + n = e2->e_sym; + newp = AddToAPath (e1, e2, p); + + for (i = 0; i < n; i++){ + if (ExtLtExp2 (e1, e2->e_args[i], newp) == True) + return True; + } + } else if (e2->e_kind == Ind){ + if (ExtLtExp2 (e1, e2->e_args[0], p)) + return True; + } + + return False; +} + +static Bool LtExp (Exp e1, Exp e2) +{ + Bool b; + +#ifdef _DB_EQ_ + if (DBPrinting) + { FPrintF (outfile, "Less then e1: "); + DumpExp (outfile, e1); + FPrintF (outfile, "\n e2: "); + DumpExp (outfile, e2); + FPutC ('\n', outfile); + } +#endif + + /* JVG */ + lt_exp2_max_n_calls=0; + /* */ + b = LtExp2 (e1, e2); + +#ifdef _DB_EQ_ + if (DBPrinting){ + if (b == True) + FPrintF (outfile, "Result: True\n\n"); + else if (b == MightBeTrue) + FPrintF (outfile, "Result: MightBeTrue\n\n"); + else + FPrintF (outfile, "Result: False\n\n"); + } +#endif + + if (b == MightBeTrue && StrictDoExtEq){ + b = ExtLtExp2 (e1, e2, (APath) Null); + +#ifdef _DB_EQ_ + if (DBPrinting){ + if (b == True) + FPrintF (outfile, "Result2: True\n\n"); + else if (b == MightBeTrue) + FPrintF (outfile, "Result2: MightBeTrue\n\n"); + else + FPrintF (outfile, "Result2: False\n\n"); + } +#endif + } + + return b; +} + +static Bool IsContainedIn (Exp e1, ExpP ep2) +{ + Exp e2; + + e2 = *ep2; + + if (e2->e_mark2) + return False; + + if (EqExp (e1, e2)){ + q_exp = ep2; + return True; + } + + switch (e2->e_kind){ + case Value: + { unsigned n, i; + + e2->e_mark2 = True; + n = e2->e_fun->fun_arity; + for (i = 0; i < n; i++){ + if (IsContainedIn (e1, & e2->e_args[i])){ + e2->e_mark2 = False; + return True; + } + } + e2->e_mark2 = False; + return False; + } + case Lub: + { unsigned n, i; + e2->e_mark2 = True; + n = e2->e_sym; + for (i = 0; i < n; i++){ + if (! IsContainedIn (e1, & e2->e_args[i])){ + e2->e_mark2 = False; + return False; + } + } + e2->e_mark2 = False; + return True; + } + default: + return False; + } +} + +static int SortLtExp (Exp e1,Exp e2) +{ + ExpKind kind1, kind2; + + kind1 = e1->e_kind; + kind2 = e2->e_kind; + if (kind1 == kind2){ + if (kind1 == Value){ + if (e1->e_hnf) + return -1; + else if (e2->e_hnf) + return -1; + else + return (e1->e_fun < e2->e_fun); + } else + return False; + } else + return (kind1 < kind2); +} + +#define LESS(a,b) (SortLtExp ((a),(b))) + +static void Sort (Exp *defs, unsigned high) +{ + unsigned low,father, son; + Exp val; + + low = high / 2; + while (high > 1){ + val = defs[father = low]; + for (;;){ + son = 2 * father + 1; + if (son >= high) + { defs[father] = val; + break; + }; + if (son == high - 1){ + if (LESS (val, defs[son])){ + defs[father] = defs[son]; + defs[son] = val; + } else { + defs[father] = val; + }; + break; + }; + if (LESS (defs[son], defs[son + 1])) + son++; + if (!LESS (val, defs[son])){ + defs[father] = val; + break; + }; + defs[father] = defs[son]; + father = son; + }; + if (low > 0){ + low--; + } else { + val = defs[0]; + defs[0] = defs[--high]; + defs[high] = val; + } + } +} + +static Bool ContainsExpOfKind (Exp e, ExpKind kind) +{ + unsigned i; + Bool result = False; + + for (i = 0; i < e->e_sym; i++) + { if (e->e_args[i]->e_kind == kind) + result = True; + else if (kind == Dep && e->e_args[i]->e_kind == Bottom) + { e->e_kind = Bottom; + e->e_hnf = True; + e->e_deps = Null; + return False; + } + else if (kind == Lub && e->e_args[i]->e_kind == Top) + { e->e_kind = Top; + e->e_hnf = True; + return False; + } + } + + return result; +} + +static Bool IsInArgs (Exp *args, unsigned n, Exp e) +{ + unsigned i; + + for (i = 0; i < n; i++) + if (args[i] == e) + return True; + + return False; +} + +static void RemoveExpOfKind (Exp e, ExpKind kind) +{ unsigned i, j, k, n, new_n, new_done; + Exp *new_args; + + /* count the new number of 'kind' args (the current args + the new ones) */ + n = e->e_sym; + new_n = 0; + for (i = 0; i < n; i++) + { if (e->e_args[i]->e_kind == kind) + new_n += e->e_args[i]->e_sym; + else + new_n += 1; + } + + new_args = NewExpArgs (new_n); + + for (i = 0, j = 0; i < n; i++) + { if (e->e_args[i]->e_kind == kind) + { int kind_n = e->e_args[i]->e_sym; + for (k = 0; k < kind_n; k++) + { if (! IsInArgs (e->e_args, j, e->e_args[i]->e_args[k])) + { new_args[j] = e->e_args[i]->e_args[k]; + j++; + } + } + } + else + if (! IsInArgs (e->e_args, j, e->e_args[i])) + { new_args[j] = e->e_args[i]; + j++; + } + } + + /* put new arguments in original expression */ + e->e_args = new_args; + e->e_sym = j; + new_done = n; + + /* remove remaining subkind expressions */ + if (ContainsExpOfKind (e, kind)) + RemoveExpOfKind (e, kind); +} + +static void UpdateExp (Exp src, Exp dst); + +static void RemoveCycles (ExpP ep, ExpKind kind) +{ unsigned i, n; + Exp e = *ep; + + if (e->e_mark) + { *ep = & bottom; + e->e_mark = False; + return; + } + + e->e_mark = True; + + n = e->e_sym; + for (i = 0; i < n; i++) + { if (e->e_args[i]->e_kind == kind) + RemoveCycles (& e->e_args[i], kind); + } + + e->e_mark = False; +} /* RemoveCycles */ + +static void SortExpOfKind (Exp e, ExpKind kind) +{ unsigned n, j, i; + Bool remove; + Exp e2 = e; /* temp pointer: the pointer can be changed by RemoveCycles */ + + Assume2 (e->e_kind == kind, "No exp of right kind", "SortExpOfKind"); + + RemoveCycles (& e2, kind); + + if (ContainsExpOfKind (e, kind)) + RemoveExpOfKind (e, kind); + + if (e->e_kind != kind) + return; + + n = e->e_sym; + + Sort (e->e_args, e->e_sym); + + if (kind == Dep) + { for (i = n; i > 0; i--) + if (e->e_args[i-1]->e_kind != Top) + break; + + n = i; + } + + for (i = 0; i+1 < n; ) + { if (LtExp (e->e_args[i], e->e_args[i+1]) == True) + { remove = True; + e->e_args[i] = e->e_args[i+1]; + } + else if (LtExp (e->e_args[i+1], e->e_args[i]) == True) + remove = True; + else + remove = False; + + if (remove) + { for (j = i+1; j+1 < n; j++) + e->e_args[j] = e->e_args[j+1]; + n--; + } + else + i++; + } + e->e_sym = n; + + if (n > 20) + { +#ifdef _DB_ + FPrintF (StdOut, "SortLub %d:", n); + DumpExp (StdOut, e); + FPutC ('\n', StdOut); +#endif /* _DB_ */ + e->e_kind = Top; + return; + } + + if (n == 1 && kind == Lub) + UpdateExp (e->e_args[0], e); + else if (n == 0 && kind == Dep) + e->e_kind = Top; +} + +static void CopyDeps (Dependency fromdep,Dependency *newdeps) +{ + Dependency new; + + for (;fromdep; fromdep = fromdep->dep_next){ + new = SAllocType (DependencyRepr); + new->dep_exp = fromdep->dep_exp; + new->dep_next = *newdeps; + *newdeps = new; + } +} + +static Dependency AddDeps (Dependency fromdep, Dependency taildeps) +{ Dependency new; + + for (;fromdep; fromdep = fromdep->dep_next) + { + new = SAllocType (DependencyRepr); + new->dep_exp = fromdep->dep_exp; + new->dep_next = taildeps; + taildeps = new; + } + + return taildeps; +} /* AddDeps */ + +static Dependency CombineDependencies (Dependency deps1, Dependency deps2) +{ + Dependency new; + + new = NULL; + + if (! deps1 || ! deps2) + return NULL; + + CopyDeps (deps1,&new); + CopyDeps (deps2,&new); +/* + for (; deps1; deps1 = deps1->dep_next) + { Dependency dep; + Exp e; + + e = deps1->dep_exp; + + for (dep = deps2; dep; dep = dep->dep_next) + { if (e == dep->dep_exp) + { Dependency new2; + + new2 = SAllocType (DependencyRepr); + new2->dep_exp = e; + new2->dep_next = new; + new = new2; + } + } + } +*/ + return new; +} + +static Exp TakeLub (Exp e1, Exp e2) +{ + Exp new_e; + unsigned n, i, j; + Dependency newdeps; + + if (! e1 && ! e2) + return & bottom; + if (! e1 || e1->e_kind == Bottom) + return e2; + if (! e2 || e2->e_kind == Bottom) + return e1; + + newdeps = CombineDependencies (e1->e_deps, e2->e_deps); + + /* create a new Lub expression and copy all the elements */ + if (e1->e_kind == Lub && e2->e_kind == Lub) + { new_e = NewExp (Lub, 0, True, e1->e_sym + e2->e_sym); + j = 0; + for (i = 0; i < e1->e_sym; i++) + { if (e1->e_args[i]->e_kind == Bottom) + continue; + else if (e1->e_args[i]->e_kind == Top) + return NewTop(); + else + { new_e->e_args[j] = e1->e_args[i]; + j++; + } + } + for (i = 0; i < e2->e_sym; i++) + { if (e2->e_args[i]->e_kind == Bottom) + continue; + else if (e2->e_args[i]->e_kind == Top) + return NewTop(); + else + { new_e->e_args[j] = e2->e_args[i]; + j++; + } + } + new_e->e_sym = j; + } + else if (e1->e_kind == Lub) + { n = e1->e_sym; + new_e = NewExp (Lub, 0, True, n + 1); + j = 0; + for (i = 0; i < n; i++) + { if (e1->e_args[i]->e_kind == Bottom) + continue; + else if (e1->e_args[i]->e_kind == Top) + return NewTop(); + else + { new_e->e_args[j] = e1->e_args[i]; + j++; + } + } + new_e->e_args[j] = e2; + new_e->e_sym = j + 1; + } + else if (e2->e_kind == Lub) + { n = e2->e_sym; + new_e = NewExp (Lub, 0, True, 1 + n); + j = 0; + for (i = 0; i < n; i++) + { if (e2->e_args[i]->e_kind == Bottom) + continue; + else if (e2->e_args[i]->e_kind == Top) + return NewTop(); + else + { new_e->e_args[j] = e2->e_args[i]; + j++; + } + } + new_e->e_args[j] = e1; + new_e->e_sym = j + 1; + } + else + { new_e = NewExp (Lub, 2, True, 2); + new_e->e_args[0] = e1; + new_e->e_args[1] = e2; + } + + SortExpOfKind (new_e, Lub); + new_e->e_deps = newdeps; + return new_e; +} + +static void UpdateExp (Exp src, Exp dst) +{ unsigned arity, i; + + if (src == dst) + return; + + dst->e_kind = src->e_kind; + dst->e_hnf = src->e_hnf; + dst->e_spechnf = src->e_spechnf; + dst->e_red = False; + + switch (src->e_kind) + { + case Top: + dst->e_sym = src->e_sym; + arity = 0; + break; + case FunValue: + dst->e_fun = src->e_fun; + arity = 0; + break; + case Bottom: + dst->e_sym = src->e_sym; + dst->e_args = Null; + dst->e_deps = Null; + return; + case Ind: + dst->e_sym = src->e_sym; + arity = 1; + break; + case Value: + dst->e_fun = src->e_fun; + arity = src->e_fun->fun_arity; + break; + case Lub: + case Dep: + dst->e_sym = src->e_sym; + arity = src->e_sym; + break; + default: + Assume (False, "unknown case", "UpdateExp"); + dst->e_sym = src->e_sym; + arity = 0; + break; + } + + dst->e_args = NewExpArgs (arity); + for (i = 0; i < arity; i++) + dst->e_args[i] = src->e_args[i]; + + /* add dependencies of source to destination */ + dst->e_deps = AddDeps (dst->e_deps, src->e_deps); + + if (dst->e_kind == Lub) + SortExpOfKind (dst, Lub); +} + +/******************************************************************************* + * The function table, initialisation * + ******************************************************************************/ + +static Bool has_fail; /* the current alternative contains a Fail */ + +#define IsTupleExp(A) ((A)->e_kind==Value && ((A)->e_fun>=tuplesym[0] && (A)->e_fun<=tuplesym[MaxNodeArity-1])) +#define TypeArgsOfRecord(R) ((R)->sdef_type->type_constructors->cl_constructor->type_node_arguments) + +static Bool HasStrictAnnot (Annotation annot) +{ + if (! StrictDoAnnots) + return False; + + return annot==StrictAnnot; +} + +static Bool HasProcessAnnot (Annotation annot) +{ + return False; + + /* parallel annotations are only used in parallel compilation */ + if (! DoParallel || ! annot) + return False; + + switch (annot){ + case ContinueAnnot: + case ParallelAnnot: + case ParallelAtAnnot: + case LazyParallelAnnot: + case InterleavedAnnot: + case LazyInterleavedAnnot: + case DeferAnnot: + case WaitAnnot: + case ContInterleavedAnnot: + case ParallelNFAnnot: + case InterleavedNFAnnot: + return True; + default: + return False; + } +} + +static Exp ConvertNode (Node node, NodeId node_id); + +static void ConvertToApplyNode (Exp e, Node node, unsigned arity) +{ + if (arity==0){ + e->e_fun = node->node_symbol->symb_def->sdef_sa_fun; + e->e_kind = FunValue; + e->e_hnf = True; + } else { + Exp left, right; + Args args; + unsigned i; + + args = node->node_arguments; + + left = NewValueExp (NULL,False,0); + + ConvertToApplyNode (left, node, arity-1); + + for (i = 1; i < arity; i++, args = args->arg_next) + ; + + right = ConvertNode (args->arg_node, NULL); + + e->e_fun = apsym; + e->e_kind = Value; + e->e_hnf = True; + e->e_args = NewExpArgs (2); + e->e_args[0] = left; + e->e_args[1] = right; + } +} + +static Exp ConvertNodeId (NodeId nid) +{ + Exp e; + + if (nid->nid_exp) + return nid->nid_exp; + + if (nid->nid_refcount>=0){ + if (nid->nid_node_def) + return ConvertNode (nid->nid_node_def->def_node, nid); + else { + DoFatalError ("ConvertNode (SA): no node or nid"); + return & top; + } + } else { +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (nid->nid_node) + return ConvertNode (nid->nid_node, nid); +#endif + e = NewExp (Argument, 0, False, 1); + e->e_args[0] = NULL; + + nid->nid_exp_ = e; + + return e; + } +} + +static Exp ConvertNodeDefs (Node root, NodeDefs defs, StrictNodeIdP strictids) +{ + Exp e, rootexp; + int i, nr_strict; + NodeDefs node_def; + StrictNodeIdP ids; + + /* convert node defs */ + for_l (node_def,defs,def_next) + if (node_def->def_node!=NULL) + ConvertNode (node_def->def_node,node_def->def_id); + + /* convert root node */ + rootexp = ConvertNode (root,NULL); + + /* convert strict node defs */ + nr_strict = 0; + for_l (ids,strictids,snid_next) + nr_strict++; + + if (nr_strict==0) + return rootexp; + + e = NewValueExp (strict_sym [nr_strict - 1], False, nr_strict + 1); + + for (i=0,ids=strictids; i< nr_strict; i++,ids=ids->snid_next) + e->e_args[i] = ConvertNode (ids->snid_node_id->nid_node,ids->snid_node_id); + + e->e_args[i] = rootexp; + + return e; +} + +static unsigned CountStrictArgs (TypeArgs args) +{ + TypeNode node; + unsigned n = 0; + + if (! args) + return 0; + + for (; args; args = args->type_arg_next){ + node = args->type_arg_node; + + if (node->type_node_annotation!=StrictAnnot) + continue; + + n += 1; + + if (!node->type_node_is_var && node->type_node_symbol->symb_kind==tuple_type) + n += CountStrictArgs (node->type_node_arguments); + } + + return n; +} + +static void ConvertStrictSelections (Exp exp, TypeNode node, Exp *e_args, unsigned *i) +{ + if (!node->type_node_is_var && node->type_node_symbol->symb_kind==tuple_type){ + TypeArgs typeargs; + unsigned j; + Exp selexp; + + e_args[*i] = exp; + (*i) ++; + + for (j = 0, typeargs = node->type_node_arguments; typeargs; typeargs = typeargs->type_arg_next, j++){ + node = typeargs->type_arg_node; + + if (node->type_node_annotation!=StrictAnnot) + continue; + + selexp = NewValueExp (selectsym[j], False, 1); + selexp->e_args[0] = exp; + + ConvertStrictSelections (selexp, node, e_args, i); + } + } else { + if (exp->e_kind == Top || exp->e_hnf) + return; + + e_args[*i] = exp; + (*i) ++; + } +} + +static void InitNode (Node node); + +static void InitNodeDefs (NodeDefs defs) +{ + for ( ; defs; defs=defs->def_next){ + if (defs->def_id) + defs->def_id->nid_exp_ = NULL; + + InitNode (defs->def_node); + } +} + +static void InitNode (Node node) +{ + if (! node) + return; + + if (node->node_kind==NodeIdNode) + node->node_node_id->nid_exp_ = NULL; + else { + Args args; + + if (node->node_kind==IfNode){ + InitNodeDefs (node->node_then_node_defs); + InitNodeDefs (node->node_else_node_defs); + } +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + else if (node->node_kind==SwitchNode){ + for_l (args,node->node_arguments,arg_next){ + NodeP node_p; + + node_p=args->arg_node; + if (node_p->node_kind==CaseNode){ + NodeP case_alt_node_p; + + case_alt_node_p=node_p->node_arguments->arg_node; + if (case_alt_node_p->node_kind==PushNode){ + NodeIdListElementP node_id_list; + + for_l (node_id_list,case_alt_node_p->node_node_ids,nidl_next) + node_id_list->nidl_node_id->nid_exp=NULL; + + case_alt_node_p=case_alt_node_p->node_arguments->arg_next->arg_node; + } + + InitNode (case_alt_node_p); + InitNodeDefs (node_p->node_node_defs); + } else if (node_p->node_kind==DefaultNode){ + InitNode (node_p->node_arguments->arg_node); + InitNodeDefs (node_p->node_node_defs); + } else + error_in_function ("InitNode"); + } + + return; + } else if (node->node_kind==GuardNode){ + InitNode (node->node_arguments->arg_node); + InitNode (node->node_arguments->arg_next->arg_node); + InitNodeDefs (node->node_node_defs); + return; + } +#endif + + for_l (args,node->node_arguments,arg_next) + InitNode (args->arg_node); + } +} + +static void InitAlternative (RuleAltS *alt) +{ + NodeDefs nds; + + InitNode (alt->alt_lhs_root); + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + for_l (nds,alt->alt_lhs_defs,def_next){ + if (nds->def_id) + nds->def_id->nid_exp_ = NULL; + + InitNode (nds->def_node); + } +#endif + + if (alt->alt_kind==Contractum){ + InitNode (alt->alt_rhs_root); + InitNodeDefs (alt->alt_rhs_defs); + } +} + +/* 'StrictUpdates' defines whether a record update is strict */ + +#define StrictUpdates + +static Exp ConvertNode (Node node, NodeId nid) +{ + Exp e; + unsigned arity, i; + Args arg; + + if (nid==NULL){ + if (node->node_kind==NodeIdNode) + return ConvertNodeId (node->node_node_id); + } else { + if (nid->nid_exp) + return nid->nid_exp; + + if (node->node_kind==NodeIdNode){ + if (node->node_node_id==nid) + return ConvertNodeId (nid); + else + return ConvertNodeId (nid->nid_node->node_node_id); + } + } + + if (HasProcessAnnot (node->node_annotation)) + return & top; + + e = NewValueExp (NULL,False,0); + + if (nid) + nid->nid_exp_ = e; + + switch (node->node_kind){ + case NormalNode: + { arity = node->node_arity; + + switch (node->node_symbol->symb_kind){ + case tuple_symb: + e->e_fun = tuplesym[arity]; + break; + case bool_denot: + if (node->node_symbol -> symb_bool) + e->e_fun = true_sym; + else + e->e_fun = false_sym; + e->e_hnf = True; + break; + case cons_symb: + e->e_hnf = True; + e->e_fun = conssym; + break; + case nil_symb: + e->e_hnf = True; + e->e_fun = nilsym; + break; + case apply_symb: + e->e_fun = apsym; + break; + case select_symb: + e->e_fun = selectsym[arity - 1]; + arity = 1; + break; + case fail_symb: + has_fail = True; + e->e_fun = fail_sym; + return e; + case if_symb: + e->e_fun = if_sym; + if (arity != 3) + { e->e_kind = FunValue; + e->e_hnf = True;; + } + break; + case definition: + { + SymbDef sdef; + + sdef = node->node_symbol->symb_def; + + if (sdef->sdef_kind == INSTANCE) + DoFatalError ("Strictness analysis (ConvertNode): instance encounterred"); + + if (sdef->sdef_kind==DEFRULE || sdef->sdef_kind==SYSRULE){ + TypeAlts rule; + TypeArgs typeargs; + unsigned int i; + Exp exp; + + rule = sdef->sdef_rule_type->rule_type_rule; + typeargs = rule->type_alt_lhs->type_node_arguments; + + /* count the number of strict args in the type */ + arity = CountStrictArgs (typeargs); + + if (arity == 0){ + e->e_kind = Top; + return e; + } + + e->e_kind = Dep; + e->e_args = NewExpArgs (arity); + + i = 0; + for (arg = node->node_arguments; arg; arg = arg->arg_next, typeargs = typeargs->type_arg_next){ + if (typeargs->type_arg_node->type_node_annotation!=StrictAnnot) + continue; + + exp = ConvertNode (arg->arg_node, NULL); + + ConvertStrictSelections (exp, typeargs->type_arg_node, e->e_args, &i); + } + if (i == 0) + e->e_kind = Top; + else + e->e_sym = i; + return e; + } else { + e->e_fun = sdef->sdef_sa_fun; + + if (sdef->sdef_kind==RECORDTYPE ? arity==sdef->sdef_cons_arity : arity==sdef->sdef_arity) + e->e_kind = Value; + else { + ConvertToApplyNode (e, node, arity); + return e; + } + } + break; + } + default: + e = & top; + if (nid) + nid->nid_exp_ = e; + return e; + } + + e->e_args = NewExpArgs (arity); + + for (i = 0,arg=node->node_arguments; arg!=NULL; arg=arg->arg_next,++i) + e->e_args[i] = ConvertNode (arg->arg_node, NULL); + + break; + } + case IfNode: + { arity = 3; + e->e_fun = if_sym; + e->e_args = NewExpArgs (arity); + + /* conditional part */ + arg = node->node_arguments; + e->e_args[0] = ConvertNode (arg->arg_node, Null); + + /* then and else part */ + arg = arg->arg_next; + e->e_args[1] = ConvertNodeDefs (arg->arg_node, node->node_then_node_defs,node->node_then_strict_node_ids); + + arg = arg->arg_next; + e->e_args[2] = ConvertNodeDefs (arg->arg_node, node->node_else_node_defs,node->node_else_strict_node_ids); + break; + } + case SelectorNode: + { + int field_nr; + + field_nr = node->node_symbol->symb_def->sdef_sel_field_number; + arg = node->node_arguments; + + if (node->node_arity>=SELECTOR_U){ + if (node->node_arity>=SELECTOR_L){ + Exp tuple,record,result,tuple_result,selection; + + tuple=ConvertNode (arg->arg_node,NULL); + + record=NewValueExp (selectsym[0],False,1); + record->e_args[0]=tuple; + + result=NewValueExp (selectsym[1],False,1); + result->e_args[0]=tuple; + + selection=NewValueExp (selectsym [field_nr],False,1); + selection->e_args[0]=record; + + tuple_result=NewValueExp (tuplesym[2],True,2); + tuple_result->e_args[0]=selection; + tuple_result->e_args[1]=result; + + e->e_fun = strict_sym[1]; + e->e_args = NewExpArgs (3); + e->e_args[0] = record; + e->e_args[1] = result; + e->e_args[2] = tuple_result; + } else { + Exp record,tuple_result,selection; + + record=ConvertNode (arg->arg_node,NULL); + + selection=NewValueExp (selectsym [field_nr],False,1); + selection->e_args[0]=record; + + tuple_result=NewValueExp (tuplesym[2],True,2); + tuple_result->e_args[0]=selection; + tuple_result->e_args[1]=record; + + e->e_fun = strict_sym[0]; + e->e_args = NewExpArgs (2); + e->e_args[0] = record; + e->e_args[1] = tuple_result; + } + break; + } + + e->e_fun = selectsym [field_nr]; + e->e_args = NewExpArgs (1); + + e->e_args[0] = ConvertNode (arg->arg_node, Null); + break; + } + case UpdateNode: + { int field_nr, arity; + Exp oldrecordexp, selexp, newrecordexp; + + /* make a new exp node if a strict update is required */ +#ifndef StrictUpdates + newrecordexp = e; +#else + newrecordexp = NewValueExp (NULL,False,0); +#endif + + /* convert the old record */ + arg = node->node_arguments; + oldrecordexp = ConvertNode (arg->arg_node, Null); + + /* build a record expression for the new record node */ + newrecordexp->e_fun = node->node_symbol->symb_def->sdef_sa_fun; + newrecordexp->e_kind = Value; + arity = node->node_symbol->symb_def->sdef_cons_arity; + + /* initialise the arguments of the new record exp */ + newrecordexp->e_args = NewExpArgs (arity); + for (i = 0; i < arity; i++) + newrecordexp->e_args[i] = NULL; + + /* now fill in the updates of the new record */ + for (arg = node->node_arguments->arg_next; arg; arg = arg->arg_next) + { field_nr = arg->arg_node->node_symbol->symb_def->sdef_sel_field_number; + newrecordexp->e_args[field_nr] = ConvertNode (arg->arg_node->node_arguments->arg_node, Null); + } + + /* finally, create selections for the parts which are not updated */ + for (i = 0; i < arity; i++) + { if (newrecordexp->e_args[i]) + continue; + + selexp = NewValueExp (selectsym [i], False, 1); + selexp->e_args[0] = oldrecordexp; + newrecordexp->e_args[i] = selexp; + } + + /* fill the strictness cell if necessary */ +#ifdef StrictUpdates + e->e_args = NewExpArgs (2); + e->e_fun = strict_sym[0]; + e->e_args[0] = oldrecordexp; + e->e_args[1] = newrecordexp; +#endif + break; + } + case MatchNode: + { + Exp exp; + Symbol symbol; + + exp = ConvertNode (node->node_arguments->arg_node, Null); + + symbol=node->node_symbol; + if (symbol->symb_kind==definition && symbol->symb_def->sdef_kind==CONSTRUCTOR && + symbol->symb_def->sdef_arity==1) + { + Exp selexp; + + selexp = NewValueExp (selectsym[0], False, 1); + selexp->e_args[0] = exp; + exp = selexp; + } + + if (nid) + nid->nid_exp_ = exp; + + return exp; + } + default: + DoFatalError ("ConvertNode (SA): unknown node kind"); + return & top; + } + return e; +} + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +static void convert_pattern_to_apply_node (Exp e,SymbolP symbol,NodeIdListElementP node_id_list,unsigned arity) +{ + if (arity==0){ + e->e_fun = symbol->symb_def->sdef_sa_fun; + e->e_kind = FunValue; + e->e_hnf = True; + } else { + Exp left,right; + unsigned i; + NodeIdListElementP node_id_list_elem; + + left = NewValueExp (NULL,False,0); + + convert_pattern_to_apply_node (left,symbol,node_id_list,arity-1); + + node_id_list_elem=node_id_list; + i=1; + while (i<arity){ + node_id_list_elem=node_id_list_elem->nidl_next; + ++i; + } + + right = ConvertNodeId (node_id_list_elem->nidl_node_id); + + e->e_fun = apsym; + e->e_kind = Value; + e->e_hnf = True; + e->e_args = NewExpArgs (2); + e->e_args[0] = left; + e->e_args[1] = right; + } +} + +static Exp convert_pattern (SymbolP symbol_p,int arity,NodeIdListElementP node_id_list) +{ + NodeIdListElementP node_id_list_elem; + Exp e; + + e = NewValueExp (NULL,False,0); + + switch (symbol_p->symb_kind){ + case tuple_symb: + e->e_fun = tuplesym[arity]; + break; + case bool_denot: + if (symbol_p -> symb_bool) + e->e_fun = true_sym; + else + e->e_fun = false_sym; + e->e_hnf = True; + break; + case cons_symb: + e->e_hnf = True; + e->e_fun = conssym; + break; + case nil_symb: + e->e_hnf = True; + e->e_fun = nilsym; + break; + case definition: + { + SymbDef sdef; + + sdef = symbol_p->symb_def; + + if (sdef->sdef_kind == INSTANCE) + DoFatalError ("Strictness analysis (convert_pattern): instance encounterred"); + + if (sdef->sdef_kind==DEFRULE || sdef->sdef_kind==SYSRULE){ + TypeAlts rule; + TypeArgs typeargs; + unsigned int i; + Exp exp; + + rule = sdef->sdef_rule_type->rule_type_rule; + typeargs = rule->type_alt_lhs->type_node_arguments; + + /* count the number of strict args in the type */ + arity = CountStrictArgs (typeargs); + + if (arity == 0){ + e->e_kind = Top; + return e; + } + + e->e_kind = Dep; + e->e_args = NewExpArgs (arity); + + i = 0; + for (node_id_list_elem=node_id_list; node_id_list_elem!=NULL; node_id_list_elem=node_id_list_elem->nidl_next,typeargs=typeargs->type_arg_next){ + if (typeargs->type_arg_node->type_node_annotation==StrictAnnot){ + exp = ConvertNodeId (node_id_list_elem->nidl_node_id); + + ConvertStrictSelections (exp,typeargs->type_arg_node,e->e_args,&i); + } + } + + if (i == 0) + e->e_kind = Top; + else + e->e_sym = i; + + return e; + } else { + e->e_fun = sdef->sdef_sa_fun; + + if (sdef->sdef_kind==RECORDTYPE ? arity==sdef->sdef_cons_arity : arity==sdef->sdef_arity) + e->e_kind = Value; + else { + convert_pattern_to_apply_node (e,symbol_p,node_id_list,arity); + return e; + } + } + break; + } + default: + e = & top; + return e; + } + + e->e_args = NewExpArgs (arity); + + { + unsigned int i; + + for (i=0,node_id_list_elem=node_id_list; node_id_list_elem!=NULL; node_id_list_elem=node_id_list_elem->nidl_next,++i) + e->e_args[i] = ConvertNodeId (node_id_list_elem->nidl_node_id); + } + + return e; +} + +static void convert_root_node (NodeP rhs_root_p,NodeDefs node_defs,StrictNodeIdP strict_node_ids,Alts fun_alt_p); + +static void convert_switch_node (NodeP switch_node_p,Alts fun_alt_p) +{ + ArgP arg_p; + Alts *last_next_switch_alt_p; + + fun_alt_p->fun_rhs = ConvertNodeId (switch_node_p->node_node_id); + + fun_alt_p->fun_is_guard=0; + last_next_switch_alt_p=&fun_alt_p->fun_switch_alts; + + for_l (arg_p,switch_node_p->node_arguments,arg_next){ + Alts case_alt_p; + Bool old_has_fail; + NodeP case_alt_node_p,node_p; + + case_alt_p=SAllocType (AltsRepr); + + *last_next_switch_alt_p=case_alt_p; + last_next_switch_alt_p=&case_alt_p->fun_next; + + node_p=arg_p->arg_node; + if (node_p->node_kind==CaseNode){ + case_alt_node_p=node_p->node_arguments->arg_node; + if (case_alt_node_p->node_kind==PushNode){ + case_alt_p->fun_lhs=convert_pattern (node_p->node_symbol,node_p->node_arity,case_alt_node_p->node_node_ids); + case_alt_node_p=case_alt_node_p->node_arguments->arg_next->arg_node; + } else { + case_alt_p->fun_lhs=convert_pattern (node_p->node_symbol,0,NULL); + } + } else if (node_p->node_kind==DefaultNode){ + case_alt_node_p=node_p->node_arguments->arg_node; + case_alt_p->fun_lhs=NULL; + } else + error_in_function ("convert_switch_node"); + + old_has_fail=has_fail; + has_fail=False; + + convert_root_node (case_alt_node_p,node_p->node_node_defs,node_p->node_strict_node_ids,case_alt_p); + + case_alt_p->fun_has_fail=has_fail; + if (old_has_fail) + has_fail=True; + } + + *last_next_switch_alt_p=NULL; +} + +static void convert_guard_node (NodeP guard_node_p,NodeDefs node_defs,StrictNodeIdP strict_node_ids,Alts fun_alt_p) +{ + Alts fail_alt_p; + + fail_alt_p=SAllocType (AltsRepr); + + fun_alt_p->fun_is_guard=1; + fun_alt_p->fun_switch_alts=fail_alt_p; + + fun_alt_p->fun_rhs=ConvertNodeDefs (guard_node_p->node_arguments->arg_node,node_defs,strict_node_ids); + + convert_root_node (guard_node_p->node_arguments->arg_next->arg_node,guard_node_p->node_node_defs,guard_node_p->node_guard_strict_node_ids,fail_alt_p); +} + +static void convert_root_node (NodeP rhs_root_p,NodeDefs node_defs,StrictNodeIdP strict_node_ids,Alts fun_alt_p) +{ + if (rhs_root_p->node_kind==SwitchNode){ + NodeDefP node_def; + + for_l (node_def,node_defs,def_next) + if (node_def->def_node!=NULL) + ConvertNode (node_def->def_node,node_def->def_id); + + if (strict_node_ids!=NULL) + error_in_function ("convert_root_node"); + + convert_switch_node (rhs_root_p,fun_alt_p); + } else if (rhs_root_p->node_kind==GuardNode){ + convert_guard_node (rhs_root_p,node_defs,strict_node_ids,fun_alt_p); + } else { + fun_alt_p->fun_rhs = ConvertNodeDefs (rhs_root_p,node_defs,strict_node_ids); + fun_alt_p->fun_switch_alts=NULL; + } +} +#endif + +static void ConvertAlternatives (Alts *funalts,RuleAlts rulealts) +{ + Alts fun_alt_p; + + if (! rulealts){ + *funalts = NULL; + return; + } + + fun_alt_p=SAllocType (AltsRepr); + *funalts = fun_alt_p; + + InitAlternative (rulealts); + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + fun_alt_p->fun_lhs = ConvertNodeDefs (rulealts->alt_lhs_root,rulealts->alt_lhs_defs,NULL); +#else + fun_alt_p->fun_lhs = ConvertNodeDefs (rulealts->alt_lhs_root,NULL,NULL); +#endif + + has_fail = False; + + if (rulealts->alt_kind==Contractum){ +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + convert_root_node (rulealts->alt_rhs_root,rulealts->alt_rhs_defs,rulealts->alt_strict_node_ids,fun_alt_p); +#else + fun_alt_p->fun_rhs = ConvertNodeDefs (rulealts->alt_rhs_root, rulealts->alt_rhs_defs, rulealts->alt_strict_node_ids); +#endif + } else { + /* code block */ + fun_alt_p->fun_rhs = ⊤ +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + fun_alt_p->fun_switch_alts=NULL; +#endif + } + + fun_alt_p->fun_has_fail = has_fail; + + /* convert the following alternatives */ + ConvertAlternatives (&fun_alt_p->fun_next, rulealts->alt_next); +} + +static StrictInfo *InitNewStrictInfos (unsigned arity, StrictKind s) +{ + unsigned i; + StrictInfo *strict_infos; + + strict_infos = SAllocArrayType (arity,StrictInfo); + + for (i = 0; i < arity; i++){ + strict_infos[i].strict_arity = 1; + InitStrictInfo (&strict_infos[i],s); + } + return strict_infos; +} + +static void InitStrictResult (StrictInfo *s) +{ + s->strict_arity = 1; + InitStrictInfo (s, HnfStrict); +} + +static void ConvertStateToStrictInfo (TypeNode node, StrictInfo *s, Bool adopt_annots) +{ + if (node->type_node_is_var || node->type_node_symbol->symb_kind!=tuple_type){ +/* + #ifdef _DB_ + if (node->type_node_is_var) + printf ("ConvertStateToStrictInfo Var\n"); + else { + if (node->type_node_symbol->symb_kind==definition) + printf ("ConvertStateToStrictInfo Definition %s\n",node->type_node_symbol->symb_def->sdef_ident->ident_name); + else + printf ("ConvertStateToStrictInfo NoTuple %d\n",node->type_node_symbol->symb_kind); + } + #endif +*/ + s->strict_arity = 1; + if (adopt_annots && node->type_node_annotation==StrictAnnot) + InitStrictInfo (s, HnfStrict); + else + InitStrictInfo (s, NotStrict); + } else { + unsigned arity = node->type_node_arity; + unsigned i; + TypeArgs args = node->type_node_arguments; + + s->strict_arity = arity; +/* + #ifdef _DB_ + printf ("ConvertStateToStrictInfo Tuple %d\n",arity); + #endif +*/ + if (adopt_annots && node->type_node_annotation==StrictAnnot) + GetTupleStrictKind (s) = HnfStrict; + else + GetTupleStrictKind (s) = NotStrict; + + GetTupleInfos (s) = SAllocArrayType (arity,StrictInfo); + + for (i = 0; i < arity; i++, args = args->type_arg_next) + ConvertStateToStrictInfo (args->type_arg_node, & GetTupleInfo (s, i), + adopt_annots); + } +} + +static void ConvertTypeArgsToStrictInfos (TypeArgs args, unsigned arity, StrictInfo **strict_args, Bool adopt_annots) +{ + unsigned i; + + *strict_args = SAllocArrayType (arity,StrictInfo); + + for (i = 0; i < arity; i++, args = args->type_arg_next){ +/* + #ifdef _DB_ + printf ("ConvertTypeArgsToStrictInfos %d\n",i); + #endif +*/ + ConvertStateToStrictInfo (args->type_arg_node, & (*strict_args)[i], adopt_annots); + } +} + +static void ConvertStateInfoToStrictInfos (TypeAlts rule_type_alts, unsigned arity, StrictInfo **strict_args, + StrictInfo *result, Bool adopt_annots) +{ + TypeArgs args; + TypeNode node; + + if (! rule_type_alts){ + *strict_args = InitNewStrictInfos (arity, NotStrict); + InitStrictResult (result); + return; + } + + /* do the arguments */ + args = rule_type_alts->type_alt_lhs->type_node_arguments; + ConvertTypeArgsToStrictInfos (args, arity, strict_args, adopt_annots); + + /* do the result */ + node = rule_type_alts->type_alt_rhs; + + if (node->type_node_is_var) + InitStrictResult (result); + else + ConvertStateToStrictInfo (node, result, True); + + /* the result is of course always strict */ + if (IsTupleInfo (result)) + GetTupleStrictKind (result) = HnfStrict; + else + InitStrictInfo (result, HnfStrict); +} + +static void UpdateStateInfoWithStrictInfo (TypeNode node, StrictInfo *s,Bool *strict_added_p,Bool *warning) +{ + Bool is_strict_annotated; +#ifndef SHOW_STRICT_EXPORTED_TUPLE_ELEMENTS + Bool local_strict_added; + + local_strict_added = False; +#endif + + is_strict_annotated = node->type_node_annotation==StrictAnnot; + + if (IsTupleInfo (s)){ + unsigned arity = s->strict_arity; + unsigned i; + TypeArgs args = node->type_node_arguments; + + if (GetTupleStrictKind (s) == NotStrict){ + if (StrictChecks && is_strict_annotated) + *warning = True; + return; + } + + if (! is_strict_annotated){ + node->type_node_annotation=StrictAnnot; + *strict_added_p = True; + } + + for (i = 0; i < arity; i++, args = args->type_arg_next) +#ifdef SHOW_STRICT_EXPORTED_TUPLE_ELEMENTS + UpdateStateInfoWithStrictInfo (args->type_arg_node,&GetTupleInfo (s,i),strict_added_p,warning); +#else + UpdateStateInfoWithStrictInfo (args->type_arg_node,&GetTupleInfo (s,i),&local_strict_added,warning); +#endif + } else { +#if 0 + printf ("%d %d %d\n",GetStrictKind (s, 0),GetStrictKind (s, 1),GetStrictKind (s, 2)); +#endif + if (GetStrictKind (s, 0) != NotStrict){ + if (!is_strict_annotated){ + node->type_node_annotation=StrictAnnot; + *strict_added_p = True; + } + } else if (StrictChecks && GetStrictKind (s, 0) == NotStrict && is_strict_annotated){ + *warning = True; + } + } +} + +static void UpdateStateInfosWithStrictInfos (TypeAlts rule, unsigned arity, StrictInfo *strict_args, + StrictInfo *result, Bool *strict_added, Bool *warning) +{ unsigned i; + TypeArgs args; + + if (! rule) + return; + + /* do the arguments */ + args = rule->type_alt_lhs->type_node_arguments; + + for (i = 0; i < arity; i++, args = args->type_arg_next) + UpdateStateInfoWithStrictInfo (args->type_arg_node,&strict_args[i], strict_added, warning); + + /* the result has no sense at the moment */ +} + +Bool IsListArg (Fun *f, unsigned n) +{ + TypeArgs args; + TypeAlts typerule; + unsigned i; + + if (f->fun_kind == Function) + typerule = f->fun_symbol->sdef_rule->rule_type; + else + /* ?? */ + return False; + + args = typerule->type_alt_lhs->type_node_arguments; + + for (i = 0; i < n; i++) + args = args->type_arg_next; + + return (! args->type_arg_node->type_node_is_var && args->type_arg_node->type_node_symbol->symb_kind==list_type); +} + +static Bool HasListResult (Fun *f) +{ + TypeAlts typerule; + + if (f->fun_kind == Function) + typerule = f->fun_symbol->sdef_rule->rule_type; + else + return False; + + return (!typerule->type_alt_rhs->type_node_is_var && typerule->type_alt_rhs->type_node_symbol->symb_kind==list_type); +} + +static void BuildInfFunction (Fun *f) +{ + Alts alt, alt2; + Exp lhs, rhs, arg_cons, arg_x, arg_y, nil_exp; + + /* the following function is built: + + E2 (Cons x y) = E2 y + E2 Nil = Nil + + */ + + f->fun_symbol = Null; + f->fun_arity = 1; + f->fun_kind = Function; + f->fun_strictargs = InitNewStrictInfos (1, HnfStrict); + f->fun_single = False; + InitStrictResult (& f->fun_strictresult); + + f->fun_alts = alt = SAllocType (AltsRepr); + alt2 = SAllocType (AltsRepr); + alt->fun_has_fail = False; + alt->fun_next = alt2; + alt2->fun_has_fail = False; + alt2->fun_next = Null; + + nil_exp = NewValueExp (nilsym, True, 0); + arg_x = NewExp (Argument, 0, False, 1); + arg_y = NewExp (Argument, 0, False, 1); + arg_cons = NewValueExp (conssym, True, 2); + arg_cons->e_args[0] = arg_x; + arg_cons->e_args[1] = arg_y; + lhs = NewValueExp (inffunct_sym, False, 1); + lhs->e_args[0] = arg_cons; + rhs = NewValueExp (inffunct_sym, False, 1); + rhs->e_args[0] = arg_y; + + alt->fun_lhs = lhs; + alt->fun_rhs = rhs; + + lhs = NewValueExp (inffunct_sym, False, 1); + lhs->e_args[0] = nil_exp; + rhs = nil_exp; + alt2->fun_lhs = lhs; + alt2->fun_rhs = rhs; +} + +static void BuildBotmemFunction (Fun *f) +{ + Alts alt, alt2; + Exp lhs, rhs, arg_cons, arg_x, arg_y, strict_rhs, nil_exp; + + /* the following function is built: + + E3 (Cons x y) = Strict x (E3 y) + E3 Nil = Nil + + */ + + f->fun_symbol = Null; + f->fun_arity = 1; + f->fun_kind = Function; + f->fun_strictargs = InitNewStrictInfos (1, HnfStrict); + f->fun_single = False; + InitStrictResult (& f->fun_strictresult); + + f->fun_alts = alt = SAllocType (AltsRepr); + alt2 = SAllocType (AltsRepr); + alt->fun_has_fail = False; + alt->fun_next = alt2; + alt2->fun_has_fail = False; + alt2->fun_next = Null; + + nil_exp = NewValueExp (nilsym, True, 0); + arg_x = NewExp (Argument, 0, False, 1); + arg_y = NewExp (Argument, 0, False, 1); + arg_cons = NewValueExp (conssym, True, 2); + arg_cons->e_args[0] = arg_x; + arg_cons->e_args[1] = arg_y; + lhs = NewValueExp (botmemfunct_sym, False, 1); + lhs->e_args[0] = arg_cons; + rhs = NewValueExp (botmemfunct_sym, False, 1); + rhs->e_args[0] = arg_y; + + strict_rhs = NewValueExp (strict_sym[0], False, 2); + strict_rhs->e_args[0]= arg_x; + strict_rhs->e_args[1]= rhs; + + alt->fun_lhs = lhs; + alt->fun_rhs = strict_rhs; + + lhs = NewValueExp (botmemfunct_sym, False, 1); + lhs->e_args[0] = nil_exp; + rhs = nil_exp; + alt2->fun_lhs = lhs; + alt2->fun_rhs = rhs; +} + +static void init_predefined_symbols (void) +{ + unsigned i; + Fun *f,*funs; + unsigned nr_funs; + + /* add entries for tuples (MaxTupleArity), selectors (MaxTupleArity), + strict functions (for strict annots), lists (2), conditional (4) + and the apply. Also for the two list functions if necessary. + */ + nr_funs = MaxNodeArity + MaxNodeArity + MaxNrAnnots + 2 + 4 + 1; + if (StrictDoLists) + nr_funs += 2; + + /* allocate enough space for the function table */ + funs = (Fun *) SAlloc ((unsigned long) nr_funs * sizeof (Fun)); + + /* initialise the function table with tuples */ + for (i = 0, f = funs; i < MaxNodeArity; i++, f++){ + tuplesym[i] = f; + f->fun_symbol = Null; /* TupleDefs[i]; */ + f->fun_arity = i; + f->fun_kind = Constructor; + f->fun_strictargs = Null; + f->fun_single = True; + InitStrictResult (& f->fun_strictresult); + } + + /* initialise the function table with selectors and update functions */ + for (i = 0; i < MaxNodeArity; i++,f++){ + selectsym[i] = f; + f->fun_symbol = Null; + f->fun_arity = 1; + f->fun_kind = SelFunction; + f->fun_strictargs = InitNewStrictInfos (1, HnfStrict); + f->fun_single = False; + InitStrictResult (& f->fun_strictresult); + } + +#if MORE_ANNOTS + { + StrictInfo *shared_strict_infos; + + shared_strict_infos=InitNewStrictInfos (MaxNrAnnots+1,HnfStrict); + +#endif + /* initialise the function table with strict functions */ + for (i = 0; i < MaxNrAnnots; i++,f++){ + strict_sym[i] = f; + f->fun_symbol = Null; + f->fun_arity = i+2; + f->fun_kind = StrictFunction; +#if MORE_ANNOTS + f->fun_strictargs = shared_strict_infos; +#else + f->fun_strictargs = InitNewStrictInfos (i+2, HnfStrict); +#endif + f->fun_single = False; + InitStrictResult (& f->fun_strictresult); + } + +#if MORE_ANNOTS + } +#endif + + /* initialise the function table with lists, conditional and apply */ + nilsym = f; + f->fun_symbol = Null; + f->fun_arity = 0; + f->fun_kind = Constructor; + f->fun_strictargs = Null; + f->fun_single = False; + InitStrictResult (& f->fun_strictresult); + f++; + + conssym = f; + f->fun_symbol = Null; + f->fun_arity = 2; + f->fun_kind = Constructor; + f->fun_strictargs = Null; + f->fun_single = False; + InitStrictResult (& f->fun_strictresult); + f++; + + if_sym = f; + f->fun_symbol = Null; + f->fun_arity = 3; + f->fun_kind = IfFunction; + f->fun_strictargs = InitNewStrictInfos (3, NotStrict); + f->fun_single = False; + InitStrictInfo (f->fun_strictargs, HnfStrict); + InitStrictResult (& f->fun_strictresult); + f++; + + true_sym = f; + f->fun_symbol = Null; + f->fun_arity = 0; + f->fun_kind = Constructor; + f->fun_strictargs = Null; + f->fun_single = False; + InitStrictResult (& f->fun_strictresult); + f++; + + false_sym = f; + f->fun_symbol = Null; + f->fun_arity = 0; + f->fun_kind = Constructor; + f->fun_strictargs = Null; + f->fun_single = False; + InitStrictResult (& f->fun_strictresult); + f++; + + fail_sym = f; + f->fun_symbol = Null; + f->fun_arity = 0; + f->fun_kind = FailFunction; + f->fun_strictargs = Null; + f->fun_single = False; + InitStrictResult (& f->fun_strictresult); + f++; + + apsym = f; + f->fun_symbol = Null; + f->fun_arity = 2; + f->fun_kind = ApFunction; + f->fun_strictargs = InitNewStrictInfos (2, NotStrict); + f->fun_single = False; + InitStrictInfo (f->fun_strictargs, HnfStrict); + InitStrictResult (& f->fun_strictresult); + f++; + + /* initialise the function table with the inf and botmem function function */ + if (StrictDoLists){ + inffunct_sym = f; + BuildInfFunction (f); + f++; + + botmemfunct_sym = f; + BuildBotmemFunction (f); + f++; + } +} + +static void convert_imp_rule_type (SymbDef sdef) +{ + Fun *f; + unsigned arity; + TypeAlts rule_type; + + f=SAllocType (Fun); + + sdef->sdef_sa_fun = f; + arity = sdef->sdef_arity; + + f->fun_kind = Function; + f->fun_symbol = sdef; + f->fun_arity = arity; + + rule_type = sdef->sdef_rule->rule_type; +/* + #ifdef _DB_ + printf ("ConvertStateInfoToStrictInfos %s\n",sdef->sdef_ident->ident_name); + #endif +*/ + ConvertStateInfoToStrictInfos (rule_type,arity, &f->fun_strictargs, &f->fun_strictresult, !StrictChecks); +} + +static void convert_imp_rule_alts (SymbDef sdef) +{ + Fun *f; + + f=sdef->sdef_sa_fun; + if (f->fun_kind==Function){ + ImpRules rule; + + rule = f->fun_symbol->sdef_rule; + ConvertAlternatives (&f->fun_alts,rule->rule_alts); + } else + f->fun_alts = NULL; +} + +static void ConvertSyntaxTree (Symbol symbols) +{ + unsigned arity; + Symbol sym; + Bool annot_warning; + SymbDef sdef; + Fun *f; + + annot_warning = False; + + init_predefined_symbols(); + + /* initialise the function table with constructors */ + for_l (sym,symbols,symb_next) + if (sym->symb_kind==definition){ + sdef = sym->symb_def; + + if (sdef->sdef_kind==TYPE){ + ConstructorList talts; + + for_l (talts,sdef->sdef_type->type_constructors,cl_next){ + SymbDef cdef; + + f=SAllocType (Fun); + + cdef = talts->cl_constructor->type_node_symbol->symb_def; + + cdef->sdef_sa_fun = f; + f->fun_symbol = cdef; + arity = f->fun_arity = cdef->sdef_arity; + f->fun_single = False; + f->fun_kind = Constructor; + f->fun_single = cdef->sdef_type->type_nr_of_constructors == 1; + + cdef->sdef_constructor=talts; + + if (cdef->sdef_strict_constructor) + ConvertTypeArgsToStrictInfos (talts->cl_constructor->type_node_arguments,arity,&f->fun_strictargs, True); + else + f->fun_strictargs = NULL; + + InitStrictResult (& f->fun_strictresult); + } + } else if (sdef->sdef_kind==RECORDTYPE){ + f=SAllocType (Fun); + + sdef->sdef_sa_fun = f; + f->fun_symbol = sdef; + arity = f->fun_arity = sdef->sdef_cons_arity; + f->fun_kind = Constructor; + f->fun_single = True; + + if (sdef->sdef_strict_constructor) + ConvertTypeArgsToStrictInfos (TypeArgsOfRecord (sdef), arity,&f->fun_strictargs, True); + else + f->fun_strictargs = Null; + + InitStrictResult (& f->fun_strictresult); + } + } + + /* initialise the function table with symbols with a definition */ + for_l (sdef,scc_dependency_list,sdef_next_scc) + if (sdef->sdef_kind==IMPRULE && sdef->sdef_over_arity==0) + convert_imp_rule_type (sdef); + + /* convert the rules */ + for_l (sdef,scc_dependency_list,sdef_next_scc) + if (sdef->sdef_kind==IMPRULE && sdef->sdef_over_arity==0) + convert_imp_rule_alts (sdef); + + /* give a warning for annotated functions */ + if (annot_warning && StrictAllWarning) + GiveStrictWarning ((char *) Null, "no strictness analysis for functions with code blocks"); +} + +static void update_function_strictness (SymbDef sdef) +{ + Fun *f; + unsigned arity; + + f=sdef->sdef_sa_fun; + + arity = f->fun_arity; + + if (f->fun_kind == Function){ + TypeAlts rule; + Bool strict_added,warning; + + rule = sdef->sdef_rule->rule_type; + +#if 0 + printf ("%s\n",sdef->sdef_ident->ident_name); +#endif + + strict_added = False; + warning = False; + UpdateStateInfosWithStrictInfos (rule, arity, f->fun_strictargs, &f->fun_strictresult,&strict_added, &warning); + + if (strict_added && sdef->sdef_exported){ + if (DoListStrictTypes && ! DoListAllTypes) + PrintType (sdef, rule); + else + export_warning = True; + } + + if (warning && (StrictAllWarning || StrictChecks)) + GiveStrictWarning (sdef->sdef_ident->ident_name, "not all user annotations could be derived"); + + if (export_warning && (StrictAllWarning || StrictExportChecks)) + GiveStrictWarning (sdef->sdef_ident->ident_name, "function not annotated as being strict in definition module"); + } +} + +static void UpdateSyntaxTree (void) +{ + SymbDef sdef; + + for_l (sdef,scc_dependency_list,sdef_next_scc) + if (sdef->sdef_kind==IMPRULE && sdef->sdef_over_arity==0) + update_function_strictness (sdef); +} + +/******************************************************************************* + * The Abstract Reducer * + ******************************************************************************/ + +static Bool ReduceInContext (ExpP ep, Path p, Context context); + +static int rel_depth = 0; + +static Bool CheckRelation (Exp e, Path p, Context context) +{ + Exp exp_new, exp_cq, exp_dum; + Bool result; + unsigned old_fuel; + + /* + FPrintF (outfile, "\n\nAreRelated?"); + FPrintF (outfile, "\ne: "); + DumpExp (outfile, e); + FPrintF (outfile, "\np->e: "); + DumpExp (outfile, p->p_exp); + FPrintF (outfile, "\nexp1: "); + DumpExp (outfile, *s_exp1); + FPrintF (outfile, "\nexp2: "); + DumpExp (outfile, *s_exp2); + FPrintF (outfile, "\n"); + */ + + /* check if there is a common subexpression */ + if (! IsContainedIn (*s_exp2, s_exp1)) + return False; + + /* + FPrintF (outfile, "Yes\nqexp: "); + DumpExp (outfile, *q_exp); + FPrintF (outfile, "\n\n"); + */ + + rel_depth++; + +#ifdef _DB_EQ_ + if (DBPrinting){ + FPrintF (outfile, "Result: AreRelated ("); + DumpExp (outfile, *s_exp1); + FPrintF (outfile, ", "); + DumpExp (outfile, *s_exp2); + FPrintF (outfile, ", "); + DumpExp (outfile, *q_exp); + FPrintF (outfile, ")\n\n"); + } +#endif /* _DB_EQ_ */ + + /* we have the following situation (e is a growing expression) + e = C[C"[q]] + p->e = C[q] + + with + s_exp1 = C"[q] + s_exp2 = q (inside p->e) + q_exp = q (inside C"[q]) + + we will reduce + C[x : <q, C"[x]>] + */ + + /* fetch C"[q] from e (i.e. replace it by a copy) */ + exp_cq = InstantiateExp (*s_exp1); + exp_dum = *s_exp1; + *s_exp1 = exp_cq; + exp_cq = exp_dum; + + /* replace q by <expcq,q>, but only if q is not Bot */ + if ((*q_exp)->e_kind == Bottom) + *q_exp = exp_cq; + else + { exp_dum = NewExp (Lub, 2, True, 2); + exp_dum->e_args[0] = exp_cq; + exp_dum->e_args[1] = *q_exp; + *q_exp = exp_dum; + SortExpOfKind (exp_dum, Lub); + } + + /* create an expression to be reduced: C[q] becomes C[exp_cq] */ + exp_dum = InstantiateExp (p->p_exp); + exp_new = p->p_exp; + p->p_exp = exp_dum; + *s_exp2 = exp_cq; + + /* instantiate ?? */ + exp_new = InstantiateExp (exp_new); + +#ifdef _DB_RED_ + if (DBPrinting) + FPrintF (outfile, "Relation (%d) --> ", rel_depth); +#endif + + old_fuel = start_fuel; + result = ReduceInContext (&exp_new, (Path) Null, CopyContext (context)); + start_fuel = old_fuel; + +#ifdef _DB_RED_ + if (DBPrinting) + FPrintF (outfile, "\n<-- End relation (%d)\n", rel_depth); +#endif + + rel_depth--; + return result; +} + +static Bool IsInPath (Exp e, Path p, Exp *r, Context context) +{ + for ( ; p; p = p->p_next){ + Bool b; + + CheckAreRelated = DoStrictRelated; + + b = LtExp (e, p->p_exp); + + CheckAreRelated = False; + + if (b == True){ + *r = p->p_root; + return True; + } else if (b == AreRelated){ + if (CheckRelation (e, p, context)){ + *r = p->p_root; + return True; + } + } + } + return False; +} + +static Path AddToPath (Exp e, Path p) +{ + Path new; + + if (! StrictDoPaths) + return p; + + if (e->e_kind != Value || e->e_fun->fun_kind != Function) + return p; + + if (! StrictDoAllPaths && p && p->p_exp->e_kind == Value && p->p_exp->e_fun->fun_symbol && + p->p_exp->e_fun->fun_symbol->sdef_ancestor != e->e_fun->fun_symbol->sdef_ancestor) + return p; + + new = SAllocType (PathRepr); + + new->p_exp = InstantiateExp (e); + new->p_root = e; + new->p_next = p; + return new; +} + +/* +static Path AddToPath (Exp e, Path p) +{ Path new, p2; + + if (! StrictDoPaths) + return p; + + if (e->e_kind != Value || e->e_fun->fun_kind != Function) + return p; + + if (! StrictDoAllPaths && p && p->p_exp->e_kind == Value && p->p_exp->e_fun->fun_symbol && + p->p_exp->e_fun->fun_symbol->sdef_ancestor != e->e_fun->fun_symbol->sdef_ancestor) + return p; + + new = SAllocType (PathRepr); + + new->p_exp = InstantiateExp (e); + new->p_root = e; + new->p_next = Null; + + if (! p) + return new; + + for (p2 = p; p2->p_next; p2 = p2->p_next) + ; + + p2->p_next = new; + + return p; +} AddToPath +*/ + +static MatchKind CombineWithPartialMatch (MatchKind m) +{ + switch (m){ + case InfiniteMatch: + case PartialInfiniteMatch: + return PartialInfiniteMatch; + case NoMatch: + return NoMatch; + case LubMatch: + return LubMatch; + case ReduceMatch: + return ReduceMatch; + default: + return PartialMatch; + } +} + +static void BindArgsToTop (Exp *args, unsigned arity, Bool *no_patterns) +{ + unsigned i; + + for (i = 0; i < arity; i++){ + switch (args[i]->e_kind){ + case Argument: + args[i]->e_args[0] = NewTop(); + continue; + case Value: + if (! args[i]->e_fun->fun_single) + *no_patterns = False; + BindArgsToTop (args[i]->e_args, args[i]->e_fun->fun_arity, no_patterns); + break; + case Lub: + Assume2 (False, "Lub in pattern", "BindArgsToExp"); + default: + *no_patterns = False; + } + } +} + +static Bool ReduceDepExpression (Exp e, Path p, Context context) +{ + unsigned arity, i; + + arity = e->e_sym; + + for (i = 0; i < arity; i++){ + if (ReduceInContext (& e->e_args[i], p, NewSimpleContext (HnfStrict, context->context_speculative))) + return True; + } + + SortExpOfKind (e, Dep); + + if (e->e_kind == Bottom) + return True; + + /* collect all dependencies, and replace by Top */ + arity = e->e_sym; + for (i = 0; i < arity; i++) + { if (e->e_args[i]->e_kind != Bottom) + e->e_deps = AddDeps (e->e_args[i]->e_deps, e->e_deps); + } + e->e_kind = Top; + e->e_hnf = True; + + return False; +} + +static Exp ConvertExpWithContext (Exp e, Context context) +{ + if (context->context_arity != 1) + return e; + + switch (context->context_kind){ + case SpineStrict: + { + Exp new; + + new = NewValueExp (inffunct_sym, False, 1); + new->e_args[0] = e; + return new; + } + case TailStrict: + { + Exp new; + + new = NewValueExp (botmemfunct_sym, False, 1); + new->e_args[0] = e; + return new; + } + default: + return e; + } +} + +static Bool CheckStrictArgsOfFunction (Exp e, Path p, Context context) +{ + unsigned arity, i; + Fun *f; + StrictInfo *strictargs; + Context newcontext; + Exp new, *args; + Dependency newdeps; + + f = e->e_fun; + args = e->e_args; + newdeps = e->e_deps; + + if (! (strictargs = f->fun_strictargs)) + return False; + + arity = f->fun_arity; + for (i = 0; i < arity; i++){ + newcontext = StrictInfoToContext (& strictargs[i], context, False); + if (! IsStrictContext (newcontext)) + continue; + + new = ConvertExpWithContext (args[i], newcontext); + + if (ReduceInContext (& new, p, newcontext)) + return True; + + CopyDeps (new->e_deps, & newdeps); + } + + e->e_deps = newdeps; + return False; +} + +static Exp TakeContextLub (ExpP ep1, ExpP ep2, Path p, Context context) +{ + if (*ep1){ + if (ReduceInContext (ep1, p, context)) + *ep1 = & bottom; + } else + *ep1 = & bottom; + + if (*ep2){ + if (ReduceInContext (ep2, p, context)) + *ep2 = & bottom; + } else + *ep2 = & bottom; + + return TakeLub (*ep1, *ep2); +} + +static MatchKind MatchArgs (Exp args_act[], Exp args_for[], unsigned n, Dependency *dep, ExpP *e_stopp); + +static MatchKind MatchExp (ExpP ep_act,Exp e_for,Dependency *dep,Exp **e_stopp) +{ + MatchKind m; + + if (e_for->e_kind==Argument){ + e_for->e_args[0] = *ep_act; + return TotalMatch; + } else if (!(*ep_act)->e_hnf){ + *e_stopp = ep_act; + return ReduceMatch; + } else if ((*ep_act)->e_kind == Bottom) + return InfiniteMatch; + else if ((*ep_act)->e_kind == Lub){ + *e_stopp = ep_act; + return LubMatch; + } + + /* the formal argument is a pattern, the actual argument a reduce, non-Bottom, non-Lub + value, so start the pattern matching + */ + + switch (e_for->e_kind){ + case Top: + m = PartialMatch; + break; + case FunValue: + if ((*ep_act)->e_kind == FunValue){ + if (e_for->e_fun == (*ep_act)->e_fun){ + m = TotalMatch; + break; + } else + return NoMatch; + } + m = PartialMatch; + break; + case Value: + switch ((*ep_act)->e_kind){ + case Top: + case Dep: + case Ind: + { + Bool no_patterns; + + /* In case of a constructor with only one alternative we have a TotalMatch */ + no_patterns = True; + BindArgsToTop (e_for->e_args, e_for->e_fun->fun_arity, &no_patterns); + + if (no_patterns && e_for->e_fun->fun_single) + m = TotalMatch; + else + m = PartialMatch; + break; + } + case Value: + if ((*ep_act)->e_fun != e_for->e_fun) + return NoMatch; + + m = MatchArgs ((*ep_act)->e_args, e_for->e_args, (*ep_act)->e_fun->fun_arity, dep, e_stopp); + if (m != PartialMatch && m != TotalMatch) + return m; + break; + default: + Assume (False, "illegal case", "MatchExp"); + return NoMatch; + } + break; + default: + Assume (False, "illegal case", "MatchExp"); + return NoMatch; + } + + /* we have a partial or total match, test now for dependencies */ + if ((*ep_act)->e_deps && (*ep_act)->e_kind != Bottom) + CopyDeps ((*ep_act)->e_deps, dep); + + return m; +} + +static MatchKind MatchArgs (Exp args_act[],Exp args_for[],unsigned n,Dependency *dep,ExpP *e_stopp) +{ + MatchKind m; + + if (n == 0) + return TotalMatch; + + m = MatchExp (&args_act[0],args_for[0],dep,e_stopp); + + switch (m){ + case LubMatch: + case ReduceMatch: + case NoMatch: + case InfiniteMatch: + case PartialInfiniteMatch: + return m; + case PartialMatch: + return CombineWithPartialMatch (MatchArgs (&args_act[1], &args_for[1], n-1, dep, e_stopp)); + case TotalMatch: + return MatchArgs (&args_act[1], &args_for[1], n-1, dep, e_stopp); + default: + Assume (False, "unknown case", "MatchArgs"); + return NoMatch; + } +} + +static MatchKind MatchAlternative (Exp *ep,Exp *args_act,Exp *args_for,Alts alt,unsigned n,Dependency rootdeps,Path p,Context context); + +static MatchKind MatchAlternative (Exp *ep,Exp *args_act,Exp *args_for,Alts alt,unsigned n,Dependency rootdeps,Path p,Context context) +{ + MatchKind m; + ExpP e_stopp; + Dependency newdeps; + + newdeps = NULL; + *ep = NULL; + + m = MatchArgs (args_act,args_for,n,&newdeps,&e_stopp); + + switch (m){ + case LubMatch: + { + Exp next_e,*lub_args,e_stop; + unsigned k, i; + MatchKind next_m; + + next_e = NULL; + + /* store the Lub expression (it can be changed by future reductions, but the argument vector cannot) */ + + e_stop = *e_stopp; + lub_args = e_stop->e_args; + k = e_stop->e_sym; + m = NoMatch; + + /* replace the Lub expression with all its elements */ + for (i = 0; i < k; i++){ + *e_stopp = lub_args[i]; + + next_m = MatchAlternative (&next_e, args_act, args_for, alt, n, rootdeps, p, context); + + switch (next_m){ + case NoMatch: + if (m == TotalMatch) + m = PartialMatch; + continue; + case InfiniteMatch: + case PartialInfiniteMatch: + if (m == NoMatch) + m = PartialInfiniteMatch; + continue; + case PartialMatch: + m = PartialMatch; + *ep = TakeContextLub (ep, &next_e, p, context); + break; + case TotalMatch: + if (m == NoMatch && i == 0) + m = TotalMatch; + else if (m != TotalMatch) + m = PartialMatch; + *ep = TakeContextLub (ep, &next_e, p, context); + break; + } + } + + /* restore the original expression */ + *e_stopp = e_stop; + + /* return the match result */ + if (m == LubMatch) + m = NoMatch; + break; + } + case ReduceMatch: + ReduceInContext (e_stopp, p, NewSimpleContext (HnfStrict, False)); + return MatchAlternative (ep, args_act, args_for, alt, n, rootdeps, p, context); + case InfiniteMatch: + case PartialInfiniteMatch: + case NoMatch: + break; + case PartialMatch: + case TotalMatch: +#ifdef _DB_ +# ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (alt->fun_switch_alts==NULL) +# endif + if (!ArgsBound (alt->fun_rhs)){ + FPrintF (StdError, "WARNING!!!\n"); + if (alt->fun_lhs==NULL) + FPutS ("NULL",StdError); + else + DumpExp (StdError, alt->fun_lhs); + FPutC ('\n', StdError); + DumpExp (StdError, alt->fun_rhs); + FPutC ('\n', StdError); + DumpExp (StdError, *args_act); + FPutC ('\n', StdError); + /* Assume (False, "Not all args bound", "MatchAlternative"); */ + } +#endif + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (alt->fun_switch_alts==NULL){ +#endif + +#ifdef _DB_ + fprintf (outfile,"InstantiateExp: "); + DumpExp (outfile,alt->fun_rhs); + fprintf (outfile,"\n"); +#endif + + *ep = InstantiateExp (alt->fun_rhs); + + if ((*ep)->e_kind!=Bottom){ + CopyDeps (rootdeps,&newdeps); + (*ep)->e_deps = newdeps; + } + +#if 1 /* JVG */ + if (m==TotalMatch && alt->fun_has_fail && (*ep)->e_kind==Value && (*ep)->e_fun->fun_kind==IfFunction){ + (*ep)->e_red = True; + + if (CheckStrictArgsOfFunction (*ep,p,context)){ + UpdateExp (&bottom,*ep); + (*ep)->e_red = False; + return InfiniteMatch; + } + + (*ep)->e_red = False; + } +#endif + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + } else { + if (!alt->fun_is_guard){ + Exp switch_arg_exp,new_e,next_e; + Alts switch_alt; + MatchKind next_m; + + switch_arg_exp=alt->fun_rhs; + if (switch_arg_exp->e_kind!=Argument) + error_in_function ("MatchAlternative"); + + switch_arg_exp=switch_arg_exp->e_args[0]; + next_e=NULL; + new_e=NULL; + + for_l (switch_alt,alt->fun_switch_alts,fun_next){ + if (switch_alt->fun_lhs!=NULL){ + next_m=MatchAlternative (&next_e,&switch_arg_exp,&switch_alt->fun_lhs,switch_alt,1,rootdeps,p,context); +# if 0 && defined(_DB_) + fprintf (outfile,"MatchAlternative\nactual arg = "); + DumpExp (outfile,switch_arg_exp); + fprintf (outfile,"\nformal arg = "); + DumpExp (outfile,switch_alt->fun_lhs); + fprintf (outfile,"\n"); +# endif + } else + next_m=MatchAlternative (&next_e,&switch_arg_exp,&switch_alt->fun_lhs,switch_alt,0,rootdeps,p,context); + + switch (next_m){ + case NoMatch: + case PartialInfiniteMatch: + continue; + case InfiniteMatch: + if (new_e==NULL) + new_e=⊥ + break; + case PartialMatch: + new_e=TakeContextLub (&new_e,&next_e,p,context); + if (new_e->e_kind==Top && new_e->e_deps==NULL) + break; + continue; + case TotalMatch: + new_e=TakeContextLub (&new_e,&next_e,p,context); + if (switch_alt->fun_has_fail) + continue; + break; + default: + error_in_function ("MatchAlternative"); + } + break; + } + + *ep=new_e; + } else { + Exp new_e,next_e,dummy_exp; + MatchKind next_m; + + new_e = InstantiateExp (alt->fun_rhs); + + if (new_e->e_kind!=Bottom){ + CopyDeps (rootdeps,&newdeps); + new_e->e_deps = newdeps; + } + + if (m==TotalMatch && new_e->e_kind==Value && new_e->e_fun->fun_kind==IfFunction){ + new_e->e_red = True; + + if (CheckStrictArgsOfFunction (new_e,p,context)){ + UpdateExp (&bottom,new_e); + new_e->e_red = False; + *ep=new_e; + return InfiniteMatch; + } + + new_e->e_red = False; + } + + dummy_exp=NULL; + next_m=MatchAlternative (&next_e,&dummy_exp,&dummy_exp,alt->fun_switch_alts,0,rootdeps,p,context); + + switch (next_m){ + case NoMatch: + case PartialInfiniteMatch: + break; + case InfiniteMatch: + if (new_e==NULL) + new_e=⊥ + break; + case PartialMatch: + new_e=TakeContextLub (&new_e,&next_e,p,context); + break; + case TotalMatch: + new_e=TakeContextLub (&new_e,&next_e,p,context); + break; + default: + error_in_function ("MatchAlternative"); + } + + *ep=new_e; + } + } +#endif + break; + default: + Assume (False, "illegal case", "MatchAlternative"); + } + + return m; +} + +/******************************************************************************* + * Support for indirections * + ******************************************************************************/ + +static Bool ContainsIndirection2 (Exp e) +{ + unsigned i,arity; + + if (e->e_mark) + return False; + + if (e->e_deps) + return True; + + switch (e->e_kind){ + case Bottom: + case Top: + case FunValue: + return False; + case Ind: + return True; + case Value: + e->e_mark = True; + arity = e->e_fun->fun_arity; + break; + case Dep: + case Lub: + e->e_mark = True; + arity = e->e_sym; + break; + default: + Assume (False, "illegal case", "ContainsIndirection"); + return False; + } + + /* Only reached if kind is Value, Dep or Lub */ + for (i = 0; i < arity; i++) + if (ContainsIndirection2 (e->e_args[i])) + return True; + + return False; +} + +static Bool ContainsIndirection (Exp e) +{ + Bool res; + + res = ContainsIndirection2 (e); + + RemoveMark (e); + + return res; +} + +static Bool IsInEachAlt2 (Exp e, Exp root) +{ + unsigned i; + + if (e->e_mark) + return False; + + if (e->e_deps){ + Dependency deps; + + for (deps = e->e_deps; deps; deps = deps->dep_next) + if (deps->dep_exp == root) + return True; + } + + switch (e->e_kind){ + case Bottom: + return True; + case Top: + case FunValue: + return False; + case Ind: + /* it is sufficient that there is an indirection. + let: t -> t' -> C[t,t'] + and suppose we are solving indirections to t'. + Other indirections are to t, but since: + + C[t,t'] -> C[t',t'] + + they can also be considered indirections to t'. + */ + return True; + case Dep: + case Value: + { + int arity; + + if (e->e_hnf && e->e_kind != Dep) + return False; + + if (e->e_kind==Value) + arity=e->e_fun->fun_arity; + else + arity=e->e_sym; + + e->e_mark = True; + for (i = 0; i < arity; i++){ + if (IsInEachAlt2 (e->e_args[i], root)){ + e->e_mark = False; + return True; + } + } + e->e_mark = False; + return False; + } + case Lub: + e->e_mark = True; + for (i = 0; i < e->e_sym; i++) + { if (! IsInEachAlt2 (e->e_args[i], root)) + { e->e_mark = False; + return False; + } + } + e->e_mark = False; + return True; + default: + Assume (False, "illegal case", "IsInEachAlt2"); + return False; + } +} + +static Bool IsInEachAlt (Exp e, Exp root) +{ + Bool res; + + res = IsInEachAlt2 (e, root); + + return res; +} + +static void ReplaceIndByBottom (Exp e, Exp root) +{ + unsigned i, arity; + + if (e->e_imark) + return; + + if (e->e_deps){ + Dependency deps; + + for (deps = e->e_deps; deps; deps = deps->dep_next){ + if (deps->dep_exp == root){ + e->e_kind = Bottom; + e->e_hnf = True; + e->e_deps = Null; + return; + } + } + } + + switch (e->e_kind){ + case Bottom: + case Top: + case FunValue: + return; + case Ind: + e->e_kind = Bottom; + e->e_hnf = True; + e->e_deps = Null; + return; + case Value: + e->e_imark = True; + arity = e->e_fun->fun_arity; + break; + case Lub: + case Dep: + e->e_imark = True; + arity = e->e_sym; + break; + default: + Assume (False, "illegal case", "ReplaceIndByBottom"); + return; + } + + /* Only reached if kind is Value or Lub */ + for (i = 0; i < arity; i++) + ReplaceIndByBottom (e->e_args[i], root); +} /* ReplaceIndByBottom */ + +static void ReplaceIndByPtr (Exp *e, Exp root) +{ + unsigned i, arity; + + if ((*e)->e_imark) + return; +/* + if ((*e)->e_deps) + { Dependency deps; + + for (deps = (*e)->e_deps; deps; deps = deps->dep_next) + { if (deps->dep_exp == root) + { *e = root; + return; + } + } + } +*/ + switch ((*e)->e_kind){ + case Bottom: + case Top: + case FunValue: + return; + case Ind: + if (root == (*e)->e_args[0]) + *e = root; + return; + case Value: + (*e)->e_imark = True; + arity = (*e)->e_fun->fun_arity; + break; + case Lub: + case Dep: + (*e)->e_imark = True; + arity = (*e)->e_sym; + break; + default: + Assume (False, "illegal case", "ReplaceIndByPtr"); + return; + } + + /* Only reached if kind is Value or Lub */ + for (i = 0; i < arity; i++) + ReplaceIndByPtr (& (*e)->e_args[i], root); +} /* ReplaceIndByPtr */ + +static void RemoveMarksAndLubs (Exp e) +{ + unsigned arity, i; + + if (! e->e_imark) + return; + + e->e_imark = False; + switch (e->e_kind){ + case Bottom: + case Top: + case Ind: + case FunValue: + Assume2 (False, "e is marked illegal", "RemoveMarksAndLubs"); + return; + case Value: + arity = e->e_fun->fun_arity; + break; + case Lub: + case Dep: + arity = e->e_sym; + break; + default: + Assume (False, "illegal case", "RemoveMarksAndLubs"); + return; + } + + /* Only reached if kind is Value or Lub */ + for (i = 0; i < arity; i++) + RemoveMarksAndLubs (e->e_args[i]); + + if (e->e_kind == Lub) + SortExpOfKind (e, Lub); +} /* RemoveMarksAndLubs */ + +static void ResolveIndirections (ExpP rootp, Path p, Context context) +{ + if (! (*rootp)->e_hasind) + return; + + if (IsInEachAlt (*rootp, *rootp)) + ReplaceIndByBottom (*rootp, *rootp); + else + ReplaceIndByPtr (rootp, *rootp); + + RemoveMarksAndLubs (*rootp); + if ((*rootp)->e_kind == Value) + (*rootp)->e_hnf = False; + ReduceInContext (rootp, p, context); +} + +/******************************************************************************* + * * + * Reduction functions for the various kinds of functions * + + They are called by 'Reduce'. Note that right type of the expression + and reductions of strict arguments are checked by 'Reduce' + + ReduceStrict + Strict !s1...!sn x -> x; + ReduceIf + If !Bool x x -> x; + ReduceAp + Ap !(x -> y) x -> y; + ReduceSelection + SelectN !(x1....xM) -> xN; + ReduceFunction + general function call + + * * + ******************************************************************************/ + +static Exp GetResultOfFunctionApplication (Exp e, Path p, Context context) +{ + MatchKind m; + Exp new_e,next_e; + Alts alt; + Fun * f; +#ifdef _DB_RED_ + unsigned i; +#endif + + new_e = NULL; + next_e = NULL; + + f = e->e_fun; + +#ifdef _DB_RED_ + for (alt = f->fun_alts, i = 1; alt!=NULL; alt = alt->fun_next, i++){ +#else + for_l (alt,f->fun_alts,fun_next){ +#endif + m = MatchAlternative (&next_e,e->e_args,alt->fun_lhs->e_args,alt,f->fun_arity,e->e_deps,p,context); + +#ifdef _DB_RED_ + if (DBPrinting){ + DumpMatch (outfile, m); + FPrintF (outfile, " (%s, %d)\n", f->fun_symbol ? f->fun_symbol->sdef_ident->ident_name : "??", i); + } +#endif + + switch (m){ + case NoMatch: + case PartialInfiniteMatch: + continue; + case InfiniteMatch: + if (new_e) + return new_e; + else + return & bottom; + case PartialMatch: + new_e = TakeContextLub (&new_e, &next_e, p, context); + if (new_e->e_kind == Top && ! new_e->e_deps) + return new_e; + continue; + case TotalMatch: + new_e = TakeContextLub (&new_e, &next_e, p, context); + /* consider it as a partial match if the right hand side leads to a fail reduction */ + if (alt->fun_has_fail) + continue; + return new_e; + default: + Assume (False, "unknown case", "GetResultOfFunctionApplication"); + } + } + + if (new_e) + return new_e; + else + return ⊥ +} + +static Exp ReduceFunction (Exp e, Path p, Context context) +{ + Exp result; + StrictInfo *r; + Context newcontext; + + r = &e->e_fun->fun_strictresult; + newcontext = StrictInfoToContext (r, context, True); + + result = GetResultOfFunctionApplication (e, p, newcontext); +/* JVG */ + if (ReduceInContext (&result, p, newcontext)) +/* + if (ReduceInContext (&result, p, context)) +*/ + return & bottom; + + return result; +} + +static Exp ReduceStrictFunction (Exp e, Path p, Context context) +{ + int arity; + + arity = e->e_fun->fun_arity; + + if (ReduceInContext (& e->e_args[arity-1], p, context)) + return & bottom; + else + return e->e_args[arity-1]; +} + +static Exp ReduceIfFunction (Exp e, Path p, Context context) +{ + Exp cond; + + cond = e->e_args[0]; + if (cond->e_kind == Value){ + Exp e2; + + if (cond->e_fun==true_sym) + e2 = e->e_args[1]; + else if (cond->e_fun==false_sym) + e2 = e->e_args[2]; + else + return TakeContextLub (& e->e_args[1], & e->e_args[2], p, context); + + if (ReduceInContext (& e2, p, context)) + return & bottom; + else + return e2; + } else + return TakeContextLub (& e->e_args[1], & e->e_args[2], p, context); + +} + +static Exp ReduceAp (Exp e, Path p, Context context) +{ + Exp e2; + unsigned n; + + /* walk through the left AP spine, note that this spine is in hnf !! */ + for (e2 = e, n = 0; ; e2 = e2->e_args[0], n++){ + if (e2->e_kind == Value && e2->e_fun->fun_kind == ApFunction) + continue; + else + break; + } + + switch (e2->e_kind){ + case Top: + case Dep: + case Ind: + if (IsSpeculativeContext (context)) + return e; + else + return NewTop(); + case Lub: + { Exp new_e = Null, next_e; + unsigned arity; + + /* if there is a lub, it should be the first element of the spine */ + Assume2 (n == 1, "strange Lub in AP spine", "ReduceAp"); + + /* replace the top most AP by a Lub of reduced AP nodes */ + arity = e2->e_sym; + + for (n = 0; n < arity; n++){ + next_e = NewValueExp (apsym, False, 2); + + next_e->e_args[0] = e2->e_args[n]; + next_e->e_args[1] = e->e_args[1]; + + new_e = TakeContextLub (& new_e, & next_e, p, context); + } + return new_e; + } + case Value: + case Bottom: + Assume2 (False, "first arg of AP not reduced, or type error", "ReduceAp"); + return NewTop(); + case FunValue: + { + unsigned arity; + Exp new; + + arity = e2->e_fun->fun_arity; + + if (arity != n){ + e->e_hnf = True; + return e; + } + new = NewValueExp (e2->e_fun, False, arity); + + for (e2 = e, n = arity; n > 0; e2 = e2->e_args[0], n--) + new->e_args[n-1] = e2->e_args[1]; + + if (ReduceInContext (& new, p, context)) + return & bottom; + else + return new; + } + default: + Assume (False, "unknown case", "ReduceAp"); + return NewTop(); + } +} + +static Exp GetSelection (Exp tuple_exp, unsigned n, Path p, Context context) +{ + switch (tuple_exp->e_kind){ + case Top: + case Dep: + case Ind: + return NewTop(); + case Bottom: + return & bottom; + case Value: + { ExpP argp; + + if (n >= tuple_exp->e_fun->fun_arity) + return & bottom; + + argp = & tuple_exp->e_args [n]; + if (ReduceInContext (argp, p, context)) + return & bottom; + else + return *argp; + } + default: + Assume (False, "illegal case", "GetSelection"); + return ⊤ + } +} + +static Exp ReduceSelector (Exp e, Path p, Context context) +{ + Exp tuple_exp, new_e; + unsigned i, arity; + + tuple_exp = e->e_args[0]; + if (tuple_exp->e_kind == Lub){ + /* try to take the selections of the elements of the lub */ + arity = tuple_exp->e_sym; + new_e = NewExp (Lub, arity, True, arity); + + for (i = 0; i < arity; i++) + new_e->e_args[i] = GetSelection (tuple_exp->e_args[i], e->e_fun - selectsym[0], p, context); + + if (new_e->e_kind == Lub) + SortExpOfKind (new_e, Lub); + return new_e; + } + else + return GetSelection (tuple_exp, e->e_fun - selectsym[0], p, context); +} + +/* The reduction engine */ + +static void ReduceArguments (Exp e) +{ + unsigned i, arity; + + arity = e->e_fun->fun_arity; + + for (i = 0; i < arity; i++){ +#ifdef _DB_ + printf ("Reduce argument %d\n",i); +#endif + (void) ReduceInContext (& e->e_args[i], (Path) Null, NewSimpleContext (HnfStrict, True)); +#ifdef _DB_ + printf ("End reduce argument %d\n",i); +#endif + } +} + +static Exp MakeIndirection (Exp e) +{ + Exp new; + + new = NewExp (Ind, 0, True, 1); + new->e_deps = SAllocType (DependencyRepr); + new->e_deps->dep_exp = e; + new->e_deps->dep_next = Null; + new->e_args[0] = e; + return new; +} + +static void Reduce (ExpP ep, Path p, Context context) +{ + Exp e2,e; + + e = *ep; + if (e->e_kind==Dep){ + if (ReduceDepExpression (e, p, context)){ + UpdateExp (& bottom, e); + e->e_red = False; + } + return; + } + + Assume (e->e_kind == Value, "illegal expression kind", "Reduce"); + + /* mark the node is being under reduction. The marking should be removed + before returning + */ + e->e_red = True; + +#ifdef DIVIDE_FUEL + { + unsigned int saved_fuel1,saved_fuel2; + + saved_fuel1=(start_fuel>>2); + saved_fuel2=(start_fuel>>1); + + start_fuel-=saved_fuel1; +#endif + + if (CheckStrictArgsOfFunction (e, p, context)){ +#ifdef DIVIDE_FUEL + start_fuel+=saved_fuel1; +#endif + e = *ep; + UpdateExp (& bottom, e); + e->e_red = False; + return; + } + +#ifdef DIVIDE_FUEL + start_fuel+=saved_fuel1; +#endif + + if (e->e_fun->fun_kind == Function && StrictDoEager){ +#ifdef DIVIDE_FUEL + if (start_fuel>saved_fuel2){ + start_fuel-=saved_fuel2; +#endif + e = *ep; + ReduceArguments (e); +#ifdef DIVIDE_FUEL + start_fuel+=saved_fuel2; + } +#endif + } +#ifdef DIVIDE_FUEL + } +#endif + + /* NOTE: the arguments have to be reduced before the next switches + statement, because 'ep' itself might be reduced by the above call + */ + + e = *ep; + if (e->e_kind != Value) + return; + + switch (e->e_fun->fun_kind){ + case Constructor: + e->e_red = False; + e->e_hnf = True; + return; + case Function: + e2 = ReduceFunction (e, p, context); + break; + case IfFunction: + e2 = ReduceIfFunction (e, p, context); + break; + case ApFunction: + e2 = ReduceAp (e, p, context); + break; + case SelFunction: + e2 = ReduceSelector (e, p, context); + break; + case StrictFunction: + e2 = ReduceStrictFunction (e, p, context); + break; + case FailFunction: + e2 = & bottom; + break; + default: + Assume (False, "illegal function kind", "Reduce"); + return; + } + + e->e_red = False; + UpdateExp (e2, e); +} + +static Bool CheckEndOfReductions (ExpP ep, Path p, Context context, Bool *result) +{ + Exp root, e; + + e = *ep; + + /* check the reduction context */ + if (! IsStrictContext (context)) + return True; + + /* check for hnf and simple context */ + if (e->e_hnf){ +/* JVG ??? 2-10-1998 */ + if (e->e_kind==Bottom){ + *result = True; + return True; + } +/* */ + if (context->context_arity == 1){ + *result = e->e_kind == Bottom; + return True; + } + } + + /* check if expression is already evaluated in speculative context */ + if (IsSpeculativeContext (context) && e->e_spechnf) + return True; + + /* check if current exp is already under reduction */ + if (e->e_red){ + *ep = MakeIndirection (e); + (*ep)->e_hasind = True; +#ifdef _DB_RED_ + if (DBPrinting){ + FPrintF (outfile, "Result is indirection: "); + DumpExp (outfile, *ep); + FPutC ('\n', outfile); + } +#endif + return True; + } + +#ifdef _DB_RED_ + if (DBPrinting){ + FPrintF (outfile, "Reduce (%u ", start_fuel); + DumpContext (outfile, context); + FPutS ("): ", outfile); + DumpExp (outfile, *ep); + FPrintF (outfile, "\n Path: "); + DumpPath (outfile, p); + FPutC ('\n', outfile); + } +#endif + + /* check current reduction fuel */ + if (OutOfFuel()){ +/* JVG added */ + if (e->e_kind!=Bottom) +/* */ + UpdateExp (& top, e); + + if (! max_time_reached){ + if (StrictAllWarning) + GiveStrictWarning (CurrentName,"out of fuel (result approximated)"); + else + time_warning = True; + max_time_reached = True; + } +#ifdef _DB_RED_ + if (DBPrinting) + FPrintF (outfile, "Result is approximated\n"); +#endif + return True; + } + + /* check if exp is in current path */ + if (IsInPath (e, p, & root, context)){ + *ep = MakeIndirection (root); + root->e_hasind = True; +#ifdef _DB_RED_ + if (DBPrinting){ + FPrintF (outfile, "Result is Indirection: "); + DumpExp (outfile, *ep); + FPutC ('\n', outfile); + } +#endif + return True; + } + + return False; +} + +static Bool ReduceInContext (ExpP ep, Path p, Context context) +{ + Exp e; + Path newp; + Bool result = False; + +#ifdef _DB_RED_ + unsigned e_fuel = start_fuel; +#endif + +#ifdef CHECK_STACK_OVERFLOW + char x; + + if (&x < min_stack){ + printf ("Stack overflow in ReduceInContext\n"); +#ifdef _DB_ + FPrintF (outfile, "Stack overflow in ReduceInContext\n"); +#endif +/* JVG added */ + if ((*ep)->e_kind!=Bottom) +/* */ + UpdateExp (& top, *ep); + return False; + } +#endif + + /* start with some checks which result in easy returns */ + if (CheckEndOfReductions (ep, p, context, & result)) + return result; + + e = *ep; + newp = AddToPath (e, p); + + if (! e->e_hnf){ + e->e_hasind = False; + Reduce (ep, newp, context); + } + + ResolveIndirections (ep, p, context); + + e = *ep; + result = False; + + if (e->e_kind == Bottom) + result = True; + else if (IsSpeculativeContext (context)){ + e->e_spechnf = True; + result = (e->e_kind == Bottom); + } else { +/* JVG */ + if (e->e_kind==Value && e->e_fun->fun_kind!=Constructor && ! e->e_hnf && ! ContainsIndirection (e)) +/* + Bool cont_ind; + + cont_ind = ContainsIndirection (e); + if (e->e_kind == Value && e->e_fun->fun_kind != Constructor && ! e->e_hnf && ! cont_ind) +*/ + UpdateExp (& top, e); + } + +#ifdef _DB_RED_ + if (DBPrinting){ + FPrintF (outfile, "Result (%d): ", e_fuel); + DumpExp (outfile, e); + FPutC ('\n', outfile); + FPutC ('\n', outfile); + } +#endif + + if (result == True) + return True; + else if (context->context_arity == 1){ + switch (context->context_kind){ + case SpineStrict: + if (e->e_kind == Value && e->e_fun==conssym){ + if (ReduceInContext (& e->e_args[1], p, context)) + return True; + } + + if (LtExp ((*ep), & inf) == True) + return True; + break; + case TailStrict: + if (e->e_kind == Value && e->e_fun==conssym){ + if (ReduceInContext (& e->e_args[1], p, context)) + return True; + if (ReduceInContext (& (*ep)->e_args[0], p, NewSimpleContext (HnfStrict, False))) + return True; + } + + if (LtExp ((*ep), & botmem) == True) + return True; + break; + default: + return result; + } + } else { + unsigned i, arity = context->context_arity; + + if (IsTupleExp (e)){ + for (i = 0; i < arity; i++){ + if (ReduceInContext (& e->e_args[i], p, context->context_args[i])){ + (*ep) = (*ep)->e_args[i] = & bottom; + return True; + } + } + } else { + if (e->e_kind == Lub){ + for (i = 0; i < (*ep)->e_sym; i++){ + if (!ReduceInContext (& (*ep)->e_args[i], p, context)) + return False; + + (*ep)->e_args[i] = & bottom; + } + return True; + } else + return False; + } + } + +#ifdef _DB_RED_ + if (DBPrinting){ + FPrintF (outfile, "Result (%d): ", e_fuel); + DumpExp (outfile, *ep); + FPutC ('\n', outfile); + FPutC ('\n', outfile); + } +#endif + + return result; +} + +/* The initialisation functions */ + +static unsigned found_strict; /* the number of found strict args */ + +static Fun * cur_funct; /* the current function id */ +static unsigned cur_argnr; /* the current argument number */ + +static Exp BuildTupleExp (StrictInfo *s, Exp bottomelem) +{ Exp e; + + if (s->strict_arity < 0) + { s->strict_arity = -s->strict_arity; + e = bottomelem; + } + else if (! IsTupleInfo (s)) + e = NewTop(); + else + { unsigned arity, i; + + arity = s->strict_arity; + e = NewValueExp (tuplesym[arity], True, arity); + + for (i = 0; i < arity; i++) + e->e_args[i] = BuildTupleExp (& GetTupleInfo (s, i), bottomelem); + } + + return e; +} + +static Exp BuildApplicationWithBottom (StrictKind argkind, StrictKind context) +{ + Exp e, bottom_elem; + unsigned i; + unsigned arity; + + arity = cur_funct->fun_arity; + + /* set the general values of the expression */ + bottom_elem = & bottom; + e = NewValueExp (cur_funct, False, arity); + + /* set all arguments to top */ + for (i = 0; i < arity; i++) + e->e_args[i] = NewTop(); + + /* set the right argument to bottom, inf ... */ + switch (argkind){ + case NotStrict: + return e; + case HnfStrict: + bottom_elem = & bottom; + break; + case SpineStrict: + Assume2 (IsListArg (cur_funct,cur_argnr), "BuildAppWithBot" , "??"); + if (IsListArg (cur_funct,cur_argnr)) + bottom_elem = & inf; + else + bottom_elem = & bottom; + break; + case TailStrict: + Assume2 (IsListArg (cur_funct,cur_argnr), "BuildAppWithBot" , "??"); + if (IsListArg (cur_funct,cur_argnr)) + bottom_elem = & botmem; + else + bottom_elem = & bottom; + break; + } + + e->e_args[cur_argnr] = BuildTupleExp (&cur_funct->fun_strictargs[cur_argnr], bottom_elem); + + /* set the outermost function */ + switch (context){ + case NotStrict: + case HnfStrict: + return e; + case SpineStrict: + { Exp e2; + + e2 = NewValueExp (inffunct_sym, False, 1); + e2->e_args[0] = e; + return e2; + } + case TailStrict: + { Exp e2; + + e2 = NewValueExp (botmemfunct_sym, False, 1); + e2->e_args[0] = e; + return e2; + } + } + + return e; +} + +static void SetStrict (StrictInfo *s, StrictKind kind, unsigned k) +{ + unsigned i; + + if (s == &cur_funct->fun_strictargs[cur_argnr]) + found_strict++; + + if (IsTupleInfo (s)) + GetTupleStrictKind (s) = kind; + else { + if (! IsListArg (cur_funct, cur_argnr) && kind != NotStrict) + kind = HnfStrict; + + for (i = k; i < 3; i++) + GetStrictKind (s, i) = MaxStrict (GetStrictKind (s, i), kind); + } +} + +static Bool CheckIfStrict (StrictKind arg_kind, StrictKind context) +{ + Bool result; + Exp e; + unsigned m; + + SetStartFuel(); + + if (setjmp (SAEnv2) == 0){ + e = BuildApplicationWithBottom (arg_kind, context); + result = ReduceInContext (& e, (Path) Null, NewSimpleContext (context, False)); + } else + result = False; + + m = MemUse (); + if (m > max_memuse) + max_memuse = m; + + FreeUnFreezedBlocks(); + + return (result || e->e_kind == Bottom); +} + +static void FindStrictPropsOfStrictInfo (StrictInfo *s, StrictKind arg_kind, StrictKind context) +{ + unsigned i,index; + + if (! context) + return; + + index = ContextToIndex (context); + + if (IsTupleInfo (s)){ + /* We allow no contexts for lists within a tuple at the moment */ + if (context == SpineStrict || context == TailStrict) + return; + + if (GetTupleStrictKind (s) == NotStrict){ + s->strict_arity = - s->strict_arity; + + if (CheckIfStrict (arg_kind, context)) + SetStrict (s, HnfStrict, index); + } + + /* Find strictness properties of arguments of tuple */ + if (context != HnfStrict) + ; + else if (GetTupleStrictKind (s) == HnfStrict){ + for (i = 0; i < s->strict_arity; i++) + FindStrictPropsOfStrictInfo (& GetTupleInfo(s, i), arg_kind, context); + } + } else { + if (GetStrictKind (s, index) < arg_kind){ + s->strict_arity = - s->strict_arity; + + if (CheckIfStrict (arg_kind, context)) + SetStrict (s, arg_kind, index); + } + } + if (s->strict_arity < 0) + s->strict_arity = - s->strict_arity; +} + +static void DeriveStrictness (Fun *f, unsigned arg, StrictKind arg_kind, StrictKind context) +{ + cur_funct = f; + cur_argnr = arg; + + FindStrictPropsOfStrictInfo (&f->fun_strictargs[arg], arg_kind, context); +} + +#define IsAnalysableFun(A) (! (A)->fun_symbol->sdef_no_sa &&\ + (A)->fun_arity != 0 &&\ + (A)->fun_kind == Function) + +static void FindStrictPropertiesOfFunction (Fun *f) +{ + unsigned arity,n; + /* ContextRepr context; */ + + n = 0; + + arity = f->fun_arity; + + if (! IsAnalysableFun (f)) + return; + + max_depth_reached = False; + max_time_reached = False; + CurrentName = f->fun_symbol->sdef_ident->ident_name; + +#ifdef _DB_ + DBPrinting = 1; /* strcmp ("catenate", CurrentName) == 0; */ +#endif + +#ifdef _DB_STACK_ + if (DBPrinting) + FPrintF (outfile, "--> %s\n", CurrentName); +#endif + + /* Check if function might terminate, currently disabled since all args + have to be changed!! */ + /* DeriveStrictness (f, 0, NotStrict, SimpleContext (&context, HnfStrict, False)); */ + + /* Check for normal strictness in argument */ + for (n = 0; n < arity; n++) + DeriveStrictness (f, n, HnfStrict, HnfStrict); + + /* Check for special kinds of strictness in the case of lists */ + if (StrictDoLists){ + Bool list_result; + + list_result = HasListResult (f); + + for (n = 0; n < arity; n++){ + if (! IsListArg (f, n)) + continue; + + /* Hnf context */ + DeriveStrictness (f, n, SpineStrict, HnfStrict); + DeriveStrictness (f, n, TailStrict, HnfStrict); + + if (! list_result) + continue; + + /* Spine context */ + DeriveStrictness (f, n, SpineStrict, SpineStrict); + DeriveStrictness (f, n, TailStrict, SpineStrict); + + /* Tail context */ + DeriveStrictness (f, n, SpineStrict, TailStrict); + DeriveStrictness (f, n, TailStrict, TailStrict); + } + } + +#ifdef _DB_TEST_ + if (StrictDoVerbose) + { FPrintF (StdOut, "(%4d)%15s ", (int) start_fuel, f->fun_symbol->sdef_ident->ident_name); + DumpStrictInfoOfFunction (StdOut, f); + FPutC ('\n', StdOut); + } +#endif +} + +#ifdef _DB_TEST_ +static void PrintFoundStrictArgs (File w) +{ + unsigned perc,nr_args; + SymbDef sdef; + + nr_args = 0; + + for_l (sdef,scc_dependency_list,sdef_next_scc) + if (sdef->sdef_kind==IMPRULE && sdef->sdef_over_arity==0){ + Fun *f; + + f=sdef->sdef_sa_fun; + + if (! StrictDoVerbose) + { FPrintF (StdOut, "%15s ", f->fun_symbol->sdef_ident->ident_name); + DumpStrictInfoOfFunction (StdOut, f); + FPutC ('\n', StdOut); + } + nr_args += f->fun_arity; + } + + if (nr_args == 0) + perc = 100; + else + perc = (100 * found_strict) / nr_args; + FPrintF (w, "\n%d strict arguments found (%d%%), %d Kbyte used\n", found_strict, perc, max_memuse); +} +#endif + +int init_strictness_analysis (ImpMod imod) +{ + StrictWarning = DoStrictWarning; + StrictAllWarning = DoStrictAllWarning; + StrictChecks = DoStrictCheck; + StrictExportChecks = DoStrictExportChecks; + + Verbose ("Strictness analysis"); + + /* Initialise all */ +#ifdef _DB_ + cur_add = 1; + outfile = StdOut; +/* StrictDoLists = True; */ + DBPrinting = False; +#endif + + max_memuse = 0; + found_strict = 0; + initialising = True; + FreeBlocks (); + + /* to be inited before converting the syntaxtree */ + InitExp (&top, Top, 0, True); + InitExp (&bottom, Bottom, 0, True); + + if (setjmp (SAEnv) == 0){ + + ConvertSyntaxTree (imod->im_symbols); + + /* other values are converted after syntaxconversion (because of cons symbol) */ + InitValues (); + + /* + dump the table (DB mode only) + DumpTable (StdOut); + return; + */ + + FreezeAlloc (); + + initialising = False; + + return True; + } else { + FreeBlocks (); + if (StrictWarning) + GiveStrictWarning (NULL,"not enough memory for strictness analysis"); + +#ifdef _DB_ +/* FClose (outfile); +*/ +#endif + return False; + } +} + +void do_strictness_analysis (void) +{ +#ifdef CHECK_STACK_OVERFLOW + char x; + + min_stack = &x - 20*1024; +#endif + + depth_warning = False; + time_warning = False; + export_warning = False; + mem_warning = False; + + /* Do the analysis */ + { + SymbDef sdef; + + for_l (sdef,scc_dependency_list,sdef_next_scc) + if (sdef->sdef_kind==IMPRULE && sdef->sdef_over_arity==0) + FindStrictPropertiesOfFunction (sdef->sdef_sa_fun); + } + + UpdateSyntaxTree(); + +#ifdef _DB_TEST_ + PrintFoundStrictArgs (StdOut); +#endif + +#ifdef _DB_ +/* + FClose (outfile); +*/ +#endif + +#if 0 + if (StrictWarning){ + if (mem_warning || depth_warning || time_warning) + GiveStrictWarning (NULL, "derived strictness properties approximated"); + } else +#endif + if (StrictAllWarning){ + if (mem_warning) + GiveStrictWarning (NULL,"strictness analysis out of memory (result approximated)"); + if (depth_warning) + GiveStrictWarning (NULL,"max depth reached in strictness analysis (result approximated)"); + if (time_warning) + GiveStrictWarning (NULL,"max time needed in strictness analysis (result approximated)"); + } + + if (StrictWarning && export_warning) + GiveStrictWarning ((char *) Null, "not all derived strictness information is exported"); + + free_unused_sa_blocks(); +} + +void finish_strictness_analysis (void) +{ + if (n_allocated_blocks!=0){ + if (bottom.e_kind!=Bottom || bottom.e_hnf!=True || top.e_kind!=Top || top.e_hnf!=True) + ErrorInCompiler ("sa","","Bottom or top changed"); + + FreeBlocks(); + } +} + +void StrictnessAnalysis (ImpMod imod) +{ + if (init_strictness_analysis (imod)){ + do_strictness_analysis(); + finish_strictness_analysis(); + } +} + +int StrictnessAnalysisConvertRules (ImpRuleS *rules) +{ + initialising = True; + + if (setjmp (SAEnv)==0){ + ImpRuleS *rule; + + for_l (rule,rules,rule_next) + convert_imp_rule_type (rule->rule_root->node_symbol->symb_def); + + for_l (rule,rules,rule_next) + convert_imp_rule_alts (rule->rule_root->node_symbol->symb_def); + + FreezeAlloc(); + + initialising = False; + return 1; + } else { + FreeUnFreezedBlocks(); + return 0; + } +} + +void StrictnessAnalysisForRule (SymbDef sdef) +{ + FindStrictPropertiesOfFunction (sdef->sdef_sa_fun); + + update_function_strictness (sdef); +} diff --git a/backendC/CleanCompilerSources/sa.h b/backendC/CleanCompilerSources/sa.h new file mode 100644 index 0000000..c489039 --- /dev/null +++ b/backendC/CleanCompilerSources/sa.h @@ -0,0 +1,12 @@ + +extern Bool DoStrictExportChecks; +extern Bool DoStrictRelated; + +extern void StrictnessAnalysis (ImpMod imod); +extern int init_strictness_analysis (ImpMod imod); +extern void do_strictness_analysis (void); +extern void finish_strictness_analysis (void); +extern int StrictnessAnalysisConvertRules (ImpRuleS *rules); +extern void StrictnessAnalysisForRule (SymbDef sdef); +extern void free_unused_sa_blocks (void); + diff --git a/backendC/CleanCompilerSources/sa.t b/backendC/CleanCompilerSources/sa.t new file mode 100644 index 0000000..be21c3c --- /dev/null +++ b/backendC/CleanCompilerSources/sa.t @@ -0,0 +1,155 @@ +/* +#define _DB_ + +#define _DB_TEST_ +*/ + +/* Debug Options */ + +#ifdef _DB_ +# ifndef _DB_TEST_ +# define _DB_TEST_ +# endif +# define _DB_RED_ +/* # define _DB_EQ_ */ +#endif + +/* Expressions */ + +typedef enum { + Bottom, Ind, FunValue, Value, Lub, Top, Argument, Dep +} ExpKind; + +typedef struct _exp *Exp; + +typedef struct _dependency *Dependency; + +typedef struct _dependency { + Exp dep_exp; + Dependency dep_next; +} DependencyRepr; + +typedef Exp *ExpP; + +typedef struct _exp { + union { + unsigned short u_sym; + struct _fun * u_fun; /* if a value, a function id */ + } e_u; + ExpKind e_kind; /* the kind of expression */ + unsigned char e_hnf:1, /* set if reduced to hnf */ + e_spechnf:1, /* set if reduced in spec context */ + e_hasind:1, /* used for indirections */ + e_red:1, /* used for reductions */ + e_imark:1, /* for marking use with Inds */ + e_mark:1, /* for general use */ + e_mark2:1; /* not for general use */ + Exp *e_args; /* the arguments of the exp */ + Exp e_fwd; /* for forwarding pointers */ + Dependency e_deps; /* the current dependency list */ +#ifdef _DB_ + unsigned e_mmark:1, /* used for testing */ + e_dmark:1, /* used for dumping */ + e_shared:1; /* used for dumping */ + unsigned e_add; /* the address of the exp */ +#endif /* _DB_ */ +} ExpRepr; + +#define e_sym e_u.u_sym +#define e_fun e_u.u_fun + +typedef enum { + Function, Constructor, + IfFunction, ApFunction, SelFunction, + StrictFunction, FailFunction +} FunKind; + +typedef enum { + NotStrict = 0, HnfStrict = 1, SpineStrict = 2, TailStrict = 3 +} StrictKind; + +typedef struct _strictinfo { + int strict_arity; + union { + StrictKind info_kinds[3]; + struct { + StrictKind info_kind; + struct _strictinfo *info_args; + } strict_tuple; + } strict_info; +} StrictInfo; + +typedef struct _context *Context; + +typedef struct _context { + unsigned context_arity:8, + context_kind:2, + context_speculative:1; + Context * context_args; +} ContextRepr; + +#define IsStrictContext(C) ((C)->context_kind != NotStrict) +#define IsSpeculativeContext(C) ((C)->context_speculative) + +#define IsTupleInfo(A) ((A)->strict_arity != 1) +#define GetTupleStrictKind(A) ((A)->strict_info.strict_tuple.info_kind) +#define GetTupleInfos(A) ((A)->strict_info.strict_tuple.info_args) +#define GetTupleInfo(A,B) ((A)->strict_info.strict_tuple.info_args[B]) +#define GetStrictKinds(A) ((A)->strict_info.info_kinds) +#define GetStrictKind(A,B) ((A)->strict_info.info_kinds[B]) +#define InitStrictInfo(A,B) ((A)->strict_info.info_kinds[0] = \ + (A)->strict_info.info_kinds[1] = \ + (A)->strict_info.info_kinds[2] = (B)) +#define ContextToIndex(A) ((A) == NotStrict ? 0 : (A) - 1) + +typedef struct _alts *Alts; + +typedef struct _alts { + Exp fun_lhs; + Exp fun_rhs; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + Alts fun_switch_alts; +#endif + Alts fun_next; + Bool fun_has_fail; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + Bool fun_is_guard; /* if fun_switch_alts!=NULL */ +#endif +} AltsRepr; + +typedef struct _fun { + SymbDef fun_symbol; + StrictInfo* fun_strictargs; + Alts fun_alts; + StrictInfo fun_strictresult; + unsigned short fun_arity; + unsigned short fun_single:1; /* TRUE if pattern matching on symbol always succeeds */ + FunKind fun_kind; +} Fun; + +/* paths used in less-then operator */ + +typedef struct _apath *APath; + +typedef struct _apath { + Exp ap_e1; + Exp ap_e2; + APath ap_next; +} APathRepr; + +/* paths used during reduction */ + +typedef struct _path *Path; + +typedef struct _path { + Exp p_exp; + Exp p_root; + Path p_next; +} PathRepr; + +/* abstract matching results */ + +typedef enum { + NoMatch, InfiniteMatch, PartialMatch, PartialInfiniteMatch, + TotalMatch, LubMatch, ReduceMatch +} MatchKind; diff --git a/backendC/CleanCompilerSources/scanner.h b/backendC/CleanCompilerSources/scanner.h new file mode 100644 index 0000000..b550cc4 --- /dev/null +++ b/backendC/CleanCompilerSources/scanner.h @@ -0,0 +1,115 @@ +/* + +---------------------------------------------------------------------+ + | For each identifier stored in the symbol table a structure of | + | type 'Ident' is reserved. | + +---------------------------------------------------------------------+ +*/ + +extern char *ConvertNextTokenToString (void); + +typedef + enum + { + IdentToken, IntToken, CharToken, + StringToken, RealToken, AnnotToken, InstructionToken, + EOFToken, + errorsym, barsym, strictsym, opensym, + closesym, opensquaresym, closesquaresym, colonsym, + typesym, semicolonsym, commasym, dotsym, openbracesym, + closebracesym, arrowsym, abstypesym, + arraysym, strictarraysym, unboxedarraysym, + + atsym,boolsym, codesym, charsym,defsym, + falsesym, filesym, fromsym, ifsym, impsym, +/* RWS */ + allsym, + importsym, intsym, macrosym, modulesym, procidsym, redidsym, + realsym, rulesym, stringsym, + systemsym, truesym, typedefsym, applysym, + uniquesym, worldsym, + NumberOfKeywords /* make sure that this constant is the last one */ + + } KeywordKind; + +extern char **ReservedWords; + + enum + { + /* 0 .. 255 are reserved for single ascii characters */ + kTokenImport = 256, kTokenFrom, kTokenDefinition, kTokenImplementation, + kTokenSystem, kTokenModule, + kTokenLet, kTokenIn, kTokenCase, kTokenOf, + kTokenWith, kTokenWhere, kTokenEquals, kTokenEqualColon, + kTokenColonDoubleEqual, kTokenDoubleBackSlash, + kTokenDoubleRightArrow, + kTokenLeftArrow, kTokenLeftArrowColon, kTokenRightArrow, + kTokenInfix, kTokenInfixL, kTokenInfixR, + kTokenDotDot, kTokenDoubleColon, + + kTokenProcessOpen, kTokenProcessClose, + kTokenChar, kTokenMultiChar, kTokenString, kTokenInt, kTokenReal, + kTokenLowerIdentifier, kTokenUpperIdentifier, kTokenUnderscoreIdentifier, + kTokenCode, kTokenInstruction, + kTokenFalse, kTokenTrue, + kTokenIf, kTokenAll, + kNoToken, kTokenEOF, + kTokenHashExclamationMark, + + kTokenOverload, kTokenInstance, kTokenClass, + kTokenExport, + +#ifdef H + kTokenData, kTokenType, kTokenAtSign, kTokenThen, kTokenElse, kTokenInterface, +#endif + + kTokenDefault, kTokenResync + }; + +typedef unsigned int Token; + +STRUCT (tokenValue, TokenValue) +{ + Token token; + long lineNumber; + union { + char *literal; + IdentStringP identString; + } value; +}; + +typedef enum { kScanModeNormal,kScanModeTypes,kScanModeInstructions } ScanMode; + +extern IdentP RetrieveFromSymbolTable (char *name); +extern IdentP PutStringInHashTable (char *string, TableKind tabkind); +extern IdentP PutIdentStringInTable (IdentStringP identString, TableKind tabkind); + + +extern void InitScanner (void); + +extern void ScanInit (void); +extern void ScanSetMode (ScanMode scanMode); +enum {kOffsideOnHardBrace = True, kNoOffsideOnHardBrace = False}; +extern void ScanSetOffside (Bool offsideOnHardBrace); +extern Bool ScanUnsetOffside (void); +extern void ScanSetLayoutOption (void); +extern Bool ScanOpenFile (char *fileName, FileKind fileKind); +#if WRITE_DCL_MODIFICATION_TIME +extern Bool ScanOpenFileWithModificationTime (char *fileName, FileKind fileKind, FileTime *file_time_p); +#endif +extern void ScanCloseFile (void); +extern Bool ScanTokenToString (Token token, char *string); + +/* + ScanCleanToken fills the global structure gCurrentToken. +*/ +extern void ScanInitialise (void); + +#ifdef CLEAN2 +extern void ScanInitIdentStringTable (void); +#endif + +extern void ScanCleanToken (void); +extern TokenValueS gCurrentToken; +extern void ScanInlineFile (char *fname); + +extern Bool gApplyLayoutRule; diff --git a/backendC/CleanCompilerSources/scanner_2.c b/backendC/CleanCompilerSources/scanner_2.c new file mode 100644 index 0000000..e756907 --- /dev/null +++ b/backendC/CleanCompilerSources/scanner_2.c @@ -0,0 +1,715 @@ +/* + Ronny Wichers Schreur + University of Nijmegen +*/ + + +#pragma segment scanner + +# include <stdio.h> +# include <string.h> +# include <ctype.h> +# include <limits.h> + +# undef H + +# include "compiledefines.h" +# include "types.t" + +#if defined (applec) || (defined (__MWERKS__) && !defined (_WINDOWS_)) || defined (__MRC__) +# define __ppc__ +#endif + +# include "system.h" +# include "syntaxtr.t" +# include "comsupport.h" +# include "scanner.h" +# include "sizes.h" + +# if (defined (__MWERKS__) || defined (__MRC__)) && !defined _WINDOWS_ /* && !defined (MAKE_MPW_TOOL) */ +# define CACHE_DCL_FILES +# define CACHE_INLINE_FILES +# else +# undef CACHE_DCL_FILES +# undef CACHE_INLINE_FILES +# endif + +char **ReservedWords; + +static IdentP +NewIdent (TableKind tableKind, char *name) +{ + IdentP ident; + + ident = CompAllocType (struct ident); + + ident->ident_table = tableKind; + ident->ident_name = name; + + ident->ident_next = NULL; + ident->ident_environ = NULL; + ident->ident_symbol = NULL; + ident->ident_local_defs = NULL; + ident->ident_mark = 0; + + return (ident); +} /* NewIdent */ + +#define CompAllocString(size) ((char*)CompAlloc(size)) + +static char * +AllocString (char *string, short length) +{ + int i; + char *s, *newString; + + s = newString = CompAllocString (length+1); + + for (i = 0; i < length; i++) + *s++ = *string++; + *s = '\0'; + + return (newString); +} /* AllocString */ + +# define kIdentStringTableSizeBits 10 +# define kIdentStringTableSize ((1 << kIdentStringTableSizeBits) - 1) + +static IdentStringP *gIdentStringTable; + +static IdentStringP +StringInTable (char *string, short length) +{ + int i; + unsigned long hash; + IdentStringP identString, *identStringPtr; + char *s; + + hash = 0; + s = string; + for (i = 0; i < length; i++) + { + hash <<= 2; + hash += *s++; + } + + /* Compute (hash % kIdentStringTableSize) */ + while (hash >= (kIdentStringTableSize<<1)) + hash = (hash & kIdentStringTableSize) + (hash >> kIdentStringTableSizeBits); + if (hash >= kIdentStringTableSize) + hash -= kIdentStringTableSize; + + identStringPtr = &gIdentStringTable [hash]; + + while ((identString = *identStringPtr) != NIL) + { + int compare; + + compare = strncmp (identString->string, string, length); + + if (compare == 0 && (compare = ((unsigned char *)identString->string) [length]) == 0) + /* found it */ + break; + else if (compare > 0) + identStringPtr = &identString->left; + else /* if (compare < 0) */ + identStringPtr = &identString->right; + } + + if (identString == NIL) + { + identString = CompAllocType (struct ident_string); + + identString->left = NIL; + identString->right = NIL; + identString->ident = NIL; + + identString->string = AllocString (string, length); + + *identStringPtr = identString; + } + + return (identString); +} /* StringInTable */ + +IdentP +PutIdentStringInTable (IdentStringP identString, TableKind tableKind) +{ + IdentP ident; + + for (ident = identString->ident; ident != NIL; ident = ident->ident_next) + if (ident->ident_table == tableKind) + break; + + if (ident == NIL) + { + ident = NewIdent (tableKind, identString->string); + + ident->ident_next = identString->ident; + + identString->ident = ident; + } + + return (ident); +} /* PutIdentStringInTable */ + +IdentP +PutStringInHashTable (char *string, TableKind tableKind) +{ + IdentStringP identString; + + identString = StringInTable (string, strlen (string)); + + return (PutIdentStringInTable (identString, tableKind)); +} /* PutStringInHashTable */ + +STRUCT (keyWordInfo, KeyWordInfo) +{ + char *name; + Token token; +}; + +static void +PutKeyWordInTable (KeyWordInfoP keyWord) +{ + IdentStringP identString; + IdentP ident; + + identString = StringInTable (keyWord->name, strlen (keyWord->name)); + + ident = NewIdent (KeyWordTable, identString->string); + + ident->ident_next = identString->ident; + ident->ident_environ = NIL; + ident->ident_symbol = (struct symbol *) keyWord->token; + + identString->ident = ident; +} /* PutKeyWordInTable */ + +IdentP +RetrieveFromSymbolTable (char *string) +{ + char *s; + unsigned long hash; + IdentStringP identString; + IdentP ident; + + hash = 0; + for (s = string; *s != '\0'; s++) + { + hash <<= 2; + hash += *s; + } + + /* Compute (hash % 1023) */ + while (hash >= 2046) + hash = (hash & 1023) + (hash >> 10); + if (hash >= 1023) + hash -= 1023; + + identString = gIdentStringTable [hash]; + + while (identString != NIL) + { + int compare; + + compare = strcmp (identString->string, string); + + if (compare == 0) + /* found it */ + break; + else if (compare > 0) + identString = identString->left; + else /* if (compare < 0) */ + identString = identString->right; + } + + if (identString != NIL) + { + for (ident = identString->ident; ident != NIL; ident = ident->ident_next) + if (ident->ident_table == SymbolIdTable) + break; + } + else + ident = NIL; + + return (ident); +} /* RetrieveFromSymbolTable */ + +/* + +-----------------------------------------------------------------------+ + | ReadInlineCode scans all the imported SYSTEM modules and stores the | + | the encountered inline instructions in the symbol table. | + +-----------------------------------------------------------------------+ +*/ + +char NextLine[LineLength]; + +/* has a command been read? */ + +static char *IsCommand (char *com, char *p) +{ + while (*com++ == *p++) + if (*com == '\0') + return (p); + return ((char *) NIL); +} + +/* scan a file for .inline-.end command pairs */ + +char *InlineCodeBuffer; +unsigned InlineBufferIndex, InlineBufferStart; + +#ifdef CACHE_INLINE_FILES + +struct inline_cache_list { + struct inline_cache_list * icache_next; + struct file_block * icache_file_blocks; +#if defined (__MWERKS__) || defined (THINK_C) || defined (__MRC__) + char icache_file_name[]; +#else + char icache_file_name[0]; +#endif +}; + +#define BUFFER_SIZE 1024 + +struct file_block { + int file_block_size; + struct file_block * file_block_next; + char file_block_data[BUFFER_SIZE]; +}; + +struct file_block **next_file_block_l; + +static int reading_from_cache=0; + +static struct inline_cache_list * inline_cache=NULL; + +static File inline_file; + +static int chars_left_in_buffer; +static int end_of_file; +static char *buffer_p; + +static int open_inline_file_for_block_reading (char *file_name) +{ + struct inline_cache_list **icache_elem_p,*new_icache_elem; + int file_name_length; + + chars_left_in_buffer=0; + end_of_file=0; + reading_from_cache=0; + + for (icache_elem_p=&inline_cache; *icache_elem_p; + icache_elem_p=&(*icache_elem_p)->icache_next) + { + if (!strcmp ((*icache_elem_p)->icache_file_name,file_name)){ + reading_from_cache=1; + + next_file_block_l=&(*icache_elem_p)->icache_file_blocks; + return 1; + } + } + + inline_file = FOpen (file_name, abcFile, "r"); + if (inline_file==NULL) + return 0; + +#if defined (THINK_C) || defined (POWER) + setvbuf (inline_file,NULL,_IOFBF,8192); +#endif + + file_name_length=strlen (file_name); + + new_icache_elem=(struct inline_cache_list*)Alloc (1,sizeof (struct inline_cache_list)+file_name_length+1); + + strcpy (new_icache_elem->icache_file_name,file_name); + new_icache_elem->icache_next=NULL; + new_icache_elem->icache_file_blocks=NULL; + *icache_elem_p=new_icache_elem; + + next_file_block_l=&new_icache_elem->icache_file_blocks; + + return 1; +} + +static int get_line_from_inline_file (char *line_buffer,int line_length) +{ + char *line_buffer_p; + + line_buffer_p=line_buffer; + + for (;;){ + while (chars_left_in_buffer>0){ + char c; + + c=*buffer_p++; + --chars_left_in_buffer; + + if (line_length>1){ + --line_length; + *line_buffer_p++=c; + } + + if (c=='\n'){ + *line_buffer_p=0; + return 1; + } + } + + if (!reading_from_cache){ + struct file_block *file_block; + + if (end_of_file){ + *line_buffer_p=0; + return line_buffer!=line_buffer_p; + } + + file_block=(struct file_block*)Alloc (1,sizeof (struct file_block)); + + chars_left_in_buffer=FRead (file_block->file_block_data,1,BUFFER_SIZE,inline_file); + buffer_p=file_block->file_block_data; + + file_block->file_block_size=chars_left_in_buffer; + file_block->file_block_next=NULL; + + end_of_file = chars_left_in_buffer!=BUFFER_SIZE; + + *next_file_block_l=file_block; + next_file_block_l=&file_block->file_block_next; + } else { + struct file_block *file_block; + + file_block=*next_file_block_l; + + if (file_block==NULL){ + *line_buffer_p=0; + return line_buffer!=line_buffer_p; + } + + chars_left_in_buffer=file_block->file_block_size; + buffer_p=file_block->file_block_data; + + if (chars_left_in_buffer==0){ + *line_buffer_p=0; + return line_buffer!=line_buffer_p; + } + + next_file_block_l=&file_block->file_block_next; + } + }; +} + +extern void clear_inline_cache (void); +void clear_inline_cache (void) +{ + struct inline_cache_list *icache_elem,*next_icache_elem; + + icache_elem=inline_cache; + inline_cache=NULL; + + while (icache_elem!=NULL){ + struct file_block *icache_file_blocks,*next_icache_file_block; + + next_icache_elem=icache_elem->icache_next; + icache_file_blocks=icache_elem->icache_file_blocks; + icache_elem->icache_file_blocks=NULL; + Free (icache_elem); + + while (icache_file_blocks!=NULL){ + next_icache_file_block=icache_file_blocks->file_block_next; + Free (icache_file_blocks); + icache_file_blocks=next_icache_file_block; + } + + icache_elem=next_icache_elem; + } +} +#endif + +void ScanInlineFile (char *fname) +{ + register char *tail, *instr, *importingModule, *importingExtension; + IdentP instrid; + int nrinstr; +#ifndef CACHE_INLINE_FILES + File f; +#endif + + importingModule = CurrentModule; + importingExtension = CurrentExt; + + CurrentModule = fname; + CurrentExt = GetFileExtension (abcFile); + +#ifdef CACHE_INLINE_FILES + if (!open_inline_file_for_block_reading (fname)) +#else + if (! (f = FOpen (fname, abcFile, "r"))) +#endif + { CurrentModule = importingModule; + CurrentExt = importingExtension; + + return; + } +#ifndef CACHE_INLINE_FILES +# if defined (THINK_C) || defined (POWER) + setvbuf ((void*) f, NULL, _IOFBF, 8192); +# endif +#endif + + CurrentLine = 0; + CurrentPhase = NULL; + + for (;;){ +#ifdef CACHE_INLINE_FILES + if (!get_line_from_inline_file (NextLine,LineLength)) +#else + if (! FGetS (NextLine, LineLength, f)) +#endif + break; + + for (tail = NextLine; isspace (*tail); tail++) + ; + + /* if not at .inline reenter loop from top */ + if ((tail = IsCommand (".inline", tail)) == NIL) + continue; + + /* get the function name */ + while (*tail == ' ' || *tail == '\t') + tail++; + + /* terminate it with a '\0' */ + for (instr = tail; ! isspace (*tail); tail++) + ; + if (instr == tail) + continue; + + *tail = '\0'; + if (! (instrid = RetrieveFromSymbolTable (instr))) + continue; + if (instrid->ident_environ!=importingModule) + continue; + if ((instrid->ident_mark & INLINE_MASK) != 0) + { + StaticMessage (True, "%s", "multiple .inline directives", instr); + continue; + } + instrid->ident_mark |= INLINE_MASK; + + /* Open the buffer for the next instructions */ + InlineBufferIndex = InlineBufferStart; + + for (nrinstr = 0; nrinstr <= MaxInlineInstr;){ +#ifdef CACHE_INLINE_FILES + if (!get_line_from_inline_file (NextLine,LineLength)){ +#else + if (! FGetS (NextLine, LineLength, f)){ +#endif + StaticMessage (False, "%s", "%s no .end found in this file", instrid->ident_name,fname); + + break; + } + for (tail = NextLine; *tail == ' ' || *tail == '\t'; tail++) + ; + if (IsCommand (".end", tail)) + break; + + if (*tail != '\n' && *tail != '\0'){ + instr = NextLine; + /* Copy this instruction into the buffer */ + + do + { if (InlineBufferIndex < InlineBuffSize-2) + InlineCodeBuffer [InlineBufferIndex++] = *instr++; + else + DoFatalError ("too many inline instructions"); + } while (*instr != '\n' && *instr != '\0'); + + /* close the instruction with a newline character */ + InlineCodeBuffer [InlineBufferIndex++] = '\n'; + nrinstr++; + } + } + + if (nrinstr > MaxInlineInstr){ + StaticMessage (False, "%s", "%s file contains too many instructions", instrid->ident_name,fname); + } + + /* save the list of inline instructions */ +/* if (InlineBufferIndex != InlineBufferStart){ */ + instrid->ident_instructions = &InlineCodeBuffer [InlineBufferStart]; + InlineBufferStart = InlineBufferIndex+1; + + /* close the list with the NULL character */ + InlineCodeBuffer [InlineBufferIndex] = '\0'; +/* } */ + } + +#ifdef CACHE_INLINE_FILES + if (!reading_from_cache) + FClose (inline_file); +#else + FClose (f); +#endif + + CurrentModule = importingModule; + CurrentExt = importingExtension; +} + +void +ScanInitIdentStringTable (void) +{ + int i; + + /* + RWS +++ clean up symbols + */ + ReservedWords = (char **) CompAlloc ((unsigned long) NumberOfKeywords * SizeOf (char *)); + ReservedWords [(int) errorsym] = "Erroneous"; + ReservedWords [(int) barsym] = "|"; + ReservedWords [(int) strictsym] = "!"; + ReservedWords [(int) opensym] = "("; + ReservedWords [(int) closesym] = ")"; + ReservedWords [(int) opensquaresym] = "["; + ReservedWords [(int) closesquaresym] = "]"; + ReservedWords [(int) colonsym] = ":"; + ReservedWords [(int) typesym] = "::"; + ReservedWords [(int) semicolonsym] = ";"; + ReservedWords [(int) commasym] = ","; + ReservedWords [(int) dotsym] = "."; + ReservedWords [(int) openbracesym] = "{"; + ReservedWords [(int) closebracesym] = "}"; + ReservedWords [(int) arrowsym] = "->"; + ReservedWords [(int) abstypesym] = "AbsType"; + + ReservedWords [(int) arraysym] = "{ }"; + ReservedWords [(int) strictarraysym] = "{ ! }"; + ReservedWords [(int) unboxedarraysym] = "{ # }"; + + ReservedWords [(int) atsym] = "at"; + ReservedWords [(int) boolsym] = "Bool"; + ReservedWords [(int) charsym] = "Char"; + ReservedWords [(int) codesym] = "code"; + ReservedWords [(int) defsym] = "definition"; + ReservedWords [(int) falsesym] = "False"; + ReservedWords [(int) filesym] = "File"; + ReservedWords [(int) allsym] = "All"; + ReservedWords [(int) fromsym] = "from"; +/* RWS ... hack */ + ReservedWords [(int) ifsym] = "if "; +/* ... RWS */ + ReservedWords [(int) impsym] = "implementation"; + ReservedWords [(int) importsym] = "import"; + ReservedWords [(int) intsym] = "Int"; + ReservedWords [(int) macrosym] = "macro"; + ReservedWords [(int) modulesym] = "module"; + ReservedWords [(int) procidsym] = "ProcId"; + ReservedWords [(int) redidsym] = "RedId"; + ReservedWords [(int) realsym] = "Real"; + ReservedWords [(int) rulesym] = "rule"; +/* */ + ReservedWords [(int) stringsym] = "_STRING"; +/* */ + ReservedWords [(int) systemsym] = "system"; + ReservedWords [(int) truesym] = "True"; + ReservedWords [(int) typedefsym] = "type"; + ReservedWords [(int) applysym] = "=>"; + ReservedWords [(int) uniquesym] = "*"; + ReservedWords [(int) worldsym] = "World"; + + gIdentStringTable = (struct ident_string**)CompAlloc (kIdentStringTableSize * sizeof (struct ident_string)); + for (i = 0; i < kIdentStringTableSize; i++) + gIdentStringTable [i] = NIL; +} + +static KeyWordInfoS gKeyWords [] = +{ + { "export", kTokenExport }, + { "import", kTokenImport }, + { "from", kTokenFrom }, + { "definition", kTokenDefinition }, + { "implementation", kTokenImplementation }, + { "system", kTokenSystem }, + { "module", kTokenModule }, + { "let", kTokenLet }, + { "in", kTokenIn }, + { "case", kTokenCase }, + { "of", kTokenOf }, + { "if", kTokenIf }, + { "with", kTokenWith }, + { "where", kTokenWhere }, + { "code", kTokenCode }, + { "True", kTokenTrue }, + { "False", kTokenFalse }, +/* { "overload", kTokenOverload }, */ + { "instance", kTokenInstance }, + { "default", kTokenDefault }, + { "class", kTokenClass }, + { "infix", kTokenInfix }, + { "infixl", kTokenInfixL }, + { "infixr", kTokenInfixR }, + { "\\", '\\' }, + { "\\\\", kTokenDoubleBackSlash }, + { "#", '#' }, + { "#!", kTokenHashExclamationMark }, + { "=", '=' }, + { "|", '|' }, + { ".", '.' }, + { "!", '!' }, + { "&", '&' }, + { "..", kTokenDotDot }, + { "=:", kTokenEqualColon }, +#ifndef H + { ":", ':' }, +#endif + { ":==", kTokenColonDoubleEqual }, + { "=>", kTokenDoubleRightArrow }, + { "<-", kTokenLeftArrow }, + { "<-:", kTokenLeftArrowColon }, + { "->", kTokenRightArrow } +#ifdef H + ,{ "data", kTokenData } + ,{ "type", kTokenType } + ,{ "@", kTokenAtSign } + ,{ "then", kTokenThen } + ,{ "else", kTokenElse } + ,{ "interface", kTokenInterface } +#endif +}; + +# define ArraySize(array) ((unsigned) (sizeof (array) / sizeof (array[0]))) + +void +ScanInitialise (void) +{ + int i; +#ifndef CLEAN2 + gCharTypeTable = (unsigned char*)CompAlloc (256 * sizeof (unsigned char)), + InitialiseCharTypeTable (gCharTypeTable); + + gStateNormalTable = (ScanState*)CompAlloc (256 * sizeof (ScanState)), + InitialiseStateNormalTable (gStateNormalTable); + + gStateInstructionsTable = (ScanState*)CompAlloc (256 * sizeof (ScanState)), + InitialiseStateInstructionTable (gStateInstructionsTable); + + ScanSetMode (kScanModeNormal); + + gInputBuffer = (unsigned char*)CompAlloc (kInputBufferSize); +#endif + + ScanInitIdentStringTable(); + + for (i = 0; i < ArraySize (gKeyWords); i++) + PutKeyWordInTable (&gKeyWords [i]); +} /* ScanInitialise */ + +void +InitScanner (void) +{ + InlineCodeBuffer = (char*)CompAlloc (InlineBuffSize); + InlineBufferStart = 0; +} /* InitScanner */ diff --git a/backendC/CleanCompilerSources/set_scope_numbers.c b/backendC/CleanCompilerSources/set_scope_numbers.c new file mode 100644 index 0000000..f68417c --- /dev/null +++ b/backendC/CleanCompilerSources/set_scope_numbers.c @@ -0,0 +1,64 @@ + +#include "system.h" + +#include "settings.h" +#include "syntaxtr.t" +#include "comsupport.h" +#include "buildtree.h" +#include "codegen_types.h" +#include "codegen1.h" +#include "codegen2.h" +#include "statesgen.h" +#include "checker.h" +#include "instructions.h" +#include "optimisations.h" +#include "sa.h" + +#include "set_scope_numbers.h" + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) + +static int scope; + +static void set_node_id_scope_numbers (NodeDefP node_defs,int local_scope) +{ + NodeDefP node_def_p; + + for_l (node_def_p,node_defs,def_next) + node_def_p->def_id->nid_scope=local_scope; +} + +static void set_root_scope_numbers (NodeP node_p,int local_scope) +{ + if (node_p->node_kind==IfNode){ + int new_local_scope; + ArgP arg_p; + + node_p->node_if_scope=local_scope; + + new_local_scope=scope+2; + scope+=3; + + arg_p=node_p->node_arguments; + set_root_scope_numbers (arg_p->arg_node,local_scope); + + ++scope; + arg_p=arg_p->arg_next; + set_root_scope_numbers (arg_p->arg_node,new_local_scope); + set_node_id_scope_numbers (node_p->node_then_node_defs,new_local_scope); + + ++scope; + arg_p=arg_p->arg_next; + set_root_scope_numbers (arg_p->arg_node,new_local_scope); + set_node_id_scope_numbers (node_p->node_else_node_defs,new_local_scope); + } +} + +void set_scope_numbers (RuleAltS *rule_alt_p) +{ + scope=1; + + set_root_scope_numbers (rule_alt_p->alt_rhs_root,0); + set_node_id_scope_numbers (rule_alt_p->alt_rhs_defs,0); +} + diff --git a/backendC/CleanCompilerSources/set_scope_numbers.h b/backendC/CleanCompilerSources/set_scope_numbers.h new file mode 100644 index 0000000..b73e759 --- /dev/null +++ b/backendC/CleanCompilerSources/set_scope_numbers.h @@ -0,0 +1,4 @@ + +void set_scope_numbers (RuleAltS *rule_alt_p); + + diff --git a/backendC/CleanCompilerSources/settings.c b/backendC/CleanCompilerSources/settings.c new file mode 100644 index 0000000..a09d306 --- /dev/null +++ b/backendC/CleanCompilerSources/settings.c @@ -0,0 +1,51 @@ + +#include "system.h" +#include "settings.h" + +Bool + DoCode = True, + DoDebug = False, + DoListAllTypes = False, + DoListTypes = False, + DoShowAttributes = True, + DoParallel = False, + DoStackLayout = True, + DoStrictnessAnalysis = True, + DoVerbose = False, + DoWarning = True, + DoStrictWarning = True, + DoStrictAllWarning = False, + DoStrictCheck = False, + DoListStrictTypes = False; +Bool ListOptimizations = False; + +Bool DoDescriptors = False; +Bool ExportLocalLabels = False; + +Bool DoProfiling=False; /* no longer used by memory profiler */ +Bool DoTimeProfiling=False; + +Bool DoReuseUniqueNodes = False; + +Bool OptimizeLazyTupleRecursion=False; +Bool OptimizeTailCallModuloCons=False; +Bool WriteModificationTimes = False; + +unsigned StrictDepth = 10; /* 8; */ + +Bool StrictDoLists = False; +Bool StrictDoPaths = True; +Bool StrictDoAllPaths = True; +Bool StrictDoExtEq = True; +Bool StrictDoLessEqual = True; +Bool StrictDoEager = True; +Bool StrictDoVerbose = False; +Bool StrictDoAnnots = True; + +unsigned long StrictMemUse = NR_BLOCKS * BLOCK_SIZE; + +Bool FunctionMayFailIsError = False; +Bool NotUsedIsError = False; +Bool FunctionNotUsedIsError = False; + +Bool VERBOSE = True; diff --git a/backendC/CleanCompilerSources/settings.h b/backendC/CleanCompilerSources/settings.h new file mode 100644 index 0000000..ee1048f --- /dev/null +++ b/backendC/CleanCompilerSources/settings.h @@ -0,0 +1,51 @@ + +/* + Compiler setttings + Note that changes are of influence for project.c !! +*/ + +extern Bool DoCode; /* not generated in abc file */ +extern Bool DoDebug; +extern Bool DoParallel; +extern Bool DoStackLayout; +extern Bool DoStrictnessAnalysis; +extern Bool DoVerbose; +extern Bool DoWarning; +extern Bool DoListTypes; /* not generated in abc file */ +extern Bool DoListAllTypes; /* not generated in abc file */ +extern Bool DoShowAttributes; /* not generated in abc file */ +extern Bool DoListStrictTypes; /* not generated in abc file */ +extern Bool DoStrictWarning; /* not generated in abc file */ +extern Bool DoStrictAllWarning; /* not generated in abc file */ +extern Bool DoStrictCheck; /* not generated in abc file */ +extern Bool DoDescriptors; /* not generated in abc file */ +extern Bool ListOptimizations; + +extern Bool ExportLocalLabels; + +extern Bool DoProfiling; +extern Bool DoTimeProfiling; + +extern Bool DoReuseUniqueNodes; +extern Bool OptimizeLazyTupleRecursion; +extern Bool OptimizeTailCallModuloCons; +extern Bool WriteModificationTimes; + +#define NR_BLOCKS 100 +#define BLOCK_SIZE (unsigned long) (16 * KBYTE) +#define StrictDoRelated False + +extern unsigned StrictDepth; +extern Bool StrictDoLists; +extern Bool StrictDoPaths; +extern Bool StrictDoAllPaths; +extern Bool StrictDoExtEq; +extern Bool StrictDoLessEqual; +extern Bool StrictDoEager; +extern Bool StrictDoVerbose; +extern Bool StrictDoAnnots; +extern unsigned long StrictMemUse; + +extern Bool VERBOSE; + +extern Bool FunctionMayFailIsError,NotUsedIsError,FunctionNotUsedIsError; diff --git a/backendC/CleanCompilerSources/sizes.h b/backendC/CleanCompilerSources/sizes.h new file mode 100644 index 0000000..ae644e5 --- /dev/null +++ b/backendC/CleanCompilerSources/sizes.h @@ -0,0 +1,89 @@ + +#define kCopyStringLength 512 +#define MaxUnsigned 65535 + +/* The maximum arity of tuples is defined by MaxTupleArity */ + +#define MaxNodeArity 32 +#define MaxGeneratedIdentSize 512 + +/* The scanner maintains a buffer for holding identifiers and literals whereof the + size is indicated by ScanBuffSize +*/ + +#define ScanBuffSize (KBYTE*32) + +/* Identifiers may cantain upto IdLength characters */ + +#define IdLength 256 + +/* The actual size of the id-buffer is greater than the IdLength. + This allows us to add extensions of length 4 to identifiers + (used in module names) */ + +#define MaxIdLength ((SizeT) (IdLength + 4)) +#define MaxStrLength 256 /* maximum number of characters in a string */ +#define MaxCharLength 6 /* maximum number of chararcters in a character denotation */ +#define MaxNrOfDigits 80 /* maximum number of digits in a real */ +#define MaxNumLength (MaxNrOfDigits + 4) /* maximum number of characters in a real + or integer denotation */ + +#define MaxInstrLength 256 /* maximum number of characters in an instruction */ + +/* Identifiers and literals are stored in different tables. The size of these tables + are given below */ + +#define SymbTabSize ((SizeT) KBYTE) +#define NodeTabSize ((SizeT) KBYTE) +#define ModTabSize ((SizeT) 32) +#define LitTabSize ((SizeT) KBYTE) + +/* + Compsupport +*/ + +/* The compiler uses its own storage administration. When some storage is required + it is checked whether or not this storage is available. If not, a new memory + block of size MemBlockSize is allocated. Keeping the size large will slightly + increase the performance of the memory allocator. +*/ + +#ifdef __MWERKS__ +# define MemBlockSize ((SizeT) (16*KBYTE)) +#else +# define MemBlockSize ((SizeT) (32*KBYTE)) +#endif +#define TH_BlockSize ((SizeT) (16*KBYTE)) + +/* TypeChecker */ + +/* For efficient internal garbage collection the type checker uses its own storage + administration. The constant TCWorkSpaceSize has the same function as MemBlockSize + in comsupport. +*/ + +#define TCWorkSpaceSize ((SizeT) (16*KBYTE)) + +/* Code Generator */ + +/* The size of objects expressed in amounts of stack entries are given below */ + +#define SizeOfInt 1 +#define SizeOfBool 1 +#define SizeOfChar 1 +#define SizeOfReal REALSIZE +#define SizeOfFile FILESIZE +#define SizeOfVoid 1 +#define SizeOfProcId 1 +#define SizeOfAStackElem 1 + +#define NrOfGlobalSelectors 6 + +/* Inline instruction administration (part of the code generator) */ + +#define LineLength 300 /* maximum number of charcters on one line */ +#define MaxInlineInstr 60 /* maximum number of instructions that may be + substituted for one system call */ + +#define InlineBuffSize ((SizeT) KBYTE * 32) /* the size of the buffer + containing all the inline instructions */ diff --git a/backendC/CleanCompilerSources/statesgen.c b/backendC/CleanCompilerSources/statesgen.c new file mode 100644 index 0000000..534c405 --- /dev/null +++ b/backendC/CleanCompilerSources/statesgen.c @@ -0,0 +1,3847 @@ +/* + (Concurrent) Clean Compiler: Generation of states + ================================================== + + This module generates the (internal) states that are used during the code generation. + + Authors: Sjaak Smetsers & John van Groningen + At: University of Nijmegen, department of computing science + Version: 1.1 +*/ + +#pragma segment statesgen + +#include "system.h" + +#include "settings.h" +#include "syntaxtr.t" +#include "comsupport.h" +#include "buildtree.h" +#include "codegen_types.h" +#include "codegen1.h" +#include "codegen2.h" +#include "statesgen.h" +#include "checker.h" +#include "instructions.h" +#include "optimisations.h" +#include "sa.h" + +/* #include "dbprint.h" */ + +#define UNBOX_STRICT_CONSTRUCTOR_RECORD +#define UNBOX_STRICT_RECORD_WITH_ONE_FIELD +#define FASTER_STRICT_IF /* also in codegen2.c */ +#define FASTER_STRICT_AND_OR +#define UNTUPLE_STRICT_TUPLES /* also in optimisations.c */ + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) +#define for_la(v1,v2,l1,l2,n1) for(v1=(l1),v2=(l2);v1!=NULL;v1=v1->n1,++v2) +#define for_li(v,i,l,n) for(v=(l),i=0;v!=NULL;v=v->n,++i) +#define for_ll(v1,v2,l1,l2,n1,n2) for(v1=(l1),v2=(l2);v1!=NULL;v1=v1->n1,v2=v2->n2) +#define for_lla(v1,v2,v3,l1,l2,a3,n1,n2) for(v1=(l1),v2=(l2),v3=(a3);v1!=NULL;v1=v1->n1,v2=v2->n2,++v3) + +static void error_in_function (char *m) +{ + ErrorInCompiler ("statesgen.c",m,""); +} + +static char *Elhsannots = "annotations are not allowed at this position"; +static char *ECodeBlock = "missing type specification"; +static char *Wtypeannot = "only strict annotations in a type rule will be regarded"; +static char *Wparannot = "parallel annotations ignored in sequential mode"; +static char *Wrootannot = "root annotations are ignored"; +/* +static char *Econflict = "conflicting parallel annotations"; +static char *WEorIoverrule = "strict annotation overruled by parallel annotation"; +static char *WStrictoverrule = "parallel annotation overruled by strict annotation"; +static char *Wapplannot = "parallel annotations on implicitly defined nodeids are ignored"; +static char *Wnonterm = "non-terminating rule specified"; +static char *Wunkannot = "unknown annotation"; +*/ + +/* some routines for setting the state fields of an object */ + +StateS BasicSymbolStates [Nr_Of_Predef_Types]; + +int FirstStateIsStricter (StateS offered_state,StateS demanded_state) +{ + if (offered_state.state_type==SimpleState){ + if (IsSimpleState (demanded_state)){ + switch (offered_state.state_kind){ + case OnB: + case StrictOnA: + case StrictRedirection: + return 1; + case OnA: + case SemiStrict: + case LazyRedirection: + case Parallel: + case UnderEval: + return demanded_state.state_kind==OnA; + default: + error_in_function ("FirstStateIsStricter"); + return 0; + } + } else { + return 0; + } + } else { + if (IsSimpleState (demanded_state)) + return 1; + else if (offered_state.state_type==ArrayState && demanded_state.state_type==ArrayState) + return 1; + else + return 0; + } +} + +#define BETWEEN(l,h,v) ((unsigned)((v)-(l)) <= (unsigned)((h)-(l))) + +int FieldArgumentNodeStatesAreStricter (ArgS *offered_args,ArgS *field_args,States record_states) +{ + ArgS *offered_arg,*field_arg; + + for_ll (offered_arg,field_arg,offered_args,field_args,arg_next,arg_next){ + int node_kind; + Node arg_node; + int field_number; + + field_number=field_arg->arg_node->node_symbol->symb_def->sdef_sel_field_number; + + arg_node=offered_arg->arg_node; + + node_kind=arg_node->node_kind; + if (node_kind!=NodeIdNode){ + if (node_kind==NormalNode && (BETWEEN (int_denot,real_denot,arg_node->node_symbol->symb_kind) || arg_node->node_symbol->symb_kind==string_denot)) + ; + else + if (!FirstStateIsStricter (arg_node->node_state,record_states[field_number])) + return 0; + } else + if (!FirstStateIsStricter (arg_node->node_node_id->nid_state,record_states[field_number])) + return 0; + } + + return 1; +} + +void SetUnaryState (StateS *state_p,StateKind kind,ObjectKind object) +{ + state_p->state_arity = 1; + state_p->state_kind = kind; + state_p->state_object = object; + state_p->state_type = SimpleState; + state_p->state_mark = 0; +} + +static void SetTupleState (StateS *state_p,States args,int arity) +{ + state_p->state_arity = arity; + state_p->state_tuple_arguments = args; + state_p->state_type = TupleState; + state_p->state_mark = 0; +} + +static void SetUpdateableTupleState (StateS *state_p,States args,int arity) +{ + state_p->state_arity = arity; + state_p->state_tuple_arguments = args; + state_p->state_type = TupleState; + state_p->state_mark = STATE_ELEMENTS_UPDATEABLE_MASK; +} + +static void SetRecordState (StateS *state_p,SymbDef record_sdef,int arity) +{ + RecordStateDescr recdesc; + + recdesc = (RecordStateDescr) CompAlloc (sizeof (struct record_state_descr) + (arity-1)*sizeof (struct state)); + recdesc->rs_symb = record_sdef; + + state_p->state_arity = arity; + state_p->state_record_desc = recdesc; + state_p->state_type = RecordState; + state_p->state_mark = 0; +} + +static void SetUnboxedArrayState (StateS *state_p,States arg) +{ + state_p->state_arity = 0; + state_p->state_array_arguments = arg; + state_p->state_type = ArrayState ; + state_p->state_mark = 0; +} + +StateS LazyState,StrictState; + +#define NewArrayOfStates(n) (States) CompAlloc (sizeof (StateS)*(n)) + +static States NewArrayOfUnaryStates (int arity, StateKind init) +{ + int i; + States argstates; + + argstates = NewArrayOfStates (arity); + + for (i=0; i<arity; i++) + SetUnaryState (&argstates [i], init, UnknownObj); + + return argstates; +} + +void ConvertAnnotationToState (Annotation annot,StateS *state_p) +{ + if (annot==NoAnnot) + return; + else if (annot==StrictAnnot){ + *state_p=StrictState; + return; + } else { + SetUnaryState (state_p, DoParallel ? Parallel : OnA, UnknownObj); + if (DoParallel) + state_p->state_mark |= STATE_PARALLEL_MASK; + return; + } +} + +static void GenRecordState (SymbDef sdef); + +void ConvertTypeToState (TypeNode type,StateS *state_p,StateKind kind) +{ + Symbol symbol; + + symbol=type->type_node_symbol; + + if (symbol->symb_kind < Nr_Of_Predef_Types){ + *state_p = BasicSymbolStates [symbol->symb_kind]; + if (kind!=StrictOnA) + state_p->state_kind=kind; + } else if (symbol->symb_kind==definition && symbol->symb_def->sdef_kind==RECORDTYPE){ + if (kind==StrictOnA){ + GenRecordState (symbol->symb_def); + *state_p=symbol->symb_def->sdef_record_state; + } else + SetUnaryState (state_p,kind,RecordObj); + } else +#if ABSTRACT_OBJECT + if (symbol->symb_kind==definition && symbol->symb_def->sdef_kind==ABSTYPE) + SetUnaryState (state_p,kind,AbstractObj); + else +#endif + SetUnaryState (state_p,kind,UnknownObj); + +#ifdef REUSE_UNIQUE_NODES + if (type->type_node_attribute==UniqueAttr || (symbol->symb_kind==definition && + (symbol->symb_def->sdef_kind==TYPE || symbol->symb_def->sdef_kind==RECORDTYPE) && + symbol->symb_def->sdef_type->type_lhs->ft_attribute==UniqueAttr)) + { + state_p->state_mark |= STATE_UNIQUE_MASK; + } + + if ((state_p->state_mark & STATE_UNIQUE_MASK) && state_p->state_type==SimpleState){ + if (symbol->symb_kind==list_type || symbol->symb_kind==tuple_type || + (symbol->symb_kind==definition && (symbol->symb_def->sdef_kind==TYPE || symbol->symb_def->sdef_kind==RECORDTYPE))) + { + unsigned long unq_type_args; + TypeArgs type_arg; + int i; + + unq_type_args=0; + for_li (type_arg,i,type->type_node_arguments,type_arg_next) + if (type_arg->type_arg_node->type_node_attribute==UniqueAttr) + unq_type_args |= 1<<i; + + if (unq_type_args!=0){ + state_p->state_mark |= STATE_UNIQUE_TYPE_ARGUMENTS_MASK; + state_p->state_unq_type_args = unq_type_args; + } + } + } +#endif + + if (kind==StrictOnA && IsSimpleState (*state_p)){ + ObjectKind obj_kind; + + obj_kind=state_p->state_object; + if (obj_kind==TupleObj){ + int i; + TypeArgs arg; + + SetTupleState (state_p, NewArrayOfStates (type->type_node_arity), type->type_node_arity); + + for_li (arg,i,type->type_node_arguments,type_arg_next){ + TypeNode arg_type_node; + + arg_type_node=arg->type_arg_node; + + if (!arg_type_node->type_node_is_var){ + ConvertTypeToState (arg_type_node,&state_p->state_tuple_arguments[i],arg_type_node->type_node_annotation==NoAnnot ? OnA : StrictOnA); +#ifdef UNTUPLE_STRICT_TUPLES_ + arg_type_node->type_node_state=state_p->state_tuple_arguments[i]; +#endif + } else + state_p->state_tuple_arguments[i] = arg_type_node->type_node_annotation==NoAnnot ? LazyState : StrictState; + } + } else if (obj_kind==UnboxedArrayObj || obj_kind==StrictArrayObj || obj_kind==ArrayObj){ + TypeNode element_node; + + element_node=type->type_node_arguments->type_arg_node; + + state_p->state_arity = 1; + state_p->state_array_arguments = NewArrayOfStates (1); + state_p->state_type = ArrayState; + state_p->state_mark=0; + + switch (obj_kind){ + case ArrayObj: + SetUnaryState (& state_p->state_array_arguments [0], OnA, UnknownObj); + break; + case StrictArrayObj: + state_p->state_array_arguments [0] = StrictState; + break; + case UnboxedArrayObj: + if (element_node->type_node_is_var) + state_p->state_array_arguments [0] = StrictState; + else + ConvertTypeToState (element_node,&state_p->state_array_arguments [0],StrictOnA); + state_p->state_mark |= STATE_UNBOXED_ARRAY_MASK; + break; + } + } + } +} + +static void GenRecordState (SymbDef sdef) +{ + if (sdef->sdef_checkstatus < ConvertingToState){ + Types rectype; + FieldList fields; + States fieldstates; + int i,oldline; + Symbol oldsymbol; + FlatType lhs; + int strict_record; + + rectype = sdef->sdef_type; + lhs = rectype->type_lhs; + + oldline = CurrentLine; + oldsymbol = CurrentSymbol; + + CurrentSymbol = lhs->ft_symbol; + CurrentLine = rectype->type_line; + + sdef->sdef_checkstatus = ConvertingToState; /* to detect cyclic strict field dependencies */ + SetRecordState (&sdef->sdef_record_state, sdef, sdef->sdef_cons_arity); + fieldstates=sdef->sdef_record_state.state_record_arguments; + +/* rectype->type_constructors->cl_constructor->type_node_state = sdef->sdef_record_state; */ + + strict_record=0; + + for_li (fields,i,rectype->type_fields,fl_next){ + TypeNode field_type_node; + + field_type_node = fields->fl_type; + + if (field_type_node->type_node_annotation==StrictAnnot){ + strict_record=1; + if (!field_type_node->type_node_is_var){ + ConvertTypeToState (field_type_node,&fields->fl_state,StrictOnA); + + if (fields->fl_state.state_type==RecordState +#ifdef UNBOX_STRICT_RECORD_WITH_ONE_FIELD + && !(fields->fl_state.state_arity==1) +#endif + ) + { + SetUnaryState (&fieldstates[i], StrictOnA, RecordObj); +#ifdef REUSE_UNIQUE_NODES + if (field_type_node->type_node_attribute==UniqueAttr) + fieldstates[i].state_mark |= STATE_UNIQUE_MASK; +#endif + } else + fieldstates[i]=fields->fl_state; + } else + fieldstates[i]=fields->fl_state=field_type_node->type_node_annotation==NoAnnot ? LazyState : StrictState; +#ifdef REUSE_UNIQUE_NODES + if (field_type_node->type_node_attribute==UniqueAttr){ + fieldstates[i].state_mark |= STATE_UNIQUE_MASK; + fields->fl_state.state_mark |= STATE_UNIQUE_MASK; + } +#endif + } else { + fieldstates[i] = LazyState; +#ifdef REUSE_UNIQUE_NODES + if (field_type_node->type_node_attribute==UniqueAttr) + fieldstates[i].state_mark |= STATE_UNIQUE_MASK; +#endif + } + + fields->fl_symbol->symb_def->sdef_sel_field = fields; + } + + sdef->sdef_strict_constructor=strict_record; + sdef->sdef_checkstatus = ConvertedToState; /* to detect cyclic strict field dependencies */ + + CurrentSymbol = oldsymbol; + CurrentLine = oldline; + } else if (sdef->sdef_checkstatus == ConvertedToState) + return; + else + StaticMessage (True, "%S", "%s cyclic strict field dependencies are not allowed", CurrentSymbol, sdef->sdef_ident->ident_name); + +} + +static void GenResultStatesOfLazyFields (SymbDef sdef) +{ + FieldList fields; + Types rectype; + int i; + + rectype = sdef->sdef_type; + + CurrentSymbol = rectype->type_lhs->ft_symbol; + CurrentLine = rectype->type_line; + + for (i=0, fields = rectype->type_fields; fields; i++, fields = fields->fl_next){ + TypeNode field_type_node = fields->fl_type; + + if (field_type_node->type_node_annotation!=StrictAnnot){ + if (field_type_node->type_node_is_var || field_type_node->type_node_symbol->symb_kind==apply_symb) + SetUnaryState (&fields->fl_state, LazyRedirection, UnknownObj); + else + ConvertTypeToState (field_type_node,&fields->fl_state,StrictOnA); + } + } +} + +static void ChangeFieldRecordStateForStrictAbsTypeFields (SymbDef icl_sdef,SymbDef dcl_sdef) +{ + Types icl_type; + FieldList icl_field; + StateP icl_fieldstate_p,dcl_fieldstate_p; + + icl_type = icl_sdef->sdef_type; + + CurrentSymbol = icl_type->type_lhs->ft_symbol; + CurrentLine = icl_type->type_line; + + icl_fieldstate_p=icl_sdef->sdef_record_state.state_record_arguments; + dcl_fieldstate_p=dcl_sdef->sdef_record_state.state_record_arguments; + + for_l (icl_field,icl_type->type_fields,fl_next){ + if (dcl_fieldstate_p->state_type==SimpleState && + (icl_fieldstate_p->state_type!=SimpleState || + icl_fieldstate_p->state_kind!=dcl_fieldstate_p->state_kind)) + { + StaticMessage (False, "%S", "%S strict field is boxed because the field type is an abstract type", + CurrentSymbol, icl_field->fl_symbol); + + *icl_fieldstate_p=*dcl_fieldstate_p; + } + + ++icl_fieldstate_p; + ++dcl_fieldstate_p; + } +} + +static void GenerateStatesForConstructors (SymbDef sdef) +{ + ConstructorList constructor; + + CurrentLine = sdef->sdef_type->type_line; + + for_l (constructor,sdef->sdef_type->type_constructors,cl_next){ + int strict_constructor; + SymbDef constructor_sdef; + TypeNode type_node; + TypeArgs arg; + StateP state_p; + + type_node=constructor->cl_constructor; + CurrentSymbol=type_node->type_node_symbol; + + constructor_sdef=CurrentSymbol->symb_def; + + state_p = NewArrayOfStates (constructor_sdef->sdef_arity); + constructor->cl_state_p = state_p; + + constructor_sdef->sdef_constructor=constructor; + + strict_constructor=0; + + for_l (arg,type_node->type_node_arguments,type_arg_next){ + TypeNode type_arg_node; + + type_arg_node=arg->type_arg_node; + + if (type_arg_node->type_node_annotation==StrictAnnot){ + strict_constructor=1; + + if (!type_arg_node->type_node_is_var){ + ConvertTypeToState (type_arg_node,state_p,StrictOnA); + + if (state_p->state_type==RecordState) +#ifdef UNBOX_STRICT_CONSTRUCTOR_RECORD + if (type_node->type_node_arguments->type_arg_next!=NULL) +#endif +#ifdef UNBOX_STRICT_RECORD_WITH_ONE_FIELD + if (!(state_p->state_arity==1)) +#endif + SetUnaryState (state_p, StrictOnA, RecordObj); + } else { + *state_p=StrictState; + } + } else + *state_p=LazyState; + + ++state_p; + } + + constructor_sdef->sdef_strict_constructor=strict_constructor; + } +} + +static void ChangeElementStateForStrictAbsTypeFields (SymbDef icl_sdef,SymbDef dcl_sdef) +{ + Types icl_type = icl_sdef->sdef_type, dcl_type = dcl_sdef->sdef_type; + ConstructorList icl_cons, dcl_cons; + + CurrentLine = icl_type->type_line; + + for (icl_cons = icl_type->type_constructors, dcl_cons = dcl_type->type_constructors; dcl_cons; + icl_cons = icl_cons->cl_next, dcl_cons = dcl_cons->cl_next) + { + TypeNode icl_node,dcl_node; + SymbDef icl_constructor,dcl_constructor; + + icl_node=icl_cons->cl_constructor; + icl_constructor=icl_node->type_node_symbol->symb_def; + + if (icl_constructor->sdef_strict_constructor){ + TypeArgs icl_arg,dcl_arg; + StateP icl_arg_state_p,dcl_arg_state_p; + + dcl_node=dcl_cons->cl_constructor; + CurrentSymbol=dcl_node->type_node_symbol; + dcl_constructor=CurrentSymbol->symb_def; + + icl_arg=icl_node->type_node_arguments; + dcl_arg=dcl_node->type_node_arguments; + icl_arg_state_p=icl_cons->cl_state_p; + dcl_arg_state_p=dcl_cons->cl_state_p; + + while (icl_arg!=NULL){ + TypeNode icl_element_node,dcl_element_node; + + icl_element_node=icl_arg->type_arg_node; + dcl_element_node=dcl_arg->type_arg_node; + + if (dcl_arg_state_p->state_type==SimpleState && + (icl_arg_state_p->state_type!=SimpleState || icl_arg_state_p->state_kind!=dcl_arg_state_p->state_kind)) + { + StaticMessage (False, "%S", "%S element is boxed because its type is an abstract type", + CurrentSymbol, icl_element_node->type_node_symbol); + + *icl_arg_state_p=*dcl_arg_state_p; + } + + icl_arg=icl_arg->type_arg_next; + dcl_arg=dcl_arg->type_arg_next; + ++icl_arg_state_p; + ++dcl_arg_state_p; + } + } + } +} + +void GenerateStatesForRecords (Symbol symbols) +{ + Symbol symb; + + for_l (symb,symbols,symb_next) + if (symb->symb_kind==definition){ + SymbDef def; + + def=symb->symb_def; + if (def->sdef_kind==RECORDTYPE){ + GenRecordState (def); + GenResultStatesOfLazyFields (def); + + if (def->sdef_exported){ + SymbDef dcl_sdef; + + dcl_sdef=def->sdef_dcl_icl; + + if (dcl_sdef!=NULL && dcl_sdef->sdef_kind==RECORDTYPE){ + GenRecordState (dcl_sdef); + GenResultStatesOfLazyFields (dcl_sdef); + ChangeFieldRecordStateForStrictAbsTypeFields (def,dcl_sdef); + } + } + } else if (def->sdef_kind==TYPE){ + GenerateStatesForConstructors (def); + + if (def->sdef_exported){ + SymbDef dcl_sdef; + + dcl_sdef=def->sdef_dcl_icl; + + if (dcl_sdef->sdef_kind==TYPE){ + GenerateStatesForConstructors (dcl_sdef); + ChangeElementStateForStrictAbsTypeFields (def,dcl_sdef); + } + } + } + } +} + +/* +static Bool AnnotHasDeferAttr (Annotation annotkind) +{ + switch (annotkind){ + case InterleavedAnnot: + case LazyInterleavedAnnot: + case ContinueAnnot: + case DeferAnnot: + case WaitAnnot: + case ContInterleavedAnnot: + case InterleavedNFAnnot: + return True; + default: + return False; + } +} +*/ + +static StateS DetermineStatesOfRuleType (TypeAlts ruletype,StateS *const function_state_p) +{ + TypeNode lhsroot; + TypeArgs type_arg; + StateP arg_state_p; + + lhsroot = ruletype->type_alt_lhs; + + CurrentSymbol = lhsroot ->type_node_symbol; + CurrentLine = ruletype->type_alt_line; + + if (lhsroot->type_node_annotation!=NoAnnot) + StaticMessage (False, "%S", Wrootannot, CurrentSymbol); + + arg_state_p=function_state_p; + for_l (type_arg,lhsroot->type_node_arguments,type_arg_next){ + if (!(type_arg->type_arg_node->type_node_annotation==NoAnnot || type_arg->type_arg_node->type_node_annotation==StrictAnnot)) + StaticMessage (False, "%S", Wtypeannot, CurrentSymbol); + + if (!type_arg->type_arg_node->type_node_is_var) + ConvertTypeToState (type_arg->type_arg_node,arg_state_p,type_arg->type_arg_node->type_node_annotation==NoAnnot ? OnA : StrictOnA); + else + *arg_state_p = type_arg->type_arg_node->type_node_annotation==NoAnnot ? LazyState : StrictState; + + ++arg_state_p; + } + + if (ruletype->type_alt_rhs->type_node_is_var || ruletype->type_alt_rhs->type_node_symbol->symb_kind==apply_symb){ + function_state_p[-1] = StrictState; + function_state_p[-1].state_kind = StrictRedirection; + } else + ConvertTypeToState (ruletype->type_alt_rhs,&function_state_p[-1],StrictOnA); + + return function_state_p[-1]; +} + +typedef struct type_node *TypeNodeP; + +#ifdef REUSE_UNIQUE_NODES +# ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +static void determine_unique_state_of_constructor_argument (StateP result_state_p,StateP type_state_p,TypeNodeP type_arg_node,int lhs_type_attribute) +{ + if (type_arg_node->type_node_is_var){ + if ((type_state_p->state_mark & STATE_UNIQUE_TYPE_ARGUMENTS_MASK) && + type_arg_node->type_node_tv->tv_argument_nr>=0 && + (type_state_p->state_unq_type_args & (1<<(type_arg_node->type_node_tv->tv_argument_nr)))) + { + result_state_p->state_mark |= STATE_UNIQUE_MASK; + } + } else { + AttributeKind arg_type_attribute; + + arg_type_attribute=type_arg_node->type_node_attribute; + + if (arg_type_attribute==UniqueAttr || (arg_type_attribute>=FirstUniVarNumber && arg_type_attribute==lhs_type_attribute)) + result_state_p->state_mark |= STATE_UNIQUE_MASK; + + if ((result_state_p->state_mark & STATE_UNIQUE_MASK) && result_state_p->state_type==SimpleState){ + Symbol symbol; + + symbol=type_arg_node->type_node_symbol; + + if (symbol->symb_kind==list_type || symbol->symb_kind==tuple_type || (symbol->symb_kind==definition && + (symbol->symb_def->sdef_kind==TYPE || symbol->symb_def->sdef_kind==RECORDTYPE))) + { + unsigned long unq_type_args; + TypeArgs type_arg; + int i; + + unq_type_args=0; + for_li (type_arg,i,type_arg_node->type_node_arguments,type_arg_next){ + TypeNodeP type_arg_node_p; + + type_arg_node_p=type_arg->type_arg_node; + if (type_arg_node_p->type_node_is_var){ + if ((type_state_p->state_mark & STATE_UNIQUE_TYPE_ARGUMENTS_MASK) && + type_arg_node_p->type_node_tv->tv_argument_nr>=0 && + (type_state_p->state_unq_type_args & (1<<(type_arg_node_p->type_node_tv->tv_argument_nr)))) + { + unq_type_args |= 1<<i; + } + } else { + AttributeKind arg_type_attribute; + + arg_type_attribute=type_arg_node_p->type_node_attribute; + if (arg_type_attribute==UniqueAttr || (arg_type_attribute>=FirstUniVarNumber && arg_type_attribute==lhs_type_attribute)) + unq_type_args |= 1<<i; + } + } + + if (unq_type_args!=0){ + result_state_p->state_mark |= STATE_UNIQUE_TYPE_ARGUMENTS_MASK; + result_state_p->state_unq_type_args = unq_type_args; + } + } + } + } +} +# else +static StateP determine_unique_state_of_constructor_argument (StateP type_state_p,TypeNodeP type_arg_node,int lhs_type_attribute) +{ + if (type_arg_node->type_node_is_var){ + if ((type_state_p->state_mark & STATE_UNIQUE_TYPE_ARGUMENTS_MASK) && + type_arg_node->type_node_tv->tv_argument_nr>=0 && + (type_state_p->state_unq_type_args & (1<<(type_arg_node->type_node_tv->tv_argument_nr))) && + (type_state_p->state_mark & STATE_UNIQUE_MASK)==0) + { + StateP result_state_p; + + result_state_p=CompAllocType (StateS); + *result_state_p=*type_state_p; + result_state_p->state_mark |= STATE_UNIQUE_MASK; + + return result_state_p; + } else + return type_state_p; + } else { + AttributeKind arg_type_attribute; + StateP result_state_p; + + arg_type_attribute=type_arg_node->type_node_attribute; + + if (arg_type_attribute==UniqueAttr || (arg_type_attribute>=FirstUniVarNumber && arg_type_attribute==lhs_type_attribute)){ + result_state_p=CompAllocType (StateS); + *result_state_p=*type_state_p; + result_state_p->state_mark |= STATE_UNIQUE_MASK; + + type_state_p=result_state_p; + } else + result_state_p=NULL; + + if ((type_state_p->state_mark & STATE_UNIQUE_MASK) && type_state_p->state_type==SimpleState){ + Symbol symbol; + + symbol=type_arg_node->type_node_symbol; + + if (symbol->symb_kind==list_type || symbol->symb_kind==tuple_type || (symbol->symb_kind==definition && + (symbol->symb_def->sdef_kind==TYPE || symbol->symb_def->sdef_kind==RECORDTYPE))) + { + unsigned long unq_type_args; + TypeArgs type_arg; + int i; + + unq_type_args=0; + for_li (type_arg,i,type_arg_node->type_node_arguments,type_arg_next){ + TypeNodeP type_arg_node_p; + + type_arg_node_p=type_arg->type_arg_node; + if (type_arg_node_p->type_node_is_var){ + if ((type_state_p->state_mark & STATE_UNIQUE_TYPE_ARGUMENTS_MASK) && + type_arg_node_p->type_node_tv->tv_argument_nr>=0 && + (type_state_p->state_unq_type_args & (1<<(type_arg_node_p->type_node_tv->tv_argument_nr)))) + { + unq_type_args |= 1<<i; + } + } else { + AttributeKind arg_type_attribute; + + arg_type_attribute=type_arg_node_p->type_node_attribute; + if (arg_type_attribute==UniqueAttr || (arg_type_attribute>=FirstUniVarNumber && arg_type_attribute==lhs_type_attribute)) + unq_type_args |= 1<<i; + } + } + + if (unq_type_args!=0){ + if (result_state_p==NULL){ + result_state_p=CompAllocType (StateS); + *result_state_p=*type_state_p; + } + result_state_p->state_mark |= STATE_UNIQUE_TYPE_ARGUMENTS_MASK; + result_state_p->state_unq_type_args = unq_type_args; + + return result_state_p; + } + } + } + + return type_state_p; + } +} +# endif +#endif + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +static void GenStatesInLhsSubArguments (Node argnode,StateS states[]); +static void GenStatesInLhsSubArg (Node argnode,StateP arg_state_p); + +static void GenStatesInLhsNode (Node node,StateP arg_state_p) +{ + Args arg; + + if (node->node_annotation!=NoAnnot) + StaticMessage (True, "%S", "%S %s",CurrentSymbol,node->node_symbol, Elhsannots); + + if (node->node_kind==NormalNode){ + Symbol symbol; + + symbol=node->node_symbol; + if (symbol->symb_kind==definition){ + SymbDef sdef; + + sdef=symbol->symb_def; + + if (sdef->sdef_kind==CONSTRUCTOR){ +# ifdef REUSE_UNIQUE_NODES + AttributeKind lhs_type_attribute; + + lhs_type_attribute=sdef->sdef_type->type_lhs->ft_attribute; + + if (lhs_type_attribute==UniqueAttr) + arg_state_p->state_mark |= STATE_UNIQUE_MASK; + + if (sdef->sdef_arity==node->node_arity && (arg_state_p->state_mark & STATE_UNIQUE_MASK)){ + if (sdef->sdef_strict_constructor){ + struct type_arg *type_arg_p; + StateP constructor_arg_state_p; + ArgS *arg; + + for_lla (arg,type_arg_p,constructor_arg_state_p, + node->node_arguments,sdef->sdef_constructor->cl_constructor->type_node_arguments,symbol->symb_def->sdef_constructor->cl_state_p, + arg_next,type_arg_next) + { + Node arg_node; + + arg->arg_state = *constructor_arg_state_p; + + determine_unique_state_of_constructor_argument (&arg->arg_state,arg_state_p,type_arg_p->type_arg_node,lhs_type_attribute); + + arg_node=arg->arg_node; + + if (arg_node->node_kind==NodeIdNode){ + arg_node->node_node_id->nid_lhs_state_p_=&arg->arg_state; + arg_node=arg_node->node_node_id->nid_node; + if (!arg_node) + continue; + } + + GenStatesInLhsSubArg (arg_node,&arg->arg_state); + } + } else { + struct type_arg *type_arg_p; + ArgS *arg; + + for_ll (arg,type_arg_p,node->node_arguments,sdef->sdef_constructor->cl_constructor->type_node_arguments,arg_next,type_arg_next){ + Node arg_node; + + arg->arg_state=LazyState; + + determine_unique_state_of_constructor_argument (&arg->arg_state,arg_state_p,type_arg_p->type_arg_node,lhs_type_attribute); + + arg_node=arg->arg_node; + + if (arg_node->node_kind==NodeIdNode){ + arg_node->node_node_id->nid_lhs_state_p_=&arg->arg_state; + arg_node=arg_node->node_node_id->nid_node; + if (!arg_node) + continue; + } + + GenStatesInLhsNode (arg_node,&arg->arg_state); + } + } + return; + } +# endif + if (sdef->sdef_strict_constructor && sdef->sdef_arity==node->node_arity){ + GenStatesInLhsSubArguments (node,symbol->symb_def->sdef_constructor->cl_state_p); + return; + } + } else if (sdef->sdef_kind==RECORDTYPE){ +# ifdef REUSE_UNIQUE_NODES + AttributeKind lhs_type_attribute; + + lhs_type_attribute=sdef->sdef_type->type_lhs->ft_attribute; + + if (lhs_type_attribute==UniqueAttr) + arg_state_p->state_mark |= STATE_UNIQUE_MASK; + + if (arg_state_p->state_mark & STATE_UNIQUE_MASK){ + StateP arg_state_p; + ArgS *arg; + FieldList field; + + for_lla (arg,field,arg_state_p,node->node_arguments, + sdef->sdef_type->type_fields,sdef->sdef_record_state.state_record_arguments,arg_next,fl_next) + { + Node arg_node; + + arg->arg_state = *arg_state_p; + + determine_unique_state_of_constructor_argument (&arg->arg_state,arg_state_p,field->fl_type,lhs_type_attribute); + + arg_node=arg->arg_node; + + if (arg_node->node_kind==NodeIdNode){ + arg_node->node_node_id->nid_lhs_state_p_=&arg->arg_state; + arg_node=arg_node->node_node_id->nid_node; + if (!arg_node) + continue; + } + + GenStatesInLhsSubArg (arg_node,&arg->arg_state); + } + } else +# endif + GenStatesInLhsSubArguments (node,sdef->sdef_record_state.state_record_arguments); + return; + } + } +# ifdef REUSE_UNIQUE_NODES + else if (symbol->symb_kind==cons_symb && (arg_state_p->state_mark & STATE_UNIQUE_MASK) && node->node_arity==2){ + Node arg_node; + + arg=node->node_arguments; + + arg->arg_state=LazyState; + if ((arg_state_p->state_mark & STATE_UNIQUE_TYPE_ARGUMENTS_MASK) && (arg_state_p->state_unq_type_args & 1)){ + arg->arg_state.state_mark |= STATE_UNIQUE_MASK; + } + + arg_node=arg->arg_node; + if (arg_node->node_kind==NodeIdNode){ + arg_node->node_node_id->nid_lhs_state_p_=&arg->arg_state; + arg_node=arg_node->node_node_id->nid_node; + } + if (arg_node!=NULL) + GenStatesInLhsNode (arg_node,&arg->arg_state); + + arg=arg->arg_next; + + arg->arg_state=LazyState; + arg->arg_state.state_mark |= STATE_UNIQUE_MASK; + if ((arg_state_p->state_mark & STATE_UNIQUE_TYPE_ARGUMENTS_MASK) && (arg_state_p->state_unq_type_args & 1)){ + arg->arg_state.state_mark |= STATE_UNIQUE_TYPE_ARGUMENTS_MASK; + arg->arg_state.state_unq_type_args = 1; + } + + arg_node=arg->arg_node; + if (arg_node->node_kind==NodeIdNode){ + arg_node->node_node_id->nid_lhs_state_p_=&arg->arg_state; + arg_node=arg_node->node_node_id->nid_node; + } + if (arg_node!=NULL) + GenStatesInLhsNode (arg_node,&arg->arg_state); + + return; + } else if (symbol->symb_kind==tuple_symb && (arg_state_p->state_mark & STATE_UNIQUE_MASK)){ + int i; + + for_li (arg,i,node->node_arguments,arg_next){ + Node arg_node; + + arg->arg_state=LazyState; + if ((arg_state_p->state_mark & STATE_UNIQUE_TYPE_ARGUMENTS_MASK) && (arg_state_p->state_unq_type_args & (1<<i))){ + arg->arg_state.state_mark |= STATE_UNIQUE_MASK; + } + + arg_node=arg->arg_node; + if (arg_node->node_kind==NodeIdNode){ + arg_node->node_node_id->nid_lhs_state_p_=&arg->arg_state; + arg_node=arg_node->node_node_id->nid_node; + } + if (arg_node!=NULL) + GenStatesInLhsNode (arg_node,&arg->arg_state); + } + + return; + } +# endif + } + + for_l (arg,node->node_arguments,arg_next){ + Node arg_node; + + arg->arg_state=LazyState; + + arg_node=arg->arg_node; + + if (arg_node->node_kind==NodeIdNode){ + arg_node->node_node_id->nid_lhs_state_p_=&arg->arg_state; + arg_node=arg_node->node_node_id->nid_node; + if (!arg_node) + continue; + } + + GenStatesInLhsNode (arg_node,&arg->arg_state); + } +} + +static void GenStatesInLhsSubArg (Node arg_node,StateP arg_state_p) +{ + if (arg_node->node_annotation!=NoAnnot) + StaticMessage (True, "%S", Elhsannots, CurrentSymbol); + + switch (arg_state_p->state_type){ + case RecordState: + GenStatesInLhsSubArguments (arg_node,arg_node->node_symbol->symb_def->sdef_record_state.state_record_arguments); + return; + case TupleState: + GenStatesInLhsSubArguments (arg_node,arg_state_p->state_tuple_arguments); + return; + default: + GenStatesInLhsNode (arg_node,arg_state_p); + return; + } +} + +static void GenStatesInLhsSubArguments (Node node,StateS states[]) +{ + StateP arg_state_p; + ArgS *arg; + + for (arg=node->node_arguments,arg_state_p=states; arg!=NULL; arg=arg->arg_next,++arg_state_p){ + Node arg_node; + + arg->arg_state = *arg_state_p; + + arg_node=arg->arg_node; + + if (arg_node->node_kind==NodeIdNode){ + arg_node->node_node_id->nid_lhs_state_p_=&arg->arg_state; + arg_node=arg_node->node_node_id->nid_node; + if (!arg_node) + continue; + } + + GenStatesInLhsSubArg (arg_node,&arg->arg_state); + } +} + +static void DetermineLhsStatesOfRule (ImpRules rule) +{ + RuleAlts alt; + StateP function_state_p; + + function_state_p=rule->rule_state_p; + + CurrentSymbol = rule->rule_root->node_symbol; + + for_l (alt,rule->rule_alts,alt_next){ + CurrentLine = alt->alt_line; + + GenStatesInLhsSubArguments (alt->alt_lhs_root,function_state_p); + + alt->alt_lhs_root->node_state = function_state_p[-1]; /* i.e. the result kind */ + } +} +#endif + +unsigned next_def_number; + +void ExamineTypesAndLhsOfImpRuleSymbolDefinitionAgain (SymbDef def) +{ + StateS rootstate; + + rootstate = DetermineStatesOfRuleType (def->sdef_rule->rule_type,def->sdef_rule->rule_state_p); + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + DetermineLhsStatesOfRule (def->sdef_rule); +#endif + + if (def->sdef_exported && def->sdef_dcl_icl!=NULL && def->sdef_dcl_icl->sdef_kind!=INSTANCE) + rootstate=def->sdef_dcl_icl->sdef_rule_type->rule_type_state_p[-1]; + + if (IsSimpleState (rootstate)){ + if (rootstate.state_kind == OnA || rootstate.state_kind == StrictOnA){ + def->sdef_calledwithrootnode = True; + def->sdef_returnsnode = True; + } else if (rootstate.state_kind == StrictRedirection){ + def->sdef_calledwithrootnode = False; + def->sdef_returnsnode = True; + } else { + def->sdef_calledwithrootnode = False; + def->sdef_returnsnode = False; + } + } else { + def->sdef_calledwithrootnode = False; + def->sdef_returnsnode = False; + } +} + +#define allocate_function_state(arity) (((StateP)(CompAlloc (sizeof(StateS)*((arity)+1))))+1) + +void ExamineTypesAndLhsOfSymbolDefinition (SymbDef def) +{ + StateS rootstate; + + if (def->sdef_over_arity!=0) + return; + + def->sdef_number = 0; + + if (def->sdef_exported && def->sdef_dcl_icl!=def) + def->sdef_mark |= SDEF_USED_LAZILY_MASK | SDEF_USED_CURRIED_MASK; + + switch (def->sdef_kind){ + case SYSRULE: + def->sdef_ident->ident_symbol = NULL; + def->sdef_ident->ident_environ = CurrentModule; + case DEFRULE: + if (def->sdef_isused){ + def->sdef_rule_type->rule_type_state_p = allocate_function_state (def->sdef_arity); + rootstate = DetermineStatesOfRuleType (def->sdef_rule_type->rule_type_rule,def->sdef_rule_type->rule_type_state_p); + } else + return; + break; + case IMPRULE: + if (def->sdef_module==CurrentModule) + def->sdef_number = next_def_number++; + + def->sdef_rule->rule_state_p = allocate_function_state (def->sdef_arity); + rootstate = DetermineStatesOfRuleType (def->sdef_rule->rule_type,def->sdef_rule->rule_state_p); + + if (def->sdef_exported && def->sdef_dcl_icl!=NULL && def->sdef_dcl_icl->sdef_kind!=INSTANCE){ + def->sdef_dcl_icl->sdef_rule_type->rule_type_state_p = allocate_function_state (def->sdef_arity); + rootstate = DetermineStatesOfRuleType (def->sdef_dcl_icl->sdef_rule_type->rule_type_rule,def->sdef_dcl_icl->sdef_rule_type->rule_type_state_p); + } +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + DetermineLhsStatesOfRule (def->sdef_rule); +#endif + break; + case RECORDTYPE: + { + FieldList fields; + + if (def->sdef_module==CurrentModule) + def->sdef_number = next_def_number++; + for_l (fields,def->sdef_type->type_fields,fl_next) + ExamineTypesAndLhsOfSymbolDefinition (fields->fl_symbol->symb_def); + + rootstate = def->sdef_record_state; + break; + } + case FIELDSELECTOR: + rootstate = def->sdef_sel_field->fl_state; + + if (def->sdef_module==CurrentModule) + def->sdef_number = next_def_number++; + if (def->sdef_exported && def->sdef_dcl_icl!=NULL && def->sdef_dcl_icl->sdef_sel_field) + rootstate = def->sdef_dcl_icl->sdef_sel_field->fl_state; + break; + case TYPE: + if (def->sdef_module==CurrentModule) + def->sdef_number = next_def_number++; + rootstate = LazyState; + break; + case CONSTRUCTOR: + if (def->sdef_module==CurrentModule) + def->sdef_number = next_def_number++; + rootstate = OnAState; + break; + default: + rootstate = OnAState; + break; + } + + if (IsSimpleState (rootstate)){ + if (rootstate.state_kind == OnA || rootstate.state_kind == StrictOnA){ + def->sdef_calledwithrootnode = True; + def->sdef_returnsnode = True; + } else if (rootstate.state_kind == StrictRedirection){ + def->sdef_calledwithrootnode = False; + def->sdef_returnsnode = True; + } else { + def->sdef_calledwithrootnode = False; + def->sdef_returnsnode = False; + } + } else { + def->sdef_calledwithrootnode = False; + def->sdef_returnsnode = False; + } +} + +void ExamineTypesAndLhsOfSymbols (Symbol symbs) +{ + next_def_number = 1; + + while (symbs!=NULL){ + if (symbs->symb_kind==definition) + ExamineTypesAndLhsOfSymbolDefinition (symbs->symb_def); + + symbs=symbs->symb_next; + } +} + +extern PolyList UserDefinedArrayFunctions; + +void ImportSymbols (Symbol symbols) +{ + Symbol symbol; + PolyList array_fun; + + for_l (array_fun,UserDefinedArrayFunctions,pl_next){ + SymbDef fun_def; + + fun_def = ((Symbol) array_fun->pl_elem)->symb_def; + + if (fun_def ->sdef_mark & (SDEF_USED_LAZILY_MASK | SDEF_USED_CURRIED_MASK)) + fun_def -> sdef_module = CurrentModule; + } + + for_l (symbol,symbols,symb_next){ + SymbDef sdef; + + if (symbol->symb_kind==definition) + sdef=symbol->symb_def; + else + continue; + + if (sdef->sdef_module!=CurrentModule){ + if (sdef->sdef_isused && sdef->sdef_over_arity==0) + GenImport (sdef); + + if (sdef->sdef_kind==RECORDTYPE){ + FieldList fields; + + for_l (fields,sdef->sdef_type->type_fields,fl_next){ + SymbDef field_sdef; + + field_sdef=fields->fl_symbol->symb_def; + + if (field_sdef->sdef_isused && field_sdef->sdef_over_arity==0) + GenImport (field_sdef); + } + } + } + } +} + +static Bool ShouldDecrRefCount; + +#if OPTIMIZE_LAZY_TUPLE_RECURSION +# define IF_OPTIMIZE_LAZY_TUPLE_RECURSION(a) ,a +#else +# define IF_OPTIMIZE_LAZY_TUPLE_RECURSION(a) +#endif + +#if OPTIMIZE_LAZY_TUPLE_RECURSION +static int roots_are_tuples_or_calls_to_this_function (NodeP node_p,NodeDefP node_defs,SymbDef function_sdef_p) +{ + switch (node_p->node_kind){ + case SwitchNode: + { + ArgP arg_p; + + for_l (arg_p,node_p->node_arguments,arg_next) + if (!roots_are_tuples_or_calls_to_this_function (arg_p->arg_node->node_arguments->arg_node,arg_p->arg_node->node_node_defs,function_sdef_p)) + return 0; + + return 1; + } + case PushNode: + return roots_are_tuples_or_calls_to_this_function (node_p->node_arguments->arg_next->arg_node,node_defs,function_sdef_p); + case GuardNode: + { + while (node_p->node_kind==GuardNode){ + if (!roots_are_tuples_or_calls_to_this_function (node_p->node_arguments->arg_node,node_defs,function_sdef_p)) + return 0; + + node_defs=node_p->node_node_defs; + node_p=node_p->node_arguments->arg_next->arg_node; + } + + return roots_are_tuples_or_calls_to_this_function (node_p,node_defs,function_sdef_p); + } + case IfNode: + { + ArgP then_arg_p; + NodeP else_node_p; + + then_arg_p=node_p->node_arguments->arg_next; + + if (!roots_are_tuples_or_calls_to_this_function (then_arg_p->arg_node,node_p->node_then_node_defs,function_sdef_p)) + return 0; + + else_node_p=then_arg_p->arg_next->arg_node; + + if (else_node_p->node_kind==NormalNode && else_node_p->node_symbol->symb_kind==fail_symb) + return 1; + + return roots_are_tuples_or_calls_to_this_function (else_node_p,node_p->node_else_node_defs,function_sdef_p); + } + default: + { + if (node_p->node_kind==NormalNode){ + SymbolP node_symbol_p; + + node_symbol_p=node_p->node_symbol; + if (node_symbol_p->symb_kind==tuple_symb) + return 1; + else if (node_symbol_p->symb_kind==definition && node_symbol_p->symb_def==function_sdef_p + && node_p->node_arity==node_symbol_p->symb_def->sdef_arity) + return 1; + } + } + } + + return 0; +} +#endif + +static void DecrRefCountCopiesOfArgs (Args args IF_OPTIMIZE_LAZY_TUPLE_RECURSION(int local_scope)); + +static void DecrRefCountCopiesOfArg (Args arg IF_OPTIMIZE_LAZY_TUPLE_RECURSION(int local_scope)) +{ + Node node; + + node=arg->arg_node; + + if (node->node_kind!=NodeIdNode){ +#if OPTIMIZE_LAZY_TUPLE_RECURSION + if (OptimizeLazyTupleRecursion && node->node_kind==NormalNode && node->node_symbol->symb_kind==select_symb && node->node_arguments->arg_node->node_kind==NodeIdNode + && node->node_arguments->arg_node->node_node_id->nid_scope==local_scope + ){ + NodeId node_id; + + node_id=node->node_arguments->arg_node->node_node_id; + + if (node_id->nid_mark2 & NID_HAS_LAZY_SELECTOR_COUNTER){ + ++node_id->nid_lazy_selector_ref_count; + + if (node_id->nid_lazy_selector_ref_count==node_id->nid_refcount){ + NodeP node_id_def_node; + + node_id_def_node=node_id->nid_node_def->def_node; + if (node_id_def_node->node_kind==NormalNode && node_id_def_node->node_symbol->symb_kind==definition + && node_id_def_node->node_symbol->symb_def->sdef_kind==IMPRULE && IsLazyState (node_id_def_node->node_state) + && node_id_def_node->node_symbol==CurrentSymbol + ){ + SymbDef function_sdef_p; + RuleAltP rule_alt_p; + + function_sdef_p=node_id_def_node->node_symbol->symb_def; + rule_alt_p=function_sdef_p->sdef_rule->rule_alts; + + if (roots_are_tuples_or_calls_to_this_function (rule_alt_p->alt_rhs_root,rule_alt_p->alt_rhs_defs,function_sdef_p)){ + node_id->nid_node_def->def_id->nid_mark2 |= NID_CALL_VIA_LAZY_SELECTIONS_ONLY; + node_id_def_node->node_symbol->symb_def->sdef_rule->rule_mark |= RULE_CALL_VIA_LAZY_SELECTIONS_ONLY; + if (ListOptimizations) + printf ("Optimize lazy tuple recursion of %s\n",node_id_def_node->node_symbol->symb_def->sdef_ident->ident_name); + } + } + } + } else { + node_id->nid_mark2 |= NID_HAS_LAZY_SELECTOR_COUNTER; + node_id->nid_lazy_selector_ref_count=1; + } + + if (node_id->nid_ref_count_copy>0 && node_id->nid_node_def) + --node_id->nid_ref_count_copy__; + } else +#endif + DecrRefCountCopiesOfArgs (node->node_arguments IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + } else { + NodeId node_id; + + node_id=node->node_node_id; + if (node_id->nid_ref_count_copy>0 && node_id->nid_node_def) + --node_id->nid_ref_count_copy__; + } +} + +static void DecrRefCountCopiesOfArgs (Args args IF_OPTIMIZE_LAZY_TUPLE_RECURSION(int local_scope)) +{ + for (; args; args = args->arg_next) + DecrRefCountCopiesOfArg (args IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); +} + +static StateS *RemoveUndefinedsFromTupleState (StateS *state_p,int arity) +{ + int n; + StateS *element_state_p,*new_element_states; + + element_state_p=state_p; + + new_element_states=NULL; + + for (n=0; n<arity; ++n, ++element_state_p){ + if (IsSimpleState (*element_state_p)){ + if (element_state_p->state_kind==Undefined){ + if (new_element_states==NULL){ + StateS *new_element_state_p,*old_element_state_p; + int i; + + new_element_states=NewArrayOfStates (arity); + element_state_p=&new_element_states[n]; + + new_element_state_p=new_element_states; + old_element_state_p=state_p; + for (i=0; i<arity; ++i) + *new_element_state_p++ = *old_element_state_p++; + } + element_state_p->state_kind=OnA; + } + } else if (element_state_p->state_type==TupleState){ + StateS *new_element_states_2; + + new_element_states_2=RemoveUndefinedsFromTupleState + (element_state_p->state_tuple_arguments,element_state_p->state_arity); + if (new_element_states_2){ + if (new_element_states==NULL){ + StateS *new_element_state_p,*old_element_state_p; + int i; + + new_element_states=NewArrayOfStates (arity); + element_state_p=&new_element_states[n]; + + new_element_state_p=new_element_states; + old_element_state_p=state_p; + for (i=0; i<arity; ++i) + *new_element_state_p++ = *old_element_state_p++; + } + element_state_p->state_tuple_arguments=new_element_states_2; + } + } + } + + return new_element_states; +} + +static Bool ChangeState (StateS *old_state_p,StateS newstate) +{ + switch (old_state_p->state_kind){ + case OnA: + case StrictOnA: + *old_state_p = newstate; + return True; + case Undefined: + *old_state_p = newstate; + return False; + default: + return False; + } +} + +static Bool AdjustState (StateS *old_state_p, StateS newstate) +{ + if (IsSimpleState (newstate)){ + if (IsSimpleState (*old_state_p)){ + switch (newstate.state_kind){ + case StrictOnA: + case OnB: + return ChangeState (old_state_p, newstate); + default: + return False; + } + } else + return False; + } else if (IsSimpleState (*old_state_p)){ + if (newstate.state_type==TupleState && + (old_state_p->state_kind==OnA || old_state_p->state_kind==StrictOnA || old_state_p->state_kind==Undefined)) + { + StateS *element_states; + + element_states=RemoveUndefinedsFromTupleState (newstate.state_tuple_arguments,newstate.state_arity); + + *old_state_p=newstate; + + if (element_states){ +/* CheckWarning ("undefined state in tuple state removed",NULL); */ + old_state_p->state_tuple_arguments=element_states; + } + + return old_state_p->state_kind!=Undefined; + } + + return ChangeState (old_state_p,newstate); + } else if (newstate.state_type==TupleState){ + int i, arity; + StateS argstate; + Bool new_arg_states; + + arity = old_state_p->state_arity; + new_arg_states = False; + + Assume (newstate.state_arity == arity, "statesgen", "AdjustState"); + + for (i=0; i<arity; i++){ + argstate = old_state_p->state_tuple_arguments[i]; + if (AdjustState (& argstate, newstate.state_tuple_arguments[i]) && ! new_arg_states){ + int j; + States argstates; + + new_arg_states = True; + argstates = NewArrayOfStates (arity); + for (j=0; j<arity; j++) + argstates[j] = old_state_p->state_tuple_arguments[j]; + old_state_p->state_tuple_arguments = argstates; + } + old_state_p->state_tuple_arguments[i] = argstate; + } + return new_arg_states; + } else + return False; +} + +static void DetermineStateOfThenOrElse (Args t_or_e_args, NodeDefs *t_or_e_defs, StateS demstate,int local_scope) +{ + Node node; + + node=t_or_e_args->arg_node; + + if (node->node_kind==NodeIdNode && *t_or_e_defs==NULL){ + NodeId node_id; + + node_id=node->node_node_id; + if (node_id->nid_ref_count_copy>=0) + --node_id->nid_ref_count_copy__; + } else + DetermineStatesOfRootNodeAndDefs (node,t_or_e_defs,demstate, local_scope); + + AdjustState (&t_or_e_args->arg_state,demstate); +} + +static void DecrementRefCountCopy (NodeId nid) +{ + if (nid->nid_ref_count_copy>0) + --nid->nid_ref_count_copy__; +} + +#if 0 +# include "dbprint.h" +#endif + +static Bool AdjustStateOfSharedNode (NodeId nid, StateS demstate, int local_scope) +{ + /* + Note that if the reference count of a node identifier smaller than one means that the corresponding node + has already been treated. In that case it would be dangerous to adjust the node state + */ + + if (nid->nid_ref_count_copy>=0){ + NodeDefs nodedef; + + nodedef = nid->nid_node_def; + + if (nodedef!=NULL){ + int node_id_scope; + + if (ShouldDecrRefCount) + DecrementRefCountCopy (nid); + + node_id_scope=nid->nid_scope; + if (node_id_scope<0) + node_id_scope=-node_id_scope; + +#if 0 + printf ("AdjustStateOfSharedNode "); + DPrintNodeId (nid,StdOut); + printf (" %d %d\n",node_id_scope,local_scope); +#endif + + if (node_id_scope>=local_scope){ + Node argnode; + + argnode = nodedef->def_node; + if (nid->nid_mark & ON_A_CYCLE_MASK) + AdjustState (&argnode->node_state, StrictState); + else + AdjustState (&argnode->node_state, demstate); + } + + if (nodedef->def_node) + return (nodedef->def_node->node_state.state_mark & STATE_PARALLEL_MASK)!=0; + } +#if 0 + else { + printf ("AdjustStateOfSharedNode nid_node_def=NULL "); + DPrintNodeId (nid,StdOut); + printf (" %d %d\n",nid->nid_scope,local_scope); + } +#endif + } + + return False; +} + +static Bool ArgInAStrictContext (Args arg, StateS demstate, Bool semistrict, int local_scope); + +static Bool DetermineStrictArgContext (Args arg, StateS demstate, int local_scope) +{ + AdjustState (&arg->arg_state, demstate); + + return ArgInAStrictContext (arg, arg->arg_state, False, local_scope); +} + +static StateP GetStateOfArguments (SymbDef sdef,int actual_arity) +{ + int symbol_arity; + StateP state_p; + + switch (sdef->sdef_kind){ + case DEFRULE: + case SYSRULE: + state_p=sdef->sdef_rule_type->rule_type_state_p; + symbol_arity = sdef->sdef_arity; + break; + case IMPRULE: + state_p=sdef->sdef_rule->rule_state_p; + symbol_arity = sdef->sdef_arity; + break; + case RECORDTYPE: + state_p=sdef->sdef_record_state.state_record_arguments; + symbol_arity = sdef->sdef_cons_arity; + break; + default: + return NULL; + } + + if (symbol_arity==actual_arity) + return state_p; + else + return NULL; +} + +static Bool ArgsInAStrictContext (StateP arg_state_p,Args argn, int local_scope) +{ + Bool parallel; + + parallel = False; + + for (; argn!=NULL; argn=argn->arg_next){ + if (! IsLazyState (*arg_state_p)){ + if (DetermineStrictArgContext (argn,*arg_state_p,local_scope)) + parallel = True; + } else if (ShouldDecrRefCount) + DecrRefCountCopiesOfArg (argn IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + + ++arg_state_p; + } + + return parallel; +} + +#if DESTRUCTIVE_RECORD_UPDATES + static Bool UpdateNodeInAStrictOrSemiStrictContext (Node node,StateP demanded_state_p,int local_scope,Bool semi_strict) +#else + static Bool UpdateNodeInAStrictOrSemiStrictContext (Node node,int local_scope,Bool semi_strict) +#endif +{ + Bool parallel; + SymbDef record_sdef; + int type_arg_number; + ArgS *arg; + StateP record_arg_states; + + parallel=False; + + record_sdef=node->node_symbol->symb_def; + + if (!semi_strict){ +#if DESTRUCTIVE_RECORD_UPDATES + if (demanded_state_p->state_type==SimpleState && + demanded_state_p->state_kind==StrictOnA && + demanded_state_p->state_object==RecordObj) + { + node->node_state = *demanded_state_p; + } else +#endif + node->node_state = record_sdef->sdef_record_state; + } + + arg=node->node_arguments; + + if (semi_strict + ? ArgInAStrictContext (arg,StrictState,True,local_scope) + : DetermineStrictArgContext (arg, record_sdef->sdef_record_state,local_scope)) + parallel = True; + + type_arg_number=0; + + record_arg_states=record_sdef->sdef_record_state.state_record_arguments; + + while ((arg=arg->arg_next)!=NULL){ + int selector_number; + Node selector_node; + + selector_node=arg->arg_node; + selector_number=selector_node->node_symbol->symb_def->sdef_sel_field_number; + + while (type_arg_number!=selector_number){ + ++type_arg_number; + } + + if (!IsLazyState (record_arg_states[type_arg_number])){ + if (semi_strict + ? ArgInAStrictContext (selector_node->node_arguments,StrictState,True,local_scope) + : DetermineStrictArgContext (selector_node->node_arguments,record_arg_states[type_arg_number],local_scope)) + parallel = True; + } else if (ShouldDecrRefCount) + DecrRefCountCopiesOfArg (selector_node->node_arguments IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + } + + if (parallel) + node->node_state.state_mark |= STATE_PARALLEL_MASK; + + return parallel; +} + +int optimise_strict_tuple_result_functions; + +static Bool NodeInAStrictContext (Node node,StateS demanded_state,int local_scope) +{ + Bool parallel; + + parallel=False; + + if (node->node_kind==NormalNode){ + Symbol rootsymb; + + rootsymb = node->node_symbol; + switch (rootsymb->symb_kind){ + case cons_symb: + if (ShouldDecrRefCount) + DecrRefCountCopiesOfArgs (node->node_arguments IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + case nil_symb: + SetUnaryState (&node->node_state, StrictOnA, ListObj); + break; + case apply_symb: + node->node_state = StrictState; + node->node_state.state_kind = StrictRedirection; + parallel = DetermineStrictArgContext (node->node_arguments, StrictState, local_scope); + if (ShouldDecrRefCount) + DecrRefCountCopiesOfArg (node->node_arguments->arg_next IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + break; + case if_symb: + { + Args args; + + args = node->node_arguments; + node->node_state = StrictState; + + if (node->node_arity==3){ + if (DetermineStrictArgContext (args, BasicSymbolStates[bool_type], local_scope)) + parallel = True; + + args = args->arg_next; +#ifdef FASTER_STRICT_IF + node->node_state=demanded_state; + + if (DetermineStrictArgContext (args,demanded_state,20000/*local_scope+1*/)) + parallel = True; + + args=args->arg_next; + + if (DetermineStrictArgContext (args,demanded_state,20000/*local_scope+1*/)) + parallel = True; + + break; +#else + node->node_state.state_kind = StrictRedirection; +#endif + } + if (ShouldDecrRefCount) + for (; args; args = args->arg_next) + DecrRefCountCopiesOfArg (args IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + break; + } + case select_symb: + { + Args arg; + Node argnode; + + arg=node->node_arguments; + + SetUpdateableTupleState (&arg->arg_state, NewArrayOfUnaryStates (rootsymb->symb_arity, Undefined), rootsymb->symb_arity); + + arg->arg_state.state_tuple_arguments [node->node_arity - 1] = demanded_state; + + argnode=arg->arg_node; + if (argnode->node_kind!=NodeIdNode) + parallel = NodeInAStrictContext (argnode, arg->arg_state, local_scope); + else { + NodeId node_id; + + node_id=argnode->node_node_id; + + if (node_id->nid_ref_count_copy>=0 && node_id->nid_node_def){ + int node_id_scope; + + argnode = node_id->nid_node_def->def_node; + + if (ShouldDecrRefCount) + DecrementRefCountCopy (node_id); + + node_id_scope=node_id->nid_scope; + if (node_id_scope<0) + node_id_scope=-node_id_scope; + +#if 0 + printf ("NodeInAStrictContext select_symb "); + DPrintNodeId (node_id,StdOut); + printf (" %d %d\n",node_id_scope,local_scope); +#endif + if (node_id_scope>=local_scope){ + if (IsSimpleState (argnode->node_state)){ + if (argnode->node_state.state_kind!=Parallel){ + SetUpdateableTupleState (&argnode->node_state, NewArrayOfUnaryStates (rootsymb->symb_arity, OnA), rootsymb->symb_arity); + AdjustState (&argnode->node_state.state_tuple_arguments[node->node_arity-1],demanded_state); + } + } else { + if ((argnode->node_state.state_mark & STATE_ELEMENTS_UPDATEABLE_MASK)==0){ + int i,arity; + States arg_states; + + arity = argnode->node_state.state_arity; + arg_states = NewArrayOfStates (arity); + + for (i=0; i<arity; ++i) + arg_states[i] = argnode->node_state.state_tuple_arguments[i]; + + argnode->node_state.state_tuple_arguments = arg_states; + argnode->node_state.state_mark |= STATE_ELEMENTS_UPDATEABLE_MASK; + } + + AdjustState (&argnode->node_state.state_tuple_arguments[node->node_arity-1],demanded_state); + } + } + } + } + node->node_state = demanded_state; + break; + } + case tuple_symb: + if (IsSimpleState (demanded_state)){ + SetUnaryState (&node->node_state, StrictOnA, TupleObj); + if (ShouldDecrRefCount) + DecrRefCountCopiesOfArgs (node->node_arguments IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + } else { + Args arg; int i; + + for (i=0, arg=node->node_arguments; arg!=NULL; arg=arg->arg_next, i++){ + Bool par; + + par = False; + if (!IsLazyState (demanded_state.state_tuple_arguments[i])){ + if (DetermineStrictArgContext (arg,demanded_state.state_tuple_arguments[i],local_scope)) + par = True; + } else if (ShouldDecrRefCount) + DecrRefCountCopiesOfArg (arg IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + + arg->arg_state = demanded_state.state_tuple_arguments[i]; + + if (par){ + arg->arg_state.state_mark |= STATE_PARALLEL_MASK; + parallel = True; + } + } + node->node_state = demanded_state; + } + break; + case definition: + { + StateP definition_state_p; + SymbDef sdef; + + sdef = rootsymb->symb_def; + + if (sdef->sdef_arfun!=NoArrayFun + && ( (sdef->sdef_arfun==_UnqArraySelectLastFun || sdef->sdef_arfun==_UnqArraySelectNextFun) && node->node_arity==2) + || (sdef->sdef_arfun==_ArrayUpdateFun && node->node_arity==3)) + { + StateP function_state_p; + + function_state_p=sdef->sdef_rule_type->rule_type_state_p; + + if (!(function_state_p[0].state_type==SimpleState && function_state_p[0].state_object==UnknownObj)){ + StateP arg_node_state_p; + NodeP arg_node_p; + ArgP arg_p; + + arg_p=node->node_arguments; + + if (sdef->sdef_arfun!=_ArrayUpdateFun){ + parallel = ArgsInAStrictContext (function_state_p,arg_p,local_scope); + node->node_state = function_state_p[-1]; + + arg_node_p=arg_p->arg_node; + if (arg_node_p->node_kind!=NodeIdNode){ + arg_node_state_p=&arg_node_p->node_state; + + if (arg_node_state_p->state_type==TupleState && arg_node_state_p->state_tuple_arguments[1].state_type!=SimpleState){ + StateP tuple_state_args_p,tuple_result_state_args_p,result_state_p; + + result_state_p=&arg_node_state_p->state_tuple_arguments[1]; + + tuple_state_args_p=CompAllocArray (2,StateS); + tuple_state_args_p[0]=arg_p->arg_state.state_tuple_arguments[0]; + tuple_state_args_p[1]=*result_state_p; + arg_p->arg_state.state_tuple_arguments=tuple_state_args_p; + + tuple_result_state_args_p=CompAllocArray (2,StateS); + tuple_result_state_args_p[0]=node->node_state.state_tuple_arguments[0]; + tuple_result_state_args_p[1]=*result_state_p; + node->node_state.state_tuple_arguments=tuple_result_state_args_p; + } + } + } else { + NodeP arg_node_p; + + if (demanded_state.state_type!=SimpleState){ + StateS arg_states[3],*update_arg_tuple_arg_states; + + arg_states[0]=function_state_p[0]; + arg_states[1]=function_state_p[1]; + arg_states[2]=function_state_p[2]; + + update_arg_tuple_arg_states=NewArrayOfStates (2); + update_arg_tuple_arg_states[0]=arg_states[0].state_tuple_arguments[0]; + update_arg_tuple_arg_states[1]=demanded_state; + + arg_states[0].state_tuple_arguments=update_arg_tuple_arg_states; + + parallel = ArgsInAStrictContext (arg_states,arg_p,local_scope); + node->node_state = demanded_state; + } else { + parallel = ArgsInAStrictContext (function_state_p,arg_p,local_scope); + node->node_state = function_state_p[-1]; + + arg_node_p=arg_p->arg_node; + if (arg_node_p->node_kind!=NodeIdNode){ + arg_node_state_p=&arg_node_p->node_state; + + if (arg_node_state_p->state_type==TupleState && arg_node_state_p->state_tuple_arguments[1].state_type!=SimpleState){ + StateP tuple_state_args_p,result_state_p; + + result_state_p=&arg_node_state_p->state_tuple_arguments[1]; + + tuple_state_args_p=CompAllocArray (2,StateS); + tuple_state_args_p[0]=arg_p->arg_state.state_tuple_arguments[0]; + tuple_state_args_p[1]=*result_state_p; + arg_p->arg_state.state_tuple_arguments=tuple_state_args_p; + + node->node_state=*result_state_p; + } + } + } + } + break; + } + } + + definition_state_p = GetStateOfArguments (sdef,node->node_arity); + + if (definition_state_p!=NULL){ +#ifdef FASTER_STRICT_AND_OR + if (sdef->sdef_module==DeltaBId->ident_name && node->node_arity==2){ + if (sdef->sdef_ident==AndId){ + ArgP arg1,arg2,false_arg; + NodeP false_node; + + arg1=node->node_arguments; + arg2=arg1->arg_next; + + /* if arg2 is a node_id, incorrect code if and on root (redirection with jmpevalupd) */ + + if (arg2->arg_node->node_kind!=NodeIdNode){ + node->node_symbol=IfSymbol; + node->node_arity=3; + + false_node=NewNode (FalseSymbol,NULL,0); + false_node->node_state=LazyState; + + false_arg=NewArgument (false_node); + false_arg->arg_state=LazyState; + + arg2->arg_next=false_arg; + + return NodeInAStrictContext (node,demanded_state,local_scope); + } + } else if (sdef->sdef_ident==OrId){ + ArgP arg1,arg2,true_arg; + NodeP true_node; + + arg1=node->node_arguments; + arg2=arg1->arg_next; + + /* if arg2 is a node_id, incorrect code if or on root (redirection with jmpevalupd) */ + + if (arg2->arg_node->node_kind!=NodeIdNode){ + node->node_symbol=IfSymbol; + node->node_arity=3; + + true_node=NewNode (TrueSymbol,NULL,0); + true_node->node_state=LazyState; + + true_arg=NewArgument (true_node); + true_arg->arg_state=LazyState; + + arg1->arg_next=true_arg; + true_arg->arg_next=arg2; + + return NodeInAStrictContext (node,demanded_state,local_scope); + } + } + } +#endif + + if (sdef->sdef_kind==IMPRULE && demanded_state.state_type==TupleState && definition_state_p[-1].state_type==TupleState + && !(sdef->sdef_rule->rule_mark & RULE_CAF_MASK) && sdef->sdef_rule->rule_alts->alt_kind==Contractum && optimise_strict_tuple_result_functions) + optimise_tuple_result_function (node,demanded_state); + + if (sdef->sdef_kind==RECORDTYPE) + node->node_state = sdef->sdef_record_state; + else + node->node_state = definition_state_p[-1]; + parallel = ArgsInAStrictContext (definition_state_p,node->node_arguments,local_scope); + } else { + if (sdef->sdef_kind==CONSTRUCTOR && sdef->sdef_strict_constructor && sdef->sdef_arity==node->node_arity){ + SetUnaryState (&node->node_state,StrictOnA,UnknownObj); + parallel = ArgsInAStrictContext (sdef->sdef_constructor->cl_state_p,node->node_arguments,local_scope); + } else { + if (ShouldDecrRefCount) + DecrRefCountCopiesOfArgs (node->node_arguments IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + node->node_state = StrictState; + } + } + break; + } + default: + if (rootsymb->symb_kind < Nr_Of_Predef_Types){ + node->node_state = BasicSymbolStates [rootsymb->symb_kind]; + node->node_state.state_kind = demanded_state.state_kind; + } + break; + } + } else if (node->node_kind==SelectorNode){ + SymbDef ssymb; + + ssymb = node->node_symbol->symb_def; + + if (node->node_arity>=SELECTOR_U){ + StateP record_state_p,tuple_arg_states; + + record_state_p=&ssymb->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state; + tuple_arg_states=NewArrayOfStates (2); + + if (node->node_arity>=SELECTOR_L){ + StateS sel_arg_state,*sel_arg_tuple_arg_states; + NodeP arg_node_p; + + sel_arg_tuple_arg_states=NewArrayOfStates (2); + sel_arg_tuple_arg_states[0]=*record_state_p; + + if (demanded_state.state_type==TupleState && !IsLazyState (demanded_state.state_tuple_arguments[1])){ + sel_arg_tuple_arg_states[1]=demanded_state.state_tuple_arguments[1]; + tuple_arg_states[1]=demanded_state.state_tuple_arguments[1]; + } else { + sel_arg_tuple_arg_states[1]=StrictState; + tuple_arg_states[1]=StrictState; + } + SetTupleState (&sel_arg_state,sel_arg_tuple_arg_states,2); + + parallel = DetermineStrictArgContext (node->node_arguments,sel_arg_state,local_scope); + + arg_node_p=node->node_arguments->arg_node; + if (arg_node_p->node_kind!=NodeIdNode && arg_node_p->node_state.state_type==TupleState + && arg_node_p->node_state.state_tuple_arguments[1].state_type!=SimpleState) + { + StateP result_state_p; + + result_state_p=&arg_node_p->node_state.state_tuple_arguments[1]; + + tuple_arg_states[1]=*result_state_p; + sel_arg_tuple_arg_states[1]=*result_state_p; + } + } else { + parallel = DetermineStrictArgContext (node->node_arguments,*record_state_p,local_scope); + tuple_arg_states[1]=*record_state_p; + } + + tuple_arg_states[0]=record_state_p->state_record_arguments[ssymb->sdef_sel_field_number]; + SetTupleState (&node->node_state,tuple_arg_states,2); + } else { + parallel = DetermineStrictArgContext (node->node_arguments, + ssymb->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state,local_scope); + node->node_state=demanded_state; + } + } else if (node->node_kind==UpdateNode) +#if DESTRUCTIVE_RECORD_UPDATES + return UpdateNodeInAStrictOrSemiStrictContext (node,&demanded_state,local_scope,False); +#else + return UpdateNodeInAStrictOrSemiStrictContext (node,local_scope,False); +#endif + else if (node->node_kind==MatchNode){ + parallel = DetermineStrictArgContext (node->node_arguments,StrictState,local_scope); + + node->node_state=demanded_state; + } else + error_in_function ("NodeInAStrictContext"); + + if (parallel) + node->node_state.state_mark |= STATE_PARALLEL_MASK; + + return parallel; +} + +static Bool NodeInASemiStrictContext (Node node, int local_scope); + +static Bool ArgInAStrictContext (Args arg, StateS demstate, Bool semistrict, int local_scope) +{ + Bool parallel; + Node argnode; + + parallel = False; + + argnode=arg->arg_node; + + if (argnode->node_kind!=NodeIdNode){ + if (semistrict && argnode->node_number<0){ + parallel = NodeInASemiStrictContext (argnode,local_scope); + argnode->node_state.state_kind = SemiStrict; + } else + parallel = NodeInAStrictContext (argnode, demstate, local_scope); + } else + parallel = AdjustStateOfSharedNode (argnode->node_node_id, demstate, local_scope); + + if (parallel) + arg->arg_state.state_mark |= STATE_PARALLEL_MASK; + + return parallel; +} + +static Bool NodeInASemiStrictContext (Node node,int local_scope) +{ + switch (node->node_kind){ + case NormalNode: + { + Bool parallel; + Symbol symb; + + symb = node->node_symbol; + + parallel = False; + + if (symb->symb_kind==definition){ + SymbDef sdef; + ArgP arg_p; + StateP arg_state_p; + + sdef=symb->symb_def; + arg_state_p = GetStateOfArguments (sdef,node->node_arity); + + if (arg_state_p==NULL && sdef->sdef_kind==CONSTRUCTOR && + sdef->sdef_strict_constructor && sdef->sdef_arity==node->node_arity) + { + arg_state_p=sdef->sdef_constructor->cl_state_p; + } + + if (arg_state_p!=NULL){ + for_l (arg_p,node->node_arguments,arg_next){ + if (IsLazyState (*arg_state_p)){ + if (ShouldDecrRefCount) + DecrRefCountCopiesOfArg (arg_p IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + } else + if (ArgInAStrictContext (arg_p,StrictState,True,local_scope)) + parallel = True; + + ++arg_state_p; + } + } else + DecrRefCountCopiesOfArgs (node->node_arguments IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + } else + DecrRefCountCopiesOfArgs (node->node_arguments IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + + if (parallel) + node->node_state.state_mark |= STATE_PARALLEL_MASK; + + return parallel; + } + case SelectorNode: + case MatchNode: + if (ArgInAStrictContext (node->node_arguments,StrictState,True,local_scope)){ + node->node_state.state_mark |= STATE_PARALLEL_MASK; + return True; + } else + return False; + case UpdateNode: +#if DESTRUCTIVE_RECORD_UPDATES + return UpdateNodeInAStrictOrSemiStrictContext (node,&StrictState,local_scope,True); +#else + return UpdateNodeInAStrictOrSemiStrictContext (node,local_scope,True); +#endif + default: + error_in_function ("NodeInASemiStrictContext"); + return False; + } +} + +static void DetermineStatesOfNonIfRootNode (Node root,NodeId root_id,StateS demstate,int local_scope) +{ + if (root->node_state.state_kind != OnA){ + StaticMessage (False, "%S", Wrootannot, CurrentSymbol); + root->node_state.state_kind = OnA; + } + + if (root_id) + root_id->nid_ref_count_copy_=-1; /* to indicate that this node has been examined */ + + if (root_id && (root_id->nid_mark & ON_A_CYCLE_MASK)){ + (void) NodeInASemiStrictContext (root, local_scope); + root->node_state.state_kind = SemiStrict; + } else + NodeInAStrictContext (root, demstate, local_scope); +} + +static int scope; + +static void DetermineStatesOfGuardRootNode (Node node, NodeId nid, StateS demstate,int local_scope) +{ + if (node->node_kind!=IfNode) + DetermineStatesOfNonIfRootNode (node, nid, demstate, local_scope); + else { + Args condpart; + int new_local_scope; + + new_local_scope=scope+2; + scope+=3; + + condpart = node->node_arguments; + + AdjustState (&condpart->arg_state, BasicSymbolStates [bool_type]); + + if (condpart->arg_node->node_kind!=NodeIdNode) + DetermineStatesOfGuardRootNode (condpart->arg_node, NULL,condpart->arg_state, local_scope); + else + /* the parallel state of the condition is not needed */ + AdjustStateOfSharedNode (condpart->arg_node->node_node_id,condpart->arg_state,local_scope); + + AdjustState (&node->node_state, demstate); + + ++scope; + DetermineStateOfThenOrElse (condpart->arg_next,&node->node_then_node_defs,demstate,new_local_scope); + + ++scope; + DetermineStateOfThenOrElse (condpart->arg_next->arg_next,&node->node_else_node_defs,demstate,new_local_scope); + } +} + +static void ParAnnotInAStrictContext (Node node,Annotation annot, int local_scope) +{ + if (annot==ParallelAtAnnot){ + Node at_node; + + at_node=get_p_at_node (node); + + if (at_node->node_kind!=NodeIdNode) + NodeInAStrictContext (at_node,BasicSymbolStates[procid_type],local_scope); + } +} + +static void DetermineStatesOfNodeDefs (NodeDefs firstdef, int local_scope) +{ + NodeDefs next; + Bool ready; + + for_l (next,firstdef,def_next) + if ((next->def_id->nid_mark & ON_A_CYCLE_MASK) && next->def_node!=NULL) + DecrRefCountCopiesOfArgs (next->def_node->node_arguments IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + + /* examine all parallel annotated nodes */ + + for_l (next,firstdef,def_next){ + Node node; + + node=next->def_node; + if (node && node->node_annotation && node->node_state.state_kind==Parallel) + ParAnnotInAStrictContext (node,node->node_annotation, local_scope); + } + + /* determine states */ + + do { + ready = True; + + /* First we examine all the nodes that are not lazy anymore */ + + for_l (next,firstdef,def_next){ + Node node; + + node = next->def_node; + if (node && ! IsLazyState (node->node_state) && + (next->def_id->nid_ref_count_copy==0 || + (next->def_id->nid_ref_count_copy>=0 && (next->def_id->nid_mark & ON_A_CYCLE_MASK)))) + { + + /* to indicate that this node has already been examined: */ + next->def_id->nid_ref_count_copy_ = -1; + + ready = False; + + /* + JVG: hack to remove undefined's in tuple state of tuples which are selected + and for which there are selectors and may be other references in a lazy context + (can lead to less efficient code) + */ + + if (next->def_id->nid_refcount>1 && node->node_kind==NormalNode + && node->node_symbol->symb_kind==select_symb + && node->node_state.state_type==TupleState) + { + StateS *element_states; + + element_states=RemoveUndefinedsFromTupleState + (node->node_state.state_tuple_arguments,node->node_state.state_arity); + if (element_states) + node->node_state.state_tuple_arguments=element_states; + } + + if (next->def_id->nid_mark & ON_A_CYCLE_MASK){ + ShouldDecrRefCount = False; + NodeInASemiStrictContext (node,local_scope); + SetUnaryState (&node->node_state, SemiStrict, node->node_state.state_object); + } else { + ShouldDecrRefCount = True; + NodeInAStrictContext (node, node->node_state, local_scope); + } + } + } + + if (ready){ + for_l (next,firstdef,def_next){ + if (next->def_node && IsLazyState (next->def_node->node_state) && + ! (next->def_id->nid_mark & ON_A_CYCLE_MASK) && next->def_id->nid_ref_count_copy==0) + { + next->def_id->nid_ref_count_copy_ = -1; + ready = False; + DecrRefCountCopiesOfArgs (next->def_node->node_arguments IF_OPTIMIZE_LAZY_TUPLE_RECURSION(local_scope)); + break; + } + } + } + } while (! ready); + + for_l (next,firstdef,def_next) + if (next->def_node) + if (! (next->def_id->nid_ref_count_copy<0 || + (next->def_id->nid_ref_count_copy==0 && (next->def_id->nid_mark & ON_A_CYCLE_MASK)))) + { + error_in_function ("DetermineStatesOfNodeDefs"); + } +} + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + +static void set_push_node_id_states (NodeIdListElementP node_ids,StateS states[]) +{ + StateP arg_state_p; + + for (arg_state_p=states; node_ids!=NULL; node_ids=node_ids->nidl_next,++arg_state_p){ + NodeIdP node_id_p; + + node_id_p=node_ids->nidl_node_id; + node_id_p->nid_lhs_state_p_=arg_state_p; + node_id_p->nid_ref_count_copy=node_id_p->nid_refcount; + } +} + +static void set_lazy_push_node_id_states (NodeIdListElementP node_ids) +{ + for (; node_ids!=NULL; node_ids=node_ids->nidl_next){ + NodeIdP node_id_p; + + node_id_p=node_ids->nidl_node_id; + node_id_p->nid_lhs_state_p_=&LazyState; + node_id_p->nid_ref_count_copy=node_id_p->nid_refcount; + } +} + +static void DetermineStatesOfNodeAndDefs (Node root_node,NodeDefs node_defs,StateS demstate,int local_scope) +{ + ShouldDecrRefCount = True; + + if (root_node->node_kind==SwitchNode){ + ArgP arg_p; + int old_scope; + + old_scope=scope; + + if (node_defs!=NULL) + error_in_function ("DetermineStatesOfNodeAndDefs"); + + root_node->node_state = *root_node->node_node_id->nid_lhs_state_p; + root_node->node_node_id->nid_ref_count_copy=root_node->node_node_id->nid_refcount; + + for_l (arg_p,root_node->node_arguments,arg_next){ + NodeP arg_node_p; + + arg_node_p=arg_p->arg_node; + scope=old_scope; + + if (arg_node_p->node_kind==CaseNode){ + NodeP case_alt_node_p; + + case_alt_node_p=arg_node_p->node_arguments->arg_node; + if (case_alt_node_p->node_kind==PushNode){ + NodeIdP node_id_p; + StateP node_id_state_p; + NodeIdListElementP node_ids; + + node_id_p=case_alt_node_p->node_arguments->arg_node->node_node_id; + node_id_state_p=node_id_p->nid_lhs_state_p; + node_ids=case_alt_node_p->node_node_ids; + + switch (node_id_state_p->state_type){ + case RecordState: + set_push_node_id_states (node_ids,case_alt_node_p->node_record_symbol->symb_def->sdef_record_state.state_record_arguments); + break; + case TupleState: + set_push_node_id_states (node_ids,node_id_state_p->state_tuple_arguments); + break; + default: + { + Symbol symbol; + + symbol=case_alt_node_p->node_record_symbol; + + if (symbol->symb_kind==definition){ + SymbDef sdef; + + sdef=symbol->symb_def; + + if (sdef->sdef_kind==CONSTRUCTOR){ +# ifdef REUSE_UNIQUE_NODES + AttributeKind lhs_type_attribute; + + lhs_type_attribute=sdef->sdef_type->type_lhs->ft_attribute; + + if (lhs_type_attribute==UniqueAttr && (node_id_state_p->state_mark & STATE_UNIQUE_MASK)==0){ + StateP unique_state_p; + + unique_state_p=CompAllocType (StateS); + *unique_state_p=*node_id_state_p; + unique_state_p->state_mark |= STATE_UNIQUE_MASK; + + node_id_state_p=unique_state_p; + node_id_p->nid_lhs_state_p=unique_state_p; + } + + if (sdef->sdef_arity==case_alt_node_p->node_arity && (node_id_state_p->state_mark & STATE_UNIQUE_MASK)){ + NodeIdListElementP node_ids_elem; + + if (sdef->sdef_strict_constructor){ + struct type_arg *type_arg_p; + StateP constructor_arg_state_p; + + for_lla (node_ids_elem,type_arg_p,constructor_arg_state_p, + node_ids,sdef->sdef_constructor->cl_constructor->type_node_arguments,symbol->symb_def->sdef_constructor->cl_state_p, + nidl_next,type_arg_next) + { + NodeIdP node_id_p; + + node_id_p=node_ids_elem->nidl_node_id; + node_id_p->nid_ref_count_copy=node_id_p->nid_refcount; + + node_id_p->nid_lhs_state_p_=determine_unique_state_of_constructor_argument (constructor_arg_state_p,type_arg_p->type_arg_node,lhs_type_attribute); + } + } else { + struct type_arg *type_arg_p; + + for_ll (node_ids_elem,type_arg_p,node_ids,sdef->sdef_constructor->cl_constructor->type_node_arguments,nidl_next,type_arg_next){ + NodeIdP node_id_p; + + node_id_p=node_ids_elem->nidl_node_id; + node_id_p->nid_ref_count_copy=node_id_p->nid_refcount; + + node_id_p->nid_lhs_state_p_=determine_unique_state_of_constructor_argument (&LazyState,type_arg_p->type_arg_node,lhs_type_attribute); + } + } + } else +# endif + if (sdef->sdef_strict_constructor && sdef->sdef_arity==case_alt_node_p->node_arity) + set_push_node_id_states (node_ids,sdef->sdef_constructor->cl_state_p); + else + set_lazy_push_node_id_states (node_ids); + } else if (sdef->sdef_kind==RECORDTYPE){ +# ifdef REUSE_UNIQUE_NODES + AttributeKind lhs_type_attribute; + + lhs_type_attribute=sdef->sdef_type->type_lhs->ft_attribute; + + if (lhs_type_attribute==UniqueAttr && (node_id_state_p->state_mark & STATE_UNIQUE_MASK)==0){ + StateP unique_state_p; + + unique_state_p=CompAllocType (StateS); + *unique_state_p=*node_id_state_p; + unique_state_p->state_mark |= STATE_UNIQUE_MASK; + + node_id_state_p=unique_state_p; + node_id_p->nid_lhs_state_p=unique_state_p; + } + + if (node_id_state_p->state_mark & STATE_UNIQUE_MASK){ + NodeIdListElementP node_ids_elem; + StateP arg_state_p; + FieldList field; + + for_lla (node_ids_elem,field,arg_state_p,node_ids, + sdef->sdef_type->type_fields,sdef->sdef_record_state.state_record_arguments,nidl_next,fl_next) + { + NodeIdP node_id_p; + + node_id_p=node_ids_elem->nidl_node_id; + node_id_p->nid_ref_count_copy=node_id_p->nid_refcount; + + node_id_p->nid_lhs_state_p_=determine_unique_state_of_constructor_argument (arg_state_p,field->fl_type,lhs_type_attribute); + } + } else +# endif + + set_push_node_id_states (node_ids,sdef->sdef_record_state.state_record_arguments); + } else + set_lazy_push_node_id_states (node_ids); + } else +# 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; + + node_id_p=node_ids->nidl_node_id; + node_id_p->nid_ref_count_copy=node_id_p->nid_refcount; + + 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); + *unique_state_p=LazyState; + unique_state_p->state_mark |= STATE_UNIQUE_MASK; + + node_id_p->nid_lhs_state_p_=unique_state_p; + } else + node_id_p->nid_lhs_state_p_=&LazyState; + + node_ids=node_ids->nidl_next; + + node_id_p=node_ids->nidl_node_id; + node_id_p->nid_ref_count_copy=node_id_p->nid_refcount; + + { + StateP unique_state_p; + + unique_state_p=CompAllocType (StateS); + + *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; + unique_state_p->state_unq_type_args = 1; + } + + node_id_p->nid_lhs_state_p_=unique_state_p; + } + } else if (symbol->symb_kind==tuple_symb && (node_id_state_p->state_mark & STATE_UNIQUE_MASK)){ + NodeIdListElementP node_ids_elem; + int i; + + for_li (node_ids_elem,i,node_ids,nidl_next){ + NodeIdP node_id_p; + + node_id_p=node_ids_elem->nidl_node_id; + node_id_p->nid_ref_count_copy=node_id_p->nid_refcount; + + if ((node_id_state_p->state_mark & STATE_UNIQUE_TYPE_ARGUMENTS_MASK) && (node_id_state_p->state_unq_type_args & (1<<i))){ + StateP unique_state_p; + + unique_state_p=CompAllocType (StateS); + *unique_state_p=LazyState; + unique_state_p->state_mark |= STATE_UNIQUE_MASK; + + node_id_p->nid_lhs_state_p_=unique_state_p; + } else + node_id_p->nid_lhs_state_p_=&LazyState; + } + } else +# endif + set_lazy_push_node_id_states (node_ids); + } + } + + DetermineStatesOfNodeAndDefs (case_alt_node_p->node_arguments->arg_next->arg_node,arg_node_p->node_node_defs,demstate,local_scope); + } else + DetermineStatesOfNodeAndDefs (case_alt_node_p,arg_node_p->node_node_defs,demstate,local_scope); + } else if (arg_node_p->node_kind==DefaultNode){ + DetermineStatesOfNodeAndDefs (arg_node_p->node_arguments->arg_node,arg_node_p->node_node_defs,demstate,local_scope); + } else + error_in_function ("DetermineStatesOfNodeAndDefs"); + } + } else if (root_node->node_kind==GuardNode){ + int old_scope; + + old_scope=scope; + DetermineStatesOfNodeAndDefs (root_node->node_arguments->arg_node,node_defs,demstate,local_scope); + scope=old_scope; + DetermineStatesOfNodeAndDefs (root_node->node_arguments->arg_next->arg_node,root_node->node_node_defs,demstate,local_scope); + } else { + if (root_node->node_kind==NodeIdNode){ + NodeId node_id; + + node_id=root_node->node_node_id; + if (node_id->nid_node==NULL || node_id->nid_ref_count_copy<0) + return; + + DetermineStatesOfGuardRootNode (node_id->nid_node,node_id,demstate,local_scope); + } else + DetermineStatesOfGuardRootNode (root_node,NULL,demstate,local_scope); + + if (node_defs) + DetermineStatesOfNodeDefs (node_defs,local_scope); + } +} +#endif + +void DetermineStatesOfRootNodeAndDefs (Node root_node,NodeDefs *rootdef,StateS demstate,int local_scope) +{ +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + DetermineStatesOfNodeAndDefs (root_node,*rootdef,demstate,local_scope); +#else + ShouldDecrRefCount = True; + + if (root_node->node_kind==NodeIdNode){ + NodeId node_id; + + node_id=root_node->node_node_id; + if (node_id->nid_node==NULL || node_id->nid_ref_count_copy<0) + return; + + DetermineStatesOfGuardRootNode (node_id->nid_node,node_id,demstate,local_scope); + } else + DetermineStatesOfGuardRootNode (root_node,NULL,demstate,local_scope); + + if (*rootdef) + DetermineStatesOfNodeDefs (*rootdef,local_scope); +#endif +} + +#ifdef OBSERVE_ARRAY_SELECTS_IN_PATTERN + static void set_states_of_array_selects_in_pattern (RuleAlts alt) + { + StrictNodeIdP strict_node_id; + + for_l (strict_node_id,alt->alt_strict_node_ids,snid_next){ + if (strict_node_id->snid_array_select_in_pattern){ + NodeP select_node,array_uselect_node; + NodeId node_id; + + node_id=strict_node_id->snid_node_id; + if (node_id->nid_node->node_symbol->symb_kind==select_symb){ + select_node=node_id->nid_node; + array_uselect_node=select_node->node_arguments->arg_node; + } else { + select_node=NULL; + array_uselect_node=node_id->nid_node; + } + + if (array_uselect_node->node_state.state_type==TupleState){ + StateP tuple_arg_states; + + tuple_arg_states=NewArrayOfStates (2); + SetUnaryState (&tuple_arg_states[1],Undefined,UnknownObj); + tuple_arg_states[0]=array_uselect_node->node_state.state_tuple_arguments[0]; + SetTupleState (&array_uselect_node->node_state,tuple_arg_states,2); + + if (select_node!=NULL && select_node->node_state.state_type==SimpleState + && select_node->node_state.state_kind==StrictOnA + && select_node->node_arguments->arg_state.state_type==TupleState + && select_node->node_arguments->arg_state.state_tuple_arguments[0].state_type==SimpleState + && select_node->node_arguments->arg_state.state_tuple_arguments[0].state_kind==StrictOnA + ){ + select_node->node_state=array_uselect_node->node_state.state_tuple_arguments[0]; + SetTupleState (&select_node->node_arguments->arg_state,tuple_arg_states,2); + } + } + } + } + } +#endif + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +static void set_states_in_lhs (ArgP arguments,StateP states) +{ + StateP arg_state_p; + ArgP arg_p; + + for_la (arg_p,arg_state_p,arguments,states,arg_next){ + Node arg_node; + + arg_p->arg_state=*arg_state_p; + + arg_node=arg_p->arg_node; + + if (arg_node->node_kind==NodeIdNode){ + NodeId node_id_p; + + node_id_p=arg_node->node_node_id; + node_id_p->nid_lhs_state_p_=&arg_p->arg_state; + node_id_p->nid_ref_count_copy=node_id_p->nid_refcount; + + arg_node=node_id_p->nid_node; + if (arg_node!=NULL){ + if (arg_state_p->state_type==TupleState) + set_states_in_lhs (arg_node->node_arguments,arg_state_p->state_tuple_arguments); + else if (arg_state_p->state_type==RecordState) + set_states_in_lhs (arg_node->node_arguments,arg_state_p->state_record_arguments); + } + } else { + if (arg_state_p->state_type==TupleState) + set_states_in_lhs (arg_node->node_arguments,arg_state_p->state_tuple_arguments); + else if (arg_state_p->state_type==RecordState) + set_states_in_lhs (arg_node->node_arguments,arg_state_p->state_record_arguments); + else + error_in_function ("set_states_in_lhs"); + } + } +} +#endif + +void GenerateStatesForRule (ImpRuleS *rule) +{ + SymbDef rule_sdef; + + CurrentSymbol=rule->rule_root->node_symbol; + rule_sdef=CurrentSymbol->symb_def; + + if (rule_sdef->sdef_over_arity==0){ + RuleAlts alt; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + StateP function_state_p; + + function_state_p=rule->rule_state_p; +#endif + + for_l (alt,rule->rule_alts,alt_next){ + CurrentLine = alt->alt_line; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + set_states_in_lhs (alt->alt_lhs_root->node_arguments,function_state_p); + alt->alt_lhs_root->node_state = function_state_p[-1]; /* i.e. the result state */ +#endif + + scope=1; + + if (alt->alt_kind==Contractum){ + DetermineStatesOfRootNodeAndDefs (alt->alt_rhs_root,&alt->alt_rhs_defs,alt->alt_lhs_root->node_state,0); + +#ifdef OBSERVE_ARRAY_SELECTS_IN_PATTERN + set_states_of_array_selects_in_pattern (alt); +#endif + } else if (rule->rule_type==NULL) + StaticMessage (True, "%S", ECodeBlock, CurrentSymbol); + } + } +} + +void GenerateStates (ImpRules rules) +{ + ImpRuleS *rule; + + for_l (rule,rules,rule_next) + GenerateStatesForRule (rule); +} + +static NodeDefS **RemoveLocallySharedNodeDefs (NodeDefS **start,NodeDefS **end,NodeDefS **loclist,int scope) +{ + NodeDefS **newend,**current; + + newend = start; + current = start; + + while (current!=end){ + int node_id_scope; + + node_id_scope=(*current)->def_id->nid_scope; + if (node_id_scope<0) + node_id_scope=-node_id_scope; + + if (node_id_scope>scope){ + NodeDefP remove; + + remove = *current; + *start = remove->def_next; + current = &remove->def_next; + *loclist = remove; + loclist = current; + } else { + current = start = &(*start)->def_next; + newend = start; + } + } + + *loclist = NULL; + + return newend; +} + +void DetermineNodeState (Node node) +{ + if (node->node_annotation==NoAnnot) + node->node_state=LazyState; + else if (node->node_annotation==StrictAnnot) + node->node_state=StrictState; + else { + SetUnaryState (&node->node_state, DoParallel ? Parallel : OnA, UnknownObj); + if (DoParallel) + node->node_state.state_mark |= STATE_PARALLEL_MASK; + + if (node->node_state.state_kind==Parallel){ + if (DoParallel) + /* node->node_attribute = AnnotHasDeferAttr (node->node_annotation->annot_kind) */; + else { + StaticMessage (False, "%S", Wparannot, CurrentSymbol); + node->node_state.state_kind = OnA; + } + } + } +} + +static int NodeIdCount; +static NodeId NodeIdStackTop; + +static Bool MarkComponentNodesOnACycle (Node node,int group_number) +{ + if (node->node_number!=0) + return node->node_number<0; + + switch (node->node_kind){ + case NodeIdNode: + { + NodeId node_id; + + node_id=node->node_node_id; + + if (node_id->nid_mark & ON_A_CYCLE_MASK && node_id->nid_number==group_number){ + node->node_number=-1; + MarkComponentNodesOnACycle (node_id->nid_node,group_number); + return True; + } else { + node->node_number=1; + return False; + } + } + case NormalNode: + case UpdateNode: + case SelectorNode: + case MatchNode: + { + ArgS *arg; + Bool on_a_cycle; + + on_a_cycle=False; + + node->node_number=1; + for_l (arg,node->node_arguments,arg_next) + if (MarkComponentNodesOnACycle (arg->arg_node,group_number)) + on_a_cycle=True; + + if (on_a_cycle) + node->node_number=-1; + + return on_a_cycle; + } + case IfNode: + default: + error_in_function ("MarkComponentNodesOnACycle"); + return False; + } +} + +static void AddStrictLhsNodeIdsToNodeDefs (StrictNodeIdP strict_node_id,NodeDefs *defs_p) +{ + while (strict_node_id){ + NodeId node_id; + + node_id=strict_node_id->snid_node_id; + + if (node_id->nid_refcount<0){ + NodeDefS *new_def; + + new_def = NewNodeDef (node_id,NULL); +/* node_id->nid_node_def = new_def; */ + + new_def->def_next=*defs_p; + *defs_p=new_def; + defs_p=&new_def->def_next; + } else if ((strict_node_id->snid_mark & STRICT_NODE_ID_OBSERVE_MASK) && node_id->nid_refcount>0 && node_id->nid_node!=NULL){ + if (node_id->nid_node_def!=NULL) + node_id->nid_node_def->def_mark |= NODE_DEF_OBSERVE_MASK; + } + + strict_node_id=strict_node_id->snid_next; + } +} + +#ifdef ADD_ARGUMENTS_TO_HIGHER_ORDER_FUNCTIONS +static ImpRuleP new_rules_with_more_arguments,*last_new_rule_with_more_arguments_h; + +static int get_symbol_arity_or_zero (SymbolP symbol_p) +{ + switch (symbol_p->symb_kind){ + case definition: + { + SymbDef sdef; + + sdef=symbol_p->symb_def; + + switch (sdef->sdef_kind){ + case DEFRULE: + case SYSRULE: + case IMPRULE: + case CONSTRUCTOR: + return sdef->sdef_arity; + case RECORDTYPE: + return sdef->sdef_cons_arity; + } + break; + } + case cons_symb: + return 2; + case if_symb: + return 3; + } + + return 0; +} + +static NodeP add_argument_to_node (NodeP rhs_root_p,NodeIdP new_node_id_p); + +static NodeP add_argument_to_if_node (NodeP rhs_root_p,NodeIdP new_node_id_p) +{ + ArgP then_arg_p,else_arg_p; + NodeP else_node_p; + + then_arg_p=rhs_root_p->node_arguments->arg_next; + else_arg_p=then_arg_p->arg_next; + else_node_p=else_arg_p->arg_node; + + then_arg_p->arg_node=add_argument_to_node (then_arg_p->arg_node,new_node_id_p); + + if (else_node_p->node_kind!=NormalNode || else_node_p->node_symbol->symb_kind!=fail_symb){ + --new_node_id_p->nid_refcount; + else_arg_p->arg_node=add_argument_to_node (else_node_p,new_node_id_p); + } + + return rhs_root_p; +} + +static NodeP add_argument_to_node (NodeP rhs_root_p,NodeIdP new_node_id_p) +{ + ArgP new_arg1,new_arg2; + + if (rhs_root_p->node_kind==NormalNode){ + SymbolP root_symbol_p; + + root_symbol_p=rhs_root_p->node_symbol; + if (root_symbol_p->symb_kind==if_symb && rhs_root_p->node_arity==3) + return add_argument_to_if_node (rhs_root_p,new_node_id_p); + else if (get_symbol_arity_or_zero (root_symbol_p) > rhs_root_p->node_arity){ + ArgP *last_rhs_arg_h; + + new_arg2=NewArgument (NewNodeIdNode (new_node_id_p)); + + last_rhs_arg_h=&rhs_root_p->node_arguments; + while (*last_rhs_arg_h) + last_rhs_arg_h=&(*last_rhs_arg_h)->arg_next; + + *last_rhs_arg_h=new_arg2; + ++rhs_root_p->node_arity; + + return rhs_root_p; + } + } else if (rhs_root_p->node_kind==IfNode) + return add_argument_to_if_node (rhs_root_p,new_node_id_p); + + new_arg2=NewArgument (NewNodeIdNode (new_node_id_p)); + + new_arg1=NewArgument (rhs_root_p); + new_arg1->arg_next=new_arg2; + rhs_root_p=NewNode (ApplySymbol,new_arg1,2); + + return rhs_root_p; +} + +static SymbolP copy_imp_rule_and_add_arguments (SymbDef rule_sdef,int n_extra_arguments) +{ + SymbolP new_symbol_p; + SymbDef new_sdef_p; + ImpRuleP old_rule_p,new_rule_p,last_rule_version_p; + int n_wanted_arguments; + + n_wanted_arguments=rule_sdef->sdef_arity + n_extra_arguments; + + old_rule_p=rule_sdef->sdef_rule; + + while (old_rule_p->rule_mark & RULE_HAS_VERSION_WITH_MORE_ARGUMENTS){ + old_rule_p=old_rule_p->rule_next_function_with_more_arguments; + + if (old_rule_p->rule_root->node_symbol->symb_def->sdef_arity==n_wanted_arguments) + return old_rule_p->rule_root->node_symbol; + } + + new_symbol_p=copy_imp_rule_and_type (rule_sdef); + + new_sdef_p=new_symbol_p->symb_def; + new_rule_p=new_sdef_p->sdef_rule; + old_rule_p=rule_sdef->sdef_rule; + + last_rule_version_p=old_rule_p; + while (last_rule_version_p->rule_mark & RULE_HAS_VERSION_WITH_MORE_ARGUMENTS) + last_rule_version_p=last_rule_version_p->rule_next_function_with_more_arguments; + + last_rule_version_p->rule_mark |= RULE_HAS_VERSION_WITH_MORE_ARGUMENTS; + last_rule_version_p->rule_next_function_with_more_arguments=new_rule_p; + + new_sdef_p->sdef_next_scc=rule_sdef->sdef_next_scc; + rule_sdef->sdef_next_scc=new_sdef_p; + + copy_imp_rule_nodes (old_rule_p,new_rule_p); + + { + struct type_alt *rule_type; + struct type_node *rhs_type_node_p; + struct type_arg **last_lhs_type_arg_p; + int n; + + rule_type=new_rule_p->rule_type; + rhs_type_node_p=rule_type->type_alt_rhs; + last_lhs_type_arg_p=&rule_type->type_alt_lhs->type_node_arguments; + while (*last_lhs_type_arg_p) + last_lhs_type_arg_p=&(*last_lhs_type_arg_p)->type_arg_next; + + for (n=0; n<n_extra_arguments; ++n){ +#if 0 + if (rhs_type_node_p->type_node_is_var){ + struct type_arg *new_type_arg_p; + + new_type_arg_p=NewTypeArgument (NewTypeVarNode (NewTypeVar (NULL),NoAnnot,NoAttr)); + + *last_lhs_type_arg_p=new_type_arg_p; + last_lhs_type_arg_p=&new_type_arg_p->type_arg_next; + } else +#else + if (rhs_type_node_p->type_node_is_var || rhs_type_node_p->type_node_symbol->symb_kind!=fun_type) + error_in_function ("copy_imp_rule_and_add_arguments"); +#endif + { + struct type_arg *first_arg_p; + + if (rhs_type_node_p->type_node_symbol->symb_kind!=fun_type) + error_in_function ("copy_imp_rule_and_add_arguments"); + + first_arg_p=rhs_type_node_p->type_node_arguments; + *last_lhs_type_arg_p=first_arg_p; + + first_arg_p->type_arg_node->type_node_annotation=NoAnnot; + + last_lhs_type_arg_p=&first_arg_p->type_arg_next; + + rhs_type_node_p=first_arg_p->type_arg_next->type_arg_node; + } + } + + *last_lhs_type_arg_p=NULL; + rule_type->type_alt_rhs=rhs_type_node_p; + + rule_type->type_alt_lhs->type_node_arity += n_extra_arguments; + } + + { + RuleAltP alt_p; + + for_l (alt_p,new_rule_p->rule_alts,alt_next){ + int n; + ArgP *last_lhs_arg_h; + + last_lhs_arg_h=&alt_p->alt_lhs_root->node_arguments; + while (*last_lhs_arg_h) + last_lhs_arg_h=&(*last_lhs_arg_h)->arg_next; + + for (n=0; n<n_extra_arguments; ++n){ + NodeIdP new_node_id_p; + ArgP new_arg; + + new_node_id_p=NewNodeId (NULL); + new_node_id_p->nid_refcount=-2; + + new_arg=NewArgument (NewNodeIdNode (new_node_id_p)); + + *last_lhs_arg_h=new_arg; + last_lhs_arg_h=&new_arg->arg_next; + + alt_p->alt_rhs_root=add_argument_to_node (alt_p->alt_rhs_root,new_node_id_p); + } + + *last_lhs_arg_h=NULL; + + alt_p->alt_lhs_root->node_arity += n_extra_arguments; + } + + new_sdef_p->sdef_arity += n_extra_arguments; + } + + new_rule_p->rule_next=NULL; + + *last_new_rule_with_more_arguments_h=new_rule_p; + last_new_rule_with_more_arguments_h=&new_rule_p->rule_next; + + return new_symbol_p; +} + +static int create_new_function_with_more_arguments (NodeP node_p,int determine_node_state) +{ + NodeP function_node_p; + int n_extra_arguments; + + n_extra_arguments=1; + function_node_p=node_p->node_arguments->arg_node; + + if (function_node_p->node_kind==NodeIdNode && function_node_p->node_node_id->nid_refcount==1 && function_node_p->node_node_id->nid_node->node_annotation==NoAnnot){ + function_node_p=function_node_p->node_node_id->nid_node; + node_p->node_arguments->arg_node=function_node_p; + } + + while (function_node_p->node_kind==NormalNode && function_node_p->node_symbol->symb_kind==apply_symb){ + ArgP next_function_node_p_arg; + + next_function_node_p_arg=function_node_p->node_arguments; + function_node_p=next_function_node_p_arg->arg_node; + ++n_extra_arguments; + + if (function_node_p->node_kind==NodeIdNode && function_node_p->node_node_id->nid_refcount==1 && function_node_p->node_node_id->nid_node->node_annotation==NoAnnot){ + function_node_p=function_node_p->node_node_id->nid_node; + next_function_node_p_arg->arg_node=function_node_p; + } + } + + if (function_node_p->node_kind==NormalNode){ + SymbolP function_symbol_p; + + function_symbol_p=function_node_p->node_symbol; + + if (function_symbol_p->symb_kind==definition){ + if (function_symbol_p->symb_def->sdef_kind==IMPRULE && !(function_symbol_p->symb_def->sdef_rule->rule_mark & RULE_CAF_MASK)){ + if (function_node_p->node_arity <= function_symbol_p->symb_def->sdef_arity){ + struct type_node *rhs_type_node_p; + SymbolP new_function_symbol; + SymbDef rule_sdef; + NodeP function_node_p2; + ArgP *arg_h; + int n_extra_function_arguments,n; + + rule_sdef=function_symbol_p->symb_def; + rhs_type_node_p=rule_sdef->sdef_rule->rule_type->type_alt_rhs; + + n_extra_function_arguments=n_extra_arguments+function_node_p->node_arity-rule_sdef->sdef_arity; + + n=n_extra_function_arguments; + while (n>0){ + if (rhs_type_node_p->type_node_is_var){ +#if 0 + n=0; +#endif + break; + } else if (rhs_type_node_p->type_node_symbol->symb_kind==fun_type){ + rhs_type_node_p=rhs_type_node_p->type_node_arguments->type_arg_next->type_arg_node; + --n; + } else + break; + } + + if (n<=0){ + if (n_extra_function_arguments>0){ + new_function_symbol=copy_imp_rule_and_add_arguments (rule_sdef,n_extra_function_arguments); + + node_p->node_symbol=new_function_symbol; + } else + node_p->node_symbol=function_node_p->node_symbol; + + function_node_p2=node_p->node_arguments->arg_node; + node_p->node_arguments=node_p->node_arguments->arg_next; + + while (function_node_p2!=function_node_p){ + ArgP second_arg_p; + + second_arg_p=function_node_p2->node_arguments->arg_next; + + second_arg_p->arg_next=node_p->node_arguments; + node_p->node_arguments=second_arg_p; + + function_node_p2=function_node_p2->node_arguments->arg_node; + } + + arg_h=&function_node_p->node_arguments; + while (*arg_h!=NULL) + arg_h=&(*arg_h)->arg_next; + + *arg_h=node_p->node_arguments; + node_p->node_arguments=function_node_p->node_arguments; + + node_p->node_arity=function_node_p->node_arity+n_extra_arguments; + + return 1; + } + } + } + } else if (function_symbol_p->symb_kind==if_symb && function_node_p->node_arity==3){ + NodeP apply_node_p; + int n_lhs_node_id_applies; + + n_lhs_node_id_applies=0; + apply_node_p=node_p; + while (apply_node_p->node_kind==NormalNode && apply_node_p->node_symbol->symb_kind==apply_symb){ + ArgP apply_arg1; + NodeP apply_arg2_node_p; + + apply_arg1=apply_node_p->node_arguments; + apply_arg2_node_p=apply_arg1->arg_next->arg_node; + + if (apply_arg2_node_p->node_kind==NodeIdNode && apply_arg2_node_p->node_node_id->nid_refcount<0){ + apply_node_p=apply_arg1->arg_node; + ++n_lhs_node_id_applies; + } else + break; + } + + if (n_lhs_node_id_applies==n_extra_arguments){ + int n; + + for (n=0; n<n_extra_arguments; ++n){ + int m; + + apply_node_p=node_p; + + for (m=0; m<n_extra_arguments-1-n; ++m) + apply_node_p=apply_node_p->node_arguments->arg_node; + + function_node_p=add_argument_to_node (function_node_p,apply_node_p->node_arguments->arg_next->arg_node->node_node_id); + } + + *node_p=*function_node_p; + if (determine_node_state) + DetermineNodeState (node_p); + } + } + } + + return 0; +} +#endif + +static NodeDefs *CollectSharedNodeIdsInNode (Node* node_p,NodeId parent_node_id,NodeDefs *last) +{ + Node node; + + node=*node_p; + if (node->node_kind==NodeIdNode){ + NodeId node_id; + + node_id=node->node_node_id; + + if (node_id->nid_refcount>0){ + if (!(node_id->nid_mark & SHARED_NODES_COLLECTED_MASK)){ + node_id->nid_mark |= SHARED_NODES_COLLECTED_MASK; + + node_id->nid_ref_count_copy_=node_id->nid_refcount; + + if (node_id->nid_refcount>1 || node_id->nid_node->node_annotation){ + int my_number; + + my_number=NodeIdCount++; + + node_id->nid_number=my_number; + node_id->nid_forward_node_id_=NodeIdStackTop; + NodeIdStackTop=node_id; + + last = CollectSharedNodeIdsInNode (&node_id->nid_node,node_id,last); + + if (/* node_id->nid_forward_node_id && */ parent_node_id) + parent_node_id->nid_number=MINIMUM (parent_node_id->nid_number,node_id->nid_number); + + if (node_id->nid_number==my_number){ + NodeId next_node_id; + NodeDefs newdef; + + next_node_id = NodeIdStackTop; + NodeIdStackTop = next_node_id->nid_forward_node_id; + next_node_id->nid_forward_node_id_ = NULL; + + newdef = NewNodeDef (next_node_id,next_node_id->nid_node); + next_node_id->nid_node_def_ = newdef; + *last=newdef; + last=&newdef->def_next; + + if (next_node_id!=node_id){ + next_node_id->nid_number=my_number; + next_node_id->nid_mark|=ON_A_CYCLE_MASK; + + do { + next_node_id = NodeIdStackTop; + NodeIdStackTop = next_node_id->nid_forward_node_id; + next_node_id->nid_forward_node_id_ = NULL; + + next_node_id->nid_number=my_number; + next_node_id->nid_mark|=ON_A_CYCLE_MASK; + + newdef = NewNodeDef (next_node_id,next_node_id->nid_node); + next_node_id->nid_node_def_ = newdef; + *last=newdef; + last=&newdef->def_next; + } while (next_node_id!=node_id); + } + + if (node_id->nid_mark & ON_A_CYCLE_MASK) + MarkComponentNodesOnACycle (node_id->nid_node,node_id->nid_number); + } + } else { + *node_p=node_id->nid_node; + last = CollectSharedNodeIdsInNode (node_p,parent_node_id,last); + } + } else + if (node_id->nid_forward_node_id){ + node_id->nid_mark|=ON_A_CYCLE_MASK; + parent_node_id->nid_number=MINIMUM (parent_node_id->nid_number,node_id->nid_number); + } + } else + node_id->nid_ref_count_copy_=node_id->nid_refcount; + } else { + DetermineNodeState (node); + + if (node->node_annotation==ParallelAtAnnot){ + Node at_node; + + at_node=get_p_at_node (node); + + last = CollectSharedNodeIdsInNode (&at_node,parent_node_id,last); + } + + if (node->node_kind!=IfNode){ + ArgP arg; + +#ifdef ADD_ARGUMENTS_TO_HIGHER_ORDER_FUNCTIONS + if (node->node_kind==NormalNode && node->node_symbol->symb_kind==apply_symb) + (void) create_new_function_with_more_arguments (node,1); +#endif + + for_l (arg,node->node_arguments,arg_next){ + arg->arg_state=LazyState; + last = CollectSharedNodeIdsInNode (&arg->arg_node,parent_node_id,last); + } + } else { + NodeDefs *shared; + Args cond_arg,then_arg,else_arg; + int local_scope; + + cond_arg=node->node_arguments; + then_arg=cond_arg->arg_next; + else_arg=then_arg->arg_next; + + local_scope=scope+1; + scope+=3; + + cond_arg->arg_state=LazyState; + + /*{ + Node root_node; + + root_node=cond_arg->arg_node; + if (root_node->node_kind==NodeIdNode && root_node->node_node_id->nid_refcount==1) + root_node->node_node_id->nid_node->node_annotation=NoAnnot; + }*/ + + last = CollectSharedNodeIdsInNode (&cond_arg->arg_node,parent_node_id,last); + ++scope; + + shared=last; + then_arg->arg_state=LazyState; + + /*{ + Node root_node; + + root_node=then_arg->arg_node; + if (root_node->node_kind==NodeIdNode && root_node->node_node_id->nid_refcount==1) + root_node->node_node_id->nid_node->node_annotation=NoAnnot; + }*/ + + last=CollectSharedNodeIdsInNode (&then_arg->arg_node,parent_node_id,last); + last=RemoveLocallySharedNodeDefs (shared,last,&node->node_then_node_defs,local_scope); + + ++scope; + + shared=last; + else_arg->arg_state=LazyState; + + /*{ + Node root_node; + + root_node=else_arg->arg_node; + if (root_node->node_kind==NodeIdNode && root_node->node_node_id->nid_refcount==1) + root_node->node_node_id->nid_node->node_annotation=NoAnnot; + }*/ + + last=CollectSharedNodeIdsInNode (&else_arg->arg_node,parent_node_id,last); + last=RemoveLocallySharedNodeDefs (shared,last,&node->node_else_node_defs,local_scope); + + AddStrictLhsNodeIdsToNodeDefs (node->node_then_strict_node_ids,&node->node_then_node_defs); + AddStrictLhsNodeIdsToNodeDefs (node->node_else_strict_node_ids,&node->node_else_node_defs); + } + } + + return last; +} + +static void CollectSharedAndAnnotatedNodesInRhs (NodeS **root_p,NodeDefS **defs_p,StrictNodeIdP strict_node_ids) +{ + NodeDefS **last; + NodeP root_node; + + scope=1; + + NodeIdCount=1; + NodeIdStackTop = (NodeId)-1; + + root_node=*root_p; + + /* removed, causes crash if let! in other scope + if (root_node->node_kind==NodeIdNode && root_node->node_node_id->nid_refcount==1) + root_node->node_node_id->nid_node->node_annotation=NoAnnot; + */ + +#ifdef ADD_ARGUMENTS_TO_HIGHER_ORDER_FUNCTIONS + while (root_node->node_kind==NormalNode && + ((root_node->node_symbol->symb_kind==apply_symb && create_new_function_with_more_arguments (root_node,0)) || + (root_node->node_symbol->symb_kind==definition && root_node->node_symbol->symb_def->sdef_kind==IMPRULE))) + { + ImpRuleP imp_rule_p; + + imp_rule_p=root_node->node_symbol->symb_def->sdef_rule; + + if ((imp_rule_p->rule_mark & RULE_LAMBDA_FUNCTION_MASK) && + root_node->node_symbol->symb_def->sdef_arity==root_node->node_arity && + imp_rule_p->rule_alts->alt_next==NULL +# ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + && ! (imp_rule_p->rule_alts->alt_rhs_root->node_kind==SwitchNode || + imp_rule_p->rule_alts->alt_rhs_root->node_kind==GuardNode || + imp_rule_p->rule_alts->alt_rhs_root->node_kind==IfNode) +# endif + ) + { + ArgP call_arg_p,lhs_arg_p; + + for_l (lhs_arg_p,imp_rule_p->rule_alts->alt_lhs_root->node_arguments,arg_next) + if (lhs_arg_p->arg_node->node_kind!=NodeIdNode || + lhs_arg_p->arg_node->node_node_id->nid_refcount==-1 || + lhs_arg_p->arg_node->node_node_id->nid_node!=NULL) + { + break; + } + + if (lhs_arg_p==NULL){ + NodeP new_root_node; +/* + PrintRuleNode (root_node,False,StdOut); + FPrintF (StdOut,"\n"); + PrintRuleAlt (imp_rule_p->rule_alts,StdOut); +*/ + for_ll (call_arg_p,lhs_arg_p,root_node->node_arguments,imp_rule_p->rule_alts->alt_lhs_root->node_arguments,arg_next,arg_next){ + NodeP call_node_p; + NodeIdP lhs_node_id_p,call_node_id_p; + + lhs_node_id_p=lhs_arg_p->arg_node->node_node_id; + + call_node_p=call_arg_p->arg_node; + if (call_node_p->node_kind==NodeIdNode) + call_node_id_p=call_node_p->node_node_id; + else { + NodeDefP new_node_def_p; + + call_node_id_p=NewNodeId (NULL); + call_node_id_p->nid_refcount=1; + call_node_id_p->nid_ref_count_copy_=1; + call_node_id_p->nid_exp_=NULL; + + call_node_id_p->nid_node=call_node_p; + + new_node_def_p = NewNodeDef (call_node_id_p,call_node_p); + new_node_def_p->def_next=*defs_p; + *defs_p=new_node_def_p; + } + + call_node_id_p->nid_mark &= ~SHARED_NODES_COLLECTED_MASK; + if (call_node_id_p->nid_refcount<0) + call_node_id_p->nid_refcount -= -2-lhs_node_id_p->nid_refcount; + else + call_node_id_p->nid_refcount += -2-lhs_node_id_p->nid_refcount; + + lhs_node_id_p->nid_forward_node_id=call_node_id_p; + } + + copy_rhs_node_defs_and_root (imp_rule_p->rule_alts,&new_root_node,defs_p); +/* + PrintRuleNode (new_root_node,False,StdOut); + FPrintF (StdOut,"\n"); + PrintNodeDefs (*defs_p,False,StdOut); + FPrintF (StdOut,"\n"); + FPrintF (StdOut,"\n"); +*/ + root_node=new_root_node; + *root_p=new_root_node; + + continue; + } + } + break; + } +#endif + + last=defs_p; + + last = CollectSharedNodeIdsInNode (root_p,NULL,last); + *last = NULL; + + AddStrictLhsNodeIdsToNodeDefs (strict_node_ids,defs_p); +} + +static void AnnotateStrictNodeIds (Node node,StrictNodeIdP strict_node_ids,NodeDefS **node_def_h) +{ + StrictNodeIdP strict_node_id; + + for_l (strict_node_id,strict_node_ids,snid_next){ + NodeId node_id; + + node_id=strict_node_id->snid_node_id; + +#ifdef OBSERVE_ARRAY_SELECTS_IN_PATTERN + if (strict_node_id->snid_array_select_in_pattern && node_id->nid_node->node_symbol->symb_kind==select_symb){ + NodeP array_uselect_node; + SymbDef uselect_sdef; + TypeArg *type_arg; + + array_uselect_node=node_id->nid_node->node_arguments->arg_node; + uselect_sdef=array_uselect_node->node_symbol->symb_def; + + if (uselect_sdef->sdef_kind==IMPRULE) + type_arg=uselect_sdef->sdef_rule->rule_type->type_alt_lhs->type_node_arguments; + else + type_arg=uselect_sdef->sdef_rule_type->rule_type_rule->type_alt_lhs->type_node_arguments; + + if (!type_arg->type_arg_node->type_node_is_var && + (type_arg->type_arg_node->type_node_symbol->symb_kind==strict_array_type || + type_arg->type_arg_node->type_node_symbol->symb_kind==unboxed_array_type) + ){ + node_id->nid_node->node_annotation=StrictAnnot; + } else { + NodeIdP uselect_node_id_p; + NodeDefP new_def; + + uselect_node_id_p=NewNodeId (NULL); + uselect_node_id_p->nid_refcount=1; + + node_id->nid_node->node_arguments->arg_node=NewNodeIdNode (uselect_node_id_p); + array_uselect_node->node_annotation=StrictAnnot; + + strict_node_id->snid_node_id=uselect_node_id_p; + + new_def = NewNodeDef (uselect_node_id_p,array_uselect_node); + uselect_node_id_p->nid_node=array_uselect_node; + new_def->def_next=*node_def_h; + *node_def_h=new_def; + node_def_h=&new_def->def_next; + } + } else +#endif + if (node_id->nid_refcount>0 && node_id->nid_node) + node_id->nid_node->node_annotation=StrictAnnot; + } + + if (node->node_kind==IfNode){ + ArgS *arg; + + arg=node->node_arguments; + AnnotateStrictNodeIds (arg->arg_node,NULL,NULL); + arg = arg->arg_next; + AnnotateStrictNodeIds (arg->arg_node,node->node_then_strict_node_ids,&node->node_then_node_defs); + arg = arg->arg_next; + AnnotateStrictNodeIds (arg->arg_node,node->node_else_strict_node_ids,&node->node_else_node_defs); + } +} + +static void DetermineSharedAndAnnotatedNodesOfRule (ImpRuleP rule) +{ + SymbDef rule_sdef; + + CurrentSymbol=rule->rule_root->node_symbol; + + rule_sdef=CurrentSymbol->symb_def; + + if (rule_sdef->sdef_over_arity==0){ + RuleAlts alt; + + for_l (alt,rule->rule_alts,alt_next) + if (alt->alt_kind==Contractum){ + CurrentLine = alt->alt_line; + + AnnotateStrictNodeIds (alt->alt_rhs_root,alt->alt_strict_node_ids,&alt->alt_rhs_defs); + + CollectSharedAndAnnotatedNodesInRhs (&alt->alt_rhs_root,&alt->alt_rhs_defs,alt->alt_strict_node_ids); + } + } +} + +static void reset_states_and_ref_count_copies_of_node_defs (NodeDefS *node_def); + +static void reset_states_and_ref_count_copies_of_node (Node node) +{ + if (node->node_kind==NodeIdNode){ + NodeId node_id; + + node_id=node->node_node_id; + + node_id->nid_ref_count_copy_=node_id->nid_refcount; +#if OPTIMIZE_LAZY_TUPLE_RECURSION + node_id->nid_mark2 &= ~NID_HAS_LAZY_SELECTOR_COUNTER; +#endif + } else { + DetermineNodeState (node); + + if (node->node_annotation==ParallelAtAnnot){ + Node at_node; + + at_node=get_p_at_node (node); + + reset_states_and_ref_count_copies_of_node (at_node); + } + + if (node->node_kind!=IfNode){ + ArgP arg; + + for_l (arg,node->node_arguments,arg_next){ + arg->arg_state=LazyState; + reset_states_and_ref_count_copies_of_node (arg->arg_node); + } + } else { + Args cond_arg,then_arg,else_arg; + + cond_arg=node->node_arguments; + then_arg=cond_arg->arg_next; + else_arg=then_arg->arg_next; + + cond_arg->arg_state=LazyState; + reset_states_and_ref_count_copies_of_node (cond_arg->arg_node); + + then_arg->arg_state=LazyState; + reset_states_and_ref_count_copies_of_node (then_arg->arg_node); + + else_arg->arg_state=LazyState; + reset_states_and_ref_count_copies_of_node (else_arg->arg_node); + + reset_states_and_ref_count_copies_of_node_defs (node->node_then_node_defs); + reset_states_and_ref_count_copies_of_node_defs (node->node_else_node_defs); + } + } +} + +static void reset_states_and_ref_count_copies_of_node_defs (NodeDefS *node_defs) +{ + NodeDefS *node_def; + + for_l (node_def,node_defs,def_next) + if (node_def->def_node!=NULL){ + node_def->def_id->nid_ref_count_copy_=node_def->def_id->nid_refcount; + node_def->def_id->nid_node_def_=node_def; + reset_states_and_ref_count_copies_of_node (node_def->def_node); + } +} + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +static void reset_states_and_ref_count_copies_of_root_node (NodeP node_p) +{ + if (node_p->node_kind==IfNode){ + Args cond_arg,then_arg,else_arg; + + DetermineNodeState (node_p); + + cond_arg=node_p->node_arguments; + then_arg=cond_arg->arg_next; + else_arg=then_arg->arg_next; + + cond_arg->arg_state=LazyState; + reset_states_and_ref_count_copies_of_root_node (cond_arg->arg_node); + + then_arg->arg_state=LazyState; + reset_states_and_ref_count_copies_of_root_node (then_arg->arg_node); + + else_arg->arg_state=LazyState; + reset_states_and_ref_count_copies_of_root_node (else_arg->arg_node); + + reset_states_and_ref_count_copies_of_node_defs (node_p->node_then_node_defs); + reset_states_and_ref_count_copies_of_node_defs (node_p->node_else_node_defs); + } else if (node_p->node_kind==SwitchNode){ + ArgP arg_p; + + for_l (arg_p,node_p->node_arguments,arg_next){ + NodeP node_p; + + node_p=arg_p->arg_node; + if (node_p->node_kind==CaseNode){ + NodeP case_alt_node_p; + + case_alt_node_p=node_p->node_arguments->arg_node; + if (case_alt_node_p->node_kind==PushNode){ + NodeIdListElementP node_id_list; + + for_l (node_id_list,case_alt_node_p->node_node_ids,nidl_next) + node_id_list->nidl_node_id->nid_ref_count_copy_=node_id_list->nidl_node_id->nid_refcount; + + case_alt_node_p=case_alt_node_p->node_arguments->arg_next->arg_node; + } + + reset_states_and_ref_count_copies_of_root_node (case_alt_node_p); + reset_states_and_ref_count_copies_of_node_defs (node_p->node_node_defs); + } else if (node_p->node_kind==DefaultNode){ + reset_states_and_ref_count_copies_of_root_node (node_p->node_arguments->arg_node); + reset_states_and_ref_count_copies_of_node_defs (node_p->node_node_defs); + } else + error_in_function ("reset_states_and_ref_count_copies_of_root_node"); + } + } else if (node_p->node_kind==GuardNode){ + reset_states_and_ref_count_copies_of_root_node (node_p->node_arguments->arg_node); + reset_states_and_ref_count_copies_of_root_node (node_p->node_arguments->arg_next->arg_node); + reset_states_and_ref_count_copies_of_node_defs (node_p->node_node_defs); + } else + reset_states_and_ref_count_copies_of_node (node_p); +} +#endif + +void reset_states_and_ref_count_copies (ImpRuleS *rule) +{ + SymbDef rule_sdef; + + CurrentSymbol=rule->rule_root->node_symbol; + + rule_sdef=CurrentSymbol->symb_def; + + if (rule_sdef->sdef_over_arity==0){ + RuleAlts alt; + + for_l (alt,rule->rule_alts,alt_next) + if (alt->alt_kind==Contractum){ + CurrentLine = alt->alt_line; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + reset_states_and_ref_count_copies_of_root_node (alt->alt_rhs_root); +#else + reset_states_and_ref_count_copies_of_node (alt->alt_rhs_root); +#endif + reset_states_and_ref_count_copies_of_node_defs (alt->alt_rhs_defs); + } + } +} + +void DetermineSharedAndAnnotatedNodes (ImpRules rules,SymbolP *im_symbols_h) +{ + ImpRuleP rule; + +#ifdef ADD_ARGUMENTS_TO_HIGHER_ORDER_FUNCTIONS + last_new_rule_with_more_arguments_h=&new_rules_with_more_arguments; +#endif + + for_l (rule,rules,rule_next) + DetermineSharedAndAnnotatedNodesOfRule (rule); + +#ifdef ADD_ARGUMENTS_TO_HIGHER_ORDER_FUNCTIONS + if (new_rules_with_more_arguments!=NULL){ + ImpRuleP *rule_h,new_rule_p; + + rule_h=&rules; + while (*rule_h!=NULL) + rule_h=&(*rule_h)->rule_next; + + while (*im_symbols_h) + im_symbols_h=&(*im_symbols_h)->symb_next; + + while (new_rules_with_more_arguments!=NULL){ + SymbolP new_symbol_p; + + new_rule_p=new_rules_with_more_arguments; + + DetermineSharedAndAnnotatedNodesOfRule (new_rule_p); + + new_rules_with_more_arguments=new_rule_p->rule_next; + + *rule_h=new_rule_p; + rule_h=&new_rule_p->rule_next; + + new_symbol_p=new_rule_p->rule_root->node_symbol; + *im_symbols_h=new_symbol_p; + im_symbols_h=&new_symbol_p->symb_next; + } + + *rule_h=NULL; + *im_symbols_h=NULL; + } +#endif +} + +void InitStatesGen (void) +{ + SetUnaryState (& StrictState, StrictOnA, UnknownObj); + SetUnaryState (& LazyState, OnA, UnknownObj); + + SetUnaryState (& BasicSymbolStates[int_type], OnB, IntObj); + SetUnaryState (& BasicSymbolStates[bool_type], OnB, BoolObj); + SetUnaryState (& BasicSymbolStates[char_type], OnB, CharObj); + SetUnaryState (& BasicSymbolStates[string_type], StrictOnA, StringObj); + SetUnaryState (& BasicSymbolStates[real_type], OnB, RealObj); + SetUnaryState (& BasicSymbolStates[file_type], OnB, FileObj); + SetUnaryState (& BasicSymbolStates[world_type], StrictOnA, WorldObj); + SetUnaryState (& BasicSymbolStates[procid_type], OnB, ProcIdObj); + SetUnaryState (& BasicSymbolStates[redid_type], OnB, RedIdObj); + SetUnaryState (& BasicSymbolStates[int_denot], OnB, IntObj); + SetUnaryState (& BasicSymbolStates[bool_denot], OnB, BoolObj); + SetUnaryState (& BasicSymbolStates[char_denot], OnB, CharObj); + SetUnboxedArrayState (& BasicSymbolStates[string_denot],&BasicSymbolStates[char_type]); + SetUnaryState (& BasicSymbolStates[real_denot], OnB, RealObj); + SetUnaryState (& BasicSymbolStates[array_type], StrictOnA, ArrayObj); + SetUnaryState (& BasicSymbolStates[strict_array_type], StrictOnA, StrictArrayObj); + SetUnaryState (& BasicSymbolStates[unboxed_array_type], StrictOnA, UnboxedArrayObj); + SetUnaryState (& BasicSymbolStates[fun_type], StrictOnA, UnknownObj); + SetUnaryState (& BasicSymbolStates[list_type], StrictOnA, ListObj); + SetUnaryState (& BasicSymbolStates[tuple_type], StrictOnA, TupleObj); +#ifdef CLEAN2 + SetUnaryState (& BasicSymbolStates[dynamic_type], StrictOnA, DynamicObj); +#endif +} diff --git a/backendC/CleanCompilerSources/statesgen.h b/backendC/CleanCompilerSources/statesgen.h new file mode 100644 index 0000000..63c6bdd --- /dev/null +++ b/backendC/CleanCompilerSources/statesgen.h @@ -0,0 +1,32 @@ + +#define DESTRUCTIVE_RECORD_UPDATES 1 +#define ADD_ARGUMENTS_TO_HIGHER_ORDER_FUNCTIONS + +#define IsLazyState(state) ((state).state_type==SimpleState && (state).state_kind>StrictOnA) +#define IsLazyStateKind(statekind) ((statekind)>StrictOnA) + +extern StateS BasicSymbolStates[],LazyState,StrictState; +extern int FirstStateIsStricter (StateS offered_state,StateS demanded_state); +extern int FieldArgumentNodeStatesAreStricter (ArgS *offered_args,ArgS *field_args,States record_states); +extern void ConvertAnnotationToState (Annotation annot, States state); +extern void SetUnaryState (States state, StateKind kind, ObjectKind object); +extern Bool HasExternalAnnot (Node node); +extern void GenerateStatesForRecords (Symbol symbs); +extern void InitStatesGen (void); +extern void GenerateStates (ImpRules rules); +extern void DetermineSharedAndAnnotatedNodes (ImpRules rules,SymbolP *im_symbols_h); +extern void DetermineStateOfArrayElem (Symbol elemtype, States state); +extern void ExamineTypesAndLhsOfSymbols (Symbol symbs); +extern void ImportSymbols (Symbol symbols); +extern void DetermineStatesOfRootNodeAndDefs (Node root_node,NodeDefs *rootdef,StateS demstate,int local_scope); + +extern unsigned next_def_number; + +extern void ExamineTypesAndLhsOfSymbolDefinition (SymbDef def); +extern void ExamineTypesAndLhsOfImpRuleSymbolDefinitionAgain (SymbDef def); +extern void GenerateStatesForRule (ImpRuleS *rule); +extern void reset_states_and_ref_count_copies (ImpRuleS *rule); +extern void DetermineNodeState (Node node); +extern void ConvertTypeToState (TypeNode type,States state,StateKind kind); + +extern int optimise_strict_tuple_result_functions; diff --git a/backendC/CleanCompilerSources/statesgen.print.c b/backendC/CleanCompilerSources/statesgen.print.c new file mode 100644 index 0000000..f167195 --- /dev/null +++ b/backendC/CleanCompilerSources/statesgen.print.c @@ -0,0 +1,165 @@ + +#define PrintAnnotation(annot) + +static void PrintUnaryState (StateKind kind, ObjectKind obj) +{ + switch (kind) + { case OnB: FPutS ("OnB ", StdError); break; + case OnA: FPutS ("OnA ", StdError); break; + case StrictOnA: FPutS ("StrictOnA ", StdError); break; + case SemiStrict: FPutS ("SemiStrict ", StdError); break; + case StrictRedirection: FPutS ("StrictRedirection ", StdError); break; + case Parallel: FPutS ("Parallel ", StdError); break; + case Undefined: FPutS ("Undefined ", StdError); break; + case UnderEval: FPutS ("UnderEval ", StdError); break; + } + switch (obj){ + case UnknownObj: FPutS ("???", StdError); break; + case IntObj: FPutS ("Int ", StdError); break; + case BoolObj: FPutS ("Bool ", StdError); break; + case CharObj: FPutS ("Char ", StdError); break; + case StringObj: FPutS ("String ", StdError); break; + case RealObj: FPutS ("Real ", StdError); break; + case FileObj: FPutS ("File ", StdError); break; + case TupleObj: FPutS ("Tuple ", StdError); break; + case ListObj: FPutS ("List ", StdError); break; + case ProcIdObj: FPutS ("ProcId ", StdError); break; + } +} /* PrintUnaryState */ + + +static void PrintState (State state) +{ + return; + if (ArityOfState (state) == 1) + PrintUnaryState (KindOfState(state),ObjectOfState(state)); +} /* PrintState */ + + +static void PrintNode (Node node, Bool brackets); + +static void PrintNodeId (NodeId nid, Node follow) +{ + if (nid) + { if (nid -> nid_name) + FPrintF (StdError, "%d.%s",nid->nid_refcount, nid -> nid_name -> Name); + else + FPrintF (StdError, "%d.sel%ld",nid->nid_refcount, (long) nid); + if (follow) + FPutC (':', StdError); + } +} /* PrintNodeId */ + +static void PrintArgument (Args arg, Bool brackets) +{ + PrintState (arg -> arg_state); + PrintNodeId (arg -> arg_id, arg -> arg_pattern); + if (arg -> arg_pattern) + PrintNode (arg -> arg_pattern, brackets); + +} /* PrintArgument */ + +static void PrintArguments (Args args, char separator, Bool brackets) +{ + if (args) + { PrintArgument (args, brackets); + for (args = args -> arg_next; args; args = args -> arg_next) + { FPutC (separator, StdError); + PrintArgument (args, brackets); + } + } +} /* PrintArguments */ + +static void PrintNodeDefs (NodeDefs defs, Bool brackets); + +static void PrintNode (Node node, Bool brackets) +{ + if (IsOnACycle (node -> node_number)) + FPutS ("<C>", StdError); + PrintState (node -> node_state); + if (node -> node_kind == NormalNodeKind) + { if (node->node_symbol -> symb_kind == tuple_denot) + { FPutC ('(', StdError); + PrintArguments (GetNodeArguments(node), ',', False); + FPutC (')', StdError); + } + else if (node->node_symbol -> symb_kind == list_type) + { FPutC ('[', StdError); + PrintArguments (GetNodeArguments(node), ',', False); + FPutC (']', StdError); + } + else + { if (brackets && GetNodeArguments(node)) + FPutC ('(', StdError); + FPutS (ConvertSymbolToString (node->node_symbol), StdError); + if (GetNodeArguments(node)) + { FPutC (' ', StdError); + PrintArguments (GetNodeArguments(node),' ', True); + if (brackets) + FPutC (')', StdError); + } + } + } + else + { Args elsepart, thenpart, condpart = GetIfArguments(node); + thenpart = condpart -> arg_next; + elsepart = thenpart -> arg_next; + if (brackets) + FPutC ('(', StdError); + FPutS ("IF ", StdError); + PrintArgument (condpart, True); + FPutC ('\n', StdError); + FPutS ("THEN ", StdError); + PrintArgument (thenpart, True); + if (node->node_then_node_defs) + { FPutS ("[", StdError); + PrintNodeDefs (node->node_then_node_defs, False); + FPutS ("]\nELSE ", StdError); + } + else + FPutS ("\nELSE ", StdError); + PrintArgument (elsepart, True); + if (GetElseShared(node)) + { FPutS ("[\n", StdError); + PrintNodeDefs (GetElseShared(node), False); + FPutS ("]\n", StdError); + } + if (brackets) + FPutC (')', StdError); + } + +} /* PrintNode */ + +static void PrintNodeDefs (NodeDefs defs, Bool brackets) +{ + for ( ; defs; defs = defs -> def_next) + { FPrintF (StdError, "%d: ", (int) defs->def_number); + PrintNodeId (defs -> def_id, defs -> def_node); + if (defs -> def_node) + PrintNode (defs -> def_node, False); + FPutS ("\n", StdError); + } + +} /* PrintNodeDefs */ + +static void PrintRuleAlt (RuleAlts rulealt) +{ + PrintNode (rulealt -> alt_lhs -> def_node, False); + FPutS (" -> ", StdError); + if (rulealt -> alt_kind == Contractum) + PrintNodeDefs (rulealt -> alt_rhs.alt_rhs_graph, False); + else + FPutS (rulealt -> alt_rhs.alt_rhs_root -> redir_id -> nid_name -> Name, + StdError); + FPutS (";\n", StdError); + +} /* PrintRuleAlt */ + +static void PrintRule (Rule rule) +{ + RuleAlts rulealt = rule -> rule_alts; + + for (; rulealt; rulealt = rulealt -> alt_next); + PrintRuleAlt (rulealt); + +} /* PrintRule */ diff --git a/backendC/CleanCompilerSources/syntax_tree_types.h b/backendC/CleanCompilerSources/syntax_tree_types.h new file mode 100644 index 0000000..ded1bf9 --- /dev/null +++ b/backendC/CleanCompilerSources/syntax_tree_types.h @@ -0,0 +1,547 @@ +/* + Version 1.2 17 dec1996 +*/ + +#define BASIC_TYPE_IDS_STRING "ibcrfswpvr" /* indexed by SymbKind */ + +#define Type_Variable_Mark (1 << Nr_Of_Basic_Types) + +typedef enum +{ NoUniAttr, NotUniqueAttr, UniqueAttr, ExistsAttr, UniqueVariable, FirstUniVarNumber +} UniquenessAttributeKind; + +typedef unsigned AttributeKind; + +typedef struct poly_list +{ void * pl_elem; + struct poly_list * pl_next; +} * PolyList; + +typedef struct export_list +{ + union + { IdentStringP exp_u_ident_string; + struct symbol_def * exp_u_class; + } exp_union; + + unsigned long exp_type_vector; + unsigned exp_line; + struct export_list * exp_next; +} *ExportList; + +#define exp_class exp_union.exp_u_class +#define exp_ident exp_union.exp_u_ident_string + +typedef struct type_arg * TypeArgs, TypeArg; +typedef struct type_node * TypeNode; +typedef struct type_alt * TypeAlts; + +typedef struct +{ BITVECT tac_uniprop; + BITVECT tac_possign; + BITVECT tac_negsign; +} TypeArgClass; + +#define type_uniprop type_argclass.tac_uniprop +#define type_possign type_argclass.tac_possign +#define type_negsign type_argclass.tac_negsign + +typedef struct type_var *TypeVar; + +typedef struct type_var_list +{ + TypeVar tvl_elem; + struct type_var_list * tvl_next; + AttributeKind tvl_attribute; + Bool tvl_exist_quant:1; + Bool tvl_cons_variable:1; + +} * TypeVarList; + +typedef struct flat_type +{ + Symbol ft_symbol; + TypeVarList ft_arguments; + TypeVarList ft_exist_quant_arguments; + + struct cons_var_list * ft_cons_vars; + struct uni_var_admin * ft_attr_vars; + + AttributeKind ft_attribute; + int ft_arity; + int ft_exist_arity; + +} * FlatType; + +typedef enum { SLK_Symbol, SLK_TreeOfLists, SLK_ListNumber } SymbolListKind; + +STRUCT (symbol_list, SymbolList) +{ + union + { struct symbol_def * sl_u_symbol; + IdentStringP sl_u_ident_string; + struct symbol_list * sl_u_next_tree; + int sl_u_class_number; + } sl_union; + + struct symbol_list * sl_next; + + SymbolListKind sl_kind; + +}; + +#define sl_symbol sl_union.sl_u_symbol +#define sl_ident_string sl_union.sl_u_ident_string +#define sl_next_tree sl_union.sl_u_next_tree +#define sl_class_number sl_union.sl_u_class_number + +STRUCT (type_context, TypeContext) +{ + SymbolList tyco_symbols; + +#ifdef SHORT_CLASS_NAMES + int tyco_number; +#endif + TypeVar tyco_variable; + +/* + AttributeKind tyco_attribute; +*/ + unsigned long tyco_basic_instances; + struct type_context * tyco_next; + +}; + +typedef struct _instance +{ + Symbol ins_overloaded_symbol; + Symbol ins_symbol; + + TypeNode ins_type; + TypeContext ins_type_context; + + struct type_alt * ins_type_alt; + struct type_cell * ins_over_vars; + + union /* struct */ + { struct type_cell * u1_ins_type_cell; + struct _instance * u1_ins_next; + } ins_union1; + + union + { ImpRules u2_ins_imprule; + RuleTypes u2_ins_defrule; + } ins_union2; + + int ins_context_arity; + unsigned ins_line; + Bool ins_exported:1; + Bool ins_unq_attributed:1; + Bool ins_is_default:1; + unsigned ins_kind:5; + +} * Instance; + +#define ins_type_cell ins_union1.u1_ins_type_cell +#define ins_next ins_union1.u1_ins_next +#define ins_imprule ins_union2.u2_ins_imprule +#define ins_defrule ins_union2.u2_ins_defrule + +/* + +typedef struct type_list +{ + TypeNode tl_type; + TypeContext tl_type_context; + Bool tl_is_default; + struct type_list * tl_next; +} *TypeList; + +typedef struct dcl_instance +{ + IdentStringP di_symbol; + TypeList di_types; + unsigned di_line; + struct dcl_instance * di_next; + +} * DclInstance; + +typedef struct icl_instance +{ + IdentStringP ii_symbol; + TypeNode ii_type; + TypeContext ii_type_context; + PolyList ii_instances; + unsigned ii_line; + Bool ii_is_default; + struct icl_instance * ii_next; + +} * IclInstance; + +*/ + +typedef struct overloaded +{ + Symbol ol_symbol; + TypeVar ol_type_var; + TypeAlts ol_type; + +/* + Instance ol_instances; + Instance ol_generic_instance; +*/ + unsigned long ol_basic_instances; + struct overloaded * ol_next; + struct class_def * ol_class; + + AttributeKind ol_attribute; + AttributeKind ol_next_attribute; + + unsigned ol_line; + unsigned ol_number; + Bool ol_has_default_instance; + +} * Overloaded; + +typedef struct field_list +{ + Symbol fl_symbol; + TypeNode fl_type; + StateS fl_state; + struct field_list * fl_next; +} * FieldList; + +typedef struct member_list +{ + Symbol ml_symbol; + Overloaded ml_rule; + struct member_list *ml_next; +} * MemberList; + +typedef struct constructor_list +{ + TypeNode cl_constructor; + FieldList cl_fields; + StateP cl_state_p; /* for constructors, union met cl_fields ? */ + TypeVarList cl_exist_quant_typevars; + struct constructor_list * cl_next; + +} * ConstructorList; + +typedef struct type +{ + FlatType type_lhs; + ConstructorList type_constructors; + struct type * type_next; + unsigned type_line; + int type_nr_of_constructors; /* 0 for records */ + int type_number; + TypeArgClass type_argclass; + + BITVECT type_exivars; + BITVECT type_univars; + BITVECT type_consvars; + +} * Types; + +#define type_fields type_constructors -> cl_fields +#define type_symbol type_lhs -> ft_symbol + +typedef struct class_instance +{ + union + { IdentStringP ci_u1_ident_string; + Symbol ci_u1_class_symbol; + } ci_union1; + + Symbol ci_instance_symbol; + TypeNode ci_type; + TypeContext ci_type_context; + struct uni_var_admin * ci_attr_vars; + + union + { struct class_instance * ci_u3_link; + struct type_cell * ci_u3_type_cell; + } ci_union3; + + struct type_cell ** ci_over_vars; + + union + { Instance ci_u2_member_instance_list; + Instance * ci_u2_member_instances; + } ci_union2; + + int ci_context_arity; + + struct class_instance * ci_next; + + unsigned ci_line; + Bool ci_is_default:1; + Bool ci_is_imported:1; + Bool ci_is_member_instance_list:1; + unsigned ci_kind:5; + +} * ClassInstance; + +#define ci_class_symbol ci_union1.ci_u1_class_symbol +#define ci_ident_string ci_union1.ci_u1_ident_string +#define ci_member_instance_list ci_union2.ci_u2_member_instance_list +#define ci_member_instances ci_union2.ci_u2_member_instances +#define ci_link ci_union3.ci_u3_link +#define ci_type_cell ci_union3.ci_u3_type_cell + +typedef struct class_def +{ + Symbol cd_symbol; + TypeVar cd_variable; + + AttributeKind cd_attribute; + + TypeContext cd_context; + + union + { MemberList cd_u_all_members; + Overloaded * cd_u_members; + } cd_union; + + MemberList cd_derived_members; + + SymbolList cd_context_classes; + + ClassInstance cd_instances; + ClassInstance cd_generic_instance; + + unsigned long cd_imported_basic_instances; + unsigned long cd_defined_basic_instances; + + struct class_def * cd_next; + unsigned cd_line; + unsigned cd_nr_of_members; + + Bool cd_has_default_instance:1; + Bool cd_internal:1; + Bool cd_is_member_list:1; + +} * ClassDefinition; + +#define cd_all_members cd_union.cd_u_all_members +#define cd_members cd_union.cd_u_members + +struct rule_type +{ TypeAlts rule_type_rule; + StateP rule_type_state_p; + TypeNode rule_type_root; + struct rule_type * rule_type_next; + unsigned rule_type_line; +}; + +typedef struct syn_type SynType,*SynTypes; + +struct syn_type +{ FlatType syn_lhs; + TypeNode syn_rhs; + TypeVarList syn_exist_quant_typevars; + struct syn_type * syn_next; + TypeArgClass syn_argclass; + + BITVECT syn_univars; + BITVECT syn_consvars; + + unsigned syn_line; +}; + +#define syntype_uniprop syn_argclass.tac_uniprop +#define syntype_possign syn_argclass.tac_possign +#define syntype_negsign syn_argclass.tac_negsign + +#define syntype_exivars syn_exivars +#define syntype_univars syn_univars + +#define syntype_symbol syn_lhs -> ft_symbol + +typedef struct abs_type +{ FlatType abs_graph; + struct symbol_def * abs_impl; + struct abs_type * abs_next; + TypeArgClass abs_argclass; + BITVECT abs_exivars; + BITVECT abs_univars; + unsigned abs_line; + int abs_number; +} *AbsTypes; + +#define abstype_uniprop abs_argclass.tac_uniprop +#define abstype_possign abs_argclass.tac_possign +#define abstype_negsign abs_argclass.tac_negsign + +#define abstype_exivars abs_exivars +#define abstype_univars abs_univars + +#define abstype_symbol abs_graph -> ft_symbol + +#ifdef THINK_C +#define DTypeNodeKind(v) \ + (v==VariableTypeNode?"VariableTypeNode": \ + v==NormalTypeNode?"NormalTypeNode": \ + v==SelectorTypeNode?"SelectorTypeNode":"") +#endif + +struct type_node +{ + union + { TypeVar contents_tv; + Symbol contents_symbol; + } type_node_contents; + + struct type_arg * type_node_arguments; +#if 0 + StateS type_node_state; +#endif + AttributeKind type_node_attribute; + short type_node_arity; + Annotation type_node_annotation; + unsigned char type_node_is_var:1; +}; + +#define type_node_symbol type_node_contents.contents_symbol +#define type_node_tv type_node_contents.contents_tv + +struct type_arg +{ TypeNode type_arg_node; + TypeArgs type_arg_next; +}; + +typedef struct attr_kind_list +{ AttributeKind akl_elem; + struct uni_var * akl_id; + struct attr_kind_list * akl_next; +} * AttributeKindList; + +typedef struct uni_var_equats +{ AttributeKind uve_demanded; + struct uni_var * uve_demanded_var; + AttributeKindList uve_offered; + struct uni_var_equats * uve_next; +} * UniVarEquations; + +typedef struct type_alt +{ + TypeNode type_alt_lhs; + TypeNode type_alt_rhs; + UniVarEquations type_alt_attr_equations; + TypeContext type_alt_type_context; + + struct uni_var_admin * type_alt_attr_vars; + + unsigned type_alt_line; +} TypeAlt; + +typedef struct cons_var_list +{ + TypeVar cvl_nodeid; + TypeArgClass * cvl_argclass; + struct cons_var_list * cvl_next; + int cvl_number; + int cvl_arity; + +} * ConsVarList; + +struct type_var +{ + Ident tv_ident; + unsigned short tv_mark; + int tv_refcount; + int tv_number; + int tv_argument_nr; + int tv_overvar_arity; + union + { TypeVar u1_imp_tv; + TypeNode u1_subst_type; + struct cons_var_list * u1_cons_var_info; + } tv_u1; + union + { TypeVar u2_forward_tv; + struct type_cell * u2_type; + TypeNode u2_type_node; + struct type_context * u2_context; + PolyList u2_formal_type_vars; + } tv_u2; +}; + +#define tv_type tv_u2.u2_type /* comparser,typechecker */ +#define tv_type_node tv_u2.u2_type_node /* typeconv */ +#define tv_forward_tv tv_u2.u2_forward_tv /* checker,transform */ +#define tv_type_context tv_u2.u2_context /* checktypedefs */ +#define tv_formal_type_vars tv_u2.u2_formal_type_vars/* checktypedefs */ + +#define tv_imp_tv tv_u1.u1_imp_tv +#define tv_subst_type tv_u1.u1_subst_type /* checktypedefs */ +#define tv_cons_var_info tv_u1.u1_cons_var_info /* checktypedefs */ +#define tv_imp_tv tv_u1.u1_imp_tv /* checktypedefs */ + +#define TestMark(n,f,mask) (((n)->f & (mask)) != 0) +#define SetMark(n,f,mask) ((n)->f |= (mask)) +#define ClearMark(n,f,mask) ((n)->f &= ~(mask)) + +#define TV_INSTANTIATION_MASK (1 << 0) /* checktypedefs */ +#define TV_VERIFY_MASK (1 << 1) /* checktypedefs */ +#define TV_CONVERSION_MASK (1 << 2) /* typeconv */ +#define TV_EXISTENTIAL_ATTRIBUTE_MASK (1 << 3) /* checktypedefs, typeconv */ +#define TV_RHS_EXISTENTIAL_MASK (1 << 4) /* checktypedefs */ +#define TV_CONSTRUCTOR_VARIABLE_MASK (1 << 5) /* checktypedefs */ +#define TV_OVERLOADED_VARIABLE_MASK (1 << 6) /* comparser */ +#define TV_INIT_MASK (1 << 7) /* checktypedefs */ +#define TV_DUPLICATED (1 << 8) /* checktypedefs */ +#define TV_UNIQUE_MASK (1 << 9) /* checktypedefs */ +#define TV_CLASS_VARIABLE_MASK (1 << 10) /* checktypedefs */ +#define TV_CONS_VAR_WITH_ARGS (1 << 11) /* checktypedefs */ +#define TV_UNIQUE_VARIABLE_PRINT_MASK (1 << 12) /* typeconv */ +#define TV_NO_CONTEXT_VARIABLE_MASK (1 << 13) /* checktypedefs */ +#define TV_WITH_INST_RESTR (1 << 14) /* checktypedefs */ +#define TV_HAS_INST_MASK (1 << 15) /* checktypedefs */ + +typedef struct uni_var +{ + Ident uv_ident; + unsigned short uv_mark; + int uv_number; + struct uni_var * uv_next_uni_var; + UniVarEquations uv_equations; + +} * UniVar; + +#define UV_INSTANTIATION_MASK (1 << 0) /* checktypedefs */ +#define UV_CYCLE_MASK (1 << 1) /* checktypedefs */ +#define UV_CHECKED_MASK (1 << 2) /* checktypedefs */ + +typedef struct uni_var_admin +{ unsigned uva_next_number; + UniVar uva_list; + +} * UniVarAdministration; + +#ifdef SHORT_CLASS_NAMES +STRUCT (module_info, ModuleInfo) +{ + Symbol mi_module_symbol; + struct class_conversion_table * mi_class_table; + int mi_next_class_number; + struct type_conversion_table * mi_type_table; + int mi_next_type_number; +}; + +STRUCT (class_conversion_table, ClassConversionTable) +{ int cct_number; + SymbolList cct_symbols; + struct class_conversion_table * cct_next; +}; + +STRUCT (type_conversion_table, TypeConversionTable) +{ int tct_number; + struct symbol_def * tct_type_symbol; + struct type_conversion_table * tct_next; +}; + +#endif + + diff --git a/backendC/CleanCompilerSources/syntaxtr.t b/backendC/CleanCompilerSources/syntaxtr.t new file mode 100644 index 0000000..aa337bd --- /dev/null +++ b/backendC/CleanCompilerSources/syntaxtr.t @@ -0,0 +1,1134 @@ +/* + Version 1.1 23-1-1996 +*/ + +#include "compiledefines.h" + +#define D 0 + +#define class class_is_keyword +#define new new_is_keyword + +#define STRUCT(struct_name,type_name) \ + typedef struct struct_name type_name##S; \ + typedef struct struct_name *type_name; \ + typedef struct struct_name *type_name##P; \ + struct struct_name + +typedef unsigned long BITVECT; + +typedef enum +{ NoAttr, DeferAttr, CopyAttr +} GraphAttributeKind; + +typedef enum +{ NotUsed, UniquelyUsed, SelectivelyUsed, MultiplyUsed, ObservinglyUsed +} OccurrenceKind; + +typedef enum { + TupleState, ArrayState, RecordState, SimpleState +} StateType; + +/* the order of the StateKinds is used by IsLazyState and ExpectsResultNode */ +typedef enum { + OnB, LazyRedirection, StrictRedirection, /* strict states, no result node */ + StrictOnA, /* strict state, result node */ + OnA, SemiStrict, Parallel, Undefined, UnderEval /* lazy states, result node */ +} StateKind; + +typedef enum { + UnknownObj, +#if ABSTRACT_OBJECT + AbstractObj, +#endif + IntObj, BoolObj, CharObj, RealObj, FileObj, StringObj, + TupleObj, ListObj, RecordObj, ArrayObj, StrictArrayObj, UnboxedArrayObj, + WorldObj, ProcIdObj, RedIdObj +#ifdef CLEAN2 + ,DynamicObj +#endif + , NrOfObjects +} ObjectKind; + +#if ABSTRACT_OBJECT +# define BASIC_ELEMS_STRING "uuibcrfsaaaaaaippa" /* index by ObjectKind */ +#else +# define BASIC_ELEMS_STRING "uibcrfsaaaaaaippa" /* index by ObjectKind */ +#endif + +typedef enum { + int_type, bool_type, char_type, real_type, + file_type, string_type,world_type, procid_type, + redid_type, + Nr_Of_Basic_Types, + int_denot, bool_denot, char_denot, real_denot, + Nr_Of_Basic_Denots, + string_denot, + fun_type, array_type, strict_array_type, unboxed_array_type, list_type, tuple_type, empty_type, +#ifdef CLEAN2 + dynamic_type, +#endif + Nr_Of_Predef_Types, + tuple_symb, cons_symb, nil_symb, + apply_symb, if_symb, fail_symb, all_symb, + select_symb, + Nr_Of_Predef_FunsOrConses, + definition, newsymbol, instance_symb, empty_symbol, field_symbol_list, + erroneous_symb +} SymbKind; + +#ifdef THINK_C +#define DSymbKind(v) ( \ + v==definition?"definition": \ + v==int_denot?"int_denot": \ + v==tuple_symb?"tuple_symb": \ + v==cons_symb?"cons_symb": \ + v==nil_symb?"nil_symb": \ + v==select_symb?"select_symb": \ + v==apply_symb?"apply_symb": \ + v==if_symb?"if_symb": \ + v==newsymbol?"newsymbol": \ + v==emptysymbol?"emptysymbol": \ + v==field_symbol_list?"field_symbol_list": \ + "") +#endif + +#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 */ + struct record_state_descr * sd_rs; /* for RecordState */ + unsigned long sd_unq_type_args; /* for SimpleState with STATE_UNIQUE_TYPE_ARGUMENTS_MASK */ + } state_descr; + short state_arity; + unsigned char state_kind:4; /* StateKind, for SimpleState */ + unsigned char state_mark:4; + unsigned char state_object:6; /* ObjectKind, for SimpleState */ + unsigned char state_type:2; /* StateType */ +}; + +#define state_unq_type_args state_descr.sd_unq_type_args + +#define STATE_UNIQUE_TYPE_ARGUMENTS_MASK 8 + +# define state_record_symbol state_descr.sd_rs->rs_symb +# define state_record_arguments state_descr.sd_rs->rs_args +# 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; + +#define STATE_PARALLEL_MASK 1 +#define STATE_UNBOXED_ARRAY_MASK 2 /* for ArrayState */ +#define STATE_ELEMENTS_UPDATEABLE_MASK 2 /* for TupleState */ +#define STATE_UNIQUE_MASK 4 + +typedef struct record_state_descr { + struct symbol_def * rs_symb; + StateS rs_args[1]; +} *RecordStateDescr; + +typedef enum { + SymbolIdTable, TypeSymbolIdTable, TypeVarIdTable, ModuleIdTable, FieldIdTable, KeyWordTable, InternalIdTable +} TableKind; + +typedef union symb_value { + struct ident * val_ident; + struct symbol_def * val_def; + char * val_int; + Bool val_bool; + char * val_char; + char * val_string; + char * val_real; + char * val_error_mess; + int val_arity; + 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; +} SymbValue; + +STRUCT (symbol,Symbol) { + SymbValue symb_val; + Symbol symb_next; + unsigned symb_kind:8; /* SymbKind */ + Bool symb_infix:1; + unsigned symb_infix_priority:4; + unsigned symb_infix_assoc:2; /* Assoc */ +}; + +#define symb_ident symb_val.val_ident +#define symb_def symb_val.val_def +#define symb_int symb_val.val_int +#define symb_bool symb_val.val_bool +#define symb_char symb_val.val_char +#define symb_string symb_val.val_string +#define symb_real symb_val.val_real +#define symb_arity symb_val.val_arity +#define symb_type symb_val.val_type +#define symb_arrfun symb_val.val_arrfun +#define symb_symb symb_val.val_symb +#define symb_instance symb_val.val_instance + +#define symb_member symb_val.val_member +#define symb_error_mess symb_val.val_error_mess + +STRUCT(ident,Ident){ + char * ident_name; + char * ident_environ; + union{ + Symbol ident_u1_symbol; + struct node_id * ident_u1_nodeid; + struct type_var * ident_u1_tv; + struct uni_var * ident_u1_uni_var; + char * ident_u1_instructions; + } ident_union1; + +#ifdef SHORT_CLASS_NAMES + union{ + struct local_def * ident_u2_local_defs; + struct module_info * ident_u2_mod_info; + } ident_union2; +#else + struct local_def * ident_local_defs; +#endif + + struct ident * ident_next; + unsigned char ident_table; /* TableKind */ + unsigned char ident_mark; +}; + +#define ident_symbol ident_union1.ident_u1_symbol +#define ident_nodeid ident_union1.ident_u1_nodeid +#define ident_tv ident_union1.ident_u1_tv +#define ident_uni_var ident_union1.ident_u1_uni_var +#define ident_instructions ident_union1.ident_u1_instructions + +#ifdef SHORT_CLASS_NAMES +#define ident_local_defs ident_union2.ident_u2_local_defs +#define ident_mod_info ident_union2.ident_u2_mod_info +#endif + +#define IMPORT_MASK 1 +#define IMPORTED_MASK 2 +#define BOUND_MASK 4 +#define INLINE_MASK 8 +#define IMPLICITLY_IMPORTED_MASK 16 +#define ID_UNIVAR_MASK (1 << 5) +#define ID_TYPEVAR_MASK (1 << 6) +#define ID_CLASSVAR_MASK (1 << 7) + +/* + The order in which the annotationkinds appear in the enum type + determines their priority +*/ + +typedef enum { + NoAnnot, StrictAnnot, + /* parallel annotations: */ + ContinueAnnot, ParallelAnnot, + LazyParallelAnnot, InterleavedAnnot, LazyInterleavedAnnot, + ProcessAnnot,ParallelAtAnnot, DeferAnnot, ContInterleavedAnnot, WaitAnnot, + ParallelNFAnnot, InterleavedNFAnnot +} Annotation; + +typedef enum { AssocNone=0, AssocLeft=1, AssocRight=2 } Assoc; + +typedef struct ident_string *IdentStringP; + +struct ident_string { + IdentStringP left; + IdentStringP right; + Ident ident; + char *string; +}; + +typedef struct symb_list SymbElem,*SymbList; + +struct symb_list { + IdentStringP slist_ident_string; + SymbList slist_next; + unsigned slist_line; +}; + +typedef struct def_repr DefRepr,*DefMod; + +typedef struct import_list ImportElem,*ImportList; + +struct import_list { + Symbol ilist_module; + Bool ilist_all; + unsigned ilist_line; + SymbList ilist_symbs; + DefMod ilist_def; + ImportList ilist_next; +}; + +typedef struct node_def *NodeDefs; + +typedef struct { + short index_a; + short index_b; +} Index; + +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; + unsigned short nid_mark2; + int nid_refcount; + int nid_number; + union { + struct node_id * inf2_forward_node_id; + struct type_cell * inf2_type; + Index inf2_index; + int inf2_lazy_selector_ref_count; + } nid_inf2; + union { + struct { + union { + struct node * u1_subst_node; + struct node_id * u1_subst_node_id; + struct reference_info * u1_ref_info; +/* NodeDefs u1_nodedef; */ + } s_u1; + int s_ref_count_copy; + } inf1_s; + StateS inf1_state; + } nid_inf1; + int nid_scope; + struct node * nid_node; + union { + struct _exp * u3_exp; + struct node_id* u3_lhs_tuple_node_id; + struct node_id_ref_count_list * u3_ref_count_element; /* pattern_match: graph */ + } nid_u3; + union { + NodeDefs u4_node_def; /* only for rhs */ + struct state * u4_lhs_state_p; /* only for lhs */ + } nid_u4; +}; + +#define nid_subst_node nid_inf1.inf1_s.s_u1.u1_subst_node /* macros */ +#define nid_subst_node_id nid_inf1.inf1_s.s_u1.u1_subst_node_id /* macros */ +#define nid_reference_info nid_inf1.inf1_s.s_u1.u1_ref_info /* refcountanal */ +/* #define nid_node_def nid_inf1.inf1_s.s_u1.u1_nodedef ** buildtree,sa,statesgen,optimisations */ +#define nid_ref_count_copy nid_inf1.inf1_s.s_ref_count_copy /* statesgen */ +#define nid_state nid_inf1.inf1_state /* codegen2,instructions */ + +#define nid_type nid_inf2.inf2_type /* comparser,typechecker */ +#define nid_forward_node_id nid_inf2.inf2_forward_node_id /* checker,transform */ +#define nid_node_id_ref_count_element nid_u3.u3_ref_count_element /* pattern_match */ +#define nid_node_id_ref_count_element_ nid_u3.u3_ref_count_element /* pattern_match */ +#define nid_a_index nid_inf2.inf2_index.index_a /* codegen2,instructions */ +#define nid_b_index nid_inf2.inf2_index.index_b /* codegen2,instructions */ + +#define nid_lazy_selector_ref_count nid_inf2.inf2_lazy_selector_ref_count/* statesgen */ + +#define nid_type_ nid_inf2.inf2_type /* comparser,typechecker */ +#define nid_forward_node_id_ nid_inf2.inf2_forward_node_id /* checker,transform */ +#define nid_a_index_ nid_inf2.inf2_index.index_a /* codegen2,instructions */ +#define nid_b_index_ nid_inf2.inf2_index.index_b /* codegen2,instructions */ + +#define nid_exp nid_u3.u3_exp /* sa */ +#define nid_lhs_tuple_node_id nid_u3.u3_lhs_tuple_node_id + +#define nid_node_def nid_u4.u4_node_def /* buildtree,sa,statesgen,optimisations */ +#define nid_lhs_state_p nid_u4.u4_lhs_state_p + +#define nid_ref_count_copy_ nid_ref_count_copy +#define nid_ref_count_copy__ nid_ref_count_copy +#define nid_node_def_ nid_node_def +#define nid_state_ nid_state +#define nid_state__ nid_state +#define nid_lhs_tuple_node_id_ nid_lhs_tuple_node_id +#define nid_subst_node_ nid_subst_node +#define nid_subst_node_id_ nid_subst_node_id +#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 */ + +#define SHARED_NODES_COLLECTED_MASK 1 +#define NID_ALIAS_MASK 2 +#define NID_ALIAS_MARK_MASK 4 +#define NID_COUNTED_AND_USED_IN_INNER_SCOPE 8 +#define NID_EXTRA_REFCOUNT_MASK 16 +#define COPY_NODE_MASK 64 +#define ON_A_CYCLE_MASK 128 +#define NID_VERIFY_MASK 256 /* macros */ +#define NID_THEN_ELSE_NON_LOCAL_NODE_ID 512 /* pattern_match */ + +#define NID_TYPE_CHECKED_MASK 1024 /* typechecker */ +#define NID_TYPE_ATTRIBUTED_MASK 2048 /* typechecker */ +#define NID_EXTRA_REFCOUNT_SUBTRACTED_MASK 4096 /* checker */ + +#define NID_STRICT_LHS_TUPLE_ELEMENT_MASK 8192 /* codegen1,codegen2 */ +#define NID_SHARED_SELECTION_NODE_ID 16384 +#define NID_LIFTED_BY_OPTIMISE 32768 /* optimisations */ + +/* Masks for nid_mark2 */ + +#define NID_HAS_REF_COUNT_INFO_MASK (1 << 0) /* refcountanal */ +#define NID_DETERMINE_REF_COUNT_MASK (1 << 1) /* refcountanal */ +#define NID_REF_COUNT_DETERMINED_MASK (1 << 2) /* refcountanal */ +#define NID_LHS_ROOT_ID (1 << 3) /* refcountanal */ +#define NID_READ_ONLY_ID (1 << 4) /* typechecker */ +#define NID_FIELD_NAME_MASK (1 << 5) /* typechecker */ + +#define NID_COMPONENT_DETERMINED_MASK 256 /* optimise_lambda */ +#define NID_LIFTED_CONSTANT_CHECKED_MASK 512 /* checker */ +#define NID_LIFTED_MASK 1024 /* checker */ +#define NID_REFERENCE_NOT_COUNTED_MASK 2048 /* checker */ +#define NID_LHS_PUSHED 4096 /* codegen1 */ + +#define NID_HAS_LAZY_SELECTOR_COUNTER 8192 /* statesgen */ +#define NID_CALL_VIA_LAZY_SELECTIONS_ONLY 16384 /* statesgen */ +#define NID_HAS_REFCOUNT_WITHOUT_UPDATES 32768 + +typedef struct imp_rule *ImpRules; +typedef struct rule_type *RuleTypes; + +STRUCT (strict_node_id,StrictNodeId){ + union { + NodeId val_node_id; /* if snid_kind==0 */ + Ident val_ident; /* if snid_kind==1 */ + } snid_val; + struct strict_node_id * snid_next; + unsigned snid_mark:8; +#ifdef OBSERVE_ARRAY_SELECTS_IN_PATTERN + unsigned snid_array_select_in_pattern:1; +#endif +}; + +#define STRICT_NODE_ID_IDENT_MASK 1 +#define STRICT_NODE_ID_OBSERVE_MASK 2 + +#define snid_node_id snid_val.val_node_id +#define snid_ident snid_val.val_ident + +STRUCT (if_node_contents,IfNodeContents){ + NodeDefs if_then_node_defs; + ImpRules if_then_rules; + union { + StrictNodeIdP u_strict_node_ids; + struct poly_list * u_observer_list; + struct node_id_ref_count_list * u_node_id_ref_counts; + } if_then_u; + NodeDefs if_else_node_defs; + ImpRules if_else_rules; + union { + StrictNodeIdP u_strict_node_ids; + struct poly_list * u_observer_list; + struct node_id_ref_count_list * u_node_id_ref_counts; + } if_else_u; + int if_local_scope; +}; + +#define if_then_strict_node_ids if_then_u.u_strict_node_ids +#define if_else_strict_node_ids if_else_u.u_strict_node_ids +#define if_then_observer_list if_then_u.u_observer_list +#define if_else_observer_list if_else_u.u_observer_list +#define node_then_node_id_ref_counts node_contents.contents_if->if_then_u.u_node_id_ref_counts +#define node_else_node_id_ref_counts node_contents.contents_if->if_else_u.u_node_id_ref_counts + +typedef enum { + IfNode, NormalNode, SelectorNode, NodeIdNode, UpdateNode, MatchNode, /* normal nodes */ + RecordNode, IdentNode, ApplyNode, PrefixNode, ScopeNode, /* nodes in parser and checker */ + IndirectionNode, /* nodes in optimise_lambda */ + OverloadedNode, RecursionNode, UpdateNodeInTC, /* nodes in typechecker */ + SwitchNode, CaseNode, DefaultNode, PushNode, GuardNode, TupleSelectorsNode, FillUniqueNode /* nodes in codegen */ +} NodeKind; + +#ifdef THINK_C +#define DNodeKind(v) ( \ + v==IfNode?"IfNode": \ + v==NormalNode?"NormalNode": \ + v==SelectorNode?"SelectorNode": \ + v==NodeIdNode?"NodeIdNode": \ + v==RecordNode?"RecordNode": \ + v==UpdateNode?"UpdateNode": \ + v==IdentNode?"IdentNode": \ + v==ApplyNode?"ApplyNode": \ + v==PrefixNode?"PrefixNode" \ + :"") +#endif + +#define SELECTOR_U 2 +#define SELECTOR_F 3 +#define SELECTOR_L 4 +#define SELECTOR_N 5 + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +STRUCT (case_node_contents,CaseNodeContents){ + struct node_id_ref_count_list * case_node_id_ref_counts; + StrictNodeIdP case_strict_node_ids; +}; +#endif + +STRUCT (node,Node){ + union { + struct if_node_contents * contents_if; + Symbol contents_symbol; + NodeId contents_node_id; + Ident contents_ident; + struct node * contents_node; + struct node_id_list_element *contents_node_ids; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + StrictNodeIdP contents_guard_strict_node_ids; +#endif + } node_contents; + + struct arg * node_arguments; + + union { + StateS su_state; + struct { + union { + Symbol u_record_symbol; /* comparser,checker */ + struct symbol_type * u_type_info; /* typechecker */ + struct recursive_call * u_recursive_call; /* typechecker */ + struct overloaded_function *u_overloaded_application; /* typechecker */ + } s_u; + int s_line; /* size for PushNode */ + } su_s; + struct { + struct node_def * u_node_defs; /* for CaseNode,DefaultNode and GuardNode */ +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + struct case_node_contents * u_case; +#else + struct node_id_ref_count_list * u_node_id_ref_counts; +#endif + } su_u; + struct { + struct node_def * scope_node_defs; + struct imp_rule * scope_imp_rules; + } su_scope; /* for ScopeNode */ + } node_su; + + short node_arity; + unsigned char node_kind; /* NodeKind */ + signed char node_number:2; /* statesgen: -1,0 or 1,pattern_match ? */ + Annotation node_annotation:6; +}; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +# define node_node_id_ref_counts node_su.su_u.u_case->case_node_id_ref_counts +# define node_strict_node_ids node_su.su_u.u_case->case_strict_node_ids +#else +# define node_node_id_ref_counts node_su.su_u.u_node_id_ref_counts +#endif + +#define node_state node_su.su_state +#define node_record_symbol node_su.su_s.s_u.u_record_symbol +#define node_type node_su.su_s.s_u.u_type_info +#define node_recursive_call node_su.su_s.s_u.u_recursive_call +#define node_overloaded_application node_su.su_s.s_u.u_overloaded_application +#define node_line node_su.su_s.s_line +#define node_node_defs node_su.su_u.u_node_defs +#define node_symbol node_contents.contents_symbol +#define node_node_id node_contents.contents_node_id +#define node_ident node_contents.contents_ident +#define node_node node_contents.contents_node +#define node_node_ids node_contents.contents_node_ids + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +#define node_guard_strict_node_ids node_contents.contents_guard_strict_node_ids +#endif + +#define node_then_node_defs node_contents.contents_if->if_then_node_defs +#define node_then_rules node_contents.contents_if->if_then_rules +#define node_then_strict_node_ids node_contents.contents_if->if_then_strict_node_ids +#define node_else_node_defs node_contents.contents_if->if_else_node_defs +#define node_else_rules node_contents.contents_if->if_else_rules +#define node_else_strict_node_ids node_contents.contents_if->if_else_strict_node_ids +#define node_if_scope node_contents.contents_if->if_local_scope + +#define node_scope_node_defs node_su.su_scope.scope_node_defs +#define node_scope_imp_rules node_su.su_scope.scope_imp_rules + +#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 + +STRUCT (arg,Arg){ + Node arg_node; + struct arg * arg_next; + union { + StateS u_state; + unsigned long u_occurrence; /* OccurrenceKind */ + } arg_u; +}; +typedef struct arg *Args; + +#define arg_state arg_u.u_state +#define arg_occurrence arg_u.u_occurrence + +STRUCT (node_def,NodeDef){ + union { + NodeId u1_id; + Node u1_pattern; + } def_u1; + Node def_node; + NodeDefs def_next; + int def_mark; +}; + +#define def_id def_u1.u1_id +#define def_pattern def_u1.u1_pattern + +#define NODE_DEF_HAS_LHS_PATTERN_MASK 1 +#define NODE_DEF_NEW_SCOPE_MASK 2 +#define NODE_DEF_NORMAL_SCOPE_MASK 4 +#define NODE_DEF_MARKED 8 +#define NODE_DEF_OBSERVE_MASK 16 +#define NODE_DEF_SELECT_AND_REMOVE_MASK 32 + +typedef struct local_def { + union { + NodeId contents_node_id; /* ldef_node_id, if ldef_kind==0 */ + Symbol contents_symbol; /* ldef_symbol, if ldef_kind==1 */ + } ldef_contents; + struct local_def * ldef_next; + int ldef_scope; + char ldef_kind; + char ldef_lifted; +} LocalDef,*LocalDefP; + +#define ldef_node_id ldef_contents.contents_node_id +#define ldef_symbol ldef_contents.contents_symbol + +/* for implementing calls to C or the OS */ + +typedef struct parameter Parameter,*Parameters; + +struct parameter { + union { + NodeId val_node_id; /* if par_kind == 0 */ + Ident val_ident; /* if par_kind == 1 */ + } par_val; + Ident par_loc; + Parameters par_next; + int par_kind; +}; + +#define par_node_id par_val.val_node_id +#define par_ident par_val.val_ident + +typedef struct instruction Instruction,*Instructions; + +struct instruction { + char * instr_this; + Instructions instr_next; +}; + +STRUCT (code_block,CodeBlock){ + Parameters co_parin; + Parameters co_parout; + Instructions co_instr; + Bool co_is_abc_code; +#ifdef CLEAN2 + Bool co_is_inline; +#endif +}; + +typedef enum { + Contractum, ExternalCall +} RhsKind; + +typedef struct rule_alt *RuleAlts; + +STRUCT (rule_alt,RuleAlt){ + Node alt_lhs_root; + NodeDefs alt_lhs_defs; + union { + Node rhs_root; + CodeBlock rhs_code; + } alt_rhs; + NodeDefs alt_rhs_defs; + union { + StrictNodeIdP u_alt_strict_node_ids; + struct poly_list * u_alt_observer_list; + } alt_u; + struct lifted_node_id * alt_lifted_node_ids; + ImpRules alt_local_imp_rules; + RuleAlts alt_next; + unsigned alt_line; + BITVECT alt_used_arguments; +#ifdef OS2 + unsigned alt_kind:4; /* RhsKind */ +#else + unsigned alt_kind:3; /* RhsKind */ +#endif + Bool alt_write_access:1; + Bool alt_may_fail:1; +}; + +#define alt_rhs_root alt_rhs.rhs_root +#define alt_rhs_code alt_rhs.rhs_code +#define alt_strict_node_ids alt_u.u_alt_strict_node_ids +#define alt_observer_list alt_u.u_alt_observer_list + +typedef struct macro Macro,*Macros; + +struct macro { + RuleAlts macro_rule; + Node macro_root; + unsigned macro_line; + Macros macro_next; +}; + +typedef enum { + NEWDEFINITION, ABSTYPE, TYPE, TYPESYN, DEFRULE, IMPRULE, + CONSTRUCTOR, SYSRULE, MACRORULE, + RECORDTYPE, FIELDSELECTOR, + OVERLOADEDRULE, + INSTANCE, CLASS, CLASSINSTANCE, CLASSLIST +} SDefKind; + +#define SDefKindSize 5 +#define DERIVEDRULE 16 + +typedef enum { + Indefinite, CurrentlyChecked, TypeChecked, + Predefined, Expanded, TotallyExpanded, + ConvertingToState, ConvertedToState +} CheckStatus; + +typedef enum { + CreateArrayFun, ArraySelectFun, UnqArraySelectFun, ArrayUpdateFun, + ArrayReplaceFun, ArraySizeFun, UnqArraySizeFun, + _CreateArrayFun,_UnqArraySelectFun,_UnqArraySelectNextFun,_UnqArraySelectLastFun, + _ArrayUpdateFun, + NoArrayFun +} ArrayFunKind; + +#define ArrayFunKindBitSize 4 + +#include "syntax_tree_types.h" + +STRUCT (imp_rule,ImpRule){ + NodeP rule_root; + RuleAlts rule_alts; + struct type_alt * rule_type; + StateP rule_state_p; + ImpRules rule_next; + union { + struct depend_function *u_depend_functions; + ImpRuleP u_next_changed_function; + ImpRuleP u_next_used_function; + ImpRuleP u_next_function_with_more_arguments; + } rule_u; + struct node * rule_lazy_call_node; +#if STORE_STRICT_CALL_NODES + struct node * rule_strict_call_node; + struct node * rule_strict_call_node2; +#endif + unsigned rule_line; + unsigned rule_mark; + unsigned rule_ref_count; +}; + +#define RULE_CHECKED_MASK 1 +#define RULE_CAF_MASK 2 +#define RULE_LAZY_CALL_NODE_MASK 4 +#if STORE_STRICT_CALL_NODES +# define RULE_STRICT_CALL_NODE_MASK 8 +# define RULE_STRICT_CALL_NODE2_MASK 16 +#endif +#define RULE_HAS_VERSION_WITH_MORE_ARGUMENTS 32 +#define RULE_UNBOXED_LAZY_CALL 64 +#define RULE_INTERNAL_FUNCTION_MASK 128 +#define RULE_LAMBDA_FUNCTION_MASK 256 +#define RULE_HAS_REF_COUNT_MASK 512 + +#define RULE_CALL_VIA_LAZY_SELECTIONS_ONLY 1024 + +#define rule_depend_functions rule_u.u_depend_functions /* comparser,checker,macros */ +#define rule_next_changed_function rule_u.u_next_changed_function /* optimisations */ +#define rule_next_used_function rule_u.u_next_used_function /* optimisations */ +#define rule_next_function_with_more_arguments rule_u.u_next_function_with_more_arguments /* statesgen */ + +STRUCT (symbol_def,SymbDef){ + char *sdef_module; + Ident sdef_ident; + union + { Types u_type; + RuleTypes u_rule_type; + SynTypes u_syn_type; + AbsTypes u_abs_type; + ImpRules u_rule; + Macros u_macro; + Overloaded u_overloaded; + Instance u_instance; + ClassDefinition u_class; + ClassInstance u_class_instance; + SymbolList u_class_symb_list; + } sdef_u; + union + { struct symbol_type_info * sti_rule_type_info; + struct symbol_type * sti_type_cons_info; + unsigned long sti_class_instance_info; + StateS typeinfo_record_state; + struct + { FieldList fieldinfo_sel_field; + Node fieldinfo_sel_node; + int fieldinfo_sel_field_number; + } sdef_fieldinfo; + struct constructor_list * typeinfo_constructor; /* for CONSTRUCTOR */ + } sdef_typeinfo; + + unsigned sdef_number; + unsigned sdef_ancestor; + short sdef_arity; + short sdef_cons_arity; + short sdef_over_arity; + unsigned short sdef_nr_of_lifted_nodeids; + + union { + struct _fun * u3_sa_fun; /* sa.c */ + unsigned u3_instantiation_depth; + } sdef_u3; + + struct symbol_def * sdef_dcl_icl; /* to dcl if sdef_exported, to icl if sdef_main_dcl */ + + union { + struct symbol_def * u1_next_scc; + Symbol u1_subst_symbol; + } sdef_u1; + + union { + struct symbol_def * sdef_u2_parent; + struct member_item * sdef_u2_class_members; +/* struct symbol_def * sdef_u2_aliases; */ + struct type_cons_repr * sdef_u2_type_cons_repr; + struct symbol_def * sdef_u2_next_version; /* for IMPRULES */ + } sdef_u2; + + unsigned sdef_line; + int sdef_mark; + + Bool sdef_isused:1; + Bool sdef_is_local_function:1; + + Bool sdef_is_instantiated:1; + + Bool sdef_no_sa:1; + Bool sdef_explicitly_imported:1; + Bool sdef_has_aliases:1; + + Bool sdef_attributed:1; + Bool sdef_returnsnode:1; + Bool sdef_calledwithrootnode:1; + + Bool sdef_has_inftype:1; + Bool sdef_typable:1; + Bool sdef_contains_freevars:1; + Bool sdef_noncoercible:1; + Bool sdef_unq_attributed:1; + Bool sdef_is_cyclic:1; + Bool sdef_is_redirection:1; + Bool sdef_is_observing:1; + Bool sdef_is_hyperstrict:1; + Bool sdef_with_uniqueness_variables:1; + Bool sdef_current_type_vars_mark:1; /* for TYPESYN */ + Bool sdef_abstract_type_synonym:1; /* for TYPESYN */ + Bool sdef_strict_constructor:1; /* for CONSTRUCTOR and RECORDTYPE */ + Bool sdef_exported:1; + Bool sdef_main_dcl:1; /* if in .dcl of main .icl */ + Bool sdef_first_group_element:1; + Bool sdef_infix:1; +#ifdef OS2 + int sdef_stupid_gcc; + SDefKind sdef_kind:SDefKindSize; + unsigned sdef_infix_priority:4; + unsigned sdef_checkstatus:4; /* CheckStatus */ + unsigned sdef_prop_status:4; /* CheckStatus */ + unsigned sdef_arfun:ArrayFunKindBitSize; /* ArrayFunKind */ + unsigned sdef_infix_assoc:2; /* Assoc */ +#else + unsigned sdef_kind:SDefKindSize; + unsigned sdef_infix_priority:4; + unsigned sdef_infix_assoc:2; /* Assoc */ + unsigned sdef_checkstatus:3; /* CheckStatus */ + unsigned sdef_prop_status:3; /* CheckStatus */ + unsigned sdef_arfun:ArrayFunKindBitSize; /* ArrayFunKind */ +#endif +}; + +#define sdef_type sdef_u.u_type +#define sdef_rule_type sdef_u.u_rule_type +#define sdef_syn_type sdef_u.u_syn_type +#define sdef_abs_type sdef_u.u_abs_type +#define sdef_rule sdef_u.u_rule +#define sdef_macro sdef_u.u_macro +#define sdef_rc sdef_u.u_rc +#define sdef_overloaded sdef_u.u_overloaded +#define sdef_instance sdef_u.u_instance +#define sdef_class_instance sdef_u.u_class_instance +#define sdef_class_symb_list sdef_u.u_class_symb_list + +#define sdef_class sdef_u.u_class + +#define sdef_instantiation_depth sdef_u3.u3_instantiation_depth +#define sdef_sa_fun sdef_u3.u3_sa_fun + +#define sdef_next_scc sdef_u1.u1_next_scc +#define sdef_subst_symbol sdef_u1.u1_subst_symbol /* macros */ + +#define SDEF_USED_LAZILY_MASK 1 +#define SDEF_USED_STRICTLY_MASK 2 +#define SDEF_USED_CURRIED_MASK 4 +#define SDEF_LOCAL_MACRO_FUNCTION_MASK 8 +#define SDEF_NEXT_IMP_RULE_VERSION_MASK 32 +#define SDEF_HAS_IMP_RULE_VERSIONS_MASK 64 +#define SDEF_OPTIMISED_FUNCTION_MASK 128 + +/* some macros to reuse bit fields */ + +#define sdef_group_number sdef_ancestor +#define sdef_has_instance_info sdef_used_as_instance + +#define sdef_parent sdef_u2.sdef_u2_parent +#define sdef_class_members sdef_u2.sdef_u2_class_members +#define sdef_aliases sdef_u2.sdef_u2_aliases +#define sdef_type_cons_repr sdef_u2.sdef_u2_type_cons_repr + +#define sdef_next_version sdef_u2.sdef_u2_next_version + +#define sdef_constructor sdef_typeinfo.typeinfo_constructor + +#define sdef_rule_type_info sdef_typeinfo.sti_rule_type_info +#define sdef_type_cons_info sdef_typeinfo.sti_type_cons_info +#define sdef_class_instance_info sdef_typeinfo.sti_class_instance_info + +#define sdef_rule_cons_type_info sdef_rc->rc_type_info + +#define sdef_rule_cons_imprule sdef_rc->rc_imprule +#define sdef_rule_cons_defrule sdef_rc->rc_defrule + +#define sdef_record_state sdef_typeinfo.typeinfo_record_state +#define sdef_ar_fun_aps sdef_typeinfo.typeinfo_ar_fun_aps +#define sdef_sel_field sdef_typeinfo.sdef_fieldinfo.fieldinfo_sel_field +#define sdef_sel_node sdef_typeinfo.sdef_fieldinfo.fieldinfo_sel_node + +#define sdef_sel_field_number sdef_typeinfo.sdef_fieldinfo.fieldinfo_sel_field_number + +#if IMPORT_OBJ_AND_LIB +struct string_list { + char * sl_string; + struct string_list *sl_next; +}; +#endif + +typedef struct { + Symbol im_name; + Symbol im_symbols; + ImportList im_imports; + Types im_types; + SynTypes im_syn_types; + ImpRules im_rules; + Macros im_macros; + struct symbol_def * im_start; + Bool im_main; + DefMod im_def_module; + ClassDefinition im_classes; + ClassInstance im_instances; + +#ifdef SHORT_CLASS_NAMES + struct module_info * im_module_info; +#endif +#if IMPORT_OBJ_AND_LIB + struct string_list * im_imported_objs; + struct string_list * im_imported_libs; +#endif +#if WRITE_DCL_MODIFICATION_TIME + FileTime im_modification_time; +#endif +} *ImpMod, ImpRepr; + +struct def_repr { + Symbol dm_name; + Symbol dm_symbols; + ImportList dm_imports; + ExportList dm_exports; + Types dm_types; + SynTypes dm_syn_types; + AbsTypes dm_abs_types; + RuleTypes dm_rules; + Macros dm_macros; + Bool dm_system_module; + ClassDefinition dm_classes; + ClassInstance dm_instances; + +#ifdef SHORT_CLASS_NAMES + struct module_info * dm_module_info; +#endif +#if WRITE_DCL_MODIFICATION_TIME + FileTime dm_modification_time; +#endif +}; diff --git a/backendC/CleanCompilerSources/system.h b/backendC/CleanCompilerSources/system.h new file mode 100644 index 0000000..2d964ff --- /dev/null +++ b/backendC/CleanCompilerSources/system.h @@ -0,0 +1,118 @@ +/* + system.h + Author: Eric Nocker + At: Department of Computer Science + University of Nijmegen +*/ + +#define _SYSTEM_ +#define _WINDOWS_ + +#if defined (applec) || (defined (__MWERKS__) && !defined (_WINDOWS_)) || defined (__MRC__) +# define _MAC_ +# define _STANDALONE_ + +#define __ppc__ + +#elif defined (THINK_C) +# define _MACUSER_ +#else +# define _STANDALONE_ +#endif + +#define _DEBUG_ + +#if defined (_MAC_) +# include "mac.h" +#elif defined (_MACUSER_) +# include "macuser.h" +#elif defined (_SUN_) +# include "sun.h" +#elif defined (OS2) +# include "os2.h" +#elif defined (_WINDOWS_) +# include "windows_io.h" +#else +# include "standard.h" +#endif + +#include "types.t" + +#ifdef GEN_SUPPORT_H +# include "gensupport.h" +#else + +#define MAXPATHLEN 1024 + +extern char *PATHLIST; + +extern char *GetFileExtension (FileKind kind); +extern File FOpen (char *wname, FileKind kind, char *mode); +#if defined(WRITE_DCL_MODIFICATION_TIME) && WRITE_DCL_MODIFICATION_TIME +extern File FOpenWithFileTime (char *file_name,FileKind kind, char *mode,FileTime *file_time_p); +#endif +extern int FDelete (char *fname, FileKind kind); +extern int FClose (File f); + +#ifdef _MACUSER_ +/* const declarations required */ + extern int FPrintF (File f, const char *fmt,...); + extern int FPutS (const char *s, File f); + extern size_t FWrite (const void *ptr, size_t size, size_t count, File f); +#else +extern int FPutS (char *s, File f); +extern size_t FWrite (void *ptr, size_t size, size_t count, File f); +# ifdef _VARARGS_ +extern int FPrintF (File f, char *fmt,...); +# else +extern int FPrintF (); /* (File w, char *fmt,...) */ +# endif +#endif + +#if defined (_MACUSER_) + extern File StdOut; + extern File StdError; + extern File StdVerboseH; + extern File StdVerboseL; + extern File StdListTypes; +#endif + +#ifndef __ppc__ +extern char *FGetS (char *s, int n, File f); +#endif +extern size_t FRead (void *ptr, size_t size, size_t count, File f); +extern int FSeek (File f, long offset, int origin); +extern long FTell (File f); +extern FileTime FGetFileTime (char *fname, FileKind kind); +#if defined(WRITE_DCL_MODIFICATION_TIME) && WRITE_DCL_MODIFICATION_TIME +extern void FWriteFileTime (FileTime file_time,File f); +#endif +extern Bool GetOptionsFromIclFile (char *fname, CompilerOptions *opts); + +#ifdef _VARARGS_ + extern void DoError (char *fmt,...); + extern void DoFatalError (char *fmt,...); + extern void CmdError (char *errormsg,...); +#else + extern void DoError (); + extern void DoFatalError (); + extern void CmdError (); +#endif + +extern void (*SetSignal (void (*f) (void))) (void); + +extern int CheckInterrupt (void); + +extern void *Alloc (unsigned long count, SizeT size); + +extern void Free (void *p); + +#ifdef THINK_C +#define ReSize(A) (((A)+1) & ~1) +#else +#define ReSize(A) (((A)+3) & ~3) +#endif + +extern int System (char *s); + +#endif diff --git a/backendC/CleanCompilerSources/tcsupport.h b/backendC/CleanCompilerSources/tcsupport.h new file mode 100644 index 0000000..7a28d85 --- /dev/null +++ b/backendC/CleanCompilerSources/tcsupport.h @@ -0,0 +1,42 @@ +/* + +Version 1.0 06/09/1995 + +Author: Sjaak Smetsers + +*/ + +extern jmp_buf ExitTypeComponent; + +#ifdef SHORT_CLASS_NAMES +extern int gNextTypeNumber; +#endif + +extern void OverloadingError (Symbol symbol, char *msg, TypeCell type, Bool make_jump); + +extern void Unify (TypeCell offtype, TypeCell demtype, Node uni_node, int argnr); + +extern UnificationStatus UnifyTypes (TypeCell offtype, TypeCell demtype); + +extern void UnifyError (UnificationStatus ustat, Node err_node, int err_argnr, TypeCell type1, TypeCell type2); + +extern void UniquenessError (UniquenessErrorKind err_kind, Node err_node, int err_argnr, TypeCell type, TypeCell sub_type); + +extern void ReportTypeError (Node err_node, int err_argnr, char *err_msg); + +extern TypeCell ExpandSynonymType (TypeCell synappl, SymbDef syndef); + +extern AttributeCellKind DetermineAttrkindOfTypeCell (TypeCell type); + +#define GetExistentionalVarsOfTypeCons(typecons) (typecons -> sdef_contains_freevars) ?\ + typecons -> sdef_type -> type_exivars : ALLBITSCLEAR + +extern Symbol BuildNewSymbol (SymbDef old_symb_def, int id_nr, TypeCell ins_types [], int arity, TableKind table); + +extern Symbol BuildNewClassSymbol (SymbolList class_symbols); + +extern Ident BuildNewSymbolId (char *prefix, int id_nr, TypeCell ins_types [], int arity, TableKind table); + +extern TypeCell SkipTypeSynIndirection (TypeCell type); + +extern void PrepareTypesAndImportedInstances (Symbol symbs, char *icl_module); diff --git a/backendC/CleanCompilerSources/tcsupport_2.c b/backendC/CleanCompilerSources/tcsupport_2.c new file mode 100644 index 0000000..173f6e1 --- /dev/null +++ b/backendC/CleanCompilerSources/tcsupport_2.c @@ -0,0 +1,187 @@ +/* + Version 1.2 21/01/1997 + + Author: Sjaak Smetsers +*/ + +#pragma options (!macsbug_names) + +#include "system.h" + +#include "settings.h" +#include "syntaxtr.t" +#include "comsupport.h" + +#include "sizes.h" +#include "checker.h" +#include "checksupport.h" +#include "tctypes.t" +#include "typechecker.h" +#include "typechecker2.h" +#include "typeconv.h" +#include "tcsupport.h" +#include "overloading.h" +#include "scanner.h" +#include "comparser.h" +#include "buildtree.h" + +BITVECT DetermineUniPropOfTypeCons (SymbDef typecons) +{ + if (typecons -> sdef_kind == TYPE || typecons -> sdef_kind == RECORDTYPE) + return (typecons -> sdef_type) ? typecons -> sdef_type -> type_uniprop : ALLBITSSET; + else + return (typecons -> sdef_kind == TYPESYN) ? typecons -> sdef_syn_type -> syntype_uniprop : ALLBITSSET; + +} /* DetermineUniPropOfTypeCons */ + +BITVECT DetermineConsVarsOfTypeCons (SymbDef typecons, ConsVarList * cons_vars) +{ + if (typecons -> sdef_kind == TYPE || typecons -> sdef_kind == RECORDTYPE) + { if (typecons -> sdef_type) + { * cons_vars = typecons -> sdef_type -> type_lhs -> ft_cons_vars; + return typecons -> sdef_type -> type_consvars; + } + else + { * cons_vars = NULL; + return ALLBITSCLEAR; + } + } + else if (typecons -> sdef_kind == TYPESYN) + { * cons_vars = typecons -> sdef_syn_type -> syn_lhs -> ft_cons_vars ; + return typecons -> sdef_syn_type -> syn_consvars; + } + else + { * cons_vars = NULL; + return ALLBITSCLEAR; + } + +} /* DetermineConsVarsOfTypeCons */ + +TypeCell SkipIndirectionChain (TypeCell type) +{ + MemoryCheck (type); + for (; type -> tc_kind == Indirection; type = type -> contents_indirect) + MemoryCheck (type); + return type; +} /* SkipIndirectionChain */ + +#define SubstitutedType(typeargs) ((typeargs)[-1]) + +TypeCell SkipTypeSynIndirection (TypeCell type) +{ + if (type -> tc_kind == ConstructorType && type -> tc_expanded) + { type = SubstitutedType (type -> contents_tc_args); + SkipIndirections (type); + } + return type; + +} /* SkipTypeSynIndirection */ + +void PrintNodeSymbol (Node node, int arg_nr, File file) +{ + Symbol rootsymb; + + switch (node -> node_kind) + { + case IfNode: + switch (arg_nr) + { + case 1: FPutS ("condition part of guard or if rule", file); + return; + case 2: FPutS ("then part of guard or if rule", file); + return; + case 3: FPutS ("else part of guard or if rule", file); + return; + default: FPutS ("guard or if rule", file); + return; + } + break; + case SelectorNode: + if (arg_nr == 1) + FPutS ("argument of selection", file); + else + FPutS ("selection", file); + return; + case MatchNode: + if (arg_nr == 1) + { FPutS ("rhs selection of", file); + break; + } + else + { FPutS ("rhs selection", file); + return; + } + case UpdateNode: + FPutS ("update of record", file); + break; + case NodeIdNode: + if (node -> node_node_id -> nid_ident != NULL) + { Ident id = node -> node_node_id -> nid_ident; + if (TestMark (node -> node_node_id, nid_mark2, NID_FIELD_NAME_MASK)) + { SymbDef rec_symb = (SymbDef) id -> ident_environ; + + FPrintF (file, "field %s of record %s", id -> ident_name, rec_symb -> sdef_ident -> ident_name); + } + else + FPutS (id -> ident_name, file); + } + else if (node -> node_node_id -> nid_node) + PrintNodeSymbol (node -> node_node_id -> nid_node, 0, file); + return; + default: + break; + } + + rootsymb = node -> node_symbol; + + if (rootsymb -> symb_kind == select_symb) + { if (arg_nr == 1) + { FPrintF (file, "%d-tuple selection of ", rootsymb -> symb_arity); + PrintNodeSymbol (node -> node_arguments -> arg_node, 0, file); + } + else + FPrintF (file, "selection of the %d-th argument of a %d-tuple ", node -> node_arity, rootsymb -> symb_arity); + } + else if (rootsymb -> symb_kind == apply_symb) + { if (arg_nr == 1) + PrintNodeSymbol (node -> node_arguments -> arg_node, 0, file); + else + { Node argnode; + for (arg_nr = 1, argnode = node -> node_arguments -> arg_node; + argnode -> node_kind == NormalNode && argnode -> node_symbol -> symb_kind == apply_symb; + argnode = argnode -> node_arguments -> arg_node) + arg_nr ++; + PrintNodeSymbol (argnode, arg_nr, file); + } + } + else if (rootsymb -> symb_kind == tuple_symb) + { int tup_arity = node -> node_arity; + FPutS ("(_", file); + for (tup_arity--; tup_arity > 0; tup_arity--) + FPutS (",_", file); + FPutC (')', file); + } + else + { if (arg_nr > 0) + { if (rootsymb -> symb_kind == definition && rootsymb -> symb_def -> sdef_kind == IMPRULE) + { if (arg_nr <= rootsymb -> symb_def -> sdef_nr_of_lifted_nodeids) + { Args lifted_arg; + int i; + + for (i = 1, lifted_arg = node -> node_arguments; i < arg_nr; i ++, lifted_arg = lifted_arg -> arg_next) + ; + if (lifted_arg -> arg_node -> node_kind == NodeIdNode) + FPrintF (StdError, "internal argument %s of ", lifted_arg -> arg_node -> node_node_id -> nid_ident -> ident_name); + else + FPrintF (StdError, "internal argument %d of ", arg_nr); + } + else + FPrintF (StdError, "argument %d of ", arg_nr - rootsymb -> symb_def -> sdef_nr_of_lifted_nodeids); + } + else + FPrintF (StdError, "argument %d of ", arg_nr); + } + PrintSymbol (rootsymb, file); + } + +} /* PrintNodeSymbol */ diff --git a/backendC/CleanCompilerSources/tctypes.t b/backendC/CleanCompilerSources/tctypes.t new file mode 100644 index 0000000..c99828d --- /dev/null +++ b/backendC/CleanCompilerSources/tctypes.t @@ -0,0 +1,406 @@ +/* + +Version 1.0 26/08/1994 + +Author: Sjaak Smetsers + +*/ + +/**** + internal representation for types used by the type checker +****/ + +STRUCT (symbol_type, SymbolType) +{ + struct type_cell ** syt_args; + struct type_cell * syt_result; +/* + unsigned long syt_unspec_args; +*/ + unsigned short syt_arity; + unsigned short syt_mark:1; + unsigned short syt_part_spec:1; + +}; + + + +STRUCT (type_alt_info, TypeAltInfo) +{ + struct recursive_call * tai_recursive_calls; + struct overloaded_function * tai_overloaded_funs; + struct internal_call * tai_internal_calls; + struct type_alt_info * tai_next; + unsigned tai_line; + +}; + +struct lifted_arguments_info +{ + struct overloaded_variable_list_elem * lai_overloaded_vars; + PolyList lai_type_vars; + PolyList lai_attribute_vars; +} ; + +STRUCT (symbol_type_info,SymbolTypeInfo) +{ + SymbolTypeP sti_type1; + SymbolTypeP sti_type2; + struct type_cell ** sti_overloaded_vars; + TypeAltInfo sti_type_alt_info; + union + { struct lifted_arguments_info * sti_u_lifted_args_info; + PolyList sti_u_lifted_over_vars; + } sti_union; +} ; + +#define sti_lifted_args_info sti_union.sti_u_lifted_args_info +#define sti_lifted_over_vars sti_union.sti_u_lifted_over_vars + +STRUCT (type_cons_repr, TypeConsRepr) +{ + SymbDef tcr_symbol; + int tcr_arity; +}; + +#define sdef_inf_type sdef_rule_type_info -> sti_type1 +#define sdef_predef_type sdef_rule_type_info -> sti_type2 +#define sdef_overloaded_vars sdef_rule_type_info -> sti_overloaded_vars +#define sdef_type_alt_info sdef_rule_type_info -> sti_type_alt_info +#define sdef_lifted_args_info sdef_rule_type_info -> sti_lifted_args_info + +#define sdef_lifted_temp_over_vars sdef_rule_type_info -> sti_lifted_args_info -> lai_overloaded_vars +#define sdef_lifted_type_vars sdef_rule_type_info -> sti_lifted_args_info -> lai_type_vars +#define sdef_lifted_attr_vars sdef_rule_type_info -> sti_lifted_args_info -> lai_attribute_vars +#define sdef_lifted_over_vars sdef_rule_type_info -> sti_lifted_over_vars + +#define sdef_rc_inf_type sdef_rule_cons_type_info -> sti_type1 +#define sdef_rc_predef_type sdef_rule_cons_type_info -> sti_type2 + +typedef unsigned int AttributeCellKind; + enum + { AC_Indirection = 0, AC_UnChanging = 0, AC_Unique, AC_Variable, AC_NotUnique + }; + +#define AttributeCellKindSize 2 + +#ifdef THINK_C +#define DAttributeCellKind(v) (\ + v == AC_Indirection ? "AC_Indirection" :\ + v == AC_Unique ? "AC_Unique" :\ + v == AC_Variable ? "AC_Variable" :\ + v == AC_NotUnique ? "AC_NotUnique" :\ + "Unknown") +#endif + +typedef struct plain_attr_var +{ Bool pav_mark:1; + Bool pav_exi_quanti:1; + AttributeCellKind pav_varkind:AttributeCellKindSize; + struct temp_attr_var * pav_forward; +} *PlainAttrVar; + +STRUCT (attr_var_with_equatuations, AttrVarWithEquations) +{ struct + { Bool ave_bi_mark:1; + Bool ave_bi_coercible:1; + Bool ave_bi_present_mark:1; + Bool ave_bi_printed:1; + unsigned ave_bi_number; + } ave_bitinfo; + union + { struct temp_attr_var * ave_inf_forward; + struct simple_attr_equation * ave_inf_impl_equa; + } ave_info; + struct simple_attr_equation * ave_equations; +} ; + +#define ave_mark ave_bitinfo.ave_bi_mark +#define ave_coercible ave_bitinfo.ave_bi_coercible + +#define ave_present_mark ave_bitinfo.ave_bi_present_mark +#define ave_printed ave_bitinfo.ave_bi_printed + +#define ave_number ave_bitinfo.ave_bi_number +#define ave_refcount ave_bitinfo.ave_bi_refcount +#define ave_offrefcount ave_bitinfo.ave_bi_offrefcount +#define ave_forward ave_info.ave_inf_forward +#define ave_impl_equa ave_info.ave_inf_impl_equa + +STRUCT (attr_equation_list, AttrEquationList) +{ struct + { Bool ae_bi_mark:1; + Bool ae_bi_implicit:1; + } ae_bitinfo; + + AttrEquationList ae_nextoffered; + struct temp_attr_var * ae_offered; + + union + { struct attr_equation_list * ae_inf_nextdemanded; + AttrVarWithEquationsP ae_inf_forward; + } ae_info; + + struct temp_attr_var * ae_demanded; +}; + +#define ae_mark ae_bitinfo.ae_bi_mark +#define ae_implicit ae_bitinfo.ae_bi_implicit +#define ae_nextdemanded ae_info.ae_inf_nextdemanded +#define ae_forward ae_info.ae_inf_forward + +STRUCT (simple_attr_equation, SimpleAttrEquation) +{ Bool sae_mark:1; + AttrVarWithEquationsP sae_offattr; + struct simple_attr_equation * sae_next; +}; + +STRUCT (temp_attr_var, TempAttrVar) +{ Bool tav_mark: 1; + Bool tav_present: 1; + Bool tav_free: 1; + Bool tav_onstack: 1; + Bool tav_exi_quanti: 1; + Bool tav_non_coercible: 1; + + AttributeCellKind tav_varkind: AttributeCellKindSize; + unsigned tav_number; + AttrEquationList tav_offered; + union + { AttrVarWithEquationsP tav_inf_forward; + AttrEquationList tav_inf_demanded; + TempAttrVar tav_inf_indirection; + SimpleAttrEquation tav_inf_impl_equa; + } tav_info; +}; + +#define tav_forward tav_info.tav_inf_forward +#define tav_demanded tav_info.tav_inf_demanded +#define tav_indirection tav_info.tav_inf_indirection +#define tav_impl_equa tav_info.tav_inf_impl_equa + +STRUCT (class_variable_info, ClassVariableInfo) +{ + SymbolList cv_overloaded; + NodeId cv_nodeid; +}; + +typedef union +{ struct + { SymbolList tv_overloaded; + union + { struct type_cell * tv_u_forward; + TypeVar tv_u_type_var; + unsigned tv_u_number; + } tv_u; + } cc_variable; + Symbol cc_basic; + struct + { TypeConsRepr tcc_symbol; + struct type_cell ** tcc_args; + } cc_typeconstructor; + struct + { struct type_cell * fc_arg; + struct type_cell * fc_result; + } cc_funtype; + struct + { struct type_cell * sc_indirect; + struct type_cell * sc_arg; + } cc_strictnessinfo; + struct + { union + { struct type_cell * cv_u_forward; + TypeVar cv_u_type_var; + } cv_u; + ClassVariableInfo cv_info; + } cc_classvariable; + struct + { int cova_arity; + struct type_cell ** cova_types; + } cc_constructorvariable; + struct + { struct type_cell * void_forward; + } cc_voidtype; + struct + { struct type_cell * empty_forward; + } cc_emptytype; + +} CellContents; + +/* Don not change the order of constants in the next enumaration type */ + +typedef unsigned int CellKind; + enum + { BasicType, VoidType, FunctionType, ConstructorType, + TypeVariable, ExistentialVariable, StrictnessCell, + ClassVariable, ConstructorVariable, + Indirection, EmptyType + }; + +#define CellKindSize 4 + +#ifdef THINK_C +#define DCellKind(v) (\ + v == BasicType ? "BasicType" :\ + v == ConstructorType ? "ConstructorType" :\ + v == FunctionType ? "FunctionType" :\ + v == TypeVariable ? "TypeVariable" :\ + v == VoidType ? "VoidType" :\ + v == StrictnessCell ? "StrictnessCell" :\ + v == Indirection ? "Indirection" :\ + v == ExistentialVariable ? "ExistentialVariable" :\ + v == ClassVariable ? "ClassVariable" :\ + v == ConstructorVariable ? "ConstructorVariable" :\ + "Unknown") +#endif + +#ifndef _NEW_ARRAY_ + +typedef unsigned int StrictCellKind; + enum + { SC_Lazy, SC_Strict, SC_Var, SC_Indirection + }; + +#define StrictCellKindSize 2 + +#endif + +#ifdef THINK_C +#define DStrictCellKind(v) (\ + v == SC_Lazy ? "SC_Lazy" :\ + v == SC_Strict ? "SC_Strict" :\ + v == SC_Var ? "SC_Var" :\ + v == SC_Indirection ? "SC_Indirection" :\ + "Unknown") +#endif + + +typedef unsigned int AttrVarKind; + enum + { AVK_None, AVK_Plain, AVK_Equation, AVK_Temporarily + }; + +#define AttrVarKindSize 2 + +#ifdef THINK_C +#define DAttrVarKind(v) (\ + v == AVK_None ? "AVK_None" :\ + v == AVK_Plain ? "AVK_Plain" :\ + v == AVK_Equation ? "AVK_Equation" :\ + v == AVK_Temporarily ? "AVK_Temporarily":\ + "Unknown") +#endif + +#define MaxInstanciationDepth 8 + +typedef struct +{ Bool ci_removed: 1; + Bool ci_printed: 1; + Bool ci_free: 1; + Bool ci_mark: 1; + Bool ci_expanded: 1; + Bool ci_hidden: 1; + Bool ci_overloaded: 1; + Bool ci_class_var: 1; + Bool ci_strict: 1; + Bool ci_tmp_cell: 1; + Bool ci_copy_cell: 1; + Bool ci_with_insres: 1; + Bool ci_no_match: 1; + Bool ci_non_coercible: 1; + Bool ci_default: 1; + + CellKind ci_kind: CellKindSize; + AttributeCellKind ci_attrkind: AttributeCellKindSize; + AttrVarKind ci_attrvarkind:AttrVarKindSize; + unsigned ci_instdepth: MaxInstanciationDepth; + +} CellInfo; + +STRUCT (overloaded_type, OverloadedType) +{ TempAttrVar olt_tempvar; + struct type_cell * olt_forward; +}; + +typedef union +{ TempAttrVar cai_tempvar; + PlainAttrVar cai_plainvar; + AttrVarWithEquationsP cai_equvar; + struct type_cell * cai_forward; + OverloadedTypeP cai_overloadedtypes; +} CellAttrInfo; + +typedef struct type_cell +{ CellInfo tc_cellinfo; + CellContents tc_contents; + CellAttrInfo tc_attrinfo; +} *TypeCell; + +#define tc_kind tc_cellinfo.ci_kind +#define tc_removed tc_cellinfo.ci_removed +#define tc_free tc_cellinfo.ci_free +#define tc_mark tc_cellinfo.ci_mark +#define tc_expanded tc_cellinfo.ci_expanded +#define tc_hidden tc_cellinfo.ci_hidden +#define tc_overloaded tc_cellinfo.ci_overloaded +#define tc_class_var tc_cellinfo.ci_class_var +#define tc_printed tc_cellinfo.ci_printed +#define tc_tmp_cell tc_cellinfo.ci_tmp_cell +#define tc_copy_cell tc_cellinfo.ci_copy_cell +#define tc_strict tc_cellinfo.ci_strict +#define tc_with_insres tc_cellinfo.ci_with_insres +#define tc_no_match tc_cellinfo.ci_no_match +#define tc_non_coercible tc_cellinfo.ci_non_coercible +#define tc_default tc_cellinfo.ci_default + +#ifndef _NEW_ARRAY_ + +#define tc_strictkind tc_cellinfo.ci_strictkind + +#endif + +#define tc_attrkind tc_cellinfo.ci_attrkind +#define tc_attrvarkind tc_cellinfo.ci_attrvarkind +#define tc_instdepth tc_cellinfo.ci_instdepth + +#define tc_tempattrvar tc_attrinfo.cai_tempvar +#define tc_plainattrvar tc_attrinfo.cai_plainvar +#define tc_equattrvar tc_attrinfo.cai_equvar +#define tc_forward tc_attrinfo.cai_forward +#define tc_overloadedtypes tc_attrinfo.cai_overloadedtypes + + +#define tv_forward tv_u.tv_u_forward +#define tv_type_var tv_u.tv_u_type_var +#define tv_number tv_u.tv_u_number + +#define contents_vc_number tc_contents.cc_variable.tv_number +#define contents_vc_forward tc_contents.cc_variable.tv_forward +#define contents_vc_type_var tc_contents.cc_variable.tv_type_var +#define contents_overloaded tc_contents.cc_variable.tv_overloaded +#define contents_indirect tc_contents.cc_variable.tv_forward + +#define contents_basic tc_contents.cc_basic +#define contents_tc_symbol tc_contents.cc_typeconstructor.tcc_symbol + +#define contents_tc_symbdef contents_tc_symbol -> tcr_symbol +#define contents_tc_arity contents_tc_symbol -> tcr_arity + +#define contents_tc_args tc_contents.cc_typeconstructor.tcc_args +#define contents_ft_arg tc_contents.cc_funtype.fc_arg +#define contents_ft_result tc_contents.cc_funtype.fc_result +#define contents_si_indirect tc_contents.cc_strictnessinfo.sc_indirect +#define contents_si_arg tc_contents.cc_strictnessinfo.sc_arg + +#define contents_cv_forward tc_contents.cc_classvariable.cv_u.cv_u_forward +#define contents_cv_type_var tc_contents.cc_classvariable.cv_u.cv_u_type_var +#define contents_cv_info tc_contents.cc_classvariable.cv_info + +#define contents_cv_overloaded contents_cv_info -> cv_overloaded +#define contents_cv_nodeid contents_cv_info -> cv_nodeid + +#define contents_cova_arity tc_contents.cc_constructorvariable.cova_arity +#define contents_cova_types tc_contents.cc_constructorvariable.cova_types + +#define contents_void_forward tc_contents.cc_voidtype.void_forward +#define contents_empty_forward tc_contents.cc_emptytype.empty_forward diff --git a/backendC/CleanCompilerSources/transform.h b/backendC/CleanCompilerSources/transform.h new file mode 100644 index 0000000..7c99698 --- /dev/null +++ b/backendC/CleanCompilerSources/transform.h @@ -0,0 +1,3 @@ + +extern void EliminateCodeSharing (ImpRules rules); + diff --git a/backendC/CleanCompilerSources/typechecker.h b/backendC/CleanCompilerSources/typechecker.h new file mode 100644 index 0000000..c9dcced --- /dev/null +++ b/backendC/CleanCompilerSources/typechecker.h @@ -0,0 +1,33 @@ +/* + +Version 1.0 25/04/1994 + +Author: Sjaak Smetsers + +*/ +extern Bool TypeError; + +extern Bool TypeChecker (ImpMod imod); + +extern void ListTypes (ImpMod imod); + + +extern SymbDef ListDef, TupleDefs [], ArrayDefs []; + +extern Symbol EmptySymbol; + +extern PolyList UserDefinedArrayFunctions; + +extern void InitTypeChecker (void); + +extern void PrintNodeSymbol (Node node, int arg_nr, File file); + +extern void PrintTCType (struct type_cell * type, struct type_cell * sub_type); + +extern unsigned ArityOfTypeSymbol (Symbol type_symb); + +extern unsigned long ConvertTypeToTypeVector (TypeNode type); + +extern FlatType RetrieveLhsOfTypeDefinition (SymbDef tdef); + +extern Ident IdentOfOverloadedInstance (Symbol inst_symb);
\ No newline at end of file diff --git a/backendC/CleanCompilerSources/typechecker2.h b/backendC/CleanCompilerSources/typechecker2.h new file mode 100644 index 0000000..0e0a7b8 --- /dev/null +++ b/backendC/CleanCompilerSources/typechecker2.h @@ -0,0 +1,206 @@ +/* + +Version 1.0 25/04/1994 + +Author: Sjaak Smetsers + +*/ + +#undef _TYPESBUG_ + +/* + Type definitions +*/ + +typedef + enum + { US_OK, US_OrdinaryFailure, US_SpecificationError, US_UniquenessError, US_UniquenessSpecificationError, + US_StrictnessError, US_LiftedTypeVarError, US_LiftedAttrVarError, US_OverloadingError, + US_ExistentialError, US_ConstructorVarError + } UnificationStatus; + +/* + Global variables +*/ + +extern ImpRules *LastNewImpRule; + +extern SymbDef *LastNewDependency; + +extern Symbol *LastNewSymbol; + +typedef struct overloaded_variable_list_elem +{ + TypeCell ovle_temp_type; + TypeCell ovle_copy_type; + struct overloaded_variable_list_elem * ovle_next; + +} *OverloadedVariableList; + +extern OverloadedVariableList OverloadedTypeVars; + +extern Bool DoDeriveUniAttributes; + +extern int ErroneousArgumentNumber; + +extern HeapDescr TCWorkSpace, TCTempSpace; + +extern void *AllocInTCWorkSpace (SizeT size); +/* + Global functions +*/ + +#ifdef _MEMORY_CHECK_ +#define SkipIndirections(type) \ + if (MemoryCheck (type), (type) -> tc_kind == Indirection)\ + (type) = (TypeCell) SkipIndirectionChain ((type) -> contents_indirect) +#else +#define SkipIndirections(type) \ + if ((type) -> tc_kind == Indirection)\ + (type) = (TypeCell) SkipIndirectionChain ((type) -> contents_indirect) +#endif + +extern TypeCell SkipIndirectionChain (TypeCell type); + +#define SkipSC_Indirections(type) \ + if ((type) -> tc_strict == SC_Indirection)\ + (type) = (TypeCell) Skip_SCI_Chain ((type) -> contents_si_indirect) + +extern TypeCell Skip_SCI_Chain (TypeCell type); + +#define SkipAttrVarIndirections(avar) \ + if ((avar) -> tav_varkind == AC_Indirection)\ + (avar) = SkipAttrVarIndirectionChain ((avar) -> tav_indirection) + +extern TempAttrVar SkipAttrVarIndirectionChain (TempAttrVar avar); + +#ifdef _MEMORY_CHECK_ +extern void MemoryCheck (void * ptr); +#else +#define MemoryCheck(ptr) +#endif + +extern PlainAttrVar NewPlainAttrVar (void); + +extern TempAttrVar NewTempAttrVar (void); + +extern AttrVarWithEquations NewAttrVarWithEquations (unsigned attrnr); + +extern TypeCell NewTypeVariableCell (HeapDescr hd, AttributeCellKind attrkind); + +extern TypeCell NewConstructorTypeCell (SymbDef type_cons, int act_arity, AttributeCellKind attrkind); + +#define cAddExtraArgument True +#define cDontAddExtraArgument False + +extern TypeCell NewTemporaryConstructorTypeCell (TypeConsRepr type_cons, int act_arity, AttributeCellKind attrkind, Bool extra_argument); + +extern BITVECT DetermineUniPropOfTypeCell (SymbDef cons_def, TypeCell cons_cell); + +extern BITVECT DetermineConsVarsOfTypeCons (SymbDef typecons, ConsVarList * cons_vars); + +extern BITVECT DetermineUniPropOfTypeCons (SymbDef typecons); + +extern BITVECT DetermineUniPropOfTypeConsVar (TypeArgClass arg_class [], int arity); + +extern void CreateAttributeEquationsForConstructorVariables (SymbDef cons_def, TypeCell arg_cells []); + +extern BITVECT DetermineUniVarsOfTypeCons (SymbDef typecons); + +extern AttributeCellKind DetermineAttrkindOfTemporaryTypeCell (TypeCell type); + +extern TypeCell NewAttributedTypeVariable (HeapDescr hd, AttrVarKind av_kind); + +extern TypeCell BasicCells [], UniqueBasicCells [], StrictBasicCells [Nr_Of_Basic_Types]; + +extern TypeCell NewTypeCell (CellKind kind, HeapDescr hd); + +extern TypeCell NewBasicTypeCell (Symbol symbol, HeapDescr hd); + +extern TypeCell NewAttributedBasicTypeCell (Symbol symbol, HeapDescr hd, AttributeCellKind attrkind); + +extern TypeCell NewFunctionTypeCell (HeapDescr hd, AttributeCellKind attrkind); + +extern TypeCell NewVoidTypeCell (AttributeCellKind attrkind, HeapDescr hd); + +extern TypeConsRepr NewTypeConstructorRepr (SymbDef symbol, int arity, HeapDescr hd); + +extern TypeCell NewConstructorVariableCell (int arity, HeapDescr hd); + +extern TypeCell NewEmptyTypeCell (Bool is_strict, HeapDescr hd); + +extern SymbDef GetTupleDef (int arity); + +extern SymbolType NewSymbolType (HeapDescr hd, int arity); + +extern void DumpSymbolType (Symbol symbol, SymbolType stype, int arity); + +typedef enum { LhsConstructor, RhsConstructor, AnySymbol } SymbolApplKind; + +extern TypeCell CreateInstance (TypeCell type, Bool marking, SymbolApplKind symb_appl, int inst_depth, unsigned group_nr); + +extern TypeCell CreateInstanceOfTypeCell (TypeCell elemtype); + +extern SymbolType CreateInstanceOfSymbolType (SymbolType stype, int demarity, int offarity, SymbolApplKind symb_appl); + +extern Bool ExpandSynonymTypesIfNecessary (TypeCell *t1, TypeCell *t2); + +extern UnificationStatus CompareSymbolTypes (SymbolType orig_type, SymbolType temp_type); + +extern UnificationStatus SubstituteVariable (TypeCell alpha, TypeCell beta); + +extern Bool CopySymbolType (SymbDef fun_symb, SymbolType dst_type); + +extern TypeCell RetrieveInstanceOfTypeVar (TypeCell type_var); + +extern void AdjustOverloadedNode (Node old_node, Node new_node); + +extern void AdjustRecursionNode (Node old_node, Node new_node); + +extern void CheckMarkingsOfSymbolType (SymbolType stype); + +extern AttrEquationList NewAttributeEquation (TempAttrVar demvar, TempAttrVar offvar, + AttrEquationList nextdem, AttrEquationList nextoff, Bool implicit); + +#define cEquationIsImplicit True +#define cEquationIsNotImplicit False + +extern void CreateAttributeEquation (TempAttrVar demvar, TempAttrVar offvar, Bool implicit); + +extern Bool AdjustDemandedAttributeList (TempAttrVar demvar); + +extern PolyList *CollectPropagatingTypeArgs (ConsVarList cons_var, TypeCell type_args [], int arity, + PolyList extra_args [], int nr_of_extra_args); + +extern Bool HasObservingResultType (TypeCell type); + +extern Bool AdjustAttributeOfTypeCell (TypeCell type, AttributeCellKind attr_kind); + +extern Bool MakeAttributeNotUnique (TypeCell type); + +extern SymbolType InstantiateRecordSelectorType (Symbol sel_symb, int sel_kind); + +typedef enum + { UEK_OK, UEK_MultiToUni, UEK_NonCoercible, UEK_UniqueRequired, UEK_EssentiallyUnique, UEK_ExistentionalAttr + } UniquenessErrorKind; + +extern UniquenessErrorKind DetermineAttributeDependencies (TypeCell demtype, TypeCell offtype, Bool write_access, Bool non_coercible); + +extern UniquenessErrorKind ExpandSubstitutedTypes (TypeCell type, TypeCell * result_cell_p); + +extern UniquenessErrorKind EquateAttributesOfType (TypeCell type1, AttributeCellKind attr1, TypeCell type2, AttributeCellKind attr2); + +extern TypeCell gErroneousTypeCell; +extern Bool gDemandedIsErroneous; + +#ifdef SHORT_CLASS_NAMES + +extern ModuleInfo gModuleInfo, gIclModuleInfo; + +extern ModuleInfo NewModuleInfo (Symbol module_symbol); + +extern int ConvertSymbolListToNumber (SymbolList class_symbols); + +#endif + + diff --git a/backendC/CleanCompilerSources/typechecker2_2.c b/backendC/CleanCompilerSources/typechecker2_2.c new file mode 100644 index 0000000..f882816 --- /dev/null +++ b/backendC/CleanCompilerSources/typechecker2_2.c @@ -0,0 +1,289 @@ +/* + Version 1.0 21/09/1994 + + Author: Sjaak Smetsers +*/ + +#include "system.h" + +#include "settings.h" +#include "syntaxtr.t" +#include "comsupport.h" + +#include "scanner.h" +#include "comparser.h" +#include "sizes.h" +#include "checker.h" +#include "transform.h" +#include "sa.h" +#include "statesgen.h" +#include "tctypes.t" +#include "typechecker.h" +#include "typechecker2.h" +#include "tcsupport.h" +#include "typeconv.h" +#include "refcountanal.h" +#include "overloading.h" +#include "buildtree.h" + +static char *TC2 = "typechecker2"; + +static TypeCell gSubType = NULL; +static unsigned NextTypeVariable; +static PolyList OverloadedTypeVariables; + +static void PrintAttributeEquationsOfTypes (TypeCell type); + +static Bool DPST = True, DPT = True; + +static void PrintTypeCell (TypeCell type, Bool brackets, Bool with_uni_attrs); + +static void PrintTypeCells (int arity, TypeCell typecells[], char separator, Bool brackets, Bool with_uni_attrs) +{ + if (arity > 0) + { int i; + PrintTypeCell (typecells [0], brackets, with_uni_attrs); + for (i=1; i<arity; i++) + { FPutC (separator, StdError); + PrintTypeCell (typecells [i], brackets, with_uni_attrs); + } + } + +} /* PrintTypeCells */ + +#define cDoPrintBrackets True +#define cDoNotPrintBrackets False + +#define cDoPrintAttributes True +#define cDoNotPrintAttributes False + +static void PrintAttributeVarWithEquations (AttrVarWithEquations avar) +{ +/** if (avar -> ave_coercible) + { switch (avar -> ave_refcount) + { + case RC_UsedOnceInLhs: + switch (avar -> ave_offrefcount) + { + case RC_NotUsed: + FPrintF (StdError, "<<%u>> ", avar -> ave_number); + break; + case RC_UsedOnceInLhs: + case RC_UsedInLhs: + FPrintF (StdError, "<%u> ", avar -> ave_number); + break; + default: + FPrintF (StdError, "%u ", avar -> ave_number); + break; + } + break; + case RC_UsedInRhs: + case RC_UsedOnceInRhs: + if (AppearOnlyAsOfferedAttrsInTheRhs (avar -> ave_equations)) + FPrintF (StdError, "|%u| ", avar -> ave_number); + else + FPrintF (StdError, "%u ", avar -> ave_number); + break; + default: + FPrintF (StdError, "%u ", avar -> ave_number); + break; + } + } + else **/ + FPrintF (StdError, "<%u> ", avar -> ave_number); + +} /* PrintAttributeVarWithEquations */ + +static char *PrintVars = "abcdefghi"; +#define NrOfPrintVars 9 + +static void PrintTypeVariable (TypeCell type_var) +{ + if (type_var -> contents_vc_number < NrOfPrintVars) + FPutC (PrintVars [type_var -> contents_vc_number - 1], StdError); + else + FPrintF (StdError, "a%d", type_var -> contents_vc_number); + +} /* PrintTypeVariable */ + +static void PrintTypeCell (TypeCell type, Bool brackets, Bool with_uni_attrs) +{ + if (type == NULL) + FPutC ('_', StdError); + else + { TypeCell ind_type = type; + SkipIndirections (type); + + if (gSubType != NULL) + type = SkipTypeSynIndirection (type); + if (type == gSubType) + FPutS ("^ ", StdError); + + if (with_uni_attrs) + { if (ind_type -> tc_attrkind != AC_NotUnique) + { if (ind_type -> tc_attrkind == AC_Unique) + FPutS ("* ", StdError); + else + { switch (ind_type -> tc_attrvarkind) + { + case AVK_Plain: + FPrintF (StdError, "Plain %lu ", (unsigned long) ind_type -> tc_plainattrvar); + break; + case AVK_Equation: + PrintAttributeVarWithEquations (ind_type -> tc_equattrvar); + ind_type -> tc_equattrvar -> ave_present_mark = True; + break; + case AVK_Temporarily: + if (ind_type -> tc_tempattrvar -> tav_varkind == AC_Unique) + FPutS ("* ", StdError); + else if (ind_type -> tc_tempattrvar -> tav_varkind == AC_Variable) + FPrintF (StdError, "Temp %lu ", (unsigned long) ind_type -> tc_tempattrvar); + break; + } + } + } + } + switch (type -> tc_kind) + { + case BasicType: + PrintSymbol (type -> contents_basic, StdError); + return; + case ConstructorType: + { SymbDef def = type -> contents_tc_symbdef; + if (def -> sdef_ident == ListId) + { FPutC ('[', StdError); + if (type -> contents_tc_arity == 1) + PrintTypeCell (type -> contents_tc_args [0], cDoNotPrintBrackets, with_uni_attrs); + FPutC (']', StdError); + } + else if (def -> sdef_ident == TupleId) + { FPutC ('(', StdError); + PrintTypeCells (type -> contents_tc_arity, type -> contents_tc_args, ',', False, with_uni_attrs); + FPutC (')', StdError); + } + else + { ArrayInstance arr_inst; + + for (arr_inst = 0; arr_inst < NrOfArrayInstances; arr_inst++) + { if (def == ArrayDefs [arr_inst]) + { switch (arr_inst) + { + case LazyArrayInstance: + FPutC ('{', StdError); + break; + case StrictArrayInstance: + FPutS ("{!", StdError); + break; + case UnboxedArrayInstance: + FPutS ("{#", StdError); + break; + } + if (type -> contents_tc_arity == 1) + PrintTypeCell (type -> contents_tc_args [0], cDoNotPrintBrackets, with_uni_attrs); + + FPutC ('}', StdError); + return; + } + } + if (brackets && type -> contents_tc_arity > 0) + FPutC ('(', StdError); + FPutS (def -> sdef_ident -> ident_name, StdError); + if (type -> contents_tc_arity > 0) + { FPutC (' ', StdError); + PrintTypeCells (type -> contents_tc_arity, type -> contents_tc_args, ' ', True, with_uni_attrs); + if (brackets) + FPutC (')', StdError); + } + } + return; + } + case FunctionType: + { TypeCell ft_arg = type -> contents_ft_arg; + + if (brackets) + FPutC ('(', StdError); + PrintTypeCell (ft_arg, ft_arg -> tc_kind == FunctionType, with_uni_attrs); + FPutS (" -> ", StdError); + + PrintTypeCell (type -> contents_ft_result, cDoNotPrintBrackets, with_uni_attrs); + if (brackets) + FPutC (')', StdError); + return; + } + case TypeVariable: + case ExistentialVariable: + if (! type -> tc_printed) + { type -> contents_vc_number = NextTypeVariable++; + type -> tc_printed = True; + if (type -> tc_overloaded) + OverloadedTypeVariables = NewPolyListElem (type, OverloadedTypeVariables, TCTempSpace); + } + PrintTypeVariable (type); + return; + case VoidType: + FPutS ("Void", StdError); + return; + case ConstructorVariable: + FPutC ('(', StdError); + PrintTypeCells (type -> contents_cova_arity + 1, type -> contents_cova_types, ' ', False, with_uni_attrs); + FPutC (')', StdError); + return; + default: + Assume (False, TC2, "PrintTypeCell"); + return; + } + } + +} /* PrintTypeCell */ + +static void *AllocInTCTempSpace (SizeT size) +{ + return TH_Alloc (TCTempSpace, size); + +} /* AllocInTCTempSpace */ + +static void PrintSymbolList (SymbolList class_symbs) +{ + SymbolList new_list = NULL; + ConvertClassSymbolTreeToList (class_symbs, & new_list, AllocInTCTempSpace); + + FPutC (' ', StdError); + PrintTypeClass (new_list -> sl_symbol, StdError); + + for (new_list = new_list -> sl_next; new_list; new_list = new_list -> sl_next) + { FPutS (" , ", StdError); + PrintTypeClass (new_list -> sl_symbol, StdError); + } + +} /* PrintTypeContext */ + +static void PrintTypeContexts (PolyList over_vars) +{ + for (;;) + { TypeCell next_var = (TypeCell) over_vars -> pl_elem; + + PrintSymbolList (next_var -> contents_overloaded); + FPutC (' ', StdError); + PrintTypeVariable (next_var); + if ((over_vars = over_vars -> pl_next)) + FPutS (" &", StdError); + else + break; + } + +} /* PrintTypeContexts */ + +void PrintTCType (TypeCell type, TypeCell sub_type) +{ + TypeCell prev_sub_type = gSubType; + gSubType = sub_type; + NextTypeVariable = 1; + OverloadedTypeVariables = NULL; + PrintTypeCell (type, cDoNotPrintBrackets, cDoNotPrintAttributes); + if (OverloadedTypeVariables) + { FPutS (" |", StdError); + PrintTypeContexts (OverloadedTypeVariables); + } + gSubType = prev_sub_type; + +} /* PrintTCType */ diff --git a/backendC/CleanCompilerSources/typechecker_2.c b/backendC/CleanCompilerSources/typechecker_2.c new file mode 100644 index 0000000..19a27c6 --- /dev/null +++ b/backendC/CleanCompilerSources/typechecker_2.c @@ -0,0 +1,126 @@ +/* + Version 1.2.3 26/03/1997 + + Author: Sjaak Smetsers +*/ + +#pragma options (!macsbug_names) + +#include "system.h" + +#include "settings.h" +#include "syntaxtr.t" +#include "comsupport.h" + +#include "scanner.h" +#include "comparser.h" +#include "sizes.h" +#include "checker.h" +#include "checksupport.h" +#include "transform.h" +#include "sa.h" +#include "statesgen.h" +#include "tctypes.t" +#include "typechecker.h" +#include "typechecker2.h" +#include "typeconv.h" +#include "refcountanal.h" +#include "overloading.h" +#include "tcsupport.h" +#include "buildtree.h" +#include "version.h" + +#ifdef _DEBUG_ + static char *TC = "typechecker"; +#endif + +#undef _TYPESBUG_ + +#ifdef _PRINTRULES_ +#include "dbprint.h" +#endif + +SymbDef ArrayDefs [NrOfArrayInstances]; + +void ListTypes (ImpMod imod) +{ + if (DoListAllTypes) + { ImpRules irule; + for (irule = imod -> im_rules; irule; irule = irule -> rule_next) + { SymbDef imp_sdef = irule -> rule_root -> node_symbol -> symb_def; + +#ifdef CLEAN2 + if (strncmp (imp_sdef->sdef_ident->ident_name, "_dictionary", 11) != 0 || imp_sdef->sdef_isused) +#endif + PrintType (imp_sdef, irule -> rule_type); + } + } + +} /* ListTypes */ + +PolyList UserDefinedArrayFunctions; + +Bool TypeError; + +FlatType RetrieveLhsOfTypeDefinition (SymbDef tdef) +{ + switch (tdef -> sdef_kind) + { + case TYPE: + case RECORDTYPE: + return tdef -> sdef_type != NULL ? tdef -> sdef_type -> type_lhs : NULL; + case TYPESYN: + return tdef -> sdef_syn_type -> syn_lhs; + break; + case ABSTYPE: + return tdef -> sdef_abs_type -> abs_graph; + break; + default: + return NULL; + } + +} /* RetrieveLhsOfTypeDefinition */ + +HeapDescr TCTempSpace; + +void InitTypeChecker (void) +{ +#ifndef CLEAN2 + EmptySymbol = CompAllocType (SymbolS); + EmptySymbol -> symb_kind = empty_symbol; + + InitialCellInfo.ci_removed = False; + InitialCellInfo.ci_free = False; + InitialCellInfo.ci_mark = False; + InitialCellInfo.ci_expanded = False; + InitialCellInfo.ci_printed = False; + InitialCellInfo.ci_hidden = False; + InitialCellInfo.ci_overloaded = False; + InitialCellInfo.ci_no_match = False; + InitialCellInfo.ci_class_var = False; + InitialCellInfo.ci_tmp_cell = False; + InitialCellInfo.ci_copy_cell = False; + InitialCellInfo.ci_strict = False; + InitialCellInfo.ci_with_insres = False; + InitialCellInfo.ci_non_coercible = False; + InitialCellInfo.ci_default = False; + + InitialCellInfo.ci_kind = BasicType; + InitialCellInfo.ci_attrkind = AC_NotUnique; + InitialCellInfo.ci_attrvarkind = AVK_Plain; + InitialCellInfo.ci_instdepth = 0; + + InitialTempAttrVar.tav_mark = False; + InitialTempAttrVar.tav_present = False; + InitialTempAttrVar.tav_free = False; + InitialTempAttrVar.tav_onstack = False; + InitialTempAttrVar.tav_exi_quanti = False; + InitialTempAttrVar.tav_non_coercible = False; + + InitialTempAttrVar.tav_varkind = AC_Variable; + InitialTempAttrVar.tav_number = 0; + InitialTempAttrVar.tav_offered = NULL; + InitialTempAttrVar.tav_demanded = NULL; +#endif +} + diff --git a/backendC/CleanCompilerSources/typeconv.h b/backendC/CleanCompilerSources/typeconv.h new file mode 100644 index 0000000..967c2dc --- /dev/null +++ b/backendC/CleanCompilerSources/typeconv.h @@ -0,0 +1,37 @@ +/* + +Version 1.0 25/04/1994 + +Author: Sjaak Smetsers + +*/ + +extern Bool ConvertTypesOfLiftedTypeVarsOrWildCards (TypeAlts type_alt, SymbolType symbtype, PolyList lifted_type_vars); + +extern TypeAlts ConvertSymbolTypeToRuleType (Symbol rule_symbol, SymbolType rtype, int arity, + TypeCell extra_args [], int nr_of_extra_args, TypeCell over_vars [], int over_arity); + +extern void PrintType (SymbDef tdef, TypeAlts type); + +extern Symbol ConvertSymbDefToSymbol (SymbDef sdef); + +extern void ConvertSymbolToType (SymbDef sdef, char * module_env); +extern Bool ConvertTypeAltToTCType (SymbDef lhs_def, SymbolType result_type, TypeAlts type_alt, + unsigned nr_of_lifted_args, int over_arity, TypeCell over_vars []); + +extern void InitAttributeRow (void); + +extern void InitARC_Info (void); + +extern void ConversionError (Symbol which_symbol, char *which, char *error); + +extern SymbolTypeInfoP NewSymbolTypeInfo (void); + +extern void PrintTypeClass (SymbDef class_def, File file); + +#define NewTypeCells(n,hd) TH_AllocArray (hd,n,TypeCell) + +#ifdef SHORT_CLASS_NAMES +extern void ConvertTypeContextToNumbers (DefMod dmod); +#endif + diff --git a/backendC/CleanCompilerSources/typeconv_2.c b/backendC/CleanCompilerSources/typeconv_2.c new file mode 100644 index 0000000..6a1c0fb --- /dev/null +++ b/backendC/CleanCompilerSources/typeconv_2.c @@ -0,0 +1,660 @@ +/* + +Version 1.0 26/08/1994 + +Author: Sjaak Smetsers + +*/ + +#define STATES_GENERATED +#define STORE_UNIQUE_ATTRIBUTES_IN_TYPE_NODES + +#include "system.h" + +#include "settings.h" +#include "syntaxtr.t" +#include "comsupport.h" + +#include "tctypes.t" +#include "scanner.h" +#include "comparser.h" +#include "sizes.h" +#include "checker.h" +#include "transform.h" +#include "sa.h" +#include "typechecker.h" +#include "typechecker2.h" +#include "typeconv.h" +#include "overloading.h" +#include "checksupport.h" +#include "statesgen.h" +#include "buildtree.h" + +typedef + struct attr_ref_count_info + { BITVECT arci_used; + BITVECT arci_multiply_used; + BITVECT arci_implicitly_attributed; + struct attr_ref_count_info * arci_next; + } * ARC_Info; + +static ARC_Info CurrentARC_Info; + +static ARC_Info NewARC_Info (void) +{ + ARC_Info new = CompAllocType (struct attr_ref_count_info); + new -> arci_used = ALLBITSCLEAR; + new -> arci_multiply_used = ALLBITSCLEAR; + new -> arci_implicitly_attributed = ALLBITSCLEAR; + new -> arci_next = NULL; + return new; + +} /* NewARC_Info */ + +static void ClearARC_Info (void) +{ + ARC_Info next; + for (next = CurrentARC_Info; next; next = next -> arci_next) + { next -> arci_used = ALLBITSCLEAR; + next -> arci_multiply_used = ALLBITSCLEAR; + next -> arci_implicitly_attributed = ALLBITSCLEAR; + } + +} /* ClearARC_Info */ + +static void UpdateRefCountInfo (int attr_var, Bool used_implicitly) +{ + ARC_Info attrinfo = CurrentARC_Info; + while (attr_var >= 32) + { attr_var -= 32; + if (attrinfo -> arci_next == NULL) + attrinfo -> arci_next = NewARC_Info (); + attrinfo = attrinfo -> arci_next; + } + if (used_implicitly) + attrinfo -> arci_implicitly_attributed |= BIT (attr_var); + if (BITTEST (attrinfo -> arci_used, attr_var)) + attrinfo -> arci_multiply_used |= BIT (attr_var); + else + attrinfo -> arci_used |= BIT (attr_var); + +} /* UpdateRefCountInfo */ + +static Bool DetermineRefCountOfAttributeVarsInTypeVar (TypeNode type_var) +{ + if (type_var -> type_node_attribute >= FirstUniVarNumber) + { if (type_var -> type_node_tv != NULL) + { if (! TestMark (type_var -> type_node_tv, tv_mark, TV_UNIQUE_VARIABLE_PRINT_MASK)) + { SetMark (type_var -> type_node_tv, tv_mark, TV_UNIQUE_VARIABLE_PRINT_MASK); + UpdateRefCountInfo (type_var -> type_node_attribute - FirstUniVarNumber, False); + } + } + return True; + } + else + return False; + +} /* DetermineRefCountOfAttributeVarsInTypeVar */ + +static BITVECT CombineTypeArguments (ConsVarList cons_var, int arity1, BITVECT args1, int arity2, BITVECT args2) +{ + BITVECT combined_args = ALLBITSCLEAR; + int cons_var_arity = cons_var -> cvl_arity; + + int i, j; + + for (j = 0; j < cons_var_arity; j++) + { BITVECT cons_var_prop = cons_var -> cvl_argclass [j].tac_uniprop; + + for (i = 0; i < arity1; i++) + { if (BITTEST (cons_var_prop, i) && BITTEST (args1, i)) + combined_args |= BIT (j); + } + + for (i = 0; i < arity2; i++) + { if (BITTEST (cons_var_prop, i+arity1) && BITTEST (args2, i)) + combined_args |= BIT (j); + } + } + + return combined_args; + +} /* CombineTypeArguments */ + +static Bool DetermineRefCountOfAttributeVarsInNode (TypeNode type_node); + +static Bool DetermineRefCountOfAttributeVarsInTypeConsNode (TypeNode type_node, Symbol type_symb, + int nr_of_extra_args, BITVECT extra_prop_args) +{ + TypeArgs type_args; + int arg_nr; + + Bool contains_propating_univars = False; + + ConsVarList cons_vars; + BITVECT uniprop, cons_var_vect, propagating_args = ALLBITSCLEAR; + + + if (type_symb -> symb_kind == definition) + { cons_var_vect = DetermineConsVarsOfTypeCons (type_symb -> symb_def, & cons_vars); + uniprop = DetermineUniPropOfTypeCons (type_symb -> symb_def); + } + else + { cons_var_vect = ALLBITSCLEAR; + cons_vars = NULL; + if (type_symb -> symb_kind == fun_type) + uniprop = ALLBITSCLEAR; + else if (type_symb -> symb_kind == apply_symb) + uniprop = BIT (0); + else + uniprop = ALLBITSSET; + } + + for (type_args = type_node -> type_node_arguments, arg_nr=0; type_args; + type_args = type_args -> type_arg_next, arg_nr++) + { if (! BITTEST (cons_var_vect, arg_nr)) + { if (DetermineRefCountOfAttributeVarsInNode (type_args -> type_arg_node)) + { propagating_args |= BIT(arg_nr); + if (BITTEST (uniprop, arg_nr)) + contains_propating_univars = True; + } + } + } + + for (type_args = type_node -> type_node_arguments, arg_nr=0; cons_vars; cons_vars = cons_vars -> cvl_next) + { for (; type_args != NULL && arg_nr < cons_vars -> cvl_number; arg_nr++, type_args = type_args -> type_arg_next) + ; + if (type_args != NULL) + { TypeNode cons_node = type_args -> type_arg_node; + + if (cons_node -> type_node_is_var) + { if (DetermineRefCountOfAttributeVarsInTypeVar (cons_node) && BITTEST (uniprop, arg_nr)) + contains_propating_univars = True; + } + else + { BITVECT comb_args_prop = CombineTypeArguments (cons_vars, type_node -> type_node_arity, propagating_args, + nr_of_extra_args, extra_prop_args); + + if (DetermineRefCountOfAttributeVarsInTypeConsNode (cons_node, cons_node -> type_node_symbol, + cons_vars -> cvl_arity, comb_args_prop) && BITTEST (uniprop, arg_nr)) + contains_propating_univars = True; + } + } + } + + if (! contains_propating_univars) + { extra_prop_args &= uniprop >> type_node -> type_node_arity; + + for (arg_nr = 0; arg_nr < nr_of_extra_args; arg_nr ++) + { if (BITTEST (extra_prop_args, arg_nr)) + { contains_propating_univars = True; + break; + } + } + } + + if (type_node -> type_node_attribute >= FirstUniVarNumber) + { UpdateRefCountInfo (type_node -> type_node_attribute - FirstUniVarNumber, contains_propating_univars); + return True; + } + else + return contains_propating_univars; + +} /* DetermineRefCountOfAttributeVarsInTypeConsNode */ + +static Bool DetermineRefCountOfAttributeVarsInNode (TypeNode type_node) +{ + if (type_node -> type_node_is_var) + return DetermineRefCountOfAttributeVarsInTypeVar (type_node); + else + { Symbol typesymb = type_node -> type_node_symbol; + + if (typesymb -> symb_kind < Nr_Of_Basic_Types) + { if (type_node -> type_node_attribute >= FirstUniVarNumber) + { UpdateRefCountInfo (type_node -> type_node_attribute - FirstUniVarNumber, False); + return True; + } + else + return False; + } + else + return DetermineRefCountOfAttributeVarsInTypeConsNode (type_node, typesymb, 0, ALLBITSCLEAR); + } + + +} /* DetermineRefCountOfAttributeVarsInNode */ + +static void DetermineRefCountOfAttributeVars (TypeAlts type) +{ + TypeArgs type_args; + UniVarEquations attr_equas; + + ClearARC_Info (); + + for (type_args = type -> type_alt_lhs -> type_node_arguments; type_args; type_args = type_args -> type_arg_next) + DetermineRefCountOfAttributeVarsInNode (type_args -> type_arg_node); + DetermineRefCountOfAttributeVarsInNode (type -> type_alt_rhs); + + for (attr_equas = type -> type_alt_attr_equations; attr_equas; attr_equas = attr_equas -> uve_next) + { AttributeKindList next; + UpdateRefCountInfo (attr_equas -> uve_demanded - FirstUniVarNumber, False); + for (next = attr_equas -> uve_offered; next; next = next -> akl_next) + UpdateRefCountInfo (next -> akl_elem - FirstUniVarNumber, False); + } + +} /* DetermineRefCountOfAttributeVars */ + +static char *TypeConv = "typeconv"; + +static unsigned RetrieveRefCountInfo (int attr_var, Bool *used_implicitly) +{ + ARC_Info attrinfo = CurrentARC_Info; + unsigned newnumber = 0; + int i; + + while (attr_var >= 32) + { attr_var -= 32; + for (i = 0; i < 32; i++) + { if (BITTEST (attrinfo -> arci_multiply_used, i)) + newnumber++; + } + attrinfo = attrinfo -> arci_next; + Assume (attrinfo != NULL, TypeConv, "RetrieveRefCountInfo"); + } + if (BITTEST (attrinfo -> arci_multiply_used, attr_var)) + { for (i = 0; i < attr_var; i++) + { if (BITTEST (attrinfo -> arci_multiply_used, i)) + newnumber++; + } + *used_implicitly = False; + return newnumber + 1; + } + else + { *used_implicitly = BITTEST (attrinfo -> arci_implicitly_attributed, attr_var); + return 0; + } + +} /* RetrieveRefCountInfo */ + +static char *PrintVars = "abcdefghijklmnopqrst"; +#define NrOfPrintVars 20 + +static char *PrintUniVars = "uvwxyz"; +#define NrOfPrintUniVars 6 + +#define cDoPrintAnnot True +#define cDontPrintAnnot False + +static void PrintNode (TypeNode node, Bool brackets, Bool strict_context, Bool print_annot); +static unsigned RetrieveRefCountInfo (int attr_var, Bool *used_implicitly); + +static void PrintAttributeVariable (unsigned attr_nr) +{ + if (attr_nr <= NrOfPrintUniVars) + FPrintF (StdListTypes, "%c", PrintUniVars [attr_nr - 1]); + else + FPrintF (StdListTypes, "u%d", attr_nr - NrOfPrintUniVars); + +} /* PrintAttributeVariable */ + +extern Bool DoShowAttributes; + +#define cDoPrintColon True + +static Bool PrintAttribute (AttributeKind attr, Bool print_colon) +{ + if (attr == UniqueAttr) + { FPutC ('*', StdListTypes); + return True; + } + else if (DoShowAttributes) + { Bool used_implicitly; + unsigned attr_nr = RetrieveRefCountInfo (attr - FirstUniVarNumber, & used_implicitly); + + if (attr_nr == 0) + { if (! used_implicitly) + { FPutC ('.', StdListTypes); + return True; + } + else + return False; + } + else + { PrintAttributeVariable (attr_nr); + if (print_colon) + FPutC (':', StdListTypes); + return True; + } + } + else + return False; + +} /* PrintAttribute */ + +#define cDoPrintAttribute True +#define cDontPrintAttribute False + +#define cInAStrictContext True +#define cNotInAStrictContext False + +#define cPrintBrackets True +#define cDontPrintBrackets False + + +static void PrintArgument (TypeArgs arg, Bool brackets, Bool strict_context, Bool print_attribute) +{ + if (arg -> type_arg_node -> type_node_is_var) + { if (strict_context) +#ifdef STATES_GENERATED +# if 1 + strict_context = arg -> type_arg_node -> type_node_annotation==StrictAnnot; +# else + strict_context = !IsLazyState (arg -> type_arg_node -> type_node_state); +# endif +#else + strict_context = arg -> type_arg_node -> type_node_state.state_kind == StrictOnA; +#endif + + if ( strict_context && (DoListAllTypes || DoListStrictTypes) && +#ifdef STATES_GENERATED +# if 1 + arg -> type_arg_node -> type_node_annotation==StrictAnnot) +# else + !IsLazyState (arg -> type_arg_node -> type_node_state)) +# endif +#else + arg -> type_arg_node -> type_node_state.state_kind == StrictOnA) +#endif + FPutC ('!', StdListTypes); + + if (print_attribute && arg -> type_arg_node -> type_node_attribute > NoAttr) + PrintAttribute (arg -> type_arg_node -> type_node_attribute, arg -> type_arg_node -> type_node_tv != NULL); + + if (arg -> type_arg_node -> type_node_tv) + { if (arg -> type_arg_node -> type_node_tv -> tv_ident) + FPutS (arg -> type_arg_node -> type_node_tv -> tv_ident -> ident_name, StdListTypes); + else + FPrintF (StdListTypes, "i%ld", arg -> type_arg_node -> type_node_tv); + } + } + else + PrintNode (arg -> type_arg_node, brackets, strict_context, cDoPrintAnnot); + +} /* PrintArgument */ + +static void PrintArguments (TypeArgs args, char separator, Bool brackets, Bool strict_context, FlatType form_type) +{ + if (args) + { int arg_nr, nr_of_exi_vars; + TypeVarList form_type_vars; + + if (form_type != NULL) + { nr_of_exi_vars = form_type -> ft_exist_arity; + form_type_vars = form_type -> ft_arguments; + + if (nr_of_exi_vars > 0) + { FPutC (':', StdListTypes); + PrintArgument (args, cPrintBrackets, strict_context, cDoPrintAttribute); + } + else + { PrintArgument (args, brackets, strict_context, ! TestMark (form_type_vars -> tvl_elem, tv_mark, TV_EXISTENTIAL_ATTRIBUTE_MASK)); + form_type_vars = form_type_vars -> tvl_next; + } + } + else + { nr_of_exi_vars = 0; + form_type_vars = NULL; + PrintArgument (args, brackets, strict_context, cDoPrintAttribute); + } + + for (arg_nr = 1, args = args -> type_arg_next; args; args = args -> type_arg_next, arg_nr++) + { if (arg_nr == nr_of_exi_vars) + FPutS (": ", StdListTypes); + else if (arg_nr < nr_of_exi_vars) + { FPutC (',', StdListTypes); + PrintArgument (args, brackets, strict_context, cDoPrintAttribute); + continue; + } + else + FPutC (separator, StdListTypes); + + if (form_type_vars != NULL) + { PrintArgument (args, brackets, strict_context, ! TestMark (form_type_vars -> tvl_elem, tv_mark, TV_EXISTENTIAL_ATTRIBUTE_MASK)); + form_type_vars = form_type_vars -> tvl_next; + } + else + PrintArgument (args, brackets, strict_context, cDoPrintAttribute); + } + if (arg_nr == nr_of_exi_vars) + FPutC (':', StdListTypes); + } + +} /* PrintArguments */ + +static void PrintNode (TypeNode node, Bool brackets, Bool strict_context, Bool print_annot) +{ + + if (print_annot && strict_context && (DoListAllTypes || DoListStrictTypes) && +#ifdef STATES_GENERATED +# if 1 + node -> type_node_annotation==StrictAnnot) +# else + !IsLazyState (node -> type_node_state)) +# endif +#else + node -> type_node_state.state_kind == StrictOnA) +#endif + FPutC ('!', StdListTypes); + + if (node -> type_node_attribute > NoAttr) + { if (PrintAttribute (node -> type_node_attribute, cDoPrintColon) && + (node -> type_node_symbol -> symb_kind == fun_type || node -> type_node_symbol -> symb_kind == apply_symb)) + brackets = True; + } + switch (node -> type_node_symbol -> symb_kind) + { + case tuple_type: + { int form_arity = node -> type_node_symbol -> symb_arity; + + if (node -> type_node_arity == form_arity) + { FPutC ('(', StdListTypes); + PrintArguments (node -> type_node_arguments, ',', cDontPrintBrackets, strict_context, NULL); + FPutC (')', StdListTypes); + } + else + { int i; + if (brackets && node -> type_node_arguments) + FPutC ('(', StdListTypes); + FPutC ('(', StdListTypes); + for (i=1; i<form_arity; i++) + FPutC (',', StdListTypes); + FPutC (')', StdListTypes); + if (node -> type_node_arguments) + { PrintArguments (node -> type_node_arguments, ' ', cPrintBrackets, strict_context, NULL); + if (brackets) + FPutC (')', StdListTypes); + } + } + break; + } + case list_type: + FPutC ('[', StdListTypes); + PrintArguments (node -> type_node_arguments, ',', cDontPrintBrackets, cNotInAStrictContext, NULL); + FPutC (']', StdListTypes); + break; + case array_type: + FPutS ("{", StdListTypes); + PrintArguments (node -> type_node_arguments, ',', cDontPrintBrackets, cInAStrictContext, NULL); + FPutS ("}", StdListTypes); + break; + case strict_array_type: + FPutS ("{!", StdListTypes); + PrintArguments (node -> type_node_arguments, ',', cDontPrintBrackets, cInAStrictContext, NULL); + FPutS ("}", StdListTypes); + break; + case unboxed_array_type: + FPutS ("{#", StdListTypes); + PrintArguments (node -> type_node_arguments, ',', cDontPrintBrackets, cInAStrictContext, NULL); + FPutS ("}", StdListTypes); + break; + case fun_type: + { TypeNode arg_type_node = node -> type_node_arguments -> type_arg_node; + if (brackets) + FPutC ('(', StdListTypes); + if ((! arg_type_node -> type_node_is_var) && arg_type_node -> type_node_symbol -> symb_kind == fun_type) + PrintArgument (node -> type_node_arguments, cPrintBrackets, cNotInAStrictContext, cDoPrintAttribute); + else + PrintArgument (node -> type_node_arguments, cDontPrintBrackets, cNotInAStrictContext, cDoPrintAttribute); + FPutS (" -> ", StdListTypes); + PrintArgument (node -> type_node_arguments -> type_arg_next, cDontPrintBrackets, cNotInAStrictContext, cDoPrintAttribute); + if (brackets) + FPutC (')', StdListTypes); + break; + } + case apply_symb: + if (brackets) + FPutC ('(', StdListTypes); + PrintArguments (node -> type_node_arguments, ' ', cPrintBrackets, strict_context, NULL); + if (brackets) + FPutC (')', StdListTypes); + break; + default: + if (brackets && node -> type_node_arguments) + FPutC ('(', StdListTypes); + PrintSymbol (node -> type_node_symbol, StdListTypes); + if (node -> type_node_arguments) + { FlatType lhs_type; + + if (node -> type_node_symbol -> symb_kind == definition) + lhs_type = RetrieveLhsOfTypeDefinition (node -> type_node_symbol -> symb_def); + else + lhs_type = NULL; + + FPutC (' ', StdListTypes); + PrintArguments (node -> type_node_arguments,' ', cPrintBrackets, strict_context, lhs_type); + if (brackets) + FPutC (')', StdListTypes); + } + break; + } + +} /* PrintNode */ + +static void PrintAttributeEquations (UniVarEquations attr_equas) +{ + FPutS (", [", StdListTypes); + + for ( ; ; ) + { AttributeKindList next; + Bool used_implicitly; + unsigned dem_attr_nr = RetrieveRefCountInfo (attr_equas -> uve_demanded - FirstUniVarNumber, & used_implicitly); + + for (next = attr_equas -> uve_offered ; ; ) + { unsigned off_attr_nr = RetrieveRefCountInfo (next -> akl_elem - FirstUniVarNumber, & used_implicitly); + PrintAttributeVariable (off_attr_nr); + if ((next = next -> akl_next)) + FPutC (' ', StdListTypes); + else + break; + } + + + FPutS (" <= ", StdListTypes); + PrintAttributeVariable (dem_attr_nr); + + if ((attr_equas = attr_equas -> uve_next)) + FPutS (", ", StdListTypes); + else + break; + } + FPutC (']', StdListTypes); + +} /* PrintAttributeEquations */ + +#include <ctype.h> + +void PrintTypeClass (SymbDef class_def, File file) +{ + char * class_name = class_def -> sdef_ident -> ident_name; + + if (*class_name == '.') + class_name++; + + FPutS (class_name, file); + +} /* PrintTypeClass */ + +static void PrintTypeContext (TypeContext context) +{ + SymbolList class_symbs = context -> tyco_symbols; + TypeVar context_var = context -> tyco_variable; + + PrintTypeClass (class_symbs -> sl_symbol, StdListTypes); + + for (class_symbs = class_symbs -> sl_next; class_symbs; class_symbs = class_symbs -> sl_next) + { FPutS (" , ", StdListTypes); + PrintTypeClass (class_symbs -> sl_symbol, StdListTypes); + } + + FPutC (' ', StdListTypes); + if (TestMark (context_var, tv_mark, TV_WITH_INST_RESTR)) + FPutC ('.', StdListTypes); + FPutS (context_var -> tv_ident -> ident_name, StdListTypes); + +} /* PrintTypeContext */ + +void PrintType (SymbDef tdef, TypeAlts type) +{ + TypeNode lhs_root = type -> type_alt_lhs; + TypeArgs lhsargs = lhs_root -> type_node_arguments; + int i; + + if (tdef -> sdef_unq_attributed && DoShowAttributes) + DetermineRefCountOfAttributeVars (type); + + for (i=0; i<tdef -> sdef_nr_of_lifted_nodeids; i++) + lhsargs = lhsargs -> type_arg_next; + + PrintSymbolOfIdent (tdef -> sdef_ident, tdef -> sdef_line, StdListTypes); + FPutS (" :: ", StdListTypes); + + if (lhsargs) + { PrintArguments (lhsargs,' ', cPrintBrackets, cInAStrictContext, NULL); + FPutS (" -> ", StdListTypes); + } + if (type -> type_alt_rhs -> type_node_is_var) + { if (type -> type_alt_rhs -> type_node_attribute > NoAttr) + PrintAttribute (type -> type_alt_rhs -> type_node_attribute, cDoPrintColon); + FPutS (type -> type_alt_rhs -> type_node_tv -> tv_ident -> ident_name, StdListTypes); + } + else + { Bool rhs_brackets = (lhsargs == NULL) && (type -> type_alt_rhs -> type_node_symbol -> symb_kind == fun_type); + PrintNode (type -> type_alt_rhs, rhs_brackets, cInAStrictContext, cDontPrintAnnot); + } + if (type -> type_alt_type_context) + { TypeContext next_context; + FPutS (" | ", StdListTypes); + PrintTypeContext (type -> type_alt_type_context); + for (next_context = type -> type_alt_type_context -> tyco_next; next_context; next_context = next_context -> tyco_next) + { FPutS (" & ", StdListTypes); + PrintTypeContext (next_context); + } + } + + if (DoShowAttributes && type -> type_alt_attr_equations) + PrintAttributeEquations (type -> type_alt_attr_equations); + + FPutS (";\n", StdListTypes); + + if (tdef -> sdef_nr_of_lifted_nodeids > 0) + { FPutS ("// internal argument types:", StdListTypes); + for (i=0, lhsargs = lhs_root -> type_node_arguments; + i<tdef -> sdef_nr_of_lifted_nodeids; i++, lhsargs = lhsargs -> type_arg_next) + { FPutC (' ', StdListTypes); + PrintArgument (lhsargs, cPrintBrackets, cInAStrictContext, cDoPrintAttribute); + } + FPutC ('\n', StdListTypes); + } + + +} /* PrintType */ diff --git a/backendC/CleanCompilerSources/types.t b/backendC/CleanCompilerSources/types.t new file mode 100644 index 0000000..74feca2 --- /dev/null +++ b/backendC/CleanCompilerSources/types.t @@ -0,0 +1,82 @@ + +#if !defined (_THE__TYPES_) +#define _THE__TYPES_ + +#define _WINDOWS_ + +#if (defined (__MWERKS__) && !defined (_WINDOWS_)) || defined (__MRC__) +# define POWER 1 +#endif + +#define NIL 0L +#define Null 0L + +#define REALSIZE 2 +#define FILESIZE 2 + +#define KBYTE 1024L + +#ifdef THINK_C + typedef enum { + False = 0, True, MightBeTrue + } Bool; +#else + typedef unsigned Bool; + enum { + False = 0, True, MightBeTrue + }; +#endif + +typedef enum + {abcFile = 1, iclFile, dclFile, dumpFile, statFile, + stasFile, helpFile, applFile, assFile, sunAssFile, + obj00File, obj20File, obj81File, + otherFile,miraFile,miraExpFile + } FileKind; + +#define EndOfFile ((int) -1) +#define FileNameMax 256 +#define FOpenMax 10 +#define SeekSet +#define SeekCur +#define SeekEnd + +typedef unsigned long SysTime; + +#define NR_OPTIONS 9 + +typedef struct +{ + unsigned opt_code:1, + opt_debug:1, + opt_inline:1, + opt_listalltypes:1, + opt_listtypes:1, + opt_parallel:1, + opt_stacklayout:1, + opt_strictnessanalysis:1, + opt_typecheck:1, + opt_verbose:1, + opt_warning:1, + opt_system:1, + opt_liststricttypes:1; +} CompilerOptions; + + +#endif + +#ifdef _WINDOWS_ +#include <stdarg.h> +#define FileTime FILETIME +#ifdef __MWERKS__ +# include <x86_prefix.h> +#else +# define _X86_ +#endif +#include <windef.h> +#include <winbase.h> +#else +typedef unsigned long FileTime; +#endif + +#define NoFile ((FileTime) 0) diff --git a/backendC/CleanCompilerSources/version.c b/backendC/CleanCompilerSources/version.c new file mode 100644 index 0000000..473ba40 --- /dev/null +++ b/backendC/CleanCompilerSources/version.c @@ -0,0 +1,3 @@ +#include "version.h" + +int VERSION=916; diff --git a/backendC/CleanCompilerSources/version.h b/backendC/CleanCompilerSources/version.h new file mode 100644 index 0000000..c0310a7 --- /dev/null +++ b/backendC/CleanCompilerSources/version.h @@ -0,0 +1 @@ +extern int VERSION;
\ No newline at end of file diff --git a/backendC/CleanCompilerSources/windows_io.c b/backendC/CleanCompilerSources/windows_io.c new file mode 100644 index 0000000..986d95e --- /dev/null +++ b/backendC/CleanCompilerSources/windows_io.c @@ -0,0 +1,442 @@ + +#ifdef __MWERKS__ +# define _WINDOWS_ +#endif + +#include "compiledefines.h" +#include "system.h" +#include <stdio.h> + +#ifdef __MWERKS__ +# include <x86_prefix.h> +#else +# define _X86_ +#endif +#include <windef.h> +#include <winbase.h> + +char *GetFileExtension (FileKind kind) +{ + switch (kind){ + case abcFile: + return ".abc"; + case obj00File: + case obj20File: + case obj81File: + return ".obj"; + case iclFile: + return ".icl"; + case dclFile: + return ".dcl"; + case dumpFile: + return ".dmp"; + case statFile: + return ".stt"; + case stasFile: + return ".str"; + case assFile: + return ".a"; + case sunAssFile: + return ".s"; + case helpFile: + case applFile: + case otherFile: + default: + return ""; + } +} + +char clean_lib_directory[129] = "."; + +#if WRITE_DCL_MODIFICATION_TIME +static int file_exists_with_time (char *file_name,FileTime *file_time_p) +{ + HANDLE h; + WIN32_FIND_DATA find_data; + + h=FindFirstFile (file_name,&find_data); + + if (h!=INVALID_HANDLE_VALUE){ + FindClose (h); + + *file_time_p=find_data.ftLastWriteTime; + return True; + } else + return False; +} +#endif + +static int file_exists (char *file_name) +{ + HANDLE h; + WIN32_FIND_DATA find_data; + + h=FindFirstFile (file_name,&find_data); + + if (h!=INVALID_HANDLE_VALUE){ + FindClose (h); + return True; + } else + return False; +} + +static int use_clean_system_files_folder=1; + +extern char *path_parameter; + +#if WRITE_DCL_MODIFICATION_TIME +static Bool find_filepath_and_time (char *fname,FileKind kind,char *path,FileTime *file_time_p) +{ + char *s,*path_elem,c,*pathlist,*ext; + + if (path_parameter==NULL) + pathlist=getenv ("CLEANPATH"); + else + pathlist=path_parameter; + + if (pathlist==NULL) + pathlist="."; + + ext = GetFileExtension (kind); + + if (! (fname[0]=='\\' || (fname[0]!=0 && fname[1]==':'))){ + path_elem = pathlist; + + s=path_elem; + for (;;){ + c = *s; + if (c == ';' || c == '\0'){ + char *from_p,*dest_p; + + from_p=path_elem; + dest_p=path; + while (from_p<s) + *dest_p++ = *from_p++; + *dest_p = '\0'; + + strcat (path,"\\"); + strcat (path,fname); + strcat (path,ext); + if (file_exists_with_time (path,file_time_p)) + return True; + + if (c == '\0') + break; + + path_elem = ++s; + } else + ++s; + } + } + + strcpy (path,fname); + strcat (path,ext); + + return file_exists_with_time (path,file_time_p); +} +#endif + +static Bool findfilepath (char *fname,FileKind kind,char *path) +{ + char *s,*path_elem,c,*pathlist,*ext; + int in_clean_system_files_folder; + + if (path_parameter==NULL) + pathlist=getenv ("CLEANPATH"); + else + pathlist=path_parameter; + + if (pathlist==NULL) + pathlist="."; + + ext = GetFileExtension (kind); + + in_clean_system_files_folder=0; + + if (use_clean_system_files_folder) + switch (kind){ + case abcFile: + case obj00File: + case obj20File: + case obj81File: + in_clean_system_files_folder=1; + } + + + if (! (fname[0]=='\\' || (fname[0]!=0 && fname[1]==':'))){ + path_elem = pathlist; + + s=path_elem; + for (;;){ + c = *s; + if (c == ';' || c == '\0'){ + char *from_p,*dest_p; + + from_p=path_elem; + dest_p=path; + while (from_p<s) + *dest_p++ = *from_p++; + *dest_p = '\0'; + + if (in_clean_system_files_folder) + strcat (path,"\\Clean System Files\\"); + else + strcat (path,"\\"); + strcat (path,fname); + strcat (path,ext); + if (file_exists (path)) + return True; + + if (c == '\0') + break; + + path_elem = ++s; + } else + ++s; + } + } + + if (in_clean_system_files_folder){ + strcpy (path,"Clean System Files\\"); + strcat (path,fname); + } else + strcpy (path,fname); + strcat (path,ext); + + return file_exists (path); +} + +/* +#include <share.h> + + file=(File) _fsopen (path,mode,_SH_DENYNO); +*/ + +#if WRITE_DCL_MODIFICATION_TIME +File FOpenWithFileTime (char *file_name,FileKind kind, char *mode,FileTime *file_time_p) +{ + char path[MAXPATHLEN]; + Bool res; + + res=find_filepath_and_time (file_name, kind, path,file_time_p); + + if (res || mode[0] != 'r') + return fopen (path, mode); + else + return NULL; +} +#endif + +File FOpen (char *fname,FileKind kind,char *mode) +{ + char path[MAXPATHLEN]; + Bool res; + + if (fname[0]=='\\' || (fname[0]!=0 && fname[1]==':')){ + strcpy (path,fname); + strcat (path,GetFileExtension (kind)); + return fopen (path,mode); + } + + if (mode[0]=='r'){ + findfilepath (fname,kind,path); + return fopen (path,mode); + } else { + res=findfilepath (fname,dclFile,path); + if (!res) + res=findfilepath (fname,iclFile,path); + + if (res){ + char *p,*after_last_slash; + + after_last_slash=NULL; + + p=path; + while (*p) + if (*p++=='\\') + after_last_slash=p; + + if (after_last_slash==NULL) + after_last_slash=path; + + if (use_clean_system_files_folder){ + strcpy (after_last_slash,"Clean System Files"); + + if (!file_exists (path)){ + SECURITY_ATTRIBUTES sa; + + sa.nLength = sizeof(SECURITY_ATTRIBUTES); + sa.bInheritHandle = TRUE; + sa.lpSecurityDescriptor = NULL; + + CreateDirectory (path,&sa); + } + + strcat (after_last_slash,"\\"); + strcat (after_last_slash,fname); + } else + strcpy (after_last_slash,fname); + strcat (after_last_slash,GetFileExtension (kind)); + + return fopen (path,mode); + } else + return NULL; + } +} + +int FClose (File f) +{ + return fclose ((FILE *) f); +} + +int FDelete (char *fname, FileKind kind) +{ + char path[MAXPATHLEN]; + Bool res; + + res = findfilepath (fname,kind,path); + + if (res) + return remove (path); + else + return -1; +} + +int FPrintF (File f, char *fmt, ...) +{ int n; + va_list args; + + va_start (args, fmt); + + n = vfprintf ((FILE*)f, fmt, args); + + va_end (args); + return n; +} + +size_t FWrite (void *ptr, size_t size, size_t count, File f) +{ + return fwrite (ptr, size, count, (FILE *) f); +} + +size_t FRead (void *ptr, size_t size, size_t count, File f) +{ + return fread (ptr, size, count, (FILE *) f); +} + +char *FGetS (char *s, int n, File f) +{ + return fgets (s, n, (FILE *) f); +} + +int FPutS (char *s, File f) +{ + return fputs (s, (FILE *) f); +} + +int FSeek (File f, long offset, int origin) +{ + return fseek ((FILE *) f, offset, origin); +} + +long FTell (File f) +{ + return ftell ((FILE *) f); +} + +SysTime GetSysTime (unsigned scale) +{ + return 0; +} + +void StopTimer (void) +{ +} + +void ResetTimer (void) +{ +} + +void DoError (char *fmt, ...) +{ + va_list args; + + va_start (args, fmt); + + (void) vfprintf (stderr, fmt, args); + + va_end (args); +} + +void DoFatalError (char *fmt, ...) +{ + va_list args; + + va_start (args, fmt); + + (void) vfprintf (stderr, fmt, args); + + va_end (args); + + exit (0); +} + +void CmdError (char *errormsg,...) +{ + va_list args; + + va_start (args, errormsg); + + fputs ("Command line error: ", stdout); + vfprintf (stdout, errormsg, args); + fputc ('\n', stdout); + + va_end (args); +} + +static void DoNothing (void) +{ +} + +void (*SetSignal (void (*f) (void))) (void) +{ + return DoNothing; +} + +int CheckInterrupt (void) +{ + return 0; +} + +void *Alloc (long unsigned count, SizeT size) +{ + if (size == 1){ + if (count >= MAXUNSIGNED) + DoFatalError ("Allocate: severe memory allocation problem"); + return (void *) malloc ((size_t) count); + } + else if (count >= (MAXUNSIGNED / size)) + DoFatalError ("Allocate: severe memory allocation problem"); + return (void *) malloc ((size_t) (count * size)); +} + +void Free (void *p) +{ + (void) free (p); +} + +#ifdef WRITE_DCL_MODIFICATION_TIME +void FWriteFileTime (FileTime file_time,File f) +{ + SYSTEMTIME date_and_time; + FILETIME local_file_time; + + FileTimeToLocalFileTime (&file_time,&local_file_time); + + FileTimeToSystemTime (&local_file_time,&date_and_time); + + fprintf (f,"%04d%02d%02d%02d%02d%02d", + date_and_time.wYear,date_and_time.wMonth,date_and_time.wDay, + date_and_time.wHour,date_and_time.wMinute,date_and_time.wSecond); +} +#endif diff --git a/backendC/CleanCompilerSources/windows_io.h b/backendC/CleanCompilerSources/windows_io.h new file mode 100644 index 0000000..6567980 --- /dev/null +++ b/backendC/CleanCompilerSources/windows_io.h @@ -0,0 +1,48 @@ + +extern int MACVAR; +#define CheckVersion if (MACVAR != VERSION) DoFatalError ("Wrong version number") + +typedef short TwoBytesInt; +typedef int FourBytesInt; +typedef unsigned short TwoBytesUnsigned; +typedef unsigned int FourBytesUnsigned; + +typedef double EightBytesReal; +typedef float FourBytesReal; + +#define SizeT unsigned long +#define SizeOf(A) ((SizeT) sizeof (A)) + +#include <limits.h> +#define MAXUNSIGNED ULONG_MAX + +#define _VARARGS_ + +#include <string.h> +#include <stdlib.h> + +#if defined (__MWERKS__) || defined (_WINDOWS_) +# include <stdio.h> +#else +# include <unix.h> +#endif + +#include <setjmp.h> +#include <stdarg.h> + +typedef FILE *File; + +/* special for MacIntosh command line support */ +extern void InitIO (void); +extern void GetPreferences (char *fname); + +#define StdOut stdout +#define StdError stderr +#define StdVerboseH stdout +#define StdVerboseL stdout +#define StdTrace stdout +#define StdDebug stdout; +#define StdListTypes stdout + +#define FGetC(f) fgetc(f) +#define FPutC(c,f) fputc(c,f) |