# 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 */