Commit a4c34367 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

towards unboxing through newtypes

Mon Sep 18 14:44:50 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * towards unboxing through newtypes
  Sat Aug  5 21:42:05 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * towards unboxing through newtypes
    Fri Jul 14 12:02:32 EDT 2006  kevind@bu.edu
parent 839f2da8
......@@ -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}
......@@ -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')
......
......@@ -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
......
......@@ -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)]
......
......@@ -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}
%************************************************************************
......
......@@ -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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment