\section[Simplify]{The main module of the simplifier}
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module Simplify ( simplTopBinds, simplExpr ) where
#include "HsVersions.h"
import Type hiding ( substTy, extendTvSubst )
import SimplEnv
import SimplUtils
+import MkId ( rUNTIME_ERROR_ID )
import Id
import Var
import IdInfo
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) )
import CoreUtils
-import Rules ( lookupRule )
+import Rules ( lookupRule, getRules )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import TysPrim ( realWorldStatePrimTy )
import Maybes ( orElse )
import Data.List ( mapAccumL )
import Outputable
-import Util
+import FastString
\end{code}
\begin{code}
simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
-simplTopBinds env binds
+simplTopBinds env0 binds0
= do { -- Put all the top-level binders into scope at the start
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
- ; env <- simplRecBndrs env (bindersOfBinds binds)
+ ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
; dflags <- getDOptsSmpl
; let dump_flag = dopt Opt_D_dump_inlinings dflags ||
dopt Opt_D_dump_rule_firings dflags
- ; env' <- simpl_binds dump_flag env binds
+ ; env2 <- simpl_binds dump_flag env1 binds0
; freeTick SimplifierDone
- ; return (getFloats env') }
+ ; return (getFloats env2) }
where
-- We need to track the zapped top-level binders, because
-- they should have their fragile IdInfo zapped (notably occurrence info)
-- The dump-flag emits a trace for each top-level binding, which
-- helps to locate the tracing for inlining and rule firing
simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
- simpl_binds dump env [] = return env
- simpl_binds dump env (bind:binds) = do { env' <- trace dump bind $
+ simpl_binds _ env [] = return env
+ simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $
simpl_bind env bind
; simpl_binds dump env' binds }
- trace True bind = pprTrace "SimplBind" (ppr (bindersOf bind))
- trace False bind = \x -> x
+ trace_bind True bind = pprTrace "SimplBind" (ppr (bindersOf bind))
+ trace_bind False _ = \x -> x
simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
simplRecBind :: SimplEnv -> TopLevelFlag
-> [(InId, InExpr)]
-> SimplM SimplEnv
-simplRecBind env top_lvl pairs
- = do { let (env_with_info, triples) = mapAccumL add_rules env pairs
- ; env' <- go (zapFloats env_with_info) triples
- ; return (env `addRecFloats` env') }
- -- addFloats adds the floats from env',
- -- *and* updates env with the in-scope set from env'
+simplRecBind env0 top_lvl pairs0
+ = do { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0
+ ; env1 <- go (zapFloats env_with_info) triples
+ ; return (env0 `addRecFloats` env1) }
+ -- addFloats adds the floats from env1,
+ -- _and_ updates env0 with the in-scope set from env1
where
add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
-- Add the (substituted) rules to the binder
go env [] = return env
go env ((old_bndr, new_bndr, rhs) : pairs)
- = do { env <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
- ; go env pairs }
+ = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
+ ; go env' pairs }
\end{code}
simplOrTopPair is used for
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
= do { let rhs_env = rhs_se `setInScope` env
- (tvs, body) = collectTyBinders rhs
+ (tvs, body) = case collectTyBinders rhs of
+ (tvs, body) | not_lam body -> (tvs,body)
+ | otherwise -> ([], rhs)
+ not_lam (Lam _ _) = False
+ not_lam _ = True
+ -- Do not do the "abstract tyyvar" thing if there's
+ -- a lambda inside, becuase it defeats eta-reduction
+ -- f = /\a. \x. g a x
+ -- should eta-reduce
+
; (body_env, tvs') <- simplBinders rhs_env tvs
- -- See Note [Floating and type abstraction]
- -- in SimplUtils
+ -- See Note [Floating and type abstraction] in SimplUtils
- -- Simplify the RHS; note the mkRhsStop, which tells
- -- the simplifier that this is the RHS of a let.
- ; let rhs_cont = mkRhsStop (applyTys (idType bndr1) (mkTyVarTys tvs'))
- ; (body_env1, body1) <- simplExprF body_env body rhs_cont
+ -- Simplify the RHS
+ ; (body_env1, body1) <- simplExprF body_env body mkBoringStop
-- ANF-ise a constructor or PAP rhs
; (body_env2, body2) <- prepareRhs body_env1 body1
do { tick LetFloatFromLet
; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
; rhs' <- mkLam tvs' body3
- ; return (extendFloats env poly_binds, rhs') }
+ ; let env' = foldl (addPolyBind top_lvl) env poly_binds
+ ; return (env', rhs') }
; completeBind env' top_lvl bndr bndr1 rhs' }
\end{code}
-> SimplM SimplEnv
simplNonRecX env bndr new_rhs
- = do { (env, bndr') <- simplBinder env bndr
- ; completeNonRecX env NotTopLevel NonRecursive
- (isStrictId bndr) bndr bndr' new_rhs }
+ = do { (env', bndr') <- simplBinder env bndr
+ ; completeNonRecX env' (isStrictId bndr) bndr bndr' new_rhs }
completeNonRecX :: SimplEnv
- -> TopLevelFlag -> RecFlag -> Bool
+ -> Bool
-> InId -- Old binder
-> OutId -- New binder
-> OutExpr -- Simplified RHS
-> SimplM SimplEnv
-completeNonRecX env top_lvl is_rec is_strict old_bndr new_bndr new_rhs
+completeNonRecX env is_strict old_bndr new_bndr new_rhs
= do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
; (env2, rhs2) <-
- if doFloatFromRhs top_lvl is_rec is_strict rhs1 env1
+ if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
then do { tick LetFloatFromLet
; return (addFloats env env1, rhs1) } -- Add the floats to the main env
else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Adds new floats to the env iff that allows us to return a good RHS
prepareRhs env (Cast rhs co) -- Note [Float coercions]
- | (ty1, ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
+ | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
, not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
= do { (env', rhs') <- makeTrivial env rhs
; return (env', Cast rhs' co) }
-prepareRhs env rhs
- = do { (is_val, env', rhs') <- go 0 env rhs
- ; return (env', rhs') }
+prepareRhs env0 rhs0
+ = do { (_is_val, env1, rhs1) <- go 0 env0 rhs0
+ ; return (env1, rhs1) }
where
go n_val_args env (Cast rhs co)
= do { (is_val, env', rhs') <- go n_val_args env rhs
is_val = n_val_args > 0 -- There is at least one arg
-- ...and the fun a constructor or PAP
&& (isDataConWorkId fun || n_val_args < idArity fun)
- go n_val_args env other
+ go _ env other
= return (False, env, other)
\end{code}
| exprIsTrivial expr
= return (env, expr)
| otherwise -- See Note [Take care] below
- = do { var <- newId FSLIT("a") (exprType expr)
- ; env <- completeNonRecX env NotTopLevel NonRecursive
- False var var expr
- ; return (env, substExpr env (Var var)) }
+ = do { var <- newId (fsLit "a") (exprType expr)
+ ; env' <- completeNonRecX env False var var expr
+ ; return (env', substExpr env' (Var var)) }
\end{code}
-- Use the substitution to make quite, quite sure that the
-- substitution will happen, since we are going to discard the binding
- | otherwise
- = let
+ | otherwise
+ = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
+ where
+ unfolding | omit_unfolding = NoUnfolding
+ | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs
+ old_info = idInfo old_bndr
+ occ_info = occInfo old_info
+ wkr = substWorker env (workerInfo old_info)
+ omit_unfolding = isNonRuleLoopBreaker occ_info || not (activeInline env old_bndr)
+
+-----------------
+addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
+-- Add a new binding to the environment, complete with its unfolding
+-- but *do not* do postInlineUnconditionally, because we have already
+-- processed some of the scope of the binding
+-- We still want the unfolding though. Consider
+-- let
+-- x = /\a. let y = ... in Just y
+-- in body
+-- Then we float the y-binding out (via abstractFloats and addPolyBind)
+-- but 'x' may well then be inlined in 'body' in which case we'd like the
+-- opportunity to inline 'y' too.
+
+addPolyBind top_lvl env (NonRec poly_id rhs)
+ = addNonRecWithUnf env poly_id rhs unfolding NoWorker
+ where
+ unfolding | not (activeInline env poly_id) = NoUnfolding
+ | otherwise = mkUnfolding (isTopLevel top_lvl) rhs
+ -- addNonRecWithInfo adds the new binding in the
+ -- proper way (ie complete with unfolding etc),
+ -- and extends the in-scope set
+
+addPolyBind _ env bind@(Rec _) = extendFloats env bind
+ -- Hack: letrecs are more awkward, so we extend "by steam"
+ -- without adding unfoldings etc. At worst this leads to
+ -- more simplifier iterations
+
+-----------------
+addNonRecWithUnf :: SimplEnv
+ -> OutId -> OutExpr -- New binder and RHS
+ -> Unfolding -> WorkerInfo -- and unfolding
+ -> SimplEnv
+-- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set
+addNonRecWithUnf env new_bndr rhs unfolding wkr
+ = final_id `seq` -- This seq forces the Id, and hence its IdInfo,
+ -- and hence any inner substitutions
+ addNonRec env final_id rhs
+ -- The addNonRec adds it to the in-scope set too
+ where
-- Arity info
- new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
+ new_bndr_info = idInfo new_bndr `setArityInfo` exprArity rhs
-- Unfolding info
-- Add the unfolding *only* for non-loop-breakers
-- (for example) be no longer strictly demanded.
-- The solution here is a bit ad hoc...
info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
- `setWorkerInfo` worker_info
+ `setWorkerInfo` wkr
- final_info | loop_breaker = new_bndr_info
- | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
+ final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
| otherwise = info_w_unf
-
+
final_id = new_bndr `setIdInfo` final_info
- in
- -- These seqs forces the Id, and hence its IdInfo,
- -- and hence any inner substitutions
- final_id `seq`
- -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
- return (addNonRec env final_id new_rhs)
- where
- unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
- worker_info = substWorker env (workerInfo old_info)
- loop_breaker = isNonRuleLoopBreaker occ_info
- old_info = idInfo old_bndr
- occ_info = occInfo old_info
\end{code}
\begin{code}
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
- where
- expr_ty' = substTy env (exprType expr)
- -- The type in the Stop continuation, expr_ty', is usually not used
- -- It's only needed when discarding continuations after finding
- -- a function that returns bottom.
- -- Hence the lazy substitution
-
+simplExpr env expr = simplExprC env expr mkBoringStop
simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
-- Simplify an expression, given a continuation
= -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
simplExprF' env e cont
+simplExprF' :: SimplEnv -> InExpr -> SimplCont
+ -> SimplM (SimplEnv, OutExpr)
simplExprF' env (Var v) cont = simplVar env v cont
simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
simplExprF' env (Note n expr) cont = simplNote env n expr cont
do { ty' <- simplType env ty
; rebuild env (Type ty') cont }
-simplExprF' env (Case scrut bndr case_ty alts) cont
+simplExprF' env (Case scrut bndr _ alts) cont
| not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
= -- Simplify the scrutinee with a Select continuation
simplExprF env scrut (Select NoDup bndr alts env cont)
do { case_expr' <- simplExprC env scrut case_cont
; rebuild env case_expr' cont }
where
- case_cont = Select NoDup bndr alts env (mkBoringStop case_ty')
- case_ty' = substTy env case_ty -- c.f. defn of simplExpr
+ case_cont = Select NoDup bndr alts env mkBoringStop
simplExprF' env (Let (Rec pairs) body) cont
- = do { env <- simplRecBndrs env (map fst pairs)
+ = do { env' <- simplRecBndrs env (map fst pairs)
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
- ; env <- simplRecBind env NotTopLevel pairs
- ; simplExprF env body cont }
+ ; env'' <- simplRecBind env' NotTopLevel pairs
+ ; simplExprF env'' body cont }
simplExprF' env (Let (NonRec bndr rhs) body) cont
= simplNonRecE env bndr (rhs, env) ([], body) cont
rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
-- At this point the substitution in the SimplEnv should be irrelevant
-- only the in-scope set and floats should matter
-rebuild env expr cont
- = -- pprTrace "rebuild" (ppr expr $$ ppr cont $$ ppr (seFloats env)) $
- case cont of
+rebuild env expr cont0
+ = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $
+ case cont0 of
Stop {} -> return (env, expr)
CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
- StrictArg fun ty _ info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont
+ StrictArg fun _ info cont -> rebuildCall env (fun `App` expr) info cont
StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
; simplLam env' bs body cont }
ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
\begin{code}
simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
-> SimplM (SimplEnv, OutExpr)
-simplCast env body co cont
- = do { co' <- simplType env co
- ; simplExprF env body (addCoerce co' cont) }
+simplCast env body co0 cont0
+ = do { co1 <- simplType env co0
+ ; simplExprF env body (addCoerce co1 cont0) }
where
addCoerce co cont = add_coerce co (coercionKind co) cont
- add_coerce co (s1, k1) cont -- co :: ty~ty
+ add_coerce _co (s1, k1) cont -- co :: ty~ty
| s1 `coreEqType` k1 = cont -- is a no-op
- add_coerce co1 (s1, k2) (CoerceIt co2 cont)
- | (l1, t1) <- coercionKind co2
+ add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
+ | (_l1, t1) <- coercionKind co2
-- coerce T1 S1 (coerce S1 K1 e)
-- ==>
-- e, if T1=K1
, s1 `coreEqType` t1 = cont -- The coerces cancel out
| otherwise = CoerceIt (mkTransCoercion co1 co2) cont
- add_coerce co (s1s2, t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
+ add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
-- (f `cast` g) ty ---> (f ty) `cast` (g @ ty)
-- This implements the PushT rule from the paper
| Just (tyvar,_) <- splitForAllTy_maybe s1s2
, not (isCoVar tyvar)
= ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
where
- ty' = substTy arg_se arg_ty
+ ty' = substTy (arg_se `setInScope` env) arg_ty
-- ToDo: the PushC rule is not implemented at all
- add_coerce co (s1s2, t1t2) (ApplyTo dup arg arg_se cont)
+ add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
| not (isTypeArg arg) -- This implements the Push rule from the paper
, isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
-- co : s1s2 :=: t1t2
-- (->) t1 t2 :=: (->) s1 s2
[co1, co2] = decomposeCo 2 co
new_arg = mkCoerce (mkSymCoercion co1) arg'
- arg' = substExpr arg_se arg
+ arg' = substExpr (arg_se `setInScope` env) arg
add_coerce co _ cont = CoerceIt co cont
\end{code}
simplLam env [] body cont = simplExprF env body cont
- -- Type-beta reduction
-simplLam env (bndr:bndrs) body (ApplyTo _ (Type ty_arg) arg_se cont)
- = ASSERT( isTyVar bndr )
- do { tick (BetaReduction bndr)
- ; ty_arg' <- simplType (arg_se `setInScope` env) ty_arg
- ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
-
- -- Ordinary beta reduction
+ -- Beta reduction
simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
= do { tick (BetaReduction bndr)
; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
-- Not enough args, so there are real lambdas left to put in the result
simplLam env bndrs body cont
- = do { (env, bndrs') <- simplLamBndrs env bndrs
- ; body' <- simplExpr env body
+ = do { (env', bndrs') <- simplLamBndrs env bndrs
+ ; body' <- simplExpr env' body
; new_lam <- mkLam bndrs' body'
- ; rebuild env new_lam cont }
+ ; rebuild env' new_lam cont }
------------------
simplNonRecE :: SimplEnv
-> InId -- The binder
-> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
- -> ([InId], InExpr) -- Body of the let/lambda
+ -> ([InBndr], InExpr) -- Body of the let/lambda
-- \xs.e
-> SimplCont
-> SimplM (SimplEnv, OutExpr)
-- Why? Because of the binder-occ-info-zapping done before
-- the call to simplLam in simplExprF (Lam ...)
+ -- First deal with type applications and type lets
+ -- (/\a. e) (Type ty) and (let a = Type ty in e)
+simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
+ = ASSERT( isTyVar bndr )
+ do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
+ ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
+
simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
| preInlineUnconditionally env NotTopLevel bndr rhs
= do { tick (PreInlineUnconditionally bndr)
\begin{code}
-- Hack alert: we only distinguish subsumed cost centre stacks for the
-- purposes of inlining. All other CCCSs are mapped to currentCCS.
+simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont
+ -> SimplM (SimplEnv, OutExpr)
simplNote env (SCC cc) e cont
= do { e' <- simplExpr (setEnclosingCC env currentCCS) e
; rebuild env (mkSCC cc e') cont }
%************************************************************************
\begin{code}
+simplVar :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
simplVar env var cont
= case substId env var of
DoneEx e -> simplExprF (zapSubstEnv env) e cont
---------------------------------------------------------
-- Dealing with a call site
+completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
completeCall env var cont
= do { dflags <- getDOptsSmpl
; let (args,call_cont) = contArgs cont
-- is recursive, and hence a loop breaker:
-- foldr k z (build g) = g k z
-- So it's up to the programmer: rules can cause divergence
- ; rules <- getRules
+ ; rule_base <- getSimplRules
; let in_scope = getInScope env
+ rules = getRules rule_base var
maybe_rule = case activeRule dflags env of
Nothing -> Nothing -- No rules apply
Just act_fn -> lookupRule act_fn in_scope
- rules var args
+ var args rules
; case maybe_rule of {
Just (rule, rule_rhs) -> do
tick (RuleFired (ru_name rule))
------------- No inlining! ----------------
-- Next, look for rules or specialisations that match
--
- rebuildCall env (Var var) (idType var)
+ rebuildCall env (Var var)
(mkArgInfo var n_val_args call_cont) cont
}}}}
rebuildCall :: SimplEnv
- -> OutExpr -> OutType -- Function and its type
+ -> OutExpr -- Function
-> ArgInfo
-> SimplCont
-> SimplM (SimplEnv, OutExpr)
-rebuildCall env fun fun_ty (ArgInfo { ai_strs = [] }) cont
+rebuildCall env fun (ArgInfo { ai_strs = [] }) cont
-- When we run out of strictness args, it means
-- that the call is definitely bottom; see SimplUtils.mkArgInfo
-- Then we want to discard the entire strict continuation. E.g.
| not (contIsTrivial cont) -- Only do this if there is a non-trivial
= return (env, mk_coerce fun) -- contination to discard, else we do it
where -- again and again!
- cont_ty = contResultType cont
+ fun_ty = exprType fun
+ cont_ty = contResultType env fun_ty cont
co = mkUnsafeCoercion fun_ty cont_ty
- mk_coerce expr | cont_ty `coreEqType` fun_ty = fun
- | otherwise = mkCoerce co fun
+ mk_coerce expr | cont_ty `coreEqType` fun_ty = expr
+ | otherwise = mkCoerce co expr
-rebuildCall env fun fun_ty info (ApplyTo _ (Type arg_ty) se cont)
+rebuildCall env fun info (ApplyTo _ (Type arg_ty) se cont)
= do { ty' <- simplType (se `setInScope` env) arg_ty
- ; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont }
+ ; rebuildCall env (fun `App` Type ty') info cont }
-rebuildCall env fun fun_ty
+rebuildCall env fun
(ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs })
(ApplyTo _ arg arg_se cont)
- | str || isStrictType arg_ty -- Strict argument
+ | str -- Strict argument
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setFloats` env) arg
- (StrictArg fun fun_ty cci arg_info' cont)
+ (StrictArg fun cci arg_info' cont)
-- Note [Shadowing]
| otherwise -- Lazy argument
-- have to be very careful about bogus strictness through
-- floating a demanded let.
= do { arg' <- simplExprC (arg_se `setInScope` env) arg
- (mkLazyArgStop arg_ty cci)
- ; rebuildCall env (fun `App` arg') res_ty arg_info' cont }
+ (mkLazyArgStop cci)
+ ; rebuildCall env (fun `App` arg') arg_info' cont }
where
- (arg_ty, res_ty) = splitFunTy fun_ty
arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs }
cci | has_rules || disc > 0 = ArgCtxt has_rules disc -- Be keener here
| otherwise = BoringCtxt -- Nothing interesting
-rebuildCall env fun fun_ty info cont
+rebuildCall env fun _ cont
= rebuild env fun cont
\end{code}
-- 2. Eliminate the case if scrutinee is evaluated
--------------------------------------------------
-rebuildCase env scrut case_bndr [(con,bndrs,rhs)] cont
+rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
-- See if we can get rid of the case altogether
-- See the extensive notes on case-elimination above
-- mkCase made sure that if all the alternatives are equal,
-- other problems
-- Also we don't want to discard 'seq's
= do { tick (CaseElim case_bndr)
- ; env <- simplNonRecX env case_bndr scrut
- ; simplExprF env rhs cont }
+ ; env' <- simplNonRecX env case_bndr scrut
+ ; simplExprF env' rhs cont }
where
-- The case binder is going to be evaluated later,
-- and the scrutinee is a simple variable
&& not (isTickBoxOp v)
-- ugly hack; covering this case is what
-- exprOkForSpeculation was intended for.
- var_demanded_later other = False
+ var_demanded_later _ = False
--------------------------------------------------
rebuildCase env scrut case_bndr alts cont
= do { -- Prepare the continuation;
-- The new subst_env is in place
- (env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont
+ (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
-- Simplify the alternatives
- ; (scrut', case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont
- ; let res_ty' = contResultType dup_cont
- ; case_expr <- mkCase scrut' case_bndr' res_ty' alts'
-
- -- Notice that rebuildDone returns the in-scope set from env, not alt_env
- -- The case binder *not* scope over the whole returned case-expression
- ; rebuild env case_expr nodup_cont }
+ ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
+
+ -- Check for empty alternatives
+ ; if null alts' then
+ -- This isn't strictly an error, although it is unusual.
+ -- It's possible that the simplifer might "see" that
+ -- an inner case has no accessible alternatives before
+ -- it "sees" that the entire branch of an outer case is
+ -- inaccessible. So we simply put an error case here instead.
+ pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
+ let res_ty' = contResultType env' (substTy env' (coreAltsType alts)) dup_cont
+ lit = mkStringLit "Impossible alternative"
+ in return (env', mkApps (Var rUNTIME_ERROR_ID) [Type res_ty', lit])
+
+ else do
+ { case_expr <- mkCase scrut' case_bndr' alts'
+
+ -- Notice that rebuild gets the in-scope set from env, not alt_env
+ -- The case binder *not* scope over the whole returned case-expression
+ ; rebuild env' case_expr nodup_cont } }
\end{code}
simplCaseBinder checks whether the scrutinee is a variable, v. If so,
Note [no-case-of-case]
~~~~~~~~~~~~~~~~~~~~~~
-There is a time we *don't* want to do that, namely when
--fno-case-of-case is on. This happens in the first simplifier pass,
-and enhances full laziness. Here's the bad case:
- f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
-If we eliminate the inner case, we trap it inside the I# v -> arm,
-which might prevent some full laziness happening. I've seen this
-in action in spectral/cichelli/Prog.hs:
- [(m,n) | m <- [1..max], n <- [1..max]]
-Hence the check for NoCaseOfCase.
+We *used* to suppress the binder-swap in case expressoins when
+-fno-case-of-case is on. Old remarks:
+ "This happens in the first simplifier pass,
+ and enhances full laziness. Here's the bad case:
+ f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
+ If we eliminate the inner case, we trap it inside the I# v -> arm,
+ which might prevent some full laziness happening. I've seen this
+ in action in spectral/cichelli/Prog.hs:
+ [(m,n) | m <- [1..max], n <- [1..max]]
+ Hence the check for NoCaseOfCase."
+However, now the full-laziness pass itself reverses the binder-swap, so this
+check is no longer necessary.
Note [Suppressing the case binder-swap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt]
-> SimplM (SimplEnv, OutExpr, OutId)
-simplCaseBinder env scrut case_bndr alts
- = do { (env1, case_bndr1) <- simplBinder env case_bndr
+simplCaseBinder env0 scrut0 case_bndr0 alts
+ = do { (env1, case_bndr1) <- simplBinder env0 case_bndr0
; fam_envs <- getFamEnvs
- ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut
- case_bndr case_bndr1 alts
+ ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut0
+ case_bndr0 case_bndr1 alts
-- Note [Improving seq]
; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2
; return (env3, scrut2, case_bndr3) }
where
- improve_seq fam_envs env1 scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
+ improve_seq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
| Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
- = do { case_bndr2 <- newId FSLIT("nt") ty2
+ = do { case_bndr2 <- newId (fsLit "nt") ty2
; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
- env2 = extendIdSubst env1 case_bndr rhs
+ env2 = extendIdSubst env case_bndr rhs
; return (env2, scrut `Cast` co, case_bndr2) }
- improve_seq fam_envs env1 scrut case_bndr case_bndr1 alts
- = return (env1, scrut, case_bndr1)
+ improve_seq _ env scrut _ case_bndr1 _
+ = return (env, scrut, case_bndr1)
improve_case_bndr env scrut case_bndr
- | switchIsOn (getSwitchChecker env) NoCaseOfCase
- -- See Note [no-case-of-case]
- = (env, case_bndr)
+ -- See Note [no-case-of-case]
+ -- | switchIsOn (getSwitchChecker env) NoCaseOfCase
+ -- = (env, case_bndr)
| otherwise -- Failed try; see Note [Suppressing the case binder-swap]
-- not (isEvaldUnfolding (idUnfolding v))
where
rhs = Cast (Var case_bndr') (mkSymCoercion co)
- other -> (env, case_bndr)
+ _ -> (env, case_bndr)
where
case_bndr' = zapOccInfo case_bndr
env1 = modifyInScope env case_bndr case_bndr'
simplAlts :: SimplEnv
-> OutExpr
-> InId -- Case binder
- -> [InAlt] -> SimplCont
+ -> [InAlt] -- Non-empty
+ -> SimplCont
-> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
-- Like simplExpr, this just returns the simplified alternatives;
-- it not return an environment
simplAlts env scrut case_bndr alts cont'
= -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
do { let alt_env = zapFloats env
- ; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
+ ; (alt_env', scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
- ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env scrut case_bndr' alts
+ ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut case_bndr' alts
- ; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts
+ ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
; return (scrut', case_bndr', alts') }
------------------------------------
; rhs' <- simplExprC env' rhs cont'
; return (DEFAULT, [], rhs') }
-simplAlt env imposs_deflt_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
+simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
= ASSERT( null bndrs )
do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
; rhs' <- simplExprC env' rhs cont'
; return (LitAlt lit, [], rhs') }
-simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
+simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
= do { -- Deal with the pattern-bound variables
-- Mark the ones that are in ! positions in the
-- data constructor as certainly-evaluated.
-- NB: simplLamBinders preserves this eval info
- let vs_with_evals = add_evals vs (dataConRepStrictness con)
- ; (env, vs') <- simplLamBndrs env vs_with_evals
+ let vs_with_evals = add_evals (dataConRepStrictness con)
+ ; (env', vs') <- simplLamBndrs env vs_with_evals
-- Bind the case-binder to (con args)
; let inst_tys' = tyConAppArgs (idType case_bndr')
con_args = map Type inst_tys' ++ varsToCoreExprs vs'
- env' = addBinderUnfolding env case_bndr' (mkConApp con con_args)
+ env'' = addBinderUnfolding env' case_bndr'
+ (mkConApp con con_args)
- ; rhs' <- simplExprC env' rhs cont'
+ ; rhs' <- simplExprC env'' rhs cont'
; return (DataAlt con, vs', rhs') }
where
-- add_evals records the evaluated-ness of the bound variables of
-- We really must record that b is already evaluated so that we don't
-- go and re-evaluate it when constructing the result.
-- See Note [Data-con worker strictness] in MkId.lhs
- add_evals vs strs
- = go vs strs
+ add_evals the_strs
+ = go vs the_strs
where
go [] [] = []
- go (v:vs) strs | isTyVar v = v : go vs strs
- go (v:vs) (str:strs)
- | isMarkedStrict str = evald_v : go vs strs
- | otherwise = zapped_v : go vs strs
+ go (v:vs') strs | isTyVar v = v : go vs' strs
+ go (v:vs') (str:strs)
+ | isMarkedStrict str = evald_v : go vs' strs
+ | otherwise = zapped_v : go vs' strs
where
zapped_v = zap_occ_info v
evald_v = zapped_v `setIdUnfolding` evaldUnfolding
- go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr strs)
+ go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
-- zap_occ_info: if the case binder is alive, then we add the unfolding
-- case_bndr = C vs
-- case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
-- ==> case e of t { (a,b) -> ...(a)... }
-- Look, Ma, a is alive now.
- zap_occ_info | isDeadBinder case_bndr' = \id -> id
+ zap_occ_info | isDeadBinder case_bndr' = \ident -> ident
| otherwise = zapOccInfo
addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
All this should happen in one sweep.
\begin{code}
-knownCon :: SimplEnv -> OutExpr -> AltCon -> [OutExpr]
+knownCon :: SimplEnv -> OutExpr -> AltCon
+ -> [OutExpr] -- Args *including* the universal args
-> InId -> [InAlt] -> SimplCont
-> SimplM (SimplEnv, OutExpr)
= do { tick (KnownBranch bndr)
; knownAlt env scrut args bndr (findAlt con alts) cont }
-knownAlt env scrut args bndr (DEFAULT, bs, rhs) cont
+knownAlt :: SimplEnv -> OutExpr -> [OutExpr]
+ -> InId -> (AltCon, [CoreBndr], InExpr) -> SimplCont
+ -> SimplM (SimplEnv, OutExpr)
+knownAlt env scrut _ bndr (DEFAULT, bs, rhs) cont
= ASSERT( null bs )
- do { env <- simplNonRecX env bndr scrut
+ do { env' <- simplNonRecX env bndr scrut
-- This might give rise to a binding with non-atomic args
-- like x = Node (f x) (g x)
-- but simplNonRecX will atomic-ify it
- ; simplExprF env rhs cont }
+ ; simplExprF env' rhs cont }
-knownAlt env scrut args bndr (LitAlt lit, bs, rhs) cont
+knownAlt env scrut _ bndr (LitAlt _, bs, rhs) cont
= ASSERT( null bs )
- do { env <- simplNonRecX env bndr scrut
- ; simplExprF env rhs cont }
+ do { env' <- simplNonRecX env bndr scrut
+ ; simplExprF env' rhs cont }
-knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont
+knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
= do { let dead_bndr = isDeadBinder bndr -- bndr is an InId
n_drop_tys = length (dataConUnivTyVars dc)
- ; env <- bind_args env dead_bndr bs (drop n_drop_tys args)
+ ; env' <- bind_args env dead_bndr bs (drop n_drop_tys the_args)
; let
-- It's useful to bind bndr to scrut, rather than to a fresh
-- binding x = Con arg1 .. argn
-- about duplicating the arg redexes; in that case, make
-- a new con-app from the args
bndr_rhs = case scrut of
- Var v -> scrut
- other -> con_app
- con_app = mkConApp dc (take n_drop_tys args ++ con_args)
- con_args = [substExpr env (varToCoreExpr b) | b <- bs]
+ Var _ -> scrut
+ _ -> con_app
+ con_app = mkConApp dc (take n_drop_tys the_args ++ con_args)
+ con_args = [substExpr env' (varToCoreExpr b) | b <- bs]
-- args are aready OutExprs, but bs are InIds
- ; env <- simplNonRecX env bndr bndr_rhs
- ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $
- simplExprF env rhs cont }
+ ; env'' <- simplNonRecX env' bndr bndr_rhs
+ ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env'')) $
+ simplExprF env'' rhs cont }
where
-- Ugh!
- bind_args env dead_bndr [] _ = return env
+ bind_args env' _ [] _ = return env'
- bind_args env dead_bndr (b:bs) (Type ty : args)
+ bind_args env' dead_bndr (b:bs') (Type ty : args)
= ASSERT( isTyVar b )
- bind_args (extendTvSubst env b ty) dead_bndr bs args
+ bind_args (extendTvSubst env' b ty) dead_bndr bs' args
- bind_args env dead_bndr (b:bs) (arg : args)
+ bind_args env' dead_bndr (b:bs') (arg : args)
= ASSERT( isId b )
- do { let b' = if dead_bndr then b else zapOccInfo b
- -- Note that the binder might be "dead", because it doesn't occur
- -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
- -- Nevertheless we must keep it if the case-binder is alive, because it may
- -- be used in the con_app. See Note [zapOccInfo]
- ; env <- simplNonRecX env b' arg
- ; bind_args env dead_bndr bs args }
+ do { let b' = if dead_bndr then b else zapOccInfo b
+ -- Note that the binder might be "dead", because it doesn't
+ -- occur in the RHS; and simplNonRecX may therefore discard
+ -- it via postInlineUnconditionally.
+ -- Nevertheless we must keep it if the case-binder is alive,
+ -- because it may be used in the con_app. See Note [zapOccInfo]
+ ; env'' <- simplNonRecX env' b' arg
+ ; bind_args env'' dead_bndr bs' args }
bind_args _ _ _ _ =
- pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr args $$
+ pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$
text "scrut:" <+> ppr scrut
\end{code}
-- continunation)
-- No need to make it duplicatable if there's only one alternative
-prepareCaseCont env [alt] cont = return (env, cont, mkBoringStop (contResultType cont))
-prepareCaseCont env alts cont = mkDupableCont env cont
+prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
+prepareCaseCont env _ cont = mkDupableCont env cont
\end{code}
\begin{code}
mkDupableCont env cont
| contIsDupable cont
- = return (env, cont, mkBoringStop (contResultType cont))
+ = return (env, cont, mkBoringStop)
-mkDupableCont env (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
+mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
mkDupableCont env (CoerceIt ty cont)
- = do { (env, dup, nodup) <- mkDupableCont env cont
- ; return (env, CoerceIt ty dup, nodup) }
+ = do { (env', dup, nodup) <- mkDupableCont env cont
+ ; return (env', CoerceIt ty dup, nodup) }
-mkDupableCont env cont@(StrictBind bndr _ _ se _)
- = return (env, mkBoringStop (substTy se (idType bndr)), cont)
+mkDupableCont env cont@(StrictBind {})
+ = return (env, mkBoringStop, cont)
-- See Note [Duplicating strict continuations]
-mkDupableCont env cont@(StrictArg _ fun_ty _ _ _)
- = return (env, mkBoringStop (funArgTy fun_ty), cont)
+mkDupableCont env cont@(StrictArg {})
+ = return (env, mkBoringStop, cont)
-- See Note [Duplicating strict continuations]
mkDupableCont env (ApplyTo _ arg se cont)
-- ==>
-- let a = ...arg...
-- in [...hole...] a
- do { (env, dup_cont, nodup_cont) <- mkDupableCont env cont
- ; arg <- simplExpr (se `setInScope` env) arg
- ; (env, arg) <- makeTrivial env arg
- ; let app_cont = ApplyTo OkToDup arg (zapSubstEnv env) dup_cont
- ; return (env, app_cont, nodup_cont) }
+ do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
+ ; arg' <- simplExpr (se `setInScope` env') arg
+ ; (env'', arg'') <- makeTrivial env' arg'
+ ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env') dup_cont
+ ; return (env'', app_cont, nodup_cont) }
-mkDupableCont env cont@(Select _ case_bndr [(_,bs,rhs)] se case_cont)
+mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
-- See Note [Single-alternative case]
-- | not (exprIsDupable rhs && contIsDupable case_cont)
-- | not (isDeadBinder case_bndr)
- | all isDeadBinder bs -- InIds
- = return (env, mkBoringStop scrut_ty, cont)
- where
- scrut_ty = substTy se (idType case_bndr)
+ | all isDeadBinder bs -- InIds
+ && not (isUnLiftedType (idType case_bndr))
+ -- Note [Single-alternative-unlifted]
+ = return (env, mkBoringStop, cont)
mkDupableCont env (Select _ case_bndr alts se cont)
= -- e.g. (case [...hole...] of { pi -> ei })
-- let ji = \xij -> ei
-- in case [...hole...] of { pi -> ji xij }
do { tick (CaseOfCase case_bndr)
- ; (env, dup_cont, nodup_cont) <- mkDupableCont env cont
+ ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont
-- NB: call mkDupableCont here, *not* prepareCaseCont
-- We must make a duplicable continuation, whereas prepareCaseCont
-- doesn't when there is a single case branch
- ; let alt_env = se `setInScope` env
- ; (alt_env, case_bndr') <- simplBinder alt_env case_bndr
- ; alts' <- mapM (simplAlt alt_env [] case_bndr' dup_cont) alts
+ ; let alt_env = se `setInScope` env'
+ ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
+ ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts
-- Safe to say that there are no handled-cons for the DEFAULT case
-- NB: simplBinder does not zap deadness occ-info, so
-- a dead case_bndr' will still advertise its deadness
-- NB: we don't use alt_env further; it has the substEnv for
-- the alternatives, and we don't want that
- ; (env, alts') <- mkDupableAlts env case_bndr' alts'
- ; return (env, -- Note [Duplicated env]
- Select OkToDup case_bndr' alts' (zapSubstEnv env)
- (mkBoringStop (contResultType dup_cont)),
+ ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
+ ; return (env'', -- Note [Duplicated env]
+ Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop,
nodup_cont) }
-> SimplM (SimplEnv, [InAlt])
-- Absorbs the continuation into the new alternatives
-mkDupableAlts env case_bndr' alts
- = go env alts
+mkDupableAlts env case_bndr' the_alts
+ = go env the_alts
where
- go env [] = return (env, [])
- go env (alt:alts)
- = do { (env, alt') <- mkDupableAlt env case_bndr' alt
- ; (env, alts') <- go env alts
- ; return (env, alt' : alts' ) }
-
+ go env0 [] = return (env0, [])
+ go env0 (alt:alts)
+ = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
+ ; (env2, alts') <- go env1 alts
+ ; return (env2, alt' : alts' ) }
+
+mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
+ -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
mkDupableAlt env case_bndr' (con, bndrs', rhs')
| exprIsDupable rhs' -- Note [Small alternative rhs]
= return (env, (con, bndrs', rhs'))
; (final_bndrs', final_args) -- Note [Join point abstraction]
<- if (any isId used_bndrs')
then return (used_bndrs', varsToCoreExprs used_bndrs')
- else do { rw_id <- newId FSLIT("w") realWorldStatePrimTy
+ else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy
; return ([rw_id], [Var realWorldPrimId]) }
- ; join_bndr <- newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty')
+ ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
-- Note [Funky mkPiTypes]
; let -- We make the lambdas into one-shot-lambdas. The
join_rhs = mkLams really_final_bndrs rhs'
join_call = mkApps (Var join_bndr) final_args
- ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) }
+ ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) }
-- See Note [Duplicated env]
\end{code}
When x is inlined into its full context, we find that it was a bad
idea to have pushed the outer case inside the (...) case.
+Note [Single-alternative-unlifted]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here's another single-alternative where we really want to do case-of-case:
+
+data Mk1 = Mk1 Int#
+data Mk1 = Mk2 Int#
+
+M1.f =
+ \r [x_s74 y_s6X]
+ case
+ case y_s6X of tpl_s7m {
+ M1.Mk1 ipv_s70 -> ipv_s70;
+ M1.Mk2 ipv_s72 -> ipv_s72;
+ }
+ of
+ wild_s7c
+ { __DEFAULT ->
+ case
+ case x_s74 of tpl_s7n {
+ M1.Mk1 ipv_s77 -> ipv_s77;
+ M1.Mk2 ipv_s79 -> ipv_s79;
+ }
+ of
+ wild1_s7b
+ { __DEFAULT -> ==# [wild1_s7b wild_s7c];
+ };
+ };
+
+So the outer case is doing *nothing at all*, other than serving as a
+join-point. In this case we really want to do case-of-case and decide
+whether to use a real join point or just duplicate the continuation.
+
+Hence: check whether the case binder's type is unlifted, because then
+the outer case is *not* a seq.
projects / ghc-hetmet.git / blobdiff