Commit e7639818 authored by John van Groningen's avatar John van Groningen
Browse files

create new fv_info_ptr's for strict lets in distributeLets, because otherwise

backendpreprocess may number variables incorrectly, causing a crash
in backend.dll,
renamed VI_CaseVar to VI_CaseOrStrictLetVar
parent 5b1b574f
......@@ -38,7 +38,7 @@ convertCasesOfFunctions groups main_dcl_module_n dcl_functions common_defs fun_d
= addNewFunctionsToGroups common_defs cs_fun_heap cs_new_functions main_dcl_module_n groups imported_types imported_conses type_heaps cs_var_heap
(imported_functions, imported_conses) = foldSt split collected_imports ([], imported_conses)
= (imported_functions, groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs },
imported_types, imported_conses, cs_var_heap, type_heaps, /* abort "that's enough" */ cs_expr_heap)
imported_types, imported_conses, cs_var_heap, type_heaps, cs_expr_heap)
where
convert_groups group_nr groups dcl_functions common_defs main_dcl_module_n fun_defs_and_ci
| group_nr == size groups
......@@ -91,14 +91,11 @@ instance checkCaseTypes Expression where
instance checkCaseTypes Case where
checkCaseTypes kees=:{case_expr, case_guards, case_default, case_explicit, case_info_ptr} expr_heap
# (info, expr_heap)
= readPtr case_info_ptr expr_heap
# {ct_cons_types}
= case_type info
# (info, expr_heap) = readPtr case_info_ptr expr_heap
# {ct_cons_types} = case_type info
# (guards_ok, expr_heap) = checkCaseTypesCasePatterns case_guards ct_cons_types expr_heap
# (default_ok, expr_heap)= checkCaseTypes case_default expr_heap
= (guards_ok && default_ok, expr_heap)
where
case_type (EI_CaseTypeAndSplits type _)
= type
......@@ -340,7 +337,7 @@ where
weightedRefCount rci (FailExpr _) rs
= rs
weightedRefCount rci expr rs
= abort ("weightedRefCount [Expression] (convertcases, 864))" -*-> expr)
= abort ("weightedRefCount [Expression] (convertcases))" -*-> expr)
addPatternVariable depth {cv_variable = var_info_ptr, cv_count = ref_count} (free_vars, var_heap)
# (var_info, var_heap) = readPtr var_info_ptr var_heap
......@@ -425,7 +422,6 @@ weightedRefCountInPatternExpr rci=:{rci_depth} pattern_expr (previous_free_vars,
(all_free_vars, rcs_var_heap) = foldSt (collect_free_variable rci_depth) rcs_free_vars (previous_free_vars, rcs_var_heap)
// -*-> ("remove_vars ", depth, free_vars_with_rc)
= (free_vars_with_rc, (all_free_vars, rcs_imports, rcs_var_heap, rcs_expr_heap))
where
select_unused_free_variable depth var=:{cv_variable = var_ptr, cv_count = var_count} (collected_vars, var_heap)
# (VI_LetVar info=:{lvi_count,lvi_depth}, var_heap) = readPtr var_ptr var_heap
......@@ -563,7 +559,7 @@ where
-> (Var { var & var_info_ptr = lei.lei_var.fv_info_ptr }, ds)
// otherwise
-> (Var { var & var_info_ptr = lei.lei_var.fv_info_ptr }, ds)
VI_CaseVar var_info_ptr
VI_CaseOrStrictLetVar var_info_ptr
-> (Var { var & var_info_ptr = var_info_ptr }, ds)
_
-> (Var var, ds)
......@@ -603,7 +599,7 @@ where
# (EI_LetTypeAndRefCounts let_type ref_counts) = let_info
nr_of_strict_lets = length let_strict_binds
ds_var_heap = set_let_expr_info di_depth let_lazy_binds ref_counts (drop nr_of_strict_lets let_type) ds_var_heap
ds_var_heap = foldSt set_strict_let_expr_info let_strict_binds ds_var_heap
(let_strict_binds,ds_var_heap) = mapSt set_strict_let_expr_info let_strict_binds ds_var_heap
(let_expr, ds) = distributeLets di let_expr { ds & ds_var_heap = ds_var_heap, ds_expr_heap = ds_expr_heap }
(let_strict_binds, ds) = distributeLets di let_strict_binds ds
ds = foldSt (distribute_lets_in_non_distributed_let di) let_lazy_binds ds
......@@ -633,8 +629,9 @@ where
set_let_expr_info _ [] _ _ var_heap
= var_heap
set_strict_let_expr_info {lb_dst} var_heap
= var_heap <:= (lb_dst.fv_info_ptr, VI_LocalLetVar)
set_strict_let_expr_info lb=:{lb_dst={fv_info_ptr}} var_heap
# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
= ({lb & lb_dst.fv_info_ptr = new_info_ptr}, var_heap <:= (fv_info_ptr, VI_CaseOrStrictLetVar new_info_ptr))
distribute_lets_in_non_distributed_let di {lb_dst={fv_ident,fv_info_ptr}} ds=:{ds_var_heap}
# (VI_LetExpression lei=:{lei_count}, ds_var_heap) = readPtr fv_info_ptr ds_var_heap
......@@ -654,7 +651,7 @@ where
determine_input_parameter bind=:{bind_dst} var_heap
# (var_info, var_heap) = readPtr bind_dst.var_info_ptr var_heap
= case var_info of
VI_CaseVar new_info_ptr
VI_CaseOrStrictLetVar new_info_ptr
-> ({ bind & bind_dst = { bind_dst & var_info_ptr = new_info_ptr }}, var_heap)
_
-> (bind, var_heap)
......@@ -760,14 +757,13 @@ where
= (No, ds)
refresh_variable fv=:{fv_info_ptr} var_heap
# (new_info_ptr, var_heap) = newPtr (VI_Labelled_Empty "refresh_variable") var_heap
= ({ fv & fv_info_ptr = new_info_ptr }, var_heap <:= (fv_info_ptr, VI_CaseVar new_info_ptr))
# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
= ({ fv & fv_info_ptr = new_info_ptr }, var_heap <:= (fv_info_ptr, VI_CaseOrStrictLetVar new_info_ptr))
mark_local_let_var depth {cv_variable, cv_count} (local_vars, var_heap)
# (VI_LetExpression lei=:{lei_count,lei_depth,lei_var}, var_heap) = readPtr cv_variable var_heap
| lei_count == cv_count && lei_depth==depth-1 // -*-> ("mark_test", lei_count, cv_count)
= ([(cv_variable, lei_count, lei_depth) : local_vars ], var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth}))
// -*-> ("mark_local_let_var ", lei.lei_var.fv_ident, cv_variable, (lei.lei_var.fv_info_ptr, cv_count, depth))
->> ("mark_local_let_var ", lei_var.fv_ident.id_name, lei_depth, " ->> ", depth)
// otherwise
= (local_vars, var_heap)
......@@ -1627,10 +1623,8 @@ convertRootCasesAlgebraicPatterns ci l cs
where
convertRootCasesAlgebraicPattern :: ConvertInfo (AlgebraicPattern, [AType]) *ConvertState -> (AlgebraicPattern, *ConvertState)
convertRootCasesAlgebraicPattern ci (pattern=:{ap_expr, ap_vars}, arg_types) cs
# ci
= {ci & ci_bound_vars= exactZip ap_vars arg_types ++ ci.ci_bound_vars}
# (ap_expr, cs)
= convertRootCases ci ap_expr cs
# ci = {ci & ci_bound_vars= exactZip ap_vars arg_types ++ ci.ci_bound_vars}
# (ap_expr, cs) = convertRootCases ci ap_expr cs
= ({pattern & ap_expr=ap_expr}, cs)
instance convertRootCases (Optional a) | convertRootCases a where
......@@ -1685,20 +1679,6 @@ where
# (let_strict_binds,let_lazy_binds,ci,cs) = convert_let_binds let_strict_binds let_lazy_binds let_info_ptr ci cs
# (let_expr, cs) = convertCases ci let_expr cs
= ({ lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, cs)
/*
convertCases ci=:{ci_bound_vars} lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr} cs=:{cs_expr_heap}
# (let_info, cs_expr_heap) = readPtr let_info_ptr cs_expr_heap
cs = { cs & cs_expr_heap = cs_expr_heap }
= case let_info of
EI_LetType let_type
# ci_bound_vars = addLetVars (let_strict_binds ++ let_lazy_binds) let_type ci_bound_vars
# (let_strict_binds, cs) = convertCases {ci & ci_bound_vars=ci_bound_vars} let_strict_binds cs
# (let_lazy_binds, cs) = convertCases ci let_lazy_binds cs
# (let_expr, cs) = convertCases ci let_expr cs
-> ({ lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, cs)
_
-> abort "convertCases [Let] (convertcases 53)" // <<- let_info
*/
instance convertCases Expression
where
......@@ -1891,7 +1871,6 @@ where
new_case_function opt_id result_type rhs free_vars local_vars
bound_vars group_index common_defs cs=:{cs_expr_heap}
# body
= TransformedBody {tb_args=[var \\ (var, _) <- free_vars], tb_rhs=rhs}
(_,type)
......@@ -1907,7 +1886,6 @@ new_case_function opt_id result_type rhs free_vars local_vars
}
// (body, cs)
// = convertCasesInBody body (Yes type) group_index common_defs cs
# (fun_ident, (cs_next_fun_nr, cs_new_functions, cs_fun_heap))
= newFunctionWithType opt_id body local_vars type group_index
(cs.cs_next_fun_nr, cs.cs_new_functions, cs.cs_fun_heap)
......@@ -1921,23 +1899,6 @@ splitGuards (BasicPatterns basicType patterns)
splitGuards (OverloadedListPatterns type decons_expr patterns)
= [OverloadedListPatterns type decons_expr [pattern] \\ pattern <- patterns]
:: TypedVariable =
{ tv_free_var :: !FreeVar
, tv_type :: !AType
}
copyExpression :: ![TypedVariable] !Expression !*VarHeap -> (![Expression], ![TypedVariable], ![FreeVar], !Expression, !*VarHeap)
copyExpression bound_vars expr var_heap
# var_heap = foldSt (\{tv_free_var={fv_info_ptr},tv_type} -> writePtr fv_info_ptr (VI_BoundVar tv_type)) bound_vars var_heap
(expr, {cp_free_vars, cp_var_heap, cp_local_vars}) = copy expr { cp_free_vars = [], cp_var_heap = var_heap, cp_local_vars = [] }
(bound_vars, free_typed_vars, var_heap) = foldSt retrieve_variable cp_free_vars ([], [], cp_var_heap)
= (bound_vars, free_typed_vars, cp_local_vars, expr, var_heap)
where
retrieve_variable (var_info_ptr, type) (bound_vars, free_typed_vars, var_heap)
# (VI_FreeVar name new_ptr count type, var_heap) = readPtr var_info_ptr var_heap
= ( [Var { var_ident = name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} : bound_vars],
[{tv_free_var = { fv_def_level = NotALevel, fv_ident = name, fv_info_ptr = new_ptr, fv_count = count }, tv_type = type} : free_typed_vars], var_heap)
:: CopyState =
{ cp_free_vars :: ![(VarInfoPtr,AType)]
, cp_local_vars :: ![FreeVar]
......@@ -1966,9 +1927,7 @@ where
cp_var_heap = cp_var_heap <:= (var_info_ptr, VI_FreeVar var_ident new_info_ptr 1 type) })
-*-> ("copy: VI_BoundVar", var_ident.id_name, ptrToInt new_info_ptr)
_
// | True <<- ("copy BoundVar", var_ident.id_name, ptrToInt var_info_ptr, var_info)
// -> (var,cp_info)
-> abort "copy [BoundVar] (convertcases, 612)" // <<- ("copy BoundVar", var_ident.id_name, ptrToInt var_info_ptr, var_info)
-> abort "copy [BoundVar] (convertcases)"
instance copy Expression
where
......
......@@ -690,7 +690,8 @@ from convertDynamics import :: TypeCodeVariableInfo, :: DynamicValueAliasInfo
VI_FreeVar !Ident !VarInfoPtr !Int !AType | VI_BoundVar !AType | VI_LocalVar |
VI_ClassVar !Ident !VarInfoPtr !Int | /* to hold dictionary variables during overloading */
VI_ForwardClassVar !VarInfoPtr | /* to hold the dictionary variable generated during overloading */
VI_Forward !BoundVar | VI_LetVar !LetVarInfo | VI_LetExpression !LetExpressionInfo | VI_CaseVar !VarInfoPtr |
VI_Forward !BoundVar | VI_LetVar !LetVarInfo | VI_LetExpression !LetExpressionInfo |
VI_CaseOrStrictLetVar !VarInfoPtr |
VI_CorrespondenceNumber !Int | /* it is assumed that this alternative is _only_ used in module comparedefimp */
VI_SequenceNumber !Int | VI_AliasSequenceNumber !BoundVar |
VI_Used | /* for indicating that an imported function has been used */
......@@ -706,7 +707,7 @@ from convertDynamics import :: TypeCodeVariableInfo, :: DynamicValueAliasInfo
// MdM
VI_CPSExprVar !CheatCompiler /* a pointer to a variable in CleanProverSystem is stored here, using a cast */
// ... MdM
| VI_Labelled_Empty {#Char} // RWS debugging
| VI_Labelled_Empty !{#Char} // RWS debugging
| VI_LocalLetVar // RWS, mark Let vars during case transformation
:: ExtendedVarInfo = EVI_VarType !AType
......@@ -851,7 +852,6 @@ cNonRecursiveAppl :== False
:: ExtendedExprInfo
= EEI_ActiveCase !ActiveCaseInfo
:: ActiveCaseInfo =
{ aci_params :: ![FreeVar]
, aci_opt_unfolder :: !(Optional SymbIdent)
......@@ -860,15 +860,6 @@ cNonRecursiveAppl :== False
, aci_safe :: !Bool
}
/*
:: UnboundVariable =
{ free_name :: !Ident
, free_info_ptr :: !VarInfoPtr
, free_selections :: ![Int]
}
*/
/*
OverloadedCall contains (type) information about functions that are overloaded. This structure is built during type checking
and used after (standard) unification to insert the proper instances of the corresponding functions.
......
Supports Markdown
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