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}
Note [Profiling and unpacking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.
%************************************************************************
%* *
......
......@@ -36,9 +36,10 @@ module Coercion (
mkNewTypeCo,
-- ** Decomposition
splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
getCoVar_maybe,