X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=71fee4c75c21b69a860fe1fce6c7512387d71f4f;hb=ca8d50e001ffa64cefac0231f1cdbdff19b47e8c;hp=1e524b29fbaae3823256a02faec0193a25a69a6b;hpb=bc53629a7d43c0ef94029b3fad5abb7ba5b1495f;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 1e524b2..71fee4c 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -84,13 +84,14 @@ module TcType (
   isFFIExternalTy,     -- :: Type -> Bool
   isFFIDynArgumentTy,  -- :: Type -> Bool
   isFFIDynResultTy,    -- :: Type -> Bool
+  isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool
+  isFFIPrimResultTy,   -- :: DynFlags -> Type -> Bool
   isFFILabelTy,        -- :: Type -> Bool
   isFFIDotnetTy,       -- :: DynFlags -> Type -> Bool
   isFFIDotnetObjTy,    -- :: Type -> Bool
   isFFITy,	       -- :: Type -> Bool
   isFunPtrTy,          -- :: Type -> Bool
   tcSplitIOType_maybe, -- :: Type -> Maybe Type  
-  toDNType,            -- :: Type -> DNType
 
   --------------------------------
   -- Rexported from Type
@@ -124,7 +125,8 @@ module TcType (
   typeKind, tidyKind,
 
   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
-  tcTyVarsOfType, tcTyVarsOfTypes, exactTyVarsOfType, exactTyVarsOfTypes,
+  tcTyVarsOfType, tcTyVarsOfTypes, tcTyVarsOfPred, exactTyVarsOfType,
+  exactTyVarsOfTypes, 
 
   pprKind, pprParendKind,
   pprType, pprParendType, pprTypeApp, pprTyThingCategory,
@@ -150,7 +152,6 @@ import DynFlags
 import Name
 import NameSet
 import VarEnv
-import OccName
 import PrelNames
 import TysWiredIn
 import BasicTypes
@@ -160,7 +161,6 @@ import ListSetOps
 import Outputable
 import FastString
 
-import Data.List
 import Data.IORef
 \end{code}
 
@@ -352,6 +352,7 @@ data UserTypeCtxt
   | ForSigCtxt Name	-- Foreign inport or export signature
   | DefaultDeclCtxt	-- Types in a default declaration
   | SpecInstCtxt	-- SPECIALISE instance pragma
+  | ThBrackCtxt		-- Template Haskell type brackets [t| ... |]
 
 -- Notes re TySynCtxt
 -- We allow type synonyms that aren't types; e.g.  type List = []
@@ -409,6 +410,7 @@ 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 ThBrackCtxt     = ptext (sLit "a Template Haskell quotation [t|...|]")
 pprUserTypeCtxt LamPatSigCtxt   = ptext (sLit "a pattern type signature")
 pprUserTypeCtxt BindPatSigCtxt  = ptext (sLit "a pattern type signature")
 pprUserTypeCtxt ResSigCtxt      = ptext (sLit "a result type signature")
@@ -1225,6 +1227,18 @@ isFFILabelTy :: Type -> Bool
 -- or a newtype of either.
 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
 
+isFFIPrimArgumentTy :: DynFlags -> Type -> Bool
+-- Checks for valid argument type for a 'foreign import prim'
+-- Currently they must all be simple unlifted types.
+isFFIPrimArgumentTy dflags ty
+   = checkRepTyCon (legalFIPrimArgTyCon dflags) ty
+
+isFFIPrimResultTy :: DynFlags -> Type -> Bool
+-- Checks for valid result type for a 'foreign import prim'
+-- Currently it must be an unlifted type, including unboxed tuples.
+isFFIPrimResultTy dflags ty
+   = checkRepTyCon (legalFIPrimResultTyCon dflags) ty
+
 isFFIDotnetTy :: DynFlags -> Type -> Bool
 isFFIDotnetTy dflags ty
   = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc || 
@@ -1243,39 +1257,6 @@ isFFIDotnetObjTy ty
 isFunPtrTy :: Type -> Bool
 isFunPtrTy = checkRepTyConKey [funPtrTyConKey]
 
-toDNType :: Type -> DNType
-toDNType ty
-  | isStringTy ty = DNString
-  | isFFIDotnetObjTy ty = DNObject
-  | Just (tc,argTys) <- tcSplitTyConApp_maybe ty 
-  =  case lookup (getUnique tc) dn_assoc of
-       Just x  -> x
-       Nothing 
-         | tc `hasKey` ioTyConKey -> toDNType (head argTys)
-	 | otherwise -> pprPanic ("toDNType: unsupported .NET type") 
-			  (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
-  | otherwise = panic "toDNType"	-- Is this right?
-    where
-      dn_assoc :: [ (Unique, DNType) ]
-      dn_assoc = [ (unitTyConKey,   DNUnit)
-      		 , (intTyConKey,    DNInt)
-      	         , (int8TyConKey,   DNInt8)
-		 , (int16TyConKey,  DNInt16)
-		 , (int32TyConKey,  DNInt32)
-		 , (int64TyConKey,  DNInt64)
-		 , (wordTyConKey,   DNInt)
-		 , (word8TyConKey,  DNWord8)
-		 , (word16TyConKey, DNWord16)
-		 , (word32TyConKey, DNWord32)
-		 , (word64TyConKey, DNWord64)
-		 , (floatTyConKey,  DNFloat)
-		 , (doubleTyConKey, DNDouble)
-		 , (ptrTyConKey,    DNPtr)
-		 , (funPtrTyConKey, DNPtr)
-		 , (charTyConKey,   DNChar)
-		 , (boolTyConKey,   DNBool)
-		 ]
-
 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
 -- Look through newtypes, but *not* foralls
 -- Should work even for recursive newtypes
@@ -1350,6 +1331,26 @@ boxedMarshalableTyCon tc
 			 , stablePtrTyConKey
 			 , boolTyConKey
 			 ]
+
+legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool
+-- Check args of 'foreign import prim', only allow simple unlifted types.
+-- Strictly speaking it is unnecessary to ban unboxed tuples here since
+-- currently they're of the wrong kind to use in function args anyway.
+legalFIPrimArgTyCon dflags tc
+  = dopt Opt_UnliftedFFITypes dflags
+    && isUnLiftedTyCon tc
+    && not (isUnboxedTupleTyCon tc)
+
+legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool
+-- Check result type of 'foreign import prim'. Allow simple unlifted
+-- types and also unboxed tuple result types '... -> (# , , #)'
+legalFIPrimResultTyCon dflags tc
+  = dopt Opt_UnliftedFFITypes dflags
+    && isUnLiftedTyCon tc
+    && (isUnboxedTupleTyCon tc
+        || case tyConPrimRep tc of	-- Note [Marshalling VoidRep]
+	   VoidRep -> False
+	   _       -> True)
 \end{code}
 
 Note [Marshalling VoidRep]