mkPrimOpId, mkFCallId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
+ mkUnpackCase, mkProductBox,
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
- lazyId, lazyIdUnfolding, lazyIdKey,
+ lazyId, lazyIdUnfolding, lazyIdKey,
mkRuntimeErrorApp,
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
)
import TysWiredIn ( charTy, mkListTy )
import PrelRules ( primOpRules )
-import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes )
-import Coercion ( mkSymCoercion, mkUnsafeCoercion )
+import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType )
+import Coercion ( mkSymCoercion, mkUnsafeCoercion,
+ splitNewTypeRepCo_maybe )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
mkTyConApp, mkTyVarTys, mkClassPred,
mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon,
newTyConCo, tyConArity )
import Class ( Class, classTyCon, classSelIds )
-import Var ( Id, TyVar, Var )
+import Var ( Id, TyVar, Var, setIdType )
import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
import OccName ( mkOccNameFS, varName )
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
-- NB: A newtype always has a vanilla DataCon; no existentials etc
-- res_tys will simply be the dataConUnivTyVars
sel_body | isNewTyCon tycon = unwrapNewTypeBody tycon res_tys (Var data_id)
- | otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts)
+ | otherwise = Case (Var data_id) data_id field_ty (default_alt ++ the_alts)
mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids
-- We pull the field lambdas to the top, so we need to
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
+ = result
+ where
+ result = mkUnpackCase the_id arg arg_ty con_args boxing_con rhs
+ (tycon, tycon_args, 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 -> Type -> [Id] -> DataCon -> CoreExpr -> CoreExpr
+-- (mkUnpackCase x e args Con body)
+-- returns
+-- case (e `cast` ...) of bndr { Con args -> body }
+--
+-- the type of the bndr passed in is irrelevent
+mkUnpackCase bndr arg arg_ty unpk_args boxing_con body
+ = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
+ where
+ (cast_arg, bndr_ty) = 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, ty)
+
+-- ...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 && not (isRecursiveTyCon 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')
projects / ghc-hetmet.git / blobdiff