From: simonpj Date: Tue, 28 Aug 2001 10:06:30 +0000 (+0000) Subject: [project @ 2001-08-28 10:06:29 by simonpj] X-Git-Tag: Approximately_9120_patches~1066 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b0604aad2c311d8713c2497afa6373bd938d501b;p=ghc-hetmet.git [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. --- diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES index fb966c6..79288ae 100644 --- a/ghc/compiler/DEPEND-NOTES +++ b/ghc/compiler/DEPEND-NOTES @@ -24,10 +24,14 @@ 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 CoreSyn diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 44126b8..a925c1b 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -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 diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 8220405..e27f261 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -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. diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index ca4f950..0950413 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -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, @@ -408,117 +399,6 @@ largeIntegerDataCon = pcDataCon largeIntegerDataConName %************************************************************************ %* * -\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} %* * %************************************************************************ diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 836d2ab..371a0c7 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -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 ) diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 440ef58..c33b8cd 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -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} + diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 8aa119a..0e18104 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -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 ) diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index a6abdcf..eee1f20 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -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,13 +49,23 @@ 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, allDistinctTyVars, @@ -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} - %************************************************************************ %* * @@ -668,6 +645,120 @@ namesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of %************************************************************************ %* * +\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} %* * %************************************************************************ diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 33cd4b1..d16aa04 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -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} + %************************************************************************ %* *