From a4c34367ce3e836f52f0ffb1e379ce81b8d65316 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 17:35:26 +0000 Subject: [PATCH] towards unboxing through newtypes Mon Sep 18 14:44:50 EDT 2006 Manuel M T Chakravarty * towards unboxing through newtypes Sat Aug 5 21:42:05 EDT 2006 Manuel M T Chakravarty * towards unboxing through newtypes Fri Jul 14 12:02:32 EDT 2006 kevind@bu.edu --- compiler/basicTypes/DataCon.lhs | 26 ++++++-- compiler/basicTypes/MkId.lhs | 111 ++++++++++++++++++++++++++--------- compiler/stranal/DmdAnal.lhs | 7 +-- compiler/stranal/WwLib.lhs | 19 +++--- compiler/typecheck/TcTyClsDecls.lhs | 22 ++++--- compiler/types/Type.lhs | 8 ++- 6 files changed, 139 insertions(+), 54 deletions(-) diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 289fdef..486745c 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -23,7 +23,8 @@ module DataCon ( isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon, isVanillaDataCon, classDataCon, - splitProductType_maybe, splitProductType, + splitProductType_maybe, splitProductType, deepSplitProductType, + deepSplitProductType_maybe ) where #include "HsVersions.h" @@ -31,13 +32,13 @@ module DataCon ( 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 ) @@ -687,6 +688,20 @@ splitProductType str ty 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 @@ -698,6 +713,7 @@ computeRep stricts tys 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} diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index bc45f52..1485f48 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -21,6 +21,7 @@ module MkId ( mkPrimOpId, mkFCallId, mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody, + mkUnpackCase, mkProductBox, -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, @@ -45,8 +46,9 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, ) 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, @@ -71,11 +73,11 @@ import DataCon ( DataCon, DataConIds(..), dataConTyCon, dataConUnivTyVars, 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, @@ -316,14 +318,9 @@ mkDataConIds wrap_name wkr_name data_con 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 @@ -563,7 +560,75 @@ mkRecordSelId tycon field_label 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 @@ -610,21 +675,11 @@ mkReboxingAlt us con args rhs -- 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') diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 6adda66..3fc8477 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -171,10 +171,9 @@ dmdAnal sigs dmd (Cast e co) (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 diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index c4e78eb..8b4f6aa 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -15,9 +15,10 @@ import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo, 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 @@ -341,17 +342,17 @@ mkWWstr_one arg -- 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 @@ -443,13 +444,13 @@ mkWWcpr body_ty RetCPR 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 @@ -495,7 +496,7 @@ mk_unpk_case arg unpk_args boxing_con boxing_tycon body = 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)] diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index a23c6ba..d67ae90 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -36,7 +36,8 @@ import TcMType ( newKindVar, checkValidTheta, checkValidType, 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 ) @@ -606,14 +607,21 @@ chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark 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} %************************************************************************ diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index fd8e8c5..c3013ab 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -56,7 +56,7 @@ module Type ( predTypeRep, mkPredTy, mkPredTys, -- Newtypes - splitRecNewType_maybe, + splitRecNewType_maybe, newTyConInstRhs, -- Lifting and boxity isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType, @@ -410,6 +410,12 @@ splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) 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} -- 1.7.10.4