Commit 0dd5ac28 authored by Martin Wierich's avatar Martin Wierich
Browse files

fusion works now. The fusion switch in module typesupport is enabled

parent b09775cd
......@@ -23,6 +23,7 @@ where
kind_list_to_string [] = " ?????? "
kind_list_to_string [k] = "* -> *"
kind_list_to_string [k:ks] = "* -> " +++ kind_list_to_string ks
toString ki = "PPPP" //abort ("instance toString KindInfo matcht niet"->>ki)
kindError kind1 kind2 error
......
implementation module convertDynamics
import syntax, transform, utilities, convertcases
// XXX
import RWSDebug
:: *ConversionInfo =
{ ci_predef_symb :: !*PredefinedSymbols
......
......@@ -413,7 +413,7 @@ element_appears imported_st element_ident dcl_index
# structureInfo = case opt_element_idents of
No -> SI_DotDot
Yes element_idents -> (SI_Elements element_idents False)
newStructure = (struct_id, SI_DotDot, st, (if defined No (Yes dcl_index)))
newStructure = (struct_id, structureInfo, st, (if defined No (Yes dcl_index)))
= element_appears imported_st element_ident dcl_index t [newStructure:akku] index modules cs
# (Yes element_idents) = opt_element_idents
oneLess = filter ((<>) element_ident) element_idents
......@@ -475,8 +475,6 @@ element_appears_in_stomm_struct imported_st element_ident dcl_index index type_n
# com_member_def = dcl_module.dcl_common.com_member_defs.[dcl_index]
{glob_object} = com_member_def.me_class
com_class_def = dcl_module.dcl_common.com_class_defs.[glob_object]
allMembers = com_class_def.class_members
member_idents = [ ds_ident \\ {ds_ident} <-: allMembers]
appears = com_class_def.class_name.id_name==type_name_string
= (appears, modules, cs)
continuation _ _ _ modules cs
......@@ -575,7 +573,7 @@ consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_i
consequences_of_macro count dcl_index f_consequences icl_functions expr_heap
# (icl_function, icl_functions) = icl_functions![dcl_index]
{fun_symb, fun_type, fun_body} = icl_function
{fun_body} = icl_function
result = consequences fun_body
= expand_functions_and_dynamics result [] (f_consequences, icl_functions, expr_heap)
where
......@@ -601,8 +599,6 @@ consequences_of_macro count dcl_index f_consequences icl_functions expr_heap
-> ([], expr_heap)
(EI_Dynamic (Yes dynamicType))
-> (consequences dynamicType, expr_heap)
(EI_Dynamic (Yes dynamicType))
-> (consequences dynamicType, expr_heap)
(EI_DynamicType dynamicType further_dynamic_ptrs)
# (further_conseqs, expr_heap) = expand_dynamics further_dynamic_ptrs [] expr_heap
-> (further_conseqs++consequences dynamicType, expr_heap)
......
......@@ -3,6 +3,8 @@ module main
import scanner, parse, postparse, check, type, trans, convertcases, utilities, convertDynamics
import StdEnv
// XXX
import RWSDebug
Start world
# (std_io, world) = stdio world
......@@ -16,6 +18,17 @@ Start world
(ms.ms_out, ms.ms_files))) world
= fclose ms_out world
CommandLoop proj ms=:{ms_io}
# answer = "c t5"
(command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer))
| command == []
= CommandLoop proj { ms & ms_io = ms_io}
# (ready, proj, ms) = DoCommand command argument proj { ms & ms_io = ms_io}
| ready
= ms
= ms
/*
CommandLoop proj ms=:{ms_io}
# (answer, ms_io) = freadline (ms_io <<< "> ")
(command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer))
......@@ -25,6 +38,7 @@ CommandLoop proj ms=:{ms_io}
| ready
= ms
= CommandLoop proj ms
*/
:: MainStateDefs funs funtypes types conses classes instances members selectors =
{ msd_funs :: !funs
......@@ -163,19 +177,20 @@ loadModule mod_ident predef_symbols hash_table ms=:{ms_files,ms_error,ms_io,ms_o
= (No, predef_symbols, { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io, ms_out = ms_out })
# (components, fun_defs) = partitionateFunctions (fun_defs ---> "partitionateFunctions") [ { ir_from = 0, ir_to = nr_of_global_funs }, icl_instances, icl_specials]
(components, fun_defs, ms_io) = showTypes components 0 fun_defs ms_io
// (components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out
// (components, fun_defs, ms_error) = showTypes components 0 fun_defs ms_error
(components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
(cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
= analyseGroups (components ---> "Transform") fun_defs heaps.hp_var_heap heaps.hp_expression_heap
(components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= analyseGroups common_defs (components ---> "Transform") fun_defs imported_funs heaps.hp_var_heap heaps.hp_expression_heap
#!(components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs var_heap heaps.hp_type_heaps expression_heap
/// (components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
(components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
// (components, fun_defs, ms_error) = showTypes components 0 fun_defs ms_error
(dcl_types, used_conses, var_heap, type_heaps) = convertIclModule common_defs dcl_types used_conses var_heap type_heaps
(dcl_types, used_conses, var_heap, type_heaps) = convertDclModule dcl_mods common_defs dcl_types used_conses var_heap type_heaps
(components, fun_defs, predef_symbols, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components ---> "convertDynamics") fun_defs predef_symbols
dcl_types used_conses var_heap type_heaps expression_heap
(components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out
// (components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out
(used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses var_heap type_heaps expression_heap
(dcl_types, var_heap, type_heaps)
......@@ -247,6 +262,8 @@ where
show_component [] show_types fun_defs file
= (fun_defs, file <<< '\n')
show_component [fun:funs] show_types fun_defs file
| fun>=size fun_defs
= abort ("YYY "+++toString fun+++" "+++toString (size fun_defs))
#! fun_def = fun_defs.[fun]
| show_types
= show_component funs show_types fun_defs (file <<< '\n' <<< fun_def)
......@@ -297,9 +314,7 @@ where
= (fun_defs, file <<< '\n')
show_types [fun:funs] fun_defs file
#! fun_def = fun_defs.[fun]
# properties = { form_properties = cAttributed bitor cAnnotated, form_attr_position = No }
(Yes ftype) = fun_def.fun_type
= show_types funs fun_defs (file <<< fun_def.fun_symb <<< " :: " <:: (properties, ftype) <<< '\n' )
= show_types funs fun_defs (file <<< '\n' <<< fun_def.fun_type)
converFileToListOfStrings file_name files error
# (ok, file, files) = fopen file_name FReadText files
......
......@@ -478,7 +478,12 @@ cIsALocalVar :== False
VI_ExpandedType !SymbolType | /* for storing the (expanded) type of an imported function */
VI_Record ![AuxiliaryPattern] |
VI_Pattern !AuxiliaryPattern |
VI_Default !Int /* used during conversion of dynamics; the Int indiacted the refenrence count */
VI_Default !Int | /* used during conversion of dynamics; the Int indiacted the refenrence count */
VI_Body !SymbIdent !TransformedBody ![FreeVar] | /* used during fusion */
VI_Dictionary !SymbIdent ![Expression] ![Type] | /* used during fusion */
VI_Extended !ExtendedVarInfo !VarInfo
:: ExtendedVarInfo = EVI_VarType !AType
:: ArgumentPosition :== Int
......@@ -638,20 +643,16 @@ cNonRecursiveAppl :== False
| EI_Default !Expression !AType !ExprInfoPtr
| EI_DefaultFunction !SymbIdent ![Expression]
| EI_Extended ![ExtendedExprInfo] !ExprInfo
| EI_Extended !ExtendedExprInfo !ExprInfo
:: ExtendedExprInfo
= EEI_ActiveCase !ActiveCaseInfo
:: ActiveCaseInfo =
{ aci_arg_pos :: !Int
, aci_opt_unfolder:: !(Optional SymbIdent)
, aci_free_vars :: !Optional [VarId]
}
:: VarId =
{ v_name :: !Ident
, v_info_ptr :: !VarInfoPtr
{ aci_params :: ![FreeVar]
, aci_opt_unfolder :: !(Optional SymbIdent)
, aci_free_vars :: !Optional [BoundVar]
, aci_linearity_of_patterns :: ![[Bool]]
}
:: RefCountsInCase =
......
......@@ -434,7 +434,12 @@ cIsALocalVar :== False
VI_ExpandedType !SymbolType | /* for storing the (expanded) type of an imported function */
VI_Record ![AuxiliaryPattern] |
VI_Pattern !AuxiliaryPattern |
VI_Default !Int /* used during conversion of dynamics; the Int indiacted the refenrence count */
VI_Default !Int | /* used during conversion of dynamics; the Int indiacted the refenrence count */
VI_Body !SymbIdent !TransformedBody ![FreeVar] | /* used during fusion */
VI_Dictionary !SymbIdent ![Expression] ![Type] | /* used during fusion */
VI_Extended !ExtendedVarInfo !VarInfo
:: ExtendedVarInfo = EVI_VarType !AType
:: ArgumentPosition :== Int
......@@ -585,20 +590,16 @@ cNotVarNumber :== -1
| EI_Default !Expression !AType !ExprInfoPtr
| EI_DefaultFunction !SymbIdent ![Expression]
| EI_Extended ![ExtendedExprInfo] !ExprInfo
| EI_Extended !ExtendedExprInfo !ExprInfo
:: ExtendedExprInfo
= EEI_ActiveCase !ActiveCaseInfo
:: ActiveCaseInfo =
{ aci_arg_pos :: !Int
, aci_opt_unfolder:: !(Optional SymbIdent)
, aci_free_vars :: !Optional [VarId]
}
:: VarId =
{ v_name :: !Ident
, v_info_ptr :: !VarInfoPtr
{ aci_params :: ![FreeVar]
, aci_opt_unfolder :: !(Optional SymbIdent)
, aci_free_vars :: !Optional [BoundVar]
, aci_linearity_of_patterns :: ![[Bool]]
}
:: RefCountsInCase =
......@@ -1276,7 +1277,7 @@ where
instance <<< BoundVar
where
(<<<) file {var_name,var_info_ptr,var_expr_ptr}
= file <<< var_name <<< '<' <<< ptrToInt var_info_ptr <<< ',' <<< ptrToInt var_expr_ptr <<< '>'
= file <<< var_name <<< '<' <<< ptrToInt var_info_ptr /*<<< ',' <<< ptrToInt var_expr_ptr*/ <<< '>'
instance <<< Bind a b | <<< a & <<< b
where
......@@ -1326,8 +1327,10 @@ where
instance <<< Expression
where
(<<<) file (Var ident) = file <<< ident
(<<<) file (App {app_symb, app_args})
= file <<< app_symb <<< ' ' <<< app_args
(<<<) file (App {app_symb, app_args, app_info_ptr})
= file <<< app_symb <<< (if (app_symb.symb_name.id_name=="==" && isNilPtr app_info_ptr) "\"NIL\"" "") <<< ' ' <<< app_args
// was (<<<) file (App {app_symb, app_args})
// = file <<< app_symb <<< ' ' <<< app_args
(<<<) file (f_exp @ a_exp) = file <<< '(' <<< f_exp <<< " @ " <<< a_exp <<< ')'
(<<<) file (Let {let_binds, let_expr}) = write_binds (file <<< "let " <<< '\n') let_binds <<< "in\n" <<< let_expr
where
......
......@@ -10,7 +10,7 @@ cAccumulating :== -3
:: CleanupInfo
analyseGroups :: !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap
analyseGroups :: !{# CommonDefs} !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap
-> (!CleanupInfo, !*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap)
transformGroups :: !CleanupInfo !*{! Group} !*{#FunDef} !{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } !*VarHeap !*TypeHeaps !*ExpressionHeap
......
......@@ -88,29 +88,38 @@ where
:: BitVector :== Int
:: *AnalyseInfo =
{ ai_heap :: !*VarHeap
{ ai_var_heap :: !*VarHeap
, ai_cons_class :: !*{! ConsClasses}
, ai_cur_ref_counts :: !*{#Int} // for each variable 0,1 or 2
, ai_class_subst :: !* ConsClassSubst
, ai_next_var :: !Int
, ai_cases_of_vars_for_function :: ![(!ExprInfoPtr,!VarInfoPtr)]
, ai_next_var_of_fun :: !Int
, ai_cases_of_vars_for_function :: ![Case]
}
:: SharedAI =
{ sai_common_defs :: !{# CommonDefs }
, sai_imported_funs :: !{# {# FunType} }
}
:: ConsClassSubst :== {# ConsClass}
:: CleanupInfo :== [ExprInfoPtr]
cNoFunArg :== -1
cNope :== -1
/*
The argument classification (i.e. 'accumulating', 'active' or 'passive') of consumers
is represented by an negative integer value.
Possitive classifications are used to identify variables.
is represented by a negative integer value.
Positive classifications are used to identify variables.
Unification of classifications is done on-the-fly
*/
cNoFunArg :== -1
cPassive :== -1
cActive :== -2
cAccumulating :== -3
cVarOfWeirdCase :== -4
IsAVariable cons_class :== cons_class >= 0
......@@ -165,115 +174,134 @@ write_ptr ptr val heap mess
= abort mess
= heap <:= (ptr,val)
class consumerRequirements a :: !a !AnalyseInfo -> (!ConsClass, !AnalyseInfo)
readVarInfo :: VarInfoPtr *VarHeap -> (VarInfo, !*VarHeap)
readVarInfo var_info_ptr var_heap
# (var_info, var_heap) = readPtr var_info_ptr var_heap
= case var_info of
VI_Extended _ original_var_info -> (original_var_info, var_heap)
_ -> (var_info, var_heap)
writeVarInfo :: VarInfoPtr VarInfo *VarHeap -> *VarHeap
writeVarInfo var_info_ptr new_var_info var_heap
# (old_var_info, var_heap) = readPtr var_info_ptr var_heap
= case old_var_info of
VI_Extended extensions _ -> writePtr var_info_ptr (VI_Extended extensions new_var_info) var_heap
_ -> writePtr var_info_ptr new_var_info var_heap
class consumerRequirements a :: !a !{# CommonDefs} !AnalyseInfo -> (!ConsClass, !UnsafePatternBool, !AnalyseInfo)
:: UnsafePatternBool :== Bool
not_an_unsafe_pattern (cc, _, ai) = (cc, False, ai)
instance consumerRequirements BoundVar
where
consumerRequirements {var_info_ptr} ai=:{ai_heap}
#! var_info = sreadPtr var_info_ptr ai_heap
= continuation var_info ai
consumerRequirements {var_info_ptr} _ ai=:{ai_var_heap}
# (var_info, ai_var_heap) = readPtr var_info_ptr ai_var_heap
= continuation var_info { ai & ai_var_heap=ai_var_heap }
where
continuation (VI_AccVar temp_var arg_position) ai=:{ai_cur_ref_counts}
| arg_position<0
= (temp_var, ai)
// | arg_position<0
// = (temp_var, ai)
#! ref_count = ai_cur_ref_counts.[arg_position]
ai_cur_ref_counts = { ai_cur_ref_counts & [arg_position]=min (ref_count+1) 2 }
= (temp_var, { ai & ai_cur_ref_counts=ai_cur_ref_counts })
= (temp_var, False, { ai & ai_cur_ref_counts=ai_cur_ref_counts })
// continuation vi ai
// = (cPassive, ai)
instance consumerRequirements Expression where
consumerRequirements (Var var) ai
= consumerRequirements var ai
consumerRequirements (App app) ai
= consumerRequirements app ai
consumerRequirements (fun_expr @ exprs) ai
# (cc_fun, ai) = consumerRequirements fun_expr ai
consumerRequirements (Var var) common_defs ai
= consumerRequirements var common_defs ai
consumerRequirements (App app) common_defs ai
= consumerRequirements app common_defs ai
consumerRequirements (fun_expr @ exprs) common_defs ai
# (cc_fun, _, ai) = consumerRequirements fun_expr common_defs ai
ai_class_subst = unifyClassifications cActive cc_fun ai.ai_class_subst
= consumerRequirements exprs { ai & ai_class_subst = ai_class_subst }
consumerRequirements (Let {let_binds,let_expr}) ai=:{ai_next_var,ai_heap}
# (new_next_var, ai_heap) = init_variables let_binds ai_next_var ai_heap
# ai = acc_requirements_of_let_binds let_binds ai_next_var { ai & ai_next_var = new_next_var, ai_heap = ai_heap }
= consumerRequirements let_expr ai
= consumerRequirements exprs common_defs { ai & ai_class_subst = ai_class_subst }
consumerRequirements (Let {let_binds,let_expr}) common_defs ai=:{ai_next_var,ai_next_var_of_fun,ai_var_heap}
# (new_next_var, new_ai_next_var_of_fun, ai_var_heap) = init_variables let_binds ai_next_var ai_next_var_of_fun ai_var_heap
# ai = acc_requirements_of_let_binds let_binds ai_next_var common_defs
{ ai & ai_next_var = new_next_var, ai_next_var_of_fun = new_ai_next_var_of_fun, ai_var_heap = ai_var_heap }
= consumerRequirements let_expr common_defs ai // XXX why not not_an_unsafe_pattern
where
init_variables [{bind_dst={fv_info_ptr}} : binds] ai_next_var ai_heap
= init_variables binds (inc ai_next_var)
(write_ptr fv_info_ptr (VI_AccVar ai_next_var cNoFunArg) ai_heap "init_variables")
init_variables [] ai_next_var ai_heap
= (ai_next_var, ai_heap)
acc_requirements_of_let_binds [ {bind_src, bind_dst={fv_info_ptr}} : binds ] ai_next_var ai
# (bind_var, ai) = consumerRequirements bind_src ai
init_variables [{bind_dst={fv_info_ptr}} : binds] ai_next_var ai_next_var_of_fun ai_var_heap
= init_variables binds (inc ai_next_var) (inc ai_next_var_of_fun)
(writePtr fv_info_ptr (VI_AccVar ai_next_var ai_next_var_of_fun) ai_var_heap)
init_variables [] ai_next_var ai_next_var_of_fun ai_var_heap
= (ai_next_var, ai_next_var_of_fun, ai_var_heap)
acc_requirements_of_let_binds [ {bind_src, bind_dst={fv_info_ptr}} : binds ] ai_next_var common_defs ai
# (bind_var, _, ai) = consumerRequirements bind_src common_defs ai
ai_class_subst = unifyClassifications ai_next_var bind_var ai.ai_class_subst
= acc_requirements_of_let_binds binds (inc ai_next_var) { ai & ai_class_subst = ai_class_subst }
acc_requirements_of_let_binds [] ai_next_var ai
= acc_requirements_of_let_binds binds (inc ai_next_var) common_defs { ai & ai_class_subst = ai_class_subst }
acc_requirements_of_let_binds [] ai_next_var _ ai
= ai
consumerRequirements (Case case_expr) ai
= consumerRequirements case_expr ai
consumerRequirements (BasicExpr _ _) ai
= (cPassive, ai)
consumerRequirements (MatchExpr _ _ expr) ai
= consumerRequirements expr ai
consumerRequirements (Selection _ expr selectors) ai
# (cc, ai) = consumerRequirements expr ai
consumerRequirements (Case case_expr) common_defs ai
= consumerRequirements case_expr common_defs ai
consumerRequirements (BasicExpr _ _) _ ai
= (cPassive, False, ai)
consumerRequirements (MatchExpr _ _ expr) common_defs ai
= consumerRequirements expr common_defs ai
consumerRequirements (Selection _ expr selectors) common_defs ai
# (cc, _, ai) = consumerRequirements expr common_defs ai
ai_class_subst = unifyClassifications cActive cc ai.ai_class_subst
ai = requirementsOfSelectors selectors { ai & ai_class_subst = ai_class_subst }
= (cPassive, ai)
consumerRequirements (Update expr1 selectors expr2) ai
# (cc, ai) = consumerRequirements expr1 ai
ai = requirementsOfSelectors selectors ai
(cc, ai) = consumerRequirements expr2 ai
= (cPassive, ai)
consumerRequirements (RecordUpdate cons_symbol expression expressions) ai
# (cc, ai) = consumerRequirements expression ai
(cc, ai) = consumerRequirements expressions ai
= (cPassive, ai)
consumerRequirements (TupleSelect tuple_symbol arg_nr expr) ai
= consumerRequirements expr ai
consumerRequirements (AnyCodeExpr _ _ _) ai
= (cPassive, ai)
consumerRequirements (ABCCodeExpr _ _) ai
= (cPassive, ai)
consumerRequirements (DynamicExpr dynamic_expr) ai
= consumerRequirements dynamic_expr ai
consumerRequirements (TypeCodeExpression _) ai
= (cPassive, ai)
consumerRequirements EE ai
= (cPassive, ai)
consumerRequirements expr ai
ai = requirementsOfSelectors selectors common_defs { ai & ai_class_subst = ai_class_subst }
= (cPassive, False, ai)
consumerRequirements (Update expr1 selectors expr2) common_defs ai
# (cc, _, ai) = consumerRequirements expr1 common_defs ai
ai = requirementsOfSelectors selectors common_defs ai
(cc, _, ai) = consumerRequirements expr2 common_defs ai
= (cPassive, False, ai)
consumerRequirements (RecordUpdate cons_symbol expression expressions) common_defs ai
# (cc, _, ai) = consumerRequirements expression common_defs ai
(cc, _, ai) = consumerRequirements expressions common_defs ai
= (cPassive, False, ai)
consumerRequirements (TupleSelect tuple_symbol arg_nr expr) common_defs ai
= consumerRequirements expr common_defs ai
consumerRequirements (AnyCodeExpr _ _ _) _ ai
= (cPassive, False, ai)
consumerRequirements (ABCCodeExpr _ _) _ ai
= (cPassive, False, ai)
consumerRequirements (DynamicExpr dynamic_expr) common_defs ai
= consumerRequirements dynamic_expr common_defs ai
consumerRequirements (TypeCodeExpression _) _ ai
= (cPassive, False, ai)
consumerRequirements EE _ ai
= (cPassive, False, ai)
consumerRequirements expr _ ai
= abort ("consumerRequirements " <<- expr)
requirementsOfSelectors selectors ai
= foldSt reqs_of_selector selectors ai
requirementsOfSelectors selectors common_defs ai
= foldSt (reqs_of_selector common_defs) selectors ai
where
reqs_of_selector (ArraySelection _ _ index_expr) ai
# (_, ai) = consumerRequirements index_expr ai
reqs_of_selector common_defs (ArraySelection _ _ index_expr) ai
# (_, _, ai) = consumerRequirements index_expr common_defs ai
= ai
reqs_of_selector (DictionarySelection dict_var _ _ index_expr) ai
# (_, ai) = consumerRequirements index_expr ai
(cc_var, ai) = consumerRequirements dict_var ai
reqs_of_selector common_defs (DictionarySelection dict_var _ _ index_expr) ai
# (_, _, ai) = consumerRequirements index_expr common_defs ai
(cc_var, _, ai) = consumerRequirements dict_var common_defs ai
= { ai & ai_class_subst = unifyClassifications cActive cc_var ai.ai_class_subst }
reqs_of_selector _ ai
reqs_of_selector _ _ ai
= ai
instance consumerRequirements App where
consumerRequirements {app_symb={symb_kind = SK_Function {glob_module,glob_object}, symb_arity, symb_name}, app_args} ai=:{ai_cons_class}
consumerRequirements {app_symb={symb_kind = SK_Function {glob_module,glob_object}, symb_arity, symb_name}, app_args} common_defs ai=:{ai_cons_class}
| glob_module == cIclModIndex
| glob_object < size ai_cons_class
#! fun_class = ai_cons_class.[glob_object]
= reqs_of_args fun_class.cc_args app_args cPassive ai
= consumerRequirements app_args ai
= consumerRequirements app_args ai
= reqs_of_args fun_class.cc_args app_args cPassive common_defs ai
= consumerRequirements app_args common_defs ai
= consumerRequirements app_args common_defs ai
where
reqs_of_args _ [] cumm_arg_class ai
= (cumm_arg_class, ai)
reqs_of_args [] _ cumm_arg_class ai
= (cumm_arg_class, ai)
reqs_of_args [form_cc : ccs] [arg : args] cumm_arg_class ai
# (act_cc, ai) = consumerRequirements arg ai
reqs_of_args _ [] cumm_arg_class _ ai
= (cumm_arg_class, False, ai)
reqs_of_args [] _ cumm_arg_class _ ai
= (cumm_arg_class, False, ai)
reqs_of_args [form_cc : ccs] [arg : args] cumm_arg_class common_defs ai
# (act_cc, _, ai) = consumerRequirements arg common_defs ai
ai_class_subst = unifyClassifications form_cc act_cc ai.ai_class_subst
= reqs_of_args ccs args (combineClasses act_cc cumm_arg_class) { ai & ai_class_subst = ai_class_subst }
= reqs_of_args ccs args (combineClasses act_cc cumm_arg_class) common_defs { ai & ai_class_subst = ai_class_subst }
/*
consumerRequirements {app_symb={symb_kind = SK_InternalFunction _}, app_args=[arg:_]} ai
......@@ -281,31 +309,95 @@ instance consumerRequirements App where
ai_class_subst = unifyClassifications cActive cc ai.ai_class_subst
= (cPassive, { ai & ai_class_subst = ai_class_subst })
*/
consumerRequirements {app_args} ai
= consumerRequirements app_args ai
consumerRequirements {app_args} common_defs ai
= not_an_unsafe_pattern (consumerRequirements app_args common_defs ai)
instance consumerRequirements Case where
consumerRequirements {case_expr,case_guards,case_default,case_info_ptr} ai
# ai = case case_expr of
(Var {var_info_ptr}) -> { ai & ai_cases_of_vars_for_function=[(case_info_ptr,var_info_ptr):ai.ai_cases_of_vars_for_function] }
consumerRequirements kees=:{case_expr,case_guards,case_default,case_info_ptr} common_defs ai
# (cce, _, ai) = consumerRequirements case_expr common_defs ai
(ccgs, unsafe_bits, ai) = consumer_requirements_of_guards case_guards common_defs ai
has_default = case case_default of { Yes _ -> True; _ -> False }
(ccd, default_is_unsafe, ai) = consumerRequirements case_default common_defs ai
(every_constructor_appears_in_safe_pattern, ambiguity_exists) = inspect_patterns common_defs has_default case_guards unsafe_bits
safe = (has_default && not default_is_unsafe) || every_constructor_appears_in_safe_pattern
ai_class_subst = unifyClassifications (if ambiguity_exists cVarOfWeirdCase cActive) cce ai.ai_class_subst
ai = { ai & ai_class_subst = ai_class_subst }
ai = case case_expr of
(Var {var_info_ptr})
-> case ambiguity_exists of
False -> { ai & ai_cases_of_vars_for_function=[kees:ai.ai_cases_of_vars_for_function] }
True -> ai
_ -> ai
(cce, ai) = consumerRequirements case_expr ai
ai_class_subst = unifyClassifications cActive cce ai.ai_class_subst
(ccgs, ai) = consumerRequirements case_guards { ai & ai_class_subst = ai_class_subst }
(ccd, ai) = consumerRequirements case_default ai
= (combineClasses ccgs ccd, ai)
/* XXX was
instance consumerRequirements Case where
consumerRequirements {case_expr,case_guards,case_default} ai
# (cce, ai) = consumerRequirements case_expr ai
ai_class_subst = unifyClassifications cActive cce ai.ai_class_subst
(ccgs, ai) = consumerRequirements (case_guards,case_default) { ai & ai_class_subst = ai_class_subst }
= (ccgs, ai)
*/
= (combineClasses ccgs ccd, not safe, ai)
where
inspect_patterns common_defs has_default (AlgebraicPatterns {glob_object, glob_module} algebraic_patterns) unsafe_bits
# type_def = common_defs.[glob_module].com_type_defs.[glob_object]
defined_symbols = case type_def.td_rhs of
AlgType defined_symbols -> defined_symbols
RecordType {rt_constructor} -> [rt_constructor]
all_constructors = [ ds_index \\ {ds_index}<-defined_symbols ]
pattern_constructors = [ glob_object.ds_index \\ {ap_symbol={glob_object}}<-algebraic_patterns]
sorted_pattern_constructors = sort pattern_constructors unsafe_bits
all_sorted_constructors = if (is_sorted all_constructors) all_constructors (quicksort (<) all_constructors)
= (appearance_loop all_sorted_constructors sorted_pattern_constructors, ambiguity_loop has_default sorted_pattern_constructors)
where