Commit 89f4221b authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏘
Browse files

remove TC; types

type constructors in dynamic types are now uniquely represented by the
descriptor of their TD_ (type definition) function
parent fdcb4510
...@@ -383,7 +383,8 @@ backEndConvertModules p s main_dcl_module_n var_heap attr_var_heap be ...@@ -383,7 +383,8 @@ backEndConvertModules p s main_dcl_module_n var_heap attr_var_heap be
backEndConvertModulesH :: PredefinedSymbols FrontEndSyntaxTree !Int *BackEndState -> *BackEndState backEndConvertModulesH :: PredefinedSymbols FrontEndSyntaxTree !Int *BackEndState -> *BackEndState
backEndConvertModulesH predefs {fe_icl = backEndConvertModulesH predefs {fe_icl =
fe_icl =: {icl_name, icl_functions, icl_common,icl_global_functions,icl_imported_objects,icl_foreign_exports,icl_used_module_numbers, icl_modification_time}, fe_icl =: {icl_name, icl_functions, icl_common,icl_global_functions,
icl_type_funs, icl_imported_objects,icl_foreign_exports,icl_used_module_numbers, icl_modification_time},
fe_components, fe_dcls, fe_arrayInstances} fe_components, fe_dcls, fe_arrayInstances}
main_dcl_module_n backEnd main_dcl_module_n backEnd
// sanity check ... // sanity check ...
...@@ -398,7 +399,8 @@ backEndConvertModulesH predefs {fe_icl = ...@@ -398,7 +399,8 @@ backEndConvertModulesH predefs {fe_icl =
= backEnd = backEnd
# backEnd # backEnd
= abort "front end abort" backEnd = abort "front end abort" backEnd
*/ #! backEnd = appBackEnd (BESetMainDclModuleN main_dcl_module_n) backEnd */
#! backEnd = appBackEnd (BESetMainDclModuleN main_dcl_module_n) backEnd
#! backEnd #! backEnd
= appBackEnd (BEDeclareModules (size fe_dcls)) backEnd = appBackEnd (BEDeclareModules (size fe_dcls)) backEnd
#! backEnd #! backEnd
...@@ -442,7 +444,8 @@ backEndConvertModulesH predefs {fe_icl = ...@@ -442,7 +444,8 @@ backEndConvertModulesH predefs {fe_icl =
#! backEnd #! backEnd
= appBackEnd (BEDeclareIclModule icl_name.id_name icl_modification_time (size icl_functions) (size icl_common.com_type_defs) (size icl_common.com_cons_defs) (size icl_common.com_selector_defs)) (backEnd -*-> "BEDeclareIclModule") = appBackEnd (BEDeclareIclModule icl_name.id_name icl_modification_time (size icl_functions) (size icl_common.com_type_defs) (size icl_common.com_cons_defs) (size icl_common.com_selector_defs)) (backEnd -*-> "BEDeclareIclModule")
#! backEnd #! backEnd
= declareFunctionSymbols icl_functions functionIndices icl_global_functions (backEnd -*-> "declareFunctionSymbols") = declareFunctionSymbols icl_functions functionIndices
(icl_type_funs ++ icl_global_functions) (backEnd -*-> "declareFunctionSymbols")
#! backEnd #! backEnd
= declare main_dcl_module_n icl_common (backEnd -*-> "declare (main_dcl_module_n)") = declare main_dcl_module_n icl_common (backEnd -*-> "declare (main_dcl_module_n)")
#! backEnd #! backEnd
...@@ -470,6 +473,16 @@ backEndConvertModulesH predefs {fe_icl = ...@@ -470,6 +473,16 @@ backEndConvertModulesH predefs {fe_icl =
with with
dcl_common dcl_common
= currentDcl.dcl_common = currentDcl.dcl_common
# backEnd
= foldSt beExportFunction exported_local_type_funs backEnd
with
exported_local_type_funs
| False && currentDcl.dcl_module_kind == MK_None
= []
// otherwise
= flatten [[r.ir_from .. r.ir_to-1]
\\ r <- [icl_type_funs!!1]]
# backEnd = bindSpecialIdents predefs icl_used_module_numbers backEnd # backEnd = bindSpecialIdents predefs icl_used_module_numbers backEnd
#! backEnd = removeExpandedTypesFromDclModules fe_dcls icl_used_module_numbers backEnd #! backEnd = removeExpandedTypesFromDclModules fe_dcls icl_used_module_numbers backEnd
= (backEnd -*-> "backend done") = (backEnd -*-> "backend done")
...@@ -483,7 +496,9 @@ declareOtherDclModules dcls main_dcl_module_n used_module_numbers ...@@ -483,7 +496,9 @@ declareOtherDclModules dcls main_dcl_module_n used_module_numbers
where where
declareOtherDclModule :: ModuleIndex DclModule -> BackEnder declareOtherDclModule :: ModuleIndex DclModule -> BackEnder
declareOtherDclModule moduleIndex dclModule declareOtherDclModule moduleIndex dclModule
| moduleIndex == main_dcl_module_n || moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers) | moduleIndex == main_dcl_module_n
|| moduleIndex == cPredefinedModuleIndex
|| not (inNumberSet moduleIndex used_module_numbers)
= identity = identity
// otherwise // otherwise
= declareDclModule moduleIndex dclModule = declareDclModule moduleIndex dclModule
...@@ -494,7 +509,9 @@ defineOtherDclModules dcls main_dcl_module_n used_module_numbers ...@@ -494,7 +509,9 @@ defineOtherDclModules dcls main_dcl_module_n used_module_numbers
where where
defineOtherDclModule :: ModuleIndex DclModule -> BackEnder defineOtherDclModule :: ModuleIndex DclModule -> BackEnder
defineOtherDclModule moduleIndex dclModule defineOtherDclModule moduleIndex dclModule
| moduleIndex == main_dcl_module_n || moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers) | moduleIndex == main_dcl_module_n
|| moduleIndex == cPredefinedModuleIndex
|| not (inNumberSet moduleIndex used_module_numbers)
= identity = identity
// otherwise // otherwise
= defineDclModule moduleIndex dclModule = defineDclModule moduleIndex dclModule
...@@ -518,9 +535,11 @@ declareDclModule moduleIndex {dcl_name, dcl_modification_time, dcl_common, dcl_f ...@@ -518,9 +535,11 @@ declareDclModule moduleIndex {dcl_name, dcl_modification_time, dcl_common, dcl_f
= appBackEnd (BEDeclareDclModule moduleIndex dcl_name.id_name dcl_modification_time (isSystem dcl_module_kind) (size dcl_functions) (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs) (size dcl_common.com_selector_defs)) = appBackEnd (BEDeclareDclModule moduleIndex dcl_name.id_name dcl_modification_time (isSystem dcl_module_kind) (size dcl_functions) (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs) (size dcl_common.com_selector_defs))
defineDclModule :: ModuleIndex DclModule -> BackEnder defineDclModule :: ModuleIndex DclModule -> BackEnder
defineDclModule moduleIndex {dcl_name, dcl_common, dcl_functions,dcl_instances} defineDclModule moduleIndex
{dcl_name, dcl_common, dcl_functions, dcl_type_funs, dcl_instances}
= declare moduleIndex dcl_common = declare moduleIndex dcl_common
o` declareFunTypes moduleIndex dcl_functions dcl_instances.ir_from o` declareFunTypes moduleIndex dcl_functions
[{ir_from = 0, ir_to = dcl_instances.ir_from}, dcl_type_funs]
removeExpandedTypesFromDclModules :: {#DclModule} NumberSet -> BackEnder removeExpandedTypesFromDclModules :: {#DclModule} NumberSet -> BackEnder
removeExpandedTypesFromDclModules dcls used_module_numbers removeExpandedTypesFromDclModules dcls used_module_numbers
...@@ -654,7 +673,6 @@ declareFunctionSymbols functions functionIndices globalFunctions backEnd ...@@ -654,7 +673,6 @@ declareFunctionSymbols functions functionIndices globalFunctions backEnd
where where
functionName :: {#Char} Int [IndexRange] -> {#Char} functionName :: {#Char} Int [IndexRange] -> {#Char}
functionName name functionIndex icl_global_functions functionName name functionIndex icl_global_functions
// | trace_t ("|"+++toString functionIndex)
| index_in_ranges functionIndex icl_global_functions | index_in_ranges functionIndex icl_global_functions
= name = name
= (name +++ ";" +++ toString functionIndex) = (name +++ ";" +++ toString functionIndex)
...@@ -744,28 +762,30 @@ instance declareWithIndex (TypeDef a) where ...@@ -744,28 +762,30 @@ instance declareWithIndex (TypeDef a) where
declareWithIndex typeIndex moduleIndex {td_ident} declareWithIndex typeIndex moduleIndex {td_ident}
= appBackEnd (BEDeclareType typeIndex moduleIndex td_ident.id_name) = appBackEnd (BEDeclareType typeIndex moduleIndex td_ident.id_name)
declareFunTypes :: ModuleIndex {#FunType} Int -> BackEnder declareFunTypes :: ModuleIndex {#FunType} [IndexRange] -> BackEnder
declareFunTypes moduleIndex funTypes nrOfDclFunctions declareFunTypes moduleIndex funTypes ranges
= foldStateWithIndexA (declareFunType moduleIndex nrOfDclFunctions) funTypes = foldStateWithIndexA (declareFunType moduleIndex ranges) funTypes
declareFunType :: ModuleIndex Index Int FunType -> BackEnder declareFunType :: ModuleIndex [IndexRange] Int FunType -> BackEnder
declareFunType moduleIndex nrOfDclFunctions functionIndex {ft_ident, ft_type_ptr} declareFunType moduleIndex ranges functionIndex {ft_ident, ft_type_ptr}
= \be0 -> let (vi,be) = read_from_var_heap ft_type_ptr be0 in = \be0 -> let (vi,be) = read_from_var_heap ft_type_ptr be0 in
(case vi of (case vi of
VI_ExpandedType expandedType VI_ExpandedType expandedType
-> beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex nrOfDclFunctions) -> beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex ranges)
o` beDefineRuleType functionIndex moduleIndex (convertTypeAlt functionIndex moduleIndex expandedType) o` beDefineRuleType functionIndex moduleIndex (convertTypeAlt functionIndex moduleIndex expandedType)
_ _
-> identity) be -> identity) be
where where
functionName :: {#Char} Int Int -> {#Char} functionName :: {#Char} Int [IndexRange] -> {#Char}
functionName name functionIndex nrOfDclFunctions functionName name functionIndex ranges
// | trace_tn (name+++(if (functionIndex < nrOfDclFunctions) "" (";" +++ toString functionIndex))) | index_in_ranges functionIndex ranges
| functionIndex < nrOfDclFunctions
= name = name
// otherwise = (name +++ ";" +++ toString functionIndex)
= name +++ ";" +++ toString functionIndex where
index_in_ranges index [{ir_from, ir_to}:ranges]
= (index>=ir_from && index < ir_to) || index_in_ranges index ranges;
index_in_ranges index []
= False
defineTypes :: ModuleIndex {#ConsDef} {#SelectorDef} {#CheckedTypeDef} -> BackEnder defineTypes :: ModuleIndex {#ConsDef} {#SelectorDef} {#CheckedTypeDef} -> BackEnder
defineTypes moduleIndex constructors selectors types defineTypes moduleIndex constructors selectors types
......
...@@ -502,7 +502,10 @@ BEDeclareModules (int nModules) ...@@ -502,7 +502,10 @@ BEDeclareModules (int nModules)
gBEState.be_modules = (BEModuleP) ConvertAlloc (nModules * sizeof (BEModuleS)); gBEState.be_modules = (BEModuleP) ConvertAlloc (nModules * sizeof (BEModuleS));
for (i = 0; i < nModules; i++) for (i = 0; i < nModules; i++)
{
gBEState.be_modules [i].bem_name = NULL; gBEState.be_modules [i].bem_name = NULL;
gBEState.be_modules [i].bem_nFunctions = 0;
}
} /* BEDeclareModules */ } /* BEDeclareModules */
BESymbolP BESymbolP
...@@ -3431,15 +3434,21 @@ BEExportFunction (int functionIndex) ...@@ -3431,15 +3434,21 @@ BEExportFunction (int functionIndex)
dclModule = &gBEState.be_icl.beicl_dcl_module; dclModule = &gBEState.be_icl.beicl_dcl_module;
Assert ((unsigned int) functionIndex < dclModule->bem_nFunctions); if (((unsigned int) functionIndex < dclModule->bem_nFunctions))
functionSymbol = &dclModule->bem_functions [functionIndex]; {
Assert (functionSymbol->symb_kind == definition); functionSymbol = &dclModule->bem_functions [functionIndex];
dclDef = functionSymbol->symb_def; Assert (functionSymbol->symb_kind == definition);
dclDef = functionSymbol->symb_def;
dclDef->sdef_dcl_icl = iclDef;
Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0);
}
else
dclDef = NULL;
Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0);
iclDef->sdef_dcl_icl = dclDef; iclDef->sdef_dcl_icl = dclDef;
dclDef->sdef_dcl_icl = iclDef;
iclDef->sdef_exported = True; iclDef->sdef_exported = True;
} /* BEExportFunction */ } /* BEExportFunction */
......
...@@ -646,14 +646,12 @@ where ...@@ -646,14 +646,12 @@ where
# predef_type_index # predef_type_index
= type_index + FirstTypePredefinedSymbolIndex = type_index + FirstTypePredefinedSymbolIndex
= constructorExp (predefinedTypeConstructor predef_type_index) SK_Function 0 ci = constructorExp (predefinedTypeConstructor predef_type_index) SK_Function 0 ci
typeConstructor (GTT_Constructor cons_ident fun_ident) ci typeConstructor (GTT_Constructor fun_ident) ci
# type_cons
= App {app_symb = cons_ident, app_args = [], app_info_ptr = nilPtr}
# type_fun # type_fun
= App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr} = App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr}
# (to_tc_symb, ci) # (to_tc_symb, ci)
= getSymbol PD_Dyn__to_TypeCodeConstructor SK_Function 2 ci = getSymbol PD_Dyn__to_TypeCodeConstructor SK_Function 2 ci
= (App {app_symb = to_tc_symb, app_args = [type_cons, type_fun], app_info_ptr = nilPtr}, ci) = (App {app_symb = to_tc_symb, app_args = [type_fun], app_info_ptr = nilPtr}, ci)
typeConstructor (GTT_Basic basic_type) ci typeConstructor (GTT_Basic basic_type) ci
= constructorExp (basicTypeConstructor basic_type) SK_Function 0 ci = constructorExp (basicTypeConstructor basic_type) SK_Function 0 ci
typeConstructor GTT_Function ci typeConstructor GTT_Function ci
......
...@@ -1293,35 +1293,19 @@ toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} c ...@@ -1293,35 +1293,19 @@ toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} c
| module_index == cPredefinedModuleIndex | module_index == cPredefinedModuleIndex
= GTT_PredefTypeConstructor type = GTT_PredefTypeConstructor type
// otherwise // otherwise
# tc_type_index # type
= type_index + 1 = common_defs.[module_index].com_type_defs.[type_index]
# types
= common_defs.[module_index].com_type_defs
// sanity check ...
# type_ident
= types.[type_index].td_ident.id_name
# td_fun_index # td_fun_index
= types.[type_index].td_fun_index = type.td_fun_index
# tc_type_name
= types.[tc_type_index].td_ident.id_name
| "TC;" +++ type_ident <> tc_type_name
= fatal "toTypeCodeConstructor" ("name mismatch (" +++ type_ident +++ ", " +++ tc_type_name +++ ")")
// ... sanity check
# ({td_rhs=AlgType [{ds_ident, ds_index}:_]})
= types.[tc_type_index]
# type_constructor
= { symb_ident = ds_ident
, symb_kind = SK_Constructor {glob_module = module_index, glob_object = ds_index}
}
// sanity check ... // sanity check ...
| td_fun_index == NoIndex | td_fun_index == NoIndex
= fatal "toTypeCodeConstructor" ("no function (" +++ type_ident +++ ")") = fatal "toTypeCodeConstructor" ("no function (" +++ type.td_ident.id_name +++ ")")
// ... sanity check // ... sanity check
# type_fun # type_fun
= { symb_ident = {ds_ident & id_info = nilPtr} // this is wrong but let's give it a try = { symb_ident = {type.td_ident & id_info = nilPtr} // this is wrong but let's give it a try
, symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index} , symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index}
} }
= GTT_Constructor type_constructor type_fun = GTT_Constructor type_fun
fatal :: {#Char} {#Char} -> .a fatal :: {#Char} {#Char} -> .a
fatal function_name message fatal function_name message
......
...@@ -1477,54 +1477,9 @@ reorganiseDefinitionsAndAddTypes mod_ident support_dynamics icl_module defs ca ...@@ -1477,54 +1477,9 @@ reorganiseDefinitionsAndAddTypes mod_ident support_dynamics icl_module defs ca
, import_file_position = NoPos , import_file_position = NoPos
} }
# imports = if (mod_ident == clean_types_module_ident) [] [clean_types_module] # imports = if (mod_ident == clean_types_module_ident) [] [clean_types_module]
# (rev_defs, ca) = reorganiseDefinitions icl_module [PD_Import imports : defs] 0 0 0 0 ca
= addTypeConstructors defs [PD_Import imports] ca // otherwise
= reorganiseDefinitions icl_module (reverse rev_defs) 0 0 0 0 ca
= reorganiseDefinitions icl_module defs 0 0 0 0 ca = reorganiseDefinitions icl_module defs 0 0 0 0 ca
where
addTypeConstructors [] rev_defs ca
= (rev_defs, ca)
addTypeConstructors [PD_Type type_def : defs] rev_defs ca
# (type_def, tc_def, ca)
= addTypeConstructor type_def ca
= addTypeConstructors defs [PD_Type tc_def, PD_Type type_def : rev_defs] ca
addTypeConstructors [def : defs] rev_defs ca
= addTypeConstructors defs [def : rev_defs] ca
addTypeConstructor def=:{td_ident, td_attribute, td_attrs, td_args, td_arity, td_pos} ca=:{ca_hash_table}
# tc_name = "TC;" +++ td_ident.id_name
# ({boxed_ident=tc_cons_ident}, ca_hash_table) = putIdentInHashTable tc_name IC_Expression ca_hash_table
# ({boxed_ident=tc_type_ident}, ca_hash_table) = putIdentInHashTable tc_name IC_Type ca_hash_table
= (def, type_tc_def tc_type_ident tc_cons_ident td_ident td_attribute td_attrs td_args
td_arity td_pos, { ca & ca_hash_table = ca_hash_table })
where
type_tc_def ident cons_ident type_ident attr attrs args arity position
= { td_ident = ident
, td_index = NoIndex
, td_arity = arity
, td_args = args
, td_attrs = attrs
, td_context = []
, td_rhs = ConsList [type_tc_cons cons_ident type_ident args arity position]
, td_attribute = attr
, td_pos = position
, td_used_types = []
, td_fun_index = NoIndex
}
type_tc_cons cons_ident type_ident args arity position
= { pc_cons_ident = cons_ident
, pc_cons_arity = 1
, pc_exi_vars = []
, pc_arg_types = [type type_ident args arity]
, pc_args_strictness = NotStrict
, pc_cons_prio = NoPrio
, pc_cons_pos = position
}
type type_ident args arity
= { at_attribute = TA_None
, at_type = TA (MakeNewTypeSymbIdent type_ident arity)
[{at_attribute = TA_None, at_type = TV arg.atv_variable} \\ arg <- args]
}
belongsToTypeSpec name prio new_name is_infix :== belongsToTypeSpec name prio new_name is_infix :==
name == new_name && sameFixity prio is_infix name == new_name && sameFixity prio is_infix
......
...@@ -1289,7 +1289,7 @@ instance == OverloadedListType ...@@ -1289,7 +1289,7 @@ instance == OverloadedListType
:: GlobalTCType :: GlobalTCType
= GTT_Basic !BasicType = GTT_Basic !BasicType
| GTT_Constructor !SymbIdent !SymbIdent // type_cons type_fun | GTT_Constructor !SymbIdent
| GTT_PredefTypeConstructor !(Global Index) | GTT_PredefTypeConstructor !(Global Index)
| GTT_Function | GTT_Function
......
...@@ -598,8 +598,8 @@ instance reify GlobalTCType where ...@@ -598,8 +598,8 @@ instance reify GlobalTCType where
# predef_type_index # predef_type_index
= type_index + FirstTypePredefinedSymbolIndex = type_index + FirstTypePredefinedSymbolIndex
= function (predefinedTypeConstructor predef_type_index) = function (predefinedTypeConstructor predef_type_index)
reify (GTT_Constructor type_cons type_fun) reify (GTT_Constructor type_fun)
= function PD_Dyn__to_TypeCodeConstructor ` type_cons ` type_fun = function PD_Dyn__to_TypeCodeConstructor ` type_fun
predefinedTypeConstructor predef_type_index predefinedTypeConstructor predef_type_index
| predef_type_index == PD_ListType | predef_type_index == PD_ListType
...@@ -638,38 +638,21 @@ basic value ...@@ -638,38 +638,21 @@ basic value
// copied and adopted from overloading // copied and adopted from overloading
toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} common_defs toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} common_defs
| module_index == cPredefinedModuleIndex | module_index == cPredefinedModuleIndex
= GTT_PredefTypeConstructor type = GTT_PredefTypeConstructor type
// otherwise // otherwise
# tc_type_index # type
= type_index + 1 = common_defs.[module_index].com_type_defs.[type_index]
# types
= common_defs.[module_index].com_type_defs
// sanity check ...
# type_ident
= types.[type_index].td_ident.id_name
# tc_type_name
= types.[tc_type_index].td_ident.id_name
| "TC;" +++ type_ident <> tc_type_name
= fatal "toTypeCodeConstructor" ("name mismatch (" +++ type_ident +++ ", " +++ tc_type_name +++ ")")
// ... sanity check
# ({td_rhs=AlgType [{ds_ident, ds_index}:_]})
= types.[tc_type_index]
# type_constructor
= { symb_ident = ds_ident
, symb_kind = SK_Constructor {glob_module = module_index, glob_object = ds_index}
}
# td_fun_index # td_fun_index
= types.[type_index].td_fun_index = type.td_fun_index
// sanity check ... // sanity check ...
| td_fun_index == NoIndex | td_fun_index == NoIndex
= fatal "toTypeCodeConstructor" ("no function (" +++ type_ident = fatal "toTypeCodeConstructor" ("no function (" +++ type.td_ident.id_name +++ ")")
+++ " type " +++ toString type_index +++ " module " +++ toString module_index +++ ")")
// ... sanity check // ... sanity check
# type_fun # type_fun
= { symb_ident = {ds_ident & id_info = nilPtr} // this is wrong but let's give it a try = { symb_ident = {type.td_ident & id_info = nilPtr} // this is wrong but let's give it a try
, symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index} , symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index}
} }
= GTT_Constructor type_constructor type_fun = GTT_Constructor type_fun
fatal :: {#Char} {#Char} -> .a fatal :: {#Char} {#Char} -> .a
fatal function_name message fatal function_name message
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment