From b8b6f1a62f670982ebd3b6d3df3c8a0fd9d77425 Mon Sep 17 00:00:00 2001
From: ronny
Date: Thu, 22 Aug 2002 12:18:39 +0000
Subject: transform implicit cases on rhs variables, see comment before
splitCases in convertcases
git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@1188 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d
---
frontend/convertcases.icl | 652 ++++++++++++++++++++++++++++++++++++++++++----
1 file changed, 596 insertions(+), 56 deletions(-)
(limited to 'frontend/convertcases.icl')
diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl
index ba07654..25e2f49 100644
--- a/frontend/convertcases.icl
+++ b/frontend/convertcases.icl
@@ -3,7 +3,7 @@
*/
implementation module convertcases
-import syntax, transform, checksupport, StdCompare, check, utilities, trans, general //, RWSDebug
+import syntax, transform, checksupport, StdCompare, check, utilities, trans, general; // , RWSDebug
// exactZip fails when its arguments are of unequal length
exactZip` :: ![.a] ![.b] -> [(.a,.b)]
@@ -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, cs_expr_heap)
+ imported_types, imported_conses, cs_var_heap, type_heaps, /* abort "that's enough" */ 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
@@ -64,7 +64,12 @@ where
ds = { ds_lets = [], ds_var_heap = rcs_var_heap, ds_expr_heap = rcs_expr_heap}
(tb_rhs, ds) = distributeLets 1 tb_rhs ds -*-> "dis"
(tb_rhs, {ds_var_heap, ds_expr_heap}) = buildLetExpr tb_rhs ds -*-> "build"
- = (TransformedBody {body & tb_rhs = tb_rhs }, (rcs_imports, { cs & cs_var_heap = ds_var_heap, cs_expr_heap = ds_expr_heap}))
+
+ (_, {ss_expr_heap, ss_var_heap})
+ = findSplitCases {si_moved = False, si_next_alt=No} tb_rhs
+ {ss_var_heap=ds_var_heap, ss_expr_heap = ds_expr_heap}
+
+ = (TransformedBody {body & tb_rhs = tb_rhs }, (rcs_imports, { cs & cs_var_heap = ss_var_heap, cs_expr_heap = ss_expr_heap}))
-*-> ("eliminate_code_sharing_in_function (distributeLets)", 2, tb_rhs)
split :: SymbKind (ImportedFunctions, ImportedConstructors) -> (ImportedFunctions, ImportedConstructors)
@@ -540,7 +545,7 @@ where
new_depth = depth + 1
(local_lets, ds_var_heap) = mark_local_let_vars new_depth tot_ref_counts ds_var_heap
- -*-> ("ref_counts", case_expr, tot_ref_counts, ref_counts_in_patterns)
+ // -*-> ("ref_counts", case_expr, tot_ref_counts, ref_counts_in_patterns)
with
mark_local_let_vars new_depth tot_ref_counts var_heap
@@ -740,6 +745,320 @@ where
# (bind_src, cp_info) = distributeLets depth bind_src cp_info
= ({ bind & bind_src = bind_src }, cp_info)
+/*
+ Split case expressions.
+
+ Splitting a case expression can be necessary because of limitations in
+ the compiler's backend. The backend can only handle case expressions that
+ match on left-hand-side variable and are on root positions (right-hand-side
+ of functions, the resulting expression of let expressions on a root
+ position and the right-hand side or default of case expressions an on a
+ root position). The exact test can be found in convertRootCases.
+
+ There's a difference in the semantics of implicit cases (which are written
+ as patterns by the programmer) and explicit cases (written as case expres-
+ sions by the programmer).
+
+ Implicit cases (denoted as case'):
+
+ fi x y
+ = case' x of / fi 1 2 \
+ 1 -> case' y of | syntax tree for = 3 |
+ 2 -> 3 | fi _ _ |
+ _ -> 4 \ = 4 /
+
+ (fi 1 2) reduces to 2
+
+ Explicit cases:
+
+ fe x y
+ = case x of
+ 1 -> case y of
+ 2 -> 3
+ _ -> 4
+
+ (fe 1 2) reduces to <<run-time error>>
+
+ The frontend introduces functions for cases expressions that are explicit
+ or that the backend can't handle. For the example above:
+
+ fe x y
+ = _c1 x y
+ _c1 x y
+ = case' x of
+ 1 -> _c2
+ _ -> 4
+ _c2 y
+ = case' y of
+ 2 -> 3
+
+ This agrees with the semantics: the function _c2 will fail during
+ evaluation of (fe 1 2).
+
+ Problems occur when there's an implicit case expression that can't be
+ handled by the backend. These case expressions result from transformations
+ in the compiler (fusion in transform.icl and the conversion of dynamics).
+ For example, in the function
+
+ f
+ = case' 1 of
+ 1 -> case' 2 of
+ 3 -> 4
+ _ -> 5
+
+ f should reduce to 5, but in the direct translation
+
+ f
+ = _c1 1
+ _c1 x
+ = case' x of
+ 1 -> _c2 2
+ _ -> 5
+ _c2 y
+ = case' y of
+ 3 -> 4
+
+ f erroneously reduces to <<run-time error>>.
+
+ The solution is to split the case in _c1, introduce a function for the
+ second part (the default alternative of _c1), and call this function from
+ both _c1 and _c2
+
+ f
+ = _c1 1
+ _c1 x
+ = case' x of
+ 1 -> _c2 2
+ _ -> _f
+ _c2 y
+ = case' y of
+ 3 -> 4
+ _ -> _f
+ _f
+ = 5
+
+ This transformation is done in two phases. First findSplitCases determines
+ where cases should be split, and to which alternative of an outer case
+ a case should pass control if it doesn't have a default. This information
+ is recorded in the expression heap (accessed through the case_info_ptr).
+
+ The actual splitting, the introduction of new functions, and the
+ introduction of calls to these functions is done in convertRootCases.
+*/
+
+:: SplitState =
+ { ss_expr_heap :: !.ExpressionHeap
+ , ss_var_heap :: !.VarHeap
+ }
+
+:: SplitInfo =
+ { si_next_alt :: !Optional NextAlt
+ , si_moved :: !Bool
+ }
+
+class findSplitCases e :: !SplitInfo !e !*SplitState -> (Bool, *SplitState)
+
+(:-) infixl
+(:-) a f
+ :== f a
+
+instance findSplitCases (Optional a) | findSplitCases a where
+ findSplitCases _ No ss
+ = (False, ss) <<- "findSplitCases (Opt No)"
+ findSplitCases si (Yes x) ss
+ = findSplitCases si x ss <<- "findSplitCases (Opt No)"
+
+instance findSplitCases Expression where
+ findSplitCases si (Let lad) ss
+ = findSplitCases si lad ss <<- "findSplitCases (Exp Let)"
+ findSplitCases si (Case kees) ss
+ = findSplitCases si kees ss <<- "findSplitCases (Exp Case)"
+ findSplitCases _ _ ss
+ = (False, ss) <<- "findSplitCases (Exp _)"
+
+instance findSplitCases Case where
+ findSplitCases si kees=:{case_info_ptr, case_guards, case_default} ss
+ # ss
+ = init_case_split_info case_info_ptr ss <<- "findSplitCases (Case)"
+ # (f2, ss)
+ = split_guards {si & si_next_alt = first_next_alt, si_moved = False} use_outer_alt case_guards (False, ss)
+ # (split, ss)
+ = nextAlts {si & si_moved = f2} kees ss
+ # (f3, ss)
+ = findSplitCases si case_default ss
+ = (split || f3, ss) ->> ("findSplitCases (Case)" +++ toString split +++ toString f2 +++ toString f3)
+ where
+ first_next_alt
+ = Yes {na_case = case_info_ptr, na_alt_nr = 1}
+ use_outer_alt
+ = use_outer_alt_for_last_alt case_default si
+
+ init_case_split_info case_info_ptr ss=:{ss_expr_heap}
+ # (case_info, ss_expr_heap)
+ = readPtr case_info_ptr ss_expr_heap
+ # type = case_type case_info
+ ss_expr_heap
+ = ss_expr_heap <:= (case_info_ptr,
+ EI_CaseTypeAndSplits type {sic_splits = [], sic_next_alt = No})
+ = {ss & ss_expr_heap = ss_expr_heap}
+// ->> (toString kees.case_ident, " = ", ptrToInt case_info_ptr)
+ where
+ case_type (EI_CaseTypeAndRefCounts type _)
+ = type
+ case_type (EI_CaseTypeAndSplits type _)
+ /*
+ The same case is encountered twice by findSplitCases. This can
+ happen because distributeLets doesn't copy expressions. So
+
+ Start
+ # x = case 1 of 1 -> 1
+ | True
+ = x
+ = x
+
+ is transformed to
+
+ Start
+ | True
+ = case 1 of 1 -> 1
+ = case 1 of 1 -> 1
+
+ but the two cases are shared in the syntax tree (and thus
+ have the same case_info_ptr). We just leave the case shared
+ under the assumption that in both instances it will be split
+ in exactly the same way.
+ */
+ = type
+ case_type info
+ = abort "case_type???" <<- info
+
+// split_guards :: SplitInfo (Optional (Optional NextAlt)) CasePatterns *SplitState -> (Bool, *SplitState)
+ split_guards si use_outer_alt (AlgebraicPatterns _ alts) ss
+ = split_alts si use_outer_alt alts ss
+ split_guards si use_outer_alt (BasicPatterns _ alts) ss
+ = split_alts si use_outer_alt alts ss
+ split_guards si use_outer_alt (OverloadedListPatterns _ _ alts) ss
+ = split_alts si use_outer_alt alts ss
+
+// split_alts :: SplitInfo (Optional (Optional NextAlt)) [a] *SplitState -> (Bool, *SplitState) | findSplitCases a
+ split_alts _ _ [] (s, ss)
+ = (s, ss)
+ split_alts _ (Yes si) [last] (f1, ss)
+ # (f2, ss)
+ = findSplitCases si last ss
+ = (f1 || f2, ss)
+ split_alts si last_next_alt [pattern : patterns] (f1, ss)
+ # (f2, ss)
+ = findSplitCases si pattern ss
+ = split_alts (incAltNr si) last_next_alt patterns (f1 || f2, ss)
+
+// use_outer_alt_for_last_alt :: (Optional Expression) ExprInfoPtr SplitInfo -> Optional (Optional NextAlt)
+ use_outer_alt_for_last_alt No si =: {si_next_alt, si_moved}
+ /*
+ This case has no default. If the last alternative fails,
+ control is passed to the outer case.
+ */
+ = Yes si // {si_next_alt, si_moved}
+ use_outer_alt_for_last_alt (Yes _) si
+ = No
+
+// debug ...
+instance toString (Optional a) | toString a where
+ toString No
+ = ""
+ toString (Yes x)
+ = toString x
+// ... debug
+
+class incAltNr a :: a -> a
+
+instance incAltNr Int where
+ incAltNr alt_nr
+ = alt_nr + 1
+
+instance incAltNr NextAlt where
+ incAltNr next_alt=:{na_alt_nr}
+ = {next_alt & na_alt_nr = incAltNr na_alt_nr}
+
+instance incAltNr (Optional a) | incAltNr a where
+ incAltNr No
+ = No
+ incAltNr (Yes x)
+ = Yes (incAltNr x)
+
+instance incAltNr SplitInfo where
+ incAltNr si=:{si_next_alt}
+ = {si & si_next_alt = incAltNr si_next_alt}
+
+instance findSplitCases AlgebraicPattern where
+ findSplitCases si {ap_expr} ss
+ = findSplitCases si ap_expr ss <<- "findSplitCases (AlgebraicPattern)"
+
+instance findSplitCases BasicPattern where
+ findSplitCases si {bp_expr} ss
+ = findSplitCases si bp_expr ss <<- "findSplitCases (BasicPattern)"
+
+instance findSplitCases Let where
+ findSplitCases si {let_expr} ss
+ = findSplitCases si let_expr ss <<- "findSplitCases (Let)"
+
+nextAlts :: SplitInfo Case *SplitState -> (Bool, *SplitState)
+nextAlts si=:{si_next_alt=Yes next_alt, si_moved} kees=:{case_info_ptr} ss
+ # (jumps, ss=:{ss_expr_heap})
+ = jumps_to_next_alt si_moved kees ss
+ | jumps
+ // update the info for this case
+ # (EI_CaseTypeAndSplits type splits, ss_expr_heap)
+ = readPtr case_info_ptr ss_expr_heap
+ ss_expr_heap
+ = ss_expr_heap <:= (case_info_ptr,
+ EI_CaseTypeAndSplits type {splits & sic_next_alt = Yes next_alt})
+
+ // update the info for the outer case
+ # (EI_CaseTypeAndSplits type splits, ss_expr_heap)
+ = readPtr next_alt.na_case ss_expr_heap
+ split
+ = {sc_alt_nr = next_alt.na_alt_nr, sc_call = No}
+ ss_expr_heap
+ = ss_expr_heap <:= (next_alt.na_case,
+ EI_CaseTypeAndSplits type {splits & sic_splits = [split : splits.sic_splits]})
+ ss_expr_heap
+ = ss_expr_heap
+ ->> (toString kees.case_ident, ptrToInt case_info_ptr,
+ "jumps to ", ptrToInt next_alt.na_case, next_alt.na_alt_nr)
+
+ = (True, {ss & ss_expr_heap = ss_expr_heap})
+ // otherwise
+ = (False, ss)
+ where
+/* stress test, convert all cases without a default
+ jumps_to_next_alt _ {case_default = No} ss
+ = (True, ss)
+*/
+/* stress test, convert all explicit cases (may change semantics for failing programs)
+ jumps_to_next_alt _ {case_default = No, case_explicit = True, case_expr}
+ = (True, ss) ->> (toString (ptrToInt case_info_ptr) +++ " jumps, because explicit")
+*/
+ jumps_to_next_alt True {case_default = No} ss
+ = (True, ss) ->> (toString (ptrToInt case_info_ptr) +++ " jumps, because alt was moved")
+ jumps_to_next_alt _ {case_default = No, case_explicit = False, case_expr} ss
+ | not (is_lhs_var case_expr ss.ss_var_heap)
+ = (True, ss) ->> (toString (ptrToInt case_info_ptr) +++ " jumps, because implicit no lhs var")
+ jumps_to_next_alt moved _ ss
+ = (False, ss) ->> (toString (ptrToInt case_info_ptr) +++ " doesn't jumps" +++ toString moved +++ toString kees.case_explicit)
+
+ is_lhs_var (Var {var_info_ptr}) var_heap
+ = case sreadPtr var_info_ptr var_heap of
+ VI_LocalLetVar
+ -> False
+ _
+ -> True
+ is_lhs_var _ _
+ = False
+
+nextAlts {si_moved} kees ss
+ = (False, ss) ->> ("nextAlts no outerdefault" +++ toString si_moved +++ toString kees.case_explicit)
+
newFunction :: !(Optional Ident) !FunctionBody ![FreeVar] ![AType] !AType !Int !(!Int, ![FunctionInfoPtr],!*FunctionHeap)
-> (! SymbIdent, !(!Int, ![FunctionInfoPtr],!*FunctionHeap))
newFunction opt_id fun_bodies local_vars arg_types result_type group_index state
@@ -911,10 +1230,12 @@ instance convertRootCases Expression where
(let_expr, cs) = convertRootCases (if (isEmpty let_strict_binds) ci {ci & ci_case_level=CaseLevelAfterGuardRoot}) let_expr cs
= (Let { lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, cs)
- convertRootCases ci caseExpr=:(Case kees=:{case_expr, case_guards, case_default, case_explicit, case_info_ptr}) cs=:{cs_var_heap, cs_expr_heap}
+ convertRootCases ci caseExpr=:(Case kees=:{case_expr, case_guards, case_default, case_explicit, case_info_ptr}) cs
= case case_guards of // -*-> "convertRootCases, guards???" of
BasicPatterns BT_Bool patterns
| is_guard_case patterns case_default case_explicit case_expr
+ # ({case_expr, case_guards, case_default, case_explicit, case_info_ptr}, cs)
+ = splitCase ci kees cs
-> convert_boolean_case_into_guard ci case_expr patterns case_default case_info_ptr cs
_
-> case case_expr of
@@ -922,14 +1243,17 @@ instance convertRootCases Expression where
| not case_explicit || (case ci.ci_case_level of
CaseLevelAfterGuardRoot -> False
_ -> True)
- # (EI_CaseTypeAndRefCounts case_type _, cs_expr_heap) = readPtr case_info_ptr cs.cs_expr_heap
+ # (EI_CaseTypeAndSplits case_type _, cs_expr_heap) = readPtr case_info_ptr cs.cs_expr_heap
# (varInfo, cs_var_heap) = readPtr var.var_info_ptr cs.cs_var_heap
# cs = {cs & cs_expr_heap=cs_expr_heap, cs_var_heap=cs_var_heap} // -*-> varInfo
-> case varInfo of
VI_LocalLetVar
- -> convertCases ci caseExpr cs // -*-> "convertRootCases, no guards"
+ -> convertNonRootCase ci kees cs // -*-> "convertRootCases, no guards"
_
// | True <<- ("convertRootCases",varInfo)
+ # ({case_expr, case_guards, case_default, case_explicit, case_info_ptr}, cs)
+ = splitCase ci kees cs
+
# (case_expr, cs) = convertCases ci case_expr cs
# (case_guards, cs) = convertRootCasesCasePatterns ci case_guards case_type.ct_cons_types cs
# (case_default, cs)= convertRootCases ci case_default cs
@@ -976,6 +1300,145 @@ instance convertRootCases Expression where
convertRootCases ci expr cs
= convertCases ci expr cs
+splitCase :: ConvertInfo Case *ConvertState -> (Case, *ConvertState)
+splitCase ci kees=:{case_info_ptr} cs=:{cs_expr_heap}
+ # (EI_CaseTypeAndSplits case_type splits=:{sic_next_alt, sic_splits}, cs_expr_heap)
+ = readPtr case_info_ptr cs_expr_heap
+ # (kees, cs_expr_heap)
+ = addDefault sic_next_alt kees cs_expr_heap
+ | isEmpty sic_splits
+ // optimisation for the common case
+ = (kees, {cs & cs_expr_heap = cs_expr_heap}) ->> ("split: no", toString kees.case_ident, ptrToInt kees.case_info_ptr)
+ # sic_splits
+ = uniq (sortBy (>) sic_splits)
+
+ # cs_expr_heap
+ = cs_expr_heap <:= (case_info_ptr,
+ EI_CaseTypeAndSplits case_type {splits & sic_splits = []})
+
+ # (kees, case_type, cs=:{cs_expr_heap})
+ = split ci sic_splits (kees, case_type, {cs & cs_expr_heap = cs_expr_heap})->> ("split: yes", toString kees.case_ident, ptrToInt kees.case_info_ptr) //, sic_splits)
+ = (kees, {cs & cs_expr_heap = cs_expr_heap})
+
+class split a :: ConvertInfo a (Case, CaseType, *ConvertState) -> (Case, CaseType, *ConvertState)
+
+instance split [a] | split a where
+ split ci splits (kees, case_type, cs)
+ = foldSt (split ci) splits (kees, case_type, cs)
+
+instance split SplitCase where
+ split ci split=:{sc_alt_nr} (kees, case_type, cs=:{cs_expr_heap})
+ # (kees1, kees2)
+ = splitIt sc_alt_nr kees
+ # (case_type1, case_type2)
+ = splitIt sc_alt_nr case_type
+ # case_type_and_splits2
+ = EI_CaseTypeAndSplits case_type2 {sic_splits = [], sic_next_alt = No}
+ # (case_info_ptr2, cs_expr_heap)
+ = newPtr case_type_and_splits2 cs_expr_heap
+
+ # kees2
+ = {kees2 & case_info_ptr = case_info_ptr2}
+ # (call, cs)
+ = convertNonRootCase ci kees2 {cs & cs_expr_heap = cs_expr_heap}
+ # kees1
+ = {kees1 & case_default = Yes call}
+ # (EI_CaseTypeAndSplits _ splits1, cs_expr_heap)
+ = readPtr kees.case_info_ptr cs.cs_expr_heap
+ # case_type_and_splits1
+ = EI_CaseTypeAndSplits case_type1 {splits1 & sic_splits = [{split & sc_call = Yes call} : splits1.sic_splits]}
+ # cs_expr_heap
+ = cs_expr_heap <:= (kees.case_info_ptr, case_type_and_splits1)
+ = (kees1, case_type1, {cs & cs_expr_heap = cs_expr_heap})
+
+class splitIt a :: CaseAltNr a -> (a, a)
+
+instance splitIt Case where
+ splitIt alt_nr kees=:{case_guards}
+ # (case_guards1, case_guards2)
+ = splitIt alt_nr case_guards
+ # kees1
+ = {kees & case_guards = case_guards1, case_default=No}
+ # kees2
+ = {kees & case_guards = case_guards2}
+ = (kees1, kees2)
+
+instance splitIt CaseType where
+ splitIt alt_nr case_type=:{ct_cons_types}
+ # (ct_cons_types1, ct_cons_types2)
+ = splitIt alt_nr ct_cons_types
+ # case_type1
+ = {case_type & ct_cons_types = ct_cons_types1}
+ # case_type2
+ = {case_type & ct_cons_types = ct_cons_types2}
+ = (case_type1, case_type2)
+
+instance splitIt CasePatterns where
+ splitIt alt_nr (AlgebraicPatterns type alts)
+ # (alts1, alts2)
+ = splitIt alt_nr alts
+ = (AlgebraicPatterns type alts1, AlgebraicPatterns type alts2)
+ splitIt alt_nr (BasicPatterns type alts)
+ # (alts1, alts2)
+ = splitIt alt_nr alts
+ = (BasicPatterns type alts1, BasicPatterns type alts2)
+ splitIt alt_nr (OverloadedListPatterns type decons alts)
+ # (alts1, alts2)
+ = splitIt alt_nr alts
+ = (OverloadedListPatterns type decons alts1, OverloadedListPatterns type decons alts2)
+
+instance splitIt [a] where
+ splitIt alt_nr l
+ = (take alt_nr l, drop alt_nr l)
+
+instance < SplitCase where
+ (<) a b
+ = a.sc_alt_nr < b.sc_alt_nr
+
+instance == SplitCase where
+ (==) a b
+ = a.sc_alt_nr == b.sc_alt_nr
+
+uniq :: [a] -> [a] | Eq a
+uniq [a : rest =: [b : t]]
+ | a == b
+ = uniq rest
+ // otherwise
+ = [a : uniq rest]
+uniq l
+ = l
+
+class addDefault a :: a Case *ExpressionHeap -> (Case, *ExpressionHeap)
+
+instance addDefault (Optional a) | addDefault a where
+ addDefault (Yes next_alt) kees expr_heap
+ = addDefault next_alt kees expr_heap
+ addDefault _ kees expr_heap
+ = (kees, expr_heap)
+
+instance addDefault NextAlt where
+ addDefault next_alt kees expr_heap
+ # (call, expr_heap)
+ = find_call next_alt expr_heap
+ = addDefault call kees expr_heap
+ where
+ find_call :: NextAlt *ExpressionHeap -> (Expression, *ExpressionHeap)
+ find_call {na_case, na_alt_nr} expr_heap
+ # (EI_CaseTypeAndSplits case_type {sic_splits}, expr_heap)
+ = readPtr na_case expr_heap
+ # sic_splits = sic_splits ->> ("find_call", ptrToInt na_case, na_alt_nr)
+ # call
+ = hd [ call
+ \\ {sc_call=Yes call, sc_alt_nr} <- sic_splits
+ | sc_alt_nr==na_alt_nr
+ ]
+ = (call, expr_heap)
+
+instance addDefault Expression where
+ addDefault expr kees=:{case_default=No} expr_heap
+ = ({kees & case_default=Yes expr}, expr_heap)
+ addDefault expr kees expr_heap
+ = abort ("trying to overwrite default of " +++ toString (ptrToInt kees.case_info_ptr) +++ " " +++ toString kees.case_ident)
convertRootCasesCasePatterns :: ConvertInfo CasePatterns [[AType]] *ConvertState -> (CasePatterns, *ConvertState)
convertRootCasesCasePatterns ci (BasicPatterns bt patterns) _ cs
# (patterns, cs)
@@ -1100,6 +1563,12 @@ where
# (expr, cs) = convertCases ci expr cs
= (TupleSelect tuple_symbol arg_nr expr, cs)
convertCases ci (Case case_expr) cs
+ // this is a case on a non-root position
+ # (_, {ss_expr_heap, ss_var_heap})
+ = findSplitCases {si_moved=False, si_next_alt=No} case_expr
+ {ss_var_heap=cs.cs_var_heap,ss_expr_heap = cs.cs_expr_heap}
+ cs
+ = {cs & cs_var_heap=ss_var_heap, cs_expr_heap = ss_expr_heap}
= convertNonRootCase ci case_expr cs
convertCases ci expr cs
= (expr, cs)
@@ -1116,25 +1585,82 @@ where
convertCases ci selector cs
= (selector, cs)
-convertNonRootCase ci=:{ci_bound_vars, ci_group_index, ci_common_defs} kees=:{ case_expr, case_guards, case_default, case_ident, case_info_ptr} cs
- # (EI_CaseTypeAndRefCounts case_type _, cs_expr_heap) = readPtr case_info_ptr cs.cs_expr_heap
+convertDefault ci=:{ci_bound_vars, ci_group_index, ci_common_defs}
+ kees=:{case_ident, case_info_ptr, case_default=Yes defoult} cs
+ # (EI_CaseTypeAndSplits case_type _, cs_expr_heap) = readPtr case_info_ptr cs.cs_expr_heap
+ cs = { cs & cs_expr_heap = cs_expr_heap }
+
+ (act_vars, form_vars, local_vars, defoult, old_fv_info_ptr_values,cs_var_heap)
+ = copy_case_expr ci_bound_vars defoult cs.cs_var_heap
+ cs = { cs & cs_var_heap = cs_var_heap}
+
+ (fun_symb, cs)
+ = new_case_function case_ident case_type.ct_result_type defoult form_vars local_vars
+ ci_bound_vars ci_group_index ci_common_defs cs
+
+ # cs_var_heap=fold2St restore_old_fv_info_ptr_value old_fv_info_ptr_values ci_bound_vars cs.cs_var_heap
+ with
+ restore_old_fv_info_ptr_value old_fv_info_ptr_value ({fv_info_ptr},type) var_heap
+ = writePtr fv_info_ptr old_fv_info_ptr_value var_heap
+ # cs = { cs & cs_var_heap = cs_var_heap}
+ = (App { app_symb = fun_symb, app_args = act_vars, app_info_ptr = nilPtr }, cs)
+
+convertNonRootCase ci=:{ci_bound_vars, ci_group_index, ci_common_defs} kees=:{ case_expr, case_ident, case_info_ptr} cs
+ # (is_degenerate, defoult)
+ = case_is_degenerate kees
+ | is_degenerate
+ # (EI_CaseTypeAndSplits case_type _, cs_expr_heap) = readPtr case_info_ptr cs.cs_expr_heap
+ cs = { cs & cs_expr_heap = cs_expr_heap }
+
+// test ...
+ (defoult, cs) = convertRootCases ci defoult cs
+// ... test
+ (act_vars, form_vars, local_vars, caseExpr, old_fv_info_ptr_values,cs_var_heap)
+ = copy_case_expr ci_bound_vars (defoult) cs.cs_var_heap
+
+ cs = { cs & cs_var_heap = cs_var_heap}
+
+ (fun_symb, cs) = new_case_function case_ident case_type.ct_result_type caseExpr
+ form_vars local_vars
+ ci_bound_vars ci_group_index ci_common_defs cs
+
+ # cs_var_heap=restore_old_fv_info_ptr_values old_fv_info_ptr_values ci_bound_vars cs.cs_var_heap
+ with
+ restore_old_fv_info_ptr_values [old_fv_info_ptr_value:old_fv_info_ptr_values] [({fv_info_ptr},type):bound_vars] var_heap
+ # var_heap=writePtr fv_info_ptr old_fv_info_ptr_value var_heap
+ = restore_old_fv_info_ptr_values old_fv_info_ptr_values bound_vars var_heap
+ restore_old_fv_info_ptr_values [] bound_vars var_heap
+ = var_heap
+ # cs = { cs & cs_var_heap = cs_var_heap}
+
+ = (App { app_symb = fun_symb, app_args = act_vars, app_info_ptr = nilPtr }, cs)
+
+ // otherwise
+
+ # (EI_CaseTypeAndSplits case_type _, cs_expr_heap) = readPtr case_info_ptr cs.cs_expr_heap
cs = { cs & cs_expr_heap = cs_expr_heap }
(new_info_ptr, cs_var_heap) = newPtr (VI_LocalVar) cs.cs_var_heap
var_id = {id_name = "_x", id_info = nilPtr}
case_var = Var {var_name = var_id, var_info_ptr = new_info_ptr, var_expr_ptr = nilPtr}
case_free_var = { fv_def_level = NotALevel, fv_name = var_id, fv_info_ptr = new_info_ptr, fv_count = 0}
- cs = { cs & cs_var_heap = cs_var_heap}
kees = {kees & case_expr=case_var, case_explicit=False}
+ cs = { cs & cs_var_heap = cs_var_heap}
+
(case_expr, cs) = convertCases ci case_expr cs
+// test ...
+ (caseExpr, cs) = convertRootCases ci (Case kees) cs
+// ... test
(act_vars, form_vars, local_vars, caseExpr, old_fv_info_ptr_values,cs_var_heap)
- = copy_case_expr ci_bound_vars (Case kees) cs.cs_var_heap
+ = copy_case_expr ci_bound_vars caseExpr cs.cs_var_heap
+
cs = { cs & cs_var_heap = cs_var_heap}
- (fun_symb, cs) = new_case_function case_ident case_type caseExpr case_free_var form_vars local_vars
+ (fun_symb, cs) = new_case_function case_ident case_type.ct_result_type caseExpr
+ [(case_free_var, case_type.ct_pattern_type) : form_vars] local_vars
ci_bound_vars ci_group_index ci_common_defs cs
# cs_var_heap=restore_old_fv_info_ptr_values old_fv_info_ptr_values ci_bound_vars cs.cs_var_heap
@@ -1151,50 +1677,60 @@ where
get_case_var (Var var)
= var
- copy_case_expr bound_vars guards_and_default var_heap
+ case_is_degenerate {case_guards = AlgebraicPatterns _ [], case_default=Yes defoult}
+ = (True, defoult)
+ case_is_degenerate {case_guards = BasicPatterns _ [], case_default=Yes defoult}
+ = (True, defoult)
+ case_is_degenerate {case_guards = OverloadedListPatterns _ _ [], case_default=Yes defoult}
+ = (True, defoult)
+ case_is_degenerate _
+ = (False, undef)
+
+
+copy_case_expr bound_vars guards_and_default var_heap
// # var_heap = foldSt (\({fv_name,fv_info_ptr},type) -> writePtr fv_info_ptr (VI_BoundVar type) -*-> (fv_name,fv_info_ptr)) bound_vars var_heap
- # (old_fv_info_ptr_values,var_heap) = store_VI_BoundVar_in_bound_vars_and_save_old_values bound_vars [] var_heap
- with
- store_VI_BoundVar_in_bound_vars_and_save_old_values [({fv_info_ptr},type):bound_vars] old_fv_info_ptr_values var_heap
- # (old_fv_info_ptr_value,var_heap)=readPtr fv_info_ptr var_heap
- # var_heap=writePtr fv_info_ptr (VI_BoundVar type) var_heap
- # (old_fv_info_ptr_values,var_heap) = store_VI_BoundVar_in_bound_vars_and_save_old_values bound_vars old_fv_info_ptr_values var_heap
- = ([old_fv_info_ptr_value:old_fv_info_ptr_values],var_heap)
- store_VI_BoundVar_in_bound_vars_and_save_old_values [] old_fv_info_ptr_values var_heap
- = (old_fv_info_ptr_values,var_heap)
- (expr, {cp_free_vars, cp_var_heap, cp_local_vars}) = copy guards_and_default { 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, old_fv_info_ptr_values,var_heap)
+ # (old_fv_info_ptr_values,var_heap) = store_VI_BoundVar_in_bound_vars_and_save_old_values bound_vars [] var_heap
+ with
+ store_VI_BoundVar_in_bound_vars_and_save_old_values [({fv_info_ptr},type):bound_vars] old_fv_info_ptr_values var_heap
+ # (old_fv_info_ptr_value,var_heap)=readPtr fv_info_ptr var_heap
+ # var_heap=writePtr fv_info_ptr (VI_BoundVar type) var_heap
+ # (old_fv_info_ptr_values,var_heap) = store_VI_BoundVar_in_bound_vars_and_save_old_values bound_vars old_fv_info_ptr_values var_heap
+ = ([old_fv_info_ptr_value:old_fv_info_ptr_values],var_heap)
+ store_VI_BoundVar_in_bound_vars_and_save_old_values [] old_fv_info_ptr_values var_heap
+ = (old_fv_info_ptr_values,var_heap)
+ (expr, {cp_free_vars, cp_var_heap, cp_local_vars}) = copy guards_and_default { 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, old_fv_info_ptr_values,var_heap)
// -*-> ("copy_case_expr", length bound_vars, length free_typed_vars)
- 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_name = name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} : bound_vars],
- [({ fv_def_level = NotALevel, fv_name = name, fv_info_ptr = new_ptr, fv_count = count }, type) : free_typed_vars], var_heap)
-
- new_case_function opt_id {ct_result_type,ct_pattern_type,ct_cons_types} caseExpr case_var free_vars local_vars
- bound_vars group_index common_defs cs=:{cs_expr_heap}
-
- # body
- = TransformedBody {tb_args=[case_var : [var \\ (var, _) <- free_vars]], tb_rhs=caseExpr}
- (_,type)
- = removeAnnotations
- { st_vars = []
- , st_args = [ct_pattern_type : [ type \\ (_, type) <- free_vars]]
- , st_args_strictness=NotStrict
- , st_arity = 1 + length free_vars
- , st_result = ct_result_type
- , st_context = []
- , st_attr_vars = []
- , st_attr_env = []
- }
- (body, cs)
- = convertCasesInBody body (Yes type) group_index common_defs cs
-
- # (fun_symb, (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)
- = (fun_symb, { cs & cs_fun_heap = cs_fun_heap, cs_next_fun_nr = cs_next_fun_nr, cs_new_functions = cs_new_functions })
+ 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_name = name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} : bound_vars],
+ [({ fv_def_level = NotALevel, fv_name = name, fv_info_ptr = new_ptr, fv_count = count }, type) : free_typed_vars], var_heap)
+
+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)
+ = removeAnnotations
+ { st_vars = []
+ , st_args = [ type \\ (_, type) <- free_vars]
+ , st_args_strictness=NotStrict
+ , st_arity = length free_vars
+ , st_result = result_type
+ , st_context = []
+ , st_attr_vars = []
+ , st_attr_env = []
+ }
+// (body, cs)
+// = convertCasesInBody body (Yes type) group_index common_defs cs
+
+ # (fun_symb, (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)
+ = (fun_symb, { cs & cs_fun_heap = cs_fun_heap, cs_next_fun_nr = cs_next_fun_nr, cs_new_functions = cs_new_functions })
splitGuards :: CasePatterns -> [CasePatterns]
splitGuards (AlgebraicPatterns index patterns)
@@ -1331,7 +1867,7 @@ where
instance copy Case
where
- copy this_case=:{case_expr, case_guards, case_default} cp_info
+ copy this_case=:{case_expr, case_guards, case_default, case_info_ptr} cp_info
# ((case_expr,(case_guards,case_default)), cp_info) = copy (case_expr,(case_guards,case_default)) cp_info
= ({ this_case & case_expr = case_expr, case_guards = case_guards, case_default = case_default}, cp_info)
@@ -1409,4 +1945,8 @@ where
*/
(-*->) infixl
-(-*->) a b :== a // ---> b
+(-*->) a b :== a ---> b
+(->>) infixl
+(->>) a b :== a // ---> b
+(<<-) infixl
+(<<-) a b :== a // ---> b
--
cgit v1.2.3