X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=50659d522d63354c854ce39fb88a3aab3c1d3c7c;hb=f6a68d3109f977fe4431df51d1412d916e7c08da;hp=24cf3f8722b911aa6a2e6d514c6293731b32db21;hpb=a13551ce57c67a333f41f0a6fe7e05a09d0c3614;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 24cf3f8..50659d5 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -45,7 +45,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, 
 
   ---------------------------------
@@ -139,6 +140,7 @@ import ForeignCall
 import Unify
 import VarSet
 import Type
+import Coercion
 import TyCon
 
 -- others:
@@ -790,14 +792,23 @@ 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
+        NoteTy _ ty     -> tcInstHeadTyNotSynonym ty
+        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
+	NoteTy _ ty     -> tcInstHeadTyAppAllTyVars ty
+	TyConApp _ tys  -> ok tys
 	FunTy arg res   -> ok [arg, res]
 	other		-> False
   where
@@ -830,6 +841,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}
 
 
@@ -1040,6 +1052,7 @@ exactTyVarsOfType ty
     go (AppTy fun arg)	    	  = go fun `unionVarSet` go arg
     go (ForAllTy tyvar ty)  	  = delVarSet (go ty) tyvar
                                     `unionVarSet` go_tv tyvar
+    go (NoteTy _ _) 		  = panic "exactTyVarsOfType"	-- Handled by tcView
 
     go_pred (IParam _ ty)    = go ty
     go_pred (ClassP _ tys)   = exactTyVarsOfTypes tys
@@ -1093,22 +1106,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
@@ -1153,13 +1172,11 @@ isFFIDotnetTy dflags ty
 	--     it no longer does so.  May need to adjust isFFIDotNetTy
 	--     if we do want to look through newtypes.
 
-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
@@ -1242,7 +1259,11 @@ legalFFITyCon tc
   = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
 
 marshalableTyCon dflags tc
-  =  (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
+  =  (dopt Opt_UnliftedFFITypes dflags 
+      && isUnLiftedTyCon tc
+      && case tyConPrimRep tc of	-- Note [Marshalling VoidRep]
+	   VoidRep -> False
+	   other   -> True)
   || boxedMarshalableTyCon tc
 
 boxedMarshalableTyCon tc
@@ -1257,3 +1278,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