X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=f68d94962d56ede169253cc3ba3b55275336dd8a;hp=3d4249854195e30f06ea640679ad95274ea1090f;hb=6821c8a47c0fc61a2d989d368f926cc0ded776e9;hpb=272fb49ecfeffe7aaa66b9b61bab12d8a858458d diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 3d42498..f68d949 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -15,6 +15,13 @@ 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 @@ -28,9 +35,10 @@ module TcType ( UserTypeCtxt(..), pprUserTypeCtxt, TcTyVarDetails(..), BoxInfo(..), pprTcTyVarDetails, MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolTvBinding, pprSkolInfo, - isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isBoxyTyVar, isSigTyVar, isExistentialTyVar, + isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isBoxyTyVar, + isSigTyVar, isExistentialTyVar, isTyConableTyVar, metaTvRef, - isFlexi, isIndirect, + isFlexi, isIndirect, isRuntimeUnk, isUnk, -------------------------------- -- Builders @@ -44,7 +52,8 @@ module TcType ( tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe, - tcValidInstHeadTy, tcGetTyVar_maybe, tcGetTyVar, + tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars, + tcGetTyVar_maybe, tcGetTyVar, tcSplitSigmaTy, tcMultiSplitSigmaTy, --------------------------------- @@ -53,9 +62,10 @@ module TcType ( tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX, eqKind, isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy, - isDoubleTy, isFloatTy, isIntTy, isStringTy, - isIntegerTy, isBoolTy, isUnitTy, + isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, + isIntegerTy, isBoolTy, isUnitTy, isCharTy, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, + isOpenSynTyConApp, --------------------------------- -- Misc type manipulators @@ -122,7 +132,7 @@ module TcType ( tcTyVarsOfType, tcTyVarsOfTypes, exactTyVarsOfType, exactTyVarsOfTypes, pprKind, pprParendKind, - pprType, pprParendType, pprTyThingCategory, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprPred, pprTheta, pprThetaArrow, pprClassPred ) where @@ -138,6 +148,7 @@ import ForeignCall import Unify import VarSet import Type +import Coercion import TyCon -- others: @@ -154,12 +165,12 @@ import Util import Maybes import ListSetOps import Outputable +import FastString import Data.List import Data.IORef \end{code} - %************************************************************************ %* * \subsection{Types} @@ -292,12 +303,12 @@ data BoxInfo -- b2 is another (currently empty) box. data MetaDetails - = Flexi -- Flexi type variables unify to become - -- Indirects. + = Flexi -- Flexi type variables unify to become + -- Indirects. - | Indirect TcType -- INVARIANT: - -- For a BoxTv, this type must be non-boxy - -- For a TauTv, this type must be a tau-type + | Indirect TcType -- INVARIANT: + -- For a BoxTv, this type must be non-boxy + -- For a TauTv, this type must be a tau-type -- Generally speaking, SkolemInfo should not contain location info -- that is contained in the Name of the tyvar with this SkolemInfo @@ -322,6 +333,9 @@ data SkolemInfo | GenSkol [TcTyVar] -- Bound when doing a subsumption check for TcType -- (forall tvs. ty) + | RuntimeUnkSkol -- a type variable used to represent an unknown + -- runtime type (used in the GHCi debugger) + | UnkSkol -- Unhelpful info (until I improve it) ------------------------------------- @@ -381,7 +395,6 @@ kind_var_occ :: OccName -- Just one for all KindVars -- They may be jiggled by tidying kind_var_occ = mkOccName tvName "k" \end{code} -\end{code} %************************************************************************ %* * @@ -392,23 +405,23 @@ kind_var_occ = mkOccName tvName "k" \begin{code} pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging -pprTcTyVarDetails (SkolemTv _) = ptext SLIT("sk") -pprTcTyVarDetails (MetaTv BoxTv _) = ptext SLIT("box") -pprTcTyVarDetails (MetaTv TauTv _) = ptext SLIT("tau") -pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext SLIT("sig") +pprTcTyVarDetails (SkolemTv _) = ptext (sLit "sk") +pprTcTyVarDetails (MetaTv BoxTv _) = ptext (sLit "box") +pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") +pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig") pprUserTypeCtxt :: UserTypeCtxt -> SDoc -pprUserTypeCtxt (FunSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n) -pprUserTypeCtxt ExprSigCtxt = ptext SLIT("an expression type signature") -pprUserTypeCtxt (ConArgCtxt c) = ptext SLIT("the type of the constructor") <+> quotes (ppr c) -pprUserTypeCtxt (TySynCtxt c) = ptext SLIT("the RHS of the type synonym") <+> quotes (ppr c) -pprUserTypeCtxt GenPatCtxt = ptext SLIT("the type pattern of a generic definition") -pprUserTypeCtxt LamPatSigCtxt = ptext SLIT("a pattern type signature") -pprUserTypeCtxt BindPatSigCtxt = ptext SLIT("a pattern type signature") -pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature") -pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign declaration for") <+> quotes (ppr n) -pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a type in a `default' declaration") -pprUserTypeCtxt SpecInstCtxt = ptext SLIT("a SPECIALISE instance pragma") +pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n) +pprUserTypeCtxt ExprSigCtxt = ptext (sLit "an expression type signature") +pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c) +pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c) +pprUserTypeCtxt GenPatCtxt = ptext (sLit "the type pattern of a generic definition") +pprUserTypeCtxt LamPatSigCtxt = ptext (sLit "a pattern type signature") +pprUserTypeCtxt BindPatSigCtxt = ptext (sLit "a pattern type signature") +pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature") +pprUserTypeCtxt (ForSigCtxt n) = ptext (sLit "the foreign declaration for") <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration") +pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma") -------------------------------- @@ -438,36 +451,39 @@ pprSkolTvBinding :: TcTyVar -> SDoc -- or nothing if we don't have anything useful to say pprSkolTvBinding tv = ASSERT ( isTcTyVar tv ) - ppr_details (tcTyVarDetails tv) + quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv) where - ppr_details (MetaTv TauTv _) = quotes (ppr tv) <+> ptext SLIT("is a meta type variable") - ppr_details (MetaTv BoxTv _) = quotes (ppr tv) <+> ptext SLIT("is a boxy type variable") + ppr_details (MetaTv TauTv _) = ptext (sLit "is a meta type variable") + ppr_details (MetaTv BoxTv _) = ptext (sLit "is a boxy type variable") ppr_details (MetaTv (SigTv info) _) = ppr_skol info ppr_details (SkolemTv info) = ppr_skol info - ppr_skol UnkSkol = empty -- Unhelpful; omit - ppr_skol info = quotes (ppr tv) <+> ptext SLIT("is bound by") - <+> sep [pprSkolInfo info, nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))] + ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful + ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type") + ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"), + sep [pprSkolInfo info, + nest 2 (ptext (sLit "at") <+> ppr (getSrcLoc tv))]] pprSkolInfo :: SkolemInfo -> SDoc pprSkolInfo (SigSkol ctxt) = pprUserTypeCtxt ctxt -pprSkolInfo (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls) -pprSkolInfo InstSkol = ptext SLIT("the instance declaration") -pprSkolInfo FamInstSkol = ptext SLIT("the family instance declaration") -pprSkolInfo (RuleSkol name) = ptext SLIT("the RULE") <+> doubleQuotes (ftext name) -pprSkolInfo ArrowSkol = ptext SLIT("the arrow form") -pprSkolInfo (PatSkol dc) = sep [ptext SLIT("the constructor") <+> quotes (ppr dc)] -pprSkolInfo (GenSkol tvs ty) = sep [ptext SLIT("the polymorphic type"), +pprSkolInfo (ClsSkol cls) = ptext (sLit "the class declaration for") <+> quotes (ppr cls) +pprSkolInfo InstSkol = ptext (sLit "the instance declaration") +pprSkolInfo FamInstSkol = ptext (sLit "the family instance declaration") +pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name) +pprSkolInfo ArrowSkol = ptext (sLit "the arrow form") +pprSkolInfo (PatSkol dc) = sep [ptext (sLit "the constructor") <+> quotes (ppr dc)] +pprSkolInfo (GenSkol tvs ty) = sep [ptext (sLit "the polymorphic type"), nest 2 (quotes (ppr (mkForAllTys tvs ty)))] -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen pprSkolInfo UnkSkol = panic "UnkSkol" +pprSkolInfo RuntimeUnkSkol = panic "RuntimeUnkSkol" instance Outputable MetaDetails where - ppr Flexi = ptext SLIT("Flexi") - ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty + ppr Flexi = ptext (sLit "Flexi") + ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty \end{code} @@ -478,11 +494,26 @@ instance Outputable MetaDetails where %************************************************************************ \begin{code} -isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isBoxyTyVar, isMetaTyVar :: TyVar -> Bool +isImmutableTyVar :: TyVar -> Bool + isImmutableTyVar tv | isTcTyVar tv = isSkolemTyVar tv | otherwise = True +isTyConableTyVar, isSkolemTyVar, isExistentialTyVar, + isBoxyTyVar, isMetaTyVar :: TcTyVar -> Bool + +isTyConableTyVar tv + -- True of a meta-type variable that can be filled in + -- with a type constructor application; in particular, + -- not a SigTv + = ASSERT( isTcTyVar tv) + case tcTyVarDetails tv of + MetaTv BoxTv _ -> True + MetaTv TauTv _ -> True + MetaTv (SigTv {}) _ -> False + SkolemTv {} -> False + isSkolemTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of @@ -515,17 +546,27 @@ isSigTyVar tv metaTvRef :: TyVar -> IORef MetaDetails metaTvRef tv - = ASSERT( isTcTyVar tv ) + = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of MetaTv _ ref -> ref other -> pprPanic "metaTvRef" (ppr tv) isFlexi, isIndirect :: MetaDetails -> Bool -isFlexi Flexi = True -isFlexi other = False +isFlexi Flexi = True +isFlexi other = False isIndirect (Indirect _) = True isIndirect other = False + +isRuntimeUnk :: TyVar -> Bool +isRuntimeUnk x | isTcTyVar x + , SkolemTv RuntimeUnkSkol <- tcTyVarDetails x = True + | otherwise = False + +isUnk :: TyVar -> Bool +isUnk x | isTcTyVar x + , SkolemTv UnkSkol <- tcTyVarDetails x = True + | otherwise = False \end{code} @@ -571,10 +612,10 @@ isRigidTy :: TcType -> Bool -- A type is rigid if it has no meta type variables in it isRigidTy ty = all isImmutableTyVar (varSetElems (tcTyVarsOfType ty)) -isRefineableTy :: TcType -> Bool +isRefineableTy :: TcType -> (Bool,Bool) -- A type should have type refinements applied to it if it has -- free type variables, and they are all rigid -isRefineableTy ty = not (null tc_tvs) && all isImmutableTyVar tc_tvs +isRefineableTy ty = (null tc_tvs, all isImmutableTyVar tc_tvs) where tc_tvs = varSetElems (tcTyVarsOfType ty) @@ -630,9 +671,7 @@ tcSplitPhiTy ty = split ty ty [] 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 (eq_pred:ts) - where - PredTy eq_pred = tyVarKind tv + | 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) @@ -694,9 +733,16 @@ tcSplitFunTys ty = case tcSplitFunTy_maybe ty of (args,res') = tcSplitFunTys res tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) -tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' -tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res) -tcSplitFunTy_maybe other = Nothing +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 + -- Note the (not (isPredTy arg)) guard + -- Consider (?x::Int) => Bool + -- We don't want to treat this as a function type! + -- A concrete example is test tc230: + -- f :: () -> (?p :: ()) => () -> () + -- + -- g = f () () tcSplitFunTysN :: TcRhoType @@ -761,14 +807,21 @@ tcSplitDFunHead tau Just (ClassP clas tys) -> (clas, tys) other -> panic "tcSplitDFunHead" -tcValidInstHeadTy :: Type -> Bool +tcInstHeadTyNotSynonym :: Type -> Bool -- Used in Haskell-98 mode, for the argument types of an instance head -- These must not be type synonyms, but everywhere else type synonyms -- are transparent, so we need a special function here -tcValidInstHeadTy ty +tcInstHeadTyNotSynonym ty = case ty of - NoteTy _ ty -> tcValidInstHeadTy ty - TyConApp tc tys -> not (isSynTyCon tc) && ok tys + TyConApp tc tys -> not (isSynTyCon tc) + _ -> True + +tcInstHeadTyAppAllTyVars :: Type -> Bool +-- Used in Haskell-98 mode, for the argument types of an instance head +-- These must be a constructor applied to type variable arguments +tcInstHeadTyAppAllTyVars ty + = case ty of + TyConApp _ tys -> ok tys FunTy arg res -> ok [arg, res] other -> False where @@ -778,7 +831,6 @@ tcValidInstHeadTy ty where tvs = mapCatMaybes get_tv tys - get_tv (NoteTy _ ty) = get_tv ty -- Again, do not look get_tv (TyVarTy tv) = Just tv -- through synonyms get_tv other = Nothing \end{code} @@ -801,6 +853,7 @@ tcSplitPredTy_maybe other = 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)) \end{code} @@ -874,11 +927,11 @@ dataConsStupidTheta (con1:cons) = nubBy tcEqPred all_preds where all_preds = dataConStupidTheta con1 ++ other_stupids - res_tys1 = dataConResTys con1 - tvs1 = tyVarsOfTypes res_tys1 + res_ty1 = dataConOrigResTy con1 other_stupids = [ substPred subst pred | con <- cons - , let Just subst = tcMatchTys tvs1 res_tys1 (dataConResTys con) + , let (tvs, _, _, res_ty) = dataConSig con + Just subst = tcMatchTy (mkVarSet tvs) res_ty res_ty1 , pred <- dataConStupidTheta con ] dataConsStupidTheta [] = panic "dataConsStupidTheta" \end{code} @@ -919,8 +972,15 @@ isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isIntegerTy = is_tc integerTyConKey isIntTy = is_tc intTyConKey +isWordTy = is_tc wordTyConKey isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey +isCharTy = is_tc charTyConKey + +isStringTy ty + = case tcSplitTyConApp_maybe ty of + Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty + other -> False is_tc :: Unique -> Type -> Bool -- Newtypes are opaque to this @@ -929,6 +989,15 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of Nothing -> False \end{code} +\begin{code} +-- NB: Currently used in places where we have already expanded type synonyms; +-- hence no 'coreView'. This could, however, be changed without breaking +-- any code. +isOpenSynTyConApp :: TcTauType -> Bool +isOpenSynTyConApp (TyConApp tc _) = isOpenSynTyCon tc +isOpenSynTyConApp _other = False +\end{code} + %************************************************************************ %* * @@ -950,7 +1019,6 @@ tcTyVarsOfType :: Type -> TcTyVarSet tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv else emptyVarSet tcTyVarsOfType (TyConApp tycon tys) = tcTyVarsOfTypes tys -tcTyVarsOfType (NoteTy _ ty) = tcTyVarsOfType ty tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg @@ -990,6 +1058,15 @@ exactTyVarsOfType is used by the type checker to figure out exactly which type variables are mentioned in a type. It's also used in the smart-app checking code --- see TcExpr.tcIdApp +On the other hand, consider a *top-level* definition + f = (\x -> x) :: T a -> T a +If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then +if we have an application like (f "x") we get a confusing error message +involving Any. So the conclusion is this: when generalising + - at top level use tyVarsOfType + - in nested bindings use exactTyVarsOfType +See Trac #1813 for example. + \begin{code} exactTyVarsOfType :: TcType -> TyVarSet -- Find the free type variables (of any kind) @@ -1024,7 +1101,6 @@ end of the compiler. tyClsNamesOfType :: Type -> NameSet tyClsNamesOfType (TyVarTy tv) = emptyNameSet tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys -tyClsNamesOfType (NoteTy _ ty2) = tyClsNamesOfType ty2 tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys tyClsNamesOfType (PredTy (EqPred ty1 ty2)) = tyClsNamesOfType ty1 `unionNameSets` tyClsNamesOfType ty2 @@ -1058,22 +1134,28 @@ restricted set of types as arguments and results (the restricting factor being the ) \begin{code} -tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) --- (isIOType t) returns (Just (IO,t')) if t is of the form (IO t'), or --- some newtype wrapping thereof +tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, CoercionI) +-- (isIOType t) returns Just (IO,t',co) +-- if co : t ~ IO t' -- returns Nothing otherwise tcSplitIOType_maybe ty - | Just (io_tycon, [io_res_ty]) <- tcSplitTyConApp_maybe ty, + = case tcSplitTyConApp_maybe ty of -- This split absolutely has to be a tcSplit, because we must -- see the IO type; and it's a newtype which is transparent to splitTyConApp. - io_tycon `hasKey` ioTyConKey - = Just (io_tycon, io_res_ty) - | Just ty' <- coreView ty -- Look through non-recursive newtypes - = tcSplitIOType_maybe ty' + Just (io_tycon, [io_res_ty]) + | io_tycon `hasKey` ioTyConKey + -> Just (io_tycon, io_res_ty, IdCo) - | otherwise - = Nothing + Just (tc, tys) + | not (isRecursiveTyCon tc) + , Just (ty, co1) <- instNewTyCon_maybe tc tys + -- Newtypes that require a coercion are ok + -> case tcSplitIOType_maybe ty of + Nothing -> Nothing + Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2) + + other -> Nothing isFFITy :: Type -> Bool -- True for any TyCon that can possibly be an arg or result of an FFI call @@ -1114,25 +1196,15 @@ isFFIDotnetTy :: DynFlags -> Type -> Bool isFFIDotnetTy dflags ty = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc || isFFIDotnetObjTy ty || isStringTy ty)) ty + -- NB: isStringTy used to look through newtypes, but + -- it no longer does so. May need to adjust isFFIDotNetTy + -- if we do want to look through newtypes. --- Support String as an argument or result from a .NET FFI call. -isStringTy ty = - case tcSplitTyConApp_maybe (repType ty) of - Just (tc, [arg_ty]) - | tc == listTyCon -> - case tcSplitTyConApp_maybe (repType arg_ty) of - Just (cc,[]) -> cc == charTyCon - _ -> False - _ -> False - --- Support String as an argument or result from a .NET FFI call. -isFFIDotnetObjTy ty = - let +isFFIDotnetObjTy ty + = checkRepTyCon check_tc t_ty + where (_, t_ty) = tcSplitForAllTys ty - in - case tcSplitTyConApp_maybe (repType t_ty) of - Just (tc, [arg_ty]) | getName tc == objectTyConName -> True - _ -> False + check_tc tc = getName tc == objectTyConName toDNType :: Type -> DNType toDNType ty @@ -1215,7 +1287,12 @@ legalFFITyCon tc = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon marshalableTyCon dflags tc - = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc) + = (dopt Opt_UnliftedFFITypes dflags + && isUnLiftedTyCon tc + && not (isUnboxedTupleTyCon tc) + && case tyConPrimRep tc of -- Note [Marshalling VoidRep] + VoidRep -> False + other -> True) || boxedMarshalableTyCon tc boxedMarshalableTyCon tc @@ -1230,3 +1307,12 @@ boxedMarshalableTyCon tc , boolTyConKey ] \end{code} + +Note [Marshalling VoidRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't treat State# (whose PrimRep is VoidRep) as marshalable. +In turn that means you can't write + foreign import foo :: Int -> State# RealWorld + +Reason: the back end falls over with panic "primRepHint:VoidRep"; + and there is no compelling reason to permit it