diff options
| -rw-r--r-- | frontend/type.icl | 12 | ||||
| -rw-r--r-- | frontend/typesupport.dcl | 10 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 167 |
3 files changed, 83 insertions, 106 deletions
diff --git a/frontend/type.icl b/frontend/type.icl index 7d4eb4d..8168176 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -1312,8 +1312,8 @@ where = cleanUpSymbolType exp_fun_type type_contexts case_and_let_exprs coercion_env attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_expr_heap ts.ts_error | ts_error.ea_ok - # (ts_fun_env, attr_var_env, ts_type_heaps, ts_error) - = check_function_type fun_type tmp_fun_type clean_fun_type defs ts.ts_fun_env attr_var_env ts_type_heaps ts_error + # (ts_fun_env, attr_var_env, ts_type_heaps, ts_expr_heap, ts_error) + = check_function_type fun_type tmp_fun_type clean_fun_type case_and_let_exprs defs ts.ts_fun_env attr_var_env ts_type_heaps ts_expr_heap ts_error -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error }) -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_expr_heap = ts_expr_heap, ts_error = ts_error }) UncheckedType exp_fun_type @@ -1323,13 +1323,15 @@ where ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType clean_fun_type } -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error }) - check_function_type fun_type tmp_fun_type=:{tst_lifted} clean_fun_type=:{st_arity, st_args, st_vars, st_attr_vars} defs fun_env attr_var_env type_heaps error + check_function_type fun_type tmp_fun_type=:{tst_lifted} clean_fun_type=:{st_arity, st_args, st_vars, st_attr_vars} case_and_let_exprs + defs fun_env attr_var_env type_heaps expr_heap error # (equi, attr_var_env, type_heaps) = equivalent clean_fun_type tmp_fun_type defs attr_var_env type_heaps | equi # type_with_lifted_arg_types = addLiftedArgumentsToSymbolType fun_type tst_lifted st_args st_vars st_attr_vars - = ({ fun_env & [fun] = CheckedType type_with_lifted_arg_types}, attr_var_env, type_heaps, error) + (type_heaps, expr_heap) = updateExpressionTypes clean_fun_type fun_type case_and_let_exprs type_heaps expr_heap + = ({ fun_env & [fun] = CheckedType type_with_lifted_arg_types}, attr_var_env, type_heaps, expr_heap, error) // ---> ("check_function_type", clean_fun_type, fun_type, type_with_lifted_arg_types) - = (fun_env, attr_var_env, type_heaps, specification_error clean_fun_type error) + = (fun_env, attr_var_env, type_heaps, expr_heap, specification_error clean_fun_type error) where add_lifted_arg_types arity_diff args1 args2 | arity_diff > 0 diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl index b3f01ef..3a098c0 100644 --- a/frontend/typesupport.dcl +++ b/frontend/typesupport.dcl @@ -4,8 +4,6 @@ import checksupport, StdCompare from unitype import Coercions, CoercionTree, AttributePartition -do_fusion :== False -// MW: this switch is used to en(dis)able the fusion algorithm which currently isn't ready errorHeading :: !String !*ErrorAdmin -> *ErrorAdmin @@ -51,13 +49,9 @@ equivalent :: !SymbolType !TempSymbolType !{# CommonDefs} !*AttributeEnv !*Type , tst_attr_env :: ![AttrCoercion] } -class bind_and_unify_types a :: a a !*TypeVarHeap -> *TypeVarHeap +updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap) -instance bind_and_unify_types AType, Type, [a] | bind_and_unify_types a - -class substitute a :: !a !u:TypeHeaps -> (!a, !u:TypeHeaps) +class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps) instance substitute AType, Type, TypeContext, AttrInequality, CaseType, [a] | substitute a instance <<< TempSymbolType - -is_non_variable_type :: !Type -> Bool diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 972b76d..c4f4707 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -3,8 +3,8 @@ implementation module typesupport import StdEnv, StdCompare import syntax, parse, check, unitype, utilities, RWSDebug -do_fusion :== False -// MW: this switch is used to en(dis)able the fusion algorithm which currently isn't ready + +SwitchFusion x y = y :: Store :== Int @@ -331,94 +331,70 @@ where (ct_cons_types, cus) = clean_up cui ct_cons_types cus = ({ctype & ct_pattern_type = ct_pattern_type, ct_cons_types = ct_cons_types, ct_result_type = ct_result_type}, cus) +/* + In 'bindInstances t1 t2' type variables of t1 are bound to the corresponding subtypes of t2, provided that + t2 is a substitution instance of t1. Binding is done by setting the 'tv_info_ptr' of the variables of t1 + to 'TVI_Type t' were t is the subtype to which the type variable is matched. + Be careful with calling 'bindInstances': all the 'tv_info_ptr'-info's should be cleaned first, unless one + is sure that t1 does not contain any 'tv_info_ptr' with value 'TVI_Type ...'. -class bind_and_unify_types a :: a a !*TypeVarHeap -> *TypeVarHeap -instance bind_and_unify_types Type + instance bindInstances AType, Type, [a] | bindInstances a +*/ + +updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap) +updateExpressionTypes {st_args,st_vars,st_result,st_attr_vars} st_copy case_and_let_exprs heaps=:{th_vars,th_attrs} expr_heap + # th_vars = foldSt (\{tv_info_ptr} var_heap -> var_heap <:= (tv_info_ptr, TVI_Empty)) st_vars th_vars + th_attrs = foldSt (\{av_info_ptr} attr_heap -> attr_heap <:= (av_info_ptr, AVI_Empty)) st_attr_vars th_attrs + th_vars = bindInstances st_args st_copy.st_args th_vars + th_vars = bindInstances st_result st_copy.st_result th_vars + = foldSt update_expression_type case_and_let_exprs ({heaps & th_vars = th_vars, th_attrs = th_attrs}, expr_heap) +where + update_expression_type expr_ptr (type_heaps, expr_heap) + # (info, expr_heap) = readPtr expr_ptr expr_heap + = case info of + EI_CaseType case_type + # (case_type, type_heaps) = substitute case_type type_heaps + -> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type)) + EI_LetType let_type + # (let_type, type_heaps) = substitute let_type type_heaps + -> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type)) + + +class bindInstances a :: !a !a !*TypeVarHeap -> *TypeVarHeap + +instance bindInstances Type where - bind_and_unify_types (TV tv_1) (TV tv_2) type_var_heap - # (root_1, type_var_heap) = get_root tv_1 type_var_heap - (root_2, type_var_heap) = get_root tv_2 type_var_heap - maybe_root_tv_1 = only_tv root_1 - maybe_root_tv_2 = only_tv root_2 - = case (maybe_root_tv_1, maybe_root_tv_2) of - (Yes root_tv_1, No) - -> bind_root_variable_to_type root_tv_1 root_2 type_var_heap - (No, Yes root_tv_2) - -> bind_root_variable_to_type root_tv_2 root_1 type_var_heap - (Yes root_tv_1, Yes root_tv_2) - | root_tv_1.tv_info_ptr==root_tv_2.tv_info_ptr - -> type_var_heap - -> bind_roots_together root_tv_1 root_2 type_var_heap - (No, No) + bindInstances (TV {tv_info_ptr}) type type_var_heap + # (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap + = case tv_info of + TVI_Type ind_type -> type_var_heap - where - bind_roots_together :: TypeVar Type *(Heap TypeVarInfo) -> .Heap TypeVarInfo; - bind_roots_together root_tv_1 root_type_2 type_var_heap - = type_var_heap <:= (root_tv_1.tv_info_ptr, TVI_Type root_type_2) - - bind_and_unify_types (TV tv_1) type type_var_heap - | not (is_non_variable_type type) - = abort "compiler error in typesupport.icl: assertion failed (1)" - = bind_variable_to_type tv_1 type type_var_heap - bind_and_unify_types type (TV tv_1) type_var_heap - | not (is_non_variable_type type) - = abort "compiler error in typesupport.icl: assertion failed (2)" - = bind_variable_to_type tv_1 type type_var_heap - bind_and_unify_types (TA _ arg_types1) (TA _ arg_types2) type_var_heap - = bind_and_unify_types arg_types1 arg_types2 type_var_heap - bind_and_unify_types (l1 --> r1) (l2 --> r2) type_var_heap - = bind_and_unify_types r1 r2 (bind_and_unify_types l1 l2 type_var_heap) - bind_and_unify_types (TB _) (TB _) type_var_heap + _ + -> type_var_heap <:= (tv_info_ptr, TVI_Type type) + bindInstances (TA _ arg_types1) (TA _ arg_types2) type_var_heap + = bindInstances arg_types1 arg_types2 type_var_heap + bindInstances (l1 --> r1) (l2 --> r2) type_var_heap + = bindInstances r1 r2 (bindInstances l1 l2 type_var_heap) + bindInstances (TB _) (TB _) type_var_heap = type_var_heap - bind_and_unify_types ((CV l1) :@: r1) ((CV l2) :@: r2) type_var_heap - = bind_and_unify_types r1 r2 (bind_and_unify_types (TV l1) (TV l2) type_var_heap) + bindInstances ((CV l1) :@: r1) ((CV l2) :@: r2) type_var_heap + = bindInstances r1 r2 (bindInstances (TV l1) (TV l2) type_var_heap) -instance bind_and_unify_types [a] | bind_and_unify_types a +instance bindInstances [a] | bindInstances a where - bind_and_unify_types [] [] type_var_heap + bindInstances [] [] type_var_heap = type_var_heap - bind_and_unify_types [x:xs] [y:ys] type_var_heap - = bind_and_unify_types xs ys (bind_and_unify_types x y type_var_heap) + bindInstances [x:xs] [y:ys] type_var_heap + = bindInstances xs ys (bindInstances x y type_var_heap) -instance bind_and_unify_types AType +instance bindInstances AType where - bind_and_unify_types {at_type=t1} {at_type=t2} type_var_heap - = bind_and_unify_types t1 t2 type_var_heap + bindInstances {at_type=t1} {at_type=t2} type_var_heap + = bindInstances t1 t2 type_var_heap -only_tv :: u:Type -> Optional u:TypeVar; -only_tv (TV tv) = Yes tv -only_tv _ = No - -is_non_variable_type :: !Type -> Bool -is_non_variable_type (TA _ _) = True -is_non_variable_type (_ --> _) = True -is_non_variable_type (_ :@: _) = True -is_non_variable_type (TB _) = True -is_non_variable_type _ = False - -bind_variable_to_type tv type type_var_heap - # (root, type_var_heap) = get_root tv type_var_heap - = case (only_tv root) of - (Yes tv) -> bind_root_variable_to_type tv type type_var_heap - No -> type_var_heap - -bind_root_variable_to_type {tv_info_ptr} type type_var_heap - = type_var_heap <:= (tv_info_ptr, TVI_Type type) - -get_root :: TypeVar *(Heap TypeVarInfo) -> (Type,.Heap TypeVarInfo); -get_root this_tv type_var_heap - # (tv_info, type_var_heap) = readPtr this_tv.tv_info_ptr type_var_heap - = case tv_info of - TVI_Empty - -> (TV this_tv, type_var_heap) - (TVI_Type type) - | is_non_variable_type type - -> (type, type_var_heap) - -> case type of - (TV next_tv) -> get_root next_tv type_var_heap -class substitute a :: !a !u:TypeHeaps -> (!a, !u:TypeHeaps) +class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps) instance substitute AType where @@ -429,18 +405,18 @@ where instance substitute TypeAttribute where substitute (TA_Var {av_name, av_info_ptr}) heaps=:{th_attrs} -/* MW: was: - #! av_info = sreadPtr av_info_ptr th_attrs - # (AVI_Attr attr) = av_info - = (attr, heaps) +/* + This alternative's code can be replaced with the original again, when the fusion algorithm becomes able to + infer correct type attributes */ -// XXX this alternative's code can be replaced with the original again, when the fusion algorithm becomes able to -// infer correct type attributes #! av_info = sreadPtr av_info_ptr th_attrs = case av_info of - (AVI_Attr attr) -> (attr, heaps) - _ | do_fusion -> (TA_Multi, heaps) - -> abort "compiler bug nr 7689 in module typesupport" + AVI_Attr attr + -> (attr, heaps) + _ + -> SwitchFusion + (TA_Multi, heaps) + (abort "compiler bug nr 7689 in module typesupport") substitute TA_None heaps = (TA_Multi, heaps) substitute attr heaps @@ -469,13 +445,15 @@ where # (tc_types, heaps) = substitute tc_types heaps = ({ tc & tc_types = tc_types }, heaps) -substituteTypeVariable {tv_name,tv_info_ptr} heaps=:{th_vars} - #! tv_info = sreadPtr tv_info_ptr th_vars +substituteTypeVariable tv=:{tv_name,tv_info_ptr} heaps=:{th_vars} + # (tv_info, th_vars) = readPtr tv_info_ptr th_vars + heaps = { heaps & th_vars = th_vars } = case tv_info of TVI_Type type -> (type, heaps) _ - -> abort ("Error in substitute (Type)" ---> (tv_info, tv_name)) + -> (TV tv, heaps) +// -> abort ("Error in substitute (Type)" ---> (tv_info, tv_name)) instance substitute Type where @@ -496,10 +474,13 @@ where instance substitute AttributeVar where - substitute {av_info_ptr} heaps=:{th_attrs} + substitute av=:{av_info_ptr} heaps=:{th_attrs} #! av_info = sreadPtr av_info_ptr th_attrs - # (AVI_Attr (TA_Var attr_var)) = av_info - = (attr_var, heaps) + = case av_info of + AVI_Attr (TA_Var attr_var) + -> (attr_var, heaps) + _ + -> (av, heaps) instance substitute AttrInequality where |