X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=6b326b0e32f7cf85c8f909d08d0b65b290f35cf8;hb=5479f1a02fae9141c02a7873c57af80323b0fc0d;hp=f68d94962d56ede169253cc3ba3b55275336dd8a;hpb=6821c8a47c0fc61a2d989d368f926cc0ded776e9;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index f68d949..6b326b0 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -15,13 +15,6 @@ The "tc" prefix is for "TypeChecker", because the type checker is the principal client. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcType ( -------------------------------- -- Types @@ -48,7 +41,7 @@ module TcType ( -- Splitters -- These are important because they do not look through newtypes tcView, - tcSplitForAllTys, tcSplitPhiTy, + tcSplitForAllTys, tcSplitPhiTy, tcSplitPredFunTy_maybe, tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe, @@ -78,7 +71,8 @@ module TcType ( getClassPredTys_maybe, getClassPredTys, isClassPred, isTyVarClassPred, isEqPred, mkDictTy, tcSplitPredTy_maybe, - isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, + isPredTy, isDictTy, isDictLikeTy, + tcSplitDFunTy, tcSplitDFunHead, predTyUnique, mkClassPred, isInheritablePred, isIPPred, dataConsStupidTheta, isRefineableTy, isRefineablePred, @@ -94,6 +88,7 @@ module TcType ( isFFIDotnetTy, -- :: DynFlags -> Type -> Bool isFFIDotnetObjTy, -- :: Type -> Bool isFFITy, -- :: Type -> Bool + isFunPtrTy, -- :: Type -> Bool tcSplitIOType_maybe, -- :: Type -> Maybe Type toDNType, -- :: Type -> DNType @@ -103,7 +98,7 @@ module TcType ( unliftedTypeKind, liftedTypeKind, argTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, - isSubArgTypeKind, isSubKind, defaultKind, + isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind, kindVarRef, mkKindVar, Type, PredType(..), ThetaType, @@ -153,7 +148,6 @@ import TyCon -- others: import DynFlags -import CoreSyn import Name import NameSet import VarEnv @@ -381,7 +375,7 @@ kindVarRef tc = ASSERT ( isTcTyVar tc ) case tcTyVarDetails tc of MetaTv TauTv ref -> ref - other -> pprPanic "kindVarRef" (ppr tc) + _ -> pprPanic "kindVarRef" (ppr tc) mkKindVar :: Unique -> IORef MetaDetails -> KindVar mkKindVar u r @@ -428,7 +422,7 @@ pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma") tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar) -- Tidy the type inside a GenSkol, preparatory to printing it tidySkolemTyVar env tv - = ASSERT( isSkolemTyVar tv || isSigTyVar tv ) + = ASSERT( isTcTyVar tv && (isSkolemTyVar tv || isSigTyVar tv ) ) (env1, mkTcTyVar (tyVarName tv) (tyVarKind tv) info1) where (env1, info1) = case tcTyVarDetails tv of @@ -515,7 +509,7 @@ isTyConableTyVar tv SkolemTv {} -> False isSkolemTyVar tv - = ASSERT( isTcTyVar tv ) + = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of SkolemTv _ -> True MetaTv _ _ -> False @@ -524,39 +518,40 @@ isExistentialTyVar tv -- Existential type variable, bound by a pattern = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of SkolemTv (PatSkol {}) -> True - other -> False + _ -> False isMetaTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of MetaTv _ _ -> True - other -> False + _ -> False isBoxyTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of MetaTv BoxTv _ -> True - other -> False + _ -> False +isSigTyVar :: Var -> Bool isSigTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of MetaTv (SigTv _) _ -> True - other -> False + _ -> False metaTvRef :: TyVar -> IORef MetaDetails metaTvRef tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of MetaTv _ ref -> ref - other -> pprPanic "metaTvRef" (ppr tv) + _ -> pprPanic "metaTvRef" (ppr tv) isFlexi, isIndirect :: MetaDetails -> Bool -isFlexi Flexi = True -isFlexi other = False +isFlexi Flexi = True +isFlexi _ = False isIndirect (Indirect _) = True -isIndirect other = False +isIndirect _ = False isRuntimeUnk :: TyVar -> Bool isRuntimeUnk x | isTcTyVar x @@ -594,8 +589,8 @@ isTauTy (TyVarTy tv) = ASSERT( not (isTcTyVar tv && isBoxyTyVar tv) ) isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc isTauTy (AppTy a b) = isTauTy a && isTauTy b isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (PredTy p) = True -- Don't look through source types -isTauTy other = False +isTauTy (PredTy _) = True -- Don't look through source types +isTauTy _ = False isTauTyCon :: TyCon -> Bool @@ -631,7 +626,7 @@ getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty' getDFunTyKey (TyVarTy tv) = getOccName tv getDFunTyKey (TyConApp tc _) = getOccName tc getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (FunTy arg _) = getOccName funTyCon +getDFunTyKey (FunTy _ _) = getOccName funTyCon getDFunTyKey (ForAllTy _ t) = getDFunTyKey t getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) -- PredTy shouldn't happen @@ -657,24 +652,33 @@ tcSplitForAllTys :: Type -> ([TyVar], Type) tcSplitForAllTys ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs - split orig_ty (ForAllTy tv ty) tvs + split _ (ForAllTy tv ty) tvs | not (isCoVar tv) = split ty ty (tv:tvs) - split orig_ty t tvs = (reverse tvs, orig_ty) + split orig_ty _ tvs = (reverse tvs, orig_ty) +tcIsForAllTy :: Type -> Bool tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy tv ty) = not (isCoVar tv) -tcIsForAllTy t = False +tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv) +tcIsForAllTy _ = False + +tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) +-- Split off the first predicate argument from a type +tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' +tcSplitPredFunTy_maybe (ForAllTy tv ty) + | isCoVar tv = Just (coVarPred tv, ty) +tcSplitPredFunTy_maybe (FunTy arg res) + | Just p <- tcSplitPredTy_maybe arg = Just (p, res) +tcSplitPredFunTy_maybe _ + = Nothing tcSplitPhiTy :: Type -> (ThetaType, Type) -tcSplitPhiTy ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs - - split orig_ty (ForAllTy tv ty) ts - | isCoVar tv = split ty ty (coVarPred tv : ts) - split orig_ty (FunTy arg res) ts - | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts) - split orig_ty ty ts = (reverse ts, orig_ty) +tcSplitPhiTy ty + = split ty [] + where + split ty ts + = case tcSplitPredFunTy_maybe ty of + Just (pred, ty) -> split ty (pred:ts) + Nothing -> (reverse ts, ty) tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) tcSplitSigmaTy ty = case tcSplitForAllTys ty of @@ -695,7 +699,7 @@ tcMultiSplitSigmaTy tcMultiSplitSigmaTy sigma = case (tcSplitSigmaTy sigma) of - ([],[],ty) -> ([], sigma) + ([], [], _) -> ([], sigma) (tvs, theta, ty) -> case tcMultiSplitSigmaTy ty of (pairs, rest) -> ((tvs,theta):pairs, rest) @@ -722,7 +726,7 @@ tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -- Newtypes are opaque, so they may be split -- However, predicates are not treated -- as tycon applications by the type checker -tcSplitTyConApp_maybe other = Nothing +tcSplitTyConApp_maybe _ = Nothing ----------------------- tcSplitFunTys :: Type -> ([Type], Type) @@ -735,7 +739,7 @@ tcSplitFunTys ty = case tcSplitFunTy_maybe ty of tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res) -tcSplitFunTy_maybe other = Nothing +tcSplitFunTy_maybe _ = Nothing -- Note the (not (isPredTy arg)) guard -- Consider (?x::Int) => Bool -- We don't want to treat this as a function type! @@ -759,8 +763,13 @@ tcSplitFunTysN ty n_args | otherwise = ([], ty) +tcSplitFunTy :: Type -> (Type, Type) tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) + +tcFunArgTy :: Type -> Type tcFunArgTy ty = fst (tcSplitFunTy ty) + +tcFunResultTy :: Type -> Type tcFunResultTy ty = snd (tcSplitFunTy ty) ----------------------- @@ -784,8 +793,8 @@ tcSplitAppTys ty ----------------------- tcGetTyVar_maybe :: Type -> Maybe TyVar tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty' -tcGetTyVar_maybe (TyVarTy tv) = Just tv -tcGetTyVar_maybe other = Nothing +tcGetTyVar_maybe (TyVarTy tv) = Just tv +tcGetTyVar_maybe _ = Nothing tcGetTyVar :: String -> Type -> TyVar tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty) @@ -805,7 +814,7 @@ tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead tau = case tcSplitPredTy_maybe tau of Just (ClassP clas tys) -> (clas, tys) - other -> panic "tcSplitDFunHead" + _ -> panic "tcSplitDFunHead" tcInstHeadTyNotSynonym :: Type -> Bool -- Used in Haskell-98 mode, for the argument types of an instance head @@ -813,7 +822,7 @@ tcInstHeadTyNotSynonym :: Type -> Bool -- are transparent, so we need a special function here tcInstHeadTyNotSynonym ty = case ty of - TyConApp tc tys -> not (isSynTyCon tc) + TyConApp tc _ -> not (isSynTyCon tc) _ -> True tcInstHeadTyAppAllTyVars :: Type -> Bool @@ -823,7 +832,7 @@ tcInstHeadTyAppAllTyVars ty = case ty of TyConApp _ tys -> ok tys FunTy arg res -> ok [arg, res] - other -> False + _ -> False where -- Check that all the types are type variables, -- and that each is distinct @@ -832,7 +841,7 @@ tcInstHeadTyAppAllTyVars ty tvs = mapCatMaybes get_tv tys get_tv (TyVarTy tv) = Just tv -- through synonyms - get_tv other = Nothing + get_tv _ = Nothing \end{code} @@ -848,34 +857,36 @@ tcSplitPredTy_maybe :: Type -> Maybe PredType -- Returns Just for predicates only tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty' tcSplitPredTy_maybe (PredTy p) = Just p -tcSplitPredTy_maybe other = Nothing - +tcSplitPredTy_maybe _ = Nothing + predTyUnique :: PredType -> Unique -predTyUnique (IParam n _) = getUnique (ipNameName n) -predTyUnique (ClassP clas tys) = getUnique clas -predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b)) +predTyUnique (IParam n _) = getUnique (ipNameName n) +predTyUnique (ClassP clas _) = getUnique clas +predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b)) \end{code} --------------------- Dictionary types --------------------------------- \begin{code} +mkClassPred :: Class -> [Type] -> PredType mkClassPred clas tys = ClassP clas tys isClassPred :: PredType -> Bool -isClassPred (ClassP clas tys) = True -isClassPred other = False +isClassPred (ClassP _ _) = True +isClassPred _ = False -isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys -isTyVarClassPred other = False +isTyVarClassPred :: PredType -> Bool +isTyVarClassPred (ClassP _ tys) = all tcIsTyVarTy tys +isTyVarClassPred _ = False getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) -getClassPredTys_maybe _ = Nothing +getClassPredTys_maybe _ = Nothing getClassPredTys :: PredType -> (Class, [Type]) getClassPredTys (ClassP clas tys) = (clas, tys) -getClassPredTys other = panic "getClassPredTys" +getClassPredTys _ = panic "getClassPredTys" mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = mkPredTy (ClassP clas tys) @@ -883,15 +894,52 @@ mkDictTy clas tys = mkPredTy (ClassP clas tys) isDictTy :: Type -> Bool isDictTy ty | Just ty' <- tcView ty = isDictTy ty' isDictTy (PredTy p) = isClassPred p -isDictTy other = False +isDictTy _ = False + +isDictLikeTy :: Type -> Bool +-- Note [Dictionary-like types] +isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty' +isDictLikeTy (PredTy p) = isClassPred p +isDictLikeTy (TyConApp tc tys) + | isTupleTyCon tc = all isDictLikeTy tys +isDictLikeTy _ = False \end{code} +Note [Dictionary-like types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Being "dictionary-like" means either a dictionary type or a tuple thereof. +In GHC 6.10 we build implication constraints which construct such tuples, +and if we land up with a binding + t :: (C [a], Eq [a]) + t = blah +then we want to treat t as cheap under "-fdicts-cheap" for example. +(Implication constraints are normally inlined, but sadly not if the +occurrence is itself inside an INLINE function! Until we revise the +handling of implication constraints, that is.) This turned out to +be important in getting good arities in DPH code. Example: + + class C a + class D a where { foo :: a -> a } + instance C a => D (Maybe a) where { foo x = x } + + bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) + {-# INLINE bar #-} + bar x y = (foo (Just x), foo (Just y)) + +Then 'bar' should jolly well have arity 4 (two dicts, two args), but +we ended up with something like + bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... + in \x,y. ) + +This is all a bit ad-hoc; eg it relies on knowing that implication +constraints build tuples. + --------------------- Implicit parameters --------------------------------- \begin{code} isIPPred :: PredType -> Bool isIPPred (IParam _ _) = True -isIPPred other = False +isIPPred _ = False isInheritablePred :: PredType -> Bool -- Can be inherited by a context. For example, consider @@ -904,7 +952,7 @@ isInheritablePred :: PredType -> Bool -- which can be free in g's rhs, and shared by both calls to g isInheritablePred (ClassP _ _) = True isInheritablePred (EqPred _ _) = True -isInheritablePred other = False +isInheritablePred _ = False \end{code} --------------------- Equality predicates --------------------------------- @@ -950,24 +998,29 @@ any foralls. E.g. \begin{code} isSigmaTy :: Type -> Bool isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty' -isSigmaTy (ForAllTy tyvar ty) = True -isSigmaTy (FunTy a b) = isPredTy a -isSigmaTy _ = False +isSigmaTy (ForAllTy _ _) = True +isSigmaTy (FunTy a _) = isPredTy a +isSigmaTy _ = False isOverloadedTy :: Type -> Bool +-- Yes for a type of a function that might require evidence-passing +-- Used only by bindInstsOfLocalFuns/Pats +-- NB: be sure to check for type with an equality predicate; hence isCoVar isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' -isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty -isOverloadedTy (FunTy a b) = isPredTy a -isOverloadedTy _ = False +isOverloadedTy (ForAllTy tv ty) = isCoVar tv || isOverloadedTy ty +isOverloadedTy (FunTy a _) = isPredTy a +isOverloadedTy _ = False isPredTy :: Type -> Bool -- Belongs in TcType because it does -- not look through newtypes, or predtypes (of course) isPredTy ty | Just ty' <- tcView ty = isPredTy ty' -isPredTy (PredTy sty) = True -isPredTy _ = False +isPredTy (PredTy _) = True +isPredTy _ = False \end{code} \begin{code} +isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, + isUnitTy, isCharTy :: Type -> Bool isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isIntegerTy = is_tc integerTyConKey @@ -977,10 +1030,11 @@ isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey isCharTy = is_tc charTyConKey +isStringTy :: Type -> Bool isStringTy ty = case tcSplitTyConApp_maybe ty of Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty - other -> False + _ -> False is_tc :: Unique -> Type -> Bool -- Newtypes are opaque to this @@ -994,8 +1048,9 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of -- hence no 'coreView'. This could, however, be changed without breaking -- any code. isOpenSynTyConApp :: TcTauType -> Bool -isOpenSynTyConApp (TyConApp tc _) = isOpenSynTyCon tc -isOpenSynTyConApp _other = False +isOpenSynTyConApp (TyConApp tc tys) = isOpenSynTyCon tc && + length tys == tyConArity tc +isOpenSynTyConApp _other = False \end{code} @@ -1018,7 +1073,7 @@ tcTyVarsOfType :: Type -> TcTyVarSet -- (Types.tyVarsOfTypes finds all free TyVars) tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv else emptyVarSet -tcTyVarsOfType (TyConApp tycon tys) = tcTyVarsOfTypes tys +tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg @@ -1076,7 +1131,7 @@ exactTyVarsOfType ty where go ty | Just ty' <- tcView ty = go ty' -- This is the key line go (TyVarTy tv) = unitVarSet tv - go (TyConApp tycon tys) = exactTyVarsOfTypes tys + go (TyConApp _ tys) = exactTyVarsOfTypes tys go (PredTy ty) = go_pred ty go (FunTy arg res) = go arg `unionVarSet` go res go (AppTy fun arg) = go fun `unionVarSet` go arg @@ -1099,15 +1154,16 @@ end of the compiler. \begin{code} tyClsNamesOfType :: Type -> NameSet -tyClsNamesOfType (TyVarTy tv) = emptyNameSet +tyClsNamesOfType (TyVarTy _) = emptyNameSet tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys -tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty +tyClsNamesOfType (PredTy (IParam _ ty)) = tyClsNamesOfType ty tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys tyClsNamesOfType (PredTy (EqPred ty1 ty2)) = tyClsNamesOfType ty1 `unionNameSets` tyClsNamesOfType ty2 tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg -tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty +tyClsNamesOfType (ForAllTy _ ty) = tyClsNamesOfType ty +tyClsNamesOfTypes :: [Type] -> NameSet tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys tyClsNamesOfDFunHead :: Type -> NameSet @@ -1119,7 +1175,7 @@ tyClsNamesOfDFunHead :: Type -> NameSet -- even if Foo *is* locally defined tyClsNamesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of - (tvs,_,head_ty) -> tyClsNamesOfType head_ty + (_, _, head_ty) -> tyClsNamesOfType head_ty \end{code} @@ -1155,7 +1211,7 @@ tcSplitIOType_maybe ty Nothing -> Nothing Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2) - other -> Nothing + _ -> Nothing isFFITy :: Type -> Bool -- True for any TyCon that can possibly be an arg or result of an FFI call @@ -1200,12 +1256,16 @@ isFFIDotnetTy dflags ty -- it no longer does so. May need to adjust isFFIDotNetTy -- if we do want to look through newtypes. +isFFIDotnetObjTy :: Type -> Bool isFFIDotnetObjTy ty = checkRepTyCon check_tc t_ty where (_, t_ty) = tcSplitForAllTys ty check_tc tc = getName tc == objectTyConName +isFunPtrTy :: Type -> Bool +isFunPtrTy = checkRepTyConKey [funPtrTyConKey] + toDNType :: Type -> DNType toDNType ty | isStringTy ty = DNString @@ -1240,14 +1300,19 @@ toDNType ty ] checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool - -- Look through newtypes - -- Non-recursive ones are transparent to splitTyConApp, - -- but recursive ones aren't. Manuel had: - -- newtype T = MkT (Ptr T) - -- and wanted it to work... -checkRepTyCon check_tc ty - | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc - | otherwise = False +-- Look through newtypes, but *not* foralls +-- Should work even for recursive newtypes +-- eg Manuel had: newtype T = MkT (Ptr T) +checkRepTyCon check_tc ty + = go [] ty + where + go rec_nts ty + | Just (tc,tys) <- splitTyConApp_maybe ty + = case carefullySplitNewType_maybe rec_nts tc tys of + Just (rec_nts', ty') -> go rec_nts' ty' + Nothing -> check_tc tc + | otherwise + = False checkRepTyConKey :: [Unique] -> Type -> Bool -- Like checkRepTyCon, but just looks at the TyCon key @@ -1278,7 +1343,7 @@ legalFEResultTyCon tc legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool -- Checks validity of types going from Haskell -> external world -legalOutgoingTyCon dflags safety tc +legalOutgoingTyCon dflags _ tc = marshalableTyCon dflags tc legalFFITyCon :: TyCon -> Bool @@ -1286,15 +1351,17 @@ legalFFITyCon :: TyCon -> Bool legalFFITyCon tc = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon +marshalableTyCon :: DynFlags -> TyCon -> Bool marshalableTyCon dflags tc = (dopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc && not (isUnboxedTupleTyCon tc) && case tyConPrimRep tc of -- Note [Marshalling VoidRep] VoidRep -> False - other -> True) + _ -> True) || boxedMarshalableTyCon tc +boxedMarshalableTyCon :: TyCon -> Bool boxedMarshalableTyCon tc = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey , int32TyConKey, int64TyConKey