Commit af8a9421 authored by Martijn Vervoort's avatar Martijn Vervoort
Browse files

- collection of used type constructors in unify/coerce. There are two sources:

  dynamic pattern matches and types passed to type dependent functions.
- added !Bool-field to GTT_Constructor
- changed overloading, type and convertDynamics to propagate the type
  information
parent 82fd627c
......@@ -26,16 +26,17 @@ from type_io_common import class toString (..),instance toString GlobalTCType;
, ci_next_fun_nr :: !Index
// data needed to generate coercions
, ci_placeholders_and_tc_args :: [(!BoundVar,Ptr VarInfo)]
, ci_generated_global_tc_placeholders :: !Bool
, ci_used_tcs :: [Ptr VarInfo]
, ci_symb_ident :: SymbIdent
, ci_sel_type_field :: Expression -> Expression //Optional (!Int,!(Global DefinedSymbol))
, ci_sel_value_field :: Expression -> Expression //Optional (!Int,!(Global DefinedSymbol))
, ci_module_id_symbol :: Expression
, ci_internal_type_id :: Expression
, ci_module_id :: Optional LetBind
, ci_type_id :: !Optional !TypeSymbIdent
, ci_placeholders_and_tc_args :: [(!BoundVar,Ptr VarInfo)]
, ci_generated_global_tc_placeholders :: !Bool
, ci_used_tcs :: [Ptr VarInfo]
, ci_symb_ident :: SymbIdent
, ci_sel_type_field :: Expression -> Expression //Optional (!Int,!(Global DefinedSymbol))
, ci_sel_value_field :: Expression -> Expression //Optional (!Int,!(Global DefinedSymbol))
, ci_module_id_symbol :: Expression
, ci_internal_type_id :: Expression
, ci_module_id :: Optional LetBind
, ci_type_id :: !Optional !TypeSymbIdent
, ci_type_constructor_used_in_dynamic_patterns :: !*{#Bool}
}
:: ConversionInput =
......@@ -64,8 +65,9 @@ F a b = b
//write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] !*TypeHeaps !*PredefinedSymbols -> (.Bool,.File,!*TypeHeaps,!*PredefinedSymbols)
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules type_heaps predefined_symbols
//write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] _ _ !*TypeHeaps !*PredefinedSymbols -> (.Bool,.File,!*TypeHeaps,!*PredefinedSymbols)
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules global_type_instances ci_type_constructor_used_in_dynamic_patterns type_heaps predefined_symbols
# (pre_mod, predefined_symbols) = predefined_symbols![PD_PredefinedModule]
# write_type_info_state2
= { WriteTypeInfoState |
......@@ -75,28 +77,46 @@ write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_modul
};
# (j,tcl_file)
= fposition tcl_file
// | True
// = abort ("TypeVar " +++ toString j)
#! (tcl_file,write_type_info_state)
= write_type_info common_defs tcl_file write_type_info_state2
#! (tcl_file,write_type_info_state)
= write_type_info directly_imported_dcl_modules tcl_file write_type_info_state
// dynamic pattern matches
#! type_constructors_in_dynamic_patterns
= collect_type_constructors_in_dynamic_patterns 0 (size global_type_instances) []
#! (tcl_file,write_type_info_state)
= write_type_info type_constructors_in_dynamic_patterns tcl_file write_type_info_state
#! (type_heaps,_)
= f write_type_info_state //!type_heaps;
= f write_type_info_state;
#! tcl_file
= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
#! tcl_file
= fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file
= (True,tcl_file,type_heaps,predefined_symbols)
where
collect_type_constructors_in_dynamic_patterns :: !Int !Int [(!TypeSymbIdent,!String)] -> [(!TypeSymbIdent,!String)]
collect_type_constructors_in_dynamic_patterns i limit type_constructors_in_dynamic_patterns
| i == limit
= type_constructors_in_dynamic_patterns
| isGTT_Constructor global_type_instances.[i]
# (GTT_Constructor type_name=:{type_name={id_name}} module_name used_in_application_of_type_dependent_function)
= global_type_instances.[i]
| used_in_application_of_type_dependent_function || ci_type_constructor_used_in_dynamic_patterns.[i]
= collect_type_constructors_in_dynamic_patterns (inc i) limit [(type_name,module_name):type_constructors_in_dynamic_patterns]
= collect_type_constructors_in_dynamic_patterns (inc i) limit type_constructors_in_dynamic_patterns
= collect_type_constructors_in_dynamic_patterns (inc i) limit type_constructors_in_dynamic_patterns
where
isGTT_Constructor (GTT_Constructor _ _ _) = True
isGTT_Constructor _ = False
f write_type_info_state=:{wtis_type_heaps}
= (wtis_type_heaps,{write_type_info_state & wtis_type_heaps = abort "convertDynamics.icl"});
//---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs);
/*2.0
f (Yes tcl_file)
......@@ -106,22 +126,6 @@ f (Yes tcl_file)
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional !*File) {# DclModule} !IclModule [String]
-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, (Optional !*File))
convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap tcl_file dcl_mods icl_mod directly_imported_dcl_modules
# (tcl_file,type_heaps,predefined_symbols)
= case tcl_file of
No
-> (No,type_heaps,predefined_symbols)
/*2.0
_
# tcl_file = f tcl_file;
0.2*/
//1.3
(Yes tcl_file)
//3.1
# (ok,tcl_file,type_heaps,predefined_symbols)
= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file directly_imported_dcl_modules type_heaps predefined_symbols
| not ok
-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
-> (Yes tcl_file,type_heaps,predefined_symbols)
# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamic]
#! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols)
= case (pds_module == (-1) || pds_def == (-1)) of
......@@ -211,8 +215,9 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
-> Yes ci_type_id
#! nr_of_funs = size fun_defs
#! s_global_type_instances = size global_type_instances
# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
# (groups, (fun_defs, {ci_predef_symb, ci_var_heap, ci_expr_heap, ci_fun_heap, ci_new_functions}))
# (groups, (fun_defs, {ci_predef_symb, ci_var_heap, ci_expr_heap, ci_fun_heap, ci_new_functions, ci_type_constructor_used_in_dynamic_patterns}))
= convert_groups 0 groups global_type_instances (fun_defs, {
ci_predef_symb = predefined_symbols, ci_var_heap = var_heap, ci_expr_heap = expr_heap,
ci_new_functions = [], ci_new_variables = [], ci_fun_heap = newHeap, ci_next_fun_nr = nr_of_funs, ci_placeholders_and_tc_args = [],
......@@ -221,9 +226,30 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
ci_module_id_symbol = App module_symb,
ci_internal_type_id = module_id_app,
ci_module_id = No,
ci_type_id = ci_type_id })
ci_type_id = ci_type_id,
ci_type_constructor_used_in_dynamic_patterns = createArray s_global_type_instances False
})
(groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap)
= addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types [] type_heaps ci_var_heap
// store type info
# (tcl_file,type_heaps,ci_predef_symb)
= case tcl_file of
No
-> (No,type_heaps,ci_predef_symb)
/*2.0
_
# tcl_file = f tcl_file;
0.2*/
//1.3
(Yes tcl_file)
//3.1
# (ok,tcl_file,type_heaps,ci_predef_symb)
= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file directly_imported_dcl_modules global_type_instances ci_type_constructor_used_in_dynamic_patterns type_heaps ci_predef_symb
| not ok
-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
-> (Yes tcl_file,type_heaps,ci_predef_symb)
= (groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }, ci_predef_symb, imported_types, imported_conses, ci_var_heap, type_heaps, ci_expr_heap, tcl_file)
where
convert_groups group_nr groups global_type_instances fun_defs_and_ci
......@@ -472,7 +498,7 @@ where
= (MatchExpr symb expression, ci)
convertDynamics cinp bound_vars default_expr (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_type_code}) ci=:{ci_symb_ident}
# (dyn_expr, ci) = convertDynamics cinp bound_vars default_expr dyn_expr ci
(_,dyn_type_code, _, _, ci) = convertTypecode2 cinp dyn_type_code False PD_UV_Placeholder [] [] ci
(_,dyn_type_code, _, _, ci) = convertTypecode2 cinp dyn_type_code False [] [] ci
= (App { app_symb = ci_symb_ident,
app_args = [dyn_expr, dyn_type_code],
app_info_ptr = nilPtr }, ci)
......@@ -482,31 +508,36 @@ where
= (EE, ci)
convertDynamics cinp bound_vars default_expr expr=:(NoBind _) ci
= (expr,ci)
/*
replace all references in a type code expression which refer to an argument i.e. the argument contains a
type to their placeholders. Return is a list of (placeholder,argument) list. Each tuple is used later as
arguments to the coerce relation. This should be optional
is_dynamic_pattern (is_dynamic_pattern)
True
1) replace TC-references passed as an argument to the current function, in a type code expression by placeholders. A
(placeholder,argument)-list is returned to generate the coercion later on.
2) A PD_UPV_Placeholder is generated for each TCE_UniType-variable occuring in the type code expression.
3) store type constructors in ci_type_constructor_used_in_dynamic_patterns
False
1) do *not* replace TC-reference
2) A PD_UV_Placeholder is generated for each TCE_UniType-variable occuring in the type code expression.
3) do *not* store type constructors
*/
convertTypecode2 cinp (TCE_UniType uni_vars type_code) replace_tc_args uni_placeholder binds placeholders_and_tc_args ci
# (let_binds, ci) = createUniversalVariables uni_placeholder uni_vars [] ci
convertTypecode2 cinp (TCE_UniType uni_vars type_code) is_dynamic_pattern binds placeholders_and_tc_args ci
# (let_binds, ci) = createUniversalVariables (if is_dynamic_pattern PD_UPV_Placeholder PD_UV_Placeholder) uni_vars [] ci
(let_info_ptr, ci) = let_ptr (length let_binds) ci
(e, type_code_expr, binds, placeholders_and_tc_args, ci) = convertTypecode2 cinp type_code False uni_placeholder [] [] ci
(e, type_code_expr, binds, placeholders_and_tc_args, ci) = convertTypecode2 cinp type_code is_dynamic_pattern [] [] ci
= (e, Let { let_strict_binds = [],
let_lazy_binds = let_binds,
let_expr = type_code_expr,
let_info_ptr = let_info_ptr,
let_expr_position = NoPos}, binds, placeholders_and_tc_args, ci)
// ci_placeholders_and_tc_args
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_Var var_info_ptr) replace_tc_args uni_placeholder binds placeholders_and_tc_args ci
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_Var var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
#! cinp_st_args
= filter (\{fv_info_ptr} -> fv_info_ptr == var_info_ptr) cinp_st_args
| isEmpty cinp_st_args
#! (e,binds,placeholders_and_tc_args,ci)
= convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci
= convertTypecode cinp t is_dynamic_pattern binds placeholders_and_tc_args ci
= (False,e,binds,placeholders_and_tc_args,ci)
/*
......@@ -516,12 +547,12 @@ convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_Var var_info_ptr) replace_tc_args
*/
= (True,Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args,ci)
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_TypeTerm var_info_ptr) replace_tc_args uni_placeholder binds placeholders_and_tc_args ci
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_TypeTerm var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
#! cinp_st_args
= filter (\{fv_info_ptr} -> fv_info_ptr == var_info_ptr) cinp_st_args
| isEmpty cinp_st_args
#! (e,binds,placeholders_and_tc_args,ci)
= convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci
= convertTypecode cinp t is_dynamic_pattern binds placeholders_and_tc_args ci
= (False,e,binds,placeholders_and_tc_args,ci)
/*
......@@ -531,18 +562,16 @@ convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_TypeTerm var_info_ptr) replace_tc_
*/
= (True,Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args,ci)
// = convertTypecode2 cinp t replace_tc_args binds placeholders_and_tc_args ci
convertTypecode2 cinp t replace_tc_args uni_placeholder binds placeholders_and_tc_args ci
convertTypecode2 cinp t is_dynamic_pattern binds placeholders_and_tc_args ci
#! (e,binds,placeholders_and_tc_args,ci)
= convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci
= convertTypecode cinp t is_dynamic_pattern binds placeholders_and_tc_args ci
= (False,e,binds,placeholders_and_tc_args,ci)
convertTypecode cinp TCE_Empty replace_tc_args binds placeholders_and_tc_args ci
convertTypecode cinp TCE_Empty is_dynamic_pattern binds placeholders_and_tc_args ci
= (EE,binds,placeholders_and_tc_args,ci)
convertTypecode cinp=:{cinp_st_args} (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci=:{ci_placeholders_and_tc_args,ci_var_heap}
| not replace_tc_args
convertTypecode cinp=:{cinp_st_args} (TCE_Var var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci=:{ci_placeholders_and_tc_args,ci_var_heap}
| not is_dynamic_pattern
= (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
// check if tc_arg has already been replaced by a placeholder
......@@ -570,19 +599,19 @@ where
// 2. It is also a argument of the function
// Thus a tc argument variable.
// This forms a special case: instead of an unify, a coerce can be generated
convertTypecode cinp (TCE_TypeTerm var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
convertTypecode cinp (TCE_TypeTerm var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
/*
** TCE_Var and TCE_TypeTerm are not equivalent. A TCE_TypeTerm is used for an argument which contains
** a type representation. A TCE_Var is an existential quantified type variable. In previous phases no
** clear distinction is made. It should be possible to generate the proper type code expression for
** these two but it would involve changing a lot of small things.
*/
= convertTypecode cinp (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
= convertTypecode cinp (TCE_Var var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
convertTypecode cinp (TCE_Constructor index typecode_exprs) replace_tc_args binds placeholders_and_tc_args ci=:{ci_internal_type_id}
convertTypecode cinp (TCE_Constructor index typecode_exprs) is_dynamic_pattern binds placeholders_and_tc_args ci=:{ci_internal_type_id}
# (typecons_symb, ci) = getSymbol PD_TypeConsSymbol SK_Constructor (USE_DummyModuleName 3 2) ci
constructor = get_constructor cinp.cinp_glob_type_inst index
(typecode_exprs,binds,placeholders_and_tc_args,ci) = convertTypecodes cinp typecode_exprs replace_tc_args binds placeholders_and_tc_args ci
# (constructor,ci) = get_constructor cinp.cinp_glob_type_inst index ci
(typecode_exprs,binds,placeholders_and_tc_args,ci) = convertTypecodes cinp typecode_exprs is_dynamic_pattern binds placeholders_and_tc_args ci
# (ci_internal_type_id,ci)
= get_module_id ci
= (App {app_symb = typecons_symb,
......@@ -591,26 +620,36 @@ convertTypecode cinp (TCE_Constructor index typecode_exprs) replace_tc_args bind
where
get_module_id ci=:{ci_module_id=Yes {lb_dst}}
= (Var (freeVarToVar lb_dst),ci)
get_constructor :: !{!GlobalTCType} Index !*ConversionInfo -> (Expression,!*ConversionInfo)
get_constructor glob_type_inst index ci=:{ci_type_constructor_used_in_dynamic_patterns}
# ci
= case is_dynamic_pattern of
True -> { ci & ci_type_constructor_used_in_dynamic_patterns.[index] = True }
_ -> ci
= (BasicExpr (BVS ("\"" +++ toString glob_type_inst.[index] +++ "\"")),ci)
convertTypecodes _ [] is_dynamic_pattern binds placeholders_and_tc_args ci
# (nil_symb, ci) = getSymbol PD_NilSymbol SK_Constructor 0 ci
= (App { app_symb = nil_symb,
app_args = [],
app_info_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
convertTypecodes cinp [typecode_expr : typecode_exprs] is_dynamic_pattern binds placeholders_and_tc_args ci
# (cons_symb, ci) = getSymbol PD_ConsSymbol SK_Constructor 2 ci
# (expr,binds,placeholders_and_tc_args, ci) = convertTypecode cinp typecode_expr is_dynamic_pattern binds placeholders_and_tc_args ci
# (exprs,binds,placeholders_and_tc_args,ci) = convertTypecodes cinp typecode_exprs is_dynamic_pattern binds placeholders_and_tc_args ci
= (App { app_symb = cons_symb,
app_args = [expr , exprs],
app_info_ptr = nilPtr}, binds,placeholders_and_tc_args, ci)
convertTypecode cinp (TCE_Selector selections var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
convertTypecode cinp (TCE_Selector selections var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
#! (var,binds,placeholders_and_tc_args,ci)
= convertTypecode cinp (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
= convertTypecode cinp (TCE_Var var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
= (Selection NormalSelector var selections,binds,placeholders_and_tc_args,ci)
//convertTypecodes :: !ConversionInput [TypeCodeExpression] !*ConversionInfo -> (Expression,!*ConversionInfo)
convertTypecodes _ [] replace_tc_args binds placeholders_and_tc_args ci
# (nil_symb, ci) = getSymbol PD_NilSymbol SK_Constructor 0 ci
= (App { app_symb = nil_symb,
app_args = [],
app_info_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
convertTypecodes cinp [typecode_expr : typecode_exprs] replace_tc_args binds placeholders_and_tc_args ci
# (cons_symb, ci) = getSymbol PD_ConsSymbol SK_Constructor 2 ci
# (expr,binds,placeholders_and_tc_args, ci) = convertTypecode cinp typecode_expr replace_tc_args binds placeholders_and_tc_args ci
# (exprs,binds,placeholders_and_tc_args,ci) = convertTypecodes cinp typecode_exprs replace_tc_args binds placeholders_and_tc_args ci
= (App { app_symb = cons_symb,
app_args = [expr , exprs],
app_info_ptr = nilPtr}, binds,placeholders_and_tc_args, ci)
determine_defaults :: (Optional Expression) DefaultExpression !*ConversionInfo -> (Optional Expression, DefaultExpression, !*ConversionInfo)
/***
......@@ -833,7 +872,7 @@ where
/*** convert the elements of this pattern ***/
(a_ij_binds, ci) = createTypePatternVariables dp_type_patterns_vars [] ci
(generate_coerce,type_code,_,martijn, ci) = convertTypecode2 cinp dp_type_code True /* should be changed to True for type dependent functions */ /* WAS: a_ij_binds*/ PD_UPV_Placeholder [] [] ci //{ci & ci_module_id = No} // ci
(generate_coerce,type_code,_,martijn, ci) = convertTypecode2 cinp dp_type_code True /* should be changed to True for type dependent functions */ /* WAS: a_ij_binds*/ [] [] ci //{ci & ci_module_id = No} // ci
# (is_last_dynamic_pattern,dp_rhs)
= isLastDynamicPattern dp_rhs;
......@@ -1111,10 +1150,6 @@ addToBoundVars :: BoundVar AType BoundVariables -> BoundVariables
addToBoundVars var type bound_vars
= [ { tv_free_var = varToFreeVar var 0, tv_type = type } : bound_vars ]
get_constructor :: !{!GlobalTCType} Index -> Expression
get_constructor glob_type_inst index
= BasicExpr (BVS ("\"" +++ toString glob_type_inst.[index] +++ "\""))
getResultType :: ExprInfoPtr !*ConversionInfo -> (!AType, !*ConversionInfo)
getResultType case_info_ptr ci=:{ci_expr_heap}
# (EI_CaseType {ct_result_type}, ci_expr_heap) = readPtr case_info_ptr ci_expr_heap
......
......@@ -18,12 +18,13 @@ import syntax, check, typesupport
}
:: SpecialInstances =
{ si_next_array_member_index :: !Index
, si_array_instances :: ![ArrayInstance]
, si_list_instances :: ![ArrayInstance]
, si_tail_strict_list_instances :: ![ArrayInstance]
, si_next_TC_member_index :: !Index
, si_TC_instances :: ![GlobalTCInstance]
{ si_next_array_member_index :: !Index
, si_array_instances :: ![ArrayInstance]
, si_list_instances :: ![ArrayInstance]
, si_tail_strict_list_instances :: ![ArrayInstance]
, si_next_TC_member_index :: !Index
, si_TC_instances :: ![GlobalTCInstance]
, si_type_constructors_in_patterns :: ![!Index]
}
:: OverloadingState =
......@@ -43,10 +44,11 @@ tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Ind
-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState)
:: TypeCodeInfo =
{ tci_next_index :: !Index
, tci_instances :: ![GlobalTCInstance]
, tci_type_var_heap :: !.TypeVarHeap
, tci_dcl_modules :: !{# DclModule}
{ tci_next_index :: !Index
, tci_instances :: ![GlobalTCInstance]
, tci_type_var_heap :: !.TypeVarHeap
, tci_dcl_modules :: !{# DclModule}
, tci_type_constructors_in_patterns :: ![!Index]
}
removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !Int !*{#FunDef} !*{! FunctionType} !*ExpressionHeap
......
......@@ -44,12 +44,13 @@ import genericsupport, compilerSwitches, type_io_common
}
:: SpecialInstances =
{ si_next_array_member_index :: !Index
, si_array_instances :: ![ArrayInstance]
, si_list_instances :: ![ArrayInstance]
, si_tail_strict_list_instances :: ![ArrayInstance]
, si_next_TC_member_index :: !Index
, si_TC_instances :: ![GlobalTCInstance]
{ si_next_array_member_index :: !Index
, si_array_instances :: ![ArrayInstance]
, si_list_instances :: ![ArrayInstance]
, si_tail_strict_list_instances :: ![ArrayInstance]
, si_next_TC_member_index :: !Index
, si_TC_instances :: ![GlobalTCInstance]
, si_type_constructors_in_patterns :: ![!Index]
}
:: LocalTypePatternVariable =
......@@ -86,7 +87,7 @@ where
where
compare_types (GTT_Basic bt1) (GTT_Basic bt2)
= bt1 =< bt2
compare_types (GTT_Constructor cons1 _) (GTT_Constructor cons2 _)
compare_types (GTT_Constructor cons1 _ _) (GTT_Constructor cons2 _ _)
= cons1 =< cons2
compare_types _ _
= Equal
......@@ -527,7 +528,7 @@ where
# defining_module_name
= dcl_modules.[glob_module].dcl_name.id_name
# (inst_index, (si_next_TC_member_index, si_TC_instances))
= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (si_next_TC_member_index, si_TC_instances)
= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name False) (si_next_TC_member_index, si_TC_instances)
(rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap)
= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances)
......@@ -535,7 +536,7 @@ where
# defining_module_name
= dcl_modules.[glob_module].dcl_name.id_name
# (inst_index, (si_next_TC_member_index, si_TC_instances))
= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (si_next_TC_member_index, si_TC_instances)
= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name False) (si_next_TC_member_index, si_TC_instances)
(rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap)
= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances)
......@@ -1291,14 +1292,14 @@ getTCDictionary symb_name var_info_ptr (var_heap, error)
_
-> (var_info_ptr, (var_heap, overloadingError symb_name error))
:: TypeCodeInfo =
{ tci_next_index :: !Index
, tci_instances :: ![GlobalTCInstance]
, tci_type_var_heap :: !.TypeVarHeap
, tci_dcl_modules :: !{# DclModule}
{ tci_next_index :: !Index
, tci_instances :: ![GlobalTCInstance]
, tci_type_var_heap :: !.TypeVarHeap
, tci_dcl_modules :: !{# DclModule}
, tci_type_constructors_in_patterns :: ![!Index]
}
class toTypeCodeExpression type :: !Ident type !(!*TypeCodeInfo,!*VarHeap,!*ErrorAdmin) -> (!TypeCodeExpression, !(!*TypeCodeInfo,!*VarHeap,!*ErrorAdmin))
instance toTypeCodeExpression Type
......@@ -1307,14 +1308,14 @@ where
# defining_module_name
= tci_dcl_modules.[glob_module].dcl_name.id_name
# (inst_index, (tci_next_index, tci_instances))
= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (tci_next_index, tci_instances)
= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name False) (tci_next_index, tci_instances)
(type_code_args, tci) = mapSt (toTypeCodeExpression symb_name) type_args ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error)
= (TCE_Constructor inst_index type_code_args, tci)
toTypeCodeExpression symb_name (TAS cons_id=:{type_index={glob_module}} type_args _) (tci=:{tci_next_index,tci_instances,tci_dcl_modules},var_heap,error)
# defining_module_name
= tci_dcl_modules.[glob_module].dcl_name.id_name
# (inst_index, (tci_next_index, tci_instances))
= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (tci_next_index, tci_instances)
= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name False) (tci_next_index, tci_instances)
(type_code_args, tci) = mapSt (toTypeCodeExpression symb_name) type_args ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error)
= (TCE_Constructor inst_index type_code_args, tci)
toTypeCodeExpression symb_name (TB basic_type) (tci=:{tci_next_index,tci_instances},var_heap,error)
......@@ -1632,7 +1633,9 @@ where
# (var_info_ptr, (ui_var_heap,ui_error)) = getTCDictionary symb_name var_info_ptr (ui_var_heap, ui_error)
= (Var {var_name = v_tc_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, { ui & ui_var_heap = ui_var_heap, ui_error = ui_error})
// MV ...
convertTypecode (TCE_Constructor index typecode_exprs) ui=:{ui_x={x_internal_type_id}}
convertTypecode (TCE_Constructor index typecode_exprs) ui=:{ui_x={x_internal_type_id,x_type_code_info={tci_type_constructors_in_patterns} }}
# ui
= { ui & ui_x.x_type_code_info.tci_type_constructors_in_patterns = [index:tci_type_constructors_in_patterns] }
# (typecons_symb,ui) = getSymbol PD_TypeConsSymbol SK_Constructor ui
(constructor,ui) = get_constructor index ui
(typecode_exprs, ui) = convertTypecodes typecode_exprs ui
......
......@@ -1278,7 +1278,7 @@ instance == OverloadedListType
| TCE_Selector ![Selection] !VarInfoPtr
| TCE_UniType ![VarInfoPtr] !TypeCodeExpression
:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent !String | GTT_Function
:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent !String !Bool | GTT_Function
:: FunctionPattern = FP_Basic !BasicValue !(Optional FreeVar)
......
......@@ -1241,7 +1241,7 @@ cIsNotStrict :== False
| TCE_Selector ![Selection] !VarInfoPtr
| TCE_UniType ![VarInfoPtr] !TypeCodeExpression
:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent !String | GTT_Function
:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent !String !Bool | GTT_Function
:: FunctionPattern = FP_Basic !BasicValue !(Optional FreeVar)
| FP_Algebraic !(Global DefinedSymbol) ![FunctionPattern] !(Optional FreeVar)
......
......@@ -2136,7 +2136,7 @@ typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_de
ts = { ts_fun_env = InitFunEnv fun_env_size, ts_var_heap = hp_var_heap, ts_expr_heap = hp_expression_heap, ts_generic_heap = hp_generic_heap, ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [],
ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error, ts_out = out }
ti = { ti_common_defs = ti_common_defs, ti_functions = ti_functions,ti_main_dcl_module_n=main_dcl_module_n }
special_instances = { si_next_array_member_index = fun_env_size, si_array_instances = [], si_list_instances = [], si_tail_strict_list_instances = [], si_next_TC_member_index = 0, si_TC_instances = [] }
special_instances = { si_next_array_member_index = fun_env_size, si_array_instances = [], si_list_instances = [], si_tail_strict_list_instances = [], si_next_TC_member_index = 0, si_TC_instances = [], si_type_constructors_in_patterns = [] }
# (type_error, fun_defs, predef_symbols, special_instances, ts) = type_components list_inferred_types 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts)
(fun_defs,ts_fun_env) = update_function_types 0 comps ts.ts_fun_env fun_defs
(type_error, fun_defs, predef_symbols, special_instances, {ts_td_infos,ts_fun_env,ts_error,ts_var_heap, ts_expr_heap, ts_type_heaps, ts_generic_heap,ts_out})
......@@ -2324,22 +2324,22 @@ where
| isEmpty over_info
# ts_type_heaps = ts.ts_type_heaps
type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances,
tci_type_var_heap = ts_type_heaps.th_vars, tci_dcl_modules = dcl_modules }
(fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error, os_predef_symbols)
tci_type_var_heap = ts_type_heaps.th_vars, tci_dcl_modules = dcl_modules, tci_type_constructors_in_patterns = os_special_instances.si_type_constructors_in_patterns }
(fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap,tci_type_constructors_in_patterns}, ts_var_heap, ts_error, os_predef_symbols)
= updateDynamics comp local_pattern_variables main_dcl_module_n fun_defs ts.ts_fun_env ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols
= ( type_error || not ts_error.ea_ok,
fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances },
fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances, si_type_constructors_in_patterns = tci_type_constructors_in_patterns },
{ ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [],
ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True },
ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }, ts_fun_env = ts_fun_env})
# ts_type_heaps = ts.ts_type_heaps
type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances,
type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances, tci_type_constructors_in_patterns = os_special_instances.si_type_constructors_in_patterns,
tci_type_var_heap = ts_type_heaps.th_vars, tci_dcl_modules = dcl_modules }
(fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error, os_predef_symbols)
(fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap,tci_type_constructors_in_patterns}, ts_var_heap, ts_error, os_predef_symbols)
= removeOverloadedFunctions comp local_pattern_variables main_dcl_module_n fun_defs ts.ts_fun_env
ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols
= ( type_error || not ts_error.ea_ok,
fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances },
fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances, si_type_constructors_in_patterns = tci_type_constructors_in_patterns },
{ ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [],
ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True },
ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }, ts_fun_env = ts_fun_env})
......@@ -2576,7 +2576,7 @@ where
type_of (UncheckedType tst) = tst
type_of (SpecifiedType _ _ tst) = tst
create_special_instances {si_array_instances,si_list_instances,si_tail_strict_list_instances,si_next_array_member_index,si_next_TC_member_index,si_TC_instances} fun_env_size common_defs fun_defs predef_symbols type_heaps error
create_special_instances {si_array_instances,si_list_instances,si_tail_strict_list_instances,si_next_array_member_index,si_next_TC_member_index,si_TC_instances,si_type_constructors_in_patterns} fun_env_size common_defs fun_defs predef_symbols type_heaps error
# fun_defs = add_extra_elements_to_fun_def_array (si_next_array_member_index-fun_env_size) fun_defs
with
add_extra_elements_to_fun_def_array n_new_elements fun_defs
......@@ -2591,10 +2591,15 @@ where
= convert_list_instances si_list_instances PD_UListClass common_defs fun_defs predef_symbols type_heaps error
(tail_strict_list_first_instance_indices,fun_defs, predef_symbols, type_heaps, error)
= convert_list_instances si_tail_strict_list_instances PD_UTSListClass common_defs fun_defs predef_symbols type_heaps error
type_code_instances = {createArray si_next_TC_member_index GTT_Function & [gtci_index] = gtci_typ