diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/convertDynamics.icl | 79 | ||||
| -rw-r--r-- | frontend/overloading.icl | 14 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 |
3 files changed, 46 insertions, 49 deletions
diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index bbe667d..7250896 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -122,18 +122,23 @@ where convert_function group_nr dynamic_representation fun (fun_defs, ci) # (fun_def, fun_defs) = fun_defs![fun] {fun_body, fun_type, fun_info} = fun_def - | isEmpty fun_info.fi_dynamics + | fun_info.fi_properties bitand FI_HasTypeCodes==0 && isEmpty fun_info.fi_dynamics = (fun_defs, ci) - - # (unify_subst_var, ci) = newVariable "unify_subst" VI_Empty ci + # (unify_subst_var, ci) = newVariable "unify_subst" VI_NotUsed ci # ci = {ci & ci_type_pattern_var_count = 0, ci_type_var_count = 0} - # (fun_body, ci) = convertDynamics {cinp_st_args = [], cinp_dynamic_representation = dynamic_representation, cinp_subst_var = unify_subst_var} fun_body ci - = ({fun_defs & [fun] = {fun_def & fun_body = fun_body, fun_info = {fun_info & fi_local_vars = ci.ci_new_variables ++ fun_info.fi_local_vars }}}, {ci & ci_new_variables = []}) +mark_cinp_subst_var :: !BoundVar !*VarHeap -> *VarHeap; +mark_cinp_subst_var {var_info_ptr} var_heap + = case sreadPtr var_info_ptr var_heap of + VI_NotUsed + -> writePtr var_info_ptr VI_Empty var_heap + _ + -> var_heap + class convertDynamics a :: !ConversionInput !a !*ConversionState -> (!a, !*ConversionState) instance convertDynamics [a] | convertDynamics a where @@ -153,55 +158,58 @@ instance convertDynamics FunctionBody where = (TransformedBody body, ci) instance convertDynamics TransformedBody where - convertDynamics cinp body=:{tb_args,tb_rhs} ci=:{ci_var_heap} - // this actually marks all arguments as type terms (also the regular arguments - // and dictionaries) + convertDynamics cinp=:{cinp_subst_var} body=:{tb_args,tb_rhs} ci=:{ci_var_heap} + // this actually marks all arguments as type terms (also the regular arguments and dictionaries) // # ci_var_heap // = foldSt mark_var tb_args ci_var_heap # (tb_rhs, ci) - = convertDynamics cinp tb_rhs {ci & ci_var_heap = ci_var_heap} + = convertDynamics cinp tb_rhs {ci & ci_var_heap = ci_var_heap} # (global_tpvs, subst, ci) - = foldSt collect_global_type_pattern_var tb_args ([], cinp.cinp_subst_var, ci) - # (tb_rhs, ci) - = share_init_subst subst global_tpvs tb_rhs ci - = ({body & tb_rhs = tb_rhs}, ci) + = foldSt collect_global_type_pattern_var tb_args ([], cinp_subst_var, ci) + = case sreadPtr cinp_subst_var.var_info_ptr ci.ci_var_heap of + VI_NotUsed + -> ({body & tb_rhs = tb_rhs}, ci) + _ + # (tb_rhs, ci) = share_init_subst subst global_tpvs tb_rhs ci + -> ({body & tb_rhs = tb_rhs}, ci) where // mark_var :: FreeVar *VarHeap -> *VarHeap // mark_var {fv_info_ptr} var_heap // = writePtr fv_info_ptr (VI_TypeCodeVariable TCI_TypeTerm) var_heap collect_global_type_pattern_var :: FreeVar ([LetBind], BoundVar, *ConversionState) -> ([LetBind], BoundVar, *ConversionState) - collect_global_type_pattern_var {fv_info_ptr} (let_binds, subst, ci) + collect_global_type_pattern_var {fv_info_ptr} (let_binds, subst_var, ci) # (var_info, ci_var_heap) = readPtr fv_info_ptr ci.ci_var_heap ci = {ci & ci_var_heap = ci_var_heap} = case var_info of VI_TypeCodeVariable (TCI_TypePatternVar tpv) # type_code = Var {var_ident = a_ij_var_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} - -> bind_global_type_pattern_var tpv type_code let_binds subst ci + -> bind_global_type_pattern_var tpv type_code let_binds subst_var ci VI_TypeCodeVariable (TCI_SelectionsTypePatternVar tc_selections) - -> collect_global_type_pattern_var_selections tc_selections fv_info_ptr let_binds subst ci + -> collect_global_type_pattern_var_selections tc_selections fv_info_ptr let_binds subst_var ci _ - -> (let_binds, subst, ci) + -> (let_binds, subst_var, ci) where - bind_global_type_pattern_var tpv type_code let_binds subst ci + bind_global_type_pattern_var tpv type_code let_binds subst_var ci # (bind_global_tpv_symb, ci) = getSymbol PD_Dyn_bind_global_type_pattern_var SK_Function 3 ci (unify_subst_var, ci) = newVariable "gtpv_subst" VI_Empty ci + ci & ci_var_heap = mark_cinp_subst_var cinp_subst_var ci.ci_var_heap let_bind = { lb_src = App { app_symb = bind_global_tpv_symb, app_args = [tpv, type_code, Var unify_subst_var], app_info_ptr = nilPtr } - , lb_dst = varToFreeVar subst 1 + , lb_dst = varToFreeVar subst_var 1 , lb_position = NoPos } = ([let_bind:let_binds], unify_subst_var, ci) - collect_global_type_pattern_var_selections [(tpv,selections):tc_selections] fv_info_ptr let_binds subst ci + collect_global_type_pattern_var_selections [(tpv,selections):tc_selections] fv_info_ptr let_binds subst_var ci # dictionary = Var {var_ident = a_ij_var_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} type_code = Selection NormalSelector dictionary selections - (let_binds,subst,ci) = bind_global_type_pattern_var tpv type_code let_binds subst ci - = collect_global_type_pattern_var_selections tc_selections fv_info_ptr let_binds subst ci - collect_global_type_pattern_var_selections [] fv_info_ptr let_binds subst ci - = (let_binds,subst,ci) + (let_binds,subst_var,ci) = bind_global_type_pattern_var tpv type_code let_binds subst_var ci + = collect_global_type_pattern_var_selections tc_selections fv_info_ptr let_binds subst_var ci + collect_global_type_pattern_var_selections [] fv_info_ptr let_binds subst_var ci + = (let_binds,subst_var,ci) share_init_subst :: BoundVar [LetBind] Expression *ConversionState -> (Expression, *ConversionState) @@ -375,14 +383,14 @@ convertDynamicCase cinp=:{cinp_dynamic_representation={dr_dynamic_symbol, dr_dyn convertDynamicAlts _ _ _ _ _ defoult [] ci = (defoult, ci) -convertDynamicAlts cinp kees type_var value_var result_type defoult [{dp_rhs, dp_position, dp_type_code, dp_var}:alts] ci +convertDynamicAlts cinp=:{cinp_subst_var} kees type_var value_var result_type defoult [{dp_rhs, dp_position, dp_type_code, dp_var}:alts] ci # (type_code, binds, ci) = convertPatternTypeCode cinp dp_type_code ci # (unify_symb, ci) = getSymbol PD_Dyn_unify SK_Function (extended_unify_and_coerce 3 4) /*3 was 2 */ ci - - # unify_call = App {app_symb = unify_symb, app_args = [Var cinp.cinp_subst_var,Var type_var,type_code], app_info_ptr = nilPtr} + # ci & ci_var_heap = mark_cinp_subst_var cinp_subst_var ci.ci_var_heap + # unify_call = App {app_symb = unify_symb, app_args = [Var cinp_subst_var,Var type_var,type_code], app_info_ptr = nilPtr} // FIXME, more precise types (not all TEs) # (let_info_ptr, ci) = let_ptr (/* 4 */ 3+length binds) ci @@ -458,25 +466,21 @@ instance convertDynamics Selection where # (expr, ci) = convertDynamics cinp expr ci = (DictionarySelection var selectors expr_ptr expr, ci) -convertExprTypeCode - :: !ConversionInput !TypeCodeExpression !*ConversionState +convertExprTypeCode :: !ConversionInput !TypeCodeExpression !*ConversionState -> (!Expression, !*ConversionState) -convertExprTypeCode cinp tce ci +convertExprTypeCode cinp=:{cinp_subst_var} tce ci # (type_code, (has_var, binds, ci)) = convertTypeCode False cinp tce (False, [], ci) - // sanity check ... | not (isEmpty binds) = abort "unexpected binds in expression type code" - // ... sanity check | has_var + # ci & ci_var_heap = mark_cinp_subst_var cinp_subst_var ci.ci_var_heap # (normalise_symb, ci) = getSymbol PD_Dyn_normalise SK_Function 2 ci # type_code - = App { app_symb = normalise_symb, - app_args = [ Var cinp.cinp_subst_var, type_code], app_info_ptr = nilPtr } - = (type_code, ci) - // otherwise - = (type_code, ci) + = App {app_symb = normalise_symb, app_args = [Var cinp.cinp_subst_var, type_code], app_info_ptr = nilPtr} + = (type_code, ci) + = (type_code, ci) convertPatternTypeCode :: !ConversionInput !TypeCodeExpression !*ConversionState -> (!Expression, ![LetBind], !*ConversionState) @@ -679,7 +683,6 @@ freeVarToVar :: FreeVar -> BoundVar freeVarToVar {fv_ident, fv_info_ptr} = { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} - getResultType :: ExprInfoPtr !*ConversionState -> (!AType, !*ConversionState) getResultType case_info_ptr ci=:{ci_expr_heap} # (EI_CaseType {ct_result_type}, ci_expr_heap) = readPtr case_info_ptr ci_expr_heap diff --git a/frontend/overloading.icl b/frontend/overloading.icl index ce5858e..b94f3d2 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -1340,7 +1340,6 @@ where # (fun_def, fun_defs) = fun_defs![fun_index] (CheckedType st=:{st_context,st_args}, fun_env) = fun_env![fun_index] {fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_ident,fun_pos} = fun_def - var_heap = mark_FPC_arguments st_args tb_args var_heap error = setErrorAdmin (newPosition fun_ident fun_pos) error @@ -1357,19 +1356,12 @@ where # {ui_instance_calls, ui_local_vars, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_has_type_codes, ui_error, ui_x = {x_type_code_info = type_code_info, x_predef_symbols = predef_symbols}} = ui # (tb_args, var_heap) = foldSt retrieve_class_argument rev_variables (tb_args, ui_var_heap) - fun_info = mark_type_codes ui_has_type_codes fun_info - fun_def = { fun_def & fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_arity = length tb_args, - fun_info = { fun_info & fi_calls = fun_info.fi_calls ++ ui_instance_calls, fi_local_vars = ui_local_vars } } + fun_def & fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_arity = length tb_args, + fun_info = {fun_info & fi_calls = fun_info.fi_calls ++ ui_instance_calls, fi_local_vars = ui_local_vars, + fi_properties = fun_info.fi_properties bitor FI_HasTypeCodes} #! ok = ui_error.ea_ok = (ok, { ui_fun_defs & [fun_index] = fun_def }, ui_fun_env, ui_symbol_heap, type_code_info, var_heap, ui_error, predef_symbols) = (False, fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols) - where - // this is a ugly way to mark this function for conversion in convertDynamics - // FIXME: find a better way to mark the function - mark_type_codes True info=:{fi_dynamics=[]} - = {info & fi_dynamics = [nilPtr]} - mark_type_codes _ info - = info mark_FPC_arguments :: ![AType] ![FreeVar] !*VarHeap -> *VarHeap mark_FPC_arguments st_args tb_args var_heap diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index a64a78d..066c32d 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -666,6 +666,7 @@ FI_MemberInstanceRequiresTypeInDefMod :== 16 FI_GenericFun :== 32 FI_Unused :== 64 // used in module trans FI_UnusedUsed :== 128 // used in module trans +FI_HasTypeCodes :== 256 :: FunInfo = { fi_calls :: ![FunCall] @@ -794,6 +795,7 @@ pIsSafe :== True VI_ExpressionOrBody !Expression !SymbIdent !TransformedBody ![FreeVar] ![TypeVar] ![TypeVar] | /* used during fusion */ VI_Dictionary !SymbIdent ![Expression] !Type | /* used during fusion */ VI_Extended !ExtendedVarInfo !VarInfo | + VI_NotUsed | // MdM VI_CPSExprVar !CheatCompiler /* a pointer to a variable in CleanProverSystem is stored here, using a cast */ // ... MdM |