Commit 9703f10f authored by John van Groningen's avatar John van Groningen

set FI_HasTypeCodes in fi_properties if a function contains type codes and

should be converted in module convertDynamics, instead of storing a list with one nilPtr in fi_dynamics,
remove unnecessary Let expressions with unused variables by
initializing with VI_NotUsed instead of VI_Empty
parent dc8586a7
...@@ -122,18 +122,23 @@ where ...@@ -122,18 +122,23 @@ where
convert_function group_nr dynamic_representation fun (fun_defs, ci) convert_function group_nr dynamic_representation fun (fun_defs, ci)
# (fun_def, fun_defs) = fun_defs![fun] # (fun_def, fun_defs) = fun_defs![fun]
{fun_body, fun_type, fun_info} = fun_def {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) = (fun_defs, ci)
# (unify_subst_var, ci) = newVariable "unify_subst" VI_NotUsed ci
# (unify_subst_var, ci) = newVariable "unify_subst" VI_Empty ci
# ci = {ci & ci_type_pattern_var_count = 0, ci_type_var_count = 0} # 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, # (fun_body, ci) = convertDynamics {cinp_st_args = [], cinp_dynamic_representation = dynamic_representation,
cinp_subst_var = unify_subst_var} fun_body ci 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 }}}, = ({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 = []}) {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) class convertDynamics a :: !ConversionInput !a !*ConversionState -> (!a, !*ConversionState)
instance convertDynamics [a] | convertDynamics a where instance convertDynamics [a] | convertDynamics a where
...@@ -153,55 +158,58 @@ instance convertDynamics FunctionBody where ...@@ -153,55 +158,58 @@ instance convertDynamics FunctionBody where
= (TransformedBody body, ci) = (TransformedBody body, ci)
instance convertDynamics TransformedBody where instance convertDynamics TransformedBody where
convertDynamics cinp body=:{tb_args,tb_rhs} ci=:{ci_var_heap} 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 // this actually marks all arguments as type terms (also the regular arguments and dictionaries)
// and dictionaries)
// # ci_var_heap // # ci_var_heap
// = foldSt mark_var tb_args ci_var_heap // = foldSt mark_var tb_args ci_var_heap
# (tb_rhs, ci) # (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) # (global_tpvs, subst, ci)
= foldSt collect_global_type_pattern_var tb_args ([], cinp.cinp_subst_var, ci) = foldSt collect_global_type_pattern_var tb_args ([], cinp_subst_var, ci)
# (tb_rhs, ci) = case sreadPtr cinp_subst_var.var_info_ptr ci.ci_var_heap of
= share_init_subst subst global_tpvs tb_rhs ci VI_NotUsed
= ({body & tb_rhs = tb_rhs}, ci) -> ({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 where
// mark_var :: FreeVar *VarHeap -> *VarHeap // mark_var :: FreeVar *VarHeap -> *VarHeap
// mark_var {fv_info_ptr} var_heap // mark_var {fv_info_ptr} var_heap
// = writePtr fv_info_ptr (VI_TypeCodeVariable TCI_TypeTerm) 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 :: 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 # (var_info, ci_var_heap) = readPtr fv_info_ptr ci.ci_var_heap
ci = {ci & ci_var_heap = ci_var_heap} ci = {ci & ci_var_heap = ci_var_heap}
= case var_info of = case var_info of
VI_TypeCodeVariable (TCI_TypePatternVar tpv) VI_TypeCodeVariable (TCI_TypePatternVar tpv)
# type_code = Var {var_ident = a_ij_var_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} # 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) 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 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) # (bind_global_tpv_symb, ci)
= getSymbol PD_Dyn_bind_global_type_pattern_var SK_Function 3 ci = getSymbol PD_Dyn_bind_global_type_pattern_var SK_Function 3 ci
(unify_subst_var, ci) = newVariable "gtpv_subst" VI_Empty 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 let_bind
= { lb_src = App { app_symb = bind_global_tpv_symb, = { lb_src = App { app_symb = bind_global_tpv_symb,
app_args = [tpv, type_code, Var unify_subst_var], app_args = [tpv, type_code, Var unify_subst_var],
app_info_ptr = nilPtr } app_info_ptr = nilPtr }
, lb_dst = varToFreeVar subst 1 , lb_dst = varToFreeVar subst_var 1
, lb_position = NoPos } , lb_position = NoPos }
= ([let_bind:let_binds], unify_subst_var, ci) = ([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} # dictionary = Var {var_ident = a_ij_var_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr}
type_code = Selection NormalSelector dictionary selections type_code = Selection NormalSelector dictionary selections
(let_binds,subst,ci) = bind_global_type_pattern_var tpv type_code 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 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 ci collect_global_type_pattern_var_selections [] fv_info_ptr let_binds subst_var ci
= (let_binds,subst,ci) = (let_binds,subst_var,ci)
share_init_subst :: BoundVar [LetBind] Expression *ConversionState share_init_subst :: BoundVar [LetBind] Expression *ConversionState
-> (Expression, *ConversionState) -> (Expression, *ConversionState)
...@@ -375,14 +383,14 @@ convertDynamicCase cinp=:{cinp_dynamic_representation={dr_dynamic_symbol, dr_dyn ...@@ -375,14 +383,14 @@ convertDynamicCase cinp=:{cinp_dynamic_representation={dr_dynamic_symbol, dr_dyn
convertDynamicAlts _ _ _ _ _ defoult [] ci convertDynamicAlts _ _ _ _ _ defoult [] ci
= (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) # (type_code, binds, ci)
= convertPatternTypeCode cinp dp_type_code ci = convertPatternTypeCode cinp dp_type_code ci
# (unify_symb, ci) # (unify_symb, ci)
= getSymbol PD_Dyn_unify SK_Function (extended_unify_and_coerce 3 4) /*3 was 2 */ ci = getSymbol PD_Dyn_unify SK_Function (extended_unify_and_coerce 3 4) /*3 was 2 */ ci
# 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.cinp_subst_var,Var type_var,type_code], app_info_ptr = nilPtr} # 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) // FIXME, more precise types (not all TEs)
# (let_info_ptr, ci) = let_ptr (/* 4 */ 3+length binds) ci # (let_info_ptr, ci) = let_ptr (/* 4 */ 3+length binds) ci
...@@ -458,24 +466,20 @@ instance convertDynamics Selection where ...@@ -458,24 +466,20 @@ instance convertDynamics Selection where
# (expr, ci) = convertDynamics cinp expr ci # (expr, ci) = convertDynamics cinp expr ci
= (DictionarySelection var selectors expr_ptr expr, ci) = (DictionarySelection var selectors expr_ptr expr, ci)
convertExprTypeCode convertExprTypeCode :: !ConversionInput !TypeCodeExpression !*ConversionState
:: !ConversionInput !TypeCodeExpression !*ConversionState
-> (!Expression, !*ConversionState) -> (!Expression, !*ConversionState)
convertExprTypeCode cinp tce ci convertExprTypeCode cinp=:{cinp_subst_var} tce ci
# (type_code, (has_var, binds, ci)) # (type_code, (has_var, binds, ci))
= convertTypeCode False cinp tce (False, [], ci) = convertTypeCode False cinp tce (False, [], ci)
// sanity check ...
| not (isEmpty binds) | not (isEmpty binds)
= abort "unexpected binds in expression type code" = abort "unexpected binds in expression type code"
// ... sanity check
| has_var | has_var
# ci & ci_var_heap = mark_cinp_subst_var cinp_subst_var ci.ci_var_heap
# (normalise_symb, ci) # (normalise_symb, ci)
= getSymbol PD_Dyn_normalise SK_Function 2 ci = getSymbol PD_Dyn_normalise SK_Function 2 ci
# type_code # type_code
= App { app_symb = normalise_symb, = App {app_symb = normalise_symb, app_args = [Var cinp.cinp_subst_var, type_code], app_info_ptr = nilPtr}
app_args = [ Var cinp.cinp_subst_var, type_code], app_info_ptr = nilPtr }
= (type_code, ci) = (type_code, ci)
// otherwise
= (type_code, ci) = (type_code, ci)
convertPatternTypeCode :: !ConversionInput !TypeCodeExpression !*ConversionState convertPatternTypeCode :: !ConversionInput !TypeCodeExpression !*ConversionState
...@@ -679,7 +683,6 @@ freeVarToVar :: FreeVar -> BoundVar ...@@ -679,7 +683,6 @@ freeVarToVar :: FreeVar -> BoundVar
freeVarToVar {fv_ident, fv_info_ptr} freeVarToVar {fv_ident, fv_info_ptr}
= { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} = { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr}
getResultType :: ExprInfoPtr !*ConversionState -> (!AType, !*ConversionState) getResultType :: ExprInfoPtr !*ConversionState -> (!AType, !*ConversionState)
getResultType case_info_ptr ci=:{ci_expr_heap} getResultType case_info_ptr ci=:{ci_expr_heap}
# (EI_CaseType {ct_result_type}, ci_expr_heap) = readPtr case_info_ptr ci_expr_heap # (EI_CaseType {ct_result_type}, ci_expr_heap) = readPtr case_info_ptr ci_expr_heap
......
...@@ -1340,7 +1340,6 @@ where ...@@ -1340,7 +1340,6 @@ where
# (fun_def, fun_defs) = fun_defs![fun_index] # (fun_def, fun_defs) = fun_defs![fun_index]
(CheckedType st=:{st_context,st_args}, fun_env) = fun_env![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 {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 var_heap = mark_FPC_arguments st_args tb_args var_heap
error = setErrorAdmin (newPosition fun_ident fun_pos) error error = setErrorAdmin (newPosition fun_ident fun_pos) error
...@@ -1357,19 +1356,12 @@ where ...@@ -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_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 = ui
# (tb_args, var_heap) = foldSt retrieve_class_argument rev_variables (tb_args, ui_var_heap) # (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_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_arity = length tb_args,
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_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_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) = (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) = (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 :: ![AType] ![FreeVar] !*VarHeap -> *VarHeap
mark_FPC_arguments st_args tb_args var_heap mark_FPC_arguments st_args tb_args var_heap
......
...@@ -666,6 +666,7 @@ FI_MemberInstanceRequiresTypeInDefMod :== 16 ...@@ -666,6 +666,7 @@ FI_MemberInstanceRequiresTypeInDefMod :== 16
FI_GenericFun :== 32 FI_GenericFun :== 32
FI_Unused :== 64 // used in module trans FI_Unused :== 64 // used in module trans
FI_UnusedUsed :== 128 // used in module trans FI_UnusedUsed :== 128 // used in module trans
FI_HasTypeCodes :== 256
:: FunInfo = :: FunInfo =
{ fi_calls :: ![FunCall] { fi_calls :: ![FunCall]
...@@ -794,6 +795,7 @@ pIsSafe :== True ...@@ -794,6 +795,7 @@ pIsSafe :== True
VI_ExpressionOrBody !Expression !SymbIdent !TransformedBody ![FreeVar] ![TypeVar] ![TypeVar] | /* used during fusion */ VI_ExpressionOrBody !Expression !SymbIdent !TransformedBody ![FreeVar] ![TypeVar] ![TypeVar] | /* used during fusion */
VI_Dictionary !SymbIdent ![Expression] !Type | /* used during fusion */ VI_Dictionary !SymbIdent ![Expression] !Type | /* used during fusion */
VI_Extended !ExtendedVarInfo !VarInfo | VI_Extended !ExtendedVarInfo !VarInfo |
VI_NotUsed |
// MdM // MdM
VI_CPSExprVar !CheatCompiler /* a pointer to a variable in CleanProverSystem is stored here, using a cast */ VI_CPSExprVar !CheatCompiler /* a pointer to a variable in CleanProverSystem is stored here, using a cast */
// ... MdM // ... MdM
......
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