#include "HsVersions.h"
import CoreSyn
-import CoreUtils ( exprType, mkInlineMe )
+import CoreUtils ( exprType )
import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
isOneShotLambda, setOneShotLambda,
- mkWildId, setIdInfo
+ setIdInfo
)
-import IdInfo ( CprInfo(..), noCprInfo, vanillaIdInfo )
-import DataCon ( DataCon, splitProductType )
+import IdInfo ( CprInfo(..), vanillaIdInfo )
+import DataCon ( splitProductType )
import Demand ( Demand(..), wwLazy, wwPrim )
import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID )
import TysPrim ( realWorldStatePrimTy )
-import TysWiredIn ( unboxedTupleCon, unboxedTupleTyCon )
-import Type ( isUnLiftedType,
+import TysWiredIn ( tupleCon )
+import Type ( Type, isUnLiftedType,
splitForAllTys, splitFunTys, isAlgType,
- splitNewType_maybe,
- mkTyConApp, mkFunTys,
- Type
+ splitNewType_maybe, mkFunTys
)
-import TyCon ( isNewTyCon, isProductTyCon, TyCon )
-import BasicTypes ( NewOrData(..), Arity )
-import Var ( TyVar, Var, isId )
-import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs,
- mapUs, UniqSM )
-import Util ( zipWithEqual, zipEqual, lengthExceeds )
+import BasicTypes ( NewOrData(..), Arity, Boxity(..) )
+import Var ( Var, isId )
+import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, UniqSM )
+import Util ( zipWithEqual )
import Outputable
import List ( zipWith4 )
\end{code}
Id -> CoreExpr, -- Wrapper body, lacking only the worker Id
CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs
+-- wrap_fn_args E = \x y -> E
+-- work_fn_args E = E x y
+
+-- wrap_fn_str E = case x of { (a,b) ->
+-- case a of { (a1,a2) ->
+-- E a1 a2 b y }}
+-- work_fn_str E = \a2 a2 b y ->
+-- let a = (a1,a2) in
+-- let x = (a,b) in
+-- E
+
mkWwBodies fun_ty arity demands res_bot one_shots cpr_info
= mkWWargs fun_ty arity demands' res_bot one_shots' `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
- mkWWstr wrap_args `thenUs` \ (work_dmds, wrap_fn_str, work_fn_str) ->
mkWWcpr res_ty cpr_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) ->
- mkWWfixup cpr_res_ty work_dmds `thenUs` \ (final_work_dmds, wrap_fn_fixup, work_fn_fixup) ->
+ mkWWstr cpr_res_ty wrap_args `thenUs` \ (work_dmds, wrap_fn_str, work_fn_str) ->
- returnUs (final_work_dmds,
- Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . wrap_fn_fixup . Var,
- work_fn_fixup . work_fn_str . work_fn_cpr . work_fn_args)
+ returnUs (work_dmds,
+ Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . Var,
+ work_fn_str . work_fn_cpr . work_fn_args)
-- We use an INLINE unconditionally, even if the wrapper turns out to be
-- something trivial like
-- fw = ...
%************************************************************************
%* *
-\subsection{Fixup stuff}
-%* *
-%************************************************************************
-
-\begin{code}
-mkWWfixup res_ty work_dmds
- | null work_dmds && isUnLiftedType res_ty
- -- Horrid special case. If the worker would have no arguments, and the
- -- function returns a primitive type value, that would make the worker into
- -- an unboxed value. We box it by passing a dummy void argument, thus:
- --
- -- f = /\abc. \xyz. fw abc void
- -- fw = /\abc. \v. body
- --
- -- We use the state-token type which generates no code
- = getUniqueUs `thenUs` \ void_arg_uniq ->
- let
- void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
- in
- returnUs ([wwPrim],
- \ call_to_worker -> App call_to_worker (Var realWorldPrimId),
- \ worker_body -> Lam void_arg worker_body)
-
- | otherwise
- = returnUs (work_dmds, id, id)
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Strictness stuff}
%* *
%************************************************************************
\begin{code}
-mkWWstr :: [Var] -- Wrapper args; have their demand info on them
+mkWWstr :: Type -- Result type
+ -> [Var] -- Wrapper args; have their demand info on them
-- *Includes type variables*
-> UniqSM ([Demand], -- Demand on worker (value) args
CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
-- but *with* lambdas
-mkWWstr wrap_args
- = mk_ww_str wrap_args `thenUs` \ (work_args, wrap_fn, work_fn) ->
- returnUs ( [idDemandInfo v | v <- work_args, isId v],
- \ wrapper_body -> wrap_fn (mkVarApps wrapper_body work_args),
- \ worker_body -> mkLams work_args (work_fn worker_body))
+mkWWstr res_ty wrap_args
+ = mk_ww_str wrap_args `thenUs` \ (work_args, take_apart, put_together) ->
+ let
+ work_dmds = [idDemandInfo v | v <- work_args, isId v]
+ apply_to args fn = mkVarApps fn args
+ in
+ if not (null work_dmds && isUnLiftedType res_ty) then
+ returnUs ( work_dmds,
+ take_apart . apply_to work_args,
+ mkLams work_args . put_together)
+ else
+ -- Horrid special case. If the worker would have no arguments, and the
+ -- function returns a primitive type value, that would make the worker into
+ -- an unboxed value. We box it by passing a dummy void argument, thus:
+ --
+ -- f = /\abc. \xyz. fw abc void
+ -- fw = /\abc. \v. body
+ --
+ -- We use the state-token type which generates no code
+ getUniqueUs `thenUs` \ void_arg_uniq ->
+ let
+ void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
+ in
+ returnUs ([wwPrim],
+ take_apart . apply_to [realWorldPrimId] . apply_to work_args,
+ mkLams work_args . Lam void_arg . put_together)
-- Empty case
mk_ww_str []
work_wild = mk_ww_local work_uniq body_ty
arg = mk_ww_local arg_uniq con_arg_ty1
in
- returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], mkConApp data_con (map Type tycon_arg_tys ++ [Var arg]))],
- \ body -> Case body work_wild [(DataAlt data_con, [arg], Var arg)],
+ returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], mkConApp data_con (map Type tycon_arg_tys ++ [Var arg]))],
+ \ body -> workerCase body work_wild [(DataAlt data_con, [arg], Var arg)],
con_arg_ty1)
| otherwise -- The general case
let
(wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
arg_vars = map Var args
- ubx_tup_con = unboxedTupleCon n_con_args
+ ubx_tup_con = tupleCon Unboxed 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 = mkConApp data_con (map Type tycon_arg_tys ++ arg_vars)
in
returnUs (\ wkr_call -> Case wkr_call wrap_wild [(DataAlt ubx_tup_con, args, con_app)],
- \ body -> Case body work_wild [(DataAlt data_con, args, ubx_tup_app)],
+ \ body -> workerCase body work_wild [(DataAlt data_con, args, ubx_tup_app)],
ubx_tup_ty)
where
- (tycon, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty
+ (_, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "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
+
+workerCase (Note (SCC cc) e) arg alts = Note (SCC cc) (Case e arg alts)
+workerCase e arg alts = Case e arg alts
\end{code}
projects / ghc-hetmet.git / blobdiff