Commit d3b8991b authored by Simon Peyton Jones's avatar Simon Peyton Jones

Introduce CPR for sum types (Trac #5075)

The main payload of this patch is to extend CPR so that it
detects when a function always returns a result constructed
with the *same* constructor, even if the constructor comes from
a sum type.  This doesn't matter very often, but it does improve
some things (results below).

Binary sizes increase a little bit, I think because there are more
wrappers.  This with -split-objs.  Without split-ojbs binary sizes
increased by 6% even for HelloWorld.hs.  It's hard to see exactly why,
but I think it was because System.Posix.Types.o got included in the
linked binary, whereas it didn't before.

        Program           Size    Allocs   Runtime   Elapsed  TotalMem
          fluid          +1.8%     -0.3%      0.01      0.01     +0.0%
            tak          +2.2%     -0.2%      0.02      0.02     +0.0%
           ansi          +1.7%     -0.3%      0.00      0.00     +0.0%
      cacheprof          +1.6%     -0.3%     +0.6%     +0.5%     +1.4%
        parstof          +1.4%     -4.4%      0.00      0.00     +0.0%
        reptile          +2.0%     +0.3%      0.02      0.02     +0.0%
----------------------------------------------------------------------
            Min          +1.1%     -4.4%     -4.7%     -4.7%    -15.0%
            Max          +2.3%     +0.3%     +8.3%     +9.4%    +50.0%
 Geometric Mean          +1.9%     -0.1%     +0.6%     +0.7%     +0.3%

Other things in this commit
~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Got rid of the Lattice class in Demand

* Refactored the way that products and newtypes are
  decomposed (no change in functionality)
parent b4e86fa8
......@@ -26,6 +26,8 @@ types that
module BasicTypes(
Version, bumpVersion, initialVersion,
ConTag, fIRST_TAG,
Arity, RepArity,
Alignment,
......@@ -111,6 +113,21 @@ type Arity = Int
type RepArity = Int
\end{code}
%************************************************************************
%* *
Constructor tags
%* *
%************************************************************************
\begin{code}
-- | Type of the tags associated with each constructor possibility
type ConTag = Int
fIRST_TAG :: ConTag
-- ^ Tags are allocated from here for real constructors
fIRST_TAG = 1
\end{code}
%************************************************************************
%* *
\subsection[Alignment]{Alignment}
......
......@@ -41,9 +41,6 @@ module DataCon (
isVanillaDataCon, classDataCon, dataConCannotMatch,
isBanged, isMarkedStrict, eqHsBang,
-- * Splitting product types
splitProductType_maybe, splitProductType,
-- ** Promotion related functions
isPromotableTyCon, promoteTyCon,
promoteDataCon, promoteDataCon_maybe
......@@ -461,13 +458,6 @@ data HsBang
-- StrictnessMark is internal only, used to indicate strictness
-- of the DataCon *worker* fields
data StrictnessMark = MarkedStrict | NotMarkedStrict
-- | Type of the tags associated with each constructor possibility
type ConTag = Int
fIRST_TAG :: ConTag
-- ^ Tags are allocated from here for real constructors
fIRST_TAG = 1
\end{code}
Note [Data con representation]
......@@ -993,56 +983,6 @@ dataConCannotMatch tys con
_ -> []
\end{code}
%************************************************************************
%* *
\subsection{Splitting products}
%* *
%************************************************************************
\begin{code}
-- | Extract the type constructor, type argument, data constructor and it's
-- /representation/ argument types from a type if it is a product type.
--
-- Precisely, we return @Just@ for any type that is all of:
--
-- * Concrete (i.e. constructors visible)
--
-- * Single-constructor
--
-- * Not existentially quantified
--
-- Whether the type is a @data@ type or a @newtype@
splitProductType_maybe
:: Type -- ^ A product type, perhaps
-> Maybe (TyCon, -- The type constructor
[Type], -- Type args of the tycon
DataCon, -- The data constructor
[Type]) -- Its /representation/ arg types
-- Rejecing existentials is conservative. Maybe some things
-- could be made to work with them, but I'm not going to sweat
-- it through till someone finds it's important.
splitProductType_maybe ty
= case splitTyConApp_maybe ty of
Just (tycon,ty_args)
| isProductTyCon tycon -- Includes check for non-existential,
-- and for constructors visible
-> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args)
where
data_con = ASSERT( not (null (tyConDataCons tycon)) )
head (tyConDataCons tycon)
_other -> Nothing
-- | As 'splitProductType_maybe', but panics if the 'Type' is not a product type
splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
splitProductType str ty
= case splitProductType_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
\end{code}
%************************************************************************
%* *
Promoting of data types to the kind level
......
This diff is collapsed.
......@@ -425,16 +425,17 @@ mkDataConWorkId wkr_name data_con
dataConCPR :: DataCon -> DmdResult
dataConCPR con
| isProductTyCon tycon
, isDataTyCon tycon
| isDataTyCon tycon -- Real data types only; that is,
-- not unboxed tuples or newtypes
, isVanillaDataCon con -- No existentials
, wkr_arity > 0
, wkr_arity <= mAX_CPR_SIZE
= cprRes
= if is_prod then cprProdRes
else cprSumRes (dataConTag con)
| otherwise
= topRes
-- RetCPR is only true for products that are real data types;
-- that is, not unboxed tuples or [non-recursive] newtypes
where
is_prod = isProductTyCon tycon
tycon = dataConTyCon con
wkr_arity = dataConRepArity con
......
......@@ -107,7 +107,6 @@ module CLabel (
import IdInfo
import BasicTypes
import Packages
import DataCon
import Module
import Name
import Unique
......
......@@ -1303,12 +1303,12 @@ mkKindErrMsg tyvar arg_ty
mkArityMsg :: Id -> MsgDoc
mkArityMsg binder
= vcat [hsep [ptext (sLit "Demand type has "),
ppr (dmdTypeDepth dmd_ty),
ptext (sLit " arguments, rhs has "),
ppr (idArity binder),
ptext (sLit "arguments, "),
ppr binder],
= vcat [hsep [ptext (sLit "Demand type has"),
ppr (dmdTypeDepth dmd_ty),
ptext (sLit "arguments, rhs has"),
ppr (idArity binder),
ptext (sLit "arguments,"),
ppr binder],
hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
]
......
......@@ -31,7 +31,7 @@ module CoreSyn (
mkFloatLit, mkFloatLitFloat,
mkDoubleLit, mkDoubleLitDouble,
mkConApp, mkTyBind, mkCoBind,
mkConApp, mkConApp2, mkTyBind, mkCoBind,
varToCoreExpr, varsToCoreExprs,
isId, cmpAltCon, cmpAlt, ltAlt,
......@@ -1133,6 +1133,11 @@ mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args
mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
mkConApp con args = mkApps (Var (dataConWorkId con)) args
mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b
mkConApp2 con tys arg_ids = Var (dataConWorkId con)
`mkApps` map Type tys
`mkApps` map varToCoreExpr arg_ids
-- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
......
......@@ -19,6 +19,7 @@ module DsCCall
, unboxArg
, boxResult
, resultWrapper
, splitDataProductType_maybe
) where
#include "HsVersions.h"
......@@ -191,7 +192,7 @@ unboxArg arg
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
maybe_product_type = splitProductType_maybe arg_ty
maybe_product_type = splitDataProductType_maybe arg_ty
is_product_type = maybeToBool maybe_product_type
Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
data_con_arity = dataConSourceArity data_con
......@@ -357,7 +358,7 @@ resultWrapper result_ty
-- Data types with a single constructor, which has a single arg
-- This includes types like Ptr and ForeignPtr
| Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
| Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty,
dataConSourceArity data_con == 1
= do dflags <- getDynFlags
let
......@@ -391,3 +392,43 @@ maybeNarrow dflags tycon
&& wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
| otherwise = id
\end{code}
%************************************************************************
%* *
\subsection{Splitting products}
%* *
%************************************************************************
\begin{code}
-- | Extract the type constructor, type argument, data constructor and it's
-- /representation/ argument types from a type if it is a product type.
--
-- Precisely, we return @Just@ for any type that is all of:
--
-- * Concrete (i.e. constructors visible)
--
-- * Single-constructor
--
-- * Not existentially quantified
--
-- Whether the type is a @data@ type or a @newtype@
splitDataProductType_maybe
:: Type -- ^ A product type, perhaps
-> Maybe (TyCon, -- The type constructor
[Type], -- Type args of the tycon
DataCon, -- The data constructor
[Type]) -- Its /representation/ arg types
-- Rejecing existentials is conservative. Maybe some things
-- could be made to work with them, but I'm not going to sweat
-- it through till someone finds it's important.
splitDataProductType_maybe ty
| Just (tycon, ty_args) <- splitTyConApp_maybe ty
, Just con <- isDataProductTyCon_maybe tycon
= Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
| otherwise
= Nothing
\end{code}
......@@ -766,7 +766,7 @@ getPrimTyOf ty
-- Except for Bool, the types we are interested in have a single constructor
-- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
| otherwise =
case splitProductType_maybe rep_ty of
case splitDataProductType_maybe rep_ty of
Just (_, _, data_con, [prim_ty]) ->
ASSERT(dataConSourceArity data_con == 1)
ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
......
......@@ -31,7 +31,7 @@ import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn
import TysPrim
import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId )
import CoreUtils ( cheapEqExpr, exprIsHNF )
import CoreUnfold ( exprIsConApp_maybe )
import Type
......
......@@ -2037,7 +2037,7 @@ simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
-- Bind the case-binder to (con args)
; let inst_tys' = tyConAppArgs (idType case_bndr')
con_app :: OutExpr
con_app = mkConApp con (map Type inst_tys' ++ varsToCoreExprs vs')
con_app = mkConApp2 con inst_tys' vs'
; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app
; rhs' <- simplExprC env'' rhs cont'
......@@ -2384,8 +2384,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do
where
-- See Note [Case binders and join points]
unf = mkInlineUnfolding Nothing rhs
rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
++ varsToCoreExprs bndrs')
rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
<+> ppr case_bndr <+> ppr con )
......
......@@ -1435,7 +1435,7 @@ calcSpecStrictness fn qvars pats
go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
go_one env d (Var v) = extendVarEnv_C bothDmd env v d
go_one env d e
| Just ds <- splitProdDmd_maybe d
| Just ds <- splitProdDmd_maybe d -- NB: d does not have to be strict
, (Var _, args) <- collectArgs e = go env ds args
go_one env _ _ = env
\end{code}
......
......@@ -221,14 +221,14 @@ dmdAnal dflags env dmd (Lam var body)
dmdAnal dflags env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
-- Only one alternative with a product constructor
| let tycon = dataConTyCon dc
, isProductTyCon tycon
, isProductTyCon tycon
, not (isRecursiveTyCon tycon)
= let
env_alt = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig
(alt_ty, alt') = dmdAnalAlt dflags env_alt dmd alt
(alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
(_, bndrs', _) = alt'
case_bndr_sig = cprSig
case_bndr_sig = cprProdSig
-- Inside the alternative, the case binder has the CPR property.
-- Meaning that a case on it will successfully cancel.
-- Example:
......@@ -621,9 +621,11 @@ mkSigTy top_lvl rec_flag env id rhs (DmdType fv dmds res)
strict_fv = filterUFM isStrictDmd fv
ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)
res' = if returnsCPR res && ignore_cpr_info
then topRes
else res
res' | returnsCPR res
, not (isTopLevel top_lvl || returnsCPRProd res)
-- See Note [CPR for sum types ]
|| ignore_cpr_info = topRes
| otherwise = res
-- Is it okay or not to assign CPR
-- (not okay in the first pass)
......@@ -637,6 +639,32 @@ mkSigTy top_lvl rec_flag env id rhs (DmdType fv dmds res)
| otherwise = False
\end{code}
Note [CPR for sum types]
~~~~~~~~~~~~~~~~~~~~~~~~
At the moment we do not do CPR for let-bindings that
* non-top level
* bind a sum type
Reason: I found that in some benchmarks we were losing let-no-escapes,
which messed it all up. Example
let j = \x. ....
in case y of
True -> j False
False -> j True
If we w/w this we get
let j' = \x. ....
in case y of
True -> case j False of { (# a #) -> Just a }
True -> case j True of { (# a #) -> Just a }
Notice that j' is not a let-no-escape any more.
However this means in turn that the *enclosing* function
may be CPR'd (via the returned Justs). But in the case of
sums, there may be Nothing alterantives; and that messes
up the sum-type CPR.
Conclusion: only do this for products. It's still not
guaranteed OK for products, but sums definitely lose sometimes.
Note [CPR for thunks]
~~~~~~~~~~~~~~~~~~~~~
If the rhs is a thunk, we usually forget the CPR info, because
......@@ -867,13 +895,11 @@ nonVirgin sigs = AE { ae_sigs = sigs, ae_virgin = False }
extendSigsWithLam :: AnalEnv -> Id -> AnalEnv
-- Extend the AnalEnv when we meet a lambda binder
extendSigsWithLam env id
| ae_virgin env -- See Note [Optimistic CPR in the "virgin" case]
= extendAnalEnv NotTopLevel env id cprSig
| isStrictDmd dmd_info -- Might be bottom, first time round
, Just {} <- deepSplitProductType_maybe $ idType id
= extendAnalEnv NotTopLevel env id cprSig
| isStrictDmd dmd_info || ae_virgin env
-- See Note [Optimistic CPR in the "virgin" case]
-- See Note [Initial CPR for strict binders]
, Just {} <- deepSplitProductType_maybe $ idType id
= extendAnalEnv NotTopLevel env id cprProdSig
| otherwise = env
where
......@@ -882,7 +908,6 @@ extendSigsWithLam env id
Note [Initial CPR for strict binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CPR is initialized for a lambda binder in an optimistic manner, i.e,
if the binder is used strictly and at least some of its components as
a product are used, which is checked by the value of the absence
......
......@@ -16,26 +16,26 @@ module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs, deepSplitProductType_maybe ) w
#include "HsVersions.h"
import CoreSyn
import CoreUtils ( exprType )
import CoreUtils ( exprType, mkCast )
import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
isOneShotLambda, setOneShotLambda, setIdUnfolding,
setIdInfo, setIdType
setIdInfo
)
import IdInfo ( vanillaIdInfo )
import DataCon
import Demand
import MkCore ( mkRuntimeErrorApp, aBSENT_ERROR_ID )
import MkId ( realWorldPrimId, voidArgId
, wrapNewTypeBody, unwrapNewTypeBody )
import MkId ( realWorldPrimId, voidArgId )
import TysPrim ( realWorldStatePrimTy )
import TysWiredIn ( tupleCon )
import Type
import Coercion ( mkSymCo, instNewTyCon_maybe, splitNewTypeRepCo_maybe )
import Coercion hiding ( substTy, substTyVarBndr )
import BasicTypes ( TupleSort(..) )
import Literal ( absentLiteralOf )
import TyCon
import UniqSupply
import Unique
import Maybes
import Util
import Outputable
import DynFlags
......@@ -424,15 +424,16 @@ mkWWstr_one dflags arg
-- Unpack case,
-- see note [Unpacking arguments with product and polymorphic demands]
| isStrictDmd dmd
, Just (_arg_tycon, _tycon_arg_tys, data_con, inst_con_arg_tys)
, Just cs <- splitProdDmd_maybe dmd
, Just (data_con, inst_tys, inst_con_arg_tys, co)
<- deepSplitProductType_maybe (idType arg)
= do { uniqs <- getUniquesM
; let cs = splitProdDmd (length inst_con_arg_tys) dmd
unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
= do { (uniq1:uniqs) <- getUniquesM
; let unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs
unbox_fn = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con
unbox_fn = mkUnpackCase (Var arg `mkCast` co) uniq1
data_con unpk_args
rebox_fn = Let (NonRec arg con_app)
con_app = mkProductBox unpk_args (idType arg)
con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
; (worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
; return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
-- Don't pass the arg, rebox instead
......@@ -456,57 +457,25 @@ nop_fn body = body
\end{code}
\begin{code}
mkUnpackCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
-- (mkUnpackCase x e args Con body)
-- returns
-- case (e `cast` ...) of bndr { Con args -> body }
--
-- the type of the bndr passed in is irrelevent
mkUnpackCase bndr arg unpk_args boxing_con body
= Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
where
(cast_arg, bndr_ty) = go (idType bndr) arg
go ty arg
| (tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty
, isNewTyCon tycon && not (isRecursiveTyCon tycon)
= go (newTyConInstRhs tycon tycon_args)
(unwrapNewTypeBody tycon tycon_args arg)
| otherwise = (arg, ty)
mkProductBox :: [Id] -> Type -> CoreExpr
mkProductBox arg_ids ty
= result_expr
where
(tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty
result_expr
| isNewTyCon tycon && not (isRecursiveTyCon tycon)
= wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args))
| otherwise = mkConApp pack_con (map Type tycon_args ++ varsToCoreExprs arg_ids)
wrap expr = wrapNewTypeBody tycon tycon_args expr
-- | As 'splitProductType_maybe', but in turn instantiates the 'TyCon' returned
-- and hence recursively tries to unpack it as far as it able to
deepSplitProductType_maybe :: Type -> Maybe (TyCon, [Type], DataCon, [Type])
deepSplitProductType_maybe :: Type -> Maybe (DataCon, [Type], [Type], Coercion)
-- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
-- then dc @ tys (args::arg_tys) |> co :: ty
deepSplitProductType_maybe ty
= do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
; let {result
| Just (ty', _co) <- instNewTyCon_maybe tycon tycon_args
, not (isRecursiveTyCon tycon)
= deepSplitProductType_maybe ty' -- Ignore the coercion?
| isNewTyCon tycon = Nothing -- cannot unbox through recursive
-- newtypes nor through families
| otherwise = Just res}
; result
}
-- | As 'deepSplitProductType_maybe', but panics if the 'Type' is not a product type
deepSplitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
deepSplitProductType str ty
= case deepSplitProductType_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
| let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo ty)
, Just (tc, tc_args) <- splitTyConApp_maybe ty1
, Just con <- isDataProductTyCon_maybe tc
= Just (con, tc_args, dataConInstArgTys con tc_args, co)
deepSplitProductType_maybe _ = Nothing
deepSplitCprType_maybe :: ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
deepSplitCprType_maybe con_tag ty
| let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo ty)
, Just (tc, tc_args) <- splitTyConApp_maybe ty1
, isDataTyCon tc
, let cons = tyConDataCons tc
con = ASSERT( cons `lengthAtLeast` con_tag ) cons !! (con_tag - fIRST_TAG)
= Just (con, tc_args, dataConInstArgTys con tc_args, co)
deepSplitCprType_maybe _ _ = Nothing
\end{code}
......@@ -534,72 +503,79 @@ mkWWcpr :: Type -- function body type
Type) -- Type of worker's body
mkWWcpr body_ty res
| not (returnsCPR res) -- No CPR info
= return (id, id, body_ty)
| not (isClosedAlgType body_ty)
= WARN( True,
text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
return (id, id, body_ty)
| n_con_args == 1 && isUnLiftedType con_arg_ty1 = do
= case returnsCPR_maybe res of
Nothing -> return (id, id, body_ty) -- No CPR info
Just con_tag | Just stuff <- deepSplitCprType_maybe con_tag body_ty
-> mkWWcpr_help stuff
| otherwise
-> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
return (id, id, body_ty)
mkWWcpr_help :: (DataCon, [Type], [Type], Coercion)
-> UniqSM (CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWcpr_help (data_con, inst_tys, arg_tys, co)
| [arg_ty1] <- arg_tys
, isUnLiftedType arg_ty1
-- Special case when there is a single result of unlifted type
--
-- Wrapper: case (..call worker..) of x -> C x
-- Worker: case ( ..body.. ) of C x -> x
(work_uniq : arg_uniq : _) <- getUniquesM
let
work_wild = mk_ww_local work_uniq body_ty
arg = mk_ww_local arg_uniq con_arg_ty1
con_app = mkProductBox [arg] body_ty
= do { (work_uniq : arg_uniq : _) <- getUniquesM
; let arg = mk_ww_local arg_uniq arg_ty1
con_app = mkConApp2 data_con inst_tys [arg] `mkCast` co
return (\ wkr_call -> Case wkr_call (arg) (exprType con_app) [(DEFAULT, [], con_app)],
\ body -> workerCase (work_wild) body [arg] data_con (Var arg),
con_arg_ty1)
; return ( \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
, \ body -> mkUnpackCase body work_uniq data_con [arg] (Var arg)
, arg_ty1 ) }
| otherwise = do -- The general case
| otherwise -- The general case
-- Wrapper: case (..call worker..) of (# a, b #) -> C a b
-- Worker: case ( ...body... ) of C a b -> (# a, b #)
uniqs <- getUniquesM
let
(wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
arg_vars = varsToCoreExprs args
ubx_tup_con = tupleCon UnboxedTuple n_con_args
ubx_tup_ty = exprType ubx_tup_app
ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars)
con_app = mkProductBox args body_ty
return (\ wkr_call -> Case wkr_call (wrap_wild) (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)],
\ body -> workerCase (work_wild) body args data_con ubx_tup_app,
ubx_tup_ty)
where
(_arg_tycon, _tycon_arg_tys, data_con, con_arg_tys) = deepSplitProductType "mkWWcpr" body_ty
n_con_args = length con_arg_tys
con_arg_ty1 = head con_arg_tys
-- If the original function looked like
-- f = \ x -> _scc_ "foo" E
--
-- then we want the CPR'd worker to look like
-- \ x -> _scc_ "foo" (case E of I# x -> x)
-- and definitely not
-- \ x -> case (_scc_ "foo" E) of I# x -> x)
--
-- This transform doesn't move work or allocation
-- from one cost centre to another.
--
-- Later [SDM]: presumably this is because we want the simplifier to
-- eliminate the case, and the scc would get in the way? I'm ok with
-- including the case itself in the cost centre, since it is morally
-- part of the function (post transformation) anyway.
workerCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
workerCase bndr (Tick tickish e) args con body
= Tick tickish (mkUnpackCase bndr e args con body)
workerCase bndr e args con body
= mkUnpackCase bndr e args con body
= do { (work_uniq : uniqs) <- getUniquesM
; let (wrap_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : arg_tys)
ubx_tup_con = tupleCon UnboxedTuple (length arg_tys)
ubx_tup_ty = exprType ubx_tup_app
ubx_tup_app = mkConApp2 ubx_tup_con arg_tys args
con_app = mkConApp2 data_con inst_tys args `mkCast` co
; return ( \ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)]
, \ body -> mkUnpackCase body work_uniq data_con args ubx_tup_app
, ubx_tup_ty ) }
mkUnpackCase :: CoreExpr -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
-- (mkUnpackCase e bndr Con args body)
-- returns
-- case e of bndr { Con args -> body }
--
-- the type of the bndr passed in is irrelevent
mkUnpackCase (Tick tickish e) uniq con args body -- See Note [Profiling and unpacking]
= Tick tickish (mkUnpackCase e uniq con args body)
mkUnpackCase scrut uniq boxing_con unpk_args body
= Case scrut
(mk_ww_local uniq (exprType scrut)) (exprType body)
[(DataAlt boxing_con, unpk_args, body)]
\end{code}