diff options
| author | Max Bolingbroke <batterseapower@hotmail.com> | 2012-03-18 00:00:38 +0000 |
|---|---|---|
| committer | Max Bolingbroke <batterseapower@hotmail.com> | 2012-05-15 21:32:55 +0100 |
| commit | 09987de4ece1fc634af6b2b37173b12ed46fdf3e (patch) | |
| tree | 42f2d5495c064994edd92d0d11574749d4353562 | |
| parent | 7950f46c8698aa813e6f1c9de9c8b5c7fe57ed93 (diff) | |
| download | haskell-unboxed-tuple-arguments2.tar.gz | |
Support code generation for unboxed-tuple function argumentsunboxed-tuple-arguments2
This is done by a 'unarisation' pre-pass at the STG level which
translates away all (live) binders binding something of unboxed
tuple type.
This has the following knock-on effects:
* The subkind hierarchy is vastly simplified (no UbxTupleKind or ArgKind)
* Various relaxed type checks in typechecker, 'foreign import prim' etc
* All case binders may be live at the Core level
46 files changed, 543 insertions, 434 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index c6226cac67..98579ac4c3 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -26,7 +26,7 @@ types that module BasicTypes( Version, bumpVersion, initialVersion, - Arity, + Arity, RepArity, Alignment, @@ -101,7 +101,18 @@ import Data.Function (on) %************************************************************************ \begin{code} +-- | The number of value arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has arity 0 +-- \x -> fib x has arity 1 type Arity = Int + +-- | The number of represented arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has representation arity 0 +-- \x -> fib x has representation arity 1 +-- \(# x, y #) -> fib (x + y) has representation arity 2 +type RepArity = Int \end{code} %************************************************************************ diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 2fbedd610c..d56aaac4ba 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -31,7 +31,7 @@ module DataCon ( dataConInstOrigArgTys, dataConRepArgTys, dataConFieldLabels, dataConFieldType, dataConStrictMarks, dataConExStricts, - dataConSourceArity, dataConRepArity, + dataConSourceArity, dataConRepArity, dataConRepRepArity, dataConIsInfix, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, dataConRepStrictness, @@ -692,9 +692,14 @@ dataConSourceArity dc = length (dcOrigArgTys dc) -- | Gives the number of actual fields in the /representation/ of the -- data constructor. This may be more than appear in the source code; -- the extra ones are the existentially quantified dictionaries -dataConRepArity :: DataCon -> Int +dataConRepArity :: DataCon -> Arity dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys +-- | The number of fields in the /representation/ of the constructor +-- AFTER taking into account the unpacking of any unboxed tuple fields +dataConRepRepArity :: DataCon -> RepArity +dataConRepRepArity dc = typeRepArity (dataConRepArity dc) (dataConRepType dc) + -- | Return whether there are any argument types for this 'DataCon's original source type isNullarySrcDataCon :: DataCon -> Bool isNullarySrcDataCon dc = null (dcOrigArgTys dc) diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index d1df6cc0ab..debd8ca369 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -41,8 +41,8 @@ module Id ( mkWorkerId, mkWiredInIdName, -- ** Taking an Id apart - idName, idType, idUnique, idInfo, idDetails, - idPrimRep, recordSelectorFieldLabel, + idName, idType, idUnique, idInfo, idDetails, idRepArity, + recordSelectorFieldLabel, -- ** Modifying an Id setIdName, setIdUnique, Id.setIdType, @@ -158,9 +158,6 @@ idUnique = Var.varUnique idType :: Id -> Kind idType = Var.varType -idPrimRep :: Id -> PrimRep -idPrimRep id = typePrimRep (idType id) - setIdName :: Id -> Name -> Id setIdName = Var.setVarName @@ -462,6 +459,9 @@ idArity id = arityInfo (idInfo id) setIdArity :: Id -> Arity -> Id setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id +idRepArity :: Id -> RepArity +idRepArity x = typeRepArity (idArity x) (idType x) + -- | Returns true if an application to n args would diverge isBottomingId :: Id -> Bool isBottomingId id = isBottomingSig (idStrictness id) diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 6d02e693fb..81e895d460 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -72,7 +72,7 @@ module CmmUtils( #include "HsVersions.h" import TyCon ( PrimRep(..) ) -import Type ( Type, typePrimRep ) +import Type ( UnaryType, typePrimRep ) import SMRep import Cmm @@ -107,7 +107,7 @@ primRepCmmType AddrRep = bWord primRepCmmType FloatRep = f32 primRepCmmType DoubleRep = f64 -typeCmmType :: Type -> CmmType +typeCmmType :: UnaryType -> CmmType typeCmmType ty = primRepCmmType (typePrimRep ty) primRepForeignHint :: PrimRep -> ForeignHint @@ -121,7 +121,7 @@ primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg primRepForeignHint FloatRep = NoHint primRepForeignHint DoubleRep = NoHint -typeForeignHint :: Type -> ForeignHint +typeForeignHint :: UnaryType -> ForeignHint typeForeignHint = primRepForeignHint . typePrimRep --------------------------------------------------- diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 9049504dca..9ad8d13b5f 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -72,7 +72,7 @@ cgTopRhsCon id con args ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. ASSERT( not (isDllConApp dflags con args) ) return () - ; ASSERT( args `lengthIs` dataConRepArity con ) return () + ; ASSERT( args `lengthIs` dataConRepRepArity con ) return () -- LAY IT OUT ; amodes <- getArgAmodes args @@ -324,7 +324,7 @@ cgReturnDataCon con amodes -- for it to be marked as "used" for LDV profiling. | opt_SccProfilingOn = build_it_then enter_it | otherwise - = ASSERT( amodes `lengthIs` dataConRepArity con ) + = ASSERT( amodes `lengthIs` dataConRepRepArity con ) do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo ; case sequel of CaseAlts _ (Just (alts, deflt_lbl)) bndr @@ -466,8 +466,8 @@ cgDataCon data_con ; ldvEnter (CmmReg nodeReg) ; body_code } - arg_reps :: [(CgRep, Type)] - arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con] + arg_reps :: [(CgRep, UnaryType)] + arg_reps = [(typeCgRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] body_code = do { -- NB: We don't set CC when entering data (WDP 94/06) diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index cb3a86ef7f..f935f95726 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -480,7 +480,7 @@ Little helper for primitives that return unboxed tuples. newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint]) newUnboxedTupleRegs res_ty = let - ty_args = tyConAppArgs (repType res_ty) + UbxTupleRep ty_args = repType res_ty (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args, let rep = typeCgRep ty, nonVoidArg rep ] diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 16e77eca35..600bbbe0df 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -311,4 +311,5 @@ shimForeignCallArg arg expr | otherwise = expr where -- should be a tycon app, since this is a foreign call - tycon = tyConAppTyCon (repType (stgArgType arg)) + UnaryRep rep_ty = repType (stgArgType arg) + tycon = tyConAppTyCon rep_ty diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index d8fd07fead..dbfad986a7 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -20,6 +20,8 @@ the STG paper. -- for details module ClosureInfo ( + idRepArity, + ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but StandardFormInfo(..), -- mkCmmInfo looks inside SMRep, @@ -156,7 +158,7 @@ ClosureInfo contains a LambdaFormInfo. data LambdaFormInfo = LFReEntrant -- Reentrant closure (a function) TopLevelFlag -- True if top level - !Int -- Arity. Invariant: always > 0 + !RepArity -- Arity. Invariant: always > 0 !Bool -- True <=> no fvs ArgDescr -- Argument descriptor (should reall be in ClosureInfo) @@ -180,7 +182,7 @@ data LambdaFormInfo | LFLetNoEscape -- See LetNoEscape module for precise description of -- these "lets". - !Int -- arity; + !RepArity -- arity; | LFBlackHole -- Used for the closures allocated to hold the result -- of a CAF. We want the target of the update frame to @@ -211,7 +213,7 @@ data StandardFormInfo -- The code for the thunk just pushes x2..xn on the stack and enters x1. -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled -- in the RTS to save space. - Int -- Arity, n + RepArity -- Arity, n \end{code} @@ -288,7 +290,7 @@ idCgRep x = typeCgRep . idType $ x tyConCgRep :: TyCon -> CgRep tyConCgRep = primRepToCgRep . tyConPrimRep -typeCgRep :: Type -> CgRep +typeCgRep :: UnaryType -> CgRep typeCgRep = primRepToCgRep . typePrimRep \end{code} @@ -384,9 +386,12 @@ might_be_a_function :: Type -> Bool -- Return False only if we are *sure* it's a data type -- Look through newtypes etc as much as poss might_be_a_function ty - = case tyConAppTyCon_maybe (repType ty) of - Just tc -> not (isDataTyCon tc) - Nothing -> True + | UnaryRep rep <- repType ty + , Just tc <- tyConAppTyCon_maybe rep + , isDataTyCon tc + = False + | otherwise + = True \end{code} @mkConLFInfo@ is similar, for constructors. @@ -404,7 +409,7 @@ mkSelectorLFInfo id offset updatable = LFThunk NotTopLevel False updatable (SelectorThunk offset) (might_be_a_function (idType id)) -mkApLFInfo :: Id -> UpdateFlag -> Int -> LambdaFormInfo +mkApLFInfo :: Id -> UpdateFlag -> RepArity -> LambdaFormInfo mkApLFInfo id upd_flag arity = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) (might_be_a_function (idType id)) @@ -416,12 +421,12 @@ Miscellaneous LF-infos. mkLFArgument :: Id -> LambdaFormInfo mkLFArgument id = LFUnknown (might_be_a_function (idType id)) -mkLFLetNoEscape :: Int -> LambdaFormInfo +mkLFLetNoEscape :: RepArity -> LambdaFormInfo mkLFLetNoEscape = LFLetNoEscape mkLFImported :: Id -> LambdaFormInfo mkLFImported id - = case idArity id of + = case idRepArity id of n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0 _ -> mkLFArgument id -- Not sure of exact arity \end{code} @@ -634,13 +639,13 @@ data CallMethod | DirectEntry -- Jump directly, with args in regs CLabel -- The code label - Int -- Its arity + RepArity -- Its arity getCallMethod :: DynFlags -> Name -- Function being applied -> CafInfo -- Can it refer to CAF's? -> LambdaFormInfo -- Its info - -> Int -- Number of available arguments + -> RepArity -- Number of available arguments -> CallMethod getCallMethod _ _ _ lf_info _ @@ -911,11 +916,11 @@ isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con isConstrClosure_maybe _ = Nothing -closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr) +closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info closureFunInfo _ = Nothing -lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr) +lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing @@ -935,7 +940,7 @@ funTagLFInfo lf | otherwise = 0 -tagForArity :: Int -> Maybe Int +tagForArity :: RepArity -> Maybe Int tagForArity i | i <= mAX_PTR_TAG = Just i | otherwise = Nothing diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 7aa159844b..a8db8f9d4e 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -273,8 +273,8 @@ cgDataCon data_con (tagForCon data_con)] } -- The case continuation code expects a tagged pointer - arg_reps :: [(PrimRep, Type)] - arg_reps = [(typePrimRep ty, ty) | ty <- dataConRepArgTys data_con] + arg_reps :: [(PrimRep, UnaryType)] + arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] -- Dynamic closure code for non-nullary constructors only ; whenC (not (isNullaryRepDataCon data_con)) diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index d4ba62c6ca..0f4c9bf81d 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -21,8 +21,8 @@ module StgCmmClosure ( DynTag, tagForCon, isSmallFamily, ConTagZ, dataConTagZ, - isVoidRep, isGcPtrRep, addIdReps, addArgReps, - argPrimRep, + idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, + argPrimRep, -- * LambdaFormInfo LambdaFormInfo, -- Abstract @@ -97,6 +97,10 @@ import DynFlags -- Why are these here? +-- NB: this is reliable because by StgCmm no Ids have unboxed tuple type +idPrimRep :: Id -> PrimRep +idPrimRep id = typePrimRep (idType id) + addIdReps :: [Id] -> [(PrimRep, Id)] addIdReps ids = [(idPrimRep id, id) | id <- ids] @@ -127,7 +131,7 @@ isGcPtrRep _ = False data LambdaFormInfo = LFReEntrant -- Reentrant closure (a function) TopLevelFlag -- True if top level - !Int -- Arity. Invariant: always > 0 + !RepArity -- Arity. Invariant: always > 0 !Bool -- True <=> no fvs ArgDescr -- Argument descriptor (should really be in ClosureInfo) @@ -188,7 +192,7 @@ data StandardFormInfo -- The code for the thunk just pushes x2..xn on the stack and enters x1. -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled -- in the RTS to save space. - Int -- Arity, n + RepArity -- Arity, n ------------------------------------------------------ @@ -231,9 +235,12 @@ might_be_a_function :: Type -> Bool -- Return False only if we are *sure* it's a data type -- Look through newtypes etc as much as poss might_be_a_function ty - = case tyConAppTyCon_maybe (repType ty) of - Just tc -> not (isDataTyCon tc) - Nothing -> True + | UnaryRep rep <- repType ty + , Just tc <- tyConAppTyCon_maybe rep + , isDataTyCon tc + = False + | otherwise + = True ------------- mkConLFInfo :: DataCon -> LambdaFormInfo @@ -266,7 +273,7 @@ mkLFImported id | otherwise = mkLFArgument id -- Not sure of exact arity where - arity = idArity id + arity = idRepArity id ------------ mkLFBlackHole :: LambdaFormInfo @@ -309,7 +316,7 @@ tagForCon con con_tag = dataConTagZ con fam_size = tyConFamilySize (dataConTyCon con) -tagForArity :: Int -> DynTag +tagForArity :: RepArity -> DynTag tagForArity arity | isSmallFamily arity = arity | otherwise = 0 @@ -458,13 +465,13 @@ data CallMethod | DirectEntry -- Jump directly, with args in regs CLabel -- The code label - Int -- Its arity + RepArity -- Its arity getCallMethod :: DynFlags -> Name -- Function being applied -> CafInfo -- Can it refer to CAF's? -> LambdaFormInfo -- Its info - -> Int -- Number of available arguments + -> RepArity -- Number of available arguments -> CallMethod getCallMethod _ _name _ lf_info _n_args @@ -744,10 +751,10 @@ closureReEntrant :: ClosureInfo -> Bool closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True closureReEntrant _ = False -closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr) +closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info -lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr) +lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index e17ac4fd32..efb20186d3 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -62,7 +62,7 @@ cgTopRhsCon id con args ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. ASSERT( not (isDllConApp dflags con args) ) return () - ; ASSERT( args `lengthIs` dataConRepArity con ) return () + ; ASSERT( args `lengthIs` dataConRepRepArity con ) return () -- LAY IT OUT ; let diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 5ea935984d..9faad02f46 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -497,7 +497,7 @@ cgConApp con stg_args ; emitReturn arg_exprs } | otherwise -- Boxed constructors; allocate and return - = ASSERT( stg_args `lengthIs` dataConRepArity con ) + = ASSERT( stg_args `lengthIs` dataConRepRepArity con ) do { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args -- The first "con" says that the name bound to this closure is -- is "con", which is a bit of a fudge, but it only affects profiling diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index c41832a0ab..5bc0f7af4e 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -304,5 +304,6 @@ add_shim arg_ty expr | otherwise = expr where - tycon = tyConAppTyCon (repType arg_ty) + UnaryRep rep_ty = repType arg_ty + tycon = tyConAppTyCon rep_ty -- should be a tycon app, since this is a foreign call diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 9afcd029a4..c33524636b 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -50,7 +50,7 @@ import StgSyn import Id import Name import TyCon ( PrimRep(..) ) -import BasicTypes ( Arity ) +import BasicTypes ( RepArity ) import DynFlags import StaticFlags @@ -128,7 +128,7 @@ adjustHpBackwards -- Making calls: directCall and slowCall ------------------------------------------------------------------------- -directCall :: CLabel -> Arity -> [StgArg] -> FCode () +directCall :: CLabel -> RepArity -> [StgArg] -> FCode () -- (directCall f n args) -- calls f(arg1, ..., argn), and applies the result to the remaining args -- The function f has arity n, and there are guaranteed at least n args @@ -144,7 +144,7 @@ slowCall fun stg_args ; slow_call fun cmm_args (argsReps stg_args) } -------------- -direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [ArgRep] -> FCode () +direct_call :: String -> CLabel -> RepArity -> [CmmExpr] -> [ArgRep] -> FCode () -- NB1: (length args) may be less than (length reps), because -- the args exclude the void ones -- NB2: 'arity' refers to the *reps* @@ -186,7 +186,7 @@ slow_call fun args reps (rts_fun, arity) = slowCallPattern reps -- These cases were found to cover about 99% of all slow calls: -slowCallPattern :: [ArgRep] -> (FastString, Arity) +slowCallPattern :: [ArgRep] -> (FastString, RepArity) -- Returns the generic apply function and arity slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6) slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5) diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index a6c592cfd8..da69030ddf 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -197,7 +197,7 @@ registerTickyCtr ctr_lbl (CmmLit (mkIntCLit 1)) ] ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) -tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode () +tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () tickyReturnOldCon arity = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") ; bumpHistogram (fsLit "RET_OLD_hst") arity } @@ -205,7 +205,7 @@ tickyReturnNewCon arity = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") ; bumpHistogram (fsLit "RET_NEW_hst") arity } -tickyUnboxedTupleReturn :: Int -> FCode () +tickyUnboxedTupleReturn :: RepArity -> FCode () tickyUnboxedTupleReturn arity = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } @@ -219,7 +219,7 @@ tickyVectoredReturn family_size -- Ticky calls -- Ticks at a *call site*: -tickyDirectCall :: Arity -> [StgArg] -> FCode () +tickyDirectCall :: RepArity -> [StgArg] -> FCode () tickyDirectCall arity args | arity == length args = tickyKnownCallExact | otherwise = do tickyKnownCallExtraArgs diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index c3327138b3..dda2260a04 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -458,7 +458,7 @@ newUnboxedTupleRegs res_ty ; ASSERT( regs `equalLength` reps ) return (regs, map primRepForeignHint reps) } where - ty_args = tyConAppArgs (repType res_ty) + UbxTupleRep ty_args = repType res_ty reps = [ rep | ty <- ty_args , let rep = typePrimRep ty diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 41b0f3bd2f..ba6a14739a 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -352,17 +352,11 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = ; subst <- getTvSubst ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) - -- If the binder is an unboxed tuple type, don't put it in scope - ; let scope = if (isUnboxedTupleType (idType var)) then - pass_var - else lintAndScopeId var - ; scope $ \_ -> + ; lintAndScopeId var $ \_ -> do { -- Check the alternatives mapM_ (lintCoreAlt scrut_ty alt_ty) alts ; checkCaseAlts e scrut_ty alts ; return alt_ty } } - where - pass_var f = f var lintCoreExpr (Type ty) = do { ty' <- lintInTy ty @@ -598,10 +592,7 @@ lintIdBndr :: Id -> (Id -> LintM a) -> LintM a -- ToDo: lint its rules lintIdBndr id linterF - = do { checkL (not (isUnboxedTupleType (idType id))) - (mkUnboxedTupleMsg id) - -- No variable can be bound to an unboxed tuple. - ; lintAndScopeId id $ \id' -> linterF id' } + = do { lintAndScopeId id $ \id' -> linterF id' } lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a lintAndScopeIds ids linterF @@ -1257,11 +1248,6 @@ mkArityMsg binder ] where (StrictSig dmd_ty) = idStrictness binder -mkUnboxedTupleMsg :: Id -> MsgDoc -mkUnboxedTupleMsg binder - = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder], - hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]] - mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc mkCastErr expr co from_ty expr_ty = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index d31c77479d..28c94c8ffb 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -154,7 +154,7 @@ dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body eqn_rhs = cantFailMatchResult body } ; var <- selectMatchVar upat ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) - ; return (scrungleMatch var rhs result) } + ; return (bindNonRec var rhs result) } dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) @@ -163,38 +163,13 @@ strictMatchOnly :: HsBind Id -> Bool strictMatchOnly (AbsBinds { abs_binds = binds }) = anyBag (strictMatchOnly . unLoc) binds strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty }) - = isUnboxedTupleType ty + = isUnLiftedType ty || isBangLPat lpat || any (isUnLiftedType . idType) (collectPatBinders lpat) strictMatchOnly (FunBind { fun_id = L _ id }) = isUnLiftedType (idType id) strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact -scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr --- Returns something like (let var = scrut in body) --- but if var is an unboxed-tuple type, it inlines it in a fragile way --- Special case to handle unboxed tuple patterns; they can't appear nested --- The idea is that --- case e of (# p1, p2 #) -> rhs --- should desugar to --- case e of (# x1, x2 #) -> ... match p1, p2 ... --- NOT --- let x = e in case x of .... --- --- But there may be a big --- let fail = ... in case e of ... --- wrapping the whole case, which complicates matters slightly --- It all seems a bit fragile. Test is dsrun013. - -scrungleMatch var scrut body - | isUnboxedTupleType (idType var) = scrungle body - | otherwise = bindNonRec var scrut body - where - scrungle (Case (Var x) bndr ty alts) - | x == var = Case scrut bndr ty alts - scrungle (Let binds body) = Let binds (scrungle body) - scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other)) - \end{code} %************************************************************************ @@ -326,7 +301,7 @@ dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty)) | otherwise = do { core_discrim <- dsLExpr discrim ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches - ; return (scrungleMatch discrim_var core_discrim matching_code) } + ; return (bindNonRec discrim_var core_discrim matching_code) } -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 88caaef875..01895332ca 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -707,9 +707,12 @@ toCType = f False = pprPanic "toCType" (ppr t) typeTyCon :: Type -> TyCon -typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of - Just (tc,_) -> tc - Nothing -> pprPanic "DsForeign.typeTyCon" (ppr ty) +typeTyCon ty + | UnaryRep rep_ty <- repType ty + , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty + = tc + | otherwise + = pprPanic "DsForeign.typeTyCon" (ppr ty) insertRetAddr :: DynFlags -> CCallConv -> [(SDoc, SDoc, Type, CmmType)] @@ -739,7 +742,7 @@ ret_addr_arg = (text "original_return_addr", text "void*", undefined, -- This function returns the primitive type associated with the boxed -- type argument to a foreign export (eg. Int ==> Int#). -getPrimTyOf :: Type -> Type +getPrimTyOf :: Type -> UnaryType getPrimTyOf ty | isBoolTy rep_ty = intPrimTy -- Except for Bool, the types we are interested in have a single constructor @@ -752,7 +755,7 @@ getPrimTyOf ty prim_ty _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty) where - rep_ty = repType ty + UnaryRep rep_ty = repType ty -- represent a primitive type as a Char, for building a string that -- described the foreign function type. The types are size-dependent, diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 090c34ffc0..bfd44384bb 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -360,6 +360,7 @@ Library SRT SimplStg StgStats + UnariseStg Rules SpecConstr Specialise diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index c84d84a78c..851ca389ab 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -271,8 +271,12 @@ collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet) collect (_, e) = go [] e where go xs e | Just e' <- bcView e = go xs e' - go xs (AnnLam x (_,e)) = go (x:xs) e - go xs not_lambda = (reverse xs, not_lambda) + go xs (AnnLam x (_,e)) + | UbxTupleRep _ <- repType (idType x) + = unboxedTupleException + | otherwise + = go (x:xs) e + go xs not_lambda = (reverse xs, not_lambda) schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) @@ -486,7 +490,7 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut -- no alts: scrut is guaranteed to diverge schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)]) - | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) + | isUnboxedTupleCon dc, UnaryRep rep_ty <- repType (idType bind1), VoidRep <- typePrimRep rep_ty -- Convert -- case .... of x { (# VoidArg'd-thing, a #) -> ... } -- to @@ -499,12 +503,12 @@ schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)]) = --trace "automagic mashing of case alts (# VoidArg, a #)" $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} - | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2) + | isUnboxedTupleCon dc, UnaryRep rep_ty <- repType (idType bind2), VoidRep <- typePrimRep rep_ty = --trace "automagic mashing of case alts (# a, VoidArg #)" $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)]) - | isUnboxedTupleCon dc + | isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1) -- Similarly, convert -- case .... of x { (# a #) -> ... } -- to @@ -603,7 +607,8 @@ schemeT d s p app -- Detect and extract relevant info for the tagToEnum kludge. maybe_is_tagToEnum_call = let extract_constr_Names ty - | Just tyc <- tyConAppTyCon_maybe (repType ty), + | UnaryRep rep_ty <- repType ty + , Just tyc <- tyConAppTyCon_maybe rep_ty, isDataTyCon tyc = map (getName . dataConWorkId) (tyConDataCons tyc) -- NOTE: use the worker name, not the source name of @@ -746,6 +751,9 @@ doCase :: Word -> Sequel -> BCEnv -> Bool -- True <=> is an unboxed tuple case, don't enter the result -> BcM BCInstrList doCase d s p (_,scrut) bndr alts is_unboxed_tuple + | UbxTupleRep _ <- repType (idType bndr) + = unboxedTupleException + | otherwise = let -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. @@ -785,6 +793,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | null real_bndrs = do rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) + | any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs + = unboxedTupleException -- algebraic alt with some binders | otherwise = let @@ -903,7 +913,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l pargs _ [] = return [] pargs d (a:az) - = let arg_ty = repType (exprType (deAnnotate' a)) + = let UnaryRep arg_ty = repType (exprType (deAnnotate' a)) in case tyConAppTyCon_maybe arg_ty of -- Don't push the FO; instead push the Addr# it @@ -1107,13 +1117,11 @@ maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) maybe_r_rep_to_go = if isSingleton r_reps then Nothing else Just (r_reps !! 1) - (r_tycon, r_reps) - = case splitTyConApp_maybe (repType r_ty) of - (Just (tyc, tys)) -> (tyc, map typePrimRep tys) - Nothing -> blargh + r_reps = case repType r_ty of + UbxTupleRep reps -> map typePrimRep reps + UnaryRep _ -> blargh ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) || r_reps == [VoidRep] ) - && isUnboxedTupleTyCon r_tycon && case maybe_r_rep_to_go of Nothing -> True Just r_rep -> r_rep /= PtrRep diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index e6da6407bb..7378141e3d 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -25,6 +25,7 @@ import NameEnv import ClosureInfo import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) +import Type ( flattenRepType, repType ) import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE ) import CgHeapery ( mkVirtHeapOffsets ) import Util @@ -98,7 +99,7 @@ make_constr_itbls cons mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr) mk_itbl dcon conNo entry_addr = do - let rep_args = [ (typeCgRep arg,arg) | arg <- dataConRepArgTys dcon ] + let rep_args = [ (typeCgRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ] (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args ptrs' = ptr_wds diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 121b269d64..4be3d87f31 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -54,12 +54,12 @@ import Name import VarEnv import Util import VarSet +import BasicTypes ( TupleSort(UnboxedTuple) ) import TysPrim import PrelNames import TysWiredIn import DynFlags import Outputable as Ppr -import FastString import Constants ( wORD_SIZE ) import GHC.Arr ( Array(..) ) import GHC.Exts @@ -662,7 +662,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do return $ fixFunDictionaries $ expandNewtypes term' else do (old_ty', rev_subst) <- instScheme quant_old_ty - my_ty <- newVar argTypeKind + my_ty <- newVar openTypeKind when (check1 quant_old_ty) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') term <- go max_depth my_ty sigma_old_ty hval @@ -682,7 +682,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do zterm' <- mapTermTypeM (\ty -> case tcSplitTyConApp_maybe ty of Just (tc, _:_) | tc /= funTyCon - -> newVar argTypeKind + -> newVar openTypeKind _ -> return ty) term zonkTerm zterm' @@ -759,32 +759,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do Just dc -> do traceTR (text "Just" <+> ppr dc) subTtypes <- getDataConArgTys dc my_ty - let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes - subTermsP <- sequence - [ appArr (go (pred max_depth) ty ty) (ptrs clos) i - | (i,ty) <- zip [0..] subTtypesP] - let unboxeds = extractUnboxed subTtypesNP clos - subTermsNP = zipWith Prim subTtypesNP unboxeds - subTerms = reOrderTerms subTermsP subTermsNP subTtypes + subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes return (Term my_ty (Right dc) a subTerms) -- The otherwise case: can be a Thunk,AP,PAP,etc. tipe_clos -> return (Suspension tipe_clos my_ty a Nothing) - -- put together pointed and nonpointed subterms in the - -- correct order. - reOrderTerms _ _ [] = [] - reOrderTerms pointed unpointed (ty:tys) - | isPtrType ty = ASSERT2(not(null pointed) - , ptext (sLit "reOrderTerms") $$ - (ppr pointed $$ ppr unpointed)) - let (t:tt) = pointed in t : reOrderTerms tt unpointed tys - | otherwise = ASSERT2(not(null unpointed) - , ptext (sLit "reOrderTerms") $$ - (ppr pointed $$ ppr unpointed)) - let (t:tt) = unpointed in t : reOrderTerms pointed tt tys - -- insert NewtypeWraps around newtypes expandNewtypes = foldTerm idTermFold { fTerm = worker } where worker ty dc hval tt @@ -802,6 +783,46 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n | otherwise = Suspension ct ty hval n +extractSubTerms :: (Type -> HValue -> TcM Term) + -> Closure -> [Type] -> TcM [Term] +extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos) + where + go ptr_i ws [] = return (ptr_i, ws, []) + go ptr_i ws (ty:tys) + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + = do (ptr_i, ws, terms0) <- go ptr_i ws elem_tys + (ptr_i, ws, terms1) <- go ptr_i ws tys + return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) + | otherwise + = case repType ty of + UnaryRep rep_ty -> do + (ptr_i, ws, term0) <- go_rep ptr_i ws ty (typePrimRep rep_ty) + (ptr_i, ws, terms1) <- go ptr_i ws tys + return (ptr_i, ws, term0 : terms1) + UbxTupleRep rep_tys -> do + (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys + (ptr_i, ws, terms1) <- go ptr_i ws tys + return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) + + go_unary_types ptr_i ws [] = return (ptr_i, ws, []) + go_unary_types ptr_i ws (rep_ty:rep_tys) = do + tv <- newVar liftedTypeKind + (ptr_i, ws, term0) <- go_rep ptr_i ws tv (typePrimRep rep_ty) + (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys + return (ptr_i, ws, term0 : terms1) + + go_rep ptr_i ws ty rep = case rep of + PtrRep -> do + t <- appArr (recurse ty) (ptrs clos) ptr_i + return (ptr_i + 1, ws, t) + _ -> do + let (ws0, ws1) = splitAt (primRepSizeW rep) ws + return (ptr_i, ws1, Prim ty ws0) + + unboxedTupleTerm ty terms = Term ty (Right (tupleCon UnboxedTuple (length terms))) + (error "unboxedTupleTerm: no HValue for unboxed tuple") terms + -- Fast, breadth-first Type reconstruction ------------------------------------------ @@ -814,7 +835,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do then return old_ty else do (old_ty', rev_subst) <- instScheme sigma_old_ty - my_ty <- newVar argTypeKind + my_ty <- newVar openTypeKind when (check1 sigma_old_ty) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') search (isMonomorphic `fmap` zonkTcType my_ty) @@ -870,11 +891,36 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do Just dc -> do arg_tys <- getDataConArgTys dc my_ty - traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) + (_, itys) <- findPtrTyss 0 arg_tys + traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) return $ [ appArr (\e-> (ty,e)) (ptrs clos) i - | (i,ty) <- zip [0..] (filter isPtrType arg_tys)] + | (i,ty) <- itys] _ -> return [] +findPtrTys :: Int -- Current pointer index + -> Type -- Type + -> TR (Int, [(Int, Type)]) +findPtrTys i ty + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + = findPtrTyss i elem_tys + + | otherwise + = case repType ty of + UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)]) + | otherwise -> return (i, []) + UbxTupleRep rep_tys -> foldM (\(i, extras) rep_ty -> if typePrimRep rep_ty == PtrRep + then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)]) + else return (i, extras)) + (i, []) rep_tys + +findPtrTyss :: Int + -> [Type] + -> TR (Int, [(Int, Type)]) +findPtrTyss i tys = foldM step (i, []) tys + where step (i, discovered) elem_ty = findPtrTys i elem_ty >>= \(i, extras) -> return (i, discovered ++ extras) + + -- Compute the difference between a base type and the type found by RTTI -- improveType <base_type> <rtti_type> -- The types can contain skolem type variables, which need to be treated as normal vars. @@ -890,7 +936,7 @@ getDataConArgTys :: DataCon -> Type -> TR [Type] -- if so, make up fresh RTTI type variables for them getDataConArgTys dc con_app_ty = do { (_, ex_tys, _) <- instTyVars ex_tvs - ; let rep_con_app_ty = repType con_app_ty + ; let UnaryRep rep_con_app_ty = repType con_app_ty ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of Just (tc, ty_args) | dataConTyCon dc == tc -> ASSERT( univ_tvs `equalLength` ty_args) @@ -909,11 +955,6 @@ getDataConArgTys dc con_app_ty univ_tvs = dataConUnivTyVars dc ex_tvs = dataConExTyVars dc -isPtrType :: Type -> Bool -isPtrType ty = case typePrimRep ty of - PtrRep -> True - _ -> False - -- Soundness checks -------------------- {- @@ -1111,7 +1152,8 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') text " in presence of newtype evidence " <> ppr new_tycon) (_, vars, _) <- instTyVars (tyConTyVars new_tycon) let ty' = mkTyConApp new_tycon vars - _ <- liftTcM (unifyType ty (repType ty')) + UnaryRep rep_ty = repType ty' + _ <- liftTcM (unifyType ty rep_ty) -- assumes that reptype doesn't ^^^^ touch tyconApp args return ty' @@ -1158,7 +1200,8 @@ isMonomorphic ty = noExistentials && noUniversals -- Use only for RTTI types isMonomorphicOnNonPhantomArgs :: RttiType -> Bool isMonomorphicOnNonPhantomArgs ty - | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty) + | UnaryRep rep_ty <- repType ty + , Just (tc, all_args) <- tcSplitTyConApp_maybe rep_ty , phantom_vars <- tyConPhantomTyVars tc , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args , tyv `notElem` phantom_vars] @@ -1196,11 +1239,3 @@ amap' :: (t -> b) -> Array Int t -> [b] amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] where g (I# i#) = case indexArray# arr# i# of (# e #) -> f e - -extractUnboxed :: [Type] -> Closure -> [[Word]] -extractUnboxed tt clos = go tt (nonPtrs clos) - where sizeofType t = primRepSizeW (typePrimRep t) - go [] _ = [] - go (t:tt) xx - | (x, rest) <- splitAt (sizeofType t) xx - = x : go tt rest diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 42147dce94..5ac1dea025 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -43,6 +43,7 @@ import HscMain import HsSyn import HscTypes import InstEnv +import TyCon import Type hiding( typeKind ) import TcType hiding( typeKind ) import Var @@ -609,8 +610,9 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- Filter out any unboxed ids; -- we can't bind these at the prompt pointers = filter (\(id,_) -> isPointer id) vars - isPointer id | PtrRep <- idPrimRep id = True - | otherwise = False + isPointer id | UnaryRep ty <- repType (idType id) + , PtrRep <- typePrimRep ty = True + | otherwise = False (ids, offsets) = unzip pointers @@ -645,7 +647,6 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- - globalise the Id (Ids are supposed to be Global, apparently). -- let result_ok = isPointer result_id - && not (isUnboxedTupleType (idType result_id)) all_ids | result_ok = result_id : new_ids | otherwise = new_ids diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 0382fcae7d..edb8b50864 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -18,7 +18,7 @@ import OccName import TypeRep ( TyThing(..) ) import Type ( Kind, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, mkTyConApp + mkTyConApp ) import Kind( mkArrowKind ) import Name( Name, nameOccName, nameModule, mkExternalName, wiredInNameTyThing_maybe ) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 7c01de1c40..93379eda2a 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -1299,14 +1299,11 @@ superKindTyConKey = mkPreludeTyConUnique 85 -- Kind constructors liftedTypeKindTyConKey, anyKindTyConKey, openTypeKindTyConKey, - unliftedTypeKindTyConKey, ubxTupleKindTyConKey, argTypeKindTyConKey, - constraintKindTyConKey :: Unique + unliftedTypeKindTyConKey, constraintKindTyConKey :: Unique anyKindTyConKey = mkPreludeTyConUnique 86 liftedTypeKindTyConKey = mkPreludeTyConUnique 87 openTypeKindTyConKey = mkPreludeTyConUnique 88 unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 -ubxTupleKindTyConKey = mkPreludeTyConUnique 90 -argTypeKindTyConKey = mkPreludeTyConUnique 91 constraintKindTyConKey = mkPreludeTyConUnique 92 -- Coercion constructors diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 89181e89cb..1b8d96df35 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -21,22 +21,18 @@ module TysPrim( tyVarList, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTy, betaTy, gammaTy, deltaTy, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, - argAlphaTy, argAlphaTyVar, argAlphaTyVars, argBetaTy, argBetaTyVar, kKiVar, -- Kind constructors... - superKindTyCon, superKind, anyKindTyCon, - liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, + superKindTyCon, superKind, anyKindTyCon, liftedTypeKindTyCon, + openTypeKindTyCon, unliftedTypeKindTyCon, constraintKindTyCon, superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName, - ubxTupleKindTyConName, argTypeKindTyConName, constraintKindTyConName, -- Kinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, constraintKind, + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, typeNatKind, typeStringKind, @@ -137,8 +133,6 @@ primTyCons , liftedTypeKindTyCon , unliftedTypeKindTyCon , openTypeKindTyCon - , argTypeKindTyCon - , ubxTupleKindTyCon , constraintKindTyCon , superKindTyCon , anyKindTyCon @@ -226,13 +220,6 @@ openAlphaTy, openBetaTy :: Type openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy = mkTyVarTy openBetaTyVar -argAlphaTyVars :: [TyVar] -argAlphaTyVar, argBetaTyVar :: TyVar -argAlphaTyVars@(argAlphaTyVar : argBetaTyVar : _) = tyVarList argTypeKind -argAlphaTy, argBetaTy :: Type -argAlphaTy = mkTyVarTy argAlphaTyVar -argBetaTy = mkTyVarTy argBetaTyVar - kKiVar :: KindVar kKiVar = (tyVarList superKind) !! 10 @@ -305,12 +292,10 @@ So you can see it's convenient to have BOX:BOX -- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's superKindTyCon, anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - ubxTupleKindTyCon, argTypeKindTyCon, constraintKindTyCon :: TyCon superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName, - ubxTupleKindTyConName, argTypeKindTyConName, constraintKindTyConName :: Name @@ -321,8 +306,6 @@ anyKindTyCon = mkKindTyCon anyKindTyConName superKind liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName superKind openTypeKindTyCon = mkKindTyCon openTypeKindTyConName superKind unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName superKind -ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName superKind -argTypeKindTyCon = mkKindTyCon argTypeKindTyConName superKind constraintKindTyCon = mkKindTyCon constraintKindTyConName superKind -------------------------- @@ -333,8 +316,6 @@ anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKi liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon openTypeKindTyConName = mkPrimTyConName (fsLit "OpenKind") openTypeKindTyConKey openTypeKindTyCon unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon -ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon -argTypeKindTyConName = mkPrimTyConName (fsLit "ArgKind") argTypeKindTyConKey argTypeKindTyCon constraintKindTyConName = mkPrimTyConName (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon mkPrimTyConName :: FastString -> Unique -> TyCon -> Name @@ -352,17 +333,13 @@ kindTyConType :: TyCon -> Type kindTyConType kind = TyConApp kind [] -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, constraintKind, - superKind :: Kind +anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, superKind :: Kind superKind = kindTyConType superKindTyCon anyKind = kindTyConType anyKindTyCon -- See Note [Any kinds] liftedTypeKind = kindTyConType liftedTypeKindTyCon unliftedTypeKind = kindTyConType unliftedTypeKindTyCon openTypeKind = kindTyConType openTypeKindTyCon -argTypeKind = kindTyConType argTypeKindTyCon -ubxTupleKind = kindTyConType ubxTupleKindTyCon constraintKind = kindTyConType constraintKindTyCon typeNatKind :: Kind diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 4b7f043adb..fab3c20173 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -353,12 +353,12 @@ mk_tuple sort arity = (tycon, tuple_con) tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind res_kind = case sort of BoxedTuple -> liftedTypeKind - UnboxedTuple -> ubxTupleKind + UnboxedTuple -> unliftedTypeKind ConstraintTuple -> constraintKind tyvars = take arity $ case sort of BoxedTuple -> alphaTyVars - UnboxedTuple -> argAlphaTyVars -- No nested unboxed tuples + UnboxedTuple -> openAlphaTyVars ConstraintTuple -> tyVarList constraintKind tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 4a92f818d4..18c0178900 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -38,8 +38,7 @@ import CoreSubst import Var ( Var ) import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) import CoreUtils ( mkAltExpr - , exprIsTrivial, exprIsCheap ) -import DataCon ( isUnboxedTupleCon ) + , exprIsTrivial) import Type ( tyConAppArgs ) import CoreSyn import Outputable @@ -112,19 +111,6 @@ to the reverse CSE mapping if the scrutinee is a non-trivial expression. case binder -> scrutinee to the substitution -Note [Unboxed tuple case binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - case f x of t { (# a,b #) -> - case ... of - True -> f x - False -> 0 } - -We must not replace (f x) by t, because t is an unboxed-tuple binder. -Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is - f x --> (# a,b #) -That is why the CSEMap has pairs of expressions. - Note [CSE for INLINE and NOINLINE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We are careful to do no CSE inside functions that the user has marked as @@ -258,20 +244,6 @@ cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts' cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt] -cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)] - | isUnboxedTupleCon con - -- Unboxed tuples are special because the case binder isn't - -- a real value. See Note [Unboxed tuple case binders] - = [(DataAlt con, args'', tryForCSE new_env rhs)] - where - (env', args') = addBinders env args - args'' = map zapIdOccInfo args' -- They should all be ids - -- Same motivation for zapping as [Case binders 2] only this time - -- it's Note [Unboxed tuple case binders] - new_env | exprIsCheap scrut' = env' - | otherwise = extendCSEnv env' scrut' tup_value - tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr)) - cseAlts env scrut' bndr bndr' alts = map cse_alt alts where diff --git a/compiler/simplStg/SimplStg.lhs b/compiler/simplStg/SimplStg.lhs index 8ade2d5f10..728ae58a10 100644 --- a/compiler/simplStg/SimplStg.lhs +++ b/compiler/simplStg/SimplStg.lhs @@ -21,6 +21,7 @@ import CostCentre ( CollectedCCs ) import SCCfinal ( stgMassageForProfiling ) import StgLint ( lintStgBindings ) import StgStats ( showStgStats ) +import UnariseStg ( unarise ) import SRT ( computeSRTs ) import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..), @@ -49,10 +50,11 @@ stg2stg dflags module_name binds ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds -- Do the main business! + ; let (us0, us1) = splitUniqSupply us' ; (processed_binds, _, cost_centres) - <- foldl_mn do_stg_pass (binds', us', ccs) (getStgToDo dflags) + <- foldl_mn do_stg_pass (binds', us0, ccs) (getStgToDo dflags) - ; let srt_binds = computeSRTs processed_binds + ; let srt_binds = computeSRTs (unarise us1 processed_binds) ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (pprStgBindingsWithSRTs srt_binds) diff --git a/compiler/simplStg/UnariseStg.lhs b/compiler/simplStg/UnariseStg.lhs new file mode 100644 index 0000000000..ac439ebfd3 --- /dev/null +++ b/compiler/simplStg/UnariseStg.lhs @@ -0,0 +1,167 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-2012 +% + +Note [Unarisation] +~~~~~~~~~~~~~~~~~~ + +The idea of this pass is to translate away *all* unboxed-tuple binders. So for example: + +f (x :: (# Int, Bool #)) = f x + f (# 1, True #) + ==> +f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True + +It is important that we do this at the STG level and NOT at the core level +because it would be very hard to make this pass Core-type-preserving. + +STG fed to the code generators *must* be unarised because the code generators do +not support unboxed tuple binders natively. + + +Note [Unarisation and arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Because of unarisation, the arity that will be recorded in the generated info table +for an Id may be larger than the idArity. Instead we record what we call the RepArity, +which is the Arity taking into account any expanded arguments, and corresponds to +the number of (possibly-void) *registers* arguments will arrive in. + +\begin{code} +module UnariseStg (unarise) where + +#include "HsVersions.h" + +import CoreSyn +import StgSyn +import VarEnv +import UniqSupply +import Id +import MkId (realWorldPrimId) +import Type +import TysWiredIn +import DataCon +import VarSet +import OccName +import Name +import Util +import Outputable +import BasicTypes + + +-- | A mapping from unboxed-tuple binders to the Ids they were expanded to. +-- +-- INVARIANT: Ids in the range don't have unboxed tuple types. +-- +-- Those in-scope variables without unboxed-tuple types are not present in +-- the domain of the mapping at all. +type UnariseEnv = VarEnv [Id] + +ubxTupleId0 :: Id +ubxTupleId0 = dataConWorkId (tupleCon UnboxedTuple 0) + +unarise :: UniqSupply -> [StgBinding] -> [StgBinding] +unarise us binds = zipWith (\us -> unariseBinding us init_env) (listSplitUniqSupply us) binds + where -- See Note [Nullary unboxed tuple] in Type.lhs + init_env = unitVarEnv ubxTupleId0 [realWorldPrimId] + +unariseBinding :: UniqSupply -> UnariseEnv -> StgBinding -> StgBinding +unariseBinding us rho bind = case bind of + StgNonRec x rhs -> StgNonRec x (unariseRhs us rho rhs) + StgRec xrhss -> StgRec $ zipWith (\us (x, rhs) -> (x, unariseRhs us rho rhs)) (listSplitUniqSupply us) xrhss + +unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs +unariseRhs us rho rhs = case rhs of + StgRhsClosure ccs b_info fvs update_flag srt args expr + -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag (unariseSRT rho srt) args' (unariseExpr us' rho' expr) + where (us', rho', args') = unariseIdBinders us rho args + StgRhsCon ccs con args + -> StgRhsCon ccs con (unariseArgs rho args) + +unariseExpr :: UniqSupply -> UnariseEnv -> StgExpr -> StgExpr +unariseExpr us rho e = case e of + -- Particularly important where (##) is concerned (Note [The nullary (# #) constructor]) + StgApp f [] | UbxTupleRep tys <- repType (idType f) + -> StgConApp (tupleCon UnboxedTuple (length tys)) (map StgVarArg (unariseId rho f)) + StgApp f args -> StgApp f (unariseArgs rho args) + StgLit l -> StgLit l + StgConApp dc args | isUnboxedTupleCon dc -> StgConApp (tupleCon UnboxedTuple (length args')) args' + | otherwise -> StgConApp dc args' + where args' = unariseArgs rho args + StgOpApp op args ty -> StgOpApp op (unariseArgs rho args) ty + StgLam xs e -> StgLam xs' (unariseExpr us' rho' e) + where (us', rho', xs') = unariseIdBinders us rho xs + StgCase e case_lives alts_lives bndr srt alt_ty alts + -> StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives) (unariseLives rho alts_lives) bndr (unariseSRT rho srt) alt_ty' alts' + where (us1, us2) = splitUniqSupply us + (alt_ty', alts') = case repType (idType bndr) of + UbxTupleRep tys -> case alts of + (DEFAULT, [], [], e):_ -> (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys, uses, unariseExpr us2' rho' e)]) + where (us2', rho', ys) = unariseIdBinder us2 rho bndr + uses = replicate (length ys) (not (isDeadBinder bndr)) + n = length tys + [(DataAlt _, ys, uses, e)] -> (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys', uses', unariseExpr us2' rho'' e)]) + where (us2', rho', ys', uses') = unariseUsedIdBinders us2 rho ys uses + rho'' = extendVarEnv rho' bndr ys' + n = length ys' + _ -> panic "unariseExpr: strange unboxed tuple alts" + UnaryRep _ -> (alt_ty, zipWith (\us alt -> unariseAlt us rho alt) (listSplitUniqSupply us2) alts) + StgLet bind e -> StgLet (unariseBinding us1 rho bind) (unariseExpr us2 rho e) + where (us1, us2) = splitUniqSupply us + StgLetNoEscape live_in_let live_in_bind bind e + -> StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind) (unariseBinding us1 rho bind) (unariseExpr us2 rho e) + where (us1, us2) = splitUniqSupply us + StgSCC cc bump_entry push_cc e -> StgSCC cc bump_entry push_cc (unariseExpr us rho e) + StgTick mod tick_n e -> StgTick mod tick_n (unariseExpr us rho e) + +unariseAlt :: UniqSupply -> UnariseEnv -> StgAlt -> StgAlt +unariseAlt us rho (con, xs, uses, e) = (con, xs', uses', unariseExpr us' rho' e) + where (us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses + +unariseSRT :: UnariseEnv -> SRT -> SRT +unariseSRT _ NoSRT = NoSRT +unariseSRT rho (SRTEntries ids) = SRTEntries (concatMapVarSet (unariseId rho) ids) +unariseSRT _ (SRT {}) = panic "unariseSRT" + +unariseLives :: UnariseEnv -> StgLiveVars -> StgLiveVars +unariseLives rho ids = concatMapVarSet (unariseId rho) ids + +unariseArgs :: UnariseEnv -> [StgArg] -> [StgArg] +unariseArgs rho = concatMap (unariseArg rho) + +unariseArg :: UnariseEnv -> StgArg -> [StgArg] +unariseArg rho (StgVarArg x) = map StgVarArg (unariseId rho x) +unariseArg _ (StgLitArg l) = [StgLitArg l] + +unariseIds :: UnariseEnv -> [Id] -> [Id] +unariseIds rho = concatMap (unariseId rho) + +unariseId :: UnariseEnv -> Id -> [Id] +unariseId rho x = case lookupVarEnv rho x of + Just ys -> ASSERT2(case repType (idType x) of UbxTupleRep _ -> True; _ -> x == ubxTupleId0, text "unariseId: not unboxed tuple" <+> ppr x) + ys + Nothing -> ASSERT2(case repType (idType x) of UbxTupleRep _ -> False; _ -> True, text "unariseId: was unboxed tuple" <+> ppr x) + [x] + +unariseUsedIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> [Bool] -> (UniqSupply, UnariseEnv, [Id], [Bool]) +unariseUsedIdBinders us rho xs uses = case mapAccumL2 (\us rho (x, use) -> third3 (map (flip (,) use)) $ unariseIdBinder us rho x) + us rho (zipEqual "unariseUsedIdBinders" xs uses) of + (us', rho', xs_usess) -> uncurry ((,,,) us' rho') (unzip (concat xs_usess)) + +unariseIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> (UniqSupply, UnariseEnv, [Id]) +unariseIdBinders us rho xs = third3 concat $ mapAccumL2 unariseIdBinder us rho xs + +unariseIdBinder :: UniqSupply -> UnariseEnv -> Id -> (UniqSupply, UnariseEnv, [Id]) +unariseIdBinder us rho x = case repType (idType x) of + UnaryRep _ -> (us, rho, [x]) + UbxTupleRep tys -> let (us0, us1) = splitUniqSupply us + ys = unboxedTupleBindersFrom us0 x tys + rho' = extendVarEnv rho x ys + in (us1, rho', ys) + +unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id] +unboxedTupleBindersFrom us x tys = zipWith (mkSysLocal fs) (uniqsFromSupply us) tys + where fs = occNameFS (getOccName x) + +concatMapVarSet :: (Var -> [Var]) -> VarSet -> VarSet +concatMapVarSet f xs = mkVarSet [x' | x <- varSetElems xs, x' <- f x] +\end{code}
\ No newline at end of file diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index d923f68887..6dc091961a 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -454,15 +454,15 @@ coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) \begin{code} mkStgAltType :: Id -> [CoreAlt] -> AltType -mkStgAltType bndr alts - = case tyConAppTyCon_maybe (repType (idType bndr)) of - Just tc | isUnboxedTupleTyCon tc -> UbxTupAlt tc - | isUnLiftedTyCon tc -> PrimAlt tc - | isAbstractTyCon tc -> look_for_better_tycon - | isAlgTyCon tc -> AlgAlt tc - | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) - PolyAlt - Nothing -> PolyAlt +mkStgAltType bndr alts = case repType (idType bndr) of + UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of + Just tc | isUnLiftedTyCon tc -> PrimAlt tc + | isAbstractTyCon tc -> look_for_better_tycon + | isAlgTyCon tc -> AlgAlt tc + | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) + PolyAlt + Nothing -> PolyAlt + UbxTupleRep rep_tys -> UbxTupAlt (length rep_tys) where _is_poly_alt_tycon tc @@ -623,7 +623,8 @@ coreToStgArgs (arg : args) = do -- Non-type argument arg_ty = exprType arg stg_arg_ty = stgArgType stg_arg bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty)) - || (typePrimRep arg_ty /= typePrimRep stg_arg_ty) + || (map typePrimRep (flattenRepType (repType arg_ty)) + /= map typePrimRep (flattenRepType (repType stg_arg_ty))) -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted), -- and pass it to a function expecting an HValue (arg_ty). This is ok because -- we can treat an unlifted value as lifted. But the other way round diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index 8f8aa3363f..ac394164b7 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -195,18 +195,19 @@ lintStgExpr (StgSCC _ _ _ expr) = lintStgExpr expr lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do _ <- MaybeT $ lintStgExpr scrut - MaybeT $ liftM Just $ + in_scope <- MaybeT $ liftM Just $ case alts_type of - AlgAlt tc -> check_bndr tc - PrimAlt tc -> check_bndr tc - UbxTupAlt tc -> check_bndr tc - PolyAlt -> return () + AlgAlt tc -> check_bndr tc >> return True + PrimAlt tc -> check_bndr tc >> return True + UbxTupAlt _ -> return False -- Binder is always dead in this case + PolyAlt -> return True - MaybeT $ addInScopeVars [bndr] $ + MaybeT $ addInScopeVars [bndr | in_scope] $ lintStgAlts alts scrut_ty where - scrut_ty = idType bndr - check_bndr tc = case tyConAppTyCon_maybe (repType scrut_ty) of + scrut_ty = idType bndr + UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple + check_bndr tc = case tyConAppTyCon_maybe scrut_rep of Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr Nothing -> addErrL bad_bndr where @@ -430,24 +431,27 @@ stgEqType :: Type -> Type -> Bool -- Fundamentally this is a losing battle because of unsafeCoerce stgEqType orig_ty1 orig_ty2 - = go rep_ty1 rep_ty2 + = gos (repType orig_ty1) (repType orig_ty2) where - rep_ty1 = deepRepType orig_ty1 - rep_ty2 = deepRepType orig_ty2 + gos :: RepType -> RepType -> Bool + gos (UbxTupleRep tys1) (UbxTupleRep tys2) + = equalLength tys1 tys2 && and (zipWith go tys1 tys2) + gos (UnaryRep ty1) (UnaryRep ty2) = go ty1 ty2 + gos _ _ = False + + go :: UnaryType -> UnaryType -> Bool go ty1 ty2 | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1 , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2 , let res = if tc1 == tc2 - then equalLength tc_args1 tc_args2 - && and (zipWith go tc_args1 tc_args2) + then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` repType) tc_args1 tc_args2) else -- TyCons don't match; but don't bleat if either is a -- family TyCon because a coercion might have made it -- equal to something else (isFamilyTyCon tc1 || isFamilyTyCon tc2) = if res then True else - pprTrace "stgEqType: unequal" (vcat [ppr orig_ty1, ppr orig_ty2, ppr rep_ty1 - , ppr rep_ty2, ppr ty1, ppr ty2]) + pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2]) False | otherwise = True -- Conservatively say "fine". diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index d87e4559a7..cb147ca488 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -109,6 +109,8 @@ isDllConApp dflags con args = isDllName this_pkg (dataConName con) || any is_dll_arg args | otherwise = False where + -- NB: typePrimRep is legit because any free variables won't have + -- unlifted type (there are no unlifted things at top level) is_dll_arg :: StgArg -> Bool is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v)) && isDllName this_pkg (idName v) @@ -512,7 +514,7 @@ type GenStgAlt bndr occ data AltType = PolyAlt -- Polymorphic (a type variable) - | UbxTupAlt TyCon -- Unboxed tuple + | UbxTupAlt Int -- Unboxed tuple of this arity | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts \end{code} @@ -628,11 +630,11 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he likes terminators instead... Ditto for case alternatives. \begin{code} -pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) +pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgBinding bndr bdee -> SDoc pprGenStgBinding (StgNonRec bndr rhs) - = hang (hsep [ppr bndr, equals]) + = hang (hsep [pprBndr LetBind bndr, equals]) 4 ((<>) (ppr rhs) semi) pprGenStgBinding (StgRec pairs) @@ -640,7 +642,7 @@ pprGenStgBinding (StgRec pairs) map (ppr_bind) pairs ++ [ifPprDebug $ ptext $ sLit "{- StgRec (end) -}"] where ppr_bind (bndr, expr) - = hang (hsep [ppr bndr, equals]) + = hang (hsep [pprBndr LetBind bndr, equals]) 4 ((<>) (ppr expr) semi) pprStgBinding :: StgBinding -> SDoc @@ -649,7 +651,7 @@ pprStgBinding bind = pprGenStgBinding bind pprStgBindings :: [StgBinding] -> SDoc pprStgBindings binds = vcat (map pprGenStgBinding binds) -pprGenStgBindingWithSRT :: (Outputable bndr, Outputable bdee, Ord bdee) +pprGenStgBindingWithSRT :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc pprGenStgBindingWithSRT (bind,srts) = vcat $ pprGenStgBinding bind : map pprSRT srts @@ -662,15 +664,15 @@ pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds) instance (Outputable bdee) => Outputable (GenStgArg bdee) where ppr = pprStgArg -instance (Outputable bndr, Outputable bdee, Ord bdee) +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) => Outputable (GenStgBinding bndr bdee) where ppr = pprGenStgBinding -instance (Outputable bndr, Outputable bdee, Ord bdee) +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) => Outputable (GenStgExpr bndr bdee) where ppr = pprStgExpr -instance (Outputable bndr, Outputable bdee, Ord bdee) +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) => Outputable (GenStgRhs bndr bdee) where ppr rhs = pprStgRhs rhs @@ -678,7 +680,7 @@ pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc pprStgArg (StgVarArg var) = ppr var pprStgArg (StgLitArg con) = ppr con -pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) +pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgExpr bndr bdee -> SDoc -- special case pprStgExpr (StgLit lit) = ppr lit @@ -694,8 +696,10 @@ pprStgExpr (StgOpApp op args _) = hsep [ pprStgOp op, brackets (interppSP args)] pprStgExpr (StgLam bndrs body) - =sep [ char '\\' <+> ppr bndrs <+> ptext (sLit "->"), + = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs) + <+> ptext (sLit "->"), pprStgExpr body ] + where ppr_list = brackets . fsep . punctuate comma -- special case: let v = <very specific thing> -- in @@ -758,7 +762,7 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) = sep [sep [ptext (sLit "case"), nest 4 (hsep [pprStgExpr expr, ifPprDebug (dcolon <+> ppr alt_type)]), - ptext (sLit "of"), ppr bndr, char '{'], + ptext (sLit "of"), pprBndr CaseBind bndr, char '{'], ifPprDebug ( nest 4 ( hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), @@ -768,10 +772,10 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) nest 2 (vcat (map pprStgAlt alts)), char '}'] -pprStgAlt :: (Outputable bndr, Outputable occ, Ord occ) +pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ) => GenStgAlt bndr occ -> SDoc pprStgAlt (con, params, _use_mask, expr) - = hang (hsep [ppr con, interppSP params, ptext (sLit "->")]) + = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), ptext (sLit "->")]) 4 (ppr expr <> semi) pprStgOp :: StgOp -> SDoc @@ -781,7 +785,7 @@ pprStgOp (StgFCallOp op _) = ppr op instance Outputable AltType where ppr PolyAlt = ptext (sLit "Polymorphic") - ppr (UbxTupAlt tc) = ptext (sLit "UbxTup") <+> ppr tc + ppr (UbxTupAlt n) = ptext (sLit "UbxTup") <+> ppr n ppr (AlgAlt tc) = ptext (sLit "Alg") <+> ppr tc ppr (PrimAlt tc) = ptext (sLit "Prim") <+> ppr tc @@ -793,7 +797,7 @@ pprStgLVs lvs else hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"] -pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) +pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgRhs bndr bdee -> SDoc -- special case diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index e6e07576d2..1194e235a3 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -223,7 +223,7 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside -- Consider ?x = 4 -- ?y = ?x + 1 tc_ip_bind (IPBind ip expr) - = do { ty <- newFlexiTyVarTy argTypeKind + = do { ty <- newFlexiTyVarTy openTypeKind ; ip_id <- newIP ip ty ; expr' <- tcMonoExpr expr ty ; return (ip_id, (IPBind (IPName ip_id) expr')) } @@ -946,7 +946,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matc = do { mono_id <- newSigLetBndr no_gen name sig ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) } | otherwise - = do { mono_ty <- newFlexiTyVarTy argTypeKind + = do { mono_ty <- newFlexiTyVarTy openTypeKind ; mono_id <- newNoSigLetBndr no_gen name mono_ty ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) } diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index b864a13872..163a581dcc 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -985,7 +985,7 @@ cond_typeableOK :: Condition -- (b) 7 or fewer args cond_typeableOK (_, tc) | tyConArity tc > 7 = Just too_many - | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tc)) + | not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc)) = Just bad_kind | otherwise = Nothing where diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 488e65458c..c915b16c42 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -184,7 +184,7 @@ tcExpr (HsIPVar ip) res_ty -- type scheme. We enforce this by creating a fresh -- type variable as its type. (Because res_ty may not -- be a tau-type.) - ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple + ; ip_ty <- newFlexiTyVarTy openTypeKind ; ip_var <- emitWanted origin (mkIPPred ip ip_ty) ; tcWrapResult (HsIPVar (IPName ip_var)) ip_ty res_ty } @@ -344,7 +344,7 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty | otherwise = -- The tup_args are a mixture of Present and Missing (for tuple sections) do { let kind = case boxity of { Boxed -> liftedTypeKind - ; Unboxed -> argTypeKind } + ; Unboxed -> openTypeKind } arity = length tup_args tup_tc = tupleTyCon (boxityNormalTupleSort boxity) arity diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index b780c3b2e0..6a1e73ad71 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -247,7 +247,7 @@ tcHsConArgType NewType bty = tcHsLiftedType (getBangType bty) -- Newtypes can't have bangs, but we don't check that -- until checkValidDataCon, so do not want to crash here -tcHsConArgType DataType bty = tcHsArgType (getBangType bty) +tcHsConArgType DataType bty = tcHsOpenType (getBangType bty) -- Can't allow an unlifted type for newtypes, because we're effectively -- going to remove the constructor while coercing it to a lifted type. -- And newtypes can't be bang'd @@ -266,10 +266,10 @@ tc_hs_arg_tys what tys kinds | (ty,kind,n) <- zip3 tys kinds [1..] ] --------------------------- -tcHsArgType, tcHsLiftedType :: LHsType Name -> TcM TcType +tcHsOpenType, tcHsLiftedType :: LHsType Name -> TcM TcType -- Used for type signatures -- Do not do validity checking -tcHsArgType ty = addTypeCtxt ty $ tc_lhs_type ty ekArg +tcHsOpenType ty = addTypeCtxt ty $ tc_lhs_type ty ekOpen tcHsLiftedType ty = addTypeCtxt ty $ tc_lhs_type ty ekLifted -- Like tcHsType, but takes an expected kind @@ -331,7 +331,7 @@ tc_hs_type hs_ty@(HsTyVar name) exp_kind ; return ty } tc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt) - = do { ty1' <- tc_lhs_type ty1 (EK argTypeKind ctxt) + = do { ty1' <- tc_lhs_type ty1 (EK openTypeKind ctxt) ; ty2' <- tc_lhs_type ty2 (EK openTypeKind ctxt) ; checkExpectedKind ty liftedTypeKind exp_kind ; return (mkFunTy ty1' ty2') } @@ -477,7 +477,7 @@ tc_tuple hs_ty tup_sort tys exp_kind where arg_kind = case tup_sort of HsBoxedTuple -> liftedTypeKind - HsUnboxedTuple -> argTypeKind + HsUnboxedTuple -> openTypeKind HsConstraintTuple -> constraintKind _ -> panic "tc_hs_type arg_kind" cxt_doc = case tup_sort of @@ -500,7 +500,7 @@ finish_tuple hs_ty tup_sort tau_tys exp_kind _ -> panic "tc_hs_type HsTupleTy" res_kind = case tup_sort of - HsUnboxedTuple -> ubxTupleKind + HsUnboxedTuple -> unliftedTypeKind HsBoxedTuple -> liftedTypeKind HsConstraintTuple -> constraintKind _ -> panic "tc_hs_type arg_kind" @@ -1192,9 +1192,9 @@ data ExpKind = EK TcKind SDoc instance Outputable ExpKind where ppr (EK k _) = ptext (sLit "Expected kind:") <+> ppr k -ekLifted, ekArg, ekConstraint :: ExpKind +ekLifted, ekOpen, ekConstraint :: ExpKind ekLifted = EK liftedTypeKind (ptext (sLit "Expected")) -ekArg = EK argTypeKind (ptext (sLit "Expected")) +ekOpen = EK openTypeKind (ptext (sLit "Expected")) ekConstraint = EK constraintKind (ptext (sLit "Expected")) -- Build an ExpKind for arguments diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 79b6b02950..5c57d1416f 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -849,19 +849,16 @@ expectedKindInCtxt :: UserTypeCtxt -> Maybe Kind expectedKindInCtxt (TySynCtxt _) = Nothing -- Any kind will do expectedKindInCtxt ThBrackCtxt = Nothing expectedKindInCtxt GhciCtxt = Nothing -expectedKindInCtxt ResSigCtxt = Just openTypeKind -expectedKindInCtxt ExprSigCtxt = Just openTypeKind expectedKindInCtxt (ForSigCtxt _) = Just liftedTypeKind expectedKindInCtxt InstDeclCtxt = Just constraintKind expectedKindInCtxt SpecInstCtxt = Just constraintKind -expectedKindInCtxt _ = Just argTypeKind +expectedKindInCtxt _ = Just openTypeKind checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context -- Not used for instance decls; checkValidInstance instead checkValidType ctxt ty = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) - ; unboxed <- xoptM Opt_UnboxedTuples ; rank2_flag <- xoptM Opt_Rank2Types ; rankn_flag <- xoptM Opt_RankNTypes ; polycomp <- xoptM Opt_PolymorphicComponents @@ -908,18 +905,9 @@ checkValidType ctxt ty kind_ok = case expectedKindInCtxt ctxt of Nothing -> True Just k -> tcIsSubKind actual_kind k - - ubx_tup - | not unboxed = UT_NotOk - | otherwise = case ctxt of - TySynCtxt _ -> UT_Ok - ExprSigCtxt -> UT_Ok - ThBrackCtxt -> UT_Ok - GhciCtxt -> UT_Ok - _ -> UT_NotOk -- Check the internal validity of the type itself - ; check_type rank ubx_tup ty + ; check_type rank ty -- Check that the thing has kind Type, and is lifted if necessary -- Do this second, because we can't usefully take the kind of an @@ -970,49 +958,45 @@ forAllAllowed (LimitedRank forall_ok _) = forall_ok forAllAllowed _ = False ---------------------------------------- -data UbxTupFlag = UT_Ok | UT_NotOk - -- The "Ok" version means "ok if UnboxedTuples is on" - ----------------------------------------- check_mono_type :: Rank -> KindOrType -> TcM () -- No foralls anywhere -- No unlifted types of any kind check_mono_type rank ty | isKind ty = return () -- IA0_NOTE: Do we need to check kinds? | otherwise - = do { check_type rank UT_NotOk ty + = do { check_type rank ty ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } -check_type :: Rank -> UbxTupFlag -> Type -> TcM () +check_type :: Rank -> Type -> TcM () -- The args say what the *type context* requires, independent -- of *flag* settings. You test the flag settings at usage sites. -- -- Rank is allowed rank for function args -- Rank 0 means no for-alls anywhere -check_type rank ubx_tup ty +check_type rank ty | not (null tvs && null theta) = do { checkTc (forAllAllowed rank) (forAllTyErr rank ty) -- Reject e.g. (Maybe (?x::Int => Int)), -- with a decent error message ; check_valid_theta SigmaCtxt theta - ; check_type rank ubx_tup tau -- Allow foralls to right of arrow + ; check_type rank tau -- Allow foralls to right of arrow ; checkAmbiguity tvs theta (tyVarsOfType tau) } where (tvs, theta, tau) = tcSplitSigmaTy ty -check_type _ _ (TyVarTy _) = return () +check_type _ (TyVarTy _) = return () -check_type rank _ (FunTy arg_ty res_ty) - = do { check_type arg_rank UT_NotOk arg_ty - ; check_type res_rank UT_Ok res_ty } +check_type rank (FunTy arg_ty res_ty) + = do { check_type arg_rank arg_ty + ; check_type res_rank res_ty } where (arg_rank, res_rank) = funArgResRank rank -check_type rank _ (AppTy ty1 ty2) +check_type rank (AppTy ty1 ty2) = do { check_arg_type rank ty1 ; check_arg_type rank ty2 } -check_type rank ubx_tup ty@(TyConApp tc tys) +check_type rank ty@(TyConApp tc tys) | isSynTyCon tc = do { -- Check that the synonym has enough args -- This applies equally to open and closed synonyms @@ -1030,38 +1014,34 @@ check_type rank ubx_tup ty@(TyConApp tc tys) else -- In the liberal case (only for closed syns), expand then check case tcView ty of - Just ty' -> check_type rank ubx_tup ty' + Just ty' -> check_type rank ty' Nothing -> pprPanic "check_tau_type" (ppr ty) } | isUnboxedTupleTyCon tc = do { ub_tuples_allowed <- xoptM Opt_UnboxedTuples - ; checkTc (ubx_tup_ok ub_tuples_allowed) ubx_tup_msg + ; checkTc ub_tuples_allowed ubx_tup_msg ; impred <- xoptM Opt_ImpredicativeTypes ; let rank' = if impred then ArbitraryRank else tyConArgMonoType -- c.f. check_arg_type -- However, args are allowed to be unlifted, or -- more unboxed tuples, so can't use check_arg_ty - ; mapM_ (check_type rank' UT_Ok) tys } + ; mapM_ (check_type rank') tys } | otherwise = mapM_ (check_arg_type rank) tys where - ubx_tup_ok ub_tuples_allowed = case ubx_tup of - UT_Ok -> ub_tuples_allowed - _ -> False - n_args = length tys tc_arity = tyConArity tc arity_msg = arityErr "Type synonym" (tyConName tc) tc_arity n_args ubx_tup_msg = ubxArgTyErr ty -check_type _ _ (LitTy {}) = return () +check_type _ (LitTy {}) = return () -check_type _ _ ty = pprPanic "check_type" (ppr ty) +check_type _ ty = pprPanic "check_type" (ppr ty) ---------------------------------------- check_arg_type :: Rank -> KindOrType -> TcM () @@ -1096,7 +1076,7 @@ check_arg_type rank ty -- (Ord (forall a.a)) => a -> a -- and so that if it Must be a monotype, we check that it is! - ; check_type rank' UT_NotOk ty + ; check_type rank' ty ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } -- NB the isUnLiftedType test also checks for -- T State# diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 38ef6bc380..8f5287b9f6 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -276,20 +276,7 @@ warnPrags id bad_sigs herald ----------------- mkLocalBinder :: Name -> TcType -> TcM TcId mkLocalBinder name ty - = do { checkUnboxedTuple ty $ - ptext (sLit "The variable") <+> quotes (ppr name) - ; return (Id.mkLocalId name ty) } - -checkUnboxedTuple :: TcType -> SDoc -> TcM () --- Check for an unboxed tuple type --- f = (# True, False #) --- Zonk first just in case it's hidden inside a meta type variable --- (This shows up as a (more obscure) kind error --- in the 'otherwise' case of tcMonoBinds.) -checkUnboxedTuple ty what - = do { zonked_ty <- zonkTcType ty - ; checkTc (not (isUnboxedTupleType zonked_ty)) - (unboxedTupleErr what zonked_ty) } + = return (Id.mkLocalId name ty) \end{code} Note [Polymorphism and pattern bindings] @@ -413,9 +400,7 @@ tc_pat _ p@(QuasiQuotePat _) _ _ = pprPanic "Should never see QuasiQuotePat in type checker" (ppr p) tc_pat _ (WildPat _) pat_ty thing_inside - = do { checkUnboxedTuple pat_ty $ - ptext (sLit "A wild-card pattern") - ; res <- thing_inside + = do { res <- thing_inside ; return (WildPat pat_ty, res) } tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside @@ -431,11 +416,9 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside -- If you fix it, don't forget the bindInstsOfPatIds! ; return (mkHsWrapPatCo co (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } -tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside - = do { checkUnboxedTuple overall_pat_ty $ - ptext (sLit "The view pattern") <+> ppr vpat - - -- Morally, expr must have type `forall a1...aN. OPT' -> B` +tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside + = do { + -- Morally, expr must have type `forall a1...aN. OPT' -> B` -- where overall_pat_ty is an instance of OPT'. -- Here, we infer a rho type for it, -- which replaces the leading foralls and constraints @@ -1060,9 +1043,4 @@ lazyUnliftedPatErr pat = failWithTc $ hang (ptext (sLit "A lazy (~) pattern cannot contain unlifted types:")) 2 (ppr pat) - -unboxedTupleErr :: SDoc -> Type -> SDoc -unboxedTupleErr what ty - = hang (what <+> ptext (sLit "cannot have an unboxed tuple type:")) - 2 (ppr ty) \end{code} diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index b45824fbc4..45084fcdd8 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -115,10 +115,10 @@ module TcType ( -------------------------------- -- Rexported from Kind Kind, typeKind, - unliftedTypeKind, liftedTypeKind, argTypeKind, + unliftedTypeKind, liftedTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, - isSubArgTypeKind, tcIsSubKind, splitKindFunTys, defaultKind, + tcIsSubKind, splitKindFunTys, defaultKind, mkMetaKindVar, -------------------------------- diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index c44ce31f2e..29f46f629c 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -159,7 +159,7 @@ matchExpectedFunTys herald arity orig_ty ------------ defer n_req fun_ty = addErrCtxtM mk_ctxt $ - do { arg_tys <- newFlexiTyVarTys n_req argTypeKind + do { arg_tys <- newFlexiTyVarTys n_req openTypeKind ; res_ty <- newFlexiTyVarTy openTypeKind ; co <- unifyType fun_ty (mkFunTys arg_tys res_ty) ; return (co, arg_tys, res_ty) } diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 21e828e99c..46089cdf93 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -15,15 +15,13 @@ module Kind ( SuperKind, Kind, typeKind, -- Kinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, constraintKind, + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, typeNatKind, typeStringKind, -- Kind constructors... anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, - unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, - constraintKindTyCon, + unliftedTypeKindTyCon, constraintKindTyCon, -- Super Kinds superKind, superKindTyCon, @@ -36,14 +34,13 @@ module Kind ( -- ** Predicates on Kinds isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isUbxTupleKind, isArgTypeKind, isConstraintKind, - isConstraintOrLiftedKind, isKind, isKindVar, + isConstraintKind, isConstraintOrLiftedKind, isKind, isKindVar, isSuperKind, isSuperKindTyCon, isLiftedTypeKindCon, isConstraintKindCon, isAnyKind, isAnyKindCon, okArrowArgKind, okArrowResultKind, - isSubArgTypeKind, isSubOpenTypeKind, + isSubOpenTypeKind, isSubKind, isSubKindCon, tcIsSubKind, tcIsSubKindCon, defaultKind, @@ -107,11 +104,10 @@ synTyConResKind :: TyCon -> Kind synTyConResKind tycon = kindAppResult (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon)) -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind, +isOpenTypeKind, isUnliftedTypeKind, isConstraintKind, isAnyKind, isConstraintOrLiftedKind :: Kind -> Bool -isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, - isUnliftedTypeKindCon, isSubArgTypeKindCon, +isOpenTypeKindCon, isUnliftedTypeKindCon, isSubOpenTypeKindCon, isConstraintKindCon, isLiftedTypeKindCon, isAnyKindCon :: TyCon -> Bool @@ -119,8 +115,6 @@ isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, isLiftedTypeKindCon tc = tyConUnique tc == liftedTypeKindTyConKey isAnyKindCon tc = tyConUnique tc == anyKindTyConKey isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey -isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey -isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey @@ -130,12 +124,6 @@ isAnyKind _ = False isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc isOpenTypeKind _ = False -isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc -isUbxTupleKind _ = False - -isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc -isArgTypeKind _ = False - isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc isUnliftedTypeKind _ = False @@ -158,10 +146,7 @@ okArrowArgKindCon kc | isConstraintKindCon kc = True | otherwise = False -okArrowResultKindCon kc - | okArrowArgKindCon kc = True - | isUbxTupleKindCon kc = True - | otherwise = False +okArrowResultKindCon = okArrowArgKindCon okArrowArgKind, okArrowResultKind :: Kind -> Bool okArrowArgKind (TyConApp kc []) = okArrowArgKindCon kc @@ -181,23 +166,13 @@ isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc isSubOpenTypeKind _ = False isSubOpenTypeKindCon kc - = isSubArgTypeKindCon kc - || isUbxTupleKindCon kc - || isOpenTypeKindCon kc - -isSubArgTypeKindCon kc - = isUnliftedTypeKindCon kc + = isOpenTypeKindCon kc + || isUnliftedTypeKindCon kc || isLiftedTypeKindCon kc - || isArgTypeKindCon kc || isConstraintKindCon kc -- Needed for error (Num a) "blah" -- and so that (Ord a -> Eq a) is well-kinded -- and so that (# Eq a, Ord b #) is well-kinded -isSubArgTypeKind :: Kind -> Bool --- ^ True of any sub-kind of ArgTypeKind -isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc -isSubArgTypeKind _ = False - -- | Is this a kind (i.e. a type-of-types)? isKind :: Kind -> Bool isKind k = isSuperKind (typeKind k) @@ -233,7 +208,6 @@ isSubKindCon :: TyCon -> TyCon -> Bool -- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ isSubKindCon kc1 kc2 | kc1 == kc2 = True - | isArgTypeKindCon kc2 = isSubArgTypeKindCon kc1 | isOpenTypeKindCon kc2 = isSubOpenTypeKindCon kc1 | otherwise = False @@ -281,7 +255,6 @@ defaultKind :: Kind -> Kind -- The test is really whether the kind is strictly above '*' defaultKind (TyConApp kc _args) | isOpenTypeKindCon kc = ASSERT( null _args ) liftedTypeKind - | isArgTypeKindCon kc = ASSERT( null _args ) liftedTypeKind defaultKind k = k -- Returns the free kind variables in a kind diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 62cc7bbfd1..4726f26213 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -82,13 +82,11 @@ module Type ( -- ** Common Kinds and SuperKinds anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, constraintKind, - superKind, + constraintKind, superKind, -- ** Common Kind type constructors liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, - anyKindTyCon, + constraintKindTyCon, anyKindTyCon, -- * Type free variables tyVarsOfType, tyVarsOfTypes, @@ -105,12 +103,10 @@ module Type ( -- * Other views onto Types coreView, tcView, - repType, deepRepType, + UnaryType, RepType(..), flattenRepType, repType, -- * Type representation for the code generator - PrimRep(..), - - typePrimRep, + typePrimRep, typeRepArity, -- * Main type substitution data types TvSubstEnv, -- Representation widely visible @@ -162,7 +158,7 @@ import PrelNames ( eqTyConKey ) -- others import {-# SOURCE #-} IParam ( ipTyCon ) import Unique ( Unique, hasKey ) -import BasicTypes ( IPName(..) ) +import BasicTypes ( Arity, RepArity, IPName(..) ) import Name ( Name ) import NameSet import StaticFlags @@ -616,7 +612,27 @@ newtype at outermost level; and bale out if we see it again. Representation types ~~~~~~~~~~~~~~~~~~~~ +Note [Nullary unboxed tuple] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We represent the nullary unboxed tuple as the unary (but void) type State# RealWorld. +The reason for this is that the ReprArity is never less than the Arity (as it would +otherwise be for a function type like (# #) -> Int). + +As a result, ReprArity is always strictly positive if Arity is. This is important +because it allows us to distinguish at runtime between a thunk and a function + takes a nullary unboxed tuple as an argument! + \begin{code} +type UnaryType = Type + +data RepType = UbxTupleRep [UnaryType] -- INVARIANT: never an empty list (see Note [Nullary unboxed tuple]) + | UnaryRep UnaryType + +flattenRepType :: RepType -> [UnaryType] +flattenRepType (UbxTupleRep tys) = tys +flattenRepType (UnaryRep ty) = [ty] + -- | Looks through: -- -- 1. For-alls @@ -625,29 +641,11 @@ newtype at outermost level; and bale out if we see it again. -- 4. All newtypes, including recursive ones, but not newtype families -- -- It's useful in the back end of the compiler. -repType :: Type -> Type +repType :: Type -> RepType repType ty = go emptyNameSet ty where - go :: NameSet -> Type -> Type - go rec_nts ty -- Expand predicates and synonyms - | Just ty' <- coreView ty - = go rec_nts ty' - - go rec_nts (ForAllTy _ ty) -- Drop foralls - = go rec_nts ty - - go rec_nts (TyConApp tc tys) -- Expand newtypes - | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys - = go rec_nts' ty' - - go _ ty = ty - -deepRepType :: Type -> Type --- Same as repType, but looks recursively -deepRepType ty - = go emptyNameSet ty - where + go :: NameSet -> Type -> RepType go rec_nts ty -- Expand predicates and synonyms | Just ty' <- coreView ty = go rec_nts ty' @@ -659,12 +657,12 @@ deepRepType ty | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys = go rec_nts' ty' - -- Apply recursively; this is the "deep" bit - go rec_nts (TyConApp tc tys) = TyConApp tc (map (go rec_nts) tys) - go rec_nts (AppTy ty1 ty2) = mkAppTy (go rec_nts ty1) (go rec_nts ty2) - go rec_nts (FunTy ty1 ty2) = FunTy (go rec_nts ty1) (go rec_nts ty2) + | isUnboxedTupleTyCon tc + = if null tys + then UnaryRep realWorldStatePrimTy -- See Note [Nullary unboxed tuple] + else UbxTupleRep (concatMap (flattenRepType . go rec_nts) tys) - go _ ty = ty + go _ ty = UnaryRep ty carefullySplitNewType_maybe :: NameSet -> TyCon -> [Type] -> Maybe (NameSet,Type) -- Return the representation of a newtype, unless @@ -684,15 +682,23 @@ carefullySplitNewType_maybe rec_nts tc tys -- ToDo: this could be moved to the code generator, using splitTyConApp instead -- of inspecting the type directly. --- | Discovers the primitive representation of a more abstract 'Type' --- Only applied to types of values -typePrimRep :: Type -> PrimRep -typePrimRep ty = case repType ty of - TyConApp tc _ -> tyConPrimRep tc - FunTy _ _ -> PtrRep - AppTy _ _ -> PtrRep -- See Note [AppTy rep] - TyVarTy _ -> PtrRep - _ -> pprPanic "typePrimRep" (ppr ty) +-- | Discovers the primitive representation of a more abstract 'UnaryType' +typePrimRep :: UnaryType -> PrimRep +typePrimRep ty + = case repType ty of + UbxTupleRep _ -> pprPanic "typePrimRep: UbxTupleRep" (ppr ty) + UnaryRep rep -> case rep of + TyConApp tc _ -> tyConPrimRep tc + FunTy _ _ -> PtrRep + AppTy _ _ -> PtrRep -- See Note [AppTy rep] + TyVarTy _ -> PtrRep + _ -> pprPanic "typePrimRep: UnaryRep" (ppr ty) + +typeRepArity :: Arity -> Type -> RepArity +typeRepArity 0 _ = 0 +typeRepArity n ty = case repType ty of + UnaryRep (FunTy ty1 ty2) -> length (flattenRepType (repType ty1)) + typeRepArity (n - 1) ty2 + _ -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty)) \end{code} Note [AppTy rep] diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 605c97fcc4..d0903ec12e 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -158,9 +158,7 @@ Note [The kind invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~ The kinds # UnliftedTypeKind - ArgKind super-kind of *, # - (#) UbxTupleKind - OpenKind super-kind of ArgKind, ubxTupleKind + OpenKind super-kind of *, # can never appear under an arrow or type constructor in a kind; they can only be at the top level of a kind. It follows that primitive TyCons, diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 12249d3a2b..d87f526bc8 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -19,7 +19,7 @@ module Util ( unzipWith, mapFst, mapSnd, - mapAndUnzip, mapAndUnzip3, + mapAndUnzip, mapAndUnzip3, mapAccumL2, nOfThem, filterOut, partitionWith, splitEithers, foldl1', foldl2, count, all2, @@ -35,6 +35,7 @@ module Util ( -- * Tuples fstOf3, sndOf3, thirdOf3, firstM, first3M, + third3, uncurry3, -- * List operations controlled by another list @@ -224,6 +225,9 @@ fstOf3 (a,_,_) = a sndOf3 (_,b,_) = b thirdOf3 (_,_,c) = c +third3 :: (c -> d) -> (a, b, c) -> (a, b, d) +third3 f (a, b, c) = (a, b, f c) + uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c \end{code} @@ -353,6 +357,12 @@ mapAndUnzip3 f (x:xs) (rs1, rs2, rs3) = mapAndUnzip3 f xs in (r1:rs1, r2:rs2, r3:rs3) + +mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) +mapAccumL2 f s1 s2 xs = (s1', s2', ys) + where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of + (s1', s2', y) -> ((s1', s2'), y)) + (s1, s2) xs \end{code} \begin{code} |