Skip to content

GitLab

Commit db332604 authored by Martin Wierich's avatar Martin Wierich
Browse files

-added position information for let bindings for better error messages 

 (changes are commented with "MW0")
parent 0d6d1318
Expand all Hide whitespace changes
Inline Side-by-side
backend/backendconvert.icl
View file @ db332604
......@@ -535,13 +535,17 @@ instance declareVars FreeVar where
declareVars freeVar (_, varHeap)
= declareVariable BELhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name varHeap
instance declareVars (Bind Expression FreeVar) where
declareVars :: (Bind Expression FreeVar) !DeclVarsInput -> BackEnder
declareVars {bind_src=App {app_symb, app_args=[Var _:_]}, bind_dst=freeVar} (aliasDummyId, varHeap)
// MW0instance declareVars (Bind Expression FreeVar) where
instance declareVars LetBind where
// MW0 declareVars :: (Bind Expression FreeVar) !DeclVarsInput -> BackEnder
declareVars :: LetBind !DeclVarsInput -> BackEnder
// MW0 declareVars {bind_src=App {app_symb, app_args=[Var _:_]}, bind_dst=freeVar} (aliasDummyId, varHeap)
declareVars {lb_src=App {app_symb, app_args=[Var _:_]}, lb_dst=freeVar} (aliasDummyId, varHeap)
| app_symb.symb_name==aliasDummyId
= identity // we have an alias. Don't declare the same variable twice
= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name varHeap
declareVars {bind_dst=freeVar} (_, varHeap)
// MW0 declareVars {bind_dst=freeVar} (_, varHeap)
declareVars {lb_dst=freeVar} (_, varHeap)
= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name varHeap
declareVariable :: Int (Ptr VarInfo) {#Char} VarHeap -> BackEnder
......@@ -1244,13 +1248,15 @@ defineLhsNodeDef freeVar pattern nodeDefs varHeap
(beNodeDef variable_sequence_number (convertPattern pattern varHeap))
(return nodeDefs) be
collectNodeDefs :: Ident Expression -> [Bind Expression FreeVar]
// MW0 collectNodeDefs :: Ident Expression -> [Bind Expression FreeVar]
collectNodeDefs :: Ident Expression -> [LetBind]
collectNodeDefs aliasDummyId (Let {let_strict_binds, let_lazy_binds})
= filterStrictAlias let_strict_binds let_lazy_binds
where
filterStrictAlias [] let_lazy_binds
= let_lazy_binds
filterStrictAlias [strict_bind=:{bind_src=App app}:strict_binds] let_lazy_binds
// MW0 filterStrictAlias [strict_bind=:{bind_src=App app}:strict_binds] let_lazy_binds
filterStrictAlias [strict_bind=:{lb_src=App app}:strict_binds] let_lazy_binds
| app.app_symb.symb_name==aliasDummyId
// the compiled source was a strict alias like "#! x = y"
= case hd app.app_args of
......@@ -1259,7 +1265,8 @@ collectNodeDefs aliasDummyId (Let {let_strict_binds, let_lazy_binds})
-> filterStrictAlias strict_binds let_lazy_binds
hd_app_args
// the node is not an alias anymore: remove just the _dummyForStrictAlias call
-> [{ strict_bind & bind_src = hd_app_args } : filterStrictAlias strict_binds let_lazy_binds]
// MW0 -> [{ strict_bind & bind_src = hd_app_args } : filterStrictAlias strict_binds let_lazy_binds]
-> [{ strict_bind & lb_src = hd_app_args } : filterStrictAlias strict_binds let_lazy_binds]
filterStrictAlias [strict_bind:strict_binds] let_lazy_binds
= [strict_bind: filterStrictAlias strict_binds let_lazy_binds]
collectNodeDefs _ _
......@@ -1269,18 +1276,22 @@ convertRhsNodeDefs :: Ident Expression Int VarHeap -> BEMonad BENodeDefP
convertRhsNodeDefs aliasDummyId expr main_dcl_module_n varHeap
= convertNodeDefs (collectNodeDefs aliasDummyId expr) varHeap
where
convertNodeDefs :: [Bind Expression FreeVar] VarHeap -> BEMonad BENodeDefP
// MW0 convertNodeDefs :: [Bind Expression FreeVar] VarHeap -> BEMonad BENodeDefP
convertNodeDefs :: [LetBind] VarHeap -> BEMonad BENodeDefP
convertNodeDefs binds varHeap
= sfoldr (beNodeDefs o flip convertNodeDef varHeap) beNoNodeDefs binds
where
convertNodeDef :: !(Bind Expression FreeVar) VarHeap -> BEMonad BENodeDefP
convertNodeDef {bind_src=expr, bind_dst=freeVar} varHeap
// MW0 convertNodeDef :: !(Bind Expression FreeVar) VarHeap -> BEMonad BENodeDefP
convertNodeDef :: !LetBind VarHeap -> BEMonad BENodeDefP
// MW0 convertNodeDef {bind_src=expr, bind_dst=freeVar} varHeap
convertNodeDef {lb_src=expr, lb_dst=freeVar} varHeap
= \be0 -> let (variable_sequence_number,be) = getVariableSequenceNumber freeVar.fv_info_ptr varHeap be0 in
beNodeDef variable_sequence_number (convertExpr expr main_dcl_module_n varHeap) be
collectStrictNodeIds :: Expression -> [FreeVar]
collectStrictNodeIds (Let {let_strict_binds, let_expr})
= [bind_dst \\ {bind_dst} <- let_strict_binds]
// MW0 = [bind_dst \\ {bind_dst} <- let_strict_binds]
= [lb_dst \\ {lb_dst} <- let_strict_binds]
collectStrictNodeIds _
= []
......
backend/backendpreprocess.icl
View file @ db332604
......@@ -113,11 +113,15 @@ instance sequence Selection where
sequence (DictionarySelection dictionaryVar dictionarySelections _ index)
= sequence index
instance sequence (Bind Expression FreeVar) where
sequence {bind_src=App app , bind_dst}
= sequence` app bind_dst
// MW0 instance sequence (Bind Expression FreeVar) where
instance sequence LetBind where
// MW0 sequence {bind_src=App app , bind_dst}
sequence {lb_src=App app , lb_dst}
// MW0 = sequence` app bind_dst
= sequence` app lb_dst
where
sequence` {app_symb, app_args} bind_dst sequenceState=:{ss_aliasDummyId}
// MW0 sequence` {app_symb, app_args} bind_dst sequenceState=:{ss_aliasDummyId}
sequence` {app_symb, app_args} lb_dst sequenceState=:{ss_aliasDummyId}
| app_symb.symb_name==ss_aliasDummyId
// the compiled source was a strict alias like "#! x = y"
= case hd app_args of
......@@ -126,13 +130,17 @@ instance sequence (Bind Expression FreeVar) where
non_alias_bound_var = case vi of
VI_SequenceNumber _ -> bound_var
VI_Alias alias_bound_var-> alias_bound_var
ss_varHeap = writePtr bind_dst.fv_info_ptr (VI_Alias non_alias_bound_var) ss_varHeap
// MW0 ss_varHeap = writePtr bind_dst.fv_info_ptr (VI_Alias non_alias_bound_var) ss_varHeap
ss_varHeap = writePtr lb_dst.fv_info_ptr (VI_Alias non_alias_bound_var) ss_varHeap
-> { sequenceState & ss_varHeap = ss_varHeap }
_
-> sequence bind_dst sequenceState
= sequence bind_dst sequenceState
// MW0 -> sequence bind_dst sequenceState
-> sequence lb_dst sequenceState
// MW0 = sequence bind_dst sequenceState
= sequence lb_dst sequenceState
sequence bind
= sequence bind.bind_dst
// MW0 = sequence bind.bind_dst
= sequence bind.lb_dst
instance sequence FunctionPattern where
sequence (FP_Algebraic _ subpatterns optionalVar)
......
frontend/check.icl
View file @ db332604
This diff is collapsed.
frontend/comparedefimp.icl
View file @ db332604
......@@ -742,8 +742,6 @@ instance e_corresponds DefinedSymbol where
instance e_corresponds FunctionBody where
// both bodies are either CheckedBodies or TransformedBodies
e_corresponds dclDef iclDef
// | False--->("compare", from_body dclDef, from_body iclDef)
// = undef
= e_corresponds (from_body dclDef) (from_body iclDef)
where
from_body (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs])
......@@ -824,6 +822,11 @@ instance e_corresponds Let where
o` e_corresponds dclLet.let_lazy_binds iclLet.let_lazy_binds
o` e_corresponds dclLet.let_expr iclLet.let_expr
instance e_corresponds LetBind where
e_corresponds dcl icl
= e_corresponds dcl.lb_src icl.lb_src
o` e_corresponds dcl.lb_dst icl.lb_dst
instance e_corresponds (Bind a b) | e_corresponds a & e_corresponds b where
e_corresponds dcl icl
= e_corresponds dcl.bind_src icl.bind_src
......@@ -941,6 +944,13 @@ e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_Function dcl_glob_index}
ec_state
= continuation_for_possibly_twice_defined_funs dcl_app_symb dcl_glob_index icl_app_symb icl_glob_index
ec_state
e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_LocalMacroFunction dcl_index}
icl_app_symb=:{symb_kind=SK_LocalMacroFunction icl_index}
ec_state
#! main_dcl_module_n=ec_state.ec_tc_state.tc_main_dcl_module_n
= continuation_for_possibly_twice_defined_funs dcl_app_symb
{ glob_module = main_dcl_module_n, glob_object = dcl_index } icl_app_symb
{ glob_module = main_dcl_module_n, glob_object = icl_index } ec_state
e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_OverloadedFunction dcl_glob_index}
icl_app_symb=:{symb_kind=SK_OverloadedFunction icl_glob_index}
ec_state
......
frontend/convertDynamics.icl
View file @ db332604
......@@ -101,6 +101,13 @@ where
convertDynamics _ _ _ No ci
= (No, ci)
instance convertDynamics LetBind
where
convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !LetBind !*ConversionInfo -> (!LetBind, !*ConversionInfo)
convertDynamics cinp bound_vars default_expr binding=:{lb_src} ci
# (lb_src, ci) = convertDynamics cinp bound_vars default_expr lb_src ci
= ({binding & lb_src = lb_src}, ci)
instance convertDynamics (Bind a b) | convertDynamics a
where
convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !(Bind a b) !*ConversionInfo -> (!Bind a b, !*ConversionInfo) | convertDynamics a
......@@ -135,7 +142,8 @@ where
= (expr @ exprs, ci)
convertDynamics cinp bound_vars default_expr (Let letje=:{let_strict_binds, let_lazy_binds, let_expr,let_info_ptr}) ci
# (let_types, ci) = determine_let_types let_info_ptr ci
bound_vars = bindVarsToTypes [ bind.bind_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
// MW0 bound_vars = bindVarsToTypes [ bind.bind_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
bound_vars = bindVarsToTypes [ bind.lb_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
(let_strict_binds, ci) = convertDynamics cinp bound_vars default_expr let_strict_binds ci
(let_lazy_binds, ci) = convertDynamics cinp bound_vars default_expr let_lazy_binds ci
(let_expr, ci) = convertDynamics cinp bound_vars default_expr let_expr ci
......@@ -205,7 +213,9 @@ where
let_expr = App { app_symb = twoTuple_symb,
app_args = [dyn_expr, dyn_type_code],
app_info_ptr = nilPtr },
let_info_ptr = let_info_ptr}, ci)
// MW0 let_info_ptr = let_info_ptr,}, ci)
let_info_ptr = let_info_ptr,
let_expr_position = NoPos}, ci)
convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci
= abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci
convertDynamics cinp bound_vars default_expr EE ci
......@@ -358,13 +368,14 @@ where
= [{ tv_free_var = {fv_def_level = NotALevel, fv_name = a_ij_var_name, fv_info_ptr = var_info_ptr, fv_count = 0}, tv_type = empty_attributed_type } : bound_vars]
open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, Bind Expression FreeVar, !*ConversionInfo)
open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, LetBind, !*ConversionInfo)
open_dynamic dynamic_expr ci
# (twotuple, ci) = getTupleSymbol 2 ci
(dynamicType_var, ci) = newVariable "dt" VI_Empty ci
dynamicType_fv = varToFreeVar dynamicType_var 1
= ( { opened_dynamic_expr = TupleSelect twotuple 0 dynamic_expr, opened_dynamic_type = Var dynamicType_var },
{ bind_src = TupleSelect twotuple 1 dynamic_expr, bind_dst = dynamicType_fv },
// MW0 { bind_src = TupleSelect twotuple 1 dynamic_expr, bind_dst = dynamicType_fv },
{ lb_src = TupleSelect twotuple 1 dynamic_expr, lb_dst = dynamicType_fv, lb_position = NoPos },
{ ci & ci_new_variables = [ dynamicType_fv : ci.ci_new_variables ]})
/**************************************************************************************************/
......@@ -395,7 +406,8 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards =
#
bound_vars = addToBoundVars (freeVarToVar dt_bind.bind_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type
// MW0 bound_vars = addToBoundVars (freeVarToVar dt_bind.bind_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type
bound_vars = addToBoundVars (freeVarToVar dt_bind.lb_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type
(addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars)))
// c_1 ind_0
......@@ -407,14 +419,17 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards =
# (tc_binds,ci)
= foldSt remove_non_used_arg tc_binds ([],ci)
= (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, let_info_ptr = let_info_ptr}, ci)
// MW0 = (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, let_info_ptr = let_info_ptr}, ci)
= (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr,
let_info_ptr = let_info_ptr, let_expr_position = NoPos }, ci)
where
remove_non_used_arg :: (Bind Expression FreeVar) ([Bind Expression FreeVar],*ConversionInfo) -> ([Bind Expression FreeVar],*ConversionInfo)
remove_non_used_arg tc_bind=:{bind_dst={fv_info_ptr}} (l,ci=:{ci_var_heap})
// MW0 remove_non_used_arg :: (Bind Expression FreeVar) ([Bind Expression FreeVar],*ConversionInfo) -> ([Bind Expression FreeVar],*ConversionInfo)
remove_non_used_arg :: LetBind ([LetBind],*ConversionInfo) -> ([LetBind],*ConversionInfo)
remove_non_used_arg tc_bind=:{lb_dst={fv_info_ptr}} (l,ci=:{ci_var_heap})
# (VI_Indirection ref_count, ci_var_heap) = readPtr fv_info_ptr ci_var_heap
| ref_count > 0
#! tc_bind
= { tc_bind & bind_dst = { tc_bind.bind_dst & fv_count = ref_count} }
= { tc_bind & lb_dst = { tc_bind.lb_dst & fv_count = ref_count} }
= ([tc_bind:l],{ci & ci_var_heap = ci_var_heap})
= (l,{ci & ci_var_heap = ci_var_heap})
......@@ -440,15 +455,19 @@ where
= addToBoundVars placeholder_var empty_attributed_type bound_vars
= (bind,(bound_vars2,ci));
where
create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
// MW0 create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo)
create_variable var_name var_info_ptr ci
# (placeholder_symb, ci) = getSymbol PD_variablePlaceholder SK_Constructor 3 ci
cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}
cyclic_fv = varToFreeVar cyclic_var 1
= ({ bind_src = App { app_symb = placeholder_symb,
app_args = [Var cyclic_var, Var cyclic_var],
app_info_ptr = nilPtr },
bind_dst = varToFreeVar cyclic_var 1
// MW0 = ({ bind_src = App { app_symb = placeholder_symb,
= ({ lb_src = App { app_symb = placeholder_symb,
app_args = [Var cyclic_var, Var cyclic_var],
app_info_ptr = nilPtr },
// MW0 bind_dst = varToFreeVar cyclic_var 1
lb_dst = varToFreeVar cyclic_var 1,
lb_position = NoPos
},
{ ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]} /*ci*/)
......@@ -508,12 +527,17 @@ where
# let_expr
= Let {
let_strict_binds = []
, let_lazy_binds = (if (isNo this_default) [] [ {bind_src = opt opt_expr , bind_dst = c_inc_i_fv }]) ++ [
{ bind_src = App { app_symb = coerce_symb, app_args = [Var a_ij_var, Var a_ij_tc_var], app_info_ptr = nilPtr },
bind_dst = coerce_result_fv }
// MW0 , let_lazy_binds = (if (isNo this_default) [] [ {bind_src = opt opt_expr , bind_dst = c_inc_i_fv }]) ++ [
// MW0 { bind_src = App { app_symb = coerce_symb, app_args = [Var a_ij_var, Var a_ij_tc_var], app_info_ptr = nilPtr },
// MW0 bind_dst = coerce_result_fv }
, let_lazy_binds = (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [
{ lb_src = App { app_symb = coerce_symb, app_args = [Var a_ij_var, Var a_ij_tc_var], app_info_ptr = nilPtr },
lb_dst = coerce_result_fv, lb_position = NoPos }
,
{ bind_src = TupleSelect twotuple 0 (Var coerce_result_var),
bind_dst = coerce_bool_fv } : let_binds
// MW0 { bind_src = TupleSelect twotuple 0 (Var coerce_result_var),
// MW0 bind_dst = coerce_bool_fv } : let_binds
{ lb_src = TupleSelect twotuple 0 (Var coerce_result_var),
lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds
],
let_expr =
Case { case_expr = Var coerce_bool_var,
......@@ -524,6 +548,7 @@ where
case_info_ptr = case_info_ptr,
case_default_pos= NoPos } // MW4++
, let_info_ptr = let_info_ptr
, let_expr_position = NoPos // MW0++
}
// dp_rhs
......@@ -532,7 +557,8 @@ where
opt (Yes x) = x
convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo
-> (Env Expression FreeVar, Expression, *ConversionInfo)
/// MW0 -> (Env Expression FreeVar, Expression, *ConversionInfo)
-> ([LetBind], Expression, *ConversionInfo)
convert_dynamic_pattern cinp bound_vars this_default pattern_number opened_dynamic result_type last_default
[{ dp_var, dp_type_patterns_vars, dp_type_code, dp_rhs } : patterns] ci
# /*** The last case may not have a default ***/
......@@ -609,10 +635,14 @@ where
a_ij_binds = add_x_i_bind opened_dynamic.opened_dynamic_expr dp_var a_ij_binds
let_expr = Let { let_strict_binds = [],
let_lazy_binds = [{ bind_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr },
bind_dst = unify_result_fv },
{ bind_src = TupleSelect twotuple 0 (Var unify_result_var),
bind_dst = unify_bool_fv } : let_binds
// MW0 let_lazy_binds = [{ bind_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr },
// MW0 bind_dst = unify_result_fv },
// MW0 { bind_src = TupleSelect twotuple 0 (Var unify_result_var),
// MW0 bind_dst = unify_bool_fv } : let_binds
let_lazy_binds = [{ lb_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr },
lb_dst = unify_result_fv, lb_position = NoPos },
{ lb_src = TupleSelect twotuple 0 (Var unify_result_var),
lb_dst = unify_bool_fv, lb_position = NoPos } : let_binds
],
let_expr = Case { case_expr = Var unify_bool_var,
// MW was: case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}],
......@@ -621,13 +651,17 @@ where
case_ident = No,
case_info_ptr = case_info_ptr,
case_default_pos= NoPos }, // MW4++
let_info_ptr = let_info_ptr }
// MW0 let_info_ptr = let_info_ptr }
let_info_ptr = let_info_ptr,
let_expr_position = NoPos }
= (a_ij_binds ++ binds, let_expr, { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]})
where
add_x_i_bind bind_src bind_dst=:{fv_count} binds
// MW0 add_x_i_bind bind_src bind_dst=:{fv_count} binds
add_x_i_bind lb_src lb_dst=:{fv_count} binds
| fv_count > 0
= [ { bind_src = bind_src, bind_dst = bind_dst } : binds ]
// MW0 = [ { bind_src = bind_src, bind_dst = bind_dst } : binds ]
= [ { lb_src = lb_src, lb_dst = lb_dst, lb_position = NoPos } : binds ]
= binds
isLastDynamicPattern dp_rhs=:(Case keesje=:{case_guards=DynamicPatterns _})
......@@ -643,7 +677,8 @@ where
// other alternatives
convert_other_patterns :: ConversionInput BoundVariables DefaultExpression Int OpenedDynamic AType !(Optional Expression) ![DynamicPattern] !*ConversionInfo
-> (Env Expression FreeVar, *ConversionInfo)
// MW0 -> (Env Expression FreeVar, *ConversionInfo)
-> ([LetBind], *ConversionInfo)
convert_other_patterns _ _ _ _ _ _ No [] ci
// no default and no alternatives left
= ([], ci)
......@@ -669,7 +704,8 @@ bind_indirection_var var=:{var_info_ptr} unify_result_var twotuple ci=:{ci_var_h
# (VI_Indirection ref_count, ci_var_heap) = readPtr var_info_ptr ci_var_heap
| ref_count > 0
# ind_fv = varToFreeVar var ref_count
= ([{ bind_src = TupleSelect twotuple 1 (Var unify_result_var), bind_dst = ind_fv }],
// MW0 = ([{ bind_src = TupleSelect twotuple 1 (Var unify_result_var), bind_dst = ind_fv }],
= ([{ lb_src = TupleSelect twotuple 1 (Var unify_result_var), lb_dst = ind_fv, lb_position = NoPos }],
{ ci & ci_var_heap = ci_var_heap, ci_new_variables = [ ind_fv : ci_new_variables ]})
= ([], {ci & ci_var_heap = ci_var_heap})
......@@ -679,12 +715,14 @@ bind_indirection_var var=:{var_info_ptr} unify_result_var twotuple ci=:{ci_var_h
it is converted into a function. The references are replaced by an appropriate function application.
*/
generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(Bind Expression FreeVar, *ConversionInfo)
// MW0 generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(Bind Expression FreeVar, *ConversionInfo)
generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(LetBind, *ConversionInfo)
generateBinding cinp bound_vars var bind_expr result_type ci
# (ref_count, ci) = get_reference_count var ci
| ref_count == 0
# free_var = varToFreeVar var 1
= ({ bind_src = bind_expr, bind_dst = free_var }, { ci & ci_new_variables = [ free_var : ci.ci_new_variables ]})
// MW0 = ({ bind_src = bind_expr, bind_dst = free_var }, { ci & ci_new_variables = [ free_var : ci.ci_new_variables ]})
= ({ lb_src = bind_expr, lb_dst = free_var, lb_position = NoPos }, { ci & ci_new_variables = [ free_var : ci.ci_new_variables ]})
# (saved_defaults, ci_var_heap) = foldSt save_default bound_vars ([], ci.ci_var_heap)
(act_args, free_typed_vars, local_free_vars, tb_rhs, ci_var_heap) = copyExpression bound_vars bind_expr ci_var_heap
#
......@@ -696,10 +734,13 @@ generateBinding cinp bound_vars var bind_expr result_type ci
= newFunction No (TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}) local_free_vars arg_types result_type cinp.cinp_group_index
(ci.ci_next_fun_nr, ci.ci_new_functions, ci.ci_fun_heap)
free_var = varToFreeVar var (inc ref_count)
= ({ bind_src = App { app_symb = fun_symb,
app_args = act_args,
app_info_ptr = nilPtr },
bind_dst = free_var },
// MW0 = ({ bind_src = App { app_symb = fun_symb,
= ({ lb_src = App { app_symb = fun_symb,
app_args = act_args,
app_info_ptr = nilPtr },
// MW0 bind_dst = free_var },
lb_dst = free_var,
lb_position = NoPos },
{ ci & ci_var_heap = ci_var_heap, ci_next_fun_nr = ci_next_fun_nr, ci_new_functions = ci_new_functions, ci_fun_heap = ci_fun_heap,
ci_new_variables = [ free_var : ci_new_variables ] })
where
......@@ -732,19 +773,24 @@ generateBinding cinp bound_vars var bind_expr result_type ci
/**************************************************************************************************/
createVariables :: [VarInfoPtr] !(Env Expression FreeVar) !*ConversionInfo -> (!Env Expression FreeVar, !*ConversionInfo)
// MW0 createVariables :: [VarInfoPtr] !(Env Expression FreeVar) !*ConversionInfo -> (!Env Expression FreeVar, !*ConversionInfo)
createVariables :: [VarInfoPtr] ![LetBind] !*ConversionInfo -> (![LetBind], !*ConversionInfo)
createVariables var_info_ptrs binds ci
= mapAppendSt (create_variable a_ij_var_name) var_info_ptrs binds ci
create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
// MW0create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo)
create_variable var_name var_info_ptr ci
# (placeholder_symb, ci) = getSymbol PD_variablePlaceholder SK_Constructor 3 ci
cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}
cyclic_fv = varToFreeVar cyclic_var 1
= ({ bind_src = App { app_symb = placeholder_symb,
// MW0 = ({ bind_src = App { app_symb = placeholder_symb,
= ({ lb_src = App { app_symb = placeholder_symb,
app_args = [Var cyclic_var, Var cyclic_var],
app_info_ptr = nilPtr },
bind_dst = varToFreeVar cyclic_var 1
// MW0 bind_dst = varToFreeVar cyclic_var 1
lb_dst = varToFreeVar cyclic_var 1,
lb_position = NoPos
},
{ ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]})
......
frontend/convertcases.icl
View file @ db332604
......@@ -28,6 +28,12 @@ where
convertCases bound_vars group_index common_defs t ci
= app2St (convertCases bound_vars group_index common_defs, convertCases bound_vars group_index common_defs) t ci
instance convertCases LetBind
where
convertCases bound_vars group_index common_defs bind=:{lb_src} ci
# (lb_src, ci) = convertCases bound_vars group_index common_defs lb_src ci
= ({ bind & lb_src = lb_src }, ci)
instance convertCases (Bind a b) | convertCases a
where
convertCases bound_vars group_index common_defs bind=:{bind_src} ci
......@@ -55,8 +61,10 @@ where
_
-> abort "convertCases [Let] (convertcases 53)" // <<- let_info
addLetVars [{bind_dst} : binds] [bind_type : bind_types] bound_vars
= addLetVars binds bind_types [ (bind_dst, bind_type) : bound_vars ]
// MW0 addLetVars [{bind_dst} : binds] [bind_type : bind_types] bound_vars
// MW0 = addLetVars binds bind_types [ (bind_dst, bind_type) : bound_vars ]
addLetVars [{lb_dst} : binds] [bind_type : bind_types] bound_vars
= addLetVars binds bind_types [ (lb_dst, bind_type) : bound_vars ]
addLetVars [] _ bound_vars
= bound_vars
......@@ -805,8 +813,10 @@ where
# (let_expr, cp_info) = copy let_expr cp_info
= (Let {lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, cp_info)
where
bind_let_var {bind_dst} (local_vars, var_heap)
= ([bind_dst : local_vars], var_heap <:= (bind_dst.fv_info_ptr, VI_LocalVar))
// MW0 bind_let_var {bind_dst} (local_vars, var_heap)
// MW0 = ([bind_dst : local_vars], var_heap <:= (bind_dst.fv_info_ptr, VI_LocalVar))
bind_let_var {lb_dst} (local_vars, var_heap)
= ([lb_dst : local_vars], var_heap <:= (lb_dst.fv_info_ptr, VI_LocalVar))
copy (Case case_expr) cp_info
# (case_expr, cp_info) = copy case_expr cp_info
= (Case case_expr, cp_info)
......@@ -947,6 +957,12 @@ instance copy (a,b) | copy a & copy b
where
copy t cp_info = app2St (copy, copy) t cp_info
instance copy LetBind
where
copy bind=:{lb_src} cp_info
# (lb_src, cp_info) = copy lb_src cp_info
= ({ bind & lb_src = lb_src }, cp_info)
instance copy (Bind a b) | copy a
where
copy bind=:{bind_src} cp_info
......@@ -1027,7 +1043,8 @@ where
where
remove_variable ([], var_heap) let_bind
= ([], var_heap)
remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{bind_dst={fv_name,fv_info_ptr}}
// MW0 remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{bind_dst={fv_name,fv_info_ptr}}
remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{lb_dst={fv_name,fv_info_ptr}}
| fv_info_ptr == var_ptr
# (VI_LetVar {lvi_count,lvi_depth}, var_heap) = readPtr fv_info_ptr var_heap
= (var_ptrs, var_heap)
......@@ -1035,11 +1052,14 @@ where
# (var_ptrs, var_heap) = remove_variable (var_ptrs, var_heap) bind
= ([var_ptr : var_ptrs], var_heap)
store_binding {bind_dst={fv_name,fv_info_ptr},bind_src} var_heap
// MW0 store_binding {bind_dst={fv_name,fv_info_ptr},bind_src} var_heap
store_binding {lb_dst={fv_name,fv_info_ptr},lb_src} var_heap
= var_heap <:= (fv_info_ptr, VI_LetVar {lvi_count = 0, lvi_depth = depth, lvi_previous = [],
lvi_new = True, lvi_expression = bind_src, lvi_var = fv_name})
// MW0 lvi_new = True, lvi_expression = bind_src, lvi_var = fv_name})
lvi_new = True, lvi_expression = lb_src, lvi_var = fv_name})
get_ref_count {bind_dst={fv_name,fv_info_ptr}} var_heap
// MW0 get_ref_count {bind_dst={fv_name,fv_info_ptr}} var_heap
get_ref_count {lb_dst={fv_name,fv_info_ptr}} var_heap
# (VI_LetVar {lvi_count}, var_heap) = readPtr fv_info_ptr var_heap
= (lvi_count, var_heap)
// ==> (fv_name,fv_info_ptr,lvi_count)
......@@ -1227,6 +1247,11 @@ instance weightedRefCount (a,b) | weightedRefCount a & weightedRefCount b
where
weightedRefCount dcl_functions common_defs depth (x,y) rc_info = weightedRefCount dcl_functions common_defs depth y (weightedRefCount dcl_functions common_defs depth x rc_info)
instance weightedRefCount LetBind
where
weightedRefCount dcl_functions common_defs depth {lb_src} rc_info
= weightedRefCount dcl_functions common_defs depth lb_src rc_info
instance weightedRefCount (Bind a b) | weightedRefCount a
where
weightedRefCount dcl_functions common_defs depth bind=:{bind_src} rc_info
......@@ -1324,15 +1349,23 @@ where
_ -> (Let { lad & let_strict_binds = let_strict_binds, let_expr = let_expr, let_lazy_binds = []},
{dl_info & di_expr_heap = dl_info.di_expr_heap <:= (let_info_ptr, EI_LetType (take nr_of_strict_lets let_type))})
where
/* MW0
set_let_expression_info depth [(let_strict, {bind_src,bind_dst}):binds][ref_count:ref_counts][type:types] var_heap
# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
lei = { lei_count = ref_count, lei_depth = depth, lei_var = { bind_dst & fv_info_ptr = new_info_ptr },
lei_expression = bind_src, lei_type = type, lei_status = LES_Untouched }
= set_let_expression_info depth binds ref_counts types (var_heap <:= (bind_dst.fv_info_ptr, VI_LetExpression lei))
*/
set_let_expression_info depth [(let_strict, {lb_src,lb_dst}):binds][ref_count:ref_counts][type:types] var_heap
# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
lei = { lei_count = ref_count, lei_depth = depth, lei_var = { lb_dst & fv_info_ptr = new_info_ptr },
lei_expression = lb_src, lei_type = type, lei_status = LES_Untouched }
= set_let_expression_info depth binds ref_counts types (var_heap <:= (lb_dst.fv_info_ptr, VI_LetExpression lei))
set_let_expression_info depth [] _ _ var_heap
= var_heap
distribute_lets_in_non_distributed_let depth {bind_dst={fv_name,fv_info_ptr}} dl_info=:{di_var_heap}
// MW0 distribute_lets_in_non_distributed_let depth {bind_dst={fv_name,fv_info_ptr}} dl_info=:{di_var_heap}
distribute_lets_in_non_distributed_let depth {lb_dst={fv_name,fv_info_ptr}} dl_info=:{di_var_heap}
# (VI_LetExpression lei=:{lei_depth,lei_count,lei_status}, di_var_heap) = readPtr fv_info_ptr di_var_heap
| lei_count > 0
// | not lei_moved && lei_count > 0
......@@ -1475,10 +1508,14 @@ buildLetExpr let_vars let_expr (var_heap, expr_heap)
-> (Let { inner_let & let_lazy_binds = lazy_binds }, (var_heap, expr_heap))
_
# (let_info_ptr, expr_heap) = newPtr (EI_LetType lazy_binds_types) expr_heap
-> (Let { let_strict_binds = [], let_lazy_binds = lazy_binds, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap))
// MW0 -> (Let { let_strict_binds = [], let_lazy_binds = lazy_binds, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap))
-> (Let { let_strict_binds = [], let_lazy_binds = lazy_binds, let_expr = let_expr,
let_info_ptr = let_info_ptr, let_expr_position = NoPos }, (var_heap, expr_heap))
where
build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !*VarHeap)
-> (!Env Expression FreeVar, ![AType], !*VarHeap)
// MW0 build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !*VarHeap)
// MW0 -> (!Env Expression FreeVar, ![AType], !*VarHeap)
build_bind :: !VarInfoPtr !(![LetBind], ![AType], !*VarHeap)
-> (![LetBind], ![AType], !*VarHeap)
build_bind info_ptr (lazy_binds, lazy_binds_types, var_heap)
# (let_info, var_heap) = readPtr info_ptr var_heap
# (VI_LetExpression lei=:{lei_var,lei_expression,lei_status,lei_type}) = let_info
......@@ -1486,7 +1523,8 @@ where
(new_info_ptr, var_heap) = newPtr VI_Empty var_heap
var_heap = var_heap <:= (info_ptr, VI_LetExpression { lei & lei_status = LES_Untouched, lei_var = { lei_var & fv_info_ptr = new_info_ptr }})
// ==> (lei_var.fv_name, info_ptr, new_info_ptr)