import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons,
callSiteInline
)
-import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, exprIsConApp_maybe,
+import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial,
+ exprIsConApp_maybe, mkPiType,
exprType, coreAltsType, exprIsValue, idAppIsCheap,
exprOkForSpeculation,
mkCoerce, mkSCC, mkInlineMe, mkAltExpr
import Rules ( lookupRule )
import CostCentre ( currentCCS )
import Type ( mkTyVarTys, isUnLiftedType, seqType,
- mkFunTy, splitTyConApp_maybe,
+ mkFunTy, splitTyConApp_maybe, tyConAppArgs,
funResultTy
)
import Subst ( mkSubst, substTy,
Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont
where
- -- We don't use CoreUtils.etaReduceExpr, because we can be more
+ -- We don't use CoreUtils.etaReduce, because we can be more
-- efficient here: (a) we already have the binders, (b) we can do
-- the triviality test before computing the free vars
try_eta body | not opt_SimplDoEtaReduction = Nothing
simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
= mapSmpl simpl_alt alts
where
- inst_tys' = case splitTyConApp_maybe (idType case_bndr') of
- Just (tycon, inst_tys) -> inst_tys
+ inst_tys' = tyConAppArgs (idType case_bndr')
-- handled_cons is all the constructors that are dealt
-- with, either by being impossible, or by there being an alternative
`thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
- newId SLIT("$j") (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
-
- -- Notice that we make the lambdas into one-shot-lambdas. The
+ newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') $ \ join_bndr ->
+ -- Notice the funky mkPiType. If the contructor has existentials
+ -- it's possible that the join point will be abstracted over
+ -- type varaibles as well as term variables.
+ -- Example: Suppose we have
+ -- data T = forall t. C [t]
+ -- Then faced with
+ -- case (case e of ...) of
+ -- C t xs::[t] -> rhs
+ -- We get the join point
+ -- let j :: forall t. [t] -> ...
+ -- j = /\t \xs::[t] -> rhs
+ -- in
+ -- case (case e of ...) of
+ -- C t xs::[t] -> j t xs
+
+ let
+ -- We make the lambdas into one-shot-lambdas. The
-- join point is sure to be applied at most once, and doing so
-- prevents the body of the join point being floated out by
-- the full laziness pass
- returnSmpl ([NonRec join_bndr (mkLams (map setOneShotLambda final_bndrs') rhs')],
+ really_final_bndrs = map one_shot final_bndrs'
+ one_shot v | isId v = setOneShotLambda v
+ | otherwise = v
+ in
+ returnSmpl ([NonRec join_bndr (mkLams really_final_bndrs rhs')],
(con, bndrs, mkApps (Var join_bndr) final_args))
\end{code}