isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon,
- splitProductType_maybe, splitProductType,
+ splitProductType_maybe, splitProductType, deepSplitProductType,
+ deepSplitProductType_maybe
) where
#include "HsVersions.h"
import Type ( Type, ThetaType,
substTyWith, substTyVar, mkTopTvSubst,
mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys,
- splitTyConApp_maybe,
+ splitTyConApp_maybe, newTyConInstRhs,
mkPredTys, isStrictPred, pprType
)
import Coercion ( isEqPred, mkEqPred )
import TyCon ( TyCon, FieldLabel, tyConDataCons,
isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
- isNewTyCon )
+ isNewTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique )
import Var ( TyVar, Id )
Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
+deepSplitProductType_maybe ty
+ = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
+ ; let {result
+ | isNewTyCon tycon && not (isRecursiveTyCon tycon)
+ = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args)
+ | otherwise = Just res}
+ ; result
+ }
+
+deepSplitProductType str ty
+ = case deepSplitProductType_maybe ty of
+ Just stuff -> stuff
+ Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
+
computeRep :: [StrictnessMark] -- Original arg strictness
-> [Type] -- and types
-> ([StrictnessMark], -- Representation arg strictness
unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)]
unbox MarkedStrict ty = [(MarkedStrict, ty)]
unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
- where
- (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" ty
+ where
+ (tycon, tycon_args, arg_dc, arg_tys)
+ = deepSplitProductType "unbox_strict_arg_ty" ty
\end{code}
mkPrimOpId, mkFCallId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
+ mkUnpackCase, mkProductBox,
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
)
import TysWiredIn ( charTy, mkListTy )
import PrelRules ( primOpRules )
-import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes )
-import Coercion ( mkSymCoercion, mkUnsafeCoercion )
+import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs )
+import Coercion ( mkSymCoercion, mkUnsafeCoercion,
+ splitRecNewTypeCo_maybe )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
mkTyConApp, mkTyVarTys, mkClassPred,
mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
dataConRepArgTys, dataConRepType,
dataConSig, dataConStrictMarks, dataConExStricts,
splitProductType, isVanillaDataCon, dataConFieldType,
- dataConInstOrigArgTys
+ dataConInstOrigArgTys, deepSplitProductType
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
- mkTemplateLocal, idName
+ mkTemplateLocal, idName, mkWildId
)
import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo,
setArityInfo, setSpecInfo, setCafInfo,
Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
MarkedUnboxed
- ->case splitProductType "do_unbox" (idType arg) of
- (tycon, tycon_args, con, tys) ->
- Case (Var arg) arg result_ty
- [(DataAlt con,
- con_args,
- body i' (reverse con_args ++ rep_args))]
- where
- (con_args, i') = mkLocals i tys
+ -> unboxProduct i (Var arg) (idType arg) the_body result_ty
+ where
+ the_body i con_args = body i (reverse con_args ++ rep_args)
mAX_CPR_SIZE :: Arity
mAX_CPR_SIZE = 10
field_lbls = dataConFieldLabels data_con
error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
- full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
+ full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
+
+-- unbox a product type...
+-- we will recurse into newtypes, casting along the way, and unbox at the
+-- first product data constructor we find. e.g.
+--
+-- data PairInt = PairInt Int Int
+-- newtype S = MkS PairInt
+-- newtype T = MkT S
+--
+-- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
+-- ids, we get (modulo int passing)
+--
+-- case (e `cast` (sym CoT)) `cast` (sym CoS) of
+-- PairInt a b -> body [a,b]
+--
+-- The Ints passed around are just for creating fresh locals
+unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> Type -> CoreExpr
+unboxProduct i arg arg_ty body res_ty
+ = mkUnpackCase the_id arg con_args boxing_con rhs
+ where
+ (_, _, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
+ ([the_id], i') = mkLocals i [arg_ty]
+ (con_args, i'') = mkLocals i' tys
+ rhs = body i'' con_args
+
+mkUnpackCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
+mkUnpackCase bndr arg unpk_args boxing_con body
+ = Case cast_arg bndr (exprType body) [(DataAlt boxing_con, unpk_args, body)]
+ where
+ cast_arg = go (idType bndr) arg
+ go ty arg
+ | res@(tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty
+ , isNewTyCon tycon && not (isRecursiveTyCon tycon)
+ = go (newTyConInstRhs tycon tycon_args)
+ (unwrapNewTypeBody tycon tycon_args arg)
+ | otherwise = arg
+
+-- ...and the dual
+reboxProduct :: [Unique] -- uniques to create new local binders
+ -> Type -- type of product to box
+ -> ([Unique], -- remaining uniques
+ CoreExpr, -- boxed product
+ [Id]) -- Ids being boxed into product
+reboxProduct us ty
+ = let
+ (tycon, tycon_args, pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
+
+ us' = dropList con_arg_tys us
+
+ arg_ids = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
+
+ bind_rhs = mkProductBox arg_ids ty
+
+ in
+ (us', bind_rhs, arg_ids)
+
+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
+ = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args))
+ | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var arg_ids)
+
+ wrap expr = wrapNewTypeBody tycon tycon_args expr
-- (mkReboxingAlt us con xs rhs) basically constructs the case
-- Term variable case
go (arg:args) (str:stricts) us
| isMarkedUnboxed str
- = let
- ty = idType arg
-
- (tycon, tycon_args, pack_con, con_arg_tys)
- = splitProductType "mkReboxingAlt" ty
-
- unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
- (binds, args') = go args stricts (dropList con_arg_tys us)
- con_app | isNewTyCon tycon = ASSERT( isSingleton unpacked_args )
- wrapNewTypeBody tycon tycon_args (Var (head unpacked_args))
- -- ToDo: is this right? Jun06
- | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
- in
- (NonRec arg con_app : binds, unpacked_args ++ args')
-
+ =
+ let (binds, unpacked_args') = go args stricts us'
+ (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg)
+ in
+ (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args')
| otherwise
= let (binds, args') = go args stricts us
in (binds, arg:args')
(dmd_ty, e') = dmdAnal sigs dmd' e
to_co = snd (coercionKind co)
dmd'
--- | Just (tc, args) <- splitTyConApp_maybe to_co
- = evalDmd
--- , isRecursiveTyCon tc = evalDmd
--- | otherwise = dmd
+ | Just (tc, args) <- splitTyConApp_maybe to_co
+ , isRecursiveTyCon tc = evalDmd
+ | otherwise = dmd
-- This coerce usually arises from a recursive
-- newtype, and we don't want to look inside them
-- for exactly the same reason that we don't look
setIdInfo
)
import IdInfo ( vanillaIdInfo )
-import DataCon ( splitProductType_maybe, splitProductType )
+import DataCon ( deepSplitProductType_maybe, splitProductType )
import NewDemand ( Demand(..), DmdResult(..), Demands(..) )
-import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID )
+import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID,
+ mkUnpackCase, mkProductBox )
import TysWiredIn ( tupleCon )
import Type ( Type, isUnLiftedType, mkFunTys,
splitForAllTys, splitFunTys, splitRecNewType_maybe, isAlgType
-- Unpack case
Eval (Prod cs)
| Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys)
- <- splitProductType_maybe (idType arg)
+ <- deepSplitProductType_maybe (idType arg)
-> getUniquesUs `thenUs` \ uniqs ->
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 = mk_unpk_case arg unpk_args data_con arg_tycon
+ unbox_fn = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con
rebox_fn = Let (NonRec arg con_app)
- con_app = mkConApp data_con (map Type tycon_arg_tys ++ map Var unpk_args)
+ con_app = mkProductBox unpk_args (idType arg)
in
mkWWstr unpk_args_w_ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
- returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
+ returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
-- Don't pass the arg, rebox instead
-- `seq` demand; evaluate in wrapper in the hope
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)
+ con_app = mkProductBox arg_vars body_ty
in
returnUs (\ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)],
\ body -> workerCase body work_wild ubx_tup_ty [(DataAlt data_con, args, ubx_tup_app)],
ubx_tup_ty)
where
- (_, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty
+ (_, 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
= Case (Var arg)
(sanitiseCaseBndr arg)
(exprType body)
- [(DataAlt boxing_con, unpk_args, body)]
+ [(DataAlt boxing_con, unpk_args, body) ]
mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
import TcType ( TcKind, TcType, Type, tyVarsOfType, mkPhiTy,
mkArrowKind, liftedTypeKind, mkTyVarTys,
tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe )
-import Type ( PredType(..), splitTyConApp_maybe, mkTyVarTy
+import Type ( PredType(..), splitTyConApp_maybe, mkTyVarTy,
+ newTyConInstRhs
-- pprParendType, pprThetaArrow
)
import Generics ( validGenericMethodType, canDoGenerics )
chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
= case bang of
HsNoBang -> NotMarkedStrict
- HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed
- HsUnbox | can_unbox -> MarkedUnboxed
+ HsStrict | unbox_strict_fields
+ && can_unbox arg_ty -> MarkedUnboxed
+ HsUnbox | can_unbox arg_ty -> MarkedUnboxed
other -> MarkedStrict
where
- can_unbox = case splitTyConApp_maybe arg_ty of
- Nothing -> False
- Just (arg_tycon, _) -> not (isNewTyCon arg_tycon) && not (isRecursiveTyCon tycon) &&
- isProductTyCon arg_tycon
+ -- we can unbox if the type is a chain of newtypes with a product tycon
+ -- at the end
+ can_unbox arg_ty = case splitTyConApp_maybe arg_ty of
+ Nothing -> False
+ Just (arg_tycon, tycon_args) ->
+ not (isRecursiveTyCon tycon) &&
+ isProductTyCon arg_tycon &&
+ (if isNewTyCon arg_tycon then
+ can_unbox (newTyConInstRhs arg_tycon tycon_args)
+ else True)
\end{code}
%************************************************************************
predTypeRep, mkPredTy, mkPredTys,
-- Newtypes
- splitRecNewType_maybe,
+ splitRecNewType_maybe, newTyConInstRhs,
-- Lifting and boxity
isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
splitNewTyConApp_maybe other = Nothing
+-- get instantiated newtype rhs, the arguments had better saturate
+-- the constructor
+newTyConInstRhs :: TyCon -> [Type] -> Type
+newTyConInstRhs tycon tys =
+ let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty
+
\end{code}