The Big INLINE Patch: totally reorganise way that INLINE pragmas work

[ghc-hetmet.git] / compiler / typecheck / TcType.lhs

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 738f1cd..dad167c 100644 (file)
--- 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
@@ -151,7 +152,6 @@ import DynFlags
 import Name
 import NameSet
 import VarEnv
-import OccName
 import PrelNames
 import TysWiredIn
 import BasicTypes
@@ -161,7 +161,6 @@ import ListSetOps
 import Outputable
 import FastString
 
-import Data.List
 import Data.IORef
 \end{code}
 
@@ -644,7 +643,6 @@ getDFunTyKey ty                  = pprPanic "getDFunTyKey" (pprType ty)
 These tcSplit functions are like their non-Tc analogues, but
        a) they do not look through newtypes
        b) they do not look through PredTys
-       c) [future] they ignore usage-type annotations
 
 However, they are non-monadic and do not follow through mutable type
 variables.  It's up to you to make sure this doesn't matter.
@@ -805,18 +803,29 @@ tcIsTyVarTy :: Type -> Bool
 tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
 
 -----------------------
-tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
+tcSplitDFunTy :: Type -> ([TyVar], Class, [Type])
 -- Split the type of a dictionary function
+-- We don't use tcSplitSigmaTy,  because a DFun may (with NDP)
+-- have non-Pred arguments, such as
+--     df :: forall m. (forall b. Eq b => Eq (m b)) -> C m
 tcSplitDFunTy ty 
-  = case tcSplitSigmaTy ty   of { (tvs, theta, tau) ->
-    case tcSplitDFunHead tau of { (clas, tys) -> 
-    (tvs, theta, clas, tys) }}
+  = case tcSplitForAllTys ty                 of { (tvs, rho)  ->
+    case tcSplitDFunHead (drop_pred_tys rho) of { (clas, tys) -> 
+    (tvs, clas, tys) }}
+  where
+    -- Discard the context of the dfun.  This can be a mix of
+    -- coercion and class constraints; or (in the general NDP case)
+    -- some other function argument
+    drop_pred_tys ty | Just ty' <- tcView ty = drop_pred_tys ty'
+    drop_pred_tys (ForAllTy tv ty) = ASSERT( isCoVar tv ) drop_pred_tys ty
+    drop_pred_tys (FunTy _ ty)     = drop_pred_tys ty
+    drop_pred_tys ty               = ty
 
 tcSplitDFunHead :: Type -> (Class, [Type])
 tcSplitDFunHead tau  
   = case tcSplitPredTy_maybe tau of 
        Just (ClassP clas tys) -> (clas, tys)
-       _ -> panic "tcSplitDFunHead"
+       _ -> pprPanic "tcSplitDFunHead" (ppr tau)
 
 tcInstHeadTyNotSynonym :: Type -> Bool
 -- Used in Haskell-98 mode, for the argument types of an instance head
@@ -1228,6 +1237,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 || 
@@ -1246,39 +1267,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
@@ -1353,6 +1341,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]