Commit b0604aad authored by simonpj's avatar simonpj
Browse files

[project @ 2001-08-28 10:06:29 by simonpj]

----------------------------------------
	Make isFFIArgumentTy understand newtypes
	----------------------------------------

This fixes the bug Manuel reported:

	newtype T = T (Ptr T)
	foreign import ccall foo :: T -> IO (Ptr T)

  test.hs:6:
      Unacceptable argument type in foreign declaration: T


On the way, I moved isFFIArgumentTy and friends out of TysWiredIn,
where they didn't really belong, into TcType.  That in turn force
me to move isStrictType, and isPrimitiveType.
parent ad6bc60d
......@@ -24,9 +24,13 @@ then
then
Unify, PprType (PprEnv)
then
Literal (TysPrim, PprType), DataCon (PprType)
Literal (TysPrim, PprType), DataCon (loop PprType)
then
TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId, loop Generics.mkGenInfo)
then
TcType( lots of TywWiredIn stuff)
then
PprType( lots of TcType stuff )
then
PrimOp (PprType, TysWiredIn)
then
......
......@@ -23,13 +23,14 @@ module DataCon (
#include "HsVersions.h"
import {-# SOURCE #-} Subst( substTyWith )
import {-# SOURCE #-} PprType( pprType )
import CmdLineOpts ( opt_DictsStrict )
import Type ( Type, TauType, ThetaType,
mkForAllTys, mkFunTys, mkTyConApp,
mkTyVarTys, splitTyConApp_maybe, repType
mkTyVarTys, splitTyConApp_maybe, repType,
mkPredTys, isStrictType
)
import TcType ( isStrictPred, mkPredTys )
import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isProductTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon )
......@@ -41,7 +42,6 @@ import NewDemand ( Demand, lazyDmd, seqDmd )
import Outputable
import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields )
import PprType () -- Instances
import Maybe
import ListSetOps ( assoc )
import Util ( zipEqual, zipWithEqual )
......@@ -236,7 +236,8 @@ mkDataCon name arg_stricts fields
-- Strictness marks for source-args
-- *after unboxing choices*,
-- but *including existential dictionaries*
real_stricts = (map mk_dict_strict_mark ex_theta) ++
ex_dict_tys = mkPredTys ex_theta
real_stricts = (map mk_dict_strict_mark ex_dict_tys) ++
zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon)
orig_arg_tys arg_stricts
......@@ -245,7 +246,7 @@ mkDataCon name arg_stricts fields
= unzip $ concat $
zipWithEqual "mkDataCon2" unbox_strict_arg_ty
real_stricts
(mkPredTys ex_theta ++ orig_arg_tys)
(ex_dict_tys ++ orig_arg_tys)
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys (tyvars ++ ex_tyvars)
......@@ -254,8 +255,8 @@ mkDataCon name arg_stricts fields
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
| otherwise = NotMarkedStrict
mk_dict_strict_mark ty | isStrictType ty = MarkedStrict
| otherwise = NotMarkedStrict
\end{code}
\begin{code}
......@@ -409,7 +410,7 @@ splitProductType_maybe ty
splitProductType str ty
= case splitProductType_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic (str ++ ": not a product") (ppr ty)
Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
-- We attempt to unbox/unpack a strict field when either:
-- (i) The tycon is imported, and the field is marked '! !', or
......
......@@ -183,7 +183,7 @@ unboxArg arg
= getSrcLocDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = repType (exprType arg)
arg_ty = repType (exprType arg)
-- The repType looks through any newtype or
-- implicit-parameter wrappings on the argument;
-- this is necessary, because isBoolTy (in particular) does not.
......
......@@ -69,15 +69,7 @@ module TysWiredIn (
voidTy,
wordDataCon,
wordTy,
wordTyCon,
isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool
isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
isFFIExportResultTy, -- :: Type -> Bool
isFFIExternalTy, -- :: Type -> Bool
isFFIDynArgumentTy, -- :: Type -> Bool
isFFIDynResultTy, -- :: Type -> Bool
isFFILabelTy, -- :: Type -> Bool
wordTyCon
) where
#include "HsVersions.h"
......@@ -90,7 +82,6 @@ import PrelNames
import TysPrim
-- others:
import ForeignCall ( Safety, playSafe )
import Constants ( mAX_TUPLE_SIZE )
import Module ( mkPrelModule )
import Name ( Name, nameRdrName, nameUnique, nameOccName,
......@@ -406,117 +397,6 @@ largeIntegerDataCon = pcDataCon largeIntegerDataConName
\end{code}
%************************************************************************
%* *
\subsection[TysWiredIn-ext-type]{External types}
%* *
%************************************************************************
The compiler's foreign function interface supports the passing of a
restricted set of types as arguments and results (the restricting factor
being the )
\begin{code}
isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
-- Checks for valid argument type for a 'foreign import'
isFFIArgumentTy dflags safety ty
= checkRepTyCon (legalOutgoingTyCon dflags safety) ty
isFFIExternalTy :: Type -> Bool
-- Types that are allowed as arguments of a 'foreign export'
isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
isFFIImportResultTy :: DynFlags -> Type -> Bool
isFFIImportResultTy dflags ty
= checkRepTyCon (legalFIResultTyCon dflags) ty
isFFIExportResultTy :: Type -> Bool
isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
isFFIDynArgumentTy :: Type -> Bool
-- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
-- or a newtype of either.
isFFIDynArgumentTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon)
isFFIDynResultTy :: Type -> Bool
-- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
-- or a newtype of either.
isFFIDynResultTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon)
isFFILabelTy :: Type -> Bool
-- The type of a foreign label must be Ptr, FunPtr, Addr,
-- or a newtype of either.
isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon)
checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
-- Look through newtypes
checkRepTyCon check_tc ty = case splitTyConApp_maybe ty of
Just (tycon, _) -> check_tc tycon
Nothing -> False
\end{code}
----------------------------------------------
These chaps do the work; they are not exported
----------------------------------------------
\begin{code}
legalFEArgTyCon :: TyCon -> Bool
-- It's illegal to return foreign objects and (mutable)
-- bytearrays from a _ccall_ / foreign declaration
-- (or be passed them as arguments in foreign exported functions).
legalFEArgTyCon tc
| getUnique tc `elem` [ foreignObjTyConKey, foreignPtrTyConKey,
byteArrayTyConKey, mutableByteArrayTyConKey ]
= False
-- It's also illegal to make foreign exports that take unboxed
-- arguments. The RTS API currently can't invoke such things. --SDM 7/2000
| otherwise
= boxedMarshalableTyCon tc
legalFIResultTyCon :: DynFlags -> TyCon -> Bool
legalFIResultTyCon dflags tc
| getUnique tc `elem`
[ foreignObjTyConKey, foreignPtrTyConKey,
byteArrayTyConKey, mutableByteArrayTyConKey ] = False
| tc == unitTyCon = True
| otherwise = marshalableTyCon dflags tc
legalFEResultTyCon :: TyCon -> Bool
legalFEResultTyCon tc
| getUnique tc `elem`
[ foreignObjTyConKey, foreignPtrTyConKey,
byteArrayTyConKey, mutableByteArrayTyConKey ] = False
| tc == unitTyCon = True
| otherwise = boxedMarshalableTyCon tc
legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
-- Checks validity of types going from Haskell -> external world
legalOutgoingTyCon dflags safety tc
| playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
= False
| otherwise
= marshalableTyCon dflags tc
marshalableTyCon dflags tc
= (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
|| boxedMarshalableTyCon tc
boxedMarshalableTyCon tc
= getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
, int32TyConKey, int64TyConKey
, wordTyConKey, word8TyConKey, word16TyConKey
, word32TyConKey, word64TyConKey
, floatTyConKey, doubleTyConKey
, addrTyConKey, ptrTyConKey, funPtrTyConKey
, charTyConKey, foreignObjTyConKey
, foreignPtrTyConKey
, stablePtrTyConKey
, byteArrayTyConKey, mutableByteArrayTyConKey
, boolTyConKey
]
\end{code}
%************************************************************************
%* *
\subsection[TysWiredIn-Bool]{The @Bool@ type}
......
......@@ -40,10 +40,9 @@ import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
import Type ( Type, mkForAllTys, seqType,
splitTyConApp_maybe, tyConAppArgs, mkTyVarTys,
isUnLiftedType,
isUnLiftedType, isStrictType,
splitRepFunTys
)
import TcType ( isStrictType )
import TyCon ( tyConDataConsIfAvailable )
import DataCon ( dataConRepArity )
import VarEnv ( SubstEnv )
......
......@@ -34,14 +34,13 @@ import Inst ( emptyLIE, LIE, plusLIE )
import ErrUtils ( Message )
import Id ( Id, mkLocalId )
import Name ( nameOccName )
import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy,
isFFIExportResultTy,
isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy,
isFFILabelTy
)
import PrimRep ( getPrimRepSize )
import Type ( typePrimRep )
import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys )
import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys,
isFFIArgumentTy, isFFIImportResultTy,
isFFIExportResultTy, isFFILabelTy,
isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy
)
import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget, isCasmTarget )
import CStrings ( CLabelString, isCLabelString )
import PrelNames ( hasKey, ioTyConKey )
......@@ -317,3 +316,4 @@ foreignDeclCtxt fo
= hang (ptext SLIT("When checking declaration:"))
4 (ppr fo)
\end{code}
......@@ -61,7 +61,9 @@ import TcType ( tcEqType, tcCmpPred,
liftedTypeKind, unliftedTypeKind, openTypeKind, defaultKind, superKind,
superBoxity, liftedBoxity, hasMoreBoxityInfo, typeKind,
tyVarsOfType, tyVarsOfTypes, tidyOpenType, tidyOpenTypes, tidyTyVar,
eqKind, isTypeKind
eqKind, isTypeKind,
isFFIArgumentTy, isFFIImportResultTy
)
import Subst ( Subst, mkTopTyVarSubst, substTy )
import Class ( classArity, className )
......@@ -73,8 +75,7 @@ import Var ( TyVar, varName, tyVarKind, tyVarName, isTyVar, mkTyVar,
-- others:
import TcMonad -- TcType, amongst others
import TysWiredIn ( voidTy, listTyCon, mkListTy, mkTupleTy,
isFFIArgumentTy, isFFIImportResultTy )
import TysWiredIn ( voidTy, listTyCon, mkListTy, mkTupleTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import ForeignCall ( Safety(..) )
import FunDeps ( grow )
......
......@@ -36,9 +36,9 @@ module TcType (
-- Predicates.
-- Again, newtypes are opaque
tcEqType, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
isQualifiedTy, isOverloadedTy, isStrictType, isStrictPred,
isQualifiedTy, isOverloadedTy,
isDoubleTy, isFloatTy, isIntTy,
isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isForeignPtrTy, isPrimitiveType,
isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isForeignPtrTy,
isTauTy, tcIsTyVarTy, tcIsForAllTy,
---------------------------------
......@@ -49,12 +49,22 @@ module TcType (
---------------------------------
-- Predicate types
PredType, mkPredTy, mkPredTys, getClassPredTys_maybe, getClassPredTys,
PredType, getClassPredTys_maybe, getClassPredTys,
isPredTy, isClassPred, isTyVarClassPred, predHasFDs,
mkDictTy, tcSplitPredTy_maybe, predTyUnique,
isDictTy, tcSplitDFunTy, predTyUnique,
mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName,
---------------------------------
-- Foreign import and export
isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool
isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
isFFIExportResultTy, -- :: Type -> Bool
isFFIExternalTy, -- :: Type -> Bool
isFFIDynArgumentTy, -- :: Type -> Bool
isFFIDynResultTy, -- :: Type -> Bool
isFFILabelTy, -- :: Type -> Bool
---------------------------------
-- Unifier and matcher
unifyTysX, unifyTyListsX, unifyExtendTysX,
......@@ -72,10 +82,11 @@ module TcType (
mkForAllTy, mkForAllTys,
mkFunTy, mkFunTys, zipFunTys,
mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
isUnLiftedType, -- Source types are always lifted
isUnboxedTupleType, -- Ditto
isPrimitiveType,
tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVar, tidyTyVars,
......@@ -100,25 +111,27 @@ import Type ( -- Re-exports
mkForAllTy, mkForAllTys, defaultKind, isTypeKind,
mkFunTy, mkFunTys, zipFunTys,
mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy,
isUnLiftedType, isUnboxedTupleType,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
isUnLiftedType, isUnboxedTupleType, isPrimitiveType,
splitNewType_maybe, splitTyConApp_maybe,
tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVar, tidyTyVars, eqKind, eqUsage,
hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind
)
import TyCon ( TyCon, isPrimTyCon, tyConArity, isNewTyCon )
import TyCon ( TyCon, isPrimTyCon, tyConArity, isNewTyCon, isUnLiftedTyCon )
import Class ( classTyCon, classHasFDs, Class )
import Var ( TyVar, tyVarKind )
import ForeignCall ( Safety, playSafe )
import VarEnv
import VarSet
-- others:
import CmdLineOpts ( opt_DictsStrict )
import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
import Name ( Name, NamedThing(..), mkLocalName )
import OccName ( OccName, mkDictOcc )
import NameSet
import PrelNames ( floatTyConKey, doubleTyConKey, foreignPtrTyConKey,
integerTyConKey, intTyConKey, addrTyConKey, boolTyConKey )
import PrelNames -- Lots (e.g. in isFFIArgumentTy
import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon )
import Unique ( Unique, Uniquable(..), mkTupleTyConUnique )
import SrcLoc ( SrcLoc )
import Util ( cmpList, thenCmp )
......@@ -346,12 +359,6 @@ tcSplitPredTy_maybe (UsageTy _ ty) = tcSplitPredTy_maybe ty
tcSplitPredTy_maybe (SourceTy p) | isPred p = Just p
tcSplitPredTy_maybe other = Nothing
mkPredTy :: PredType -> Type
mkPredTy pred = SourceTy pred
mkPredTys :: ThetaType -> [Type]
mkPredTys preds = map SourceTy preds
predTyUnique :: PredType -> Unique
predTyUnique (IParam n _) = getUnique n
predTyUnique (ClassP clas tys) = getUnique clas
......@@ -561,36 +568,6 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of
Nothing -> False
\end{code}
\begin{code}
isPrimitiveType :: Type -> Bool
-- Returns types that are opaque to Haskell.
-- Most of these are unlifted, but now that we interact with .NET, we
-- may have primtive (foreign-imported) types that are lifted
isPrimitiveType ty = case tcSplitTyConApp_maybe ty of
Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
isPrimTyCon tc
other -> False
\end{code}
@isStrictType@ computes whether an argument (or let RHS) should
be computed strictly or lazily, based only on its type
\begin{code}
isStrictType :: Type -> Bool
isStrictType ty
| isUnLiftedType ty = True
| Just pred <- tcSplitPredTy_maybe ty = isStrictPred pred
| otherwise = False
isStrictPred (ClassP clas _) = opt_DictsStrict
&& not (isNewTyCon (classTyCon clas))
isStrictPred pred = False
-- We may be strict in dictionary types, but only if it
-- has more than one component.
-- [Being strict in a single-component dictionary risks
-- poking the dictionary component, which is wrong.]
\end{code}
%************************************************************************
%* *
......@@ -666,6 +643,120 @@ namesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of
\end{code}
%************************************************************************
%* *
\subsection[TysWiredIn-ext-type]{External types}
%* *
%************************************************************************
The compiler's foreign function interface supports the passing of a
restricted set of types as arguments and results (the restricting factor
being the )
\begin{code}
isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
-- Checks for valid argument type for a 'foreign import'
isFFIArgumentTy dflags safety ty
= checkRepTyCon (legalOutgoingTyCon dflags safety) ty
isFFIExternalTy :: Type -> Bool
-- Types that are allowed as arguments of a 'foreign export'
isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
isFFIImportResultTy :: DynFlags -> Type -> Bool
isFFIImportResultTy dflags ty
= checkRepTyCon (legalFIResultTyCon dflags) ty
isFFIExportResultTy :: Type -> Bool
isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
isFFIDynArgumentTy :: Type -> Bool
-- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
-- or a newtype of either.
isFFIDynArgumentTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon)
isFFIDynResultTy :: Type -> Bool
-- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
-- or a newtype of either.
isFFIDynResultTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon)
isFFILabelTy :: Type -> Bool
-- The type of a foreign label must be Ptr, FunPtr, Addr,
-- or a newtype of either.
isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon)
checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
-- Look through newtypes
-- Non-recursive ones are transparent to splitTyConApp,
-- but recursive ones aren't; hence the splitNewType_maybe
checkRepTyCon check_tc ty
| Just ty' <- splitNewType_maybe ty = checkRepTyCon check_tc ty'
| Just (tc,_) <- splitTyConApp_maybe ty = check_tc tc
| otherwise = False
\end{code}
----------------------------------------------
These chaps do the work; they are not exported
----------------------------------------------
\begin{code}
legalFEArgTyCon :: TyCon -> Bool
-- It's illegal to return foreign objects and (mutable)
-- bytearrays from a _ccall_ / foreign declaration
-- (or be passed them as arguments in foreign exported functions).
legalFEArgTyCon tc
| getUnique tc `elem` [ foreignObjTyConKey, foreignPtrTyConKey,
byteArrayTyConKey, mutableByteArrayTyConKey ]
= False
-- It's also illegal to make foreign exports that take unboxed
-- arguments. The RTS API currently can't invoke such things. --SDM 7/2000
| otherwise
= boxedMarshalableTyCon tc
legalFIResultTyCon :: DynFlags -> TyCon -> Bool
legalFIResultTyCon dflags tc
| getUnique tc `elem`
[ foreignObjTyConKey, foreignPtrTyConKey,
byteArrayTyConKey, mutableByteArrayTyConKey ] = False
| tc == unitTyCon = True
| otherwise = marshalableTyCon dflags tc
legalFEResultTyCon :: TyCon -> Bool
legalFEResultTyCon tc
| getUnique tc `elem`
[ foreignObjTyConKey, foreignPtrTyConKey,
byteArrayTyConKey, mutableByteArrayTyConKey ] = False
| tc == unitTyCon = True
| otherwise = boxedMarshalableTyCon tc
legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
-- Checks validity of types going from Haskell -> external world
legalOutgoingTyCon dflags safety tc
| playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
= False
| otherwise
= marshalableTyCon dflags tc
marshalableTyCon dflags tc
= (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
|| boxedMarshalableTyCon tc
boxedMarshalableTyCon tc
= getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
, int32TyConKey, int64TyConKey
, wordTyConKey, word8TyConKey, word16TyConKey
, word32TyConKey, word64TyConKey
, floatTyConKey, doubleTyConKey
, addrTyConKey, ptrTyConKey, funPtrTyConKey
, charTyConKey, foreignObjTyConKey
, foreignPtrTyConKey
, stablePtrTyConKey
, byteArrayTyConKey, mutableByteArrayTyConKey
, boolTyConKey
]
\end{code}
%************************************************************************
%* *
\subsection{Unification with an explicit substitution}
......
......@@ -49,13 +49,13 @@ module Type (
applyTy, applyTys, isForAllTy,
-- Source types
SourceType(..), sourceTypeRep,
SourceType(..), sourceTypeRep, mkPredTy, mkPredTys,
-- Newtypes
splitNewType_maybe,
-- Lifting and boxity
isUnLiftedType, isUnboxedTupleType, isAlgType,
isUnLiftedType, isUnboxedTupleType, isAlgType, isStrictType, isPrimitiveType,
-- Free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
......@@ -94,7 +94,7 @@ import VarSet
import Name ( NamedThing(..), mkLocalName, tidyOccName )
import Class ( classTyCon )
import TyCon ( TyCon, isRecursiveTyCon,
import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
isFunTyCon, isNewTyCon, newTyConRep,
isAlgTyCon, isSynTyCon, tyConArity,
......@@ -103,6 +103,7 @@ import TyCon ( TyCon, isRecursiveTyCon,
)
-- others
import CmdLineOpts ( opt_DictsStrict )
import Maybes ( maybeToBool )
import SrcLoc ( noSrcLoc )
import PrimRep ( PrimRep(..) )
......@@ -606,6 +607,12 @@ Source types are always lifted.
The key function is sourceTypeRep which gives the representation of a source type:
\begin{code}
mkPredTy :: PredType -> Type
mkPredTy pred = SourceTy pred
mkPredTys :: ThetaType -> [Type]
mkPredTys preds = map SourceTy preds
sourceTypeRep :: SourceType -> Type
-- Convert a predicate to its "representation type";
-- the type of evidence for that predicate, which is actually passed at runtime
......@@ -682,7 +689,6 @@ typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds f
Free variables of a type
~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
tyVarsOfType :: Type -> TyVarSet
tyVarsOfType (TyVarTy tv) = unitVarSet tv
tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
......@@ -867,6 +873,37 @@ isAlgType ty = case splitTyConApp_maybe ty of
other -> False
\end{code}
@isStrictType@ computes whether an argument (or let RHS) should
be computed strictly or lazily, based only on its type.
Works just like isUnLiftedType, except that it has a special case
for dictionaries. Since it takes account of ClassP, you might think
this function should be in TcType, but isStrictType is used by DataCon,
which is below TcType in the hierarchy, so it's convenient to put it here.
\begin{code}
isStrictType (ForAllTy tv ty) = isStrictType ty
isStrictType (NoteTy _ ty) = isStrictType ty
isStrictType (TyConApp tc _) = isUnLiftedTyCon tc
isStrictType (UsageTy _ ty) = isStrictType ty
isStrictType (SourceTy (ClassP clas _)) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
-- We may be strict in dictionary types, but only if it
-- has more than one component.
-- [Being strict in a single-component dictionary risks
-- poking the dictionary component, which is wrong.]
isStrictType other = False
\end{code}
\begin{code}
isPrimitiveType :: Type -> Bool
-- Returns types that are opaque to Haskell.
-- Most of these are unlifted, but now that we interact with .NET, we
-- may have primtive (foreign-imported) types that are lifted
isPrimitiveType ty = case splitTyConApp_maybe ty of
Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
isPrimTyCon tc
other -> False
\end{code}
%************************************************************************
%* *
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment