diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs
index e99864ffdb61ba84a2b65138fbd99c7536779a07..7cf43ca97ce40703f8e37a83e3e1fce055d20cf5 100644
--- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs
+++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs
@@ -379,9 +379,10 @@ splitFunTysIgnoringNewTypes ty = split ty
(args, res) = splitFunTys ty
-- Is this the constructor for a product type (i.e. algebraic, single constructor)
+-- NB: isProductTyCon replies 'False' for unboxed tuples
isConProdType :: Con -> Bool
-isConProdType (DataCon con) = isProductTyCon tycon && not (isUnLiftedTyCon tycon)
- where
+isConProdType (DataCon con) = isProductTyCon tycon
+ where
tycon = dataConTyCon con
isConProdType _ = False
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index c739cc9ab17ef863424bd81221d1b23e38f028c8..b8cf54cf515cd4aa2fb522966f1e4bc758acf91f 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -19,7 +19,7 @@ import Id ( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo,
)
import IdInfo ( CprInfo(..), noCprInfo, vanillaIdInfo )
import Const ( Con(..), DataCon )
-import DataCon ( splitProductType_maybe )
+import DataCon ( splitProductType_maybe, isExistentialDataCon, dataConArgTys )
import Demand ( Demand(..) )
import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID )
import TysPrim ( realWorldStatePrimTy )
@@ -30,8 +30,7 @@ import Type ( isUnLiftedType, mkTyVarTys, mkTyVarTy, mkFunTys,
mkTyConApp, splitNewType_maybe,
Type
)
-import TyCon ( isNewTyCon,
- TyCon )
+import TyCon ( isNewTyCon, isProductTyCon, TyCon )
import BasicTypes ( NewOrData(..) )
import Var ( TyVar )
import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs,
@@ -264,34 +263,36 @@ mkWrapper fun_ty arity demands cpr_info
@mkWwBodies@ is called when doing the worker/wrapper split inside a module.
\begin{code}
-mkWwBodies :: [TyVar] -> [Id] -> Type -- Original fn args and body type
+mkWwBodies :: [TyVar] -> [Id] -- Original fn args
+ -> Type -- Type of result of original function
-> [Demand] -- Strictness info for original fn; corresp 1-1 with args
-> CprInfo -- Result of CPR analysis
-> UniqSM (Id -> CoreExpr, -- Wrapper body, lacking only the worker Id
CoreExpr -> CoreExpr, -- Worker body, lacking the original function body
[Demand]) -- Strictness info for worker
-mkWwBodies tyvars wrap_args body_ty demands cpr_info
+mkWwBodies tyvars wrap_args res_ty demands cpr_info
= let
-- demands may be longer than number of args. If we aren't doing w/w
-- for strictness then demands is an infinite list of 'lazy' args.
wrap_args_w_demands = zipWith setIdDemandInfo wrap_args demands
- (wrap_fn_coerce, work_fn_coerce) = mkWWcoerce body_ty
+
in
- mkWWstr body_ty wrap_args_w_demands `thenUs` \ (work_args_w_demands, wrap_fn_str, work_fn_str) ->
-
- mkWWcpr body_ty cpr_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr) ->
+ mkWWstr wrap_args_w_demands `thenUs` \ (wrap_fn_str, work_fn_str, work_arg_dmds) ->
+ mkWWcoerce res_ty `thenUs` \ (wrap_fn_coerce, work_fn_coerce, coerce_res_ty) ->
+ mkWWcpr coerce_res_ty cpr_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) ->
+ mkWWfixup cpr_res_ty (null work_arg_dmds) `thenUs` \ (wrap_fn_fixup, work_fn_fixup) ->
returnUs (\ work_id -> Note InlineMe $
mkLams tyvars $ mkLams wrap_args_w_demands $
- (wrap_fn_coerce . wrap_fn_str . wrap_fn_cpr) $
- mkVarApps (Var work_id) (tyvars ++ work_args_w_demands),
+ (wrap_fn_coerce . wrap_fn_cpr . wrap_fn_str . wrap_fn_fixup) $
+ mkVarApps (Var work_id) tyvars,
- \ work_body -> mkLams tyvars $ mkLams work_args_w_demands $
- (work_fn_coerce . work_fn_str . work_fn_cpr)
+ \ work_body -> mkLams tyvars $
+ (work_fn_fixup . work_fn_str . work_fn_cpr . work_fn_coerce)
work_body,
- map getIdDemandInfo work_args_w_demands)
+ work_arg_dmds)
\end{code}
@@ -313,36 +314,25 @@ where R' is the representation type for R.
\begin{code}
mkWWcoerce body_ty
= case splitNewType_maybe body_ty of
- Nothing -> (id, id)
- Just rep_ty -> (mkNote (Coerce body_ty rep_ty),
- mkNote (Coerce rep_ty body_ty))
+
+ Nothing -> returnUs (id, id, body_ty)
+
+ Just rep_ty -> returnUs (mkNote (Coerce body_ty rep_ty),
+ mkNote (Coerce rep_ty body_ty),
+ rep_ty)
\end{code}
%************************************************************************
%* *
-\subsection{Strictness stuff}
+\subsection{Fixup stuff}
%* *
%************************************************************************
-
\begin{code}
-mkWWstr :: Type -- Body type
- -> [Id] -- Wrapper args; have their demand info on them
- -> UniqSM ([Id], -- Worker args; have their demand info on them
-
- CoreExpr -> CoreExpr, -- Wrapper body, lacking the inner call to the worker
- -- and without its lambdas
- -- At the call site, the worker args are bound
-
- CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
- -- and without its lambdas
-
-mkWWstr body_ty wrap_args
- = mk_ww wrap_args `thenUs` \ (work_args, wrap_fn, work_fn) ->
-
- if null work_args && isUnLiftedType body_ty then
+mkWWfixup res_ty no_worker_args
+ | no_worker_args && 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:
@@ -351,31 +341,54 @@ mkWWstr body_ty wrap_args
-- fw = /\abc. \v. body
--
-- We use the state-token type which generates no code
- getUniqueUs `thenUs` \ void_arg_uniq ->
- let
+ = getUniqueUs `thenUs` \ void_arg_uniq ->
+ let
void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
- in
- returnUs ([void_arg],
- wrap_fn . Let (NonRec void_arg (Var realWorldPrimId)),
- work_fn)
- else
- returnUs (work_args, wrap_fn, work_fn)
-
+ in
+ returnUs (\ call_to_worker -> App call_to_worker (Var void_arg),
+ \ worker_body -> Lam void_arg worker_body)
+
+ | otherwise
+ = returnUs (id, id)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Strictness stuff}
+%* *
+%************************************************************************
+
+\begin{code}
+mkWWstr :: [Id] -- Wrapper args; have their demand info on them
+ -> UniqSM (CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
+ -- and without its lambdas
+ -- This fn adds the unboxing, and makes the
+ -- call passing the unboxed things
+
+ CoreExpr -> CoreExpr, -- Worker body, lacking the original body of the function,
+ -- but *with* lambdas
+ [Demand]) -- Worker arg demands
+mkWWstr wrap_args
+ = mk_ww_str wrap_args `thenUs` \ (work_args_w_demands, wrap_fn, work_fn) ->
+ returnUs ( \ wrapper_body -> wrap_fn (mkVarApps wrapper_body work_args_w_demands),
+ \ worker_body -> mkLams work_args_w_demands (work_fn worker_body),
+ map getIdDemandInfo work_args_w_demands)
-- Empty case
-mk_ww []
+mk_ww_str []
= returnUs ([],
\ wrapper_body -> wrapper_body,
\ worker_body -> worker_body)
-mk_ww (arg : ds)
+mk_ww_str (arg : ds)
= case getIdDemandInfo arg of
-- Absent case
WwLazy True ->
- mk_ww ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
returnUs (worker_args, wrap_fn, mk_absent_let arg . work_fn)
-- Unpack case
@@ -383,18 +396,18 @@ mk_ww (arg : ds)
getUniquesUs (length inst_con_arg_tys) `thenUs` \ uniqs ->
let
unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
- unpk_args_w_ds = zipWithEqual "mk_ww" setIdDemandInfo unpk_args cs
+ unpk_args_w_ds = zipWithEqual "mk_ww_str" setIdDemandInfo unpk_args cs
in
- mk_ww (unpk_args_w_ds ++ ds) `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ mk_ww_str (unpk_args_w_ds ++ ds) `thenUs` \ (worker_args, wrap_fn, work_fn) ->
returnUs (worker_args,
mk_unpk_case new_or_data arg unpk_args data_con arg_tycon . wrap_fn,
work_fn . mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args)
where
- (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_ww" (idType arg)
+ (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_ww_str" (idType arg)
-- Other cases
other_demand ->
- mk_ww ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
returnUs (arg : worker_args, wrap_fn, work_fn)
\end{code}
@@ -419,18 +432,19 @@ left-to-right traversal of the result structure.
mkWWcpr :: Type -- function body type
-> CprInfo -- CPR analysis results
-> UniqSM (CoreExpr -> CoreExpr, -- New wrapper
- CoreExpr -> CoreExpr) -- New worker
+ CoreExpr -> CoreExpr, -- New worker
+ Type) -- Type of worker's body
mkWWcpr body_ty NoCPRInfo
- = returnUs (id, id) -- Must be just the strictness transf.
+ = returnUs (id, id, body_ty) -- Must be just the strictness transf.
mkWWcpr body_ty (CPRInfo cpr_args)
= getUniqueUs `thenUs` \ body_arg_uniq ->
let
body_var = mk_ww_local body_arg_uniq body_ty
in
cpr_reconstruct body_ty cpr_info' `thenUs` \reconst_fn ->
- cpr_flatten body_ty cpr_info' `thenUs` \flatten_fn ->
- returnUs (reconst_fn, flatten_fn)
+ cpr_flatten body_ty cpr_info' `thenUs` \(flatten_fn, res_ty) ->
+ returnUs (reconst_fn, flatten_fn, res_ty)
where
-- We only make use of the outer level of CprInfo, otherwise we
-- may lose laziness. :-( Hopefully, we will find a use for the
@@ -445,11 +459,14 @@ from the CPR analysis and flattens the constructed product components.
These are returned in an unboxed tuple.
\begin{code}
-cpr_flatten :: Type -> CprInfo -> UniqSM (CoreExpr -> CoreExpr)
+cpr_flatten :: Type -> CprInfo -> UniqSM (CoreExpr -> CoreExpr, Type)
cpr_flatten ty cpr_info
= mk_cpr_case (ty, cpr_info) `thenUs` \(res_id, tup_ids, flatten_exp) ->
- returnUs (\body -> Case body res_id
- [(DEFAULT, [], flatten_exp (fst $ mk_unboxed_tuple tup_ids))])
+ let
+ (unbx_tuple, unbx_tuple_ty) = mk_unboxed_tuple tup_ids
+ in
+ returnUs (\body -> Case body res_id [(DEFAULT, [], flatten_exp unbx_tuple)],
+ unbx_tuple_ty)
@@ -527,6 +544,8 @@ mk_cpr_let (ty, NoCPRInfo)
returnUs (id_id, [id_id], id)
mk_cpr_let (ty, cpr_info@(CPRInfo ci_args))
+
+{- Should not be needed now: mkWWfixup does this job
| isNewTyCon tycon -- a new type: must coerce the argument to this type
= ASSERT ( null $ tail inst_con_arg_tys )
mk_cpr_let (target_of_from_type, cpr_info)
@@ -539,6 +558,7 @@ mk_cpr_let (ty, cpr_info@(CPRInfo ci_args))
| otherwise -- a data type
-- reconstruct components then apply data con
+-}
= mapUs mk_cpr_let (zip inst_con_arg_tys ci_args)
`thenUs` \sub_builds ->
getUniqueUs `thenUs` \id_uniq ->
@@ -557,9 +577,34 @@ mk_cpr_let (ty, cpr_info@(CPRInfo ci_args))
splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
-splitProductType fname ty = case splitProductType_maybe ty of
- Just stuff -> stuff
- Nothing -> pprPanic (fname ++ ": not a product") (ppr ty)
+ -- For a tiresome reason, the type might not look like a product type
+ -- This happens when compiling the compiler! The module Name
+ -- imports {-# SOURCE #-} TyCon and Id
+ -- data Name = Name NameSort Unique OccName Provenance
+ -- data NameSort = WiredInId Module Id | ...
+ -- So Name does not look recursive (because Id is imported via a hi-boot file,
+ -- which says nothing about Id's rep) but actually it is, because Ids have Names.
+ -- Modules that *import* Name have a more complete view, see that Name is recursive,
+ -- and therefore that it isn't a ProductType. This conflicts with the CPR info
+ -- in exports from Name that say "do CPR".
+ --
+ -- Arguably we should regard Name as a product anyway because it isn't recursive
+ -- via products all the way... but we don't have that info to hand, and even if
+ -- we did this case might *still* arise.
+
+ --
+ -- So we hack our way out for now, by trusting the pragma that said "do CPR"
+ -- that means we can't use splitProductType_maybe
+
+splitProductType fname ty
+ = case splitAlgTyConApp_maybe ty of
+ Just (tycon, tycon_args, (con:other_cons))
+ | null other_cons && not (isExistentialDataCon con)
+ -> WARN( not (isProductTyCon tycon),
+ text "splitProductType hack: I happened!" <+> ppr ty )
+ (tycon, tycon_args, con, dataConArgTys con tycon_args)
+
+ Nothing -> pprPanic (fname ++ ": not a product") (ppr ty)
\end{code}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 93f2ff678c2beb9029bad3fab91ba1ae066111c8..5b4aa54d9cdc652feddcb83e61162cb769c1d4eb 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -597,6 +597,7 @@ repType other_ty = other_ty
splitNewType_maybe :: Type -> Maybe Type
-- Find the representation of a newtype, if it is one
+-- Looks through multiple levels of newtype
splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
splitNewType_maybe (TyConApp tc tys) | isNewTyCon tc = case splitNewType_maybe rep_ty of
Just rep_ty' -> Just rep_ty'