diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/basicTypes/Id.hs | 9 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreOpt.hs | 51 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreUtils.hs | 1 |
3 files changed, 57 insertions, 4 deletions
diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index 01b648ee89..199842ceb1 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -66,7 +66,9 @@ module Id ( isClassOpId_maybe, isDFunId, isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, - isDataConWorkId, isDataConWorkId_maybe, isDataConWrapId, isDataConId_maybe, + isDataConWorkId, isDataConWorkId_maybe, + isDataConWrapId, isDataConWrapId_maybe, + isDataConId_maybe, idDataCon, isConLikeId, isBottomingId, idIsFrom, hasNoBinding, @@ -427,6 +429,7 @@ isClassOpId_maybe :: Id -> Maybe Class isPrimOpId_maybe :: Id -> Maybe PrimOp isFCallId_maybe :: Id -> Maybe ForeignCall isDataConWorkId_maybe :: Id -> Maybe DataCon +isDataConWrapId_maybe :: Id -> Maybe DataCon isRecordSelector id = case Var.idDetails id of RecSelId {} -> True @@ -480,6 +483,10 @@ isDataConWrapId id = case Var.idDetails id of DataConWrapId _ -> True _ -> False +isDataConWrapId_maybe id = case Var.idDetails id of + DataConWrapId con -> Just con + _ -> Nothing + isDataConId_maybe :: Id -> Maybe DataCon isDataConId_maybe id = case Var.idDetails id of DataConWorkId con -> Just con diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs index 9849eb36db..29f8ab2c3c 100644 --- a/compiler/coreSyn/CoreOpt.hs +++ b/compiler/coreSyn/CoreOpt.hs @@ -28,7 +28,7 @@ import CoreSyn import CoreSubst import CoreUtils import CoreFVs -import MkCore ( FloatBind(..) ) +import MkCore ( FloatBind(..), mkCoreLet ) import PprCore ( pprCoreBindings, pprRules ) import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) import Literal ( Literal(LitString) ) @@ -42,7 +42,7 @@ import OptCoercion ( optCoercion ) import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) import Coercion hiding ( substCo, substCoVarBndr ) -import TyCon ( tyConArity ) +import TyCon ( tyConArity, isNewTyCon ) import TysWiredIn import PrelNames import BasicTypes @@ -819,6 +819,40 @@ Is transformed into Which, effectively, means emitting a float `let x = arg` and recursively analysing the body. +This strategy requires a special case for newtypes. Suppose we have + newtype T a b where + MkT :: a -> T b a -- Note args swapped + +This defines a worker function MkT, a wrapper function $WMkT, and an axT: + $WMkT :: forall a b. a -> T b a + $WMkT = /\b a. \(x:a). MkT a b x -- A real binding + + MkT :: forall a b. a -> T a b + MkT = /\a b. \(x:a). x |> (ax a b) -- A compulsory unfolding + + axiom axT :: a ~R# T a b + +Now we are optimising + case $WMkT (I# 3) |> sym axT of I# y -> ... +we clearly want to simplify this. The danger is that we'll end up with + let a = I#3 in case a of I# y -> ... +because in general, we do this on-the-fly beta-reduction + (\x. e) blah --> let x = blah in e +and then float the the let. (Substitution would risk duplicating 'blah'.) + +But if the case-of-known-constructor doesn't actually fire (i.e. +exprIsConApp_maybe does not return Just) then nothing happens, and nothing +will happen the next time either. + +For newtype wrappers we know for sure that the argument of the beta-redex +is used exactly once, so we can substitute aggressively rather than use a let. +Hence the special case, implemented in dealWithNewtypeWrapper. +(It's sound for any beta-redex where the argument is used once, of course.) + +dealWithNewtypeWrapper is recursive since newtypes can have +multiple type arguments. + +See test T16254, which checks the behavior of newtypes. -} data ConCont = CC [CoreExpr] Coercion @@ -861,7 +895,9 @@ exprIsConApp_maybe (in_scope, id_unf) expr go subst floats (Lam var body) (CC (arg:args) co) | exprIsTrivial arg -- Don't duplicate stuff! = go (extend subst var arg) floats body (CC args co) - go subst floats (Let bndr@(NonRec b _) expr) cont + go subst floats (Lam var body) (CC (arg:args) co) + = go subst floats (mkCoreLet (NonRec var arg) body) (CC args co) + go subst floats (Let bndr@(NonRec _ _) expr) cont = let (subst', bndr') = subst_bind subst bndr in go subst' (FloatLet bndr' : floats) expr cont go subst floats (Case scrut b _ [(con, vars, expr)]) cont @@ -882,6 +918,12 @@ exprIsConApp_maybe (in_scope, id_unf) expr , count isValArg args == idArity fun = pushFloats floats $ pushCoDataCon con args co + -- See Note [beta-reduction in exprIsConApp_maybe] + | Just a <- isDataConWrapId_maybe fun + , isNewTyCon (dataConTyCon a) + , let rhs = uf_tmpl (realIdUnfolding fun) + = dealWithNewtypeWrapper (Left in_scope) floats rhs cont + -- Look through data constructor wrappers: they inline late (See Note -- [Activation for data constructor wrappers]) but we want to do -- case-of-known-constructor optimisation eagerly. @@ -922,6 +964,9 @@ exprIsConApp_maybe (in_scope, id_unf) expr (c, tys, args) <- x return (floats, c, tys, args) + dealWithNewtypeWrapper scope floats (Lam v body) (CC (arg:args) co) = + dealWithNewtypeWrapper (extend scope v arg) floats body (CC args co) + dealWithNewtypeWrapper scope floats expr args = go scope floats expr args ---------------------------- -- Operations on the (Either InScopeSet CoreSubst) -- The Left case is wildly dominant diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 9c425e72f0..8443b3be2f 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -1360,6 +1360,7 @@ isExpandableApp fn n_val_args | otherwise = case idDetails fn of DataConWorkId {} -> True -- Actually handled by isWorkFreeApp + DataConWrapId {} -> True -- See Note [beta-reduction in exprIsConApp_maybe] RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId {} -> False |