diff options
Diffstat (limited to 'compiler')
311 files changed, 24717 insertions, 20048 deletions
diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h index d85234784a..9a83af9768 100644 --- a/compiler/HsVersions.h +++ b/compiler/HsVersions.h @@ -46,18 +46,9 @@ name :: IORef (ty); \ name = Util.globalM (value); #endif -#ifdef DEBUG -#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else -#define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else +#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else +#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else #define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $ -#else --- We have to actually use all the variables we are given or we may get --- unused variable warnings when DEBUG is off. -#define ASSERT(e) if False && (not (e)) then panic "ASSERT" else -#define ASSERT2(e,msg) if False && (const False (e,msg)) then pprPanic "ASSERT2" (msg) else -#define WARN(e,msg) if False && (e) then pprPanic "WARN" (msg) else --- Here we deliberately don't use when as Control.Monad might not be imported -#endif -- Examples: Assuming flagSet :: String -> m Bool -- diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index c6226cac67..86b93ab9a2 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -26,7 +26,7 @@ types that module BasicTypes( Version, bumpVersion, initialVersion, - Arity, + Arity, RepArity, Alignment, @@ -39,8 +39,6 @@ module BasicTypes( negateFixity, funTyFixity, compareFixity, - IPName(..), ipNameName, mapIPName, - RecFlag(..), isRec, isNonRec, boolToRecFlag, RuleName, @@ -101,7 +99,18 @@ import Data.Function (on) %************************************************************************ \begin{code} +-- | The number of value arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has arity 0 +-- \x -> fib x has arity 1 type Arity = Int + +-- | The number of represented arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has representation arity 0 +-- \x -> fib x has representation arity 1 +-- \(# x, y #) -> fib (x + y) has representation arity 2 +type RepArity = Int \end{code} %************************************************************************ @@ -167,32 +176,6 @@ instance Outputable WarningTxt where %************************************************************************ %* * -\subsection{Implicit parameter identity} -%* * -%************************************************************************ - -The @IPName@ type is here because it is used in TypeRep (i.e. very -early in the hierarchy), but also in HsSyn. - -\begin{code} -newtype IPName name = IPName name -- ?x - deriving( Eq, Data, Typeable ) - -instance Functor IPName where - fmap = mapIPName - -ipNameName :: IPName name -> name -ipNameName (IPName n) = n - -mapIPName :: (a->b) -> IPName a -> IPName b -mapIPName f (IPName n) = IPName (f n) - -instance Outputable name => Outputable (IPName name) where - ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters -\end{code} - -%************************************************************************ -%* * Rules %* * %************************************************************************ @@ -561,9 +544,6 @@ instance Outputable OccInfo where | otherwise = char '*' pp_args | int_cxt = char '!' | otherwise = empty - -instance Show OccInfo where - showsPrec p occ = showsPrecSDoc p (ppr occ) \end{code} %************************************************************************ diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index e08bc67241..d46759c7fd 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -31,7 +31,7 @@ module DataCon ( dataConInstOrigArgTys, dataConRepArgTys, dataConFieldLabels, dataConFieldType, dataConStrictMarks, dataConExStricts, - dataConSourceArity, dataConRepArity, + dataConSourceArity, dataConRepArity, dataConRepRepArity, dataConIsInfix, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, dataConRepStrictness, @@ -53,6 +53,7 @@ module DataCon ( import Type import TypeRep( Type(..) ) -- Used in promoteType +import PrelNames( liftedTypeKindTyConKey ) import Kind import Unify import Coercion @@ -469,9 +470,6 @@ instance NamedThing DataCon where instance Outputable DataCon where ppr con = ppr (dataConName con) -instance Show DataCon where - showsPrec p con = showsPrecSDoc p (ppr con) - instance Data.Data DataCon where -- don't traverse? toConstr _ = abstractConstr "DataCon" @@ -562,7 +560,7 @@ mkDataCon name declared_infix mkTyConApp rep_tycon (mkTyVarTys univ_tvs) eqSpecPreds :: [(TyVar,Type)] -> ThetaType -eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ] +eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ] mk_pred_strict_mark :: PredType -> HsBang mk_pred_strict_mark pred @@ -691,9 +689,14 @@ dataConSourceArity dc = length (dcOrigArgTys dc) -- | Gives the number of actual fields in the /representation/ of the -- data constructor. This may be more than appear in the source code; -- the extra ones are the existentially quantified dictionaries -dataConRepArity :: DataCon -> Int +dataConRepArity :: DataCon -> Arity dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys +-- | The number of fields in the /representation/ of the constructor +-- AFTER taking into account the unpacking of any unboxed tuple fields +dataConRepRepArity :: DataCon -> RepArity +dataConRepRepArity dc = typeRepArity (dataConRepArity dc) (dataConRepType dc) + -- | Return whether there are any argument types for this 'DataCon's original source type isNullarySrcDataCon :: DataCon -> Bool isNullarySrcDataCon dc = null (dcOrigArgTys dc) @@ -983,12 +986,12 @@ These two 'buildPromoted..' functions are here because \begin{code} buildPromotedTyCon :: TyCon -> TyCon buildPromotedTyCon tc - = mkPromotedTyCon tc tySuperKind + = mkPromotedTyCon tc (promoteKind (tyConKind tc)) buildPromotedDataCon :: DataCon -> TyCon buildPromotedDataCon dc = ASSERT ( isPromotableType ty ) - mkPromotedDataTyCon dc (getName dc) (getUnique dc) kind arity + mkPromotedDataCon dc (getName dc) (getUnique dc) kind arity where ty = dataConUserType dc kind = promoteType ty @@ -1028,7 +1031,9 @@ isPromotableType ty -- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ] isPromotableTyCon :: TyCon -> Maybe Int isPromotableTyCon tc - | all isLiftedTypeKind (res:args) = Just $ length args + | isDataTyCon tc -- Only *data* types can be promoted, not newtypes + -- not synonyms, not type families + , all isLiftedTypeKind (res:args) = Just $ length args | otherwise = Nothing where (args, res) = splitKindFunTys (tyConKind tc) @@ -1040,7 +1045,7 @@ promoteType ty = mkForAllTys kvs (go rho) where (tvs, rho) = splitForAllTys ty - kvs = [ mkKindVar (tyVarName tv) tySuperKind | tv <- tvs ] + kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ] env = zipVarEnv tvs kvs go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys) @@ -1048,4 +1053,12 @@ promoteType ty go (TyVarTy tv) | Just kv <- lookupVarEnv env tv = TyVarTy kv go _ = panic "promoteType" -- Argument did not satisfy isPromotableType + +promoteKind :: Kind -> SuperKind +-- Promote the kind of a type constructor +-- from (* -> * -> *) to (BOX -> BOX -> BOX) +promoteKind (TyConApp tc []) + | tc `hasKey` liftedTypeKindTyConKey = superKind +promoteKind (FunTy arg res) = FunTy (promoteKind arg) (promoteKind res) +promoteKind k = pprPanic "promoteKind" (ppr k) \end{code} diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index c4143edd45..bd3638a093 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -305,9 +305,6 @@ newtype StrictSig = StrictSig DmdType instance Outputable StrictSig where ppr (StrictSig ty) = ppr ty -instance Show StrictSig where - show (StrictSig ty) = showSDoc (ppr ty) - mkStrictSig :: DmdType -> StrictSig mkStrictSig dmd_ty = StrictSig dmd_ty diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index d1df6cc0ab..ec63b893e9 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -41,8 +41,8 @@ module Id ( mkWorkerId, mkWiredInIdName, -- ** Taking an Id apart - idName, idType, idUnique, idInfo, idDetails, - idPrimRep, recordSelectorFieldLabel, + idName, idType, idUnique, idInfo, idDetails, idRepArity, + recordSelectorFieldLabel, -- ** Modifying an Id setIdName, setIdUnique, Id.setIdType, @@ -65,7 +65,7 @@ module Id ( hasNoBinding, -- ** Evidence variables - DictId, isDictId, isEvVar, + DictId, isDictId, dfunNSilent, isEvVar, -- ** Inline pragma stuff idInlinePragma, setInlinePragma, modifyInlinePragma, @@ -118,7 +118,7 @@ import Demand import Name import Module import Class -import PrimOp +import {-# SOURCE #-} PrimOp (PrimOp) import ForeignCall import Maybes import SrcLoc @@ -126,7 +126,7 @@ import Outputable import Unique import UniqSupply import FastString -import Util( count ) +import Util import StaticFlags -- infixl so you can say (id `set` a `set` b) @@ -158,9 +158,6 @@ idUnique = Var.varUnique idType :: Id -> Kind idType = Var.varType -idPrimRep :: Id -> PrimRep -idPrimRep id = typePrimRep (idType id) - setIdName :: Id -> Name -> Id setIdName = Var.setVarName @@ -345,6 +342,11 @@ isDFunId id = case Var.idDetails id of DFunId {} -> True _ -> False +dfunNSilent :: Id -> Int +dfunNSilent id = case Var.idDetails id of + DFunId ns _ -> ns + _ -> pprPanic "dfunSilent: not a dfun:" (ppr id) + isPrimOpId_maybe id = case Var.idDetails id of PrimOpId op -> Just op _ -> Nothing @@ -462,6 +464,9 @@ idArity id = arityInfo (idInfo id) setIdArity :: Id -> Arity -> Id setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id +idRepArity :: Id -> RepArity +idRepArity x = typeRepArity (idArity x) (idType x) + -- | Returns true if an application to n args would diverge isBottomingId :: Id -> Bool isBottomingId id = isBottomingSig (idStrictness id) diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 0d715ef028..93762abba9 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -75,7 +75,7 @@ module IdInfo ( import CoreSyn import Class -import PrimOp +import {-# SOURCE #-} PrimOp (PrimOp) import Name import VarSet import BasicTypes @@ -136,7 +136,14 @@ data IdDetails | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - | DFunId Bool -- ^ A dictionary function. + | DFunId Int Bool -- ^ A dictionary function. + -- Int = the number of "silent" arguments to the dfun + -- e.g. class D a => C a where ... + -- instance C a => C [a] + -- has is_silent = 1, because the dfun + -- has type dfun :: (D a, C a) => C [a] + -- See the DFun Superclass Invariant in TcInstDcls + -- -- Bool = True <=> the class has only one method, so may be -- implemented with a newtype, so it might be bad -- to be strict on this dictionary @@ -158,7 +165,8 @@ pprIdDetails other = brackets (pp other) pp (PrimOpId _) = ptext (sLit "PrimOp") pp (FCallId _) = ptext (sLit "ForeignCall") pp (TickBoxOpId _) = ptext (sLit "TickBoxOp") - pp (DFunId nt) = ptext (sLit "DFunId") + pp (DFunId ns nt) = ptext (sLit "DFunId") + <> ppWhen (ns /= 0) (brackets (int ns)) <> ppWhen nt (ptext (sLit "(nt)")) pp (RecSelId { sel_naughty = is_naughty }) = brackets $ ptext (sLit "RecSel") @@ -496,9 +504,6 @@ pprLBVarInfo IsOneShotLambda = ptext (sLit "OneShot") instance Outputable LBVarInfo where ppr = pprLBVarInfo - -instance Show LBVarInfo where - showsPrec p c = showsPrecSDoc p (ppr c) \end{code} diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index 966dca1e71..bbc70551f9 100644 --- a/compiler/basicTypes/Literal.lhs +++ b/compiler/basicTypes/Literal.lhs @@ -7,13 +7,6 @@ \begin{code} {-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Literal ( -- * Main data type @@ -52,9 +45,7 @@ module Literal import TysPrim import PrelNames import Type -import TypeRep import TyCon -import Var import Outputable import FastTypes import FastString @@ -62,6 +53,8 @@ import BasicTypes import Binary import Constants import UniqFM +import Util + import Data.Int import Data.Ratio import Data.Word @@ -120,32 +113,27 @@ data Literal -- @stdcall@ labels. @Just x@ => @\<x\>@ will -- be appended to label name when emitting assembly. - | LitInteger Integer Id -- ^ Integer literals - -- See Note [Integer literals] + | LitInteger Integer Type -- ^ Integer literals + -- See Note [Integer literals] deriving (Data, Typeable) \end{code} Note [Integer literals] ~~~~~~~~~~~~~~~~~~~~~~~ An Integer literal is represented using, well, an Integer, to make it -easier to write RULEs for them. - - * The Id is for mkInteger, which we use when finally creating the core. +easier to write RULEs for them. They also contain the Integer type, so +that e.g. literalType can return the right Type for them. - * They only get converted into real Core, - mkInteger [c1, c2, .., cn] - during the CorePrep phase. +They only get converted into real Core, + mkInteger [c1, c2, .., cn] +during the CorePrep phase, although TidyPgm looks ahead at what the +core will be, so that it can see whether it involves CAFs. - * When we initally build an Integer literal, notably when - deserialising it from an interface file (see the Binary instance - below), we don't have convenient access to the mkInteger Id. So we - just use an error thunk, and fill in the real Id when we do tcIfaceLit - in TcIface. - - * When looking for CAF-hood (in TidyPgm), we must take account of the - CAF-hood of the mk_integer field in LitInteger; see TidyPgm.cafRefsL. - Indeed this is the only reason we put the mk_integer field in the - literal -- otherwise we could just look it up in CorePrep. +When we initally build an Integer literal, notably when +deserialising it from an interface file (see the Binary instance +below), we don't have convenient access to the mkInteger Id. So we +just use an error thunk, and fill in the real Id when we do tcIfaceLit +in TcIface. Binary instance @@ -203,17 +191,14 @@ instance Binary Literal where return (MachLabel aj mb fod) _ -> do i <- get bh + -- See Note [Integer literals] return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger") - -- See Note [Integer literals] in Literal \end{code} \begin{code} instance Outputable Literal where ppr lit = pprLiteral (\d -> d) lit -instance Show Literal where - showsPrec p lit = showsPrecSDoc p (ppr lit) - instance Eq Literal where a == b = case (a `compare` b) of { EQ -> True; _ -> False } a /= b = case (a `compare` b) of { EQ -> False; _ -> True } @@ -265,7 +250,7 @@ mkMachChar = MachChar mkMachString :: String -> Literal mkMachString s = MachStr (mkFastString s) -- stored UTF-8 encoded -mkLitInteger :: Integer -> Id -> Literal +mkLitInteger :: Integer -> Type -> Literal mkLitInteger = LitInteger inIntRange, inWordRange :: Integer -> Bool @@ -389,12 +374,7 @@ literalType (MachWord64 _) = word64PrimTy literalType (MachFloat _) = floatPrimTy literalType (MachDouble _) = doublePrimTy literalType (MachLabel _ _ _) = addrPrimTy -literalType (LitInteger _ mk_integer_id) - -- We really mean idType, rather than varType, but importing Id - -- causes a module import loop - = case varType mk_integer_id of - FunTy _ (FunTy _ integerTy) -> integerTy - _ -> panic "literalType: mkIntegerId has the wrong type" +literalType (LitInteger _ t) = t absentLiteralOf :: TyCon -> Maybe Literal -- Return a literal of the appropriate primtive diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 60f4cf16ae..c1127da18f 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -69,6 +69,7 @@ import PrelNames import BasicTypes hiding ( SuccessFlag(..) ) import Util import Pair +import DynFlags import Outputable import FastString import ListSetOps @@ -503,13 +504,13 @@ mkDictSelId no_unf name clas -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } dictSelRule :: Int -> Arity - -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr + -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- Tries to persuade the argument to look like a constructor -- application, using exprIsConApp_maybe, and then selects -- from it -- sel_i t1..tk (D t1..tk op1 ... opm) = opi -- -dictSelRule val_index n_ty_args id_unf args +dictSelRule val_index n_ty_args _ id_unf args | (dict_arg : _) <- drop n_ty_args args , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg = Just (con_args !! val_index) @@ -761,14 +762,14 @@ mkPrimOpId prim_op -- details of the ccall, type and all. This means that the interface -- file reader can reconstruct a suitable Id -mkFCallId :: Unique -> ForeignCall -> Type -> Id -mkFCallId uniq fcall ty +mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id +mkFCallId dflags uniq fcall ty = ASSERT( isEmptyVarSet (tyVarsOfType ty) ) -- A CCallOpId should have no free type variables; -- when doing substitutions won't substitute over it mkGlobalId (FCallId fcall) name ty info where - occ_str = showSDoc (braces (ppr fcall <+> ppr ty)) + occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty)) -- The "occurrence name" of a ccall is the full info about the -- ccall; it is encoded, but may have embedded spaces etc! @@ -825,17 +826,29 @@ mkDictFunId :: Name -- Name to use for the dict fun; -- Implements the DFun Superclass Invariant (see TcInstDcls) mkDictFunId dfun_name tvs theta clas tys - = mkExportedLocalVar (DFunId is_nt) + = mkExportedLocalVar (DFunId n_silent is_nt) dfun_name dfun_ty vanillaIdInfo where is_nt = isNewTyCon (classTyCon clas) - dfun_ty = mkDictFunTy tvs theta clas tys + (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys -mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type +mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type) mkDictFunTy tvs theta clas tys - = mkSigmaTy tvs theta (mkClassPred clas tys) + = (length silent_theta, dfun_ty) + where + dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkClassPred clas tys) + silent_theta + | null tvs, null theta + = [] + | otherwise + = filterOut discard $ + substTheta (zipTopTvSubst (classTyVars clas) tys) + (classSCTheta clas) + -- See Note [Silent Superclass Arguments] + discard pred = any (`eqPred` pred) theta + -- See the DFun Superclass Invariant in TcInstDcls \end{code} @@ -881,11 +894,11 @@ unsafeCoerceId `setUnfoldingInfo` mkCompulsoryUnfolding rhs - ty = mkForAllTys [argAlphaTyVar,openBetaTyVar] - (mkFunTy argAlphaTy openBetaTy) - [x] = mkTemplateLocals [argAlphaTy] - rhs = mkLams [argAlphaTyVar,openBetaTyVar,x] $ - Cast (Var x) (mkUnsafeCo argAlphaTy openBetaTy) + ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] + (mkFunTy openAlphaTy openBetaTy) + [x] = mkTemplateLocals [openAlphaTy] + rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ + Cast (Var x) (mkUnsafeCo openAlphaTy openBetaTy) ------------------------------------------------ nullAddrId :: Id @@ -906,10 +919,12 @@ seqId = pcMiscPrelId seqName ty info `setSpecInfo` mkSpecInfo [seq_cast_rule] - ty = mkForAllTys [alphaTyVar,argBetaTyVar] - (mkFunTy alphaTy (mkFunTy argBetaTy argBetaTy)) - [x,y] = mkTemplateLocals [alphaTy, argBetaTy] - rhs = mkLams [alphaTyVar,argBetaTyVar,x,y] (Case (Var x) x argBetaTy [(DEFAULT, [], Var y)]) + ty = mkForAllTys [alphaTyVar,betaTyVar] + (mkFunTy alphaTy (mkFunTy betaTy betaTy)) + -- NB argBetaTyVar; see Note [seqId magic] + + [x,y] = mkTemplateLocals [alphaTy, betaTy] + rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)]) -- See Note [Built-in RULES for seq] seq_cast_rule = BuiltinRule { ru_name = fsLit "seq of cast" @@ -918,12 +933,12 @@ seqId = pcMiscPrelId seqName ty info , ru_try = match_seq_of_cast } -match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +match_seq_of_cast :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- See Note [Built-in RULES for seq] -match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr] +match_seq_of_cast _ _ [Type _, Type res_ty, Cast scrut co, expr] = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty, scrut, expr]) -match_seq_of_cast _ _ = Nothing +match_seq_of_cast _ _ _ = Nothing ------------------------------------------------ lazyId :: Id -- See Note [lazyId magic] @@ -933,12 +948,29 @@ lazyId = pcMiscPrelId lazyIdName ty info ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) \end{code} +Note [Unsafe coerce magic] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define a *primitive* + GHC.Prim.unsafeCoerce# +and then in the base library we define the ordinary function + Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b + unsafeCoerce x = unsafeCoerce# x + +Notice that unsafeCoerce has a civilized (albeit still dangerous) +polymorphic type, whose type args have kind *. So you can't use it on +unboxed values (unsafeCoerce 3#). + +In contrast unsafeCoerce# is even more dangerous because you *can* use +it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is + forall (a:OpenKind) (b:OpenKind). a -> b + Note [seqId magic] ~~~~~~~~~~~~~~~~~~ 'GHC.Prim.seq' is special in several ways. a) Its second arg can have an unboxed type x `seq` (v +# w) + Hence its second type variable has ArgKind b) Its fixity is set in LoadIface.ghcPrimIface diff --git a/compiler/basicTypes/MkId.lhs-boot b/compiler/basicTypes/MkId.lhs-boot index 4f9615a061..7891e65d7f 100644 --- a/compiler/basicTypes/MkId.lhs-boot +++ b/compiler/basicTypes/MkId.lhs-boot @@ -2,8 +2,11 @@ module MkId where import Name( Name ) import DataCon( DataCon, DataConIds ) +import {-# SOURCE #-} PrimOp( PrimOp ) +import Id( Id ) mkDataConIds :: Name -> Name -> DataCon -> DataConIds +mkPrimOpId :: PrimOp -> Id \end{code} diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index e4a9c7d82a..3fefd7b59b 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -55,7 +55,7 @@ module Name ( nameOccName, nameModule, nameModule_maybe, tidyNameOcc, hashName, localiseName, - mkLocalisedOccName, + mkLocalisedOccName, nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, @@ -168,6 +168,9 @@ Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, All built-in syntax is for wired-in things. \begin{code} +instance HasOccName Name where + occName = nameOccName + nameUnique :: Name -> Unique nameOccName :: Name -> OccName nameModule :: Name -> Module diff --git a/compiler/basicTypes/NameEnv.lhs b/compiler/basicTypes/NameEnv.lhs index 8a59e7d220..5b77014b22 100644 --- a/compiler/basicTypes/NameEnv.lhs +++ b/compiler/basicTypes/NameEnv.lhs @@ -24,11 +24,15 @@ module NameEnv ( foldNameEnv, filterNameEnv, plusNameEnv, plusNameEnv_C, alterNameEnv, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, - elemNameEnv, mapNameEnv + elemNameEnv, mapNameEnv, + + -- ** Dependency analysis + depAnal ) where #include "HsVersions.h" +import Digraph import Name import Unique import UniqFM @@ -42,6 +46,32 @@ import Maybes %************************************************************************ \begin{code} +depAnal :: (node -> [Name]) -- Defs + -> (node -> [Name]) -- Uses + -> [node] + -> [SCC node] +-- Peform dependency analysis on a group of definitions, +-- where each definition may define more than one Name +-- +-- The get_defs and get_uses functions are called only once per node +depAnal get_defs get_uses nodes + = stronglyConnCompFromEdgedVertices (map mk_node keyed_nodes) + where + keyed_nodes = nodes `zip` [(1::Int)..] + mk_node (node, key) = (node, key, mapCatMaybes (lookupNameEnv key_map) (get_uses node)) + + key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it + key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] +\end{code} + + +%************************************************************************ +%* * +\subsection{Name environment} +%* * +%************************************************************************ + +\begin{code} type NameEnv a = UniqFM a -- Domain is Name emptyNameEnv :: NameEnv a diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index ff1f71dc5c..553797f263 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -54,6 +54,7 @@ module OccName ( mkTupleOcc, setOccNameSpace, demoteOccName, + HasOccName(..), -- ** Derived 'OccName's isDerivedOccName, @@ -62,7 +63,7 @@ module OccName ( mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, - mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS, + mkGenD, mkGenR, mkGen1R, mkGenRCo, mkGenC, mkGenS, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, @@ -334,6 +335,11 @@ demoteOccName :: OccName -> Maybe OccName demoteOccName (OccName space name) = do space' <- demoteNameSpace space return $ OccName space' name + +{- | Other names in the compiler add aditional information to an OccName. +This class provides a consistent way to access the underlying OccName. -} +class HasOccName name where + occName :: name -> OccName \end{code} @@ -492,7 +498,7 @@ isDataSymOcc _ = False -- it is a data constructor or variable or whatever) isSymOcc :: OccName -> Bool isSymOcc (OccName DataName s) = isLexConSym s -isSymOcc (OccName TcClsName s) = isLexConSym s +isSymOcc (OccName TcClsName s) = isLexConSym s || isLexVarSym s isSymOcc (OccName VarName s) = isLexSym s isSymOcc (OccName TvName s) = isLexSym s -- Pretty inefficient! @@ -569,7 +575,7 @@ isDerivedOccName occ = mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, - mkGenD, mkGenR, mkGenRCo, + mkGenD, mkGenR, mkGen1R, mkGenRCo, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc @@ -612,6 +618,7 @@ mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n) (occNameString occ) mkGenR = mk_simple_deriv tcName "Rep_" +mkGen1R = mk_simple_deriv tcName "Rep1_" mkGenRCo = mk_simple_deriv tcName "CoRep_" -- data T = MkT ... deriving( Data ) needs defintions for diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index de0ff56222..624f94b886 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -44,12 +44,10 @@ module RdrName ( isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, - -- ** Printing - showRdrName, - -- * Local mapping of 'RdrName' to 'Name.Name' LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, - lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, + lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, inLocalRdrEnvScope, + localRdrEnvElts, delLocalRdrEnvList, -- * Global mapping of 'RdrName' to 'GlobalRdrElt's GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, @@ -70,6 +68,7 @@ module RdrName ( import Module import Name +import NameSet import Maybes import SrcLoc import FastString @@ -130,6 +129,10 @@ data RdrName %************************************************************************ \begin{code} + +instance HasOccName RdrName where + occName = rdrNameOcc + rdrNameOcc :: RdrName -> OccName rdrNameOcc (Qual _ occ) = occ rdrNameOcc (Unqual occ) = occ @@ -276,9 +279,6 @@ instance OutputableBndr RdrName where pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) -showRdrName :: RdrName -> String -showRdrName r = showSDoc (ppr r) - instance Eq RdrName where (Exact n1) == (Exact n2) = n1==n2 -- Convert exact to orig @@ -329,30 +329,42 @@ instance Ord RdrName where \begin{code} -- | This environment is used to store local bindings (@let@, @where@, lambda, @case@). -- It is keyed by OccName, because we never use it for qualified names -type LocalRdrEnv = OccEnv Name +-- We keep the current mapping, *and* the set of all Names in scope +-- Reason: see Note [Splicing Exact Names] in RnEnv +type LocalRdrEnv = (OccEnv Name, NameSet) emptyLocalRdrEnv :: LocalRdrEnv -emptyLocalRdrEnv = emptyOccEnv +emptyLocalRdrEnv = (emptyOccEnv, emptyNameSet) extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv -extendLocalRdrEnv env name - = extendOccEnv env (nameOccName name) name +extendLocalRdrEnv (env, ns) name + = (extendOccEnv env (nameOccName name) name, addOneToNameSet ns name) extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv -extendLocalRdrEnvList env names - = extendOccEnvList env [(nameOccName n, n) | n <- names] +extendLocalRdrEnvList (env, ns) names + = (extendOccEnvList env [(nameOccName n, n) | n <- names], addListToNameSet ns names) lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name -lookupLocalRdrEnv env (Unqual occ) = lookupOccEnv env occ -lookupLocalRdrEnv _ _ = Nothing +lookupLocalRdrEnv (env, _) (Unqual occ) = lookupOccEnv env occ +lookupLocalRdrEnv _ _ = Nothing lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name -lookupLocalRdrOcc env occ = lookupOccEnv env occ +lookupLocalRdrOcc (env, _) occ = lookupOccEnv env occ elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool -elemLocalRdrEnv rdr_name env +elemLocalRdrEnv rdr_name (env, _) | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env | otherwise = False + +localRdrEnvElts :: LocalRdrEnv -> [Name] +localRdrEnvElts (env, _) = occEnvElts env + +inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool +-- This is the point of the NameSet +inLocalRdrEnvScope name (_, ns) = name `elemNameSet` ns + +delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv +delLocalRdrEnvList (env, ns) occs = (delListFromOccEnv env occs, ns) \end{code} %************************************************************************ diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index bb7c4c363e..2c008f55d8 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -8,77 +8,70 @@ -- When the earliest compiler we want to boostrap with is -- GHC 7.2, we can make RealSrcLoc properly abstract -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - - -- | This module contains types that relate to the positions of things -- in source files, and allow tagging of those things with locations module SrcLoc ( - -- * SrcLoc - RealSrcLoc, -- Abstract - SrcLoc(..), + -- * SrcLoc + RealSrcLoc, -- Abstract + SrcLoc(..), -- ** Constructing SrcLoc - mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, + mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, - noSrcLoc, -- "I'm sorry, I haven't a clue" - generatedSrcLoc, -- Code generated within the compiler - interactiveSrcLoc, -- Code from an interactive session + noSrcLoc, -- "I'm sorry, I haven't a clue" + generatedSrcLoc, -- Code generated within the compiler + interactiveSrcLoc, -- Code from an interactive session advanceSrcLoc, - -- ** Unsafely deconstructing SrcLoc - -- These are dubious exports, because they crash on some inputs - srcLocFile, -- return the file name part - srcLocLine, -- return the line part - srcLocCol, -- return the column part - + -- ** Unsafely deconstructing SrcLoc + -- These are dubious exports, because they crash on some inputs + srcLocFile, -- return the file name part + srcLocLine, -- return the line part + srcLocCol, -- return the column part + -- * SrcSpan - RealSrcSpan, -- Abstract - SrcSpan(..), + RealSrcSpan, -- Abstract + SrcSpan(..), -- ** Constructing SrcSpan - mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, - noSrcSpan, - wiredInSrcSpan, -- Something wired into the compiler - srcLocSpan, realSrcLocSpan, - combineSrcSpans, - - -- ** Deconstructing SrcSpan - srcSpanStart, srcSpanEnd, - realSrcSpanStart, realSrcSpanEnd, - srcSpanFileName_maybe, - - -- ** Unsafely deconstructing SrcSpan - -- These are dubious exports, because they crash on some inputs - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, + mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, + noSrcSpan, + wiredInSrcSpan, -- Something wired into the compiler + srcLocSpan, realSrcLocSpan, + combineSrcSpans, + + -- ** Deconstructing SrcSpan + srcSpanStart, srcSpanEnd, + realSrcSpanStart, realSrcSpanEnd, + srcSpanFileName_maybe, + showUserSpan, + + -- ** Unsafely deconstructing SrcSpan + -- These are dubious exports, because they crash on some inputs + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol, -- ** Predicates on SrcSpan isGoodSrcSpan, isOneLineSpan, -- * Located - Located, - RealLocated, - GenLocated(..), - - -- ** Constructing Located - noLoc, + Located, + RealLocated, + GenLocated(..), + + -- ** Constructing Located + noLoc, mkGeneralLocated, - - -- ** Deconstructing Located - getLoc, unLoc, - - -- ** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, - leftmost_smallest, leftmost_largest, rightmost, - spans, isSubspanOf + + -- ** Deconstructing Located + getLoc, unLoc, + + -- ** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost, + spans, isSubspanOf, sortLocated ) where #include "Typeable.h" @@ -89,12 +82,15 @@ import FastString import Data.Bits import Data.Data +import Data.List +import Data.Ord +import System.FilePath \end{code} %************************************************************************ -%* * +%* * \subsection[SrcLoc-SrcLocations]{Source-location information} -%* * +%* * %************************************************************************ We keep information about the {\em definition} point for each entity; @@ -102,20 +98,20 @@ this is the obvious stuff: \begin{code} -- | Represents a single point within a file data RealSrcLoc - = SrcLoc FastString -- A precise location (file name) - {-# UNPACK #-} !Int -- line number, begins at 1 - {-# UNPACK #-} !Int -- column number, begins at 1 + = SrcLoc FastString -- A precise location (file name) + {-# UNPACK #-} !Int -- line number, begins at 1 + {-# UNPACK #-} !Int -- column number, begins at 1 deriving Show data SrcLoc = RealSrcLoc {-# UNPACK #-}!RealSrcLoc - | UnhelpfulLoc FastString -- Just a general indication + | UnhelpfulLoc FastString -- Just a general indication \end{code} %************************************************************************ -%* * +%* * \subsection[SrcLoc-access-fns]{Access functions} -%* * +%* * %************************************************************************ \begin{code} @@ -127,13 +123,13 @@ mkRealSrcLoc x line col = SrcLoc x line col -- | Built-in "bad" 'SrcLoc' values for particular locations noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc -noSrcLoc = UnhelpfulLoc (fsLit "<no location info>") +noSrcLoc = UnhelpfulLoc (fsLit "<no location info>") generatedSrcLoc = UnhelpfulLoc (fsLit "<compiler-generated code>") interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive session>") -- | Creates a "bad" 'SrcLoc' that has no detailed information about its location mkGeneralSrcLoc :: FastString -> SrcLoc -mkGeneralSrcLoc = UnhelpfulLoc +mkGeneralSrcLoc = UnhelpfulLoc -- | Gives the filename of the 'RealSrcLoc' srcLocFile :: RealSrcLoc -> FastString @@ -158,9 +154,9 @@ advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) \end{code} %************************************************************************ -%* * +%* * \subsection[SrcLoc-instances]{Instance declarations for various names} -%* * +%* * %************************************************************************ \begin{code} @@ -181,6 +177,9 @@ instance Ord SrcLoc where instance Ord RealSrcLoc where compare = cmpRealSrcLoc +sortLocated :: [Located a] -> [Located a] +sortLocated things = sortBy (comparing getLoc) things + cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 cmpSrcLoc (UnhelpfulLoc _) (RealSrcLoc _) = GT @@ -195,7 +194,7 @@ instance Outputable RealSrcLoc where ppr (SrcLoc src_path src_line src_col) = getPprStyle $ \ sty -> if userStyle sty || debugStyle sty then - hcat [ pprFastFilePath src_path, char ':', + hcat [ pprFastFilePath src_path, char ':', int src_line, char ':', int src_col ] @@ -221,9 +220,9 @@ instance Data SrcSpan where \end{code} %************************************************************************ -%* * +%* * \subsection[SrcSpan]{Source Spans} -%* * +%* * %************************************************************************ \begin{code} @@ -238,33 +237,33 @@ span. That is, a span of (1,1)-(1,2) is one character long, and a span of (1,1)-(1,1) is zero characters long. -} data RealSrcSpan - = SrcSpanOneLine -- a common case: a single line - { srcSpanFile :: !FastString, - srcSpanLine :: {-# UNPACK #-} !Int, - srcSpanSCol :: {-# UNPACK #-} !Int, - srcSpanECol :: {-# UNPACK #-} !Int - } + = SrcSpanOneLine -- a common case: a single line + { srcSpanFile :: !FastString, + srcSpanLine :: {-# UNPACK #-} !Int, + srcSpanSCol :: {-# UNPACK #-} !Int, + srcSpanECol :: {-# UNPACK #-} !Int + } | SrcSpanMultiLine - { srcSpanFile :: !FastString, - srcSpanSLine :: {-# UNPACK #-} !Int, - srcSpanSCol :: {-# UNPACK #-} !Int, - srcSpanELine :: {-# UNPACK #-} !Int, - srcSpanECol :: {-# UNPACK #-} !Int - } + { srcSpanFile :: !FastString, + srcSpanSLine :: {-# UNPACK #-} !Int, + srcSpanSCol :: {-# UNPACK #-} !Int, + srcSpanELine :: {-# UNPACK #-} !Int, + srcSpanECol :: {-# UNPACK #-} !Int + } | SrcSpanPoint - { srcSpanFile :: !FastString, - srcSpanLine :: {-# UNPACK #-} !Int, - srcSpanCol :: {-# UNPACK #-} !Int - } + { srcSpanFile :: !FastString, + srcSpanLine :: {-# UNPACK #-} !Int, + srcSpanCol :: {-# UNPACK #-} !Int + } deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we -- derive Show for Token data SrcSpan = RealSrcSpan !RealSrcSpan - | UnhelpfulSpan !FastString -- Just a general indication - -- also used to indicate an empty span + | UnhelpfulSpan !FastString -- Just a general indication + -- also used to indicate an empty span deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we -- derive Show for Token @@ -290,15 +289,15 @@ realSrcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan mkRealSrcSpan loc1 loc2 | line1 == line2 = if col1 == col2 - then SrcSpanPoint file line1 col1 - else SrcSpanOneLine file line1 col1 col2 + then SrcSpanPoint file line1 col1 + else SrcSpanOneLine file line1 col1 col2 | otherwise = SrcSpanMultiLine file line1 col1 line2 col2 where - line1 = srcLocLine loc1 - line2 = srcLocLine loc2 - col1 = srcLocCol loc1 - col2 = srcLocCol loc2 - file = srcLocFile loc1 + line1 = srcLocLine loc1 + line2 = srcLocLine loc2 + col1 = srcLocCol loc1 + col2 = srcLocCol loc2 + file = srcLocFile loc1 -- | Create a 'SrcSpan' between two points in a file mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan @@ -309,33 +308,33 @@ mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2) -- | Combines two 'SrcSpan' into one that spans at least all the characters -- within both spans. Assumes the "file" part is the same in both inputs -combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan -combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful -combineSrcSpans l (UnhelpfulSpan _) = l -combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2) +combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful +combineSrcSpans l (UnhelpfulSpan _) = l +combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2) = RealSrcSpan (combineRealSrcSpans span1 span2) -- | Combines two 'SrcSpan' into one that spans at least all the characters -- within both spans. Assumes the "file" part is the same in both inputs combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan combineRealSrcSpans span1 span2 - = if line_start == line_end + = if line_start == line_end then if col_start == col_end then SrcSpanPoint file line_start col_start else SrcSpanOneLine file line_start col_start col_end else SrcSpanMultiLine file line_start col_start line_end col_end where (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) - (srcSpanStartLine span2, srcSpanStartCol span2) + (srcSpanStartLine span2, srcSpanStartCol span2) (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) - (srcSpanEndLine span2, srcSpanEndCol span2) + (srcSpanEndLine span2, srcSpanEndCol span2) file = srcSpanFile span1 \end{code} %************************************************************************ -%* * +%* * \subsection[SrcSpan-predicates]{Predicates} -%* * +%* * %************************************************************************ \begin{code} @@ -353,9 +352,9 @@ isOneLineSpan (UnhelpfulSpan _) = False \end{code} %************************************************************************ -%* * +%* * \subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} -%* * +%* * %************************************************************************ \begin{code} @@ -384,9 +383,9 @@ srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c \end{code} %************************************************************************ -%* * +%* * \subsection[SrcSpan-access-fns]{Access functions} -%* * +%* * %************************************************************************ \begin{code} @@ -419,17 +418,17 @@ srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing \end{code} %************************************************************************ -%* * +%* * \subsection[SrcSpan-instances]{Instances} -%* * +%* * %************************************************************************ \begin{code} -- We want to order SrcSpans first by the start point, then by the end point. instance Ord SrcSpan where - a `compare` b = - (srcSpanStart a `compare` srcSpanStart b) `thenCmp` + a `compare` b = + (srcSpanStart a `compare` srcSpanStart b) `thenCmp` (srcSpanEnd a `compare` srcSpanEnd b) @@ -437,7 +436,7 @@ instance Outputable RealSrcSpan where ppr span = getPprStyle $ \ sty -> if userStyle sty || debugStyle sty then - pprUserRealSpan True span + text (showUserRealSpan True span) else hcat [text "{-# LINE ", int (srcSpanStartLine span), space, char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] @@ -454,36 +453,36 @@ instance Outputable SrcSpan where pprUserSpan :: Bool -> SrcSpan -> SDoc pprUserSpan _ (UnhelpfulSpan s) = ftext s -pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s - -pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc -pprUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col) - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , int line, char ':', int start_col - , ppUnless (end_col - start_col <= 1) - (char '-' <> int (end_col-1)) - -- For single-character or point spans, we just - -- output the starting column number - ] - - -pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol) - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , parens (int sline <> char ',' <> int scol) - , char '-' - , parens (int eline <> char ',' <> - if ecol == 0 then int ecol else int (ecol-1)) - ] - -pprUserRealSpan show_path (SrcSpanPoint src_path line col) - = hcat [ ppWhen show_path $ (pprFastFilePath src_path <> colon) - , int line, char ':', int col ] +pprUserSpan show_path (RealSrcSpan s) = text (showUserRealSpan show_path s) + +showUserSpan :: Bool -> SrcSpan -> String +showUserSpan _ (UnhelpfulSpan s) = unpackFS s +showUserSpan show_path (RealSrcSpan s) = showUserRealSpan show_path s + +showUserRealSpan :: Bool -> RealSrcSpan -> String +showUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col) + = (if show_path then normalise (unpackFS src_path) ++ ":" else "") + ++ show line ++ ":" ++ show start_col + ++ (if end_col - start_col <= 1 then "" else '-' : show (end_col - 1)) + -- For single-character or point spans, we just + -- output the starting column number + +showUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol) + = (if show_path then normalise (unpackFS src_path) ++ ":" else "") + ++ "(" ++ show sline ++ "," ++ show scol ++ ")" + ++ "-" + ++ "(" ++ show eline ++ "," ++ show ecol' ++ ")" + where ecol' = if ecol == 0 then ecol else ecol - 1 + +showUserRealSpan show_path (SrcSpanPoint src_path line col) + = (if show_path then normalise (unpackFS src_path) ++ ":" else "") + ++ show line ++ ":" ++ show col \end{code} %************************************************************************ -%* * +%* * \subsection[Located]{Attaching SrcSpans to things} -%* * +%* * %************************************************************************ \begin{code} @@ -538,16 +537,16 @@ instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where \end{code} %************************************************************************ -%* * +%* * \subsection{Ordering SrcSpans for InteractiveUI} -%* * +%* * %************************************************************************ \begin{code} -- | Alternative strategies for ordering 'SrcSpan's leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering rightmost = flip compare -leftmost_smallest = compare +leftmost_smallest = compare leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b) `thenCmp` (srcSpanEnd b `compare` srcSpanEnd a) @@ -562,7 +561,7 @@ spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcS isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other -> SrcSpan -- ^ The span it may be enclosed by -> Bool -isSubspanOf src parent +isSubspanOf src parent | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False | otherwise = srcSpanStart parent <= srcSpanStart src && srcSpanEnd parent >= srcSpanEnd src diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs index 4bcf090d0b..f3fb28ac21 100644 --- a/compiler/basicTypes/UniqSupply.lhs +++ b/compiler/basicTypes/UniqSupply.lhs @@ -23,7 +23,7 @@ module UniqSupply ( lazyThenUs, lazyMapUs, -- ** Deprecated operations on 'UniqSM' - getUniqueUs, getUs, returnUs, thenUs, mapUs + getUniqueUs, getUs, ) where import Unique @@ -191,13 +191,6 @@ getUniqueUs = USM (\us -> case splitUniqSupply us of getUniquesUs :: UniqSM [Unique] getUniquesUs = USM (\us -> case splitUniqSupply us of (us1,us2) -> (# uniqsFromSupply us1, us2 #)) - -mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] -mapUs _ [] = returnUs [] -mapUs f (x:xs) - = f x `thenUs` \ r -> - mapUs f xs `thenUs` \ rs -> - returnUs (r:rs) \end{code} \begin{code} diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs index f99a50cfeb..48afc8da41 100644 --- a/compiler/basicTypes/Unique.lhs +++ b/compiler/basicTypes/Unique.lhs @@ -71,6 +71,7 @@ import FastTypes import FastString import Outputable -- import StaticFlags +import Util #if defined(__GLASGOW_HASKELL__) --just for implementing a fast [0,61) -> Char function @@ -178,9 +179,6 @@ instance Uniquable FastString where instance Uniquable Int where getUnique i = mkUniqueGrimily i - -instance Uniquable n => Uniquable (IPName n) where - getUnique (IPName n) = getUnique n \end{code} @@ -222,33 +220,26 @@ instance Uniquable Unique where We do sometimes make strings with @Uniques@ in them: \begin{code} -pprUnique :: Unique -> SDoc -pprUnique uniq --- | opt_SuppressUniques --- = empty -- Used exclusively to suppress uniques so you --- | otherwise -- can compare output easily +showUnique :: Unique -> String +showUnique uniq = case unpkUnique uniq of - (tag, u) -> finish_ppr tag u (text (iToBase62 u)) + (tag, u) -> finish_show tag u (iToBase62 u) -#ifdef UNUSED -pprUnique10 :: Unique -> SDoc -pprUnique10 uniq -- in base-10, dudes - = case unpkUnique uniq of - (tag, u) -> finish_ppr tag u (int u) -#endif +finish_show :: Char -> Int -> String -> String +finish_show 't' u _pp_u | u < 26 + = -- Special case to make v common tyvars, t1, t2, ... + -- come out as a, b, ... (shorter, easier to read) + [chr (ord 'a' + u)] +finish_show tag _ pp_u = tag : pp_u -finish_ppr :: Char -> Int -> SDoc -> SDoc -finish_ppr 't' u _pp_u | u < 26 - = -- Special case to make v common tyvars, t1, t2, ... - -- come out as a, b, ... (shorter, easier to read) - char (chr (ord 'a' + u)) -finish_ppr tag _ pp_u = char tag <> pp_u +pprUnique :: Unique -> SDoc +pprUnique u = text (showUnique u) instance Outputable Unique where - ppr u = pprUnique u + ppr = pprUnique instance Show Unique where - showsPrec p uniq = showsPrecSDoc p (pprUnique uniq) + show uniq = showUnique uniq \end{code} %************************************************************************ diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index ea8e9d2622..c6e743fbb3 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -39,7 +39,8 @@ module Var ( -- * The main data type and synonyms - Var, TyVar, CoVar, Id, KindVar, DictId, DFunId, EvVar, EqVar, EvId, IpId, + Var, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId, + TyVar, TypeVar, KindVar, TKVar, -- ** Taking 'Var's apart varName, varUnique, varType, @@ -54,7 +55,7 @@ module Var ( setIdExported, setIdNotExported, -- ** Predicates - isId, isTyVar, isTcTyVar, + isId, isTKVar, isTyVar, isTcTyVar, isLocalVar, isLocalId, isGlobalId, isExportedId, mustHaveLocalBinding, @@ -102,7 +103,10 @@ import Data.Data \begin{code} type Id = Var -- A term-level identifier -type TyVar = Var -- Type *or* kind variable +type TyVar = Var -- Type *or* kind variable (historical) + +type TKVar = Var -- Type *or* kind variable (historical) +type TypeVar = Var -- Definitely a type variable type KindVar = Var -- Definitely a kind variable -- See Note [Kind and type variables] @@ -136,8 +140,8 @@ Before kind polymorphism, TyVar were used to mean type variables. Now they are use to mean kind *or* type variables. KindVar is used when we know for sure that it is a kind variable. In future, we might want to go over the whole compiler code to use: - - KiTyVar to mean kind or type variables - - TyVar to mean type variables only + - TKVar to mean kind or type variables + - TypeVar to mean type variables only - KindVar to mean kind variables @@ -157,13 +161,13 @@ in its @VarDetails@. -- | Essentially a typed 'Name', that may also contain some additional information -- about the 'Var' and it's use sites. data Var - = TyVar { -- type and kind variables + = TyVar { -- Type and kind variables -- see Note [Kind and type variables] varName :: !Name, - realUnique :: FastInt, -- Key for fast comparison - -- Identical to the Unique in the name, - -- cached here for speed - varType :: Kind -- ^ The type or kind of the 'Var' in question + realUnique :: FastInt, -- Key for fast comparison + -- Identical to the Unique in the name, + -- cached here for speed + varType :: Kind -- ^ The type or kind of the 'Var' in question } | TcTyVar { -- Used only during type inference @@ -227,9 +231,6 @@ ppr_id_scope GlobalId = ptext (sLit "gid") ppr_id_scope (LocalId Exported) = ptext (sLit "lidx") ppr_id_scope (LocalId NotExported) = ptext (sLit "lid") -instance Show Var where - showsPrec p var = showsPrecSDoc p (ppr var) - instance NamedThing Var where getName = varName @@ -329,7 +330,7 @@ setTcTyVarDetails tv details = tv { tc_tv_details = details } mkKindVar :: Name -> SuperKind -> KindVar -- mkKindVar take a SuperKind as argument because we don't have access --- to tySuperKind here. +-- to superKind here. mkKindVar name kind = TyVar { varName = name , realUnique = getKeyFastInt (nameUnique name) @@ -411,10 +412,13 @@ setIdNotExported id = ASSERT( isLocalId id ) %************************************************************************ \begin{code} -isTyVar :: Var -> Bool -- True of both type variables only -isTyVar (TyVar {}) = True -isTyVar (TcTyVar {}) = True -isTyVar _ = False +isTyVar :: Var -> Bool +isTyVar = isTKVar -- Historical + +isTKVar :: Var -> Bool -- True of both type and kind variables +isTKVar (TyVar {}) = True +isTKVar (TcTyVar {}) = True +isTKVar _ = False isTcTyVar :: Var -> Bool isTcTyVar (TcTyVar {}) = True diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs index 1fbbf8fdf3..642ae40fdb 100644 --- a/compiler/cmm/Bitmap.hs +++ b/compiler/cmm/Bitmap.hs @@ -63,7 +63,7 @@ intsToBitmap size slots{- must be sorted -} -- eg. @[0,1,3], size 4 ==> 0x4@ (we leave any bits outside the size as zero, -- just to make the bitmap easier to read). -- --- The list of @Int@s /must/ be already sorted. +-- The list of @Int@s /must/ be already sorted and duplicate-free. intsToReverseBitmap :: Int -> [Int] -> Bitmap intsToReverseBitmap size slots{- must be sorted -} | size <= 0 = [] diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 717a38a6db..6ffbbc774d 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -252,23 +252,22 @@ data ForeignLabelSource -- We can't make a Show instance for CLabel because lots of its components don't have instances. -- The regular Outputable instance only shows the label name, and not its other info. -- -pprDebugCLabel :: Platform -> CLabel -> SDoc -pprDebugCLabel platform lbl +pprDebugCLabel :: CLabel -> SDoc +pprDebugCLabel lbl = case lbl of - IdLabel{} -> pprPlatform platform lbl <> (parens $ text "IdLabel") + IdLabel{} -> ppr lbl <> (parens $ text "IdLabel") CmmLabel pkg _name _info - -> pprPlatform platform lbl <> (parens $ text "CmmLabel" <+> ppr pkg) + -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg) - RtsLabel{} -> pprPlatform platform lbl <> (parens $ text "RtsLabel") + RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel") ForeignLabel _name mSuffix src funOrData - -> pprPlatform platform lbl <> (parens - $ text "ForeignLabel" + -> ppr lbl <> (parens $ text "ForeignLabel" <+> ppr mSuffix <+> ppr src <+> ppr funOrData) - _ -> pprPlatform platform lbl <> (parens $ text "other CLabel)") + _ -> ppr lbl <> (parens $ text "other CLabel)") data IdLabelInfo @@ -534,38 +533,38 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -- ----------------------------------------------------------------------------- -- Convert between different kinds of label -toClosureLbl :: Platform -> CLabel -> CLabel -toClosureLbl _ (IdLabel n c _) = IdLabel n c Closure -toClosureLbl platform l = pprPanic "toClosureLbl" (pprCLabel platform l) - -toSlowEntryLbl :: Platform -> CLabel -> CLabel -toSlowEntryLbl _ (IdLabel n c _) = IdLabel n c Slow -toSlowEntryLbl platform l = pprPanic "toSlowEntryLbl" (pprCLabel platform l) - -toRednCountsLbl :: Platform -> CLabel -> CLabel -toRednCountsLbl _ (IdLabel n c _) = IdLabel n c RednCounts -toRednCountsLbl platform l = pprPanic "toRednCountsLbl" (pprCLabel platform l) - -toEntryLbl :: Platform -> CLabel -> CLabel -toEntryLbl _ (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry -toEntryLbl _ (IdLabel n c ConInfoTable) = IdLabel n c ConEntry -toEntryLbl _ (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry -toEntryLbl _ (IdLabel n c _) = IdLabel n c Entry -toEntryLbl _ (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt -toEntryLbl _ (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry -toEntryLbl _ (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet -toEntryLbl platform l = pprPanic "toEntryLbl" (pprCLabel platform l) - -toInfoLbl :: Platform -> CLabel -> CLabel -toInfoLbl _ (IdLabel n c Entry) = IdLabel n c InfoTable -toInfoLbl _ (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable -toInfoLbl _ (IdLabel n c ConEntry) = IdLabel n c ConInfoTable -toInfoLbl _ (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable -toInfoLbl _ (IdLabel n c _) = IdLabel n c InfoTable -toInfoLbl _ (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo -toInfoLbl _ (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo -toInfoLbl _ (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo -toInfoLbl platform l = pprPanic "CLabel.toInfoLbl" (pprCLabel platform l) +toClosureLbl :: CLabel -> CLabel +toClosureLbl (IdLabel n c _) = IdLabel n c Closure +toClosureLbl l = pprPanic "toClosureLbl" (ppr l) + +toSlowEntryLbl :: CLabel -> CLabel +toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow +toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l) + +toRednCountsLbl :: CLabel -> CLabel +toRednCountsLbl (IdLabel n c _) = IdLabel n c RednCounts +toRednCountsLbl l = pprPanic "toRednCountsLbl" (ppr l) + +toEntryLbl :: CLabel -> CLabel +toEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry +toEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry +toEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry +toEntryLbl (IdLabel n c _) = IdLabel n c Entry +toEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt +toEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry +toEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet +toEntryLbl l = pprPanic "toEntryLbl" (ppr l) + +toInfoLbl :: CLabel -> CLabel +toInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable +toInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable +toInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable +toInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable +toInfoLbl (IdLabel n c _) = IdLabel n c InfoTable +toInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo +toInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo +toInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo +toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l) -- ----------------------------------------------------------------------------- -- Does a CLabel refer to a CAF? @@ -922,8 +921,8 @@ Not exporting these Just_info labels reduces the number of symbols somewhat. -} -instance PlatformOutputable CLabel where - pprPlatform = pprCLabel +instance Outputable CLabel where + ppr c = sdocWithPlatform $ \platform -> pprCLabel platform c pprCLabel :: Platform -> CLabel -> SDoc @@ -1106,35 +1105,35 @@ pprDynamicLinkerAsmLabel platform dllInfo lbl = if platformOS platform == OSDarwin then if platformArch platform == ArchX86_64 then case dllInfo of - CodeStub -> char 'L' <> pprCLabel platform lbl <> text "$stub" - SymbolPtr -> char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr" - GotSymbolPtr -> pprCLabel platform lbl <> text "@GOTPCREL" - GotSymbolOffset -> pprCLabel platform lbl + CodeStub -> char 'L' <> ppr lbl <> text "$stub" + SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr" + GotSymbolPtr -> ppr lbl <> text "@GOTPCREL" + GotSymbolOffset -> ppr lbl else case dllInfo of - CodeStub -> char 'L' <> pprCLabel platform lbl <> text "$stub" - SymbolPtr -> char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr" + CodeStub -> char 'L' <> ppr lbl <> text "$stub" + SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr" _ -> panic "pprDynamicLinkerAsmLabel" else if osElfTarget (platformOS platform) then if platformArch platform == ArchPPC then case dllInfo of - CodeStub -> pprCLabel platform lbl <> text "@plt" - SymbolPtr -> text ".LC_" <> pprCLabel platform lbl + CodeStub -> ppr lbl <> text "@plt" + SymbolPtr -> text ".LC_" <> ppr lbl _ -> panic "pprDynamicLinkerAsmLabel" else if platformArch platform == ArchX86_64 then case dllInfo of - CodeStub -> pprCLabel platform lbl <> text "@plt" - GotSymbolPtr -> pprCLabel platform lbl <> text "@gotpcrel" - GotSymbolOffset -> pprCLabel platform lbl - SymbolPtr -> text ".LC_" <> pprCLabel platform lbl + CodeStub -> ppr lbl <> text "@plt" + GotSymbolPtr -> ppr lbl <> text "@gotpcrel" + GotSymbolOffset -> ppr lbl + SymbolPtr -> text ".LC_" <> ppr lbl else case dllInfo of - CodeStub -> pprCLabel platform lbl <> text "@plt" - SymbolPtr -> text ".LC_" <> pprCLabel platform lbl - GotSymbolPtr -> pprCLabel platform lbl <> text "@got" - GotSymbolOffset -> pprCLabel platform lbl <> text "@gotoff" + CodeStub -> ppr lbl <> text "@plt" + SymbolPtr -> text ".LC_" <> ppr lbl + GotSymbolPtr -> ppr lbl <> text "@got" + GotSymbolOffset -> ppr lbl <> text "@gotoff" else if platformOS platform == OSMinGW32 then case dllInfo of - SymbolPtr -> text "__imp_" <> pprCLabel platform lbl + SymbolPtr -> text "__imp_" <> ppr lbl _ -> panic "pprDynamicLinkerAsmLabel" else panic "pprDynamicLinkerAsmLabel" diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 9ab02f4094..d70fd8c835 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -1,14 +1,6 @@ -- Cmm representations using Hoopl's Graph CmmNode e x. {-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} #if __GLASGOW_HASKELL__ >= 703 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs @@ -139,7 +131,7 @@ data ProfilingInfo -- we add a label for the table, and expect only the 'offset/length' form data C_SRT = NoC_SRT - | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-} + | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-} deriving (Eq) needsSRT :: C_SRT -> Bool diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 72705b6f3f..2378988b68 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-} +{-# LANGUAGE GADTs, NoMonoLocalBinds #-} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and @@ -7,8 +7,8 @@ -- for details -- Norman likes local bindings --- If this module lives on I'd like to get rid of the -XNoMonoLocalBinds --- flag in due course +-- If this module lives on I'd like to get rid of the NoMonoLocalBinds +-- extension in due course -- Todo: remove -fno-warn-warnings-deprecations {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} @@ -30,7 +30,7 @@ import Constants import Digraph import qualified Prelude as P import Prelude hiding (succ) -import Util (sortLe) +import Util import BlockId import Bitmap @@ -48,7 +48,6 @@ import Control.Monad import Name import OptimizationFuel import Outputable -import Platform import SMRep import UniqSupply @@ -94,8 +93,8 @@ cafLattice = DataflowLattice "live cafs" Set.empty add where add _ (OldFact old) (NewFact new) = case old `Set.union` new of new' -> (changeIf $ Set.size new' > Set.size old, new') -cafTransfers :: Platform -> BwdTransfer CmmNode CAFSet -cafTransfers platform = mkBTransfer3 first middle last +cafTransfers :: BwdTransfer CmmNode CAFSet +cafTransfers = mkBTransfer3 first middle last where first _ live = live middle m live = foldExpDeep addCaf m live last l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live) @@ -104,12 +103,11 @@ cafTransfers platform = mkBTransfer3 first middle last CmmLit (CmmLabelOff c _) -> add c set CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set _ -> set - add l s = if hasCAF l then Set.insert (toClosureLbl platform l) s + add l s = if hasCAF l then Set.insert (toClosureLbl l) s else s cafAnal :: Platform -> CmmGraph -> CAFEnv -cafAnal platform g - = dataflowAnalBwd g [] $ analBwd cafLattice (cafTransfers platform) +cafAnal g = dataflowAnalBwd g [] $ analBwd cafLattice cafTransfers ----------------------------------------------------------------------- -- Building the SRTs @@ -121,12 +119,12 @@ data TopSRT = TopSRT { lbl :: CLabel , rev_elts :: [CLabel] , elt_map :: Map CLabel Int } -- map: CLabel -> its last entry in the table -instance PlatformOutputable TopSRT where - pprPlatform platform (TopSRT lbl next elts eltmap) = - text "TopSRT:" <+> pprPlatform platform lbl +instance Outputable TopSRT where + ppr (TopSRT lbl next elts eltmap) = + text "TopSRT:" <+> ppr lbl <+> ppr next - <+> pprPlatform platform elts - <+> pprPlatform platform eltmap + <+> ppr elts + <+> ppr eltmap emptySRT :: MonadUnique m => m TopSRT emptySRT = @@ -210,7 +208,7 @@ procpointSRT top_srt top_table entries = return (top, srt) where ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries - sorted_ints = sortLe (<=) ints + sorted_ints = sort ints offset = head sorted_ints bitmap_entries = map (subtract offset) sorted_ints len = P.last bitmap_entries + 1 @@ -241,13 +239,13 @@ to_SRT top_srt off len bmp -- keep its CAFs live.) -- Any procedure referring to a non-static CAF c must keep live -- any CAF that is reachable from c. -localCAFInfo :: Platform -> CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet) -localCAFInfo _ _ (CmmData _ _) = Nothing -localCAFInfo platform cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) = +localCAFInfo :: CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet) +localCAFInfo _ (CmmData _ _) = Nothing +localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) = case info_tbl top_info of CmmInfoTable { cit_rep = rep } | not (isStaticRep rep) - -> Just (toClosureLbl platform top_l, + -> Just (toClosureLbl top_l, expectJust "maybeBindCAFs" $ mapLookup entry cafEnv) _ -> Nothing diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 3d312caac4..e72eee041c 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -33,7 +33,7 @@ get_hints (ForeignTarget _ (ForeignConvention _ _ hints)) Results = hints get_hints (PrimTarget _) _vd = repeat NoHint cmm_target :: ForeignTarget -> Old.CmmCallTarget -cmm_target (PrimTarget op) = Old.CmmPrim op +cmm_target (PrimTarget op) = Old.CmmPrim op Nothing cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 3b6fec6925..939d4b7ca9 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -225,6 +225,10 @@ filterRegsUsed p e = foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs) emptyRegSet e +instance UserOfLocalRegs a => UserOfLocalRegs (Maybe a) where + foldRegsUsed f z (Just x) = foldRegsUsed f z x + foldRegsUsed _ z Nothing = z + instance UserOfLocalRegs CmmReg where foldRegsUsed f z (CmmLocal reg) = f z reg foldRegsUsed _ z (CmmGlobal _) = z diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 7006c74ff7..a171faa057 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -29,6 +29,8 @@ import Platform import StaticFlags import UniqSupply import MonadUtils +import Util + import Data.Bits import Data.Word @@ -175,7 +177,7 @@ mkInfoTableContents platform , srt_lit, liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } where - slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl) + slow_entry = CmmLabel (toSlowEntryLbl info_lbl) srt_lit = case srt_label of [] -> mkIntCLit 0 (lit:_rest) -> ASSERT( null _rest ) lit diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 1625307c2b..cd0558616e 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -17,7 +17,6 @@ import PprCmm () import BlockId import FastString import CLabel -import Platform import Outputable import Constants @@ -31,31 +30,25 @@ import Data.Maybe -- ----------------------------------------------------------------------------- -- Exported entry points: -cmmLint :: (PlatformOutputable d, PlatformOutputable h) - => Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc -cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops +cmmLint :: (Outputable d, Outputable h) + => GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLint tops = runCmmLint (mapM_ lintCmmDecl) tops -cmmLintDecl :: (PlatformOutputable d, PlatformOutputable h) - => Platform -> GenCmmDecl d h CmmGraph -> Maybe SDoc -cmmLintDecl platform top = runCmmLint platform lintCmmDecl top +cmmLintGraph :: CmmGraph -> Maybe SDoc +cmmLintGraph g = runCmmLint lintCmmGraph g -cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc -cmmLintGraph platform g = runCmmLint platform lintCmmGraph g - -runCmmLint :: PlatformOutputable a - => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint platform l p = - case unCL (l p) platform of - Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), - nest 2 err, - ptext $ sLit ("Program was:"), - nest 2 (pprPlatform platform p)]) - Right _ -> Nothing +runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint l p = + case unCL (l p) of + Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), + nest 2 err, + ptext $ sLit ("Program was:"), + nest 2 (ppr p)]) + Right _ -> Nothing lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint () lintCmmDecl (CmmProc _ lbl g) - = addLintInfo (\platform -> text "in proc " <> pprCLabel platform lbl) $ - lintCmmGraph g + = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g lintCmmDecl (CmmData {}) = return () @@ -165,10 +158,8 @@ lintCmmLast labels node = case node of erep <- lintCmmExpr e if (erep `cmmEqType_ignoring_ptrhood` bWord) then return () - else cmmLintErr (\platform -> - text "switch scrutinee is not a word: " <> - pprPlatform platform e <> - text " :: " <> ppr erep) + else cmmLintErr (text "switch scrutinee is not a word: " <> + ppr e <> text " :: " <> ppr erep) CmmCall { cml_target = target, cml_cont = cont } -> do _ <- lintCmmExpr target @@ -193,15 +184,15 @@ checkCond :: CmmExpr -> CmmLint () checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values checkCond expr - = cmmLintErr (\platform -> hang (text "expression is not a conditional:") 2 - (pprPlatform platform expr)) + = cmmLintErr (hang (text "expression is not a conditional:") 2 + (ppr expr)) -- ----------------------------------------------------------------------------- -- CmmLint monad -- just a basic error monad: -newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a } +newtype CmmLint a = CmmLint { unCL :: Either SDoc a } instance Monad CmmLint where CmmLint m >>= k = CmmLint $ \p -> case m p of @@ -209,10 +200,10 @@ instance Monad CmmLint where Right a -> unCL (k a) p return a = CmmLint (\_ -> Right a) -cmmLintErr :: (Platform -> SDoc) -> CmmLint a +cmmLintErr :: SDoc -> CmmLint a cmmLintErr msg = CmmLint (\p -> Left (msg p)) -addLintInfo :: (Platform -> SDoc) -> CmmLint a -> CmmLint a +addLintInfo :: SDoc -> CmmLint a -> CmmLint a addLintInfo info thing = CmmLint $ \p -> case unCL thing p of Left err -> Left (hang (info p) 2 err) @@ -220,20 +211,20 @@ addLintInfo info thing = CmmLint $ \p -> cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a cmmLintMachOpErr expr argsRep opExpectsRep - = cmmLintErr (\platform -> text "in MachOp application: " $$ - nest 2 (pprPlatform platform expr) $$ - (text "op is expecting: " <+> ppr opExpectsRep) $$ - (text "arguments provide: " <+> ppr argsRep)) + = cmmLintErr (text "in MachOp application: " $$ + nest 2 (ppr expr) $$ + (text "op is expecting: " <+> ppr opExpectsRep) $$ + (text "arguments provide: " <+> ppr argsRep)) cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a cmmLintAssignErr stmt e_ty r_ty - = cmmLintErr (\platform -> text "in assignment: " $$ - nest 2 (vcat [pprPlatform platform stmt, - text "Reg ty:" <+> ppr r_ty, - text "Rhs ty:" <+> ppr e_ty])) + = cmmLintErr (text "in assignment: " $$ + nest 2 (vcat [ppr stmt, + text "Reg ty:" <+> ppr r_ty, + text "Rhs ty:" <+> ppr e_ty])) cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a cmmLintDubiousWordOffset expr - = cmmLintErr (\platform -> text "offset is not a multiple of words: " $$ - nest 2 (pprPlatform platform expr)) + = cmmLintErr (text "offset is not a multiple of words: " $$ + nest 2 (ppr expr)) diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 2effa3a45f..2bf8bc207e 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -439,9 +439,16 @@ data CallishMachOp | MO_F32_Log | MO_F32_Exp | MO_F32_Sqrt + + | MO_S_QuotRem Width + | MO_U_QuotRem Width + | MO_U_QuotRem2 Width + | MO_Add2 Width + | MO_U_Mul2 Width + | MO_WriteBarrier | MO_Touch -- Keep variables live (when using interior pointers) - + -- Note that these three MachOps all take 1 extra parameter than the -- standard C lib versions. The extra (last) parameter contains -- alignment of the pointers. Used for optimisation in backends. diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index d7df73f4c0..7c7ed393d9 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -20,6 +20,7 @@ import OldCmm import OldPprCmm import CmmNode (wrapRecExp) import CmmUtils +import DynFlags import StaticFlags import UniqFM @@ -61,7 +62,8 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = stmt m (CmmStore e1 e2) = expr (expr m e1) e2 stmt m (CmmCall c _ as _) = f (actuals m as) c where f m (CmmCallee e _) = expr m e - f m (CmmPrim _) = m + f m (CmmPrim _ Nothing) = m + f m (CmmPrim _ (Just stmts)) = foldl' stmt m stmts stmt m (CmmBranch b) = b:m stmt m (CmmCondBranch e b) = b:(expr m e) stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e @@ -146,42 +148,43 @@ countUses :: UserOfLocalRegs a => a -> UniqFM Int countUses a = foldRegsUsed (\m r -> addToUFM_C (+) m r 1) emptyUFM a where count m r = lookupWithDefaultUFM m (0::Int) r -cmmMiniInline :: Platform -> [CmmBasicBlock] -> [CmmBasicBlock] -cmmMiniInline platform blocks = map do_inline blocks +cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock] +cmmMiniInline dflags blocks = map do_inline blocks where do_inline (BasicBlock id stmts) - = BasicBlock id (cmmMiniInlineStmts platform (countUses blocks) stmts) + = BasicBlock id (cmmMiniInlineStmts dflags (countUses blocks) stmts) -cmmMiniInlineStmts :: Platform -> UniqFM Int -> [CmmStmt] -> [CmmStmt] -cmmMiniInlineStmts _ _ [] = [] -cmmMiniInlineStmts platform uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts) +cmmMiniInlineStmts :: DynFlags -> UniqFM Int -> [CmmStmt] -> [CmmStmt] +cmmMiniInlineStmts _ _ [] = [] +cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts) -- not used: just discard this assignment | 0 <- lookupWithDefaultUFM uses 0 u - = cmmMiniInlineStmts platform uses stmts + = cmmMiniInlineStmts uses stmts -- used (foldable to small thing): try to inline at all the use sites | Just n <- lookupUFM uses u, e <- wrapRecExp foldExp expr, isTiny e = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $ + ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $ case lookForInlineMany u e stmts of (m, stmts') - | n == m -> cmmMiniInlineStmts platform (delFromUFM uses u) stmts' + | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts' | otherwise -> - stmt : cmmMiniInlineStmts platform (adjustUFM (\x -> x - m) uses u) stmts' + stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts' -- used once (non-literal): try to inline at the use site | Just 1 <- lookupUFM uses u, Just stmts' <- lookForInline u expr stmts = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $ - cmmMiniInlineStmts platform uses stmts' + ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $ + cmmMiniInlineStmts dflags uses stmts' where isTiny (CmmLit _) = True isTiny (CmmReg (CmmGlobal _)) = True -- not CmmLocal: that might invalidate the usage analysis results isTiny _ = False + platform = targetPlatform dflags foldExp (CmmMachOp op args) = cmmMachOpFold platform op args foldExp e = e @@ -272,7 +275,7 @@ inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e inlineStmt u a (CmmCall target regs es ret) = CmmCall (infn target) regs es' ret where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv - infn (CmmPrim p) = CmmPrim p + infn (CmmPrim p mStmts) = CmmPrim p (fmap (map (inlineStmt u a)) mStmts) es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ] inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 5dab1dd68b..f46d49e022 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -897,13 +897,13 @@ primCall results_code name args_code vols safety case safety of CmmUnsafe -> code (emitForeignCall' PlayRisky results - (CmmPrim p) args vols NoC_SRT CmmMayReturn) + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) CmmSafe srt -> code (emitForeignCall' PlaySafe results - (CmmPrim p) args vols NoC_SRT CmmMayReturn) where + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where CmmInterruptible -> code (emitForeignCall' PlayInterruptible results - (CmmPrim p) args vols NoC_SRT CmmMayReturn) + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode doStore rep addr_code val_code @@ -1055,7 +1055,7 @@ parseCmmFile dflags filename = do -- in there we don't want. case unP cmmParse init_state of PFailed span err -> do - let msg = mkPlainErrMsg span err + let msg = mkPlainErrMsg dflags span err return ((emptyBag, unitBag msg), Nothing) POk pst code -> do st <- initC @@ -1064,7 +1064,7 @@ parseCmmFile dflags filename = do if (errorsFound dflags ms) then return (ms, Nothing) else do - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm) return (ms, Just cmm) where no_module = panic "parseCmmFile: no module" diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 8f9e824a0c..adc27ab1ff 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -1,6 +1,6 @@ -{-# OPTIONS_GHC -XNoMonoLocalBinds #-} +{-# LANGUAGE NoMonoLocalBinds #-} -- Norman likes local bindings --- If this module lives on I'd like to get rid of this flag in due course +-- If this module lives on I'd like to get rid of this extension in due course module CmmPipeline ( -- | Converts C-- with an implicit stack and native C-- calls into @@ -76,7 +76,7 @@ cmmPipeline hsc_env topSRT prog = let cmms :: CmmGroup cmms = reverse (concat tops) - dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms) + dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) return (topSRT, cmms) @@ -127,7 +127,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ------------- Split into separate procedures ------------ procPointMap <- {-# SCC "procPointAnalysis" #-} run $ procPointAnalysis procPoints g - dumpWith dflags ppr Opt_D_dump_cmmz_procmap "procpoint map" procPointMap + dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap gs <- {-# SCC "splitAtProcPoints" #-} run $ splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g) dumps Opt_D_dump_cmmz_split "Post splitting" gs @@ -135,7 +135,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ------------- More CAFs ------------------------------ let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform g let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo platform cafEnv) gs - mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return () + mbpprTrace "localCAFs" (ppr localCAFs) $ return () -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES gs <- {-# SCC "setInfoTableStackMap" #-} @@ -161,7 +161,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) dump = dumpGraph dflags dumps flag name - = mapM_ (dumpWith dflags (pprPlatform platform) flag name) + = mapM_ (dumpWith dflags flag name) -- Runs a required transformation/analysis run = runInfiniteFuelIO (hsc_OptFuel hsc_env) @@ -173,7 +173,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO () dumpGraph dflags flag name g = do when (dopt Opt_DoCmmLinting dflags) $ do_lint g - dumpWith dflags (pprPlatform (targetPlatform dflags)) flag name g + dumpWith dflags flag name g where do_lint g = case cmmLintGraph (targetPlatform dflags) g of Just err -> do { printDump err @@ -181,14 +181,14 @@ dumpGraph dflags flag name g = do } Nothing -> return () -dumpWith :: DynFlags -> (a -> SDoc) -> DynFlag -> String -> a -> IO () -dumpWith dflags pprFun flag txt g = do +dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO () +dumpWith dflags flag txt g = do -- ToDo: No easy way of say "dump all the cmmz, *and* split -- them into files." Also, -ddump-cmmz doesn't play nicely -- with -ddump-to-file, since the headers get omitted. - dumpIfSet_dyn dflags flag txt (pprFun g) + dumpIfSet_dyn dflags flag txt (ppr g) when (not (dopt flag dflags)) $ - dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g) + dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g) -- This probably belongs in CmmBuildInfoTables? -- We're just finishing the job here: once we know what CAFs are defined diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index a719eece3c..8dda51b9b7 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -175,7 +175,7 @@ extendPPSet platform g blocks procPoints = newPoint = listToMaybe newPoints ppSuccessor b = let nreached id = case mapLookup id env `orElse` - pprPanic "no ppt" (ppr id <+> pprPlatform platform b) of + pprPanic "no ppt" (ppr id <+> ppr b) of ProcPoint -> 1 ReachedBy ps -> setSize ps block_procpoints = nreached (entryLabel b) diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs new file mode 100644 index 0000000000..c7fedad05b --- /dev/null +++ b/compiler/cmm/CmmStackLayout.hs @@ -0,0 +1,591 @@ +{-# LANGUAGE GADTs, NoMonoLocalBinds #-} +-- Norman likes local bindings +-- If this module lives on I'd like to get rid of the NoMonoLocalBinds +-- extension in due course + +{-# OPTIONS -fno-warn-tabs #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and +-- detab the module (please do the detabbing in a separate patch). See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces +-- for details + +-- Todo: remove -fno-warn-warnings-deprecations +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#if __GLASGOW_HASKELL__ >= 703 +-- GHC 7.0.1 improved incomplete pattern warnings with GADTs +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +#endif + +module CmmStackLayout + ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs + , getSpEntryMap, layout, manifestSP, igraph, areaBuilder + , stubSlotsOnDeath ) -- to help crash early during debugging +where + +import Constants +import Prelude hiding (succ, zip, unzip, last) + +import BlockId +import Cmm +import CmmUtils +import CmmProcPoint +import Maybes +import MkGraph (stackStubExpr) +import Control.Monad +import OptimizationFuel +import Outputable +import SMRep (ByteOff) + +import Compiler.Hoopl + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map + +------------------------------------------------------------------------ +-- Stack Layout -- +------------------------------------------------------------------------ + +-- | Before we lay out the stack, we need to know something about the +-- liveness of the stack slots. In particular, to decide whether we can +-- reuse a stack location to hold multiple stack slots, we need to know +-- when each of the stack slots is used. +-- Although tempted to use something simpler, we really need a full interference +-- graph. Consider the following case: +-- case <...> of +-- 1 -> <spill x>; // y is dead out +-- 2 -> <spill y>; // x is dead out +-- 3 -> <spill x and y> +-- If we consider the arms in order and we use just the deadness information given by a +-- dataflow analysis, we might decide to allocate the stack slots for x and y +-- to the same stack location, which will lead to incorrect code in the third arm. +-- We won't make this mistake with an interference graph. + +-- First, the liveness analysis. +-- We represent a slot with an area, an offset into the area, and a width. +-- Tracking the live slots is a bit tricky because there may be loads and stores +-- into only a part of a stack slot (e.g. loading the low word of a 2-word long), +-- e.g. Slot A 0 8 overlaps with Slot A 4 4. +-- +-- The definition of a slot set is intended to reduce the number of overlap +-- checks we have to make. There's no reason to check for overlap between +-- slots in different areas, so we segregate the map by Area's. +-- We expect few slots in each Area, so we collect them in an unordered list. +-- To keep these lists short, any contiguous live slots are coalesced into +-- a single slot, on insertion. + +slotLattice :: DataflowLattice SubAreaSet +slotLattice = DataflowLattice "live slots" Map.empty add + where add _ (OldFact old) (NewFact new) = case Map.foldRightWithKey addArea (False, old) new of + (change, x) -> (changeIf change, x) + addArea a newSlots z = foldr (addSlot a) z newSlots + addSlot a slot (changed, map) = + let (c, live) = liveGen slot $ Map.findWithDefault [] a map + in (c || changed, Map.insert a live map) + +slotLatticeJoin :: [SubAreaSet] -> SubAreaSet +slotLatticeJoin facts = foldr extend (fact_bot slotLattice) facts + where extend fact res = snd $ fact_join slotLattice undefined (OldFact fact) (NewFact res) + +type SlotEnv = BlockEnv SubAreaSet + -- The sub-areas live on entry to the block + +liveSlotAnal :: CmmGraph -> FuelUniqSM SlotEnv +liveSlotAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd slotLattice liveSlotTransfers + +-- Add the subarea s to the subareas in the list-set (possibly coalescing it with +-- adjacent subareas), and also return whether s was a new addition. +liveGen :: SubArea -> [SubArea] -> (Bool, [SubArea]) +liveGen s set = liveGen' s set [] + where liveGen' s [] z = (True, s : z) + liveGen' s@(a, hi, w) (s'@(a', hi', w') : rst) z = + if a /= a' || hi < lo' || lo > hi' then -- no overlap + liveGen' s rst (s' : z) + else if s' `contains` s then -- old contains new + (False, set) + else -- overlap: coalesce the slots + let new_hi = max hi hi' + new_lo = min lo lo' + in liveGen' (a, new_hi, new_hi - new_lo) rst z + where lo = hi - w -- remember: areas grow down + lo' = hi' - w' + contains (a, hi, w) (a', hi', w') = + a == a' && hi >= hi' && hi - w <= hi' - w' + +liveKill :: SubArea -> [SubArea] -> [SubArea] +liveKill (a, hi, w) set = -- pprTrace "killing slots in area" (ppr a) $ + liveKill' set [] + where liveKill' [] z = z + liveKill' (s'@(a', hi', w') : rst) z = + if a /= a' || hi < lo' || lo > hi' then -- no overlap + liveKill' rst (s' : z) + else -- overlap: split the old slot + let z' = if hi' > hi then (a, hi', hi' - hi) : z else z + z'' = if lo > lo' then (a, lo, lo - lo') : z' else z' + in liveKill' rst z'' + where lo = hi - w -- remember: areas grow down + lo' = hi' - w' + +-- Note: the stack slots that hold variables returned on the stack are not +-- considered live in to the block -- we treat the first node as a definition site. +-- BEWARE?: Am I being a little careless here in failing to check for the +-- entry Id (which would use the CallArea Old). +liveSlotTransfers :: BwdTransfer CmmNode SubAreaSet +liveSlotTransfers = mkBTransfer3 frt mid lst + where frt :: CmmNode C O -> SubAreaSet -> SubAreaSet + frt (CmmEntry l) f = Map.delete (CallArea (Young l)) f + + mid :: CmmNode O O -> SubAreaSet -> SubAreaSet + mid n f = foldSlotsUsed addSlot (removeLiveSlotDefs f n) n + lst :: CmmNode O C -> FactBase SubAreaSet -> SubAreaSet + lst n f = liveInSlots n $ case n of + CmmCall {cml_cont=Nothing, cml_args=args} -> add_area (CallArea Old) args out + CmmCall {cml_cont=Just k, cml_args=args} -> add_area (CallArea Old) args (add_area (CallArea (Young k)) args out) + CmmForeignCall {succ=k, updfr=oldend} -> add_area (CallArea Old) oldend (add_area (CallArea (Young k)) wORD_SIZE out) + _ -> out + where out = joinOutFacts slotLattice n f + add_area _ n live | n == 0 = live + add_area a n live = Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live + +-- Slot sets: adding slots, removing slots, and checking for membership. +liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet +addSlot, removeSlot :: SubAreaSet -> SubArea -> SubAreaSet +elemSlot :: SubAreaSet -> SubArea -> Bool +liftToArea a f map = Map.insert a (f (Map.findWithDefault [] a map)) map +addSlot live (a, i, w) = liftToArea a (snd . liveGen (a, i, w)) live +removeSlot live (a, i, w) = liftToArea a (liveKill (a, i, w)) live +elemSlot live (a, i, w) = + not $ fst $ liveGen (a, i, w) (Map.findWithDefault [] a live) + +removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet +removeLiveSlotDefs = foldSlotsDefd removeSlot + +liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => s -> SubAreaSet -> SubAreaSet +liveInSlots x live = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x + +liveLastIn :: CmmNode O C -> (BlockId -> SubAreaSet) -> SubAreaSet +liveLastIn l env = liveInSlots l (liveLastOut env l) + +-- Don't forget to keep the outgoing parameters in the CallArea live, +-- as well as the update frame. +-- Note: We have to keep the update frame live at a call because of the +-- case where the function doesn't return -- in that case, there won't +-- be a return to keep the update frame live. We'd still better keep the +-- info pointer in the update frame live at any call site; +-- otherwise we could screw up the garbage collector. +liveLastOut :: (BlockId -> SubAreaSet) -> CmmNode O C -> SubAreaSet +liveLastOut env l = + case l of + CmmCall _ Nothing n _ _ -> + add_area (CallArea Old) n out -- add outgoing args (includes upd frame) + CmmCall _ (Just k) n _ _ -> + add_area (CallArea Old) n (add_area (CallArea (Young k)) n out) + CmmForeignCall { succ = k, updfr = oldend } -> + add_area (CallArea Old) oldend (add_area (CallArea (Young k)) wORD_SIZE out) + _ -> out + where out = slotLatticeJoin $ map env $ successors l + add_area _ n live | n == 0 = live + add_area a n live = + Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live + +-- The liveness analysis must be precise: otherwise, we won't know if a definition +-- should really kill a live-out stack slot. +-- But the interference graph does not have to be precise -- it might decide that +-- any live areas interfere. To maintain both a precise analysis and an imprecise +-- interference graph, we need to convert the live-out stack slots to graph nodes +-- at each and every instruction; rather than reconstruct a new list of nodes +-- every time, I provide a function to fold over the nodes, which should be a +-- reasonably efficient approach for the implementations we envision. +-- Of course, it will probably be much easier to program if we just return a list... +type Set x = Map x () +data IGraphBuilder n = + Builder { foldNodes :: forall z. SubArea -> (n -> z -> z) -> z -> z + , _wordsOccupied :: AreaSizeMap -> AreaMap -> n -> [Int] + } + +areaBuilder :: IGraphBuilder Area +areaBuilder = Builder fold words + where fold (a, _, _) f z = f a z + words areaSize areaMap a = + case Map.lookup a areaMap of + Just addr -> [addr .. addr + (Map.lookup a areaSize `orElse` + pprPanic "wordsOccupied: unknown area" (ppr areaSize <+> ppr a))] + Nothing -> [] + +--slotBuilder :: IGraphBuilder (Area, Int) +--slotBuilder = undefined + +-- Now, we can build the interference graph. +-- The usual story: a definition interferes with all live outs and all other +-- definitions. +type IGraph x = Map x (Set x) +type IGPair x = (IGraph x, IGraphBuilder x) +igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> CmmGraph -> IGraph x +igraph builder env g = foldr interfere Map.empty (postorderDfs g) + where foldN = foldNodes builder + interfere block igraph = foldBlockNodesB3 (first, middle, last) block igraph + where first _ (igraph, _) = igraph + middle node (igraph, liveOut) = + (addEdges igraph node liveOut, liveInSlots node liveOut) + last node igraph = + (addEdges igraph node $ liveLastOut env' node, liveLastIn node env') + + -- add edges between a def and the other defs and liveouts + addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i + addDef (igraph, out) def@(a, _, _) = + (foldN def (addDefN out) igraph, + Map.insert a (snd $ liveGen def (Map.findWithDefault [] a out)) out) + addDefN out n igraph = + let addEdgeNO o igraph = foldN o addEdgeNN igraph + addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph + addEdgeNN' n n' igraph = Map.insert n (Map.insert n' () set) igraph + where set = Map.findWithDefault Map.empty n igraph + in Map.foldRightWithKey (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out + env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph" + +-- Before allocating stack slots, we need to collect one more piece of information: +-- what's the highest offset (in bytes) used in each Area? +-- We'll need to allocate that much space for each Area. + +-- Mapping of areas to area sizes (not offsets!) +type AreaSizeMap = AreaMap + +-- JD: WHY CAN'T THIS COME FROM THE slot-liveness info? +getAreaSize :: ByteOff -> CmmGraph -> AreaSizeMap + -- The domain of the returned mapping consists only of Areas + -- used for (a) variable spill slots, and (b) parameter passing areas for calls +getAreaSize entry_off g = + foldGraphBlocks (foldBlockNodesF3 (first, add_regslots, last)) + (Map.singleton (CallArea Old) entry_off) g + where first _ z = z + last :: CmmNode O C -> Map Area Int -> Map Area Int + last l@(CmmCall _ Nothing args res _) z = add_regslots l (add (add z area args) area res) + where area = CallArea Old + last l@(CmmCall _ (Just k) args res _) z = add_regslots l (add (add z area args) area res) + where area = CallArea (Young k) + last l@(CmmForeignCall {succ = k}) z = add_regslots l (add z area wORD_SIZE) + where area = CallArea (Young k) + last l z = add_regslots l z + add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i + addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) = + add z a $ widthInBytes $ typeWidth ty + addSlot z _ = z + add z a off = Map.insert a (max off (Map.findWithDefault 0 a z)) z + -- The 'max' is important. Two calls, to f and g, might share a common + -- continuation (and hence a common CallArea), but their number of overflow + -- parameters might differ. + -- EZY: Ought to use insert with combining function... + + +-- Find the Stack slots occupied by the subarea's conflicts +conflictSlots :: Ord x => IGPair x -> AreaSizeMap -> AreaMap -> SubArea -> Set Int +conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea = + foldNodes subarea foldNode Map.empty + where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig + conflict n' () set = liveInSlots areaMap n' set + -- Add stack slots occupied by igraph node n + liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n) + setAdd w s = Map.insert w () s + +-- Find any open space for 'area' on the stack, starting from the +-- 'offset'. If the area is a CallArea or a spill slot for a pointer, +-- then it must be word-aligned. +freeSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> Int +freeSlotFrom ig areaSize offset areaMap area = + let size = Map.lookup area areaSize `orElse` 0 + conflicts = conflictSlots ig areaSize areaMap (area, size, size) + -- CallAreas and Ptrs need to be word-aligned (round up!) + align = case area of CallArea _ -> align' + RegSlot r | isGcPtrType (localRegType r) -> align' + RegSlot _ -> id + align' n = (n + (wORD_SIZE - 1)) `div` wORD_SIZE * wORD_SIZE + -- Find a space big enough to hold the area + findSpace curr 0 = curr + findSpace curr cnt = -- part of target slot, # of bytes left to check + if Map.member curr conflicts then + findSpace (align (curr + size)) size -- try the next (possibly) open space + else findSpace (curr - 1) (cnt - 1) + in findSpace (align (offset + size)) size + +-- Find an open space on the stack, and assign it to the area. +allocSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> AreaMap +allocSlotFrom ig areaSize from areaMap area = + if Map.member area areaMap then areaMap + else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap + +-- Figure out all of the offsets from the slot location; this will be +-- non-zero for procpoints. +type SpEntryMap = BlockEnv Int +getSpEntryMap :: Int -> CmmGraph -> SpEntryMap +getSpEntryMap entry_off g@(CmmGraph {g_entry = entry}) + = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g + where add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int + add_sp_off b env = + case lastNode b of + CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env + CmmForeignCall {succ=succ} -> mapInsert succ wORD_SIZE env + _ -> env + +-- | Greedy stack layout. +-- Compute liveness, build the interference graph, and allocate slots for the areas. +-- We visit each basic block in a (generally) forward order. + +-- At each instruction that names a register subarea r, we immediately allocate +-- any available slot on the stack by the following procedure: +-- 1. Find the sub-areas S that conflict with r +-- 2. Find the stack slots used for S +-- 3. Choose a contiguous stack space s not in S (s must be large enough to hold r) + +-- For a CallArea, we allocate the stack space only when we reach a function +-- call that returns to the CallArea's blockId. +-- Then, we allocate the Area subject to the following constraints: +-- a) It must be younger than all the sub-areas that are live on entry to the block +-- This constraint is only necessary for the successor of a call +-- b) It must not overlap with any already-allocated Area with which it conflicts +-- (ie at some point, not necessarily now, is live at the same time) +-- Part (b) is just the 1,2,3 part above + +-- Note: The stack pointer only has to be younger than the youngest live stack slot +-- at proc points. Otherwise, the stack pointer can point anywhere. + +layout :: ProcPointSet -> SpEntryMap -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap +-- The domain of the returned map includes an Area for EVERY block +-- including each block that is not the successor of a call (ie is not a proc-point) +-- That's how we return the info of what the SP should be at the entry of every non +-- procpoint block. However, note that procpoint blocks have their +-- /slot/ stored, which is not necessarily the value of the SP on entry +-- to the block (in fact, it probably isn't, due to argument passing). +-- See [Procpoint Sp offset] + +layout procPoints spEntryMap env entry_off g = + let ig = (igraph areaBuilder env g, areaBuilder) + env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph" + areaSize = getAreaSize entry_off g + + -- Find the youngest live stack slot that has already been allocated + youngest_live :: AreaMap -- Already allocated + -> SubAreaSet -- Sub-areas live here + -> ByteOff -- Offset of the youngest byte of any + -- already-allocated, live sub-area + youngest_live areaMap live = fold_subareas young_slot live 0 + where young_slot (a, o, _) z = case Map.lookup a areaMap of + Just top -> max z $ top + o + Nothing -> z + fold_subareas f m z = Map.foldRightWithKey (\_ s z -> foldr f z s) z m + + -- Allocate space for spill slots and call areas + allocVarSlot = allocSlotFrom ig areaSize 0 + + -- Update the successor's incoming SP. + setSuccSPs inSp bid areaMap = + case (Map.lookup area areaMap , mapLookup bid (toBlockMap g)) of + (Just _, _) -> areaMap -- succ already knows incoming SP + (Nothing, Just _) -> + if setMember bid procPoints then + let young = youngest_live areaMap $ env' bid + -- start = case returnOff stackInfo of Just b -> max b young + -- Nothing -> young + start = young -- maybe wrong, but I don't understand + -- why the preceding is necessary... + in allocSlotFrom ig areaSize start areaMap area + else Map.insert area inSp areaMap + (_, Nothing) -> panic "Block not found in cfg" + where area = CallArea (Young bid) + + layoutAreas areaMap block = foldBlockNodesF3 (flip const, allocMid, allocLast (entryLabel block)) block areaMap + allocMid m areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap m) m + allocLast bid l areaMap = + foldr (setSuccSPs inSp) areaMap' (successors l) + where inSp = slot + spOffset -- [Procpoint Sp offset] + -- If it's not in the map, we should use our previous + -- calculation unchanged. + spOffset = mapLookup bid spEntryMap `orElse` 0 + slot = expectJust "slot in" $ Map.lookup (CallArea (Young bid)) areaMap + areaMap' = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap l) l + alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a + alloc' areaMap _ = areaMap + + initMap = Map.insert (CallArea (Young (g_entry g))) 0 + . Map.insert (CallArea Old) 0 + $ Map.empty + + areaMap = foldl layoutAreas initMap (postorderDfs g) + in -- pprTrace "ProcPoints" (ppr procPoints) $ + -- pprTrace "Area SizeMap" (ppr areaSize) $ + -- pprTrace "Entry offset" (ppr entry_off) $ + -- pprTrace "Area Map" (ppr areaMap) $ + areaMap + +{- Note [Procpoint Sp offset] + +The calculation of inSp is a little tricky. (Un)fortunately, if you get +it wrong, you will get inefficient but correct code. You know you've +got it wrong if the generated stack pointer bounces up and down for no +good reason. + +Why can't we just set inSp to the location of the slot? (This is what +the code used to do.) The trouble is when we actually hit the proc +point the start of the slot will not be the same as the actual Sp due +to argument passing: + + a: + I32[(young<b> + 4)] = cde; + // Stack pointer is moved to young end (bottom) of young<b> for call + // +-------+ + // | arg 1 | + // +-------+ <- Sp + call (I32[foobar::I32])(...) returns to Just b (4) (4) with update frame 4; + b: + // After call, stack pointer is above the old end (top) of + // young<b> (the difference is spOffset) + // +-------+ <- Sp + // | arg 1 | + // +-------+ + +If we blithely set the Sp to be the same as the slot (the young end of +young<b>), an adjustment will be necessary when we go to the next block. +This is wasteful. So, instead, for the next block after a procpoint, +the actual Sp should be set to the same as the true Sp when we just +entered the procpoint. Then manifestSP will automatically do the right +thing. + +Questions you may ask: + +1. Why don't we need to change the mapping for the procpoint itself? + Because manifestSP does its own calculation of the true stack value, + manifestSP will notice the discrepancy between the actual stack + pointer and the slot start, and adjust all of its memory accesses + accordingly. So the only problem is when we adjust the Sp in + preparation for the successor block; that's why this code is here and + not in setSuccSPs. + +2. Why don't we make the procpoint call area and the true offset match + up? If we did that, we would never use memory above the true value + of the stack pointer, thus wasting all of the stack we used to store + arguments. You might think that some clever changes to the slot + offsets, using negative offsets, might fix it, but this does not make + semantic sense. + +3. If manifestSP is already calculating the true stack value, why we can't + do this trick inside manifestSP itself? The reason is that if two + branches join with inconsistent SPs, one of them has to be fixed: we + can't know what the fix should be without already knowing what the + chosen location of SP is on the next successor. (This is + the "succ already knows incoming SP" case), This calculation cannot + be easily done in manifestSP, since it processes the nodes + /backwards/. So we need to have figured this out before we hit + manifestSP. +-} + +-- After determining the stack layout, we can: +-- 1. Replace references to stack Areas with addresses relative to the stack +-- pointer. +-- 2. Insert adjustments to the stack pointer to ensure that it is at a +-- conventional location at each proc point. +-- Because we don't take interrupts on the execution stack, we only need the +-- stack pointer to be younger than the live values on the stack at proc points. +-- 3. Compute the maximum stack offset used in the procedure and replace +-- the stack high-water mark with that offset. +manifestSP :: SpEntryMap -> AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph +manifestSP spEntryMap areaMap entry_off g@(CmmGraph {g_entry=entry}) = + ofBlockMap entry `liftM` foldl replB (return mapEmpty) (postorderDfs g) + where slot a = -- pprTrace "slot" (ppr a) $ + Map.lookup a areaMap `orElse` panic "unallocated Area" + slot' (Just id) = slot $ CallArea (Young id) + slot' Nothing = slot $ CallArea Old + sp_high = maxSlot slot g + proc_entry_sp = slot (CallArea Old) + entry_off + + spOffset id = mapLookup id spEntryMap `orElse` 0 + + sp_on_entry id | id == entry = proc_entry_sp + sp_on_entry id = slot' (Just id) + spOffset id + + -- On entry to procpoints, the stack pointer is conventional; + -- otherwise, we check the SP set by predecessors. + replB :: FuelUniqSM (BlockEnv CmmBlock) -> CmmBlock -> FuelUniqSM (BlockEnv CmmBlock) + replB blocks block = + do let (head, middles, JustC tail :: MaybeC C (CmmNode O C)) = blockToNodeList block + middles' = map (middle spIn) middles + bs <- replLast head middles' tail + flip (foldr insertBlock) bs `liftM` blocks + where spIn = sp_on_entry (entryLabel block) + + middle spOff m = mapExpDeep (replSlot spOff) m + -- XXX there shouldn't be any global registers in the + -- CmmCall, so there shouldn't be any slots in + -- CmmCall... check that... + last spOff l = mapExpDeep (replSlot spOff) l + replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i)) + replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark + CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord)) + -- Invariant: Sp is always greater than SpLim. Thus, if + -- the high water mark is zero, we can optimize away the + -- conditional branch. Relies on dead code elimination + -- to get rid of the dead GC blocks. + -- EZY: Maybe turn this into a guard that checks if a + -- statement is stack-check ish? Maybe we should make + -- an actual mach-op for it, so there's no chance of + -- mixing this up with something else... + replSlot _ (CmmMachOp (MO_U_Lt _) + [CmmMachOp (MO_Sub _) + [ CmmReg (CmmGlobal Sp) + , CmmLit (CmmInt 0 _)], + CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth) + replSlot _ e = e + + replLast :: MaybeC C (CmmNode C O) -> [CmmNode O O] -> CmmNode O C -> FuelUniqSM [CmmBlock] + replLast h m l@(CmmCall _ k n _ _) = updSp (slot' k + n) h m l + -- JD: LastForeignCall probably ought to have an outgoing + -- arg size, just like LastCall + replLast h m l@(CmmForeignCall {succ=k}) = updSp (slot' (Just k) + wORD_SIZE) h m l + replLast h m l@(CmmBranch k) = updSp (sp_on_entry k) h m l + replLast h m l = uncurry (:) `liftM` foldr succ (return (b, [])) (successors l) + where b :: CmmBlock + b = updSp' spIn h m l + succ succId z = + let succSp = sp_on_entry succId in + if succSp /= spIn then + do (b, bs) <- z + (b', bs') <- insertBetween b (adjustSp succSp) succId + return (b', bs' ++ bs) + else z + + updSp sp h m l = return [updSp' sp h m l] + updSp' sp h m l | sp == spIn = blockOfNodeList (h, m, JustC $ last sp l) + | otherwise = blockOfNodeList (h, m ++ adjustSp sp, JustC $ last sp l) + adjustSp sp = [CmmAssign (CmmGlobal Sp) e] + where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off] + off = CmmLit $ CmmInt (toInteger $ spIn - sp) wordWidth + + +-- To compute the stack high-water mark, we fold over the graph and +-- compute the highest slot offset. +maxSlot :: (Area -> Int) -> CmmGraph -> Int +maxSlot slotOff g = foldGraphBlocks (foldBlockNodesF3 (flip const, highSlot, highSlot)) 0 g + where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i + add z (a, i, _) = max z (slotOff a + i) + +----------------------------------------------------------------------------- +-- | Sanity check: stub pointers immediately after they die +----------------------------------------------------------------------------- +-- This will miss stack slots that are last used in a Last node, +-- but it should do pretty well... + +stubSlotsOnDeath :: CmmGraph -> FuelUniqSM CmmGraph +stubSlotsOnDeath g = liftM fst $ dataflowPassBwd g [] $ analRewBwd slotLattice + liveSlotTransfers + rewrites + where rewrites = mkBRewrite3 frt mid lst + frt _ _ = return Nothing + mid m liveSlots = return $ foldSlotsUsed (stub liveSlots m) Nothing m + lst _ _ = return Nothing + stub liveSlots m rst subarea@(a, off, w) = + if elemSlot liveSlots subarea then rst + else let store = mkMiddle $ CmmStore (CmmStackSlot a off) + (stackStubExpr (widthFromBytes w)) + in case rst of Nothing -> Just (mkMiddle m <*> store) + Just g -> Just (g <*> store) diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index 27277540fe..59455d3b54 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -10,6 +10,7 @@ module CmmType , Width(..) , widthInBits, widthInBytes, widthInLog, widthFromBytes , wordWidth, halfWordWidth, cIntWidth, cLongWidth + , halfWordMask , narrowU, narrowS ) where @@ -163,6 +164,11 @@ halfWordWidth | wORD_SIZE == 4 = W16 | wORD_SIZE == 8 = W32 | otherwise = panic "MachOp.halfWordRep: Unknown word size" +halfWordMask :: Integer +halfWordMask | wORD_SIZE == 4 = 0xFFFF + | wORD_SIZE == 8 = 0xFFFFFFFF + | otherwise = panic "MachOp.halfWordMask: Unknown word size" + -- cIntRep is the Width for a C-language 'int' cIntWidth, cLongWidth :: Width #if SIZEOF_INT == 4 diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 8814fc4b3e..d831a8aba5 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -73,7 +73,7 @@ module CmmUtils( #include "HsVersions.h" import TyCon ( PrimRep(..) ) -import Type ( Type, typePrimRep ) +import Type ( UnaryType, typePrimRep ) import SMRep import Cmm @@ -84,6 +84,7 @@ import OptimizationFuel as F import Unique import UniqSupply import Constants( wORD_SIZE, tAG_MASK ) +import Util import Data.Word import Data.Maybe @@ -108,7 +109,7 @@ primRepCmmType AddrRep = bWord primRepCmmType FloatRep = f32 primRepCmmType DoubleRep = f64 -typeCmmType :: Type -> CmmType +typeCmmType :: UnaryType -> CmmType typeCmmType ty = primRepCmmType (typePrimRep ty) primRepForeignHint :: PrimRep -> ForeignHint @@ -122,7 +123,7 @@ primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg primRepForeignHint FloatRep = NoHint primRepForeignHint DoubleRep = NoHint -typeForeignHint :: Type -> ForeignHint +typeForeignHint :: UnaryType -> ForeignHint typeForeignHint = primRepForeignHint . typePrimRep --------------------------------------------------- diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index 6c1031b369..00bbe6d2ee 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -213,8 +213,8 @@ instance UserOfLocalRegs CmmStmt where gen a set = foldRegsUsed f set a instance UserOfLocalRegs CmmCallTarget where - foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e - foldRegsUsed _ set (CmmPrim {}) = set + foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e + foldRegsUsed f set (CmmPrim _ mStmts) = foldRegsUsed f set mStmts instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a) @@ -277,5 +277,8 @@ data CmmCallTarget | CmmPrim -- Call a "primitive" (eg. sin, cos) CallishMachOp -- These might be implemented as inline -- code by the backend. - deriving Eq + -- If we don't know how to implement the + -- mach op, then we can replace it with + -- this list of statements: + (Maybe [CmmStmt]) diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs index cc7e2cd8d6..72e40ce4f8 100644 --- a/compiler/cmm/OldCmmLint.hs +++ b/compiler/cmm/OldCmmLint.hs @@ -31,22 +31,22 @@ import Data.Maybe -- ----------------------------------------------------------------------------- -- Exported entry points: -cmmLint :: (PlatformOutputable d, PlatformOutputable h) +cmmLint :: (Outputable d, Outputable h) => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops -cmmLintTop :: (PlatformOutputable d, PlatformOutputable h) +cmmLintTop :: (Outputable d, Outputable h) => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top -runCmmLint :: PlatformOutputable a +runCmmLint :: Outputable a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint platform l p = +runCmmLint _ l p = case unCL (l p) of Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), nest 2 err, ptext $ sLit ("Program was:"), - nest 2 (pprPlatform platform p)]) + nest 2 (ppr p)]) Right _ -> Nothing lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () @@ -81,7 +81,7 @@ lintCmmExpr platform expr@(CmmMachOp op args) = do tys <- mapM (lintCmmExpr platform) args if map (typeWidth . cmmExprType) args == machOpArgReps op then cmmCheckMachOp op args tys - else cmmLintMachOpErr platform expr (map cmmExprType args) (machOpArgReps op) + else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op) lintCmmExpr platform (CmmRegOff reg offset) = lintCmmExpr platform (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) @@ -103,14 +103,14 @@ isOffsetOp _ = False -- This expression should be an address from which a word can be loaded: -- check for funny-looking sub-word offsets. -_cmmCheckWordAddress :: Platform -> CmmExpr -> CmmLint () -_cmmCheckWordAddress platform e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) +_cmmCheckWordAddress :: CmmExpr -> CmmLint () +_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 - = cmmLintDubiousWordOffset platform e -_cmmCheckWordAddress platform e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) + = cmmLintDubiousWordOffset e +_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 - = cmmLintDubiousWordOffset platform e -_cmmCheckWordAddress _ _ + = cmmLintDubiousWordOffset e +_cmmCheckWordAddress _ = return () -- No warnings for unaligned arithmetic with the node register, @@ -128,20 +128,21 @@ lintCmmStmt platform labels = lint let reg_ty = cmmRegType reg if (erep `cmmEqType_ignoring_ptrhood` reg_ty) then return () - else cmmLintAssignErr platform stmt erep reg_ty + else cmmLintAssignErr stmt erep reg_ty lint (CmmStore l r) = do _ <- lintCmmExpr platform l _ <- lintCmmExpr platform r return () lint (CmmCall target _res args _) = - lintTarget platform target >> mapM_ (lintCmmExpr platform . hintlessCmm) args - lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e + do lintTarget platform labels target + mapM_ (lintCmmExpr platform . hintlessCmm) args + lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond e lint (CmmSwitch e branches) = do mapM_ checkTarget $ catMaybes branches erep <- lintCmmExpr platform e if (erep `cmmEqType_ignoring_ptrhood` bWord) then return () - else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <> + else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <> text " :: " <> ppr erep) lint (CmmJump e _) = lintCmmExpr platform e >> return () lint (CmmReturn) = return () @@ -149,17 +150,20 @@ lintCmmStmt platform labels = lint checkTarget id = if setMember id labels then return () else cmmLintErr (text "Branch to nonexistent id" <+> ppr id) -lintTarget :: Platform -> CmmCallTarget -> CmmLint () -lintTarget platform (CmmCallee e _) = lintCmmExpr platform e >> return () -lintTarget _ (CmmPrim {}) = return () +lintTarget :: Platform -> BlockSet -> CmmCallTarget -> CmmLint () +lintTarget platform _ (CmmCallee e _) = do _ <- lintCmmExpr platform e + return () +lintTarget _ _ (CmmPrim _ Nothing) = return () +lintTarget platform labels (CmmPrim _ (Just stmts)) + = mapM_ (lintCmmStmt platform labels) stmts -checkCond :: Platform -> CmmExpr -> CmmLint () -checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond _ (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values -checkCond platform expr +checkCond :: CmmExpr -> CmmLint () +checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values +checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2 - (pprPlatform platform expr)) + (ppr expr)) -- ----------------------------------------------------------------------------- -- CmmLint monad @@ -183,23 +187,23 @@ addLintInfo info thing = CmmLint $ Left err -> Left (hang info 2 err) Right a -> Right a -cmmLintMachOpErr :: Platform -> CmmExpr -> [CmmType] -> [Width] -> CmmLint a -cmmLintMachOpErr platform expr argsRep opExpectsRep +cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a +cmmLintMachOpErr expr argsRep opExpectsRep = cmmLintErr (text "in MachOp application: " $$ - nest 2 (pprPlatform platform expr) $$ + nest 2 (ppr expr) $$ (text "op is expecting: " <+> ppr opExpectsRep) $$ (text "arguments provide: " <+> ppr argsRep)) -cmmLintAssignErr :: Platform -> CmmStmt -> CmmType -> CmmType -> CmmLint a -cmmLintAssignErr platform stmt e_ty r_ty +cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a +cmmLintAssignErr stmt e_ty r_ty = cmmLintErr (text "in assignment: " $$ - nest 2 (vcat [pprPlatform platform stmt, + nest 2 (vcat [ppr stmt, text "Reg ty:" <+> ppr r_ty, text "Rhs ty:" <+> ppr e_ty])) -cmmLintDubiousWordOffset :: Platform -> CmmExpr -> CmmLint a -cmmLintDubiousWordOffset platform expr +cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a +cmmLintDubiousWordOffset expr = cmmLintErr (text "offset is not a multiple of words: " $$ - nest 2 (pprPlatform platform expr)) + nest 2 (ppr expr)) diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs index 14a17d7946..0ec7a25f15 100644 --- a/compiler/cmm/OldCmmUtils.hs +++ b/compiler/cmm/OldCmmUtils.hs @@ -96,3 +96,4 @@ maybeAssignTemp uniques e | hasNoGlobalRegs e = (uniques, [], e) | otherwise = (tail uniques, [CmmAssign local e], CmmReg local) where local = CmmLocal (LocalReg (head uniques) (cmmExprType e)) + diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index d0fd0cb3e4..a30be9c6c7 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -48,42 +48,39 @@ import PprCmmExpr import BasicTypes import ForeignCall import Outputable -import Platform import FastString import Data.List ----------------------------------------------------------------------------- -instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where - pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks) +instance Outputable instr => Outputable (ListGraph instr) where + ppr (ListGraph blocks) = vcat (map ppr blocks) -instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where - pprPlatform platform b = pprBBlock platform b - -instance PlatformOutputable CmmStmt where - pprPlatform = pprStmt +instance Outputable instr => Outputable (GenBasicBlock instr) where + ppr = pprBBlock +instance Outputable CmmStmt where + ppr s = pprStmt s -- -------------------------------------------------------------------------- -instance PlatformOutputable CmmSafety where - pprPlatform _ CmmUnsafe = ptext (sLit "_unsafe_call_") - pprPlatform _ CmmInterruptible = ptext (sLit "_interruptible_call_") - pprPlatform platform (CmmSafe srt) = pprPlatform platform srt - +instance Outputable CmmSafety where + ppr CmmUnsafe = ptext (sLit "_unsafe_call_") + ppr CmmInterruptible = ptext (sLit "_interruptible_call_") + ppr (CmmSafe srt) = ppr srt -- -------------------------------------------------------------------------- -- Basic blocks look like assembly blocks. -- lbl: stmt ; stmt ; .. -pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc -pprBBlock platform (BasicBlock ident stmts) = - hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts)) +pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc +pprBBlock (BasicBlock ident stmts) = + hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) -- -------------------------------------------------------------------------- -- Statements. C-- usually, exceptions to this should be obvious. -- -pprStmt :: Platform -> CmmStmt -> SDoc -pprStmt platform stmt = case stmt of +pprStmt :: CmmStmt -> SDoc +pprStmt stmt = case stmt of -- ; CmmNop -> semi @@ -92,10 +89,10 @@ pprStmt platform stmt = case stmt of CmmComment s -> text "//" <+> ftext s -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi + CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform expr <> semi + CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi where rep = ppr ( cmmExprType expr ) @@ -103,7 +100,7 @@ pprStmt platform stmt = case stmt of -- ToDo ppr volatile CmmCall (CmmCallee fn cconv) results args ret -> sep [ pp_lhs <+> pp_conv - , nest 2 (pprExpr9 platform fn <> + , nest 2 (pprExpr9 fn <> parens (commafy (map ppr_ar args))) , case ret of CmmMayReturn -> empty CmmNeverReturns -> ptext $ sLit (" never returns") @@ -113,16 +110,15 @@ pprStmt platform stmt = case stmt of | otherwise = commafy (map ppr_ar results) <+> equals -- Don't print the hints on a native C-- call ppr_ar (CmmHinted ar k) = case cconv of - CmmCallConv -> pprPlatform platform ar - _ -> pprPlatform platform (ar,k) + CmmCallConv -> ppr ar + _ -> ppr (ar,k) pp_conv = case cconv of CmmCallConv -> empty _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) -- Call a CallishMachOp, like sin or cos that might be implemented as a library call. - CmmCall (CmmPrim op) results args ret -> - pprStmt platform (CmmCall (CmmCallee (CmmLit lbl) CCallConv) - results args ret) + CmmCall (CmmPrim op _) results args ret -> + pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args ret) where -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we -- use one to get the label printed. @@ -131,29 +127,27 @@ pprStmt platform stmt = case stmt of Nothing ForeignLabelInThisPackage IsFunction) CmmBranch ident -> genBranch ident - CmmCondBranch expr ident -> genCondBranch platform expr ident - CmmJump expr live -> genJump platform expr live - CmmReturn -> genReturn platform - CmmSwitch arg ids -> genSwitch platform arg ids + CmmCondBranch expr ident -> genCondBranch expr ident + CmmJump expr live -> genJump expr live + CmmReturn -> genReturn + CmmSwitch arg ids -> genSwitch arg ids -- Just look like a tuple, since it was a tuple before -- ... is that a good idea? --Isaac Dupree instance (Outputable a) => Outputable (CmmHinted a) where ppr (CmmHinted a k) = ppr (a, k) -instance (PlatformOutputable a) => PlatformOutputable (CmmHinted a) where - pprPlatform platform (CmmHinted a k) = pprPlatform platform (a, k) -pprUpdateFrame :: Platform -> UpdateFrame -> SDoc -pprUpdateFrame platform (UpdateFrame expr args) = +pprUpdateFrame :: UpdateFrame -> SDoc +pprUpdateFrame (UpdateFrame expr args) = hcat [ ptext (sLit "jump") , space , if isTrivialCmmExpr expr - then pprExpr platform expr + then pprExpr expr else case expr of - CmmLoad (CmmReg _) _ -> pprExpr platform expr - _ -> parens (pprExpr platform expr) + CmmLoad (CmmReg _) _ -> pprExpr expr + _ -> parens (pprExpr expr) , space - , parens ( commafy $ map (pprPlatform platform) args ) ] + , parens ( commafy $ map ppr args ) ] -- -------------------------------------------------------------------------- -- goto local label. [1], section 6.6 @@ -169,10 +163,10 @@ genBranch ident = -- -- if (expr) { goto lbl; } -- -genCondBranch :: Platform -> CmmExpr -> BlockId -> SDoc -genCondBranch platform expr ident = +genCondBranch :: CmmExpr -> BlockId -> SDoc +genCondBranch expr ident = hsep [ ptext (sLit "if") - , parens(pprPlatform platform expr) + , parens (ppr expr) , ptext (sLit "goto") , ppr ident <> semi ] @@ -181,15 +175,15 @@ genCondBranch platform expr ident = -- -- jump foo(a, b, c); -- -genJump :: Platform -> CmmExpr -> Maybe [GlobalReg] -> SDoc -genJump platform expr live = +genJump :: CmmExpr -> Maybe [GlobalReg] -> SDoc +genJump expr live = hcat [ ptext (sLit "jump") , space , if isTrivialCmmExpr expr - then pprExpr platform expr + then pprExpr expr else case expr of - CmmLoad (CmmReg _) _ -> pprExpr platform expr - _ -> parens (pprExpr platform expr) + CmmLoad (CmmReg _) _ -> pprExpr expr + _ -> parens (pprExpr expr) , semi <+> ptext (sLit "// ") , maybe empty ppr live] @@ -198,9 +192,8 @@ genJump platform expr live = -- -- return (a, b, c); -- -genReturn :: Platform -> SDoc -genReturn _ = - hcat [ ptext (sLit "return") , semi ] +genReturn :: SDoc +genReturn = hcat [ ptext (sLit "return") , semi ] -- -------------------------------------------------------------------------- -- Tabled jump to local label @@ -209,8 +202,8 @@ genReturn _ = -- -- switch [0 .. n] (expr) { case ... ; } -- -genSwitch :: Platform -> CmmExpr -> [Maybe BlockId] -> SDoc -genSwitch platform expr maybe_ids +genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc +genSwitch expr maybe_ids = let pairs = groupBy snds (zip [0 .. ] maybe_ids ) @@ -218,8 +211,8 @@ genSwitch platform expr maybe_ids , int (length maybe_ids - 1) , ptext (sLit "] ") , if isTrivialCmmExpr expr - then pprExpr platform expr - else parens (pprExpr platform expr) + then pprExpr expr + else parens (pprExpr expr) , ptext (sLit " {") ]) 4 (vcat ( map caseify pairs )) $$ rbrace diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index 70cfe92862..6e968c0b1d 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -20,6 +20,7 @@ import Control.Monad import StaticFlags (opt_Fuel) import UniqSupply import Panic +import Util import Compiler.Hoopl import Compiler.Hoopl.GHC (getFuel, setFuel) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 658e3ca5d8..bd7b35310c 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -71,7 +71,7 @@ pprCs dflags cmms writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO () writeCs dflags handle cmms - = printForC handle (pprCs dflags cmms) + = printForC dflags handle (pprCs dflags cmms) -- -------------------------------------------------------------------------- -- Now do some real work @@ -203,9 +203,6 @@ pprStmt platform stmt = case stmt of pprCFunType (pprCLabel platform lbl) cconv results args <> noreturn_attr <> semi - fun_proto lbl = ptext (sLit ";EF_(") <> - pprCLabel platform lbl <> char ')' <> semi - noreturn_attr = case ret of CmmNeverReturns -> text "__attribute__ ((noreturn))" CmmMayReturn -> empty @@ -226,31 +223,46 @@ pprStmt platform stmt = case stmt of let myCall = pprCall platform (pprCLabel platform lbl) cconv results args in (real_fun_proto lbl, myCall) | not (isMathFun lbl) -> - let myCall = braces ( - pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi - $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi - $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi - ) - in (fun_proto lbl, myCall) + pprForeignCall platform (pprCLabel platform lbl) cconv results args _ -> (empty {- no proto -}, pprCall platform cast_fn cconv results args <> semi) -- for a dynamic call, no declaration is necessary. - CmmCall (CmmPrim op) results args _ret -> - pprCall platform ppr_fn CCallConv results args' - where - ppr_fn = pprCallishMachOp_for_C op - -- The mem primops carry an extra alignment arg, must drop it. - -- We could maybe emit an alignment directive using this info. - args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = init args - | otherwise = args + CmmCall (CmmPrim _ (Just stmts)) _ _ _ -> + vcat $ map (pprStmt platform) stmts + + CmmCall (CmmPrim op _) results args _ret -> + proto $$ fn_call + where + cconv = CCallConv + fn = pprCallishMachOp_for_C op + (proto, fn_call) + -- The mem primops carry an extra alignment arg, must drop it. + -- We could maybe emit an alignment directive using this info. + -- We also need to cast mem primops to prevent conflicts with GCC + -- builtins (see bug #5967). + | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove] + = pprForeignCall platform fn cconv results (init args) + | otherwise + = (empty, pprCall platform fn cconv results args) CmmBranch ident -> pprBranch ident CmmCondBranch expr ident -> pprCondBranch platform expr ident CmmJump lbl _ -> mkJMP_(pprExpr platform lbl) <> semi CmmSwitch arg ids -> pprSwitch platform arg ids +pprForeignCall :: Platform -> SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> (SDoc, SDoc) +pprForeignCall platform fn cconv results args = (proto, fn_call) + where + fn_call = braces ( + pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi + $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi + $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi + ) + cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn) + proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi + pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc pprCFunType ppr_fn cconv ress args = res_type ress <+> @@ -658,7 +670,14 @@ pprCallishMachOp_for_C mop MO_Memmove -> ptext (sLit "memmove") (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) - MO_Touch -> panic $ "pprCallishMachOp_for_C: MO_Touch not supported!" + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_Touch -> unsupported + where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop + ++ " not supported!") -- --------------------------------------------------------------------- -- Useful #defines @@ -926,13 +945,19 @@ te_Lit _ = return () te_Stmt :: CmmStmt -> TE () te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r -te_Stmt (CmmCall _ rs es _) = mapM_ (te_temp.hintlessCmm) rs >> - mapM_ (te_Expr.hintlessCmm) es +te_Stmt (CmmCall target rs es _) = do te_Target target + mapM_ (te_temp.hintlessCmm) rs + mapM_ (te_Expr.hintlessCmm) es te_Stmt (CmmCondBranch e _) = te_Expr e te_Stmt (CmmSwitch e _) = te_Expr e te_Stmt (CmmJump e _) = te_Expr e te_Stmt _ = return () +te_Target :: CmmCallTarget -> TE () +te_Target (CmmCallee {}) = return () +te_Target (CmmPrim _ Nothing) = return () +te_Target (CmmPrim _ (Just stmts)) = mapM_ te_Stmt stmts + te_Expr :: CmmExpr -> TE () te_Expr (CmmLit lit) = te_Lit lit te_Expr (CmmLoad e _) = te_Expr e @@ -1092,10 +1117,11 @@ pprHexVal w rep -- times values are unsigned. This also helps eliminate occasional -- warnings about integer overflow from gcc. - -- on 32-bit platforms, add "ULL" to 64-bit literals - repsuffix W64 | wORD_SIZE == 4 = ptext (sLit "ULL") - -- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals - repsuffix W64 | cINT_SIZE == 4 = ptext (sLit "UL") + repsuffix W64 + | cINT_SIZE == 8 = char 'U' + | cLONG_SIZE == 8 = ptext (sLit "UL") + | cLONG_LONG_SIZE == 8 = ptext (sLit "ULL") + | otherwise = panic "pprHexVal: Can't find a 64-bit type" repsuffix _ = char 'U' go 0 = empty diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 81c9b9ea93..dee6ee881e 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -48,7 +48,6 @@ import PprCmmExpr import Util import BasicTypes -import Platform import Compiler.Hoopl import Data.List import Prelude hiding (succ) @@ -59,12 +58,12 @@ import Prelude hiding (succ) instance Outputable CmmStackInfo where ppr = pprStackInfo -instance PlatformOutputable CmmTopInfo where - pprPlatform = pprTopInfo +instance Outputable CmmTopInfo where + ppr = pprTopInfo -instance PlatformOutputable (CmmNode e x) where - pprPlatform = pprNode +instance Outputable (CmmNode e x) where + ppr = pprNode instance Outputable Convention where ppr = pprConvention @@ -72,24 +71,24 @@ instance Outputable Convention where instance Outputable ForeignConvention where ppr = pprForeignConvention -instance PlatformOutputable ForeignTarget where - pprPlatform = pprForeignTarget +instance Outputable ForeignTarget where + ppr = pprForeignTarget -instance PlatformOutputable (Block CmmNode C C) where - pprPlatform = pprBlock -instance PlatformOutputable (Block CmmNode C O) where - pprPlatform = pprBlock -instance PlatformOutputable (Block CmmNode O C) where - pprPlatform = pprBlock -instance PlatformOutputable (Block CmmNode O O) where - pprPlatform = pprBlock +instance Outputable (Block CmmNode C C) where + ppr = pprBlock +instance Outputable (Block CmmNode C O) where + ppr = pprBlock +instance Outputable (Block CmmNode O C) where + ppr = pprBlock +instance Outputable (Block CmmNode O O) where + ppr = pprBlock -instance PlatformOutputable (Graph CmmNode e x) where - pprPlatform = pprGraph +instance Outputable (Graph CmmNode e x) where + ppr = pprGraph -instance PlatformOutputable CmmGraph where - pprPlatform platform = pprCmmGraph platform +instance Outputable CmmGraph where + ppr = pprCmmGraph ---------------------------------------------------------- -- Outputting types Cmm contains @@ -99,40 +98,40 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = ptext (sLit "arg_space: ") <> ppr arg_space <+> ptext (sLit "updfr_space: ") <> ppr updfr_space -pprTopInfo :: Platform -> CmmTopInfo -> SDoc -pprTopInfo platform (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = - vcat [ptext (sLit "info_tbl: ") <> pprPlatform platform info_tbl, +pprTopInfo :: CmmTopInfo -> SDoc +pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = + vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl, ptext (sLit "stack_info: ") <> ppr stack_info] ---------------------------------------------------------- -- Outputting blocks and graphs pprBlock :: IndexedCO x SDoc SDoc ~ SDoc - => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc -pprBlock platform block - = foldBlockNodesB3 ( ($$) . pprPlatform platform - , ($$) . (nest 4) . pprPlatform platform - , ($$) . (nest 4) . pprPlatform platform + => Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock block + = foldBlockNodesB3 ( ($$) . ppr + , ($$) . (nest 4) . ppr + , ($$) . (nest 4) . ppr ) block empty -pprGraph :: Platform -> Graph CmmNode e x -> SDoc -pprGraph _ GNil = empty -pprGraph platform (GUnit block) = pprPlatform platform block -pprGraph platform (GMany entry body exit) +pprGraph :: Graph CmmNode e x -> SDoc +pprGraph GNil = empty +pprGraph (GUnit block) = ppr block +pprGraph (GMany entry body exit) = text "{" - $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit) + $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit) $$ text "}" - where pprMaybeO :: PlatformOutputable (Block CmmNode e x) + where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc pprMaybeO NothingO = empty - pprMaybeO (JustO block) = pprPlatform platform block + pprMaybeO (JustO block) = ppr block -pprCmmGraph :: Platform -> CmmGraph -> SDoc -pprCmmGraph platform g +pprCmmGraph :: CmmGraph -> SDoc +pprCmmGraph g = text "{" <> text "offset" - $$ nest 2 (vcat $ map (pprPlatform platform) blocks) + $$ nest 2 (vcat $ map ppr blocks) $$ text "}" where blocks = postorderDfs g @@ -151,25 +150,25 @@ pprConvention PrimOpReturn = text "<primop-ret-convention>" pprForeignConvention :: ForeignConvention -> SDoc pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs -pprForeignTarget :: Platform -> ForeignTarget -> SDoc -pprForeignTarget platform (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn +pprForeignTarget :: ForeignTarget -> SDoc +pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn where ppr_fc :: ForeignConvention -> SDoc ppr_fc (ForeignConvention c args res) = doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res ppr_target :: CmmExpr -> SDoc - ppr_target t@(CmmLit _) = pprPlatform platform t - ppr_target fn' = parens (pprPlatform platform fn') + ppr_target t@(CmmLit _) = ppr t + ppr_target fn' = parens (ppr fn') -pprForeignTarget platform (PrimTarget op) +pprForeignTarget (PrimTarget op) -- HACK: We're just using a ForeignLabel to get this printed, the label -- might not really be foreign. - = pprPlatform platform + = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing ForeignLabelInThisPackage IsFunction)) -pprNode :: Platform -> CmmNode e x -> SDoc -pprNode platform node = pp_node <+> pp_debug +pprNode :: CmmNode e x -> SDoc +pprNode node = pp_node <+> pp_debug where pp_node :: SDoc pp_node = case node of @@ -180,10 +179,10 @@ pprNode platform node = pp_node <+> pp_debug CmmComment s -> text "//" <+> ftext s -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi + CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform expr <> semi + CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi where rep = ppr ( cmmExprType expr ) @@ -193,7 +192,7 @@ pprNode platform node = pp_node <+> pp_debug hsep [ ppUnless (null results) $ parens (commafy $ map ppr results) <+> equals, ptext $ sLit "call", - pprPlatform platform target <> parens (commafy $ map (pprPlatform platform) args) <> semi] + ppr target <> parens (commafy $ map ppr args) <> semi] -- goto label; CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi @@ -201,7 +200,7 @@ pprNode platform node = pp_node <+> pp_debug -- if (expr) goto t; else goto f; CmmCondBranch expr t f -> hsep [ ptext (sLit "if") - , parens(pprPlatform platform expr) + , parens(ppr expr) , ptext (sLit "goto") , ppr t <> semi , ptext (sLit "else goto") @@ -213,8 +212,8 @@ pprNode platform node = pp_node <+> pp_debug , int (length maybe_ids - 1) , ptext (sLit "] ") , if isTrivialCmmExpr expr - then pprPlatform platform expr - else parens (pprPlatform platform expr) + then ppr expr + else parens (ppr expr) , ptext (sLit " {") ]) 4 (vcat ( map caseify pairs )) $$ rbrace @@ -235,15 +234,15 @@ pprNode platform node = pp_node <+> pp_debug <+> parens (ppr res) , ptext (sLit " with update frame") <+> ppr updfr_off , semi ] - where pprFun f@(CmmLit _) = pprPlatform platform f - pprFun f = parens (pprPlatform platform f) + where pprFun f@(CmmLit _) = ppr f + pprFun f = parens (ppr f) CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} -> hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++ [ ptext (sLit "foreign call"), space - , pprPlatform platform t, ptext (sLit "(...)"), space + , ppr t, ptext (sLit "(...)"), space , ptext (sLit "returns to") <+> ppr s - <+> ptext (sLit "args:") <+> parens (pprPlatform platform as) + <+> ptext (sLit "args:") <+> parens (ppr as) <+> ptext (sLit "ress:") <+> parens (ppr rs) , ptext (sLit " with update frame") <+> ppr u , semi ] diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 1143d9beff..fc1ae119a0 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -32,13 +32,6 @@ -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs -- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PprCmmDecl ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic ) @@ -48,6 +41,7 @@ import CLabel import PprCmmExpr import Cmm +import DynFlags import Outputable import Platform import FastString @@ -60,52 +54,50 @@ import SMRep #include "../includes/rts/storage/FunTypes.h" -pprCmms :: (PlatformOutputable info, PlatformOutputable g) - => Platform -> [GenCmmGroup CmmStatics info g] -> SDoc -pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pprPlatform platform) cmms)) +pprCmms :: (Outputable info, Outputable g) + => [GenCmmGroup CmmStatics info g] -> SDoc +pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where separator = space $$ ptext (sLit "-------------------") $$ space -writeCmms :: (PlatformOutputable info, PlatformOutputable g) - => Platform -> Handle -> [GenCmmGroup CmmStatics info g] -> IO () -writeCmms platform handle cmms = printForC handle (pprCmms platform cmms) +writeCmms :: (Outputable info, Outputable g) + => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO () +writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms) ----------------------------------------------------------------------------- -instance (PlatformOutputable d, PlatformOutputable info, PlatformOutputable i) - => PlatformOutputable (GenCmmDecl d info i) where - pprPlatform platform t = pprTop platform t +instance (Outputable d, Outputable info, Outputable i) + => Outputable (GenCmmDecl d info i) where + ppr t = pprTop t -instance PlatformOutputable CmmStatics where - pprPlatform = pprStatics +instance Outputable CmmStatics where + ppr x = sdocWithPlatform $ \platform -> pprStatics platform x -instance PlatformOutputable CmmStatic where - pprPlatform = pprStatic +instance Outputable CmmStatic where + ppr = pprStatic -instance PlatformOutputable CmmInfoTable where - pprPlatform = pprInfoTable +instance Outputable CmmInfoTable where + ppr = pprInfoTable ----------------------------------------------------------------------------- -pprCmmGroup :: (PlatformOutputable d, - PlatformOutputable info, - PlatformOutputable g) - => Platform -> GenCmmGroup d info g -> SDoc -pprCmmGroup platform tops - = vcat $ intersperse blankLine $ map (pprTop platform) tops +pprCmmGroup :: (Outputable d, Outputable info, Outputable g) + => GenCmmGroup d info g -> SDoc +pprCmmGroup tops + = vcat $ intersperse blankLine $ map pprTop tops -- -------------------------------------------------------------------------- -- Top level `procedure' blocks. -- -pprTop :: (PlatformOutputable d, PlatformOutputable info, PlatformOutputable i) - => Platform -> GenCmmDecl d info i -> SDoc +pprTop :: (Outputable d, Outputable info, Outputable i) + => GenCmmDecl d info i -> SDoc -pprTop platform (CmmProc info lbl graph) +pprTop (CmmProc info lbl graph) - = vcat [ pprCLabel platform lbl <> lparen <> rparen - , nest 8 $ lbrace <+> pprPlatform platform info $$ rbrace - , nest 4 $ pprPlatform platform graph + = vcat [ ppr lbl <> lparen <> rparen + , nest 8 $ lbrace <+> ppr info $$ rbrace + , nest 4 $ ppr graph , rbrace ] -- -------------------------------------------------------------------------- @@ -113,32 +105,30 @@ pprTop platform (CmmProc info lbl graph) -- -- section "data" { ... } -- -pprTop platform (CmmData section ds) = - (hang (pprSection section <+> lbrace) 4 (pprPlatform platform ds)) +pprTop (CmmData section ds) = + (hang (pprSection section <+> lbrace) 4 (ppr ds)) $$ rbrace -- -------------------------------------------------------------------------- -- Info tables. -pprInfoTable :: Platform -> CmmInfoTable -> SDoc -pprInfoTable _ CmmNonInfoTable +pprInfoTable :: CmmInfoTable -> SDoc +pprInfoTable CmmNonInfoTable = empty -pprInfoTable platform - (CmmInfoTable { cit_lbl = lbl, cit_rep = rep +pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep , cit_prof = prof_info - , cit_srt = _srt }) - = vcat [ ptext (sLit "label:") <+> pprPlatform platform lbl + , cit_srt = _srt }) + = vcat [ ptext (sLit "label:") <+> ppr lbl , ptext (sLit "rep:") <> ppr rep , case prof_info of - NoProfilingInfo -> empty + NoProfilingInfo -> empty ProfilingInfo ct cd -> vcat [ ptext (sLit "type:") <+> pprWord8String ct , ptext (sLit "desc: ") <> pprWord8String cd ] ] -instance PlatformOutputable C_SRT where - pprPlatform _ (NoC_SRT) = ptext (sLit "_no_srt_") - pprPlatform platform (C_SRT label off bitmap) - = parens (pprPlatform platform label <> comma <> ppr off - <> comma <> text (show bitmap)) +instance Outputable C_SRT where + ppr NoC_SRT = ptext (sLit "_no_srt_") + ppr (C_SRT label off bitmap) + = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap)) instance Outputable ForeignHint where ppr NoHint = empty @@ -146,8 +136,6 @@ instance Outputable ForeignHint where -- ppr AddrHint = quotes(text "address") -- Temp Jan08 ppr AddrHint = (text "PtrHint") -instance PlatformOutputable ForeignHint where - pprPlatform _ = ppr -- -------------------------------------------------------------------------- -- Static data. @@ -155,11 +143,12 @@ instance PlatformOutputable ForeignHint where -- following C-- -- pprStatics :: Platform -> CmmStatics -> SDoc -pprStatics platform (Statics lbl ds) = vcat ((pprCLabel platform lbl <> colon) : map (pprPlatform platform) ds) +pprStatics platform (Statics lbl ds) + = vcat ((pprCLabel platform lbl <> colon) : map ppr ds) -pprStatic :: Platform -> CmmStatic -> SDoc -pprStatic platform s = case s of - CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit platform lit <> semi +pprStatic :: CmmStatic -> SDoc +pprStatic s = case s of + CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs index 5c8a9cf5ce..119f2b7239 100644 --- a/compiler/cmm/PprCmmExpr.hs +++ b/compiler/cmm/PprCmmExpr.hs @@ -32,13 +32,6 @@ -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs -- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PprCmmExpr ( pprExpr, pprLit , pprExpr9 {-only to import in OldPprCmm. When it dies, remove the export -} @@ -46,10 +39,8 @@ module PprCmmExpr where import CmmExpr -import CLabel import Outputable -import Platform import FastString import Data.Maybe @@ -57,19 +48,17 @@ import Numeric ( fromRat ) ----------------------------------------------------------------------------- -instance PlatformOutputable CmmExpr where - pprPlatform = pprExpr +instance Outputable CmmExpr where + ppr e = pprExpr e instance Outputable CmmReg where ppr e = pprReg e -instance PlatformOutputable CmmLit where - pprPlatform = pprLit +instance Outputable CmmLit where + ppr l = pprLit l instance Outputable LocalReg where ppr e = pprLocalReg e -instance PlatformOutputable LocalReg where - pprPlatform _ = ppr instance Outputable Area where ppr e = pprArea e @@ -81,15 +70,15 @@ instance Outputable GlobalReg where -- Expressions -- -pprExpr :: Platform -> CmmExpr -> SDoc -pprExpr platform e +pprExpr :: CmmExpr -> SDoc +pprExpr e = case e of - CmmRegOff reg i -> - pprExpr platform (CmmMachOp (MO_Add rep) - [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) - where rep = typeWidth (cmmRegType reg) - CmmLit lit -> pprLit platform lit - _other -> pprExpr1 platform e + CmmRegOff reg i -> + pprExpr (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) + where rep = typeWidth (cmmRegType reg) + CmmLit lit -> pprLit lit + _other -> pprExpr1 e -- Here's the precedence table from CmmParse.y: -- %nonassoc '>=' '>' '<=' '<' '!=' '==' @@ -105,10 +94,10 @@ pprExpr platform e -- a default conservative behaviour. -- %nonassoc '>=' '>' '<=' '<' '!=' '==' -pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc -pprExpr1 platform (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op - = pprExpr7 platform x <+> doc <+> pprExpr7 platform y -pprExpr1 platform e = pprExpr7 platform e +pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc +pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op + = pprExpr7 x <+> doc <+> pprExpr7 y +pprExpr1 e = pprExpr7 e infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc @@ -123,55 +112,55 @@ infixMachOp1 (MO_U_Lt _) = Just (char '<') infixMachOp1 _ = Nothing -- %left '-' '+' -pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 - = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) -pprExpr7 platform (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op - = pprExpr7 platform x <+> doc <+> pprExpr8 platform y -pprExpr7 platform e = pprExpr8 platform e +pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 + = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) +pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op + = pprExpr7 x <+> doc <+> pprExpr8 y +pprExpr7 e = pprExpr8 e infixMachOp7 (MO_Add _) = Just (char '+') infixMachOp7 (MO_Sub _) = Just (char '-') infixMachOp7 _ = Nothing -- %left '/' '*' '%' -pprExpr8 platform (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op - = pprExpr8 platform x <+> doc <+> pprExpr9 platform y -pprExpr8 platform e = pprExpr9 platform e +pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op + = pprExpr8 x <+> doc <+> pprExpr9 y +pprExpr8 e = pprExpr9 e infixMachOp8 (MO_U_Quot _) = Just (char '/') infixMachOp8 (MO_Mul _) = Just (char '*') infixMachOp8 (MO_U_Rem _) = Just (char '%') infixMachOp8 _ = Nothing -pprExpr9 :: Platform -> CmmExpr -> SDoc -pprExpr9 platform e = +pprExpr9 :: CmmExpr -> SDoc +pprExpr9 e = case e of - CmmLit lit -> pprLit1 platform lit - CmmLoad expr rep -> ppr rep <> brackets (pprPlatform platform expr) + CmmLit lit -> pprLit1 lit + CmmLoad expr rep -> ppr rep <> brackets (ppr expr) CmmReg reg -> ppr reg CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) - CmmMachOp mop args -> genMachOp platform mop args + CmmMachOp mop args -> genMachOp mop args -genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc -genMachOp platform mop args +genMachOp :: MachOp -> [CmmExpr] -> SDoc +genMachOp mop args | Just doc <- infixMachOp mop = case args of -- dyadic - [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y + [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y -- unary - [x] -> doc <> pprExpr9 platform x + [x] -> doc <> pprExpr9 x _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args" (pprMachOp mop <+> - parens (hcat $ punctuate comma (map (pprExpr platform) args))) + parens (hcat $ punctuate comma (map pprExpr args))) empty | isJust (infixMachOp1 mop) || isJust (infixMachOp7 mop) - || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args)) + || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args)) - | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args)) + | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args)) where ppr_op = text (map (\c -> if c == ' ' then '_' else c) (show mop)) -- replace spaces in (show mop) with underscores, @@ -182,7 +171,7 @@ genMachOp platform mop args -- infixMachOp :: MachOp -> Maybe SDoc infixMachOp mop - = case mop of + = case mop of MO_And _ -> Just $ char '&' MO_Or _ -> Just $ char '|' MO_Xor _ -> Just $ char '^' @@ -195,24 +184,24 @@ infixMachOp mop -- To minimise line noise we adopt the convention that if the literal -- has the natural machine word size, we do not append the type -- -pprLit :: Platform -> CmmLit -> SDoc -pprLit platform lit = case lit of +pprLit :: CmmLit -> SDoc +pprLit lit = case lit of CmmInt i rep -> hcat [ (if i < 0 then parens else id)(integer i) , ppUnless (rep == wordWidth) $ space <> dcolon <+> ppr rep ] CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] - CmmLabel clbl -> pprCLabel platform clbl - CmmLabelOff clbl i -> pprCLabel platform clbl <> ppr_offset i - CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel platform clbl1 <> char '-' - <> pprCLabel platform clbl2 <> ppr_offset i + CmmLabel clbl -> ppr clbl + CmmLabelOff clbl i -> ppr clbl <> ppr_offset i + CmmLabelDiffOff clbl1 clbl2 i -> ppr clbl1 <> char '-' + <> ppr clbl2 <> ppr_offset i CmmBlock id -> ppr id CmmHighStackMark -> text "<highSp>" -pprLit1 :: Platform -> CmmLit -> SDoc -pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit) -pprLit1 platform lit = pprLit platform lit +pprLit1 :: CmmLit -> SDoc +pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit) +pprLit1 lit = pprLit lit ppr_offset :: Int -> SDoc ppr_offset i @@ -224,7 +213,7 @@ ppr_offset i -- Registers, whether local (temps) or global -- pprReg :: CmmReg -> SDoc -pprReg r +pprReg r = case r of CmmLocal local -> pprLocalReg local CmmGlobal global -> pprGlobalReg global @@ -233,17 +222,17 @@ pprReg r -- We only print the type of the local reg if it isn't wordRep -- pprLocalReg :: LocalReg -> SDoc -pprLocalReg (LocalReg uniq rep) +pprLocalReg (LocalReg uniq rep) -- = ppr rep <> char '_' <> ppr uniq -- Temp Jan08 - = char '_' <> ppr uniq <> - (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh + = char '_' <> ppr uniq <> + (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh then dcolon <> ptr <> ppr rep else dcolon <> ptr <> ppr rep) where ptr = empty - --if isGcPtrType rep - -- then doubleQuotes (text "ptr") + --if isGcPtrType rep + -- then doubleQuotes (text "ptr") -- else empty -- Stack areas @@ -254,7 +243,7 @@ pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] -- needs to be kept in syn with CmmExpr.hs.GlobalReg -- pprGlobalReg :: GlobalReg -> SDoc -pprGlobalReg gr +pprGlobalReg gr = case gr of VanillaReg n _ -> char 'R' <> int n -- Temp Jan08 diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 198e192f5c..0efc99d370 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -146,10 +146,10 @@ data StableLoc -- be saved, so it makes sense to treat treat them as -- having a stable location -instance PlatformOutputable CgIdInfo where - pprPlatform platform (CgIdInfo id _ vol stb _ _) +instance Outputable CgIdInfo where + ppr (CgIdInfo id _ vol stb _ _) -- TODO, pretty pring the tag info - = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, pprPlatform platform stb] + = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, ppr stb] instance Outputable VolatileLoc where ppr NoVolatileLoc = empty @@ -157,12 +157,12 @@ instance Outputable VolatileLoc where ppr (VirHpLoc v) = ptext (sLit "vh") <+> ppr v ppr (VirNodeLoc v) = ptext (sLit "vn") <+> ppr v -instance PlatformOutputable StableLoc where - pprPlatform _ NoStableLoc = empty - pprPlatform _ VoidLoc = ptext (sLit "void") - pprPlatform _ (VirStkLoc v) = ptext (sLit "vs") <+> ppr v - pprPlatform _ (VirStkLNE v) = ptext (sLit "lne") <+> ppr v - pprPlatform platform (StableLoc a) = ptext (sLit "amode") <+> pprPlatform platform a +instance Outputable StableLoc where + ppr NoStableLoc = empty + ppr VoidLoc = ptext (sLit "void") + ppr (VirStkLoc v) = ptext (sLit "vs") <+> ppr v + ppr (VirStkLNE v) = ptext (sLit "lne") <+> ppr v + ppr (StableLoc a) = ptext (sLit "amode") <+> ppr a \end{code} %************************************************************************ @@ -411,15 +411,12 @@ getArgAmode (StgLitArg lit) = do { cmm_lit <- cgLit lit ; return (typeCgRep (literalType lit), CmmLit cmm_lit) } -getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg" - getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)] getArgAmodes [] = returnFC [] getArgAmodes (atom:atoms) - | isStgTypeArg atom = getArgAmodes atoms - | otherwise = do { amode <- getArgAmode atom - ; amodes <- getArgAmodes atoms - ; return ( amode : amodes ) } + = do { amode <- getArgAmode atom + ; amodes <- getArgAmodes atoms + ; return ( amode : amodes ) } \end{code} %************************************************************************ diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index dd607de1fc..745bf47710 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -520,7 +520,6 @@ cgAlgAlts gc_flag cc_slot alt_type alts branches = [(dataConTagZ con, blks) | (DataAlt con, blks) <- alts] - -- in return (branches, mb_deflt) diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index d6537c27e5..8f98a5f764 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -81,7 +81,8 @@ cgTopRhsClosure id ccs binder_info upd_flag args body = do ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args ; srt_info <- getSRTInfo ; mod_name <- getModuleName - ; let descr = closureDescription mod_name name + ; dflags <- getDynFlags + ; let descr = closureDescription dflags mod_name name closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr closure_label = mkLocalClosureLabel name $ idCafInfo id cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info @@ -120,10 +121,11 @@ cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload { -- LAY OUT THE OBJECT amodes <- getArgAmodes payload ; mod_name <- getModuleName + ; dflags <- getDynFlags ; let (tot_wds, ptr_wds, amodes_w_offsets) = mkVirtHeapOffsets (isLFThunk lf_info) amodes - descr = closureDescription mod_name (idName bndr) + descr = closureDescription dflags mod_name (idName bndr) closure_info = mkClosureInfo False -- Not static bndr lf_info tot_wds ptr_wds NoC_SRT -- No SRT for a std-form closure @@ -169,13 +171,14 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do ; fv_infos <- mapFCs getCgIdInfo reduced_fvs ; srt_info <- getSRTInfo ; mod_name <- getModuleName + ; dflags <- getDynFlags ; let bind_details :: [(CgIdInfo, VirtualHpOffset)] (tot_wds, ptr_wds, bind_details) = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos) add_rep info = (cgIdInfoArgRep info, info) - descr = closureDescription mod_name name + descr = closureDescription dflags mod_name name closure_info = mkClosureInfo False -- Not static bndr lf_info tot_wds ptr_wds srt_info descr @@ -485,7 +488,7 @@ emitBlackHoleCode is_single_entry = do stmtsC [ CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO)), - CmmCall (CmmPrim MO_WriteBarrier) [] [] CmmMayReturn, + CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn, CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) ] \end{code} @@ -506,9 +509,10 @@ setupUpdate closure_info code else do tickyPushUpdateFrame dflags <- getDynFlags - if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags - then pushBHUpdateFrame (CmmReg nodeReg) code - else pushUpdateFrame (CmmReg nodeReg) code + if blackHoleOnEntry closure_info && + not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags + then pushBHUpdateFrame (CmmReg nodeReg) code + else pushUpdateFrame (CmmReg nodeReg) code | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -612,13 +616,14 @@ name of the data constructor itself. Otherwise it is determined by @closureDescription@ from the let binding information. \begin{code} -closureDescription :: Module -- Module - -> Name -- Id of closure binding - -> String +closureDescription :: DynFlags + -> Module -- Module + -> Name -- Id of closure binding + -> String -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.lhs with a description generated from the data constructor -closureDescription mod_name name - = showSDocDumpOneLine (char '<' <> +closureDescription dflags mod_name name + = showSDocDumpOneLine dflags (char '<' <> (if isExternalName name then ppr name -- ppr will include the module name prefix else pprModule mod_name <> char '.' <> ppr name) <> diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 9049504dca..aff5e468ca 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -72,13 +72,12 @@ cgTopRhsCon id con args ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. ASSERT( not (isDllConApp dflags con args) ) return () - ; ASSERT( args `lengthIs` dataConRepArity con ) return () + ; ASSERT( args `lengthIs` dataConRepRepArity con ) return () -- LAY IT OUT ; amodes <- getArgAmodes args ; let - platform = targetPlatform dflags name = idName id lf_info = mkConLFInfo con closure_label = mkClosureLabel name $ idCafInfo id @@ -92,7 +91,7 @@ cgTopRhsCon id con args payload = map get_lit amodes_w_offsets get_lit (CmmLit lit, _offset) = lit - get_lit other = pprPanic "CgCon.get_lit" (pprPlatform platform other) + get_lit other = pprPanic "CgCon.get_lit" (ppr other) -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs -- NB2: all the amodes should be Lits! @@ -324,7 +323,7 @@ cgReturnDataCon con amodes -- for it to be marked as "used" for LDV profiling. | opt_SccProfilingOn = build_it_then enter_it | otherwise - = ASSERT( amodes `lengthIs` dataConRepArity con ) + = ASSERT( amodes `lengthIs` dataConRepRepArity con ) do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo ; case sequel of CaseAlts _ (Just (alts, deflt_lbl)) bndr @@ -466,8 +465,8 @@ cgDataCon data_con ; ldvEnter (CmmReg nodeReg) ; body_code } - arg_reps :: [(CgRep, Type)] - arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con] + arg_reps :: [(CgRep, UnaryType)] + arg_reps = [(typeCgRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] body_code = do { -- NB: We don't set CC when entering data (WDP 94/06) diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index cb3a86ef7f..f935f95726 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -480,7 +480,7 @@ Little helper for primitives that return unboxed tuples. newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint]) newUnboxedTupleRegs res_ty = let - ty_args = tyConAppArgs (repType res_ty) + UbxTupleRep ty_args = repType res_ty (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args, let rep = typeCgRep ty, nonVoidArg rep ] diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 09636bc6b2..e957b90b20 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -59,7 +59,6 @@ cgForeignCall results fcall stg_args live arg_hints = zipWith CmmHinted arg_exprs (map (typeForeignHint.stgArgType) stg_args) - -- in emitForeignCall results fcall arg_hints live @@ -78,9 +77,11 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live where (call_args, cmm_target) = case target of + StaticTarget _ _ False -> + panic "emitForeignCall: unexpected FFI value import" -- If the packageId is Nothing then the label is taken to be in the -- package currently being compiled. - StaticTarget lbl mPkgId + StaticTarget lbl mPkgId True -> let labelSource = case mPkgId of Nothing -> ForeignLabelInThisPackage @@ -309,4 +310,5 @@ shimForeignCallArg arg expr | otherwise = expr where -- should be a tycon app, since this is a foreign call - tycon = tyConAppTyCon (repType (stgArgType arg)) + UnaryRep rep_ty = repType (stgArgType arg) + tycon = tyConAppTyCon rep_ty diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index f98d579e62..7cdb1b6f7e 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -45,7 +45,6 @@ import Unique import StaticFlags import Constants -import DynFlags import Util import Outputable @@ -150,8 +149,6 @@ is not present in the list (it is always assumed). -} mkStackLayout :: FCode [Maybe LocalReg] mkStackLayout = do - dflags <- getDynFlags - let platform = targetPlatform dflags StackUsage { realSp = real_sp, frameSp = frame_sp } <- getStkUsage binds <- getLiveStackBindings @@ -161,7 +158,7 @@ mkStackLayout = do | (offset, b) <- binds] WARN( not (all (\bind -> fst bind >= 0) rel_binds), - pprPlatform platform binds $$ pprPlatform platform rel_binds $$ + ppr binds $$ ppr rel_binds $$ ppr frame_size $$ ppr real_sp $$ ppr frame_sp ) return $ stack_layout rel_binds frame_size diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index dff54f3bf5..71da9e9ae0 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -77,6 +77,7 @@ import VarEnv import OrdList import Unique import UniqSupply +import Util import Outputable import Control.Monad diff --git a/compiler/codeGen/CgParallel.hs b/compiler/codeGen/CgParallel.hs index 2804104708..c86ef9e34a 100644 --- a/compiler/codeGen/CgParallel.hs +++ b/compiler/codeGen/CgParallel.hs @@ -3,78 +3,73 @@ -- (c) The University of Glasgow -2006 -- -- Code generation relaed to GpH --- (a) parallel --- (b) GranSim +-- (a) parallel +-- (b) GranSim -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module CgParallel( - staticGranHdr,staticParHdr, - granFetchAndReschedule, granYield, - doGranAllocate + staticGranHdr,staticParHdr, + granFetchAndReschedule, granYield, + doGranAllocate ) where import CgMonad import CgCallConv +import DynFlags import Id import OldCmm -import StaticFlags import Outputable import SMRep +import Control.Monad + staticParHdr :: [CmmLit] -- Parallel header words in a static closure staticParHdr = [] -------------------------------------------------------- --- GranSim stuff +-- GranSim stuff -------------------------------------------------------- staticGranHdr :: [CmmLit] -- Gransim header words in a static closure staticGranHdr = [] -doGranAllocate :: CmmExpr -> Code +doGranAllocate :: CmmExpr -> Code -- macro DO_GRAN_ALLOCATE doGranAllocate _hp - | not opt_GranMacros = nopC - | otherwise = panic "doGranAllocate" + = do dflags <- getDynFlags + when (dopt Opt_GranMacros dflags) $ panic "doGranAllocate" ------------------------- granFetchAndReschedule :: [(Id,GlobalReg)] -- Live registers - -> Bool -- Node reqd? - -> Code + -> Bool -- Node reqd? + -> Code -- Emit code for simulating a fetch and then reschedule. granFetchAndReschedule regs node_reqd - | opt_GranMacros && (node `elem` map snd regs || node_reqd) - = do { fetch - ; reschedule liveness node_reqd } - | otherwise - = nopC + = do dflags <- getDynFlags + when (dopt Opt_GranMacros dflags && + (node `elem` map snd regs || node_reqd)) $ + do fetch + reschedule liveness node_reqd where liveness = mkRegLiveness regs 0 0 fetch :: FCode () fetch = panic "granFetch" - -- Was: absC (CMacroStmt GRAN_FETCH []) - --HWL: generate GRAN_FETCH macro for GrAnSim - -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai + -- Was: absC (CMacroStmt GRAN_FETCH []) + --HWL: generate GRAN_FETCH macro for GrAnSim + -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai reschedule :: StgWord -> Bool -> Code reschedule _liveness _node_reqd = panic "granReschedule" - -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ - -- mkIntCLit (I# (word2Int# liveness_mask)), - -- mkIntCLit (if node_reqd then 1 else 0)]) - + -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ + -- mkIntCLit (I# (word2Int# liveness_mask)), + -- mkIntCLit (if node_reqd then 1 else 0)]) + ------------------------- -- The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It @@ -82,26 +77,26 @@ reschedule _liveness _node_reqd = panic "granReschedule" -- @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit -- this kind of macro at the beginning of the following kinds of basic bocks: -- \begin{itemize} --- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally +-- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally -- we use @fetchAndReschedule@ at a slow entry code. -- \item Fast entry code (see @CgClosure.lhs@). -- \item Alternatives in case expressions (@CLabelledCode@ structures), provided --- that they are not inlined (see @CgCases.lhs@). These alternatives will +-- that they are not inlined (see @CgCases.lhs@). These alternatives will -- be turned into separate functions. granYield :: [(Id,GlobalReg)] -- Live registers -> Bool -- Node reqd? - -> Code + -> Code granYield regs node_reqd - | opt_GranMacros && node_reqd = yield liveness - | otherwise = nopC + = do dflags <- getDynFlags + when (dopt Opt_GranMacros dflags && node_reqd) $ yield liveness where liveness = mkRegLiveness regs 0 0 yield :: StgWord -> Code yield _liveness = panic "granYield" - -- Was : absC (CMacroStmt GRAN_YIELD + -- Was : absC (CMacroStmt GRAN_YIELD -- [mkIntCLit (I# (word2Int# liveness_mask))]) diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index b0865d69d9..641cd5d1dc 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -33,6 +33,8 @@ import Outputable import FastString import StaticFlags +import Control.Monad + -- --------------------------------------------------------------------------- -- Code generation for PrimOps @@ -402,12 +404,14 @@ emitPrimOp res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just mo_W emitPrimOp res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args emitPrimOp res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args --- Copying byte arrays +-- Copying and setting byte arrays emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] live = doCopyByteArrayOp src src_off dst dst_off n live emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] live = doCopyMutableByteArrayOp src src_off dst dst_off n live +emitPrimOp [] SetByteArrayOp [ba,off,len,c] live = + doSetByteArrayOp ba off len c live -- Population count emitPrimOp [res] PopCnt8Op [w] live = emitPopCntCall res w W8 live @@ -430,7 +434,7 @@ emitPrimOp [res] op args live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [CmmHinted res NoHint] - (CmmPrim prim) + (CmmPrim prim Nothing) [CmmHinted a NoHint | a<-args] -- ToDo: hints? (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky @@ -440,9 +444,167 @@ emitPrimOp [res] op args live = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in stmtC stmt +emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ + = let genericImpl + = [CmmAssign (CmmLocal res_q) + (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]), + CmmAssign (CmmLocal res_r) + (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_S_QuotRem wordWidth) (Just genericImpl)) + [CmmHinted res_q NoHint, + CmmHinted res_r NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + in stmtC stmt +emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ + = let genericImpl + = [CmmAssign (CmmLocal res_q) + (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]), + CmmAssign (CmmLocal res_r) + (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_U_QuotRem wordWidth) (Just genericImpl)) + [CmmHinted res_q NoHint, + CmmHinted res_r NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + in stmtC stmt +emitPrimOp [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ + = do let ty = cmmExprType arg_x_high + shl x i = CmmMachOp (MO_Shl wordWidth) [x, i] + shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i] + or x y = CmmMachOp (MO_Or wordWidth) [x, y] + ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y] + ne x y = CmmMachOp (MO_Ne wordWidth) [x, y] + minus x y = CmmMachOp (MO_Sub wordWidth) [x, y] + times x y = CmmMachOp (MO_Mul wordWidth) [x, y] + zero = lit 0 + one = lit 1 + negone = lit (fromIntegral (widthInBits wordWidth) - 1) + lit i = CmmLit (CmmInt i wordWidth) + f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode [CmmStmt] + f 0 acc high _ = return [CmmAssign (CmmLocal res_q) acc, + CmmAssign (CmmLocal res_r) high] + f i acc high low = + do roverflowedBit <- newLocalReg ty + rhigh' <- newLocalReg ty + rhigh'' <- newLocalReg ty + rlow' <- newLocalReg ty + risge <- newLocalReg ty + racc' <- newLocalReg ty + let high' = CmmReg (CmmLocal rhigh') + isge = CmmReg (CmmLocal risge) + overflowedBit = CmmReg (CmmLocal roverflowedBit) + let this = [CmmAssign (CmmLocal roverflowedBit) + (shr high negone), + CmmAssign (CmmLocal rhigh') + (or (shl high one) (shr low negone)), + CmmAssign (CmmLocal rlow') + (shl low one), + CmmAssign (CmmLocal risge) + (or (overflowedBit `ne` zero) + (high' `ge` arg_y)), + CmmAssign (CmmLocal rhigh'') + (high' `minus` (arg_y `times` isge)), + CmmAssign (CmmLocal racc') + (or (shl acc one) isge)] + rest <- f (i - 1) (CmmReg (CmmLocal racc')) + (CmmReg (CmmLocal rhigh'')) + (CmmReg (CmmLocal rlow')) + return (this ++ rest) + genericImpl <- f (widthInBits wordWidth) zero arg_x_high arg_x_low + let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 wordWidth) (Just genericImpl)) + [CmmHinted res_q NoHint, + CmmHinted res_r NoHint] + [CmmHinted arg_x_high NoHint, + CmmHinted arg_x_low NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + stmtC stmt + +emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ + = do r1 <- newLocalReg (cmmExprType arg_x) + r2 <- newLocalReg (cmmExprType arg_x) + -- This generic implementation is very simple and slow. We might + -- well be able to do better, but for now this at least works. + let genericImpl + = [CmmAssign (CmmLocal r1) + (add (bottomHalf arg_x) (bottomHalf arg_y)), + CmmAssign (CmmLocal r2) + (add (topHalf (CmmReg (CmmLocal r1))) + (add (topHalf arg_x) (topHalf arg_y))), + CmmAssign (CmmLocal res_h) + (topHalf (CmmReg (CmmLocal r2))), + CmmAssign (CmmLocal res_l) + (or (toTopHalf (CmmReg (CmmLocal r2))) + (bottomHalf (CmmReg (CmmLocal r1))))] + where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] + bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] + add x y = CmmMachOp (MO_Add wordWidth) [x, y] + or x y = CmmMachOp (MO_Or wordWidth) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) + wordWidth) + hwm = CmmLit (CmmInt halfWordMask wordWidth) + stmt = CmmCall (CmmPrim (MO_Add2 wordWidth) (Just genericImpl)) + [CmmHinted res_h NoHint, + CmmHinted res_l NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + stmtC stmt +emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _ + = do let t = cmmExprType arg_x + xlyl <- liftM CmmLocal $ newLocalReg t + xlyh <- liftM CmmLocal $ newLocalReg t + xhyl <- liftM CmmLocal $ newLocalReg t + r <- liftM CmmLocal $ newLocalReg t + -- This generic implementation is very simple and slow. We might + -- well be able to do better, but for now this at least works. + let genericImpl + = [CmmAssign xlyl + (mul (bottomHalf arg_x) (bottomHalf arg_y)), + CmmAssign xlyh + (mul (bottomHalf arg_x) (topHalf arg_y)), + CmmAssign xhyl + (mul (topHalf arg_x) (bottomHalf arg_y)), + CmmAssign r + (sum [topHalf (CmmReg xlyl), + bottomHalf (CmmReg xhyl), + bottomHalf (CmmReg xlyh)]), + CmmAssign (CmmLocal res_l) + (or (bottomHalf (CmmReg xlyl)) + (toTopHalf (CmmReg r))), + CmmAssign (CmmLocal res_h) + (sum [mul (topHalf arg_x) (topHalf arg_y), + topHalf (CmmReg xhyl), + topHalf (CmmReg xlyh), + topHalf (CmmReg r)])] + where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] + bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] + add x y = CmmMachOp (MO_Add wordWidth) [x, y] + sum = foldl1 add + mul x y = CmmMachOp (MO_Mul wordWidth) [x, y] + or x y = CmmMachOp (MO_Or wordWidth) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) + wordWidth) + hwm = CmmLit (CmmInt halfWordMask wordWidth) + stmt = CmmCall (CmmPrim (MO_U_Mul2 wordWidth) (Just genericImpl)) + [CmmHinted res_h NoHint, + CmmHinted res_l NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + stmtC stmt + emitPrimOp _ op _ _ = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) +newLocalReg :: CmmType -> FCode LocalReg +newLocalReg t = do u <- newUnique + return $ LocalReg u t -- These PrimOps are NOPs in Cmm @@ -748,6 +910,18 @@ emitCopyByteArray copy src src_off dst dst_off n live = do copy src dst dst_p src_p n live -- ---------------------------------------------------------------------------- +-- Setting byte arrays + +-- | Takes a 'MutableByteArray#', an offset into the array, a length, +-- and a byte, and sets each of the selected bytes in the array to the +-- character. +doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +doSetByteArrayOp ba off len c live + = do p <- assignTemp $ cmmOffsetExpr (cmmOffsetB ba arrWordsHdrSize) off + emitMemsetCall p c len (CmmLit (mkIntCLit 1)) live + +-- ---------------------------------------------------------------------------- -- Copying pointer arrays -- EZY: This code has an unusually high amount of assignTemp calls, seen @@ -889,7 +1063,7 @@ emitMemcpyCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memcpy) + (CmmPrim MO_Memcpy Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) @@ -906,7 +1080,7 @@ emitMemmoveCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memmove) + (CmmPrim MO_Memmove Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) @@ -924,7 +1098,7 @@ emitMemsetCall dst c n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memset) + (CmmPrim MO_Memset Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted c NoHint) , (CmmHinted n NoHint) @@ -956,7 +1130,7 @@ emitPopCntCall res x width live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [CmmHinted res NoHint] - (CmmPrim (MO_PopCnt width)) + (CmmPrim (MO_PopCnt width) Nothing) [(CmmHinted x NoHint)] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 296dd62818..1a5f916dbe 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -170,8 +170,9 @@ emitCostCentreDecl cc = do -- All cost centres will be in the main package, since we -- don't normally use -auto-all or add SCCs to other packages. -- Hence don't emit the package name in the module here. + ; dflags <- getDynFlags ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ - showSDoc (ppr (costCentreSrcSpan cc)) + showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let lits = [ zero, -- StgInt ccID, diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs index 2628760183..a869795caa 100644 --- a/compiler/codeGen/CgStackery.lhs +++ b/compiler/codeGen/CgStackery.lhs @@ -43,6 +43,7 @@ import OrdList import Outputable import Control.Monad +import Data.List \end{code} %************************************************************************ @@ -333,7 +334,7 @@ Explicitly free some stack space. freeStackSlots :: [VirtualSpOffset] -> Code freeStackSlots extra_free = do { stk_usg <- getStkUsage - ; let all_free = addFreeSlots (freeStk stk_usg) (sortLe (<=) extra_free) + ; let all_free = addFreeSlots (freeStk stk_usg) (sort extra_free) ; let (new_vsp, new_free) = trim (virtSp stk_usg) all_free ; setStkUsage (stk_usg { virtSp = new_vsp, freeStk = new_free }) } diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index 499529d841..e933fedb5b 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -43,6 +43,7 @@ import StgSyn import PrimOp import Outputable import StaticFlags +import Util import Control.Monad import Data.Maybe diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index 0ff440e6bf..021b0e4fd9 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -91,7 +91,8 @@ emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code emitTickyCounter cl_info args on_stk = ifTicky $ do { mod_name <- getModuleName - ; fun_descr_lit <- newStringCLit (fun_descr mod_name) + ; dflags <- getDynFlags + ; fun_descr_lit <- newStringCLit (fun_descr dflags mod_name) ; arg_descr_lit <- newStringCLit arg_descr ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter -- krc: note that all the fields are I32 now; some were I16 before, @@ -110,15 +111,15 @@ emitTickyCounter cl_info args on_stk name = closureName cl_info ticky_ctr_label = mkRednCountsLabel name NoCafRefs arg_descr = map (showTypeCategory . idType) args - fun_descr mod_name = ppr_for_ticky_name mod_name name + fun_descr dflags mod_name = ppr_for_ticky_name dflags mod_name name -- When printing the name of a thing in a ticky file, we want to -- give the module name even for *local* things. We print -- just "x (M)" rather that "M.x" to distinguish them from the global kind. -ppr_for_ticky_name :: Module -> Name -> String -ppr_for_ticky_name mod_name name - | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name))) - | otherwise = showSDocDebug (ppr name) +ppr_for_ticky_name :: DynFlags -> Module -> Name -> String +ppr_for_ticky_name dflags mod_name name + | isInternalName name = showSDocDebug dflags (ppr name <+> (parens (ppr mod_name))) + | otherwise = showSDocDebug dflags (ppr name) -- ----------------------------------------------------------------------------- -- Ticky stack frames diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 2bd35c8796..e7d17c1f03 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -72,7 +72,9 @@ import Outputable import Data.Char import Data.Word +import Data.List import Data.Maybe +import Data.Ord ------------------------------------------------------------------------- -- @@ -527,12 +529,10 @@ emitSwitch tag_expr branches mb_deflt lo_tag hi_tag ; let via_C | HscC <- hscTarget dflags = True | otherwise = False - ; stmts <- mk_switch tag_expr (sortLe le branches) + ; stmts <- mk_switch tag_expr (sortBy (comparing fst) branches) mb_deflt_id lo_tag hi_tag via_C ; emitCgStmts stmts } - where - (t1,_) `le` (t2,_) = t1 <= t2 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)] @@ -699,10 +699,8 @@ emitLitSwitch _ [] deflt = emitCgStmts deflt emitLitSwitch scrut branches deflt_blk = do { scrut' <- assignTemp scrut ; deflt_blk_id <- forkCgStmts deflt_blk - ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches) + ; blk <- mk_lit_switch scrut' deflt_blk_id (sortBy (comparing fst) branches) ; emitCgStmts blk } - where - le (t1,_) (t2,_) = t1 <= t2 mk_lit_switch :: CmmExpr -> BlockId -> [(Literal,CgStmts)] @@ -1011,7 +1009,8 @@ fixStgRegStmt stmt CmmCall target regs args returns -> let target' = case target of CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv - other -> other + CmmPrim op mStmts -> + CmmPrim op (fmap (map fixStgRegStmt) mStmts) args' = map (\(CmmHinted arg hint) -> (CmmHinted (fixStgRegExpr arg) hint)) args in CmmCall target' regs args' returns diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 34746984c2..7a91a5e2a1 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -20,6 +20,8 @@ the STG paper. -- for details module ClosureInfo ( + idRepArity, + ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but StandardFormInfo(..), -- mkCmmInfo looks inside SMRep, @@ -96,6 +98,7 @@ import Outputable import FastString import Constants import DynFlags +import Util \end{code} @@ -156,7 +159,7 @@ ClosureInfo contains a LambdaFormInfo. data LambdaFormInfo = LFReEntrant -- Reentrant closure (a function) TopLevelFlag -- True if top level - !Int -- Arity. Invariant: always > 0 + !RepArity -- Arity. Invariant: always > 0 !Bool -- True <=> no fvs ArgDescr -- Argument descriptor (should reall be in ClosureInfo) @@ -180,7 +183,7 @@ data LambdaFormInfo | LFLetNoEscape -- See LetNoEscape module for precise description of -- these "lets". - !Int -- arity; + !RepArity -- arity; | LFBlackHole -- Used for the closures allocated to hold the result -- of a CAF. We want the target of the update frame to @@ -211,7 +214,7 @@ data StandardFormInfo -- The code for the thunk just pushes x2..xn on the stack and enters x1. -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled -- in the RTS to save space. - Int -- Arity, n + RepArity -- Arity, n \end{code} @@ -288,7 +291,7 @@ idCgRep x = typeCgRep . idType $ x tyConCgRep :: TyCon -> CgRep tyConCgRep = primRepToCgRep . tyConPrimRep -typeCgRep :: Type -> CgRep +typeCgRep :: UnaryType -> CgRep typeCgRep = primRepToCgRep . typePrimRep \end{code} @@ -384,9 +387,12 @@ might_be_a_function :: Type -> Bool -- Return False only if we are *sure* it's a data type -- Look through newtypes etc as much as poss might_be_a_function ty - = case tyConAppTyCon_maybe (repType ty) of - Just tc -> not (isDataTyCon tc) - Nothing -> True + | UnaryRep rep <- repType ty + , Just tc <- tyConAppTyCon_maybe rep + , isDataTyCon tc + = False + | otherwise + = True \end{code} @mkConLFInfo@ is similar, for constructors. @@ -404,7 +410,7 @@ mkSelectorLFInfo id offset updatable = LFThunk NotTopLevel False updatable (SelectorThunk offset) (might_be_a_function (idType id)) -mkApLFInfo :: Id -> UpdateFlag -> Int -> LambdaFormInfo +mkApLFInfo :: Id -> UpdateFlag -> RepArity -> LambdaFormInfo mkApLFInfo id upd_flag arity = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) (might_be_a_function (idType id)) @@ -416,12 +422,12 @@ Miscellaneous LF-infos. mkLFArgument :: Id -> LambdaFormInfo mkLFArgument id = LFUnknown (might_be_a_function (idType id)) -mkLFLetNoEscape :: Int -> LambdaFormInfo +mkLFLetNoEscape :: RepArity -> LambdaFormInfo mkLFLetNoEscape = LFLetNoEscape mkLFImported :: Id -> LambdaFormInfo mkLFImported id - = case idArity id of + = case idRepArity id of n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0 _ -> mkLFArgument id -- Not sure of exact arity \end{code} @@ -634,17 +640,17 @@ data CallMethod | DirectEntry -- Jump directly, with args in regs CLabel -- The code label - Int -- Its arity + RepArity -- Its arity getCallMethod :: DynFlags -> Name -- Function being applied -> CafInfo -- Can it refer to CAF's? -> LambdaFormInfo -- Its info - -> Int -- Number of available arguments + -> RepArity -- Number of available arguments -> CallMethod -getCallMethod _ _ _ lf_info _ - | nodeMustPointToIt lf_info && opt_Parallel +getCallMethod dflags _ _ lf_info _ + | nodeMustPointToIt lf_info && dopt Opt_Parallel dflags = -- If we're parallel, then we must always enter via node. -- The reason is that the closure may have been -- fetched since we allocated it. @@ -725,7 +731,7 @@ blackHoleOnEntry cl_info = case closureLFInfo cl_info of LFReEntrant _ _ _ _ -> False LFLetNoEscape _ -> False - LFThunk _ no_fvs _updatable _ _ -> not no_fvs -- to plug space-leaks. + LFThunk _ _no_fvs _updatable _ _ -> True _other -> panic "blackHoleOnEntry" -- Should never happen isKnownFun :: LambdaFormInfo -> Bool @@ -911,11 +917,11 @@ isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con isConstrClosure_maybe _ = Nothing -closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr) +closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info closureFunInfo _ = Nothing -lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr) +lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing @@ -935,7 +941,7 @@ funTagLFInfo lf | otherwise = 0 -tagForArity :: Int -> Maybe Int +tagForArity :: RepArity -> Maybe Int tagForArity i | i <= mAX_PTR_TAG = Just i | otherwise = Nothing @@ -1097,8 +1103,16 @@ getTyDescription ty FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon ForAllTy _ ty -> getTyDescription ty + LitTy n -> getTyLitDescription n } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other + + +getTyLitDescription :: TyLit -> String +getTyLitDescription l = + case l of + NumTyLit n -> show n + StrTyLit n -> show n \end{code} diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index f8898450ef..9c936d3281 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -75,8 +75,7 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info st <- readIORef cgref let (a,st') = runC dflags this_mod st fcode - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" $ - pprPlatform (targetPlatform dflags) a + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" $ ppr a -- NB. stub-out cgs_tops and cgs_stmts. This fixes -- a big space leak. DO NOT REMOVE! diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 933aeb9d45..696af8107e 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -53,6 +53,7 @@ import MkGraph import Data.IORef import Control.Monad (when) +import Util codeGen :: DynFlags -> Module @@ -246,8 +247,8 @@ cgDataCon data_con (tagForCon data_con)] } -- The case continuation code expects a tagged pointer - arg_reps :: [(PrimRep, Type)] - arg_reps = [(typePrimRep ty, ty) | ty <- dataConRepArgTys data_con] + arg_reps :: [(PrimRep, UnaryType)] + arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] -- Dynamic closure code for non-nullary constructors only ; whenC (not (isNullaryRepDataCon data_con)) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 5838628fca..f98283f737 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -79,9 +79,10 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args ; has_srt <- getSRTInfo srt ; mod_name <- getModuleName - ; let descr = closureDescription mod_name name + ; dflags <- getDynFlags + ; let descr = closureDescription dflags mod_name name closure_info = mkClosureInfo True id lf_info 0 0 descr - closure_label = mkLocalClosureLabel name (idCafInfo id) + closure_label = mkLocalClosureLabel name (idCafInfo id) cg_id_info = litIdInfo id lf_info (CmmLabel closure_label) caffy = idCafInfo id info_tbl = mkCmmInfo closure_info -- XXX short-cut @@ -285,9 +286,10 @@ mkRhsClosure bndr cc _ fvs upd_flag args body -- MAKE CLOSURE INFO FOR THIS CLOSURE ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args ; mod_name <- getModuleName + ; dflags <- getDynFlags ; let name = idName bndr - descr = closureDescription mod_name name - fv_details :: [(NonVoid Id, VirtualHpOffset)] + descr = closureDescription dflags mod_name name + fv_details :: [(NonVoid Id, VirtualHpOffset)] (tot_wds, ptr_wds, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) (addIdReps (map stripNV reduced_fvs)) @@ -333,10 +335,11 @@ cgStdThunk bndr _cc _bndr_info _body lf_info payload = do -- AHA! A STANDARD-FORM THUNK { -- LAY OUT THE OBJECT mod_name <- getModuleName + ; dflags <- getDynFlags ; let (tot_wds, ptr_wds, payload_w_offsets) = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload) - descr = closureDescription mod_name (idName bndr) + descr = closureDescription dflags mod_name (idName bndr) closure_info = mkClosureInfo False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -404,9 +407,7 @@ closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details do { -- Allocate the global ticky counter, -- and establish the ticky-counter -- label for this block - ; dflags <- getDynFlags - ; let platform = targetPlatform dflags - ticky_ctr_lbl = closureRednCountsLabel platform cl_info + let ticky_ctr_lbl = closureRednCountsLabel cl_info ; emitTickyCounter cl_info (map stripNV args) ; setTickyCtrLabel ticky_ctr_lbl $ do @@ -463,10 +464,8 @@ mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode () mkSlowEntryCode _ [] = panic "entering a closure with no arguments?" mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info - = do dflags <- getDynFlags - let platform = targetPlatform dflags - slow_lbl = closureSlowEntryLabel platform cl_info - fast_lbl = closureLocalEntryLabel platform cl_info + = do let slow_lbl = closureSlowEntryLabel cl_info + fast_lbl = closureLocalEntryLabel cl_info -- mkDirectJump does not clobber `Node' containing function closure jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs) @@ -561,12 +560,15 @@ setupUpdate closure_info node body then do tickyUpdateFrameOmitted; body else do tickyPushUpdateFrame - --dflags <- getDynFlags - let es = [CmmReg (CmmLocal node), mkLblExpr mkUpdInfoLabel] - --if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags - -- then pushUpdateFrame es body -- XXX black hole - -- else pushUpdateFrame es body - pushUpdateFrame es body + dflags <- getDynFlags + let + bh = blackHoleOnEntry closure_info && + not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags + + lbl | bh = mkBHUpdInfoLabel + | otherwise = mkUpdInfoLabel + + pushUpdateFrame [CmmReg (CmmLocal node), mkLblExpr lbl] body | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -575,7 +577,7 @@ setupUpdate closure_info node body then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf True ; pushUpdateFrame [CmmReg (CmmLocal upd_closure), - mkLblExpr mkUpdInfoLabel] body } -- XXX black hole + mkLblExpr mkBHUpdInfoLabel] body } else do {tickyUpdateFrameOmitted; body} } @@ -679,13 +681,14 @@ link_caf _is_upd = do -- name of the data constructor itself. Otherwise it is determined by -- @closureDescription@ from the let binding information. -closureDescription :: Module -- Module +closureDescription :: DynFlags + -> Module -- Module -> Name -- Id of closure binding -> String -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.lhs with a description generated from the data constructor -closureDescription mod_name name - = showSDocDump (char '<' <> +closureDescription dflags mod_name name + = showSDocDump dflags (char '<' <> (if isExternalName name then ppr name -- ppr will include the module name prefix else pprModule mod_name <> char '.' <> ppr name) <> diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 487c94daaa..8023abddec 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -21,8 +21,8 @@ module StgCmmClosure ( DynTag, tagForCon, isSmallFamily, ConTagZ, dataConTagZ, - isVoidRep, isGcPtrRep, addIdReps, addArgReps, - argPrimRep, + idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, + argPrimRep, -- * LambdaFormInfo LambdaFormInfo, -- Abstract @@ -87,9 +87,9 @@ import TcType import TyCon import BasicTypes import Outputable -import Platform import Constants import DynFlags +import Util ----------------------------------------------------------------------------- -- Representations @@ -97,6 +97,10 @@ import DynFlags -- Why are these here? +-- NB: this is reliable because by StgCmm no Ids have unboxed tuple type +idPrimRep :: Id -> PrimRep +idPrimRep id = typePrimRep (idType id) + addIdReps :: [Id] -> [(PrimRep, Id)] addIdReps ids = [(idPrimRep id, id) | id <- ids] @@ -127,7 +131,7 @@ isGcPtrRep _ = False data LambdaFormInfo = LFReEntrant -- Reentrant closure (a function) TopLevelFlag -- True if top level - !Int -- Arity. Invariant: always > 0 + !RepArity -- Arity. Invariant: always > 0 !Bool -- True <=> no fvs ArgDescr -- Argument descriptor (should really be in ClosureInfo) @@ -188,7 +192,7 @@ data StandardFormInfo -- The code for the thunk just pushes x2..xn on the stack and enters x1. -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled -- in the RTS to save space. - Int -- Arity, n + RepArity -- Arity, n ------------------------------------------------------ @@ -231,9 +235,12 @@ might_be_a_function :: Type -> Bool -- Return False only if we are *sure* it's a data type -- Look through newtypes etc as much as poss might_be_a_function ty - = case tyConAppTyCon_maybe (repType ty) of - Just tc -> not (isDataTyCon tc) - Nothing -> True + | UnaryRep rep <- repType ty + , Just tc <- tyConAppTyCon_maybe rep + , isDataTyCon tc + = False + | otherwise + = True ------------- mkConLFInfo :: DataCon -> LambdaFormInfo @@ -266,7 +273,7 @@ mkLFImported id | otherwise = mkLFArgument id -- Not sure of exact arity where - arity = idArity id + arity = idRepArity id ------------ mkLFBlackHole :: LambdaFormInfo @@ -309,7 +316,7 @@ tagForCon con con_tag = dataConTagZ con fam_size = tyConFamilySize (dataConTyCon con) -tagForArity :: Int -> DynTag +tagForArity :: RepArity -> DynTag tagForArity arity | isSmallFamily arity = arity | otherwise = 0 @@ -458,17 +465,17 @@ data CallMethod | DirectEntry -- Jump directly, with args in regs CLabel -- The code label - Int -- Its arity + RepArity -- Its arity getCallMethod :: DynFlags -> Name -- Function being applied -> CafInfo -- Can it refer to CAF's? -> LambdaFormInfo -- Its info - -> Int -- Number of available arguments + -> RepArity -- Number of available arguments -> CallMethod -getCallMethod _ _name _ lf_info _n_args - | nodeMustPointToIt lf_info && opt_Parallel +getCallMethod dflags _name _ lf_info _n_args + | nodeMustPointToIt lf_info && dopt Opt_Parallel dflags = -- If we're parallel, then we must always enter via node. -- The reason is that the closure may have been -- fetched since we allocated it. @@ -717,7 +724,7 @@ blackHoleOnEntry cl_info = case closureLFInfo cl_info of LFReEntrant _ _ _ _ -> False LFLetNoEscape -> False - LFThunk _ no_fvs _updatable _ _ -> not no_fvs -- to plug space-leaks. + LFThunk _ _no_fvs _updatable _ _ -> True _other -> panic "blackHoleOnEntry" -- Should never happen isStaticClosure :: ClosureInfo -> Bool @@ -741,10 +748,10 @@ closureReEntrant :: ClosureInfo -> Bool closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True closureReEntrant _ = False -closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr) +closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info -lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr) +lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing @@ -762,19 +769,19 @@ isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) -- Label generation -------------------------------------- -staticClosureLabel :: Platform -> ClosureInfo -> CLabel -staticClosureLabel platform = toClosureLbl platform . closureInfoLabel +staticClosureLabel :: ClosureInfo -> CLabel +staticClosureLabel = toClosureLbl . closureInfoLabel -closureRednCountsLabel :: Platform -> ClosureInfo -> CLabel -closureRednCountsLabel platform = toRednCountsLbl platform . closureInfoLabel +closureRednCountsLabel :: ClosureInfo -> CLabel +closureRednCountsLabel = toRednCountsLbl . closureInfoLabel -closureSlowEntryLabel :: Platform -> ClosureInfo -> CLabel -closureSlowEntryLabel platform = toSlowEntryLbl platform . closureInfoLabel +closureSlowEntryLabel :: ClosureInfo -> CLabel +closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel -closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel -closureLocalEntryLabel platform - | tablesNextToCode = toInfoLbl platform . closureInfoLabel - | otherwise = toEntryLbl platform . closureInfoLabel +closureLocalEntryLabel :: ClosureInfo -> CLabel +closureLocalEntryLabel + | tablesNextToCode = toInfoLbl . closureInfoLabel + | otherwise = toEntryLbl . closureInfoLabel mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel mkClosureInfoTableLabel id lf_info @@ -861,11 +868,18 @@ getTyDescription ty FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon ForAllTy _ ty -> getTyDescription ty + LitTy n -> getTyLitDescription n } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other +getTyLitDescription :: TyLit -> String +getTyLitDescription l = + case l of + NumTyLit n -> show n + StrTyLit n -> show n + -------------------------------------- -- CmmInfoTable-related things -------------------------------------- diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 1a40a4273f..c348570a54 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -41,7 +41,7 @@ import PrelInfo import Outputable import Platform import StaticFlags -import Util ( lengthIs ) +import Util import Control.Monad import Data.Char @@ -62,7 +62,7 @@ cgTopRhsCon id con args ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. ASSERT( not (isDllConApp dflags con args) ) return () - ; ASSERT( args `lengthIs` dataConRepArity con ) return () + ; ASSERT( args `lengthIs` dataConRepRepArity con ) return () -- LAY IT OUT ; let diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 3b56e2feb6..2edd09da12 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -201,7 +201,6 @@ getArgAmode :: NonVoid StgArg -> FCode CmmExpr getArgAmode (NonVoid (StgVarArg var)) = do { info <- getCgIdInfo var; return (idInfoToAmode info) } getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit -getArgAmode (NonVoid (StgTypeArg _)) = panic "getArgAmode: type arg" getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] -- NB: Filters out void args, diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index e682af0ced..4db1dffdfc 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -590,7 +590,7 @@ cgConApp con stg_args ; emitReturn arg_exprs } | otherwise -- Boxed constructors; allocate and return - = ASSERT( stg_args `lengthIs` dataConRepArity con ) + = ASSERT( stg_args `lengthIs` dataConRepRepArity con ) do { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args -- The first "con" says that the name bound to this closure is -- is "con", which is a bit of a fudge, but it only affects profiling diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index d5c9600b38..c67e0e0c95 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -58,7 +58,9 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) = case target of - StaticTarget lbl mPkgId + StaticTarget _ _ False -> + panic "cgForeignCall: unexpected FFI value import" + StaticTarget lbl mPkgId True -> let labelSource = case mPkgId of Nothing -> ForeignLabelInThisPackage @@ -390,5 +392,6 @@ add_shim arg_ty expr | otherwise = expr where - tycon = tyConAppTyCon (repType arg_ty) + UnaryRep rep_ty = repType arg_ty + tycon = tyConAppTyCon rep_ty -- should be a tycon app, since this is a foreign call diff --git a/compiler/codeGen/StgCmmGran.hs b/compiler/codeGen/StgCmmGran.hs index 232c7c6b58..2abca3fe16 100644 --- a/compiler/codeGen/StgCmmGran.hs +++ b/compiler/codeGen/StgCmmGran.hs @@ -3,22 +3,15 @@ -- (c) The University of Glasgow -2006 -- -- Code generation relaed to GpH --- (a) parallel --- (b) GranSim +-- (a) parallel +-- (b) GranSim -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmmGran ( - staticGranHdr,staticParHdr, - granThunk, granYield, - doGranAllocate + staticGranHdr,staticParHdr, + granThunk, granYield, + doGranAllocate ) where -- This entire module consists of no-op stubs at the moment @@ -57,11 +50,11 @@ staticGranHdr :: [CmmLit] -- Gransim header words in a static closure staticGranHdr = [] -doGranAllocate :: CmmExpr -> Code +doGranAllocate :: CmmExpr -> Code -- macro DO_GRAN_ALLOCATE -doGranAllocate hp +doGranAllocate hp | not opt_GranMacros = nopC - | otherwise = panic "doGranAllocate" + | otherwise = panic "doGranAllocate" @@ -69,13 +62,13 @@ doGranAllocate hp granThunk :: Bool -> FCode () -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node -- (we prefer fetchAndReschedule-style context switches to yield ones) -granThunk node_points - | node_points = granFetchAndReschedule [] node_points - | otherwise = granYield [] node_points +granThunk node_points + | node_points = granFetchAndReschedule [] node_points + | otherwise = granYield [] node_points granFetchAndReschedule :: [(Id,GlobalReg)] -- Live registers - -> Bool -- Node reqd? - -> Code + -> Bool -- Node reqd? + -> Code -- Emit code for simulating a fetch and then reschedule. granFetchAndReschedule regs node_reqd | opt_GranMacros && (node `elem` map snd regs || node_reqd) @@ -87,15 +80,15 @@ granFetchAndReschedule regs node_reqd liveness = mkRegLiveness regs 0 0 fetch = panic "granFetch" - -- Was: absC (CMacroStmt GRAN_FETCH []) - --HWL: generate GRAN_FETCH macro for GrAnSim - -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai + -- Was: absC (CMacroStmt GRAN_FETCH []) + --HWL: generate GRAN_FETCH macro for GrAnSim + -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai reschedule liveness node_reqd = panic "granReschedule" - -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ - -- mkIntCLit (I# (word2Int# liveness_mask)), - -- mkIntCLit (if node_reqd then 1 else 0)]) - + -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ + -- mkIntCLit (I# (word2Int# liveness_mask)), + -- mkIntCLit (if node_reqd then 1 else 0)]) + ------------------------- -- The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It @@ -103,25 +96,25 @@ reschedule liveness node_reqd = panic "granReschedule" -- @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit -- this kind of macro at the beginning of the following kinds of basic bocks: -- \begin{itemize} --- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally +-- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally -- we use @fetchAndReschedule@ at a slow entry code. -- \item Fast entry code (see @CgClosure.lhs@). -- \item Alternatives in case expressions (@CLabelledCode@ structures), provided --- that they are not inlined (see @CgCases.lhs@). These alternatives will +-- that they are not inlined (see @CgCases.lhs@). These alternatives will -- be turned into separate functions. granYield :: [(Id,GlobalReg)] -- Live registers -> Bool -- Node reqd? - -> Code + -> Code granYield regs node_reqd | opt_GranMacros && node_reqd = yield liveness - | otherwise = nopC + | otherwise = nopC where liveness = mkRegLiveness regs 0 0 yield liveness = panic "granYield" - -- Was : absC (CMacroStmt GRAN_YIELD + -- Was : absC (CMacroStmt GRAN_YIELD -- [mkIntCLit (I# (word2Int# liveness_mask))]) -} diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 37dc467862..856b04367d 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -43,7 +43,7 @@ import IdInfo( CafInfo(..), mayHaveCafRefs ) import Module import FastString( mkFastString, fsLit ) import Constants -import DynFlags +import Util ----------------------------------------------------------- -- Initialise dynamic heap objects @@ -331,11 +331,7 @@ entryHeapCheck :: ClosureInfo -> FCode () entryHeapCheck cl_info offset nodeSet arity args code - = do dflags <- getDynFlags - - let platform = targetPlatform dflags - - is_thunk = arity == 0 + = do let is_thunk = arity == 0 is_fastf = case closureFunInfo cl_info of Just (_, ArgGen _) -> False _otherwise -> True @@ -345,7 +341,7 @@ entryHeapCheck cl_info offset nodeSet arity args code Just n -> mkNop -- No need to assign R1, it already -- points to the closure Nothing -> mkAssign nodeReg $ - CmmLit (CmmLabel $ staticClosureLabel platform cl_info) + CmmLit (CmmLabel $ staticClosureLabel cl_info) {- Thunks: jump GCEnter1 Function (fast): Set R1 = node, jump GCFun diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 16b33d1faf..9593af1f50 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -52,8 +52,7 @@ import StgSyn import Id import Name import TyCon ( PrimRep(..) ) -import BasicTypes ( Arity ) -import DynFlags +import BasicTypes ( RepArity ) import StaticFlags import Module @@ -61,7 +60,7 @@ import Constants import Util import Data.List import Outputable -import FastString ( mkFastString, FastString, fsLit ) +import FastString ------------------------------------------------------------------------ -- Call and return sequences @@ -166,7 +165,7 @@ adjustHpBackwards -- call f() return to Nothing updfr_off: 32 -directCall :: CLabel -> Arity -> [StgArg] -> FCode () +directCall :: CLabel -> RepArity -> [StgArg] -> FCode () -- (directCall f n args) -- calls f(arg1, ..., argn), and applies the result to the remaining args -- The function f has arity n, and there are guaranteed at least n args @@ -182,27 +181,24 @@ slowCall fun stg_args = do { dflags <- getDynFlags ; argsreps <- getArgRepsAmodes stg_args ; let (rts_fun, arity) = slowCallPattern (map fst argsreps) - ; let platform = targetPlatform dflags ; call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity argsreps ; emitComment $ mkFastString ("slow_call for " ++ - showSDoc (pprPlatform platform fun) ++ - " with pat " ++ showSDoc (ftext rts_fun)) + showSDoc dflags (ppr fun) ++ + " with pat " ++ unpackFS rts_fun) ; emit (mkAssign nodeReg fun <*> call) } -------------- -direct_call :: String -> CLabel -> Arity -> [(ArgRep,Maybe CmmExpr)] -> FCode () +direct_call :: String -> CLabel -> RepArity -> [(ArgRep,Maybe CmmExpr)] -> FCode () direct_call caller lbl arity args | debugIsOn && arity > length args -- Too few args = do -- Caller should ensure that there enough args! - dflags <- getDynFlags - let platform = targetPlatform dflags pprPanic "direct_call" $ text caller <+> ppr arity <+> - pprPlatform platform lbl <+> ppr (length args) <+> - pprPlatform platform (map snd args) <+> ppr (map fst args) + ppr lbl <+> ppr (length args) <+> + ppr (map snd args) <+> ppr (map fst args) | null rest_args -- Precisely the right number of arguments = emitCall (NativeDirectCall, NativeReturn) target (nonVArgs args) @@ -289,7 +285,7 @@ slowArgs args -- careful: reps contains voids (V), but args does not -- These cases were found to cover about 99% of all slow calls: -slowCallPattern :: [ArgRep] -> (FastString, Arity) +slowCallPattern :: [ArgRep] -> (FastString, RepArity) -- Returns the generic apply function and arity slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6) slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5) @@ -532,9 +528,8 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body emitClosureAndInfoTable :: CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode () emitClosureAndInfoTable info_tbl conv args body - = do { dflags <- getDynFlags - ; blks <- getCode body - ; let entry_lbl = toEntryLbl (targetPlatform dflags) (cit_lbl info_tbl) + = do { blks <- getCode body + ; let entry_lbl = toEntryLbl (cit_lbl info_tbl) ; emitProcWithConvention conv info_tbl entry_lbl args blks } diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 240469c3f2..cc9919a4a0 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -203,13 +203,13 @@ data CgLoc -- To tail-call it, assign to these locals, -- and branch to the block id -instance PlatformOutputable CgIdInfo where - pprPlatform platform (CgIdInfo { cg_id = id, cg_loc = loc }) - = ppr id <+> ptext (sLit "-->") <+> pprPlatform platform loc +instance Outputable CgIdInfo where + ppr (CgIdInfo { cg_id = id, cg_loc = loc }) + = ppr id <+> ptext (sLit "-->") <+> ppr loc -instance PlatformOutputable CgLoc where - pprPlatform platform (CmmLoc e) = ptext (sLit "cmm") <+> pprPlatform platform e - pprPlatform _ (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs +instance Outputable CgLoc where + ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e + ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs -- Sequel tells what to do with the result of this expression diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 9f87271fba..bd783a3b30 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -45,6 +45,7 @@ import Module import FastString import Outputable import StaticFlags +import Util ------------------------------------------------------------------------ -- Primitive operations and foreign calls @@ -475,11 +476,13 @@ emitPrimOp res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just mo_Wor emitPrimOp res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just mo_WordTo32) res args emitPrimOp res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args --- Copying byte arrays +-- Copying and setting byte arrays emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] = doCopyByteArrayOp src src_off dst dst_off n emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = doCopyMutableByteArrayOp src src_off dst dst_off n +emitPrimOp [] SetByteArrayOp [ba,off,len,c] = + doSetByteArrayOp ba off len c -- Population count emitPrimOp [res] PopCnt8Op [w] = emitPopCntCall res w W8 @@ -811,6 +814,18 @@ emitCopyByteArray copy src src_off dst dst_off n = do copy src dst dst_p src_p n -- ---------------------------------------------------------------------------- +-- Setting byte arrays + +-- | Takes a 'MutableByteArray#', an offset into the array, a length, +-- and a byte, and sets each of the selected bytes in the array to the +-- character. +doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doSetByteArrayOp ba off len c + = do p <- assignTempE $ cmmOffsetExpr (cmmOffsetB ba arrWordsHdrSize) off + emitMemsetCall p c len (CmmLit (mkIntCLit 1)) + +-- ---------------------------------------------------------------------------- -- Copying pointer arrays -- EZY: This code has an unusually high amount of assignTemp calls, seen diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index c147708cef..9ff4d0be07 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -218,7 +218,8 @@ emitCostCentreDecl cc = do ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS $ Module.moduleName $ cc_mod cc) - ; loc <- newStringCLit (showSDoc (ppr (costCentreSrcSpan cc))) + ; dflags <- getDynFlags + ; loc <- newStringCLit (showPpr dflags (costCentreSrcSpan cc)) -- XXX should UTF-8 encode -- All cost centres will be in the main package, since we -- don't normally use -auto-all or add SCCs to other packages. diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index ea74a03e1e..698bf32709 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -97,10 +97,9 @@ emitTickyCounter cl_info args = ifTicky $ do { dflags <- getDynFlags ; mod_name <- getModuleName - ; let platform = targetPlatform dflags - ticky_ctr_label = closureRednCountsLabel platform cl_info + ; let ticky_ctr_label = closureRednCountsLabel cl_info arg_descr = map (showTypeCategory . idType) args - fun_descr mod_name = ppr_for_ticky_name mod_name (closureName cl_info) + fun_descr mod_name = ppr_for_ticky_name dflags mod_name (closureName cl_info) ; fun_descr_lit <- newStringCLit (fun_descr mod_name) ; arg_descr_lit <- newStringCLit arg_descr ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter @@ -120,10 +119,10 @@ emitTickyCounter cl_info args -- When printing the name of a thing in a ticky file, we want to -- give the module name even for *local* things. We print -- just "x (M)" rather that "M.x" to distinguish them from the global kind. -ppr_for_ticky_name :: Module -> Name -> String -ppr_for_ticky_name mod_name name - | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name))) - | otherwise = showSDocDebug (ppr name) +ppr_for_ticky_name :: DynFlags -> Module -> Name -> String +ppr_for_ticky_name dflags mod_name name + | isInternalName name = showSDocDebug dflags (ppr name <+> (parens (ppr mod_name))) + | otherwise = showSDocDebug dflags (ppr name) -- ----------------------------------------------------------------------------- -- Ticky stack frames @@ -197,7 +196,7 @@ registerTickyCtr ctr_lbl (CmmLit (mkIntCLit 1)) ] ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) -tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode () +tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () tickyReturnOldCon arity = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") ; bumpHistogram (fsLit "RET_OLD_hst") arity } @@ -205,7 +204,7 @@ tickyReturnNewCon arity = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") ; bumpHistogram (fsLit "RET_NEW_hst") arity } -tickyUnboxedTupleReturn :: Int -> FCode () +tickyUnboxedTupleReturn :: RepArity -> FCode () tickyUnboxedTupleReturn arity = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } @@ -219,7 +218,7 @@ tickyVectoredReturn family_size -- Ticky calls -- Ticks at a *call site*: -tickyDirectCall :: Arity -> [StgArg] -> FCode () +tickyDirectCall :: RepArity -> [StgArg] -> FCode () tickyDirectCall arity args | arity == length args = tickyKnownCallExact | otherwise = do tickyKnownCallExtraArgs diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 246d57cda9..7609cfe38d 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -79,6 +79,8 @@ import FastString import Outputable import Data.Char +import Data.List +import Data.Ord import Data.Word import Data.Maybe @@ -458,7 +460,7 @@ newUnboxedTupleRegs res_ty ; ASSERT( regs `equalLength` reps ) return (regs, map primRepForeignHint reps) } where - ty_args = tyConAppArgs (repType res_ty) + UbxTupleRep ty_args = repType res_ty reps = [ rep | ty <- ty_args , let rep = typePrimRep ty @@ -573,16 +575,13 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do branches_lbls <- label_branches join_lbl branches tag_expr' <- assignTemp' tag_expr - emit =<< mk_switch tag_expr' (sortLe le branches_lbls) mb_deflt_lbl + emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches) mb_deflt_lbl lo_tag hi_tag via_C -- Sort the branches before calling mk_switch emitLabel join_lbl - where - (t1,_) `le` (t2,_) = t1 <= t2 - mk_switch :: CmmExpr -> [(ConTagZ, BlockId)] -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool @@ -736,10 +735,9 @@ emitCmmLitSwitch scrut branches deflt = do join_lbl <- newLabelC deflt_lbl <- label_code join_lbl deflt branches_lbls <- label_branches join_lbl branches - emit =<< mk_lit_switch scrut' deflt_lbl (sortLe le branches_lbls) + emit =<< mk_lit_switch scrut' deflt_lbl + (sortBy (comparing fst) branches_lbls) emitLabel join_lbl - where - le (t1,_) (t2,_) = t1 <= t2 mk_lit_switch :: CmmExpr -> BlockId -> [(Literal,BlockId)] diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs index 249861a4e4..7c392c48f2 100644 --- a/compiler/coreSyn/CoreArity.lhs +++ b/compiler/coreSyn/CoreArity.lhs @@ -663,7 +663,7 @@ arityType env (App fun arg ) -- The difference is observable using 'seq' -- arityType env (Case scrut _ _ alts) - | exprIsBottom scrut + | exprIsBottom scrut || null alts = ABot 0 -- Do not eta expand -- See Note [Dealing with bottom (1)] | otherwise @@ -829,14 +829,18 @@ etaInfoApp subst (Cast e co1) eis where co' = CoreSubst.substCo subst co1 -etaInfoApp subst (Case e b _ alts) eis - = Case (subst_expr subst e) b1 (coreAltsType alts') alts' +etaInfoApp subst (Case e b ty alts) eis + = Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts' where (subst1, b1) = substBndr subst b alts' = map subst_alt alts subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) where (subst2,bs') = substBndrs subst1 bs + + mk_alts_ty ty [] = ty + mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis + mk_alts_ty _ (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis etaInfoApp subst (Let b e) eis = Let b' (etaInfoApp subst' e eis) diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index cbb3bd877f..d2bb6ed57a 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -18,7 +18,7 @@ module CoreFVs ( exprSomeFreeVars, exprsSomeFreeVars, -- * Free variables of Rules, Vars and Ids - varTypeTyVars, varTypeTcTyVars, + varTypeTyVars, idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, idRuleVars, idRuleRhsVars, stableUnfoldingVars, ruleRhsFreeVars, rulesFreeVars, @@ -406,18 +406,8 @@ delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b -- Include coercion variables too! varTypeTyVars :: Var -> TyVarSet --- Find the type variables free in the type of the variable --- Remember, coercion variables can mention type variables... -varTypeTyVars var - | isLocalId var = tyVarsOfType (idType var) - | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars - -varTypeTcTyVars :: Var -> TyVarSet --- Find the type variables free in the type of the variable --- Remember, coercion variables can mention type variables... -varTypeTcTyVars var - | isLocalId var = tcTyVarsOfType (idType var) - | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars +-- Find the type/kind variables free in the type of the id/tyvar +varTypeTyVars var = tyVarsOfType (varType var) idFreeVars :: Id -> VarSet -- Type variables, rule variables, and inline variables @@ -452,7 +442,7 @@ stableUnfoldingVars fv_cand unf = case unf of CoreUnfolding { uf_tmpl = rhs, uf_src = src } | isStableSource src -> Just (exprSomeFreeVars fv_cand rhs) - DFunUnfolding _ _ args -> Just (exprsSomeFreeVars fv_cand args) + DFunUnfolding _ _ args -> Just (exprsSomeFreeVars fv_cand (dfunArgExprs args)) _other -> Nothing \end{code} @@ -496,7 +486,7 @@ freeVars (Case scrut bndr ty alts) scrut2 = freeVars scrut (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts - alts_fvs = foldr1 unionFVs alts_fvs_s + alts_fvs = foldr unionFVs noFVs alts_fvs_s fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), (con, args, rhs2)) diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index d40ef52e18..ba6a14739a 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -14,6 +14,10 @@ A ``lint'' pass to check for Core correctness -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details +#if __GLASGOW_HASKELL__ >= 704 +{-# OPTIONS_GHC -fprof-auto #-} +#endif + module CoreLint ( lintCoreBindings, lintUnfolding ) where #include "HsVersions.h" @@ -49,8 +53,8 @@ import Outputable import FastString import Util import Control.Monad +import MonadUtils import Data.Maybe -import Data.Traversable (traverse) \end{code} %************************************************************************ @@ -186,6 +190,12 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) ; checkL (not (isStrictId binder) || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))) (mkStrictMsg binder) + -- Check that if the binder is local, it is not marked as exported + ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag) + (mkNonTopExportedMsg binder) + -- Check that if the binder is local, it does not have an external name + ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag) + (mkNonTopExternalNameMsg binder) -- Check whether binder's specialisations contain any out-of-scope variables ; mapM_ (checkBndrIdInScope binder) bndr_vars @@ -223,8 +233,15 @@ type InCoercion = Coercion type InVar = Var type InTyVar = TyVar -type OutKind = Kind -- Substitution has been applied to this -type OutType = Type -- Substitution has been applied to this +type OutKind = Kind -- Substitution has been applied to this, + -- but has not been linted yet +type LintedKind = Kind -- Substitution applied, and type is linted + +type OutType = Type -- Substitution has been applied to this, + -- but has not been linted yet + +type LintedType = Type -- Substitution applied, and type is linted + type OutCoercion = Coercion type OutVar = Var type OutTyVar = TyVar @@ -253,8 +270,8 @@ lintCoreExpr (Lit lit) lintCoreExpr (Cast expr co) = do { expr_ty <- lintCoreExpr expr ; co' <- applySubstCo co - ; (from_ty, to_ty) <- lintCoercion co' - ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty) + ; (_, from_ty, to_ty) <- lintCoercion co' + ; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) ; return to_ty } lintCoreExpr (Tick (Breakpoint _ ids) expr) @@ -269,14 +286,14 @@ lintCoreExpr (Tick _other_tickish expr) lintCoreExpr (Let (NonRec tv (Type ty)) body) | isTyVar tv = -- See Note [Linting type lets] - do { ty' <- addLoc (RhsOf tv) $ lintInTy ty + do { ty' <- applySubstTy ty ; lintTyBndr tv $ \ tv' -> - addLoc (BodyOfLetRec [tv]) $ - extendSubstL tv' ty' $ do - { checkTyKind tv' ty' + do { addLoc (RhsOf tv) $ checkTyKind tv' ty' -- Now extend the substitution so we -- take advantage of it in the body - ; lintCoreExpr body } } + ; extendSubstL tv' ty' $ + addLoc (BodyOfLetRec [tv]) $ + lintCoreExpr body } } lintCoreExpr (Let (NonRec bndr rhs) body) | isId bndr @@ -297,21 +314,6 @@ lintCoreExpr (Let (Rec pairs) body) (_, dups) = removeDups compare bndrs lintCoreExpr e@(App _ _) -{- DV: This grievous hack (from ghc-constraint-solver should not be needed: - | Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments - -- of kind (* -> *) but its type insists on *. When we have polymorphic kinds, - -- we should do this properly - , Just dc <- isDataConWorkId_maybe x - , dc == eqBoxDataCon - , [Type arg_ty1, Type arg_ty2, co_e] <- args - = do arg_ty1' <- lintInTy arg_ty1 - arg_ty2' <- lintInTy arg_ty2 - unless (typeKind arg_ty1' `eqKind` typeKind arg_ty2') - (addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2)) - - lintCoreArg (mkCoercionType arg_ty1' arg_ty2' `mkFunTy` mkEqPred (arg_ty1', arg_ty2')) co_e - | otherwise --} = do { fun_ty <- lintCoreExpr fun ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args } where @@ -319,9 +321,8 @@ lintCoreExpr e@(App _ _) lintCoreExpr (Lam var expr) = addLoc (LambdaBodyOf var) $ - lintBinders [var] $ \ vars' -> - do { let [var'] = vars' - ; body_ty <- lintCoreExpr expr + lintBinder var $ \ var' -> + do { body_ty <- lintCoreExpr expr ; if isId var' then return (mkFunTy (idType var') body_ty) else @@ -351,17 +352,11 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = ; subst <- getTvSubst ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) - -- If the binder is an unboxed tuple type, don't put it in scope - ; let scope = if (isUnboxedTupleType (idType var)) then - pass_var - else lintAndScopeId var - ; scope $ \_ -> + ; lintAndScopeId var $ \_ -> do { -- Check the alternatives mapM_ (lintCoreAlt scrut_ty alt_ty) alts ; checkCaseAlts e scrut_ty alts ; return alt_ty } } - where - pass_var f = f var lintCoreExpr (Type ty) = do { ty' <- lintInTy ty @@ -375,7 +370,6 @@ lintCoreExpr (Coercion co) Note [Kind instantiation in coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Consider the following coercion axiom: ax_co [(k_ag :: BOX), (f_aa :: k_ag -> Constraint)] :: T k_ag f_aa ~ f_aa @@ -457,7 +451,6 @@ checkTyKind :: OutTyVar -> OutType -> LintM () -- Both args have had substitution applied checkTyKind tyvar arg_ty | isSuperKind tyvar_kind -- kind forall - -- IA0_NOTE: I added this case to handle kind foralls = lintKind arg_ty -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give @@ -466,33 +459,10 @@ checkTyKind tyvar arg_ty | otherwise -- type forall = do { arg_kind <- lintType arg_ty ; unless (arg_kind `isSubKind` tyvar_kind) - (addErrL (mkKindErrMsg tyvar arg_ty)) } + (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "xx" <+> ppr arg_kind))) } where tyvar_kind = tyVarKind tyvar --- Check that the kinds of a type variable and a coercion match, that --- is, if tv :: k then co :: t1 ~ t2 where t1 :: k and t2 :: k. -checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType) -checkTyCoKind tv co - = do { (t1,t2) <- lintCoercion co - -- t1,t2 have the same kind - ; unless (typeKind t1 `isSubKind` tyVarKind tv) - (addErrL (mkTyCoAppErrMsg tv co)) - ; return (t1,t2) } - -checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)] -checkTyCoKinds = zipWithM checkTyCoKind - -checkKiCoKind :: KindVar -> OutCoercion -> LintM Kind --- see lintCoercion (AxiomInstCo {}) and Note [Kind instantiation in coercions] -checkKiCoKind kv co - = do { ki <- lintKindCoercion co - ; unless (isSuperKind (tyVarKind kv)) (addErrL (mkTyCoAppErrMsg kv co)) - ; return ki } - -checkKiCoKinds :: [KindVar] -> [OutCoercion] -> LintM [Kind] -checkKiCoKinds = zipWithM checkKiCoKind - checkDeadIdOcc :: Id -> LintM () -- Occurrences of an Id should never be dead.... -- except when we are checking a case pattern @@ -522,9 +492,6 @@ checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () -- the simplifer correctly eliminates case that can't -- possibly match. -checkCaseAlts e _ [] - = addErrL (mkNullAltsMsg e) - checkCaseAlts e ty alts = do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) @@ -625,10 +592,7 @@ lintIdBndr :: Id -> (Id -> LintM a) -> LintM a -- ToDo: lint its rules lintIdBndr id linterF - = do { checkL (not (isUnboxedTupleType (idType id))) - (mkUnboxedTupleMsg id) - -- No variable can be bound to an unboxed tuple. - ; lintAndScopeId id $ \id' -> linterF id' } + = do { lintAndScopeId id $ \id' -> linterF id' } lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a lintAndScopeIds ids linterF @@ -649,93 +613,54 @@ lintAndScopeId id linterF %************************************************************************ %* * -\subsection[lint-monad]{The Lint monad} + Types and kinds %* * %************************************************************************ +We have a single linter for types and kinds. That is convenient +because sometimes it's not clear whether the thing we are looking +at is a type or a kind. + \begin{code} -lintInTy :: InType -> LintM OutType +lintInTy :: InType -> LintM LintedType +-- Types only, not kinds -- Check the type, and apply the substitution to it -- See Note [Linting type lets] lintInTy ty = addLoc (InType ty) $ do { ty' <- applySubstTy ty - ; k <- lintType ty' - ; lintKind k + ; _k <- lintType ty' ; return ty' } ------------------- -lintKind :: OutKind -> LintM () --- Check well-formedness of kinds: *, *->*, Either * (* -> *), etc -lintKind (TyVarTy kv) - = do { checkTyCoVarInScope kv - ; unless (isSuperKind (varType kv)) - (addErrL (hang (ptext (sLit "Badly kinded kind variable")) - 2 (ppr kv <+> dcolon <+> ppr (varType kv)))) } - -lintKind (FunTy k1 k2) - = do { lintKind k1; lintKind k2 } - -lintKind kind@(TyConApp tc kis) - | not (isSuperKind (tyConKind tc)) - = addErrL (hang (ptext (sLit "Type constructor") <+> quotes (ppr tc)) - 2 (ptext (sLit "cannot be used in a kind"))) - - | not (tyConArity tc == length kis) - = addErrL (hang (ptext (sLit "Unsaturated ype constructor in kind")) - 2 (quotes (ppr kind))) - - | otherwise - = mapM_ lintKind kis - -lintKind kind - = addErrL (hang (ptext (sLit "Malformed kind:")) - 2 (quotes (ppr kind))) - -------------------- lintTyBndrKind :: OutTyVar -> LintM () -- Handles both type and kind foralls. -lintTyBndrKind tv = - let ki = tyVarKind tv in - if isSuperKind ki - then return () -- kind forall - else lintKind ki -- type forall - ----------- -checkTcApp :: OutCoercion -> Int -> Type -> LintM OutType -checkTcApp co n ty - | Just tys <- tyConAppArgs_maybe ty - , n < length tys - = return (tys !! n) - | otherwise - = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co) - 2 (ptext (sLit "Offending type:") <+> ppr ty)) +lintTyBndrKind tv = lintKind (tyVarKind tv) ------------------- -lintType :: OutType -> LintM Kind +lintType :: OutType -> LintM LintedKind -- The returned Kind has itself been linted lintType (TyVarTy tv) = do { checkTyCoVarInScope tv - ; let kind = tyVarKind tv - ; lintKind kind - ; WARN( isSuperKind kind, msg ) - return kind } - where msg = hang (ptext (sLit "Expecting a type, but got a kind")) - 2 (ptext (sLit "Offending kind:") <+> ppr tv) + ; return (tyVarKind tv) } + -- We checked its kind when we added it to the envt lintType ty@(AppTy t1 t2) = do { k1 <- lintType t1 - ; lint_ty_app ty k1 [t2] } + ; k2 <- lintType t2 + ; lint_ty_app ty k1 [(t2,k2)] } -lintType ty@(FunTy t1 t2) - = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2] +lintType ty@(FunTy t1 t2) -- (->) has two different rules, for types and kinds + = do { k1 <- lintType t1 + ; k2 <- lintType t2 + ; lintArrow (ptext (sLit "type or kind") <+> quotes (ppr ty)) k1 k2 } lintType ty@(TyConApp tc tys) - | tyConHasKind tc -- Guards for SuperKindOon - , not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc + | not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc -- Check that primitive types are saturated -- See Note [The kind invariant] in TypeRep - = lint_ty_app ty (tyConKind tc) tys + = do { ks <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } | otherwise = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) @@ -743,49 +668,78 @@ lintType (ForAllTy tv ty) = do { lintTyBndrKind tv ; addInScopeVar tv (lintType ty) } ----------------- -lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind +lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) + +\end{code} + + +\begin{code} +lintKind :: OutKind -> LintM () +lintKind k = do { sk <- lintType k + ; unless (isSuperKind sk) + (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k) + 2 (ptext (sLit "has kind:") <+> ppr sk))) } +\end{code} + + +\begin{code} +lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind +lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2 + -- or lintarrow "coercion `blah'" k1 k2 + | isSuperKind k1 + = return superKind + | otherwise + = do { unless (okArrowArgKind k1) (addErrL (msg (ptext (sLit "argument")) k1)) + ; unless (okArrowResultKind k2) (addErrL (msg (ptext (sLit "result")) k2)) + ; return liftedTypeKind } + where + msg ar k + = vcat [ hang (ptext (sLit "Ill-kinded") <+> ar) + 2 (ptext (sLit "in") <+> what) + , what <+> ptext (sLit "kind:") <+> ppr k ] + +lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind lint_ty_app ty k tys - = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys + = lint_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys ---------------- -lint_co_app :: Coercion -> Kind -> [OutType] -> LintM () +lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind lint_co_app ty k tys - = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys - ; return () } + = lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys ---------------- -lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind --- (lint_kind_app d fun_kind arg_tys) +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = ptext (sLit "Negative type literal:") <+> integer n +lintTyLit (StrTyLit _) = return () + +lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind +-- (lint_app d fun_kind arg_tys) -- We have an application (f arg_ty1 .. arg_tyn), -- where f :: fun_kind -- Takes care of linting the OutTypes -lint_kind_app doc kfn tys = go kfn tys +lint_app doc kfn kas + = foldlM go_app kfn kas where fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) - , nest 2 (ptext (sLit "Arg types =") <+> ppr tys) ] - - go kfn [] = return kfn - go kfn (ty:tys) = - case splitKindFunTy_maybe kfn of - { Nothing -> - case splitForAllTy_maybe kfn of - { Nothing -> failWithL fail_msg - ; Just (kv, body) -> do - -- Something of kind (forall kv. body) gets instantiated - -- with ty. 'kv' is a kind variable and 'ty' is a kind. - { unless (isSuperKind (tyVarKind kv)) (addErrL fail_msg) - ; lintKind ty - ; go (substKiWith [kv] [ty] body) tys } } - ; Just (kfa, kfb) -> do - -- Something of kind (kfa -> kfb) is applied to ty. 'ty' is - -- a type accepting kind 'kfa'. - { k <- lintType ty - ; lintKind kfa - ; unless (k `isSubKind` kfa) (addErrL fail_msg) - ; go kfb tys } } + , nest 2 (ptext (sLit "Arg kinds =") <+> ppr kas) ] + + go_app kfn ka + | Just kfn' <- coreView kfn + = go_app kfn' ka + go_app (FunTy kfa kfb) (_,ka) + = do { unless (ka `isSubKind` kfa) (addErrL fail_msg) + ; return kfb } + + go_app (ForAllTy kv kfn) (ta,ka) + = do { unless (ka `isSubKind` tyVarKind kv) (addErrL fail_msg) + ; return (substKiWith [kv] [ta] kfn) } + + go_app _ _ = failWithL fail_msg \end{code} %************************************************************************ @@ -804,54 +758,37 @@ lintInCo co ; _ <- lintCoercion co' ; return co' } -lintKindCoercion :: OutCoercion -> LintM OutKind --- Kind coercions are only reflexivity because they mean kind --- instantiation. See Note [Kind coercions] in Coercion -lintKindCoercion (Refl k) - = do { lintKind k - ; return k } -lintKindCoercion co - = failWithL (hang (ptext (sLit "Non-refl kind coercion")) - 2 (ppr co)) - -lintCoercion :: OutCoercion -> LintM (OutType, OutType) +lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType) -- Check the kind of a coercion term, returning the kind -- Post-condition: the returned OutTypes are lint-free -- and have the same kind as each other lintCoercion (Refl ty) - = do { _ <- lintType ty - ; return (ty, ty) } + = do { k <- lintType ty + ; return (k, ty, ty) } lintCoercion co@(TyConAppCo tc cos) - = do -- We use the kind of the type constructor to know how many - -- kind coercions we have (one kind coercion for one kind - -- instantiation). - { let ki | tc `hasKey` funTyConKey && length cos == 2 - = mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind - -- It's a fully applied function, so we must use the - -- most permissive type for the arrow constructor - | otherwise = tyConKind tc - (kvs, _) = splitForAllTys ki - (cokis, cotys) = splitAt (length kvs) cos - -- kis are the kind instantiations of tc - ; kis <- mapM lintKindCoercion cokis - ; (ss,ts) <- mapAndUnzipM lintCoercion cotys - ; lint_co_app co ki (kis ++ ss) - ; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) } + | tc `hasKey` funTyConKey + , [co1,co2] <- cos + = do { (k1,s1,t1) <- lintCoercion co1 + ; (k2,s2,t2) <- lintCoercion co2 + ; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2 + ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2) } + | otherwise + = do { (ks,ss,ts) <- mapAndUnzip3M lintCoercion cos + ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks) + ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts) } lintCoercion co@(AppCo co1 co2) - = do { (s1,t1) <- lintCoercion co1 - ; (s2,t2) <- lintCoercion co2 - ; lint_co_app co (typeKind s1) [s2] - ; return (mkAppTy s1 s2, mkAppTy t1 t2) } - -lintCoercion (ForAllCo v co) - = do { let kind = tyVarKind v - -- lintKind when type forall, otherwise we are a kind forall - ; unless (isSuperKind kind) (lintKind kind) - ; (s,t) <- addInScopeVar v (lintCoercion co) - ; return (ForAllTy v s, ForAllTy v t) } + = do { (k1,s1,t1) <- lintCoercion co1 + ; (k2,s2,t2) <- lintCoercion co2 + ; rk <- lint_co_app co k1 [(s2,k2)] + ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2) } + +lintCoercion (ForAllCo tv co) + = do { lintTyBndrKind tv + ; (k, s, t) <- addInScopeVar tv (lintCoercion co) + ; return (k, mkForAllTy tv s, mkForAllTy tv t) } lintCoercion (CoVarCo cv) | not (isCoVar cv) @@ -860,58 +797,87 @@ lintCoercion (CoVarCo cv) | otherwise = do { checkTyCoVarInScope cv ; cv' <- lookupIdInScope cv - ; return (coVarKind cv') } - -lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = ktvs - , co_ax_lhs = lhs - , co_ax_rhs = rhs }) - cos) - = ASSERT2 (not (any isKiVar tvs), ppr ktvs) - do -- see Note [Kind instantiation in coercions] - { kis <- checkKiCoKinds kvs kcos - ; let tvs' = map (updateTyVarKind (Type.substTy subst)) tvs - subst = zipOpenTvSubst kvs kis - ; (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs' tcos) - ; return (substTyWith ktvs (kis ++ tys1) lhs, - substTyWith ktvs (kis ++ tys2) rhs) } - where - (kvs, tvs) = splitKiTyVars ktvs - (kcos, tcos) = splitAt (length kvs) cos + ; let (s,t) = coVarKind cv' + k = typeKind s + ; when (isSuperKind k) $ + checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality")) + 2 (ppr cv)) + ; return (k, s, t) } lintCoercion (UnsafeCo ty1 ty2) - = do { _ <- lintType ty1 - ; _ <- lintType ty2 - ; return (ty1, ty2) } + = do { k1 <- lintType ty1 + ; _k2 <- lintType ty2 +-- ; unless (k1 `eqKind` k2) $ +-- failWithL (hang (ptext (sLit "Unsafe coercion changes kind")) +-- 2 (ppr co)) + ; return (k1, ty1, ty2) } lintCoercion (SymCo co) - = do { (ty1, ty2) <- lintCoercion co - ; return (ty2, ty1) } + = do { (k, ty1, ty2) <- lintCoercion co + ; return (k, ty2, ty1) } lintCoercion co@(TransCo co1 co2) - = do { (ty1a, ty1b) <- lintCoercion co1 - ; (ty2a, ty2b) <- lintCoercion co2 + = do { (k1, ty1a, ty1b) <- lintCoercion co1 + ; (_, ty2a, ty2b) <- lintCoercion co2 ; checkL (ty1b `eqType` ty2a) (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) - ; return (ty1a, ty2b) } - -lintCoercion the_co@(NthCo d co) - = do { (s,t) <- lintCoercion co - ; sn <- checkTcApp the_co d s - ; tn <- checkTcApp the_co d t - ; return (sn, tn) } + ; return (k1, ty1a, ty2b) } + +lintCoercion the_co@(NthCo n co) + = do { (_,s,t) <- lintCoercion co + ; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of + (Just (tc_s, tys_s), Just (tc_t, tys_t)) + | tc_s == tc_t + , tys_s `equalLength` tys_t + , n < length tys_s + -> return (ks, ts, tt) + where + ts = tys_s !! n + tt = tys_t !! n + ks = typeKind ts + + _ -> failWithL (hang (ptext (sLit "Bad getNth:")) + 2 (ppr the_co $$ ppr s $$ ppr t)) } lintCoercion (InstCo co arg_ty) - = do { co_tys <- lintCoercion co - ; arg_kind <- lintType arg_ty - ; case splitForAllTy_maybe `traverse` toPair co_tys of - Just (Pair (tv1,ty1) (tv2,ty2)) + = do { (k,s,t) <- lintCoercion co + ; arg_kind <- lintType arg_ty + ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of + (Just (tv1,ty1), Just (tv2,ty2)) | arg_kind `isSubKind` tyVarKind tv1 - -> return (substTyWith [tv1] [arg_ty] ty1, - substTyWith [tv2] [arg_ty] ty2) + -> return (k, substTyWith [tv1] [arg_ty] ty1, + substTyWith [tv2] [arg_ty] ty2) | otherwise -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) - Nothing -> failWithL (ptext (sLit "Bad argument of inst")) } + _ -> failWithL (ptext (sLit "Bad argument of inst")) } + +lintCoercion co@(AxiomInstCo (CoAxiom { co_ax_tvs = ktvs + , co_ax_lhs = lhs + , co_ax_rhs = rhs }) + cos) + = do { -- See Note [Kind instantiation in coercions] + unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths"))) + ; in_scope <- getInScope + ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv + ; (subst_l, subst_r) <- foldlM check_ki + (empty_subst, empty_subst) + (ktvs `zip` cos) + ; let lhs' = Type.substTy subst_l lhs + rhs' = Type.substTy subst_r rhs + ; return (typeKind lhs', lhs', rhs') } + where + bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what) + 2 (ppr co)) + + check_ki (subst_l, subst_r) (ktv, co) + = do { (k, t1, t2) <- lintCoercion co + ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv) + -- Using subst_l is ok, because subst_l and subst_r + -- must agree on kind equalities + ; unless (k `isSubKind` ktv_kind) (bad_ax (ptext (sLit "check_ki2"))) + ; return (Type.extendTvSubst subst_l ktv t1, + Type.extendTvSubst subst_r ktv t2) } \end{code} %************************************************************************ @@ -1032,6 +998,9 @@ updateTvSubst subst' m = getTvSubst :: LintM TvSubst getTvSubst = LintM (\ _ subst errs -> (Just subst, errs)) +getInScope :: LintM InScopeSet +getInScope = LintM (\ _ subst errs -> (Just (getTvInScope subst), errs)) + applySubstTy :: InType -> LintM OutType applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) } @@ -1055,7 +1024,7 @@ lookupIdInScope id Nothing -> do { addErrL out_of_scope ; return id } } where - out_of_scope = ppr id <+> ptext (sLit "is out of scope") + out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope") oneTupleDataConId :: Id -- Should not happen @@ -1075,7 +1044,7 @@ checkInScope :: SDoc -> Var -> LintM () checkInScope loc_msg var = do { subst <- getTvSubst ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) - (hsep [ppr var, loc_msg]) } + (hsep [pprBndr LetBind var, loc_msg]) } checkTys :: OutType -> OutType -> MsgDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage @@ -1135,11 +1104,6 @@ pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] ------------------------------------------------------ -- Messages for case expressions -mkNullAltsMsg :: CoreExpr -> MsgDoc -mkNullAltsMsg e - = hang (text "Case expression with no alternatives:") - 4 (ppr e) - mkDefaultArgsMsg :: [Var] -> MsgDoc mkDefaultArgsMsg args = hang (text "DEFAULT case with binders") @@ -1225,14 +1189,6 @@ mkLetErr bndr rhs hang (ptext (sLit "Rhs:")) 4 (ppr rhs)] -mkTyCoAppErrMsg :: TyVar -> Coercion -> MsgDoc -mkTyCoAppErrMsg tyvar arg_co - = vcat [ptext (sLit "Kinds don't match in lifted coercion application:"), - hang (ptext (sLit "Type variable:")) - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (ptext (sLit "Arg coercion:")) - 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] - mkTyAppMsg :: Type -> Type -> MsgDoc mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", @@ -1263,6 +1219,13 @@ mkStrictMsg binder hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)] ] +mkNonTopExportedMsg :: Id -> MsgDoc +mkNonTopExportedMsg binder + = hsep [ptext (sLit "Non-top-level binder is marked as exported:"), ppr binder] + +mkNonTopExternalNameMsg :: Id -> MsgDoc +mkNonTopExternalNameMsg binder + = hsep [ptext (sLit "Non-top-level binder has an external name:"), ppr binder] mkKindErrMsg :: TyVar -> Type -> MsgDoc mkKindErrMsg tyvar arg_ty @@ -1285,17 +1248,14 @@ mkArityMsg binder ] where (StrictSig dmd_ty) = idStrictness binder -mkUnboxedTupleMsg :: Id -> MsgDoc -mkUnboxedTupleMsg binder - = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder], - hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]] - -mkCastErr :: Type -> Type -> MsgDoc -mkCastErr from_ty expr_ty +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc +mkCastErr expr co from_ty expr_ty = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), ptext (sLit "From-type:") <+> ppr from_ty, - ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty - ] + ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty, + ptext (sLit "Actual enclosed expr:") <+> ppr expr, + ptext (sLit "Coercion used in cast:") <+> ppr co + ] dupVars :: [[Var]] -> MsgDoc dupVars vars @@ -1307,56 +1267,3 @@ dupExtVars vars = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) 2 (ppr vars) \end{code} - --------------- DEAD CODE ------------------- - -------------------- -checkCoKind :: CoVar -> OutCoercion -> LintM () --- Both args have had substitution applied -checkCoKind covar arg_co - = do { (s2,t2) <- lintCoercion arg_co - ; unless (s1 `eqType` s2 && t1 `coreEqType` t2) - (addErrL (mkCoAppErrMsg covar arg_co)) } - where - (s1,t1) = coVarKind covar - -lintCoVarKind :: OutCoVar -> LintM () --- Check the kind of a coercion binder -lintCoVarKind tv - = do { (ty1,ty2) <- lintSplitCoVar tv - ; lintEqType ty1 ty2 - - -------------------- -lintSplitCoVar :: CoVar -> LintM (Type,Type) -lintSplitCoVar cv - = case coVarKind_maybe cv of - Just ts -> return ts - Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:") - , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))]) - -mkCoVarLetErr :: CoVar -> Coercion -> MsgDoc -mkCoVarLetErr covar co - = vcat [ptext (sLit "Bad `let' binding for coercion variable:"), - hang (ptext (sLit "Coercion variable:")) - 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)), - hang (ptext (sLit "Arg coercion:")) - 4 (ppr co)] - -mkCoAppErrMsg :: CoVar -> Coercion -> MsgDoc -mkCoAppErrMsg covar arg_co - = vcat [ptext (sLit "Kinds don't match in coercion application:"), - hang (ptext (sLit "Coercion variable:")) - 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)), - hang (ptext (sLit "Arg coercion:")) - 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] - - -mkCoAppMsg :: Type -> Coercion -> MsgDoc -mkCoAppMsg ty arg_co - = vcat [text "Illegal type application:", - hang (ptext (sLit "exp type:")) - 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), - hang (ptext (sLit "arg type:")) - 4 (ppr arg_co <+> dcolon <+> ppr (coercionKind arg_co))] - diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index ed288096f7..7680bab292 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -6,30 +6,27 @@ Core pass to saturate constructors and PrimOps \begin{code} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module CorePrep ( - corePrepPgm, corePrepExpr + corePrepPgm, corePrepExpr, cvtLitInteger ) where #include "HsVersions.h" +import HscTypes import PrelNames import CoreUtils import CoreArity import CoreFVs -import CoreMonad ( endPass, CoreToDo(..) ) +import CoreMonad ( endPass, CoreToDo(..) ) import CoreSyn import CoreSubst import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here import Type import Literal import Coercion +import TcEnv +import TcRnMonad import TyCon import Demand import Var @@ -49,11 +46,10 @@ import DynFlags import Util import Pair import Outputable -import MonadUtils import FastString import Config import Data.Bits -import Data.List ( mapAccumL ) +import Data.List ( mapAccumL ) import Control.Monad \end{code} @@ -69,15 +65,15 @@ The goal of this pass is to prepare for code generation. are always variables. * Use case for strict arguments: - f E ==> case E of x -> f x - (where f is strict) + f E ==> case E of x -> f x + (where f is strict) * Use let for non-trivial lazy arguments - f E ==> let x = E in f x - (were f is lazy and x is non-trivial) + f E ==> let x = E in f x + (were f is lazy and x is non-trivial) 3. Similarly, convert any unboxed lets into cases. - [I'm experimenting with leaving 'ok-for-speculation' + [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form right up to this point.] 4. Ensure that *value* lambdas only occur as the RHS of a binding @@ -87,11 +83,11 @@ The goal of this pass is to prepare for code generation. 5. [Not any more; nuked Jun 2002] Do the seq/par munging. 6. Clone all local Ids. - This means that all such Ids are unique, rather than the + This means that all such Ids are unique, rather than the weaker guarantee of no clashes which the simplifier provides. And that is what the code generator needs. - We don't clone TyVars or CoVars. The code gen doesn't need that, + We don't clone TyVars or CoVars. The code gen doesn't need that, and doing so would be tiresome because then we'd need to substitute in types and coercions. @@ -99,15 +95,15 @@ The goal of this pass is to prepare for code generation. rather like the cloning step above. 8. Inject bindings for the "implicit" Ids: - * Constructor wrappers - * Constructor workers + * Constructor wrappers + * Constructor workers We want curried definitions for all of these in case they aren't inlined by some caller. - + 9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs -10. Convert (LitInteger i mkInteger) into the core representation - for the Integer i. Normally this uses the mkInteger Id, but if +10. Convert (LitInteger i t) into the core representation + for the Integer i. Normally this uses mkInteger, but if we are using the integer-gmp implementation then there is a special case where we use the S# constructor for Integers that are in the range of Int. @@ -116,24 +112,24 @@ This is all done modulo type applications and abstractions, so that when type erasure is done for conversion to STG, we don't end up with any trivial or useless bindings. - + Invariants ~~~~~~~~~~ Here is the syntax of the Core produced by CorePrep: - Trivial expressions - triv ::= lit | var - | triv ty | /\a. triv + Trivial expressions + triv ::= lit | var + | triv ty | /\a. triv | truv co | /\c. triv | triv |> co Applications app ::= lit | var | app triv | app ty | app co | app |> co Expressions - body ::= app + body ::= app | let(rec) x = rhs in body -- Boxed only | case body of pat -> body - | /\a. body | /\c. body + | /\a. body | /\c. body | body |> co Right hand sides (only place where value lambdas can occur) @@ -143,48 +139,50 @@ We define a synonym for each of these non-terminals. Functions with the corresponding name produce a result in that syntax. \begin{code} -type CpeTriv = CoreExpr -- Non-terminal 'triv' -type CpeApp = CoreExpr -- Non-terminal 'app' -type CpeBody = CoreExpr -- Non-terminal 'body' -type CpeRhs = CoreExpr -- Non-terminal 'rhs' +type CpeTriv = CoreExpr -- Non-terminal 'triv' +type CpeApp = CoreExpr -- Non-terminal 'app' +type CpeBody = CoreExpr -- Non-terminal 'body' +type CpeRhs = CoreExpr -- Non-terminal 'rhs' \end{code} %************************************************************************ -%* * - Top level stuff -%* * +%* * + Top level stuff +%* * %************************************************************************ \begin{code} -corePrepPgm :: DynFlags -> CoreProgram -> [TyCon] -> IO CoreProgram -corePrepPgm dflags binds data_tycons = do +corePrepPgm :: DynFlags -> HscEnv -> CoreProgram -> [TyCon] -> IO CoreProgram +corePrepPgm dflags hsc_env binds data_tycons = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' + initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env let implicit_binds = mkDataConWorkers data_tycons -- NB: we must feed mkImplicitBinds through corePrep too -- so that they are suitably cloned and eta-expanded binds_out = initUs_ us $ do - floats1 <- corePrepTopBinds binds - floats2 <- corePrepTopBinds implicit_binds + floats1 <- corePrepTopBinds initialCorePrepEnv binds + floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds return (deFloatTop (floats1 `appendFloats` floats2)) endPass dflags CorePrep binds_out [] return binds_out -corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr -corePrepExpr dflags expr = do +corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr +corePrepExpr dflags hsc_env expr = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - let new_expr = initUs_ us (cpeBodyNF emptyCorePrepEnv expr) + initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env + let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) return new_expr -corePrepTopBinds :: [CoreBind] -> UniqSM Floats +corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats -- Note [Floating out of top level bindings] -corePrepTopBinds binds - = go emptyCorePrepEnv binds +corePrepTopBinds initialCorePrepEnv binds + = go initialCorePrepEnv binds where go _ [] = return emptyFloats go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind @@ -194,8 +192,8 @@ corePrepTopBinds binds mkDataConWorkers :: [TyCon] -> [CoreBind] -- See Note [Data constructor workers] mkDataConWorkers data_tycons - = [ NonRec id (Var id) -- The ice is thin here, but it works - | tycon <- data_tycons, -- CorePrep will eta-expand it + = [ NonRec id (Var id) -- The ice is thin here, but it works + | tycon <- data_tycons, -- CorePrep will eta-expand it data_con <- tyConDataCons tycon, let id = dataConWorkId data_con ] \end{code} @@ -203,17 +201,17 @@ mkDataConWorkers data_tycons Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings -Consider x = length [True,False] +Consider x = length [True,False] We want to get - s1 = False : [] - s2 = True : s1 - x = length s2 + s1 = False : [] + s2 = True : s1 + x = length s2 We return a *list* of bindings, because we may start with - x* = f (g y) + x* = f (g y) where x is demanded, in which case we want to finish with - a = g y - x* = f a + a = g y + x* = f a And then x will actually end up case-bound Note [CafInfo and floating] @@ -237,9 +235,9 @@ b) The top-level binding is marked NoCafRefs. This really happens So what we *want* is sat [NoCafRefs] = \xy. retry x y $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah... - + So, gruesomely, we must set the NoCafRefs flag on the sat bindings, - *and* substutite the modified 'sat' into the old RHS. + *and* substutite the modified 'sat' into the old RHS. It should be the case that 'sat' is itself [NoCafRefs] (a value, no cafs) else the original top-level binding would not itself have been @@ -247,7 +245,7 @@ b) The top-level binding is marked NoCafRefs. This really happens consistentCafInfo will find this. This is all very gruesome and horrible. It would be better to figure -out CafInfo later, after CorePrep. We'll do that in due course. +out CafInfo later, after CorePrep. We'll do that in due course. Meanwhile this horrible hack works. @@ -256,7 +254,7 @@ Note [Data constructor workers] Create any necessary "implicit" bindings for data con workers. We create the rather strange (non-recursive!) binding - $wC = \x y -> $wC x y + $wC = \x y -> $wC x y i.e. a curried constructor that allocates. This means that we can treat the worker for a constructor like any other function in the rest @@ -285,7 +283,7 @@ After specialisation and SpecConstr, we would get something like this: f :: Show b => Int -> (Int, b -> Maybe Int -> Int) f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) where - {-# RULES g $dBool = g$Bool + {-# RULES g $dBool = g$Bool g $dUnit = g$Unit #-} g = ... {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} @@ -331,28 +329,28 @@ Into this one: %************************************************************************ -%* * - The main code -%* * +%* * + The main code +%* * %************************************************************************ \begin{code} cpeBind :: TopLevelFlag - -> CorePrepEnv -> CoreBind - -> UniqSM (CorePrepEnv, Floats) + -> CorePrepEnv -> CoreBind + -> UniqSM (CorePrepEnv, Floats) cpeBind top_lvl env (NonRec bndr rhs) = do { (_, bndr1) <- cpCloneBndr env bndr ; let is_strict = isStrictDmd (idDemandInfo bndr) is_unlifted = isUnLiftedType (idType bndr) - ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive - (is_strict || is_unlifted) - env bndr1 rhs + ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive + (is_strict || is_unlifted) + env bndr1 rhs ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2 -- We want bndr'' in the envt, because it records -- the evaluated-ness of the binder - ; return (extendCorePrepEnv env bndr bndr2, - addFloat floats new_float) } + ; return (extendCorePrepEnv env bndr bndr2, + addFloat floats new_float) } cpeBind top_lvl env (Rec pairs) = do { let (bndrs,rhss) = unzip pairs @@ -361,20 +359,20 @@ cpeBind top_lvl env (Rec pairs) ; let (floats_s, bndrs2, rhss2) = unzip3 stuff all_pairs = foldrOL add_float (bndrs2 `zip` rhss2) - (concatFloats floats_s) + (concatFloats floats_s) ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), - unitFloat (FloatLet (Rec all_pairs))) } + unitFloat (FloatLet (Rec all_pairs))) } where - -- Flatten all the floats, and the currrent - -- group into a single giant Rec + -- Flatten all the floats, and the currrent + -- group into a single giant Rec add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 add_float b _ = pprPanic "cpeBind" (ppr b) --------------- cpePair :: TopLevelFlag -> RecFlag -> RhsDemand - -> CorePrepEnv -> Id -> CoreExpr - -> UniqSM (Floats, Id, CpeRhs) + -> CorePrepEnv -> Id -> CoreExpr + -> UniqSM (Floats, Id, CpeRhs) -- Used for all bindings cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs = do { (floats1, rhs1) <- cpeRhsE env rhs @@ -384,26 +382,26 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs -- Make the arity match up ; (floats3, rhs') - <- if manifestArity rhs1 <= arity - then return (floats2, cpeEtaExpand arity rhs2) - else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) - -- Note [Silly extra arguments] - (do { v <- newVar (idType bndr) - ; let float = mkFloat False False v rhs2 - ; return ( addFloat floats2 float + <- if manifestArity rhs1 <= arity + then return (floats2, cpeEtaExpand arity rhs2) + else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) + -- Note [Silly extra arguments] + (do { v <- newVar (idType bndr) + ; let float = mkFloat False False v rhs2 + ; return ( addFloat floats2 float , cpeEtaExpand arity (Var v)) }) - -- Record if the binder is evaluated - -- and otherwise trim off the unfolding altogether - -- It's not used by the code generator; getting rid of it reduces - -- heap usage and, since we may be changing uniques, we'd have - -- to substitute to keep it right + -- Record if the binder is evaluated + -- and otherwise trim off the unfolding altogether + -- It's not used by the code generator; getting rid of it reduces + -- heap usage and, since we may be changing uniques, we'd have + -- to substitute to keep it right ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding - | otherwise = bndr `setIdUnfolding` noUnfolding + | otherwise = bndr `setIdUnfolding` noUnfolding ; return (floats3, bndr', rhs') } where - arity = idArity bndr -- We must match this arity + arity = idArity bndr -- We must match this arity --------------------- float_from_rhs floats rhs @@ -418,7 +416,7 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs | otherwise = dont_float floats rhs --------------------- - float_top floats rhs -- Urhgh! See Note [CafInfo and floating] + float_top floats rhs -- Urhgh! See Note [CafInfo and floating] | mayHaveCafRefs (idCafInfo bndr) , allLazyTop floats = return (floats, rhs) @@ -437,46 +435,46 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs -- But: rhs1 might have lambdas, and we can't -- put them inside a wrapBinds = do { body <- rhsToBodyNF rhs - ; return (emptyFloats, wrapBinds floats body) } + ; return (emptyFloats, wrapBinds floats body) } {- Note [Silly extra arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we had this - f{arity=1} = \x\y. e + f{arity=1} = \x\y. e We *must* match the arity on the Id, so we have to generate f' = \x\y. e - f = \x. f' x + f = \x. f' x It's a bizarre case: why is the arity on the Id wrong? Reason -(in the days of __inline_me__): +(in the days of __inline_me__): f{arity=0} = __inline_me__ (let v = expensive in \xy. e) When InlineMe notes go away this won't happen any more. But it seems good for CorePrep to be robust. -} -- --------------------------------------------------------------------------- --- CpeRhs: produces a result satisfying CpeRhs +-- CpeRhs: produces a result satisfying CpeRhs -- --------------------------------------------------------------------------- cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- If --- e ===> (bs, e') --- then --- e = let bs in e' (semantically, that is!) +-- e ===> (bs, e') +-- then +-- e = let bs in e' (semantically, that is!) -- -- For example --- f (g x) ===> ([v = g x], f v) +-- f (g x) ===> ([v = g x], f v) cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) -cpeRhsE env (Lit (LitInteger i mk_integer)) - = cpeRhsE env (cvtLitInteger i mk_integer) +cpeRhsE env (Lit (LitInteger i _)) + = cpeRhsE env (cvtLitInteger (getMkIntegerId env) i) cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr cpeRhsE env (Var f `App` _ `App` arg) - | f `hasKey` lazyIdKey -- Replace (lazy a) by a - = cpeRhsE env arg -- See Note [lazyId magic] in MkId + | f `hasKey` lazyIdKey -- Replace (lazy a) by a + = cpeRhsE env arg -- See Note [lazyId magic] in MkId cpeRhsE env expr@(App {}) = cpeApp env expr @@ -504,8 +502,8 @@ cpeRhsE env (Cast expr co) cpeRhsE env expr@(Lam {}) = do { let (bndrs,body) = collectBinders expr ; (env', bndrs') <- cpCloneBndrs env bndrs - ; body' <- cpeBodyNF env' body - ; return (emptyFloats, mkLams bndrs' body') } + ; body' <- cpeBodyNF env' body + ; return (emptyFloats, mkLams bndrs' body') } cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut @@ -520,13 +518,13 @@ cpeRhsE env (Case scrut bndr ty alts) ; rhs' <- cpeBodyNF env2 rhs ; return (con, bs', rhs') } -cvtLitInteger :: Integer -> Id -> CoreExpr +cvtLitInteger :: Id -> Integer -> CoreExpr -- Here we convert a literal Integer to the low-level -- represenation. Exactly how we do this depends on the --- library that implements Integer. If it's GMP we --- use the S# data constructor for small literals. +-- library that implements Integer. If it's GMP we +-- use the S# data constructor for small literals. -- See Note [Integer literals] in Literal -cvtLitInteger i mk_integer +cvtLitInteger mk_integer i | cIntegerLibraryType == IntegerGMP , inIntRange i -- Special case for small integers in GMP = mkConApp integerGmpSDataCon [Lit (mkMachInt i)] @@ -544,11 +542,11 @@ cvtLitInteger i mk_integer mask = 2 ^ bits - 1 -- --------------------------------------------------------------------------- --- CpeBody: produces a result satisfying CpeBody +-- CpeBody: produces a result satisfying CpeBody -- --------------------------------------------------------------------------- cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody -cpeBodyNF env expr +cpeBodyNF env expr = do { (floats, body) <- cpeBody env expr ; return (wrapBinds floats body) } @@ -562,7 +560,7 @@ cpeBody env expr -------- rhsToBodyNF :: CpeRhs -> UniqSM CpeBody rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs - ; return (wrapBinds floats body) } + ; return (wrapBinds floats body) } -------- rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) @@ -582,12 +580,12 @@ rhsToBody (Cast e co) rhsToBody expr@(Lam {}) | Just no_lam_result <- tryEtaReducePrep bndrs body = return (emptyFloats, no_lam_result) - | all isTyVar bndrs -- Type lambdas are ok + | all isTyVar bndrs -- Type lambdas are ok = return (emptyFloats, expr) - | otherwise -- Some value lambdas + | otherwise -- Some value lambdas = do { fn <- newVar (exprType expr) ; let rhs = cpeEtaExpand (exprArity expr) expr - float = FloatLet (NonRec fn rhs) + float = FloatLet (NonRec fn rhs) ; return (unitFloat float, Var fn) } where (bndrs,body) = collectBinders expr @@ -597,19 +595,19 @@ rhsToBody expr = return (emptyFloats, expr) -- --------------------------------------------------------------------------- --- CpeApp: produces a result satisfying CpeApp +-- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- May return a CpeRhs because of saturating primops -cpeApp env expr +cpeApp env expr = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0 - ; MASSERT(null ss) -- make sure we used all the strictness info + ; MASSERT(null ss) -- make sure we used all the strictness info - -- Now deal with the function + -- Now deal with the function ; case head of Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth - ; return (floats, sat_app) } + ; return (floats, sat_app) } _other -> return (floats, app) } where @@ -620,14 +618,14 @@ cpeApp env expr -- has a constructor or primop at the head. collect_args - :: CoreExpr - -> Int -- Current app depth - -> UniqSM (CpeApp, -- The rebuilt expression - (CoreExpr,Int), -- The head of the application, - -- and no. of args it was applied to - Type, -- Type of the whole expr - Floats, -- Any floats we pulled out - [Demand]) -- Remaining argument demands + :: CoreExpr + -> Int -- Current app depth + -> UniqSM (CpeApp, -- The rebuilt expression + (CoreExpr,Int), -- The head of the application, + -- and no. of args it was applied to + Type, -- Type of the whole expr + Floats, -- Any floats we pulled out + [Demand]) -- Remaining argument demands collect_args (App fun arg@(Type arg_ty)) depth = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth @@ -639,7 +637,7 @@ cpeApp env expr collect_args (App fun arg) depth = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) - ; let + ; let (ss1, ss_rest) = case ss of (ss1:ss_rest) -> (ss1, ss_rest) [] -> (lazyDmd, []) @@ -649,42 +647,42 @@ cpeApp env expr ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) } - collect_args (Var v) depth + collect_args (Var v) depth = do { v1 <- fiddleCCall v ; let v2 = lookupCorePrepEnv env v1 ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) } - where - stricts = case idStrictness v of - StrictSig (DmdType _ demands _) - | listLengthCmp demands depth /= GT -> demands - -- length demands <= depth - | otherwise -> [] - -- If depth < length demands, then we have too few args to - -- satisfy strictness info so we have to ignore all the - -- strictness info, e.g. + (error "urk") - -- Here, we can't evaluate the arg strictly, because this - -- partial application might be seq'd + where + stricts = case idStrictness v of + StrictSig (DmdType _ demands _) + | listLengthCmp demands depth /= GT -> demands + -- length demands <= depth + | otherwise -> [] + -- If depth < length demands, then we have too few args to + -- satisfy strictness info so we have to ignore all the + -- strictness info, e.g. + (error "urk") + -- Here, we can't evaluate the arg strictly, because this + -- partial application might be seq'd collect_args (Cast fun co) depth = do { let Pair _ty1 ty2 = coercionKind co ; (fun', hd, _, floats, ss) <- collect_args fun depth ; return (Cast fun' co, hd, ty2, floats, ss) } - + collect_args (Tick tickish fun) depth | ignoreTickish tickish -- Drop these notes altogether = collect_args fun depth -- They aren't used by the code generator - -- N-variable fun, better let-bind it + -- N-variable fun, better let-bind it collect_args fun depth = do { (fun_floats, fun') <- cpeArg env True fun ty - -- The True says that it's sure to be evaluated, - -- so we'll end up case-binding it + -- The True says that it's sure to be evaluated, + -- so we'll end up case-binding it ; return (fun', (fun', depth), ty, fun_floats, []) } where - ty = exprType fun + ty = exprType fun -- --------------------------------------------------------------------------- --- CpeArg: produces a result satisfying CpeArg +-- CpeArg: produces a result satisfying CpeArg -- --------------------------------------------------------------------------- -- This is where we arrange that a non-trivial argument is let-bound @@ -692,19 +690,19 @@ cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type -> UniqSM (Floats, CpeTriv) cpeArg env is_strict arg arg_ty = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda - ; (floats2, arg2) <- if want_float floats1 arg1 - then return (floats1, arg1) - else do { body1 <- rhsToBodyNF arg1 - ; return (emptyFloats, wrapBinds floats1 body1) } - -- Else case: arg1 might have lambdas, and we can't - -- put them inside a wrapBinds + ; (floats2, arg2) <- if want_float floats1 arg1 + then return (floats1, arg1) + else do { body1 <- rhsToBodyNF arg1 + ; return (emptyFloats, wrapBinds floats1 body1) } + -- Else case: arg1 might have lambdas, and we can't + -- put them inside a wrapBinds ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument then return (floats2, arg2) else do { v <- newVar arg_ty ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 - arg_float = mkFloat is_strict is_unlifted v arg3 + arg_float = mkFloat is_strict is_unlifted v arg3 ; return (addFloat floats2 arg_float, varToCoreExpr v) } } where is_unlifted = isUnLiftedType arg_ty @@ -739,13 +737,13 @@ maybeSaturate fn expr n_args -- A gruesome special case = saturateDataToTag sat_expr - | hasNoBinding fn -- There's no binding + | hasNoBinding fn -- There's no binding = return sat_expr - | otherwise + | otherwise = return expr where - fn_arity = idArity fn + fn_arity = idArity fn excess_arity = fn_arity - n_args sat_expr = cpeEtaExpand excess_arity expr @@ -760,7 +758,7 @@ saturateDataToTag sat_expr eval_data2tag_arg :: CpeApp -> UniqSM CpeBody eval_data2tag_arg app@(fun `App` arg) | exprIsHNF arg -- Includes nullary constructors - = return app -- The arg is evaluated + = return app -- The arg is evaluated | otherwise -- Arg not evaluated, so evaluate it = do { arg_id <- newVar (exprType arg) ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding @@ -771,8 +769,8 @@ saturateDataToTag sat_expr = do { app' <- eval_data2tag_arg app ; return (Tick t app') } - eval_data2tag_arg other -- Should not happen - = pprPanic "eval_data2tag" (ppr other) + eval_data2tag_arg other -- Should not happen + = pprPanic "eval_data2tag" (ppr other) \end{code} Note [dataToTag magic] @@ -786,9 +784,9 @@ of the scope of a `seq`, or dropped the `seq` altogether. %************************************************************************ -%* * - Simple CoreSyn operations -%* * +%* * + Simple CoreSyn operations +%* * %************************************************************************ \begin{code} @@ -810,7 +808,7 @@ cpe_ExprIsTrivial _ = False \end{code} -- ----------------------------------------------------------------------------- --- Eta reduction +-- Eta reduction -- ----------------------------------------------------------------------------- Note [Eta expansion] @@ -840,14 +838,14 @@ It turns out to be much much easier to do eta expansion on the eta expander: given a CpeRhs, it must return a CpeRhs. For example here is what we do not want: - f = /\a -> g (h 3) -- h has arity 2 + f = /\a -> g (h 3) -- h has arity 2 After ANFing we get - f = /\a -> let s = h 3 in g s + f = /\a -> let s = h 3 in g s and now we do NOT want eta expansion to give - f = /\a -> \ y -> (let s = h 3 in g s) y + f = /\a -> \ y -> (let s = h 3 in g s) y Instead CoreArity.etaExpand gives - f = /\a -> \y -> let s = h 3 in g s y + f = /\a -> \y -> let s = h 3 in g s y \begin{code} cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs @@ -857,23 +855,25 @@ cpeEtaExpand arity expr \end{code} -- ----------------------------------------------------------------------------- --- Eta reduction +-- Eta reduction -- ----------------------------------------------------------------------------- Why try eta reduction? Hasn't the simplifier already done eta? But the simplifier only eta reduces if that leaves something trivial (like f, or f Int). But for deLam it would be enough to get to a partial application: - case x of { p -> \xs. map f xs } + case x of { p -> \xs. map f xs } ==> case x of { p -> map f } \begin{code} tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr tryEtaReducePrep bndrs expr@(App _ _) - | ok_to_eta_reduce f && - n_remaining >= 0 && - and (zipWith ok bndrs last_args) && - not (any (`elemVarSet` fvs_remaining) bndrs) + | ok_to_eta_reduce f + , n_remaining >= 0 + , and (zipWith ok bndrs last_args) + , not (any (`elemVarSet` fvs_remaining) bndrs) + , exprIsHNF remaining_expr -- Don't turn value into a non-value + -- else the behaviour with 'seq' changes = Just remaining_expr where (f, args) = collectArgs expr @@ -885,15 +885,15 @@ tryEtaReducePrep bndrs expr@(App _ _) ok bndr (Var arg) = bndr == arg ok _ _ = False - -- we can't eta reduce something which must be saturated. + -- We can't eta reduce something which must be saturated. ok_to_eta_reduce (Var f) = not (hasNoBinding f) - ok_to_eta_reduce _ = False --safe. ToDo: generalise + ok_to_eta_reduce _ = False -- Safe. ToDo: generalise tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) | not (any (`elemVarSet` fvs) bndrs) = case tryEtaReducePrep bndrs body of - Just e -> Just (Let bind e) - Nothing -> Nothing + Just e -> Just (Let bind e) + Nothing -> Nothing where fvs = exprFreeVars r @@ -910,20 +910,20 @@ type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recurs \end{code} %************************************************************************ -%* * - Floats -%* * +%* * + Floats +%* * %************************************************************************ \begin{code} -data FloatingBind - = FloatLet CoreBind -- Rhs of bindings are CpeRhss - -- They are always of lifted type; - -- unlifted ones are done with FloatCase - - | FloatCase - Id CpeBody - Bool -- The bool indicates "ok-for-speculation" +data FloatingBind + = FloatLet CoreBind -- Rhs of bindings are CpeRhss + -- They are always of lifted type; + -- unlifted ones are done with FloatCase + + | FloatCase + Id CpeBody + Bool -- The bool indicates "ok-for-speculation" data Floats = Floats OkToSpec (OrdList FloatingBind) @@ -939,15 +939,15 @@ instance Outputable OkToSpec where ppr OkToSpec = ptext (sLit "OkToSpec") ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk") ppr NotOkToSpec = ptext (sLit "NotOkToSpec") - + -- Can we float these binds out of the rhs of a let? We cache this decision -- to avoid having to recompute it in a non-linear way when there are -- deeply nested lets. data OkToSpec - = OkToSpec -- Lazy bindings of lifted type - | IfUnboxedOk -- A mixture of lazy lifted bindings and n - -- ok-to-speculate unlifted bindings - | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings + = OkToSpec -- Lazy bindings of lifted type + | IfUnboxedOk -- A mixture of lazy lifted bindings and n + -- ok-to-speculate unlifted bindings + | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind mkFloat is_strict is_unlifted bndr rhs @@ -955,10 +955,10 @@ mkFloat is_strict is_unlifted bndr rhs | otherwise = FloatLet (NonRec bndr rhs) where use_case = is_unlifted || is_strict && not (exprIsHNF rhs) - -- Don't make a case for a value binding, - -- even if it's strict. Otherwise we get - -- case (\x -> e) of ...! - + -- Don't make a case for a value binding, + -- even if it's strict. Otherwise we get + -- case (\x -> e) of ...! + emptyFloats :: Floats emptyFloats = Floats OkToSpec nilOL @@ -977,13 +977,13 @@ addFloat (Floats ok_to_spec floats) new_float = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) where check (FloatLet _) = OkToSpec - check (FloatCase _ _ ok_for_spec) - | ok_for_spec = IfUnboxedOk - | otherwise = NotOkToSpec - -- The ok-for-speculation flag says that it's safe to - -- float this Case out of a let, and thereby do it more eagerly - -- We need the top-level flag because it's never ok to float - -- an unboxed binding to the top level + check (FloatCase _ _ ok_for_spec) + | ok_for_spec = IfUnboxedOk + | otherwise = NotOkToSpec + -- The ok-for-speculation flag says that it's safe to + -- float this Case out of a let, and thereby do it more eagerly + -- We need the top-level flag because it's never ok to float + -- an unboxed binding to the top level unitFloat :: FloatingBind -> Floats unitFloat = addFloat emptyFloats @@ -1001,7 +1001,7 @@ combine _ NotOkToSpec = NotOkToSpec combine IfUnboxedOk _ = IfUnboxedOk combine _ IfUnboxedOk = IfUnboxedOk combine _ _ = OkToSpec - + deFloatTop :: Floats -> [CoreBind] -- For top level only; we don't expect any FloatCases deFloatTop (Floats _ floats) @@ -1009,7 +1009,7 @@ deFloatTop (Floats _ floats) where get (FloatLet b) bs = occurAnalyseRHSs b : bs get b _ = pprPanic "corePrepPgm" (ppr b) - + -- See Note [Dead code in CorePrep] occurAnalyseRHSs (NonRec x e) = NonRec x (fst (dropDeadCode e)) occurAnalyseRHSs (Rec xes) = Rec [ (x, fst (dropDeadCode e)) @@ -1072,10 +1072,10 @@ dropDeadCodeAlts alts = (alts', unionVarSets fvss) canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) -- Note [CafInfo and floating] canFloatFromNoCaf (Floats ok_to_spec fs) rhs - | OkToSpec <- ok_to_spec -- Worth trying + | OkToSpec <- ok_to_spec -- Worth trying , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) = Just (Floats OkToSpec fs', subst_expr subst rhs) - | otherwise + | otherwise = Nothing where subst_expr = substExpr (text "CorePrep") @@ -1084,8 +1084,8 @@ canFloatFromNoCaf (Floats ok_to_spec fs) rhs -> Maybe (Subst, OrdList FloatingBind) go (subst, fbs_out) [] = Just (subst, fbs_out) - - go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) + + go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) | rhs_ok r = go (subst', fbs_out `snocOL` new_fb) fbs_in where @@ -1101,10 +1101,10 @@ canFloatFromNoCaf (Floats ok_to_spec fs) rhs rs' = map (subst_expr subst') rs new_fb = FloatLet (Rec (bs' `zip` rs')) - go _ _ = Nothing -- Encountered a caffy binding + go _ _ = Nothing -- Encountered a caffy binding ------------ - set_nocaf_bndr subst bndr + set_nocaf_bndr subst bndr = (extendIdSubst subst bndr (Var bndr'), bndr') where bndr' = bndr `setIdCafInfo` NoCafRefs @@ -1121,14 +1121,14 @@ wantFloatNested is_rec strict_or_unlifted floats rhs = isEmptyFloats floats || strict_or_unlifted || (allLazyNested is_rec floats && exprIsHNF rhs) - -- Why the test for allLazyNested? - -- v = f (x `divInt#` y) - -- we don't want to float the case, even if f has arity 2, - -- because floating the case would make it evaluated too early + -- Why the test for allLazyNested? + -- v = f (x `divInt#` y) + -- we don't want to float the case, even if f has arity 2, + -- because floating the case would make it evaluated too early allLazyTop :: Floats -> Bool allLazyTop (Floats OkToSpec _) = True -allLazyTop _ = False +allLazyTop _ = False allLazyNested :: RecFlag -> Floats -> Bool allLazyNested _ (Floats OkToSpec _) = True @@ -1138,32 +1138,41 @@ allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec %************************************************************************ -%* * - Cloning -%* * +%* * + Cloning +%* * %************************************************************************ \begin{code} -- --------------------------------------------------------------------------- --- The environment +-- The environment -- --------------------------------------------------------------------------- -data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids +data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids + Id -- mkIntegerId -emptyCorePrepEnv :: CorePrepEnv -emptyCorePrepEnv = CPE emptyVarEnv +mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv +mkInitialCorePrepEnv hsc_env + = do mkIntegerId <- liftM tyThingId + $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) + return $ CPE emptyVarEnv mkIntegerId extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv -extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id') +extendCorePrepEnv (CPE env mkIntegerId) id id' + = CPE (extendVarEnv env id id') mkIntegerId extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv -extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs) +extendCorePrepEnvList (CPE env mkIntegerId) prs + = CPE (extendVarEnvList env prs) mkIntegerId lookupCorePrepEnv :: CorePrepEnv -> Id -> Id -lookupCorePrepEnv (CPE env) id +lookupCorePrepEnv (CPE env _) id = case lookupVarEnv env id of - Nothing -> id - Just id' -> id' + Nothing -> id + Just id' -> id' + +getMkIntegerId :: CorePrepEnv -> Id +getMkIntegerId (CPE _ mkIntegerId) = mkIntegerId ------------------------------------------------------------------------------ -- Cloning binders @@ -1176,7 +1185,7 @@ cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) cpCloneBndr env bndr | isLocalId bndr, not (isCoVar bndr) = do bndr' <- setVarUnique bndr <$> getUniqueM - + -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings -- so that we can drop more stuff as dead code. -- See also Note [Dead code in CorePrep] @@ -1184,11 +1193,11 @@ cpCloneBndr env bndr `setIdSpecialisation` emptySpecInfo return (extendCorePrepEnv env bndr bndr'', bndr'') - | otherwise -- Top level things, which we don't want - -- to clone, have become GlobalIds by now - -- And we don't clone tyvars, or coercion variables + | otherwise -- Top level things, which we don't want + -- to clone, have become GlobalIds by now + -- And we don't clone tyvars, or coercion variables = return (env, bndr) - + ------------------------------------------------------------------------------ -- Cloning ccall Ids; each must have a unique name, @@ -1196,7 +1205,7 @@ cpCloneBndr env bndr -- --------------------------------------------------------------------------- fiddleCCall :: Id -> UniqSM Id -fiddleCCall id +fiddleCCall id | isFCallId id = (id `setVarUnique`) <$> getUniqueM | otherwise = return id diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 16173fb332..a8de9c2b16 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -658,7 +658,7 @@ substUnfoldingSC subst unf -- Short-cut version substUnfolding subst (DFunUnfolding ar con args) = DFunUnfolding ar con (map subst_arg args) where - subst_arg = substExpr (text "dfun-unf") subst + subst_arg = fmap (substExpr (text "dfun-unf") subst) substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) -- Retain an InlineRule! @@ -1194,7 +1194,8 @@ exprIsConApp_maybe id_unf expr , length args == dfun_nargs -- See Note [DFun arity check] , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) - mk_arg e = mkApps e args + mk_arg (DFunPolyArg e) = mkApps e args + mk_arg (DFunLamArg i) = args !! i = dealWithCoercion co (con, substTys subst dfun_res_tys, map mk_arg ops) -- Look through unfoldings, but only arity-zero one; diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index d7296e3e25..a84a29a6c0 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -49,6 +49,7 @@ module CoreSyn ( -- * Unfolding data types Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), + DFunArg(..), dfunArgExprs, -- ** Constructing 'Unfolding's noUnfolding, evaldUnfolding, mkOtherCon, @@ -221,7 +222,8 @@ These data types are the heart of the compiler -- This is one of the more complicated elements of the Core language, -- and comes with a number of restrictions: -- --- 1. The list of alternatives is non-empty +-- 1. The list of alternatives may be empty; +-- See Note [Empty case alternatives] -- -- 2. The 'DEFAULT' case alternative must be first in the list, -- if it occurs at all. @@ -338,11 +340,59 @@ Note [CoreSyn let goal] application, its arguments are trivial, so that the constructor can be inlined vigorously. - Note [Type let] ~~~~~~~~~~~~~~~ See #type_let# +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The alternatives of a case expression should be exhaustive. A case expression +can have empty alternatives if (and only if) the scrutinee is bound to raise +an exception or diverge. So: + Case (error Int "Hello") b Bool [] +is fine, and has type Bool. This is one reason we need a type on +the case expression: if the alternatives are empty we can't get the type +from the alternatives! I'll write this + case (error Int "Hello") of Bool {} +with the return type just before the alterantives. + +Here's another example: + data T + f :: T -> Bool + f = \(x:t). case x of Bool {} +Since T has no data constructors, the case alterantives are of course +empty. However note that 'x' is not bound to a visbily-bottom value; +it's the *type* that tells us it's going to diverge. Its a bit of a +degnerate situation but we do NOT want to replace + case x of Bool {} --> error Bool "Inaccessible case" +because x might raise an exception, and *that*'s what we want to see! +(Trac #6067 is an example.) To preserve semantics we'd have to say + x `seq` error Bool "Inaccessible case" + but the 'seq' is just a case, so we are back to square 1. Or I suppose +we could say + x |> UnsafeCoerce T Bool +but that loses all trace of the fact that this originated with an empty +set of alternatives. + +We can use the empty-alternative construct to coerce error values from +one type to another. For example + + f :: Int -> Int + f n = error "urk" + + g :: Int -> (# Char, Bool #) + g x = case f x of { 0 -> ..., n -> ... } + +Then if we inline f in g's RHS we get + case (error Int "urk") of (# Char, Bool #) { ... } +and we can discard the alternatives since the scrutinee is bottom to give + case (error Int "urk") of (# Char, Bool #) {} + +This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #), +if for no other reason that we don't need to instantiate the (~) at an +unboxed type. + + %************************************************************************ %* * Ticks @@ -490,7 +540,7 @@ data CoreRule ru_fn :: Name, -- ^ As above ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, -- if it fires, including type arguments - ru_try :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr + ru_try :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- ^ This function does the rewrite. It given too many -- arguments, it simply discards them; the returned 'CoreExpr' -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args @@ -586,7 +636,7 @@ data Unfolding DataCon -- The dictionary data constructor (possibly a newtype datacon) - [CoreExpr] -- Specification of superclasses and methods, in positional order + [DFunArg CoreExpr] -- Specification of superclasses and methods, in positional order | CoreUnfolding { -- An unfolding for an Id with no pragma, -- or perhaps a NOINLINE pragma @@ -600,7 +650,7 @@ data Unfolding -- a `seq` on this variable uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function -- Cached version of exprIsConLike - uf_is_cheap :: Bool, -- True <=> doesn't waste (much) work to expand + uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand -- inside an inlining -- Cached version of exprIsCheap uf_expandable :: Bool, -- True <=> can expand in RULE matching @@ -618,12 +668,27 @@ data Unfolding -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on -- this variable -- - -- uf_is_cheap: Does this waste only a little work if we expand it inside an inlining? - -- Basically this is a cached version of 'exprIsCheap' + -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? + -- Basically this is a cached version of 'exprIsWorkFree' -- -- uf_guidance: Tells us about the /size/ of the unfolding template ------------------------------------------------ +data DFunArg e -- Given (df a b d1 d2 d3) + = DFunPolyArg e -- Arg is (e a b d1 d2 d3) + | DFunLamArg Int -- Arg is one of [a,b,d1,d2,d3], zero indexed + deriving( Functor ) + + -- 'e' is often CoreExpr, which are usually variables, but can + -- be trivial expressions instead (e.g. a type application). + +dfunArgExprs :: [DFunArg e] -> [e] +dfunArgExprs [] = [] +dfunArgExprs (DFunPolyArg e : as) = e : dfunArgExprs as +dfunArgExprs (DFunLamArg {} : as) = dfunArgExprs as + + +------------------------------------------------ data UnfoldingSource = InlineRhs -- The current rhs of the function -- Replace uf_tmpl each time around @@ -738,7 +803,7 @@ mkOtherCon = OtherCon seqUnfolding :: Unfolding -> () seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, - uf_is_value = b1, uf_is_cheap = b2, + uf_is_value = b1, uf_is_work_free = b2, uf_expandable = b3, uf_is_conlike = b4, uf_arity = a, uf_guidance = g}) = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g @@ -801,8 +866,8 @@ isConLikeUnfolding _ = False -- | Is the thing we will unfold into certainly cheap? isCheapUnfolding :: Unfolding -> Bool -isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap -isCheapUnfolding _ = False +isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf +isCheapUnfolding _ = False isExpandableUnfolding :: Unfolding -> Bool isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable @@ -914,13 +979,10 @@ instance Outputable AltCon where ppr (LitAlt lit) = ppr lit ppr DEFAULT = ptext (sLit "__DEFAULT") -instance Show AltCon where - showsPrec p con = showsPrecSDoc p (ppr con) - -cmpAlt :: Alt b -> Alt b -> Ordering +cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 -ltAlt :: Alt b -> Alt b -> Bool +ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT cmpAltCon :: AltCon -> AltCon -> Ordering diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index 2045538ace..e29c50cc9d 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -205,8 +205,8 @@ tidyIdBndr env@(tidy_env, var_env) id ------------ Unfolding -------------- tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding -tidyUnfolding tidy_env (DFunUnfolding ar con ids) _ - = DFunUnfolding ar con (map (tidyExpr tidy_env) ids) +tidyUnfolding tidy_env (DFunUnfolding ar con args) _ + = DFunUnfolding ar con (map (fmap (tidyExpr tidy_env)) args) tidyUnfolding tidy_env unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) unf_from_rhs diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 930041dea4..816d34e87b 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -96,7 +96,7 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr) mkSimpleUnfolding :: CoreExpr -> Unfolding mkSimpleUnfolding = mkUnfolding InlineRhs False False -mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding +mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding mkDFunUnfolding dfun_ty ops = DFunUnfolding dfun_nargs data_con ops where @@ -145,15 +145,15 @@ mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr -> Arity -> UnfoldingGuidance -> Unfolding -- Occurrence-analyses the expression before capturing it mkCoreUnfolding src top_lvl expr arity guidance - = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, - uf_src = src, - uf_arity = arity, - uf_is_top = top_lvl, - uf_is_value = exprIsHNF expr, - uf_is_conlike = exprIsConLike expr, - uf_is_cheap = exprIsCheap expr, - uf_expandable = exprIsExpandable expr, - uf_guidance = guidance } + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + uf_src = src, + uf_arity = arity, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_is_work_free = exprIsWorkFree expr, + uf_expandable = exprIsExpandable expr, + uf_guidance = guidance } mkUnfolding :: UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding -- Calculates unfolding guidance @@ -163,18 +163,18 @@ mkUnfolding src top_lvl is_bottoming expr , not (exprIsTrivial expr) = NoUnfolding -- See Note [Do not inline top-level bottoming functions] | otherwise - = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, - uf_src = src, - uf_arity = arity, - uf_is_top = top_lvl, - uf_is_value = exprIsHNF expr, - uf_is_conlike = exprIsConLike expr, - uf_expandable = exprIsExpandable expr, - uf_is_cheap = is_cheap, - uf_guidance = guidance } + = CoreUnfolding { uf_tmpl = occ_anald_expr, + uf_src = src, + uf_arity = arity, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_expandable = exprIsExpandable expr, + uf_is_work_free = exprIsWorkFree expr, + uf_guidance = guidance } where - is_cheap = exprIsCheap expr - (arity, guidance) = calcUnfoldingGuidance expr + occ_anald_expr = occurAnalyseExpr expr + (arity, guidance) = calcUnfoldingGuidance occ_anald_expr -- Sometimes during simplification, there's a large let-bound thing -- which has been substituted, and so is now dead; so 'expr' contains -- two copies of the thing while the occurrence-analysed expression doesn't @@ -392,8 +392,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr size_up (Case (Var v) _ _ alts) | v `elem` top_args -- We are scrutinising an argument variable - = alts_size (foldr1 addAltSize alt_sizes) - (foldr1 maxSize alt_sizes) + = alts_size (foldr addAltSize sizeZero alt_sizes) + (foldr maxSize sizeZero alt_sizes) -- Good to inline if an arg is scrutinised, because -- that may eliminate allocation in the caller -- And it eliminates the case itself @@ -502,6 +502,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr d2 -- Ignore d1 \end{code} + \begin{code} -- | Finds a nominal size of a string literal. litSize :: Literal -> Int @@ -541,7 +542,15 @@ funSize top_args fun n_val_args where some_val_args = n_val_args > 0 - arg_discount | some_val_args && fun `elem` top_args + size | some_val_args = 10 * (1 + n_val_args) + | otherwise = 0 + -- The 1+ is for the function itself + -- Add 1 for each non-trivial arg; + -- the allocation cost, as in let(rec) + + -- DISCOUNTS + -- See Note [Function application discounts] + arg_discount | some_val_args && one_call fun top_args = unitBag (fun, opt_UF_FunAppDiscount) | otherwise = emptyBag -- If the function is an argument and is applied @@ -550,53 +559,51 @@ funSize top_args fun n_val_args res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount | otherwise = 0 -- If the function is partially applied, show a result discount - size | some_val_args = 10 * (1 + n_val_args) - | otherwise = 0 - -- The 1+ is for the function itself - -- Add 1 for each non-trivial arg; - -- the allocation cost, as in let(rec) - + + one_call _ [] = False + one_call fun (arg:args) | fun==arg = case idOccInfo arg of + OneOcc _ one_branch _ -> one_branch + _ -> False + | otherwise = one_call fun args conSize :: DataCon -> Int -> ExprSize conSize dc n_val_args | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10)) -- Like variables --- See Note [Unboxed tuple result discount] +-- See Note [Unboxed tuple size and result discount] | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox (10 * (1 + n_val_args))) --- See Note [Constructor size] - | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (10 + n_val_args))) - -- discont was (10 * (1 + n_val_args)), but it turns out that - -- adding a bigger constant here is an unambiguous win. We - -- REALLY like unfolding constructors that get scrutinised. - -- [SDM, 25/5/11] +-- See Note [Constructor size and result discount] + | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (1 + n_val_args))) \end{code} -Note [Literal integer size] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Literal integers *can* be big (mkInteger [...coefficients...]), but -need not be (S# n). We just use an aribitrary big-ish constant here -so that, in particular, we don't inline top-level defns like - n = S# 5 -There's no point in doing so -- any optimsations will see the S# -through n's unfolding. Nor will a big size inhibit unfoldings functions -that mention a literal Integer, because the float-out pass will float -all those constants to top level. - -Note [Constructor size] -~~~~~~~~~~~~~~~~~~~~~~~ -Treat a constructors application as size 1, regardless of how many +Note [Constructor size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Treat a constructors application as size 10, regardless of how many arguments it has; we are keen to expose them (and we charge separately for their args). We can't treat them as size zero, else we find that (Just x) has size 0, which is the same as a lone variable; and hence 'v' will always be replaced by (Just x), where v is bound to Just x. +The "result discount" is applied if the result of the call is +scrutinised (say by a case). For a constructor application that will +mean the constructor application will disappear, so we don't need to +charge it to the function. So the discount should at least match the +cost of the constructor application, namely 10. But to give a bit +of extra incentive we give a discount of 10*(1 + n_val_args). + +Simon M tried a MUCH bigger discount: (10 * (10 + n_val_args)), +and said it was an "unambiguous win", but its terribly dangerous +because a fuction with many many case branches, each finishing with +a constructor, can have an arbitrarily large discount. This led to +terrible code bloat: see Trac #6099. + +Note [Unboxed tuple size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ However, unboxed tuples count as size zero. I found occasions where we had f x y z = case op# x y z of { s -> (# s, () #) } and f wasn't getting inlined. -Note [Unboxed tuple result discount] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ I tried giving unboxed tuples a *result discount* of zero (see the commented-out line). Why? When returned as a result they do not allocate, so maybe we don't want to charge so much for them If you @@ -608,6 +615,32 @@ shrank binary sizes by 0.5% it also made spectral/boyer allocate 5% more. All other changes were very small. So it's not a big deal but I didn't adopt the idea. +Note [Function application discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want a discount if the function is applied. A good example is +monadic combinators with continuation arguments, where inlining is +quite important. + +But we don't want a big discount when a function is called many times +(see the detailed comments with Trac #6048) because if the function is +big it won't be inlined at its many call sites and no benefit results. +Indeed, we can get exponentially big inlinings this way; that is what +Trac #6048 is about. + +So, we only give a function-application discount when the function appears +textually once, albeit possibly inside a lambda. + +Note [Literal integer size] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal integers *can* be big (mkInteger [...coefficients...]), but +need not be (S# n). We just use an aribitrary big-ish constant here +so that, in particular, we don't inline top-level defns like + n = S# 5 +There's no point in doing so -- any optimsations will see the S# +through n's unfolding. Nor will a big size inhibit unfoldings functions +that mention a literal Integer, because the float-out pass will float +all those constants to top level. + \begin{code} primOpSize :: PrimOp -> Int -> ExprSize primOpSize op n_val_args @@ -842,11 +875,11 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info -- Things with an INLINE pragma may have an unfolding *and* -- be a loop breaker (maybe the knot is not yet untied) CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top - , uf_is_cheap = is_cheap, uf_arity = uf_arity + , uf_is_work_free = is_wf, uf_arity = uf_arity , uf_guidance = guidance, uf_expandable = is_exp } | active_unfolding -> tryUnfolding dflags id lone_variable arg_infos cont_info unf_template is_top - is_cheap is_exp uf_arity guidance + is_wf is_exp uf_arity guidance | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags -> pprTrace "Inactive unfolding:" (ppr id) Nothing | otherwise -> Nothing @@ -859,17 +892,17 @@ tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt -> Maybe CoreExpr tryUnfolding dflags id lone_variable arg_infos cont_info unf_template is_top - is_cheap is_exp uf_arity guidance + is_wf is_exp uf_arity guidance -- uf_arity will typically be equal to (idArity id), -- but may be less for InlineRules | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags - = pprTrace ("Considering inlining: " ++ showSDoc (ppr id)) + = pprTrace ("Considering inlining: " ++ showSDocDump dflags (ppr id)) (vcat [text "arg infos" <+> ppr arg_infos, text "uf arity" <+> ppr uf_arity, text "interesting continuation" <+> ppr cont_info, text "some_benefit" <+> ppr some_benefit, text "is exp:" <+> ppr is_exp, - text "is cheap:" <+> ppr is_cheap, + text "is work-free:" <+> ppr is_wf, text "guidance" <+> ppr guidance, extra_doc, text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]) @@ -903,7 +936,7 @@ tryUnfolding dflags id lone_variable interesting_saturated_call = case cont_info of BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions] - CaseCtxt -> not (lone_variable && is_cheap) -- Note [Lone variables] + CaseCtxt -> not (lone_variable && is_wf) -- Note [Lone variables] ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt] ValAppCtxt -> True -- Note [Cast then apply] @@ -917,7 +950,7 @@ tryUnfolding dflags id lone_variable enough_args = saturated || (unsat_ok && n_val_args > 0) UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } - -> ( is_cheap && some_benefit && small_enough + -> ( is_wf && some_benefit && small_enough , (text "discounted size =" <+> int discounted_size) ) where discounted_size = size - discount @@ -1029,7 +1062,7 @@ call is at least CONLIKE. At least for the cases where we use ArgCtxt for the RHS of a 'let', we only profit from the inlining if we get a CONLIKE thing (modulo lets). -Note [Lone variables] See also Note [Interaction of exprIsCheap and lone variables] +Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables] ~~~~~~~~~~~~~~~~~~~~~ which appears below The "lone-variable" case is important. I spent ages messing about with unsatisfactory varaints, but this is nice. The idea is that if a @@ -1076,7 +1109,7 @@ However, watch out: So the non-inlining of lone_variables should only apply if the unfolding is regarded as cheap; because that is when exprIsConApp_maybe - looks through the unfolding. Hence the "&& is_cheap" in the + looks through the unfolding. Hence the "&& is_wf" in the InlineRule branch. * Even a type application or coercion isn't a lone variable. @@ -1091,7 +1124,7 @@ However, watch out: There's no advantage in inlining f here, and perhaps a significant disadvantage. Hence some_val_args in the Stop case -Note [Interaction of exprIsCheap and lone variables] +Note [Interaction of exprIsWorkFree and lone variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The lone-variable test says "don't inline if a case expression scrutines a lone variable whose unfolding is cheap". It's very @@ -1102,9 +1135,9 @@ consider to be cheap, and that's good because exprIsConApp_maybe doesn't think that expression is a constructor application. -I used to test is_value rather than is_cheap, which was utterly -wrong, because the above expression responds True to exprIsHNF, -which is what sets is_value. +In the 'not (lone_variable && is_wf)' test, I used to test is_value +rather than is_wf, which was utterly wrong, because the above +expression responds True to exprIsHNF, which is what sets is_value. This kind of thing can occur if you have diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 198ac7e610..17e2966e15 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -15,13 +15,14 @@ module CoreUtils ( mkAltExpr, -- * Taking expressions apart - findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, + findDefault, findAlt, isDefaultAlt, + mergeAlts, trimConArgs, filterAlts, -- * Properties of expressions exprType, coreAltType, coreAltsType, exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun, - exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, + exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, exprIsBig, exprIsConLike, rhsIsStatic, isCheapApp, isExpandableApp, @@ -69,7 +70,7 @@ import Util import Pair import Data.Word import Data.Bits -import Data.List ( mapAccumL ) +import Data.List \end{code} @@ -186,15 +187,7 @@ mkCast (Coercion e_co) co -- The guard here checks that g has a (~#) on both sides, -- otherwise decomposeCo fails. Can in principle happen -- with unsafeCoerce - = Coercion new_co - where - -- g :: (s1 ~# s2) ~# (t1 ~# t2) - -- g1 :: s1 ~# t1 - -- g2 :: s2 ~# t2 - new_co = mkSymCo g1 `mkTransCo` e_co `mkTransCo` g2 - [_reflk, g1, g2] = decomposeCo 3 co - -- Remember, (~#) :: forall k. k -> k -> * - -- so it takes *three* arguments, not two + = Coercion (mkCoCast e_co co) mkCast (Cast expr co2) co = ASSERT(let { Pair from_ty _to_ty = coercionKind co; @@ -342,18 +335,18 @@ This makes it easy to find, though it makes matching marginally harder. \begin{code} -- | Extract the default case alternative -findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr) +findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b) findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) findDefault alts = (alts, Nothing) -isDefaultAlt :: CoreAlt -> Bool +isDefaultAlt :: (AltCon, a, b) -> Bool isDefaultAlt (DEFAULT, _, _) = True isDefaultAlt _ = False -- | Find the case alternative corresponding to a particular -- constructor: panics if no such constructor exists -findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt +findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) -- A "Nothing" result *is* legitmiate -- See Note [Unreachable code] findAlt con alts @@ -369,7 +362,7 @@ findAlt con alts GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt --------------------------------- -mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt] +mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)] -- ^ Merge alternatives preserving order; alternatives in -- the first argument shadow ones in the second mergeAlts [] as2 = as2 @@ -396,6 +389,88 @@ trimConArgs (LitAlt _) args = ASSERT( null args ) [] trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args \end{code} +\begin{code} +filterAlts :: [Unique] -- ^ Supply of uniques used in case we have to manufacture a new AltCon + -> Type -- ^ Type of scrutinee (used to prune possibilities) + -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee + -> [(AltCon, [Var], a)] -- ^ Alternatives + -> ([AltCon], Bool, [(AltCon, [Var], a)]) + -- Returns: + -- 1. Constructors that will never be encountered by the + -- *default* case (if any). A superset of imposs_cons + -- 2. Whether we managed to refine the default alternative into a specific constructor (for statistics only) + -- 3. The new alternatives, trimmed by + -- a) remove imposs_cons + -- b) remove constructors which can't match because of GADTs + -- and with the DEFAULT expanded to a DataAlt if there is exactly + -- remaining constructor that can match + -- + -- NB: the final list of alternatives may be empty: + -- This is a tricky corner case. If the data type has no constructors, + -- which GHC allows, or if the imposs_cons covers all constructors (after taking + -- account of GADTs), then no alternatives can match. + -- + -- If callers need to preserve the invariant that there is always at least one branch + -- in a "case" statement then they will need to manually add a dummy case branch that just + -- calls "error" or similar. +filterAlts us ty imposs_cons alts = (imposs_deflt_cons, refined_deflt, merged_alts) + where + (alts_wo_default, maybe_deflt) = findDefault alts + alt_cons = [con | (con,_,_) <- alts_wo_default] + imposs_deflt_cons = nub (imposs_cons ++ alt_cons) + -- "imposs_deflt_cons" are handled + -- EITHER by the context, + -- OR by a non-DEFAULT branch in this case expression. + + trimmed_alts = filterOut impossible_alt alts_wo_default + merged_alts = mergeAlts trimmed_alts (maybeToList maybe_deflt') + -- We need the mergeAlts in case the new default_alt + -- has turned into a constructor alternative. + -- The merge keeps the inner DEFAULT at the front, if there is one + -- and interleaves the alternatives in the right order + + (refined_deflt, maybe_deflt') = case maybe_deflt of + Just deflt_rhs -> case mb_tc_app of + Just (tycon, inst_tys) + | -- This branch handles the case where we are + -- scrutinisng an algebraic data type + isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. + , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: + -- case x of { DEFAULT -> e } + -- and we don't want to fill in a default for them! + , Just all_cons <- tyConDataCons_maybe tycon + , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type + impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con + -> case filterOut impossible all_cons of + -- Eliminate the default alternative + -- altogether if it can't match: + [] -> (False, Nothing) + -- It matches exactly one constructor, so fill it in: + [con] -> (True, Just (DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)) + where (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys + _ -> (False, Just (DEFAULT, [], deflt_rhs)) + + | debugIsOn, isAlgTyCon tycon + , null (tyConDataCons tycon) + , not (isFamilyTyCon tycon || isAbstractTyCon tycon) + -- Check for no data constructors + -- This can legitimately happen for abstract types and type families, + -- so don't report that + -> pprTrace "prepareDefault" (ppr tycon) + (False, Just (DEFAULT, [], deflt_rhs)) + + _ -> (False, Just (DEFAULT, [], deflt_rhs)) + Nothing -> (False, Nothing) + + mb_tc_app = splitTyConApp_maybe ty + Just (_, inst_tys) = mb_tc_app + + impossible_alt :: (AltCon, a, b) -> Bool + impossible_alt (con, _, _) | con `elem` imposs_cons = True + impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con + impossible_alt _ = False +\end{code} + Note [Unreachable code] ~~~~~~~~~~~~~~~~~~~~~~~ It is possible (although unusual) for GHC to find a case expression @@ -557,6 +632,68 @@ dupAppSize = 8 -- Size of term we are prepared to duplicate %* * %************************************************************************ +Note [exprIsWorkFree] +~~~~~~~~~~~~~~~~~~~~~ +exprIsWorkFree is used when deciding whether to inline something; we +don't inline it if doing so might duplicate work, by peeling off a +complete copy of the expression. Here we do not want even to +duplicate a primop (Trac #5623): + eg let x = a #+ b in x +# x + we do not want to inline/duplicate x + +Previously we were a bit more liberal, which led to the primop-duplicating +problem. However, being more conservative did lead to a big regression in +one nofib benchmark, wheel-sieve1. The situation looks like this: + + let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool + noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> + case GHC.Prim.<=# x_aRs 2 of _ { + GHC.Types.False -> notDivBy ps_adM qs_adN; + GHC.Types.True -> lvl_r2Eb }} + go = \x. ...(noFactor (I# y))....(go x')... + +The function 'noFactor' is heap-allocated and then called. Turns out +that 'notDivBy' is strict in its THIRD arg, but that is invisible to +the caller of noFactor, which therefore cannot do w/w and +heap-allocates noFactor's argument. At the moment (May 12) we are just +going to put up with this, because the previous more aggressive inlining +(which treated 'noFactor' as work-free) was duplicating primops, which +in turn was making inner loops of array calculations runs slow (#5623) + +\begin{code} +exprIsWorkFree :: CoreExpr -> Bool +-- See Note [exprIsWorkFree] +exprIsWorkFree e = go 0 e + where -- n is the number of value arguments + go _ (Lit {}) = True + go _ (Type {}) = True + go _ (Coercion {}) = True + go n (Cast e _) = go n e + go n (Case scrut _ _ alts) = foldl (&&) (exprIsWorkFree scrut) + [ go n rhs | (_,_,rhs) <- alts ] + -- See Note [Case expressions are work-free] + go _ (Let {}) = False + go n (Var v) = n==0 || n < idArity v + go n (Tick t e) | tickishCounts t = False + | otherwise = go n e + go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e + | otherwise = go n e + go n (App f e) | isRuntimeArg e = exprIsWorkFree e && go (n+1) f + | otherwise = go n f +\end{code} + +Note [Case expressions are work-free] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Are case-expressions work-free? Consider + let v = case x of (p,q) -> p + go = \y -> ...case v of ... +Should we inline 'v' at its use site inside the loop? At the moment +we do. I experimented with saying that case are *not* work-free, but +that increased allocation slightly. It's a fairly small effect, and at +the moment we go for the slightly more aggressive version which treats +(case x of ....) as work-free if the alterantives are. + + Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables] ~~~~~~~~~~~~~~~~~~ in CoreUnfold.lhs @exprIsCheap@ looks at a Core expression and returns \tr{True} if @@ -791,7 +928,7 @@ expr_ok primop_ok other_expr app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool app_ok primop_ok fun args = case idDetails fun of - DFunId new_type -> not new_type + DFunId _ new_type -> not new_type -- DFuns terminate, unless the dict is implemented -- with a newtype in which case they may not @@ -1213,10 +1350,11 @@ eqExprX id_unfolding_fun env e1 e2 (bs2,rs2) = unzip ps2 env' = rnBndrs2 env bs1 bs2 - go env (Case e1 b1 _ a1) (Case e2 b2 _ a2) - = go env e1 e2 - && eqTypeX env (idType b1) (idType b2) - && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 + go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | null a1 -- See Note [Empty case alternatives] in TrieMap + = null a2 && go env e1 e2 && eqTypeX env t1 t2 + | otherwise + = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 go _ _ _ = False @@ -1246,50 +1384,9 @@ locallyBoundR rn_env v = inRnEnvR rn_env v %************************************************************************ \begin{code} -coreBindsSize :: [CoreBind] -> Int -coreBindsSize bs = foldr ((+) . bindSize) 0 bs - -exprSize :: CoreExpr -> Int --- ^ A measure of the size of the expressions, strictly greater than 0 --- It also forces the expression pretty drastically as a side effect --- Counts *leaves*, not internal nodes. Types and coercions are not counted. -exprSize (Var v) = v `seq` 1 -exprSize (Lit lit) = lit `seq` 1 -exprSize (App f a) = exprSize f + exprSize a -exprSize (Lam b e) = varSize b + exprSize e -exprSize (Let b e) = bindSize b + exprSize e -exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as -exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e -exprSize (Tick n e) = tickSize n + exprSize e -exprSize (Type t) = seqType t `seq` 1 -exprSize (Coercion co) = seqCo co `seq` 1 - -tickSize :: Tickish Id -> Int -tickSize (ProfNote cc _ _) = cc `seq` 1 -tickSize _ = 1 -- the rest are strict - -varSize :: Var -> Int -varSize b | isTyVar b = 1 - | otherwise = seqType (idType b) `seq` - megaSeqIdInfo (idInfo b) `seq` - 1 - -varsSize :: [Var] -> Int -varsSize = sum . map varSize - -bindSize :: CoreBind -> Int -bindSize (NonRec b e) = varSize b + exprSize e -bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs - -pairSize :: (Var, CoreExpr) -> Int -pairSize (b,e) = varSize b + exprSize e - -altSize :: CoreAlt -> Int -altSize (c,bs,e) = c `seq` varsSize bs + exprSize e -\end{code} - -\begin{code} -data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int } +data CoreStats = CS { cs_tm :: Int -- Terms + , cs_ty :: Int -- Types + , cs_co :: Int } -- Coercions instance Outputable CoreStats where @@ -1345,6 +1442,54 @@ coStats :: Coercion -> CoreStats coStats co = zeroCS { cs_co = coercionSize co } \end{code} + +\begin{code} +coreBindsSize :: [CoreBind] -> Int +-- We use coreBindStats for user printout +-- but this one is a quick and dirty basis for +-- the simplifier's tick limit +coreBindsSize bs = foldr ((+) . bindSize) 0 bs + +exprSize :: CoreExpr -> Int +-- ^ A measure of the size of the expressions, strictly greater than 0 +-- It also forces the expression pretty drastically as a side effect +-- Counts *leaves*, not internal nodes. Types and coercions are not counted. +exprSize (Var v) = v `seq` 1 +exprSize (Lit lit) = lit `seq` 1 +exprSize (App f a) = exprSize f + exprSize a +exprSize (Lam b e) = varSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as +exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e +exprSize (Tick n e) = tickSize n + exprSize e +exprSize (Type t) = seqType t `seq` 1 +exprSize (Coercion co) = seqCo co `seq` 1 + +tickSize :: Tickish Id -> Int +tickSize (ProfNote cc _ _) = cc `seq` 1 +tickSize _ = 1 -- the rest are strict + +varSize :: Var -> Int +varSize b | isTyVar b = 1 + | otherwise = seqType (idType b) `seq` + megaSeqIdInfo (idInfo b) `seq` + 1 + +varsSize :: [Var] -> Int +varsSize = sum . map varSize + +bindSize :: CoreBind -> Int +bindSize (NonRec b e) = varSize b + exprSize e +bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs + +pairSize :: (Var, CoreExpr) -> Int +pairSize (b,e) = varSize b + exprSize e + +altSize :: CoreAlt -> Int +altSize (c,bs,e) = c `seq` varsSize bs + exprSize e +\end{code} + + %************************************************************************ %* * \subsection{Hashing} diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index 5d1c19bc5f..410d62db7d 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -13,6 +13,7 @@ module MkCore ( mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreLams, mkWildCase, mkIfThenElse, mkWildValBinder, mkWildEvBinder, + sortQuantVars, castBottomExpr, -- * Constructing boxed literals mkWordExpr, mkWordExprWord, @@ -24,9 +25,6 @@ module MkCore ( -- * Floats FloatBind(..), wrapFloat, - -- * Constructing/deconstructing implicit parameter boxes - mkIPUnbox, mkIPBox, - -- * Constructing/deconstructing equality evidence boxes mkEqBox, @@ -61,7 +59,7 @@ module MkCore ( #include "HsVersions.h" import Id -import Var ( IpId, EvVar, setTyVarUnique ) +import Var ( EvVar, setTyVarUnique ) import CoreSyn import CoreUtils ( exprType, needsCaseBinding, bindNonRec ) @@ -71,8 +69,7 @@ import HscTypes import TysWiredIn import PrelNames -import IParam ( ipCoAxiom ) -import TcType ( mkSigmaTy, evVarPred ) +import TcType ( mkSigmaTy ) import Type import Coercion import TysPrim @@ -84,11 +81,13 @@ import Outputable import FastString import UniqSupply import BasicTypes -import Util ( notNull, zipEqual ) +import Util import Pair import Constants import Data.Char ( ord ) +import Data.List +import Data.Ord import Data.Word infixl 4 `mkCoreApp`, `mkCoreApps` @@ -101,6 +100,18 @@ infixl 4 `mkCoreApp`, `mkCoreApps` %************************************************************************ \begin{code} +sortQuantVars :: [Var] -> [Var] +-- Sort the variables (KindVars, TypeVars, and Ids) +-- into order: Type, then Kind, then Id +sortQuantVars = sortBy (comparing withCategory) + where + withCategory v = (category v, v) + category :: Var -> Int + category v + | isTyVar v = 1 + | isKindVar v = 2 + | otherwise = 3 + -- | Bind a binding group over an expression, using a @let@ or @case@ as -- appropriate (see "CoreSyn#let_app_invariant") mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr @@ -191,6 +202,16 @@ mkIfThenElse guard then_expr else_expr = mkWildCase guard boolTy (exprType then_expr) [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! (DataAlt trueDataCon, [], then_expr) ] + +castBottomExpr :: CoreExpr -> Type -> CoreExpr +-- (castBottomExpr e ty), assuming that 'e' diverges, +-- return an expression of type 'ty' +-- See Note [Empty case alternatives] in CoreSyn +castBottomExpr e res_ty + | e_ty `eqType` res_ty = e + | otherwise = Case e (mkWildValBinder e_ty) res_ty [] + where + e_ty = exprType e \end{code} The functions from this point don't really do anything cleverer than @@ -229,8 +250,8 @@ mkWordExprWord w = mkConApp wordDataCon [mkWordLitWord w] -- | Create a 'CoreExpr' which will evaluate to the given @Integer@ mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer -mkIntegerExpr i = do mkIntegerId <- lookupId mkIntegerName - return (Lit (mkLitInteger i mkIntegerId)) +mkIntegerExpr i = do t <- lookupTyCon integerTyConName + return (Lit (mkLitInteger i (mkTyConTy t))) -- | Create a 'CoreExpr' which will evaluate to the given @Float@ mkFloatExpr :: Float -> CoreExpr @@ -275,21 +296,6 @@ mkStringExprFS str \begin{code} -mkIPBox :: IPName IpId -> CoreExpr -> CoreExpr -mkIPBox ipx e = e `Cast` mkSymCo (mkAxInstCo (ipCoAxiom ip) [ty]) - where x = ipNameName ipx - Just (ip, ty) = getIPPredTy_maybe (evVarPred x) - -- NB: don't use the DataCon work id because we don't generate code for it - -mkIPUnbox :: IPName IpId -> CoreExpr -mkIPUnbox ipx = Var x `Cast` mkAxInstCo (ipCoAxiom ip) [ty] - where x = ipNameName ipx - Just (ip, ty) = getIPPredTy_maybe (evVarPred x) - -\end{code} - -\begin{code} - mkEqBox :: Coercion -> CoreExpr mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) ) Var (dataConWorkId eqBoxDataCon) `mkTyApps` [k, ty1, ty2] `App` Coercion co diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index cb12973a60..b6c682ffc0 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -38,6 +38,7 @@ import DynFlags import FastString import Exception +import Control.Monad import Data.Char import System.IO @@ -45,7 +46,7 @@ emitExternalCore :: DynFlags -> CgGuts -> IO () emitExternalCore dflags cg_guts | dopt Opt_EmitExternalCore dflags = (do handle <- openFile corename WriteMode - hPutStrLn handle (show (mkExternalCore cg_guts)) + hPutStrLn handle (show (mkExternalCore dflags cg_guts)) hClose handle) `catchIO` (\_ -> pprPanic "Failed to open or write external core output file" (text corename)) @@ -56,7 +57,10 @@ emitExternalCore _ _ -- Reinventing the Reader monad; whee. newtype CoreM a = CoreM (CoreState -> (CoreState, a)) -type CoreState = Module +data CoreState = CoreState { + cs_dflags :: DynFlags, + cs_module :: Module + } instance Monad CoreM where (CoreM m) >>= f = CoreM (\ s -> case m s of (s',r) -> case f r of @@ -67,55 +71,62 @@ runCoreM (CoreM f) s = snd $ f s ask :: CoreM CoreState ask = CoreM (\ s -> (s,s)) -mkExternalCore :: CgGuts -> C.Module +instance HasDynFlags CoreM where + getDynFlags = liftM cs_dflags ask + +mkExternalCore :: DynFlags -> CgGuts -> C.Module -- The ModGuts has been tidied, but the implicit bindings have -- not been injected, so we have to add them manually here -- We don't include the strange data-con *workers* because they are -- implicit in the data type declaration itself -mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, - cg_binds = binds}) +mkExternalCore dflags (CgGuts {cg_module=this_mod, cg_tycons = tycons, + cg_binds = binds}) {- Note that modules can be mutually recursive, but even so, we print out dependency information within each module. -} - = C.Module mname tdefs (runCoreM (mapM (make_vdef True) binds) this_mod) + = C.Module (mname dflags) tdefs (runCoreM (mapM (make_vdef True) binds) initialState) where - mname = make_mid this_mod - tdefs = foldr collect_tdefs [] tycons - -collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef] -collect_tdefs tcon tdefs + initialState = CoreState { + cs_dflags = dflags, + cs_module = this_mod + } + mname dflags = make_mid dflags this_mod + tdefs = foldr (collect_tdefs dflags) [] tycons + +collect_tdefs :: DynFlags -> TyCon -> [C.Tdef] -> [C.Tdef] +collect_tdefs dflags tcon tdefs | isAlgTyCon tcon = tdef: tdefs where tdef | isNewTyCon tcon = - C.Newtype (qtc tcon) - (qcc (newTyConCo tcon)) + C.Newtype (qtc dflags tcon) + (qcc dflags (newTyConCo tcon)) (map make_tbind tyvars) - (make_ty (snd (newTyConRhs tcon))) + (make_ty dflags (snd (newTyConRhs tcon))) | otherwise = - C.Data (qtc tcon) (map make_tbind tyvars) - (map make_cdef (tyConDataCons tcon)) + C.Data (qtc dflags tcon) (map make_tbind tyvars) + (map (make_cdef dflags) (tyConDataCons tcon)) tyvars = tyConTyVars tcon -collect_tdefs _ tdefs = tdefs +collect_tdefs _ _ tdefs = tdefs -qtc :: TyCon -> C.Qual C.Tcon -qtc = make_con_qid . tyConName +qtc :: DynFlags -> TyCon -> C.Qual C.Tcon +qtc dflags = make_con_qid dflags . tyConName -qcc :: CoAxiom -> C.Qual C.Tcon -qcc = make_con_qid . co_ax_name +qcc :: DynFlags -> CoAxiom -> C.Qual C.Tcon +qcc dflags = make_con_qid dflags . co_ax_name -make_cdef :: DataCon -> C.Cdef -make_cdef dcon = C.Constr dcon_name existentials tys +make_cdef :: DynFlags -> DataCon -> C.Cdef +make_cdef dflags dcon = C.Constr dcon_name existentials tys where - dcon_name = make_qid False False (dataConName dcon) + dcon_name = make_qid dflags False False (dataConName dcon) existentials = map make_tbind ex_tyvars ex_tyvars = dataConExTyVars dcon - tys = map make_ty (dataConRepArgTys dcon) + tys = map (make_ty dflags) (dataConRepArgTys dcon) make_tbind :: TyVar -> C.Tbind make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv)) -make_vbind :: Var -> C.Vbind -make_vbind v = (make_var_id (Var.varName v), make_ty (varType v)) +make_vbind :: DynFlags -> Var -> C.Vbind +make_vbind dflags v = (make_var_id (Var.varName v), make_ty dflags (varType v)) make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg make_vdef topLevel b = @@ -129,27 +140,34 @@ make_vdef topLevel b = let local = not topLevel || localN rhs <- make_exp e -- use local flag to determine where to add the module name - return (local, make_qid local True vName, make_ty (varType v),rhs) + dflags <- getDynFlags + return (local, make_qid dflags local True vName, make_ty dflags (varType v),rhs) where vName = Var.varName v make_exp :: CoreExpr -> CoreM C.Exp make_exp (Var v) = do let vName = Var.varName v isLocal <- isALocal vName + dflags <- getDynFlags return $ case idDetails v of - FCallId (CCall (CCallSpec (StaticTarget nm _) callconv _)) - -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v)) + FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _)) + -> C.External (unpackFS nm) (showPpr dflags callconv) (make_ty dflags (varType v)) + FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) -> + panic "make_exp: FFI values not supported" FCallId (CCall (CCallSpec DynamicTarget callconv _)) - -> C.DynExternal (showSDoc (ppr callconv)) (make_ty (varType v)) + -> C.DynExternal (showPpr dflags callconv) (make_ty dflags (varType v)) -- Constructors are always exported, so make sure to declare them -- with qualified names - DataConWorkId _ -> C.Var (make_var_qid False vName) - DataConWrapId _ -> C.Var (make_var_qid False vName) - _ -> C.Var (make_var_qid isLocal vName) + DataConWorkId _ -> C.Var (make_var_qid dflags False vName) + DataConWrapId _ -> C.Var (make_var_qid dflags False vName) + _ -> C.Var (make_var_qid dflags isLocal vName) make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s) -make_exp (Lit l) = return $ C.Lit (make_lit l) -make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t)) +make_exp (Lit l) = do dflags <- getDynFlags + return $ C.Lit (make_lit dflags l) +make_exp (App e (Type t)) = do b <- make_exp e + dflags <- getDynFlags + return $ C.Appt b (make_ty dflags t) make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))" -- TODO make_exp (App e1 e2) = do rator <- make_exp e1 @@ -157,9 +175,12 @@ make_exp (App e1 e2) = do return $ C.App rator rand make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> return $ C.Lam (C.Tb (make_tbind v)) b) -make_exp (Lam v e) | otherwise = make_exp e >>= (\ b -> - return $ C.Lam (C.Vb (make_vbind v)) b) -make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co)) +make_exp (Lam v e) | otherwise = do b <- make_exp e + dflags <- getDynFlags + return $ C.Lam (C.Vb (make_vbind dflags v)) b +make_exp (Cast e co) = do b <- make_exp e + dflags <- getDynFlags + return $ C.Cast b (make_co dflags co) make_exp (Let b e) = do vd <- make_vdef False b body <- make_exp e @@ -167,19 +188,23 @@ make_exp (Let b e) = do make_exp (Case e v ty alts) = do scrut <- make_exp e newAlts <- mapM make_alt alts - return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts + dflags <- getDynFlags + return $ C.Case scrut (make_vbind dflags v) (make_ty dflags ty) newAlts make_exp (Tick _ e) = make_exp e >>= (return . C.Tick "SCC") -- temporary make_exp _ = error "MkExternalCore died: make_exp" make_alt :: CoreAlt -> CoreM C.Alt make_alt (DataAlt dcon, vs, e) = do newE <- make_exp e - return $ C.Acon (make_con_qid (dataConName dcon)) + dflags <- getDynFlags + return $ C.Acon (make_con_qid dflags (dataConName dcon)) (map make_tbind tbs) - (map make_vbind vbs) + (map (make_vbind dflags) vbs) newE where (tbs,vbs) = span isTyVar vs -make_alt (LitAlt l,_,e) = make_exp e >>= (return . (C.Alit (make_lit l))) +make_alt (LitAlt l,_,e) = do x <- make_exp e + dflags <- getDynFlags + return $ C.Alit (make_lit dflags l) x make_alt (DEFAULT,[],e) = make_exp e >>= (return . C.Adefault) -- This should never happen, as the DEFAULT alternative binds no variables, -- but we might as well check for it: @@ -187,8 +212,8 @@ make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT " ++ "alternative had a non-empty var list") (ppr a) -make_lit :: Literal -> C.Lit -make_lit l = +make_lit :: DynFlags -> Literal -> C.Lit +make_lit dflags l = case l of -- Note that we need to check whether the character is "big". -- External Core only allows character literals up to '\xff'. @@ -206,21 +231,22 @@ make_lit l = MachDouble r -> C.Lrational r t _ -> error "MkExternalCore died: make_lit" where - t = make_ty (literalType l) + t = make_ty dflags (literalType l) -- Expand type synonyms, then convert. -make_ty :: Type -> C.Ty -- Be sure to expand types recursively! +make_ty :: DynFlags -> Type -> C.Ty -- Be sure to expand types recursively! -- example: FilePath ~> String ~> [Char] -make_ty t | Just expanded <- tcView t = make_ty expanded -make_ty t = make_ty' t +make_ty dflags t | Just expanded <- tcView t = make_ty dflags expanded +make_ty dflags t = make_ty' dflags t -- note calls to make_ty so as to expand types recursively -make_ty' :: Type -> C.Ty -make_ty' (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv)) -make_ty' (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2) -make_ty' (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2]) -make_ty' (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t) -make_ty' (TyConApp tc ts) = make_tyConApp tc ts +make_ty' :: DynFlags -> Type -> C.Ty +make_ty' _ (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv)) +make_ty' dflags (AppTy t1 t2) = C.Tapp (make_ty dflags t1) (make_ty dflags t2) +make_ty' dflags (FunTy t1 t2) = make_ty dflags (TyConApp funTyCon [t1,t2]) +make_ty' dflags (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty dflags t) +make_ty' dflags (TyConApp tc ts) = make_tyConApp dflags tc ts +make_ty' _ (LitTy {}) = panic "MkExernalCore can't do literal types yet" -- Newtypes are treated just like any other type constructor; not expanded -- Reason: predTypeRep does substitution and, while substitution deals @@ -234,10 +260,10 @@ make_ty' (TyConApp tc ts) = make_tyConApp tc ts -- expose the representation in interface files, which definitely isn't right. -- Maybe CoreTidy should know whether to expand newtypes or not? -make_tyConApp :: TyCon -> [Type] -> C.Ty -make_tyConApp tc ts = - foldl C.Tapp (C.Tcon (qtc tc)) - (map make_ty ts) +make_tyConApp :: DynFlags -> TyCon -> [Type] -> C.Ty +make_tyConApp dflags tc ts = + foldl C.Tapp (C.Tcon (qtc dflags tc)) + (map (make_ty dflags) ts) make_kind :: Kind -> C.Kind make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2) @@ -264,52 +290,53 @@ make_var_id = make_id True -- because that would just be ugly.) -- SIGH. -- We encode the package name as well. -make_mid :: Module -> C.Id +make_mid :: DynFlags -> Module -> C.Id -- Super ugly code, but I can't find anything else that does quite what I -- want (encodes the hierarchical module name without encoding the colon -- that separates the package name from it.) -make_mid m = showSDoc $ +make_mid dflags m + = showSDoc dflags $ (text $ zEncodeString $ packageIdString $ modulePackageId m) <> text ":" <> (pprEncoded $ pprModuleName $ moduleName m) where pprEncoded = pprCode CStyle -make_qid :: Bool -> Bool -> Name -> C.Qual C.Id -make_qid force_unqual is_var n = (mname,make_id is_var n) +make_qid :: DynFlags -> Bool -> Bool -> Name -> C.Qual C.Id +make_qid dflags force_unqual is_var n = (mname,make_id is_var n) where mname = case nameModule_maybe n of - Just m | not force_unqual -> make_mid m + Just m | not force_unqual -> make_mid dflags m _ -> "" -make_var_qid :: Bool -> Name -> C.Qual C.Id -make_var_qid force_unqual = make_qid force_unqual True - -make_con_qid :: Name -> C.Qual C.Id -make_con_qid = make_qid False False - -make_co :: Coercion -> C.Ty -make_co (Refl ty) = make_ty ty -make_co (TyConAppCo tc cos) = make_conAppCo (qtc tc) cos -make_co (AppCo c1 c2) = C.Tapp (make_co c1) (make_co c2) -make_co (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co co) -make_co (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv)) -make_co (AxiomInstCo cc cos) = make_conAppCo (qcc cc) cos -make_co (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty t1) (make_ty t2) -make_co (SymCo co) = C.SymCoercion (make_co co) -make_co (TransCo c1 c2) = C.TransCoercion (make_co c1) (make_co c2) -make_co (NthCo d co) = C.NthCoercion d (make_co co) -make_co (InstCo co ty) = C.InstCoercion (make_co co) (make_ty ty) +make_var_qid :: DynFlags -> Bool -> Name -> C.Qual C.Id +make_var_qid dflags force_unqual = make_qid dflags force_unqual True + +make_con_qid :: DynFlags -> Name -> C.Qual C.Id +make_con_qid dflags = make_qid dflags False False + +make_co :: DynFlags -> Coercion -> C.Ty +make_co dflags (Refl ty) = make_ty dflags ty +make_co dflags (TyConAppCo tc cos) = make_conAppCo dflags (qtc dflags tc) cos +make_co dflags (AppCo c1 c2) = C.Tapp (make_co dflags c1) (make_co dflags c2) +make_co dflags (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co dflags co) +make_co _ (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv)) +make_co dflags (AxiomInstCo cc cos) = make_conAppCo dflags (qcc dflags cc) cos +make_co dflags (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty dflags t1) (make_ty dflags t2) +make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co) +make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2) +make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co) +make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty) -- Used for both tycon app coercions and axiom instantiations. -make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty -make_conAppCo con cos = +make_conAppCo :: DynFlags -> C.Qual C.Tcon -> [Coercion] -> C.Ty +make_conAppCo dflags con cos = foldl C.Tapp (C.Tcon con) - (map make_co cos) + (map (make_co dflags) cos) ------- isALocal :: Name -> CoreM Bool isALocal vName = do - modName <- ask + modName <- liftM cs_module ask return $ case nameModule_maybe vName of -- Not sure whether isInternalName corresponds to "local"ness -- in the External Core sense; need to re-read the spec. diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 7487c66025..39910c0812 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -6,17 +6,10 @@ Printing of Core syntax \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PprCore ( - pprCoreExpr, pprParendExpr, - pprCoreBinding, pprCoreBindings, pprCoreAlt, - pprRules + pprCoreExpr, pprParendExpr, + pprCoreBinding, pprCoreBindings, pprCoreAlt, + pprRules ) where import CoreSyn @@ -29,8 +22,8 @@ import Demand import DataCon import TyCon import Type -import Kind import Coercion +import DynFlags import StaticFlags import BasicTypes import Util @@ -40,9 +33,9 @@ import Data.Maybe \end{code} %************************************************************************ -%* * +%* * \subsection{Public interfaces for Core printing (excluding instances)} -%* * +%* * %************************************************************************ @pprParendCoreExpr@ puts parens around non-atomic Core expressions. @@ -54,7 +47,7 @@ pprCoreExpr :: OutputableBndr b => Expr b -> SDoc pprParendExpr :: OutputableBndr b => Expr b -> SDoc pprCoreBindings = pprTopBinds -pprCoreBinding = pprTopBind +pprCoreBinding = pprTopBind instance OutputableBndr b => Outputable (Bind b) where ppr bind = ppr_bind bind @@ -65,9 +58,9 @@ instance OutputableBndr b => Outputable (Expr b) where %************************************************************************ -%* * +%* * \subsection{The guts} -%* * +%* * %************************************************************************ \begin{code} @@ -82,23 +75,23 @@ pprTopBind (Rec []) = ptext (sLit "Rec { }") pprTopBind (Rec (b:bs)) = vcat [ptext (sLit "Rec {"), - ppr_binding b, - vcat [blankLine $$ ppr_binding b | b <- bs], - ptext (sLit "end Rec }"), - blankLine] + ppr_binding b, + vcat [blankLine $$ ppr_binding b | b <- bs], + ptext (sLit "end Rec }"), + blankLine] \end{code} \begin{code} ppr_bind :: OutputableBndr b => Bind b -> SDoc ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr) -ppr_bind (Rec binds) = vcat (map pp binds) - where - pp bind = ppr_binding bind <> semi +ppr_bind (Rec binds) = vcat (map pp binds) + where + pp bind = ppr_binding bind <> semi ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc ppr_binding (val_bdr, expr) - = pprBndr LetBind val_bdr $$ + = pprBndr LetBind val_bdr $$ hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr) \end{code} @@ -112,95 +105,94 @@ noParens pp = pp \begin{code} ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc - -- The function adds parens in context that need - -- an atomic value (e.g. function args) + -- The function adds parens in context that need + -- an atomic value (e.g. function args) ppr_expr _ (Var name) = ppr name -ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd +ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co) ppr_expr add_par (Lit lit) = pprLiteral add_par lit -ppr_expr add_par (Cast expr co) +ppr_expr add_par (Cast expr co) = add_par $ - sep [pprParendExpr expr, - ptext (sLit "`cast`") <+> pprCo co] + sep [pprParendExpr expr, + ptext (sLit "`cast`") <+> pprCo co] where pprCo co | opt_SuppressCoercions = ptext (sLit "...") | otherwise = parens $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)] - + ppr_expr add_par expr@(Lam _ _) = let - (bndrs, body) = collectBinders expr + (bndrs, body) = collectBinders expr in add_par $ hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) - 2 (pprCoreExpr body) + 2 (pprCoreExpr body) ppr_expr add_par expr@(App {}) - = case collectArgs expr of { (fun, args) -> + = case collectArgs expr of { (fun, args) -> let - pp_args = sep (map pprArg args) - val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples - pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args)) + pp_args = sep (map pprArg args) + val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples + pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args)) in case fun of - Var f -> case isDataConWorkId_maybe f of - -- Notice that we print the *worker* - -- for tuples in paren'd format. - Just dc | saturated && isTupleTyCon tc - -> tupleParens (tupleTyConSort tc) pp_tup_args - where - tc = dataConTyCon dc - saturated = val_args `lengthIs` idArity f - - _ -> add_par (hang (ppr f) 2 pp_args) - - _ -> add_par (hang (pprParendExpr fun) 2 pp_args) + Var f -> case isDataConWorkId_maybe f of + -- Notice that we print the *worker* + -- for tuples in paren'd format. + Just dc | saturated && isTupleTyCon tc + -> tupleParens (tupleTyConSort tc) pp_tup_args + where + tc = dataConTyCon dc + saturated = val_args `lengthIs` idArity f + + _ -> add_par (hang (ppr f) 2 pp_args) + + _ -> add_par (hang (pprParendExpr fun) 2 pp_args) } ppr_expr add_par (Case expr var ty [(con,args,rhs)]) - | opt_PprCaseAsLet - = add_par $ - sep [sep [ ptext (sLit "let") - <+> char '{' - <+> ppr_case_pat con args - <+> ptext (sLit "~") - <+> ppr_bndr var - , ptext (sLit "<-") - <+> ppr_expr id expr - , char '}' - <+> ptext (sLit "in") - ] - , pprCoreExpr rhs - ] - - | otherwise - = add_par $ - sep [sep [ptext (sLit "case") <+> pprCoreExpr expr, - ifPprDebug (braces (ppr ty)), - sep [ptext (sLit "of") <+> ppr_bndr var, - char '{' <+> ppr_case_pat con args <+> arrow] - ], - pprCoreExpr rhs, - char '}' - ] + = sdocWithDynFlags $ \dflags -> + if dopt Opt_PprCaseAsLet dflags + then add_par $ + sep [sep [ ptext (sLit "let") + <+> char '{' + <+> ppr_case_pat con args + <+> ptext (sLit "~") + <+> ppr_bndr var + , ptext (sLit "<-") + <+> ppr_expr id expr + , char '}' + <+> ptext (sLit "in") + ] + , pprCoreExpr rhs + ] + else add_par $ + sep [sep [ptext (sLit "case") <+> pprCoreExpr expr, + ifPprDebug (braces (ppr ty)), + sep [ptext (sLit "of") <+> ppr_bndr var, + char '{' <+> ppr_case_pat con args <+> arrow] + ], + pprCoreExpr rhs, + char '}' + ] where ppr_bndr = pprBndr CaseBind ppr_expr add_par (Case expr var ty alts) = add_par $ sep [sep [ptext (sLit "case") - <+> pprCoreExpr expr - <+> ifPprDebug (braces (ppr ty)), - ptext (sLit "of") <+> ppr_bndr var <+> char '{'], - nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), - char '}' + <+> pprCoreExpr expr + <+> ifPprDebug (braces (ppr ty)), + ptext (sLit "of") <+> ppr_bndr var <+> char '{'], + nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), + char '}' ] where ppr_bndr = pprBndr CaseBind - + -- special cases: let ... in let ... -- ("disgusting" SLPJ) @@ -217,8 +209,8 @@ ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = add_par (hang (ptext (sLit "let {")) - 2 (hsep [ppr_binding (val_bdr,rhs), - ptext (sLit "} in")]) + 2 (hsep [ppr_binding (val_bdr,rhs), + ptext (sLit "} in")]) $$ pprCoreExpr expr) -} @@ -227,17 +219,17 @@ ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) ppr_expr add_par (Let bind expr) = add_par $ sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")), - pprCoreExpr expr] + pprCoreExpr expr] where keyword = case bind of - Rec _ -> (sLit "letrec {") - NonRec _ _ -> (sLit "let {") + Rec _ -> (sLit "letrec {") + NonRec _ _ -> (sLit "let {") ppr_expr add_par (Tick tickish expr) = add_par (sep [ppr tickish, pprCoreExpr expr]) pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc -pprCoreAlt (con, args, rhs) +pprCoreAlt (con, args, rhs) = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc @@ -256,9 +248,9 @@ ppr_case_pat con args -- | Pretty print the argument in a function application. pprArg :: OutputableBndr a => Expr a -> SDoc -pprArg (Type ty) - | opt_SuppressTypeApplications = empty - | otherwise = ptext (sLit "@") <+> pprParendType ty +pprArg (Type ty) + | opt_SuppressTypeApplications = empty + | otherwise = ptext (sLit "@") <+> pprParendType ty pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co pprArg expr = pprParendExpr expr \end{code} @@ -275,17 +267,17 @@ instance OutputableBndr Var where pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder | isTyVar binder = pprKindedTyVarBndr binder - | otherwise = pprTypedLetBinder binder $$ - ppIdInfo binder (idInfo binder) + | otherwise = pprTypedLetBinder binder $$ + ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" -pprCoreBinder bind_site bndr +pprCoreBinder bind_site bndr = getPprStyle $ \ sty -> pprTypedLamBinder bind_site (debugStyle sty) bndr pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder - | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind + | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc @@ -295,7 +287,7 @@ pprTypedLamBinder bind_site debug_on var | not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info | opt_SuppressAll = pprUntypedBinder var -- Suppress the signature | isTyVar var = parens (pprKindedTyVarBndr var) - | otherwise = parens (hang (pprIdBndr var) + | otherwise = parens (hang (pprIdBndr var) 2 (vcat [ dcolon <+> pprType (idType var), pp_unf])) where unf_info = unfoldingInfo (idInfo var) @@ -305,19 +297,14 @@ pprTypedLamBinder bind_site debug_on var pprTypedLetBinder :: Var -> SDoc -- Print binder with a type or kind signature (not paren'd) pprTypedLetBinder binder - | isTyVar binder = pprKindedTyVarBndr binder + | isTyVar binder = pprKindedTyVarBndr binder | opt_SuppressTypeSignatures = pprIdBndr binder - | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) + | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) pprKindedTyVarBndr tyvar - = ptext (sLit "@") <+> ppr tyvar <> opt_kind - where - opt_kind -- Print the kind if not * - | isLiftedTypeKind kind = empty - | otherwise = dcolon <> pprKind kind - kind = tyVarKind tyvar + = ptext (sLit "@") <+> pprTvBndr tyvar -- pprIdBndr does *not* print the type -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness @@ -325,7 +312,7 @@ pprIdBndr :: Id -> SDoc pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) pprIdBndrInfo :: IdInfo -> SDoc -pprIdBndrInfo info +pprIdBndrInfo info | opt_SuppressIdInfo = empty | otherwise = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes @@ -340,23 +327,23 @@ pprIdBndrInfo info has_dmd = case dmd_info of { Nothing -> False; Just d -> not (isTop d) } has_lbv = not (hasNoLBVarInfo lbv_info) - doc = showAttributes - [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info) - , (has_occ, ptext (sLit "Occ=") <> ppr occ_info) - , (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info) - , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info) - ] + doc = showAttributes + [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info) + , (has_occ, ptext (sLit "Occ=") <> ppr occ_info) + , (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info) + , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info) + ] \end{code} ----------------------------------------------------- --- IdDetails and IdInfo +-- IdDetails and IdInfo ----------------------------------------------------- \begin{code} ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo id info - | opt_SuppressIdInfo = empty + | opt_SuppressIdInfo = empty | otherwise = showAttributes [ (True, pp_scope <> ppr (idDetails id)) @@ -365,13 +352,13 @@ ppIdInfo id info , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info) , (has_unf, ptext (sLit "Unf=") <> ppr unf_info) , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules)) - ] -- Inline pragma, occ, demand, lbvar info - -- printed out with all binders (when debug is on); - -- see PprCore.pprIdBndr + ] -- Inline pragma, occ, demand, lbvar info + -- printed out with all binders (when debug is on); + -- see PprCore.pprIdBndr where pp_scope | isGlobalId id = ptext (sLit "GblId") - | isExportedId id = ptext (sLit "LclIdX") - | otherwise = ptext (sLit "LclId") + | isExportedId id = ptext (sLit "LclIdX") + | otherwise = ptext (sLit "LclId") arity = arityInfo info has_arity = arity /= 0 @@ -388,7 +375,7 @@ ppIdInfo id info rules = specInfoRules (specInfo info) showAttributes :: [(Bool,SDoc)] -> SDoc -showAttributes stuff +showAttributes stuff | null docs = empty | otherwise = brackets (sep (punctuate comma docs)) where @@ -396,21 +383,21 @@ showAttributes stuff \end{code} ----------------------------------------------------- --- Unfolding and UnfoldingGuidance +-- Unfolding and UnfoldingGuidance ----------------------------------------------------- \begin{code} instance Outputable UnfoldingGuidance where ppr UnfNever = ptext (sLit "NEVER") ppr (UnfWhen unsat_ok boring_ok) - = ptext (sLit "ALWAYS_IF") <> + = ptext (sLit "ALWAYS_IF") <> parens (ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <> ptext (sLit "boring_ok=") <> ppr boring_ok) ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) - = hsep [ ptext (sLit "IF_ARGS"), - brackets (hsep (map int cs)), - int size, - int discount ] + = hsep [ ptext (sLit "IF_ARGS"), + brackets (hsep (map int cs)), + int size, + int discount ] instance Outputable UnfoldingSource where ppr InlineCompulsory = ptext (sLit "Compulsory") @@ -419,30 +406,34 @@ instance Outputable UnfoldingSource where ppr InlineRhs = ptext (sLit "<vanilla>") instance Outputable Unfolding where - ppr NoUnfolding = ptext (sLit "No unfolding") - ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs - ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar) + ppr NoUnfolding = ptext (sLit "No unfolding") + ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs + ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar) <+> ppr con <+> brackets (pprWithCommas ppr ops) ppr (CoreUnfolding { uf_src = src , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf - , uf_is_conlike=conlike, uf_is_cheap=cheap - , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) - = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs) + , uf_is_conlike=conlike, uf_is_work_free=wf + , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) + = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs) where - pp_info = fsep $ punctuate comma + pp_info = fsep $ punctuate comma [ ptext (sLit "Src=") <> ppr src - , ptext (sLit "TopLvl=") <> ppr top + , ptext (sLit "TopLvl=") <> ppr top , ptext (sLit "Arity=") <> int arity , ptext (sLit "Value=") <> ppr hnf , ptext (sLit "ConLike=") <> ppr conlike - , ptext (sLit "Cheap=") <> ppr cheap + , ptext (sLit "WorkFree=") <> ppr wf , ptext (sLit "Expandable=") <> ppr exp , ptext (sLit "Guidance=") <> ppr g ] pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs pp_rhs | isStableSource src = pp_tmpl | otherwise = empty - -- Don't print the RHS or we get a quadratic - -- blowup in the size of the printout! + -- Don't print the RHS or we get a quadratic + -- blowup in the size of the printout! + +instance Outputable e => Outputable (DFunArg e) where + ppr (DFunPolyArg e) = braces (ppr e) + ppr (DFunLamArg i) = char '<' <> int i <> char '>' \end{code} ----------------------------------------------------- @@ -464,7 +455,7 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) = hang (doubleQuotes (ftext name) <+> ppr act) - 4 (sep [ptext (sLit "forall") <+> + 4 (sep [ptext (sLit "forall") <+> sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, nest 2 (ppr fn <+> sep (map pprArg tpl_args)), nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index d8a134ed87..18e4dd82a6 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -14,7 +14,7 @@ {-# LANGUAGE TypeFamilies #-} module TrieMap( CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, - TypeMap, foldTypeMap, + TypeMap, foldTypeMap, lookupTypeMap_mod, CoercionMap, MaybeMap, ListMap, @@ -30,6 +30,9 @@ import TypeRep import Var import UniqFM import Unique( Unique ) +import FastString(FastString) + +import Unify ( niFixTvSubst ) import qualified Data.Map as Map import qualified Data.IntMap as IntMap @@ -236,22 +239,37 @@ Note [Binders] - the binders in an alternative because they are totally fixed by the context +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* For a key (Case e b ty (alt:alts)) we don't need to look the return type + 'ty', because every alternative has that type. + +* For a key (Case e b ty []) we MUST look at the return type 'ty', because + otherwise (Case (error () "urk") _ Int []) would compare equal to + (Case (error () "urk") _ Bool []) + which is utterly wrong (Trac #6097) + +We could compare the return type regardless, but the wildly common case +is that it's unnecesary, so we have two fields (cm_case and cm_ecase) +for the two possibilities. Only cm_ecase looks at the type. + +See also Note [Empty case alternatives] in CoreSyn. \begin{code} data CoreMap a = EmptyCM - | CM { cm_var :: VarMap a - , cm_lit :: LiteralMap a - , cm_co :: CoercionMap a - , cm_type :: TypeMap a - , cm_cast :: CoreMap (CoercionMap a) - , cm_source :: CoreMap (TickishMap a) - , cm_app :: CoreMap (CoreMap a) - , cm_lam :: CoreMap (TypeMap a) - , cm_letn :: CoreMap (CoreMap (BndrMap a)) - , cm_letr :: ListMap CoreMap (CoreMap (ListMap BndrMap a)) - , cm_case :: CoreMap (ListMap AltMap a) - -- Note [Binders] + | CM { cm_var :: VarMap a + , cm_lit :: LiteralMap a + , cm_co :: CoercionMap a + , cm_type :: TypeMap a + , cm_cast :: CoreMap (CoercionMap a) + , cm_tick :: CoreMap (TickishMap a) + , cm_app :: CoreMap (CoreMap a) + , cm_lam :: CoreMap (TypeMap a) -- Note [Binders] + , cm_letn :: CoreMap (CoreMap (BndrMap a)) + , cm_letr :: ListMap CoreMap (CoreMap (ListMap BndrMap a)) + , cm_case :: CoreMap (ListMap AltMap a) + , cm_ecase :: CoreMap (TypeMap a) -- Note [Empty case alternatives] } @@ -261,7 +279,7 @@ wrapEmptyCM = CM { cm_var = emptyTM, cm_lit = emptyLiteralMap , cm_cast = emptyTM, cm_app = emptyTM , cm_lam = emptyTM, cm_letn = emptyTM , cm_letr = emptyTM, cm_case = emptyTM - , cm_source = emptyTM } + , cm_ecase = emptyTM, cm_tick = emptyTM } instance TrieMap CoreMap where type Key CoreMap = CoreExpr @@ -295,12 +313,13 @@ fdE k m . foldTM k (cm_co m) . foldTM k (cm_type m) . foldTM (foldTM k) (cm_cast m) - . foldTM (foldTM k) (cm_source m) + . foldTM (foldTM k) (cm_tick m) . foldTM (foldTM k) (cm_app m) . foldTM (foldTM k) (cm_lam m) . foldTM (foldTM (foldTM k)) (cm_letn m) . foldTM (foldTM (foldTM k)) (cm_letr m) . foldTM (foldTM k) (cm_case m) + . foldTM (foldTM k) (cm_ecase m) lkE :: CmEnv -> CoreExpr -> CoreMap a -> Maybe a -- lkE: lookup in trie for expressions @@ -313,9 +332,9 @@ lkE env expr cm go (Type t) = cm_type >.> lkT env t go (Coercion c) = cm_co >.> lkC env c go (Cast e c) = cm_cast >.> lkE env e >=> lkC env c - go (Tick tickish e) = cm_source >.> lkE env e >=> lkTickish tickish - go (App e1 e2) = cm_app >.> lkE env e2 >=> lkE env e1 - go (Lam v e) = cm_lam >.> lkE (extendCME env v) e >=> lkBndr env v + go (Tick tickish e) = cm_tick >.> lkE env e >=> lkTickish tickish + go (App e1 e2) = cm_app >.> lkE env e2 >=> lkE env e1 + go (Lam v e) = cm_lam >.> lkE (extendCME env v) e >=> lkBndr env v go (Let (NonRec b r) e) = cm_letn >.> lkE env r >=> lkE (extendCME env b) e >=> lkBndr env b go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs @@ -323,7 +342,9 @@ lkE env expr cm in cm_letr >.> lkList (lkE env1) rhss >=> lkE env1 e >=> lkList (lkBndr env1) bndrs - go (Case e b _ as) = cm_case >.> lkE env e + go (Case e b ty as) -- See Note [Empty case alternatives] + | null as = cm_ecase >.> lkE env e >=> lkT env ty + | otherwise = cm_case >.> lkE env e >=> lkList (lkA (extendCME env b)) as xtE :: CmEnv -> CoreExpr -> XT a -> CoreMap a -> CoreMap a @@ -334,7 +355,7 @@ xtE env (Coercion c) f m = m { cm_co = cm_co m |> xtC env c f } xtE _ (Lit l) f m = m { cm_lit = cm_lit m |> xtLit l f } xtE env (Cast e c) f m = m { cm_cast = cm_cast m |> xtE env e |>> xtC env c f } -xtE env (Tick t e) f m = m { cm_source = cm_source m |> xtE env e |>> xtTickish t f } +xtE env (Tick t e) f m = m { cm_tick = cm_tick m |> xtE env e |>> xtTickish t f } xtE env (App e1 e2) f m = m { cm_app = cm_app m |> xtE env e2 |>> xtE env e1 f } xtE env (Lam v e) f m = m { cm_lam = cm_lam m |> xtE (extendCME env v) e |>> xtBndr env v f } @@ -347,7 +368,9 @@ xtE env (Let (Rec prs) e) f m = m { cm_letr = let (bndrs,rhss) = unzip prs |> xtList (xtE env1) rhss |>> xtE env1 e |>> xtList (xtBndr env1) bndrs f } -xtE env (Case e b _ as) f m = m { cm_case = cm_case m |> xtE env e +xtE env (Case e b ty as) f m + | null as = m { cm_ecase = cm_ecase m |> xtE env e |>> xtT env ty f } + | otherwise = m { cm_case = cm_case m |> xtE env e |>> let env1 = extendCME env b in xtList (xtA env1) as f } @@ -486,7 +509,10 @@ data TypeMap a , tm_app :: TypeMap (TypeMap a) , tm_fun :: TypeMap (TypeMap a) , tm_tc_app :: NameEnv (ListMap TypeMap a) - , tm_forall :: TypeMap (BndrMap a) } + , tm_forall :: TypeMap (BndrMap a) + , tm_tylit :: TyLitMap a + } + instance Outputable a => Outputable (TypeMap a) where ppr m = text "TypeMap elts" <+> ppr (foldTypeMap (:) [] m) @@ -499,7 +525,8 @@ wrapEmptyTypeMap = TM { tm_var = emptyTM , tm_app = EmptyTM , tm_fun = EmptyTM , tm_tc_app = emptyNameEnv - , tm_forall = EmptyTM } + , tm_forall = EmptyTM + , tm_tylit = emptyTyLitMap } instance TrieMap TypeMap where type Key TypeMap = Type @@ -519,8 +546,44 @@ lkT env ty m go (AppTy t1 t2) = tm_app >.> lkT env t1 >=> lkT env t2 go (FunTy t1 t2) = tm_fun >.> lkT env t1 >=> lkT env t2 go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys + go (LitTy l) = tm_tylit >.> lkTyLit l go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv + +lkT_mod :: CmEnv + -> TyVarEnv Type -- TvSubstEnv + -> Type + -> TypeMap b -> Maybe b +lkT_mod env s ty m + | EmptyTM <- m = Nothing + | Just ty' <- coreView ty + = lkT_mod env s ty' m + | [] <- candidates + = go env s ty m + | otherwise + = Just $ snd (head candidates) -- Yikes! + where + -- Hopefully intersects is much smaller than traversing the whole vm_fvar + intersects = eltsUFM $ + intersectUFM_C (,) s (vm_fvar $ tm_var m) + candidates = [ (u,ct) | (u,ct) <- intersects + , Type.substTy (niFixTvSubst s) u `eqType` ty ] + + go env _s (TyVarTy v) = tm_var >.> lkVar env v + go env s (AppTy t1 t2) = tm_app >.> lkT_mod env s t1 >=> lkT_mod env s t2 + go env s (FunTy t1 t2) = tm_fun >.> lkT_mod env s t1 >=> lkT_mod env s t2 + go env s (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT_mod env s) tys + go _env _s (LitTy l) = tm_tylit >.> lkTyLit l + go _env _s (ForAllTy _tv _ty) = const Nothing + + {- DV TODO: Add proper lookup for ForAll -} + +lookupTypeMap_mod :: TyVarEnv a -- A substitution to be applied to the /keys/ of type map + -> (a -> Type) + -> Type + -> TypeMap b -> Maybe b +lookupTypeMap_mod s f = lkT_mod emptyCME (mapVarEnv f s) + ----------------- xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a xtT env ty f m @@ -534,6 +597,7 @@ xtT env (ForAllTy tv ty) f m = m { tm_forall = tm_forall m |> xtT (extendCME e |>> xtBndr env tv f } xtT env (TyConApp tc tys) f m = m { tm_tc_app = tm_tc_app m |> xtNamed tc |>> xtList (xtT env) tys f } +xtT _ (LitTy l) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } fdT :: (a -> b -> b) -> TypeMap a -> b -> b fdT _ EmptyTM = \z -> z @@ -542,6 +606,33 @@ fdT k m = foldTM k (tm_var m) . foldTM (foldTM k) (tm_fun m) . foldTM (foldTM k) (tm_tc_app m) . foldTM (foldTM k) (tm_forall m) + . foldTyLit k (tm_tylit m) + + + +------------------------ +data TyLitMap a = TLM { tlm_number :: Map.Map Integer a + , tlm_string :: Map.Map FastString a + } + +emptyTyLitMap :: TyLitMap a +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty } + +lkTyLit :: TyLit -> TyLitMap a -> Maybe a +lkTyLit l = + case l of + NumTyLit n -> tlm_number >.> Map.lookup n + StrTyLit n -> tlm_string >.> Map.lookup n + +xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a +xtTyLit l f m = + case l of + NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n } + StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n } + +foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b +foldTyLit l m = flip (Map.fold l) (tlm_string m) + . flip (Map.fold l) (tlm_number m) \end{code} diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 2d0ad237fc..2a4486eb69 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -3,13 +3,6 @@ % (c) University of Glasgow, 2007 % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Coverage (addTicksToBinds, hpcInitCode) where import Type @@ -29,7 +22,7 @@ import Id import VarSet import Data.List import FastString -import HscTypes +import HscTypes import Platform import StaticFlags import TyCon @@ -47,17 +40,16 @@ import System.Directory import Trace.Hpc.Mix import Trace.Hpc.Util -import BreakArray -import Data.HashTable ( hashString ) +import BreakArray import Data.Map (Map) import qualified Data.Map as Map \end{code} %************************************************************************ -%* * +%* * %* The main function: addTicksToBinds -%* * +%* * %************************************************************************ \begin{code} @@ -81,16 +73,17 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds = if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do - + let orig_file2 = guessSourceFile binds orig_file (binds1,_,st) - = unTM (addTickLHsBinds binds) - (TTE + = unTM (addTickLHsBinds binds) + (TTE { fileName = mkFastString orig_file2 - , declPath = [] - , dflags = dflags + , declPath = [] + , tte_dflags = dflags , exports = exports + , inlines = emptyVarSet , inScope = emptyVarSet , blackList = Map.fromList [ (getSrcSpan (tyConName tyCon),()) @@ -98,10 +91,10 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds = , density = mkDensity dflags , this_mod = mod }) - (TT - { tickBoxCount = 0 - , mixEntries = [] - }) + (TT + { tickBoxCount = 0 + , mixEntries = [] + }) let entries = reverse $ mixEntries st @@ -109,8 +102,10 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds = hashNo <- writeMixEntries dflags mod count entries orig_file2 modBreaks <- mkModBreaks count entries - doIfSet_dyn dflags Opt_D_dump_ticked $ printDump (pprLHsBinds binds1) - + doIfSet_dyn dflags Opt_D_dump_ticked $ + log_action dflags dflags SevDump noSrcSpan defaultDumpStyle + (pprLHsBinds binds1) + return (binds1, HpcInfo count hashNo, modBreaks) @@ -134,12 +129,12 @@ mkModBreaks count entries = do locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] declsTicks= listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ] - modBreaks = emptyModBreaks - { modBreaks_flags = breakArray - , modBreaks_locs = locsTicks + modBreaks = emptyModBreaks + { modBreaks_flags = breakArray + , modBreaks_locs = locsTicks , modBreaks_vars = varsTicks , modBreaks_decls = declsTicks - } + } -- return modBreaks @@ -155,17 +150,17 @@ writeMixEntries dflags mod count entries filename hpc_mod_dir | modulePackageId mod == mainPackageId = hpc_dir | otherwise = hpc_dir ++ "/" ++ packageIdString (modulePackageId mod) - + tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges. createDirectoryIfMissing True hpc_mod_dir modTime <- getModificationUTCTime filename - let entries' = [ (hpcPos, box) + let entries' = [ (hpcPos, box) | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] when (length entries' /= count) $ do panic "the number of .mix entries are inconsistent" let hashNo = mixHash filename modTime tabStop entries' - mixCreate hpc_mod_dir mod_name + mixCreate hpc_mod_dir mod_name $ Mix filename modTime (toHash hashNo) tabStop entries' return hashNo @@ -236,6 +231,7 @@ addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, abs_exports = abs_exports })) = do withEnv add_exports $ do + withEnv add_inlines $ do binds' <- addTickLHsBinds binds return $ L pos $ bind { abs_binds = binds' } where @@ -250,17 +246,31 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports , idName pid `elemNameSet` (exports env) ] } + add_inlines env = + env{ inlines = inlines env `extendVarSetList` + [ mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , isAnyInlinePragma (idInlinePragma pid) ] } + + addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do let name = getOccString id decl_path <- getPathEntry + density <- getDensity + + inline_ids <- liftM inlines getEnv + let inline = isAnyInlinePragma (idInlinePragma id) + || id `elemVarSet` inline_ids + + -- See Note [inline sccs] + if inline && opt_SccProfilingOn then return (L pos funBind) else do - (fvs, (MatchGroup matches' ty)) <- + (fvs, (MatchGroup matches' ty)) <- getFreeVars $ addPathEntry name $ addTickMatchGroup False (fun_matches funBind) blackListed <- isBlackListed pos - density <- getDensity exported_names <- liftM exports getEnv -- We don't want to generate code for blacklisted positions @@ -269,8 +279,6 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do let simple = isSimplePatBind funBind toplev = null decl_path exported = idName id `elemNameSet` exported_names - inline = {- pprTrace "inline" (ppr id <+> ppr (idInlinePragma id)) $ -} - isAnyInlinePragma (idInlinePragma id) tick <- if not blackListed && shouldTickBind density toplev exported simple inline @@ -326,6 +334,21 @@ bindTick density name pos fvs = do allocATickBox box_label count_entries top_only pos fvs +-- Note [inline sccs] +-- +-- It should be reasonable to add ticks to INLINE functions; however +-- currently this tickles a bug later on because the SCCfinal pass +-- does not look inside unfoldings to find CostCentres. It would be +-- difficult to fix that, because SCCfinal currently works on STG and +-- not Core (and since it also generates CostCentres for CAFs, +-- changing this would be difficult too). +-- +-- Another reason not to add ticks to INLINE functions is that this +-- sometimes handy for avoiding adding a tick to a particular function +-- (see #6131) +-- +-- So for now we do not add any ticks to INLINE functions at all. + -- ----------------------------------------------------------------------------- -- Decorate an LHsExpr with ticks @@ -387,7 +410,7 @@ addTickLHsExprLetBody e@(L pos e0) = do dont_tick_it = addTickLHsExprNever e -- version of addTick that does not actually add a tick, --- because the scope of this tick is completely subsumed by +-- because the scope of this tick is completely subsumed by -- another. addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id) addTickLHsExprNever (L pos e0) = do @@ -405,7 +428,7 @@ isGoodBreakExpr (RecordCon {}) = True isGoodBreakExpr (RecordUpd {}) = True isGoodBreakExpr (ArithSeq {}) = True isGoodBreakExpr (PArrSeq {}) = True -isGoodBreakExpr _other = False +isGoodBreakExpr _other = False isCallSite :: HsExpr Id -> Bool isCallSite HsApp{} = True @@ -436,108 +459,108 @@ addTickHsExpr e@(HsLit _) = return e addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup) addTickHsExpr (HsApp e1 e2) = - liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2) -addTickHsExpr (OpApp e1 e2 fix e3) = - liftM4 OpApp - (addTickLHsExpr e1) - (addTickLHsExprNever e2) - (return fix) + liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2) +addTickHsExpr (OpApp e1 e2 fix e3) = + liftM4 OpApp + (addTickLHsExpr e1) + (addTickLHsExprNever e2) + (return fix) (addTickLHsExpr e3) addTickHsExpr (NegApp e neg) = - liftM2 NegApp - (addTickLHsExpr e) - (addTickSyntaxExpr hpcSrcSpan neg) + liftM2 NegApp + (addTickLHsExpr e) + (addTickSyntaxExpr hpcSrcSpan neg) addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExprEvalInner e) addTickHsExpr (SectionL e1 e2) = - liftM2 SectionL - (addTickLHsExpr e1) + liftM2 SectionL + (addTickLHsExpr e1) (addTickLHsExprNever e2) -addTickHsExpr (SectionR e1 e2) = - liftM2 SectionR +addTickHsExpr (SectionR e1 e2) = + liftM2 SectionR (addTickLHsExprNever e1) - (addTickLHsExpr e2) + (addTickLHsExpr e2) addTickHsExpr (ExplicitTuple es boxity) = liftM2 ExplicitTuple (mapM addTickTupArg es) (return boxity) -addTickHsExpr (HsCase e mgs) = - liftM2 HsCase +addTickHsExpr (HsCase e mgs) = + liftM2 HsCase (addTickLHsExpr e) -- not an EvalInner; e might not necessarily -- be evaluated. (addTickMatchGroup False mgs) -addTickHsExpr (HsIf cnd e1 e2 e3) = - liftM3 (HsIf cnd) - (addBinTickLHsExpr (BinBox CondBinBox) e1) - (addTickLHsExprOptAlt True e2) - (addTickLHsExprOptAlt True e3) +addTickHsExpr (HsIf cnd e1 e2 e3) = + liftM3 (HsIf cnd) + (addBinTickLHsExpr (BinBox CondBinBox) e1) + (addTickLHsExprOptAlt True e2) + (addTickLHsExprOptAlt True e3) addTickHsExpr (HsLet binds e) = - bindLocals (collectLocalBinders binds) $ - liftM2 HsLet - (addTickHsLocalBinds binds) -- to think about: !patterns. + bindLocals (collectLocalBinders binds) $ + liftM2 HsLet + (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprLetBody e) -addTickHsExpr (HsDo cxt stmts srcloc) +addTickHsExpr (HsDo cxt stmts srcloc) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) ; return (HsDo cxt stmts' srcloc) } where - forQual = case cxt of - ListComp -> Just $ BinBox QualBinBox - _ -> Nothing -addTickHsExpr (ExplicitList ty es) = - liftM2 ExplicitList - (return ty) - (mapM (addTickLHsExpr) es) + forQual = case cxt of + ListComp -> Just $ BinBox QualBinBox + _ -> Nothing +addTickHsExpr (ExplicitList ty es) = + liftM2 ExplicitList + (return ty) + (mapM (addTickLHsExpr) es) addTickHsExpr (ExplicitPArr ty es) = - liftM2 ExplicitPArr - (return ty) - (mapM (addTickLHsExpr) es) -addTickHsExpr (RecordCon id ty rec_binds) = - liftM3 RecordCon - (return id) - (return ty) - (addTickHsRecordBinds rec_binds) + liftM2 ExplicitPArr + (return ty) + (mapM (addTickLHsExpr) es) +addTickHsExpr (RecordCon id ty rec_binds) = + liftM3 RecordCon + (return id) + (return ty) + (addTickHsRecordBinds rec_binds) addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) = - liftM5 RecordUpd - (addTickLHsExpr e) - (addTickHsRecordBinds rec_binds) - (return cons) (return tys1) (return tys2) + liftM5 RecordUpd + (addTickLHsExpr e) + (addTickHsRecordBinds rec_binds) + (return cons) (return tys1) (return tys2) addTickHsExpr (ExprWithTySigOut e ty) = - liftM2 ExprWithTySigOut - (addTickLHsExprNever e) -- No need to tick the inner expression - -- for expressions with signatures - (return ty) -addTickHsExpr (ArithSeq ty arith_seq) = - liftM2 ArithSeq - (return ty) - (addTickArithSeqInfo arith_seq) + liftM2 ExprWithTySigOut + (addTickLHsExprNever e) -- No need to tick the inner expression + -- for expressions with signatures + (return ty) +addTickHsExpr (ArithSeq ty arith_seq) = + liftM2 ArithSeq + (return ty) + (addTickArithSeqInfo arith_seq) addTickHsExpr (HsTickPragma _ (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 return $ unLoc e2 -addTickHsExpr (PArrSeq ty arith_seq) = - liftM2 PArrSeq - (return ty) - (addTickArithSeqInfo arith_seq) +addTickHsExpr (PArrSeq ty arith_seq) = + liftM2 PArrSeq + (return ty) + (addTickArithSeqInfo arith_seq) addTickHsExpr (HsSCC nm e) = - liftM2 HsSCC + liftM2 HsSCC (return nm) (addTickLHsExpr e) -addTickHsExpr (HsCoreAnn nm e) = - liftM2 HsCoreAnn +addTickHsExpr (HsCoreAnn nm e) = + liftM2 HsCoreAnn (return nm) (addTickLHsExpr e) addTickHsExpr e@(HsBracket {}) = return e addTickHsExpr e@(HsBracketOut {}) = return e addTickHsExpr e@(HsSpliceE {}) = return e addTickHsExpr (HsProc pat cmdtop) = - liftM2 HsProc - (addTickLPat pat) - (liftL (addTickHsCmdTop) cmdtop) -addTickHsExpr (HsWrap w e) = - liftM2 HsWrap - (return w) - (addTickHsExpr e) -- explicitly no tick on inside + liftM2 HsProc + (addTickLPat pat) + (liftL (addTickHsCmdTop) cmdtop) +addTickHsExpr (HsWrap w e) = + liftM2 HsWrap + (return w) + (addTickHsExpr e) -- explicitly no tick on inside addTickHsExpr e@(HsType _) = return e @@ -592,40 +615,39 @@ addTickLStmts isGuard stmts = do (stmts, _) <- addTickLStmts' isGuard stmts (return ()) return stmts -addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a +addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a -> TM ([LStmt Id], a) addTickLStmts' isGuard lstmts res - = bindLocals (collectLStmtsBinders lstmts) $ + = bindLocals (collectLStmtsBinders lstmts) $ do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts ; a <- res ; return (lstmts', a) } addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id) addTickStmt _isGuard (LastStmt e ret) = do - liftM2 LastStmt - (addTickLHsExpr e) - (addTickSyntaxExpr hpcSrcSpan ret) + liftM2 LastStmt + (addTickLHsExpr e) + (addTickSyntaxExpr hpcSrcSpan ret) addTickStmt _isGuard (BindStmt pat e bind fail) = do - liftM4 BindStmt - (addTickLPat pat) - (addTickLHsExprRHS e) - (addTickSyntaxExpr hpcSrcSpan bind) - (addTickSyntaxExpr hpcSrcSpan fail) + liftM4 BindStmt + (addTickLPat pat) + (addTickLHsExprRHS e) + (addTickSyntaxExpr hpcSrcSpan bind) + (addTickSyntaxExpr hpcSrcSpan fail) addTickStmt isGuard (ExprStmt e bind' guard' ty) = do - liftM4 ExprStmt - (addTick isGuard e) - (addTickSyntaxExpr hpcSrcSpan bind') - (addTickSyntaxExpr hpcSrcSpan guard') - (return ty) + liftM4 ExprStmt + (addTick isGuard e) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') + (return ty) addTickStmt _isGuard (LetStmt binds) = do - liftM LetStmt - (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do - liftM4 ParStmt + liftM LetStmt + (addTickHsLocalBinds binds) +addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do + liftM3 ParStmt (mapM (addTickStmtAndBinders isGuard) pairs) (addTickSyntaxExpr hpcSrcSpan mzipExpr) (addTickSyntaxExpr hpcSrcSpan bindExpr) - (addTickSyntaxExpr hpcSrcSpan returnExpr) addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts , trS_by = by, trS_using = using @@ -652,109 +674,110 @@ addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e | otherwise = addTickLHsExprRHS e -addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a) - -> TM ([LStmt Id], a) -addTickStmtAndBinders isGuard (stmts, ids) = - liftM2 (,) +addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id + -> TM (ParStmtBlock Id Id) +addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) = + liftM3 ParStmtBlock (addTickLStmts isGuard stmts) (return ids) + (addTickSyntaxExpr hpcSrcSpan returnExpr) addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id) -addTickHsLocalBinds (HsValBinds binds) = - liftM HsValBinds - (addTickHsValBinds binds) -addTickHsLocalBinds (HsIPBinds binds) = - liftM HsIPBinds - (addTickHsIPBinds binds) +addTickHsLocalBinds (HsValBinds binds) = + liftM HsValBinds + (addTickHsValBinds binds) +addTickHsLocalBinds (HsIPBinds binds) = + liftM HsIPBinds + (addTickHsIPBinds binds) addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b) addTickHsValBinds (ValBindsOut binds sigs) = - liftM2 ValBindsOut - (mapM (\ (rec,binds') -> - liftM2 (,) - (return rec) - (addTickLHsBinds binds')) - binds) - (return sigs) + liftM2 ValBindsOut + (mapM (\ (rec,binds') -> + liftM2 (,) + (return rec) + (addTickLHsBinds binds')) + binds) + (return sigs) addTickHsValBinds _ = panic "addTickHsValBinds" addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id) addTickHsIPBinds (IPBinds ipbinds dictbinds) = - liftM2 IPBinds - (mapM (liftL (addTickIPBind)) ipbinds) - (return dictbinds) + liftM2 IPBinds + (mapM (liftL (addTickIPBind)) ipbinds) + (return dictbinds) addTickIPBind :: IPBind Id -> TM (IPBind Id) addTickIPBind (IPBind nm e) = - liftM2 IPBind - (return nm) - (addTickLHsExpr e) + liftM2 IPBind + (return nm) + (addTickLHsExpr e) -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id) addTickSyntaxExpr pos x = do - L _ x' <- addTickLHsExpr (L pos x) - return $ x' + L _ x' <- addTickLHsExpr (L pos x) + return $ x' -- we do not walk into patterns. addTickLPat :: LPat Id -> TM (LPat Id) addTickLPat pat = return pat addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id) addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = - liftM4 HsCmdTop - (addTickLHsCmd cmd) - (return tys) - (return ty) - (return syntaxtable) + liftM4 HsCmdTop + (addTickLHsCmd cmd) + (return tys) + (return ty) + (return syntaxtable) addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id) addTickLHsCmd (L pos c0) = do c1 <- addTickHsCmd c0 - return $ L pos c1 + return $ L pos c1 addTickHsCmd :: HsCmd Id -> TM (HsCmd Id) addTickHsCmd (HsLam matchgroup) = liftM HsLam (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsApp c e) = - liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e) -addTickHsCmd (OpApp e1 c2 fix c3) = - liftM4 OpApp - (addTickLHsExpr e1) - (addTickLHsCmd c2) - (return fix) - (addTickLHsCmd c3) +addTickHsCmd (HsApp c e) = + liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e) +addTickHsCmd (OpApp e1 c2 fix c3) = + liftM4 OpApp + (addTickLHsExpr e1) + (addTickLHsCmd c2) + (return fix) + (addTickLHsCmd c3) addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e) -addTickHsCmd (HsCase e mgs) = - liftM2 HsCase - (addTickLHsExpr e) - (addTickCmdMatchGroup mgs) -addTickHsCmd (HsIf cnd e1 c2 c3) = - liftM3 (HsIf cnd) - (addBinTickLHsExpr (BinBox CondBinBox) e1) - (addTickLHsCmd c2) - (addTickLHsCmd c3) +addTickHsCmd (HsCase e mgs) = + liftM2 HsCase + (addTickLHsExpr e) + (addTickCmdMatchGroup mgs) +addTickHsCmd (HsIf cnd e1 c2 c3) = + liftM3 (HsIf cnd) + (addBinTickLHsExpr (BinBox CondBinBox) e1) + (addTickLHsCmd c2) + (addTickLHsCmd c3) addTickHsCmd (HsLet binds c) = - bindLocals (collectLocalBinders binds) $ - liftM2 HsLet - (addTickHsLocalBinds binds) -- to think about: !patterns. + bindLocals (collectLocalBinders binds) $ + liftM2 HsLet + (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) addTickHsCmd (HsDo cxt stmts srcloc) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) ; return (HsDo cxt stmts' srcloc) } -addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) = +addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) = liftM5 HsArrApp - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (return ty1) - (return arr_ty) - (return lr) -addTickHsCmd (HsArrForm e fix cmdtop) = + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (return ty1) + (return arr_ty) + (return lr) +addTickHsCmd (HsArrForm e fix cmdtop) = liftM3 HsArrForm - (addTickLHsExpr e) - (return fix) - (mapM (liftL (addTickHsCmdTop)) cmdtop) + (addTickLHsExpr e) + (return fix) + (mapM (liftL (addTickHsCmdTop)) cmdtop) -- Others should never happen in a command context. addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) @@ -783,7 +806,7 @@ addTickCmdGRHS :: GRHS Id -> TM (GRHS Id) -- The *guards* are *not* Cmds, although the body is -- C.f. addTickGRHS for the BinBox stuff addTickCmdGRHS (GRHS stmts cmd) - = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) + = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickLHsCmd cmd) ; return $ GRHS stmts' expr' } @@ -803,24 +826,24 @@ addTickLCmdStmts' lstmts res addTickCmdStmt :: Stmt Id -> TM (Stmt Id) addTickCmdStmt (BindStmt pat c bind fail) = do - liftM4 BindStmt - (addTickLPat pat) - (addTickLHsCmd c) - (return bind) - (return fail) + liftM4 BindStmt + (addTickLPat pat) + (addTickLHsCmd c) + (return bind) + (return fail) addTickCmdStmt (LastStmt c ret) = do - liftM2 LastStmt - (addTickLHsCmd c) - (addTickSyntaxExpr hpcSrcSpan ret) + liftM2 LastStmt + (addTickLHsCmd c) + (addTickSyntaxExpr hpcSrcSpan ret) addTickCmdStmt (ExprStmt c bind' guard' ty) = do - liftM4 ExprStmt - (addTickLHsCmd c) - (addTickSyntaxExpr hpcSrcSpan bind') + liftM4 ExprStmt + (addTickLHsCmd c) + (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') - (return ty) + (return ty) addTickCmdStmt (LetStmt binds) = do - liftM LetStmt - (addTickHsLocalBinds binds) + liftM LetStmt + (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {}) = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) @@ -833,31 +856,31 @@ addTickCmdStmt stmt@(RecStmt {}) addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id) -addTickHsRecordBinds (HsRecFields fields dd) - = do { fields' <- mapM process fields - ; return (HsRecFields fields' dd) } +addTickHsRecordBinds (HsRecFields fields dd) + = do { fields' <- mapM process fields + ; return (HsRecFields fields' dd) } where process (HsRecField ids expr doc) - = do { expr' <- addTickLHsExpr expr - ; return (HsRecField ids expr' doc) } + = do { expr' <- addTickLHsExpr expr + ; return (HsRecField ids expr' doc) } addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id) addTickArithSeqInfo (From e1) = - liftM From - (addTickLHsExpr e1) + liftM From + (addTickLHsExpr e1) addTickArithSeqInfo (FromThen e1 e2) = - liftM2 FromThen - (addTickLHsExpr e1) - (addTickLHsExpr e2) + liftM2 FromThen + (addTickLHsExpr e1) + (addTickLHsExpr e2) addTickArithSeqInfo (FromTo e1 e2) = - liftM2 FromTo - (addTickLHsExpr e1) - (addTickLHsExpr e2) + liftM2 FromTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) addTickArithSeqInfo (FromThenTo e1 e2 e3) = - liftM3 FromThenTo - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (addTickLHsExpr e3) + liftM3 FromThenTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (addTickLHsExpr e3) liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a) liftL f (L loc a) = do @@ -868,19 +891,20 @@ liftL f (L loc a) = do \begin{code} data TickTransState = TT { tickBoxCount:: Int , mixEntries :: [MixEntry_] - } + } data TickTransEnv = TTE { fileName :: FastString , density :: TickDensity - , dflags :: DynFlags + , tte_dflags :: DynFlags , exports :: NameSet + , inlines :: VarSet , declPath :: [String] , inScope :: VarSet , blackList :: Map SrcSpan () , this_mod :: Module } --- deriving Show +-- deriving Show type FreeVars = OccEnv Id noFVs :: FreeVars @@ -904,11 +928,11 @@ data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTrans instance Monad TM where return a = TM $ \ _env st -> (a,noFVs,st) - (TM m) >>= k = TM $ \ env st -> - case m env st of - (r1,fv1,st1) -> + (TM m) >>= k = TM $ \ env st -> + case m env st of + (r1,fv1,st1) -> case unTM (k r1) env st1 of - (r2,fv2,st2) -> + (r2,fv2,st2) -> (r2, fv1 `plusOccEnv` fv2, st2) -- getState :: TM TickTransState @@ -921,8 +945,8 @@ getEnv :: TM TickTransEnv getEnv = TM $ \ env st -> (env, noFVs, st) withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a -withEnv f (TM m) = TM $ \ env st -> - case m (f env) st of +withEnv f (TM m) = TM $ \ env st -> + case m (f env) st of (a, fvs, st') -> (a, fvs, st') getDensity :: TM TickDensity @@ -932,11 +956,11 @@ ifDensity :: TickDensity -> TM a -> TM a -> TM a ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el getFreeVars :: TM a -> TM (FreeVars, a) -getFreeVars (TM m) +getFreeVars (TM m) = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st') freeVar :: Id -> TM () -freeVar id = TM $ \ env st -> +freeVar id = TM $ \ env st -> if id `elemVarSet` inScope env then ((), unitOccEnv (nameOccName (idName id)) id, st) else ((), noFVs, st) @@ -953,26 +977,26 @@ getFileName = fileName `liftM` getEnv sameFileName :: SrcSpan -> TM a -> TM a -> TM a sameFileName pos out_of_scope in_scope = do file_name <- getFileName - case srcSpanFileName_maybe pos of - Just file_name2 + case srcSpanFileName_maybe pos of + Just file_name2 | file_name == file_name2 -> in_scope _ -> out_of_scope bindLocals :: [Id] -> TM a -> TM a bindLocals new_ids (TM m) - = TM $ \ env st -> + = TM $ \ env st -> case m env{ inScope = inScope env `extendVarSetList` new_ids } st of (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') - where occs = [ nameOccName (idName id) | id <- new_ids ] + where occs = [ nameOccName (idName id) | id <- new_ids ] isBlackListed :: SrcSpan -> TM Bool -isBlackListed pos = TM $ \ env st -> - case Map.lookup pos (blackList env) of - Nothing -> (False,noFVs,st) - Just () -> (True,noFVs,st) +isBlackListed pos = TM $ \ env st -> + case Map.lookup pos (blackList env) of + Nothing -> (False,noFVs,st) + Just () -> (True,noFVs,st) -- the tick application inherits the source position of its --- expression argument to support nested box allocations +-- expression argument to support nested box allocations allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id) allocTickBox boxLabel countEntries topOnly pos m | isGoodSrcSpan' pos = @@ -987,7 +1011,7 @@ allocTickBox _boxLabel _countEntries _topOnly pos m = do -- the tick application inherits the source position of its --- expression argument to support nested box allocations +-- expression argument to support nested box allocations allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) allocATickBox boxLabel countEntries topOnly pos fvs | isGoodSrcSpan' pos = @@ -1023,7 +1047,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = cc = mkUserCC (mkFastString cc_name) (this_mod env) pos (mkCostCentreUnique c) - count = countEntries && dopt Opt_ProfCountEntries (dflags env) + count = countEntries && dopt Opt_ProfCountEntries (tte_dflags env) tickish | opt_Hpc = HpcTick (this_mod env) c @@ -1049,7 +1073,7 @@ allocBinTickBox boxLabel pos m meE = (pos,declPath env, [],ExpBox False) c = tickBoxCount st mes = mixEntries st - in + in ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) (L pos e) -- notice that F and T are reversed, -- because we are building the list in @@ -1085,14 +1109,14 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") matchesOneOfMany :: [LMatch Id] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where - matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss + matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss \end{code} \begin{code} type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) --- For the hash value, we hash everything: the file name, +-- For the hash value, we hash everything: the file name, -- the timestamp of the original source file, the tab stop, -- and the mix entries. We cheat, and hash the show'd string. -- This hash only has to be hashed at Mix creation time, @@ -1100,13 +1124,13 @@ type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int mixHash file tm tabstop entries = fromIntegral $ hashString - (show $ Mix file tm 0 tabstop entries) + (show $ Mix file tm 0 tabstop entries) \end{code} %************************************************************************ -%* * +%* * %* initialisation -%* * +%* * %************************************************************************ Each module compiled with -fhpc declares an initialisation function of diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index cb482eaf89..ba3651851a 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -20,6 +20,7 @@ import StaticFlags import HscTypes import HsSyn import TcRnTypes +import TcRnMonad ( finalSafeMode ) import MkIface import Id import Name @@ -120,7 +121,7 @@ deSugar hsc_env else return (binds, hpcInfo, emptyModBreaks) initDs hsc_env mod rdr_env type_env $ do - do { let ds_ev_binds = dsEvBinds ev_binds + do { ds_ev_binds <- dsEvBinds ev_binds ; core_prs <- dsTopLHsBinds binds_cvr ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs ; (ds_fords, foreign_prs) <- dsForeigns fords @@ -169,6 +170,7 @@ deSugar hsc_env ; used_th <- readIORef tc_splice_used ; dep_files <- readIORef dependent_files + ; safe_mode <- finalSafeMode dflags tcg_env ; let mod_guts = ModGuts { mg_module = mod, @@ -194,6 +196,7 @@ deSugar hsc_env mg_modBreaks = modBreaks, mg_vect_decls = ds_vects, mg_vect_info = noVectInfo, + mg_safe_haskell = safe_mode, mg_trust_pkg = imp_trust_own_pkg imports, mg_dependent_files = dep_files } @@ -300,8 +303,8 @@ addExportFlagsAndRules target exports keep_alive rules prs -- isExternalName separates the user-defined top-level names from those -- introduced by the type checker. is_exported :: Name -> Bool - is_exported | target == HscInterpreted = isExternalName - | otherwise = (`elemNameSet` exports) + is_exported | targetRetainsAllBindings target = isExternalName + | otherwise = (`elemNameSet` exports) \end{code} diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 663c289d3c..1da6a77976 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -1124,8 +1124,8 @@ collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (LetStmt binds) = collectLocalBinders binds collectStmtBinders (ExprStmt {}) = [] collectStmtBinders (LastStmt {}) = [] -collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders - $ concatMap fst xs +collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders + $ [ s | ParStmtBlock ss _ _ <- xs, s <- ss] collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 1380774c71..8949387aae 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -18,7 +18,7 @@ lower levels it is preserved with @let@/@letrec@s). -- for details module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, - dsHsWrapper, dsTcEvBinds, dsEvBinds, dsTcCoercion + dsHsWrapper, dsTcEvBinds, dsEvBinds ) where #include "HsVersions.h" @@ -39,6 +39,8 @@ import CoreUtils import CoreArity ( etaExpand ) import CoreUnfold import CoreFVs +import UniqSupply +import Unique( Unique ) import Digraph @@ -51,7 +53,7 @@ import TysWiredIn ( eqBoxDataCon, tupleCon ) import Id import Class import DataCon ( dataConWorkId ) -import Name ( Name, localiseName ) +import Name import MkId ( seqId ) import Var import VarSet @@ -69,6 +71,7 @@ import ErrUtils( MsgDoc ) import Util import Control.Monad( when ) import MonadUtils +import Control.Monad(liftM) \end{code} %************************************************************************ @@ -112,7 +115,7 @@ dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches , fun_infix = inf }) = do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches ; let body' = mkOptTickBox tick body - rhs = dsHsWrapper co_fn (mkLams args body') + ; rhs <- dsHsWrapper co_fn (mkLams args body') ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -} return (unitOL (makeCorePair fun False 0 rhs)) } @@ -136,9 +139,10 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts , abe_mono = local, abe_prags = prags } <- export = do { bind_prs <- ds_lhs_binds binds ; let core_bind = Rec (fromOL bind_prs) - rhs = dsHsWrapper wrap $ -- Usually the identity + ; ds_binds <- dsTcEvBinds ev_binds + ; rhs <- dsHsWrapper wrap $ -- Usually the identity mkLams tyvars $ mkLams dicts $ - mkCoreLets (dsTcEvBinds ev_binds) $ + mkCoreLets ds_binds $ Let core_bind $ Var local @@ -153,36 +157,54 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts , abs_exports = exports, abs_ev_binds = ev_binds , abs_binds = binds }) + -- See Note [Desugaring AbsBinds] = do { bind_prs <- ds_lhs_binds binds - ; let core_bind = Rec (fromOL bind_prs) + ; let core_bind = Rec [ makeCorePair (add_inline lcl_id) False 0 rhs + | (lcl_id, rhs) <- fromOL bind_prs ] -- Monomorphic recursion possible, hence Rec + locals = map abe_mono exports tup_expr = mkBigCoreVarTup locals tup_ty = exprType tup_expr - poly_tup_rhs = mkLams tyvars $ mkLams dicts $ - mkCoreLets (dsTcEvBinds ev_binds) $ + ; ds_binds <- dsTcEvBinds ev_binds + ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_binds $ Let core_bind $ tup_expr - locals = map abe_mono exports ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global , abe_mono = local, abe_prags = spec_prags }) = do { tup_id <- newSysLocalDs tup_ty - ; let rhs = dsHsWrapper wrap $ + ; rhs <- dsHsWrapper wrap $ mkLams tyvars $ mkLams dicts $ mkTupleSelector locals local tup_id $ mkVarApps (Var poly_tup_id) (tyvars ++ dicts) - rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs + ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags - ; let global' = addIdSpecialisations global rules + ; let global' = (global `setInlinePragma` defaultInlinePragma) + `addIdSpecialisations` rules + -- Kill the INLINE pragma because it applies to + -- the user written (local) function. The global + -- Id is just the selector. Hmm. ; return ((global', rhs) `consOL` spec_binds) } ; export_binds_s <- mapM mk_bind exports ; return ((poly_tup_id, poly_tup_rhs) `consOL` concatOL export_binds_s) } + where + inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with + -- the inline pragma from the source + -- The type checker put the inline pragma + -- on the *global* Id, so we need to transfer it + inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) + | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports + , let prag = idInlinePragma gbl_id ] + + add_inline :: Id -> Id -- tran + add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id ------------------------ makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) @@ -219,6 +241,16 @@ dictArity :: [Var] -> Arity dictArity dicts = count isId dicts \end{code} +[Desugaring AbsBinds] +~~~~~~~~~~~~~~~~~~~~~ +In the general AbsBinds case we desugar the binding to this: + + tup a (d:Num a) = let fm = ...gm... + gm = ...fm... + in (fm,gm) + f a d = case tup a d of { (fm,gm) -> fm } + g a d = case tup a d of { (fm,gm) -> fm } + Note [Rules and inlining] ~~~~~~~~~~~~~~~~~~~~~~~~~ Common special case: no type or dictionary abstraction @@ -410,27 +442,28 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) = putSrcSpanDs loc $ do { let poly_name = idName poly_id ; spec_name <- newLocalName poly_name - ; let (bndrs, ds_lhs) = collectBinders (dsHsWrapper spec_co (Var poly_id)) - spec_ty = mkPiTypes bndrs (exprType ds_lhs) + ; (bndrs, ds_lhs) <- liftM collectBinders + (dsHsWrapper spec_co (Var poly_id)) + ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs) ; case decomposeRuleLhs bndrs ds_lhs of { Left msg -> do { warnDs msg; return Nothing } ; Right (final_bndrs, _fn, args) -> do { (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id) + ; dflags <- getDynFlags ; let spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf rule = mkRule False {- Not auto -} is_local_id - (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) + (mkFastString ("SPEC " ++ showPpr dflags poly_name)) rule_act poly_name final_bndrs args (mkVarApps (Var spec_id) bndrs) - spec_rhs = dsHsWrapper spec_co poly_rhs - spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs + ; spec_rhs <- dsHsWrapper spec_co poly_rhs + ; let spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs - ; dflags <- getDynFlags ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags) (warnDs (specOnInline poly_name)) ; return (Just (spec_pair `consOL` unf_pairs, rule)) @@ -630,7 +663,7 @@ but it seems better to reject the program because it's almost certainly a mistake. That's what the isDeadBinder call detects. Note [Constant rule dicts] -~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~ When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, which is presumably in scope at the function definition site, we can quantify over it too. *Any* dict with that type will do. @@ -663,28 +696,29 @@ as the old one, but with an Internal name and no IdInfo. \begin{code} -dsHsWrapper :: HsWrapper -> CoreExpr -> CoreExpr -dsHsWrapper WpHole e = e -dsHsWrapper (WpTyApp ty) e = App e (Type ty) -dsHsWrapper (WpLet ev_binds) e = mkCoreLets (dsTcEvBinds ev_binds) e -dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 (dsHsWrapper c2 e) +dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr +dsHsWrapper WpHole e = return e +dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty) +dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds + return (mkCoreLets bs e) +dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e) -dsHsWrapper (WpEvLam ev) e = Lam ev e -dsHsWrapper (WpTyLam tv) e = Lam tv e -dsHsWrapper (WpEvApp evtrm) e = App e (dsEvTerm evtrm) +dsHsWrapper (WpEvLam ev) e = return $ Lam ev e +dsHsWrapper (WpTyLam tv) e = return $ Lam tv e +dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm) -------------------------------------- -dsTcEvBinds :: TcEvBinds -> [CoreBind] -dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this +dsTcEvBinds :: TcEvBinds -> DsM [CoreBind] +dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this dsTcEvBinds (EvBinds bs) = dsEvBinds bs -dsEvBinds :: Bag EvBind -> [CoreBind] -dsEvBinds bs = map ds_scc (sccEvBinds bs) +dsEvBinds :: Bag EvBind -> DsM [CoreBind] +dsEvBinds bs = mapM ds_scc (sccEvBinds bs) where - ds_scc (AcyclicSCC (EvBind v r)) = NonRec v (dsEvTerm r) - ds_scc (CyclicSCC bs) = Rec (map ds_pair bs) + ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r) + ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs) - ds_pair (EvBind v r) = (v, dsEvTerm r) + ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r) sccEvBinds :: Bag EvBind -> [SCC EvBind] sccEvBinds bs = stronglyConnCompFromEdgedVertices edges @@ -693,67 +727,92 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges edges = foldrBag ((:) . mk_node) [] bs mk_node :: EvBind -> (EvBind, EvVar, [EvVar]) - mk_node b@(EvBind var term) = (b, var, evVarsOfTerm term) + mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term)) --------------------------------------- -dsEvTerm :: EvTerm -> CoreExpr -dsEvTerm (EvId v) = Var v +dsEvTerm :: EvTerm -> DsM CoreExpr +dsEvTerm (EvId v) = return (Var v) + +dsEvTerm (EvCast tm co) + = do { tm' <- dsEvTerm tm + ; dsTcCoercion co $ mkCast tm' } + -- 'v' is always a lifted evidence variable so it is + -- unnecessary to call varToCoreExpr v here. -dsEvTerm (EvCast v co) - = dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is - -- unnecessary to call varToCoreExpr v here. dsEvTerm (EvKindCast v co) - = dsTcCoercion co $ (\_ -> Var v) + = do { v' <- dsEvTerm v + ; dsTcCoercion co $ (\_ -> v') } -dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars +dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms + ; return (Var df `mkTyApps` tys `mkApps` tms') } dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox dsEvTerm (EvTupleSel v n) - = ASSERT( isTupleTyCon tc ) - Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')] - where - (tc, tys) = splitTyConApp (evVarPred v) - Just [dc] = tyConDataCons_maybe tc - v' = v `setVarType` ty_want - xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after - (tys_before, ty_want:tys_after) = splitAt n tys -dsEvTerm (EvTupleMk vs) = Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs - where dc = tupleCon ConstraintTuple (length vs) - tys = map varType vs + = do { tm' <- dsEvTerm v + ; let scrut_ty = exprType tm' + (tc, tys) = splitTyConApp scrut_ty + Just [dc] = tyConDataCons_maybe tc + xs = mkTemplateLocals tys + the_x = xs !! n + ; ASSERT( isTupleTyCon tc ) + return $ + Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] } + +dsEvTerm (EvTupleMk tms) + = do { tms' <- mapM dsEvTerm tms + ; let tys = map exprType tms' + ; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' } + where + dc = tupleCon ConstraintTuple (length tms) + dsEvTerm (EvSuperClass d n) - = Var sc_sel_id `mkTyApps` tys `App` Var d + = do { d' <- dsEvTerm d + ; let (cls, tys) = getClassPredTys (exprType d') + sc_sel_id = classSCSelId cls n -- Zero-indexed + ; return $ Var sc_sel_id `mkTyApps` tys `App` d' } where - sc_sel_id = classSCSelId cls n -- Zero-indexed - (cls, tys) = getClassPredTys (evVarPred d) -dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg] - where errorId = rUNTIME_ERROR_ID - litMsg = Lit (MachStr msg) + +dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg] + where + errorId = rUNTIME_ERROR_ID + litMsg = Lit (MachStr msg) + +dsEvTerm (EvLit l) = + case l of + EvNum n -> mkIntegerExpr n + EvStr s -> mkStringExprFS s --------------------------------------- -dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr +dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr -- This is the crucial function that moves --- from LCoercions to Coercions; see Note [TcCoercions] in Coercion +-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion -- e.g. dsTcCoercion (trans g1 g2) k -- = case g1 of EqBox g1# -> -- case g2 of EqBox g2# -> -- k (trans g1# g2#) dsTcCoercion co thing_inside - = foldr wrap_in_case result_expr eqvs_covs - where - result_expr = thing_inside (ds_tc_coercion subst co) - result_ty = exprType result_expr + = do { us <- newUniqueSupply + ; let eqvs_covs :: [(EqVar,CoVar)] + eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co)) + (uniqsFromSupply us) - -- We use the same uniques for the EqVars and the CoVars, and just change - -- the type. So the CoVars shadow the EqVars + subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs] + result_expr = thing_inside (ds_tc_coercion subst co) + result_ty = exprType result_expr - eqvs_covs :: [(EqVar,CoVar)] - eqvs_covs = [(eqv, eqv `setIdType` mkCoercionType ty1 ty2) - | eqv <- varSetElems (coVarsOfTcCo co) - , let (ty1, ty2) = getEqPredTys (evVarPred eqv)] - subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs] - - wrap_in_case (eqv, cov) body + ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) } + where + mk_co_var :: Id -> Unique -> (Id, Id) + mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc) + where + eq_nm = idName eqv + occ = nameOccName eq_nm + loc = nameSrcSpan eq_nm + ty = mkCoercionType ty1 ty2 + (ty1, ty2) = getEqPredTys (evVarPred eqv) + + wrap_in_case result_ty (eqv, cov) body = Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)] ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion @@ -776,6 +835,7 @@ ds_tc_coercion subst tc_co go (TcNthCo n co) = mkNthCo n (go co) go (TcInstCo co ty) = mkInstCo (go co) ty go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co + go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2) go (TcCoVarCo v) = ds_ev_id subst v ds_co_binds :: TcEvBinds -> CvSubst diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 06a41bcd1a..a2459f5a4c 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -48,7 +48,9 @@ import Literal import PrelNames import VarSet import Constants +import DynFlags import Outputable +import Util \end{code} Desugaring of @ccall@s consists of adding some state manipulation, @@ -97,13 +99,14 @@ dsCCall lbl args may_gc result_ty = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args (ccall_result_ty, res_wrapper) <- boxResult result_ty uniq <- newUnique + dflags <- getDynFlags let - target = StaticTarget lbl Nothing + target = StaticTarget lbl Nothing True the_fcall = CCall (CCallSpec target CCallConv may_gc) - the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty + the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) -mkFCall :: Unique -> ForeignCall +mkFCall :: DynFlags -> Unique -> ForeignCall -> [CoreExpr] -- Args -> Type -- Result type -> CoreExpr @@ -116,14 +119,14 @@ mkFCall :: Unique -> ForeignCall -- Here we build a ccall thus -- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) -- a b s x c -mkFCall uniq the_fcall val_args res_ty +mkFCall dflags uniq the_fcall val_args res_ty = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args where arg_tys = map exprType val_args body_ty = (mkFunTys arg_tys res_ty) tyvars = varSetElems (tyVarsOfType body_ty) ty = mkForAllTys tyvars body_ty - the_fcall_id = mkFCallId uniq the_fcall ty + the_fcall_id = mkFCallId dflags uniq the_fcall ty \end{code} \begin{code} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index b34640a010..11fa5d53c9 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -32,6 +32,7 @@ import HsSyn -- needs to see source types import TcType import TcEvidence +import TcRnMonad import Type import CoreSyn import CoreUtils @@ -79,14 +80,15 @@ dsValBinds (ValBindsIn _ _) _ = panic "dsValBinds ValBindsIn" ------------------------- dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr dsIPBinds (IPBinds ip_binds ev_binds) body - = do { let inner = mkCoreLets (dsTcEvBinds ev_binds) body + = do { ds_binds <- dsTcEvBinds ev_binds + ; let inner = mkCoreLets ds_binds body -- The dict bindings may not be in -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } where - ds_ip_bind (L _ (IPBind n e)) body + ds_ip_bind (L _ (IPBind ~(Right n) e)) body = do e' <- dsLExpr e - return (Let (NonRec (ipNameName n) (mkIPBox n e')) body) + return (Let (NonRec n e') body) ------------------------- ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr @@ -131,7 +133,8 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) body1 binds - ; return (mkCoreLets (dsTcEvBinds ev_binds) body2) } + ; ds_binds <- dsTcEvBinds ev_binds + ; return (mkCoreLets ds_binds body2) } dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn , fun_tick = tick, fun_infix = inf }) body @@ -152,7 +155,7 @@ dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body eqn_rhs = cantFailMatchResult body } ; var <- selectMatchVar upat ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) - ; return (scrungleMatch var rhs result) } + ; return (bindNonRec var rhs result) } dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) @@ -161,38 +164,13 @@ strictMatchOnly :: HsBind Id -> Bool strictMatchOnly (AbsBinds { abs_binds = binds }) = anyBag (strictMatchOnly . unLoc) binds strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty }) - = isUnboxedTupleType ty + = isUnLiftedType ty || isBangLPat lpat || any (isUnLiftedType . idType) (collectPatBinders lpat) strictMatchOnly (FunBind { fun_id = L _ id }) = isUnLiftedType (idType id) strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact -scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr --- Returns something like (let var = scrut in body) --- but if var is an unboxed-tuple type, it inlines it in a fragile way --- Special case to handle unboxed tuple patterns; they can't appear nested --- The idea is that --- case e of (# p1, p2 #) -> rhs --- should desugar to --- case e of (# x1, x2 #) -> ... match p1, p2 ... --- NOT --- let x = e in case x of .... --- --- But there may be a big --- let fail = ... in case e of ... --- wrapping the whole case, which complicates matters slightly --- It all seems a bit fragile. Test is dsrun013. - -scrungleMatch var scrut body - | isUnboxedTupleType (idType var) = scrungle body - | otherwise = bindNonRec var scrut body - where - scrungle (Case (Var x) bndr ty alts) - | x == var = Case scrut bndr ty alts - scrungle (Let binds body) = Let binds (scrungle body) - scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other)) - \end{code} %************************************************************************ @@ -210,14 +188,14 @@ dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e dsExpr (ExprWithTySigOut e _) = dsLExpr e dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars] -dsExpr (HsIPVar ip) = return (mkIPUnbox ip) +dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar" dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit dsExpr (HsWrap co_fn e) = do { e' <- dsExpr e - ; let wrapped_e = dsHsWrapper co_fn e' - ; warn_id <- woptDs Opt_WarnIdentities + ; wrapped_e <- dsHsWrapper co_fn e' + ; warn_id <- woptM Opt_WarnIdentities ; when warn_id $ warnAboutIdentities e' wrapped_e ; return wrapped_e } @@ -309,7 +287,7 @@ dsExpr (ExplicitTuple tup_args boxity) dsExpr (HsSCC cc expr@(L loc _)) = do mod_name <- getModuleDs - count <- doptDs Opt_ProfCountEntries + count <- doptM Opt_ProfCountEntries uniq <- newUnique Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr @@ -324,7 +302,7 @@ dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty)) | otherwise = do { core_discrim <- dsLExpr discrim ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches - ; return (scrungleMatch discrim_var core_discrim matching_code) } + ; return (bindNonRec discrim_var core_discrim matching_code) } -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints @@ -787,14 +765,15 @@ handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr handle_failure pat match fail_op | matchCanFail match = do { fail_op' <- dsExpr fail_op - ; fail_msg <- mkStringExpr (mk_fail_msg pat) + ; dflags <- getDynFlags + ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) ; extractMatchResult match (App fail_op' fail_msg) } | otherwise = extractMatchResult match (error "It can't fail") -mk_fail_msg :: Located e -> String -mk_fail_msg pat = "Pattern match failure in do expression at " ++ - showSDoc (ppr (getLoc pat)) +mk_fail_msg :: DynFlags -> Located e -> String +mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ + showPpr dflags (getLoc pat) \end{code} @@ -841,13 +820,13 @@ warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () warnDiscardedDoBindings rhs rhs_ty | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty = do { -- Warn about discarding non-() things in 'monadic' binding - ; warn_unused <- woptDs Opt_WarnUnusedDoBind + ; warn_unused <- woptM Opt_WarnUnusedDoBind ; if warn_unused && not (isUnitTy elt_ty) then warnDs (unusedMonadBind rhs elt_ty) else -- Warn about discarding m a things in 'monadic' binding of the same type, -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - do { warn_wrong <- woptDs Opt_WarnWrongDoBind + do { warn_wrong <- woptM Opt_WarnWrongDoBind ; case tcSplitAppTy_maybe elt_ty of Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty -> warnDs (wrongMonadBind rhs elt_ty) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index b613fbdcec..09afd2f06f 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -11,6 +11,8 @@ module DsForeign ( dsForeigns ) where #include "HsVersions.h" import TcRnMonad -- temp +import TypeRep + import CoreSyn import DsCCall @@ -45,6 +47,8 @@ import Config import Constants import OrdList import Pair +import Util + import Data.Maybe import Data.List \end{code} @@ -125,8 +129,8 @@ dsFImport :: Id -> Coercion -> ForeignImport -> DsM ([Binding], SDoc, SDoc) -dsFImport id co (CImport cconv safety header spec) = do - (ids, h, c) <- dsCImport id co spec cconv safety header +dsFImport id co (CImport cconv safety mHeader spec) = do + (ids, h, c) <- dsCImport id co spec cconv safety mHeader return (ids, h, c) dsCImport :: Id @@ -134,7 +138,7 @@ dsCImport :: Id -> CImportSpec -> CCallConv -> Safety - -> FastString -- header + -> Maybe Header -> DsM ([Binding], SDoc, SDoc) dsCImport id co (CLabel cid) cconv _ _ = do let ty = pFst $ coercionKind co @@ -154,8 +158,8 @@ dsCImport id co (CLabel cid) cconv _ _ = do dsCImport id co (CFunction target) cconv@PrimCallConv safety _ = dsPrimCall id co (CCall (CCallSpec target cconv safety)) -dsCImport id co (CFunction target) cconv safety header - = dsFCall id co (CCall (CCallSpec target cconv safety)) header +dsCImport id co (CFunction target) cconv safety mHeader + = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader dsCImport id co CWrapper cconv _ _ = dsFExportDynamic id co cconv @@ -182,9 +186,9 @@ fun_type_arg_stdcall_info _other_conv _ %************************************************************************ \begin{code} -dsFCall :: Id -> Coercion -> ForeignCall -> FastString +dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) -dsFCall fn_id co fcall headerFilename = do +dsFCall fn_id co fcall mDeclHeader = do let ty = pFst $ coercionKind co (tvs, fun_ty) = tcSplitForAllTys ty @@ -203,37 +207,47 @@ dsFCall fn_id co fcall headerFilename = do ccall_uniq <- newUnique work_uniq <- newUnique + dflags <- getDynFlags (fcall', cDoc) <- case fcall of - CCall (CCallSpec (StaticTarget cName mPackageId) CApiConv safety) -> + CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) -> do fcall_uniq <- newUnique let wrapperName = mkFastString "ghc_wrapper_" `appendFS` - mkFastString (showSDoc (ppr fcall_uniq)) `appendFS` + mkFastString (showPpr dflags fcall_uniq) `appendFS` mkFastString "_" `appendFS` cName - fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId) CApiConv safety) - c = include + fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety) + c = includes $$ fun_proto <+> braces (cRet <> semi) - include - | nullFS headerFilename = empty - | otherwise = text "#include <" <> ftext headerFilename <> text ">" + includes = vcat [ text "#include <" <> ftext h <> text ">" + | Header h <- nub headers ] fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes cRet | isVoidRes = cCall | otherwise = text "return" <+> cCall - cCall = ppr cName <> parens argVals + cCall = if isFun + then ppr cName <> parens argVals + else if null arg_tys + then ppr cName + else panic "dsFCall: Unexpected arguments to FFI value import" raw_res_ty = case tcSplitIOType_maybe io_res_ty of Just (_ioTyCon, res_ty) -> res_ty Nothing -> io_res_ty isVoidRes = raw_res_ty `eqType` unitTy - cResType | isVoidRes = text "void" - | otherwise = showStgType raw_res_ty + (mHeader, cResType) + | isVoidRes = (Nothing, text "void") + | otherwise = toCType raw_res_ty pprCconv = ccallConvAttribute CApiConv - argTypes - | null arg_tys = text "void" - | otherwise = hsep $ punctuate comma - [ showStgType t <+> char 'a' <> int n - | (t, n) <- zip arg_tys [1..] ] + mHeadersArgTypeList + = [ (header, cType <+> char 'a' <> int n) + | (t, n) <- zip arg_tys [1..] + , let (header, cType) = toCType t ] + (mHeaders, argTypeList) = unzip mHeadersArgTypeList + argTypes = if null argTypeList + then text "void" + else hsep $ punctuate comma argTypeList + mHeaders' = mDeclHeader : mHeader : mHeaders + headers = catMaybes mHeaders' argVals = hsep $ punctuate comma [ char 'a' <> int n | (_, n) <- zip arg_tys [1..] ] @@ -243,7 +257,7 @@ dsFCall fn_id co fcall headerFilename = do let -- Build the worker worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty) - the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty + the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty @@ -285,8 +299,9 @@ dsPrimCall fn_id co fcall = do args <- newSysLocalsDs arg_tys ccall_uniq <- newUnique + dflags <- getDynFlags let - call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty + call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty rhs = mkLams tvs (mkLams args call_app) rhs' = Cast rhs co return ([(fn_id, rhs')], empty, empty) @@ -390,9 +405,10 @@ dsFExportDynamic :: Id dsFExportDynamic id co0 cconv = do fe_id <- newSysLocalDs ty mod <- getModuleDs + dflags <- getDynFlags let -- hack: need to get at the name of the C stub we're about to generate. - fe_nm = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id) + fe_nm = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName dflags fe_id) cback <- newSysLocalDs arg_ty newStablePtrId <- dsLookupGlobalId newStablePtrName @@ -452,8 +468,8 @@ dsFExportDynamic id co0 cconv = do Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty -- Must have an IO type; hence Just -toCName :: Id -> String -toCName i = showSDoc (pprCode CStyle (ppr (idName i))) +toCName :: DynFlags -> Id -> String +toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) \end{code} %* @@ -667,21 +683,64 @@ showStgType t = text "Hs" <> text (showFFIType t) showFFIType :: Type -> String showFFIType t = getOccString (getName (typeTyCon t)) +toCType :: Type -> (Maybe Header, SDoc) +toCType = f False + where f voidOK t + -- First, if we have (Ptr t) of (FunPtr t), then we need to + -- convert t to a C type and put a * after it. If we don't + -- know a type for t, then "void" is fine, though. + | Just (ptr, [t']) <- splitTyConApp_maybe t + , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] + = case f True t' of + (mh, cType') -> + (mh, cType' <> char '*') + -- Otherwise, if we have a type constructor application, then + -- see if there is a C type associated with that constructor. + -- Note that we aren't looking through type synonyms or + -- anything, as it may be the synonym that is annotated. + | TyConApp tycon _ <- t + , Just (CType mHeader cType) <- tyConCType_maybe tycon + = (mHeader, ftext cType) + -- If we don't know a C type for this type, then try looking + -- through one layer of type synonym etc. + | Just t' <- coreView t + = f voidOK t' + -- Otherwise we don't know the C type. If we are allowing + -- void then return that; otherwise something has gone wrong. + | voidOK = (Nothing, ptext (sLit "void")) + | otherwise + = pprPanic "toCType" (ppr t) + typeTyCon :: Type -> TyCon -typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of - Just (tc,_) -> tc - Nothing -> pprPanic "DsForeign.typeTyCon" (ppr ty) +typeTyCon ty + | UnaryRep rep_ty <- repType ty + , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty + = tc + | otherwise + = pprPanic "DsForeign.typeTyCon" (ppr ty) insertRetAddr :: DynFlags -> CCallConv -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)] insertRetAddr dflags CCallConv args - = case platformArch (targetPlatform dflags) of - ArchX86_64 -> - -- On x86_64 we insert the return address after the 6th - -- integer argument, because this is the point at which we - -- need to flush a register argument to the stack (See - -- rts/Adjustor.c for details). + = case platformArch platform of + ArchX86_64 + | platformOS platform == OSMinGW32 -> + -- On other Windows x86_64 we insert the return address + -- after the 4th argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 4 args = ret_addr_arg : args + go n (arg:args) = arg : go (n+1) args + go _ [] = [] + in go 0 args + | otherwise -> + -- On other x86_64 platforms we insert the return address + -- after the 6th integer argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). let go :: Int -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)] go 6 args = ret_addr_arg : args @@ -692,6 +751,7 @@ insertRetAddr dflags CCallConv args in go 0 args _ -> ret_addr_arg : args + where platform = targetPlatform dflags insertRetAddr _ _ args = args ret_addr_arg :: (SDoc, SDoc, Type, CmmType) @@ -700,7 +760,7 @@ ret_addr_arg = (text "original_return_addr", text "void*", undefined, -- This function returns the primitive type associated with the boxed -- type argument to a foreign export (eg. Int ==> Int#). -getPrimTyOf :: Type -> Type +getPrimTyOf :: Type -> UnaryType getPrimTyOf ty | isBoolTy rep_ty = intPrimTy -- Except for Bool, the types we are interested in have a single constructor @@ -713,7 +773,7 @@ getPrimTyOf ty prim_ty _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty) where - rep_ty = repType ty + UnaryRep rep_ty = repType ty -- represent a primitive type as a Char, for building a string that -- described the foreign function type. The types are size-dependent, diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 917e8b19ed..efe14f2678 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -19,7 +19,6 @@ import TcHsSyn import CoreSyn import MkCore -import TcEvidence import DsMonad -- the monadery used in the desugarer import DsUtils @@ -34,6 +33,7 @@ import SrcLoc import Outputable import FastString import TcType +import Util \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -71,15 +71,15 @@ dsListComp lquals res_ty = do -- mix of possibly a single element in length, so we do this to leave the possibility open isParallelComp = any isParallelStmt - isParallelStmt (ParStmt _ _ _ _) = True - isParallelStmt _ = False + isParallelStmt (ParStmt {}) = True + isParallelStmt _ = False -- This function lets you desugar a inner list comprehension and a list of the binders -- of that comprehension that we need in the outer comprehension into such an expression -- and the type of the elements that it outputs (tuples of binders) -dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type) -dsInnerListComp (stmts, bndrs) +dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type) +dsInnerListComp (ParStmtBlock stmts bndrs _) = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)]) (mkListTy bndrs_tuple_type) ; return (expr, bndrs_tuple_type) } @@ -98,7 +98,7 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr, from_tup_ty) <- dsInnerListComp (stmts, from_bndrs) + (expr, from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr) -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments @@ -233,7 +233,7 @@ deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above core_list1 <- dsLExpr list1 deBindComp pat core_list1 quals core_list2 -deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list +deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs ; let (exps, qual_tys) = unzip exps_and_qual_tys @@ -243,7 +243,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) quals list } where - bndrs_s = map snd stmtss_w_bndrs + bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs] -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above pat = mkBigLHsPatTup pats @@ -473,7 +473,7 @@ dsPArrComp :: [Stmt Id] -> DsM CoreExpr -- Special case for parallel comprehension -dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals +dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals -- Special case for simple generators: -- @@ -590,7 +590,7 @@ dePArrComp (LetStmt ds : qs) pa cea = do -- singeltons qualifier lists, which we already special case in the caller. -- So, encountering one here is a bug. -- -dePArrComp (ParStmt _ _ _ _ : _) _ _ = +dePArrComp (ParStmt {} : _) _ _ = panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt" dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt" dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt" @@ -601,7 +601,7 @@ dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt" -- where -- {x_1, ..., x_n} = DV (qs) -- -dePArrParComp :: [([LStmt Id], [Id])] -> [Stmt Id] -> DsM CoreExpr +dePArrParComp :: [ParStmtBlock Id Id] -> [Stmt Id] -> DsM CoreExpr dePArrParComp qss quals = do (pQss, ceQss) <- deParStmt qss dePArrComp quals pQss ceQss @@ -609,13 +609,13 @@ dePArrParComp qss quals = do deParStmt [] = -- empty parallel statement lists have no source representation panic "DsListComp.dePArrComp: Empty parallel list comprehension" - deParStmt ((qs, xs):qss) = do -- first statement + deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement let res_expr = mkLHsVarTuple xs cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) parStmts qss (mkLHsVarPatTup xs) cqs --- parStmts [] pa cea = return (pa, cea) - parStmts ((qs, xs):qss) pa cea = do -- subsequent statements (zip'ed) + parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed) zipP <- dsDPHBuiltin zipPVar let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] ty'cea = parrElemType cea @@ -763,12 +763,12 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs -- mzip :: forall a b. m a -> m b -> m (a,b) -- NB: we need a polymorphic mzip because we call it several times -dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest - = do { exps_w_tys <- mapM ds_inner pairs -- Pairs (exp :: m ty, ty) +dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest + = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) ; mzip_op' <- dsExpr mzip_op ; let -- The pattern variables - pats = map (mkBigLHsVarPatTup . snd) pairs + pats = [ mkBigLHsVarPatTup bs | ParStmtBlock _ bs _ <- blocks] -- Pattern with tuples of variables -- [v1,v2,v3] => (v1, (v2, v3)) pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats @@ -779,11 +779,9 @@ dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest } where - ds_inner (stmts, bndrs) = do { exp <- dsInnerMonadComp stmts bndrs mono_ret_op - ; return (exp, tup_ty) } - where - mono_ret_op = HsWrap (WpTyApp tup_ty) return_op - tup_ty = mkBigCoreVarTupTy bndrs + ds_inner (ParStmtBlock stmts bndrs return_op) + = do { exp <- dsInnerMonadComp stmts bndrs return_op + ; return (exp, mkBigCoreVarTupTy bndrs) } dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) @@ -822,14 +820,16 @@ dsMcBindStmt pat rhs' bind_op fail_op stmts handle_failure pat match fail_op | matchCanFail match = do { fail_op' <- dsExpr fail_op - ; fail_msg <- mkStringExpr (mk_fail_msg pat) + ; dflags <- getDynFlags + ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) ; extractMatchResult match (App fail_op' fail_msg) } | otherwise = extractMatchResult match (error "It can't fail") - mk_fail_msg :: Located e -> String - mk_fail_msg pat = "Pattern match failure in monad comprehension at " ++ - showSDoc (ppr (getLoc pat)) + mk_fail_msg :: DynFlags -> Located e -> String + mk_fail_msg dflags pat + = "Pattern match failure in monad comprehension at " ++ + showPpr dflags (getLoc pat) -- Desugar nested monad comprehensions, for example in `then..` constructs -- dsInnerMonadComp quals [a,b,c] ret_op diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 4105a9e56c..9a1d050fb2 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -20,9 +20,9 @@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details -module DsMeta( dsBracket, +module DsMeta( dsBracket, templateHaskellNames, qTyConName, nameTyConName, - liftName, liftStringName, expQTyConName, patQTyConName, + liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, decsQTyConName, typeQTyConName, decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, quoteExpName, quotePatName, quoteDecName, quoteTypeName @@ -44,16 +44,16 @@ import PrelNames -- OccName.varName we do this by removing varName from the import of -- OccName above, making a qualified instance of OccName and using -- OccNameAlias.varName where varName ws previously used in this file. -import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName ) +import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, dataName ) import Module import Id -import Name hiding( isVarOcc, isTcOcc, varName, tcName ) +import Name hiding( isVarOcc, isTcOcc, varName, tcName ) import NameEnv import TcType import TyCon import TysWiredIn -import TysPrim ( liftedTypeKindTyConName ) +import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) import CoreSyn import MkCore import CoreUtils @@ -65,7 +65,7 @@ import Bag import FastString import ForeignCall import MonadUtils -import Util( equalLength ) +import Util import Data.Maybe import Control.Monad @@ -109,13 +109,14 @@ dsBracket brack splices ------------------------------------------------------- repTopP :: LPat Name -> DsM (Core TH.PatQ) -repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) +repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) ; pat' <- addBinds ss (repLP pat) ; wrapGenSyms ss pat' } repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) repTopDs group - = do { let { bndrs = hsGroupBinders group } ; + = do { let { tv_bndrs = hsSigTvBinders (hs_valds group) + ; bndrs = tv_bndrs ++ hsGroupBinders group } ; ss <- mkGenSyms bndrs ; -- Bind all the names mainly to avoid repeated use of explicit strings. @@ -125,16 +126,16 @@ repTopDs group -- The other important reason is that the output must mention -- only "T", not "Foo:T" where Foo is the current module - decls <- addBinds ss (do { + fix_ds <- mapM repFixD (hs_fixds group) ; val_ds <- rep_val_binds (hs_valds group) ; tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ; inst_ds <- mapM repInstD (hs_instds group) ; for_ds <- mapM repForD (hs_fords group) ; -- more needed - return (de_loc $ sort_by_loc $ - val_ds ++ catMaybes tycl_ds - ++ catMaybes inst_ds ++ for_ds) }) ; + return (de_loc $ sort_by_loc $ + val_ds ++ catMaybes tycl_ds ++ fix_ds + ++ inst_ds ++ for_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -146,8 +147,36 @@ repTopDs group } -{- Note [Binders and occurrences] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +hsSigTvBinders :: HsValBinds Name -> [Name] +-- See Note [Scoped type variables in bindings] +hsSigTvBinders binds + = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs + , tv <- hsQTvBndrs qtvs] + where + sigs = case binds of + ValBindsIn _ sigs -> sigs + ValBindsOut _ sigs -> sigs + + +{- Notes + +Note [Scoped type variables in bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a. a -> a + f x = x::a +Here the 'forall a' brings 'a' into scope over the binding group. +To achieve this we + + a) Gensym a binding for 'a' at the same time as we do one for 'f' + collecting the relevant binders with hsSigTvBinders + + b) When processing the 'forall', don't gensym + +The relevant places are signposted with references to this Note + +Note [Binders and occurrences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we desugar [d| data T = MkT |] we want to get Data "T" [] [Con "MkT" []] [] @@ -158,7 +187,7 @@ asked to fit in. We do *not* clone, though; no need for this: Data "T79" .... But if we see this: - data T = MkT + data T = MkT foo = reifyDecl T then we must desugar to @@ -170,56 +199,34 @@ in repTyClD and repC. -} -repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +-- represent associated family instances +-- +repTyClDs :: [LTyClDecl Name] -> DsM [Core TH.DecQ] +repTyClDs ds = liftM de_loc (mapMaybeM repTyClD ds) -repTyClD tydecl@(L _ (TyFamily {})) - = repTyFamily tydecl addTyVarBinds -repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, - tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, - tcdCons = cons, tcdDerivs = mb_derivs })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> - do { cxt1 <- repLContext cxt - ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts - ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; cons1 <- mapM (repC (hsLTyVarNames tvs)) cons - ; cons2 <- coreList conQTyConName cons1 - ; derivs1 <- repDerivs mb_derivs - ; bndrs1 <- coreList tyVarBndrTyConName bndrs - ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1 - } - ; return $ Just (loc, dec) - } +repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, - tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, - tcdCons = [con], tcdDerivs = mb_derivs })) +repTyClD (L loc (TyFamily { tcdFlavour = flavour, + tcdLName = tc, tcdTyVars = tvs, + tcdKindSig = opt_kind })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> - do { cxt1 <- repLContext cxt - ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts - ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; con1 <- repC (hsLTyVarNames tvs) con - ; derivs1 <- repDerivs mb_derivs - ; bndrs1 <- coreList tyVarBndrTyConName bndrs - ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1 + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + do { flav <- repFamilyFlavour flavour + ; case opt_kind of + Nothing -> repFamilyNoKind flav tc1 bndrs + Just ki -> do { ki1 <- repLKind ki + ; repFamilyKind flav tc1 bndrs ki1 } } - ; return $ Just (loc, dec) + ; return $ Just (loc, dec) } -repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, - tcdSynRhs = ty })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> - do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts - ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; ty1 <- repLTy ty - ; bndrs1 <- coreList tyVarBndrTyConName bndrs - ; repTySyn tc1 bndrs1 opt_tys2 ty1 - } - ; return (Just (loc, dec)) - } +repTyClD (L loc (TyDecl { tcdLName = tc, tcdTyVars = tvs, tcdTyDefn = defn })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; tc_tvs <- mk_extra_tvs tc tvs defn + ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs -> + repTyDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn + ; return (Just (loc, dec)) } repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tvs, tcdFDs = fds, @@ -231,10 +238,9 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, ; sigs1 <- rep_sigs sigs ; binds1 <- rep_binds meth_binds ; fds1 <- repLFunDeps fds - ; ats1 <- repLAssocFamilys ats + ; ats1 <- repTyClDs ats ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1) - ; bndrs1 <- coreList tyVarBndrTyConName bndrs - ; repClass cxt1 cls1 bndrs1 fds1 decls1 + ; repClass cxt1 cls1 bndrs fds1 decls1 } ; return $ Just (loc, dec) } @@ -244,31 +250,56 @@ repTyClD (L loc d) = putSrcSpanDs loc $ do { warnDs (hang ds_msg 4 (ppr d)) ; return Nothing } --- The type variables in the head of families are treated differently when the --- family declaration is associated. In that case, they are usage, not binding --- occurences. --- -repTyFamily :: LTyClDecl Name - -> ProcessTyVarBinds TH.Dec - -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repTyFamily (L loc (TyFamily { tcdFlavour = flavour, - tcdLName = tc, tcdTyVars = tvs, - tcdKind = opt_kind })) - tyVarBinds - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- tyVarBinds tvs $ \bndrs -> - do { flav <- repFamilyFlavour flavour - ; bndrs1 <- coreList tyVarBndrTyConName bndrs - ; case opt_kind of - Nothing -> repFamilyNoKind flav tc1 bndrs1 - Just ki -> do { ki1 <- repKind ki - ; repFamilyKind flav tc1 bndrs1 ki1 - } - } - ; return $ Just (loc, dec) - } -repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error" - +------------------------- +repTyDefn :: Core TH.Name -> Core [TH.TyVarBndr] + -> Maybe (Core [TH.TypeQ]) + -> [Name] -> HsTyDefn Name + -> DsM (Core TH.DecQ) +repTyDefn tc bndrs opt_tys tv_names + (TyData { td_ND = new_or_data, td_ctxt = cxt + , td_cons = cons, td_derivs = mb_derivs }) + = do { cxt1 <- repLContext cxt + ; derivs1 <- repDerivs mb_derivs + ; case new_or_data of + NewType -> do { con1 <- repC tv_names (head cons) + ; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 } + DataType -> do { cons1 <- mapM (repC tv_names) cons + ; cons2 <- coreList conQTyConName cons1 + ; repData cxt1 tc bndrs opt_tys cons2 derivs1 } } + +repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty }) + = do { ty1 <- repLTy ty + ; repTySyn tc bndrs opt_tys ty1 } + +------------------------- +mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name + -> HsTyDefn Name -> DsM (LHsTyVarBndrs Name) +-- If there is a kind signature it must be of form +-- k1 -> .. -> kn -> * +-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn] +mk_extra_tvs tc tvs defn + | TyData { td_kindSig = Just hs_kind } <- defn + = do { extra_tvs <- go hs_kind + ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) } + | otherwise + = return tvs + where + go :: LHsKind Name -> DsM [LHsTyVarBndr Name] + go (L loc (HsFunTy kind rest)) + = do { uniq <- newUnique + ; let { occ = mkTyVarOccFS (fsLit "t") + ; nm = mkInternalName uniq occ loc + ; hs_tv = L loc (KindedTyVar nm kind) } + ; hs_tvs <- go rest + ; return (hs_tv : hs_tvs) } + + go (L _ (HsTyVar n)) + | n == liftedTypeKindTyConName + = return [] + + go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc) + +------------------------- -- represent fundeps -- repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep]) @@ -289,35 +320,18 @@ repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour) repFamilyFlavour TypeFamily = rep2 typeFamName [] repFamilyFlavour DataFamily = rep2 dataFamName [] --- represent associated family declarations --- -repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ] -repLAssocFamilys = mapM repLAssocFamily - where - repLAssocFamily tydecl@(L _ (TyFamily {})) - = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds - repLAssocFamily tydecl - = failWithDs msg - where - msg = ptext (sLit "Illegal associated declaration in class:") <+> - ppr tydecl - --- represent associated family instances --- -repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ] -repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD - --- represent instance declarations +-- Represent instance declarations -- -repInstD :: LInstDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repInstD (L loc (FamInstDecl fi_decl)) - = repTyClD (L loc fi_decl) - +repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repInstD (L loc (FamInstD { lid_inst = fi_decl })) + = do { dec <- repFamInstD fi_decl + ; return (loc, dec) } -repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now +repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds + , cid_sigs = prags, cid_fam_insts = ats })) = do { dec <- addTyVarBinds tvs $ \_ -> -- We must bring the type variables into scope, so their - -- occurrences don't fail, even though the binders don't + -- occurrences don't fail, even though the binders don't -- appear in the resulting data structure -- -- But we do NOT bring the binders of 'binds' into scope @@ -326,37 +340,54 @@ repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now -- the selector Ids, not to fresh names (Trac #5410) -- do { cxt1 <- repContext cxt - ; cls_tcon <- repTy (HsTyVar cls) + ; cls_tcon <- repTy (HsTyVar (unLoc cls)) ; cls_tys <- repLTys tys ; inst_ty1 <- repTapps cls_tcon cls_tys ; binds1 <- rep_binds binds - ; ats1 <- repLAssocFamInst ats - ; decls <- coreList decQTyConName (ats1 ++ binds1) + ; prags1 <- rep_sigs prags + ; ats1 <- mapM (repFamInstD . unLoc) ats + ; decls <- coreList decQTyConName (ats1 ++ binds1 ++ prags1) ; repInst cxt1 inst_ty1 decls } - ; return (Just (loc, dec)) } + ; return (loc, dec) } where - Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty) + Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty + +repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ) +repFamInstD (FamInstDecl { fid_tycon = tc_name + , fid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names } + , fid_defn = defn }) + = WARN( not (null kv_names), ppr kv_names ) -- We have not yet dealt with kind + -- polymorphism in Template Haskell (sigh) + do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + ; let loc = getLoc tc_name + hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk + ; addTyClTyVarBinds hs_tvs $ \ bndrs -> + do { tys1 <- repLTys tys + ; tys2 <- coreList typeQTyConName tys1 + ; repTyDefn tc bndrs (Just tys2) tv_names defn } } repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) -repForD (L loc (ForeignImport name typ _ (CImport cc s ch cis))) +repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis))) = do MkC name' <- lookupLOcc name MkC typ' <- repLTy typ MkC cc' <- repCCallConv cc MkC s' <- repSafety s cis' <- conv_cimportspec cis - MkC str <- coreStringLit $ static - ++ unpackFS ch ++ " " - ++ cis' + MkC str <- coreStringLit (static ++ chStr ++ cis') dec <- rep2 forImpDName [cc', s', str, name', typ'] return (loc, dec) where conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls)) conv_cimportspec (CFunction DynamicTarget) = return "dynamic" - conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs) + conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs) + conv_cimportspec (CFunction (StaticTarget _ _ False)) = panic "conv_cimportspec: values not supported yet" conv_cimportspec CWrapper = return "wrapper" static = case cis of - CFunction (StaticTarget _ _) -> "static " + CFunction (StaticTarget _ _ _) -> "static " _ -> "" + chStr = case mch of + Nothing -> "" + Just (Header h) -> unpackFS h ++ " " repForD decl = notHandled "Foreign declaration" (ppr decl) repCCallConv :: CCallConv -> DsM (Core TH.Callconv) @@ -369,6 +400,17 @@ repSafety PlayRisky = rep2 unsafeName [] repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] +repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ) +repFixD (L loc (FixitySig name (Fixity prec dir))) + = do { MkC name' <- lookupLOcc name + ; MkC prec' <- coreIntLit prec + ; let rep_fn = case dir of + InfixL -> infixLDName + InfixR -> infixRDName + InfixN -> infixNDName + ; dec <- rep2 rep_fn [prec', name'] + ; return (loc, dec) } + ds_msg :: SDoc ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") @@ -377,43 +419,46 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") ------------------------------------------------------- repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ) -repC _ (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ [] - , con_details = details, con_res = ResTyH98 })) - = do { con1 <- lookupLOcc con -- See note [Binders and occurrences] +repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ [] + , con_details = details, con_res = ResTyH98 })) + | null (hsQTvBndrs con_tvs) + = do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] ; repConstr con1 details } + repC tvs (L _ (ConDecl { con_name = con , con_qvars = con_tvs, con_cxt = L _ ctxt , con_details = details , con_res = res_ty })) = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty - ; let ex_tvs = [ tv | tv <- con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)] + ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs) + , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) } + ; binds <- mapM dupBinder con_tv_subst ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs - do { con1 <- lookupLOcc con -- See note [Binders and occurrences] + do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] ; c' <- repConstr con1 details ; ctxt' <- repContext (eq_ctxt ++ ctxt) - ; ex_bndrs' <- coreList tyVarBndrTyConName ex_bndrs - ; rep2 forallCName [unC ex_bndrs', unC ctxt', unC c'] } } + ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } } -in_subst :: Name -> [(Name,Name)] -> Bool -in_subst _ [] = False -in_subst n ((n',_):ns) = n==n' || in_subst n ns +in_subst :: [(Name,Name)] -> Name -> Bool +in_subst [] _ = False +in_subst ((n',_):ns) n = n==n' || in_subst ns n mkGadtCtxt :: [Name] -- Tyvars of the data type - -> ResType Name + -> ResType (LHsType Name) -> DsM (HsContext Name, [(Name,Name)]) --- Given a data type in GADT syntax, figure out the equality --- context, so that we can represent it with an explicit +-- Given a data type in GADT syntax, figure out the equality +-- context, so that we can represent it with an explicit -- equality context, because that is the only way to express -- the GADT in TH syntax -- --- Example: +-- Example: -- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e -- mkGadtCtxt [a,b,c] [d,e] (T d [e] e) --- returns --- (b~[e], c~e), [d->a] --- +-- returns +-- (b~[e], c~e), [d->a] +-- -- This function is fiddly, but not really hard mkGadtCtxt _ ResTyH98 = return ([], []) @@ -423,14 +468,14 @@ mkGadtCtxt data_tvs (ResTyGADT res_ty) , data_tvs `equalLength` tys = return (go [] [] (data_tvs `zip` tys)) - | otherwise - = failWithDs (ptext (sLit "Malformed constructor result type") <+> ppr res_ty) + | otherwise + = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty) where go cxt subst [] = (cxt, subst) go cxt subst ((data_tv, ty) : rest) | Just con_tv <- is_hs_tyvar ty , isTyVarName con_tv - , not (in_subst con_tv subst) + , not (in_subst subst con_tv) = go cxt ((con_tv, data_tv) : subst) rest | otherwise = go (eq_pred : cxt) subst rest @@ -442,13 +487,13 @@ mkGadtCtxt data_tvs (ResTyGADT res_ty) is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty is_hs_tyvar _ = Nothing - + repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) -repBangTy ty= do +repBangTy ty= do MkC s <- rep2 str [] MkC t <- repLTy ty' rep2 strictTypeName [s, t] - where + where (str, ty') = case ty of L _ (HsBangTy HsUnpack ty) -> (unpackedName, ty) L _ (HsBangTy _ ty) -> (isStrictName, ty) @@ -461,7 +506,7 @@ repBangTy ty= do repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name]) repDerivs Nothing = coreList nameTyConName [] repDerivs (Just ctxt) - = do { strs <- mapM rep_deriv ctxt ; + = do { strs <- mapM rep_deriv ctxt ; coreList nameTyConName strs } where rep_deriv :: LHsType Name -> DsM (Core TH.Name) @@ -489,7 +534,7 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (L loc (TypeSig nms ty)) = rep_proto nms ty loc +rep_sig (L loc (TypeSig nms ty)) = mapM (rep_ty_sig loc ty) nms rep_sig (L _ (GenericSig nm _)) = failWithDs msg where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm) , ptext (sLit "Default signatures are not supported by Template Haskell") ] @@ -498,20 +543,31 @@ rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc rep_sig _ = return [] -rep_proto :: [Located Name] -> LHsType Name -> SrcSpan - -> DsM [(SrcSpan, Core TH.DecQ)] -rep_proto nms ty loc - = mapM f nms +rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name + -> DsM (SrcSpan, Core TH.DecQ) +rep_ty_sig loc (L _ ty) nm + = do { nm1 <- lookupLOcc nm + ; ty1 <- rep_ty ty + ; sig <- repProto nm1 ty1 + ; return (loc, sig) } where - f nm = do { nm1 <- lookupLOcc nm - ; ty1 <- repLTy ty - ; sig <- repProto nm1 ty1 - ; return (loc, sig) - } + -- We must special-case the top-level explicit for-all of a TypeSig + -- See Note [Scoped type variables in bindings] + rep_ty (HsForAllTy Explicit tvs ctxt ty) + = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) + ; repTyVarBndrWithKind tv name } + ; bndrs1 <- mapM rep_in_scope_tv (hsQTvBndrs tvs) + ; bndrs2 <- coreList tyVarBndrTyConName bndrs1 + ; ctxt1 <- repLContext ctxt + ; ty1 <- repLTy ty + ; repTForall bndrs2 ctxt1 ty1 } -rep_inline :: Located Name + rep_ty ty = repTy ty + + +rep_inline :: Located Name -> InlinePragma -- Never defaultInlinePragma - -> SrcSpan + -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_inline nm ispec loc = do { nm1 <- lookupLOcc nm @@ -520,7 +576,7 @@ rep_inline nm ispec loc ; return [(loc, pragma)] } -rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan +rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialise nm ty ispec loc = do { nm1 <- lookupLOcc nm @@ -528,35 +584,38 @@ rep_specialise nm ty ispec loc ; pragma <- if isDefaultInlinePragma ispec then repPragSpec nm1 ty1 -- SPECIALISE else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE - ; repPragSpecInl nm1 ty1 ispec1 } + ; repPragSpecInl nm1 ty1 ispec1 } ; return [(loc, pragma)] } +repInline :: InlineSpec -> DsM (Core TH.Inline) +repInline NoInline = dataCon noInlineDataConName +repInline Inline = dataCon inlineDataConName +repInline Inlinable = dataCon inlinableDataConName +repInline spec = notHandled "repInline" (ppr spec) + -- Extract all the information needed to build a TH.InlinePrag -- rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma -> DsM (Core TH.InlineSpecQ) rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline }) - | Just (flag, phase) <- activation1 - = repInlineSpecPhase inline1 match1 flag phase + | Just (flag, phase) <- activation1 + = do { inline1 <- repInline inline + ; repInlineSpecPhase inline1 match1 flag phase } | otherwise - = repInlineSpecNoPhase inline1 match1 + = do { inline1 <- repInline inline + ; repInlineSpecNoPhase inline1 match1 } where match1 = coreBool (rep_RuleMatchInfo match) activation1 = rep_Activation activation - inline1 = case inline of - Inline -> coreBool True - _other -> coreBool False - -- We have no representation for Inlinable - rep_RuleMatchInfo FunLike = False rep_RuleMatchInfo ConLike = True rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive - rep_Activation (ActiveBefore phase) = Just (coreBool False, + rep_Activation (ActiveBefore phase) = Just (coreBool False, MkC $ mkIntExprInt phase) - rep_Activation (ActiveAfter phase) = Just (coreBool True, + rep_Activation (ActiveAfter phase) = Just (coreBool True, MkC $ mkIntExprInt phase) @@ -564,40 +623,48 @@ rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inlin -- Types ------------------------------------------------------- --- We process type variable bindings in two ways, either by generating fresh --- names or looking up existing names. The difference is crucial for type --- families, depending on whether they are associated or not. --- -type ProcessTyVarBinds a = - [LHsTyVarBndr Name] -- the binders to be added - -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env - -> DsM (Core (TH.Q a)) - +addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added + -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env + -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument --- -addTyVarBinds :: ProcessTyVarBinds a + addTyVarBinds tvs m - = do { freshNames <- mkGenSyms (hsLTyVarNames tvs) + = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs) ; term <- addBinds freshNames $ - do { kindedBndrs <- mapM mk_tv_bndr (tvs `zip` freshNames) - ; m kindedBndrs } + do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames) + ; kbs2 <- coreList tyVarBndrTyConName kbs1 + ; m kbs2 } ; wrapGenSyms freshNames term } where mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) --- Look up a list of type variables; the computations passed as the second --- argument gets the *new* names on Core-level as an argument --- -lookupTyVarBinds :: ProcessTyVarBinds a -lookupTyVarBinds tvs m = - do - let names = hsLTyVarNames tvs - mkWithKinds = map repTyVarBndrWithKind tvs - bndrs <- mapM lookupBinder names - kindedBndrs <- zipWithM ($) mkWithKinds bndrs - m kindedBndrs +addTyClTyVarBinds :: LHsTyVarBndrs Name + -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) + -> DsM (Core (TH.Q a)) + +-- Used for data/newtype declarations, and family instances, +-- so that the nested type variables work right +-- instance C (T a) where +-- type W (T a) = blah +-- The 'a' in the type instance is the one bound by the instance decl +addTyClTyVarBinds tvs m + = do { let tv_names = hsLKiTyVarNames tvs + ; env <- dsGetMetaEnv + ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) + -- Make fresh names for the ones that are not already in scope + -- This makes things work for family declarations + + ; term <- addBinds freshNames $ + do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs) + ; kbs2 <- coreList tyVarBndrTyConName kbs1 + ; m kbs2 } + + ; wrapGenSyms freshNames term } + where + mk_tv_bndr tv = do { v <- lookupOcc (hsLTyVarName tv) + ; repTyVarBndrWithKind tv v } -- Produce kinded binder constructors from the Haskell tyvar binders -- @@ -605,8 +672,8 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name -> Core TH.Name -> DsM (Core TH.TyVarBndr) repTyVarBndrWithKind (L _ (UserTyVar {})) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ ki _)) nm - = repKind ki >>= repKindedTV nm +repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm + = repLKind ki >>= repKindedTV nm -- represent a type context -- @@ -614,7 +681,7 @@ repLContext :: LHsContext Name -> DsM (Core TH.CxtQ) repLContext (L _ ctxt) = repContext ctxt repContext :: HsContext Name -> DsM (Core TH.CxtQ) -repContext ctxt = do +repContext ctxt = do preds <- mapM repLPred ctxt predList <- coreList predQTyConName preds repCtxt predList @@ -632,7 +699,7 @@ repPred ty tys1 <- repLTys tys tys2 <- coreList typeQTyConName tys1 repClassP cls1 tys2 -repPred (HsEqTy tyleft tyright) +repPred (HsEqTy tyleft tyright) = do tyleft1 <- repLTy tyleft tyright1 <- repLTy tyright @@ -651,25 +718,27 @@ repLTy :: LHsType Name -> DsM (Core TH.TypeQ) repLTy (L _ ty) = repTy ty repTy :: HsType Name -> DsM (Core TH.TypeQ) -repTy (HsForAllTy _ tvs ctxt ty) = +repTy (HsForAllTy _ tvs ctxt ty) = addTyVarBinds tvs $ \bndrs -> do ctxt1 <- repLContext ctxt ty1 <- repLTy ty - bndrs1 <- coreList tyVarBndrTyConName bndrs - repTForall bndrs1 ctxt1 ty1 + repTForall bndrs ctxt1 ty1 repTy (HsTyVar n) - | isTvOcc (nameOccName n) = do - tv1 <- lookupTvOcc n - repTvar tv1 - | otherwise = do - tc1 <- lookupOcc n - repNamedTyCon tc1 -repTy (HsAppTy f a) = do + | isTvOcc occ = do tv1 <- lookupOcc n + repTvar tv1 + | isDataOcc occ = do tc1 <- lookupOcc n + repPromotedTyCon tc1 + | otherwise = do tc1 <- lookupOcc n + repNamedTyCon tc1 + where + occ = nameOccName n + +repTy (HsAppTy f a) = do f1 <- repLTy f a1 <- repLTy a repTapp f1 a1 -repTy (HsFunTy f a) = do +repTy (HsFunTy f a) = do f1 <- repLTy f a1 <- repLTy a tcon <- repArrowTyCon @@ -686,7 +755,7 @@ repTy (HsTupleTy HsUnboxedTuple tys) = do tys1 <- repLTys tys tcon <- repUnboxedTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys +repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) @@ -694,23 +763,61 @@ repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) repTy (HsParTy t) = repLTy t repTy (HsKindSig t k) = do t1 <- repLTy t - k1 <- repKind k + k1 <- repLKind k repTSig t1 k1 repTy (HsSpliceTy splice _ _) = repSplice splice +repTy (HsExplicitListTy _ tys) = do + tys1 <- repLTys tys + repTPromotedList tys1 +repTy (HsExplicitTupleTy _ tys) = do + tys1 <- repLTys tys + tcon <- repPromotedTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsTyLit lit) = do + lit' <- repTyLit lit + repTLit lit' repTy ty = notHandled "Exotic form of type" (ppr ty) +repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ) +repTyLit (HsNumTy i) = rep2 numTyLitName [mkIntExpr i] +repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s + ; rep2 strTyLitName [s'] + } + -- represent a kind -- -repKind :: LHsKind Name -> DsM (Core TH.Kind) -repKind ki +repLKind :: LHsKind Name -> DsM (Core TH.Kind) +repLKind ki = do { let (kis, ki') = splitHsFunType ki - ; kis_rep <- mapM repKind kis - ; ki'_rep <- repNonArrowKind ki' - ; foldrM repArrowK ki'_rep kis_rep + ; kis_rep <- mapM repLKind kis + ; ki'_rep <- repNonArrowLKind ki' + ; kcon <- repKArrow + ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2 + ; foldrM f ki'_rep kis_rep } - where - repNonArrowKind (L _ (HsTyVar name)) | name == liftedTypeKindTyConName = repStarK - repNonArrowKind k = notHandled "Exotic form of kind" (ppr k) + +repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind) +repNonArrowLKind (L _ ki) = repNonArrowKind ki + +repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind) +repNonArrowKind (HsTyVar name) + | name == liftedTypeKindTyConName = repKStar + | name == constraintKindTyConName = repKConstraint + | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar + | otherwise = lookupOcc name >>= repKCon +repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f + ; a' <- repLKind a + ; repKApp f' a' + } +repNonArrowKind (HsListTy k) = do { k' <- repLKind k + ; kcon <- repKList + ; repKApp kcon k' + } +repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks + ; kcon <- repKTuple (length ks) + ; repKApps kcon ks' + } +repNonArrowKind k = notHandled "Exotic form of kind" (ppr k) ----------------------------------------------------------------------------- -- Splices @@ -719,7 +826,7 @@ repKind ki repSplice :: HsSplice Name -> DsM (Core a) -- See Note [How brackets and nested splices are handled] in TcSplice -- We return a CoreExpr of any old type; the context should know -repSplice (HsSplice n _) +repSplice (HsSplice n _) = do { mb_val <- dsLookupMetaEnv n ; case mb_val of Just (Splice e) -> do { e' <- dsExpr e @@ -743,7 +850,7 @@ repLE (L loc e) = putSrcSpanDs loc (repE e) repE :: HsExpr Name -> DsM (Core TH.ExpQ) repE (HsVar x) = - do { mb_val <- dsLookupMetaEnv x + do { mb_val <- dsLookupMetaEnv x ; case mb_val of Nothing -> do { str <- globalVar x ; repVarOrCon x str } @@ -760,17 +867,17 @@ repE (HsLam (MatchGroup [m] _)) = repLambda m repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b} repE (OpApp e1 op _ e2) = - do { arg1 <- repLE e1; - arg2 <- repLE e2; + do { arg1 <- repLE e1; + arg2 <- repLE e2; the_op <- repLE op ; - repInfixApp arg1 the_op arg2 } + repInfixApp arg1 the_op arg2 } repE (NegApp x _) = do a <- repLE x negateVar <- lookupOcc negateName >>= repVar negateVar `repApp` a repE (HsPar x) = repLE x -repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } -repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } +repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } +repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; repCaseE arg (nonEmptyCoreList ms2) } @@ -785,14 +892,14 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet -repE e@(HsDo ctxt sts _) +repE e@(HsDo ctxt sts _) | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False } - = do { (ss,zs) <- repLSts sts; + = do { (ss,zs) <- repLSts sts; e' <- repDoE (nonEmptyCoreList zs); wrapGenSyms ss e' } | ListComp <- ctxt - = do { (ss,zs) <- repLSts sts; + = do { (ss,zs) <- repLSts sts; e' <- repComp (nonEmptyCoreList zs); wrapGenSyms ss e' } @@ -801,7 +908,7 @@ repE e@(HsDo ctxt sts _) repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) -repE e@(ExplicitTuple es boxed) +repE e@(ExplicitTuple es boxed) | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) | isBoxed boxed = do { xs <- repLEs [e | Present e <- es]; repTup xs } | otherwise = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs } @@ -819,15 +926,15 @@ repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 repE (ArithSeq _ aseq) = case aseq of From e -> do { ds1 <- repLE e; repFrom ds1 } - FromThen e1 e2 -> do + FromThen e1 e2 -> do ds1 <- repLE e1 ds2 <- repLE e2 repFromThen ds1 ds2 - FromTo e1 e2 -> do + FromTo e1 e2 -> do ds1 <- repLE e1 ds2 <- repLE e2 repFromTo ds1 ds2 - FromThenTo e1 e2 e3 -> do + FromThenTo e1 e2 e3 -> do ds1 <- repLE e1 ds2 <- repLE e2 ds3 <- repLE e3 @@ -842,11 +949,11 @@ repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e) repE e = notHandled "Expression form" (ppr e) ----------------------------------------------------------------------------- --- Building representations of auxillary structures like Match, Clause, Stmt, +-- Building representations of auxillary structures like Match, Clause, Stmt, -repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ) +repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ) repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) = - do { ss1 <- mkGenSyms (collectPatBinders p) + do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p ; (ss2,ds) <- repBinds wheres @@ -858,7 +965,7 @@ repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ) repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) = - do { ss1 <- mkGenSyms (collectPatsBinders ps) + do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps ; (ss2,ds) <- repBinds wheres @@ -870,12 +977,12 @@ repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) = repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ) repGuards [L _ (GRHS [] e)] = do {a <- repLE e; repNormal a } -repGuards other +repGuards other = do { zs <- mapM process other; let {(xs, ys) = unzip zs}; gd <- repGuarded (nonEmptyCoreList ys); wrapGenSyms (concat xs) gd } - where + where process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2)) = do { x <- repLNormalGE e1 e2; @@ -903,18 +1010,18 @@ repFields (HsRecFields { rec_flds = flds }) -- and we could reuse the original names (x and x). -- -- do { x'1 <- gensym "x" --- ; x'2 <- gensym "x" +-- ; x'2 <- gensym "x" -- ; doE [ BindSt (pvar x'1) [| f 1 |] --- , BindSt (pvar x'2) [| f x |] --- , NoBindSt [| g x |] +-- , BindSt (pvar x'2) [| f x |] +-- , NoBindSt [| g x |] -- ] -- } -- The strategy is to translate a whole list of do-bindings by building a --- bigger environment, and a bigger set of meta bindings +-- bigger environment, and a bigger set of meta bindings -- (like: x'1 <- gensym "x" ) and then combining these with the translations -- of the expressions within the Do - + ----------------------------------------------------------------------------- -- The helper function repSts computes the translation of each sub expression -- and a bunch of prefix bindings denoting the dynamic renaming. @@ -924,10 +1031,10 @@ repLSts stmts = repSts (map unLoc stmts) repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ]) repSts (BindStmt p e _ _ : ss) = - do { e2 <- repLE e - ; ss1 <- mkGenSyms (collectPatBinders p) + do { e2 <- repLE e + ; ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { - ; p1 <- repLP p; + ; p1 <- repLP p; ; (ss2,zs) <- repSts ss ; z <- repBindSt p1 e2 ; return (ss1++ss2, z : zs) }} @@ -935,13 +1042,13 @@ repSts (LetStmt bs : ss) = do { (ss1,ds) <- repBinds bs ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) - ; return (ss1++ss2, z : zs) } -repSts (ExprStmt e _ _ _ : ss) = + ; return (ss1++ss2, z : zs) } +repSts (ExprStmt e _ _ _ : ss) = do { e2 <- repLE e - ; z <- repNoBindSt e2 + ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } -repSts [LastStmt e _] +repSts [LastStmt e _] = do { e2 <- repLE e ; z <- repNoBindSt e2 ; return ([], [z]) } @@ -953,7 +1060,7 @@ repSts other = notHandled "Exotic statement" (ppr other) -- Bindings ----------------------------------------------------------- -repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) +repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) repBinds EmptyLocalBinds = do { core_list <- coreList decQTyConName [] ; return ([], core_list) } @@ -961,14 +1068,15 @@ repBinds EmptyLocalBinds repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b) repBinds (HsValBinds decs) - = do { let { bndrs = collectHsValBinders decs } + = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs } -- No need to worrry about detailed scopes within -- the binding group, because we are talking Names - -- here, so we can safely treat it as a mutually + -- here, so we can safely treat it as a mutually -- recursive group + -- For hsSigTvBinders see Note [Scoped type variables in bindings] ; ss <- mkGenSyms bndrs ; prs <- addBinds ss (rep_val_binds decs) - ; core_list <- coreList decQTyConName + ; core_list <- coreList decQTyConName (de_loc (sort_by_loc prs)) ; return (ss, core_list) } @@ -991,10 +1099,10 @@ rep_binds' binds = mapM rep_bind (bagToList binds) rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Assumes: all the binders of the binding are alrady in the meta-env --- Note GHC treats declarations of a variable (not a pattern) --- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match +-- Note GHC treats declarations of a variable (not a pattern) +-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns -rep_bind (L loc (FunBind { fun_id = fn, +rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) @@ -1011,7 +1119,7 @@ rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ })) ; return (loc, ans) } rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres })) - = do { patcore <- repLP pat + = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore @@ -1019,11 +1127,11 @@ rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres })) ; return (loc, ans') } rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) - = do { v' <- lookupBinder v + = do { v' <- lookupBinder v ; e2 <- repLE e ; x <- repNormal e2 ; patcore <- repPvar v' - ; empty_decls <- coreList decQTyConName [] + ; empty_decls <- coreList decQTyConName [] ; ans <- repVal patcore x empty_decls ; return (srcLocSpan (getSrcLoc v), ans) } @@ -1031,27 +1139,27 @@ rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" ----------------------------------------------------------------------------- -- Since everything in a Bind is mutually recursive we need rename all --- all the variables simultaneously. For example: +-- all the variables simultaneously. For example: -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to -- do { f'1 <- gensym "f" -- ; g'2 <- gensym "g" -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]}, -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]} -- ]} --- This requires collecting the bindings (f'1 <- gensym "f"), and the --- environment ( f |-> f'1 ) from each binding, and then unioning them --- together. As we do this we collect GenSymBinds's which represent the renamed --- variables bound by the Bindings. In order not to lose track of these --- representations we build a shadow datatype MB with the same structure as +-- This requires collecting the bindings (f'1 <- gensym "f"), and the +-- environment ( f |-> f'1 ) from each binding, and then unioning them +-- together. As we do this we collect GenSymBinds's which represent the renamed +-- variables bound by the Bindings. In order not to lose track of these +-- representations we build a shadow datatype MB with the same structure as -- MonoBinds, but which has slots for the representations ----------------------------------------------------------------------------- -- GHC allows a more general form of lambda abstraction than specified --- by Haskell 98. In particular it allows guarded lambda's like : +-- by Haskell 98. In particular it allows guarded lambda's like : -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like --- (\ p1 .. pn -> exp) by causing an error. +-- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch Name -> DsM (Core TH.ExpQ) repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) @@ -1063,12 +1171,12 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) - + ----------------------------------------------------------------------------- -- Patterns -- repP deals with patterns. It assumes that we have already --- walked over the pattern(s) once to collect the binders, and --- have extended the environment. So every pattern-bound +-- walked over the pattern(s) once to collect the binders, and +-- have extended the environment. So every pattern-bound -- variable should already appear in the environment. -- Process a list of patterns @@ -1080,13 +1188,13 @@ repLP :: LPat Name -> DsM (Core TH.PatQ) repLP (L _ p) = repP p repP :: Pat Name -> DsM (Core TH.PatQ) -repP (WildPat _) = repPwild +repP (WildPat _) = repPwild repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' } repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } -repP (ParPat p) = repLP p +repP (ParPat p) = repLP p repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } repP (TuplePat ps boxed _) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } @@ -1152,15 +1260,15 @@ mkGenSyms :: [Name] -> DsM [GenSymBind] mkGenSyms ns = do { var_ty <- lookupType nameTyConName ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] } - + addBinds :: [GenSymBind] -> DsM a -> DsM a --- Add a list of fresh names for locally bound entities to the --- meta environment (which is part of the state carried around --- by the desugarer monad) +-- Add a list of fresh names for locally bound entities to the +-- meta environment (which is part of the state carried around +-- by the desugarer monad) addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal) -dupBinder (new, old) +dupBinder (new, old) = do { mb_val <- dsLookupMetaEnv old ; case mb_val of Just val -> return (new, val) @@ -1175,7 +1283,7 @@ lookupBinder :: Name -> DsM (Core TH.Name) lookupBinder = lookupOcc -- Binders are brought into scope before the pattern or what-not is -- desugared. Moreover, in instance declaration the binder of a method - -- will be the selector Id and hence a global; so we need the + -- will be the selector Id and hence a global; so we need the -- globalVar case of lookupOcc -- Look up a name that is either locally bound or a global name @@ -1194,21 +1302,9 @@ lookupOcc n case mb_val of Nothing -> globalVar n Just (Bound x) -> return (coreVar x) - Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) + Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) } -lookupTvOcc :: Name -> DsM (Core TH.Name) --- Type variables can't be staged and are not lexically scoped in TH -lookupTvOcc n - = do { mb_val <- dsLookupMetaEnv n ; - case mb_val of - Just (Bound x) -> return (coreVar x) - _ -> failWithDs msg - } - where - msg = vcat [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n) - , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ] - globalVar :: Name -> DsM (Core TH.Name) -- Not bound by the meta-env -- Could be top-level; or could be local @@ -1239,18 +1335,18 @@ lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ) lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; return (mkTyConApp tc []) } -wrapGenSyms :: [GenSymBind] +wrapGenSyms :: [GenSymBind] -> Core (TH.Q a) -> DsM (Core (TH.Q a)) --- wrapGenSyms [(nm1,id1), (nm2,id2)] y --- --> bindQ (gensym nm1) (\ id1 -> --- bindQ (gensym nm2 (\ id2 -> +-- wrapGenSyms [(nm1,id1), (nm2,id2)] y +-- --> bindQ (gensym nm1) (\ id1 -> +-- bindQ (gensym nm2 (\ id2 -> -- y)) wrapGenSyms binds body@(MkC b) = do { var_ty <- lookupType nameTyConName ; go var_ty binds } where - [elt_ty] = tcTyConAppArgs (exprType b) + [elt_ty] = tcTyConAppArgs (exprType b) -- b :: Q a, so we can get the type 'a' by looking at the -- argument type. NB: this relies on Q being a data/newtype, -- not a type synonym @@ -1260,7 +1356,7 @@ wrapGenSyms binds body@(MkC b) = do { MkC body' <- go var_ty binds ; lit_str <- occNameLit name ; gensym_app <- repGensym lit_str - ; repBindQ var_ty elt_ty + ; repBindQ var_ty elt_ty gensym_app (MkC (Lam id body')) } occNameLit :: Name -> DsM (Core String) @@ -1274,7 +1370,7 @@ occNameLit n = coreStringLit (occNameString (nameOccName n)) -- %********************************************************************* ----------------------------------------------------------------------------- --- PHANTOM TYPES for consistency. In order to make sure we do this correct +-- PHANTOM TYPES for consistency. In order to make sure we do this correct -- we invent a new datatype which uses phantom types. newtype Core a = MkC CoreExpr @@ -1285,6 +1381,10 @@ rep2 :: Name -> [ CoreExpr ] -> DsM (Core a) rep2 n xs = do { id <- dsLookupGlobalId n ; return (MkC (foldl App (Var id) xs)) } +dataCon :: Name -> DsM (Core a) +dataCon n = do { id <- dsLookupDataCon n + ; return $ MkC $ mkConApp id [] } + -- Then we make "repConstructors" which use the phantom types for each of the -- smart constructors of the Meta.Meta datatypes. @@ -1296,7 +1396,7 @@ rep2 n xs = do { id <- dsLookupGlobalId n -- %********************************************************************* --------------- Patterns ----------------- -repPlit :: Core TH.Lit -> DsM (Core TH.PatQ) +repPlit :: Core TH.Lit -> DsM (Core TH.PatQ) repPlit (MkC l) = rep2 litPName [l] repPvar :: Core TH.Name -> DsM (Core TH.PatQ) @@ -1341,16 +1441,16 @@ repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str | otherwise = repVar str repVar :: Core TH.Name -> DsM (Core TH.ExpQ) -repVar (MkC s) = rep2 varEName [s] +repVar (MkC s) = rep2 varEName [s] repCon :: Core TH.Name -> DsM (Core TH.ExpQ) -repCon (MkC s) = rep2 conEName [s] +repCon (MkC s) = rep2 conEName [s] repLit :: Core TH.Lit -> DsM (Core TH.ExpQ) -repLit (MkC c) = rep2 litEName [c] +repLit (MkC c) = rep2 litEName [c] repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repApp (MkC x) (MkC y) = rep2 appEName [x,y] +repApp (MkC x) (MkC y) = rep2 appEName [x,y] repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] @@ -1362,10 +1462,10 @@ repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] +repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] +repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ) repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] @@ -1453,10 +1553,10 @@ repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] -repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) +repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] -repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] +repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] -> Maybe (Core [TH.TypeQ]) -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ) repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs) @@ -1464,7 +1564,7 @@ repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs) repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs) = rep2 dataInstDName [cxt, nm, tys, cons, derivs] -repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] +repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] -> Maybe (Core [TH.TypeQ]) -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ) repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs) @@ -1472,21 +1572,21 @@ repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs) repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs) = rep2 newtypeInstDName [cxt, nm, tys, con, derivs] -repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] +repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] -> Maybe (Core [TH.TypeQ]) -> Core TH.TypeQ -> DsM (Core TH.DecQ) -repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs) +repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs) = rep2 tySynDName [nm, tvs, rhs] -repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs) +repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs) = rep2 tySynInstDName [nm, tys, rhs] repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds] -repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Core [TH.FunDep] -> Core [TH.DecQ] +repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] + -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ) -repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) +repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds] repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ) @@ -1495,27 +1595,28 @@ repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec] repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty] -repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ +repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ) -repPragSpecInl (MkC nm) (MkC ty) (MkC ispec) +repPragSpecInl (MkC nm) (MkC ty) (MkC ispec) = rep2 pragSpecInlDName [nm, ty, ispec] -repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] +repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] -> DsM (Core TH.DecQ) repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs) = rep2 familyNoKindDName [flav, nm, tvs] -repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] +repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] -> Core TH.Kind -> DsM (Core TH.DecQ) repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki) = rep2 familyKindDName [flav, nm, tvs, ki] -repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ) -repInlineSpecNoPhase (MkC inline) (MkC conlike) +repInlineSpecNoPhase :: Core TH.Inline -> Core Bool + -> DsM (Core TH.InlineSpecQ) +repInlineSpecNoPhase (MkC inline) (MkC conlike) = rep2 inlineSpecNoPhaseName [inline, conlike] -repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int +repInlineSpecPhase :: Core TH.Inline -> Core Bool -> Core Bool -> Core Int -> DsM (Core TH.InlineSpecQ) repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase) = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase] @@ -1555,7 +1656,7 @@ repConstr con (InfixCon st1 st2) ------------ Types ------------------- -repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ +repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 forallTName [tvars, ctxt, ty] @@ -1573,6 +1674,17 @@ repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ) repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] +repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ) +repTPromotedList [] = repPromotedNilTyCon +repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon + ; f <- repTapp tcon t + ; t' <- repTPromotedList ts + ; repTapp f t' + } + +repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ) +repTLit (MkC lit) = rep2 litTName [lit] + --------- Type constructors -------------- repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) @@ -1592,6 +1704,18 @@ repArrowTyCon = rep2 arrowTName [] repListTyCon :: DsM (Core TH.TypeQ) repListTyCon = rep2 listTName [] +repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) +repPromotedTyCon (MkC s) = rep2 promotedTName [s] + +repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ) +repPromotedTupleTyCon i = rep2 promotedTupleTName [mkIntExprInt i] + +repPromotedNilTyCon :: DsM (Core TH.TypeQ) +repPromotedNilTyCon = rep2 promotedNilTName [] + +repPromotedConsTyCon :: DsM (Core TH.TypeQ) +repPromotedConsTyCon = rep2 promotedConsTName [] + ------------ Kinds ------------------- repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr) @@ -1600,17 +1724,39 @@ repPlainTV (MkC nm) = rep2 plainTVName [nm] repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr) repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] -repStarK :: DsM (Core TH.Kind) -repStarK = rep2 starKName [] +repKVar :: Core TH.Name -> DsM (Core TH.Kind) +repKVar (MkC s) = rep2 varKName [s] -repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind) -repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2] +repKCon :: Core TH.Name -> DsM (Core TH.Kind) +repKCon (MkC s) = rep2 conKName [s] + +repKTuple :: Int -> DsM (Core TH.Kind) +repKTuple i = rep2 tupleKName [mkIntExprInt i] + +repKArrow :: DsM (Core TH.Kind) +repKArrow = rep2 arrowKName [] + +repKList :: DsM (Core TH.Kind) +repKList = rep2 listKName [] + +repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind) +repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2] + +repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind) +repKApps f [] = return f +repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks } + +repKStar :: DsM (Core TH.Kind) +repKStar = rep2 starKName [] + +repKConstraint :: DsM (Core TH.Kind) +repKConstraint = rep2 constraintKName [] ---------------------------------------------------------- -- Literals repLiteral :: HsLit -> DsM (Core TH.Lit) -repLiteral lit +repLiteral lit = do lit' <- case lit of HsIntPrim i -> mk_integer i HsWordPrim w -> mk_integer w @@ -1647,7 +1793,7 @@ mk_string s = return $ HsString s repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) repOverloadedLiteral (OverLit { ol_val = val}) = do { lit <- mk_lit val; repLiteral lit } - -- The type Rational will be in the environment, becuase + -- The type Rational will be in the environment, becuase -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used @@ -1655,7 +1801,7 @@ mk_lit :: OverLitVal -> DsM HsLit mk_lit (HsIntegral i) = mk_integer i mk_lit (HsFractional f) = mk_rational f mk_lit (HsIsString s) = mk_string s - + --------------- Miscellaneous ------------------- repGensym :: Core String -> DsM (Core (TH.Q TH.Name)) @@ -1663,8 +1809,8 @@ repGensym (MkC lit_str) = rep2 newNameName [lit_str] repBindQ :: Type -> Type -- a and b -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b)) -repBindQ ty_a ty_b (MkC x) (MkC y) - = rep2 bindQName [Type ty_a, Type ty_b, x, y] +repBindQ ty_a ty_b (MkC x) (MkC y) + = rep2 bindQName [Type ty_a, Type ty_b, x, y] repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a])) repSequenceQ ty_a (MkC list) @@ -1675,7 +1821,7 @@ repSequenceQ ty_a (MkC list) coreList :: Name -- Of the TyCon of the element type -> [Core a] -> DsM (Core [a]) -coreList tc_name es +coreList tc_name es = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } coreList' :: Type -- The element type @@ -1707,7 +1853,7 @@ coreVar id = MkC (Var id) notHandled :: String -> SDoc -> DsM a notHandled what doc = failWithDs msg where - msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell")) + msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell")) 2 doc @@ -1718,7 +1864,7 @@ notHandled what doc = failWithDs msg -- %************************************************************************ -- To add a name, do three things --- +-- -- 1) Allocate a key -- 2) Make a "Name" -- 3) Add the name to knownKeyNames @@ -1729,12 +1875,12 @@ templateHaskellNames :: [Name] templateHaskellNames = [ returnQName, bindQName, sequenceQName, newNameName, liftName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, liftStringName, - + -- Lit charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName, + floatPrimLName, doublePrimLName, rationalLName, -- Pat litPName, varPName, tupPName, unboxedTupPName, conPName, tildePName, bangPName, infixPName, @@ -1762,10 +1908,10 @@ templateHaskellNames = [ bindSName, letSName, noBindSName, parSName, -- Dec funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceDName, sigDName, forImpDName, + classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, - tySynInstDName, + tySynInstDName, infixLDName, infixRDName, infixNDName, -- Cxt cxtName, -- Pred @@ -1780,17 +1926,23 @@ templateHaskellNames = [ varStrictTypeName, -- Type forallTName, varTName, conTName, appTName, - tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, + tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName, + promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, + -- TyLit + numTyLitName, strTyLitName, -- TyVarBndr plainTVName, kindedTVName, -- Kind - starKName, arrowKName, + varKName, conKName, tupleKName, arrowKName, listKName, appKName, + starKName, constraintKName, -- Callconv cCallName, stdCallName, -- Safety unsafeName, safeName, interruptibleName, + -- Inline + noInlineDataConName, inlineDataConName, inlinableDataConName, -- InlineSpec inlineSpecNoPhaseName, inlineSpecPhaseName, -- FunDep @@ -1805,7 +1957,7 @@ templateHaskellNames = [ varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, - predQTyConName, decsQTyConName, + predQTyConName, decsQTyConName, -- Quasiquoting quoteDecName, quoteTypeName, quoteExpName, quotePatName] @@ -1818,18 +1970,19 @@ qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") mkTHModule :: FastString -> Module mkTHModule m = mkModule thPackageId (mkModuleNameFS m) -libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name -libFun = mk_known_key_name OccName.varName thLib -libTc = mk_known_key_name OccName.tcName thLib -thFun = mk_known_key_name OccName.varName thSyn -thTc = mk_known_key_name OccName.tcName thSyn -qqFun = mk_known_key_name OccName.varName qqLib +libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name +libFun = mk_known_key_name OccName.varName thLib +libTc = mk_known_key_name OccName.tcName thLib +thFun = mk_known_key_name OccName.varName thSyn +thTc = mk_known_key_name OccName.tcName thSyn +thCon = mk_known_key_name OccName.dataName thSyn +qqFun = mk_known_key_name OccName.varName qqLib -------------------- TH.Syntax ----------------------- qTyConName, nameTyConName, fieldExpTyConName, patTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName, - predTyConName :: Name + predTyConName :: Name qTyConName = thTc (fsLit "Q") qTyConKey nameTyConName = thTc (fsLit "Name") nameTyConKey fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey @@ -1961,7 +2114,8 @@ parSName = libFun (fsLit "parS") parSIdKey funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName, - newtypeInstDName, tySynInstDName :: Name + newtypeInstDName, tySynInstDName, + infixLDName, infixRDName, infixNDName :: Name funDName = libFun (fsLit "funD") funDIdKey valDName = libFun (fsLit "valD") valDIdKey dataDName = libFun (fsLit "dataD") dataDIdKey @@ -1979,6 +2133,9 @@ familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +infixLDName = libFun (fsLit "infixLD") infixLDIdKey +infixRDName = libFun (fsLit "infixRD") infixRDIdKey +infixNDName = libFun (fsLit "infixND") infixNDIdKey -- type Ctxt = ... cxtName :: Name @@ -2012,16 +2169,28 @@ varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey -- data Type = ... forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName, - listTName, appTName, sigTName :: Name -forallTName = libFun (fsLit "forallT") forallTIdKey -varTName = libFun (fsLit "varT") varTIdKey -conTName = libFun (fsLit "conT") conTIdKey -tupleTName = libFun (fsLit "tupleT") tupleTIdKey -unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey -arrowTName = libFun (fsLit "arrowT") arrowTIdKey -listTName = libFun (fsLit "listT") listTIdKey -appTName = libFun (fsLit "appT") appTIdKey -sigTName = libFun (fsLit "sigT") sigTIdKey + listTName, appTName, sigTName, litTName, + promotedTName, promotedTupleTName, + promotedNilTName, promotedConsTName :: Name +forallTName = libFun (fsLit "forallT") forallTIdKey +varTName = libFun (fsLit "varT") varTIdKey +conTName = libFun (fsLit "conT") conTIdKey +tupleTName = libFun (fsLit "tupleT") tupleTIdKey +unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey +arrowTName = libFun (fsLit "arrowT") arrowTIdKey +listTName = libFun (fsLit "listT") listTIdKey +appTName = libFun (fsLit "appT") appTIdKey +sigTName = libFun (fsLit "sigT") sigTIdKey +litTName = libFun (fsLit "litT") litTIdKey +promotedTName = libFun (fsLit "promotedT") promotedTIdKey +promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey +promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey +promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey + +-- data TyLit = ... +numTyLitName, strTyLitName :: Name +numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey +strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey -- data TyVarBndr = ... plainTVName, kindedTVName :: Name @@ -2029,9 +2198,16 @@ plainTVName = libFun (fsLit "plainTV") plainTVIdKey kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey -- data Kind = ... -starKName, arrowKName :: Name -starKName = libFun (fsLit "starK") starKIdKey -arrowKName = libFun (fsLit "arrowK") arrowKIdKey +varKName, conKName, tupleKName, arrowKName, listKName, appKName, + starKName, constraintKName :: Name +varKName = libFun (fsLit "varK") varKIdKey +conKName = libFun (fsLit "conK") conKIdKey +tupleKName = libFun (fsLit "tupleK") tupleKIdKey +arrowKName = libFun (fsLit "arrowK") arrowKIdKey +listKName = libFun (fsLit "listK") listKIdKey +appKName = libFun (fsLit "appK") appKIdKey +starKName = libFun (fsLit "starK") starKIdKey +constraintKName = libFun (fsLit "constraintK") constraintKIdKey -- data Callconv = ... cCallName, stdCallName :: Name @@ -2044,6 +2220,12 @@ unsafeName = libFun (fsLit "unsafe") unsafeIdKey safeName = libFun (fsLit "safe") safeIdKey interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey +-- data Inline = ... +noInlineDataConName, inlineDataConName, inlinableDataConName :: Name +noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey +inlineDataConName = thCon (fsLit "Inline") inlineDataConKey +inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey + -- data InlineSpec = ... inlineSpecNoPhaseName, inlineSpecPhaseName :: Name inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey @@ -2122,7 +2304,7 @@ predQTyConKey = mkPreludeTyConUnique 224 tyVarBndrTyConKey = mkPreludeTyConUnique 225 decsQTyConKey = mkPreludeTyConUnique 226 --- IdUniques available: 200-399 +-- IdUniques available: 200-499 -- If you want to change this, make sure you check in PrelNames returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, @@ -2243,7 +2425,8 @@ parSIdKey = mkPreludeMiscIdUnique 323 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey, - dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique + dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, + infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 330 valDIdKey = mkPreludeMiscIdUnique 331 dataDIdKey = mkPreludeMiscIdUnique 332 @@ -2261,6 +2444,9 @@ familyKindDIdKey = mkPreludeMiscIdUnique 343 dataInstDIdKey = mkPreludeMiscIdUnique 344 newtypeInstDIdKey = mkPreludeMiscIdUnique 345 tySynInstDIdKey = mkPreludeMiscIdUnique 346 +infixLDIdKey = mkPreludeMiscIdUnique 347 +infixRDIdKey = mkPreludeMiscIdUnique 348 +infixNDIdKey = mkPreludeMiscIdUnique 349 -- type Cxt = ... cxtIdKey :: Unique @@ -2294,55 +2480,80 @@ varStrictTKey = mkPreludeMiscIdUnique 375 -- data Type = ... forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey, - listTIdKey, appTIdKey, sigTIdKey :: Unique -forallTIdKey = mkPreludeMiscIdUnique 380 -varTIdKey = mkPreludeMiscIdUnique 381 -conTIdKey = mkPreludeMiscIdUnique 382 -tupleTIdKey = mkPreludeMiscIdUnique 383 -unboxedTupleTIdKey = mkPreludeMiscIdUnique 384 -arrowTIdKey = mkPreludeMiscIdUnique 385 -listTIdKey = mkPreludeMiscIdUnique 386 -appTIdKey = mkPreludeMiscIdUnique 387 -sigTIdKey = mkPreludeMiscIdUnique 388 + listTIdKey, appTIdKey, sigTIdKey, litTIdKey, + promotedTIdKey, promotedTupleTIdKey, + promotedNilTIdKey, promotedConsTIdKey :: Unique +forallTIdKey = mkPreludeMiscIdUnique 380 +varTIdKey = mkPreludeMiscIdUnique 381 +conTIdKey = mkPreludeMiscIdUnique 382 +tupleTIdKey = mkPreludeMiscIdUnique 383 +unboxedTupleTIdKey = mkPreludeMiscIdUnique 384 +arrowTIdKey = mkPreludeMiscIdUnique 385 +listTIdKey = mkPreludeMiscIdUnique 386 +appTIdKey = mkPreludeMiscIdUnique 387 +sigTIdKey = mkPreludeMiscIdUnique 388 +litTIdKey = mkPreludeMiscIdUnique 389 +promotedTIdKey = mkPreludeMiscIdUnique 390 +promotedTupleTIdKey = mkPreludeMiscIdUnique 391 +promotedNilTIdKey = mkPreludeMiscIdUnique 392 +promotedConsTIdKey = mkPreludeMiscIdUnique 393 + +-- data TyLit = ... +numTyLitIdKey, strTyLitIdKey :: Unique +numTyLitIdKey = mkPreludeMiscIdUnique 394 +strTyLitIdKey = mkPreludeMiscIdUnique 395 -- data TyVarBndr = ... plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 390 -kindedTVIdKey = mkPreludeMiscIdUnique 391 +plainTVIdKey = mkPreludeMiscIdUnique 396 +kindedTVIdKey = mkPreludeMiscIdUnique 397 -- data Kind = ... -starKIdKey, arrowKIdKey :: Unique -starKIdKey = mkPreludeMiscIdUnique 392 -arrowKIdKey = mkPreludeMiscIdUnique 393 +varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey, + starKIdKey, constraintKIdKey :: Unique +varKIdKey = mkPreludeMiscIdUnique 398 +conKIdKey = mkPreludeMiscIdUnique 399 +tupleKIdKey = mkPreludeMiscIdUnique 400 +arrowKIdKey = mkPreludeMiscIdUnique 401 +listKIdKey = mkPreludeMiscIdUnique 402 +appKIdKey = mkPreludeMiscIdUnique 403 +starKIdKey = mkPreludeMiscIdUnique 404 +constraintKIdKey = mkPreludeMiscIdUnique 405 -- data Callconv = ... cCallIdKey, stdCallIdKey :: Unique -cCallIdKey = mkPreludeMiscIdUnique 394 -stdCallIdKey = mkPreludeMiscIdUnique 395 +cCallIdKey = mkPreludeMiscIdUnique 406 +stdCallIdKey = mkPreludeMiscIdUnique 407 -- data Safety = ... unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique -unsafeIdKey = mkPreludeMiscIdUnique 400 -safeIdKey = mkPreludeMiscIdUnique 401 -interruptibleIdKey = mkPreludeMiscIdUnique 403 +unsafeIdKey = mkPreludeMiscIdUnique 408 +safeIdKey = mkPreludeMiscIdUnique 409 +interruptibleIdKey = mkPreludeMiscIdUnique 411 + +-- data Inline = ... +noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique +noInlineDataConKey = mkPreludeDataConUnique 40 +inlineDataConKey = mkPreludeDataConUnique 41 +inlinableDataConKey = mkPreludeDataConUnique 42 -- data InlineSpec = inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique -inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 404 -inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 405 +inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 412 +inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 413 -- data FunDep = ... funDepIdKey :: Unique -funDepIdKey = mkPreludeMiscIdUnique 406 +funDepIdKey = mkPreludeMiscIdUnique 414 -- data FamFlavour = ... typeFamIdKey, dataFamIdKey :: Unique -typeFamIdKey = mkPreludeMiscIdUnique 407 -dataFamIdKey = mkPreludeMiscIdUnique 408 +typeFamIdKey = mkPreludeMiscIdUnique 415 +dataFamIdKey = mkPreludeMiscIdUnique 416 -- quasiquoting quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 410 -quotePatKey = mkPreludeMiscIdUnique 411 -quoteDecKey = mkPreludeMiscIdUnique 412 -quoteTypeKey = mkPreludeMiscIdUnique 413 +quoteExpKey = mkPreludeMiscIdUnique 418 +quotePatKey = mkPreludeMiscIdUnique 419 +quoteDecKey = mkPreludeMiscIdUnique 420 +quoteTypeKey = mkPreludeMiscIdUnique 421 diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index e68e6db7c2..46c7bf269b 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -20,14 +20,14 @@ module DsMonad ( mkPrintUnqualifiedDs, newUnique, UniqSupply, newUniqueSupply, - getGhcModeDs, doptDs, woptDs, + getGhcModeDs, dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon, PArrBuiltin(..), dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe, dsInitPArrBuiltin, - DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, + DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, -- Warnings DsWarning, warnDs, failWithDs, @@ -346,12 +346,6 @@ We can also reach out and either set/grab location information from the @SrcSpan@ being carried around. \begin{code} -doptDs :: DynFlag -> TcRnIf gbl lcl Bool -doptDs = doptM - -woptDs :: WarningFlag -> TcRnIf gbl lcl Bool -woptDs = woptM - getGhcModeDs :: DsM GhcMode getGhcModeDs = getDynFlags >>= return . ghcMode @@ -367,14 +361,16 @@ putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) warnDs :: SDoc -> DsM () warnDs warn = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkWarnMsg loc (ds_unqual env) warn + ; dflags <- getDynFlags + ; let msg = mkWarnMsg dflags loc (ds_unqual env) warn ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } failWithDs :: SDoc -> DsM a failWithDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkErrMsg loc (ds_unqual env) err + ; dflags <- getDynFlags + ; let msg = mkErrMsg dflags loc (ds_unqual env) err ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) ; failM } @@ -480,6 +476,9 @@ dsInitPArrBuiltin thing_inside \end{code} \begin{code} +dsGetMetaEnv :: DsM (NameEnv DsMetaVal) +dsGetMetaEnv = do { env <- getLclEnv; return (ds_meta env) } + dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) } diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 5473edf216..52944e8347 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -76,6 +76,7 @@ import Outputable import SrcLoc import Util import ListSetOps +import DynFlags import FastString import Control.Monad ( zipWithM ) @@ -439,8 +440,9 @@ mkErrorAppDs :: Id -- The error function mkErrorAppDs err_id ty msg = do src_loc <- getSrcSpanDs + dflags <- getDynFlags let - full_msg = showSDoc (hcat [ppr src_loc, text "|", msg]) + full_msg = showSDoc dflags (hcat [ppr src_loc, text "|", msg]) core_msg = Lit (mkMachString full_msg) -- mkMachString returns a result of type String# return (mkApps (Var err_id) [Type ty, core_msg]) diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 974d3183a7..c80446a751 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -356,7 +356,7 @@ matchCoercion (var:vars) ty (eqns@(eqn1:_)) ; var' <- newUniqueId var (hsPatType pat) ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getCoPat) eqns - ; let rhs' = dsHsWrapper co (Var var) + ; rhs' <- dsHsWrapper co (Var var) ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) } matchCoercion _ _ _ = panic "matchCoercion" diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index f3b613fdbb..e1b2ef83df 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -26,12 +26,13 @@ import TcType import DsMonad import DsUtils import MkCore ( mkCoreLets ) -import Util ( all2, takeList, zipEqual ) +import Util import ListSetOps ( runs ) import Id import NameEnv import SrcLoc import Outputable +import Control.Monad(liftM) \end{code} We are confronted with the first column of patterns in a set of @@ -131,18 +132,20 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult -- All members of the group have compatible ConArgPats match_group arg_vars arg_eqn_prs - = do { let (wraps, eqns') = unzip (map shift arg_eqn_prs) - group_arg_vars = select_arg_vars arg_vars arg_eqn_prs + = do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) + ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs ; match_result <- match (group_arg_vars ++ vars) ty eqns' ; return (adjustMatchResult (foldr1 (.) wraps) match_result) } shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, pat_binds = bind, pat_args = args } : pats })) - = ( wrapBinds (tvs `zip` tvs1) - . wrapBinds (ds `zip` dicts1) - . mkCoreLets (dsTcEvBinds bind) - , eqn { eqn_pats = conArgPats arg_tys args ++ pats }) + = do ds_bind <- dsTcEvBinds bind + return ( wrapBinds (tvs `zip` tvs1) + . wrapBinds (ds `zip` dicts1) + . mkCoreLets ds_bind + , eqn { eqn_pats = conArgPats arg_tys args ++ pats } + ) shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) -- Choose the right arg_vars in the right order for this group diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index f0b88ebcd4..0969f5b078 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -20,12 +20,6 @@ Category: Development Build-Type: Simple Cabal-Version: >= 1.2.3 -Flag base4 - Description: Choose the even newer, even smaller, split-up base package. - -Flag base3 - Description: Choose the new smaller, split-up base package. - Flag dynlibs Description: Dynamic library support Default: False @@ -54,26 +48,20 @@ Flag stage3 Library Exposed: False - if flag(base4) - Build-Depends: base >= 4 && < 5 - if flag(base3) - Build-Depends: base >= 3 && < 4 - if !flag(base3) && !flag(base4) - Build-Depends: base < 3 + Build-Depends: base >= 4 && < 5, + directory >= 1 && < 1.2, + process >= 1 && < 1.2, + bytestring >= 0.9 && < 0.11, + time < 1.5, + containers >= 0.1 && < 0.6, + array >= 0.1 && < 0.5, + filepath >= 1 && < 1.4, + Cabal, + hpc if flag(stage1) && impl(ghc < 7.5) Build-Depends: old-time >= 1 && < 1.2 - if flag(base3) || flag(base4) - Build-Depends: directory >= 1 && < 1.2, - process >= 1 && < 1.2, - bytestring >= 0.9 && < 0.10, - time < 1.5, - containers >= 0.1 && < 0.5, - array >= 0.1 && < 0.5 - - Build-Depends: filepath >= 1 && < 1.4 - Build-Depends: Cabal, hpc if os(windows) Build-Depends: Win32 else @@ -89,14 +77,10 @@ Library Build-Depends: bin-package-db Build-Depends: hoopl - -- GHC 6.4.2 needs to be able to find WCsubst.c, which needs to be - -- able to find WCsubst.h - Include-Dirs: ../libraries/base/cbits, ../libraries/base/include - Extensions: CPP, MagicHash, UnboxedTuples, PatternGuards, ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances, MultiParamTypeClasses, - FlexibleInstances, Rank2Types, ScopedTypeVariables, + FlexibleInstances, RankNTypes, ScopedTypeVariables, DeriveDataTypeable, BangPatterns if impl(ghc >= 7.1) Extensions: NondecreasingIndentation @@ -356,7 +340,6 @@ Library RnEnv RnExpr RnHsDoc - RnHsSyn RnNames RnPat RnSource @@ -377,6 +360,7 @@ Library SRT SimplStg StgStats + UnariseStg Rules SpecConstr Specialise @@ -420,7 +404,6 @@ Library TcCanonical TcSMonad Class - IParam Coercion FamInstEnv FunDeps @@ -530,7 +513,6 @@ Library SPARC.CodeGen SPARC.CodeGen.Amode SPARC.CodeGen.Base - SPARC.CodeGen.CCall SPARC.CodeGen.CondCode SPARC.CodeGen.Gen32 SPARC.CodeGen.Gen64 diff --git a/compiler/ghc.mk b/compiler/ghc.mk index f5b93db162..1ea6159812 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -1,6 +1,6 @@ # ----------------------------------------------------------------------------- # -# (c) 2009 The University of Glasgow +# (c) 2009-2012 The University of Glasgow # # This file is part of the GHC build system. # @@ -27,8 +27,6 @@ endef # The 'echo' commands simply spit the values of various make variables # into Config.hs, whence they can be compiled and used by GHC itself -compiler_CONFIG_HS = compiler/main/Config.hs - # This is just to avoid generating a warning when generating deps # involving RtsFlags.h compiler_stage1_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES @@ -137,9 +135,6 @@ else endif @echo done. -# XXX 2010-08-19: This is a legacy clean. Remove later. -$(eval $(call clean-target,compiler,config_hs,compiler/main/Config.hs)) - # ----------------------------------------------------------------------------- # Create platform includes @@ -315,6 +310,9 @@ ifeq "$(GhcWithInterpreter)" "YES" compiler_stage2_CONFIGURE_OPTS += --flags=ghci ifeq "$(BuildSharedLibs)" "YES" +# There are too many symbols to make a Windows DLL for the ghc package, +# so we don't build it the dyn way; see trac #5987 +ifneq "$(TargetOS_CPP)" "mingw32" compiler_stage2_CONFIGURE_OPTS += --enable-shared # If we are going to use dynamic libraries instead of .o files for ghci, # we will need to always retain CAFs in the compiler. @@ -323,6 +321,7 @@ compiler_stage2_CONFIGURE_OPTS += --enable-shared # code is run. compiler_stage2_CONFIGURE_OPTS += --flags=dynlibs endif +endif ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO" # Should GHCI be building info tables in the TABLES_NEXT_TO_CODE style @@ -360,7 +359,7 @@ ifeq "$(GhcProfiled)" "YES" compiler/main/GhcMake_HC_OPTS += -auto-all compiler/main/GHC_HC_OPTS += -auto-all -# or alternatively addd {-# OPTIONS_GHC -auto-all #-} to the top of +# or alternatively add {-# OPTIONS_GHC -auto-all #-} to the top of # modules you're interested in. # We seem to still build the vanilla libraries even if we say @@ -408,8 +407,9 @@ endif endif ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" +compiler_stage1_MUNGED_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion)) define compiler_PACKAGE_MAGIC -compiler_stage1_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion)) +compiler_stage1_VERSION = $(compiler_stage1_MUNGED_VERSION) endef # Don't register the non-munged package @@ -427,6 +427,14 @@ compiler_stage1_SplitObjs = NO compiler_stage2_SplitObjs = NO compiler_stage3_SplitObjs = NO +ifeq "$(TargetOS_CPP)" "mingw32" +# There are too many symbols to make a Windows DLL for the ghc package, +# so we don't build it the dyn way; see trac #5987 +compiler_stage1_EXCLUDED_WAYS := dyn +compiler_stage2_EXCLUDED_WAYS := dyn +compiler_stage3_EXCLUDED_WAYS := dyn +endif + # if stage is set to something other than "1" or "", disable stage 1 ifneq "$(filter-out 1,$(stage))" "" compiler_stage1_NOT_NEEDED = YES @@ -497,11 +505,11 @@ compiler/main/Constants_HC_OPTS += -fforce-recomp # LibFFI.hs #includes ffi.h compiler/stage2/build/LibFFI.hs : $(libffi_HEADERS) # On Windows it seems we also need to link directly to libffi -ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32" +ifeq "$(HostOS_CPP)" "mingw32" define windowsDynLinkToFfi # $1 = way ifneq "$$(findstring dyn, $1)" "" -compiler_stage2_$1_ALL_HC_OPTS += -lffi-5 +compiler_stage2_$1_ALL_HC_OPTS += -l$$(LIBFFI_WINDOWS_LIB) endif endef $(foreach way,$(GhcLibWays),$(eval $(call windowsDynLinkToFfi,$(way)))) diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 360dffed43..5e5a5f0c62 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -34,8 +34,9 @@ import ClosureInfo -- CgRep stuff import DynFlags import Outputable import Platform +import Util -import Control.Monad ( foldM ) +import Control.Monad import Control.Monad.ST ( runST ) import Data.Array.MArray @@ -47,6 +48,7 @@ import Foreign import Data.Char ( ord ) import Data.List import Data.Map (Map) +import Data.Maybe (fromMaybe) import qualified Data.Map as Map import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld ) @@ -124,84 +126,63 @@ assembleBCOs dflags proto_bcos tycons return (ByteCode bcos itblenv) assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO -assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) - = let - -- pass 1: collect up the offsets of the local labels. - -- Remember that the first insn starts at offset - -- sizeOf Word / sizeOf Word16 - -- since offset 0 (eventually) will hold the total # of insns. - lableInitialOffset - | wORD_SIZE_IN_BITS == 64 = 4 - | wORD_SIZE_IN_BITS == 32 = 2 - | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" - label_env = mkLabelEnv Map.empty lableInitialOffset instrs - - -- Jump instructions are variable-sized, there are long and - -- short variants depending on the magnitude of the offset. - -- However, we can't tell what size instructions we will need - -- until we have calculated the offsets of the labels, which - -- depends on the size of the instructions... We could - -- repeat the calculation and hope to reach a fixpoint, but - -- instead we just calculate the worst-case size and use that - -- to decide whether *all* the jumps in this BCO will be long - -- or short. - - -- True => all our jumps will be long - large_bco = isLarge max_w16s - where max_w16s = fromIntegral (length instrs) * maxInstr16s :: Word - - mkLabelEnv :: Map Word16 Word -> Word -> [BCInstr] - -> Map Word16 Word - mkLabelEnv env _ [] = env - mkLabelEnv env i_offset (i:is) - = let new_env - = case i of LABEL n -> Map.insert n i_offset env ; _ -> env - in mkLabelEnv new_env (i_offset + instrSize16s i large_bco) is - - findLabel :: Word16 -> Word - findLabel lab - = case Map.lookup lab label_env of - Just bco_offset -> bco_offset - Nothing -> pprPanic "assembleBCO.findLabel" (ppr lab) - in - do -- pass 2: generate the instruction, ptr and nonptr bits - insns <- return emptySS :: IO (SizedSeq Word16) - lits <- return emptySS :: IO (SizedSeq BCONPtr) - ptrs <- return emptySS :: IO (SizedSeq BCOPtr) - let init_asm_state = (insns,lits,ptrs) - (final_insns, final_lits, final_ptrs) - <- mkBits dflags large_bco findLabel init_asm_state instrs - - let asm_insns = ssElts final_insns - n_insns = sizeSS final_insns - - insns_arr = mkInstrArray lableInitialOffset n_insns asm_insns - !insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr - - bitmap_arr = mkBitmapArray bsize bitmap - !bitmap_barr = case bitmap_arr of UArray _lo _hi _n barr -> barr - - let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs - - -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive - -- objects, since they might get run too early. Disable this until - -- we figure out what to do. - -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) - - return ul_bco - -- where - -- zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#)) - -- free ptr +assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do + -- pass 1: collect up the offsets of the local labels. + let asm = mapM_ (assembleI dflags) instrs + + -- Remember that the first insn starts at offset + -- sizeOf Word / sizeOf Word16 + -- since offset 0 (eventually) will hold the total # of insns. + initial_offset = largeArg16s + + -- Jump instructions are variable-sized, there are long and short variants + -- depending on the magnitude of the offset. However, we can't tell what + -- size instructions we will need until we have calculated the offsets of + -- the labels, which depends on the size of the instructions... So we + -- first create the label environment assuming that all jumps are short, + -- and if the final size is indeed small enough for short jumps, we are + -- done. Otherwise, we repeat the calculation, and we force all jumps in + -- this BCO to be long. + (n_insns0, lbl_map0) = inspectAsm False initial_offset asm + ((n_insns, lbl_map), long_jumps) + | isLarge n_insns0 = (inspectAsm True initial_offset asm, True) + | otherwise = ((n_insns0, lbl_map0), False) + + env :: Word16 -> Word + env lbl = fromMaybe + (pprPanic "assembleBCO.findLabel" (ppr lbl)) + (Map.lookup lbl lbl_map) + + -- pass 2: run assembler and generate instructions, literals and pointers + let initial_insns = addListToSS emptySS $ largeArg n_insns + let initial_state = (initial_insns, emptySS, emptySS) + (final_insns, final_lits, final_ptrs) <- execState initial_state $ runAsm long_jumps env asm + + -- precomputed size should be equal to final size + ASSERT (n_insns == sizeSS final_insns) return () + + let asm_insns = ssElts final_insns + barr a = case a of UArray _lo _hi _n b -> b + + insns_arr = listArray (0, n_insns - 1) asm_insns + !insns_barr = barr insns_arr + + bitmap_arr = mkBitmapArray bsize bitmap + !bitmap_barr = barr bitmap_arr + + ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs + + -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive + -- objects, since they might get run too early. Disable this until + -- we figure out what to do. + -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) + + return ul_bco mkBitmapArray :: Word16 -> [StgWord] -> UArray Int StgWord mkBitmapArray bsize bitmap = listArray (0, length bitmap) (fromIntegral bsize : bitmap) -mkInstrArray :: Word -> Word -> [Word16] -> UArray Word Word16 -mkInstrArray lableInitialOffset n_insns asm_insns - = let size = lableInitialOffset + n_insns - in listArray (0, size - 1) (largeArg size ++ asm_insns) - -- instrs nonptrs ptrs type AsmState = (SizedSeq Word16, SizedSeq BCONPtr, @@ -211,12 +192,12 @@ data SizedSeq a = SizedSeq !Word [a] emptySS :: SizedSeq a emptySS = SizedSeq 0 [] --- Why are these two monadic??? -addToSS :: SizedSeq a -> a -> IO (SizedSeq a) -addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs)) -addListToSS :: SizedSeq a -> [a] -> IO (SizedSeq a) +addToSS :: SizedSeq a -> a -> SizedSeq a +addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs) + +addListToSS :: SizedSeq a -> [a] -> SizedSeq a addListToSS (SizedSeq n r_xs) xs - = return (SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)) + = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs) ssElts :: SizedSeq a -> [a] ssElts (SizedSeq _ r_xs) = reverse r_xs @@ -224,8 +205,111 @@ ssElts (SizedSeq _ r_xs) = reverse r_xs sizeSS :: SizedSeq a -> Word sizeSS (SizedSeq n _) = n -sizeSS16 :: SizedSeq a -> Word16 -sizeSS16 (SizedSeq n _) = fromIntegral n +data Operand + = Op Word + | SmallOp Word16 + | LargeOp Word + | LabelOp Word16 + +data Assembler a + = AllocPtr (IO BCOPtr) (Word -> Assembler a) + | AllocLit [BCONPtr] (Word -> Assembler a) + | AllocLabel Word16 (Assembler a) + | Emit Word16 [Operand] (Assembler a) + | NullAsm a + +instance Monad Assembler where + return = NullAsm + NullAsm x >>= f = f x + AllocPtr p k >>= f = AllocPtr p (k >=> f) + AllocLit l k >>= f = AllocLit l (k >=> f) + AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f) + Emit w ops k >>= f = Emit w ops (k >>= f) + +ioptr :: IO BCOPtr -> Assembler Word +ioptr p = AllocPtr p return + +ptr :: BCOPtr -> Assembler Word +ptr = ioptr . return + +lit :: [BCONPtr] -> Assembler Word +lit l = AllocLit l return + +label :: Word16 -> Assembler () +label w = AllocLabel w (return ()) + +emit :: Word16 -> [Operand] -> Assembler () +emit w ops = Emit w ops (return ()) + +type LabelEnv = Word16 -> Word + +largeOp :: Bool -> Operand -> Bool +largeOp long_jumps op = case op of + LargeOp _ -> True + SmallOp _ -> False + Op w -> isLarge w + LabelOp _ -> long_jumps + +runAsm :: Bool -> LabelEnv -> Assembler a -> State AsmState IO a +runAsm long_jumps e = go + where + go (NullAsm x) = return x + go (AllocPtr p_io k) = do + p <- lift p_io + w <- State $ \(st_i0,st_l0,st_p0) -> do + let st_p1 = addToSS st_p0 p + return ((st_i0,st_l0,st_p1), sizeSS st_p0) + go $ k w + go (AllocLit lits k) = do + w <- State $ \(st_i0,st_l0,st_p0) -> do + let st_l1 = addListToSS st_l0 lits + return ((st_i0,st_l1,st_p0), sizeSS st_l0) + go $ k w + go (AllocLabel _ k) = go k + go (Emit w ops k) = do + let largeOps = any (largeOp long_jumps) ops + opcode + | largeOps = largeArgInstr w + | otherwise = w + words = concatMap expand ops + expand (SmallOp w) = [w] + expand (LargeOp w) = largeArg w + expand (LabelOp w) = expand (Op (e w)) + expand (Op w) = if largeOps then largeArg w else [fromIntegral w] + State $ \(st_i0,st_l0,st_p0) -> do + let st_i1 = addListToSS st_i0 (opcode : words) + return ((st_i1,st_l0,st_p0), ()) + go k + +type LabelEnvMap = Map Word16 Word + +data InspectState = InspectState + { instrCount :: !Word + , ptrCount :: !Word + , litCount :: !Word + , lblEnv :: LabelEnvMap + } + +inspectAsm :: Bool -> Word -> Assembler a -> (Word, LabelEnvMap) +inspectAsm long_jumps initial_offset + = go (InspectState initial_offset 0 0 Map.empty) + where + go s (NullAsm _) = (instrCount s, lblEnv s) + go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n) + where n = ptrCount s + go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n) + where n = litCount s + go s (AllocLabel lbl k) = go s' k + where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) } + go s (Emit _ ops k) = go s' k + where + s' = s { instrCount = instrCount s + size } + size = sum (map count ops) + 1 + largeOps = any (largeOp long_jumps) ops + count (SmallOp _) = 1 + count (LargeOp _) = largeArg16s + count (LabelOp _) = count (Op 0) + count (Op _) = if largeOps then largeArg16s else 1 -- Bring in all the bci_ bytecode constants. #include "rts/Bytecodes.h" @@ -249,194 +333,110 @@ largeArg16s :: Word largeArg16s | wORD_SIZE_IN_BITS == 64 = 4 | otherwise = 2 --- This is where all the action is (pass 2 of the assembler) -mkBits :: DynFlags - -> Bool -- jumps are long - -> (Word16 -> Word) -- label finder - -> AsmState - -> [BCInstr] -- instructions (in) - -> IO AsmState - -mkBits dflags long_jumps findLabel st proto_insns - = foldM doInstr st proto_insns - where - doInstr :: AsmState -> BCInstr -> IO AsmState - doInstr st i - = case i of - STKCHECK n - | isLarge n -> instrn st (largeArgInstr bci_STKCHECK : largeArg n) - | otherwise -> instr2 st bci_STKCHECK (fromIntegral n) - - PUSH_L o1 -> instr2 st bci_PUSH_L o1 - PUSH_LL o1 o2 -> instr3 st bci_PUSH_LL o1 o2 - PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3 - PUSH_G nm -> do (p, st2) <- ptr st (BCOPtrName nm) - instr2 st2 bci_PUSH_G p - PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op) - instr2 st2 bci_PUSH_G p - PUSH_BCO proto -> do ul_bco <- assembleBCO dflags proto - (p, st2) <- ptr st (BCOPtrBCO ul_bco) - instr2 st2 bci_PUSH_G p - PUSH_ALTS proto -> do ul_bco <- assembleBCO dflags proto - (p, st2) <- ptr st (BCOPtrBCO ul_bco) - instr2 st2 bci_PUSH_ALTS p - PUSH_ALTS_UNLIFTED proto pk -> do - ul_bco <- assembleBCO dflags proto - (p, st2) <- ptr st (BCOPtrBCO ul_bco) - instr2 st2 (push_alts pk) p - PUSH_UBX (Left lit) nws - -> do (np, st2) <- literal st lit - instr3 st2 bci_PUSH_UBX np nws - PUSH_UBX (Right aa) nws - -> do (np, st2) <- addr st aa - instr3 st2 bci_PUSH_UBX np nws - - PUSH_APPLY_N -> do instr1 st bci_PUSH_APPLY_N - PUSH_APPLY_V -> do instr1 st bci_PUSH_APPLY_V - PUSH_APPLY_F -> do instr1 st bci_PUSH_APPLY_F - PUSH_APPLY_D -> do instr1 st bci_PUSH_APPLY_D - PUSH_APPLY_L -> do instr1 st bci_PUSH_APPLY_L - PUSH_APPLY_P -> do instr1 st bci_PUSH_APPLY_P - PUSH_APPLY_PP -> do instr1 st bci_PUSH_APPLY_PP - PUSH_APPLY_PPP -> do instr1 st bci_PUSH_APPLY_PPP - PUSH_APPLY_PPPP -> do instr1 st bci_PUSH_APPLY_PPPP - PUSH_APPLY_PPPPP -> do instr1 st bci_PUSH_APPLY_PPPPP - PUSH_APPLY_PPPPPP -> do instr1 st bci_PUSH_APPLY_PPPPPP - - SLIDE n by -> instr3 st bci_SLIDE n by - ALLOC_AP n -> instr2 st bci_ALLOC_AP n - ALLOC_AP_NOUPD n -> instr2 st bci_ALLOC_AP_NOUPD n - ALLOC_PAP arity n -> instr3 st bci_ALLOC_PAP arity n - MKAP off sz -> instr3 st bci_MKAP off sz - MKPAP off sz -> instr3 st bci_MKPAP off sz - UNPACK n -> instr2 st bci_UNPACK n - PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon - instr3 st2 bci_PACK itbl_no sz - LABEL _ -> return st - TESTLT_I i l -> do (np, st2) <- int st i - jumpInstr2 st2 bci_TESTLT_I np (findLabel l) - TESTEQ_I i l -> do (np, st2) <- int st i - jumpInstr2 st2 bci_TESTEQ_I np (findLabel l) - TESTLT_W w l -> do (np, st2) <- word st w - jumpInstr2 st2 bci_TESTLT_W np (findLabel l) - TESTEQ_W w l -> do (np, st2) <- word st w - jumpInstr2 st2 bci_TESTEQ_W np (findLabel l) - TESTLT_F f l -> do (np, st2) <- float st f - jumpInstr2 st2 bci_TESTLT_F np (findLabel l) - TESTEQ_F f l -> do (np, st2) <- float st f - jumpInstr2 st2 bci_TESTEQ_F np (findLabel l) - TESTLT_D d l -> do (np, st2) <- double st d - jumpInstr2 st2 bci_TESTLT_D np (findLabel l) - TESTEQ_D d l -> do (np, st2) <- double st d - jumpInstr2 st2 bci_TESTEQ_D np (findLabel l) - TESTLT_P i l -> jumpInstr2 st bci_TESTLT_P i (findLabel l) - TESTEQ_P i l -> jumpInstr2 st bci_TESTEQ_P i (findLabel l) - CASEFAIL -> instr1 st bci_CASEFAIL - SWIZZLE stkoff n -> instr3 st bci_SWIZZLE stkoff n - JMP l -> jumpInstr1 st bci_JMP (findLabel l) - ENTER -> instr1 st bci_ENTER - RETURN -> instr1 st bci_RETURN - RETURN_UBX rep -> instr1 st (return_ubx rep) - CCALL off m_addr int -> do (np, st2) <- addr st m_addr - instr4 st2 bci_CCALL off np int - BRK_FUN array index info -> do - (p1, st2) <- ptr st (BCOPtrArray array) - (p2, st3) <- ptr st2 (BCOPtrBreakInfo info) - instr4 st3 bci_BRK_FUN p1 index p2 - - instrn :: AsmState -> [Word16] -> IO AsmState - instrn st [] = return st - instrn (st_i, st_l, st_p) (i:is) - = do st_i' <- addToSS st_i i - instrn (st_i', st_l, st_p) is - - jumpInstr1 st i1 i2 - | long_jumps = instrn st (largeArgInstr i1 : largeArg i2) - | otherwise = instr2 st i1 (fromIntegral i2) - - jumpInstr2 st i1 i2 i3 - | long_jumps = instrn st (largeArgInstr i1 : i2 : largeArg i3) - | otherwise = instr3 st i1 i2 (fromIntegral i3) - - instr1 (st_i0,st_l0,st_p0) i1 - = do st_i1 <- addToSS st_i0 i1 - return (st_i1,st_l0,st_p0) - - instr2 (st_i0,st_l0,st_p0) w1 w2 - = do st_i1 <- addToSS st_i0 w1 - st_i2 <- addToSS st_i1 w2 - return (st_i2,st_l0,st_p0) - - instr3 (st_i0,st_l0,st_p0) w1 w2 w3 - = do st_i1 <- addToSS st_i0 w1 - st_i2 <- addToSS st_i1 w2 - st_i3 <- addToSS st_i2 w3 - return (st_i3,st_l0,st_p0) - - instr4 (st_i0,st_l0,st_p0) w1 w2 w3 w4 - = do st_i1 <- addToSS st_i0 w1 - st_i2 <- addToSS st_i1 w2 - st_i3 <- addToSS st_i2 w3 - st_i4 <- addToSS st_i3 w4 - return (st_i4,st_l0,st_p0) - - float (st_i0,st_l0,st_p0) f - = do let ws = mkLitF f - st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) - return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) - - double (st_i0,st_l0,st_p0) d - = do let ws = mkLitD d - st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) - return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) - - int (st_i0,st_l0,st_p0) i - = do let ws = mkLitI i - st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) - return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) - - word (st_i0,st_l0,st_p0) w - = do let ws = [w] - st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) - return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) - - int64 (st_i0,st_l0,st_p0) i - = do let ws = mkLitI64 i - st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) - return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) - - addr (st_i0,st_l0,st_p0) a - = do let ws = mkLitPtr a - st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) - return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) - - litlabel (st_i0,st_l0,st_p0) fs - = do st_l1 <- addListToSS st_l0 [BCONPtrLbl fs] - return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) - - ptr (st_i0,st_l0,st_p0) p - = do st_p1 <- addToSS st_p0 p - return (sizeSS16 st_p0, (st_i0,st_l0,st_p1)) - - itbl (st_i0,st_l0,st_p0) dcon - = do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon)) - return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) - - literal st (MachLabel fs (Just sz) _) - | platformOS (targetPlatform dflags) == OSMinGW32 - = litlabel st (appendFS fs (mkFastString ('@':show sz))) - -- On Windows, stdcall labels have a suffix indicating the no. of - -- arg words, e.g. foo@8. testcase: ffi012(ghci) - literal st (MachLabel fs _ _) = litlabel st fs - literal st (MachWord w) = int st (fromIntegral w) - literal st (MachInt j) = int st (fromIntegral j) - literal st MachNullAddr = int st 0 - literal st (MachFloat r) = float st (fromRational r) - literal st (MachDouble r) = double st (fromRational r) - literal st (MachChar c) = int st (ord c) - literal st (MachInt64 ii) = int64 st (fromIntegral ii) - literal st (MachWord64 ii) = int64 st (fromIntegral ii) - literal _ other = pprPanic "ByteCodeAsm.literal" (ppr other) +assembleI :: DynFlags + -> BCInstr + -> Assembler () +assembleI dflags i = case i of + STKCHECK n -> emit bci_STKCHECK [Op n] + PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1] + PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] + PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3] + PUSH_G nm -> do p <- ptr (BCOPtrName nm) + emit bci_PUSH_G [Op p] + PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) + emit bci_PUSH_G [Op p] + PUSH_BCO proto -> do let ul_bco = assembleBCO dflags proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit bci_PUSH_G [Op p] + PUSH_ALTS proto -> do let ul_bco = assembleBCO dflags proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit bci_PUSH_ALTS [Op p] + PUSH_ALTS_UNLIFTED proto pk + -> do let ul_bco = assembleBCO dflags proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit (push_alts pk) [Op p] + PUSH_UBX (Left lit) nws -> do np <- literal lit + emit bci_PUSH_UBX [Op np, SmallOp nws] + PUSH_UBX (Right aa) nws -> do np <- addr aa + emit bci_PUSH_UBX [Op np, SmallOp nws] + + PUSH_APPLY_N -> emit bci_PUSH_APPLY_N [] + PUSH_APPLY_V -> emit bci_PUSH_APPLY_V [] + PUSH_APPLY_F -> emit bci_PUSH_APPLY_F [] + PUSH_APPLY_D -> emit bci_PUSH_APPLY_D [] + PUSH_APPLY_L -> emit bci_PUSH_APPLY_L [] + PUSH_APPLY_P -> emit bci_PUSH_APPLY_P [] + PUSH_APPLY_PP -> emit bci_PUSH_APPLY_PP [] + PUSH_APPLY_PPP -> emit bci_PUSH_APPLY_PPP [] + PUSH_APPLY_PPPP -> emit bci_PUSH_APPLY_PPPP [] + PUSH_APPLY_PPPPP -> emit bci_PUSH_APPLY_PPPPP [] + PUSH_APPLY_PPPPPP -> emit bci_PUSH_APPLY_PPPPPP [] + + SLIDE n by -> emit bci_SLIDE [SmallOp n, SmallOp by] + ALLOC_AP n -> emit bci_ALLOC_AP [SmallOp n] + ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [SmallOp n] + ALLOC_PAP arity n -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n] + MKAP off sz -> emit bci_MKAP [SmallOp off, SmallOp sz] + MKPAP off sz -> emit bci_MKPAP [SmallOp off, SmallOp sz] + UNPACK n -> emit bci_UNPACK [SmallOp n] + PACK dcon sz -> do itbl_no <- lit [BCONPtrItbl (getName dcon)] + emit bci_PACK [Op itbl_no, SmallOp sz] + LABEL lbl -> label lbl + TESTLT_I i l -> do np <- int i + emit bci_TESTLT_I [Op np, LabelOp l] + TESTEQ_I i l -> do np <- int i + emit bci_TESTEQ_I [Op np, LabelOp l] + TESTLT_W w l -> do np <- word w + emit bci_TESTLT_W [Op np, LabelOp l] + TESTEQ_W w l -> do np <- word w + emit bci_TESTEQ_W [Op np, LabelOp l] + TESTLT_F f l -> do np <- float f + emit bci_TESTLT_F [Op np, LabelOp l] + TESTEQ_F f l -> do np <- float f + emit bci_TESTEQ_F [Op np, LabelOp l] + TESTLT_D d l -> do np <- double d + emit bci_TESTLT_D [Op np, LabelOp l] + TESTEQ_D d l -> do np <- double d + emit bci_TESTEQ_D [Op np, LabelOp l] + TESTLT_P i l -> emit bci_TESTLT_P [SmallOp i, LabelOp l] + TESTEQ_P i l -> emit bci_TESTEQ_P [SmallOp i, LabelOp l] + CASEFAIL -> emit bci_CASEFAIL [] + SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n] + JMP l -> emit bci_JMP [LabelOp l] + ENTER -> emit bci_ENTER [] + RETURN -> emit bci_RETURN [] + RETURN_UBX rep -> emit (return_ubx rep) [] + CCALL off m_addr i -> do np <- addr m_addr + emit bci_CCALL [SmallOp off, Op np, SmallOp i] + BRK_FUN array index info -> do p1 <- ptr (BCOPtrArray array) + p2 <- ptr (BCOPtrBreakInfo info) + emit bci_BRK_FUN [Op p1, SmallOp index, Op p2] + + where + literal (MachLabel fs (Just sz) _) + | platformOS (targetPlatform dflags) == OSMinGW32 + = litlabel (appendFS fs (mkFastString ('@':show sz))) + -- On Windows, stdcall labels have a suffix indicating the no. of + -- arg words, e.g. foo@8. testcase: ffi012(ghci) + literal (MachLabel fs _ _) = litlabel fs + literal (MachWord w) = int (fromIntegral w) + literal (MachInt j) = int (fromIntegral j) + literal MachNullAddr = int 0 + literal (MachFloat r) = float (fromRational r) + literal (MachDouble r) = double (fromRational r) + literal (MachChar c) = int (ord c) + literal (MachInt64 ii) = int64 (fromIntegral ii) + literal (MachWord64 ii) = int64 (fromIntegral ii) + literal other = pprPanic "ByteCodeAsm.literal" (ppr other) + + litlabel fs = lit [BCONPtrLbl fs] + addr = words . mkLitPtr + float = words . mkLitF + double = words . mkLitD + int = words . mkLitI + int64 = words . mkLitI64 + words ws = lit (map BCONPtrWord ws) + word w = words [w] isLarge :: Word -> Bool isLarge n = n > 65535 @@ -457,67 +457,6 @@ return_ubx VoidArg = bci_RETURN_V return_ubx LongArg = bci_RETURN_L return_ubx PtrArg = bci_RETURN_P - --- The size in 16-bit entities of an instruction. -instrSize16s :: BCInstr -> Bool -> Word -instrSize16s instr long_jumps - = case instr of - STKCHECK n -> if isLarge n then 1 + largeArg16s else 2 - PUSH_L{} -> 2 - PUSH_LL{} -> 3 - PUSH_LLL{} -> 4 - PUSH_G{} -> 2 - PUSH_PRIMOP{} -> 2 - PUSH_BCO{} -> 2 - PUSH_ALTS{} -> 2 - PUSH_ALTS_UNLIFTED{} -> 2 - PUSH_UBX{} -> 3 - PUSH_APPLY_N{} -> 1 - PUSH_APPLY_V{} -> 1 - PUSH_APPLY_F{} -> 1 - PUSH_APPLY_D{} -> 1 - PUSH_APPLY_L{} -> 1 - PUSH_APPLY_P{} -> 1 - PUSH_APPLY_PP{} -> 1 - PUSH_APPLY_PPP{} -> 1 - PUSH_APPLY_PPPP{} -> 1 - PUSH_APPLY_PPPPP{} -> 1 - PUSH_APPLY_PPPPPP{} -> 1 - SLIDE{} -> 3 - ALLOC_AP{} -> 2 - ALLOC_AP_NOUPD{} -> 2 - ALLOC_PAP{} -> 3 - MKAP{} -> 3 - MKPAP{} -> 3 - UNPACK{} -> 2 - PACK{} -> 3 - LABEL{} -> 0 -- !! - TESTLT_I{} -> 2 + jump - TESTEQ_I{} -> 2 + jump - TESTLT_W{} -> 2 + jump - TESTEQ_W{} -> 2 + jump - TESTLT_F{} -> 2 + jump - TESTEQ_F{} -> 2 + jump - TESTLT_D{} -> 2 + jump - TESTEQ_D{} -> 2 + jump - TESTLT_P{} -> 2 + jump - TESTEQ_P{} -> 2 + jump - JMP{} -> 1 + jump - CASEFAIL{} -> 1 - ENTER{} -> 1 - RETURN{} -> 1 - RETURN_UBX{} -> 1 - CCALL{} -> 4 - SWIZZLE{} -> 3 - BRK_FUN{} -> 4 - where - jump | long_jumps = largeArg16s - | otherwise = 1 - --- The biggest instruction in Word16s -maxInstr16s :: Word -maxInstr16s = 2 + largeArg16s -- LARGE TESTLT_I = 2 + largeArg16s - -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the -- bit pattern is correct for the host's word size and endianness. diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index afc51163e3..d722964bcd 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -66,6 +66,7 @@ import Module import Data.Map (Map) import qualified Data.Map as Map import qualified FiniteMap as Map +import Data.Ord -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -131,11 +132,11 @@ coreExprToBCOs dflags this_mod expr type BCInstrList = OrdList BCInstr -type Sequel = Word16 -- back off to this depth before ENTER +type Sequel = Word -- back off to this depth before ENTER -- Maps Ids to the offset from the stack _base_ so we don't have -- to mess with it after each push/pop. -type BCEnv = Map Id Word16 -- To find vars on the stack +type BCEnv = Map Id Word -- To find vars on the stack {- ppBCEnv :: BCEnv -> SDoc @@ -271,8 +272,12 @@ collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet) collect (_, e) = go [] e where go xs e | Just e' <- bcView e = go xs e' - go xs (AnnLam x (_,e)) = go (x:xs) e - go xs not_lambda = (reverse xs, not_lambda) + go xs (AnnLam x (_,e)) + | UbxTupleRep _ <- repType (idType x) + = unboxedTupleException + | otherwise + = go (x:xs) e + go xs not_lambda = (reverse xs, not_lambda) schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) @@ -298,10 +303,10 @@ schemeR_wrk fvs nm original_body (args, body) arity bitmap_size bitmap False{-not alts-}) -- introduce break instructions for ticked expressions -schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList +schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList schemeER_wrk d p rhs | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs - = do code <- schemeE d 0 p newRhs + = do code <- schemeE (fromIntegral d) 0 p newRhs arr <- getBreakArray this_mod <- getCurrentModule let idOffSets = getVarOffSets d p fvs @@ -315,16 +320,23 @@ schemeER_wrk d p rhs BA arr# -> BRK_FUN arr# (fromIntegral tick_no) breakInfo return $ breakInstr `consOL` code - | otherwise = schemeE d 0 p rhs + | otherwise = schemeE (fromIntegral d) 0 p rhs -getVarOffSets :: Word16 -> BCEnv -> [Id] -> [(Id, Word16)] +getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)] getVarOffSets d p = catMaybes . map (getOffSet d p) -getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16) +getOffSet :: Word -> BCEnv -> Id -> Maybe (Id, Word16) getOffSet d env id = case lookupBCEnv_maybe id env of Nothing -> Nothing - Just offset -> Just (id, d - offset) + Just offset -> Just (id, trunc16 $ d - offset) + +trunc16 :: Word -> Word16 +trunc16 w + | w > fromIntegral (maxBound :: Word16) + = panic "stack depth overflow" + | otherwise + = fromIntegral w fvsToEnv :: BCEnv -> VarSet -> [Id] -- Takes the free variables of a right-hand side, and @@ -342,7 +354,7 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs, -- ----------------------------------------------------------------------------- -- schemeE -returnUnboxedAtom :: Word16 -> Sequel -> BCEnv +returnUnboxedAtom :: Word -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> CgRep -> BcM BCInstrList -- Returning an unlifted value. @@ -355,7 +367,7 @@ returnUnboxedAtom d s p e e_rep -- Compile code to apply the given expression to the remaining args -- on the stack, returning a HNF. -schemeE :: Word16 -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList +schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList schemeE d s p e | Just e' <- bcView e @@ -368,10 +380,8 @@ schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeCgRep (literal schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e VoidArg schemeE d s p e@(AnnVar v) - | isUnLiftedType v_type = returnUnboxedAtom d s p e (typeCgRep v_type) - | otherwise = schemeT d s p e - where - v_type = idType v + | isUnLiftedType (idType v) = returnUnboxedAtom d s p e (bcIdCgRep v) + | otherwise = schemeT d s p e schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) | (AnnVar v, args_r_to_l) <- splitApp rhs, @@ -404,7 +414,7 @@ schemeE d s p (AnnLet binds (_,body)) -- after the closures have been allocated in the heap (but not -- filled in), and pointers to them parked on the stack. p' = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p - d' = d + n_binds + d' = d + fromIntegral n_binds zipE = zipEqual "schemeE" -- ToDo: don't build thunks for things with no free variables @@ -415,7 +425,7 @@ schemeE d s p (AnnLet binds (_,body)) | otherwise = MKPAP build_thunk dd (fv:fvs) size bco off arity = do (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) - more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity + more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity return (push_code `appOL` more_push_code) alloc_code = toOL (zipWith mkAlloc sizes arities) @@ -475,8 +485,12 @@ schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs) -- ignore other kinds of tick schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs -schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)]) - | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) +schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut + -- no alts: scrut is guaranteed to diverge + +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) + | isUnboxedTupleCon dc + , UnaryRep rep_ty1 <- repType (idType bind1), UnaryRep rep_ty2 <- repType (idType bind2) -- Convert -- case .... of x { (# VoidArg'd-thing, a #) -> ... } -- to @@ -485,25 +499,47 @@ schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)]) -- -- Note that it does not matter losing the void-rep thing from the -- envt (it won't be bound now) because we never look such things up. - - = --trace "automagic mashing of case alts (# VoidArg, a #)" $ - doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} - - | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2) - = --trace "automagic mashing of case alts (# a, VoidArg #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} - -schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)]) - | isUnboxedTupleCon dc + , Just res <- case () of + _ | VoidRep <- typePrimRep rep_ty1 + -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + | VoidRep <- typePrimRep rep_ty2 + -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + | otherwise + -> Nothing + = res + +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) + | isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1) -- Similarly, convert -- case .... of x { (# a #) -> ... } -- to -- case .... of a { DEFAULT -> ... } = --trace "automagic mashing of case alts (# a #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + +schemeE d s p (AnnCase scrut bndr _ [(DEFAULT, [], rhs)]) + | Just (tc, tys) <- splitTyConApp_maybe (idType bndr) + , isUnboxedTupleTyCon tc + , Just res <- case tys of + [ty] | UnaryRep _ <- repType ty + , let bind = bndr `setIdType` ty + -> Just $ doCase d s p scrut bind [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + [ty1, ty2] | UnaryRep rep_ty1 <- repType ty1 + , UnaryRep rep_ty2 <- repType ty2 + -> case () of + _ | VoidRep <- typePrimRep rep_ty1 + , let bind2 = bndr `setIdType` ty2 + -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + | VoidRep <- typePrimRep rep_ty2 + , let bind1 = bndr `setIdType` ty1 + -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + | otherwise + -> Nothing + _ -> Nothing + = res schemeE d s p (AnnCase scrut bndr _ alts) - = doCase d s p scrut bndr alts False{-not an unboxed tuple-} + = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-} schemeE _ _ _ expr = pprPanic "ByteCodeGen.schemeE: unhandled case" @@ -542,7 +578,7 @@ schemeE _ _ _ expr -- 4. Otherwise, it must be a function call. Push the args -- right to left, SLIDE and ENTER. -schemeT :: Word16 -- Stack depth +schemeT :: Word -- Stack depth -> Sequel -- Sequel depth -> BCEnv -- stack env -> AnnExpr' Id VarSet @@ -561,7 +597,7 @@ schemeT d s p app = do (push, arg_words) <- pushAtom d p arg tagToId_sequence <- implement_tagToId constr_names return (push `appOL` tagToId_sequence - `appOL` mkSLIDE 1 (d+arg_words-s) + `appOL` mkSLIDE 1 (d - s + fromIntegral arg_words) `snocOL` ENTER) -- Case 1 @@ -593,7 +629,8 @@ schemeT d s p app -- Detect and extract relevant info for the tagToEnum kludge. maybe_is_tagToEnum_call = let extract_constr_Names ty - | Just tyc <- tyConAppTyCon_maybe (repType ty), + | UnaryRep rep_ty <- repType ty + , Just tyc <- tyConAppTyCon_maybe rep_ty, isDataTyCon tyc = map (getName . dataConWorkId) (tyConDataCons tyc) -- NOTE: use the worker name, not the source name of @@ -625,7 +662,7 @@ schemeT d s p app -- Generate code to build a constructor application, -- leaving it on top of the stack -mkConAppCode :: Word16 -> Sequel -> BCEnv +mkConAppCode :: Word -> Sequel -> BCEnv -> DataCon -- The data constructor -> [AnnExpr' Id VarSet] -- Args, in *reverse* order -> BcM BCInstrList @@ -646,12 +683,12 @@ mkConAppCode orig_d _ p con args_r_to_l do_pushery d (arg:args) = do (push, arg_words) <- pushAtom d p arg - more_push_code <- do_pushery (d+arg_words) args + more_push_code <- do_pushery (d + fromIntegral arg_words) args return (push `appOL` more_push_code) do_pushery d [] = return (unitOL (PACK con n_arg_words)) where - n_arg_words = d - orig_d + n_arg_words = trunc16 $ d - orig_d -- ----------------------------------------------------------------------------- @@ -662,19 +699,15 @@ mkConAppCode orig_d _ p con args_r_to_l -- returned, even if it is a pointed type. We always just return. unboxedTupleReturn - :: Word16 -> Sequel -> BCEnv + :: Word -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList -unboxedTupleReturn d s p arg = do - (push, sz) <- pushAtom d p arg - return (push `appOL` - mkSLIDE sz (d-s) `snocOL` - RETURN_UBX (atomRep arg)) +unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg) -- ----------------------------------------------------------------------------- -- Generate code for a tail-call doTailCall - :: Word16 -> Sequel -> BCEnv + :: Word -> Sequel -> BCEnv -> Id -> [AnnExpr' Id VarSet] -> BcM BCInstrList doTailCall init_d s p fn args @@ -685,7 +718,7 @@ doTailCall init_d s p fn args (push_fn, sz) <- pushAtom d p (AnnVar fn) ASSERT( sz == 1 ) return () return (push_fn `appOL` ( - mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL` + mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL` unitOL ENTER)) do_pushes d args reps = do let (push_apply, n, rest_of_reps) = findPushSeq reps @@ -698,7 +731,7 @@ doTailCall init_d s p fn args push_seq d [] = return (d, nilOL) push_seq d (arg:args) = do (push_code, sz) <- pushAtom d p arg - (final_d, more_push_code) <- push_seq (d+sz) args + (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args return (final_d, push_code `appOL` more_push_code) -- v. similar to CgStackery.findMatch, ToDo: merge @@ -731,20 +764,25 @@ findPushSeq _ -- ----------------------------------------------------------------------------- -- Case expressions -doCase :: Word16 -> Sequel -> BCEnv +doCase :: Word -> Sequel -> BCEnv -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet] - -> Bool -- True <=> is an unboxed tuple case, don't enter the result + -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result -> BcM BCInstrList doCase d s p (_,scrut) bndr alts is_unboxed_tuple + | UbxTupleRep _ <- repType (idType bndr) + = unboxedTupleException + | otherwise = let -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. -- When an alt is entered, it assumes the returned value is -- on top of the itbl. + ret_frame_sizeW :: Word ret_frame_sizeW = 2 -- An unlifted value gets an extra info table pushed on top -- when it is returned. + unlifted_itbl_sizeW :: Word unlifted_itbl_sizeW | isAlgCase = 0 | otherwise = 1 @@ -758,10 +796,14 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- Env in which to compile the alts, not including -- any vars bound by the alts themselves - p_alts = Map.insert bndr (d_bndr - 1) p + d_bndr' = fromIntegral d_bndr - 1 + p_alts0 = Map.insert bndr d_bndr' p + p_alts = case is_unboxed_tuple of + Just ubx_bndr -> Map.insert ubx_bndr d_bndr' p_alts0 + Nothing -> p_alts0 bndr_ty = idType bndr - isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple + isAlgCase = not (isUnLiftedType bndr_ty) && isNothing is_unboxed_tuple -- given an alt, return a discr and code for it. codeAlt (DEFAULT, _, (_,rhs)) @@ -773,6 +815,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | null real_bndrs = do rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) + | any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs + = unboxedTupleException -- algebraic alt with some binders | otherwise = let @@ -788,8 +832,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple p_alts in do MASSERT(isAlgCase) - rhs_code <- schemeE (d_alts+size) s p' rhs - return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code) + rhs_code <- schemeE (d_alts + size) s p' rhs + return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code) where real_bndrs = filterOut isTyVar bndrs @@ -828,18 +872,19 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- really want a bitmap up to depth (d-s). This affects compilation of -- case-of-case expressions, which is the only time we can be compiling a -- case expression with s /= 0. - bitmap_size = d-s + bitmap_size = trunc16 $ d-s bitmap_size' :: Int bitmap_size' = fromIntegral bitmap_size bitmap = intsToReverseBitmap bitmap_size'{-size-} - (sortLe (<=) (filter (< bitmap_size') rel_slots)) + (sort (filter (< bitmap_size') rel_slots)) where binds = Map.toList p - rel_slots = map fromIntegral $ concat (map spread binds) - spread (id, offset) - | isFollowableArg (idCgRep id) = [ rel_offset ] - | otherwise = [] - where rel_offset = d - offset - 1 + -- NB: unboxed tuple cases bind the scrut binder to the same offset + -- as one of the alt binders, so we have to remove any duplicates here: + rel_slots = nub $ map fromIntegral $ concat (map spread binds) + spread (id, offset) | isFollowableArg (bcIdCgRep id) = [ rel_offset ] + | otherwise = [] + where rel_offset = trunc16 $ d - fromIntegral offset - 1 in do alt_stuff <- mapM codeAlt alts @@ -849,10 +894,11 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple alt_bco_name = getName bndr alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts) 0{-no arity-} bitmap_size bitmap True{-is alts-} - -- in -- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ -- "\n bitmap = " ++ show bitmap) $ do - scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut + scrut_code <- schemeE (d + ret_frame_sizeW) + (d + ret_frame_sizeW) + p scrut alt_bco' <- emitBc alt_bco let push_alts | isAlgCase = PUSH_ALTS alt_bco' @@ -869,7 +915,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- (machine) code for the ccall, and create bytecodes to call that and -- then return in the right way. -generateCCall :: Word16 -> Sequel -- stack and sequel depths +generateCCall :: Word -> Sequel -- stack and sequel depths -> BCEnv -> CCallSpec -- where to call -> Id -- of target, for type info @@ -889,32 +935,32 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l pargs _ [] = return [] pargs d (a:az) - = let arg_ty = repType (exprType (deAnnotate' a)) + = let UnaryRep arg_ty = repType (exprType (deAnnotate' a)) in case tyConAppTyCon_maybe arg_ty of -- Don't push the FO; instead push the Addr# it -- contains. Just t | t == arrayPrimTyCon || t == mutableArrayPrimTyCon - -> do rest <- pargs (d + addr_sizeW) az + -> do rest <- pargs (d + fromIntegral addr_sizeW) az code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a return ((code,AddrRep):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon - -> do rest <- pargs (d + addr_sizeW) az + -> do rest <- pargs (d + fromIntegral addr_sizeW) az code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a return ((code,AddrRep):rest) -- Default case: push taggedly, but otherwise intact. _ -> do (code_a, sz_a) <- pushAtom d p a - rest <- pargs (d+sz_a) az + rest <- pargs (d + fromIntegral sz_a) az return ((code_a, atomPrimRep a) : rest) -- Do magic for Ptr/Byte arrays. Push a ptr to the array on -- the stack but then advance it over the headers, so as to -- point to the payload. - parg_ArrayishRep :: Word16 -> Word16 -> BCEnv -> AnnExpr' Id VarSet + parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList parg_ArrayishRep hdrSize d p a = do (push_fo, _) <- pushAtom d p a @@ -986,7 +1032,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l DynamicTarget -> return (False, panic "ByteCodeGen.generateCCall(dyn)") - StaticTarget target _ + StaticTarget _ _ False -> + panic "generateCCall: unexpected FFI value import" + StaticTarget target _ True -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target) return (True, res) where @@ -999,7 +1047,6 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l | otherwise = target - -- in (is_static, static_target_addr) <- get_target_info let @@ -1014,14 +1061,14 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l (push_Addr, d_after_Addr) | is_static = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW], - d_after_args + addr_sizeW) + d_after_args + fromIntegral addr_sizeW) | otherwise -- is already on the stack = (nilOL, d_after_args) -- Push the return placeholder. For a call returning nothing, -- this is a VoidArg (tag). r_sizeW = fromIntegral (primRepSizeW r_rep) - d_after_r = d_after_Addr + r_sizeW + d_after_r = d_after_Addr + fromIntegral r_sizeW r_lit = mkDummyLiteral r_rep push_r = (if returns_void then nilOL @@ -1033,9 +1080,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- instruction needs to describe the chunk of stack containing -- the ccall args to the GC, so it needs to know how large it -- is. See comment in Interpreter.c with the CCALL instruction. - stk_offset = d_after_r - s + stk_offset = trunc16 $ d_after_r - s - -- in -- the only difference in libffi mode is that we prepare a cif -- describing the call type by calling libffi, and we attach the -- address of this to the CCALL instruction. @@ -1048,9 +1094,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller) (fromIntegral (fromEnum (playInterruptible safety)))) -- slide and return - wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s) + wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s) `snocOL` RETURN_UBX (primRepToCgRep r_rep) - --in --trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $ return ( push_args `appOL` @@ -1091,13 +1136,11 @@ maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) maybe_r_rep_to_go = if isSingleton r_reps then Nothing else Just (r_reps !! 1) - (r_tycon, r_reps) - = case splitTyConApp_maybe (repType r_ty) of - (Just (tyc, tys)) -> (tyc, map typePrimRep tys) - Nothing -> blargh + r_reps = case repType r_ty of + UbxTupleRep reps -> map typePrimRep reps + UnaryRep _ -> blargh ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) || r_reps == [VoidRep] ) - && isUnboxedTupleTyCon r_tycon && case maybe_r_rep_to_go of Nothing -> True Just r_rep -> r_rep /= PtrRep @@ -1148,7 +1191,7 @@ implement_tagToId names -- to 5 and not to 4. Stack locations are numbered from zero, so a -- depth 6 stack has valid words 0 .. 5. -pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16) +pushAtom :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16) pushAtom d p e | Just e' <- bcView e @@ -1158,7 +1201,8 @@ pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, = return (nilOL, 0) -- treated just like a variable VoidArg pushAtom d p (AnnVar v) - | idCgRep v == VoidArg + | UnaryRep rep_ty <- repType (idType v) + , VoidArg <- typeCgRep rep_ty = return (nilOL, 0) | isFCallId v @@ -1168,7 +1212,7 @@ pushAtom d p (AnnVar v) = return (unitOL (PUSH_PRIMOP primop), 1) | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable - = let l = d - d_v + sz - 2 + = let l = trunc16 $ d - d_v + fromIntegral sz - 2 in return (toOL (genericReplicate sz (PUSH_L l)), sz) -- d - d_v the number of words between the TOS -- and the 1st slot of the object @@ -1262,7 +1306,7 @@ mkMultiBranch maybe_ncons raw_ways = do -- shouldn't happen? mkTree [val] range_lo range_hi - | range_lo `eqAlt` range_hi + | range_lo == range_hi = return (snd val) | null defaults -- Note [CASEFAIL] = do lbl <- getLabelBc @@ -1302,14 +1346,11 @@ mkMultiBranch maybe_ncons raw_ways = do [] -> nilOL [(_, def)] -> LABEL lbl_default `consOL` def _ -> panic "mkMultiBranch/the_default" - -- in instrs <- mkTree notd_ways init_lo init_hi return (instrs `appOL` the_default) where (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways - notd_ways = sortLe - (\w1 w2 -> leAlt (fst w1) (fst w2)) - not_defaults + notd_ways = sortBy (comparing fst) not_defaults testLT (DiscrI i) fail_label = TESTLT_I i fail_label testLT (DiscrW i) fail_label = TESTLT_W i fail_label @@ -1344,22 +1385,6 @@ mkMultiBranch maybe_ncons raw_ways = do Just n -> (0, fromIntegral n - 1) Nothing -> (minBound, maxBound) - (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2 - (DiscrW w1) `eqAlt` (DiscrW w2) = w1 == w2 - (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2 - (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2 - (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2 - NoDiscr `eqAlt` NoDiscr = True - _ `eqAlt` _ = False - - (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2 - (DiscrW w1) `leAlt` (DiscrW w2) = w1 <= w2 - (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2 - (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2 - (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2 - NoDiscr `leAlt` NoDiscr = True - _ `leAlt` _ = False - isNoDiscr NoDiscr = True isNoDiscr _ = False @@ -1389,6 +1414,7 @@ data Discr | DiscrD Double | DiscrP Word16 | NoDiscr + deriving (Eq, Ord) instance Outputable Discr where ppr (DiscrI i) = int i @@ -1399,11 +1425,26 @@ instance Outputable Discr where ppr NoDiscr = text "DEF" -lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word16 +lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word lookupBCEnv_maybe = Map.lookup idSizeW :: Id -> Int -idSizeW id = cgRepSizeW (typeCgRep (idType id)) +idSizeW = cgRepSizeW . bcIdCgRep + +bcIdCgRep :: Id -> CgRep +bcIdCgRep = primRepToCgRep . bcIdPrimRep + +bcIdPrimRep :: Id -> PrimRep +bcIdPrimRep = typePrimRep . bcIdUnaryType + +bcIdUnaryType :: Id -> UnaryType +bcIdUnaryType x = case repType (idType x) of + UnaryRep rep_ty -> rep_ty + UbxTupleRep [rep_ty] -> rep_ty + UbxTupleRep [rep_ty1, rep_ty2] + | VoidRep <- typePrimRep rep_ty1 -> rep_ty2 + | VoidRep <- typePrimRep rep_ty2 -> rep_ty1 + _ -> pprPanic "bcIdUnaryType" (ppr x $$ ppr (idType x)) -- See bug #1257 unboxedTupleException :: a @@ -1415,8 +1456,19 @@ unboxedTupleException " Workaround: use -fobject-code, or compile this module to .o separately.")) -mkSLIDE :: Word16 -> Word16 -> OrdList BCInstr -mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d) +mkSLIDE :: Word16 -> Word -> OrdList BCInstr +mkSLIDE n d + -- if the amount to slide doesn't fit in a word, + -- generate multiple slide instructions + | d > fromIntegral limit + = SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit) + | d == 0 + = nilOL + | otherwise + = if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d) + where + limit :: Word16 + limit = maxBound splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann]) -- The arguments are returned in *right-to-left* order @@ -1443,13 +1495,13 @@ bcView _ = Nothing isVoidArgAtom :: AnnExpr' Var ann -> Bool isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e' -isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep +isVoidArgAtom (AnnVar v) = bcIdCgRep v == VoidArg isVoidArgAtom (AnnCoercion {}) = True isVoidArgAtom _ = False atomPrimRep :: AnnExpr' Id ann -> PrimRep atomPrimRep e | Just e' <- bcView e = atomPrimRep e' -atomPrimRep (AnnVar v) = typePrimRep (idType v) +atomPrimRep (AnnVar v) = bcIdPrimRep v atomPrimRep (AnnLit l) = typePrimRep (literalType l) atomPrimRep (AnnCoercion {}) = VoidRep atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) @@ -1463,7 +1515,7 @@ isPtrAtom e = atomRep e == PtrArg -- Let szsw be the sizes in words of some items pushed onto the stack, -- which has initial depth d'. Return the values which the stack environment -- should map these items to. -mkStackOffsets :: Word16 -> [Word16] -> [Word16] +mkStackOffsets :: Word -> [Word] -> [Word] mkStackOffsets original_depth szsw = map (subtract 1) (tail (scanl (+) original_depth szsw)) diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 2dd1d11ea6..7378141e3d 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -6,8 +6,16 @@ ByteCodeItbls: Generate infotables for interpreter-made bytecodes \begin{code} {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} +#ifndef GHCI_TABLES_NEXT_TO_CODE +{-# OPTIONS_GHC -Wwarn #-} +-- There are lots of warnings when GHCI_TABLES_NEXT_TO_CODE is off. +-- It would be nice to fix this properly, but for now we turn -Werror +-- off. +#endif + module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls , StgInfoTable(..) + , State(..), runState, evalState, execState, MonadT(..) ) where #include "HsVersions.h" @@ -17,6 +25,7 @@ import NameEnv import ClosureInfo import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) +import Type ( flattenRepType, repType ) import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE ) import CgHeapery ( mkVirtHeapOffsets ) import Util @@ -24,6 +33,8 @@ import Util import Foreign import Foreign.C +import Control.Monad ( liftM ) + import GHC.Exts ( Int(I#), addr2Int# ) import GHC.Ptr ( Ptr(..) ) \end{code} @@ -88,7 +99,7 @@ make_constr_itbls cons mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr) mk_itbl dcon conNo entry_addr = do - let rep_args = [ (typeCgRep arg,arg) | arg <- dataConRepArgTys dcon ] + let rep_args = [ (typeCgRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ] (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args ptrs' = ptr_wds @@ -279,7 +290,7 @@ instance Storable StgConInfoTable where , sizeOf (infoTable conInfoTable) ] alignment _ = SIZEOF_VOID_P peek ptr - = runState (castPtr ptr) $ do + = evalState (castPtr ptr) $ do #ifdef GHCI_TABLES_NEXT_TO_CODE desc <- load #endif @@ -303,7 +314,7 @@ instance Storable StgConInfoTable where pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable -> IO () pokeConItbl wr_ptr ex_ptr itbl - = runState (castPtr wr_ptr) $ do + = evalState (castPtr wr_ptr) $ do #ifdef GHCI_TABLES_NEXT_TO_CODE store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB)) #endif @@ -346,7 +357,7 @@ instance Storable StgInfoTable where = SIZEOF_VOID_P poke a0 itbl - = runState (castPtr a0) + = evalState (castPtr a0) $ do #ifndef GHCI_TABLES_NEXT_TO_CODE store (entry itbl) @@ -360,7 +371,7 @@ instance Storable StgInfoTable where #endif peek a0 - = runState (castPtr a0) + = evalState (castPtr a0) $ do #ifndef GHCI_TABLES_NEXT_TO_CODE entry' <- load @@ -402,8 +413,14 @@ class (Monad m, Monad (t m)) => MonadT t m where instance Monad m => MonadT (State s) m where lift m = State (\s -> m >>= \a -> return (s, a)) -runState :: (Monad m) => s -> State s m a -> m a -runState s (State m) = m s >>= return . snd +runState :: Monad m => s -> State s m a -> m (s, a) +runState s (State m) = m s + +evalState :: Monad m => s -> State s m a -> m a +evalState s m = liftM snd (runState s m) + +execState :: Monad m => s -> State s m a -> m s +execState s m = liftM fst (runState s m) type PtrIO = State (Ptr Word8) IO diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 603accd189..0087eb2994 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -27,6 +27,7 @@ import Module import FastString import Panic import Outputable +import Util -- Standard libraries @@ -39,8 +40,6 @@ import GHC.Arr ( Array(..), STArray(..) ) import GHC.IO ( IO(..) ) import GHC.Exts import GHC.Ptr ( castPtr ) - -import Data.Word \end{code} @@ -109,18 +108,15 @@ linkBCO' ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS) let n_literals = sizeSS literalsSS n_ptrs = sizeSS ptrsSS - ptrs_arr <- if n_ptrs > 65535 - then panic "linkBCO: >= 64k ptrs" - else mkPtrsArray ie ce (fromIntegral n_ptrs) ptrs + ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs let !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr litRange - | n_literals > 65535 = panic "linkBCO: >= 64k literals" | n_literals > 0 = (0, fromIntegral n_literals - 1) | otherwise = (1, 0) - literals_arr :: UArray Word16 Word + literals_arr :: UArray Word Word literals_arr = listArray litRange linked_literals !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr @@ -130,7 +126,7 @@ linkBCO' ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS) -- we recursively link any sub-BCOs while making the ptrs array -mkPtrsArray :: ItblEnv -> ClosureEnv -> Word16 -> [BCOPtr] -> IO (Array Word16 HValue) +mkPtrsArray :: ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue) mkPtrsArray ie ce n_ptrs ptrs = do let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0) marr <- newArray_ ptrRange @@ -164,7 +160,7 @@ instance MArray IOArray e IO where unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e) -- XXX HACK: we should really have a new writeArray# primop that takes a BCO#. -writeArrayBCO :: IOArray Word16 a -> Int -> BCO# -> IO () +writeArrayBCO :: IOArray Word a -> Int -> BCO# -> IO () writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# -> case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# -> (# s#, () #) } diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index c8946d6367..20b7e13e7f 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -27,6 +27,7 @@ import GHC import Outputable import PprTyThing import MonadUtils +import DynFlags import Exception import Control.Monad @@ -34,7 +35,6 @@ import Data.List import Data.Maybe import Data.IORef -import System.IO import GHC.Exts ------------------------------------- @@ -58,7 +58,8 @@ pprintClosureCommand bindThings force str = do -- Finally, print the Terms unqual <- GHC.getPrintUnqual docterms <- mapM showTerm terms - liftIO $ (printForUser stdout unqual . vcat) + dflags <- getDynFlags + liftIO $ (printOutputForUser dflags unqual . vcat) (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) ids docterms) @@ -162,8 +163,8 @@ showTerm term = do -- XXX: this tries to disable logging of errors -- does this still do what it is intended to do -- with the changed error handling and logging? - let noop_log _ _ _ _ = return () - expr = "show " ++ showSDoc (ppr bname) + let noop_log _ _ _ _ _ = return () + expr = "show " ++ showPpr dflags bname _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} txt_ <- withExtendedLinkEnv [(bname, val)] (GHC.compileExpr expr) @@ -226,4 +227,4 @@ pprTypeAndContents id = do traceOptIf :: GhcMonad m => DynFlag -> SDoc -> m () traceOptIf flag doc = do dflags <- GHC.getSessionDynFlags - when (dopt flag dflags) $ liftIO $ printForUser stderr alwaysQualify doc + when (dopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index f357b97669..331c294973 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -3,6 +3,7 @@ module DebuggerUtils ( ) where import ByteCodeItbls +import DynFlags import FastString import TcRnTypes import TcRnMonad @@ -45,7 +46,8 @@ dataConInfoPtrToName x = do occFS = mkFastStringByteList occ occName = mkOccNameFS OccName.dataName occFS modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) - return (Left$ showSDoc$ ppr modName <> dot <> ppr occName ) + dflags <- getDynFlags + return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName) `recoverM` (Right `fmap` lookupOrig modName occName) where diff --git a/compiler/ghci/LibFFI.hsc b/compiler/ghci/LibFFI.hsc index d54307973e..9bdabda0c2 100644 --- a/compiler/ghci/LibFFI.hsc +++ b/compiler/ghci/LibFFI.hsc @@ -57,7 +57,7 @@ prepForeignCall cconv arg_types result_type convToABI :: CCallConv -> C_ffi_abi convToABI CCallConv = fFI_DEFAULT_ABI -#ifdef mingw32_HOST_OS +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) convToABI StdCallConv = fFI_STDCALL #endif -- unknown conventions are mapped to the default, (#3336) @@ -111,7 +111,7 @@ fFI_OK = (#const FFI_OK) fFI_DEFAULT_ABI :: C_ffi_abi fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI) -#ifdef mingw32_HOST_OS +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) fFI_STDCALL :: C_ffi_abi fFI_STDCALL = (#const FFI_STDCALL) #endif diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index f4ad61757f..06096c3579 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -8,25 +8,18 @@ -- calling the object-code linker and the byte-code linker where -- necessary. -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly module Linker ( HValue, getHValue, showLinkerState, - linkExpr, linkDecls, unload, withExtendedLinkEnv, + linkExpr, linkDecls, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, - extendLoadedPkgs, - linkPackages,initDynLinker,linkModule, + extendLoadedPkgs, + linkPackages,initDynLinker,linkModule, - -- Saving/restoring globals - PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals - ) where + -- Saving/restoring globals + PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals + ) where #include "HsVersions.h" @@ -71,7 +64,11 @@ import Control.Concurrent.MVar import System.FilePath import System.IO +#if __GLASGOW_HASKELL__ > 704 +import System.Directory hiding (findFile) +#else import System.Directory +#endif import Distribution.Package hiding (depends, PackageId) @@ -80,12 +77,12 @@ import Exception %************************************************************************ -%* * - The Linker's state -%* * +%* * + The Linker's state +%* * %************************************************************************ -The persistent linker state *must* match the actual state of the +The persistent linker state *must* match the actual state of the C dynamic linker at all times, so we keep it in a private global variable. The global IORef used for PersistentLinkerState actually contains another MVar. @@ -97,7 +94,7 @@ interpreted code only), for use during linking. \begin{code} GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState) -GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised +GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO () modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f @@ -108,37 +105,37 @@ modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f data PersistentLinkerState = PersistentLinkerState { - -- Current global mapping from Names to their true values + -- Current global mapping from Names to their true values closure_env :: ClosureEnv, - -- The current global mapping from RdrNames of DataCons to - -- info table addresses. - -- When a new Unlinked is linked into the running image, or an existing - -- module in the image is replaced, the itbl_env must be updated - -- appropriately. + -- The current global mapping from RdrNames of DataCons to + -- info table addresses. + -- When a new Unlinked is linked into the running image, or an existing + -- module in the image is replaced, the itbl_env must be updated + -- appropriately. itbl_env :: !ItblEnv, - -- The currently loaded interpreted modules (home package) - bcos_loaded :: ![Linkable], + -- The currently loaded interpreted modules (home package) + bcos_loaded :: ![Linkable], - -- And the currently-loaded compiled modules (home package) - objs_loaded :: ![Linkable], + -- And the currently-loaded compiled modules (home package) + objs_loaded :: ![Linkable], - -- The currently-loaded packages; always object code - -- Held, as usual, in dependency order; though I am not sure if - -- that is really important - pkgs_loaded :: ![PackageId] + -- The currently-loaded packages; always object code + -- Held, as usual, in dependency order; though I am not sure if + -- that is really important + pkgs_loaded :: ![PackageId] } emptyPLS :: DynFlags -> PersistentLinkerState -emptyPLS _ = PersistentLinkerState { - closure_env = emptyNameEnv, - itbl_env = emptyNameEnv, - pkgs_loaded = init_pkgs, - bcos_loaded = [], - objs_loaded = [] } - - -- Packages that don't need loading, because the compiler +emptyPLS _ = PersistentLinkerState { + closure_env = emptyNameEnv, + itbl_env = emptyNameEnv, + pkgs_loaded = init_pkgs, + bcos_loaded = [], + objs_loaded = [] } + + -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. -- -- The linker's symbol table is populated with RTS symbols using an @@ -180,7 +177,7 @@ getHValue hsc_env name = do else return (pls, pls) lookupName (closure_env pls) name - + linkDependencies :: HscEnv -> PersistentLinkerState -> SrcSpan -> [Module] -> IO (PersistentLinkerState, SuccessFlag) @@ -188,17 +185,17 @@ linkDependencies hsc_env pls span needed_mods = do -- initDynLinker (hsc_dflags hsc_env) let hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env - -- The interpreter and dynamic linker can only handle object code built - -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. - -- So here we check the build tag: if we're building a non-standard way - -- then we need to find & link object files built the "normal" way. + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. maybe_normal_osuf <- checkNonStdWay dflags span - -- Find what packages and linkables are required + -- Find what packages and linkables are required (lnks, pkgs) <- getLinkDeps hsc_env hpt pls - maybe_normal_osuf span needed_mods + maybe_normal_osuf span needed_mods - -- Link the packages and modules required + -- Link the packages and modules required pls1 <- linkPackages' dflags pkgs pls linkModules dflags pls1 lnks @@ -223,35 +220,36 @@ withExtendedLinkEnv new_env action new = delListFromNameEnv cur (map fst new_env) in return pls{ closure_env = new } --- filterNameMap removes from the environment all entries except --- those for a given set of modules; --- Note that this removes all *local* (i.e. non-isExternal) names too --- (these are the temporary bindings from the command line). +-- filterNameMap removes from the environment all entries except +-- those for a given set of modules; +-- Note that this removes all *local* (i.e. non-isExternal) names too +-- (these are the temporary bindings from the command line). -- Used to filter both the ClosureEnv and ItblEnv filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a) -filterNameMap mods env +filterNameMap mods env = filterNameEnv keep_elt env where - keep_elt (n,_) = isExternalName n - && (nameModule n `elem` mods) + keep_elt (n,_) = isExternalName n + && (nameModule n `elem` mods) -- | Display the persistent linker state. -showLinkerState :: IO () -showLinkerState - = do pls <- readIORef v_PersistentLinkerState >>= readMVar - printDump (vcat [text "----- Linker state -----", - text "Pkgs:" <+> ppr (pkgs_loaded pls), - text "Objs:" <+> ppr (objs_loaded pls), - text "BCOs:" <+> ppr (bcos_loaded pls)]) +showLinkerState :: DynFlags -> IO () +showLinkerState dflags + = do pls <- readIORef v_PersistentLinkerState >>= readMVar + log_action dflags dflags SevDump noSrcSpan defaultDumpStyle + (vcat [text "----- Linker state -----", + text "Pkgs:" <+> ppr (pkgs_loaded pls), + text "Objs:" <+> ppr (objs_loaded pls), + text "BCOs:" <+> ppr (bcos_loaded pls)]) \end{code} %************************************************************************ -%* * +%* * \subsection{Initialisation} -%* * +%* * %************************************************************************ \begin{code} @@ -284,56 +282,83 @@ initDynLinker dflags = reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState reallyInitDynLinker dflags = do { -- Initialise the linker state - let pls0 = emptyPLS dflags + let pls0 = emptyPLS dflags - -- (a) initialise the C dynamic linker - ; initObjLinker + -- (a) initialise the C dynamic linker + ; initObjLinker - -- (b) Load packages from the command-line - ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0 + -- (b) Load packages from the command-line (Note [preload packages]) + ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0 - -- (c) Link libraries from the command-line - ; let optl = getOpts dflags opt_l - ; let minus_ls = [ lib | '-':'l':lib <- optl ] + -- (c) Link libraries from the command-line + ; let optl = getOpts dflags opt_l + ; let minus_ls = [ lib | '-':'l':lib <- optl ] ; let lib_paths = libraryPaths dflags ; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls - -- (d) Link .o files from the command-line + -- (d) Link .o files from the command-line ; cmdline_ld_inputs <- readIORef v_Ld_inputs - ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs + ; classified_ld_inputs <- mapM (classifyLdInput dflags) cmdline_ld_inputs - -- (e) Link any MacOS frameworks - ; let framework_paths + -- (e) Link any MacOS frameworks + ; let framework_paths | isDarwinTarget = frameworkPaths dflags | otherwise = [] - ; let frameworks + ; let frameworks | isDarwinTarget = cmdlineFrameworks dflags | otherwise = [] - -- Finally do (c),(d),(e) + -- Finally do (c),(d),(e) ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ] ++ libspecs - ++ map Framework frameworks - ; if null cmdline_lib_specs then return pls - else do + ++ map Framework frameworks + ; if null cmdline_lib_specs then return pls + else do - { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs - ; maybePutStr dflags "final link ... " - ; ok <- resolveObjs + { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs + ; maybePutStr dflags "final link ... " + ; ok <- resolveObjs - ; if succeeded ok then maybePutStrLn dflags "done" - else ghcError (ProgramError "linking extra libraries/objects failed") + ; if succeeded ok then maybePutStrLn dflags "done" + else ghcError (ProgramError "linking extra libraries/objects failed") ; return pls - }} + }} + + +{- Note [preload packages] + +Why do we need to preload packages from the command line? This is an +explanation copied from #2437: + +I tried to implement the suggestion from #3560, thinking it would be +easy, but there are two reasons we link in packages eagerly when they +are mentioned on the command line: + + * So that you can link in extra object files or libraries that + depend on the packages. e.g. ghc -package foo -lbar where bar is a + C library that depends on something in foo. So we could link in + foo eagerly if and only if there are extra C libs or objects to + link in, but.... -classifyLdInput :: FilePath -> IO (Maybe LibrarySpec) -classifyLdInput f + * Haskell code can depend on a C function exported by a package, and + the normal dependency tracking that TH uses can't know about these + dependencies. The test ghcilink004 relies on this, for example. + +I conclude that we need two -package flags: one that says "this is a +package I want to make available", and one that says "this is a +package I want to link in eagerly". Would that be too complicated for +users? +-} + +classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) +classifyLdInput dflags f | isObjectFilename f = return (Just (Object f)) | isDynLibFilename f = return (Just (DLLPath f)) - | otherwise = do - hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'") - return Nothing + | otherwise = do + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle + (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) + return Nothing preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO () preloadLib dflags lib_paths framework_paths lib_spec @@ -355,13 +380,13 @@ preloadLib dflags lib_paths framework_paths lib_spec Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec - DLLPath dll_path - -> do maybe_errstr <- loadDLL dll_path + DLLPath dll_path + -> do maybe_errstr <- loadDLL dll_path case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec - Framework framework + Framework framework | isDarwinTarget -> do maybe_errstr <- loadFramework framework_paths framework case maybe_errstr of @@ -374,13 +399,13 @@ preloadLib dflags lib_paths framework_paths lib_spec preloadFailed sys_errmsg paths spec = do maybePutStr dflags "failed.\n" ghcError $ - CmdLineError ( + CmdLineError ( "user specified .o/.so/.DLL could not be loaded (" ++ sys_errmsg ++ ")\nWhilst trying to load: " ++ showLS spec ++ "\nAdditional directories searched:" ++ (if null paths then " (none)" else (concat (intersperse "\n" (map (" "++) paths))))) - + -- Not interested in the paths in the static case. preload_static _paths name = do b <- doesFileExist name @@ -394,9 +419,9 @@ preloadLib dflags lib_paths framework_paths lib_spec %************************************************************************ -%* * - Link a byte-code expression -%* * +%* * + Link a byte-code expression +%* * %************************************************************************ \begin{code} @@ -408,25 +433,25 @@ preloadLib dflags lib_paths framework_paths lib_spec -- linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue linkExpr hsc_env span root_ul_bco - = do { - -- Initialise the linker (if it's not been done already) + = do { + -- Initialise the linker (if it's not been done already) let dflags = hsc_dflags hsc_env ; initDynLinker dflags - -- Take lock for the actual work. + -- Take lock for the actual work. ; modifyPLS $ \pls0 -> do { - -- Link the packages and modules required + -- Link the packages and modules required ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods ; if failed ok then - ghcError (ProgramError "") + ghcError (ProgramError "") else do { - -- Link the expression itself + -- Link the expression itself let ie = itbl_env pls - ce = closure_env pls + ce = closure_env pls - -- Link the necessary packages and linkables + -- Link the necessary packages and linkables ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco] ; return (pls, root_hval) }}} @@ -434,17 +459,17 @@ linkExpr hsc_env span root_ul_bco free_names = nameSetToList (bcoFreeNames root_ul_bco) needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, + needed_mods = [ nameModule n | n <- free_names, isExternalName n, -- Names from other modules not (isWiredInName n) -- Exclude wired-in names ] -- (see note below) - -- Exclude wired-in names because we may not have read - -- their interface files, so getLinkDeps will fail - -- All wired-in names are in the base package, which we link - -- by default, so we can safely ignore them here. - -dieWith :: SrcSpan -> MsgDoc -> IO a -dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage SevFatal span msg))) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + +dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a +dieWith dflags span msg = ghcError (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) checkNonStdWay :: DynFlags -> SrcSpan -> IO Bool @@ -461,52 +486,52 @@ checkNonStdWay dflags srcspan = do -- because the dynamic objects contain refs to e.g. __stginit_base_Prelude_dyn -- whereas we have __stginit_base_Prelude_. if (objectSuf dflags == normalObjectSuffix) - then failNonStd srcspan + then failNonStd dflags srcspan else return True normalObjectSuffix :: String normalObjectSuffix = phaseInputExt StopLn -failNonStd :: SrcSpan -> IO Bool -failNonStd srcspan = dieWith srcspan $ +failNonStd :: DynFlags -> SrcSpan -> IO Bool +failNonStd dflags srcspan = dieWith dflags srcspan $ ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$ ptext (sLit "You need to build the program twice: once the normal way, and then") $$ ptext (sLit "in the desired way using -osuf to set the object file suffix.") - + getLinkDeps :: HscEnv -> HomePackageTable -> PersistentLinkerState -> Bool -- replace object suffices? - -> SrcSpan -- for error messages - -> [Module] -- If you need these - -> IO ([Linkable], [PackageId]) -- ... then link these first + -> SrcSpan -- for error messages + -> [Module] -- If you need these + -> IO ([Linkable], [PackageId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files getLinkDeps hsc_env hpt pls replace_osuf span mods -- Find all the packages and linkables that a set of modules depends on = do { - -- 1. Find the dependent home-pkg-modules/packages from each iface + -- 1. Find the dependent home-pkg-modules/packages from each iface -- (omitting iINTERACTIVE, which is already linked) (mods_s, pkgs_s) <- follow_deps (filter ((/=) iNTERACTIVE) mods) emptyUniqSet emptyUniqSet; - let { - -- 2. Exclude ones already linked - -- Main reason: avoid findModule calls in get_linkable - mods_needed = mods_s `minusList` linked_mods ; - pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; + let { + -- 2. Exclude ones already linked + -- Main reason: avoid findModule calls in get_linkable + mods_needed = mods_s `minusList` linked_mods ; + pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; - linked_mods = map (moduleName.linkableModule) + linked_mods = map (moduleName.linkableModule) (objs_loaded pls ++ bcos_loaded pls) - } ; - - -- 3. For each dependent module, find its linkable - -- This will either be in the HPT or (in the case of one-shot - -- compilation) we may need to use maybe_getFileLinkable + } ; + + -- 3. For each dependent module, find its linkable + -- This will either be in the HPT or (in the case of one-shot + -- compilation) we may need to use maybe_getFileLinkable let { osuf = objectSuf dflags } ; lnks_needed <- mapM (get_linkable osuf replace_osuf) mods_needed ; - return (lnks_needed, pkgs_needed) } + return (lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env this_pkg = thisPackage dflags @@ -527,8 +552,8 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods mb_iface <- initIfaceCheck hsc_env $ loadInterface msg mod (ImportByUser False) iface <- case mb_iface of - Maybes.Failed err -> ghcError (ProgramError (showSDoc err)) - Maybes.Succeeded iface -> return iface + Maybes.Failed err -> ghcError (ProgramError (showSDoc dflags err)) + Maybes.Succeeded iface -> return iface when (mi_boot iface) $ link_boot_mod_error mod @@ -554,44 +579,44 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods text "due to use of Template Haskell" - link_boot_mod_error mod = - ghcError (ProgramError (showSDoc ( - text "module" <+> ppr mod <+> + link_boot_mod_error mod = + ghcError (ProgramError (showSDoc dflags ( + text "module" <+> ppr mod <+> text "cannot be linked; it is only available as a boot module"))) no_obj :: Outputable a => a -> IO b - no_obj mod = dieWith span $ - ptext (sLit "cannot find object file for module ") <> - quotes (ppr mod) $$ - while_linking_expr - + no_obj mod = dieWith dflags span $ + ptext (sLit "cannot find object file for module ") <> + quotes (ppr mod) $$ + while_linking_expr + while_linking_expr = ptext (sLit "while linking an interpreted expression") - -- This one is a build-system bug + -- This one is a build-system bug get_linkable osuf replace_osuf mod_name -- A home-package module - | Just mod_info <- lookupUFM hpt mod_name - = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) - | otherwise - = do -- It's not in the HPT because we are in one shot mode, - -- so use the Finder to get a ModLocation... - mb_stuff <- findHomeModule hsc_env mod_name - case mb_stuff of - Found loc mod -> found loc mod - _ -> no_obj mod_name + | Just mod_info <- lookupUFM hpt mod_name + = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) + | otherwise + = do -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + mb_stuff <- findHomeModule hsc_env mod_name + case mb_stuff of + Found loc mod -> found loc mod + _ -> no_obj mod_name where found loc mod = do { - -- ...and then find the linkable for it - mb_lnk <- findObjectLinkableMaybe mod loc ; - case mb_lnk of { - Nothing -> no_obj mod ; - Just lnk -> adjust_linkable lnk - }} + -- ...and then find the linkable for it + mb_lnk <- findObjectLinkableMaybe mod loc ; + case mb_lnk of { + Nothing -> no_obj mod ; + Just lnk -> adjust_linkable lnk + }} adjust_linkable lnk | replace_osuf = do new_uls <- mapM adjust_ul (linkableUnlinked lnk) - return lnk{ linkableUnlinked=new_uls } + return lnk{ linkableUnlinked=new_uls } | otherwise = return lnk @@ -600,19 +625,19 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods let new_file = reverse (drop (length osuf + 1) (reverse file)) <.> normalObjectSuffix ok <- doesFileExist new_file - if (not ok) - then dieWith span $ - ptext (sLit "cannot find normal object file ") - <> quotes (text new_file) $$ while_linking_expr - else return (DotO new_file) + if (not ok) + then dieWith dflags span $ + ptext (sLit "cannot find normal object file ") + <> quotes (text new_file) $$ while_linking_expr + else return (DotO new_file) adjust_ul _ = panic "adjust_ul" \end{code} %************************************************************************ -%* * +%* * Loading a Decls statement -%* * +%* * %************************************************************************ \begin{code} linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () --[HValue] @@ -643,7 +668,7 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do free_names = concatMap (nameSetToList . bcoFreeNames) unlinkedBCOs needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, + needed_mods = [ nameModule n | n <- free_names, isExternalName n, -- Names from other modules not (isWiredInName n) -- Exclude wired-in names ] -- (see note below) @@ -656,9 +681,9 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do %************************************************************************ -%* * +%* * Loading a single module -%* * +%* * %************************************************************************ \begin{code} @@ -672,11 +697,11 @@ linkModule hsc_env mod = do \end{code} %************************************************************************ -%* * - Link some linkables - The linkables may consist of a mixture of - byte-code modules and object modules -%* * +%* * + Link some linkables + The linkables may consist of a mixture of + byte-code modules and object modules +%* * %************************************************************************ \begin{code} @@ -684,19 +709,19 @@ linkModules :: DynFlags -> PersistentLinkerState -> [Linkable] -> IO (PersistentLinkerState, SuccessFlag) linkModules dflags pls linkables = mask_ $ do -- don't want to be interrupted by ^C in here - - let (objs, bcos) = partition isObjectLinkable + + let (objs, bcos) = partition isObjectLinkable (concatMap partitionLinkable linkables) - -- Load objects first; they can't depend on BCOs - (pls1, ok_flag) <- dynLinkObjs dflags pls objs + -- Load objects first; they can't depend on BCOs + (pls1, ok_flag) <- dynLinkObjs dflags pls objs + + if failed ok_flag then + return (pls1, Failed) + else do + pls2 <- dynLinkBCOs pls1 bcos + return (pls2, Succeeded) - if failed ok_flag then - return (pls1, Failed) - else do - pls2 <- dynLinkBCOs pls1 bcos - return (pls2, Succeeded) - -- HACK to support f-x-dynamic in the interpreter; no other purpose partitionLinkable :: Linkable -> [Linkable] @@ -704,7 +729,7 @@ partitionLinkable li = let li_uls = linkableUnlinked li li_uls_obj = filter isObject li_uls li_uls_bco = filter isInterpretable li_uls - in + in case (li_uls_obj, li_uls_bco) of (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj}, li {linkableUnlinked=li_uls_bco}] @@ -720,118 +745,118 @@ findModuleLinkable_maybe lis mod linkableInSet :: Linkable -> [Linkable] -> Bool linkableInSet l objs_loaded = case findModuleLinkable_maybe objs_loaded (linkableModule l) of - Nothing -> False - Just m -> linkableTime l == linkableTime m + Nothing -> False + Just m -> linkableTime l == linkableTime m \end{code} %************************************************************************ -%* * +%* * \subsection{The object-code linker} -%* * +%* * %************************************************************************ \begin{code} dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable] -> IO (PersistentLinkerState, SuccessFlag) dynLinkObjs dflags pls objs = do - -- Load the object files and link them - let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs - pls1 = pls { objs_loaded = objs_loaded' } - unlinkeds = concatMap linkableUnlinked new_objs - - mapM_ loadObj (map nameOfObject unlinkeds) - - -- Link the all together - ok <- resolveObjs - - -- If resolving failed, unload all our - -- object modules and carry on - if succeeded ok then do - return (pls1, Succeeded) - else do - pls2 <- unload_wkr dflags [] pls1 + -- Load the object files and link them + let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs + pls1 = pls { objs_loaded = objs_loaded' } + unlinkeds = concatMap linkableUnlinked new_objs + + mapM_ loadObj (map nameOfObject unlinkeds) + + -- Link the all together + ok <- resolveObjs + + -- If resolving failed, unload all our + -- object modules and carry on + if succeeded ok then do + return (pls1, Succeeded) + else do + pls2 <- unload_wkr dflags [] pls1 return (pls2, Failed) -rmDupLinkables :: [Linkable] -- Already loaded - -> [Linkable] -- New linkables - -> ([Linkable], -- New loaded set (including new ones) - [Linkable]) -- New linkables (excluding dups) +rmDupLinkables :: [Linkable] -- Already loaded + -> [Linkable] -- New linkables + -> ([Linkable], -- New loaded set (including new ones) + [Linkable]) -- New linkables (excluding dups) rmDupLinkables already ls = go already [] ls where go already extras [] = (already, extras) go already extras (l:ls) - | linkableInSet l already = go already extras ls - | otherwise = go (l:already) (l:extras) ls + | linkableInSet l already = go already extras ls + | otherwise = go (l:already) (l:extras) ls \end{code} %************************************************************************ -%* * +%* * \subsection{The byte-code linker} -%* * +%* * %************************************************************************ \begin{code} dynLinkBCOs :: PersistentLinkerState -> [Linkable] -> IO PersistentLinkerState dynLinkBCOs pls bcos = do - let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos - pls1 = pls { bcos_loaded = bcos_loaded' } - unlinkeds :: [Unlinked] - unlinkeds = concatMap linkableUnlinked new_bcos - - cbcs :: [CompiledByteCode] - cbcs = map byteCodeOfObject unlinkeds - - - ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs] - ies = [ie | ByteCode _ ie <- cbcs] - gce = closure_env pls + let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos + pls1 = pls { bcos_loaded = bcos_loaded' } + unlinkeds :: [Unlinked] + unlinkeds = concatMap linkableUnlinked new_bcos + + cbcs :: [CompiledByteCode] + cbcs = map byteCodeOfObject unlinkeds + + + ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs] + ies = [ie | ByteCode _ ie <- cbcs] + gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos - -- XXX What happens to these linked_bcos? + -- XXX What happens to these linked_bcos? - let pls2 = pls1 { closure_env = final_gce, - itbl_env = final_ie } + let pls2 = pls1 { closure_env = final_gce, + itbl_env = final_ie } - return pls2 + return pls2 -- Link a bunch of BCOs and return them + updated closure env. -linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env +linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env -- True <=> add only toplevel BCOs to closure env - -> ItblEnv - -> ClosureEnv + -> ItblEnv + -> ClosureEnv -> [UnlinkedBCO] -> IO (ClosureEnv, [HValue]) - -- The returned HValues are associated 1-1 with - -- the incoming unlinked BCOs. Each gives the - -- value of the corresponding unlinked BCO - + -- The returned HValues are associated 1-1 with + -- the incoming unlinked BCOs. Each gives the + -- value of the corresponding unlinked BCO + linkSomeBCOs toplevs_only ie ce_in ul_bcos = do let nms = map unlinkedBCOName ul_bcos - hvals <- fixIO + hvals <- fixIO ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs) in mapM (linkBCO ie ce_out) ul_bcos ) let ce_all_additions = zip nms hvals ce_top_additions = filter (isExternalName.fst) ce_all_additions - ce_additions = if toplevs_only then ce_top_additions + ce_additions = if toplevs_only then ce_top_additions else ce_all_additions - ce_out = -- make sure we're not inserting duplicate names into the - -- closure environment, which leads to trouble. - ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) - extendClosureEnv ce_in ce_additions + ce_out = -- make sure we're not inserting duplicate names into the + -- closure environment, which leads to trouble. + ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) + extendClosureEnv ce_in ce_additions return (ce_out, hvals) \end{code} %************************************************************************ -%* * - Unload some object modules -%* * +%* * + Unload some object modules +%* * %************************************************************************ \begin{code} @@ -854,92 +879,92 @@ unload :: DynFlags -> IO () unload dflags linkables = mask_ $ do -- mask, so we're safe from Ctrl-C in here - - -- Initialise the linker (if it's not been done already) - initDynLinker dflags - new_pls + -- Initialise the linker (if it's not been done already) + initDynLinker dflags + + new_pls <- modifyPLS $ \pls -> do - pls1 <- unload_wkr dflags linkables pls + pls1 <- unload_wkr dflags linkables pls return (pls1, pls1) - debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls)) - debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)) - return () + debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls)) + debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)) + return () unload_wkr :: DynFlags - -> [Linkable] -- stable linkables - -> PersistentLinkerState + -> [Linkable] -- stable linkables + -> PersistentLinkerState -> IO PersistentLinkerState -- Does the core unload business -- (the wrapper blocks exceptions and deals with the PLS get and put) unload_wkr _ linkables pls - = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables + = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables - objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) + objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls) - let bcos_retained = map linkableModule bcos_loaded' - itbl_env' = filterNameMap bcos_retained (itbl_env pls) + let bcos_retained = map linkableModule bcos_loaded' + itbl_env' = filterNameMap bcos_retained (itbl_env pls) closure_env' = filterNameMap bcos_retained (closure_env pls) - new_pls = pls { itbl_env = itbl_env', - closure_env = closure_env', - bcos_loaded = bcos_loaded', - objs_loaded = objs_loaded' } + new_pls = pls { itbl_env = itbl_env', + closure_env = closure_env', + bcos_loaded = bcos_loaded', + objs_loaded = objs_loaded' } - return new_pls + return new_pls where maybeUnload :: [Linkable] -> Linkable -> IO Bool maybeUnload keep_linkables lnk | linkableInSet lnk keep_linkables = return True - | otherwise + | otherwise = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk] - -- The components of a BCO linkable may contain - -- dot-o files. Which is very confusing. - -- - -- But the BCO parts can be unlinked just by - -- letting go of them (plus of course depopulating - -- the symbol table which is done in the main body) - return False + -- The components of a BCO linkable may contain + -- dot-o files. Which is very confusing. + -- + -- But the BCO parts can be unlinked just by + -- letting go of them (plus of course depopulating + -- the symbol table which is done in the main body) + return False \end{code} %************************************************************************ -%* * - Loading packages -%* * +%* * + Loading packages +%* * %************************************************************************ \begin{code} -data LibrarySpec - = Object FilePath -- Full path name of a .o file, including trailing .o - -- For dynamic objects only, try to find the object - -- file in all the directories specified in - -- v_Library_paths before giving up. +data LibrarySpec + = Object FilePath -- Full path name of a .o file, including trailing .o + -- For dynamic objects only, try to find the object + -- file in all the directories specified in + -- v_Library_paths before giving up. - | Archive FilePath -- Full path name of a .a file, including trailing .a + | Archive FilePath -- Full path name of a .a file, including trailing .a - | DLL String -- "Unadorned" name of a .DLL/.so - -- e.g. On unix "qt" denotes "libqt.so" - -- On WinDoze "burble" denotes "burble.DLL" - -- loadDLL is platform-specific and adds the lib/.so/.DLL - -- suffixes platform-dependently + | DLL String -- "Unadorned" name of a .DLL/.so + -- e.g. On unix "qt" denotes "libqt.so" + -- On WinDoze "burble" denotes "burble.DLL" + -- loadDLL is platform-specific and adds the lib/.so/.DLL + -- suffixes platform-dependently | DLLPath FilePath -- Absolute or relative pathname to a dynamic library - -- (ends with .dll or .so). + -- (ends with .dll or .so). - | Framework String -- Only used for darwin, but does no harm + | Framework String -- Only used for darwin, but does no harm -- If this package is already part of the GHCi binary, we'll already -- have the right DLLs for this package loaded, so don't try to -- load them again. --- +-- -- But on Win32 we must load them 'again'; doing so is a harmless no-op -- as far as the loader is concerned, but it does initialise the list --- of DLL handles that rts/Linker.c maintains, and that in turn is --- used by lookupSymbol. So we must call addDLL for each library +-- of DLL handles that rts/Linker.c maintains, and that in turn is +-- used by lookupSymbol. So we must call addDLL for each library -- just to get the DLL handle into the list. partOfGHCi :: [PackageName] partOfGHCi @@ -964,7 +989,7 @@ linkPackages :: DynFlags -> [PackageId] -> IO () -- we don't really need to use the package-config dependencies. -- -- However we do need the package-config stuff (to find aux libs etc), --- and following them lets us load libraries in the right order, which +-- and following them lets us load libraries in the right order, which -- perhaps makes the error message a bit more localised if we get a link -- failure. So the dependency walking code is still here. @@ -989,25 +1014,25 @@ linkPackages' dflags new_pks pls = do foldM link_one pkgs new_pkgs link_one pkgs new_pkg - | new_pkg `elem` pkgs -- Already linked - = return pkgs + | new_pkg `elem` pkgs -- Already linked + = return pkgs - | Just pkg_cfg <- lookupPackage pkg_map new_pkg - = do { -- Link dependents first + | Just pkg_cfg <- lookupPackage pkg_map new_pkg + = do { -- Link dependents first pkgs' <- link pkgs [ Maybes.expectJust "link_one" $ Map.lookup ipid ipid_map | ipid <- depends pkg_cfg ] - -- Now link the package itself - ; linkPackage dflags pkg_cfg - ; return (new_pkg : pkgs') } + -- Now link the package itself + ; linkPackage dflags pkg_cfg + ; return (new_pkg : pkgs') } - | otherwise - = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) + | otherwise + = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) linkPackage :: DynFlags -> PackageConfig -> IO () linkPackage dflags pkg - = do + = do let dirs = Packages.libraryDirs pkg let hs_libs = Packages.hsLibraries pkg @@ -1035,29 +1060,29 @@ linkPackage dflags pkg extra_classifieds <- mapM (locateLib dflags False dirs) extra_libs let classifieds = hs_classifieds ++ extra_classifieds - -- Complication: all the .so's must be loaded before any of the .o's. + -- Complication: all the .so's must be loaded before any of the .o's. let known_dlls = [ dll | DLLPath dll <- classifieds ] dlls = [ dll | DLL dll <- classifieds ] objs = [ obj | Object obj <- classifieds ] archs = [ arch | Archive arch <- classifieds ] - maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ") + maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ") - -- See comments with partOfGHCi - when (packageName pkg `notElem` partOfGHCi) $ do - loadFrameworks pkg + -- See comments with partOfGHCi + when (packageName pkg `notElem` partOfGHCi) $ do + loadFrameworks pkg mapM_ load_dyn (known_dlls ++ map mkSOName dlls) - -- After loading all the DLLs, we can load the static objects. - -- Ordering isn't important here, because we do one final link - -- step to resolve everything. - mapM_ loadObj objs - mapM_ loadArchive archs + -- After loading all the DLLs, we can load the static objects. + -- Ordering isn't important here, because we do one final link + -- step to resolve everything. + mapM_ loadObj objs + mapM_ loadArchive archs maybePutStr dflags "linking ... " ok <- resolveObjs - if succeeded ok then maybePutStrLn dflags "done." - else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'")) + if succeeded ok then maybePutStrLn dflags "done." + else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'")) -- we have already searched the filesystem; the strings passed to load_dyn -- can be passed directly to loadDLL. They are either fully-qualified @@ -1080,10 +1105,10 @@ loadFrameworks pkg frameworks = Packages.frameworks pkg load fw = do r <- loadFramework fw_dirs fw - case r of - Nothing -> return () - Just err -> ghcError (CmdLineError ("can't load framework: " - ++ fw ++ " (" ++ err ++ ")" )) + case r of + Nothing -> return () + Just err -> ghcError (CmdLineError ("can't load framework: " + ++ fw ++ " (" ++ err ++ ")" )) -- Try to find an object file for a given library in the given paths. -- If it isn't present, we assume that addDLL in the RTS can find it, @@ -1178,40 +1203,40 @@ loadFramework extraPaths rootname \end{code} %************************************************************************ -%* * - Helper functions -%* * +%* * + Helper functions +%* * %************************************************************************ \begin{code} -findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path - -> [FilePath] -- Directories to look in - -> IO (Maybe FilePath) -- The first file path to match -findFile _ [] +findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path + -> [FilePath] -- Directories to look in + -> IO (Maybe FilePath) -- The first file path to match +findFile _ [] = return Nothing findFile mk_file_path (dir:dirs) - = do { let file_path = mk_file_path dir - ; b <- doesFileExist file_path - ; if b then - return (Just file_path) - else - findFile mk_file_path dirs } + = do { let file_path = mk_file_path dir + ; b <- doesFileExist file_path + ; if b then + return (Just file_path) + else + findFile mk_file_path dirs } \end{code} \begin{code} maybePutStr :: DynFlags -> String -> IO () maybePutStr dflags s | verbosity dflags > 0 = putStr s - | otherwise = return () + | otherwise = return () maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s - | otherwise = return () + | otherwise = return () \end{code} %************************************************************************ -%* * - Tunneling global variables into new instance of GHC library -%* * +%* * + Tunneling global variables into new instance of GHC library +%* * %************************************************************************ \begin{code} diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs index dedc9ceb2f..2e3965ab0d 100644 --- a/compiler/ghci/ObjLink.lhs +++ b/compiler/ghci/ObjLink.lhs @@ -3,38 +3,31 @@ % -- --------------------------------------------------------------------------- --- The dynamic linker for object code (.o .so .dll files) +-- The dynamic linker for object code (.o .so .dll files) -- --------------------------------------------------------------------------- Primarily, this module consists of an interface to the C-land dynamic linker. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module ObjLink ( - initObjLinker, -- :: IO () - loadDLL, -- :: String -> IO (Maybe String) - loadArchive, -- :: String -> IO () - loadObj, -- :: String -> IO () - unloadObj, -- :: String -> IO () +module ObjLink ( + initObjLinker, -- :: IO () + loadDLL, -- :: String -> IO (Maybe String) + loadArchive, -- :: String -> IO () + loadObj, -- :: String -> IO () + unloadObj, -- :: String -> IO () insertSymbol, -- :: String -> String -> Ptr a -> IO () - lookupSymbol, -- :: String -> IO (Maybe (Ptr a)) - resolveObjs -- :: IO SuccessFlag + lookupSymbol, -- :: String -> IO (Maybe (Ptr a)) + resolveObjs -- :: IO SuccessFlag ) where import Panic -import BasicTypes ( SuccessFlag, successIf ) -import Config ( cLeadingUnderscore ) +import BasicTypes ( SuccessFlag, successIf ) +import Config ( cLeadingUnderscore ) import Util import Control.Monad ( when ) import Foreign.C -import Foreign ( nullPtr ) +import Foreign ( nullPtr ) import GHC.Exts ( Ptr(..) ) import System.Posix.Internals ( CFilePath, withFilePath ) import System.FilePath ( dropExtension ) @@ -57,8 +50,8 @@ lookupSymbol str_in = do withCAString str $ \c_str -> do addr <- c_lookupSymbol c_str if addr == nullPtr - then return Nothing - else return (Just addr) + then return Nothing + else return (Just addr) prefixUnderscore :: String -> String prefixUnderscore @@ -85,9 +78,9 @@ loadDLL str0 = do -- maybe_errmsg <- withFilePath str $ \dll -> c_addDLL dll if maybe_errmsg == nullPtr - then return Nothing - else do str <- peekCString maybe_errmsg - return (Just str) + then return Nothing + else do str <- peekCString maybe_errmsg + return (Just str) loadArchive :: String -> IO () loadArchive str = do diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index f140c8fb09..f06d120bc4 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -45,7 +45,7 @@ import Var import TcRnMonad import TcType import TcMType -import TcHsSyn ( mkZonkTcTyVar ) +import TcHsSyn ( zonkTcTypeToType, mkEmptyZonkEnv ) import TcUnify import TcEnv @@ -54,12 +54,12 @@ import Name import VarEnv import Util import VarSet +import BasicTypes ( TupleSort(UnboxedTuple) ) import TysPrim import PrelNames import TysWiredIn import DynFlags import Outputable as Ppr -import FastString import Constants ( wORD_SIZE ) import GHC.Arr ( Array(..) ) import GHC.Exts @@ -378,7 +378,7 @@ ppr_termM _ _ t = ppr_termM1 t ppr_termM1 :: Monad m => Term -> m SDoc ppr_termM1 Prim{value=words, ty=ty} = - return$ text$ repPrim (tyConAppTyCon ty) words + return $ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = return (char '_' <+> ifPprDebug (text "::" <> ppr ty)) ppr_termM1 Suspension{ty=ty, bound_to=Just n} @@ -493,33 +493,33 @@ cPprTermBase y = ppr_list _ _ = panic "doList" -repPrim :: TyCon -> [Word] -> String -repPrim t = rep where +repPrim :: TyCon -> [Word] -> SDoc +repPrim t = rep where rep x - | t == charPrimTyCon = show (build x :: Char) - | t == intPrimTyCon = show (build x :: Int) - | t == wordPrimTyCon = show (build x :: Word) - | t == floatPrimTyCon = show (build x :: Float) - | t == doublePrimTyCon = show (build x :: Double) - | t == int32PrimTyCon = show (build x :: Int32) - | t == word32PrimTyCon = show (build x :: Word32) - | t == int64PrimTyCon = show (build x :: Int64) - | t == word64PrimTyCon = show (build x :: Word64) - | t == addrPrimTyCon = show (nullPtr `plusPtr` build x) - | t == stablePtrPrimTyCon = "<stablePtr>" - | t == stableNamePrimTyCon = "<stableName>" - | t == statePrimTyCon = "<statethread>" - | t == realWorldTyCon = "<realworld>" - | t == threadIdPrimTyCon = "<ThreadId>" - | t == weakPrimTyCon = "<Weak>" - | t == arrayPrimTyCon = "<array>" - | t == byteArrayPrimTyCon = "<bytearray>" - | t == mutableArrayPrimTyCon = "<mutableArray>" - | t == mutableByteArrayPrimTyCon = "<mutableByteArray>" - | t == mutVarPrimTyCon= "<mutVar>" - | t == mVarPrimTyCon = "<mVar>" - | t == tVarPrimTyCon = "<tVar>" - | otherwise = showSDoc (char '<' <> ppr t <> char '>') + | t == charPrimTyCon = text $ show (build x :: Char) + | t == intPrimTyCon = text $ show (build x :: Int) + | t == wordPrimTyCon = text $ show (build x :: Word) + | t == floatPrimTyCon = text $ show (build x :: Float) + | t == doublePrimTyCon = text $ show (build x :: Double) + | t == int32PrimTyCon = text $ show (build x :: Int32) + | t == word32PrimTyCon = text $ show (build x :: Word32) + | t == int64PrimTyCon = text $ show (build x :: Int64) + | t == word64PrimTyCon = text $ show (build x :: Word64) + | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x) + | t == stablePtrPrimTyCon = text "<stablePtr>" + | t == stableNamePrimTyCon = text "<stableName>" + | t == statePrimTyCon = text "<statethread>" + | t == realWorldTyCon = text "<realworld>" + | t == threadIdPrimTyCon = text "<ThreadId>" + | t == weakPrimTyCon = text "<Weak>" + | t == arrayPrimTyCon = text "<array>" + | t == byteArrayPrimTyCon = text "<bytearray>" + | t == mutableArrayPrimTyCon = text "<mutableArray>" + | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>" + | t == mutVarPrimTyCon = text "<mutVar>" + | t == mVarPrimTyCon = text "<mVar>" + | t == tVarPrimTyCon = text "<tVar>" + | otherwise = char '<' <> ppr t <> char '>' where build ww = unsafePerformIO $ withArray ww (peek . castPtr) -- This ^^^ relies on the representation of Haskell heap values being -- the same as in a C array. @@ -662,7 +662,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do return $ fixFunDictionaries $ expandNewtypes term' else do (old_ty', rev_subst) <- instScheme quant_old_ty - my_ty <- newVar argTypeKind + my_ty <- newVar openTypeKind when (check1 quant_old_ty) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') term <- go max_depth my_ty sigma_old_ty hval @@ -682,7 +682,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do zterm' <- mapTermTypeM (\ty -> case tcSplitTyConApp_maybe ty of Just (tc, _:_) | tc /= funTyCon - -> newVar argTypeKind + -> newVar openTypeKind _ -> return ty) term zonkTerm zterm' @@ -750,7 +750,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- ignore the unpointed args, and recover the pointeds -- This preserves laziness, and should be safe. traceTR (text "Nothing" <+> ppr dcname) - let tag = showSDoc (ppr dcname) + let dflags = hsc_dflags hsc_env + tag = showPpr dflags dcname vars <- replicateM (length$ elems$ ptrs clos) (newVar liftedTypeKind) subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i @@ -759,32 +760,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do Just dc -> do traceTR (text "Just" <+> ppr dc) subTtypes <- getDataConArgTys dc my_ty - let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes - subTermsP <- sequence - [ appArr (go (pred max_depth) ty ty) (ptrs clos) i - | (i,ty) <- zip [0..] subTtypesP] - let unboxeds = extractUnboxed subTtypesNP clos - subTermsNP = zipWith Prim subTtypesNP unboxeds - subTerms = reOrderTerms subTermsP subTermsNP subTtypes + subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes return (Term my_ty (Right dc) a subTerms) -- The otherwise case: can be a Thunk,AP,PAP,etc. tipe_clos -> return (Suspension tipe_clos my_ty a Nothing) - -- put together pointed and nonpointed subterms in the - -- correct order. - reOrderTerms _ _ [] = [] - reOrderTerms pointed unpointed (ty:tys) - | isPtrType ty = ASSERT2(not(null pointed) - , ptext (sLit "reOrderTerms") $$ - (ppr pointed $$ ppr unpointed)) - let (t:tt) = pointed in t : reOrderTerms tt unpointed tys - | otherwise = ASSERT2(not(null unpointed) - , ptext (sLit "reOrderTerms") $$ - (ppr pointed $$ ppr unpointed)) - let (t:tt) = unpointed in t : reOrderTerms pointed tt tys - -- insert NewtypeWraps around newtypes expandNewtypes = foldTerm idTermFold { fTerm = worker } where worker ty dc hval tt @@ -802,6 +784,46 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n | otherwise = Suspension ct ty hval n +extractSubTerms :: (Type -> HValue -> TcM Term) + -> Closure -> [Type] -> TcM [Term] +extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos) + where + go ptr_i ws [] = return (ptr_i, ws, []) + go ptr_i ws (ty:tys) + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + = do (ptr_i, ws, terms0) <- go ptr_i ws elem_tys + (ptr_i, ws, terms1) <- go ptr_i ws tys + return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) + | otherwise + = case repType ty of + UnaryRep rep_ty -> do + (ptr_i, ws, term0) <- go_rep ptr_i ws ty (typePrimRep rep_ty) + (ptr_i, ws, terms1) <- go ptr_i ws tys + return (ptr_i, ws, term0 : terms1) + UbxTupleRep rep_tys -> do + (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys + (ptr_i, ws, terms1) <- go ptr_i ws tys + return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) + + go_unary_types ptr_i ws [] = return (ptr_i, ws, []) + go_unary_types ptr_i ws (rep_ty:rep_tys) = do + tv <- newVar liftedTypeKind + (ptr_i, ws, term0) <- go_rep ptr_i ws tv (typePrimRep rep_ty) + (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys + return (ptr_i, ws, term0 : terms1) + + go_rep ptr_i ws ty rep = case rep of + PtrRep -> do + t <- appArr (recurse ty) (ptrs clos) ptr_i + return (ptr_i + 1, ws, t) + _ -> do + let (ws0, ws1) = splitAt (primRepSizeW rep) ws + return (ptr_i, ws1, Prim ty ws0) + + unboxedTupleTerm ty terms = Term ty (Right (tupleCon UnboxedTuple (length terms))) + (error "unboxedTupleTerm: no HValue for unboxed tuple") terms + -- Fast, breadth-first Type reconstruction ------------------------------------------ @@ -814,7 +836,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do then return old_ty else do (old_ty', rev_subst) <- instScheme sigma_old_ty - my_ty <- newVar argTypeKind + my_ty <- newVar openTypeKind when (check1 sigma_old_ty) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') search (isMonomorphic `fmap` zonkTcType my_ty) @@ -870,11 +892,36 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do Just dc -> do arg_tys <- getDataConArgTys dc my_ty - traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) + (_, itys) <- findPtrTyss 0 arg_tys + traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) return $ [ appArr (\e-> (ty,e)) (ptrs clos) i - | (i,ty) <- zip [0..] (filter isPtrType arg_tys)] + | (i,ty) <- itys] _ -> return [] +findPtrTys :: Int -- Current pointer index + -> Type -- Type + -> TR (Int, [(Int, Type)]) +findPtrTys i ty + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + = findPtrTyss i elem_tys + + | otherwise + = case repType ty of + UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)]) + | otherwise -> return (i, []) + UbxTupleRep rep_tys -> foldM (\(i, extras) rep_ty -> if typePrimRep rep_ty == PtrRep + then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)]) + else return (i, extras)) + (i, []) rep_tys + +findPtrTyss :: Int + -> [Type] + -> TR (Int, [(Int, Type)]) +findPtrTyss i tys = foldM step (i, []) tys + where step (i, discovered) elem_ty = findPtrTys i elem_ty >>= \(i, extras) -> return (i, discovered ++ extras) + + -- Compute the difference between a base type and the type found by RTTI -- improveType <base_type> <rtti_type> -- The types can contain skolem type variables, which need to be treated as normal vars. @@ -890,7 +937,7 @@ getDataConArgTys :: DataCon -> Type -> TR [Type] -- if so, make up fresh RTTI type variables for them getDataConArgTys dc con_app_ty = do { (_, ex_tys, _) <- instTyVars ex_tvs - ; let rep_con_app_ty = repType con_app_ty + ; let UnaryRep rep_con_app_ty = repType con_app_ty ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of Just (tc, ty_args) | dataConTyCon dc == tc -> ASSERT( univ_tvs `equalLength` ty_args) @@ -909,11 +956,6 @@ getDataConArgTys dc con_app_ty univ_tvs = dataConUnivTyVars dc ex_tvs = dataConExTyVars dc -isPtrType :: Type -> Bool -isPtrType ty = case typePrimRep ty of - PtrRep -> True - _ -> False - -- Soundness checks -------------------- {- @@ -1111,7 +1153,8 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') text " in presence of newtype evidence " <> ppr new_tycon) (_, vars, _) <- instTyVars (tyConTyVars new_tycon) let ty' = mkTyConApp new_tycon vars - _ <- liftTcM (unifyType ty (repType ty')) + UnaryRep rep_ty = repType ty' + _ <- liftTcM (unifyType ty rep_ty) -- assumes that reptype doesn't ^^^^ touch tyconApp args return ty' @@ -1131,7 +1174,7 @@ zonkTerm = foldTermM (TermFoldM zonkRttiType :: TcType -> TcM Type -- Zonk the type, replacing any unbound Meta tyvars -- by skolems, safely out of Meta-tyvar-land -zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta mkTyVarTy) +zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta) where zonk_unbound_meta tv = ASSERT( isTcTyVar tv ) @@ -1158,7 +1201,8 @@ isMonomorphic ty = noExistentials && noUniversals -- Use only for RTTI types isMonomorphicOnNonPhantomArgs :: RttiType -> Bool isMonomorphicOnNonPhantomArgs ty - | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty) + | UnaryRep rep_ty <- repType ty + , Just (tc, all_args) <- tcSplitTyConApp_maybe rep_ty , phantom_vars <- tyConPhantomTyVars tc , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args , tyv `notElem` phantom_vars] @@ -1196,11 +1240,3 @@ amap' :: (t -> b) -> Array Int t -> [b] amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] where g (I# i#) = case indexArray# arr# i# of (# e #) -> f e - -extractUnboxed :: [Type] -> Closure -> [[Word]] -extractUnboxed tt clos = go tt (nonPtrs clos) - where sizeofType t = primRepSizeW (typePrimRep t) - go [] _ = [] - go (t:tt) xx - | (x, rest) <- splitAt (sizeofType t) xx - = x : go tt rest diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 5318c5be49..a5839c2406 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -31,7 +31,6 @@ import TysWiredIn import BasicTypes as Hs import ForeignCall import Unique -import MonadUtils import ErrUtils import Bag import Util @@ -42,7 +41,6 @@ import Control.Monad( unless ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH - import GHC.Exts ------------------------------------------------------------------- @@ -54,7 +52,7 @@ convertToHsDecls loc ds = initCvt loc (mapM cvt_dec ds) cvt_dec d = wrapMsg "declaration" d (cvtDec d) convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName) -convertToHsExpr loc e +convertToHsExpr loc e = initCvt loc $ wrapMsg "expression" e $ cvtl e convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName) @@ -70,7 +68,7 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc a } -- Push down the source location; -- Can fail, with a single error message --- NB: If the conversion succeeds with (Right x), there should +-- NB: If the conversion succeeds with (Right x), there should -- be no exception values hiding in x -- Reason: so a (head []) in TH code doesn't subsequently -- make GHC crash when it tries to walk the generated tree @@ -110,10 +108,10 @@ wrapMsg what item (CvtM m) Left err -> Left (err $$ getPprStyle msg) Right v -> Right v) where - -- Show the item in pretty syntax normally, + -- Show the item in pretty syntax normally, -- but with all its constructors if you say -dppr-debug msg sty = hang (ptext (sLit "When splicing a TH") <+> text what <> colon) - 2 (if debugStyle sty + 2 (if debugStyle sty then text (show item) else text (pprint item)) @@ -124,7 +122,7 @@ wrapL (CvtM m) = CvtM (\loc -> case m loc of ------------------------------------------------------------------- cvtDec :: TH.Dec -> CvtM (LHsDecl RdrName) -cvtDec (TH.ValD pat body ds) +cvtDec (TH.ValD pat body ds) | TH.VarP s <- pat = do { s' <- vNameL s ; cl' <- cvtClause (Clause [] body ds) @@ -135,11 +133,11 @@ cvtDec (TH.ValD pat body ds) ; body' <- cvtGuard body ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds ; returnL $ Hs.ValD $ - PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds' + PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds' , pat_rhs_ty = void, bind_fvs = placeHolderNames , pat_ticks = (Nothing,[]) } } -cvtDec (TH.FunD nm cls) +cvtDec (TH.FunD nm cls) | null cls = failWith (ptext (sLit "Function binding for") <+> quotes (text (TH.pprint nm)) @@ -149,11 +147,15 @@ cvtDec (TH.FunD nm cls) ; cls' <- mapM cvtClause cls ; returnL $ Hs.ValD $ mkFunBind nm' cls' } -cvtDec (TH.SigD nm typ) +cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ ; returnL $ Hs.SigD (TypeSig [nm'] ty') } +cvtDec (TH.InfixD fx nm) + = do { nm' <- vNameL nm + ; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) } + cvtDec (PragmaD prag) = do { prag' <- cvtPragmaD prag ; returnL $ Hs.SigD prag' } @@ -161,43 +163,54 @@ cvtDec (PragmaD prag) cvtDec (TySynD tc tvs rhs) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; rhs' <- cvtType rhs - ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') } + ; returnL $ TyClD (TyDecl { tcdLName = tc' + , tcdTyVars = tvs', tcdFVs = placeHolderNames + , tcdTyDefn = TySynonym rhs' }) } cvtDec (DataD ctxt tc tvs constrs derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing - , tcdCons = cons', tcdDerivs = derivs' }) } + ; let defn = TyData { td_ND = DataType, td_cType = Nothing + , td_ctxt = ctxt' + , td_kindSig = Nothing + , td_cons = cons', td_derivs = derivs' } + ; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs' + , tcdTyDefn = defn, tcdFVs = placeHolderNames }) } cvtDec (NewtypeD ctxt tc tvs constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing - , tcdCons = [con'], tcdDerivs = derivs'}) } + ; let defn = TyData { td_ND = NewType, td_cType = Nothing + , td_ctxt = ctxt' + , td_kindSig = Nothing + , td_cons = [con'], td_derivs = derivs' } + ; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs' + , tcdTyDefn = defn, tcdFVs = placeHolderNames }) } cvtDec (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds - ; (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs - ; returnL $ - TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' - , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds' - , tcdATs = ats', tcdATDefs = [], tcdDocs = [] } - -- no docs in TH ^^ + ; (binds', sigs', fams', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs + ; returnL $ TyClD $ + ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' + , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds' + , tcdATs = fams', tcdATDefs = ats', tcdDocs = [] + , tcdFVs = placeHolderNames } + -- no docs in TH ^^ } - + cvtDec (InstanceD ctxt ty decs) - = do { (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "an instance declaration")) decs + = do { let doc = ptext (sLit "an instance declaration") + ; (binds', sigs', fams', ats') <- cvt_ci_decs doc decs + ; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; ctxt' <- cvtContext ctxt ; L loc ty' <- cvtType ty ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty' - ; returnL $ InstD (ClsInstDecl inst_ty' binds' sigs' ats') } + ; returnL $ InstD (ClsInstD inst_ty' binds' sigs' ats') } -cvtDec (ForeignD ford) +cvtDec (ForeignD ford) = do { ford' <- cvtForD ford ; returnL $ ForD ford' } @@ -210,93 +223,87 @@ cvtDec (FamilyD flav tc tvs kind) cvtFamFlavour DataFam = DataFamily cvtDec (DataInstD ctxt tc tys constrs derivs) - = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys + = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; returnL $ InstD $ FamInstDecl $ - TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing - , tcdCons = cons', tcdDerivs = derivs' } } + ; let defn = TyData { td_ND = DataType, td_cType = Nothing + , td_ctxt = ctxt' + , td_kindSig = Nothing + , td_cons = cons', td_derivs = derivs' } + + ; returnL $ InstD $ FamInstD + { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = typats' + , fid_defn = defn, fid_fvs = placeHolderNames } }} cvtDec (NewtypeInstD ctxt tc tys constr derivs) - = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys + = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; returnL $ InstD $ FamInstDecl $ - TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing - , tcdCons = [con'], tcdDerivs = derivs' } } + ; let defn = TyData { td_ND = NewType, td_cType = Nothing + , td_ctxt = ctxt' + , td_kindSig = Nothing + , td_cons = [con'], td_derivs = derivs' } + ; returnL $ InstD $ FamInstD + { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = typats' + , fid_defn = defn, fid_fvs = placeHolderNames } } } cvtDec (TySynInstD tc tys rhs) - = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys + = do { (_, tc', tys') <- cvt_tyinst_hdr [] tc tys ; rhs' <- cvtType rhs - ; returnL $ InstD $ FamInstDecl $ - TySynonym tc' tvs' tys' rhs' } + ; returnL $ InstD $ FamInstD + { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = tys' + , fid_defn = TySynonym rhs', fid_fvs = placeHolderNames } } } ---------------- cvt_ci_decs :: MsgDoc -> [TH.Dec] -> CvtM (LHsBinds RdrName, [LSig RdrName], - [LTyClDecl RdrName]) + [LTyClDecl RdrName], -- Family decls + [LFamInstDecl RdrName]) -- Convert the declarations inside a class or instance decl -- ie signatures, bindings, and associated types cvt_ci_decs doc decs = do { decs' <- mapM cvtDec decs - ; let (ats', bind_sig_decs') = partitionWith is_tycl decs' - ; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs' - ; let (binds', bads) = partitionWith is_bind prob_binds' + ; let (ats', bind_sig_decs') = partitionWith is_fam_inst decs' + ; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs' + ; let (binds', prob_fams') = partitionWith is_bind prob_binds' + ; let (fams', bads) = partitionWith is_fam_decl prob_fams' ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - ; return (listToBag binds', sigs', ats') } + ; return (listToBag binds', sigs', fams', ats') } ---------------- cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] -> CvtM ( LHsContext RdrName , Located RdrName - , [LHsTyVarBndr RdrName]) + , LHsTyVarBndrs RdrName) cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc ; tvs' <- cvtTvs tvs - ; return (cxt', tc', tvs') + ; return (cxt', tc', tvs') } cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] -> CvtM ( LHsContext RdrName , Located RdrName - , [LHsTyVarBndr RdrName] - , Maybe [LHsType RdrName]) + , HsWithBndrs [LHsType RdrName]) cvt_tyinst_hdr cxt tc tys = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc - ; tvs <- concatMapM collect tys - ; tvs' <- cvtTvs tvs ; tys' <- mapM cvtType tys - ; return (cxt', tc', tvs', Just tys') - } - where - collect (ForallT _ _ _) - = failWith $ text "Forall type not allowed as type parameter" - collect (VarT tv) = return [PlainTV tv] - collect (ConT _) = return [] - collect (TupleT _) = return [] - collect (UnboxedTupleT _) = return [] - collect ArrowT = return [] - collect ListT = return [] - collect (AppT t1 t2) - = do { tvs1 <- collect t1 - ; tvs2 <- collect t2 - ; return $ tvs1 ++ tvs2 - } - collect (SigT (VarT tv) ki) = return [KindedTV tv ki] - collect (SigT ty _) = collect ty + ; return (cxt', tc', mkHsWithBndrs tys') } ------------------------------------------------------------------- -- Partitioning declarations ------------------------------------------------------------------- -is_tycl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName) -is_tycl (L loc (Hs.TyClD tcd)) = Left (L loc tcd) -is_tycl decl = Right decl +is_fam_decl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName) +is_fam_decl (L loc (TyClD d@(TyFamily {}))) = Left (L loc d) +is_fam_decl decl = Right decl + +is_fam_inst :: LHsDecl RdrName -> Either (LFamInstDecl RdrName) (LHsDecl RdrName) +is_fam_inst (L loc (Hs.InstD (FamInstD { lid_inst = d }))) = Left (L loc d) +is_fam_inst decl = Right decl is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName) is_sig (L loc (Hs.SigD sig)) = Left (L loc sig) @@ -306,8 +313,8 @@ is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName) is_bind (L loc (Hs.ValD bind)) = Left (L loc bind) is_bind decl = Right decl -mkBadDecMsg :: MsgDoc -> [LHsDecl RdrName] -> MsgDoc -mkBadDecMsg doc bads +mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc +mkBadDecMsg doc bads = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon , nest 2 (vcat (map Outputable.ppr bads)) ] @@ -319,19 +326,19 @@ mkBadDecMsg doc bads cvtConstr :: TH.Con -> CvtM (LConDecl RdrName) cvtConstr (NormalC c strtys) - = do { c' <- cNameL c + = do { c' <- cNameL c ; cxt' <- returnL [] ; tys' <- mapM cvt_arg strtys ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') } cvtConstr (RecC c varstrtys) - = do { c' <- cNameL c + = do { c' <- cNameL c ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') } cvtConstr (InfixC st1 c st2) - = do { c' <- cNameL c + = do { c' <- cNameL c ; cxt' <- returnL [] ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 @@ -341,7 +348,7 @@ cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; L loc ctxt' <- cvtContext ctxt ; L _ con' <- cvtConstr con - ; returnL $ con' { con_qvars = tvs' ++ con_qvars con' + ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con')) , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } } cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) @@ -350,7 +357,7 @@ cvt_arg (NotStrict, ty) = cvtType ty cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsUnpack ty' } cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName) -cvt_id_arg (i, str, ty) +cvt_id_arg (i, str, ty) = do { i' <- vNameL i ; ty' <- cvt_arg (str,ty) ; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) } @@ -375,7 +382,7 @@ noExistentials = [] cvtForD :: Foreign -> CvtM (ForeignDecl RdrName) cvtForD (ImportF callconv safety from nm ty) - | Just impspec <- parseCImport (cvt_conv callconv) safety' + | Just impspec <- parseCImport (cvt_conv callconv) safety' (mkFastString (TH.nameBase nm)) from = do { nm' <- vNameL nm ; ty' <- cvtType ty @@ -414,9 +421,9 @@ cvtPragmaD (SpecialiseP nm ty opt_ispec) ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) } cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma -cvtInlineSpec Nothing +cvtInlineSpec Nothing = defaultInlinePragma -cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) +cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo , inl_inline = inl_spec, inl_sat = Nothing } where @@ -426,12 +433,13 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) cvtRuleMatchInfo False = FunLike cvtRuleMatchInfo True = ConLike - inl_spec | inline = Inline - | otherwise = NoInline - -- Currently we have no way to say Inlinable + inl_spec = case inline of + TH.NoInline -> Hs.NoInline + TH.Inline -> Hs.Inline + TH.Inlinable -> Hs.Inlinable - cvtActivation Nothing | inline = AlwaysActive - | otherwise = NeverActive + cvtActivation Nothing | inline == TH.NoInline = NeverActive + | otherwise = AlwaysActive cvtActivation (Just (False, phase)) = ActiveBefore phase cvtActivation (Just (True , phase)) = ActiveAfter phase @@ -440,7 +448,7 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) --------------------------------------------------- cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName) -cvtLocalDecs doc ds +cvtLocalDecs doc ds | null ds = return EmptyLocalBinds | otherwise @@ -467,12 +475,12 @@ cvtl e = wrapL (cvt e) where cvt (VarE s) = do { s' <- vName s; return $ HsVar s' } cvt (ConE s) = do { s' <- cName s; return $ HsVar s' } - cvt (LitE l) + cvt (LitE l) | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } | otherwise = do { l' <- cvtLit l; return $ HsLit l' } cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' } - cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e + cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } -- Note [Dropping constructors] @@ -483,23 +491,23 @@ cvtl e = wrapL (cvt e) ; return $ HsIf (Just noSyntaxExpr) x' y' z' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds ; e' <- cvtl e; return $ HsLet ds' e' } - cvt (CaseE e ms) + cvt (CaseE e ms) | null ms = failWith (ptext (sLit "Case expression with no alternatives")) | otherwise = do { e' <- cvtl e; ms' <- mapM cvtMatch ms ; return $ HsCase e' (mkMatchGroup ms') } cvt (DoE ss) = cvtHsDo DoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' } - cvt (ListE xs) + cvt (ListE xs) | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' } -- Infix expressions cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y - ; wrapParL HsPar $ + ; wrapParL HsPar $ OpApp (mkLHsPar x') s' undefined (mkLHsPar y') } - -- Parenthesise both arguments and result, + -- Parenthesise both arguments and result, -- to ensure this operator application does -- does not get re-associated -- See Note [Operator association] @@ -514,7 +522,7 @@ cvtl e = wrapL (cvt e) -- Note [Dropping constructors] cvt (UInfixE x s y) = do { x' <- cvtl x - ; let x'' = case x' of + ; let x'' = case x' of L _ (OpApp {}) -> x' _ -> mkLHsPar x' ; cvtOpApp x'' s y } -- Note [Converting UInfix] @@ -546,7 +554,7 @@ which we don't want. -} cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName)) -cvtFld (v,e) +cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) } @@ -626,7 +634,7 @@ cvtHsDo do_or_lc stmts | otherwise = do { stmts' <- cvtStmts stmts ; let Just (stmts'', last') = snocView stmts' - + ; last'' <- case last' of L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') @@ -636,18 +644,18 @@ cvtHsDo do_or_lc stmts bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt , ptext (sLit "(It should be an expression.)") ] - + cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName] -cvtStmts = mapM cvtStmt +cvtStmts = mapM cvtStmt cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName) cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds ; returnL $ LetStmt ds' } -cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr noSyntaxExpr } +cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr } where - cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) } + cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName) cvtMatch (TH.Match p body decs) @@ -668,23 +676,23 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs ; returnL $ GRHS gs' rhs' } cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) -cvtOverLit (IntegerL i) +cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i placeHolderType} -cvtOverLit (RationalL r) +cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType} -cvtOverLit (StringL s) +cvtOverLit (StringL s) = do { let { s' = mkFastString s } ; force s' - ; return $ mkHsIsString s' placeHolderType + ; return $ mkHsIsString s' placeHolderType } cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" -- An Integer is like an (overloaded) '3' in a Haskell source program -- Similarly 3.5 for fractionals -{- Note [Converting strings] +{- Note [Converting strings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to -a string literal for "xy". Of course, we might hope to get +a string literal for "xy". Of course, we might hope to get (LitE (StringL "xy")), but not always, and allCharLs fails quickly if it isn't a literal string -} @@ -694,7 +702,7 @@ allCharLs :: [TH.Exp] -> Maybe String -- NB: only fire up this setup for a non-empty list, else -- there's a danger of returning "" for [] :: [Int]! allCharLs xs - = case xs of + = case xs of LitE (CharL c) : ys -> go [c] ys _ -> Nothing where @@ -709,10 +717,10 @@ cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) } cvtLit (CharL c) = do { force c; return $ HsChar c } cvtLit (StringL s) = do { let { s' = mkFastString s } - ; force s' + ; force s' ; return $ HsString s' } -cvtLit (StringPrimL s) = do { let { s' = mkFastString s } - ; force s' +cvtLit (StringPrimL s) = do { let { s' = mkFastStringByteList s } + ; force s' ; return $ HsStringPrim s' } cvtLit _ = panic "Convert.cvtLit: Unexpected literal" -- cvtLit should not be called on IntegerL, RationalL @@ -729,7 +737,7 @@ cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName) cvtp (TH.LitP l) | overloadedLit l = do { l' <- cvtOverLit l ; return (mkNPat l' Nothing) } - -- Not right for negative patterns; + -- Not right for negative patterns; -- need to think about that! | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' } @@ -739,7 +747,7 @@ cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed v cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps ; return $ ConPatIn s' (PrefixCon ps') } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 - ; wrapParL ParPat $ + ; wrapParL ParPat $ ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) } -- See Note [Operator association] cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] @@ -749,9 +757,10 @@ cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } cvtp TH.WildP = return $ WildPat void cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs - ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } + ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } -cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' } +cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t + ; return $ SigPatIn p' (mkHsWithBndrs t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) @@ -776,19 +785,17 @@ cvtOpAppP x op y ----------------------------------------------------------- -- Types and type variables -cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName] -cvtTvs tvs = mapM cvt_tv tvs +cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName) +cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) -cvt_tv (TH.PlainTV nm) +cvt_tv (TH.PlainTV nm) = do { nm' <- tName nm - ; returnL $ UserTyVar nm' placeHolderKind - } -cvt_tv (TH.KindedTV nm ki) + ; returnL $ UserTyVar nm' } +cvt_tv (TH.KindedTV nm ki) = do { nm' <- tName nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar nm' ki' placeHolderKind - } + ; returnL $ KindedTyVar nm' ki' } cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } @@ -806,17 +813,20 @@ cvtPred (TH.EqualP ty1 ty2) } cvtType :: TH.Type -> CvtM (LHsType RdrName) -cvtType ty +cvtType = cvtTypeKind "type" + +cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName) +cvtTypeKind ty_str ty = do { (head_ty, tys') <- split_ty_app ty ; case head_ty of - TupleT n + TupleT n | length tys' == n -- Saturated - -> if n==1 then return (head tys') -- Singleton tuples treated + -> if n==1 then return (head tys') -- Singleton tuples treated -- like nothing (ie just parens) else returnL (HsTupleTy HsBoxedTuple tys') - | n == 1 - -> failWith (ptext (sLit "Illegal 1-tuple type constructor")) - | otherwise + | n == 1 + -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) + | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon BoxedTuple n))) tys' UnboxedTupleT n | length tys' == n -- Saturated @@ -839,7 +849,7 @@ cvtType ty -> do { tvs' <- cvtTvs tvs ; cxt' <- cvtContext cxt ; ty' <- cvtType ty - ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' + ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty' } SigT ty ki @@ -848,7 +858,39 @@ cvtType ty ; mk_apps (HsKindSig ty' ki') tys' } - _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty)) + LitT lit + -> returnL (HsTyLit (cvtTyLit lit)) + + PromotedT nm -> do { nm' <- cName nm; mk_apps (HsTyVar nm') tys' } + -- Promoted data constructor; hence cName + + PromotedTupleT n + | n == 1 + -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str))) + | m == n -- Saturated + -> do { let kis = replicate m placeHolderKind + ; returnL (HsExplicitTupleTy kis tys') + } + where + m = length tys' + + PromotedNilT + -> returnL (HsExplicitListTy placeHolderKind []) + + PromotedConsT -- See Note [Representing concrete syntax in types] + -- in Language.Haskell.TH.Syntax + | [ty1, L _ (HsExplicitListTy _ tys2)] <- tys' + -> returnL (HsExplicitListTy placeHolderKind (ty1:tys2)) + | otherwise + -> mk_apps (HsTyVar (getRdrName consDataCon)) tys' + + StarT + -> returnL (HsTyVar (getRdrName liftedTypeKindTyCon)) + + ConstraintT + -> returnL (HsTyVar (getRdrName constraintKindTyCon)) + + _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) } mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName) @@ -862,16 +904,25 @@ split_ty_app ty = go ty [] go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') } go f as = return (f,as) +cvtTyLit :: TH.TyLit -> HsTyLit +cvtTyLit (NumTyLit i) = HsNumTy i +cvtTyLit (StrTyLit s) = HsStrTy (fsLit s) + cvtKind :: TH.Kind -> CvtM (LHsKind RdrName) -cvtKind StarK = returnL (HsTyVar (getRdrName liftedTypeKindTyCon)) -cvtKind (ArrowK k1 k2) = do - k1' <- cvtKind k1 - k2' <- cvtKind k2 - returnL (HsFunTy k1' k2') +cvtKind = cvtTypeKind "kind" cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName)) cvtMaybeKind Nothing = return Nothing -cvtMaybeKind (Just ki) = cvtKind ki >>= return . Just +cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki + ; return (Just ki') } + +----------------------------------------------------------- +cvtFixity :: TH.Fixity -> Hs.Fixity +cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir) + where + cvt_dir TH.InfixL = Hs.InfixL + cvt_dir TH.InfixR = Hs.InfixR + cvt_dir TH.InfixN = Hs.InfixN ----------------------------------------------------------- @@ -904,7 +955,7 @@ vName n = cvtName OccName.varName n -- Constructor function names; this is Haskell source, hence srcDataName cNameL n = wrapL (cName n) -cName n = cvtName OccName.dataName n +cName n = cvtName OccName.dataName n -- Type variable names tName n = cvtName OccName.tvName n @@ -916,17 +967,17 @@ tconName n = cvtName OccName.tcClsName n cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName cvtName ctxt_ns (TH.Name occ flavour) | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str) - | otherwise + | otherwise = do { loc <- getL - ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour - ; force rdr_name + ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour + ; force rdr_name ; return rdr_name } where occ_str = TH.occString occ okOcc :: OccName.NameSpace -> String -> Bool okOcc _ [] = False -okOcc ns str@(c:_) +okOcc ns str@(c:_) | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c | otherwise = startsConId c || startsConSym c || str == "[]" @@ -939,7 +990,7 @@ isVarName (TH.Name occ _) (c:_) -> startsVarId c || startsVarSym c badOcc :: OccName.NameSpace -> String -> SDoc -badOcc ctxt_ns occ +badOcc ctxt_ns occ = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns <+> ptext (sLit "name:") <+> quotes (text occ) @@ -955,9 +1006,9 @@ thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- to have a binding site inside it. (cf Trac #5434) -- -- ToDo: we may generate silly RdrNames, by passing a name space --- that doesn't match the string, like VarName ":+", +-- that doesn't match the string, like VarName ":+", -- which will give confusing error messages later --- +-- -- The strict applications ensure that any buried exceptions get forced thRdrName loc ctxt_ns th_occ th_name = case th_name of @@ -1001,7 +1052,7 @@ isBuiltInOcc ctxt_ns occ go_tuple n (',' : rest) = go_tuple (n+1) rest go_tuple _ _ = Nothing - tup_name n + tup_name n | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon BoxedTuple n) | otherwise = Name.getName (tupleCon BoxedTuple n) @@ -1040,19 +1091,19 @@ Consider this TH term construction: It represents the term \[x1,x2]. \x3. (x1,x2,x3,x) -a) We don't want to complain about "x" being bound twice in +a) We don't want to complain about "x" being bound twice in the pattern [x1,x2] b) We don't want x3 to shadow the x1,x2 -c) We *do* want 'x' (dynamically bound with mkName) to bind +c) We *do* want 'x' (dynamically bound with mkName) to bind to the innermost binding of "x", namely x3. -d) When pretty printing, we want to print a unique with x1,x2 +d) When pretty printing, we want to print a unique with x1,x2 etc, else they'll all print as "x" which isn't very helpful When we convert all this to HsSyn, the TH.Names are converted with thRdrName. To achieve (b) we want the binders to be Exact RdrNames. Achieving (a) is a bit awkward, because - - We must check for duplicate and shadowed names on Names, - not RdrNames, *after* renaming. + - We must check for duplicate and shadowed names on Names, + not RdrNames, *after* renaming. See Note [Collect binders only after renaming] in HsUtils - But to achieve (a) we must distinguish between the Exact diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index bb8b337a00..26097df6c4 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -34,13 +34,13 @@ import NameSet import BasicTypes import Outputable import SrcLoc -import Util import Var import Bag import FastString import Data.Data hiding ( Fixity ) -import Data.List ( intersect ) +import Data.List +import Data.Ord \end{code} %************************************************************************ @@ -175,12 +175,12 @@ data HsBindLR idL idR -- of this last construct.) data ABExport id - = ABE { abe_poly :: id + = ABE { abe_poly :: id -- Any INLINE pragmas is attached to this Id , abe_mono :: id - , abe_wrap :: HsWrapper -- See Note [AbsBinds wrappers] + , abe_wrap :: HsWrapper -- See Note [AbsBinds wrappers] -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly - , abe_prags :: TcSpecPrags } - deriving (Data, Typeable) + , abe_prags :: TcSpecPrags -- SPECIALISE pragmas + } deriving (Data, Typeable) placeHolderNames :: NameSet -- Used for the NameSet in FunBind and PatBind prior to the renamer @@ -267,7 +267,7 @@ pprLHsBindsForUser binds sigs decls = [(loc, ppr sig) | L loc sig <- sigs] ++ [(loc, ppr bind) | L loc bind <- bagToList binds] - sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls + sort_by_loc decls = sortBy (comparing fst) decls pprDeclList :: [SDoc] -> SDoc -- Braces with a space -- Print a bunch of declarations @@ -368,16 +368,13 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf, ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , abs_exports = exports, abs_binds = val_binds , abs_ev_binds = ev_binds }) - = sep [ptext (sLit "AbsBinds"), - brackets (interpp'SP tyvars), - brackets (interpp'SP dictvars), - brackets (sep (punctuate comma (map ppr exports)))] - $$ - nest 2 ( vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] - -- Print type signatures - $$ pprLHsBinds val_binds ) - $$ - ifPprDebug (ppr ev_binds) + = hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars) + <+> brackets (interpp'SP dictvars)) + 2 $ braces $ vcat + [ ptext (sLit "Exports:") <+> brackets (sep (punctuate comma (map ppr exports))) + , ptext (sLit "Exported types:") <+> vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] + , ptext (sLit "Binds:") <+> pprLHsBinds val_binds + , ifPprDebug (ptext (sLit "Evidence:") <+> ppr ev_binds) ] instance (OutputableBndr id) => Outputable (ABExport id) where ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) @@ -419,10 +416,12 @@ isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds type LIPBind id = Located (IPBind id) -- | Implicit parameter bindings. +{- These bindings start off as (Left "x") in the parser and stay +that way until after type-checking when they are replaced with +(Right d), where "d" is the name of the dictionary holding the +evidene for the implicit parameter. -} data IPBind id - = IPBind - (IPName id) - (LHsExpr id) + = IPBind (Either HsIPName id) (LHsExpr id) deriving (Data, Typeable) instance (OutputableBndr id) => Outputable (HsIPBinds id) where @@ -430,7 +429,10 @@ instance (OutputableBndr id) => Outputable (HsIPBinds id) where $$ ifPprDebug (ppr ds) instance (OutputableBndr id) => Outputable (IPBind id) where - ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs) + ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) + where name = case lr of + Left ip -> pprBndr LetBind ip + Right id -> pprBndr LetBind id \end{code} diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index e6d369c519..2d8df43898 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -12,16 +12,16 @@ -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. module HsDecls ( -- * Toplevel declarations - HsDecl(..), LHsDecl, + HsDecl(..), LHsDecl, HsTyDefn(..), -- ** Class or type declarations TyClDecl(..), LTyClDecl, TyClGroup, - isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl, - isFamInstDecl, tcdName, tyClDeclTyVars, - countTyClDecls, + isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, + isHsDataDefn, isHsSynDefn, tcdName, famInstDeclName, + countTyClDecls, pprTyDefnFlavour, pprTyClDeclFlavour, -- ** Instance declarations InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..), - FamInstDecl, LFamInstDecl, instDeclFamInsts, + FamInstDecl(..), LFamInstDecl, instDeclFamInsts, -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, @@ -80,7 +80,6 @@ import FastString import Bag import Control.Monad ( liftM ) import Data.Data hiding (TyCon) -import Data.Maybe ( isJust ) \end{code} %************************************************************************ @@ -414,27 +413,6 @@ Interface file code: \begin{code} --- Representation of indexed types --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Family kind signatures are represented by the variant `TyFamily'. It --- covers "type family", "newtype family", and "data family" declarations, --- distinguished by the value of the field `tcdFlavour'. --- --- Indexed types are represented by 'TyData' and 'TySynonym' using the field --- 'tcdTyPats::Maybe [LHsType name]', with the following meaning: --- --- * If it is 'Nothing', we have a *vanilla* data type declaration or type --- synonym declaration and 'tcdVars' contains the type parameters of the --- type constructor. --- --- * If it is 'Just pats', we have the definition of an indexed type. Then, --- 'pats' are type patterns for the type-indexes of the type constructor --- and 'tcdTyVars' are the variables in those patterns. Hence, the arity of --- the indexed type (ie, the number of indexes) is 'length tcdTyPats' and --- *not* 'length tcdVars'. --- --- In both cases, 'tcdVars' collects all variables we need to quantify over. - type LTyClDecl name = Located (TyClDecl name) type TyClGroup name = [LTyClDecl name] -- This is used in TcTyClsDecls to represent -- strongly connected components of decls @@ -447,65 +425,23 @@ data TyClDecl name tcdExtName :: Maybe FastString } - | -- | @type/data family T :: *->*@ - TyFamily { tcdFlavour:: FamilyFlavour, -- type or data - tcdLName :: Located name, -- type constructor - tcdTyVars :: [LHsTyVarBndr name], -- type variables - tcdKind :: Maybe (LHsKind name) -- result kind - } - - - | -- | Declares a data type or newtype, giving its construcors - -- @ - -- data/newtype T a = <constrs> - -- data/newtype instance T [a] = <constrs> - -- @ - TyData { tcdND :: NewOrData, - tcdCtxt :: LHsContext name, -- ^ Context - tcdLName :: Located name, -- ^ Type constructor - - tcdTyVars :: [LHsTyVarBndr name], -- ^ Type variables - tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns. - -- See Note [tcdTyVars and tcdTyPats] - - tcdKindSig:: Maybe (LHsKind name), - -- ^ Optional kind signature. - -- - -- @(Just k)@ for a GADT-style @data@, or @data - -- instance@ decl with explicit kind sig - - tcdCons :: [LConDecl name], - -- ^ Data constructors - -- - -- For @data T a = T1 | T2 a@ - -- the 'LConDecl's all have 'ResTyH98'. - -- For @data T a where { T1 :: T a }@ - -- the 'LConDecls' all have 'ResTyGADT'. - - tcdDerivs :: Maybe [LHsType name] - -- ^ Derivings; @Nothing@ => not specified, - -- @Just []@ => derive exactly what is asked - -- - -- These "types" must be of form - -- @ - -- forall ab. C ty1 ty2 - -- @ - -- Typically the foralls and ty args are empty, but they - -- are non-empty for the newtype-deriving case + TyFamily { tcdFlavour :: FamilyFlavour, -- type or data + tcdLName :: Located name, -- type constructor + tcdTyVars :: LHsTyVarBndrs name, -- type variables + tcdKindSig :: Maybe (LHsKind name) -- result kind } - | TySynonym { tcdLName :: Located name, -- ^ type constructor - tcdTyVars :: [LHsTyVarBndr name], -- ^ type variables - tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns - -- See Note [tcdTyVars and tcdTyPats] - tcdSynRhs :: LHsType name -- ^ synonym expansion - } + | -- | @type/data declaration + TyDecl { tcdLName :: Located name -- ^ Type constructor + , tcdTyVars :: LHsTyVarBndrs name + , tcdTyDefn :: HsTyDefn name + , tcdFVs :: NameSet } | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... tcdLName :: Located name, -- ^ Name of the class - tcdTyVars :: [LHsTyVarBndr name], -- ^ Class type variables + tcdTyVars :: LHsTyVarBndrs name, -- ^ Class type variables tcdFDs :: [Located (FunDep name)], -- ^ Functional deps tcdSigs :: [LSig name], -- ^ Methods' signatures tcdMeths :: LHsBinds name, -- ^ Default methods @@ -513,10 +449,54 @@ data TyClDecl name -- only 'TyFamily' tcdATDefs :: [LFamInstDecl name], -- ^ Associated type defaults; ie -- only 'TySynonym' - tcdDocs :: [LDocDecl] -- ^ Haddock docs + tcdDocs :: [LDocDecl], -- ^ Haddock docs + tcdFVs :: NameSet } deriving (Data, Typeable) + +data HsTyDefn name -- The payload of a type synonym or data type defn + -- Used *both* for vanialla type/data declarations, + -- *and* for type/data family instances + = TySynonym { td_synRhs :: LHsType name } -- ^ Synonym expansion + + | -- | Declares a data type or newtype, giving its construcors + -- @ + -- data/newtype T a = <constrs> + -- data/newtype instance T [a] = <constrs> + -- @ + TyData { td_ND :: NewOrData, + td_ctxt :: LHsContext name, -- ^ Context + td_cType :: Maybe CType, + td_kindSig:: Maybe (LHsKind name), + -- ^ Optional kind signature. + -- + -- @(Just k)@ for a GADT-style @data@, + -- or @data instance@ decl, with explicit kind sig + -- + -- Always @Nothing@ for H98-syntax decls + + td_cons :: [LConDecl name], + -- ^ Data constructors + -- + -- For @data T a = T1 | T2 a@ + -- the 'LConDecl's all have 'ResTyH98'. + -- For @data T a where { T1 :: T a }@ + -- the 'LConDecls' all have 'ResTyGADT'. + + td_derivs :: Maybe [LHsType name] + -- ^ Derivings; @Nothing@ => not specified, + -- @Just []@ => derive exactly what is asked + -- + -- These "types" must be of form + -- @ + -- forall ab. C ty1 ty2 + -- @ + -- Typically the foralls and ty args are empty, but they + -- are non-empty for the newtype-deriving case + } + deriving( Data, Typeable ) + data NewOrData = NewType -- ^ @newtype Blah ...@ | DataType -- ^ @data Blah ...@ @@ -528,53 +508,39 @@ data FamilyFlavour deriving (Data, Typeable) \end{code} -Note [tcdTyVars and tcdTyPats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [tcdTypats and HsTyPats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use TyData and TySynonym both for vanilla data/type declarations type T a = Int AND for data/type family instance declarations type instance F [a] = (a,Int) -tcdTyPats = Nothing +tcdTyPats = HsTyDefn tvs This is a vanilla data type or type synonym - tcdTyVars are the quantified type variables - -tcdTyPats = Just tys - This is a data/type family instance declaration - tcdTyVars are fv(tys) + tvs are the quantified type variables - Eg class C s t where - type F t p :: * - instance C w (a,b) where - type F (a,b) x = x->a - The tcdTyVars of the F decl are {a,b,x}, even though the F decl - is nested inside the 'instance' decl. - - However after the renamer, the uniques will match up: - instance C w7 (a8,b9) where - type F (a8,b9) x10 = x10->a8 - so that we can compare the type patter in the 'instance' decl and - in the associated 'type' decl ------------------------------ Simple classifiers \begin{code} --- | @True@ <=> argument is a @data@\/@newtype@ or @data@\/@newtype instance@ +isHsDataDefn, isHsSynDefn :: HsTyDefn name -> Bool +isHsDataDefn (TyData {}) = True +isHsDataDefn _ = False + +isHsSynDefn (TySynonym {}) = True +isHsSynDefn _ = False + +-- | @True@ <=> argument is a @data@\/@newtype@ -- declaration. isDataDecl :: TyClDecl name -> Bool -isDataDecl (TyData {}) = True -isDataDecl _other = False +isDataDecl (TyDecl { tcdTyDefn = defn }) = isHsDataDefn defn +isDataDecl _other = False -- | type or type instance declaration -isTypeDecl :: TyClDecl name -> Bool -isTypeDecl (TySynonym {}) = True -isTypeDecl _other = False - --- | vanilla Haskell type synonym (ie, not a type instance) isSynDecl :: TyClDecl name -> Bool -isSynDecl (TySynonym {tcdTyPats = Nothing}) = True -isSynDecl _other = False +isSynDecl (TyDecl { tcdTyDefn = defn }) = isHsSynDefn defn +isSynDecl _other = False -- | type class isClassDecl :: TyClDecl name -> Bool @@ -585,27 +551,16 @@ isClassDecl _ = False isFamilyDecl :: TyClDecl name -> Bool isFamilyDecl (TyFamily {}) = True isFamilyDecl _other = False - --- | family instance (types, newtypes, and data types) -isFamInstDecl :: TyClDecl name -> Bool -isFamInstDecl tydecl - | isTypeDecl tydecl - || isDataDecl tydecl = isJust (tcdTyPats tydecl) - | otherwise = False \end{code} Dealing with names \begin{code} +famInstDeclName :: LFamInstDecl a -> a +famInstDeclName (L _ (FamInstDecl { fid_tycon = L _ name })) = name + tcdName :: TyClDecl name -> name tcdName decl = unLoc (tcdLName decl) - -tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name] -tyClDeclTyVars (TyFamily {tcdTyVars = tvs}) = tvs -tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs -tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs -tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs -tyClDeclTyVars (ForeignType {}) = [] \end{code} \begin{code} @@ -618,11 +573,11 @@ countTyClDecls decls count isNewTy decls, -- ...instances count isFamilyDecl decls) where - isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True - isDataTy _ = False + isDataTy TyDecl{ tcdTyDefn = TyData { td_ND = DataType } } = True + isDataTy _ = False - isNewTy TyData{tcdND = NewType, tcdTyPats = Nothing} = True - isNewTy _ = False + isNewTy TyDecl{ tcdTyDefn = TyData { td_ND = NewType } } = True + isNewTy _ = False \end{code} \begin{code} @@ -633,8 +588,8 @@ instance OutputableBndr name = hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon] ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, - tcdTyVars = tyvars, tcdKind = mb_kind}) - = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind + tcdTyVars = tyvars, tcdKindSig = mb_kind}) + = pp_flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind where pp_flavour = case flavour of TypeFamily -> ptext (sLit "type family") @@ -644,27 +599,8 @@ instance OutputableBndr name Nothing -> empty Just kind -> dcolon <+> ppr kind - ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats, - tcdSynRhs = mono_ty}) - = hang (ptext (sLit "type") <+> - (if isJust typats then ptext (sLit "instance") else empty) <+> - pp_decl_head [] ltycon tyvars typats <+> - equals) - 4 (ppr mono_ty) - - ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon, - tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig, - tcdCons = condecls, tcdDerivs = derivings}) - = pp_tydecl (null condecls && isJust mb_sig) - (ppr new_or_data <+> - (if isJust typats then ptext (sLit "instance") else empty) <+> - pp_decl_head (unLoc context) ltycon tyvars typats <+> - ppr_sigx mb_sig) - (pp_condecls condecls) - derivings - where - ppr_sigx Nothing = empty - ppr_sigx (Just kind) = dcolon <+> ppr kind + ppr (TyDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdTyDefn = defn }) + = pp_ty_defn (pp_vanilla_decl_head ltycon tyvars) defn ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFDs = fds, @@ -680,20 +616,25 @@ instance OutputableBndr name pprLHsBindsForUser methods sigs) ] where top_matter = ptext (sLit "class") - <+> pp_decl_head (unLoc context) lclas tyvars Nothing + <+> pp_vanilla_decl_head lclas tyvars (unLoc context) <+> pprFundeps (map unLoc fds) -pp_decl_head :: OutputableBndr name - => HsContext name - -> Located name - -> [LHsTyVarBndr name] - -> Maybe [LHsType name] +pp_vanilla_decl_head :: OutputableBndr name + => Located name + -> LHsTyVarBndrs name + -> HsContext name -> SDoc -pp_decl_head context thing tyvars Nothing -- no explicit type patterns - = hsep [pprHsContext context, ppr thing, interppSP tyvars] -pp_decl_head context thing _ (Just typats) -- explicit type patterns - = hsep [ pprHsContext context, ppr thing - , hsep (map (pprParendHsType.unLoc) typats)] +pp_vanilla_decl_head thing tyvars context + = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars] + +pp_fam_inst_head :: OutputableBndr name + => Located name + -> HsWithBndrs [LHsType name] + -> HsContext name + -> SDoc +pp_fam_inst_head thing (HsWB { hswb_cts = typats }) context -- explicit type patterns + = hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing) + , hsep (map (pprParendHsType.unLoc) typats)] pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax @@ -701,20 +642,48 @@ pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs)) -pp_tydecl :: OutputableBndr name => Bool -> SDoc -> SDoc -> Maybe [LHsType name] -> SDoc -pp_tydecl True pp_head _ _ - = pp_head -pp_tydecl False pp_head pp_decl_rhs derivings - = hang pp_head 4 (sep [ - pp_decl_rhs, - case derivings of - Nothing -> empty - Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)] - ]) +pp_ty_defn :: OutputableBndr name + => (HsContext name -> SDoc) -- Printing the header + -> HsTyDefn name + -> SDoc + +pp_ty_defn pp_hdr (TySynonym { td_synRhs = rhs }) + = hang (ptext (sLit "type") <+> pp_hdr [] <+> equals) + 4 (ppr rhs) + +pp_ty_defn pp_hdr (TyData { td_ND = new_or_data, td_ctxt = L _ context + , td_kindSig = mb_sig + , td_cons = condecls, td_derivs = derivings }) + | null condecls + = ppr new_or_data <+> pp_hdr context <+> pp_sig + + | otherwise + = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig) + 2 (pp_condecls condecls $$ pp_derivings) + where + pp_sig = case mb_sig of + Nothing -> empty + Just kind -> dcolon <+> ppr kind + pp_derivings = case derivings of + Nothing -> empty + Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)] + +instance OutputableBndr name => Outputable (HsTyDefn name) where + ppr d = pp_ty_defn (\_ -> ptext (sLit "Naked HsTyDefn")) d instance Outputable NewOrData where ppr NewType = ptext (sLit "newtype") ppr DataType = ptext (sLit "data") + +pprTyDefnFlavour :: HsTyDefn a -> SDoc +pprTyDefnFlavour (TyData { td_ND = nd }) = ppr nd +pprTyDefnFlavour (TySynonym {}) = ptext (sLit "type") + +pprTyClDeclFlavour :: TyClDecl a -> SDoc +pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") +pprTyClDeclFlavour (TyFamily {}) = ptext (sLit "family") +pprTyClDeclFlavour (TyDecl { tcdTyDefn = defn }) = pprTyDefnFlavour defn +pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type") \end{code} @@ -748,7 +717,7 @@ data ConDecl name , con_explicit :: HsExplicitFlag -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy') - , con_qvars :: [LHsTyVarBndr name] + , con_qvars :: LHsTyVarBndrs name -- ^ Type variables. Depending on 'con_res' this describes the -- following entities -- @@ -765,7 +734,7 @@ data ConDecl name , con_details :: HsConDeclDetails name -- ^ The main payload - , con_res :: ResType name + , con_res :: ResType (LHsType name) -- ^ Result type of the constructor , con_doc :: Maybe LHsDocString @@ -785,16 +754,16 @@ hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map cd_fld_type flds -data ResType name +data ResType ty = ResTyH98 -- Constructor was declared using Haskell 98 syntax - | ResTyGADT (LHsType name) -- Constructor was declared using GADT-style syntax, - -- and here is its result type + | ResTyGADT ty -- Constructor was declared using GADT-style syntax, + -- and here is its result type deriving (Data, Typeable) -instance OutputableBndr name => Outputable (ResType name) where +instance Outputable ty => Outputable (ResType ty) where -- Debugging only - ppr ResTyH98 = ptext (sLit "ResTyH98") - ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty) + ppr ResTyH98 = ptext (sLit "ResTyH98") + ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> ppr ty \end{code} @@ -809,7 +778,7 @@ pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details] where ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc (unLoc con), ppr t2] - ppr_details (PrefixCon tys) = hsep (pprPrefixOcc (unLoc con) : map ppr tys) + ppr_details (PrefixCon tys) = hsep (pprPrefixOcc (unLoc con) : map (pprParendHsType . unLoc) tys) ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs @@ -837,27 +806,60 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG %************************************************************************ \begin{code} -type LInstDecl name = Located (InstDecl name) - type LFamInstDecl name = Located (FamInstDecl name) -type FamInstDecl name = TyClDecl name -- Type or data family instance +data FamInstDecl name + = FamInstDecl + { fid_tycon :: Located name + , fid_pats :: HsWithBndrs [LHsType name] -- ^ Type patterns (with kind and type bndrs) + , fid_defn :: HsTyDefn name -- Type or data family instance + , fid_fvs :: NameSet } + deriving( Typeable, Data ) +type LInstDecl name = Located (InstDecl name) data InstDecl name -- Both class and family instances - = ClsInstDecl - (LHsType name) -- Context => Class Instance-type - -- Using a polytype means that the renamer conveniently - -- figures out the quantified type variables for us. - (LHsBinds name) - [LSig name] -- User-supplied pragmatic info - [LFamInstDecl name] -- Family instances for associated types + = ClsInstD + { cid_poly_ty :: LHsType name -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. + , cid_binds :: LHsBinds name + , cid_sigs :: [LSig name] -- User-supplied pragmatic info + , cid_fam_insts :: [LFamInstDecl name] -- Family instances for associated types + } + + | FamInstD -- type/data family instance + { lid_inst :: FamInstDecl name } + deriving (Data, Typeable) +\end{code} - | FamInstDecl -- type/data family instance - (FamInstDecl name) +Note [Family instance declaration binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A FamInstDecl is a data/type family instance declaration +the fid_pats field is LHS patterns, and the tvs of the HsBSig +tvs are fv(pat_tys), *including* ones that are already in scope - deriving (Data, Typeable) + Eg class C s t where + type F t p :: * + instance C w (a,b) where + type F (a,b) x = x->a + The tcdTyVars of the F decl are {a,b,x}, even though the F decl + is nested inside the 'instance' decl. + + However after the renamer, the uniques will match up: + instance C w7 (a8,b9) where + type F (a8,b9) x10 = x10->a8 + so that we can compare the type patter in the 'instance' decl and + in the associated 'type' decl + +\begin{code} +instance (OutputableBndr name) => Outputable (FamInstDecl name) where + ppr (FamInstDecl { fid_tycon = tycon + , fid_pats = pats + , fid_defn = defn }) + = pp_ty_defn (pp_fam_inst_head tycon pats) defn instance (OutputableBndr name) => Outputable (InstDecl name) where - ppr (ClsInstDecl inst_ty binds sigs ats) + ppr (ClsInstD { cid_poly_ty = inst_ty, cid_binds = binds + , cid_sigs = sigs, cid_fam_insts = ats }) | null sigs && null ats && isEmptyBag binds -- No "where" part = top_matter @@ -868,16 +870,16 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where where top_matter = ptext (sLit "instance") <+> ppr inst_ty - ppr (FamInstDecl decl) = ppr decl + ppr (FamInstD { lid_inst = decl }) = ppr decl -- Extract the declarations of associated types from an instance -instDeclFamInsts :: [LInstDecl name] -> [LTyClDecl name] +instDeclFamInsts :: [LInstDecl name] -> [FamInstDecl name] instDeclFamInsts inst_decls = concatMap do_one inst_decls where - do_one (L _ (ClsInstDecl _ _ _ fam_insts)) = fam_insts - do_one (L loc (FamInstDecl fam_inst)) = [L loc fam_inst] + do_one (L _ (ClsInstD { cid_fam_insts = fam_insts })) = map unLoc fam_insts + do_one (L _ (FamInstD { lid_inst = fam_inst })) = [fam_inst] \end{code} %************************************************************************ @@ -983,7 +985,7 @@ data ForeignImport = -- import of a C entity -- CImport CCallConv -- ccall or stdcall Safety -- interruptible, safe or unsafe - FastString -- name of C header + (Maybe Header) -- name of C header CImportSpec -- details of the C entity deriving (Data, Typeable) @@ -1013,16 +1015,21 @@ instance OutputableBndr name => Outputable (ForeignDecl name) where 2 (dcolon <+> ppr ty) instance Outputable ForeignImport where - ppr (CImport cconv safety header spec) = + ppr (CImport cconv safety mHeader spec) = ppr cconv <+> ppr safety <+> char '"' <> pprCEntity spec <> char '"' where - pp_hdr = if nullFS header then empty else ftext header + pp_hdr = case mHeader of + Nothing -> empty + Just (Header header) -> ftext header pprCEntity (CLabel lbl) = ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl - pprCEntity (CFunction (StaticTarget lbl _)) = - ptext (sLit "static") <+> pp_hdr <+> ppr lbl + pprCEntity (CFunction (StaticTarget lbl _ isFun)) = + ptext (sLit "static") + <+> pp_hdr + <+> (if isFun then empty else ptext (sLit "value")) + <+> ppr lbl pprCEntity (CFunction (DynamicTarget)) = ptext (sLit "dynamic") pprCEntity (CWrapper) = ptext (sLit "wrapper") @@ -1055,10 +1062,10 @@ data RuleDecl name data RuleBndr name = RuleBndr (Located name) - | RuleBndrSig (Located name) (LHsType name) + | RuleBndrSig (Located name) (HsWithBndrs (LHsType name)) deriving (Data, Typeable) -collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name] +collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs (LHsType name)] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] instance OutputableBndr name => Outputable (RuleDecl name) where diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 1dd3c83f31..dcfcb9f8f0 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -32,7 +32,7 @@ import Name import BasicTypes import DataCon import SrcLoc -import Util( dropTail ) +import Util import StaticFlags( opt_PprStyle_Debug ) import Outputable import FastString @@ -106,7 +106,7 @@ noSyntaxTable = [] -- | A Haskell expression. data HsExpr id = HsVar id -- ^ variable - | HsIPVar (IPName id) -- ^ implicit parameter + | HsIPVar HsIPName -- ^ implicit parameter | HsOverLit (HsOverLit id) -- ^ Overloaded literals | HsLit HsLit -- ^ Simple (non-overloaded) literals @@ -473,7 +473,7 @@ ppr_expr (ExplicitList _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitPArr _ exprs) - = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) + = paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (RecordCon con_id _ rbinds) = hang (ppr con_id) 2 (ppr rbinds) @@ -489,7 +489,7 @@ ppr_expr (ExprWithTySigOut expr sig) 4 (ppr sig) ppr_expr (ArithSeq _ info) = brackets (ppr info) -ppr_expr (PArrSeq _ info) = pa_brackets (ppr info) +ppr_expr (PArrSeq _ info) = paBrackets (ppr info) ppr_expr EWildPat = char '_' ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e @@ -554,11 +554,6 @@ pprCmdArg (HsCmdTop cmd _ _ _) instance OutputableBndr id => Outputable (HsCmdTop id) where ppr = pprCmdArg - --- add parallel array brackets around a document --- -pa_brackets :: SDoc -> SDoc -pa_brackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") \end{code} HsSyn records exactly where the user put parens, with HsPar. @@ -880,11 +875,9 @@ data StmtLR idL idR | LetStmt (HsLocalBindsLR idL idR) -- ParStmts only occur in a list/monad comprehension - | ParStmt [([LStmt idL], [idR])] + | ParStmt [ParStmtBlock idL idR] (SyntaxExpr idR) -- Polymorphic `mzip` for monad comprehensions (SyntaxExpr idR) -- The `>>=` operator - (SyntaxExpr idR) -- Polymorphic `return` operator - -- with type (forall a. a -> m a) -- See notes [Monad Comprehensions] -- After renaming, the ids are the binders -- bound by the stmts and used after themp @@ -948,6 +941,13 @@ data TransForm -- The 'f' below is the 'using' function, 'e' is the by function = ThenForm -- then f or then f by e (depending on trS_by) | GroupForm -- then group using f or then group by e using f (depending on trS_by) deriving (Data, Typeable) + +data ParStmtBlock idL idR + = ParStmtBlock + [LStmt idL] + [idR] -- The variables to be returned + (SyntaxExpr idR) -- The return operator + deriving( Data, Typeable ) \end{code} Note [The type of bind in Stmts] @@ -1087,6 +1087,10 @@ In any other context than 'MonadComp', the fields for most of these \begin{code} +instance (OutputableBndr idL, OutputableBndr idR) + => Outputable (ParStmtBlock idL idR) where + ppr (ParStmtBlock stmts _ _) = interpp'SP stmts + instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where ppr stmt = pprStmt stmt @@ -1095,11 +1099,10 @@ pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr e pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr] pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] pprStmt (ExprStmt expr _ _ _) = ppr expr -pprStmt (ParStmt stmtss _ _ _) = hsep (map doStmts stmtss) - where doStmts stmts = ptext (sLit "| ") <> ppr stmts +pprStmt (ParStmt stmtss _ _) = sep (punctuate (ptext (sLit " | ")) (map ppr stmtss)) pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form }) - = sep (ppr_lc_stmts stmts ++ [pprTransStmt by using form]) + = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , recS_later_ids = later_ids }) @@ -1132,7 +1135,7 @@ pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts pprDo ListComp stmts = brackets $ pprComp stmts -pprDo PArrComp stmts = pa_brackets $ pprComp stmts +pprDo PArrComp stmts = paBrackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt @@ -1143,16 +1146,17 @@ ppr_do_stmts stmts = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts)) <+> rbrace -ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc] -ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts] - pprComp :: OutputableBndr id => [LStmt id] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | not (null quals) , L _ (LastStmt body _) <- last quals - = hang (ppr body <+> char '|') 2 (interpp'SP (dropTail 1 quals)) + = hang (ppr body <+> char '|') 2 (pprQuals (dropTail 1 quals)) | otherwise - = pprPanic "pprComp" (interpp'SP quals) + = pprPanic "pprComp" (pprQuals quals) + +pprQuals :: OutputableBndr id => [LStmt id] -> SDoc +-- Show list comprehension qualifiers separated by commas +pprQuals quals = interpp'SP quals \end{code} %************************************************************************ diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index ee75414d4c..7163cbfe10 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -12,6 +12,7 @@ module HsImpExp where import Module ( ModuleName ) import HsDoc ( HsDocString ) +import OccName ( HasOccName(..), isTcOcc, isSymOcc ) import Outputable import FastString @@ -57,7 +58,7 @@ simpleImportDecl mn = ImportDecl { \end{code} \begin{code} -instance (OutputableBndr name) => Outputable (ImportDecl name) where +instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) where ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe , ideclQualified = qual, ideclImplicit = implicit @@ -134,12 +135,20 @@ ieNames (IEDocNamed _ ) = [] \end{code} \begin{code} -instance (OutputableBndr name, Outputable name) => Outputable (IE name) where + +pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc +pprImpExp name = type_pref <+> pprPrefixOcc name + where + occ = occName name + type_pref | isTcOcc occ && isSymOcc occ = ptext (sLit "type") + | otherwise = empty + +instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where ppr (IEVar var) = pprPrefixOcc var - ppr (IEThingAbs thing) = ppr thing - ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"] + ppr (IEThingAbs thing) = pprImpExp thing + ppr (IEThingAll thing) = hcat [pprImpExp thing, text "(..)"] ppr (IEThingWith thing withs) - = pprPrefixOcc thing <> parens (fsep (punctuate comma (map pprPrefixOcc withs))) + = pprImpExp thing <> parens (fsep (punctuate comma (map pprImpExp withs))) ppr (IEModuleContents mod') = ptext (sLit "module") <+> ppr mod' ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">") diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 3180d24152..64bda890db 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -131,8 +131,8 @@ data Pat id (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) ------------ Pattern type signatures --------------- - | SigPatIn (LPat id) -- Pattern with a type signature - (LHsType id) + | SigPatIn (LPat id) -- Pattern with a type signature + (HsWithBndrs (LHsType id)) -- Signature can bind both kind and type vars | SigPatOut (LPat id) -- Pattern with a type signature Type @@ -246,7 +246,7 @@ pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat] pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ParPat pat) = parens (ppr pat) pprPat (ListPat pats _) = brackets (interpp'SP pats) -pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) +pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) pprPat (ConPatIn con details) = pprUserCon con details @@ -292,11 +292,6 @@ instance (OutputableBndr id, Outputable arg) ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg, hsRecPun = pun }) = ppr f <+> (ppUnless pun $ equals <+> ppr arg) - --- add parallel array brackets around a document --- -pabrackets :: SDoc -> SDoc -pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") \end{code} diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index a8ae81e935..ba1794d281 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -46,6 +46,7 @@ import HsUtils import HsDoc -- others: +import OccName ( HasOccName ) import IfaceSyn ( IfaceBinding ) import Outputable import SrcLoc @@ -97,7 +98,7 @@ data HsExtCore name -- Read from Foo.hcr instance Outputable Char where ppr c = text [c] -instance (OutputableBndr name) +instance (OutputableBndr name, HasOccName name) => Outputable (HsModule name) where ppr (HsModule Nothing _ imports decls _ mbDoc) diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index accb3ddc14..a57c48a1c6 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -6,40 +6,36 @@ HsTypes: Abstract syntax: user-defined types \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# LANGUAGE DeriveDataTypeable #-} module HsTypes ( - HsType(..), LHsType, HsKind, LHsKind, - HsTyVarBndr(..), LHsTyVarBndr, - HsTupleSort(..), HsExplicitFlag(..), - HsContext, LHsContext, - HsQuasiQuote(..), + HsType(..), LHsType, HsKind, LHsKind, + HsTyVarBndr(..), LHsTyVarBndr, + LHsTyVarBndrs(..), + HsWithBndrs(..), + HsTupleSort(..), HsExplicitFlag(..), + HsContext, LHsContext, + HsQuasiQuote(..), HsTyWrapper(..), + HsTyLit(..), + HsIPName(..), hsIPNameFS, - LBangType, BangType, HsBang(..), + LBangType, BangType, HsBang(..), getBangType, getBangStrictness, - ConDeclField(..), pprConDeclFields, - - mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, - hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName, - hsTyVarKind, hsLTyVarKind, hsTyVarNameKind, - hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, - splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, - splitHsForAllTy, splitLHsForAllTy, + ConDeclField(..), pprConDeclFields, + + mkHsQTvs, hsQTvBndrs, + mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, + hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames, + hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, + splitLHsInstDeclTy_maybe, splitHsClassTy_maybe, splitLHsClassTy_maybe, splitHsFunType, - splitHsAppTys, mkHsAppTys, mkHsOpTy, + splitHsAppTys, mkHsAppTys, mkHsOpTy, - -- Printing - pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, + -- Printing + pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, ) where import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) @@ -47,6 +43,8 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import HsLit import NameSet( FreeVars ) +import Name( Name ) +import RdrName( RdrName ) import Type import HsDoc import BasicTypes @@ -60,16 +58,16 @@ import Data.Data %************************************************************************ -%* * - Quasi quotes; used in types and elsewhere -%* * +%* * + Quasi quotes; used in types and elsewhere +%* * %************************************************************************ \begin{code} data HsQuasiQuote id = HsQuasiQuote - id -- The quasi-quoter - SrcSpan -- The span of the enclosed string - FastString -- The enclosed string + id -- The quasi-quoter + SrcSpan -- The span of the enclosed string + FastString -- The enclosed string deriving (Data, Typeable) instance OutputableBndr id => Outputable (HsQuasiQuote id) where @@ -83,14 +81,14 @@ ppr_qq (HsQuasiQuote quoter _ quote) = %************************************************************************ -%* * +%* * \subsection{Bang annotations} -%* * +%* * %************************************************************************ \begin{code} type LBangType name = Located (BangType name) -type BangType name = HsType name -- Bangs are in the HsType data type +type BangType name = HsType name -- Bangs are in the HsType data type getBangType :: LHsType a -> LHsType a getBangType (L _ (HsBangTy _ ty)) = ty @@ -103,13 +101,24 @@ getBangStrictness _ = HsNoBang %************************************************************************ -%* * +%* * \subsection{Data types} -%* * +%* * %************************************************************************ This is the syntax for types as seen in type signatures. +Note [HsBSig binder lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a binder (or pattern) decoarated with a type or kind, + \ (x :: a -> a). blah + forall (a :: k -> *) (b :: k). blah +Then we use a LHsBndrSig on the binder, so that the +renamer can decorate it with the variables bound +by the pattern ('a' in the first example, 'k' in the second), +assuming that neither of them is in scope already +See also Note [Kind and type-variable binders] in RnTypes + \begin{code} type LHsContext name = Located (HsContext name) @@ -119,59 +128,120 @@ type LHsType name = Located (HsType name) type HsKind name = HsType name type LHsKind name = Located (HsKind name) +type LHsTyVarBndr name = Located (HsTyVarBndr name) + +data LHsTyVarBndrs name + = HsQTvs { hsq_kvs :: [Name] -- Kind variables + , hsq_tvs :: [LHsTyVarBndr name] -- Type variables + -- See Note [HsForAllTy tyvar binders] + } + deriving( Data, Typeable ) + +mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName +-- Just at RdrName because in the Name variant we should know just +-- what the kind-variable binders are; and we don't +mkHsQTvs tvs = HsQTvs { hsq_kvs = panic "mkHsQTvs", hsq_tvs = tvs } + +emptyHsQTvs :: LHsTyVarBndrs name -- Use only when you know there are no kind binders +emptyHsQTvs = HsQTvs { hsq_kvs = [], hsq_tvs = [] } + +hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name] +hsQTvBndrs = hsq_tvs + +data HsWithBndrs thing + = HsWB { hswb_cts :: thing -- Main payload (type or list of types) + , hswb_kvs :: [Name] -- Kind vars + , hswb_tvs :: [Name] -- Type vars + } + deriving (Data, Typeable) + +mkHsWithBndrs :: thing -> HsWithBndrs thing +mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = panic "mkHsTyWithBndrs:kvs" + , hswb_tvs = panic "mkHsTyWithBndrs:tvs" } + + +-- | These names are used eary on to store the names of implicit +-- parameters. They completely disappear after type-checking. +newtype HsIPName = HsIPName FastString-- ?x + deriving( Eq, Data, Typeable ) + +hsIPNameFS :: HsIPName -> FastString +hsIPNameFS (HsIPName n) = n + +instance Outputable HsIPName where + ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters + +instance OutputableBndr HsIPName where + pprBndr _ n = ppr n -- Simple for now + pprInfixOcc n = ppr n + pprPrefixOcc n = ppr n + + +data HsTyVarBndr name + = UserTyVar -- No explicit kinding + name -- See Note [Printing KindedTyVars] + + | KindedTyVar + name + (LHsKind name) -- The user-supplied kind signature + -- *** NOTA BENE *** A "monotype" in a pragma can have + -- for-alls in it, (mostly to do with dictionaries). These + -- must be explicitly Kinded. + deriving (Data, Typeable) + + data HsType name - = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way - -- the user wrote it originally, so that the printer can - -- print it as the user wrote it - [LHsTyVarBndr name] -- With ImplicitForAll, this is the empty list - -- until the renamer fills in the variables - (LHsContext name) - (LHsType name) - - | HsTyVar name -- Type variable, type constructor, or data constructor + = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way + -- the user wrote it originally, so that the printer can + -- print it as the user wrote it + (LHsTyVarBndrs name) + (LHsContext name) + (LHsType name) + + | HsTyVar name -- Type variable, type constructor, or data constructor -- see Note [Promotions (HsTyVar)] - | HsAppTy (LHsType name) - (LHsType name) + | HsAppTy (LHsType name) + (LHsType name) - | HsFunTy (LHsType name) -- function type - (LHsType name) + | HsFunTy (LHsType name) -- function type + (LHsType name) - | HsListTy (LHsType name) -- Element type + | HsListTy (LHsType name) -- Element type - | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] + | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] - | HsTupleTy HsTupleSort - [LHsType name] -- Element types (length gives arity) + | HsTupleTy HsTupleSort + [LHsType name] -- Element types (length gives arity) - | HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) + | HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) - | HsParTy (LHsType name) -- See Note [Parens in HsSyn] in HsExpr - -- Parenthesis preserved for the precedence re-arrangement in RnTypes - -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! + | HsParTy (LHsType name) -- See Note [Parens in HsSyn] in HsExpr + -- Parenthesis preserved for the precedence re-arrangement in RnTypes + -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! - | HsIParamTy (IPName name) -- (?x :: ty) + | HsIParamTy HsIPName -- (?x :: ty) (LHsType name) -- Implicit parameters as they occur in contexts | HsEqTy (LHsType name) -- ty1 ~ ty2 (LHsType name) -- Always allowed even without TypeOperators, and has special kinding rule - | HsKindSig (LHsType name) -- (ty :: kind) - (LHsKind name) -- A type with a kind signature + | HsKindSig (LHsType name) -- (ty :: kind) + (LHsKind name) -- A type with a kind signature - | HsQuasiQuoteTy (HsQuasiQuote name) + | HsQuasiQuoteTy (HsQuasiQuote name) - | HsSpliceTy (HsSplice name) - FreeVars -- Variables free in the splice (filled in by renamer) - PostTcKind + | HsSpliceTy (HsSplice name) + FreeVars -- Variables free in the splice (filled in by renamer) + PostTcKind | HsDocTy (LHsType name) LHsDocString -- A documented type - | HsBangTy HsBang (LHsType name) -- Bang-style type annotations - | HsRecTy [ConDeclField name] -- Only in data type declarations + | HsBangTy HsBang (LHsType name) -- Bang-style type annotations + | HsRecTy [ConDeclField name] -- Only in data type declarations - | HsCoreTy Type -- An escape hatch for tunnelling a *closed* - -- Core Type through HsSyn. + | HsCoreTy Type -- An escape hatch for tunnelling a *closed* + -- Core Type through HsSyn. | HsExplicitListTy -- A promoted explicit list PostTcKind -- See Note [Promoted lists and tuples] @@ -181,9 +251,17 @@ data HsType name [PostTcKind] -- See Note [Promoted lists and tuples] [LHsType name] + | HsTyLit HsTyLit -- A promoted numeric literal. + | HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output deriving (Data, Typeable) + +data HsTyLit + = HsNumTy Integer + | HsStrTy FastString + deriving (Data, Typeable) + data HsTyWrapper = WpKiApps [Kind] -- kind instantiation: [] k1 k2 .. kn deriving (Data, Typeable) @@ -195,6 +273,22 @@ mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 \end{code} +Note [HsForAllTy tyvar binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After parsing: + * Implicit => empty + Explicit => the varibles the user wrote + +After renaming + * Implicit => the *type* variables free in the type + Explicit => the variables the user wrote (renamed) + +The kind variables bound in the hsq_kvs field come both + a) from the kind signatures on the kind vars (eg k1) + b) from the scope of the forall (eg k2) +Example: f :: forall (a::k1) b. T a (b::k2) + + Note [Unit tuples] ~~~~~~~~~~~~~~~~~~ Consider the type @@ -276,42 +370,42 @@ data HsTupleSort = HsUnboxedTuple data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable) -data ConDeclField name -- Record fields have Haddoc docs on them +data ConDeclField name -- Record fields have Haddoc docs on them = ConDeclField { cd_fld_name :: Located name, - cd_fld_type :: LBangType name, - cd_fld_doc :: Maybe LHsDocString } + cd_fld_type :: LBangType name, + cd_fld_doc :: Maybe LHsDocString } deriving (Data, Typeable) ----------------------- -- Combine adjacent for-alls. -- The following awkward situation can happen otherwise: --- f :: forall a. ((Num a) => Int) +-- f :: forall a. ((Num a) => Int) -- might generate HsForAll (Just [a]) [] (HsForAll Nothing [Num a] t) -- Then a isn't discovered as ambiguous, and we abstract the AbsBinds wrt [] -- but the export list abstracts f wrt [a]. Disaster. -- -- A valid type must have one for-all at the top of the type, or of the fn arg types -mkImplicitHsForAllTy :: LHsContext name -> LHsType name -> HsType name -mkExplicitHsForAllTy :: [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name -mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty +mkImplicitHsForAllTy :: LHsContext RdrName -> LHsType RdrName -> HsType RdrName +mkExplicitHsForAllTy :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName +mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty -mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name +mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName -- Smart constructor for HsForAllTy mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty -mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty +mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp (mkHsQTvs tvs) ctxt ty -- mk_forall_ty makes a pure for-all type (no context) -mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name -mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty -mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty -mk_forall_ty exp tvs ty = HsForAllTy exp tvs (noLoc []) ty - -- Even if tvs is empty, we still make a HsForAll! - -- In the Implicit case, this signals the place to do implicit quantification - -- In the Explicit case, it prevents implicit quantification - -- (see the sigtype production in Parser.y.pp) - -- so that (forall. ty) isn't implicitly quantified +mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsType RdrName -> HsType RdrName +mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty +mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 qtvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty +mk_forall_ty exp tvs ty = HsForAllTy exp (mkHsQTvs tvs) (noLoc []) ty + -- Even if tvs is empty, we still make a HsForAll! + -- In the Implicit case, this signals the place to do implicit quantification + -- In the Explicit case, it prevents implicit quantification + -- (see the sigtype production in Parser.y.pp) + -- so that (forall. ty) isn't implicitly quantified plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag Implicit `plus` Implicit = Implicit @@ -323,106 +417,61 @@ hsExplicitTvs (L _ (HsForAllTy Explicit tvs _ _)) = hsLTyVarNames tvs hsExplicitTvs _ = [] --------------------- -type LHsTyVarBndr name = Located (HsTyVarBndr name) - -data HsTyVarBndr name - = UserTyVar -- No explicit kinding - name -- See Note [Printing KindedTyVars] - PostTcKind - - | KindedTyVar - name - (LHsKind name) -- The user-supplied kind signature - PostTcKind - -- *** NOTA BENE *** A "monotype" in a pragma can have - -- for-alls in it, (mostly to do with dictionaries). These - -- must be explicitly Kinded. - deriving (Data, Typeable) - hsTyVarName :: HsTyVarBndr name -> name -hsTyVarName (UserTyVar n _) = n -hsTyVarName (KindedTyVar n _ _) = n - -hsTyVarKind :: HsTyVarBndr name -> Kind -hsTyVarKind (UserTyVar _ k) = k -hsTyVarKind (KindedTyVar _ _ k) = k - -hsLTyVarKind :: LHsTyVarBndr name -> Kind -hsLTyVarKind = hsTyVarKind . unLoc - -hsTyVarNameKind :: HsTyVarBndr name -> (name, Kind) -hsTyVarNameKind (UserTyVar n k) = (n,k) -hsTyVarNameKind (KindedTyVar n _ k) = (n,k) +hsTyVarName (UserTyVar n) = n +hsTyVarName (KindedTyVar n _) = n hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc -hsTyVarNames :: [HsTyVarBndr name] -> [name] -hsTyVarNames tvs = map hsTyVarName tvs +hsLTyVarNames :: LHsTyVarBndrs name -> [name] +-- Type variables only +hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs) -hsLTyVarNames :: [LHsTyVarBndr name] -> [name] -hsLTyVarNames = map hsLTyVarName +hsLKiTyVarNames :: LHsTyVarBndrs Name -> [Name] +-- Kind and type variables +hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) + = kvs ++ map hsLTyVarName tvs hsLTyVarLocName :: LHsTyVarBndr name -> Located name hsLTyVarLocName = fmap hsTyVarName -hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name] -hsLTyVarLocNames = map hsLTyVarLocName - -replaceTyVarName :: (Monad m) => HsTyVarBndr name1 -> name2 -- new type name - -> (LHsKind name1 -> m (LHsKind name2)) -- kind renaming - -> m (HsTyVarBndr name2) -replaceTyVarName (UserTyVar _ k) n' _ = return $ UserTyVar n' k -replaceTyVarName (KindedTyVar _ k tck) n' rn = do - k' <- rn k - return $ KindedTyVar n' k' tck - -replaceLTyVarName :: (Monad m) => LHsTyVarBndr name1 -> name2 - -> (LHsKind name1 -> m (LHsKind name2)) - -> m (LHsTyVarBndr name2) -replaceLTyVarName (L loc n1) n2 rn = replaceTyVarName n1 n2 rn >>= return . L loc +hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name] +hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs) \end{code} \begin{code} splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n]) splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) -splitHsAppTys f as = (f,as) +splitHsAppTys f as = (f,as) mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) mkHsAppTys fun_ty (arg_ty:arg_tys) = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys where - mk_app fun arg = HsAppTy (noLoc fun) arg + mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of the application; -- they are never used -splitHsInstDeclTy_maybe :: HsType name - -> Maybe ([LHsTyVarBndr name], HsContext name, name, [LHsType name]) -splitHsInstDeclTy_maybe ty - = fmap (\(tvs, cxt, L _ n, tys) -> (tvs, cxt, n, tys)) $ splitLHsInstDeclTy_maybe (noLoc ty) - splitLHsInstDeclTy_maybe :: LHsType name - -> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name]) - -- Split up an instance decl type, returning the pieces + -> Maybe (LHsTyVarBndrs name, HsContext name, Located name, [LHsType name]) + -- Split up an instance decl type, returning the pieces splitLHsInstDeclTy_maybe inst_ty = do let (tvs, cxt, ty) = splitLHsForAllTy inst_ty (cls, tys) <- splitLHsClassTy_maybe ty return (tvs, cxt, cls, tys) -splitHsForAllTy :: HsType name -> ([LHsTyVarBndr name], HsContext name, HsType name) -splitHsForAllTy ty = case splitLHsForAllTy (noLoc ty) of (tvs, cxt, L _ ty) -> (tvs, cxt, ty) - splitLHsForAllTy :: LHsType name - -> ([LHsTyVarBndr name], HsContext name, LHsType name) + -> (LHsTyVarBndrs name, HsContext name, LHsType name) splitLHsForAllTy poly_ty = case unLoc poly_ty of HsParTy ty -> splitLHsForAllTy ty HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty) - _ -> ([], [], poly_ty) + _ -> (emptyHsQTvs, [], poly_ty) -- The type vars should have been computed by now, even if they were implicit splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name]) @@ -448,42 +497,51 @@ splitLHsClassTy_maybe ty -- Splits HsType into the (init, last) parts -- Breaks up any parens in the result type: --- splitHsFunType (a -> (b -> c)) = ([a,b], c) +-- splitHsFunType (a -> (b -> c)) = ([a,b], c) splitHsFunType :: LHsType name -> ([LHsType name], LHsType name) splitHsFunType (L _ (HsFunTy x y)) = (x:args, res) where (args, res) = splitHsFunType y splitHsFunType (L _ (HsParTy ty)) = splitHsFunType ty -splitHsFunType other = ([], other) +splitHsFunType other = ([], other) \end{code} %************************************************************************ -%* * +%* * \subsection{Pretty printing} -%* * +%* * %************************************************************************ \begin{code} instance (OutputableBndr name) => Outputable (HsType name) where ppr ty = pprHsType ty +instance Outputable HsTyLit where + ppr = ppr_tylit + +instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where + ppr qtvs = interppSP (hsQTvBndrs qtvs) + instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where - ppr (UserTyVar name _) = ppr name - ppr (KindedTyVar name kind _) = parens $ hsep [ppr name, dcolon, ppr kind] + ppr (UserTyVar name) = ppr name + ppr (KindedTyVar name kind) = parens $ hsep [ppr name, dcolon, ppr kind] + +instance (Outputable thing) => Outputable (HsWithBndrs thing) where + ppr (HsWB { hswb_cts = ty }) = ppr ty -pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> SDoc -pprHsForAll exp tvs cxt +pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc +pprHsForAll exp qtvs cxt | show_forall = forall_part <+> pprHsContext (unLoc cxt) | otherwise = pprHsContext (unLoc cxt) where show_forall = opt_PprStyle_Debug - || (not (null tvs) && is_explicit) + || (not (null (hsQTvBndrs qtvs)) && is_explicit) is_explicit = case exp of {Explicit -> True; Implicit -> False} - forall_part = ptext (sLit "forall") <+> interppSP tvs <> dot + forall_part = ptext (sLit "forall") <+> ppr qtvs <> dot pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc -pprHsContext [] = empty +pprHsContext [] = empty pprHsContext [L _ pred] = ppr pred <+> darrow pprHsContext cxt = ppr_hs_context cxt <+> darrow @@ -495,8 +553,8 @@ pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, - cd_fld_doc = doc }) - = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc + cd_fld_doc = doc }) + = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc \end{code} Note [Printing KindedTyVars] @@ -520,12 +578,12 @@ pREC_OP = 2 -- Used for arg of any infix operator pREC_CON = 3 -- Used for arg of type applicn: -- always parenthesise unless atomic -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> SDoc -> SDoc -- Wrap in parens if (ctxt >= op) +maybeParen :: Int -- Precedence of context + -> Int -- Precedence of top-level operator + -> SDoc -> SDoc -- Wrap in parens if (ctxt >= op) maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - + | otherwise = p + -- printing works more-or-less as for Types pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc @@ -538,7 +596,7 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty -- (b) Drop top-level for-all type variables in user style -- since they are implicit in Haskell prepare :: PprStyle -> HsType name -> HsType name -prepare sty (HsParTy ty) = prepare sty (unLoc ty) +prepare sty (HsParTy ty) = prepare sty (unLoc ty) prepare _ ty = ty ppr_mono_lty :: (OutputableBndr name) => Int -> LHsType name -> SDoc @@ -549,7 +607,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) = maybeParen ctxt_prec pREC_FUN $ sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty] -ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr ty +ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty pREC_CON ty ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds ppr_mono_ty _ (HsTyVar name) = ppr name @@ -559,13 +617,14 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) HsUnboxedTuple -> UnboxedTuple _ -> BoxedTuple ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind) -ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys) ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys) +ppr_mono_ty _ (HsTyLit t) = ppr_tylit t ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty) = ppr_mono_ty ctxt_prec ty @@ -597,7 +656,7 @@ ppr_mono_ty _ (HsParTy ty) = parens (ppr_mono_lty pREC_TOP ty) -- Put the parens in where the user did -- But we still use the precedence stuff to add parens because - -- toHsType doesn't put in any HsParTys, so we may still need them + -- toHsType doesn't put in any HsParTys, so we may still need them ppr_mono_ty ctxt_prec (HsDocTy ty doc) = maybeParen ctxt_prec pREC_OP $ @@ -609,14 +668,15 @@ ppr_mono_ty ctxt_prec (HsDocTy ty doc) ppr_fun_ty :: (OutputableBndr name) => Int -> LHsType name -> LHsType name -> SDoc ppr_fun_ty ctxt_prec ty1 ty2 = let p1 = ppr_mono_lty pREC_FUN ty1 - p2 = ppr_mono_lty pREC_TOP ty2 + p2 = ppr_mono_lty pREC_TOP ty2 in maybeParen ctxt_prec pREC_FUN $ sep [p1, ptext (sLit "->") <+> p2] -------------------------- -pabrackets :: SDoc -> SDoc -pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") +ppr_tylit :: HsTyLit -> SDoc +ppr_tylit (HsNumTy i) = integer i +ppr_tylit (HsStrTy s) = text (show s) \end{code} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 293f5b05a6..32fe487609 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -33,7 +33,7 @@ module HsUtils( nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, - mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, + mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, -- Bindings mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, @@ -66,10 +66,9 @@ module HsUtils( collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectStmtsBinders, collectLStmtBinders, collectStmtBinders, - collectSigTysFromPats, collectSigTysFromPat, hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders, - hsForeignDeclsBinders, hsGroupBinders, + hsForeignDeclsBinders, hsGroupBinders, hsFamInstBinders, -- Collecting implicit binders lStmtsImplicits, hsValBindsImplicits, lPatImplicits @@ -94,9 +93,8 @@ import SrcLoc import FastString import Util import Bag - +import Outputable import Data.Either -import Data.Maybe \end{code} @@ -218,7 +216,8 @@ mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL id mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR emptyTransStmt :: StmtLR idL idR -emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = [] +emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" + , trS_stmts = [], trS_bndrs = [] , trS_by = Nothing, trS_using = noLoc noSyntaxExpr , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr , trS_fmap = noSyntaxExpr } @@ -267,8 +266,9 @@ mkHsString :: String -> HsLit mkHsString s = HsString (mkFastString s) ------------- -userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)] -userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ] +userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)] +-- Caller sets location +userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] \end{code} @@ -536,8 +536,8 @@ collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (LetStmt binds) = collectLocalBinders binds collectStmtBinders (ExprStmt {}) = [] collectStmtBinders (LastStmt {}) = [] -collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders - $ concatMap fst xs +collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders + $ [s | ParStmtBlock ss _ _ <- xs, s <- ss] collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss @@ -622,9 +622,10 @@ hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name] -- We need to look at instance declarations too, -- because their associated types may bind data constructors hsTyClDeclsBinders tycl_decls inst_decls - = [n | d <- instDeclFamInsts inst_decls ++ concat tycl_decls - , L _ n <- hsLTyClDeclBinders d] + = map unLoc (concatMap (concatMap hsLTyClDeclBinders) tycl_decls ++ + concatMap (hsInstDeclBinders . unLoc) inst_decls) +------------------- hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs. -- The first one is guaranteed to be the name of the decl. For record fields @@ -632,24 +633,37 @@ hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] -- occurence. We use the equality to filter out duplicate field names hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d +------------------- hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name] hsTyClDeclBinders (TyFamily {tcdLName = name}) = [name] hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name] -hsTyClDeclBinders (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}) +hsTyClDeclBinders (ClassDecl { tcdLName = cls_name, tcdSigs = sigs + , tcdATs = ats, tcdATDefs = fam_insts }) = cls_name : - concatMap hsLTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns] - -hsTyClDeclBinders (TySynonym {tcdLName = name, tcdTyPats = mb_pats }) - | isJust mb_pats = [] - | otherwise = [name] - -- See Note [Binders in family instances] - -hsTyClDeclBinders (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats }) - | isJust mb_pats = hsConDeclsBinders cons - | otherwise = tc_name : hsConDeclsBinders cons + concatMap hsLTyClDeclBinders ats ++ + concatMap (hsFamInstBinders . unLoc) fam_insts ++ + [n | L _ (TypeSig ns _) <- sigs, n <- ns] + +hsTyClDeclBinders (TyDecl { tcdLName = name, tcdTyDefn = defn }) + = name : hsTyDefnBinders defn + +------------------- +hsInstDeclBinders :: Eq name => InstDecl name -> [Located name] +hsInstDeclBinders (ClsInstD { cid_fam_insts = fis }) = concatMap (hsFamInstBinders . unLoc) fis +hsInstDeclBinders (FamInstD { lid_inst = fi }) = hsFamInstBinders fi + +------------------- +hsFamInstBinders :: Eq name => FamInstDecl name -> [Located name] +hsFamInstBinders (FamInstDecl { fid_defn = defn }) = hsTyDefnBinders defn + +------------------- +hsTyDefnBinders :: Eq name => HsTyDefn name -> [Located name] +hsTyDefnBinders (TySynonym {}) = [] +hsTyDefnBinders (TyData { td_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] +------------------- hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name] -- See hsTyClDeclBinders for what this does -- The function is boringly complicated because of the records @@ -698,8 +712,7 @@ lStmtsImplicits = hs_lstmts hs_stmt (LetStmt binds) = hs_local_binds binds hs_stmt (ExprStmt {}) = emptyNameSet hs_stmt (LastStmt {}) = emptyNameSet - hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs - + hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss @@ -752,34 +765,3 @@ lPatImplicits = hs_lpat pat_explicit = maybe True (i<) (rec_dotdot fs)] details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2 \end{code} - - -%************************************************************************ -%* * - Collecting type signatures from patterns -%* * -%************************************************************************ - -\begin{code} -collectSigTysFromPats :: [InPat name] -> [LHsType name] -collectSigTysFromPats pats = foldr collect_sig_lpat [] pats - -collectSigTysFromPat :: InPat name -> [LHsType name] -collectSigTysFromPat pat = collect_sig_lpat pat [] - -collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name] -collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc - -collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name] -collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc) - -collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc -collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc -collect_sig_pat (AsPat _ pat) acc = collect_sig_lpat pat acc -collect_sig_pat (ParPat pat) acc = collect_sig_lpat pat acc -collect_sig_pat (ListPat pats _) acc = foldr collect_sig_lpat acc pats -collect_sig_pat (PArrPat pats _) acc = foldr collect_sig_lpat acc pats -collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats -collect_sig_pat (ConPatIn _ ps) acc = foldr collect_sig_lpat acc (hsConPatArgs ps) -collect_sig_pat _ acc = acc -- Literals, vars, wildcard -\end{code} diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index d821c13fdc..201e7bb900 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -19,11 +19,11 @@ module BinIface ( #include "HsVersions.h" import TcRnMonad -import TyCon (TyCon, tyConName, tupleTyConSort, tupleTyConArity, isTupleTyCon, tyConIP_maybe) +import TyCon (TyCon, tyConName, tupleTyConSort, tupleTyConArity, isTupleTyCon) import DataCon (dataConName, dataConWorkId, dataConTyCon) -import IParam (ipFastString, ipTyConName) import PrelInfo (wiredInThings, basicKnownKeyNames) import Id (idName, isDataConWorkId_maybe) +import CoreSyn (DFunArg(..)) import TysWiredIn import IfaceEnv import HscTypes @@ -39,7 +39,6 @@ import DynFlags import UniqFM import UniqSupply import CostCentre -import StaticFlags import Panic import Binary import SrcLoc @@ -51,6 +50,7 @@ import Outputable import Platform import FastString import Constants +import Util import Data.Bits import Data.Char @@ -85,7 +85,7 @@ readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do let printer :: SDoc -> IO () printer = case traceBinIFaceReading of - TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle + TraceBinIFaceReading -> \sd -> log_action dflags dflags SevOutput noSrcSpan defaultDumpStyle sd QuietBinIFaceReading -> \_ -> return () wantedGot :: Outputable a => String -> a -> a -> IO () wantedGot what wanted got = @@ -123,7 +123,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do -- Check the interface file version and ways. check_ver <- get bh - let our_ver = show opt_HiVersion + let our_ver = show hiVersion wantedGot "Version" our_ver check_ver errorOnMismatch "mismatched interface file versions" our_ver check_ver @@ -173,7 +173,7 @@ writeBinIface dflags hi_path mod_iface = do else Binary.put_ bh (0 :: Word64) -- The version and way descriptor go next - put_ bh (show opt_HiVersion) + put_ bh (show hiVersion) let way_descr = getWayDescr dflags put_ bh way_descr @@ -315,7 +315,7 @@ knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames] -- See Note [Symbol table representation of names] putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () -putName dict BinSymbolTable{ +putName _dict BinSymbolTable{ bin_symtab_map = symtab_map_ref, bin_symtab_next = symtab_next } bh name | name `elemUFM` knownKeyNamesMap @@ -326,10 +326,6 @@ putName dict BinSymbolTable{ = case wiredInNameTyThing_maybe name of Just (ATyCon tc) | isTupleTyCon tc -> putTupleName_ bh tc 0 - | Just ip <- tyConIP_maybe tc -> do - off <- allocateFastString dict (ipFastString ip) - -- MASSERT(off < 2^(30 :: Int)) - put_ bh (0xC0000000 .|. off) Just (ADataCon dc) | let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 1 Just (AnId x) @@ -361,7 +357,7 @@ putTupleName_ bh tc thing_tag getSymtabName :: NameCacheUpdater -> Dictionary -> SymbolTable -> BinHandle -> IO Name -getSymtabName ncu dict symtab bh = do +getSymtabName _ncu _dict symtab bh = do i <- get bh case i .&. 0xC0000000 of 0x00000000 -> return $! symtab ! fromIntegral (i :: Word32) @@ -384,7 +380,6 @@ getSymtabName ncu dict symtab bh = do _ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i) thing_tag = (i .&. 0x0CFFFFFF) `shiftR` 26 arity = fromIntegral (i .&. 0x03FFFFFF) - 0xC0000000 -> liftM ipTyConName $ updateNameCache ncu $ flip allocateIPName (dict ! fromIntegral (i .&. 0x3FFFFFFF)) _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) data BinSymbolTable = BinSymbolTable { @@ -425,7 +420,6 @@ data BinDictionary = BinDictionary { -- All the binary instances -- BasicTypes -{-! for IPName derive: Binary !-} {-! for Fixity derive: Binary !-} {-! for FixityDirection derive: Binary !-} {-! for Boxity derive: Binary !-} @@ -824,11 +818,6 @@ instance Binary Fixity where ab <- get bh return (Fixity aa ab) -instance (Binary name) => Binary (IPName name) where - put_ bh (IPName aa) = put_ bh aa - get bh = do aa <- get bh - return (IPName aa) - ------------------------------------------------------------------------- -- Types from: Demand ------------------------------------------------------------------------- @@ -998,33 +987,14 @@ instance Binary IfaceType where putByte bh 3 put_ bh ag put_ bh ah - - -- Simple compression for common cases of TyConApp - put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6 - put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7 - put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8 - put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty } - -- Unit tuple and pairs - put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) = putByte bh 10 - put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) - = do { putByte bh 11; put_ bh t1; put_ bh t2 } - -- Kind cases - put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12 - put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13 - put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14 - put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15 - put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16 - put_ bh (IfaceTyConApp IfaceConstraintKindTc []) = putByte bh 17 - put_ bh (IfaceTyConApp IfaceSuperKindTc []) = putByte bh 18 - put_ bh (IfaceCoConApp cc tys) - = do { putByte bh 19; put_ bh cc; put_ bh tys } - - -- Generic cases - put_ bh (IfaceTyConApp (IfaceTc tc) tys) - = do { putByte bh 20; put_ bh tc; put_ bh tys } + = do { putByte bh 4; put_ bh cc; put_ bh tys } put_ bh (IfaceTyConApp tc tys) - = do { putByte bh 21; put_ bh tc; put_ bh tys } + = do { putByte bh 5; put_ bh tc; put_ bh tys } + + put_ bh (IfaceLitTy n) + = do { putByte bh 30; put_ bh n } + get bh = do h <- getByte bh @@ -1040,70 +1010,32 @@ instance Binary IfaceType where 3 -> do ag <- get bh ah <- get bh return (IfaceFunTy ag ah) - - -- Now the special cases for TyConApp - 6 -> return (IfaceTyConApp IfaceIntTc []) - 7 -> return (IfaceTyConApp IfaceCharTc []) - 8 -> return (IfaceTyConApp IfaceBoolTc []) - 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) } - 10 -> return (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) - 11 -> do { t1 <- get bh; t2 <- get bh - ; return (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) } - 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc []) - 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc []) - 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc []) - 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc []) - 16 -> return (IfaceTyConApp IfaceArgTypeKindTc []) - 17 -> return (IfaceTyConApp IfaceConstraintKindTc []) - 18 -> return (IfaceTyConApp IfaceSuperKindTc []) - - 19 -> do { cc <- get bh; tys <- get bh - ; return (IfaceCoConApp cc tys) } - - 20 -> do { tc <- get bh; tys <- get bh - ; return (IfaceTyConApp (IfaceTc tc) tys) } - 21 -> do { tc <- get bh; tys <- get bh - ; return (IfaceTyConApp tc tys) } + 4 -> do { cc <- get bh; tys <- get bh + ; return (IfaceCoConApp cc tys) } + 5 -> do { tc <- get bh; tys <- get bh + ; return (IfaceTyConApp tc tys) } + + 30 -> do n <- get bh + return (IfaceLitTy n) _ -> panic ("get IfaceType " ++ show h) -instance Binary IfaceTyCon where - -- Int,Char,Bool can't show up here because they can't not be saturated - put_ bh IfaceIntTc = putByte bh 1 - put_ bh IfaceBoolTc = putByte bh 2 - put_ bh IfaceCharTc = putByte bh 3 - put_ bh IfaceListTc = putByte bh 4 - put_ bh IfacePArrTc = putByte bh 5 - put_ bh IfaceLiftedTypeKindTc = putByte bh 6 - put_ bh IfaceOpenTypeKindTc = putByte bh 7 - put_ bh IfaceUnliftedTypeKindTc = putByte bh 8 - put_ bh IfaceUbxTupleKindTc = putByte bh 9 - put_ bh IfaceArgTypeKindTc = putByte bh 10 - put_ bh IfaceConstraintKindTc = putByte bh 11 - put_ bh IfaceSuperKindTc = putByte bh 12 - put_ bh (IfaceTupTc bx ar) = do { putByte bh 13; put_ bh bx; put_ bh ar } - put_ bh (IfaceTc ext) = do { putByte bh 14; put_ bh ext } - put_ bh (IfaceIPTc n) = do { putByte bh 15; put_ bh n } +instance Binary IfaceTyLit where + put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n - get bh = do - h <- getByte bh - case h of - 1 -> return IfaceIntTc - 2 -> return IfaceBoolTc - 3 -> return IfaceCharTc - 4 -> return IfaceListTc - 5 -> return IfacePArrTc - 6 -> return IfaceLiftedTypeKindTc - 7 -> return IfaceOpenTypeKindTc - 8 -> return IfaceUnliftedTypeKindTc - 9 -> return IfaceUbxTupleKindTc - 10 -> return IfaceArgTypeKindTc - 11 -> return IfaceConstraintKindTc - 12 -> return IfaceSuperKindTc - 13 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } - 14 -> do { ext <- get bh; return (IfaceTc ext) } - 15 -> do { n <- get bh; return (IfaceIPTc n) } - _ -> panic ("get IfaceTyCon " ++ show h) + get bh = + do tag <- getByte bh + case tag of + 1 -> do { n <- get bh + ; return (IfaceNumTyLit n) } + 2 -> do { n <- get bh + ; return (IfaceStrTyLit n) } + _ -> panic ("get IfaceTyLit " ++ show tag) + +instance Binary IfaceTyCon where + put_ bh (IfaceTc ext) = put_ bh ext + get bh = liftM IfaceTc (get bh) instance Binary IfaceCoCon where put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } @@ -1113,8 +1045,7 @@ instance Binary IfaceCoCon where put_ bh IfaceTransCo = putByte bh 4 put_ bh IfaceInstCo = putByte bh 5 put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } - put_ bh (IfaceIPCoAx ip) = do { putByte bh 7; put_ bh ip } - + get bh = do h <- getByte bh case h of @@ -1125,7 +1056,6 @@ instance Binary IfaceCoCon where 4 -> return IfaceTransCo 5 -> return IfaceInstCo 6 -> do { d <- get bh; return (IfaceNthCo d) } - 7 -> do { ip <- get bh; return (IfaceIPCoAx ip) } _ -> panic ("get IfaceCoCon " ++ show h) ------------------------------------------------------------------------- @@ -1181,6 +1111,10 @@ instance Binary IfaceExpr where putByte bh 12 put_ bh ie put_ bh ico + put_ bh (IfaceECase a b) = do + putByte bh 13 + put_ bh a + put_ bh b get bh = do h <- getByte bh case h of @@ -1219,6 +1153,9 @@ instance Binary IfaceExpr where 12 -> do ie <- get bh ico <- get bh return (IfaceCast ie ico) + 13 -> do a <- get bh + b <- get bh + return (IfaceECase a b) _ -> panic ("get IfaceExpr " ++ show h) instance Binary IfaceConAlt where @@ -1244,13 +1181,21 @@ instance Binary IfaceBinding where instance Binary IfaceIdDetails where put_ bh IfVanillaId = putByte bh 0 put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b - put_ bh IfDFunId = putByte bh 2 + put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } get bh = do h <- getByte bh case h of 0 -> return IfVanillaId 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } - _ -> return IfDFunId + _ -> do { n <- get bh; return (IfDFunId n) } + +instance Binary (DFunArg IfaceExpr) where + put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e + put_ bh (DFunLamArg i) = putByte bh 1 >> put_ bh i + get bh = do { h <- getByte bh + ; case h of + 0 -> do { a <- get bh; return (DFunPolyArg a) } + _ -> do { a <- get bh; return (DFunLamArg a) } } instance Binary IfaceIdInfo where put_ bh NoInfo = putByte bh 0 @@ -1370,7 +1315,7 @@ instance Binary IfaceDecl where put_ _ (IfaceForeign _ _) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do putByte bh 2 put_ bh (occNameFS a1) put_ bh a2 @@ -1379,6 +1324,7 @@ instance Binary IfaceDecl where put_ bh a5 put_ bh a6 put_ bh a7 + put_ bh a8 put_ bh (IfaceSyn a1 a2 a3 a4) = do putByte bh 3 @@ -1421,8 +1367,9 @@ instance Binary IfaceDecl where a5 <- get bh a6 <- get bh a7 <- get bh + a8 <- get bh occ <- return $! mkOccNameFS tcName a1 - return (IfaceData occ a2 a3 a4 a5 a6 a7) + return (IfaceData occ a2 a3 a4 a5 a6 a7 a8) 3 -> do a1 <- get bh a2 <- get bh a3 <- get bh diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 75b8d91881..9456bdaf34 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -29,6 +29,7 @@ import DataCon import Var import VarSet import BasicTypes +import ForeignCall import Name import MkId import Class @@ -37,7 +38,7 @@ import Type import Coercion import TcRnMonad -import Util ( isSingleton ) +import Util import Outputable \end{code} @@ -56,6 +57,7 @@ buildSynTyCon tc_name tvs rhs rhs_kind parent ------------------------------------------------------ buildAlgTyCon :: Name -> [TyVar] -- ^ Kind variables and type variables + -> Maybe CType -> ThetaType -- ^ Stupid theta -> AlgTyConRhs -> RecFlag @@ -63,8 +65,8 @@ buildAlgTyCon :: Name -> TyConParent -> TyCon -buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn parent - = mkAlgTyCon tc_name kind ktvs stupid_theta rhs parent is_rec gadt_syn +buildAlgTyCon tc_name ktvs cType stupid_theta rhs is_rec gadt_syn parent + = mkAlgTyCon tc_name kind ktvs cType stupid_theta rhs parent is_rec gadt_syn where kind = mkPiKinds ktvs liftedTypeKind @@ -201,13 +203,13 @@ buildClass :: Bool -- True <=> do not include unfoldings -> TcRnIf m n Class buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec - = do { traceIf (text "buildClass") + = fixM $ \ rec_clas -> -- Only name generation inside loop + do { traceIf (text "buildClass") ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc -- The class name is the 'parent' for this datacon, not its tycon, -- because one should import the class to get the binding for -- the datacon - ; fixM (\ rec_clas -> do { -- Only name generation inside loop ; op_items <- mapM (mk_op_item rec_clas) sig_stuff -- Build the selector id and default method id @@ -276,8 +278,7 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec op_items tycon } ; traceIf (text "buildClass" <+> ppr tycon) - ; return result - })} + ; return result } where mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem mk_op_item rec_clas (op_name, dm_spec, _) diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs index 5e4a7092bf..0365be7338 100644 --- a/compiler/iface/FlagChecker.hs +++ b/compiler/iface/FlagChecker.hs @@ -10,6 +10,7 @@ import Binary import BinIface () import DynFlags import HscTypes +import Module import Name import Fingerprint -- import Outputable @@ -21,11 +22,12 @@ import System.FilePath (normalise) -- | Produce a fingerprint of a @DynFlags@ value. We only base -- the finger print on important fields in @DynFlags@ so that -- the recompilation checker can use this fingerprint. -fingerprintDynFlags :: DynFlags -> (BinHandle -> Name -> IO ()) +fingerprintDynFlags :: DynFlags -> Module -> (BinHandle -> Name -> IO ()) -> IO Fingerprint -fingerprintDynFlags DynFlags{..} nameio = - let mainis = (mainModIs, mainFunIs) +fingerprintDynFlags DynFlags{..} this_mod nameio = + let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing + -- see #5878 -- pkgopts = (thisPackage dflags, sort $ packageFlags dflags) safeHs = setSafeMode safeHaskell -- oflags = sort $ filter filterOFlags $ flags dflags @@ -38,12 +40,8 @@ fingerprintDynFlags DynFlags{..} nameio = cpp = (map normalise includePaths, sOpt_P settings) -- normalise: eliminate spurious differences due to "./foo" vs "foo" - -- -i, -osuf, -hcsuf, -hisuf, -odir, -hidir, -stubdir, -o, -ohi - paths = (map normalise importPaths, - [ objectSuf, hcSuf, hiSuf ], - [ objectDir, hiDir, stubDir, outputHi ]) - -- NB. not outputFile, we don't want "ghc --make M -o <file>" - -- to force recompilation when <file> changes. + -- Note [path flags and recompilation] + paths = [ hcSuf ] -- -fprof-auto etc. prof = if opt_SccProfilingOn then fromEnum profAuto else 0 @@ -51,3 +49,33 @@ fingerprintDynFlags DynFlags{..} nameio = in -- pprTrace "flags" (ppr (mainis, safeHs, lang, cpp, paths)) $ computeFingerprint nameio (mainis, safeHs, lang, cpp, paths, prof) + +{- Note [path flags and recompilation] + +There are several flags that we deliberately omit from the +recompilation check; here we explain why. + +-osuf, -odir, -hisuf, -hidir + If GHC decides that it does not need to recompile, then + it must have found an up-to-date .hi file and .o file. + There is no point recording these flags - the user must + have passed the correct ones. Indeed, the user may + have compiled the source file in one-shot mode using + -o to specify the .o file, and then loaded it in GHCi + using -odir. + +-stubdir + We omit this one because it is automatically set by -outputdir, and + we don't want changes in -outputdir to automatically trigger + recompilation. This could be wrong, but only in very rare cases. + +-i (importPaths) + For the same reason as -osuf etc. above: if GHC decides not to + recompile, then it must have already checked all the .hi files on + which the current module depends, so it must have found them + successfully. It is occasionally useful to be able to cd to a + different directory and use -i flags to enable GHC to find the .hi + files; we don't want this to force recompilation. + +The only path-related flag left is -hcsuf. +-} diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 4c66a98314..20a21c3733 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -12,14 +12,14 @@ module IfaceEnv ( newGlobalBinder, newImplicitBinder, lookupIfaceTop, lookupOrig, lookupOrigNameCache, extendNameCache, - newIPName, newIfaceName, newIfaceNames, + newIfaceName, newIfaceNames, extendIfaceIdEnv, extendIfaceTyVarEnv, tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar, ifaceExportNames, -- Name-cache stuff - allocateGlobalBinder, allocateIPName, initNameCache, updNameCache, + allocateGlobalBinder, initNameCache, updNameCache, getNameCache, mkNameCacheUpdater, NameCacheUpdater(..) ) where @@ -40,13 +40,12 @@ import UniqFM import FastString import UniqSupply import SrcLoc -import BasicTypes +import Util import Outputable import Exception ( evaluate ) import Data.IORef ( atomicModifyIORef, readIORef ) -import qualified Data.Map as Map \end{code} @@ -164,21 +163,6 @@ lookupOrig mod occ new_cache = extendNameCache (nsNames name_cache) mod occ name in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}} - -allocateIPName :: NameCache -> FastString -> (NameCache, IPName Name) -allocateIPName name_cache ip = case Map.lookup ip ipcache of - Just name_ip -> (name_cache, name_ip) - Nothing -> (new_ns, name_ip) - where - (us_here, us') = splitUniqSupply (nsUniqs name_cache) - tycon_u:datacon_u:dc_wrk_u:co_ax_u:_ = uniqsFromSupply us_here - name_ip = mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u - new_ipcache = Map.insert ip name_ip ipcache - new_ns = name_cache {nsUniqs = us', nsIPs = new_ipcache} - where ipcache = nsIPs name_cache - -newIPName :: FastString -> TcRnIf m n (IPName Name) -newIPName ip = updNameCache $ flip allocateIPName ip \end{code} %************************************************************************ @@ -248,8 +232,7 @@ mkNameCacheUpdater = do initNameCache :: UniqSupply -> [Name] -> NameCache initNameCache us names = NameCache { nsUniqs = us, - nsNames = initOrigNames names, - nsIPs = Map.empty } + nsNames = initOrigNames names } initOrigNames :: [Name] -> OrigNameCache initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index fd8b361b3d..bc5fc954eb 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -35,6 +35,8 @@ module IfaceSyn ( #include "HsVersions.h" import IfaceType +import CoreSyn( DFunArg, dfunArgExprs ) +import PprCore() -- Printing DFunArgs import Demand import Annotations import Class @@ -68,6 +70,7 @@ data IfaceDecl ifIdInfo :: IfaceIdInfo } | IfaceData { ifName :: OccName, -- Type constructor + ifCType :: Maybe CType, -- C type for CAPI FFI ifTyVars :: [IfaceTvBndr], -- Type variables ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data/data family info @@ -193,7 +196,7 @@ type IfaceAnnTarget = AnnTarget OccName data IfaceIdDetails = IfVanillaId | IfRecSelId IfaceTyCon Bool - | IfDFunId + | IfDFunId Int -- Number of silent args data IfaceIdInfo = NoInfo -- When writing interface file without -O @@ -236,7 +239,7 @@ data IfaceUnfolding | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in -- another module. - | IfDFunUnfold [IfaceExpr] + | IfDFunUnfold [DFunArg IfaceExpr] -------------------------------- data IfaceExpr @@ -248,6 +251,7 @@ data IfaceExpr | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr | IfaceCase IfaceExpr IfLclName [IfaceAlt] + | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] | IfaceLet IfaceBinding IfaceExpr | IfaceCast IfaceExpr IfaceCoercion | IfaceLit Literal @@ -278,6 +282,12 @@ data IfaceBinding data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo \end{code} +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In IfaceSyn an IfaceCase does not record the types of the alternatives, +unlike CorSyn Case. But we need this type if the alternatives are empty. +Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. + Note [Expose recursive functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For supercompilation we want to put *all* unfoldings in the interface @@ -453,7 +463,8 @@ pprIfaceDecl (IfaceId {ifName = var, ifType = ty, pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, +pprIfaceDecl (IfaceSyn {ifName = tycon, + ifTyVars = tyvars, ifSynRhs = Just mono_ty}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty]) @@ -463,11 +474,12 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) 4 (dcolon <+> ppr kind) -pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context, +pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType, + ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifAxiom = mbAxiom}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 4 (vcat [pprRec isrec, pp_condecls tycon condecls, + 4 (vcat [pprCType cType, pprRec isrec, pp_condecls tycon condecls, pprAxiom mbAxiom]) where pp_nd = case condecls of @@ -489,6 +501,10 @@ pprIfaceDecl (IfaceAxiom {ifName = name, ifTyVars = tyvars, = hang (ptext (sLit "axiom") <+> ppr name <+> ppr tyvars) 2 (dcolon <+> ppr lhs <+> text "~#" <+> ppr rhs) +pprCType :: Maybe CType -> SDoc +pprCType Nothing = ptext (sLit "No C type associated") +pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType + pprRec :: RecFlag -> SDoc pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec @@ -614,6 +630,11 @@ pprIfaceExpr add_par i@(IfaceLam _ _) collect bs (IfaceLam b e) = collect (b:bs) e collect bs e = (reverse bs, e) +pprIfaceExpr add_par (IfaceECase scrut ty) + = add_par (sep [ ptext (sLit "case") <+> pprIfaceExpr noParens scrut + , ptext (sLit "ret_ty") <+> pprParendIfaceType ty + , ptext (sLit "of {}") ]) + pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) = add_par (sep [ptext (sLit "case") <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") @@ -682,7 +703,7 @@ instance Outputable IfaceIdDetails where ppr IfVanillaId = empty ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc <+> if b then ptext (sLit "<naughty>") else empty - ppr IfDFunId = ptext (sLit "DFunId") + ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns) instance Outputable IfaceIdInfo where ppr NoInfo = empty @@ -795,6 +816,7 @@ freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& fnList freeNamesIfType ts +freeNamesIfType (IfaceLitTy _) = emptyNameSet freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t @@ -836,7 +858,7 @@ freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet -freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs) freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v @@ -848,7 +870,7 @@ freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e - +freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty freeNamesIfExpr (IfaceCase s _ alts) = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts @@ -875,7 +897,6 @@ freeNamesIfExpr _ = emptyNameSet freeNamesIfTc :: IfaceTyCon -> NameSet freeNamesIfTc (IfaceTc tc) = unitNameSet tc -- ToDo: shouldn't we include IfaceIntTc & co.? -freeNamesIfTc _ = emptyNameSet freeNamesIfCo :: IfaceCoCon -> NameSet freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 5441287eef..c484b0637f 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -14,11 +14,11 @@ This module defines interface types and binders -- for details module IfaceType ( - IfExtName, IfLclName, IfIPName, + IfExtName, IfLclName, IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..), + IfaceTyLit(..), IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, - ifaceTyConName, -- Conversion from Type -> IfaceType toIfaceType, toIfaceKind, toIfaceContext, @@ -37,8 +37,6 @@ module IfaceType ( import Coercion import TypeRep hiding( maybeParen ) -import Type (tyConAppTyCon_maybe) -import IParam (ipFastString) import TyCon import Id import Var @@ -62,8 +60,6 @@ type IfLclName = FastString -- A local name in iface syntax type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn -- (However Internal or System Names never should) -type IfIPName = FastString -- Represent implicit parameters simply as a string - data IfaceBndr -- Local (non-top-level) binders = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr @@ -83,66 +79,27 @@ data IfaceType -- A kind of universal type, used for types, kinds, and coerci | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated -- Includes newtypes, synonyms, tuples | IfaceCoConApp IfaceCoCon [IfaceType] -- Always saturated + | IfaceLitTy IfaceTyLit type IfacePredType = IfaceType type IfaceContext = [IfacePredType] -data IfaceTyCon -- Encodes type constructors, kind constructors - -- coercion constructors, the lot - = IfaceTc IfExtName -- The common case - | IfaceIntTc | IfaceBoolTc | IfaceCharTc - | IfaceListTc | IfacePArrTc - | IfaceTupTc TupleSort Arity - | IfaceIPTc IfIPName -- Used for implicit parameter TyCons - - -- Kind constructors - | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc - | IfaceUbxTupleKindTc | IfaceArgTypeKindTc | IfaceConstraintKindTc +data IfaceTyLit + = IfaceNumTyLit Integer + | IfaceStrTyLit FastString - -- SuperKind constructor - | IfaceSuperKindTc -- IA0_NOTE: You might want to check if I didn't forget something. +-- Encodes type constructors, kind constructors +-- coercion constructors, the lot +newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName } -- Coercion constructors data IfaceCoCon = IfaceCoAx IfExtName - | IfaceIPCoAx FastString | IfaceReflCo | IfaceUnsafeCo | IfaceSymCo | IfaceTransCo | IfaceInstCo | IfaceNthCo Int - -ifaceTyConName :: IfaceTyCon -> Name -ifaceTyConName IfaceIntTc = intTyConName -ifaceTyConName IfaceBoolTc = boolTyConName -ifaceTyConName IfaceCharTc = charTyConName -ifaceTyConName IfaceListTc = listTyConName -ifaceTyConName IfacePArrTc = parrTyConName -ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar) -ifaceTyConName IfaceLiftedTypeKindTc = liftedTypeKindTyConName -ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName -ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName -ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName -ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName -ifaceTyConName IfaceConstraintKindTc = constraintKindTyConName -ifaceTyConName IfaceSuperKindTc = tySuperKindTyConName -ifaceTyConName (IfaceTc ext) = ext -ifaceTyConName (IfaceIPTc n) = pprPanic "ifaceTyConName:IPTc" (ppr n) - -- Note [The Name of an IfaceAnyTc] \end{code} -Note [The Name of an IfaceAnyTc] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -IA0_NOTE: This is an old comment. It needs to be updated with IPTc which -I don't know about. - -It isn't easy to get the Name of an IfaceAnyTc in a pure way. What you -really need to do is to transform it to a TyCon, and get the Name of that. -But doing so needs the monad because there's an IfaceKind inside, and we -need a Kind. - -In fact, ifaceTyConName is only used for instances and rules, and we don't -expect to instantiate those at these (internal-ish) Any types, so rather -than solve this potential problem now, I'm going to defer it until it happens! - %************************************************************************ %* * Functions over IFaceTypes @@ -214,11 +171,12 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty] pprIfaceTvBndr :: IfaceTvBndr -> SDoc -pprIfaceTvBndr (tv, IfaceTyConApp IfaceLiftedTypeKindTc []) - = ppr tv +pprIfaceTvBndr (tv, IfaceTyConApp tc []) + | ifaceTyConName tc == liftedTypeKindTyConName = ppr tv pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) + pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc -pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars) +pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars) \end{code} ----------------------------- Printing IfaceType ------------------------------------ @@ -241,6 +199,8 @@ ppr_ty :: Int -> IfaceType -> SDoc ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys +ppr_ty _ (IfaceLitTy n) = ppr_tylit n + ppr_ty ctxt_prec (IfaceCoConApp tc tys) = maybeParen ctxt_prec tYCON_PREC (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))]) @@ -280,36 +240,36 @@ pprIfaceForAllPart tvs ctxt doc ppr_tc_app :: Int -> IfaceTyCon -> [IfaceType] -> SDoc ppr_tc_app _ tc [] = ppr_tc tc -ppr_tc_app _ IfaceListTc [ty] = brackets (pprIfaceType ty) -ppr_tc_app _ IfaceListTc _ = panic "ppr_tc_app IfaceListTc" - -ppr_tc_app _ IfacePArrTc [ty] = pabrackets (pprIfaceType ty) -ppr_tc_app _ IfacePArrTc _ = panic "ppr_tc_app IfacePArrTc" - -ppr_tc_app _ (IfaceTupTc sort _) tys = - tupleParens sort (sep (punctuate comma (map pprIfaceType tys))) - -ppr_tc_app _ (IfaceIPTc n) [ty] = - parens (ppr n <> dcolon <> pprIfaceType ty) -ppr_tc_app _ (IfaceIPTc _) _ = panic "ppr_tc_app IfaceIPTc" +ppr_tc_app _ (IfaceTc n) [ty] | n == listTyConName = brackets (pprIfaceType ty) +ppr_tc_app _ (IfaceTc n) [ty] | n == parrTyConName = paBrackets (pprIfaceType ty) +ppr_tc_app _ (IfaceTc n) tys + | Just (ATyCon tc) <- wiredInNameTyThing_maybe n + , Just sort <- tyConTuple_maybe tc + , tyConArity tc == length tys + = tupleParens sort (sep (punctuate comma (map pprIfaceType tys))) ppr_tc_app ctxt_prec tc tys - = maybeParen ctxt_prec tYCON_PREC + = maybeParen ctxt_prec tYCON_PREC (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))]) ppr_tc :: IfaceTyCon -> SDoc -- Wrap infix type constructors in parens -ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (getOccName ext_nm) (ppr tc) -ppr_tc tc = ppr tc +ppr_tc tc = wrap (ifaceTyConName tc) (ppr tc) + where + -- The kind * does not get wrapped in parens. + wrap name | name == liftedTypeKindTyConName = id + wrap name = parenSymOcc (getOccName name) + +ppr_tylit :: IfaceTyLit -> SDoc +ppr_tylit (IfaceNumTyLit n) = integer n +ppr_tylit (IfaceStrTyLit n) = text (show n) ------------------- instance Outputable IfaceTyCon where - ppr (IfaceIPTc n) = ppr (IPName n) - ppr other_tc = ppr (ifaceTyConName other_tc) + ppr = ppr . ifaceTyConName instance Outputable IfaceCoCon where ppr (IfaceCoAx n) = ppr n - ppr (IfaceIPCoAx ip) = ppr (IPName ip) ppr IfaceReflCo = ptext (sLit "Refl") ppr IfaceUnsafeCo = ptext (sLit "Unsafe") ppr IfaceSymCo = ptext (sLit "Sym") @@ -317,6 +277,9 @@ instance Outputable IfaceCoCon where ppr IfaceInstCo = ptext (sLit "Inst") ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d +instance Outputable IfaceTyLit where + ppr = ppr_tylit + ------------------- pprIfaceContext :: IfaceContext -> SDoc -- Prints "(C a, D b) =>", including the arrow @@ -326,10 +289,6 @@ pprIfaceContext theta = ppr_preds theta <+> darrow ppr_preds :: [IfacePredType] -> SDoc ppr_preds [pred] = ppr pred -- No parens ppr_preds preds = parens (sep (punctuate comma (map ppr preds))) - -------------------- -pabrackets :: SDoc -> SDoc -pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") \end{code} %************************************************************************ @@ -362,6 +321,7 @@ toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2) toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) +toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n) toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) toIfaceTyVar :: TyVar -> FastString @@ -372,35 +332,14 @@ toIfaceCoVar = occNameFS . getOccName ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon -toIfaceTyCon tc - | isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc) - | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n) - | otherwise = toIfaceTyCon_name (tyConName tc) +toIfaceTyCon = toIfaceTyCon_name . tyConName toIfaceTyCon_name :: Name -> IfaceTyCon -toIfaceTyCon_name nm - | Just (ATyCon tc) <- wiredInNameTyThing_maybe nm - = toIfaceWiredInTyCon tc nm - | otherwise - = IfaceTc nm - -toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon -toIfaceWiredInTyCon tc nm - | isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc) - | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n) - | nm == intTyConName = IfaceIntTc - | nm == boolTyConName = IfaceBoolTc - | nm == charTyConName = IfaceCharTc - | nm == listTyConName = IfaceListTc - | nm == parrTyConName = IfacePArrTc - | nm == liftedTypeKindTyConName = IfaceLiftedTypeKindTc - | nm == unliftedTypeKindTyConName = IfaceUnliftedTypeKindTc - | nm == openTypeKindTyConName = IfaceOpenTypeKindTc - | nm == argTypeKindTyConName = IfaceArgTypeKindTc - | nm == constraintKindTyConName = IfaceConstraintKindTc - | nm == ubxTupleKindTyConName = IfaceUbxTupleKindTc - | nm == tySuperKindTyConName = IfaceSuperKindTc - | otherwise = IfaceTc nm +toIfaceTyCon_name = IfaceTc + +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x +toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x ---------------- toIfaceTypes :: [Type] -> [IfaceType] @@ -437,11 +376,6 @@ coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo , toIfaceType ty ] coAxiomToIfaceType :: CoAxiom -> IfaceCoCon -coAxiomToIfaceType con - | Just tc <- tyConAppTyCon_maybe (co_ax_lhs con) - , Just ip <- tyConIP_maybe tc - = IfaceIPCoAx (ipFastString ip) - | otherwise - = IfaceCoAx (coAxiomName con) +coAxiomToIfaceType con = IfaceCoAx (coAxiomName con) \end{code} diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 107c24c94f..493e18b825 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -34,6 +34,7 @@ import HscTypes import BasicTypes hiding (SuccessFlag(..)) import TcRnMonad +import Constants import PrelNames import PrelInfo import MkId ( seqId ) @@ -49,7 +50,7 @@ import Maybes import ErrUtils import Finder import UniqFM -import StaticFlags +import SrcLoc import Outputable import BinIface import Panic @@ -63,7 +64,7 @@ import Control.Monad %************************************************************************ %* * - loadSrcInterface, loadOrphanModules, loadHomeInterface + loadSrcInterface, loadOrphanModules, loadInterfaceForName These three are called from TcM-land %* * @@ -161,8 +162,9 @@ loadUserInterface is_boot doc mod_name loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface loadInterfaceWithException doc mod_name where_from = do { mb_iface <- loadInterface doc mod_name where_from + ; dflags <- getDynFlags ; case mb_iface of - Failed err -> ghcError (ProgramError (showSDoc err)) + Failed err -> ghcError (ProgramError (showSDoc dflags err)) Succeeded iface -> return iface } ------------------ @@ -372,7 +374,6 @@ loadDecl ignore_prags mod (_version, decl) -- the names associated with the decl main_name <- lookupOrig mod (ifName decl) -- ; traceIf (text "Loading decl for " <> ppr main_name) - ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl) -- Typecheck the thing, lazily -- NB. Firstly, the laziness is there in case we never need the @@ -445,6 +446,7 @@ loadDecl ignore_prags mod (_version, decl) Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl)) + ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl) ; return $ (main_name, thing) : -- uses the invariant that implicit_names and -- implictTyThings are bijective @@ -643,7 +645,8 @@ showIface hsc_env filename = do -- non-profiled interfaces, for example. iface <- initTcRnIf 's' hsc_env () () $ readBinIface IgnoreHiWay TraceBinIFaceReading filename - printDump (pprModIface iface) + let dflags = hsc_dflags hsc_env + log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (pprModIface iface) \end{code} \begin{code} @@ -655,7 +658,7 @@ pprModIface iface <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else empty) <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else empty) <+> (if mi_hpc iface then ptext (sLit "[hpc]") else empty) - <+> integer opt_HiVersion + <+> integer hiVersion , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface)) , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface)) , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface)) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 9904042fe0..91651829b7 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -19,6 +19,7 @@ module MkIface ( checkOldIface, -- See if recompilation is required, by -- comparing version information + RecompileRequired(..), recompileRequired, tyThingToIfaceDecl -- Converting things to their Iface equivalents ) where @@ -106,10 +107,13 @@ import Bag import Exception import Control.Monad +import Data.Function import Data.List import Data.Map (Map) import qualified Data.Map as Map +import Data.Ord import Data.IORef +import System.Directory import System.FilePath \end{code} @@ -133,32 +137,35 @@ mkIface :: HscEnv -- to write it mkIface hsc_env maybe_old_fingerprint mod_details - ModGuts{ mg_module = this_mod, - mg_boot = is_boot, - mg_used_names = used_names, - mg_used_th = used_th, - mg_deps = deps, - mg_dir_imps = dir_imp_mods, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_hpc_info = hpc_info, - mg_trust_pkg = self_trust, + ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_used_names = used_names, + mg_used_th = used_th, + mg_deps = deps, + mg_dir_imps = dir_imp_mods, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_hpc_info = hpc_info, + mg_safe_haskell = safe_mode, + mg_trust_pkg = self_trust, mg_dependent_files = dependent_files } = mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names used_th deps rdr_env fix_env - warns hpc_info dir_imp_mods self_trust dependent_files mod_details + warns hpc_info dir_imp_mods self_trust dependent_files + safe_mode mod_details -- | make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any -- object code at all ('HscNothing'). mkIfaceTc :: HscEnv -> Maybe Fingerprint -- The old fingerprint, if we have it + -> SafeHaskellMode -- The safe haskell mode -> ModDetails -- gotten from mkBootModDetails, probably -> TcGblEnv -- Usages, deprecations, etc -> IO (Messages, Maybe (ModIface, Bool)) -mkIfaceTc hsc_env maybe_old_fingerprint mod_details +mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details tc_result@TcGblEnv{ tcg_mod = this_mod, tcg_src = hsc_src, tcg_imports = imports, @@ -178,7 +185,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details mkIface_ hsc_env maybe_old_fingerprint this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env fix_env warns hpc_info (imp_mods imports) - (imp_trust_own_pkg imports) dep_files mod_details + (imp_trust_own_pkg imports) dep_files safe_mode mod_details mkUsedNames :: TcGblEnv -> NameSet @@ -224,11 +231,12 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface -> NameEnv FixItem -> Warnings -> HpcInfo -> ImportedMods -> Bool -> [FilePath] + -> SafeHaskellMode -> ModDetails -> IO (Messages, Maybe (ModIface, Bool)) mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names used_th deps rdr_env fix_env src_warns - hpc_info dir_imp_mods pkg_trust_req dependent_files + hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, @@ -242,7 +250,6 @@ mkIface_ hsc_env maybe_old_fingerprint -- to expose in the interface = do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files - ; safeInf <- hscGetSafeInf hsc_env ; let { entities = typeEnvElts type_env ; decls = [ tyThingToIfaceDecl entity @@ -261,13 +268,7 @@ mkIface_ hsc_env maybe_old_fingerprint ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts ; iface_vect_info = flattenVectInfo vect_info - - -- Check if we are in Safe Inference mode - -- but we failed to pass the muster - ; safeMode = if safeInferOn dflags && not safeInf - then Sf_None - else safeHaskell dflags - ; trust_info = setSafeMode safeMode + ; trust_info = setSafeMode safe_mode ; intermediate_iface = ModIface { mi_module = this_mod, @@ -278,16 +279,16 @@ mkIface_ hsc_env maybe_old_fingerprint -- Sort these lexicographically, so that -- the result is stable across compilations - mi_insts = sortLe le_inst iface_insts, - mi_fam_insts = sortLe le_fam_inst iface_fam_insts, - mi_rules = sortLe le_rule iface_rules, + mi_insts = sortBy cmp_inst iface_insts, + mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts, + mi_rules = sortBy cmp_rule iface_rules, mi_vect_info = iface_vect_info, mi_fixities = fixities, mi_warns = warns, mi_anns = mkIfaceAnnotations anns, - mi_globals = Just rdr_env, + mi_globals = maybeGlobalRdrEnv rdr_env, -- Left out deliberately: filled in by addFingerprints mi_iface_hash = fingerprint0, @@ -323,10 +324,10 @@ mkIface_ hsc_env maybe_old_fingerprint | otherwise = emptyBag errs_and_warns = (orph_warnings, emptyBag) unqual = mkPrintUnqualified dflags rdr_env - inst_warns = listToBag [ instOrphWarn unqual d + inst_warns = listToBag [ instOrphWarn dflags unqual d | (d,i) <- insts `zip` iface_insts , isNothing (ifInstOrph i) ] - rule_warns = listToBag [ ruleOrphWarn unqual this_mod r + rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r | r <- iface_rules , isNothing (ifRuleOrph r) , if ifRuleAuto r then warn_auto_orphs @@ -344,21 +345,29 @@ mkIface_ hsc_env maybe_old_fingerprint -- correctly. This stems from the fact that the interface had -- not changed, so addFingerprints returns the old ModIface -- with the old GlobalRdrEnv (mi_globals). - ; let final_iface = new_iface{ mi_globals = Just rdr_env } + ; let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env } ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }} where - r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 - i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2 - i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2 - - le_occ :: Name -> Name -> Bool - -- Compare lexicographically by OccName, *not* by unique, because - -- the latter is not stable across compilations - le_occ n1 n2 = nameOccName n1 <= nameOccName n2 + cmp_rule = comparing ifRuleName + -- Compare these lexicographically by OccName, *not* by unique, + -- because the latter is not stable across compilations: + cmp_inst = comparing (nameOccName . ifDFun) + cmp_fam_inst = comparing (nameOccName . ifFamInstTcName) dflags = hsc_dflags hsc_env + -- We only fill in mi_globals if the module was compiled to byte + -- code. Otherwise, the compiler may not have retained all the + -- top-level bindings and they won't be in the TypeEnv (see + -- Desugar.addExportFlagsAndRules). The mi_globals field is used + -- by GHCi to decide whether the module has its full top-level + -- scope available. (#5534) + maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv + maybeGlobalRdrEnv rdr_env + | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env + | otherwise = Nothing + deliberatelyOmitted :: String -> a deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) @@ -380,7 +389,7 @@ mkIface_ hsc_env maybe_old_fingerprint ----------------------------- writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO () writeIfaceFile dflags location new_iface - = do createDirectoryHierarchy (takeDirectory hi_file_path) + = do createDirectoryIfMissing True (takeDirectory hi_file_path) writeBinIface dflags hi_file_path new_iface where hi_file_path = ml_hi_file location @@ -583,7 +592,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- - (some of) dflags -- it returns two hashes, one that shouldn't change -- the abi hash and one that should - flag_hash <- fingerprintDynFlags dflags putNameLiterally + flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally -- the ABI hash depends on: -- - decls @@ -839,14 +848,14 @@ oldMD5 dflags bh = do return $! readHexFingerprint hash_str -} -instOrphWarn :: PrintUnqualified -> ClsInst -> WarnMsg -instOrphWarn unqual inst - = mkWarnMsg (getSrcSpan inst) unqual $ +instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg +instOrphWarn dflags unqual inst + = mkWarnMsg dflags (getSrcSpan inst) unqual $ hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst) -ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg -ruleOrphWarn unqual mod rule - = mkWarnMsg silly_loc unqual $ +ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg +ruleOrphWarn dflags unqual mod rule + = mkWarnMsg dflags silly_loc unqual $ ptext (sLit "Orphan rule:") <+> ppr rule where silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1) @@ -1073,11 +1082,26 @@ Trac #5362 for an example. Such Names are always %* * Load the old interface file for this module (unless we have it already), and check whether it is up to date - %* * %************************************************************************ \begin{code} +data RecompileRequired + = UpToDate + -- ^ everything is up to date, recompilation is not required + | MustCompile + -- ^ The .hs file has been touched, or the .o/.hi file does not exist + | RecompBecause String + -- ^ The .o/.hi files are up to date, but something else has changed + -- to force recompilation; the String says what (one-line summary) + deriving Eq + +recompileRequired :: RecompileRequired -> Bool +recompileRequired UpToDate = False +recompileRequired _ = True + + + -- | Top level function to check if the version of an old interface file -- is equivalent to the current source file the user asked us to compile. -- If the same, we can avoid recompilation. We return a tuple where the @@ -1091,13 +1115,14 @@ checkOldIface :: HscEnv -> IO (RecompileRequired, Maybe ModIface) checkOldIface hsc_env mod_summary source_modified maybe_iface - = do showPass (hsc_dflags hsc_env) $ - "Checking old interface for " ++ (showSDoc $ ppr $ ms_mod mod_summary) + = do let dflags = hsc_dflags hsc_env + showPass dflags $ + "Checking old interface for " ++ (showPpr dflags $ ms_mod mod_summary) initIfaceCheck hsc_env $ check_old_iface hsc_env mod_summary source_modified maybe_iface check_old_iface :: HscEnv -> ModSummary -> SourceModified -> Maybe ModIface - -> IfG (Bool, Maybe ModIface) + -> IfG (RecompileRequired, Maybe ModIface) check_old_iface hsc_env mod_summary src_modified maybe_iface = let dflags = hsc_dflags hsc_env getIface = @@ -1131,19 +1156,19 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface -- avoid reading an interface; just return the one we might -- have been supplied with. True | not (isObjectTarget $ hscTarget dflags) -> - return (outOfDate, maybe_iface) + return (MustCompile, maybe_iface) -- Try and read the old interface for the current module -- from the .hi file left from the last time we compiled it True -> do maybe_iface' <- getIface - return (outOfDate, maybe_iface') + return (MustCompile, maybe_iface') False -> do maybe_iface' <- getIface case maybe_iface' of -- We can't retrieve the iface - Nothing -> return (outOfDate, Nothing) + Nothing -> return (MustCompile, Nothing) -- We have got the old iface; check its versions -- even in the SourceUnmodifiedAndStable case we @@ -1151,15 +1176,6 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface -- might have changed or gone away. Just iface -> checkVersions hsc_env mod_summary iface --- | @recompileRequired@ is called from the HscMain. It checks whether --- a recompilation is required. It needs access to the persistent state, --- finder, etc, because it may have to load lots of interface files to --- check their versions. -type RecompileRequired = Bool -upToDate, outOfDate :: Bool -upToDate = False -- Recompile not required -outOfDate = True -- Recompile required - -- | Check if a module is still the same 'version'. -- -- This function is called in the recompilation checker after we have @@ -1180,9 +1196,9 @@ checkVersions hsc_env mod_summary iface ppr (mi_module iface) <> colon) ; recomp <- checkFlagHash hsc_env iface - ; if recomp then return (outOfDate, Nothing) else do { + ; if recompileRequired recomp then return (recomp, Nothing) else do { ; recomp <- checkDependencies hsc_env mod_summary iface - ; if recomp then return (outOfDate, Just iface) else do { + ; if recompileRequired recomp then return (recomp, Just iface) else do { -- Source code unchanged and no errors yet... carry on -- @@ -1211,10 +1227,13 @@ checkVersions hsc_env mod_summary iface checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired checkFlagHash hsc_env iface = do let old_hash = mi_flag_hash iface - new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) putNameLiterally + new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) + (mi_module iface) + putNameLiterally case old_hash == new_hash of True -> up_to_date (ptext $ sLit "Module flags unchanged") - False -> out_of_date_hash (ptext $ sLit " Module flags have changed") + False -> out_of_date_hash "flags changed" + (ptext $ sLit " Module flags have changed") old_hash new_hash -- If the direct imports of this module are resolved to targets that @@ -1229,18 +1248,16 @@ checkFlagHash hsc_env iface = do -- Returns True if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface - = orM (map dep_missing (ms_imps summary ++ ms_srcimps summary)) + = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary)) where prev_dep_mods = dep_mods (mi_deps iface) prev_dep_pkgs = dep_pkgs (mi_deps iface) this_pkg = thisPackage (hsc_dflags hsc_env) - orM = foldr f (return False) - where f m rest = do b <- m; if b then return True else rest - dep_missing (L _ (ImportDecl { ideclName = L _ mod, ideclPkgQual = pkg })) = do find_res <- liftIO $ findImportedModule hsc_env mod pkg + let reason = moduleNameString mod ++ " changed" case find_res of Found _ mod | pkg == this_pkg @@ -1248,20 +1265,20 @@ checkDependencies hsc_env summary iface then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " not among previous dependencies" - return outOfDate + return (RecompBecause reason) else - return upToDate + return UpToDate | otherwise -> if pkg `notElem` (map fst prev_dep_pkgs) then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " is from package " <> quotes (ppr pkg) <> text ", which is not among previous dependencies" - return outOfDate + return (RecompBecause reason) else - return upToDate + return UpToDate where pkg = modulePackageId mod - _otherwise -> return outOfDate + _otherwise -> return (RecompBecause reason) needInterface :: Module -> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired @@ -1275,8 +1292,10 @@ needInterface mod continue -- Instead, get an Either back which we can test case mb_iface of - Failed _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"), - ppr mod])) + Failed _ -> do + traceHiDiffs (sep [ptext (sLit "Couldn't load interface for module"), + ppr mod]) + return MustCompile -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain: it might -- just be that the current module doesn't need that @@ -1292,7 +1311,8 @@ checkModUsage _this_pkg UsagePackageModule{ usg_mod = mod, usg_mod_hash = old_mod_hash } = needInterface mod $ \iface -> do - checkModuleFingerprint old_mod_hash (mi_mod_hash iface) + let reason = moduleNameString (moduleName mod) ++ " changed" + checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface) -- We only track the ABI hash of package modules, rather than -- individual entity usages, so if the ABI hash changes we must -- recompile. This is safe but may entail more recompilation when @@ -1312,19 +1332,21 @@ checkModUsage this_pkg UsageHomeModule{ new_decl_hash = mi_hash_fn iface new_export_hash = mi_exp_hash iface + reason = moduleNameString mod_name ++ " changed" + -- CHECK MODULE - recompile <- checkModuleFingerprint old_mod_hash new_mod_hash - if not recompile then return upToDate else do - + recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash + if not (recompileRequired recompile) then return UpToDate else do + -- CHECK EXPORT LIST - checkMaybeHash maybe_old_export_hash new_export_hash + checkMaybeHash reason maybe_old_export_hash new_export_hash (ptext (sLit " Export list changed")) $ do -- CHECK ITEMS ONE BY ONE - recompile <- checkList [ checkEntityUsage new_decl_hash u + recompile <- checkList [ checkEntityUsage reason new_decl_hash u | u <- old_decl_hash] - if recompile - then return outOfDate -- This one failed, so just bail out now + if recompileRequired recompile + then return recompile -- This one failed, so just bail out now else up_to_date (ptext (sLit " Great! The bits I use are up to date")) @@ -1333,65 +1355,72 @@ checkModUsage _this_pkg UsageFile{ usg_file_path = file, liftIO $ handleIO handle $ do new_mtime <- getModificationUTCTime file - return $ old_mtime /= new_mtime + if (old_mtime /= new_mtime) + then return recomp + else return UpToDate where + recomp = RecompBecause (file ++ " changed") handle = #ifdef DEBUG - \e -> pprTrace "UsageFile" (text (show e)) $ return True + \e -> pprTrace "UsageFile" (text (show e)) $ return recomp #else - \_ -> return True -- if we can't find the file, just recompile, don't fail + \_ -> return recomp -- if we can't find the file, just recompile, don't fail #endif ------------------------ -checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG RecompileRequired -checkModuleFingerprint old_mod_hash new_mod_hash +checkModuleFingerprint :: String -> Fingerprint -> Fingerprint + -> IfG RecompileRequired +checkModuleFingerprint reason old_mod_hash new_mod_hash | new_mod_hash == old_mod_hash = up_to_date (ptext (sLit "Module fingerprint unchanged")) | otherwise - = out_of_date_hash (ptext (sLit " Module fingerprint has changed")) + = out_of_date_hash reason (ptext (sLit " Module fingerprint has changed")) old_mod_hash new_mod_hash ------------------------ -checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc +checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc -> IfG RecompileRequired -> IfG RecompileRequired -checkMaybeHash maybe_old_hash new_hash doc continue +checkMaybeHash reason maybe_old_hash new_hash doc continue | Just hash <- maybe_old_hash, hash /= new_hash - = out_of_date_hash doc hash new_hash + = out_of_date_hash reason doc hash new_hash | otherwise = continue ------------------------ -checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint)) +checkEntityUsage :: String + -> (OccName -> Maybe (OccName, Fingerprint)) -> (OccName, Fingerprint) -> IfG RecompileRequired -checkEntityUsage new_hash (name,old_hash) +checkEntityUsage reason new_hash (name,old_hash) = case new_hash name of Nothing -> -- We used it before, but it ain't there now - out_of_date (sep [ptext (sLit "No longer exported:"), ppr name]) + out_of_date reason (sep [ptext (sLit "No longer exported:"), ppr name]) Just (_, new_hash) -- It's there, but is it up to date? | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) - return upToDate - | otherwise -> out_of_date_hash (ptext (sLit " Out of date:") <+> ppr name) + return UpToDate + | otherwise -> out_of_date_hash reason (ptext (sLit " Out of date:") <+> ppr name) old_hash new_hash -up_to_date, out_of_date :: SDoc -> IfG RecompileRequired -up_to_date msg = traceHiDiffs msg >> return upToDate -out_of_date msg = traceHiDiffs msg >> return outOfDate +up_to_date :: SDoc -> IfG RecompileRequired +up_to_date msg = traceHiDiffs msg >> return UpToDate + +out_of_date :: String -> SDoc -> IfG RecompileRequired +out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason) -out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired -out_of_date_hash msg old_hash new_hash - = out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash]) +out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired +out_of_date_hash reason msg old_hash new_hash + = out_of_date reason (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash]) ---------------------- checkList :: [IfG RecompileRequired] -> IfG RecompileRequired -- This helper is used in two places -checkList [] = return upToDate +checkList [] = return UpToDate checkList (check:checks) = do recompile <- check - if recompile - then return outOfDate + if recompileRequired recompile + then return recompile else checkList checks \end{code} @@ -1425,6 +1454,7 @@ tyThingToIfaceDecl (ATyCon tycon) | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, + ifCType = tyConCType tycon, ifTyVars = toIfaceTvBndrs tyvars, ifCtxt = toIfaceContext (tyConStupidTheta tycon), ifCons = ifaceConDecls (algTyConRhs tycon), @@ -1613,7 +1643,7 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) -------------------------- toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId -toIfaceIdDetails (DFunId {}) = IfDFunId +toIfaceIdDetails (DFunId ns _) = IfDFunId ns toIfaceIdDetails (RecSelId { sel_naughty = n , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) @@ -1678,7 +1708,7 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity if_rhs = toIfaceExpr rhs toIfUnfolding lb (DFunUnfolding _ar _con ops) - = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) + = Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops))) -- No need to serialise the data constructor; -- we can recover it from the type of the dfun @@ -1735,7 +1765,9 @@ toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) toIfaceExpr (Coercion co) = IfaceCo (coToIfaceType co) toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b) toIfaceExpr (App f a) = toIfaceApp f [a] -toIfaceExpr (Case s x _ as) = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as) +toIfaceExpr (Case s x ty as) + | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) + | otherwise = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as) toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (coToIfaceType co) toIfaceExpr (Tick t e) = IfaceTick (toIfaceTickish t) (toIfaceExpr e) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 6946752158..80c2029a70 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -32,16 +32,16 @@ import CoreUtils import CoreUnfold import CoreLint import WorkWrap +import MkCore( castBottomExpr ) import Id import MkId import IdInfo import Class -import IParam import TyCon import DataCon import PrelNames import TysWiredIn -import TysPrim ( tySuperKindTyCon ) +import TysPrim ( superKindTyConName ) import BasicTypes ( Arity, strongLoopBreaker ) import Literal import qualified Var @@ -432,6 +432,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ; return (AnId (mkGlobalId details name ty info)) } tc_iface_decl parent _ (IfaceData {ifName = occ_name, + ifCType = cType, ifTyVars = tv_bndrs, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, @@ -443,7 +444,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, { stupid_theta <- tcIfaceCtxt ctxt ; parent' <- tc_parent tyvars mb_axiom_name ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons - ; return (buildAlgTyCon tc_name tyvars stupid_theta + ; return (buildAlgTyCon tc_name tyvars cType stupid_theta cons is_rec gadt_syn parent') } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } @@ -466,7 +467,7 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ifSynKind = kind }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop] + ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tc_syn_rhs mb_rhs_ty ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent @@ -479,27 +480,41 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, tc_iface_decl _parent ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, - ifTyVars = tv_bndrs, ifFDs = rdr_fds, + ifTyVars = tv_bndrs, ifFDs = rdr_fds, ifATs = rdr_ats, ifSigs = rdr_sigs, ifRec = tc_isrec }) -- ToDo: in hs-boot files we should really treat abstract classes specially, -- as we do abstract tycons = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop tc_occ - ; ctxt <- tcIfaceCtxt rdr_ctxt + ; traceIf (text "tc-iface-class1" <+> ppr tc_occ) + ; ctxt <- mapM tc_sc rdr_ctxt + ; traceIf (text "tc-iface-class2" <+> ppr tc_occ) ; sigs <- mapM tc_sig rdr_sigs ; fds <- mapM tc_fd rdr_fds + ; traceIf (text "tc-iface-class3" <+> ppr tc_occ) ; cls <- fixM $ \ cls -> do { ats <- mapM (tc_at cls) rdr_ats + ; traceIf (text "tc-iface-class4" <+> ppr tc_occ) ; buildClass ignore_prags tc_name tyvars ctxt fds ats sigs tc_isrec } ; return (ATyCon (classTyCon cls)) } where + tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) + -- The *length* of the superclasses is used by buildClass, and hence must + -- not be inside the thunk. But the *content* maybe recursive and hence + -- must be lazy (via forkM). Example: + -- class C (T a) => D a where + -- data T a + -- Here the associated type T is knot-tied with the class, and + -- so we must not pull on T too eagerly. See Trac #5970 + mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred + tc_sig (IfaceClassOp occ dm rdr_ty) = do { op_name <- lookupIfaceTop occ - ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty) + ; op_ty <- forkM (mk_op_doc op_name rdr_ty) (tcIfaceType rdr_ty) -- Must be done lazily for just the same reason as the -- type of a data con; to avoid sucking in types that - -- it mentions unless it's necessray to do so + -- it mentions unless it's necessary to do so ; return (op_name, dm, op_ty) } tc_at cls (IfaceAT tc_decl defs_decls) @@ -512,7 +527,7 @@ tc_iface_decl _parent ignore_prags \tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan) (mapM tcIfaceType pat_tys) (tcIfaceType ty) - mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty] + mk_op_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty] tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 ; tvs2' <- mapM tcIfaceTyVar tvs2 @@ -618,8 +633,8 @@ look at it. \begin{code} tcIfaceInst :: IfaceClsInst -> IfL ClsInst -tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag, - ifInstCls = cls, ifInstTys = mb_tcs }) +tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag + , ifInstCls = cls, ifInstTys = mb_tcs }) = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ tcIfaceExtId dfun_occ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs @@ -628,10 +643,10 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag, tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs , ifFamInstAxiom = axiom_name } ) - = do axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $ - tcIfaceCoAxiom axiom_name - let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - return (mkImportedFamInst fam mb_tcs' axiom') + = do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $ + tcIfaceCoAxiom axiom_name + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedFamInst fam mb_tcs' axiom') } \end{code} @@ -853,21 +868,75 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo \begin{code} tcIfaceType :: IfaceType -> IfL Type -tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } -tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } -tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } -tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') } +tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } +tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } +tcIfaceType (IfaceLitTy l) = do { l1 <- tcIfaceTyLit l; return (LitTy l1) } +tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } +tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc + ; tks' <- tcIfaceTcArgs (tyConKind tc') tks + ; return (mkTyConApp tc' tks') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } tcIfaceType t@(IfaceCoConApp {}) = pprPanic "tcIfaceType" (ppr t) tcIfaceTypes :: [IfaceType] -> IfL [Type] tcIfaceTypes tys = mapM tcIfaceType tys +tcIfaceTcArgs :: Kind -> [IfaceType] -> IfL [Type] +tcIfaceTcArgs _ [] + = return [] +tcIfaceTcArgs kind (tk:tks) + = case splitForAllTy_maybe kind of + Nothing -> tcIfaceTypes (tk:tks) + Just (_, kind') -> do { k' <- tcIfaceKind tk + ; tks' <- tcIfaceTcArgs kind' tks + ; return (k':tks') } + ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType tcIfaceCtxt sts = mapM tcIfaceType sts + +----------------------------------------- +tcIfaceTyLit :: IfaceTyLit -> IfL TyLit +tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) +tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) + +----------------------------------------- +tcIfaceKind :: IfaceKind -> IfL Kind -- See Note [Checking IfaceTypes vs IfaceKinds] +tcIfaceKind (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } +tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') } +tcIfaceKind (IfaceFunTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') } +tcIfaceKind (IfaceTyConApp tc ts) = do { tc' <- tcIfaceKindCon tc; ts' <- tcIfaceKinds ts; return (mkTyConApp tc' ts') } +tcIfaceKind (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceKind t; return (ForAllTy tv' t') } +tcIfaceKind t = pprPanic "tcIfaceKind" (ppr t) -- IfaceCoApp, IfaceLitTy + +tcIfaceKinds :: [IfaceKind] -> IfL [Kind] +tcIfaceKinds tys = mapM tcIfaceKind tys \end{code} +Note [Checking IfaceTypes vs IfaceKinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to know whether we are checking a *type* or a *kind*. +Consider module M where + Proxy :: forall k. k -> * + data T = T +and consider the two IfaceTypes + M.Proxy * M.T{tc} + M.Proxy 'M.T{tc} 'M.T(d} +The first is conventional, but in the latter we use the promoted +type constructor (as a kind) and data constructor (as a type). However, +the Name of the promoted type constructor is just M.T; it's the *same name* +as the ordinary type constructor. + +We could add a "promoted" flag to an IfaceTyCon, but that's a bit heavy. +Instead we use context to distinguish, as in the source language. + - When checking a kind, we look up M.T{tc} and promote it + - When checking a type, we look up M.T{tc} and don't promote it + and M.T{d} and promote it + See tcIfaceKindCon and tcIfaceKTyCon respectively + +This context business is why we need tcIfaceTcArgs. + + %************************************************************************ %* * Coercions @@ -880,6 +949,7 @@ tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts +tcIfaceCo t@(IfaceLitTy _) = mkReflCo <$> tcIfaceType t tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> mkForAllCo tv' <$> tcIfaceCo t @@ -887,7 +957,6 @@ tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts -tcIfaceCoApp (IfaceIPCoAx ip) ts = AxiomInstCo <$> liftM ipCoAxiom (newIPName ip) <*> mapM tcIfaceCo ts tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2 tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 @@ -926,11 +995,12 @@ tcIfaceExpr (IfaceExt gbl) tcIfaceExpr (IfaceLit lit) = do lit' <- tcIfaceLit lit return (Lit lit') - + tcIfaceExpr (IfaceFCall cc ty) = do ty' <- tcIfaceType ty u <- newUnique - return (Var (mkFCallId u cc ty')) + dflags <- getDynFlags + return (Var (mkFCallId dflags u cc ty')) tcIfaceExpr (IfaceTuple boxity args) = do args' <- mapM tcIfaceExpr args @@ -949,6 +1019,11 @@ tcIfaceExpr (IfaceLam bndr body) tcIfaceExpr (IfaceApp fun arg) = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg +tcIfaceExpr (IfaceECase scrut ty) + = do { scrut' <- tcIfaceExpr scrut + ; ty' <- tcIfaceType ty + ; return (castBottomExpr scrut' ty') } + tcIfaceExpr (IfaceCase scrut case_bndr alts) = do scrut' <- tcIfaceExpr scrut case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) @@ -1005,12 +1080,12 @@ tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) ------------------------- tcIfaceLit :: Literal -> IfL Literal --- Integer literals deserialise to (LitInteeger i <error thunk>) --- so tcIfaceLit just fills in the mkInteger Id +-- Integer literals deserialise to (LitInteger i <error thunk>) +-- so tcIfaceLit just fills in the type. -- See Note [Integer literals] in Literal tcIfaceLit (LitInteger i _) - = do mkIntegerId <- tcIfaceExtId mkIntegerName - return (mkLitInteger i mkIntegerId) + = do t <- tcIfaceTyCon (IfaceTc integerTyConName) + return (mkLitInteger i (mkTyConTy t)) tcIfaceLit lit = return lit ------------------------- @@ -1085,8 +1160,8 @@ do_one (IfaceRec pairs) thing_inside \begin{code} tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _ IfVanillaId = return VanillaId -tcIdDetails ty IfDFunId - = return (DFunId (isNewTyCon (classTyCon cls))) +tcIdDetails ty (IfDFunId ns) + = return (DFunId ns (isNewTyCon (classTyCon cls))) where (_, _, cls, _) = tcSplitDFunTy ty @@ -1150,12 +1225,14 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) } tcUnfolding name dfun_ty _ (IfDFunUnfold ops) - = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops + = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops ; return (case mb_ops1 of Nothing -> noUnfolding Just ops1 -> mkDFunUnfolding dfun_ty ops1) } where doc = text "Class ops for dfun" <+> ppr name + tc_arg (DFunPolyArg e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') } + tc_arg (DFunLamArg i) = return (DFunLamArg i) tcUnfolding name ty info (IfExtWrapper arity wkr) = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr) @@ -1167,15 +1244,16 @@ tcIfaceWrapper :: Name -> Type -> IdInfo -> Arity -> IfL Id -> IfL Unfolding tcIfaceWrapper name ty info arity get_worker = do { mb_wkr_id <- forkM_maybe doc get_worker ; us <- newUniqueSupply + ; dflags <- getDynFlags ; return (case mb_wkr_id of Nothing -> noUnfolding - Just wkr_id -> make_inline_rule wkr_id us) } + Just wkr_id -> make_inline_rule dflags wkr_id us) } where doc = text "Worker for" <+> ppr name - make_inline_rule wkr_id us + make_inline_rule dflags wkr_id us = mkWwInlineRule wkr_id - (initUs_ us (mkWrapper ty strict_sig) wkr_id) + (initUs_ us (mkWrapper dflags ty strict_sig) wkr_id) arity -- Again we rely here on strictness info always appearing @@ -1235,6 +1313,9 @@ tcIfaceGlobal :: Name -> IfL TyThing tcIfaceGlobal name | Just thing <- wiredInNameTyThing_maybe name -- Wired-in things include TyCons, DataCons, and Ids + -- Even though we are in an interface file, we want to make + -- sure the instances and RULES of this thing (particularly TyCon) are loaded + -- Imagine: f :: Double -> Double = do { ifCheckWiredInThing thing; return thing } | otherwise = do { env <- getGblEnv @@ -1279,37 +1360,24 @@ tcIfaceGlobal name -- emasculated form (e.g. lacking data constructors). tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon -tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon -tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon -tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon -tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon -tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) -tcIfaceTyCon (IfaceIPTc n) = do { n' <- newIPName n - ; tcWiredInTyCon (ipTyCon n') } -tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name - ; return (check_tc (tyThingTyCon thing)) } - where - check_tc tc - | debugIsOn = case toIfaceTyCon tc of - IfaceTc _ -> tc - _ -> pprTrace "check_tc" (ppr tc) tc - | otherwise = tc --- we should be okay just returning Kind constructors without extra loading -tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon -tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon -tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon -tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon -tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon -tcIfaceTyCon IfaceConstraintKindTc = return constraintKindTyCon -tcIfaceTyCon IfaceSuperKindTc = return tySuperKindTyCon - --- Even though we are in an interface file, we want to make --- sure the instances and RULES of this tycon are loaded --- Imagine: f :: Double -> Double -tcWiredInTyCon :: TyCon -> IfL TyCon -tcWiredInTyCon tc = do { ifCheckWiredInThing (ATyCon tc) - ; return tc } +tcIfaceTyCon (IfaceTc name) + = do { thing <- tcIfaceGlobal name + ; case thing of -- A "type constructor" can be a promoted data constructor + -- c.f. Trac #5881 + ATyCon tc -> return tc + ADataCon dc -> return (buildPromotedDataCon dc) + _ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) } + +tcIfaceKindCon :: IfaceTyCon -> IfL TyCon +tcIfaceKindCon (IfaceTc name) + = do { thing <- tcIfaceGlobal name + ; case thing of -- A "type constructor" here is a promoted type constructor + -- c.f. Trac #5881 + ATyCon tc + | isSuperKind (tyConKind tc) -> return tc -- Mainly just '*' or 'AnyK' + | otherwise -> return (buildPromotedTyCon tc) + + _ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) } tcIfaceCoAxiom :: Name -> IfL CoAxiom tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name @@ -1381,12 +1449,12 @@ bindIfaceTyVars bndrs thing_inside (occs,kinds) = unzip bndrs isSuperIfaceKind :: IfaceKind -> Bool -isSuperIfaceKind (IfaceTyConApp IfaceSuperKindTc []) = True +isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == superKindTyConName isSuperIfaceKind _ = False mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar mk_iface_tyvar name ifKind - = do { kind <- tcIfaceType ifKind + = do { kind <- tcIfaceKind ifKind ; return (Var.mkTyVar name kind) } bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index 32df9e3217..d05a90609e 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -49,7 +49,6 @@ module Llvm ( ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, - llvmSDoc ) where diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index c2177782f2..2b2725d187 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -19,9 +19,6 @@ module Llvm.PpLlvm ( ppLlvmFunctions, ppLlvmFunction, - -- * Utility functions - llvmSDoc - ) where #include "HsVersions.h" @@ -30,8 +27,7 @@ import Llvm.AbsSyn import Llvm.Types import Data.List ( intersperse ) -import Pretty -import qualified Outputable as Out +import Outputable import Unique -------------------------------------------------------------------------------- @@ -39,7 +35,7 @@ import Unique -------------------------------------------------------------------------------- -- | Print out a whole LLVM module. -ppLlvmModule :: LlvmModule -> Doc +ppLlvmModule :: LlvmModule -> SDoc ppLlvmModule (LlvmModule comments aliases meta globals decls funcs) = ppLlvmComments comments $+$ newLine $+$ ppLlvmAliases aliases $+$ newLine @@ -49,20 +45,20 @@ ppLlvmModule (LlvmModule comments aliases meta globals decls funcs) $+$ ppLlvmFunctions funcs -- | Print out a multi-line comment, can be inside a function or on its own -ppLlvmComments :: [LMString] -> Doc +ppLlvmComments :: [LMString] -> SDoc ppLlvmComments comments = vcat $ map ppLlvmComment comments -- | Print out a comment, can be inside a function or on its own -ppLlvmComment :: LMString -> Doc +ppLlvmComment :: LMString -> SDoc ppLlvmComment com = semi <+> ftext com -- | Print out a list of global mutable variable definitions -ppLlvmGlobals :: [LMGlobal] -> Doc +ppLlvmGlobals :: [LMGlobal] -> SDoc ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls -- | Print out a global mutable variable definition -ppLlvmGlobal :: LMGlobal -> Doc +ppLlvmGlobal :: LMGlobal -> SDoc ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) = let sect = case x of Just x' -> text ", section" <+> doubleQuotes (ftext x') @@ -85,21 +81,21 @@ ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth -- | Print out a list of LLVM type aliases. -ppLlvmAliases :: [LlvmAlias] -> Doc +ppLlvmAliases :: [LlvmAlias] -> SDoc ppLlvmAliases tys = vcat $ map ppLlvmAlias tys -- | Print out an LLVM type alias. -ppLlvmAlias :: LlvmAlias -> Doc +ppLlvmAlias :: LlvmAlias -> SDoc ppLlvmAlias (name, ty) = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty -- | Print out a list of LLVM metadata. -ppLlvmMetas :: [LlvmMeta] -> Doc +ppLlvmMetas :: [LlvmMeta] -> SDoc ppLlvmMetas metas = vcat $ map ppLlvmMeta metas -- | Print out an LLVM metadata definition. -ppLlvmMeta :: LlvmMeta -> Doc +ppLlvmMeta :: LlvmMeta -> SDoc ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas) = exclamation <> int u <> text " = metadata !{" <> hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}" @@ -112,7 +108,7 @@ ppLlvmMeta (MetaNamed n metas) pprNode n = exclamation <> int n -- | Print out an LLVM metadata value. -ppLlvmMetaVal :: LlvmMetaVal -> Doc +ppLlvmMetaVal :: LlvmMetaVal -> SDoc ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s) ppLlvmMetaVal (MetaVar v) = texts v ppLlvmMetaVal (MetaNode (LMMetaUnamed u)) @@ -120,11 +116,11 @@ ppLlvmMetaVal (MetaNode (LMMetaUnamed u)) -- | Print out a list of function definitions. -ppLlvmFunctions :: LlvmFunctions -> Doc +ppLlvmFunctions :: LlvmFunctions -> SDoc ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs -- | Print out a function definition. -ppLlvmFunction :: LlvmFunction -> Doc +ppLlvmFunction :: LlvmFunction -> SDoc ppLlvmFunction (LlvmFunction dec args attrs sec body) = let attrDoc = ppSpaceJoin attrs secDoc = case sec of @@ -139,7 +135,7 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) = $+$ newLine -- | Print out a function defenition header. -ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc +ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args = let varg' = case varg of VarArgs | null p -> text "..." @@ -155,13 +151,13 @@ ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align -- | Print out a list of function declaration. -ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc +ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs -- | Print out a function declaration. -- Declarations define the function type but don't define the actual body of -- the function. -ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc +ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) = let varg' = case varg of VarArgs | null p -> text "..." @@ -177,12 +173,12 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) -- | Print out a list of LLVM blocks. -ppLlvmBlocks :: LlvmBlocks -> Doc +ppLlvmBlocks :: LlvmBlocks -> SDoc ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks -- | Print out an LLVM block. -- It must be part of a function definition. -ppLlvmBlock :: LlvmBlock -> Doc +ppLlvmBlock :: LlvmBlock -> SDoc ppLlvmBlock (LlvmBlock blockId stmts) = go blockId stmts where @@ -201,12 +197,12 @@ ppLlvmBlock (LlvmBlock blockId stmts) $+$ ppRest -- | Print out an LLVM block label. -ppLlvmBlockLabel :: LlvmBlockId -> Doc -ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon +ppLlvmBlockLabel :: LlvmBlockId -> SDoc +ppLlvmBlockLabel id = pprUnique id <> colon -- | Print out an LLVM statement. -ppLlvmStatement :: LlvmStatement -> Doc +ppLlvmStatement :: LlvmStatement -> SDoc ppLlvmStatement stmt = let ind = (text " " <>) in case stmt of @@ -226,7 +222,7 @@ ppLlvmStatement stmt = -- | Print out an LLVM expression. -ppLlvmExpression :: LlvmExpression -> Doc +ppLlvmExpression :: LlvmExpression -> SDoc ppLlvmExpression expr = case expr of Alloca tp amount -> ppAlloca tp amount @@ -248,7 +244,7 @@ ppLlvmExpression expr -- | Should always be a function pointer. So a global var of function type -- (since globals are always pointers) or a local var of pointer function type. -ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> Doc +ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> SDoc ppCall ct fptr vals attrs = case fptr of -- -- if local var function pointer, unwrap @@ -278,13 +274,13 @@ ppCall ct fptr vals attrs = case fptr of <+> rparen <+> attrDoc -ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> Doc +ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc ppMachOp op left right = (texts op) <+> (texts (getVarType left)) <+> (text $ getName left) <> comma <+> (text $ getName right) -ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> Doc +ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc ppCmpOp op left right = let cmpOp | isInt (getVarType left) && isInt (getVarType right) = text "icmp" @@ -299,16 +295,16 @@ ppCmpOp op left right = <+> (text $ getName left) <> comma <+> (text $ getName right) -ppAssignment :: LlvmVar -> Doc -> Doc +ppAssignment :: LlvmVar -> SDoc -> SDoc ppAssignment var expr = (text $ getName var) <+> equals <+> expr -ppFence :: Bool -> LlvmSyncOrdering -> Doc +ppFence :: Bool -> LlvmSyncOrdering -> SDoc ppFence st ord = let singleThread = case st of True -> text "singlethread" False -> empty in text "fence" <+> singleThread <+> ppSyncOrdering ord -ppSyncOrdering :: LlvmSyncOrdering -> Doc +ppSyncOrdering :: LlvmSyncOrdering -> SDoc ppSyncOrdering SyncUnord = text "unordered" ppSyncOrdering SyncMonotonic = text "monotonic" ppSyncOrdering SyncAcquire = text "acquire" @@ -316,59 +312,59 @@ ppSyncOrdering SyncRelease = text "release" ppSyncOrdering SyncAcqRel = text "acq_rel" ppSyncOrdering SyncSeqCst = text "seq_cst" -ppLoad :: LlvmVar -> Doc +ppLoad :: LlvmVar -> SDoc ppLoad var = text "load" <+> texts var -ppStore :: LlvmVar -> LlvmVar -> Doc +ppStore :: LlvmVar -> LlvmVar -> SDoc ppStore val dst = text "store" <+> texts val <> comma <+> texts dst -ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc +ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to -ppMalloc :: LlvmType -> Int -> Doc +ppMalloc :: LlvmType -> Int -> SDoc ppMalloc tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 in text "malloc" <+> texts tp <> comma <+> texts amount' -ppAlloca :: LlvmType -> Int -> Doc +ppAlloca :: LlvmType -> Int -> SDoc ppAlloca tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 in text "alloca" <+> texts tp <> comma <+> texts amount' -ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> Doc +ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc ppGetElementPtr inb ptr idx = let indexes = comma <+> ppCommaJoin idx inbound = if inb then text "inbounds" else empty in text "getelementptr" <+> inbound <+> texts ptr <> indexes -ppReturn :: Maybe LlvmVar -> Doc +ppReturn :: Maybe LlvmVar -> SDoc ppReturn (Just var) = text "ret" <+> texts var ppReturn Nothing = text "ret" <+> texts LMVoid -ppBranch :: LlvmVar -> Doc +ppBranch :: LlvmVar -> SDoc ppBranch var = text "br" <+> texts var -ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> Doc +ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc ppBranchIf cond trueT falseT = text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT -ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> Doc +ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc ppPhi tp preds = let ppPreds (val, label) = brackets $ (text $ getName val) <> comma <+> (text $ getName label) in text "phi" <+> texts tp <+> hcat (intersperse comma $ map ppPreds preds) -ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> Doc +ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc ppSwitch scrut dflt targets = let ppTarget (val, lab) = texts val <> comma <+> texts lab ppTargets xs = brackets $ vcat (map ppTarget xs) @@ -376,7 +372,7 @@ ppSwitch scrut dflt targets = <+> ppTargets targets -ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> Doc +ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc ppAsm asm constraints rty vars sideeffect alignstack = let asm' = doubleQuotes $ ftext asm cons = doubleQuotes $ ftext constraints @@ -388,15 +384,15 @@ ppAsm asm constraints rty vars sideeffect alignstack = <+> cons <> vars' -ppMetaStatement :: [MetaData] -> LlvmStatement -> Doc +ppMetaStatement :: [MetaData] -> LlvmStatement -> SDoc ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta -ppMetaExpr :: [MetaData] -> LlvmExpression -> Doc +ppMetaExpr :: [MetaData] -> LlvmExpression -> SDoc ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta -ppMetas :: [MetaData] -> Doc +ppMetas :: [MetaData] -> SDoc ppMetas meta = hcat $ map ppMeta meta where ppMeta (name, (LMMetaUnamed n)) @@ -406,25 +402,21 @@ ppMetas meta = hcat $ map ppMeta meta -------------------------------------------------------------------------------- -- * Misc functions -------------------------------------------------------------------------------- -ppCommaJoin :: (Show a) => [a] -> Doc +ppCommaJoin :: (Show a) => [a] -> SDoc ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs) -ppSpaceJoin :: (Show a) => [a] -> Doc +ppSpaceJoin :: (Show a) => [a] -> SDoc ppSpaceJoin strs = hcat $ intersperse space (map texts strs) --- | Convert SDoc to Doc -llvmSDoc :: Out.SDoc -> Doc -llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d - --- | Showable to Doc -texts :: (Show a) => a -> Doc +-- | Showable to SDoc +texts :: (Show a) => a -> SDoc texts = (text . show) -- | Blank line. -newLine :: Doc +newLine :: SDoc newLine = text "" -- | Exclamation point. -exclamation :: Doc +exclamation :: SDoc exclamation = text "!" diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 531d90a8ee..5c2e420545 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -27,6 +27,7 @@ import UniqSupply import Util import SysTools ( figureLlvmVersion ) +import Control.Monad ( when ) import Data.IORef ( writeIORef ) import Data.Maybe ( fromMaybe ) import System.IO @@ -48,12 +49,10 @@ llvmCodeGen dflags h us cmms in (d,env') in do showPass dflags "LlVM CodeGen" - dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc pprLlvmHeader + dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader bufh <- newBufHandle h - Prt.bufLeftRender bufh $ pprLlvmHeader - ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags - -- cache llvm version for later use - writeIORef (llvmVersion dflags) ver + Prt.bufLeftRender bufh $ withPprStyleDoc dflags (mkCodeStyle CStyle) pprLlvmHeader + ver <- getLlvmVersion env' <- {-# SCC "llvm_datas_gen" #-} cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] {-# SCC "llvm_procs_gen" #-} @@ -61,6 +60,22 @@ llvmCodeGen dflags h us cmms bFlush bufh return () + where + -- | Handle setting up the LLVM version. + getLlvmVersion = do + ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags + -- cache llvm version for later use + writeIORef (llvmVersion dflags) ver + when (ver < minSupportLlvmVersion) $ + errorMsg dflags (text "You are using an old version of LLVM that" + <> text " isn't supported anymore!" + $+$ text "We will try though...") + when (ver > maxSupportLlvmVersion) $ + putMsg dflags (text "You are using a new version of LLVM that" + <> text " hasn't been tested yet!" + $+$ text "We will try though...") + return ver + -- ----------------------------------------------------------------------------- -- | Do LLVM code generation on all these Cmms data sections. @@ -72,11 +87,11 @@ cmmDataLlvmGens dflags h env [] lmdata = let (env', lmdata') = {-# SCC "llvm_resolve" #-} resolveLlvmDatas env lmdata lmdoc = {-# SCC "llvm_data_ppr" #-} - Prt.vcat $ map pprLlvmData lmdata' + vcat $ map pprLlvmData lmdata' in do - dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc + dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc {-# SCC "llvm_data_out" #-} - Prt.bufLeftRender h lmdoc + Prt.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle CStyle) lmdoc return env' cmmDataLlvmGens dflags h env (cmm:cmms) lmdata @@ -100,7 +115,7 @@ cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl cmmProcLlvmGens _ _ _ _ [] _ [] = return () -cmmProcLlvmGens _ h _ _ [] _ ivars +cmmProcLlvmGens dflags h _ _ [] _ ivars = let ivars' = concat ivars cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr ty = (LMArray (length ivars') i8Ptr) @@ -108,6 +123,7 @@ cmmProcLlvmGens _ h _ _ [] _ ivars lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray) in Prt.bufLeftRender h $ {-# SCC "llvm_used_ppr" #-} + withPprStyleDoc dflags (mkCodeStyle CStyle) $ pprLlvmData ([lmUsed], []) cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars @@ -119,7 +135,8 @@ cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivar cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm - Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} Prt.vcat docs + Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} + withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars) @@ -132,14 +149,14 @@ cmmLlvmGen dflags us env cmm = do fixStgRegisters cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmmGroup (targetPlatform dflags) [fixed_cmm]) + (pprCmmGroup [fixed_cmm]) -- generate llvm code from cmm let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-} initUs us $ genLlvmProc env fixed_cmm dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" - (vcat $ map (docToSDoc . fst . pprLlvmCmmDecl env' 0) llvmBC) + (vcat $ map (fst . pprLlvmCmmDecl env' 0) llvmBC) return (usGen, env', llvmBC) diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 9bdb115505..19ca511f16 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -9,7 +9,8 @@ module LlvmCodeGen.Base ( LlvmCmmDecl, LlvmBasicBlock, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, - LlvmVersion, defaultLlvmVersion, + LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion, + maxSupportLlvmVersion, LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert, funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform, @@ -144,7 +145,13 @@ type LlvmVersion = Int -- | The LLVM Version we assume if we don't know defaultLlvmVersion :: LlvmVersion -defaultLlvmVersion = 28 +defaultLlvmVersion = 30 + +minSupportLlvmVersion :: LlvmVersion +minSupportLlvmVersion = 28 + +maxSupportLlvmVersion :: LlvmVersion +maxSupportLlvmVersion = 31 -- ---------------------------------------------------------------------------- -- * Environment Handling @@ -226,7 +233,10 @@ getDflags (LlvmEnv (_, _, _, d)) = d -- | Pretty print a 'CLabel'. strCLabel_llvm :: LlvmEnv -> CLabel -> LMString strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-} - (fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l + (fsLit . toString . pprCLabel (getLlvmPlatform env)) l + where dflags = getDflags env + style = Outp.mkCodeStyle Outp.CStyle + toString doc = Outp.renderWithStyle dflags doc style -- | Create an external definition for a 'CLabel' defined in another module. genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 059328f868..79a0c00543 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -172,7 +172,7 @@ genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] -- Write barrier needs to be handled specially as it is implemented as an LLVM -- intrinsic function. -genCall env (CmmPrim MO_WriteBarrier) _ _ _ +genCall env (CmmPrim MO_WriteBarrier _) _ _ _ | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] = return (env, nilOL, []) | getLlvmVer env > 29 = barrier env @@ -182,7 +182,7 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ -- types and things like Word8 are backed by an i32 and just present a logical -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM -- is strict about types. -genCall env t@(CmmPrim (MO_PopCnt w)) [CmmHinted dst _] args _ = do +genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do let width = widthToLlvmInt w dstTy = cmmToLlvmType $ localRegType dst funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible @@ -202,10 +202,12 @@ genCall env t@(CmmPrim (MO_PopCnt w)) [CmmHinted dst _] args _ = do -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. -genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy || - op == MO_Memset || - op == MO_Memmove = do - let (isVolTy, isVolVal) = if getLlvmVer env >= 28 +genCall env t@(CmmPrim op _) [] args' CmmMayReturn + | op == MO_Memcpy || + op == MO_Memset || + op == MO_Memmove = do + let (args, alignVal) = splitAlignVal args' + (isVolTy, isVolVal) = if getLlvmVer env >= 28 then ([i1], [mkIntLit i1 0]) else ([], []) argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy | otherwise = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy @@ -216,11 +218,25 @@ genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy || (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t (argVars', stmts3) <- castVars $ zip argVars argTy - let arguments = argVars' ++ isVolVal + let arguments = argVars' ++ (alignVal:isVolVal) call = Expr $ Call StdCall fptr arguments [] stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` trashStmts `snocOL` call return (env2, stmts, top1 ++ top2) + + where + splitAlignVal xs = (init xs, extractLit $ last xs) + + -- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other + -- than a direct constant (i.e. 'i32 8') as the alignment argument for the + -- memcpy & co llvm intrinsic functions. So we handle this directly now. + extractLit (CmmHinted (CmmLit (CmmInt i _)) _) = mkIntLit i32 i + extractLit _other = trace ("WARNING: Non constant alignment value given" ++ + " for memcpy! Please report to GHC developers") + mkIntLit i32 0 + +genCall env (CmmPrim _ (Just stmts)) _ _ _ + = stmtsToInstrs env stmts (nilOL, []) -- Handle all other foreign calls and prim ops. genCall env target res args ret = do @@ -240,7 +256,7 @@ genCall env target res args ret = do -- extract Cmm call convention let cconv = case target of CmmCallee _ conv -> conv - CmmPrim _ -> PrimCallConv + CmmPrim _ _ -> PrimCallConv -- translate to LLVM call convention let lmconv = case cconv of @@ -337,7 +353,7 @@ getFunPtr env funTy targ = case targ of (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) return (env', v2, stmts `snocOL` s1, top) - CmmPrim mop -> litCase $ cmmPrimOpFunctions env mop + CmmPrim mop _ -> litCase $ cmmPrimOpFunctions env mop where litCase name = do @@ -469,17 +485,21 @@ cmmPrimOpFunctions env mop (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w) - MO_WriteBarrier -> - panic $ "cmmPrimOpFunctions: MO_WriteBarrier not supported here" - MO_Touch -> - panic $ "cmmPrimOpFunctions: MO_Touch not supported here" + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported where intrinTy1 = (if getLlvmVer env >= 28 then "p0i8.p0i8." else "") ++ show llvmWord intrinTy2 = (if getLlvmVer env >= 28 then "p0i8." else "") ++ show llvmWord - + unsupported = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " not supported here") -- | Tail function calls genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData @@ -627,7 +647,7 @@ genStore_slow env addr val meta = do other -> pprPanic "genStore: ptr not right type!" - (PprCmm.pprExpr (getLlvmPlatform env) addr <+> text ( + (PprCmm.pprExpr addr <+> text ( "Size of Ptr: " ++ show llvmPtrBits ++ ", Size of var: " ++ show (llvmWidthInBits other) ++ ", Var: " ++ show vaddr)) @@ -942,7 +962,10 @@ genMachOp_slow env opt op [x, y] = case op of else do -- Error. Continue anyway so we can debug the generated ll file. - let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr (getLlvmPlatform env)) + let dflags = getDflags env + style = mkCodeStyle CStyle + toString doc = renderWithStyle dflags doc style + cmmToStr = (lines . toString . PprCmm.pprExpr) let dx = Comment $ map fsLit $ cmmToStr x let dy = Comment $ map fsLit $ cmmToStr y (v1, s1) <- doExpr (ty vx) $ binOp vx vy @@ -1101,7 +1124,7 @@ genLoad_slow env e ty meta = do return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) other -> pprPanic "exprToVar: CmmLoad expression is not right type!" - (PprCmm.pprExpr (getLlvmPlatform env) e <+> text ( + (PprCmm.pprExpr e <+> text ( "Size of Ptr: " ++ show llvmPtrBits ++ ", Size of var: " ++ show (llvmWidthInBits other) ++ ", Var: " ++ show iptr)) diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 187d1ecf03..1c715989a8 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -17,8 +17,7 @@ import CLabel import OldCmm import FastString -import qualified Outputable -import Pretty +import Outputable import Unique @@ -27,7 +26,7 @@ import Unique -- -- | Header code for LLVM modules -pprLlvmHeader :: Doc +pprLlvmHeader :: SDoc pprLlvmHeader = moduleLayout $+$ text "" @@ -37,7 +36,7 @@ pprLlvmHeader = -- | LLVM module layout description for the host target -moduleLayout :: Doc +moduleLayout :: SDoc moduleLayout = #if i386_TARGET_ARCH @@ -76,7 +75,7 @@ moduleLayout = -- | Pretty print LLVM data code -pprLlvmData :: LlvmData -> Doc +pprLlvmData :: LlvmData -> SDoc pprLlvmData (globals, types) = let tryConst (v, Just s ) = ppLlvmGlobal (v, Just s) tryConst g@(_, Nothing) = ppLlvmGlobal g @@ -91,7 +90,7 @@ pprLlvmData (globals, types) = -- | Pretty print LLVM code -pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (Doc, [LlvmVar]) +pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar]) pprLlvmCmmDecl _ _ (CmmData _ lmdata) = (vcat $ map pprLlvmData lmdata, []) @@ -116,7 +115,7 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks)) -- | Pretty print CmmStatic -pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (Doc, [LlvmVar]) +pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (SDoc, [LlvmVar]) pprInfoTable env count info_lbl stat = let unres = genLlvmData env (Text, stat) (_, (ldata, ltypes)) = resolveLlvmData env unres diff --git a/compiler/main/Annotations.lhs b/compiler/main/Annotations.hs index ec61a1f4a6..277c059b11 100644 --- a/compiler/main/Annotations.lhs +++ b/compiler/main/Annotations.hs @@ -1,37 +1,30 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +-- | +-- Support for source code annotation feature of GHC. That is the ANN pragma. +-- +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- module Annotations ( - -- * Main Annotation data types - Annotation(..), - AnnTarget(..), CoreAnnTarget, - getAnnTargetName_maybe, - - -- * AnnEnv for collecting and querying Annotations - AnnEnv, - mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns, - deserializeAnns - ) where + -- * Main Annotation data types + Annotation(..), + AnnTarget(..), CoreAnnTarget, + getAnnTargetName_maybe, + + -- * AnnEnv for collecting and querying Annotations + AnnEnv, + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns, + deserializeAnns + ) where -import Name import Module ( Module ) +import Name import Outputable -import UniqFM import Serialized +import UniqFM import Unique -import Data.Typeable import Data.Maybe +import Data.Typeable import Data.Word ( Word8 ) @@ -40,14 +33,14 @@ import Data.Word ( Word8 ) data Annotation = Annotation { ann_target :: CoreAnnTarget, -- ^ The target of the annotation ann_value :: Serialized -- ^ 'Serialized' version of the annotation that - -- allows recovery of its value or can + -- allows recovery of its value or can -- be persisted to an interface file } -- | An annotation target data AnnTarget name = NamedTarget name -- ^ We are annotating something with a name: - -- a type or identifier + -- a type or identifier | ModuleTarget Module -- ^ We are annotating a particular module -- | The kind of annotation target found in the middle end of the compiler @@ -57,6 +50,7 @@ instance Functor AnnTarget where fmap f (NamedTarget nm) = NamedTarget (f nm) fmap _ (ModuleTarget mod) = ModuleTarget mod +-- | Get the 'name' of an annotation target if it exists. getAnnTargetName_maybe :: AnnTarget name -> Maybe name getAnnTargetName_maybe (NamedTarget nm) = Just nm getAnnTargetName_maybe _ = Nothing @@ -74,20 +68,25 @@ instance Outputable Annotation where ppr ann = ppr (ann_target ann) -- | A collection of annotations -newtype AnnEnv = MkAnnEnv (UniqFM [Serialized]) -- Can't use a type synonym or we hit bug #2412 due to source import +newtype AnnEnv = MkAnnEnv (UniqFM [Serialized]) +-- | An empty annotation environment. emptyAnnEnv :: AnnEnv emptyAnnEnv = MkAnnEnv emptyUFM +-- | Construct a new annotation environment that contains the list of +-- annotations provided. mkAnnEnv :: [Annotation] -> AnnEnv mkAnnEnv = extendAnnEnvList emptyAnnEnv +-- | Add the given annotation to the environment. extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv extendAnnEnvList (MkAnnEnv env) anns = MkAnnEnv $ addListToUFM_C (++) env $ map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns +-- | Union two annotation environments. plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2 @@ -105,4 +104,4 @@ findAnns deserialize (MkAnnEnv ann_env) deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a] deserializeAnns deserialize (MkAnnEnv ann_env) = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env -\end{code} + diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 148e11f65b..c6d07ce027 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -243,6 +243,6 @@ missingArgErr f = Left ("missing argument for flag: " ++ f) errorsToGhcException :: [Located String] -> GhcException errorsToGhcException errs = - let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ] - in UsageError (renderWithStyle errors cmdlineParserStyle) + UsageError $ + intercalate "\n" [ showUserSpan True l ++ ": " ++ e | L l e <- errs ] diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index f29b479db2..b4d6371a5d 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -17,7 +17,6 @@ import Finder ( mkStubPaths ) import PprC ( writeCs ) import OldCmmLint ( cmmLint ) import Packages -import Util import OldCmm ( RawCmmGroup ) import HscTypes import DynFlags @@ -26,10 +25,11 @@ import SysTools import Stream (Stream) import qualified Stream -import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) +import ErrUtils import Outputable import Module import Maybes ( firstJusts ) +import SrcLoc import Control.Exception import Control.Monad @@ -65,7 +65,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream do_lint cmm = do { showPass dflags "CmmLint" ; case cmmLint (targetPlatform dflags) cmm of - Just err -> do { printDump err + Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err ; ghcExit dflags 1 } Nothing -> return () @@ -201,14 +201,13 @@ outputForeignStubs dflags mod location stubs ForeignStubs h_code c_code -> do let stub_c_output_d = pprCode CStyle c_code - stub_c_output_w = showSDoc stub_c_output_d + stub_c_output_w = showSDoc dflags stub_c_output_d -- Header file protos for "foreign export"ed functions. stub_h_output_d = pprCode CStyle h_code - stub_h_output_w = showSDoc stub_h_output_d - -- in + stub_h_output_w = showSDoc dflags stub_h_output_d - createDirectoryHierarchy (takeDirectory stub_h) + createDirectoryIfMissing True (takeDirectory stub_h) dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d diff --git a/compiler/main/Constants.lhs b/compiler/main/Constants.lhs index 2e276f64c6..0cecb82f1a 100644 --- a/compiler/main/Constants.lhs +++ b/compiler/main/Constants.lhs @@ -13,8 +13,12 @@ module Constants (module Constants) where +import Config + #include "ghc_boot_platform.h" #include "../includes/HaskellConstants.hs" +hiVersion :: Integer +hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer \end{code} diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 1694aba9b8..953b2c4568 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -176,9 +176,9 @@ processDeps :: DynFlags -- -- For {-# SOURCE #-} imports the "hi" will be "hi-boot". -processDeps _ _ _ _ _ (CyclicSCC nodes) +processDeps dflags _ _ _ _ (CyclicSCC nodes) = -- There shouldn't be any cycles; report them - ghcError (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes)) + ghcError (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes)) processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) = do { let extra_suffixes = depSuffixes dflags @@ -240,8 +240,10 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps | otherwise -> return Nothing - fail -> throwOneError $ mkPlainErrMsg srcloc $ - cannotFindModule (hsc_dflags hsc_env) imp fail + fail -> + let dflags = hsc_dflags hsc_env + in throwOneError $ mkPlainErrMsg dflags srcloc $ + cannotFindModule dflags imp fail } ----------------------------- diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index df6e7fd163..47706798f7 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -326,8 +326,7 @@ link' dflags batch_attempt_linking hpt return Succeeded else do - compilationProgressMsg dflags $ showSDoc $ - (ptext (sLit "Linking") <+> text exe_file <+> text "...") + compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...") -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of @@ -774,7 +773,7 @@ runPhase (Cpp sf) input_fn dflags0 (dflags1, unhandled_flags, warns) <- io $ parseDynamicFilePragma dflags0 src_opts setDynFlags dflags1 - io $ checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult dflags1 unhandled_flags if not (xopt Opt_Cpp dflags1) then do -- we have to be careful to emit warnings only once. @@ -791,7 +790,7 @@ runPhase (Cpp sf) input_fn dflags0 src_opts <- io $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) <- io $ parseDynamicFilePragma dflags0 src_opts - io $ checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult dflags2 unhandled_flags unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings @@ -826,7 +825,7 @@ runPhase (HsPp sf) input_fn dflags (dflags1, unhandled_flags, warns) <- io $ parseDynamicFilePragma dflags src_opts setDynFlags dflags1 - io $ checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult dflags1 unhandled_flags io $ handleFlagWarnings dflags1 warns return (Hsc sf, output_fn) @@ -1176,14 +1175,17 @@ runPhase As input_fn dflags = do llvmVer <- io $ figureLlvmVersion dflags return $ case llvmVer of - Just n | n >= 30 -> SysTools.runClang - _ -> SysTools.runAs + -- using cGccLinkerOpts here but not clear if + -- opt_c isn't a better choice + Just n | n >= 30 -> + (SysTools.runClang, cGccLinkerOpts) + + _ -> (SysTools.runAs, getOpts dflags opt_a) | otherwise - = return SysTools.runAs + = return (SysTools.runAs, getOpts dflags opt_a) - as_prog <- whichAsProg - let as_opts = getOpts dflags opt_a + (as_prog, as_opts) <- whichAsProg let cmdline_include_paths = includePaths dflags next_phase <- maybeMergeStub @@ -1191,7 +1193,7 @@ runPhase As input_fn dflags -- we create directories for the object file, because it -- might be a hierarchical module. - io $ createDirectoryHierarchy (takeDirectory output_fn) + io $ createDirectoryIfMissing True (takeDirectory output_fn) io $ as_prog dflags (map SysTools.Option as_opts @@ -1230,7 +1232,7 @@ runPhase SplitAs _input_fn dflags osuf = objectSuf dflags split_odir = base_o ++ "_" ++ osuf ++ "_split" - io $ createDirectoryHierarchy split_odir + io $ createDirectoryIfMissing True split_odir -- remove M_split/ *.o, because we're going to archive M_split/ *.o -- later and we don't want to pick up any old objects. @@ -1369,7 +1371,8 @@ runPhase LlvmLlc input_fn dflags SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts ++ [SysTools.Option tbaa] - ++ map SysTools.Option fpOpts) + ++ map SysTools.Option fpOpts + ++ map SysTools.Option abiOpts) return (next_phase, output_fn) where @@ -1381,12 +1384,19 @@ runPhase LlvmLlc input_fn dflags -- while compiling GHC source code. It's probably due to fact that it -- does not enable VFP by default. Let's do this manually here fpOpts = case platformArch (targetPlatform dflags) of - ArchARM ARMv7 ext -> if (elem VFPv3 ext) + ArchARM ARMv7 ext _ -> if (elem VFPv3 ext) then ["-mattr=+v7,+vfp3"] else if (elem VFPv3D16 ext) then ["-mattr=+v7,+vfp3,+d16"] else [] _ -> [] + -- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still + -- compiles into soft-float ABI. We need to explicitly set abi + -- to hard + abiOpts = case platformArch (targetPlatform dflags) of + ArchARM ARMv7 _ HARD -> ["-float-abi=hard"] + ArchARM ARMv7 _ _ -> [] + _ -> [] ----------------------------------------------------------------------------- -- LlvmMangle phase @@ -1453,9 +1463,9 @@ runPhase_MoveBinary dflags input_fn return True | otherwise = return True -mkExtraCObj :: DynFlags -> String -> IO FilePath -mkExtraCObj dflags xs - = do cFile <- newTempName dflags "c" +mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath +mkExtraObj dflags extn xs + = do cFile <- newTempName dflags extn oFile <- newTempName dflags "o" writeFile cFile xs let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId @@ -1474,23 +1484,19 @@ mkExtraCObj dflags xs -- so now we generate and compile a main() stub as part of every -- binary and pass the -rtsopts setting directly to the RTS (#5373) -- -mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath -mkExtraObjToLinkIntoBinary dflags dep_packages = do - link_info <- getLinkInfo dflags dep_packages - +mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath +mkExtraObjToLinkIntoBinary dflags = do let have_rts_opts_flags = isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of RtsOptsSafeOnly -> False _ -> True when (dopt Opt_NoHsMain dflags && have_rts_opts_flags) $ do - hPutStrLn stderr $ "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main.\n" ++ - " Call hs_init_ghc() from your main() function to set these options." + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ + text " Call hs_init_ghc() from your main() function to set these options.") - mkExtraCObj dflags (showSDoc (vcat [main, - link_opts link_info] - <> char '\n')) -- final newline, to - -- keep gcc happy + mkExtraObj dflags "c" (showSDoc dflags main) where main @@ -1508,31 +1514,40 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do Just opts -> ptext (sLit " __conf.rts_opts= ") <> text (show opts) <> semi, ptext (sLit " return hs_main(argc, argv, &ZCMain_main_closure,__conf);"), - char '}' + char '}', + char '\n' -- final newline, to keep gcc happy ] - link_opts info - | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - = empty - | otherwise = hcat [ - text "__asm__(\"\\t.section ", text ghcLinkInfoSectionName, - text ",\\\"\\\",", - text elfSectionNote, - text "\\n", +-- Write out the link info section into a new assembly file. Previously +-- this was included as inline assembly in the main.c file but this +-- is pretty fragile. gas gets upset trying to calculate relative offsets +-- that span the .note section (notably .text) when debug info is present +mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary dflags dep_packages = do + link_info <- getLinkInfo dflags dep_packages + + if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) + then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) + else return [] + + where + link_opts info = hcat [ + text "\t.section ", text ghcLinkInfoSectionName, + text ",\"\",", + text elfSectionNote, + text "\n", - text "\\t.ascii \\\"", info', text "\\\"\\n\");" ] + text "\t.ascii \"", info', text "\"\n" ] where - -- we need to escape twice: once because we're inside a C string, - -- and again because we're inside an asm string. - info' = text $ (escape.escape) info + info' = text $ escape info escape :: String -> String escape = concatMap (charToC.fromIntegral.ord) elfSectionNote :: String elfSectionNote = case platformArch (targetPlatform dflags) of - ArchARM _ _ -> "%note" - _ -> "@note" + ArchARM _ _ _ -> "%note" + _ -> "@note" -- The "link info" is a string representing the parameters of the -- link. We save this information in the binary, and the next time we @@ -1661,7 +1676,8 @@ linkBinary dflags o_files dep_packages = do let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths - extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags + noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages pkg_link_opts <- getPackageLinkOpts dflags dep_packages @@ -1778,7 +1794,7 @@ linkBinary dflags o_files dep_packages = do ++ framework_path_opts ++ framework_opts ++ pkg_lib_path_opts - ++ [extraLinkObj] + ++ extraLinkObj:noteLinkObjs ++ pkg_link_opts ++ pkg_framework_path_opts ++ pkg_framework_opts @@ -2132,6 +2148,6 @@ hscPostBackendPhase dflags _ hsc_lang = touchObjectFile :: DynFlags -> FilePath -> IO () touchObjectFile dflags path = do - createDirectoryHierarchy $ takeDirectory path + createDirectoryIfMissing True $ takeDirectory path SysTools.touch dflags "Touching object file" path diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 0553bd8848..60b6e82bb7 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -16,7 +16,8 @@ module DynFlags ( DynFlag(..), WarningFlag(..), ExtensionFlag(..), - LogAction, + Language(..), + FatalMessager, LogAction, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags, dopt, @@ -28,23 +29,29 @@ module DynFlags ( xopt, xopt_set, xopt_unset, + lang_set, DynFlags(..), HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, + targetRetainsAllBindings, GhcMode(..), isOneShot, GhcLink(..), isNoLink, PackageFlag(..), + PkgConfRef(..), Option(..), showOpt, DynLibLoader(..), fFlags, fWarningFlags, fLangFlags, xFlags, wayNames, dynFlagDependencies, + printOutputForUser, printInfoForUser, + -- ** Safe Haskell SafeHaskellMode(..), safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn, packageTrustOn, safeDirectImpsReq, safeImplicitImpsReq, + unsafeFlags, -- ** System tool settings and locations Settings(..), @@ -60,7 +67,11 @@ module DynFlags ( -- ** Manipulating DynFlags defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags + defaultFatalMessager, defaultLogAction, + defaultLogActionHPrintDoc, + defaultFlushOut, + defaultFlushErr, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlags, @@ -72,7 +83,13 @@ module DynFlags ( -- ** Parsing DynFlags parseDynamicFlagsCmdLine, parseDynamicFilePragma, + parseDynamicFlagsFull, + + -- ** Available DynFlags allFlags, + flagsAll, + flagsDynamic, + flagsPackage, supportedLanguagesAndExtensions, @@ -84,12 +101,15 @@ module DynFlags ( getStgToDo, -- * Compiler configuration suitable for display to the user - compilerInfo + compilerInfo, + #ifdef GHCI -- Only in stage 2 can we be sure that the RTS -- exposes the appropriate runtime boolean - , rtsIsProfiled + rtsIsProfiled, #endif + -- ** Only for use in the tracing functions in Outputable + tracingDynFlags, ) where #include "HsVersions.h" @@ -107,6 +127,7 @@ import Constants ( mAX_CONTEXT_REDUCTION_DEPTH ) import Panic import Util import Maybes ( orElse ) +import qualified Pretty import SrcLoc import FastString import Outputable @@ -128,7 +149,7 @@ import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import System.FilePath -import System.IO ( stderr, hPutChar ) +import System.IO import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -207,6 +228,7 @@ data DynFlag | Opt_D_dump_splices | Opt_D_dump_BCOs | Opt_D_dump_vect + | Opt_D_dump_avoid_vect | Opt_D_dump_ticked | Opt_D_dump_rtti | Opt_D_source_stats @@ -224,7 +246,7 @@ data DynFlag | Opt_DoStgLinting | Opt_DoCmmLinting | Opt_DoAsmLinting - | Opt_NoLlvmMangler + | Opt_NoLlvmMangler -- hidden flag | Opt_WarnIsError -- -Werror; makes warnings fatal @@ -247,11 +269,13 @@ data DynFlag | Opt_DictsCheap | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_Vectorise + | Opt_AvoidVect | Opt_RegsGraph -- do graph coloring register allocation | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation | Opt_PedanticBottoms -- Be picky about how we treat bottom - | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA - | Opt_RegLiveness -- Use the STG Reg liveness information + | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA (hidden flag) + | Opt_RegLiveness -- Use the STG Reg liveness information (hidden flag) + | Opt_IrrefutableTuples -- Interface files | Opt_IgnoreInterfacePragmas @@ -267,7 +291,6 @@ data DynFlag | Opt_ForceRecomp | Opt_ExcessPrecision | Opt_EagerBlackHoling - | Opt_ReadUserPackageConf | Opt_NoHsMain | Opt_SplitObjs | Opt_StgStats @@ -287,10 +310,16 @@ data DynFlag | Opt_BuildingCabalPackage | Opt_SSE2 | Opt_SSE4_2 + | Opt_IgnoreDotGhci | Opt_GhciSandbox | Opt_GhciHistory | Opt_HelpfulErrors | Opt_DeferTypeErrors + | Opt_Parallel + | Opt_GranMacros + + -- output style opts + | Opt_PprCaseAsLet -- temporary flags | Opt_RunCPS @@ -349,6 +378,7 @@ data WarningFlag = | Opt_WarnUnsafe | Opt_WarnSafe | Opt_WarnPointlessPragmas + | Opt_WarnUnsupportedCallingConventions deriving (Eq, Show, Enum) data Language = Haskell98 | Haskell2010 @@ -360,15 +390,18 @@ data SafeHaskellMode | Sf_Unsafe | Sf_Trustworthy | Sf_Safe - | Sf_SafeInfered + | Sf_SafeInferred deriving (Eq) +instance Show SafeHaskellMode where + show Sf_None = "None" + show Sf_Unsafe = "Unsafe" + show Sf_Trustworthy = "Trustworthy" + show Sf_Safe = "Safe" + show Sf_SafeInferred = "Safe-Inferred" + instance Outputable SafeHaskellMode where - ppr Sf_None = ptext $ sLit "None" - ppr Sf_Unsafe = ptext $ sLit "Unsafe" - ppr Sf_Trustworthy = ptext $ sLit "Trustworthy" - ppr Sf_Safe = ptext $ sLit "Safe" - ppr Sf_SafeInfered = ptext $ sLit "Safe-Infered" + ppr = text . show data ExtensionFlag = Opt_Cpp @@ -435,7 +468,6 @@ data ExtensionFlag | Opt_MonadComprehensions | Opt_GeneralizedNewtypeDeriving | Opt_RecursiveDo - | Opt_DoRec | Opt_PostfixOperators | Opt_TupleSections | Opt_PatternGuards @@ -444,6 +476,7 @@ data ExtensionFlag | Opt_RankNTypes | Opt_ImpredicativeTypes | Opt_TypeOperators + | Opt_ExplicitNamespaces | Opt_PackageImports | Opt_ExplicitForAll | Opt_AlternativeLayoutRule @@ -538,8 +571,8 @@ data DynFlags = DynFlags { depSuffixes :: [String], -- Package flags - extraPkgConfs :: [FilePath], - -- ^ The @-package-conf@ flags given on the command line, in the order + extraPkgConfs :: [PkgConfRef] -> [PkgConfRef], + -- ^ The @-package-db@ flags given on the command line, in the order -- they appeared. packageFlags :: [PackageFlag], @@ -585,12 +618,22 @@ data DynFlags = DynFlags { -- | MsgDoc output action: use "ErrUtils" instead of this if you can log_action :: LogAction, + flushOut :: FlushOut, + flushErr :: FlushErr, haddockOptions :: Maybe String, + ghciScripts :: [String], + + -- Output style options + pprUserLength :: Int, + pprCols :: Int, + traceLevel :: Int, -- Standard level is 1. Less verbose is 0. -- | what kind of {-# SCC #-} to add automatically profAuto :: ProfAuto, + interactivePrint :: Maybe String, + llvmVersion :: IORef (Int) } @@ -728,7 +771,7 @@ wayNames = map wayName . ways -- from an imported module. This will fail if no code has been generated -- for this module. You can use 'GHC.needsTemplateHaskell' to detect -- whether this might be the case and choose to either switch to a --- different target or avoid typechecking such modules. (The latter may +-- different target or avoid typechecking such modules. (The latter may be -- preferable for security reasons.) -- data HscTarget @@ -753,6 +796,17 @@ isObjectTarget HscAsm = True isObjectTarget HscLlvm = True isObjectTarget _ = False +-- | Does this target retain *all* top-level bindings for a module, +-- rather than just the exported bindings, in the TypeEnv and compiled +-- code (if any)? In interpreted mode we do this, so that GHCi can +-- call functions inside a module. In HscNothing mode we also do it, +-- so that Haddock can get access to the GlobalRdrEnv for a module +-- after typechecking it. +targetRetainsAllBindings :: HscTarget -> Bool +targetRetainsAllBindings HscInterpreted = True +targetRetainsAllBindings HscNothing = True +targetRetainsAllBindings _ = False + -- | The 'GhcMode' tells us whether we're doing multi-module -- compilation (controlled via the "GHC" API) or one-shot -- (single-module) compilation. This makes a difference primarily to @@ -899,7 +953,7 @@ defaultDynFlags mySettings = hpcDir = ".hpc", - extraPkgConfs = [], + extraPkgConfs = id, packageFlags = [], pkgDatabase = Nothing, pkgState = panic "no package state yet: call GHC.setSessionDynFlags", @@ -920,8 +974,9 @@ defaultDynFlags mySettings = haddockOptions = Nothing, flags = IntSet.fromList (map fromEnum defaultFlags), warningFlags = IntSet.fromList (map fromEnum standardWarnings), + ghciScripts = [], language = Nothing, - safeHaskell = Sf_SafeInfered, + safeHaskell = Sf_SafeInferred, thOnLoc = noSrcSpan, newDerivOnLoc = noSrcSpan, pkgTrustOnLoc = noSrcSpan, @@ -930,23 +985,72 @@ defaultDynFlags mySettings = extensions = [], extensionFlags = flattenExtensionFlags Nothing [], log_action = defaultLogAction, + flushOut = defaultFlushOut, + flushErr = defaultFlushErr, + pprUserLength = 5, + pprCols = 100, + traceLevel = 1, profAuto = NoProfAuto, - llvmVersion = panic "defaultDynFlags: No llvmVersion" + llvmVersion = panic "defaultDynFlags: No llvmVersion", + interactivePrint = Nothing } -type LogAction = Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () +-- Do not use tracingDynFlags! +-- tracingDynFlags is a hack, necessary because we need to be able to +-- show SDocs when tracing, but we don't always have DynFlags available. +-- Do not use it if you can help it. It will not reflect options set +-- by the commandline flags, and all fields may be either wrong or +-- undefined. +tracingDynFlags :: DynFlags +tracingDynFlags = defaultDynFlags tracingSettings + where tracingSettings = panic "Settings not defined in tracingDynFlags" + +type FatalMessager = String -> IO () +type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () + +defaultFatalMessager :: FatalMessager +defaultFatalMessager = hPutStrLn stderr defaultLogAction :: LogAction -defaultLogAction severity srcSpan style msg - = case severity of - SevOutput -> printSDoc msg style - SevInfo -> printErrs msg style - SevFatal -> printErrs msg style - _ -> do hPutChar stderr '\n' - printErrs (mkLocMessage severity srcSpan msg) style - -- careful (#2302): printErrs prints in UTF-8, whereas - -- converting to string first and using hPutStr would - -- just emit the low 8 bits of each unicode char. +defaultLogAction dflags severity srcSpan style msg + = case severity of + SevOutput -> printSDoc msg style + SevDump -> hPrintDump dflags stdout msg + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + _ -> do hPutChar stderr '\n' + printErrs (mkLocMessage severity srcSpan msg) style + -- careful (#2302): printErrs prints in UTF-8, whereas + -- converting to string first and using hPutStr would + -- just emit the low 8 bits of each unicode char. + where printSDoc = defaultLogActionHPrintDoc dflags stdout + printErrs = defaultLogActionHPrintDoc dflags stderr + +defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPrintDoc dflags h d sty + = do let doc = runSDoc d (initSDocContext dflags sty) + Pretty.printDoc Pretty.PageMode (pprCols dflags) h doc + hFlush h + +newtype FlushOut = FlushOut (IO ()) + +defaultFlushOut :: FlushOut +defaultFlushOut = FlushOut $ hFlush stdout + +newtype FlushErr = FlushErr (IO ()) + +defaultFlushErr :: FlushErr +defaultFlushErr = FlushErr $ hFlush stderr + +printOutputForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO () +printOutputForUser = printSevForUser SevOutput + +printInfoForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO () +printInfoForUser = printSevForUser SevInfo + +printSevForUser :: Severity -> DynFlags -> PrintUnqualified -> SDoc -> IO () +printSevForUser sev dflags unqual doc + = log_action dflags dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc {- Note [Verbosity levels] @@ -1050,15 +1154,16 @@ xopt_unset dfs f in dfs { extensions = onoffs, extensionFlags = flattenExtensionFlags (language dfs) onoffs } +lang_set :: DynFlags -> Maybe Language -> DynFlags +lang_set dflags lang = + dflags { + language = lang, + extensionFlags = flattenExtensionFlags lang (extensions dflags) + } + -- | Set the Haskell language standard to use setLanguage :: Language -> DynP () -setLanguage l = upd f - where f dfs = let mLang = Just l - oneoffs = extensions dfs - in dfs { - language = mLang, - extensionFlags = flattenExtensionFlags mLang oneoffs - } +setLanguage l = upd (`lang_set` Just l) -- | Some modules have dependencies on others through the DynFlags rather than textual imports dynFlagDependencies :: DynFlags -> [ModuleName] @@ -1078,7 +1183,7 @@ safeLanguageOn dflags = safeHaskell dflags == Sf_Safe -- | Is the Safe Haskell safe inference mode active safeInferOn :: DynFlags -> Bool -safeInferOn dflags = safeHaskell dflags == Sf_SafeInfered +safeInferOn dflags = safeHaskell dflags == Sf_SafeInferred -- | Test if Safe Imports are on in some form safeImportsOn :: DynFlags -> Bool @@ -1109,14 +1214,27 @@ safeImplicitImpsReq d = safeLanguageOn d -- want to export this functionality from the module but do want to export the -- type constructors. combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode -combineSafeFlags a b | a == Sf_SafeInfered = return b - | b == Sf_SafeInfered = return a - | a == Sf_None = return b - | b == Sf_None = return a - | a == b = return a - | otherwise = addErr errm >> return (panic errm) +combineSafeFlags a b | a == Sf_SafeInferred = return b + | b == Sf_SafeInferred = return a + | a == Sf_None = return b + | b == Sf_None = return a + | a == b = return a + | otherwise = addErr errm >> return (panic errm) where errm = "Incompatible Safe Haskell flags! (" - ++ showPpr a ++ ", " ++ showPpr b ++ ")" + ++ show a ++ ", " ++ show b ++ ")" + +-- | A list of unsafe flags under Safe Haskell. Tuple elements are: +-- * name of the flag +-- * function to get srcspan that enabled the flag +-- * function to test if the flag is on +-- * function to turn the flag off +unsafeFlags :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc, + xopt Opt_GeneralizedNewtypeDeriving, + flip xopt_unset Opt_GeneralizedNewtypeDeriving), + ("-XTemplateHaskell", thOnLoc, + xopt Opt_TemplateHaskell, + flip xopt_unset Opt_TemplateHaskell)] -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from @@ -1136,7 +1254,8 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, setPgmP, addOptl, addOptP, - addCmdlineFramework, addHaddockOpts + addCmdlineFramework, addHaddockOpts, addGhciScript, + setInteractivePrint :: String -> DynFlags -> DynFlags setOutputFile, setOutputHi, setDumpPrefixForce :: Maybe String -> DynFlags -> DynFlags @@ -1208,6 +1327,10 @@ addCmdlineFramework f d = d{ cmdlineFrameworks = f : cmdlineFrameworks d} addHaddockOpts f d = d{ haddockOptions = Just f} +addGhciScript f d = d{ ghciScripts = f : ghciScripts d} + +setInteractivePrint f d = d{ interactivePrint = Just f} + -- ----------------------------------------------------------------------------- -- Command-line options @@ -1275,31 +1398,39 @@ getStgToDo dflags -- ----------------------------------------------------------------------------- -- Parsing the dynamic flags. + -- | Parse dynamic flags from a list of command line arguments. Returns the -- the parsed 'DynFlags', the left-over arguments, and a list of warnings. -- Throws a 'UsageError' if errors occurred during parsing (such as unknown -- flags or missing arguments). -parseDynamicFlagsCmdLine :: Monad m => - DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Located String]) - -- ^ Updated 'DynFlags', left-over arguments, and - -- list of warnings. -parseDynamicFlagsCmdLine dflags args = parseDynamicFlags dflags args True +parseDynamicFlagsCmdLine :: Monad m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Located String]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True + -- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags --- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-conf). +-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). -- Used to parse flags set in a modules pragma. -parseDynamicFilePragma :: Monad m => - DynFlags -> [Located String] +parseDynamicFilePragma :: Monad m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Located String]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False + + +-- | Parses the dynamically set flags for GHC. This is the most general form of +-- the dynamic flag parser that the other methods simply wrap. It allows +-- saying which flags are valid flags and indicating if we are parsing +-- arguments from the command line or from a file pragma. +parseDynamicFlagsFull :: Monad m + => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against + -> Bool -- ^ are the arguments from the command line? + -> DynFlags -- ^ current dynamic flags + -> [Located String] -- ^ arguments to parse -> m (DynFlags, [Located String], [Located String]) - -- ^ Updated 'DynFlags', left-over arguments, and - -- list of warnings. -parseDynamicFilePragma dflags args = parseDynamicFlags dflags args False - -parseDynamicFlags :: Monad m => - DynFlags -> [Located String] -> Bool - -> m (DynFlags, [Located String], [Located String]) -parseDynamicFlags dflags0 args cmdline = do +parseDynamicFlagsFull activeFlags cmdline dflags0 args = do -- XXX Legacy support code -- We used to accept things like -- optdep-f -optdepdepend @@ -1312,12 +1443,8 @@ parseDynamicFlags dflags0 args cmdline = do f xs = xs args' = f args - -- Note: -ignore-package (package_flags) must precede -i* (dynamic_flags) - flag_spec | cmdline = package_flags ++ dynamic_flags - | otherwise = dynamic_flags - let ((leftover, errs, warns), dflags1) - = runCmdLine (processArgs flag_spec args') dflags0 + = runCmdLine (processArgs activeFlags args') dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs -- check for disabled flags in safe haskell @@ -1325,18 +1452,23 @@ parseDynamicFlags dflags0 args cmdline = do return (dflags2, leftover, sh_warns ++ warns) + -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. +-- +-- The bool is to indicate if we are parsing command line flags (false means +-- file pragma). This allows us to generate better warnings. safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) safeFlagCheck _ dflags | not (safeLanguageOn dflags || safeInferOn dflags) = (dflags, []) +-- safe or safe-infer ON safeFlagCheck cmdl dflags = case safeLanguageOn dflags of True -> (dflags', warns) -- throw error if -fpackage-trust by itself with no safe haskell flag - False | not cmdl && safeInferOn dflags && packageTrustOn dflags + False | not cmdl && packageTrustOn dflags -> (dopt_unset dflags' Opt_PackageTrust, [L (pkgTrustOnLoc dflags') $ "-fpackage-trust ignored;" ++ @@ -1348,16 +1480,16 @@ safeFlagCheck cmdl dflags = | otherwise -> (dflags' { safeHaskell = Sf_None }, []) - -- Have we infered Unsafe? + -- Have we inferred Unsafe? -- See Note [HscMain . Safe Haskell Inference] where -- TODO: Can we do better than this for inference? safeInfOk = not $ xopt Opt_OverlappingInstances dflags - (dflags', warns) = foldl check_method (dflags, []) bad_flags + (dflags', warns) = foldl check_method (dflags, []) unsafeFlags check_method (df, warns) (str,loc,test,fix) - | test df = (apFix fix df, warns ++ safeFailure loc str) + | test df = (apFix fix df, warns ++ safeFailure (loc dflags) str) | otherwise = (df, warns) apFix f = if safeInferOn dflags then id else f @@ -1365,20 +1497,14 @@ safeFlagCheck cmdl dflags = safeFailure loc str = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str] - bad_flags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc dflags, - xopt Opt_GeneralizedNewtypeDeriving, - flip xopt_unset Opt_GeneralizedNewtypeDeriving), - ("-XTemplateHaskell", thOnLoc dflags, - xopt Opt_TemplateHaskell, - flip xopt_unset Opt_TemplateHaskell)] - - {- ********************************************************************** %* * DynFlags specifications %* * %********************************************************************* -} +-- | All dynamic flags option strings. These are the user facing strings for +-- enabling and disabling options. allFlags :: [String] allFlags = map ('-':) $ [ flagName flag | flag <- dynamic_flags ++ package_flags, ok (flagOptKind flag) ] ++ @@ -1392,6 +1518,23 @@ allFlags = map ('-':) $ fflags1 = [ name | (name, _, _) <- fWarningFlags ] fflags2 = [ name | (name, _, _) <- fLangFlags ] +{- + - Below we export user facing symbols for GHC dynamic flags for use with the + - GHC API. + -} + +-- All dynamic flags present in GHC. +flagsAll :: [Flag (CmdLineP DynFlags)] +flagsAll = package_flags ++ dynamic_flags + +-- All dynamic flags, minus package flags, present in GHC. +flagsDynamic :: [Flag (CmdLineP DynFlags)] +flagsDynamic = dynamic_flags + +-- ALl package flags present in GHC. +flagsPackage :: [Flag (CmdLineP DynFlags)] +flagsPackage = package_flags + --------------- The main flags themselves ------------------ dynamic_flags :: [Flag (CmdLineP DynFlags)] dynamic_flags = [ @@ -1505,7 +1648,8 @@ dynamic_flags = [ , Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) , Flag "haddock-opts" (hasArg addHaddockOpts) , Flag "hpcdir" (SepArg setOptHpcDir) - + , Flag "ghci-script" (hasArg addGhciScript) + , Flag "interactive-print" (hasArg setInteractivePrint) ------- recompilation checker -------------------------------------- , Flag "recomp" (NoArg (do unSetDynFlag Opt_ForceRecomp deprecate "Use -fno-force-recomp instead")) @@ -1520,6 +1664,11 @@ dynamic_flags = [ , Flag "I" (Prefix addIncludePath) , Flag "i" (OptPrefix addImportPath) + ------ Output style options ----------------------------------------- + , Flag "dppr-user-length" (intSuffix (\n d -> d{ pprUserLength = n })) + , Flag "dppr-cols" (intSuffix (\n d -> d{ pprCols = n })) + , Flag "dtrace-level" (intSuffix (\n d -> d{ traceLevel = n })) + ------ Debugging ---------------------------------------------------- , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) @@ -1594,6 +1743,7 @@ dynamic_flags = [ , Flag "ddump-hi" (setDumpFlag Opt_D_dump_hi) , Flag "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) , Flag "ddump-vect" (setDumpFlag Opt_D_dump_vect) + , Flag "ddump-avoid-vect" (setDumpFlag Opt_D_dump_avoid_vect) , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_ticked) -- back compat , Flag "ddump-ticked" (setDumpFlag Opt_D_dump_ticked) , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) @@ -1608,7 +1758,7 @@ dynamic_flags = [ , Flag "dshow-passes" (NoArg (do forceRecompile setVerbosity $ Just 2)) , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) - , Flag "dno-llvm-mangler" (NoArg (setDynFlag Opt_NoLlvmMangler)) + , Flag "dno-llvm-mangler" (NoArg (setDynFlag Opt_NoLlvmMangler)) -- hidden flag ------ Machine dependant (-m<blah>) stuff --------------------------- @@ -1691,6 +1841,10 @@ dynamic_flags = [ , Flag "fpackage-trust" (NoArg setPackageTrust) , Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None)) ] + ++ map (mkFlag turnOn "" setDynFlag ) negatableFlags + ++ map (mkFlag turnOff "no-" unSetDynFlag) negatableFlags + ++ map (mkFlag turnOn "d" setDynFlag ) dFlags + ++ map (mkFlag turnOff "dno-" unSetDynFlag) dFlags ++ map (mkFlag turnOn "f" setDynFlag ) fFlags ++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags ++ map (mkFlag turnOn "f" setWarningFlag ) fWarningFlags @@ -1707,8 +1861,21 @@ dynamic_flags = [ package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ ------- Packages ---------------------------------------------------- - Flag "package-conf" (HasArg extraPkgConf_) - , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) + Flag "package-db" (HasArg (addPkgConfRef . PkgConfFile)) + , Flag "clear-package-db" (NoArg clearPkgConf) + , Flag "no-global-package-db" (NoArg removeGlobalPkgConf) + , Flag "no-user-package-db" (NoArg removeUserPkgConf) + , Flag "global-package-db" (NoArg (addPkgConfRef GlobalPkgConf)) + , Flag "user-package-db" (NoArg (addPkgConfRef UserPkgConf)) + + -- backwards compat with GHC<=7.4 : + , Flag "package-conf" (HasArg $ \path -> do + addPkgConfRef (PkgConfFile path) + deprecate "Use -package-db instead") + , Flag "no-user-package-conf" (NoArg $ do + removeUserPkgConf + deprecate "Use -no-user-package-db instead") + , Flag "package-name" (hasArg setPackageName) , Flag "package-id" (HasArg exposePackageId) , Flag "package" (HasArg exposePackage) @@ -1795,7 +1962,18 @@ fWarningFlags = [ ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ), ( "warn-unsafe", Opt_WarnUnsafe, setWarnUnsafe ), ( "warn-safe", Opt_WarnSafe, setWarnSafe ), - ( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ) ] + ( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ), + ( "warn-unsupported-calling-conventions", Opt_WarnUnsupportedCallingConventions, nop ) ] + +-- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@ +negatableFlags :: [FlagSpec DynFlag] +negatableFlags = [ + ( "ignore-dot-ghci", Opt_IgnoreDotGhci, nop ) ] + +-- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@ +dFlags :: [FlagSpec DynFlag] +dFlags = [ + ( "ppr-case-as-let", Opt_PprCaseAsLet, nop ) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fFlags :: [FlagSpec DynFlag] @@ -1834,10 +2012,12 @@ fFlags = [ ( "run-cpsz", Opt_RunCPSZ, nop ), ( "new-codegen", Opt_TryNewCodeGen, nop ), ( "vectorise", Opt_Vectorise, nop ), + ( "avoid-vect", Opt_AvoidVect, nop ), ( "regs-graph", Opt_RegsGraph, nop ), ( "regs-iterative", Opt_RegsIterative, nop ), - ( "llvm-tbaa", Opt_LlvmTBAA, nop), - ( "reg-liveness", Opt_RegLiveness, nop), + ( "llvm-tbaa", Opt_LlvmTBAA, nop), -- hidden flag + ( "regs-liveness", Opt_RegLiveness, nop), -- hidden flag + ( "irrefutable-tuples", Opt_IrrefutableTuples, nop ), ( "gen-manifest", Opt_GenManifest, nop ), ( "embed-manifest", Opt_EmbedManifest, nop ), ( "ext-core", Opt_EmitExternalCore, nop ), @@ -1846,6 +2026,8 @@ fFlags = [ ( "ghci-history", Opt_GhciHistory, nop ), ( "helpful-errors", Opt_HelpfulErrors, nop ), ( "defer-type-errors", Opt_DeferTypeErrors, nop ), + ( "parallel", Opt_Parallel, nop ), + ( "gransim", Opt_GranMacros, nop ), ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ), ( "prof-count-entries", Opt_ProfCountEntries, nop ), @@ -1914,7 +2096,7 @@ languageFlags = [ -- features can be used. safeHaskellFlags :: [FlagSpec SafeHaskellMode] safeHaskellFlags = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] - where mkF flag = (showPpr flag, flag, nop) + where mkF flag = (show flag, flag, nop) -- | These -X<blah> flags can all be reversed with -XNo<blah> xFlags :: [FlagSpec ExtensionFlag] @@ -1942,9 +2124,10 @@ xFlags = [ ( "RankNTypes", Opt_RankNTypes, nop ), ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), ( "TypeOperators", Opt_TypeOperators, nop ), - ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo' - deprecatedForExtension "DoRec"), - ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword + ( "ExplicitNamespaces", Opt_ExplicitNamespaces, nop ), + ( "RecursiveDo", Opt_RecursiveDo, nop ), -- Enables 'mdo' and 'rec' + ( "DoRec", Opt_RecursiveDo, + deprecatedForExtension "RecursiveDo" ), ( "Arrows", Opt_Arrows, nop ), ( "ParallelArrays", Opt_ParallelArrays, nop ), ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), @@ -2015,7 +2198,6 @@ xFlags = [ defaultFlags :: [DynFlag] defaultFlags = [ Opt_AutoLinkPackages, - Opt_ReadUserPackageConf, Opt_SharedImplib, @@ -2053,7 +2235,12 @@ impliedFlags , (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds) , (Opt_TypeFamilies, turnOn, Opt_KindSignatures) -- Type families use kind signatures - -- all over the place + , (Opt_PolyKinds, turnOn, Opt_KindSignatures) -- Ditto polymorphic kinds + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (Opt_TypeFamilies, turnOn, Opt_ExplicitNamespaces) + , (Opt_TypeOperators, turnOn, Opt_ExplicitNamespaces) , (Opt_ImpredicativeTypes, turnOn, Opt_RankNTypes) @@ -2064,6 +2251,11 @@ impliedFlags , (Opt_RecordWildCards, turnOn, Opt_DisambiguateRecordFields) , (Opt_ParallelArrays, turnOn, Opt_ParallelListComp) + + -- An implicit parameter constraint, `?x::Int`, is desugared into + -- `IP "x" Int`, which requires a flexible context/instance. + , (Opt_ImplicitParams, turnOn, Opt_FlexibleContexts) + , (Opt_ImplicitParams, turnOn, Opt_FlexibleInstances) ] optLevelFlags :: [([Int], DynFlag)] @@ -2121,7 +2313,8 @@ standardWarnings Opt_WarnDodgyForeignImports, Opt_WarnWrongDoBind, Opt_WarnAlternativeLayoutRuleTransitional, - Opt_WarnPointlessPragmas + Opt_WarnPointlessPragmas, + Opt_WarnUnsupportedCallingConventions ] minusWOpts :: [WarningFlag] @@ -2184,7 +2377,8 @@ glasgowExtsFlags = [ , Opt_LiberalTypeSynonyms , Opt_RankNTypes , Opt_TypeOperators - , Opt_DoRec + , Opt_ExplicitNamespaces + , Opt_RecursiveDo , Opt_ParallelListComp , Opt_EmptyDataDecls , Opt_KindSignatures @@ -2347,8 +2541,28 @@ setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) addCmdlineHCInclude :: String -> DynP () addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) -extraPkgConf_ :: FilePath -> DynP () -extraPkgConf_ p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) +data PkgConfRef + = GlobalPkgConf + | UserPkgConf + | PkgConfFile FilePath + +addPkgConfRef :: PkgConfRef -> DynP () +addPkgConfRef p = upd $ \s -> s { extraPkgConfs = (p:) . extraPkgConfs s } + +removeUserPkgConf :: DynP () +removeUserPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotUser . extraPkgConfs s } + where + isNotUser UserPkgConf = False + isNotUser _ = True + +removeGlobalPkgConf :: DynP () +removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extraPkgConfs s } + where + isNotGlobal GlobalPkgConf = False + isNotGlobal _ = True + +clearPkgConf :: DynP () +clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } exposePackage, exposePackageId, hidePackage, ignorePackage, trustPackage, distrustPackage :: String -> DynP () diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot new file mode 100644 index 0000000000..9f14d41600 --- /dev/null +++ b/compiler/main/DynFlags.hs-boot @@ -0,0 +1,13 @@ + +module DynFlags where + +import Platform + +data DynFlags + +tracingDynFlags :: DynFlags + +targetPlatform :: DynFlags -> Platform +pprUserLength :: DynFlags -> Int +pprCols :: DynFlags -> Int + diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index cc382a74fe..84eb2612e0 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -70,9 +70,10 @@ forceLoadTyCon hsc_env con_name = do mb_con_thing <- lookupTypeHscEnv hsc_env con_name case mb_con_thing of - Nothing -> throwCmdLineErrorS $ missingTyThingError con_name + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name Just (ATyCon tycon) -> return tycon - Just con_thing -> throwCmdLineErrorS $ wrongTyThingError con_name con_thing + Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing + where dflags = hsc_dflags hsc_env -- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety -- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! @@ -91,7 +92,7 @@ getValueSafely hsc_env val_name expected_type = do -- Now look up the names for the value and type constructor in the type environment mb_val_thing <- lookupTypeHscEnv hsc_env val_name case mb_val_thing of - Nothing -> throwCmdLineErrorS $ missingTyThingError val_name + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name Just (AnId id) -> do -- Check the value type in the interface against the type recovered from the type constructor -- before finally casting the value to the type we assume corresponds to that constructor @@ -107,7 +108,8 @@ getValueSafely hsc_env val_name expected_type = do value <- lessUnsafeCoerce (hsc_dflags hsc_env) "getValueSafely" hval return $ Just value else return Nothing - Just val_thing -> throwCmdLineErrorS $ wrongTyThingError val_name val_thing + Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing + where dflags = hsc_dflags hsc_env -- | Coerce a value as usual, but: @@ -149,10 +151,9 @@ lookupRdrNameInModule hsc_env mod_name rdr_name = do [] -> return Nothing _ -> panic "lookupRdrNameInModule" - Nothing -> throwCmdLineErrorS $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] - err -> throwCmdLineErrorS $ cannotFindModule dflags mod_name err - where - dflags = hsc_dflags hsc_env + Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] + err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err + where dflags = hsc_dflags hsc_env wrongTyThingError :: Name -> TyThing -> SDoc @@ -161,8 +162,8 @@ wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptex missingTyThingError :: Name -> SDoc missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] -throwCmdLineErrorS :: SDoc -> IO a -throwCmdLineErrorS = throwCmdLineError . showSDoc +throwCmdLineErrorS :: DynFlags -> SDoc -> IO a +throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags throwCmdLineError :: String -> IO a throwCmdLineError = throwGhcException . CmdLineError diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 6ba9df436c..daa66f9d2f 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -9,7 +9,7 @@ module ErrUtils ( ErrMsg, WarnMsg, Severity(..), Messages, ErrorMessages, WarningMessages, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, - MsgDoc, mkLocMessage, printError, pprMessageBag, pprErrMsgBag, + MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc, pprLocErrMsg, makeIntoWarning, errorsFound, emptyMessages, @@ -25,27 +25,32 @@ module ErrUtils ( -- * Messages during compilation putMsg, putMsgWith, errorMsg, - fatalErrorMsg, fatalErrorMsg', + fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'', compilationProgressMsg, showPass, debugTraceMsg, + + prettyPrintGhcErrors, ) where #include "HsVersions.h" import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) -import Util +import Exception import Outputable +import Panic import FastString import SrcLoc import DynFlags import StaticFlags ( opt_ErrorSpans ) +import System.Directory import System.Exit ( ExitCode(..), exitWith ) import System.FilePath import Data.List import qualified Data.Set as Set import Data.IORef +import Data.Ord import Control.Monad import System.IO @@ -59,7 +64,8 @@ type ErrorMessages = Bag ErrMsg data ErrMsg = ErrMsg { errMsgSpans :: [SrcSpan], errMsgContext :: PrintUnqualified, - errMsgShortDoc :: MsgDoc, + errMsgShortDoc :: MsgDoc, -- errMsgShort* should always + errMsgShortString :: String, -- contain the same text errMsgExtraInfo :: MsgDoc, errMsgSeverity :: Severity } @@ -70,13 +76,14 @@ type MsgDoc = SDoc data Severity = SevOutput + | SevDump | SevInfo | SevWarning | SevError | SevFatal instance Show ErrMsg where - show em = showSDoc (errMsgShortDoc em) + show em = errMsgShortString em pprMessageBag :: Bag MsgDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) @@ -95,41 +102,40 @@ mkLocMessage severity locn msg -- For warnings, print Foo.hs:34: Warning: -- <the warning message> -printError :: SrcSpan -> MsgDoc -> IO () -printError span msg = printErrs (mkLocMessage SevError span msg) defaultErrStyle - makeIntoWarning :: ErrMsg -> ErrMsg makeIntoWarning err = err { errMsgSeverity = SevWarning } -- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. -mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg -mk_err_msg sev locn print_unqual msg extra +mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg +mk_err_msg dflags sev locn print_unqual msg extra = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual - , errMsgShortDoc = msg, errMsgExtraInfo = extra + , errMsgShortDoc = msg , errMsgShortString = showSDoc dflags msg + , errMsgExtraInfo = extra , errMsgSeverity = sev } -mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg +mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg -- A long (multi-line) error message -mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg +mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg -- A short (one-line) error message -mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> MsgDoc -> ErrMsg +mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg -- Variant that doesn't care about qualified/unqualified names -mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual msg extra -mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual msg empty -mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify msg empty -mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual msg extra -mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual msg empty -mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify msg empty +mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual msg extra +mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual msg empty +mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify msg empty +mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual msg extra +mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual msg empty +mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify msg empty ---------------- emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) -warnIsErrorMsg :: ErrMsg -warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.") +warnIsErrorMsg :: DynFlags -> ErrMsg +warnIsErrorMsg dflags + = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.") errorsFound :: DynFlags -> Messages -> Bool errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) @@ -140,26 +146,31 @@ printBagOfErrors dflags bag_of_errors pprErrMsgBag :: Bag ErrMsg -> [SDoc] pprErrMsgBag bag - = [ let style = mkErrStyle unqual + = [ sdocWithDynFlags $ \dflags -> + let style = mkErrStyle dflags unqual in withPprStyle style (d $$ e) | ErrMsg { errMsgShortDoc = d, errMsgExtraInfo = e, errMsgContext = unqual } <- sortMsgBag bag ] +pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc] +pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag bag ] + pprLocErrMsg :: ErrMsg -> SDoc pprLocErrMsg (ErrMsg { errMsgSpans = spans , errMsgShortDoc = d , errMsgExtraInfo = e , errMsgSeverity = sev , errMsgContext = unqual }) - = withPprStyle (mkErrStyle unqual) (mkLocMessage sev s (d $$ e)) + = sdocWithDynFlags $ \dflags -> + withPprStyle (mkErrStyle dflags unqual) (mkLocMessage sev s (d $$ e)) where (s : _) = spans -- Should be non-empty printMsgBag :: DynFlags -> Bag ErrMsg -> IO () printMsgBag dflags bag - = sequence_ [ let style = mkErrStyle unqual - in log_action dflags sev s style (d $$ e) + = sequence_ [ let style = mkErrStyle dflags unqual + in log_action dflags dflags sev s style (d $$ e) | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, errMsgSeverity = sev, @@ -167,13 +178,8 @@ printMsgBag dflags bag errMsgContext = unqual } <- sortMsgBag bag ] sortMsgBag :: Bag ErrMsg -> [ErrMsg] -sortMsgBag bag = sortLe srcOrder $ bagToList bag - where - srcOrder err1 err2 = - case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of - LT -> True - EQ -> True - GT -> False +sortMsgBag bag = sortBy (comparing (head . errMsgSpans)) $ bagToList bag + -- TODO: Why "head ."? Why not compare the whole list? ghcExit :: DynFlags -> Int -> IO () ghcExit dflags val @@ -192,10 +198,10 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action -- ----------------------------------------------------------------------------- -- Dumping -dumpIfSet :: Bool -> String -> SDoc -> IO () -dumpIfSet flag hdr doc +dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () +dumpIfSet dflags flag hdr doc | not flag = return () - | otherwise = printDump (mkDumpDoc hdr doc) + | otherwise = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc) dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc @@ -239,14 +245,14 @@ dumpSDoc dflags dflag hdr doc mode = if append then AppendMode else WriteMode when (not append) $ writeIORef gdref (Set.insert fileName gd) - createDirectoryHierarchy (takeDirectory fileName) + createDirectoryIfMissing True (takeDirectory fileName) handle <- openFile fileName mode - hPrintDump handle doc + hPrintDump dflags handle doc hClose handle -- write the dump to stdout Nothing - -> printDump (mkDumpDoc hdr doc) + -> log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc) -- | Choose where to put a dump file based on DynFlags @@ -299,33 +305,50 @@ ifVerbose dflags val act | otherwise = return () putMsg :: DynFlags -> MsgDoc -> IO () -putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg +putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () putMsgWith dflags print_unqual msg - = log_action dflags SevInfo noSrcSpan sty msg + = log_action dflags dflags SevInfo noSrcSpan sty msg where sty = mkUserStyle print_unqual AllTheWay errorMsg :: DynFlags -> MsgDoc -> IO () -errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg +errorMsg dflags msg = + log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg fatalErrorMsg :: DynFlags -> MsgDoc -> IO () -fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg +fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg + +fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO () +fatalErrorMsg' la dflags msg = + la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg -fatalErrorMsg' :: LogAction -> MsgDoc -> IO () -fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg +fatalErrorMsg'' :: FatalMessager -> String -> IO () +fatalErrorMsg'' fm msg = fm msg compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg - = ifVerbose dflags 1 (log_action dflags SevOutput noSrcSpan defaultUserStyle (text msg)) + = ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg)) showPass :: DynFlags -> String -> IO () showPass dflags what - = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) + = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg dflags val msg - = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) + = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg) + +prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a +prettyPrintGhcErrors dflags + = ghandle $ \e -> case e of + PprPanic str doc -> + pprDebugAndThen dflags panic str doc + PprSorry str doc -> + pprDebugAndThen dflags sorry str doc + PprProgramError str doc -> + pprDebugAndThen dflags pgmError str doc + _ -> + throw e \end{code} diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.lhs-boot index 7718cbe2a6..6f4a373313 100644 --- a/compiler/main/ErrUtils.lhs-boot +++ b/compiler/main/ErrUtils.lhs-boot @@ -6,6 +6,7 @@ import SrcLoc (SrcSpan) data Severity = SevOutput + | SevDump | SevInfo | SevWarning | SevError diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index d3a8bb11de..bedb30002a 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -10,6 +10,7 @@ module GHC ( -- * Initialisation defaultErrorHandler, defaultCleanupHandler, + prettyPrintGhcErrors, -- * GHC Monad Ghc, GhcT, GhcMonad(..), HscEnv, @@ -24,8 +25,9 @@ module GHC ( DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, GhcMode(..), GhcLink(..), defaultObjectTarget, parseDynamicFlags, - getSessionDynFlags, - setSessionDynFlags, + getSessionDynFlags, setSessionDynFlags, + getProgramDynFlags, setProgramDynFlags, + getInteractiveDynFlags, setInteractiveDynFlags, parseStaticFlags, -- * Targets @@ -71,10 +73,12 @@ module GHC ( modInfoIsExportedName, modInfoLookupName, modInfoIface, + modInfoSafe, lookupGlobalName, findGlobalAnns, mkPrintUnqualifiedForModule, ModIface(..), + SafeHaskellMode(..), -- * Querying the environment packageDbModules, @@ -119,6 +123,11 @@ module GHC ( #endif lookupName, +#ifdef GHCI + -- ** EXPERIMENTAL + setGHCiMonad, +#endif + -- * Abstract syntax elements -- ** Packages @@ -253,6 +262,7 @@ import HscMain import GhcMake import DriverPipeline ( compile' ) import GhcMonad +import TcRnMonad ( finalSafeMode ) import TcRnTypes import Packages import NameSet @@ -323,35 +333,36 @@ import Prelude hiding (init) -- Unless you want to handle exceptions yourself, you should wrap this around -- the top level of your program. The default handlers output the error -- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => LogAction -> m a -> m a -defaultErrorHandler la inner = +defaultErrorHandler :: (ExceptionMonad m, MonadIO m) + => FatalMessager -> FlushOut -> m a -> m a +defaultErrorHandler fm (FlushOut flushOut) inner = -- top-level exception handler: any unrecognised exception is a compiler bug. ghandle (\exception -> liftIO $ do - hFlush stdout + flushOut case fromException exception of -- an IO exception probably isn't our fault, so don't panic Just (ioe :: IOException) -> - fatalErrorMsg' la (text (show ioe)) + fatalErrorMsg'' fm (show ioe) _ -> case fromException exception of Just UserInterrupt -> exitWith (ExitFailure 1) Just StackOverflow -> - fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it") + fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it" _ -> case fromException exception of Just (ex :: ExitCode) -> throw ex _ -> - fatalErrorMsg' la - (text (show (Panic (show exception)))) + fatalErrorMsg'' fm + (show (Panic (show exception))) exitWith (ExitFailure 1) ) $ -- error messages propagated as exceptions handleGhcException (\ge -> liftIO $ do - hFlush stdout + flushOut case ge of PhaseFailed _ code -> exitWith code Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg' la (text (show ge)) + _ -> do fatalErrorMsg'' fm (show ge) exitWith (ExitFailure 1) ) $ inner @@ -448,11 +459,33 @@ initGhcMonad mb_top_dir = do -- %* * -- %************************************************************************ --- | Updates the DynFlags in a Session. This also reads --- the package database (unless it has already been read), --- and prepares the compilers knowledge about packages. It --- can be called again to load new packages: just add new --- package flags to (packageFlags dflags). +-- $DynFlags +-- +-- The GHC session maintains two sets of 'DynFlags': +-- +-- * The "interactive" @DynFlags@, which are used for everything +-- related to interactive evaluation, including 'runStmt', +-- 'runDecls', 'exprType', 'lookupName' and so on (everything +-- under \"Interactive evaluation\" in this module). +-- +-- * The "program" @DynFlags@, which are used when loading +-- whole modules with 'load' +-- +-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the +-- interactive @DynFlags@. +-- +-- 'setProgramDynFlags', 'getProgramDynFlags' work with the +-- program @DynFlags@. +-- +-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' +-- retrieves the program @DynFlags@ (for backwards compatibility). + + +-- | Updates both the interactive and program DynFlags in a Session. +-- This also reads the package database (unless it has already been +-- read), and prepares the compilers knowledge about packages. It can +-- be called again to load new packages: just add new package flags to +-- (packageFlags dflags). -- -- Returns a list of new packages that may need to be linked in using -- the dynamic linker (see 'linkPackages') as a result of new package @@ -462,9 +495,33 @@ initGhcMonad mb_top_dir = do setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] setSessionDynFlags dflags = do (dflags', preload) <- liftIO $ initPackages dflags - modifySession (\h -> h{ hsc_dflags = dflags' }) + modifySession $ \h -> h{ hsc_dflags = dflags' + , hsc_IC = (hsc_IC h){ ic_dflags = dflags' } } + return preload + +-- | Sets the program 'DynFlags'. +setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageId] +setProgramDynFlags dflags = do + (dflags', preload) <- liftIO $ initPackages dflags + modifySession $ \h -> h{ hsc_dflags = dflags' } return preload +-- | Returns the program 'DynFlags'. +getProgramDynFlags :: GhcMonad m => m DynFlags +getProgramDynFlags = getSessionDynFlags + +-- | Set the 'DynFlags' used to evaluate interactive expressions. +-- Note: this cannot be used for changes to packages. Use +-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the +-- 'pkgState' into the interactive @DynFlags@. +setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () +setInteractiveDynFlags dflags = do + modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags }} + +-- | Get the 'DynFlags' used to evaluate interactive expressions. +getInteractiveDynFlags :: GhcMonad m => m DynFlags +getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) + parseDynamicFlags :: Monad m => DynFlags -> [Located String] @@ -533,8 +590,9 @@ guessTarget str Nothing if looksLikeModuleName file then return (target (TargetModule (mkModuleName file))) else do + dflags <- getDynFlags throwGhcException - (ProgramError (showSDoc $ + (ProgramError (showSDoc dflags $ text "target" <+> quotes (text file) <+> text "is not a module name or a source file")) where @@ -662,9 +720,11 @@ getModSummary :: GhcMonad m => ModuleName -> m ModSummary getModSummary mod = do mg <- liftM hsc_mod_graph getSession case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of - [] -> throw $ mkApiErr (text "Module not part of module graph") + [] -> do dflags <- getDynFlags + throw $ mkApiErr dflags (text "Module not part of module graph") [ms] -> return ms - multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple) + multiple -> do dflags <- getDynFlags + throw $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple) -- | Parse a module. -- @@ -689,6 +749,7 @@ typecheckModule pmod = do HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod } details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env + safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), @@ -701,7 +762,8 @@ typecheckModule pmod = do minf_exports = availsToNameSet $ md_exports details, minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), minf_instances = md_insts details, - minf_iface = Nothing + minf_iface = Nothing, + minf_safe = safe #ifdef GHCI ,minf_modBreaks = emptyModBreaks #endif @@ -775,12 +837,16 @@ data CoreModule -- | Type environment for types declared in this module cm_types :: !TypeEnv, -- | Declarations - cm_binds :: CoreProgram + cm_binds :: CoreProgram, + -- | Safe Haskell mode + cm_safe :: SafeHaskellMode } instance Outputable CoreModule where - ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = - text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) + ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, + cm_safe = sf}) + = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te + $$ vcat (map ppr cb) -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' parses, typechecks, and @@ -794,15 +860,6 @@ compileToCoreModule = compileCore False -- as to return simplified and tidied Core. compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule compileToCoreSimplified = compileCore True -{- --- | Provided for backwards-compatibility: compileToCore returns just the Core --- bindings, but for most purposes, you probably want to call --- compileToCoreModule. -compileToCore :: GhcMonad m => FilePath -> m [CoreBind] -compileToCore fn = do - mod <- compileToCoreModule session fn - return $ cm_binds mod --} -- | Takes a CoreModule and compiles the bindings therein -- to object code. The first argument is a bool flag indicating -- whether to run the simplifier. @@ -817,7 +874,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd ((moduleNameSlashes . moduleName) mName) - let modSummary = ModSummary { ms_mod = mName, + let modSum = ModSummary { ms_mod = mName, ms_hsc_src = ExtCoreFile, ms_location = modLocation, -- By setting the object file timestamp to Nothing, @@ -836,7 +893,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do } hsc_env <- getSession - liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm) + liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule @@ -854,7 +911,7 @@ compileCore simplify fn = do mod_guts <- coreModule `fmap` -- TODO: space leaky: call hsc* directly? (desugarModule =<< typecheckModule =<< parseModule modSummary) - liftM gutsToCoreModule $ + liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ if simplify then do -- If simplify is true: simplify (hscSimplify), then tidy @@ -871,18 +928,22 @@ compileCore simplify fn = do where -- two versions, based on whether we simplify (thus run tidyProgram, -- which returns a (CgGuts, ModDetails) pair, or not (in which case -- we just have a ModGuts. - gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule - gutsToCoreModule (Left (cg, md)) = CoreModule { + gutsToCoreModule :: SafeHaskellMode + -> Either (CgGuts, ModDetails) ModGuts + -> CoreModule + gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { cm_module = cg_module cg, - cm_types = md_types md, - cm_binds = cg_binds cg + cm_types = md_types md, + cm_binds = cg_binds cg, + cm_safe = safe_mode } - gutsToCoreModule (Right mg) = CoreModule { + gutsToCoreModule safe_mode (Right mg) = CoreModule { cm_module = mg_module mg, cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) (mg_tcs mg) (mg_fam_insts mg), - cm_binds = mg_binds mg + cm_binds = mg_binds mg, + cm_safe = safe_mode } -- %************************************************************************ @@ -929,9 +990,10 @@ data ModuleInfo = ModuleInfo { minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface + minf_iface :: Maybe ModIface, + minf_safe :: SafeHaskellMode #ifdef GHCI - ,minf_modBreaks :: ModBreaks + ,minf_modBreaks :: ModBreaks #endif } -- We don't want HomeModInfo here, because a ModuleInfo applies @@ -972,6 +1034,7 @@ getPackageModuleInfo hsc_env mdl minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, minf_modBreaks = emptyModBreaks })) #else @@ -992,7 +1055,8 @@ getHomeModuleInfo hsc_env mdl = minf_exports = availsToNameSet (md_exports details), minf_rdr_env = mi_globals $! hm_iface hmi, minf_instances = md_insts details, - minf_iface = Just iface + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface #ifdef GHCI ,minf_modBreaks = getModBreaks hmi #endif @@ -1037,6 +1101,10 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface +-- | Retrieve module safe haskell mode +modInfoSafe :: ModuleInfo -> SafeHaskellMode +modInfoSafe = minf_safe + #ifdef GHCI modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks @@ -1117,7 +1185,8 @@ getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynF getModuleSourceAndFlags mod = do m <- getModSummary (moduleName mod) case ml_hs_file $ ms_location m of - Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod) + Nothing -> do dflags <- getDynFlags + throw $ mkApiErr dflags (text "No source available for module " <+> ppr mod) Just sourceFile -> do source <- liftIO $ hGetStringBuffer sourceFile return (sourceFile, source, ms_hspp_opts m) @@ -1133,7 +1202,9 @@ getTokenStream mod = do let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return ts - PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) + PFailed span err -> + do dflags <- getDynFlags + throw $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err) -- | Give even more information on the source than 'getTokenStream' -- This function allows reconstructing the source completely with @@ -1144,7 +1215,9 @@ getRichTokenStream mod = do let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return $ addSourceToTokens startLoc source ts - PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) + PFailed span err -> + do dflags <- getDynFlags + throw $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err) -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the @@ -1219,11 +1292,11 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found loc m | modulePackageId m /= this_pkg -> return m - | otherwise -> modNotLoadedError m loc + | otherwise -> modNotLoadedError dflags m loc err -> noModError dflags noSrcSpan mod_name err -modNotLoadedError :: Module -> ModLocation -> IO a -modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $ +modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a +modNotLoadedError dflags m loc = ghcError $ CmdLineError $ showSDoc dflags $ text "module is not loaded:" <+> quotes (ppr (moduleName m)) <+> parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) @@ -1262,6 +1335,21 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan +-- | EXPERIMENTAL: DO NOT USE. +-- +-- Set the monad GHCi lifts user statements into. +-- +-- Checks that a type (in string form) is an instance of the +-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is, +-- throws an error otherwise. +{-# WARNING setGHCiMonad "This is experimental! Don't use." #-} +setGHCiMonad :: GhcMonad m => String -> m () +setGHCiMonad name = withSession $ \hsc_env -> do + ty <- liftIO $ hscIsGHCiMonad hsc_env name + modifySession $ \s -> + let ic = (hsc_IC s) { ic_monad = ty } + in s { hsc_IC = ic } + getHistorySpan :: GhcMonad m => History -> m SrcSpan getHistorySpan h = withSession $ \hsc_env -> return $ InteractiveEval.getHistorySpan hsc_env h @@ -1301,7 +1389,7 @@ parser str dflags filename = case unP Parser.parseModule (mkPState dflags buf loc) of PFailed span err -> - Left (unitBag (mkPlainErrMsg span err)) + Left (unitBag (mkPlainErrMsg dflags span err)) POk pst rdr_module -> let (warns,_) = getMessages pst in diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index a2fb9edf16..322c631a4c 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -4,73 +4,65 @@ -- -- (c) The University of Glasgow, 2011 -- --- This module implements multi-module compilation, and is used --- by --make and GHCi. +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. -- -- ----------------------------------------------------------------------------- - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module GhcMake( - depanal, - load, LoadHowMuch(..), + depanal, + load, LoadHowMuch(..), - topSortModuleGraph, + topSortModuleGraph, - noModError, cyclicModuleErr - ) where + noModError, cyclicModuleErr + ) where #include "HsVersions.h" #ifdef GHCI -import qualified Linker ( unload ) +import qualified Linker ( unload ) #endif -import DriverPipeline import DriverPhases -import GhcMonad -import Module -import HscTypes -import ErrUtils +import DriverPipeline import DynFlags -import HsSyn +import ErrUtils import Finder +import GhcMonad import HeaderInfo -import TcIface ( typecheckIface ) -import TcRnMonad ( initIfaceCheck ) -import RdrName ( RdrName ) +import HsSyn +import HscTypes +import Module +import RdrName ( RdrName ) +import TcIface ( typecheckIface ) +import TcRnMonad ( initIfaceCheck ) -import Exception ( evaluate, tryIO ) -import Panic -import SysTools +import Bag ( listToBag ) import BasicTypes -import SrcLoc -import Util import Digraph -import Bag ( listToBag ) -import Maybes ( expectJust, mapCatMaybes ) -import StringBuffer +import Exception ( evaluate, tryIO ) import FastString +import Maybes ( expectJust, mapCatMaybes ) import Outputable +import Panic +import SrcLoc +import StringBuffer +import SysTools import UniqFM +import Util import qualified Data.Map as Map -import qualified FiniteMap as Map( insertListWith) +import qualified FiniteMap as Map ( insertListWith ) -import System.Directory -import System.IO ( fixIO ) -import System.IO.Error ( isDoesNotExistError ) -import System.FilePath import Control.Monad -import Data.Maybe import Data.List import qualified Data.List as List +import Data.Maybe import Data.Time +import System.Directory +import System.FilePath +import System.IO ( fixIO ) +import System.IO.Error ( isDoesNotExistError ) -- ----------------------------------------------------------------------------- -- Loading the program @@ -94,14 +86,14 @@ depanal :: GhcMonad m => depanal excluded_mods allow_dup_roots = do hsc_env <- getSession let - dflags = hsc_dflags hsc_env - targets = hsc_targets hsc_env - old_graph = hsc_mod_graph hsc_env - + dflags = hsc_dflags hsc_env + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + liftIO $ showPass dflags "Chasing dependencies" liftIO $ debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } @@ -133,226 +125,219 @@ data LoadHowMuch -- load :: GhcMonad m => LoadHowMuch -> m SuccessFlag load how_much = do - mod_graph <- depanal [] False - load2 how_much mod_graph - -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] - -> m SuccessFlag -load2 how_much mod_graph = do - guessOutputFile - hsc_env <- getSession - - let hpt1 = hsc_HPT hsc_env - let dflags = hsc_dflags hsc_env - - -- The "bad" boot modules are the ones for which we have - -- B.hs-boot in the module graph, but no B.hs - -- The downsweep should have ensured this does not happen - -- (see msDeps) - let all_home_mods = [ms_mod_name s - | s <- mod_graph, not (isBootSummary s)] - bad_boot_mods = [s | s <- mod_graph, isBootSummary s, - not (ms_mod_name s `elem` all_home_mods)] - ASSERT( null bad_boot_mods ) return () - - -- check that the module given in HowMuch actually exists, otherwise - -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m - checkHowMuch _ = id - - checkMod m and_then - | m `elem` all_home_mods = and_then - | otherwise = do - liftIO $ errorMsg dflags (text "no such module:" <+> - quotes (ppr m)) - return Failed - - checkHowMuch how_much $ do - - -- mg2_with_srcimps drops the hi-boot nodes, returning a - -- graph with cycles. Among other things, it is used for - -- backing out partially complete cycles following a failed - -- upsweep, and for removing from hpt all the modules - -- not in strict downwards closure, during calls to compile. - let mg2_with_srcimps :: [SCC ModSummary] - mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing - - -- If we can determine that any of the {-# SOURCE #-} imports - -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports mg2_with_srcimps - - let - -- check the stability property for each module. - stable_mods@(stable_obj,stable_bco) - = checkStability hpt1 mg2_with_srcimps all_home_mods - - -- prune bits of the HPT which are definitely redundant now, - -- to save space. - pruned_hpt = pruneHomePackageTable hpt1 - (flattenSCCs mg2_with_srcimps) - stable_mods - - _ <- liftIO $ evaluate pruned_hpt - - -- before we unload anything, make sure we don't leave an old - -- interactive context around pointing to dead bindings. Also, - -- write the pruned HPT to allow the old HPT to be GC'd. - modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, - hsc_HPT = pruned_hpt } - - liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ - text "Stable BCO:" <+> ppr stable_bco) - - -- Unload any modules which are going to be re-linked this time around. - let stable_linkables = [ linkable - | m <- stable_obj++stable_bco, - Just hmi <- [lookupUFM pruned_hpt m], - Just linkable <- [hm_linkable hmi] ] - liftIO $ unload hsc_env stable_linkables - - -- We could at this point detect cycles which aren't broken by - -- a source-import, and complain immediately, but it seems better - -- to let upsweep_mods do this, so at least some useful work gets - -- done before the upsweep is abandoned. - --hPutStrLn stderr "after tsort:\n" - --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) - - -- Now do the upsweep, calling compile for each module in - -- turn. Final result is version 3 of everything. - - -- Topologically sort the module graph, this time including hi-boot - -- nodes, and possibly just including the portion of the graph - -- reachable from the module specified in the 2nd argument to load. - -- This graph should be cycle-free. - -- If we're restricting the upsweep to a portion of the graph, we - -- also want to retain everything that is still stable. - let full_mg :: [SCC ModSummary] - full_mg = topSortModuleGraph False mod_graph Nothing - - maybe_top_mod = case how_much of - LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m - _ -> Nothing - - partial_mg0 :: [SCC ModSummary] - partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod - - -- LoadDependenciesOf m: we want the upsweep to stop just - -- short of the specified module (unless the specified module - -- is stable). - partial_mg - | LoadDependenciesOf _mod <- how_much - = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) - List.init partial_mg0 - | otherwise - = partial_mg0 - - stable_mg = - [ AcyclicSCC ms - | AcyclicSCC ms <- full_mg, - ms_mod_name ms `elem` stable_obj++stable_bco, - ms_mod_name ms `notElem` [ ms_mod_name ms' | - AcyclicSCC ms' <- partial_mg ] ] - - mg = stable_mg ++ partial_mg - - -- clean up between compilations - let cleanup hsc_env = intermediateCleanTempFiles dflags - (flattenSCCs mg2_with_srcimps) - hsc_env - - liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") - 2 (ppr mg)) - - setSession hsc_env{ hsc_HPT = emptyHomePackageTable } - (upsweep_ok, modsUpswept) - <- upsweep pruned_hpt stable_mods cleanup mg - - -- Make modsDone be the summaries for each home module now - -- available; this should equal the domain of hpt3. - -- Get in in a roughly top .. bottom order (hence reverse). - - let modsDone = reverse modsUpswept - - -- Try and do linking in some form, depending on whether the - -- upsweep was completely or only partially successful. - - if succeeded upsweep_ok - - then - -- Easy; just relink it all. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") - - -- Clean up after ourselves - hsc_env1 <- getSession - liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 - - -- Issue a warning for the confusing case where the user - -- said '-o foo' but we're not going to do any linking. - -- We attempt linking if either (a) one of the modules is - -- called Main, or (b) the user said -no-hs-main, indicating - -- that main() is going to come from somewhere else. - -- - let ofile = outputFile dflags - let no_hs_main = dopt Opt_NoHsMain dflags - let - main_mod = mainModIs dflags - a_root_is_Main = any ((==main_mod).ms_mod) mod_graph - do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib - - when (ghcLink dflags == LinkBinary - && isJust ofile && not do_linking) $ - liftIO $ debugTraceMsg dflags 1 $ - text ("Warning: output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ - moduleNameString (moduleName main_mod) ++ " module.") - - -- link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - - loadFinish Succeeded linkresult - - else - -- Tricky. We need to back out the effects of compiling any - -- half-done cycles, both so as to clean up the top level envs - -- and to avoid telling the interactive linker to link them. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") - - let modsDone_names - = map ms_mod modsDone - let mods_to_zap_names - = findPartiallyCompletedCycles modsDone_names - mg2_with_srcimps - let mods_to_keep - = filter ((`notElem` mods_to_zap_names).ms_mod) - modsDone - - hsc_env1 <- getSession - let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) - (hsc_HPT hsc_env1) - - -- Clean up after ourselves - liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 - - -- there should be no Nothings where linkables should be, now - ASSERT(all (isJust.hm_linkable) - (eltsUFM (hsc_HPT hsc_env))) do - - -- Link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 - - modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } - loadFinish Failed linkresult - --- Finish up after a load. + mod_graph <- depanal [] False + guessOutputFile + hsc_env <- getSession + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = [ms_mod_name s + | s <- mod_graph, not (isBootSummary s)] + bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + not (ms_mod_name s `elem` all_home_mods)] + ASSERT( null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elem` all_home_mods = and_then + | otherwise = do + liftIO $ errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. Among other things, it is used for + -- backing out partially complete cycles following a failed + -- upsweep, and for removing from hpt all the modules + -- not in strict downwards closure, during calls to compile. + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports mg2_with_srcimps + + let + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + _ <- liftIO $ evaluate pruned_hpt + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + modifySession $ \_ -> discardIC $ hsc_env { hsc_HPT = pruned_hpt } + + liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco) + + -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- stable_obj++stable_bco, + Just hmi <- [lookupUFM pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + liftIO $ unload hsc_env stable_linkables + + -- We could at this point detect cycles which aren't broken by + -- a source-import, and complain immediately, but it seems better + -- to let upsweep_mods do this, so at least some useful work gets + -- done before the upsweep is abandoned. + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + + -- Now do the upsweep, calling compile for each module in + -- turn. Final result is version 3 of everything. + + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf _mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + ms_mod_name ms `elem` stable_obj++stable_bco, + ms_mod_name ms `notElem` [ ms_mod_name ms' | + AcyclicSCC ms' <- partial_mg ] ] + + mg = stable_mg ++ partial_mg + + -- clean up between compilations + let cleanup hsc_env = intermediateCleanTempFiles dflags + (flattenSCCs mg2_with_srcimps) + hsc_env + + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) + <- upsweep pruned_hpt stable_mods cleanup mg + + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domain of hpt3. + -- Get in in a roughly top .. bottom order (hence reverse). + + let modsDone = reverse modsUpswept + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if succeeded upsweep_ok + + then + -- Easy; just relink it all. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + hsc_env1 <- getSession + liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let ofile = outputFile dflags + let no_hs_main = dopt Opt_NoHsMain dflags + let + main_mod = mainModIs dflags + a_root_is_Main = any ((==main_mod).ms_mod) mod_graph + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib + + when (ghcLink dflags == LinkBinary + && isJust ofile && not do_linking) $ + liftIO $ debugTraceMsg dflags 1 $ + text ("Warning: output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") + + -- link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + + loadFinish Succeeded linkresult + + else + -- Tricky. We need to back out the effects of compiling any + -- half-done cycles, both so as to clean up the top level envs + -- and to avoid telling the interactive linker to link them. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") + + let modsDone_names + = map ms_mod modsDone + let mods_to_zap_names + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let mods_to_keep + = filter ((`notElem` mods_to_zap_names).ms_mod) + modsDone + + hsc_env1 <- getSession + let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) + (hsc_HPT hsc_env1) + + -- Clean up after ourselves + liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 + + -- there should be no Nothings where linkables should be, now + ASSERT(all (isJust.hm_linkable) + (eltsUFM (hsc_HPT hsc_env))) do + + -- Link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 + + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } + loadFinish Failed linkresult + + +-- | Finish up after a load. +loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag -- If the link failed, unload everything and return. -loadFinish :: GhcMonad m => - SuccessFlag -> SuccessFlag - -> m SuccessFlag loadFinish _all_ok Failed = do hsc_env <- getSession liftIO $ unload hsc_env [] @@ -362,16 +347,20 @@ loadFinish _all_ok Failed -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. loadFinish all_ok Succeeded - = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext } + = do modifySession discardIC return all_ok --- Forget the current program, but retain the persistent info in HscEnv +-- | Forget the current program, but retain the persistent info in HscEnv discardProg :: HscEnv -> HscEnv discardProg hsc_env - = hsc_env { hsc_mod_graph = emptyMG, - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable } + = discardIC $ hsc_env { hsc_mod_graph = emptyMG + , hsc_HPT = emptyHomePackageTable } + +-- | Discard the contents of the InteractiveContext, but keep the DynFlags +discardIC :: HscEnv -> HscEnv +discardIC hsc_env + = hsc_env { hsc_IC = emptyInteractiveContext (ic_dflags (hsc_IC hsc_env)) } intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () intermediateCleanTempFiles dflags summaries hsc_env @@ -416,13 +405,13 @@ guessOutputFile = modifySession $ \env -> Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } -- ----------------------------------------------------------------------------- - +-- -- | Prune the HomePackageTable -- -- Before doing an upsweep, we can throw away: -- -- - For non-stable modules: --- - all ModDetails, all linked code +-- - all ModDetails, all linked code -- - all unlinked code that is out of date with respect to -- the source file -- @@ -430,34 +419,31 @@ guessOutputFile = modifySession $ \env -> -- space at the end of the upsweep, because the topmost ModDetails of the -- old HPT holds on to the entire type environment from the previous -- compilation. - -pruneHomePackageTable - :: HomePackageTable - -> [ModSummary] - -> ([ModuleName],[ModuleName]) - -> HomePackageTable - +pruneHomePackageTable :: HomePackageTable + -> [ModSummary] + -> ([ModuleName],[ModuleName]) + -> HomePackageTable pruneHomePackageTable hpt summ (stable_obj, stable_bco) = mapUFM prune hpt where prune hmi - | is_stable modl = hmi' - | otherwise = hmi'{ hm_details = emptyModDetails } - where - modl = moduleName (mi_module (hm_iface hmi)) - hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms - = hmi{ hm_linkable = Nothing } - | otherwise - = hmi - where ms = expectJust "prune" (lookupUFM ms_map modl) + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = moduleName (mi_module (hm_iface hmi)) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupUFM ms_map modl) ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] - is_stable m = m `elem` stable_obj || m `elem` stable_bco + is_stable m = m `elem` stable_obj || m `elem` stable_bco -- ----------------------------------------------------------------------------- - --- Return (names of) all those in modsDone who are part of a cycle --- as defined by theGraph. +-- +-- | Return (names of) all those in modsDone who are part of a cycle as defined +-- by theGraph. findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] findPartiallyCompletedCycles modsDone theGraph = chew theGraph @@ -478,22 +464,21 @@ findPartiallyCompletedCycles modsDone theGraph -- --------------------------------------------------------------------------- --- Unloading - +-- +-- | Unloading unload :: HscEnv -> [Linkable] -> IO () -unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' +unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' = case ghcLink (hsc_dflags hsc_env) of #ifdef GHCI - LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else - LinkInMemory -> panic "unload: no interpreter" + LinkInMemory -> panic "unload: no interpreter" -- urgh. avoid warnings: hsc_env stable_linkables #endif - _other -> return () + _other -> return () -- ----------------------------------------------------------------------------- - {- | Stability tells us which modules definitely do not need to be recompiled. @@ -514,25 +499,25 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' stable m = stableObject m || stableBCO m stableObject m = - all stableObject (imports m) - && old linkable does not exist, or is == on-disk .o - && date(on-disk .o) > date(.hs) + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) stableBCO m = - all stable (imports m) - && date(BCO) > date(.hs) + all stable (imports m) + && date(BCO) > date(.hs) @ These properties embody the following ideas: - if a module is stable, then: - - if it has been compiled in a previous pass (present in HPT) - then it does not need to be compiled or re-linked. + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. - if it has not been compiled in a previous pass, - then we only need to read its .hi file from disk and - link it to produce a 'ModDetails'. + then we only need to read its .hi file from disk and + link it to produce a 'ModDetails'. - if a modules is not stable, we will definitely be at least re-linking, and possibly re-compiling it during the 'upsweep'. @@ -542,13 +527,12 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - Note that objects are only considered stable if they only depend on other objects. We can't link object code against byte code. -} - checkStability - :: HomePackageTable -- HPT from last compilation - -> [SCC ModSummary] -- current module graph (cyclic) - -> [ModuleName] -- all home modules - -> ([ModuleName], -- stableObject - [ModuleName]) -- stableBCO + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> [ModuleName] -- all home modules + -> ([ModuleName], -- stableObject + [ModuleName]) -- stableBCO checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs where @@ -557,65 +541,66 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs | stableBCOs = (stable_obj, scc_mods ++ stable_bco) | otherwise = (stable_obj, stable_bco) where - scc = flattenSCC scc0 - scc_mods = map ms_mod_name scc - home_module m = m `elem` all_home_mods && m `notElem` scc_mods + scc = flattenSCC scc0 + scc_mods = map ms_mod_name scc + home_module m = m `elem` all_home_mods && m `notElem` scc_mods scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) - -- all imports outside the current SCC, but in the home pkg - - stable_obj_imps = map (`elem` stable_obj) scc_allimps - stable_bco_imps = map (`elem` stable_bco) scc_allimps - - stableObjects = - and stable_obj_imps - && all object_ok scc - - stableBCOs = - and (zipWith (||) stable_obj_imps stable_bco_imps) - && all bco_ok scc - - object_ok ms - | Just t <- ms_obj_date ms = t >= ms_hs_date ms - && same_as_prev t - | otherwise = False - where - same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi - -> isObjectLinkable l && t == linkableTime l - _other -> True - -- why '>=' rather than '>' above? If the filesystem stores - -- times to the nearset second, we may occasionally find that - -- the object & source have the same modification time, - -- especially if the source was automatically generated - -- and compiled. Using >= is slightly unsafe, but it matches - -- make's behaviour. + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elem` stable_obj) scc_allimps + stable_bco_imps = map (`elem` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | dopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + _other -> True + -- why '>=' rather than '>' above? If the filesystem stores + -- times to the nearset second, we may occasionally find that + -- the object & source have the same modification time, + -- especially if the source was automatically generated + -- and compiled. Using >= is slightly unsafe, but it matches + -- make's behaviour. -- -- But see #5527, where someone ran into this and it caused -- a problem. - bco_ok ms - = case lookupUFM hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi -> - not (isObjectLinkable l) && - linkableTime l >= ms_hs_date ms - _other -> False + bco_ok ms + | dopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | otherwise = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms + _other -> False -- ----------------------------------------------------------------------------- - +-- -- | The upsweep -- -- This is where we compile each module in the module graph, in a pass -- from the bottom to the top of the graph. -- -- There better had not be any cyclic groups here -- we check for them. - upsweep :: GhcMonad m - => HomePackageTable -- ^ HPT from last time round (pruned) + => HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files - -> [SCC ModSummary] -- ^ Mods to do (the worklist) + -> [SCC ModSummary] -- ^ Mods to do (the worklist) -> m (SuccessFlag, [ModSummary]) -- ^ Returns: @@ -642,8 +627,8 @@ upsweep old_hpt stable_mods cleanup sccs = do upsweep' old_hpt done (AcyclicSCC mod:mods) mod_index nmods = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleUserString.moduleName.mi_module.hm_iface) - -- (moduleEnvElts (hsc_HPT hsc_env))) + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) let logger _mod = defaultWarnErrLogger hsc_env <- getSession @@ -662,21 +647,21 @@ upsweep old_hpt stable_mods cleanup sccs = do case mb_mod_info of Nothing -> return (Failed, done) Just mod_info -> do - let this_mod = ms_mod_name mod - - -- Add new info to hsc_env - hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info - hsc_env1 = hsc_env { hsc_HPT = hpt1 } - - -- Space-saving: delete the old HPT entry - -- for mod BUT if mod is a hs-boot - -- node, don't delete it. For the - -- interface, the HPT entry is probaby for the - -- main Haskell source file. Deleting it - -- would force the real module to be recompiled + let this_mod = ms_mod_name mod + + -- Add new info to hsc_env + hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info + hsc_env1 = hsc_env { hsc_HPT = hpt1 } + + -- Space-saving: delete the old HPT entry + -- for mod BUT if mod is a hs-boot + -- node, don't delete it. For the + -- interface, the HPT entry is probaby for the + -- main Haskell source file. Deleting it + -- would force the real module to be recompiled -- every time. - old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delFromUFM old_hpt this_mod + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromUFM old_hpt this_mod done' = mod:done @@ -685,30 +670,29 @@ upsweep old_hpt stable_mods cleanup sccs = do hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' setSession hsc_env2 - upsweep' old_hpt1 done' mods (mod_index+1) nmods + upsweep' old_hpt1 done' mods (mod_index+1) nmods -- | Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. upsweep_mod :: HscEnv -> HomePackageTable - -> ([ModuleName],[ModuleName]) + -> ([ModuleName],[ModuleName]) -> ModSummary -> Int -- index of module -> Int -- total number of modules -> IO HomeModInfo - upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods = let - this_mod_name = ms_mod_name summary - this_mod = ms_mod summary - mb_obj_date = ms_obj_date summary - obj_fn = ml_obj_file (ms_location summary) - hs_date = ms_hs_date summary + this_mod_name = ms_mod_name summary + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + obj_fn = ml_obj_file (ms_location summary) + hs_date = ms_hs_date summary - is_stable_obj = this_mod_name `elem` stable_obj - is_stable_bco = this_mod_name `elem` stable_bco + is_stable_obj = this_mod_name `elem` stable_obj + is_stable_bco = this_mod_name `elem` stable_bco - old_hmi = lookupUFM old_hpt this_mod_name + old_hmi = lookupUFM old_hpt this_mod_name -- We're using the dflags for this module now, obtained by -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. @@ -729,23 +713,23 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods -- store the corrected hscTarget into the summary summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } - -- The old interface is ok if - -- a) we're compiling a source file, and the old HPT - -- entry is for a source file - -- b) we're compiling a hs-boot file - -- Case (b) allows an hs-boot file to get the interface of its - -- real source file on the second iteration of the compilation - -- manager, but that does no harm. Otherwise the hs-boot file - -- will always be recompiled + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled mb_old_iface - = case old_hmi of - Nothing -> Nothing - Just hm_info | isBootSummary summary -> Just iface - | not (mi_boot iface) -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo compile_it mb_linkable src_modified = @@ -850,13 +834,12 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable retainInTopLevelEnvs keep_these hpt = listToUFM [ (mod, expectJust "retain" mb_mod_info) - | mod <- keep_these - , let mb_mod_info = lookupUFM hpt mod - , isJust mb_mod_info ] + | mod <- keep_these + , let mb_mod_info = lookupUFM hpt mod + , isJust mb_mod_info ] -- --------------------------------------------------------------------------- -- Typecheck module loops - {- See bug #930. This code fixes a long-standing bug in --make. The problem is that when compiling the modules *inside* a loop, a data @@ -884,7 +867,6 @@ re-typecheck. Following this fix, GHC can compile itself with --make -O2. -} - reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv reTypecheckLoop hsc_env ms graph | not (isBootSummary ms) && @@ -924,17 +906,15 @@ reachableBackwards mod summaries root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) -- --------------------------------------------------------------------------- --- Topological sort of the module graph - -type SummaryNode = (ModSummary, Int, [Int]) - +-- +-- | Topological sort of the module graph topSortModuleGraph - :: Bool + :: Bool -- ^ Drop hi-boot nodes? (see below) - -> [ModSummary] - -> Maybe ModuleName + -> [ModSummary] + -> Maybe ModuleName -- ^ Root module name. If @Nothing@, use the full graph. - -> [SCC ModSummary] + -> [SCC ModSummary] -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes -- The resulting list of strongly-connected-components is in topologically -- sorted order, starting with the module(s) at the bottom of the @@ -943,12 +923,12 @@ topSortModuleGraph -- -- Drop hi-boot nodes (first boolean arg)? -- --- - @False@: treat the hi-boot summaries as nodes of the graph, --- so the graph must be acyclic +-- - @False@: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic -- --- - @True@: eliminate the hi-boot nodes, and instead pretend --- the a source-import of Foo is an import of Foo --- The resulting graph has no hi-boot nodes, but can be cyclic +-- - @True@: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can be cyclic topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph @@ -966,6 +946,8 @@ topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod | otherwise = ghcError (ProgramError "module does not exist") in graphFromEdgedVertices (seq root (reachableG graph root)) +type SummaryNode = (ModSummary, Int, [Int]) + summaryNodeKey :: SummaryNode -> Int summaryNodeKey (_, k, _) = k @@ -1022,14 +1004,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs +type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs msKey :: ModSummary -> NodeKey msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) mkNodeMap :: [ModSummary] -> NodeMap ModSummary mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] - + nodeMapElts :: NodeMap a -> [a] nodeMapElts = Map.elems @@ -1039,25 +1021,27 @@ nodeMapElts = Map.elems -- were necessary, then the edge would be part of a cycle. warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () warnUnnecessarySourceImports sccs = do - logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) - where check ms = - let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] - - warn :: Located ModuleName -> WarnMsg - warn (L loc mod) = - mkPlainErrMsg loc - (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") - <+> quotes (ppr mod)) + dflags <- getDynFlags + logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)) + where check dflags ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn dflags i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: DynFlags -> Located ModuleName -> WarnMsg + warn dflags (L loc mod) = + mkPlainErrMsg dflags loc + (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") + <+> quotes (ppr mod)) ----------------------------------------------------------------------------- --- Downsweep (dependency analysis) - +-- +-- | Downsweep (dependency analysis) +-- -- Chase downwards from the specified root set, returning summaries -- for all home modules encountered. Only follow source-import -- links. - +-- -- We pass in the previous collection of summaries, which is used as a -- cache to avoid recalculating a module summary if the source is -- unchanged. @@ -1065,18 +1049,17 @@ warnUnnecessarySourceImports sccs = do -- The returned list of [ModSummary] nodes has one node for each home-package -- module, plus one for any hs-boot files. The imports of these nodes -- are all there, including the imports of non-home-package modules. - downsweep :: HscEnv - -> [ModSummary] -- Old summaries - -> [ModuleName] -- Ignore dependencies on these; treat - -- them as if they were package modules - -> Bool -- True <=> allow multiple targets to have - -- the same module name; this is - -- very useful for ghc -M - -> IO [ModSummary] - -- The elts of [ModSummary] all have distinct - -- (Modules, IsBoot) identifiers, unless the Bool is true - -- in which case there can be repeats + -> [ModSummary] -- Old summaries + -> [ModuleName] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO [ModSummary] + -- The elts of [ModSummary] all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true + -- in which case there can be repeats downsweep hsc_env old_summaries excl_mods allow_dup_roots = do rootSummaries <- mapM getRootSummary roots @@ -1085,86 +1068,86 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots summs <- loop (concatMap msDeps rootSummaries) root_map return summs where - roots = hsc_targets hsc_env + dflags = hsc_dflags hsc_env + roots = hsc_targets hsc_env - old_summary_map :: NodeMap ModSummary - old_summary_map = mkNodeMap old_summaries + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap old_summaries - getRootSummary :: Target -> IO ModSummary - getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) - = do exists <- liftIO $ doesFileExist file - if exists - then summariseFile hsc_env old_summaries file mb_phase + getRootSummary :: Target -> IO ModSummary + getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) + = do exists <- liftIO $ doesFileExist file + if exists + then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - else throwOneError $ mkPlainErrMsg noSrcSpan $ - text "can't find file:" <+> text file - getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) - = do maybe_summary <- summariseModule hsc_env old_summary_map False - (L rootLoc modl) obj_allowed + else throwOneError $ mkPlainErrMsg dflags noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) + = do maybe_summary <- summariseModule hsc_env old_summary_map False + (L rootLoc modl) obj_allowed maybe_buf excl_mods - case maybe_summary of - Nothing -> packageModErr modl - Just s -> return s - - rootLoc = mkGeneralSrcSpan (fsLit "<command line>") - - -- In a root module, the filename is allowed to diverge from the module - -- name, so we have to check that there aren't multiple root files - -- defining the same module (otherwise the duplicates will be silently - -- ignored, leading to confusing behaviour). - checkDuplicates :: NodeMap [ModSummary] -> IO () - checkDuplicates root_map - | allow_dup_roots = return () - | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr (head dup_roots) - where - dup_roots :: [[ModSummary]] -- Each at least of length 2 - dup_roots = filterOut isSingleton (nodeMapElts root_map) - - loop :: [(Located ModuleName,IsBootInterface)] - -- Work list: process these modules - -> NodeMap [ModSummary] - -- Visited set; the range is a list because - -- the roots can have the same module names - -- if allow_dup_roots is True - -> IO [ModSummary] - -- The result includes the worklist, except - -- for those mentioned in the visited set - loop [] done = return (concat (nodeMapElts done)) - loop ((wanted_mod, is_boot) : ss) done - | Just summs <- Map.lookup key done - = if isSingleton summs then - loop ss done - else - do { multiRootsErr summs; return [] } - | otherwise + case maybe_summary of + Nothing -> packageModErr dflags modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "<command line>") + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates :: NodeMap [ModSummary] -> IO () + checkDuplicates root_map + | allow_dup_roots = return () + | null dup_roots = return () + | otherwise = liftIO $ multiRootsErr dflags (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton (nodeMapElts root_map) + + loop :: [(Located ModuleName,IsBootInterface)] + -- Work list: process these modules + -> NodeMap [ModSummary] + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> IO [ModSummary] + -- The result includes the worklist, except + -- for those mentioned in the visited set + loop [] done = return (concat (nodeMapElts done)) + loop ((wanted_mod, is_boot) : ss) done + | Just summs <- Map.lookup key done + = if isSingleton summs then + loop ss done + else + do { multiRootsErr dflags summs; return [] } + | otherwise = do mb_s <- summariseModule hsc_env old_summary_map is_boot wanted_mod True Nothing excl_mods case mb_s of Nothing -> loop ss done Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) - where - key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) + where + key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) --- XXX Does the (++) here need to be flipped? mkRootMap :: [ModSummary] -> NodeMap [ModSummary] mkRootMap summaries = Map.insertListWith (flip (++)) [ (msKey s, [s]) | s <- summaries ] Map.empty -msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] --- (msDeps s) returns the dependencies of the ModSummary s. +-- | Returns the dependencies of the ModSummary s. -- A wrinkle is that for a {-# SOURCE #-} import we return --- *both* the hs-boot file --- *and* the source file +-- *both* the hs-boot file +-- *and* the source file -- as "dependencies". That ensures that the list of all relevant -- modules always contains B.hs if it contains B.hs-boot. -- Remember, this pass isn't doing the topological sort. It's -- just gathering the list of all relevant ModSummaries +msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] msDeps s = concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] - ++ [ (m,False) | m <- ms_home_imps s ] + ++ [ (m,False) | m <- ms_home_imps s ] home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] @@ -1187,107 +1170,106 @@ ms_home_imps = home_imps . ms_imps -- We have two types of summarisation: -- -- * Summarise a file. This is used for the root module(s) passed to --- cmLoadModules. The file is read, and used to determine the root --- module name. The module name may differ from the filename. +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. -- -- * Summarise a module. We are given a module name, and must provide --- a summary. The finder is used to locate the file in which the module --- resides. +-- a summary. The finder is used to locate the file in which the module +-- resides. summariseFile - :: HscEnv - -> [ModSummary] -- old summaries - -> FilePath -- source file name - -> Maybe Phase -- start phase + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase -> Bool -- object code allowed? - -> Maybe (StringBuffer,UTCTime) - -> IO ModSummary + -> Maybe (StringBuffer,UTCTime) + -> IO ModSummary summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - -- we can use a cached summary if one is available and the - -- source file hasn't changed, But we have to look up the summary - -- by source file, rather than module name as we do in summarise. + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. | Just old_summary <- findSummaryBySourceFile old_summaries file = do - let location = ms_location old_summary - - -- return the cached summary if the source didn't change - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationUTCTime file - -- The file exists; we checked in getRootSummary above. - -- If it gets removed subsequently, then this - -- getModificationUTCTime may fail, but that's the right - -- behaviour. - - if ms_hs_date old_summary == src_timestamp - then do -- update the object-file timestamp - obj_timestamp <- + let location = ms_location old_summary + + src_timestamp <- get_src_timestamp + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationUTCTime may fail, but that's the right + -- behaviour. + + -- return the cached summary if the source didn't change + if ms_hs_date old_summary == src_timestamp + then do -- update the object-file timestamp + obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then liftIO $ getObjTimestamp location False else return Nothing - return old_summary{ ms_obj_date = obj_timestamp } - else - new_summary + return old_summary{ ms_obj_date = obj_timestamp } + else + new_summary src_timestamp | otherwise - = new_summary + = do src_timestamp <- get_src_timestamp + new_summary src_timestamp where - new_summary = do - let dflags = hsc_dflags hsc_env + get_src_timestamp = case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationUTCTime file + -- getMofificationUTCTime may fail + + new_summary src_timestamp = do + let dflags = hsc_dflags hsc_env - (dflags', hspp_fn, buf) - <- preprocessFile hsc_env file mb_phase maybe_buf + (dflags', hspp_fn, buf) + <- preprocessFile hsc_env file mb_phase maybe_buf (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file - -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation dflags mod_name file - - -- Tell the Finder cache where it is, so that subsequent calls - -- to findModule will find it, even if it's not on any search path - mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location + -- Make a ModLocation for this file + location <- liftIO $ mkHomeModLocation dflags mod_name file - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationUTCTime file - -- getMofificationTime may fail + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location -- when the user asks to load a source file by name, we only -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- + obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then liftIO $ modificationTimeIfExists (ml_obj_file location) else return Nothing return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, - ms_location = location, + ms_location = location, ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, + ms_hspp_buf = Just buf, ms_srcimps = srcimps, ms_textual_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp }) + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp }) findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary findSummaryBySourceFile summaries file = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], - expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of - [] -> Nothing - (x:_) -> Just x + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:_) -> Just x -- Summarise a module, and pick up source and timestamp. summariseModule - :: HscEnv - -> NodeMap ModSummary -- Map of old summaries - -> IsBootInterface -- True <=> a {-# SOURCE #-} import - -> Located ModuleName -- Imported module to be summarised + :: HscEnv + -> NodeMap ModSummary -- Map of old summaries + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Located ModuleName -- Imported module to be summarised -> Bool -- object code allowed? - -> Maybe (StringBuffer, UTCTime) - -> [ModuleName] -- Modules to exclude - -> IO (Maybe ModSummary) -- Its new summary + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] -- Modules to exclude + -> IO (Maybe ModSummary) -- Its new summary summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) obj_allowed maybe_buf excl_mods @@ -1295,22 +1277,22 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) = return Nothing | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map - = do -- Find its new timestamp; all the - -- ModSummaries in the old map have valid ml_hs_files - let location = ms_location old_summary - src_fn = expectJust "summariseModule" (ml_hs_file location) - - -- check the modification time on the source file, and - -- return the cached summary if it hasn't changed. If the - -- file has disappeared, we need to call the Finder again. - case maybe_buf of - Just (_,t) -> check_timestamp old_summary location src_fn t - Nothing -> do - m <- tryIO (getModificationUTCTime src_fn) - case m of - Right t -> check_timestamp old_summary location src_fn t - Left e | isDoesNotExistError e -> find_it - | otherwise -> ioError e + = do -- Find its new timestamp; all the + -- ModSummaries in the old map have valid ml_hs_files + let location = ms_location old_summary + src_fn = expectJust "summariseModule" (ml_hs_file location) + + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> check_timestamp old_summary location src_fn t + Nothing -> do + m <- tryIO (getModificationUTCTime src_fn) + case m of + Right t -> check_timestamp old_summary location src_fn t + Left e | isDoesNotExistError e -> find_it + | otherwise -> ioError e | otherwise = find_it where @@ -1319,89 +1301,89 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) hsc_src = if is_boot then HsBootFile else HsSrcFile check_timestamp old_summary location src_fn src_timestamp - | ms_hs_date old_summary == src_timestamp = do - -- update the object-file timestamp + | ms_hs_date old_summary == src_timestamp = do + -- update the object-file timestamp obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then getObjTimestamp location is_boot else return Nothing - return (Just old_summary{ ms_obj_date = obj_timestamp }) - | otherwise = - -- source changed: re-summarise. - new_summary location (ms_mod old_summary) src_fn src_timestamp + return (Just old_summary{ ms_obj_date = obj_timestamp }) + | otherwise = + -- source changed: re-summarise. + new_summary location (ms_mod old_summary) src_fn src_timestamp find_it = do - -- Don't use the Finder's cache this time. If the module was - -- previously a package module, it may have now appeared on the - -- search path, so we want to consider it to be a home module. If - -- the module was previously a home module, it may have moved. - uncacheModule hsc_env wanted_mod - found <- findImportedModule hsc_env wanted_mod Nothing - case found of - Found location mod - | isJust (ml_hs_file location) -> - -- Home package - just_found location mod - | otherwise -> - -- Drop external-pkg - ASSERT(modulePackageId mod /= thisPackage dflags) - return Nothing - - err -> noModError dflags loc wanted_mod err - -- Not found + -- Don't use the Finder's cache this time. If the module was + -- previously a package module, it may have now appeared on the + -- search path, so we want to consider it to be a home module. If + -- the module was previously a home module, it may have moved. + uncacheModule hsc_env wanted_mod + found <- findImportedModule hsc_env wanted_mod Nothing + case found of + Found location mod + | isJust (ml_hs_file location) -> + -- Home package + just_found location mod + | otherwise -> + -- Drop external-pkg + ASSERT(modulePackageId mod /= thisPackage dflags) + return Nothing + + err -> noModError dflags loc wanted_mod err + -- Not found just_found location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so - let location' | is_boot = addBootSuffixLocn location - | otherwise = location - src_fn = expectJust "summarise2" (ml_hs_file location') + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let location' | is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = expectJust "summarise2" (ml_hs_file location') - -- Check that it exists - -- It might have been deleted since the Finder last found it - maybe_t <- modificationTimeIfExists src_fn - case maybe_t of - Nothing -> noHsFileErr loc src_fn - Just t -> new_summary location' mod src_fn t + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> noHsFileErr dflags loc src_fn + Just t -> new_summary location' mod src_fn t new_summary location mod src_fn src_timestamp = do - -- Preprocess the source file and get its imports - -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf + -- Preprocess the source file and get its imports + -- The dflags' contains the OPTIONS pragmas + (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn - when (mod_name /= wanted_mod) $ - throwOneError $ mkPlainErrMsg mod_loc $ - text "File name does not match module name:" - $$ text "Saw:" <+> quotes (ppr mod_name) + when (mod_name /= wanted_mod) $ + throwOneError $ mkPlainErrMsg dflags' mod_loc $ + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) - -- Find the object timestamp, and return the summary - obj_timestamp <- + -- Find the object timestamp, and return the summary + obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then getObjTimestamp location is_boot else return Nothing - return (Just (ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, + return (Just (ModSummary { ms_mod = mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, - ms_textual_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp })) + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_textual_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp })) getObjTimestamp :: ModLocation -> Bool -> IO (Maybe UTCTime) getObjTimestamp location is_boot = if is_boot then return Nothing - else modificationTimeIfExists (ml_obj_file location) + else modificationTimeIfExists (ml_obj_file location) preprocessFile :: HscEnv @@ -1411,59 +1393,59 @@ preprocessFile :: HscEnv -> IO (DynFlags, FilePath, StringBuffer) preprocessFile hsc_env src_fn mb_phase Nothing = do - (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- hGetStringBuffer hspp_fn - return (dflags', hspp_fn, buf) + (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) + buf <- hGetStringBuffer hspp_fn + return (dflags', hspp_fn, buf) preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) = do let dflags = hsc_dflags hsc_env - let local_opts = getOptions dflags buf src_fn + let local_opts = getOptions dflags buf src_fn - (dflags', leftovers, warns) + (dflags', leftovers, warns) <- parseDynamicFilePragma dflags local_opts - checkProcessArgsResult leftovers + checkProcessArgsResult dflags leftovers handleFlagWarnings dflags' warns - let needs_preprocessing - | Just (Unlit _) <- mb_phase = True - | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True - -- note: local_opts is only required if there's no Unlit phase - | xopt Opt_Cpp dflags' = True - | dopt Opt_Pp dflags' = True - | otherwise = False + let needs_preprocessing + | Just (Unlit _) <- mb_phase = True + | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True + -- note: local_opts is only required if there's no Unlit phase + | xopt Opt_Cpp dflags' = True + | dopt Opt_Pp dflags' = True + | otherwise = False - when needs_preprocessing $ - ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") + when needs_preprocessing $ + ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") - return (dflags', src_fn, buf) + return (dflags', src_fn, buf) ----------------------------------------------------------------------------- --- Error messages +-- Error messages ----------------------------------------------------------------------------- noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab -- ToDo: we don't have a proper line number for this error noModError dflags loc wanted_mod err - = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err - -noHsFileErr :: SrcSpan -> String -> IO a -noHsFileErr loc path - = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path + = throwOneError $ mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err + +noHsFileErr :: DynFlags -> SrcSpan -> String -> IO a +noHsFileErr dflags loc path + = throwOneError $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path -packageModErr :: ModuleName -> IO a -packageModErr mod - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "is a package module" - -multiRootsErr :: [ModSummary] -> IO () -multiRootsErr [] = panic "multiRootsErr" -multiRootsErr summs@(summ1:_) - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> - text "is defined in multiple files:" <+> - sep (map text files) +packageModErr :: DynFlags -> ModuleName -> IO a +packageModErr dflags mod + = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "is a package module" + +multiRootsErr :: DynFlags -> [ModSummary] -> IO () +multiRootsErr _ [] = panic "multiRootsErr" +multiRootsErr dflags summs@(summ1:_) + = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> + text "is defined in multiple files:" <+> + sep (map text files) where mod = ms_mod summ1 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs @@ -1498,5 +1480,5 @@ cyclicModuleErr mss ppr_ms :: ModSummary -> SDoc ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> - (parens (text (msHsFilePath ms))) + (parens (text (msHsFilePath ms))) diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 6322024c9e..91902d6b77 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -64,7 +64,7 @@ getImports :: DynFlags getImports dflags buf filename source_filename = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 case unP parseHeader (mkPState dflags buf loc) of - PFailed span err -> parseError span err + PFailed span err -> parseError dflags span err POk pst rdr_module -> do let _ms@(_warns, errs) = getMessages pst -- don't log warnings: they'll be reported when we parse the file @@ -123,8 +123,8 @@ mkPrelImports this_mod loc implicit_prelude import_decls ideclAs = Nothing, ideclHiding = Nothing } -parseError :: SrcSpan -> MsgDoc -> IO a -parseError span err = throwOneError $ mkPlainErrMsg span err +parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a +parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err -------------------------------------------------------------- -- Get options @@ -141,7 +141,8 @@ getOptionsFromFile dflags filename (openBinaryFile filename ReadMode) (hClose) (\handle -> do - opts <- fmap getOptions' $ lazyGetToks dflags' filename handle + opts <- fmap (getOptions' dflags) + (lazyGetToks dflags' filename handle) seqList opts $ return opts) where -- We don't need to get haddock doc tokens when we're just -- getting the options from pragmas, and lazily lexing them @@ -160,12 +161,12 @@ blockSize = 1024 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token] lazyGetToks dflags filename handle = do buf <- hGetStringBufferBlock handle blockSize - unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False + unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize where loc = mkRealSrcLoc (mkFastString filename) 1 1 - lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token] - lazyLexBuf handle state eof = do + lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] + lazyLexBuf handle state eof size = do case unP (lexer return) state of POk state' t -> do -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) @@ -173,22 +174,26 @@ lazyGetToks dflags filename handle = do -- if this token reached the end of the buffer, and we haven't -- necessarily read up to the end of the file, then the token might -- be truncated, so read some more of the file and lex it again. - then getMore handle state + then getMore handle state size else case t of L _ ITeof -> return [t] - _other -> do rest <- lazyLexBuf handle state' eof + _other -> do rest <- lazyLexBuf handle state' eof size return (t : rest) - _ | not eof -> getMore handle state + _ | not eof -> getMore handle state size | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof] -- parser assumes an ITeof sentinel at the end - getMore :: Handle -> PState -> IO [Located Token] - getMore handle state = do + getMore :: Handle -> PState -> Int -> IO [Located Token] + getMore handle state size = do -- pprTrace "getMore" (text (show (buffer state))) (return ()) - nextbuf <- hGetStringBufferBlock handle blockSize - if (len nextbuf == 0) then lazyLexBuf handle state True else do + let new_size = size * 2 + -- double the buffer size each time we read a new block. This + -- counteracts the quadratic slowdown we otherwise get for very + -- large module names (#5981) + nextbuf <- hGetStringBufferBlock handle new_size + if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do newbuf <- appendStringBuffers (buffer state) nextbuf - unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False + unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] @@ -210,15 +215,16 @@ getOptions :: DynFlags -> FilePath -- ^ Source filename. Used for location info. -> [Located String] -- ^ Parsed options. getOptions dflags buf filename - = getOptions' (getToks dflags filename buf) + = getOptions' dflags (getToks dflags filename buf) -- The token parser is written manually because Happy can't -- return a partial result when it encounters a lexer error. -- We want to extract options before the buffer is passed through -- CPP, so we can't use the same trick as 'getImports'. -getOptions' :: [Located Token] -- Input buffer +getOptions' :: DynFlags + -> [Located Token] -- Input buffer -> [Located String] -- Options. -getOptions' toks +getOptions' dflags toks = parseToks toks where getToken (L _loc tok) = tok @@ -248,14 +254,14 @@ getOptions' toks = parseLanguage xs parseToks _ = [] parseLanguage (L loc (ITconid fs):rest) - = checkExtension (L loc fs) : + = checkExtension dflags (L loc fs) : case rest of (L _loc ITcomma):more -> parseLanguage more (L _loc ITclose_prag):more -> parseToks more - (L loc _):_ -> languagePragParseError loc + (L loc _):_ -> languagePragParseError dflags loc [] -> panic "getOptions'.parseLanguage(1) went past eof token" parseLanguage (tok:_) - = languagePragParseError (getLoc tok) + = languagePragParseError dflags (getLoc tok) parseLanguage [] = panic "getOptions'.parseLanguage(2) went past eof token" @@ -265,51 +271,51 @@ getOptions' toks -- -- Throws a 'SourceError' if the input list is non-empty claiming that the -- input flags are unknown. -checkProcessArgsResult :: MonadIO m => [Located String] -> m () -checkProcessArgsResult flags +checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () +checkProcessArgsResult dflags flags = when (notNull flags) $ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags where mkMsg (L loc flag) - = mkPlainErrMsg loc $ + = mkPlainErrMsg dflags loc $ (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) ----------------------------------------------------------------------------- -checkExtension :: Located FastString -> Located String -checkExtension (L l ext) +checkExtension :: DynFlags -> Located FastString -> Located String +checkExtension dflags (L l ext) -- Checks if a given extension is valid, and if so returns -- its corresponding flag. Otherwise it throws an exception. = let ext' = unpackFS ext in if ext' `elem` supportedLanguagesAndExtensions then L l ("-X"++ext') - else unsupportedExtnError l ext' + else unsupportedExtnError dflags l ext' -languagePragParseError :: SrcSpan -> a -languagePragParseError loc = +languagePragParseError :: DynFlags -> SrcSpan -> a +languagePragParseError dflags loc = throw $ mkSrcErr $ unitBag $ - (mkPlainErrMsg loc $ + (mkPlainErrMsg dflags loc $ vcat [ text "Cannot parse LANGUAGE pragma" , text "Expecting comma-separated list of language options," , text "each starting with a capital letter" , nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ]) -unsupportedExtnError :: SrcSpan -> String -> a -unsupportedExtnError loc unsup = +unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a +unsupportedExtnError dflags loc unsup = throw $ mkSrcErr $ unitBag $ - mkPlainErrMsg loc $ + mkPlainErrMsg dflags loc $ text "Unsupported extension: " <> text unsup $$ if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) where suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions -optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages -optionsErrorMsgs unhandled_flags flags_lines _filename +optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages +optionsErrorMsgs dflags unhandled_flags flags_lines _filename = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) where unhandled_flags_lines = [ L l f | f <- unhandled_flags, L l f' <- flags_lines, f == f' ] mkMsg (L flagSpan flag) = - ErrUtils.mkPlainErrMsg flagSpan $ + ErrUtils.mkPlainErrMsg dflags flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index bdb26dfb38..000c9ead31 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -62,6 +62,7 @@ module HscMain , hscTcRnGetInfo , hscCheckSafe #ifdef GHCI + , hscIsGHCiMonad , hscGetModuleInterface , hscRnImportDecls , hscTcRnLookupRdrName @@ -151,6 +152,7 @@ import qualified Stream import Stream (Stream) import CLabel +import Util import Data.List import Control.Monad @@ -176,19 +178,17 @@ newHscEnv dflags = do fc_var <- newIORef emptyUFM mlc_var <- newIORef emptyModuleEnv optFuel <- initOptFuelState - safe_var <- newIORef True return HscEnv { hsc_dflags = dflags, hsc_targets = [], hsc_mod_graph = [], - hsc_IC = emptyInteractiveContext, + hsc_IC = emptyInteractiveContext dflags, hsc_HPT = emptyHomePackageTable, hsc_EPS = eps_var, hsc_NC = nc_var, hsc_FC = fc_var, hsc_MLC = mlc_var, hsc_OptFuel = optFuel, - hsc_type_env_var = Nothing, - hsc_safeInf = safe_var } + hsc_type_env_var = Nothing } knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, @@ -222,6 +222,13 @@ runHsc hsc_env (Hsc hsc) = do printOrThrowWarnings (hsc_dflags hsc_env) w return a +-- A variant of runHsc that switches in the DynFlags from the +-- InteractiveContext before running the Hsc computation. +-- +runInteractiveHsc :: HscEnv -> Hsc a -> IO a +runInteractiveHsc hsc_env = + runHsc (hsc_env { hsc_dflags = ic_dflags (hsc_IC hsc_env) }) + getWarnings :: Hsc WarningMessages getWarnings = Hsc $ \_ w -> return (w, w) @@ -292,31 +299,41 @@ ioMsgMaybe' ioA = do #ifdef GHCI hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name] -hscTcRnLookupRdrName hsc_env rdr_name = - runHsc hsc_env $ ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name +hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name #endif hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) -hscTcRcLookupName hsc_env name = - runHsc hsc_env $ ioMsgMaybe' $ tcRnLookupName hsc_env name +hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnLookupName hsc_env name -- ignore errors: the only error we're likely to get is -- "name not found", and the Maybe in the return type -- is used to indicate that. hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst])) -hscTcRnGetInfo hsc_env name = - runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name +hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnGetInfo hsc_env name #ifdef GHCI +hscIsGHCiMonad :: HscEnv -> String -> IO Name +hscIsGHCiMonad hsc_env name = + let icntxt = hsc_IC hsc_env + in runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env icntxt name + hscGetModuleInterface :: HscEnv -> Module -> IO ModIface -hscGetModuleInterface hsc_env mod = - runHsc hsc_env $ ioMsgMaybe $ getModuleInterface hsc_env mod +hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ getModuleInterface hsc_env mod -- ----------------------------------------------------------------------------- -- | Rename some import declarations hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv -hscRnImportDecls hsc_env import_decls = - runHsc hsc_env $ ioMsgMaybe $ tcRnImportDecls hsc_env import_decls +hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnImportDecls hsc_env import_decls #endif -- ----------------------------------------------------------------------------- @@ -347,7 +364,7 @@ hscParse' mod_summary = do case unP parseModule (mkPState dflags buf loc) of PFailed span err -> - liftIO $ throwOneError (mkPlainErrMsg span err) + liftIO $ throwOneError (mkPlainErrMsg dflags span err) POk pst rdr_module -> do logWarningsReportErrors (getMessages pst) @@ -398,10 +415,7 @@ type RenamedStuff = hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff) hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do - tc_result <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src mod_summary) - True rdr_module + tc_result <- tcRnModule' hsc_env mod_summary True rdr_module -- This 'do' is in the Maybe monad! let rn_info = do decl <- tcg_rn_decls tc_result @@ -412,6 +426,34 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do return (tc_result, rn_info) +-- wrapper around tcRnModule to handle safe haskell extras +tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule + -> Hsc TcGblEnv +tcRnModule' hsc_env sum save_rn_syntax mod = do + tcg_res <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ + tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod + + tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res) + dflags <- getDynFlags + + -- end of the Safe Haskell line, how to respond to user? + if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK) + -- if safe haskell off or safe infer failed, wipe trust + then wipeTrust tcg_res emptyBag + + -- module safe, throw warning if needed + else do + tcg_res' <- hscCheckSafeImports tcg_res + safe <- liftIO $ readIORef (tcg_safeInfer tcg_res') + when (safe && wopt Opt_WarnSafe dflags) + (logWarnings $ unitBag $ + mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ errSafe tcg_res') + return tcg_res' + where + pprMod t = ppr $ moduleName $ tcg_mod t + errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" + -- | Convert a typechecked module to Core hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts hscDesugar hsc_env mod_summary tc_result = @@ -436,9 +478,11 @@ hscDesugar' mod_location tc_result = do -- we should use fingerprint versions instead. makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails -> IO (ModIface,Bool) -makeSimpleIface hsc_env maybe_old_iface tc_result details = - runHsc hsc_env $ ioMsgMaybe $ - mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result +makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do + safe_mode <- hscGetSafeMode tc_result + ioMsgMaybe $ do + mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode + details tc_result -- | Make a 'ModDetails' from the results of typechecking. Used when -- typechecking only, as opposed to full compilation. @@ -538,12 +582,12 @@ data HsCompiler a = HsCompiler { -> Hsc a, -- | Code generation for normal modules. - hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint + hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint -> Hsc a } genericHscCompile :: HsCompiler a - -> (HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ()) + -> (HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary -> IO ()) -> HscEnv -> ModSummary -> SourceModified -> Maybe ModIface -> Maybe (Int, Int) -> IO a @@ -561,7 +605,7 @@ genericHscCompile compiler hscMessage hsc_env let mb_old_hash = fmap mi_iface_hash mb_checked_iface let skip iface = do - hscMessage hsc_env mb_mod_index RecompNotRequired mod_summary + hscMessage hsc_env mb_mod_index UpToDate mod_summary runHsc hsc_env $ hscNoRecomp compiler iface compile reason = do @@ -584,12 +628,12 @@ genericHscCompile compiler hscMessage hsc_env -- doing for us in one-shot mode. case mb_checked_iface of - Just iface | not recomp_reqd -> + Just iface | not (recompileRequired recomp_reqd) -> if mi_used_th iface && not stable - then compile RecompForcedByTH + then compile (RecompBecause "TH") else skip iface _otherwise -> - compile RecompRequired + compile recomp_reqd hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a hscCheckRecompBackend compiler tc_result hsc_env mod_summary @@ -602,7 +646,7 @@ hscCheckRecompBackend compiler tc_result hsc_env mod_summary let mb_old_hash = fmap mi_iface_hash mb_checked_iface case mb_checked_iface of - Just iface | not recomp_reqd + Just iface | not (recompileRequired recomp_reqd) -> runHsc hsc_env $ hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) } @@ -793,32 +837,33 @@ genModDetails old_iface -- Progress displayers. -------------------------------------------------------------- -data RecompReason = RecompNotRequired | RecompRequired | RecompForcedByTH - deriving Eq - -oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO () +oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary + -> IO () oneShotMsg hsc_env _mb_mod_index recomp _mod_summary = case recomp of - RecompNotRequired -> + UpToDate -> compilationProgressMsg (hsc_dflags hsc_env) $ "compilation IS NOT required" _other -> return () -batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO () +batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary + -> IO () batchMsg hsc_env mb_mod_index recomp mod_summary = case recomp of - RecompRequired -> showMsg "Compiling " - RecompNotRequired - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " + MustCompile -> showMsg "Compiling " "" + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" | otherwise -> return () - RecompForcedByTH -> showMsg "Compiling [TH] " + RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") where - showMsg msg = - compilationProgressMsg (hsc_dflags hsc_env) $ + dflags = hsc_dflags hsc_env + showMsg msg reason = + compilationProgressMsg dflags $ (showModuleIndex mb_mod_index ++ - msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) - (recomp == RecompRequired) mod_summary) + msg ++ showModMsg dflags (hscTarget dflags) + (recompileRequired recomp) mod_summary) + ++ reason -------------------------------------------------------------- -- FrontEnds @@ -828,30 +873,8 @@ hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv hscFileFrontEnd mod_summary = do hpm <- hscParse' mod_summary hsc_env <- getHscEnv - dflags <- getDynFlags - tcg_env <- - {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src mod_summary) False hpm - tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env) - - -- end of the Safe Haskell line, how to respond to user? - if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK) - - -- if safe haskell off or safe infer failed, wipe trust - then wipeTrust tcg_env emptyBag - - -- module safe, throw warning if needed - else do - tcg_env' <- hscCheckSafeImports tcg_env - safe <- liftIO $ hscGetSafeInf hsc_env - when (safe && wopt Opt_WarnSafe dflags) - (logWarnings $ unitBag $ - mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_env') - return tcg_env' - where - pprMod t = ppr $ moduleName $ tcg_mod t - errSafe t = quotes (pprMod t) <+> text "has been infered as safe!" + tcg_env <- tcRnModule' hsc_env mod_summary False hpm + return tcg_env -------------------------------------------------------------- -- Safe Haskell @@ -901,22 +924,22 @@ hscCheckSafeImports tcg_env = do case safeLanguageOn dflags of True -> do -- we nuke user written RULES in -XSafe - logWarnings $ warns (tcg_rules tcg_env') + logWarnings $ warns dflags (tcg_rules tcg_env') return tcg_env' { tcg_rules = [] } False -- user defined RULES, so not safe or already unsafe | safeInferOn dflags && not (null $ tcg_rules tcg_env') || safeHaskell dflags == Sf_None - -> wipeTrust tcg_env' $ warns (tcg_rules tcg_env') + -> wipeTrust tcg_env' $ warns dflags (tcg_rules tcg_env') - -- trustworthy OR safe infered with no RULES + -- trustworthy OR safe inferred with no RULES | otherwise -> return tcg_env' where - warns rules = listToBag $ map warnRules rules - warnRules (L loc (HsRule n _ _ _ _ _ _)) = - mkPlainWarnMsg loc $ + warns dflags rules = listToBag $ map (warnRules dflags) rules + warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) = + mkPlainWarnMsg dflags loc $ text "Rule \"" <> ftext n <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" @@ -983,7 +1006,7 @@ checkSafeImports dflags tcg_env cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal cond' v1@(m1,_,l1,s1) (_,_,_,s2) | s1 /= s2 - = throwErrors $ unitBag $ mkPlainErrMsg l1 + = throwErrors $ unitBag $ mkPlainErrMsg dflags l1 (text "Module" <+> ppr m1 <+> (text $ "is imported both as a safe and unsafe import!")) | otherwise @@ -1022,16 +1045,16 @@ hscCheckSafe' dflags m l = do iface <- lookup' m case iface of -- can't load iface to check trust! - Nothing -> throwErrors $ unitBag $ mkPlainErrMsg l - $ text "Can't load the interface file for" <+> ppr m <> - text ", to check that it can be safely imported" + Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l + $ text "Can't load the interface file for" <+> ppr m + <> text ", to check that it can be safely imported" -- got iface, check trust Just iface' -> do let trust = getSafeMode $ mi_trust iface' trust_own_pkg = mi_trust_pkg iface' -- check module is trusted - safeM = trust `elem` [Sf_SafeInfered, Sf_Safe, Sf_Trustworthy] + safeM = trust `elem` [Sf_SafeInferred, Sf_Safe, Sf_Trustworthy] -- check package is trusted safeP = packageTrusted trust trust_own_pkg m -- pkg trust reqs @@ -1044,13 +1067,16 @@ hscCheckSafe' dflags m l = do return (trust == Sf_Trustworthy, pkgRs) where - pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m - <+> text "can't be safely imported!" <+> text "The package (" - <> ppr (modulePackageId m) - <> text ") the module resides in isn't trusted." - modTrustErr = unitBag $ mkPlainErrMsg l $ ppr m - <+> text "can't be safely imported!" - <+> text "The module itself isn't safe." + pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg dflags l $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The package (" <> ppr (modulePackageId m) + <> text ") the module resides in isn't trusted." + ] + modTrustErr = unitBag $ mkPlainErrMsg dflags l $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The module itself isn't safe." ] -- | Check the package a module resides in is trusted. Safe compiled -- modules are trusted without requiring that their package is trusted. For @@ -1058,9 +1084,9 @@ hscCheckSafe' dflags m l = do -- otherwise we check the package trust flag. packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool packageTrusted _ _ _ - | not (packageTrustOn dflags) = True - packageTrusted Sf_Safe False _ = True - packageTrusted Sf_SafeInfered False _ = True + | not (packageTrustOn dflags) = True + packageTrusted Sf_Safe False _ = True + packageTrusted Sf_SafeInferred False _ = True packageTrusted _ _ m | isHomePkg m = True | otherwise = trusted $ getPackageDetails (pkgState dflags) @@ -1103,33 +1129,44 @@ checkPkgTrust dflags pkgs = | trusted $ getPackageDetails (pkgState dflags) pkg = Nothing | otherwise - = Just $ mkPlainErrMsg noSrcSpan - $ text "The package (" <> ppr pkg <> text ") is required" - <> text " to be trusted but it isn't!" + = Just $ mkPlainErrMsg dflags noSrcSpan + $ text "The package (" <> ppr pkg <> text ") is required" <> + text " to be trusted but it isn't!" -- | Set module to unsafe and wipe trust information. -- --- Make sure to call this method to set a module to infered unsafe, +-- Make sure to call this method to set a module to inferred unsafe, -- it should be a central and single failure method. wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv wipeTrust tcg_env whyUnsafe = do - env <- getHscEnv dflags <- getDynFlags when (wopt Opt_WarnUnsafe dflags) (logWarnings $ unitBag $ - mkPlainWarnMsg (warnUnsafeOnLoc dflags) whyUnsafe') + mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) - liftIO $ hscSetSafeInf env False + liftIO $ writeIORef (tcg_safeInfer tcg_env) False return $ tcg_env { tcg_imports = wiped_trust } where - wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } - pprMod = ppr $ moduleName $ tcg_mod tcg_env - whyUnsafe' = vcat [ quotes pprMod <+> text "has been infered as unsafe!" - , text "Reason:" - , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ] - + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } + pprMod = ppr $ moduleName $ tcg_mod tcg_env + whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" + , text "Reason:" + , nest 4 $ (vcat $ badFlags df) $+$ + (vcat $ pprErrMsgBagWithLoc whyUnsafe) + ] + badFlags df = concat $ map (badFlag df) unsafeFlags + badFlag df (str,loc,on,_) + | on df = [mkLocMessage SevOutput (loc df) $ + text str <+> text "is not allowed in Safe Haskell"] + | otherwise = [] + +-- | Figure out the final correct safe haskell mode +hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode +hscGetSafeMode tcg_env = do + dflags <- getDynFlags + liftIO $ finalSafeMode dflags tcg_env -------------------------------------------------------------- -- Simplifiers @@ -1152,12 +1189,13 @@ hscSimpleIface :: TcGblEnv -> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails) hscSimpleIface tc_result mb_old_iface = do - hsc_env <- getHscEnv - details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + hsc_env <- getHscEnv + details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + safe_mode <- hscGetSafeMode tc_result (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} ioMsgMaybe $ - mkIfaceTc hsc_env mb_old_iface details tc_result + mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env return (new_iface, no_change, details) @@ -1226,13 +1264,13 @@ hscGenHardCode cgguts mod_summary = do -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form prepd_binds <- {-# SCC "CorePrep" #-} - corePrepPgm dflags core_binds data_tycons ; + corePrepPgm dflags hsc_env core_binds data_tycons ; ----------------- Convert to STG ------------------ (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds - let prof_init = profilingInitCode platform this_mod cost_centre_info + let prof_init = profilingInitCode this_mod cost_centre_info foreign_stubs = foreign_stubs0 `appendStubC` prof_init ------------------ Code generation ------------------ @@ -1253,7 +1291,7 @@ hscGenHardCode cgguts mod_summary = do cmmToRawCmm platform cmms let dump a = do dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" - (pprPlatform platform a) + (ppr a) return a rawcmms1 = Stream.mapM dump rawcmms0 @@ -1286,8 +1324,9 @@ hscInteractive (iface, details, cgguts) mod_summary = do ------------------- -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form + hsc_env <- getHscEnv prepd_binds <- {-# SCC "CorePrep" #-} - liftIO $ corePrepPgm dflags core_binds data_tycons ; + liftIO $ corePrepPgm dflags hsc_env core_binds data_tycons ----------------- Generate byte code ------------------ comp_bc <- liftIO $ byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks @@ -1330,7 +1369,6 @@ tryNewCodeGen :: HscEnv -> Module -> [TyCon] tryNewCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do let dflags = hsc_dflags hsc_env - platform = targetPlatform dflags let cmm_stream :: Stream IO New.CmmGroup () cmm_stream = {-# SCC "StgCmm" #-} @@ -1343,8 +1381,7 @@ tryNewCodeGen hsc_env this_mod data_tycons -- to proc-point splitting). let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz - "Cmm produced by new codegen" - (pprPlatform platform a) + "Cmm produced by new codegen" (ppr a) return a ppr_stream1 = Stream.mapM dump1 cmm_stream @@ -1363,8 +1400,7 @@ tryNewCodeGen hsc_env this_mod data_tycons Stream.yield (cmmOfZgraph (srtToData topSRT)) let - dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ - pprPlatform platform a + dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a return a ppr_stream2 = Stream.mapM dump2 pipeline_stream @@ -1408,7 +1444,7 @@ IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver -- -- We return Nothing to indicate an empty statement (or comment only), not a -- parse error. -hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue])) +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv)) hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1 -- | Compile a stmt all the way to an HValue, but don't run it @@ -1419,8 +1455,10 @@ hscStmtWithLocation :: HscEnv -> String -- ^ The statement -> String -- ^ The source -> Int -- ^ Starting line - -> IO (Maybe ([Id], IO [HValue])) -hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do + -> IO (Maybe ([Id], IO [HValue], FixityEnv)) +hscStmtWithLocation hsc_env0 stmt source linenumber = + runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv maybe_stmt <- hscParseStmtWithLocation source linenumber stmt case maybe_stmt of Nothing -> return Nothing @@ -1434,7 +1472,7 @@ hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do -- Rename and typecheck it -- Here we lift the stmt into the IO monad, see Note -- [Interactively-bound Ids in GHCi] in TcRnDriver - (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt + (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt -- Desugar it ds_expr <- ioMsgMaybe $ @@ -1446,7 +1484,7 @@ hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr let hval_io = unsafeCoerce# hval :: IO [HValue] - return $ Just (ids, hval_io) + return $ Just (ids, hval_io, fix_env) -- | Compile a decls hscDecls :: HscEnv @@ -1460,7 +1498,9 @@ hscDeclsWithLocation :: HscEnv -> String -- ^ The source -> Int -- ^ Starting line -> IO ([TyThing], InteractiveContext) -hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do +hscDeclsWithLocation hsc_env0 str source linenumber = + runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv L _ (HsModule{ hsmodDecls = decls }) <- hscParseThingWithLocation source linenumber parseModule str @@ -1478,8 +1518,8 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do {- Desugar it -} -- We use a basically null location for iNTERACTIVE let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, - ml_hi_file = undefined, - ml_obj_file = undefined} + ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file", + ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"} ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv {- Simplify -} @@ -1498,7 +1538,7 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do {- Prepare For Code Generation -} -- Do saturation and convert to A-normal form prepd_binds <- {-# SCC "CorePrep" #-} - liftIO $ corePrepPgm dflags core_binds data_tycons + liftIO $ corePrepPgm dflags hsc_env core_binds data_tycons {- Generate byte code -} cbc <- liftIO $ byteCodeGen dflags this_mod @@ -1531,26 +1571,27 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do return (tythings, ictxt) hscImport :: HscEnv -> String -> IO (ImportDecl RdrName) -hscImport hsc_env str = runHsc hsc_env $ do +hscImport hsc_env str = runInteractiveHsc hsc_env $ do (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule str case is of [i] -> return (unLoc i) _ -> liftIO $ throwOneError $ - mkPlainErrMsg noSrcSpan $ + mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ ptext (sLit "parse error in import declaration") -- | Typecheck an expression (but don't run it) hscTcExpr :: HscEnv -> String -- ^ The expression -> IO Type -hscTcExpr hsc_env expr = runHsc hsc_env $ do +hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (ExprStmt expr _ _ _)) -> ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr _ -> - throwErrors $ unitBag $ mkPlainErrMsg noSrcSpan + throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan (text "not an expression:" <+> quotes (text expr)) -- | Find the kind of a type @@ -1559,7 +1600,8 @@ hscKcType -> Bool -- ^ Normalise the type -> String -- ^ The type as a string -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind -hscKcType hsc_env normalise str = runHsc hsc_env $ do +hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv ty <- hscParseType str ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) normalise ty @@ -1577,7 +1619,7 @@ hscParseType = hscParseThing parseType hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) hscParseIdentifier hsc_env str = - runHsc hsc_env $ hscParseThing parseIdentifier str + runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing hscParseThing = hscParseThingWithLocation "<interactive>" 1 @@ -1594,7 +1636,7 @@ hscParseThingWithLocation source linenumber parser str case unP parser (mkPState dflags buf loc) of PFailed span err -> do - let msg = mkPlainErrMsg span err + let msg = mkPlainErrMsg dflags span err throwErrors $ unitBag msg POk pst thing -> do @@ -1602,21 +1644,23 @@ hscParseThingWithLocation source linenumber parser str liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) return thing -hscCompileCore :: HscEnv -> Bool -> ModSummary -> CoreProgram -> IO () -hscCompileCore hsc_env simplify mod_summary binds = runHsc hsc_env $ do - guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds) - (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing - hscWriteIface iface changed mod_summary - _ <- hscGenHardCode cgguts mod_summary - return () +hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary + -> CoreProgram -> IO () +hscCompileCore hsc_env simplify safe_mode mod_summary binds + = runHsc hsc_env $ do + guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds) + (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing + hscWriteIface iface changed mod_summary + _ <- hscGenHardCode cgguts mod_summary + return () where maybe_simplify mod_guts | simplify = hscSimplify' mod_guts | otherwise = return mod_guts -- Makes a "vanilla" ModGuts. -mkModGuts :: Module -> CoreProgram -> ModGuts -mkModGuts mod binds = +mkModGuts :: Module -> SafeHaskellMode -> CoreProgram -> ModGuts +mkModGuts mod safe binds = ModGuts { mg_module = mod, mg_boot = False, @@ -1641,6 +1685,7 @@ mkModGuts mod binds = mg_vect_info = noVectInfo, mg_inst_env = emptyInstEnv, mg_fam_inst_env = emptyFamInstEnv, + mg_safe_haskell = safe, mg_trust_pkg = False, mg_dependent_files = [] } @@ -1670,7 +1715,7 @@ hscCompileCoreExpr hsc_env srcspan ds_expr let tidy_expr = tidyExpr emptyTidyEnv simpl_expr {- Prepare for codegen -} - prepd_expr <- corePrepExpr dflags tidy_expr + prepd_expr <- corePrepExpr dflags hsc_env tidy_expr {- Lint if necessary -} -- ToDo: improve SrcLoc @@ -1702,7 +1747,7 @@ hscCompileCoreExpr hsc_env srcspan ds_expr dumpIfaceStats :: HscEnv -> IO () dumpIfaceStats hsc_env = do eps <- readIORef (hsc_EPS hsc_env) - dumpIfSet (dump_if_trace || dump_rn_stats) + dumpIfSet dflags (dump_if_trace || dump_rn_stats) "Interface statistics" (ifaceStats eps) where diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs new file mode 100644 index 0000000000..79eb8f54cb --- /dev/null +++ b/compiler/main/HscStats.hs @@ -0,0 +1,160 @@ +-- | +-- Statistics for per-module compilations +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- +module HscStats ( ppSourceStats ) where + +import Bag +import HsSyn +import Outputable +import RdrName +import SrcLoc +import Util + +import Data.Char + +-- | Source Statistics +ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc +ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) + = (if short then hcat else vcat) + (map pp_val + [("ExportAll ", export_all), -- 1 if no export list + ("ExportDecls ", export_ds), + ("ExportModules ", export_ms), + ("Imports ", imp_no), + (" ImpSafe ", imp_safe), + (" ImpQual ", imp_qual), + (" ImpAs ", imp_as), + (" ImpAll ", imp_all), + (" ImpPartial ", imp_partial), + (" ImpHiding ", imp_hiding), + ("FixityDecls ", fixity_sigs), + ("DefaultDecls ", default_ds), + ("TypeDecls ", type_ds), + ("DataDecls ", data_ds), + ("NewTypeDecls ", newt_ds), + ("TypeFamilyDecls ", type_fam_ds), + ("DataConstrs ", data_constrs), + ("DataDerivings ", data_derivs), + ("ClassDecls ", class_ds), + ("ClassMethods ", class_method_ds), + ("DefaultMethods ", default_method_ds), + ("InstDecls ", inst_ds), + ("InstMethods ", inst_method_ds), + ("InstType ", inst_type_ds), + ("InstData ", inst_data_ds), + ("TypeSigs ", bind_tys), + ("GenericSigs ", generic_sigs), + ("ValBinds ", val_bind_ds), + ("FunBinds ", fn_bind_ds), + ("InlineMeths ", method_inlines), + ("InlineBinds ", bind_inlines), + ("SpecialisedMeths ", method_specs), + ("SpecialisedBinds ", bind_specs) + ]) + where + decls = map unLoc ldecls + + pp_val (_, 0) = empty + pp_val (str, n) + | not short = hcat [text str, int n] + | otherwise = hcat [text (trim str), equals, int n, semi] + + trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) + + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) + = count_sigs [d | SigD d <- decls] + -- NB: this omits fixity decls on local bindings and + -- in class decls. ToDo + + tycl_decls = [d | TyClD d <- decls] + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = + countTyClDecls tycl_decls + + inst_decls = [d | InstD d <- decls] + inst_ds = length inst_decls + default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls + val_decls = [d | ValD d <- decls] + + real_exports = case exports of { Nothing -> []; Just es -> es } + n_exports = length real_exports + export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False}) + real_exports + export_ds = n_exports - export_ms + export_all = case exports of { Nothing -> 1; _ -> 0 } + + (val_bind_ds, fn_bind_ds) + = foldr add2 (0,0) (map count_bind val_decls) + + (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) + = foldr add7 (0,0,0,0,0,0,0) (map import_info imports) + (data_constrs, data_derivs) + = foldr add2 (0,0) (map data_info tycl_decls) + (class_method_ds, default_method_ds) + = foldr add2 (0,0) (map class_info tycl_decls) + (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) + = foldr add5 (0,0,0,0,0) (map inst_info inst_decls) + + count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0) + count_bind (PatBind {}) = (0,1) + count_bind (FunBind {}) = (0,1) + count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) + + count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs) + + sig_info (FixSig _) = (1,0,0,0,0) + sig_info (TypeSig _ _) = (0,1,0,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0,0) + sig_info (InlineSig _ _) = (0,0,0,1,0) + sig_info (GenericSig _ _) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) + + import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclHiding = spec })) + = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) + safe_info = qual_info + qual_info False = 0 + qual_info True = 1 + as_info Nothing = 0 + as_info (Just _) = 1 + spec_info Nothing = (0,0,0,0,1,0,0) + spec_info (Just (False, _)) = (0,0,0,0,0,1,0) + spec_info (Just (True, _)) = (0,0,0,0,0,0,1) + + data_info (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}}) + = (length cs, case derivs of Nothing -> 0 + Just ds -> length ds) + data_info _ = (0,0) + + class_info decl@(ClassDecl {}) + = case count_sigs (map unLoc (tcdSigs decl)) of + (_,classops,_,_,_) -> + (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) + class_info _ = (0,0) + + inst_info (FamInstD { lid_inst = d }) + = case countATDecl d of + (tyd, dtd) -> (0,0,0,tyd,dtd) + inst_info (ClsInstD { cid_binds = inst_meths, cid_sigs = inst_sigs, cid_fam_insts = ats }) + = case count_sigs (map unLoc inst_sigs) of + (_,_,ss,is,_) -> + case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of + (tyDecl, dtDecl) -> + (addpr (foldr add2 (0,0) + (map (count_bind.unLoc) (bagToList inst_meths))), + ss, is, tyDecl, dtDecl) + where + countATDecl (FamInstDecl { fid_defn = TyData {} }) = (0, 1) + countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0) + + addpr :: (Int,Int) -> Int + add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) + add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int) + add7 :: (Int,Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int, Int) + + addpr (x,y) = x+y + add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) + add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) + add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) + diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index 168e49af4a..b5fe0fdf86 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -141,7 +141,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) spec_info (Just (False, _)) = (0,0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,0,1) - data_info (TyData {tcdCons = cs, tcdDerivs = derivs}) + data_info (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}}) = (length cs, case derivs of Nothing -> 0 Just ds -> length ds) data_info _ = (0,0) @@ -152,9 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) class_info _ = (0,0) - inst_info (FamInstDecl d) = case countATDecl d of + inst_info (FamInstD d) = case countATDecl d of (tyd, dtd) -> (0,0,0,tyd,dtd) - inst_info (ClsInstDecl _ inst_meths inst_sigs ats) + inst_info (ClsInstD _ inst_meths inst_sigs ats) = case count_sigs (map unLoc inst_sigs) of (_,_,ss,is,_) -> case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of @@ -163,10 +163,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is, tyDecl, dtDecl) where - countATDecl (TyData {}) = (0, 1) - countATDecl (TySynonym {}) = (1, 0) - countATDecl d = pprPanic "countATDecl: Unhandled decl" - (ppr d) + countATDecl (FamInstDecl { fid_defn = TyData {} }) = (0, 1) + countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0) addpr :: (Int,Int) -> Int add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 9840b407ce..156f081d3e 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -44,6 +44,7 @@ module HscTypes ( InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, icInScopeTTs, icPlusGblRdrEnv, extendInteractiveContext, substInteractiveContext, + setInteractivePrintName, InteractiveImport(..), mkPrintUnqualified, pprModulePrefix, @@ -73,7 +74,7 @@ module HscTypes ( -- * Information on imports and exports WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, - NameCache(..), OrigNameCache, OrigIParamCache, + NameCache(..), OrigNameCache, IfaceExport, -- * Warnings @@ -95,7 +96,6 @@ module HscTypes ( noIfaceVectInfo, isNoIfaceVectInfo, -- * Safe Haskell information - hscGetSafeInf, hscSetSafeInf, IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, trustInfoToNum, numToTrustInfo, IsSafeImport, @@ -137,7 +137,7 @@ import Annotations import Class import TyCon import DataCon -import PrelNames ( gHC_PRIM ) +import PrelNames ( gHC_PRIM, ioTyConName, printName ) import Packages hiding ( Version(..) ) import DynFlags import DriverPhases @@ -163,7 +163,6 @@ import Util import Control.Monad ( mplus, guard, liftM, when ) import Data.Array ( Array, array ) import Data.IORef -import Data.Map ( Map ) import Data.Time import Data.Word import Data.Typeable ( Typeable ) @@ -182,8 +181,8 @@ mkSrcErr = SourceError srcErrorMessages :: SourceError -> ErrorMessages srcErrorMessages (SourceError msgs) = msgs -mkApiErr :: SDoc -> GhcApiError -mkApiErr = GhcApiError +mkApiErr :: DynFlags -> SDoc -> GhcApiError +mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) throwOneError :: MonadIO m => ErrMsg -> m ab throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err @@ -222,11 +221,11 @@ handleSourceError handler act = gcatch act (\(e :: SourceError) -> handler e) -- | An error thrown if the GHC API is used in an incorrect fashion. -newtype GhcApiError = GhcApiError SDoc +newtype GhcApiError = GhcApiError String deriving Typeable instance Show GhcApiError where - show (GhcApiError msg) = showSDoc msg + show (GhcApiError msg) = msg instance Exception GhcApiError @@ -236,7 +235,7 @@ printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () printOrThrowWarnings dflags warns | dopt Opt_WarnIsError dflags = when (not (isEmptyBag warns)) $ do - throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg + throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags | otherwise = printBagOfErrors dflags warns @@ -245,7 +244,7 @@ handleFlagWarnings dflags warns = when (wopt Opt_WarnDeprecatedFlags dflags) $ do -- It would be nicer if warns :: [Located MsgDoc], but that -- has circular import problems. - let bag = listToBag [ mkPlainWarnMsg loc (text warn) + let bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) | L loc warn <- warns ] printOrThrowWarnings dflags bag @@ -324,24 +323,12 @@ data HscEnv -- by limiting the number of transformations, -- we can use binary search to help find compiler bugs. - hsc_type_env_var :: Maybe (Module, IORef TypeEnv), + hsc_type_env_var :: Maybe (Module, IORef TypeEnv) -- ^ Used for one-shot compilation only, to initialise -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for -- 'TcRunTypes.TcGblEnv' - - hsc_safeInf :: {-# UNPACK #-} !(IORef Bool) - -- ^ Have we infered the module being compiled as - -- being safe? } --- | Get if the current module is considered safe or not by inference. -hscGetSafeInf :: HscEnv -> IO Bool -hscGetSafeInf hsc_env = readIORef (hsc_safeInf hsc_env) - --- | Set if the current module is considered safe or not by inference. -hscSetSafeInf :: HscEnv -> Bool -> IO () -hscSetSafeInf hsc_env b = writeIORef (hsc_safeInf hsc_env) b - -- | Retrieve the ExternalPackageState cache. hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (hsc_EPS hsc_env) @@ -842,6 +829,8 @@ data ModGuts mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance enviroment for /home-package/ modules -- (including this one); c.f. 'tcg_fam_inst_env' + mg_safe_haskell :: SafeHaskellMode, + -- ^ Safe Haskell mode mg_trust_pkg :: Bool, -- ^ Do we need to trust our own package for Safe Haskell? -- See Note [RnNames . Trust Own Package] @@ -917,6 +906,13 @@ appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) -- context in which statements are executed in a GHC session. data InteractiveContext = InteractiveContext { + ic_dflags :: DynFlags, + -- ^ The 'DynFlags' used to evaluate interative expressions + -- and statements. + + ic_monad :: Name, + -- ^ The monad that GHCi is executing in + ic_imports :: [InteractiveImport], -- ^ The GHCi context is extended with these imports -- @@ -946,6 +942,13 @@ data InteractiveContext -- time we update the context, we just take the results -- from the instance code that already does that. + ic_fix_env :: FixityEnv, + -- ^ Fixities declared in let statements + + ic_int_print :: Name, + -- ^ The function that is used for printing results + -- of expressions in ghci and -e mode. + #ifdef GHCI ic_resume :: [Resume], -- ^ The stack of breakpoint contexts @@ -977,13 +980,19 @@ hscDeclsWithLocation) and save them in ic_sys_vars. -} -- | Constructs an empty InteractiveContext. -emptyInteractiveContext :: InteractiveContext -emptyInteractiveContext - = InteractiveContext { ic_imports = [], +emptyInteractiveContext :: DynFlags -> InteractiveContext +emptyInteractiveContext dflags + = InteractiveContext { ic_dflags = dflags, + -- IO monad by default + ic_monad = ioTyConName, + ic_imports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, ic_tythings = [], ic_sys_vars = [], ic_instances = ([],[]), + ic_fix_env = emptyNameEnv, + -- System.IO.print by default + ic_int_print = printName, #ifdef GHCI ic_resume = [], #endif @@ -1018,6 +1027,9 @@ extendInteractiveContext ictxt new_tythings new_names = [ nameOccName (getName id) | AnId id <- new_tythings ] +setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext +setInteractivePrintName ic n = ic{ic_int_print = n} + -- ToDo: should not add Ids to the gbl env here -- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing @@ -1041,7 +1053,7 @@ data InteractiveImport -- ^ Bring the exports of a particular module -- (filtered by an import decl) into scope - | IIModule Module + | IIModule ModuleName -- ^ Bring into scope the entire top-level envt of -- of this module, including the things imported -- into it. @@ -1088,7 +1100,7 @@ exposed (say P2), so we use M.T for that, and P1:M.T for the other one. This is handled by the qual_mod component of PrintUnqualified, inside the (ppr mod) of case (3), in Name.pprModulePrefix -\begin{code} + \begin{code} -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified @@ -1760,17 +1772,12 @@ its binding site, we fix it up. data NameCache = NameCache { nsUniqs :: UniqSupply, -- ^ Supply of uniques - nsNames :: OrigNameCache, + nsNames :: OrigNameCache -- ^ Ensures that one original name gets one unique - nsIPs :: OrigIParamCache - -- ^ Ensures that one implicit parameter name gets one unique } -- | Per-module cache of original 'OccName's given 'Name's type OrigNameCache = ModuleEnv (OccEnv Name) - --- | Module-local cache of implicit parameter 'OccName's given 'Name's -type OrigIParamCache = Map FastString (IPName Name) \end{code} @@ -1867,9 +1874,9 @@ instance Outputable ModSummary where char '}' ] -showModMsg :: HscTarget -> Bool -> ModSummary -> String -showModMsg target recomp mod_summary - = showSDoc $ +showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String +showModMsg dflags target recomp mod_summary + = showSDoc dflags $ hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), char '(', text (normalise $ msHsFilePath mod_summary) <> comma, case target of @@ -1880,7 +1887,7 @@ showModMsg target recomp mod_summary char ')'] where mod = moduleName (ms_mod mod_summary) - mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) + mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) \end{code} %************************************************************************ @@ -2056,26 +2063,26 @@ noIfaceTrustInfo = setSafeMode Sf_None trustInfoToNum :: IfaceTrustInfo -> Word8 trustInfoToNum it = case getSafeMode it of - Sf_None -> 0 - Sf_Unsafe -> 1 - Sf_Trustworthy -> 2 - Sf_Safe -> 3 - Sf_SafeInfered -> 4 + Sf_None -> 0 + Sf_Unsafe -> 1 + Sf_Trustworthy -> 2 + Sf_Safe -> 3 + Sf_SafeInferred -> 4 numToTrustInfo :: Word8 -> IfaceTrustInfo numToTrustInfo 0 = setSafeMode Sf_None numToTrustInfo 1 = setSafeMode Sf_Unsafe numToTrustInfo 2 = setSafeMode Sf_Trustworthy numToTrustInfo 3 = setSafeMode Sf_Safe -numToTrustInfo 4 = setSafeMode Sf_SafeInfered +numToTrustInfo 4 = setSafeMode Sf_SafeInferred numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" instance Outputable IfaceTrustInfo where - ppr (TrustInfo Sf_None) = ptext $ sLit "none" - ppr (TrustInfo Sf_Unsafe) = ptext $ sLit "unsafe" - ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" - ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" - ppr (TrustInfo Sf_SafeInfered) = ptext $ sLit "safe-infered" + ppr (TrustInfo Sf_None) = ptext $ sLit "none" + ppr (TrustInfo Sf_Unsafe) = ptext $ sLit "unsafe" + ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" + ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" + ppr (TrustInfo Sf_SafeInferred) = ptext $ sLit "safe-inferred" \end{code} %************************************************************************ diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index cdc2ca501a..60681fc6e7 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -43,6 +43,7 @@ import HscMain import HsSyn import HscTypes import InstEnv +import TyCon import Type hiding( typeKind ) import TcType hiding( typeKind ) import Var @@ -72,6 +73,7 @@ import MonadUtils import System.Directory import Data.Dynamic +import Data.Either import Data.List (find) import Control.Monad #if __GLASGOW_HASKELL__ >= 701 @@ -84,7 +86,6 @@ import GHC.Exts import Data.Array import Exception import Control.Concurrent -import System.IO import System.IO.Unsafe -- ----------------------------------------------------------------------------- @@ -176,6 +177,12 @@ findEnclosingDecls hsc_env inf = mb = getModBreaks hmi in modBreaks_decls mb ! breakInfo_number inf +-- | Update fixity environment in the current interactive context. +updateFixityEnv :: GhcMonad m => FixityEnv -> m () +updateFixityEnv fix_env = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } } -- | Run a statement in the current interactive context. Statement -- may bind multple values. @@ -195,8 +202,9 @@ runStmtWithLocation source linenumber expr step = -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. - let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } + let ic = hsc_IC hsc_env -- use the interactive dflags + idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedBinds + hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } } -- compile to value (IO [HValue]), don't run r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber @@ -205,11 +213,13 @@ runStmtWithLocation source linenumber expr step = -- empty statement / comment Nothing -> return (RunOk []) - Just (tyThings, hval) -> do + Just (tyThings, hval, fix_env) -> do + updateFixityEnv fix_env + status <- withVirtualCWD $ - withBreakAction (isStep step) dflags' breakMVar statusMVar $ do - liftIO $ sandboxIO dflags' statusMVar hval + withBreakAction (isStep step) idflags' breakMVar statusMVar $ do + liftIO $ sandboxIO idflags' statusMVar hval let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) @@ -229,13 +239,7 @@ runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] runDeclsWithLocation source linenumber expr = do hsc_env <- getSession - - -- Turn off -fwarn-unused-bindings when running a statement, to hide - -- warnings about the implicit bindings we introduce. - let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } - - (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env' expr source linenumber + (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber setSession $ hsc_env { hsc_IC = ic } hsc_env <- getSession @@ -416,8 +420,8 @@ rethrow dflags io = Exception.catch io $ \se -> do withInterruptsSentTo :: ThreadId -> IO r -> IO r withInterruptsSentTo thread get_result = do - bracket (modifyMVar_ interruptTargetThread (return . (thread:))) - (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl)) + bracket (pushInterruptTargetThread thread) + (\_ -> popInterruptTargetThread) (\_ -> get_result) -- This function sets up the interpreter for catching breakpoints, and @@ -606,8 +610,9 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- Filter out any unboxed ids; -- we can't bind these at the prompt pointers = filter (\(id,_) -> isPointer id) vars - isPointer id | PtrRep <- idPrimRep id = True - | otherwise = False + isPointer id | UnaryRep ty <- repType (idType id) + , PtrRep <- typePrimRep ty = True + | otherwise = False (ids, offsets) = unzip pointers @@ -642,7 +647,6 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- - globalise the Id (Ids are supposed to be Global, apparently). -- let result_ok = isPointer result_id - && not (isUnboxedTupleType (idType result_id)) all_ids | result_ok = result_id : new_ids | otherwise = new_ids @@ -704,8 +708,9 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do WARN(True, text (":print failed to calculate the " ++ "improvement for a type")) hsc_env Just subst -> do - when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $ - printForUser stderr alwaysQualify $ + let dflags = hsc_dflags hsc_env + when (dopt Opt_D_dump_rtti dflags) $ + printInfoForUser dflags alwaysQualify $ fsep [text "RTTI Improvement for", ppr id, equals, ppr subst] let ic' = extendInteractiveContext @@ -763,11 +768,16 @@ abandonAll = do -- with the partial computation, which still ends in takeMVar, -- so any attempt to evaluate one of these thunks will block -- unless we fill in the MVar. +-- (c) wait for the thread to terminate by taking its status MVar. This +-- step is necessary to prevent race conditions with +-- -fbreak-on-exception (see #5975). -- See test break010. abandon_ :: Resume -> IO () abandon_ r = do killThread (resumeThreadId r) putMVar (resumeBreakMVar r) () + _ <- takeMVar (resumeStatMVar r) + return () -- ----------------------------------------------------------------------------- -- Bounded list, optimised for repeated cons @@ -804,27 +814,41 @@ fromListBL bound l = BL (length l) bound l [] setContext :: GhcMonad m => [InteractiveImport] -> m () setContext imports = do { hsc_env <- getSession - ; all_env <- liftIO $ findGlobalRdrEnv hsc_env imports + ; let dflags = hsc_dflags hsc_env + ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports + ; case all_env_err of + Left (mod, err) -> ghcError (formatError dflags mod err) + Right all_env -> do { ; let old_ic = hsc_IC hsc_env final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env ; modifySession $ \_ -> hsc_env{ hsc_IC = old_ic { ic_imports = imports - , ic_rn_gbl_env = final_rdr_env }}} + , ic_rn_gbl_env = final_rdr_env }}}} + where + formatError dflags mod err = ProgramError . showSDoc dflags $ + text "Cannot add module" <+> ppr mod <+> + text "to context:" <+> text err -findGlobalRdrEnv :: HscEnv -> [InteractiveImport] -> IO GlobalRdrEnv +findGlobalRdrEnv :: HscEnv -> [InteractiveImport] + -> IO (Either (ModuleName, String) GlobalRdrEnv) -- Compute the GlobalRdrEnv for the interactive context findGlobalRdrEnv hsc_env imports = do { idecls_env <- hscRnImportDecls hsc_env idecls -- This call also loads any orphan modules - ; imods_env <- mapM (mkTopLevEnv (hsc_HPT hsc_env)) imods - ; return (foldr plusGlobalRdrEnv idecls_env imods_env) } + ; return $ case partitionEithers (map mkEnv imods) of + ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) + (err : _, _) -> Left err } where idecls :: [LImportDecl RdrName] idecls = [noLoc d | IIDecl d <- imports] - imods :: [Module] + imods :: [ModuleName] imods = [m | IIModule m <- imports] + mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of + Left err -> Left (mod, err) + Right env -> Right env + availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv availsToGlobalRdrEnv mod_name avails = mkGlobalRdrEnv (gresFromAvails imp_prov avails) @@ -836,17 +860,14 @@ availsToGlobalRdrEnv mod_name avails is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } -mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv +mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv mkTopLevEnv hpt modl - = case lookupUFM hpt (moduleName modl) of - Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ - showSDoc (ppr modl))) + = case lookupUFM hpt modl of + Nothing -> Left "not a home module" Just details -> case mi_globals (hm_iface details) of - Nothing -> - ghcError (ProgramError ("mkTopLevEnv: not interpreted " - ++ showSDoc (ppr modl))) - Just env -> return env + Nothing -> Left "not interpreted" + Just env -> Right env -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set @@ -947,7 +968,8 @@ typeKind normalise str = withSession $ \hsc_env -> do compileExpr :: GhcMonad m => String -> m HValue compileExpr expr = withSession $ \hsc_env -> do - Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) + Just (ids, hval, fix_env) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) + updateFixityEnv fix_env hvals <- liftIO hval case (ids,hvals) of ([_],[hv]) -> return hv @@ -971,9 +993,11 @@ dynCompileExpr expr = do } setContext (IIDecl importDecl : iis) let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" - Just (ids, hvals) <- withSession $ \hsc_env -> + Just (ids, hvals, fix_env) <- withSession $ \hsc_env -> liftIO $ hscStmt hsc_env stmt setContext iis + updateFixityEnv fix_env + vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) case (ids,vals) of (_:[], v:[]) -> return v @@ -986,7 +1010,8 @@ showModule :: GhcMonad m => ModSummary -> m String showModule mod_summary = withSession $ \hsc_env -> do interpreted <- isModuleInterpreted mod_summary - return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary) + let dflags = hsc_dflags hsc_env + return (showModMsg dflags (hscTarget dflags) interpreted mod_summary) isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool isModuleInterpreted mod_summary = withSession $ \hsc_env -> diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index 913e58c6fb..d34d9e1f5c 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -1,47 +1,42 @@ +-- | +-- Package configuration information: essentially the interface to Cabal, with +-- some utilities -- -- (c) The University of Glasgow, 2004 -- +module PackageConfig ( + -- $package_naming --- | Package configuration information: essentially the interface to Cabal, with some utilities - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details + -- * PackageId + mkPackageId, packageConfigId, -module PackageConfig ( - -- $package_naming - - -- * PackageId - mkPackageId, packageConfigId, - - -- * The PackageConfig type: information about a package - PackageConfig, - InstalledPackageInfo_(..), display, - Version(..), - PackageIdentifier(..), - defaultPackageConfig, + -- * The PackageConfig type: information about a package + PackageConfig, + InstalledPackageInfo_(..), display, + Version(..), + PackageIdentifier(..), + defaultPackageConfig, packageConfigToInstalledPackageInfo, - installedPackageInfoToPackageConfig, - ) where + installedPackageInfoToPackageConfig + ) where #include "HsVersions.h" -import Maybes -import Module import Distribution.InstalledPackageInfo import Distribution.ModuleName import Distribution.Package hiding (PackageId) import Distribution.Text import Distribution.Version +import Maybes +import Module + -- ----------------------------------------------------------------------------- --- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we +-- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we -- might need to extend it with some GHC-specific stuff, but for now it's fine. type PackageConfig = InstalledPackageInfo_ Module.ModuleName + defaultPackageConfig :: PackageConfig defaultPackageConfig = emptyInstalledPackageInfo @@ -51,9 +46,9 @@ defaultPackageConfig = emptyInstalledPackageInfo -- $package_naming -- #package_naming# -- Mostly the compiler deals in terms of 'PackageName's, which don't --- have the version suffix. This is so that we don't need to know the +-- have the version suffix. This is so that we don't need to know the -- version for the @-package-name@ flag, or know the versions of --- wired-in packages like @base@ & @rts@. Versions are confined to the +-- wired-in packages like @base@ & @rts@. Versions are confined to the -- package sub-system. -- -- This means that in theory you could have multiple base packages installed @@ -88,3 +83,4 @@ installedPackageInfoToPackageConfig hiddenModules = h })) = pkgconf{ exposedModules = map mkModuleName e, hiddenModules = map mkModuleName h } + diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 1d6ad4a472..5bea131088 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -2,51 +2,44 @@ % (c) The University of Glasgow, 2006 % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Package manipulation module Packages ( - module PackageConfig, - - -- * The PackageConfigMap - PackageConfigMap, emptyPackageConfigMap, lookupPackage, - extendPackageConfigMap, dumpPackages, - - -- * Reading the package config, and processing cmdline args - PackageState(..), - initPackages, - getPackageDetails, - lookupModuleInAllPackages, lookupModuleWithSuggestions, - - -- * Inspecting the set of packages in scope - getPackageIncludePath, - getPackageLibraryPath, - getPackageLinkOpts, - getPackageExtraCcOpts, - getPackageFrameworkPath, - getPackageFrameworks, - getPreloadPackagesAnd, + module PackageConfig, + + -- * The PackageConfigMap + PackageConfigMap, emptyPackageConfigMap, lookupPackage, + extendPackageConfigMap, dumpPackages, + + -- * Reading the package config, and processing cmdline args + PackageState(..), + initPackages, + getPackageDetails, + lookupModuleInAllPackages, lookupModuleWithSuggestions, + + -- * Inspecting the set of packages in scope + getPackageIncludePath, + getPackageLibraryPath, + getPackageLinkOpts, + getPackageExtraCcOpts, + getPackageFrameworkPath, + getPackageFrameworks, + getPreloadPackagesAnd, collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, - -- * Utils - isDllName + -- * Utils + isDllName ) where #include "HsVersions.h" -import PackageConfig +import PackageConfig import DynFlags import StaticFlags -import Config ( cProjectVersion ) -import Name ( Name, nameModule_maybe ) +import Config ( cProjectVersion ) +import Name ( Name, nameModule_maybe ) import UniqFM import Module import Util @@ -66,6 +59,7 @@ import System.Directory import System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix import Control.Monad +import Data.Char (isSpace) import Data.List as List import Data.Map (Map) import qualified Data.Map as Map @@ -81,12 +75,12 @@ import qualified Data.Set as Set -- -- The package state is computed by 'initPackages', and kept in DynFlags. -- --- * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages --- with the same name to become hidden. --- +-- * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages +-- with the same name to become hidden. +-- -- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden. --- --- * Let @exposedPackages@ be the set of packages thus exposed. +-- +-- * Let @exposedPackages@ be the set of packages thus exposed. -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of -- their dependencies. -- @@ -107,28 +101,28 @@ import qualified Data.Set as Set -- Notes on DLLs -- ~~~~~~~~~~~~~ --- When compiling module A, which imports module B, we need to --- know whether B will be in the same DLL as A. --- If it's in the same DLL, we refer to B_f_closure --- If it isn't, we refer to _imp__B_f_closure +-- When compiling module A, which imports module B, we need to +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. data PackageState = PackageState { - pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig - -- The exposed flags are adjusted according to -package and - -- -hide-package flags, and -ignore-package removes packages. + pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig + -- The exposed flags are adjusted according to -package and + -- -hide-package flags, and -ignore-package removes packages. preloadPackages :: [PackageId], - -- The packages we're going to link in eagerly. This list - -- should be in reverse dependency order; that is, a package - -- is always mentioned before the packages it depends on. + -- The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. - moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping - -- Derived from pkgIdMap. - -- Maps Module to (pkgconf,exposed), where pkgconf is the - -- PackageConfig for the package containing the module, and - -- exposed is True if the package exposes that module. + moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping + -- Derived from pkgIdMap. + -- Maps Module to (pkgconf,exposed), where pkgconf is the + -- PackageConfig for the package containing the module, and + -- exposed is True if the package exposes that module. installedPackageIdMap :: InstalledPackageIdMap } @@ -149,7 +143,7 @@ lookupPackage = lookupUFM extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap -extendPackageConfigMap pkg_map new_pkgs +extendPackageConfigMap pkg_map new_pkgs = foldl add pkg_map new_pkgs where add pkg_map p = addToUFM pkg_map (packageConfigId p) p @@ -159,10 +153,10 @@ getPackageDetails :: PackageState -> PackageId -> PackageConfig getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid) -- ---------------------------------------------------------------------------- --- Loading the package config files and building up the package state +-- Loading the package db files and building up the package state -- | Call this after 'DynFlags.parseDynFlags'. It reads the package --- configuration files, and sets up various internal tables of package +-- database files, and sets up various internal tables of package -- information, according to the package-related flags on the -- command-line (@-package@, @-hide-package@ etc.) -- @@ -175,14 +169,14 @@ getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdM -- 'pkgState' in 'DynFlags' and return a list of packages to -- link in. initPackages :: DynFlags -> IO (DynFlags, [PackageId]) -initPackages dflags = do +initPackages dflags = do pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags Just db -> return $ setBatchPackageFlags dflags db - (pkg_state, preload, this_pkg) + (pkg_state, preload, this_pkg) <- mkPackageState dflags pkg_db [] (thisPackage dflags) return (dflags{ pkgDatabase = Just pkg_db, - pkgState = pkg_state, + pkgState = pkg_state, thisPackage = this_pkg }, preload) @@ -191,66 +185,61 @@ initPackages dflags = do readPackageConfigs :: DynFlags -> IO [PackageConfig] readPackageConfigs dflags = do - e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH") - system_pkgconfs <- getSystemPackageConfigs dflags - - let pkgconfs = case e_pkg_path of - Left _ -> system_pkgconfs - Right path - | last cs == "" -> init cs ++ system_pkgconfs - | otherwise -> cs - where cs = parseSearchPath path - -- if the path ends in a separator (eg. "/foo/bar:") - -- the we tack on the system paths. - - pkgs <- mapM (readPackageConfig dflags) - (pkgconfs ++ reverse (extraPkgConfs dflags)) - -- later packages shadow earlier ones. extraPkgConfs - -- is in the opposite order to the flags on the - -- command line. - - return (concat pkgs) - - -getSystemPackageConfigs :: DynFlags -> IO [FilePath] -getSystemPackageConfigs dflags = do - -- System one always comes first - let system_pkgconf = systemPackageConfig dflags - - -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) - -- unless the -no-user-package-conf flag was given. - user_pkgconf <- do - if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do - appdir <- getAppUserDataDirectory "ghc" - let - dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) - pkgconf = dir </> "package.conf.d" - -- - exist <- doesDirectoryExist pkgconf - if exist then return [pkgconf] else return [] - `catchIO` (\_ -> return []) - - return (system_pkgconf : user_pkgconf) + let system_conf_refs = [UserPkgConf, GlobalPkgConf] + + e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | null (last cs) + -> map PkgConfFile (init cs) ++ system_conf_refs + | otherwise + -> map PkgConfFile cs + where cs = parseSearchPath path + -- if the path ends in a separator (eg. "/foo/bar:") + -- then we tack on the system paths. + + let conf_refs = reverse (extraPkgConfs dflags base_conf_refs) + -- later packages shadow earlier ones. extraPkgConfs + -- is in the opposite order to the flags on the + -- command line. + confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs + + liftM concat $ mapM (readPackageConfig dflags) confs + +resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath) +resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags) +resolvePackageConfig _ UserPkgConf = handleIO (\_ -> return Nothing) $ do + appdir <- getAppUserDataDirectory "ghc" + let dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) + pkgconf = dir </> "package.conf.d" + exist <- doesDirectoryExist pkgconf + return $ if exist then Just pkgconf else Nothing +resolvePackageConfig _ (PkgConfFile name) = return $ Just name readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig] readPackageConfig dflags conf_file = do isdir <- doesDirectoryExist conf_file - proto_pkg_configs <- + proto_pkg_configs <- if isdir then do let filename = conf_file </> "package.cache" debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename) conf <- readBinPackageDB filename return (map installedPackageInfoToPackageConfig conf) - else do + else do isfile <- doesFileExist conf_file when (not isfile) $ - ghcError $ InstallationError $ + ghcError $ InstallationError $ "can't find a package database at " ++ conf_file debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file) str <- readFile conf_file - return (map installedPackageInfoToPackageConfig $ read str) + case reads str of + [(configs, rest)] + | all isSpace rest -> return (map installedPackageInfoToPackageConfig configs) + _ -> ghcError $ InstallationError $ + "invalid package database file " ++ conf_file let top_dir = topDir dflags @@ -293,7 +282,7 @@ mungePackagePaths top_dir pkgroot pkg = haddockInterfaces = munge_paths (haddockInterfaces pkg), haddockHTMLs = munge_urls (haddockHTMLs pkg) } - where + where munge_paths = map munge_path munge_urls = map munge_url @@ -329,56 +318,57 @@ mungePackagePaths top_dir pkgroot pkg = -- (-package, -hide-package, -ignore-package). applyPackageFlag - :: UnusablePackages + :: DynFlags + -> UnusablePackages -> [PackageConfig] -- Initial database -> PackageFlag -- flag to apply -> IO [PackageConfig] -- new database -applyPackageFlag unusable pkgs flag = +applyPackageFlag dflags unusable pkgs flag = case flag of ExposePackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) + where p' = p {exposed=True} + ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) _ -> panic "applyPackageFlag" ExposePackageId str -> case selectPackages (matchingId str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) + where p' = p {exposed=True} + ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) _ -> panic "applyPackageFlag" HidePackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (ps,qs) -> return (map hide ps ++ qs) - where hide p = p {exposed=False} + where hide p = p {exposed=False} -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (ps,qs) -> return (map trust ps ++ qs) - where trust p = p {trusted=True} + where trust p = p {trusted=True} DistrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (ps,qs) -> return (map distrust ps ++ qs) - where distrust p = p {trusted=False} + where distrust p = p {trusted=False} _ -> panic "applyPackageFlag" where - -- When a package is requested to be exposed, we hide all other - -- packages with the same name. - hideAll name ps = map maybe_hide ps - where maybe_hide p + -- When a package is requested to be exposed, we hide all other + -- packages with the same name. + hideAll name ps = map maybe_hide ps + where maybe_hide p | pkgName (sourcePackageId p) == name = p {exposed=False} | otherwise = p @@ -401,8 +391,8 @@ selectPackages matches pkgs unusable -- version, or just the name if it is unambiguous. matchingStr :: String -> PackageConfig -> Bool matchingStr str p - = str == display (sourcePackageId p) - || str == display (pkgName (sourcePackageId p)) + = str == display (sourcePackageId p) + || str == display (pkgName (sourcePackageId p)) matchingId :: String -> PackageConfig -> Bool matchingId str p = InstalledPackageId str == installedPackageId p @@ -413,20 +403,21 @@ sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId))) comparing :: Ord a => (t -> a) -> t -> t -> Ordering comparing f a b = f a `compare` f b -packageFlagErr :: PackageFlag +packageFlagErr :: DynFlags + -> PackageFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a -- for missing DPH package we emit a more helpful error message, because -- this may be the result of using -fdph-par or -fdph-seq. -packageFlagErr (ExposePackage pkg) [] | is_dph_package pkg - = ghcError (CmdLineError (showSDoc $ dph_err)) +packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg + = ghcError (CmdLineError (showSDoc dflags $ dph_err)) where dph_err = text "the " <> text pkg <> text " package is not installed." $$ text "To install it: \"cabal install dph\"." is_dph_package pkg = "dph" `isPrefixOf` pkg - -packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) - where err = text "cannot satisfy " <> ppr_flag <> + +packageFlagErr dflags flag reasons = ghcError (CmdLineError (showSDoc dflags $ err)) + where err = text "cannot satisfy " <> ppr_flag <> (if null reasons then empty else text ": ") $$ nest 4 (ppr_reasons $$ text "(use -v for more information)") @@ -452,20 +443,20 @@ packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig] hideOldPackages dflags pkgs = mapM maybe_hide pkgs where maybe_hide p - | not (exposed p) = return p - | (p' : _) <- later_versions = do - debugTraceMsg dflags 2 $ - (ptext (sLit "hiding package") <+> pprSPkg p <+> - ptext (sLit "to avoid conflict with later version") <+> - pprSPkg p') - return (p {exposed=False}) - | otherwise = return p - where myname = pkgName (sourcePackageId p) - myversion = pkgVersion (sourcePackageId p) - later_versions = [ p | p <- pkgs, exposed p, - let pkg = sourcePackageId p, - pkgName pkg == myname, - pkgVersion pkg > myversion ] + | not (exposed p) = return p + | (p' : _) <- later_versions = do + debugTraceMsg dflags 2 $ + (ptext (sLit "hiding package") <+> pprSPkg p <+> + ptext (sLit "to avoid conflict with later version") <+> + pprSPkg p') + return (p {exposed=False}) + | otherwise = return p + where myname = pkgName (sourcePackageId p) + myversion = pkgVersion (sourcePackageId p) + later_versions = [ p | p <- pkgs, exposed p, + let pkg = sourcePackageId p, + pkgName pkg == myname, + pkgVersion pkg > myversion ] -- ----------------------------------------------------------------------------- -- Wired-in packages @@ -494,43 +485,43 @@ findWiredInPackages dflags pkgs = do matches :: PackageConfig -> String -> Bool pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid - -- find which package corresponds to each wired-in package - -- delete any other packages with the same name - -- update the package and any dependencies to point to the new - -- one. + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. -- -- When choosing which package to map to a wired-in package -- name, we prefer exposed packages, and pick the latest -- version. To override the default choice, -hide-package -- could be used to hide newer versions. -- - findWiredInPackage :: [PackageConfig] -> String - -> IO (Maybe InstalledPackageId) - findWiredInPackage pkgs wired_pkg = + findWiredInPackage :: [PackageConfig] -> String + -> IO (Maybe InstalledPackageId) + findWiredInPackage pkgs wired_pkg = let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in - case all_ps of - [] -> notfound - many -> pick (head (sortByVersion many)) + case all_ps of + [] -> notfound + many -> pick (head (sortByVersion many)) where notfound = do - debugTraceMsg dflags 2 $ - ptext (sLit "wired-in package ") - <> text wired_pkg - <> ptext (sLit " not found.") - return Nothing - pick :: InstalledPackageInfo_ ModuleName + debugTraceMsg dflags 2 $ + ptext (sLit "wired-in package ") + <> text wired_pkg + <> ptext (sLit " not found.") + return Nothing + pick :: InstalledPackageInfo_ ModuleName -> IO (Maybe InstalledPackageId) pick pkg = do debugTraceMsg dflags 2 $ - ptext (sLit "wired-in package ") - <> text wired_pkg - <> ptext (sLit " mapped to ") - <> pprIPkg pkg - return (Just (installedPackageId pkg)) + ptext (sLit "wired-in package ") + <> text wired_pkg + <> ptext (sLit " mapped to ") + <> pprIPkg pkg + return (Just (installedPackageId pkg)) mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids - let + let wired_in_ids = catMaybes mb_wired_in_ids -- this is old: we used to assume that if there were @@ -541,13 +532,13 @@ findWiredInPackages dflags pkgs = do -- wrappers that depend on this one. e.g. base-4.0 is the -- latest, base-3.0 is a compat wrapper depending on base-4.0. {- - deleteOtherWiredInPackages pkgs = filterOut bad pkgs - where bad p = any (p `matches`) wired_in_pkgids + deleteOtherWiredInPackages pkgs = filterOut bad pkgs + where bad p = any (p `matches`) wired_in_pkgids && package p `notElem` map fst wired_in_ids -} - updateWiredInDependencies pkgs = map upd_pkg pkgs - where upd_pkg p + updateWiredInDependencies pkgs = map upd_pkg pkgs + where upd_pkg p | installedPackageId p `elem` wired_in_ids = p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } } | otherwise @@ -650,9 +641,9 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags) case partition (matchingStr str) pkgs of (ps, _) -> [ (installedPackageId p, IgnoredWithFlag) | p <- ps ] - -- missing package is not an error for -ignore-package, - -- because a common usage is to -ignore-package P as - -- a preventative measure just in case P exists. + -- missing package is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. doit _ = panic "ignorePackages" -- ----------------------------------------------------------------------------- @@ -665,7 +656,7 @@ depClosure index ipids = closure Map.empty ipids closure set [] = Map.keys set closure set (ipid : ipids) | ipid `Map.member` set = closure set ipids - | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) + | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) (depends p ++ ipids) | otherwise = closure set ipids @@ -688,7 +679,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do {- Plan. - 1. P = transitive closure of packages selected by -package-id + 1. P = transitive closure of packages selected by -package-id 2. Apply shadowing. When there are multiple packages with the same sourcePackageId, @@ -746,7 +737,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do ipid_selected = depClosure ipid_map [ InstalledPackageId i | ExposePackageId i <- flags ] - + (ignore_flags, other_flags) = partition is_ignore flags is_ignore IgnorePackage{} = True is_ignore _ = False @@ -765,7 +756,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- Modify the package database according to the command-line flags -- (-package, -hide-package, -ignore-package, -hide-all-packages). -- - pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags + pkgs1 <- foldM (applyPackageFlag dflags unusable) pkgs0_unique other_flags let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1 -- Here we build up a set of the packages mentioned in -package @@ -776,7 +767,9 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ] - get_exposed (ExposePackage s) = filter (matchingStr s) pkgs2 + get_exposed (ExposePackage s) + = take 1 $ sortByVersion (filter (matchingStr s) pkgs2) + -- -package P means "the latest version of P" (#7030) get_exposed (ExposePackageId s) = filter (matchingId s) pkgs2 get_exposed _ = [] @@ -793,7 +786,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do lookupIPID ipid@(InstalledPackageId str) | Just pid <- Map.lookup ipid ipid_map = return pid - | otherwise = missingPackageErr str + | otherwise = missingPackageErr dflags str preload2 <- mapM lookupIPID preload1 @@ -808,9 +801,9 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- set up preloaded package when we are just building it preload3 = nub $ filter (/= this_package) $ (basicLinkedPackages ++ preload2) - + -- Close the preload packages with their dependencies - dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing)) + dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload let pstate = PackageState{ preloadPackages = dep_preload, @@ -820,7 +813,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do } return (pstate, new_dep_preload, this_package) - + -- ----------------------------------------------------------------------------- -- Make the mapping from module to package info @@ -831,15 +824,15 @@ mkModuleMap mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids where pkgids = map packageConfigId (eltsUFM pkg_db) - - extend_modmap pkgid modmap = - addListToUFM_C (++) modmap - ([(m, [(pkg, True)]) | m <- exposed_mods] ++ - [(m, [(pkg, False)]) | m <- hidden_mods]) - where - pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) - exposed_mods = exposedModules pkg - hidden_mods = hiddenModules pkg + + extend_modmap pkgid modmap = + addListToUFM_C (++) modmap + ([(m, [(pkg, True)]) | m <- exposed_mods] ++ + [(m, [(pkg, False)]) | m <- hidden_mods]) + where + pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg pprSPkg :: PackageConfig -> SDoc pprSPkg p = text (display (sourcePackageId p)) @@ -863,7 +856,7 @@ getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String] getPackageIncludePath dflags pkgs = collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs -collectIncludeDirs :: [PackageConfig] -> [FilePath] +collectIncludeDirs :: [PackageConfig] -> [FilePath] collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps)) -- | Find all the library paths in these and the preload packages @@ -876,14 +869,14 @@ collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps)) -- | Find all the link options in these and the preload packages getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String] -getPackageLinkOpts dflags pkgs = +getPackageLinkOpts dflags pkgs = collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs collectLinkOpts :: DynFlags -> [PackageConfig] -> [String] collectLinkOpts dflags ps = concat (map all_opts ps) where - libs p = packageHsLibs dflags p ++ extraLibraries p - all_opts p = map ("-l" ++) (libs p) ++ ldOptions p + libs p = packageHsLibs dflags p ++ extraLibraries p + all_opts p = map ("-l" ++) (libs p) ++ ldOptions p packageHsLibs :: DynFlags -> PackageConfig -> [String] packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) @@ -895,7 +888,7 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) -- we leave out the _dyn, because it is superfluous -- debug RTS includes support for -eventlog - ways2 | WayDebug `elem` map wayName ways1 + ways2 | WayDebug `elem` map wayName ways1 = filter ((/= WayEventLog) . wayName) ways1 | otherwise = ways1 @@ -903,14 +896,14 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) tag = mkBuildTag (filter (not . wayRTSOnly) ways2) rts_tag = mkBuildTag ways2 - mkDynName | opt_Static = id - | otherwise = (++ ("-ghc" ++ cProjectVersion)) + mkDynName | opt_Static = id + | otherwise = (++ ("-ghc" ++ cProjectVersion)) addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) addSuffix other_lib = other_lib ++ (expandTag tag) expandTag t | null t = "" - | otherwise = '_':t + | otherwise = '_':t -- | Find all the C-compiler options in these and the preload packages getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String] @@ -933,7 +926,7 @@ getPackageFrameworks dflags pkgs = do -- ----------------------------------------------------------------------------- -- Package Utils --- | Takes a 'Module', and if the module is in a package returns +-- | Takes a 'Module', and if the module is in a package returns -- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package, -- and exposed is @True@ if the package exposes the module. lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)] @@ -968,28 +961,31 @@ lookupModuleWithSuggestions dflags m -- 'PackageConfig's getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig] getPreloadPackagesAnd dflags pkgids = - let + let state = pkgState dflags pkg_map = pkgIdMap state ipid_map = installedPackageIdMap state preload = preloadPackages state pairs = zip pkgids (repeat Nothing) in do - all_pkgs <- throwErr (foldM (add_package pkg_map ipid_map) preload pairs) + all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs) return (map (getPackageDetails state) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). -closeDeps :: PackageConfigMap +closeDeps :: DynFlags + -> PackageConfigMap -> Map InstalledPackageId PackageId -> [(PackageId, Maybe PackageId)] -> IO [PackageId] -closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps) +closeDeps dflags pkg_map ipid_map ps + = throwErr dflags (closeDepsErr pkg_map ipid_map ps) -throwErr :: MaybeErr MsgDoc a -> IO a -throwErr m = case m of - Failed e -> ghcError (CmdLineError (showSDoc e)) - Succeeded r -> return r +throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a +throwErr dflags m + = case m of + Failed e -> ghcError (CmdLineError (showSDoc dflags e)) + Succeeded r -> return r closeDepsErr :: PackageConfigMap -> Map InstalledPackageId PackageId @@ -998,21 +994,21 @@ closeDepsErr :: PackageConfigMap closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper -add_package :: PackageConfigMap +add_package :: PackageConfigMap -> Map InstalledPackageId PackageId -> [PackageId] -> (PackageId,Maybe PackageId) -> MaybeErr MsgDoc [PackageId] add_package pkg_db ipid_map ps (p, mb_parent) - | p `elem` ps = return ps -- Check if we've already added this package + | p `elem` ps = return ps -- Check if we've already added this package | otherwise = case lookupPackage pkg_db p of - Nothing -> Failed (missingPackageMsg (packageIdString p) <> + Nothing -> Failed (missingPackageMsg (packageIdString p) <> missingDependencyMsg mb_parent) Just pkg -> do - -- Add the package's dependents also - ps' <- foldM add_package_ipid ps (depends pkg) - return (p : ps') + -- Add the package's dependents also + ps' <- foldM add_package_ipid ps (depends pkg) + return (p : ps') where add_package_ipid ps ipid@(InstalledPackageId str) | Just pid <- Map.lookup ipid ipid_map @@ -1020,8 +1016,9 @@ add_package pkg_db ipid_map ps (p, mb_parent) | otherwise = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent) -missingPackageErr :: String -> IO a -missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p))) +missingPackageErr :: DynFlags -> String -> IO a +missingPackageErr dflags p + = ghcError (CmdLineError (showSDoc dflags (missingPackageMsg p))) missingPackageMsg :: String -> SDoc missingPackageMsg p = ptext (sLit "unknown package:") <+> text p @@ -1049,9 +1046,9 @@ isDllName this_pkg name -- | Show package info on console, if verbosity is >= 3 dumpPackages :: DynFlags -> IO () dumpPackages dflags - = do let pkg_map = pkgIdMap (pkgState dflags) - putMsg dflags $ - vcat (map (text . showInstalledPackageInfo - . packageConfigToInstalledPackageInfo) - (eltsUFM pkg_map)) + = do let pkg_map = pkgIdMap (pkgState dflags) + putMsg dflags $ + vcat (map (text . showInstalledPackageInfo + . packageConfigToInstalledPackageInfo) + (eltsUFM pkg_map)) \end{code} diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 07eb214f74..b927f12d2c 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -9,7 +9,11 @@ -- ----------------------------------------------------------------------------- -module StaticFlagParser (parseStaticFlags) where +module StaticFlagParser ( + parseStaticFlags, + parseStaticFlagsFull, + flagsStatic + ) where #include "HsVersions.h" @@ -46,11 +50,18 @@ import Data.List -- XXX: can we add an auto-generated list of static flags here? -- parseStaticFlags :: [Located String] -> IO ([Located String], [Located String]) -parseStaticFlags args = do +parseStaticFlags = parseStaticFlagsFull flagsStatic + +-- | Parse GHC's static flags as @parseStaticFlags@ does. However it also +-- takes a list of available static flags, such that certain flags can be +-- enabled or disabled through this argument. +parseStaticFlagsFull :: [Flag IO] -> [Located String] + -> IO ([Located String], [Located String]) +parseStaticFlagsFull flagsAvailable args = do ready <- readIORef v_opt_C_ready when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession") - (leftover, errs, warns1) <- processArgs static_flags args + (leftover, errs, warns1) <- processArgs flagsAvailable args when (not (null errs)) $ ghcError $ errorsToGhcException errs -- deal with the way flags: the way (eg. prof) gives rise to @@ -62,8 +73,10 @@ parseStaticFlags args = do let unreg_flags | cGhcUnregisterised == "YES" = unregFlags | otherwise = [] + -- as these are GHC generated flags, we parse them with all static flags + -- in scope, regardless of what availableFlags are passed in. (more_leftover, errs, warns2) <- - processArgs static_flags (unreg_flags ++ way_flags') + processArgs flagsStatic (unreg_flags ++ way_flags') -- see sanity code in staticOpts writeIORef v_opt_C_ready True @@ -88,7 +101,7 @@ parseStaticFlags args = do return (excess_prec ++ cg_flags ++ more_leftover ++ leftover, warns1 ++ warns2) -static_flags :: [Flag IO] +flagsStatic :: [Flag IO] -- All the static flags should appear in this list. It describes how each -- static flag should be processed. Two main purposes: -- (a) if a command-line flag doesn't appear in the list, GHC can complain @@ -102,13 +115,9 @@ static_flags :: [Flag IO] -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override -- flags further down the list with the same prefix. -static_flags = [ - ------- GHCi ------------------------------------------------------- - Flag "ignore-dot-ghci" (PassFlag addOpt) - , Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) - +flagsStatic = [ ------- ways -------------------------------------------------------- - , Flag "prof" (NoArg (addWay WayProf)) + Flag "prof" (NoArg (addWay WayProf)) , Flag "eventlog" (NoArg (addWay WayEventLog)) , Flag "parallel" (NoArg (addWay WayPar)) , Flag "gransim" (NoArg (addWay WayGran)) @@ -123,9 +132,6 @@ static_flags = [ ------ Debugging ---------------------------------------------------- , Flag "dppr-debug" (PassFlag addOpt) - , Flag "dppr-cols" (AnySuffix addOpt) - , Flag "dppr-user-length" (AnySuffix addOpt) - , Flag "dppr-case-as-let" (PassFlag addOpt) , Flag "dsuppress-all" (PassFlag addOpt) , Flag "dsuppress-uniques" (PassFlag addOpt) , Flag "dsuppress-coercions" (PassFlag addOpt) @@ -135,7 +141,6 @@ static_flags = [ , Flag "dsuppress-var-kinds" (PassFlag addOpt) , Flag "dsuppress-type-signatures" (PassFlag addOpt) , Flag "dopt-fuel" (AnySuffix addOpt) - , Flag "dtrace-level" (AnySuffix addOpt) , Flag "dno-debug-output" (PassFlag addOpt) , Flag "dstub-dead-values" (PassFlag addOpt) -- rest of the debugging flags are dynamic @@ -178,9 +183,6 @@ isStaticFlag f = "fscc-profiling", "fdicts-strict", "fspec-inline-join-points", - "firrefutable-tuples", - "fparallel", - "fgransim", "fno-hi-version-check", "dno-black-holing", "fno-state-hack", diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index c2f8674aa9..4695d83ed0 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -27,10 +27,7 @@ module StaticFlags ( WayName(..), Way(..), v_Ways, isRTSWay, mkBuildTag, -- Output style options - opt_PprUserLength, - opt_PprCols, - opt_PprCaseAsLet, - opt_PprStyle_Debug, opt_TraceLevel, + opt_PprStyle_Debug, opt_NoDebugOutput, -- Suppressing boring aspects of core dumps @@ -51,8 +48,6 @@ module StaticFlags ( -- language opts opt_DictsStrict, - opt_IrrefutableTuples, - opt_Parallel, -- optimisation opts opt_NoStateHack, @@ -79,11 +74,7 @@ module StaticFlags ( opt_Static, -- misc opts - opt_IgnoreDotGhci, - opt_GhciScripts, opt_ErrorSpans, - opt_GranMacros, - opt_HiVersion, opt_HistorySize, opt_Unregisterised, v_Ld_inputs, @@ -103,10 +94,11 @@ module StaticFlags ( import Config import FastString import Util -import Maybes ( firstJusts, catMaybes ) +import Maybes ( firstJusts ) import Panic import Control.Monad ( liftM3 ) +import Data.Function import Data.Maybe ( listToMaybe ) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) @@ -133,7 +125,6 @@ lookUp :: FastString -> Bool lookup_def_int :: String -> Int -> Int lookup_def_float :: String -> Float -> Float lookup_str :: String -> Maybe String -lookup_all_str :: String -> [String] -- holds the static opts while they're being collected, before -- being unsafely read by unpacked_static_opts below. @@ -164,10 +155,6 @@ lookup_str sw Just str -> Just str Nothing -> Nothing -lookup_all_str sw = map f $ catMaybes (map (stripPrefix sw) staticFlags) where - f ('=' : str) = str - f str = str - lookup_def_int sw def = case (lookup_str sw) of Nothing -> def -- Use default Just xx -> try_read sw xx @@ -204,12 +191,6 @@ unpacked_opts = expandAts l = [l] -} -opt_IgnoreDotGhci :: Bool -opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci") - -opt_GhciScripts :: [String] -opt_GhciScripts = lookup_all_str "-ghci-script" - -- debugging options -- | Suppress all that is suppressable in core dumps. -- Except for uniques, as some simplifier phases introduce new varibles that @@ -260,34 +241,10 @@ opt_SuppressUniques :: Bool opt_SuppressUniques = lookUp (fsLit "-dsuppress-uniques") --- | Display case expressions with a single alternative as strict let bindings -opt_PprCaseAsLet :: Bool -opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let") - --- | Set the maximum width of the dumps --- If GHC's command line options are bad then the options parser uses the --- pretty printer display the error message. In this case the staticFlags --- won't be initialized yet, so we must check for this case explicitly --- and return the default value. -opt_PprCols :: Int -opt_PprCols - = unsafePerformIO - $ do ready <- readIORef v_opt_C_ready - if (not ready) - then return 100 - else return $ lookup_def_int "-dppr-cols" 100 - opt_PprStyle_Debug :: Bool opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") -opt_TraceLevel :: Int -opt_TraceLevel = lookup_def_int "-dtrace-level" 1 -- Standard level is 1 - -- Less verbose is 0 - -opt_PprUserLength :: Int -opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name - opt_Fuel :: Int opt_Fuel = lookup_def_int "-dopt-fuel" maxBound @@ -306,12 +263,6 @@ opt_Hpc = lookUp (fsLit "-fhpc") opt_DictsStrict :: Bool opt_DictsStrict = lookUp (fsLit "-fdicts-strict") -opt_IrrefutableTuples :: Bool -opt_IrrefutableTuples = lookUp (fsLit "-firrefutable-tuples") - -opt_Parallel :: Bool -opt_Parallel = lookUp (fsLit "-fparallel") - opt_SimpleListLiterals :: Bool opt_SimpleListLiterals = lookUp (fsLit "-fsimple-list-literals") @@ -324,12 +275,6 @@ opt_CprOff = lookUp (fsLit "-fcpr-off") opt_MaxWorkerArgs :: Int opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) -opt_GranMacros :: Bool -opt_GranMacros = lookUp (fsLit "-fgransim") - -opt_HiVersion :: Integer -opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer - opt_HistorySize :: Int opt_HistorySize = lookup_def_int "-fhistory-size" 20 @@ -354,7 +299,12 @@ opt_UF_CreationThreshold, opt_UF_UseThreshold :: Int opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int opt_UF_KeenessFactor :: Float -opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (450::Int) +opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (750::Int) + -- This threshold must be reasonably high to take + -- account of possible discounts. + -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline into Csg.calc + -- (The unfolding for sqr never makes it into the interface file.) + opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (60::Int) opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (60::Int) diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index b46ca17f49..49314f2823 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -79,6 +79,16 @@ import System.Process import Control.Concurrent import FastString import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) + +#ifdef mingw32_HOST_OS +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif +#endif \end{code} How GHC finds its files @@ -489,8 +499,8 @@ runClang dflags args = do runSomething dflags "Clang (Assembler)" clang args ) (\(err :: SomeException) -> do - putMsg dflags $ text $ "Error running clang! you need clang installed" - ++ " to use the LLVM backend" + errorMsg dflags $ text $ "Error running clang! you need clang installed" + ++ " to use the LLVM backend" throw err ) @@ -528,7 +538,7 @@ figureLlvmVersion dflags = do debugTraceMsg dflags 2 (text "Error (figuring out LLVM version):" <+> text (show err)) - putMsg dflags $ vcat + errorMsg dflags $ vcat [ text "Warning:", nest 9 $ text "Couldn't figure out LLVM version!" $$ text "Make sure you have installed LLVM"] @@ -841,10 +851,10 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do msg <- readChan chan case msg of BuildMsg msg -> do - log_action dflags SevInfo noSrcSpan defaultUserStyle msg + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg loop chan hProcess t p exitcode BuildError loc msg -> do - log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg + log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg loop chan hProcess t p exitcode EOF -> loop chan hProcess (t-1) p exitcode @@ -922,7 +932,8 @@ traceCmd dflags phase_name cmd_line action = do { let verb = verbosity dflags ; showPass dflags phase_name ; debugTraceMsg dflags 3 (text cmd_line) - ; hFlush stderr + ; case flushErr dflags of + FlushErr io -> io -- And run it! ; action `catchIO` handle_exn verb @@ -970,7 +981,7 @@ getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. where fail = panic ("can't decompose ghc.exe path: " ++ show s) lower = map toLower -foreign import stdcall unsafe "windows.h GetModuleFileNameW" +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getBaseDir = return Nothing diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 34afd5ca0e..8e4e7dd0a0 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -4,13 +4,6 @@ \section{Tidying up Core} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TidyPgm ( mkBootModDetailsTc, tidyProgram, globaliseAndTidyId ) where @@ -24,10 +17,11 @@ import CoreUnfold import CoreFVs import CoreTidy import CoreMonad +import CorePrep import CoreUtils import Literal import Rules -import CoreArity ( exprArity, exprBotStrictness_maybe ) +import CoreArity ( exprArity, exprBotStrictness_maybe ) import VarEnv import VarSet import Var @@ -41,7 +35,10 @@ import Name hiding (varName) import NameSet import NameEnv import Avail +import PrelNames import IfaceEnv +import TcEnv +import TcRnMonad import TcType import DataCon import TyCon @@ -51,14 +48,17 @@ import Packages( isDllName ) import HscTypes import Maybes import UniqSupply +import ErrUtils (Severity(..)) import Outputable import FastBool hiding ( fastOr ) +import SrcLoc import Util import FastString -import Control.Monad ( when ) -import Data.List ( sortBy ) -import Data.IORef ( IORef, readIORef, writeIORef ) +import Control.Monad +import Data.Function +import Data.List ( sortBy ) +import Data.IORef ( readIORef, writeIORef ) \end{code} @@ -73,7 +73,7 @@ important for *this* module, but it's essential for ghc --make: subsequent compilations must not see (e.g.) the arity if the interface file does not contain arity If they do, they'll exploit the arity; then the arity might change, but the iface file doesn't change => -recompilation does not happen => disaster. +recompilation does not happen => disaster. For data types, the final TypeEnv will have a TyThing for the TyCon, plus one for each DataCon; the interface file will contain just one @@ -81,9 +81,9 @@ data type declaration, but it is de-serialised back into a collection of TyThings. %************************************************************************ -%* * - Plan A: simpleTidyPgm -%* * +%* * + Plan A: simpleTidyPgm +%* * %************************************************************************ @@ -91,19 +91,19 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Ignore the bindings -* Drop all WiredIn things from the TypeEnv - (we never want them in interface files) +* Drop all WiredIn things from the TypeEnv + (we never want them in interface files) * Retain all TyCons and Classes in the TypeEnv, to avoid - having to find which ones are mentioned in the - types of exported Ids + having to find which ones are mentioned in the + types of exported Ids * Trim off the constructors of non-exported TyCons, both - from the TyCon and from the TypeEnv + from the TyCon and from the TypeEnv * Drop non-exported Ids from the TypeEnv -* Tidy the types of the DFunIds of Instances, +* Tidy the types of the DFunIds of Instances, make them into GlobalIds, (they already have External Names) and add them to the TypeEnv @@ -113,7 +113,7 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small * Drop rules altogether * Tidy the bindings, to ensure that the Caf and Arity - information is correct for each top-level binder; the + information is correct for each top-level binder; the code generator needs it. And to ensure that local names have distinct OccNames in case of object-file splitting @@ -125,7 +125,7 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small -- for hs-boot files mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails -mkBootModDetailsTc hsc_env +mkBootModDetailsTc hsc_env TcGblEnv{ tcg_exports = exports, tcg_type_env = type_env, -- just for the Ids tcg_tcs = tcs, @@ -133,23 +133,23 @@ mkBootModDetailsTc hsc_env tcg_fam_insts = fam_insts } = do { let dflags = hsc_dflags hsc_env - ; showPass dflags CoreTidy + ; showPass dflags CoreTidy - ; let { insts' = tidyInstances globaliseAndTidyId insts - ; dfun_ids = map instanceDFunId insts' + ; let { insts' = tidyInstances globaliseAndTidyId insts + ; dfun_ids = map instanceDFunId insts' ; type_env1 = mkBootTypeEnv (availsToNameSet exports) (typeEnvIds type_env) tcs fam_insts - ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids - } - ; return (ModDetails { md_types = type_env' - , md_insts = insts' - , md_fam_insts = fam_insts - , md_rules = [] - , md_anns = [] - , md_exports = exports + ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids + } + ; return (ModDetails { md_types = type_env' + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_anns = [] + , md_exports = exports , md_vect_info = noVectInfo }) - } + } where mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv @@ -158,12 +158,12 @@ mkBootTypeEnv exports ids tcs fam_insts typeEnvFromEntities final_ids tcs fam_insts where -- Find the LocalIds in the type env that are exported - -- Make them into GlobalIds, and tidy their types - -- - -- It's very important to remove the non-exported ones - -- because we don't tidy the OccNames, and if we don't remove - -- the non-exported ones we'll get many things with the - -- same name in the interface file, giving chaos. + -- Make them into GlobalIds, and tidy their types + -- + -- It's very important to remove the non-exported ones + -- because we don't tidy the OccNames, and if we don't remove + -- the non-exported ones we'll get many things with the + -- same name in the interface file, giving chaos. -- -- Do make sure that we keep Ids that are already Global. -- When typechecking an .hs-boot file, the Ids come through as @@ -181,12 +181,12 @@ mkBootTypeEnv exports ids tcs fam_insts globaliseAndTidyId :: Id -> Id --- Takes an LocalId with an External Name, --- makes it into a GlobalId +-- Takes an LocalId with an External Name, +-- makes it into a GlobalId -- * unchanged Name (might be Internal or External) -- * unchanged details -- * VanillaIdInfo (makes a conservative assumption about Caf-hood) -globaliseAndTidyId id +globaliseAndTidyId id = Id.setIdType (globaliseId id) tidy_type where tidy_type = tidyTopType (idType id) @@ -194,18 +194,18 @@ globaliseAndTidyId id %************************************************************************ -%* * - Plan B: tidy bindings, make TypeEnv full of IdInfo -%* * +%* * + Plan B: tidy bindings, make TypeEnv full of IdInfo +%* * %************************************************************************ -Plan B: include pragmas, make interfaces +Plan B: include pragmas, make interfaces ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Figure out which Ids are externally visible * Tidy the bindings, externalising appropriate Ids -* Drop all Ids from the TypeEnv, and add all the External Ids from +* Drop all Ids from the TypeEnv, and add all the External Ids from the bindings. (This adds their IdInfo to the TypeEnv; and adds floated-out Ids that weren't even in the TypeEnv before.) @@ -221,7 +221,7 @@ First we figure out which Ids are "external" Ids. An "external" Id is one that is visible from outside the compilation unit. These are a) the user exported ones - b) ones mentioned in the unfoldings, workers, + b) ones mentioned in the unfoldings, workers, rules of externally-visible ones , or vectorised versions of externally-visible ones @@ -256,8 +256,8 @@ Step 2: Tidy the program Next we traverse the bindings top to bottom. For each *top-level* binder - 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, - reflecting the fact that from now on we regard it as a global, + 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, + reflecting the fact that from now on we regard it as a global, not local, Id 2. Give it a system-wide Unique. @@ -268,7 +268,7 @@ binder source of such system-wide uniques. For external Ids, use the original-name cache in the NameCache - to ensure that the unique assigned is the same as the Id had + to ensure that the unique assigned is the same as the Id had in any previous compilation run. 3. Rename top-level Ids according to the names we chose in step 1. @@ -276,14 +276,14 @@ binder make it have an Internal Name. This is used by the code generator to decide whether to make the label externally visible - 4. Give it its UTTERLY FINAL IdInfo; in ptic, - * its unfolding, if it should have one - - * its arity, computed from the number of visible lambdas + 4. Give it its UTTERLY FINAL IdInfo; in ptic, + * its unfolding, if it should have one + + * its arity, computed from the number of visible lambdas + + * its CAF info, computed from what is free in its RHS - * its CAF info, computed from what is free in its RHS - Finally, substitute these new top-level binders consistently throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. @@ -299,16 +299,19 @@ tidyProgram hsc_env (ModGuts { mg_module = mod , mg_rules = imp_rules , mg_vect_info = vect_info , mg_anns = anns - , mg_deps = deps + , mg_deps = deps , mg_foreign = foreign_stubs , mg_hpc_info = hpc_info - , mg_modBreaks = modBreaks + , mg_modBreaks = modBreaks }) = do { let { dflags = hsc_dflags hsc_env ; omit_prags = dopt Opt_OmitInterfacePragmas dflags ; expose_all = dopt Opt_ExposeAllUnfoldings dflags ; th = xopt Opt_TemplateHaskell dflags + ; data_kinds = xopt Opt_DataKinds dflags + ; no_trim_types = th || data_kinds + -- See Note [When we can't trim types] } ; showPass dflags CoreTidy @@ -320,29 +323,29 @@ tidyProgram hsc_env (ModGuts { mg_module = mod } ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env mod omit_prags expose_all + <- chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_rules (vectInfoVar vect_info) ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env } -- Glom together imp_rules and rules currently attached to binders -- Then pick just the ones we need to expose -- See Note [Which rules to expose] - ; let { (tidy_env, tidy_binds) - = tidyTopBinds hsc_env unfold_env tidy_occ_env binds } + ; (tidy_env, tidy_binds) + <- tidyTopBinds hsc_env unfold_env tidy_occ_env binds - ; let { export_set = availsToNameSet exports - ; final_ids = [ id | id <- bindersOfBinds tidy_binds, - isExternalName (idName id)] + ; let { export_set = availsToNameSet exports + ; final_ids = [ id | id <- bindersOfBinds tidy_binds, + isExternalName (idName id)] - ; tidy_type_env = tidyTypeEnv omit_prags th export_set + ; tidy_type_env = tidyTypeEnv omit_prags no_trim_types export_set (extendTypeEnvWithIds type_env final_ids) ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts - -- A DFunId will have a binding in tidy_binds, and so - -- will now be in final_env, replete with IdInfo - -- Its name will be unchanged since it was born, but - -- we want Global, IdInfo-rich (or not) DFunId in the - -- tidy_insts + -- A DFunId will have a binding in tidy_binds, and so + -- will now be in final_env, replete with IdInfo + -- Its name will be unchanged since it was born, but + -- we want Global, IdInfo-rich (or not) DFunId in the + -- tidy_insts ; tidy_rules = tidyRules tidy_env ext_rules -- You might worry that the tidy_env contains IdInfo-rich stuff @@ -369,19 +372,20 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- If the endPass didn't print the rules, but ddump-rules is -- on, print now - ; dumpIfSet (dopt Opt_D_dump_rules dflags - && (not (dopt Opt_D_dump_simpl dflags))) - CoreTidy + ; dumpIfSet dflags (dopt Opt_D_dump_rules dflags + && (not (dopt Opt_D_dump_simpl dflags))) + CoreTidy (ptext (sLit "rules")) (pprRulesForUser tidy_rules) -- Print one-line size info ; let cs = coreBindsStats tidy_binds ; when (dopt Opt_D_dump_core_stats dflags) - (printDump (ptext (sLit "Tidy size (terms,types,coercions)") - <+> ppr (moduleName mod) <> colon - <+> int (cs_tm cs) - <+> int (cs_ty cs) + (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle + (ptext (sLit "Tidy size (terms,types,coercions)") + <+> ppr (moduleName mod) <> colon + <+> int (cs_tm cs) + <+> int (cs_ty cs) <+> int (cs_co cs) )) ; return (CgGuts { cg_module = mod, @@ -390,44 +394,44 @@ tidyProgram hsc_env (ModGuts { mg_module = mod cg_foreign = foreign_stubs, cg_dep_pkgs = map fst $ dep_pkgs deps, cg_hpc_info = hpc_info, - cg_modBreaks = modBreaks }, + cg_modBreaks = modBreaks }, ModDetails { md_types = tidy_type_env, - md_rules = tidy_rules, - md_insts = tidy_insts, + md_rules = tidy_rules, + md_insts = tidy_insts, md_vect_info = tidy_vect_info, md_fam_insts = fam_insts, - md_exports = exports, - md_anns = anns -- are already tidy + md_exports = exports, + md_anns = anns -- are already tidy }) - } + } lookup_dfun :: TypeEnv -> Var -> Id lookup_dfun type_env dfun_id = case lookupTypeEnv type_env (idName dfun_id) of - Just (AnId dfun_id') -> dfun_id' - _other -> pprPanic "lookup_dfun" (ppr dfun_id) + Just (AnId dfun_id') -> dfun_id' + _other -> pprPanic "lookup_dfun" (ppr dfun_id) -------------------------- tidyTypeEnv :: Bool -- Compiling without -O, so omit prags - -> Bool -- Template Haskell is on + -> Bool -- Type-trimming flag -> NameSet -> TypeEnv -> TypeEnv -- The competed type environment is gotten from -- a) the types and classes defined here (plus implicit things) -- b) adding Ids with correct IdInfo, including unfoldings, --- gotten from the bindings +-- gotten from the bindings -- From (b) we keep only those Ids with External names; --- the CoreTidy pass makes sure these are all and only --- the externally-accessible ones --- This truncates the type environment to include only the +-- the CoreTidy pass makes sure these are all and only +-- the externally-accessible ones +-- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space -tidyTypeEnv omit_prags th exports type_env +tidyTypeEnv omit_prags no_trim_types exports type_env = let type_env1 = filterNameEnv (not . isWiredInName . getName) type_env -- (1) remove wired-in things - type_env2 | omit_prags = mapNameEnv (trimThing th exports) type_env1 + type_env2 | omit_prags = mapNameEnv (trimThing no_trim_types exports) type_env1 | otherwise = type_env1 -- (2) trimmed if necessary in @@ -436,64 +440,103 @@ tidyTypeEnv omit_prags th exports type_env -------------------------- trimThing :: Bool -> NameSet -> TyThing -> TyThing -- Trim off inessentials, for boot files and no -O -trimThing th exports (ATyCon tc) - | not th && not (mustExposeTyCon exports tc) - = ATyCon (makeTyConAbstract tc) -- Note [Trimming and Template Haskell] +trimThing no_trim_types exports (ATyCon tc) + | not (mustExposeTyCon no_trim_types exports tc) + = ATyCon (makeTyConAbstract tc) -- Note [When we can't trim types] trimThing _th _exports (AnId id) - | not (isImplicitId id) + | not (isImplicitId id) = AnId (id `setIdInfo` vanillaIdInfo) -trimThing _th _exports other_thing +trimThing _th _exports other_thing = other_thing -{- Note [Trimming and Template Haskell] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #2386) this - module M(T, makeOne) where - data T = Yay String - makeOne = [| Yay "Yep" |] +{- Note [When we can't trim types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of type trimming is to export algebraic data types +abstractly (without their data constructors) when compiling without +-O, unless of course they are explicitly exported by the user. + +We always export synonyms, because they can be mentioned in the type +of an exported Id. We could do a full dependency analysis starting +from the explicit exports, but that's quite painful, and not done for +now. + +But there are some times we can't do that, indicated by the 'no_trim_types' flag. + +First, Template Haskell. Consider (Trac #2386) this + module M(T, makeOne) where + data T = Yay String + makeOne = [| Yay "Yep" |] Notice that T is exported abstractly, but makeOne effectively exports it too! A module that splices in $(makeOne) will then look for a declartion of Yay, so it'd better be there. Hence, brutally but simply, we switch off type -constructor trimming if TH is enabled in this module. -} - - -mustExposeTyCon :: NameSet -- Exports - -> TyCon -- The tycon - -> Bool -- Can its rep be hidden? --- We are compiling without -O, and thus trying to write as little as +constructor trimming if TH is enabled in this module. + +Second, data kinds. Consider (Trac #5912) + {-# LANGUAGE DataKinds #-} + module M() where + data UnaryTypeC a = UnaryDataC a + type Bug = 'UnaryDataC +We always export synonyms, so Bug is exposed, and that means that +UnaryTypeC must be too, even though it's not explicitly exported. In +effect, DataKinds means that we'd need to do a full dependency analysis +to see what data constructors are mentioned. But we don't do that yet. + +In these two cases we just switch off type trimming altogether. + -} + +mustExposeTyCon :: Bool -- Type-trimming flag + -> NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as -- possible into the interface file. But we must expose the details of -- any data types whose constructors or fields are exported -mustExposeTyCon exports tc - | not (isAlgTyCon tc) -- Synonyms +mustExposeTyCon no_trim_types exports tc + | no_trim_types -- See Note [When we can't trim types] = True - | isEnumerationTyCon tc -- For an enumeration, exposing the constructors - = True -- won't lead to the need for further exposure - -- (This includes data types with no constructors.) - | isFamilyTyCon tc -- Open type family + + | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to + -- figure out whether it was mentioned in the type + -- of any other exported thing) = True - | otherwise -- Newtype, datatype - = any exported_con (tyConDataCons tc) - -- Expose rep if any datacon or field is exported + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors + = True -- won't lead to the need for further exposure - || (isNewTyCon tc && isFFITy (snd (newTyConRhs tc))) - -- Expose the rep for newtypes if the rep is an FFI type. - -- For a very annoying reason. 'Foreign import' is meant to - -- be able to look through newtypes transparently, but it - -- can only do that if it can "see" the newtype representation + | isFamilyTyCon tc -- Open type family + = True + + -- Below here we just have data/newtype decls or family instances + + | null data_cons -- Ditto if there are no data constructors + = True -- (NB: empty data types do not count as enumerations + -- see Note [Enumeration types] in TyCon + + | any exported_con data_cons -- Expose rep if any datacon or field is exported + = True + + | isNewTyCon tc && isFFITy (snd (newTyConRhs tc)) + = True -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + + | otherwise + = False where - exported_con con = any (`elemNameSet` exports) - (dataConName con : dataConFieldLabels con) + data_cons = tyConDataCons tc + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) tidyInstances :: (DFunId -> DFunId) -> [ClsInst] -> [ClsInst] tidyInstances tidy_dfun ispecs = map tidy ispecs where tidy ispec = setInstanceDFunId ispec $ - tidy_dfun (instanceDFunId ispec) + tidy_dfun (instanceDFunId ispec) \end{code} \begin{code} @@ -516,18 +559,18 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars , isDataConWorkId var || not (isImplicitId var) ] - tidy_scalarVars = mkVarSet [ lookup_var var + tidy_scalarVars = mkVarSet [ lookup_var var | var <- varSetElems scalarVars , isGlobalId var || isExportedId var] - + lookup_var var = lookupWithDefaultVarEnv var_env var var \end{code} %************************************************************************ -%* * - Implicit bindings -%* * +%* * + Implicit bindings +%* * %************************************************************************ Note [Injecting implicit bindings] @@ -535,9 +578,9 @@ Note [Injecting implicit bindings] We inject the implict bindings right at the end, in CoreTidy. Some of these bindings, notably record selectors, are not constructed in an optimised form. E.g. record selector for - data T = MkT { x :: {-# UNPACK #-} !Int } + data T = MkT { x :: {-# UNPACK #-} !Int } Then the unfolding looks like - x = \t. case t of MkT x1 -> let x = I# x1 in x + x = \t. case t of MkT x1 -> let x = I# x1 in x This generates bad code unless it's first simplified a bit. That is why CoreUnfold.mkImplicitUnfolding uses simleExprOpt to do a bit of optimisation first. (Only matters when the selector is used curried; @@ -562,15 +605,15 @@ Oh: two other reasons for injecting them late: - If implicit Ids are already in the bindings when we start TidyPgm, we'd have to be careful not to treat them as external Ids (in the sense of findExternalIds); else the Ids mentioned in *their* - RHSs will be treated as external and you get an interface file + RHSs will be treated as external and you get an interface file saying a18 = <blah> - but nothing refererring to a18 (because the implicit Id is the + but nothing refererring to a18 (because the implicit Id is the one that does, and implicit Ids don't appear in interface files). - More seriously, the tidied type-envt will include the implicit Id replete with a18 in its unfolding; but we won't take account of a18 when computing a fingerprint for the class; result chaos. - + There is one sort of implicit binding that is injected still later, namely those for data constructor workers. Reason (I think): it's really just a code generation trick.... binding itself makes no sense. @@ -589,9 +632,9 @@ get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) %************************************************************************ -%* * +%* * \subsection{Step 1: finding externals} -%* * +%* * %************************************************************************ See Note [Choosing external names]. @@ -600,7 +643,7 @@ See Note [Choosing external names]. type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) -- Maps each top-level Id to its new Name (the Id is tidied in step 2) -- The Unique is unchanged. If the new Name is external, it will be - -- visible in the interface file. + -- visible in the interface file. -- -- Bool => expose unfolding or not. @@ -619,13 +662,13 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders ; tidy_internal internal_ids unfold_env1 occ_env1 } where - nc_var = hsc_NC hsc_env + nc_var = hsc_NC hsc_env -- init_ext_ids is the intial list of Ids that should be -- externalised. It serves as the starting point for finding a -- deterministic, tidy, renaming for all external Ids in this -- module. - -- + -- -- It is sorted, so that it has adeterministic order (i.e. it's the -- same list every time this module is compiled), in contrast to the -- bindings, which are ordered non-deterministically. @@ -648,32 +691,32 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ avoids = [getOccName name | bndr <- binders ++ implicit_binders, let name = idName bndr, isExternalName name ] - -- In computing our "avoids" list, we must include - -- all implicit Ids - -- all things with global names (assigned once and for - -- all by the renamer) - -- since their names are "taken". - -- The type environment is a convenient source of such things. + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + -- The type environment is a convenient source of such things. -- In particular, the set of binders doesn't include -- implicit Ids at this stage. - -- We also make sure to avoid any exported binders. Consider - -- f{-u1-} = 1 -- Local decl - -- ... - -- f{-u2-} = 2 -- Exported decl - -- - -- The second exported decl must 'get' the name 'f', so we - -- have to put 'f' in the avoids list before we get to the first - -- decl. tidyTopId then does a no-op on exported binders. + -- We also make sure to avoid any exported binders. Consider + -- f{-u1-} = 1 -- Local decl + -- ... + -- f{-u2-} = 2 -- Exported decl + -- + -- The second exported decl must 'get' the name 'f', so we + -- have to put 'f' in the avoids list before we get to the first + -- decl. tidyTopId then does a no-op on exported binders. init_occ_env = initTidyOccEnv avoids search :: [(Id,Id)] -- The work-list: (external id, referrring id) - -- Make a tidy, external Name for the external id, + -- Make a tidy, external Name for the external id, -- add it to the UnfoldEnv, and do the same for the -- transitive closure of Ids it refers to - -- The referring id is used to generate a tidy - --- name for the external id + -- The referring id is used to generate a tidy + --- name for the external id -> UnfoldEnv -- id -> (new Name, show_unfold) -> TidyOccEnv -- occ env for choosing new Names -> IO (UnfoldEnv, TidyOccEnv) @@ -684,13 +727,13 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env | otherwise = do (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc - let + let (new_ids, show_unfold) | omit_prags = ([], False) | otherwise = addExternal expose_all refined_id - -- 'idocc' is an *occurrence*, but we need to see the - -- unfolding in the *definition*; so look up in binder_set + -- 'idocc' is an *occurrence*, but we need to see the + -- unfolding in the *definition*; so look up in binder_set refined_id = case lookupVarSet binder_set idocc of Just id -> id Nothing -> WARN( True, ppr idocc ) idocc @@ -713,35 +756,35 @@ addExternal :: Bool -> Id -> ([Id], Bool) addExternal expose_all id = (new_needed_ids, show_unfold) where new_needed_ids = bndrFvsInOrder show_unfold id - idinfo = idInfo id + idinfo = idInfo id show_unfold = show_unfolding (unfoldingInfo idinfo) never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) loop_breaker = isStrongLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (strictnessInfo idinfo `orElse` topSig) - -- Stuff to do with the Id's unfolding - -- We leave the unfolding there even if there is a worker - -- In GHCi the unfolding is used by importers + -- Stuff to do with the Id's unfolding + -- We leave the unfolding there even if there is a worker + -- In GHCi the unfolding is used by importers show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) - = expose_all -- 'expose_all' says to expose all - -- unfoldings willy-nilly + = expose_all -- 'expose_all' says to expose all + -- unfoldings willy-nilly - || isStableSource src -- Always expose things whose - -- source is an inline rule + || isStableSource src -- Always expose things whose + -- source is an inline rule - || not (bottoming_fn -- No need to inline bottom functions - || never_active -- Or ones that say not to - || loop_breaker -- Or that are loop breakers - || neverUnfoldGuidance guidance) + || not (bottoming_fn -- No need to inline bottom functions + || never_active -- Or ones that say not to + || loop_breaker -- Or that are loop breakers + || neverUnfoldGuidance guidance) show_unfolding (DFunUnfolding {}) = True show_unfolding _ = False \end{code} %************************************************************************ -%* * +%* * Deterministic free variables -%* * +%* * %************************************************************************ We want a deterministic free-variable list. exprFreeVars gives us @@ -760,10 +803,10 @@ run :: DFFV () -> [Id] run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of ((_,ids),_) -> ids -newtype DFFV a - = DFFV (VarSet -- Envt: non-top-level things that are in scope +newtype DFFV a + = DFFV (VarSet -- Envt: non-top-level things that are in scope -- we don't want to record these as free vars - -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far + -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far -> ((VarSet,[Var]),a)) -- Output state instance Monad DFFV where @@ -780,22 +823,22 @@ extendScopeList :: [Var] -> DFFV a -> DFFV a extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) insert :: Var -> DFFV () -insert v = DFFV $ \ env (set, ids) -> - let keep_me = isLocalId v && +insert v = DFFV $ \ env (set, ids) -> + let keep_me = isLocalId v && not (v `elemVarSet` env) && - not (v `elemVarSet` set) - in if keep_me + not (v `elemVarSet` set) + in if keep_me then ((extendVarSet set v, v:ids), ()) else ((set, ids), ()) dffvExpr :: CoreExpr -> DFFV () dffvExpr (Var v) = insert v -dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 -dffvExpr (Lam v e) = extendScope v (dffvExpr e) +dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 +dffvExpr (Lam v e) = extendScope v (dffvExpr e) dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e dffvExpr (Tick _other e) = dffvExpr e -dffvExpr (Cast e _) = dffvExpr e +dffvExpr (Cast e _) = dffvExpr e dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ (mapM_ dffvBind prs >> dffvExpr e) @@ -806,11 +849,11 @@ dffvAlt :: (t, [Var], CoreExpr) -> DFFV () dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r) dffvBind :: (Id, CoreExpr) -> DFFV () -dffvBind(x,r) +dffvBind(x,r) | not (isId x) = dffvExpr r | otherwise = dffvLetBndr False x >> dffvExpr r - -- Pass False because we are doing the RHS right here - -- If you say True you'll get *exponential* behaviour! + -- Pass False because we are doing the RHS right here + -- If you say True you'll get *exponential* behaviour! dffvLetBndr :: Bool -> Id -> DFFV () -- Gather the free vars of the RULES and unfolding of a binder @@ -832,14 +875,14 @@ dffvLetBndr vanilla_unfold id = case src of InlineRhs | vanilla_unfold -> dffvExpr rhs | otherwise -> return () - InlineWrapper v -> insert v - _ -> dffvExpr rhs - -- For a wrapper, externalise the wrapper id rather than the - -- fvs of the rhs. The two usually come down to the same thing - -- but I've seen cases where we had a wrapper id $w but a - -- rhs where $w had been inlined; see Trac #3922 - - go_unf (DFunUnfolding _ _ args) = mapM_ dffvExpr args + InlineWrapper v -> insert v + _ -> dffvExpr rhs + -- For a wrapper, externalise the wrapper id rather than the + -- fvs of the rhs. The two usually come down to the same thing + -- but I've seen cases where we had a wrapper id $w but a + -- rhs where $w had been inlined; see Trac #3922 + + go_unf (DFunUnfolding _ _ args) = mapM_ dffvExpr (dfunArgExprs args) go_unf _ = return () go_rule (BuiltinRule {}) = return () @@ -849,57 +892,57 @@ dffvLetBndr vanilla_unfold id %************************************************************************ -%* * +%* * tidyTopName -%* * +%* * %************************************************************************ -This is where we set names to local/global based on whether they really are +This is where we set names to local/global based on whether they really are externally visible (see comment at the top of this module). If the name was previously local, we have to give it a unique occurrence name if we intend to externalise it. \begin{code} tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv - -> Id -> IO (TidyOccEnv, Name) + -> Id -> IO (TidyOccEnv, Name) tidyTopName mod nc_var maybe_ref occ_env id | global && internal = return (occ_env, localiseName name) | global && external = return (occ_env, name) - -- Global names are assumed to have been allocated by the renamer, - -- so they already have the "right" unique - -- And it's a system-wide unique too + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too -- Now we get to the real reason that all this is in the IO Monad: -- we have to update the name cache in a nice atomic fashion | local && internal = do { nc <- readIORef nc_var - ; let (nc', new_local_name) = mk_new_local nc - ; writeIORef nc_var nc' - ; return (occ_env', new_local_name) } - -- Even local, internal names must get a unique occurrence, because - -- if we do -split-objs we externalise the name later, in the code generator - -- - -- Similarly, we must make sure it has a system-wide Unique, because - -- the byte-code generator builds a system-wide Name->BCO symbol table + ; let (nc', new_local_name) = mk_new_local nc + ; writeIORef nc_var nc' + ; return (occ_env', new_local_name) } + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we externalise the name later, in the code generator + -- + -- Similarly, we must make sure it has a system-wide Unique, because + -- the byte-code generator builds a system-wide Name->BCO symbol table | local && external = do { nc <- readIORef nc_var - ; let (nc', new_external_name) = mk_new_external nc - ; writeIORef nc_var nc' - ; return (occ_env', new_external_name) } + ; let (nc', new_external_name) = mk_new_external nc + ; writeIORef nc_var nc' + ; return (occ_env', new_external_name) } | otherwise = panic "tidyTopName" where - name = idName id + name = idName id external = isJust maybe_ref - global = isExternalName name - local = not global - internal = not external - loc = nameSrcSpan name + global = isExternalName name + local = not global + internal = not external + loc = nameSrcSpan name old_occ = nameOccName name new_occ - | Just ref <- maybe_ref, ref /= id = + | Just ref <- maybe_ref, ref /= id = mkOccName (occNameSpace old_occ) $ let ref_str = occNameString (getOccName ref) @@ -921,42 +964,42 @@ tidyTopName mod nc_var maybe_ref occ_env id (occ_env', occ') = tidyOccName occ_env new_occ mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc) - where - (uniq, us) = takeUniqFromSupply (nsUniqs nc) + where + (uniq, us) = takeUniqFromSupply (nsUniqs nc) mk_new_external nc = allocateGlobalBinder nc mod occ' loc - -- If we want to externalise a currently-local name, check - -- whether we have already assigned a unique for it. - -- If so, use it; if not, extend the table. - -- All this is done by allcoateGlobalBinder. - -- This is needed when *re*-compiling a module in GHCi; we must - -- use the same name for externally-visible things as we did before. + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- All this is done by allcoateGlobalBinder. + -- This is needed when *re*-compiling a module in GHCi; we must + -- use the same name for externally-visible things as we did before. \end{code} \begin{code} -findExternalRules :: Bool -- Omit pragmas +findExternalRules :: Bool -- Omit pragmas -> [CoreBind] - -> [CoreRule] -- Local rules for imported fns - -> UnfoldEnv -- Ids that are exported, so we need their rules - -> [CoreRule] + -> [CoreRule] -- Local rules for imported fns + -> UnfoldEnv -- Ids that are exported, so we need their rules + -> [CoreRule] -- The complete rules are gotten by combining - -- a) local rules for imported Ids - -- b) rules embedded in the top-level Ids + -- a) local rules for imported Ids + -- b) rules embedded in the top-level Ids findExternalRules omit_prags binds imp_id_rules unfold_env | omit_prags = [] | otherwise = filterOut internal_rule (imp_id_rules ++ local_rules) where local_rules = [ rule - | id <- bindersOfBinds binds, + | id <- bindersOfBinds binds, external_id id, - rule <- idCoreRules id - ] + rule <- idCoreRules id + ] internal_rule rule - = any (not . external_id) (varSetElems (ruleLhsFreeIds rule)) - -- Don't export a rule whose LHS mentions a locally-defined - -- Id that is completely internal (i.e. not visible to an - -- importing module) + = any (not . external_id) (varSetElems (ruleLhsFreeIds rule)) + -- Don't export a rule whose LHS mentions a locally-defined + -- Id that is completely internal (i.e. not visible to an + -- importing module) external_id id | Just (name,_) <- lookupVarEnv unfold_env id = isExternalName name @@ -965,76 +1008,79 @@ findExternalRules omit_prags binds imp_id_rules unfold_env Note [Which rules to expose] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -findExternalRules filters imp_rules to avoid binders that -aren't externally visible; but the externally-visible binders +findExternalRules filters imp_rules to avoid binders that +aren't externally visible; but the externally-visible binders are computed (by findExternalIds) assuming that all orphan -rules are externalised (see init_ext_ids in function -'search'). So in fact we may export more than we need. +rules are externalised (see init_ext_ids in function +'search'). So in fact we may export more than we need. (It's a sort of mutual recursion.) %************************************************************************ -%* * +%* * \subsection{Step 2: top-level tidying} -%* * +%* * %************************************************************************ \begin{code} -- TopTidyEnv: when tidying we need to know --- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. --- These may have arisen because the --- renamer read in an interface file mentioning M.$wf, say, --- and assigned it unique r77. If, on this compilation, we've --- invented an Id whose name is $wf (but with a different unique) --- we want to rename it to have unique r77, so that we can do easy --- comparisons with stuff from the interface file +-- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. +-- These may have arisen because the +-- renamer read in an interface file mentioning M.$wf, say, +-- and assigned it unique r77. If, on this compilation, we've +-- invented an Id whose name is $wf (but with a different unique) +-- we want to rename it to have unique r77, so that we can do easy +-- comparisons with stuff from the interface file -- --- * occ_env: The TidyOccEnv, which tells us which local occurrences +-- * occ_env: The TidyOccEnv, which tells us which local occurrences -- are 'used' -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old tidyTopBinds :: HscEnv - -> UnfoldEnv + -> UnfoldEnv -> TidyOccEnv - -> CoreProgram - -> (TidyEnv, CoreProgram) + -> CoreProgram + -> IO (TidyEnv, CoreProgram) tidyTopBinds hsc_env unfold_env init_occ_env binds - = tidy init_env binds + = do mkIntegerId <- liftM tyThingId + $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) + return $ tidy mkIntegerId init_env binds where init_env = (init_occ_env, emptyVarEnv) this_pkg = thisPackage (hsc_dflags hsc_env) - tidy env [] = (env, []) - tidy env (b:bs) = let (env1, b') = tidyTopBind this_pkg unfold_env env b - (env2, bs') = tidy env1 bs - in - (env2, b':bs') + tidy _ env [] = (env, []) + tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind this_pkg mkIntegerId unfold_env env b + (env2, bs') = tidy mkIntegerId env1 bs + in + (env2, b':bs') ------------------------ tidyTopBind :: PackageId + -> Id -> UnfoldEnv - -> TidyEnv + -> TidyEnv -> CoreBind - -> (TidyEnv, CoreBind) + -> (TidyEnv, CoreBind) -tidyTopBind this_pkg unfold_env (occ_env,subst1) (NonRec bndr rhs) +tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where Just (name',show_unfold) = lookupVarEnv unfold_env bndr - caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs + caf_info = hasCafRefs this_pkg (mkIntegerId, subst1) (idArity bndr) rhs (bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind this_pkg unfold_env (occ_env,subst1) (Rec prs) +tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) = (tidy_env2, Rec prs') where prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs) | (id,rhs) <- prs, - let (name',show_unfold) = + let (name',show_unfold) = expectJust "tidyTopBind" $ lookupVarEnv unfold_env id ] @@ -1043,70 +1089,70 @@ tidyTopBind this_pkg unfold_env (occ_env,subst1) (Rec prs) bndrs = map fst prs - -- the CafInfo for a recursive group says whether *any* rhs in - -- the group may refer indirectly to a CAF (because then, they all do). - caf_info - | or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs) - | (bndr,rhs) <- prs ] = MayHaveCafRefs - | otherwise = NoCafRefs + -- the CafInfo for a recursive group says whether *any* rhs in + -- the group may refer indirectly to a CAF (because then, they all do). + caf_info + | or [ mayHaveCafRefs (hasCafRefs this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) + | (bndr,rhs) <- prs ] = MayHaveCafRefs + | otherwise = NoCafRefs ----------------------------------------------------------- tidyTopPair :: Bool -- show unfolding - -> TidyEnv -- The TidyEnv is used to tidy the IdInfo - -- It is knot-tied: don't look at it! - -> CafInfo - -> Name -- New name - -> (Id, CoreExpr) -- Binder and RHS before tidying - -> (Id, CoreExpr) - -- This function is the heart of Step 2 - -- The rec_tidy_env is the one to use for the IdInfo - -- It's necessary because when we are dealing with a recursive - -- group, a variable late in the group might be mentioned - -- in the IdInfo of one early in the group + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> CafInfo + -> Name -- New name + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) + -- This function is the heart of Step 2 + -- The rec_tidy_env is the one to use for the IdInfo + -- It's necessary because when we are dealing with a recursive + -- group, a variable late in the group might be mentioned + -- in the IdInfo of one early in the group tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs) = (bndr1, rhs1) where bndr1 = mkGlobalId details name' ty' idinfo' - details = idDetails bndr -- Preserve the IdDetails - ty' = tidyTopType (idType bndr) + details = idDetails bndr -- Preserve the IdDetails + ty' = tidyTopType (idType bndr) rhs1 = tidyExpr rhs_tidy_env rhs - idinfo' = tidyTopIdInfo rhs_tidy_env name' rhs rhs1 (idInfo bndr) + idinfo' = tidyTopIdInfo rhs_tidy_env name' rhs rhs1 (idInfo bndr) show_unfold caf_info -- tidyTopIdInfo creates the final IdInfo for top-level -- binders. There are two delicate pieces: -- -- * Arity. After CoreTidy, this arity must not change any more. --- Indeed, CorePrep must eta expand where necessary to make --- the manifest arity equal to the claimed arity. +-- Indeed, CorePrep must eta expand where necessary to make +-- the manifest arity equal to the claimed arity. -- -- * CAF info. This must also remain valid through to code generation. --- We add the info here so that it propagates to all --- occurrences of the binders in RHSs, and hence to occurrences in --- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. --- CoreToStg makes use of this when constructing SRTs. -tidyTopIdInfo :: TidyEnv -> Name -> CoreExpr -> CoreExpr +-- We add the info here so that it propagates to all +-- occurrences of the binders in RHSs, and hence to occurrences in +-- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. +-- CoreToStg makes use of this when constructing SRTs. +tidyTopIdInfo :: TidyEnv -> Name -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> CafInfo -> IdInfo tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info - | not is_external -- For internal Ids (not externally visible) - = vanillaIdInfo -- we only need enough info for code generation - -- Arity and strictness info are enough; - -- c.f. CoreTidy.tidyLetBndr - `setCafInfo` caf_info - `setArityInfo` arity - `setStrictnessInfo` final_sig - - | otherwise -- Externally-visible Ids get the whole lot + | not is_external -- For internal Ids (not externally visible) + = vanillaIdInfo -- we only need enough info for code generation + -- Arity and strictness info are enough; + -- c.f. CoreTidy.tidyLetBndr + `setCafInfo` caf_info + `setArityInfo` arity + `setStrictnessInfo` final_sig + + | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo - `setCafInfo` caf_info - `setArityInfo` arity - `setStrictnessInfo` final_sig + `setCafInfo` caf_info + `setArityInfo` arity + `setStrictnessInfo` final_sig `setOccInfo` robust_occ_info - `setInlinePragInfo` (inlinePragInfo idinfo) - `setUnfoldingInfo` unfold_info - -- NB: we throw away the Rules - -- They have already been extracted by findExternalRules + `setInlinePragInfo` (inlinePragInfo idinfo) + `setUnfoldingInfo` unfold_info + -- NB: we throw away the Rules + -- They have already been extracted by findExternalRules where is_external = isExternalName name @@ -1132,9 +1178,9 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info --------- Unfolding ------------ unf_info = unfoldingInfo idinfo unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs - | otherwise = noUnfolding + | otherwise = noUnfolding unf_from_rhs = mkTopUnfolding is_bot tidy_rhs - is_bot = case final_sig of + is_bot = case final_sig of Just sig -> isBottomingSig sig Nothing -> False -- NB: do *not* expose the worker if show_unfold is off, @@ -1143,17 +1189,17 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info -- This is important: if you expose the worker for a loop-breaker -- then you can make the simplifier go into an infinite loop, because -- in effect the unfolding is exposed. See Trac #1709 - -- + -- -- You might think that if show_unfold is False, then the thing should -- not be w/w'd in the first place. But a legitimate reason is this: - -- the function returns bottom + -- the function returns bottom -- In this case, show_unfold will be false (we don't expose unfoldings -- for bottoming functions), but we might still have a worker/wrapper -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs --------- Arity ------------ -- Usually the Id will have an accurate arity on it, because - -- the simplifier has just run, but not always. + -- the simplifier has just run, but not always. -- One case I found was when the last thing the simplifier -- did was to let-bind a non-atomic argument and then float -- it to the top level. So it seems more robust just to @@ -1162,9 +1208,9 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info \end{code} %************************************************************************ -%* * +%* * \subsection{Figuring out CafInfo for an expression} -%* * +%* * %************************************************************************ hasCafRefs decides whether a top-level closure can point into the dynamic heap. @@ -1173,55 +1219,56 @@ used to decide whether a particular closure needs to be referenced in an SRT or not. There are two reasons for setting MayHaveCafRefs: - a) The RHS is a CAF: a top-level updatable thunk. - b) The RHS refers to something that MayHaveCafRefs + a) The RHS is a CAF: a top-level updatable thunk. + b) The RHS refers to something that MayHaveCafRefs -Possible improvement: In an effort to keep the number of CAFs (and -hence the size of the SRTs) down, we could also look at the expression and -decide whether it requires a small bounded amount of heap, so we can ignore +Possible improvement: In an effort to keep the number of CAFs (and +hence the size of the SRTs) down, we could also look at the expression and +decide whether it requires a small bounded amount of heap, so we can ignore it as a CAF. In these cases however, we would need to use an additional -CAF list to keep track of non-collectable CAFs. +CAF list to keep track of non-collectable CAFs. \begin{code} -hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo -hasCafRefs this_pkg p arity expr +hasCafRefs :: PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr -> CafInfo +hasCafRefs this_pkg p arity expr | is_caf || mentions_cafs = MayHaveCafRefs - | otherwise = NoCafRefs + | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefsE p expr) - is_dynamic_name = isDllName this_pkg + is_dynamic_name = isDllName this_pkg is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr) -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity - -- knows how much eta expansion is going to be done by + -- knows how much eta expansion is going to be done by -- CorePrep later on, and we don't want to duplicate that -- knowledge in rhsIsStatic below. -cafRefsE :: VarEnv Id -> Expr a -> FastBool +cafRefsE :: (Id, VarEnv Id) -> Expr a -> FastBool cafRefsE p (Var id) = cafRefsV p id -cafRefsE p (Lit lit) = cafRefsL p lit -cafRefsE p (App f a) = fastOr (cafRefsE p f) (cafRefsE p) a -cafRefsE p (Lam _ e) = cafRefsE p e -cafRefsE p (Let b e) = fastOr (cafRefsEs p (rhssOfBind b)) (cafRefsE p) e +cafRefsE p (Lit lit) = cafRefsL p lit +cafRefsE p (App f a) = fastOr (cafRefsE p f) (cafRefsE p) a +cafRefsE p (Lam _ e) = cafRefsE p e +cafRefsE p (Let b e) = fastOr (cafRefsEs p (rhssOfBind b)) (cafRefsE p) e cafRefsE p (Case e _bndr _ alts) = fastOr (cafRefsE p e) (cafRefsEs p) (rhssOfAlts alts) cafRefsE p (Tick _n e) = cafRefsE p e -cafRefsE p (Cast e _co) = cafRefsE p e -cafRefsE _ (Type _) = fastBool False -cafRefsE _ (Coercion _) = fastBool False +cafRefsE p (Cast e _co) = cafRefsE p e +cafRefsE _ (Type _) = fastBool False +cafRefsE _ (Coercion _) = fastBool False -cafRefsEs :: VarEnv Id -> [Expr a] -> FastBool -cafRefsEs _ [] = fastBool False +cafRefsEs :: (Id, VarEnv Id) -> [Expr a] -> FastBool +cafRefsEs _ [] = fastBool False cafRefsEs p (e:es) = fastOr (cafRefsE p e) (cafRefsEs p) es -cafRefsL :: VarEnv Id -> Literal -> FastBool --- Don't forget that the embeded mk_integer id might have Caf refs! --- See Note [Integer literals] in Literal -cafRefsL p (LitInteger _ mk_integer) = cafRefsV p mk_integer +cafRefsL :: (Id, VarEnv Id) -> Literal -> FastBool +-- Don't forget that mk_integer id might have Caf refs! +-- We first need to convert the Integer into its final form, to +-- see whether mkInteger is used. +cafRefsL p@(mk_integer, _) (LitInteger i _) = cafRefsE p (cvtLitInteger mk_integer i) cafRefsL _ _ = fastBool False -cafRefsV :: VarEnv Id -> Id -> FastBool -cafRefsV p id +cafRefsV :: (Id, VarEnv Id) -> Id -> FastBool +cafRefsV (_, p) id | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id)) | Just id' <- lookupVarEnv p id = fastBool (mayHaveCafRefs (idCafInfo id')) | otherwise = fastBool False diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 454dd86eaf..732508bffc 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -1,19 +1,12 @@ -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1993-2004 --- +-- -- This is the top-level module in the native code generator. -- -- ----------------------------------------------------------------------------- \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" @@ -40,12 +33,12 @@ import qualified PPC.Instr import qualified PPC.Ppr import RegAlloc.Liveness -import qualified RegAlloc.Linear.Main as Linear +import qualified RegAlloc.Linear.Main as Linear -import qualified GraphColor as Color -import qualified RegAlloc.Graph.Main as Color -import qualified RegAlloc.Graph.Stats as Color -import qualified RegAlloc.Graph.TrivColorable as Color +import qualified GraphColor as Color +import qualified RegAlloc.Graph.Main as Color +import qualified RegAlloc.Graph.Stats as Color +import qualified RegAlloc.Graph.TrivColorable as Color import TargetReg import Platform @@ -56,14 +49,14 @@ import Reg import NCGMonad import BlockId -import CgUtils ( fixStgRegisters ) +import CgUtils ( fixStgRegisters ) import OldCmm -import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold ) +import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold ) import OldPprCmm import CLabel import UniqFM -import Unique ( Unique, getUnique ) +import Unique ( Unique, getUnique ) import UniqSupply import DynFlags import StaticFlags @@ -71,7 +64,6 @@ import Util import BasicTypes ( Alignment ) import Digraph -import Pretty (Doc) import qualified Pretty import BufWrite import Outputable @@ -123,7 +115,7 @@ The machine-dependent bits break down as follows: machine instructions. * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really - a 'Doc'). + a 'SDoc'). * ["RegAllocInfo"] In the register allocator, we manipulate 'MRegsState's, which are 'BitSet's, one bit per machine register. @@ -148,7 +140,7 @@ data NcgImpl statics instr jumpDest = NcgImpl { canShortcut :: instr -> Maybe jumpDest, shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, - pprNatCmmDecl :: Platform -> NatCmmDecl statics instr -> Doc, + pprNatCmmDecl :: Platform -> NatCmmDecl statics instr -> SDoc, maxSpillSlots :: Int, allocatableRegs :: [RealReg], ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], @@ -160,7 +152,7 @@ data NcgImpl statics instr jumpDest = NcgImpl { nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO () nativeCodeGen dflags h us cmms = let platform = targetPlatform dflags - nCG' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () + nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms x86NcgImpl = NcgImpl { cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen @@ -209,20 +201,20 @@ nativeCodeGen dflags h us cmms ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop ,ncgMakeFarBranches = id } - ArchARM _ _ -> + ArchARM _ _ _ -> panic "nativeCodeGen: No NCG for ARM" ArchPPC_64 -> panic "nativeCodeGen: No NCG for PPC 64" ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" -nativeCodeGen' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) +nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO () nativeCodeGen' dflags ncgImpl h us cmms = do - let platform = targetPlatform dflags + let platform = targetPlatform dflags split_cmms = Stream.map add_split cmms -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little @@ -231,54 +223,55 @@ nativeCodeGen' dflags ncgImpl h us cmms (imports, prof) <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms [] [] 0 bFlush bufh - let (native, colorStats, linearStats) - = unzip3 prof - - -- dump native code - dumpIfSet_dyn dflags - Opt_D_dump_asm "Asm code" - (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) $ concat native) - - -- dump global NCG stats for graph coloring allocator - (case concat $ catMaybes colorStats of - [] -> return () - stats -> do - -- build the global register conflict graph - let graphGlobal - = foldl Color.union Color.initGraph - $ [ Color.raGraph stat - | stat@Color.RegAllocStatsStart{} <- stats] - - dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" - $ Color.pprStats stats graphGlobal - - dumpIfSet_dyn dflags - Opt_D_dump_asm_conflicts "Register conflict graph" - $ Color.dotGraph - (targetRegDotColor platform) - (Color.trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - $ graphGlobal) - - - -- dump global NCG stats for linear allocator - (case concat $ catMaybes linearStats of - [] -> return () - stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" - $ Linear.pprStats (concat native) stats) - - -- write out the imports - Pretty.printDoc Pretty.LeftMode h - $ makeImportsDoc dflags (concat imports) - - return () + let (native, colorStats, linearStats) + = unzip3 prof + + -- dump native code + dumpIfSet_dyn dflags + Opt_D_dump_asm "Asm code" + (vcat $ map (pprNatCmmDecl ncgImpl platform) $ concat native) + + -- dump global NCG stats for graph coloring allocator + (case concat $ catMaybes colorStats of + [] -> return () + stats -> do + -- build the global register conflict graph + let graphGlobal + = foldl Color.union Color.initGraph + $ [ Color.raGraph stat + | stat@Color.RegAllocStatsStart{} <- stats] + + dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" + $ Color.pprStats stats graphGlobal + + dumpIfSet_dyn dflags + Opt_D_dump_asm_conflicts "Register conflict graph" + $ Color.dotGraph + (targetRegDotColor platform) + (Color.trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + $ graphGlobal) + + + -- dump global NCG stats for linear allocator + (case concat $ catMaybes linearStats of + [] -> return () + stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" + $ Linear.pprStats (concat native) stats) + + -- write out the imports + Pretty.printDoc Pretty.LeftMode (pprCols dflags) h + $ withPprStyleDoc dflags (mkCodeStyle AsmStyle) + $ makeImportsDoc dflags (concat imports) + + return () where add_split tops - | dopt Opt_SplitObjs dflags = split_marker : tops - | otherwise = tops + | dopt Opt_SplitObjs dflags = split_marker : tops + | otherwise = tops - split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph []) + split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph []) cmmNativeGenStream :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) @@ -311,7 +304,7 @@ cmmNativeGenStream dflags ncgImpl h us cmm_stream impAcc profAcc count -- | Do native code generation on all these cmms. -- -cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) +cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> BufHandle @@ -335,158 +328,159 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count = do let platform = targetPlatform dflags - (us', native, imports, colorStats, linearStats) + (us', native, imports, colorStats, linearStats) <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count {-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h - $ Pretty.vcat $ map (pprNatCmmDecl ncgImpl platform) native + $ withPprStyleDoc dflags (mkCodeStyle AsmStyle) + $ vcat $ map (pprNatCmmDecl ncgImpl platform) native -- carefully evaluate this strictly. Binding it with 'let' -- and then using 'seq' doesn't work, because the let -- apparently gets inlined first. - lsPprNative <- return $! - if dopt Opt_D_dump_asm dflags - || dopt Opt_D_dump_asm_stats dflags - then native - else [] + lsPprNative <- return $! + if dopt Opt_D_dump_asm dflags + || dopt Opt_D_dump_asm_stats dflags + then native + else [] - count' <- return $! count + 1; + count' <- return $! count + 1; - -- force evaulation all this stuff to avoid space leaks - {-# SCC "seqString" #-} seqString (showSDoc $ vcat $ map (pprPlatform platform) imports) `seq` return () + -- force evaulation all this stuff to avoid space leaks + {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map ppr imports) `seq` return () - cmmNativeGens dflags ncgImpl + cmmNativeGens dflags ncgImpl h us' cmms - (imports : impAcc) - ((lsPprNative, colorStats, linearStats) : profAcc) - count' + (imports : impAcc) + ((lsPprNative, colorStats, linearStats) : profAcc) + count' - where seqString [] = () - seqString (x:xs) = x `seq` seqString xs `seq` () + where seqString [] = () + seqString (x:xs) = x `seq` seqString xs `seq` () -- | Complete native code generation phase for a single top-level chunk of Cmm. --- Dumping the output of each stage along the way. --- Global conflict graph and NGC stats +-- Dumping the output of each stage along the way. +-- Global conflict graph and NGC stats cmmNativeGen - :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) + :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest - -> UniqSupply - -> RawCmmDecl -- ^ the cmm to generate code for - -> Int -- ^ sequence number of this top thing - -> IO ( UniqSupply - , [NatCmmDecl statics instr] -- native code - , [CLabel] -- things imported by this cmm - , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator - , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators + -> UniqSupply + -> RawCmmDecl -- ^ the cmm to generate code for + -> Int -- ^ sequence number of this top thing + -> IO ( UniqSupply + , [NatCmmDecl statics instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators cmmNativeGen dflags ncgImpl us cmm count = do let platform = targetPlatform dflags - -- rewrite assignments to global regs - let fixed_cmm = - {-# SCC "fixStgRegisters" #-} - fixStgRegisters cmm - - -- cmm to cmm optimisations - let (opt_cmm, imports) = - {-# SCC "cmmToCmm" #-} - cmmToCmm dflags fixed_cmm - - dumpIfSet_dyn dflags - Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmmGroup platform [opt_cmm]) - - -- generate native code from cmm - let ((native, lastMinuteImports), usGen) = - {-# SCC "genMachCode" #-} - initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm - - dumpIfSet_dyn dflags - Opt_D_dump_asm_native "Native code" - (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) native) - - -- tag instructions with register liveness information - let (withLiveness, usLive) = - {-# SCC "regLiveness" #-} - initUs usGen - $ mapUs (regLiveness platform) - $ map natCmmTopToLive native - - dumpIfSet_dyn dflags - Opt_D_dump_asm_liveness "Liveness annotations added" - (vcat $ map (pprPlatform platform) withLiveness) - - -- allocate registers - (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- - if ( dopt Opt_RegsGraph dflags - || dopt Opt_RegsIterative dflags) - then do - -- the regs usable for allocation - let (alloc_regs :: UniqFM (UniqSet RealReg)) - = foldr (\r -> plusUFM_C unionUniqSets - $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) - emptyUFM - $ allocatableRegs ncgImpl - - -- do the graph coloring register allocation - let ((alloced, regAllocStats), usAlloc) - = {-# SCC "RegAlloc" #-} - initUs usLive - $ Color.regAlloc - dflags - alloc_regs - (mkUniqSet [0 .. maxSpillSlots ncgImpl]) - withLiveness - - -- dump out what happened during register allocation - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced) - - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc_stages "Build/spill stages" - (vcat $ map (\(stage, stats) - -> text "# --------------------------" - $$ text "# cmm " <> int count <> text " Stage " <> int stage - $$ pprPlatform platform stats) - $ zip [0..] regAllocStats) - - let mPprStats = - if dopt Opt_D_dump_asm_stats dflags - then Just regAllocStats else Nothing - - -- force evaluation of the Maybe to avoid space leak - mPprStats `seq` return () - - return ( alloced, usAlloc - , mPprStats - , Nothing) - - else do - -- do linear register allocation - let ((alloced, regAllocStats), usAlloc) - = {-# SCC "RegAlloc" #-} - initUs usLive - $ liftM unzip - $ mapUs (Linear.regAlloc dflags) withLiveness - - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced) - - let mPprStats = - if dopt Opt_D_dump_asm_stats dflags - then Just (catMaybes regAllocStats) else Nothing - - -- force evaluation of the Maybe to avoid space leak - mPprStats `seq` return () - - return ( alloced, usAlloc - , Nothing - , mPprStats) + -- rewrite assignments to global regs + let fixed_cmm = + {-# SCC "fixStgRegisters" #-} + fixStgRegisters cmm + + -- cmm to cmm optimisations + let (opt_cmm, imports) = + {-# SCC "cmmToCmm" #-} + cmmToCmm dflags fixed_cmm + + dumpIfSet_dyn dflags + Opt_D_dump_opt_cmm "Optimised Cmm" + (pprCmmGroup [opt_cmm]) + + -- generate native code from cmm + let ((native, lastMinuteImports), usGen) = + {-# SCC "genMachCode" #-} + initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm + + dumpIfSet_dyn dflags + Opt_D_dump_asm_native "Native code" + (vcat $ map (pprNatCmmDecl ncgImpl platform) native) + + -- tag instructions with register liveness information + let (withLiveness, usLive) = + {-# SCC "regLiveness" #-} + initUs usGen + $ mapM regLiveness + $ map natCmmTopToLive native + + dumpIfSet_dyn dflags + Opt_D_dump_asm_liveness "Liveness annotations added" + (vcat $ map ppr withLiveness) + + -- allocate registers + (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- + if ( dopt Opt_RegsGraph dflags + || dopt Opt_RegsIterative dflags) + then do + -- the regs usable for allocation + let (alloc_regs :: UniqFM (UniqSet RealReg)) + = foldr (\r -> plusUFM_C unionUniqSets + $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) + emptyUFM + $ allocatableRegs ncgImpl + + -- do the graph coloring register allocation + let ((alloced, regAllocStats), usAlloc) + = {-# SCC "RegAlloc" #-} + initUs usLive + $ Color.regAlloc + dflags + alloc_regs + (mkUniqSet [0 .. maxSpillSlots ncgImpl]) + withLiveness + + -- dump out what happened during register allocation + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc "Registers allocated" + (vcat $ map (pprNatCmmDecl ncgImpl platform) alloced) + + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc_stages "Build/spill stages" + (vcat $ map (\(stage, stats) + -> text "# --------------------------" + $$ text "# cmm " <> int count <> text " Stage " <> int stage + $$ ppr stats) + $ zip [0..] regAllocStats) + + let mPprStats = + if dopt Opt_D_dump_asm_stats dflags + then Just regAllocStats else Nothing + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + + return ( alloced, usAlloc + , mPprStats + , Nothing) + + else do + -- do linear register allocation + let ((alloced, regAllocStats), usAlloc) + = {-# SCC "RegAlloc" #-} + initUs usLive + $ liftM unzip + $ mapM (Linear.regAlloc dflags) withLiveness + + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc "Registers allocated" + (vcat $ map (pprNatCmmDecl ncgImpl platform) alloced) + + let mPprStats = + if dopt Opt_D_dump_asm_stats dflags + then Just (catMaybes regAllocStats) else Nothing + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + + return ( alloced, usAlloc + , Nothing + , mPprStats) ---- x86fp_kludge. This pass inserts ffree instructions to clear ---- the FPU stack on x86. The x86 ABI requires that the FPU stack @@ -498,55 +492,55 @@ cmmNativeGen dflags ncgImpl us cmm count let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced ---- generate jump tables - let tabled = - {-# SCC "generateJumpTables" #-} + let tabled = + {-# SCC "generateJumpTables" #-} generateJumpTables ncgImpl kludged - ---- shortcut branches - let shorted = - {-# SCC "shortcutBranches" #-} - shortcutBranches dflags ncgImpl tabled + ---- shortcut branches + let shorted = + {-# SCC "shortcutBranches" #-} + shortcutBranches dflags ncgImpl tabled - ---- sequence blocks - let sequenced = - {-# SCC "sequenceBlocks" #-} - map (sequenceTop ncgImpl) shorted + ---- sequence blocks + let sequenced = + {-# SCC "sequenceBlocks" #-} + map (sequenceTop ncgImpl) shorted ---- expansion of SPARC synthetic instrs - let expanded = - {-# SCC "sparc_expand" #-} + let expanded = + {-# SCC "sparc_expand" #-} ncgExpandTop ncgImpl sequenced - dumpIfSet_dyn dflags - Opt_D_dump_asm_expanded "Synthetic instructions expanded" - (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) expanded) + dumpIfSet_dyn dflags + Opt_D_dump_asm_expanded "Synthetic instructions expanded" + (vcat $ map (pprNatCmmDecl ncgImpl platform) expanded) - return ( usAlloc - , expanded - , lastMinuteImports ++ imports - , ppr_raStatsColor - , ppr_raStatsLinear) + return ( usAlloc + , expanded + , lastMinuteImports ++ imports + , ppr_raStatsColor + , ppr_raStatsLinear) x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr x86fp_kludge top@(CmmData _ _) = top -x86fp_kludge (CmmProc info lbl (ListGraph code)) = - CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) +x86fp_kludge (CmmProc info lbl (ListGraph code)) = + CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) -- | Build a doc for all the imports. -- -makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc +makeImportsDoc :: DynFlags -> [CLabel] -> SDoc makeImportsDoc dflags imports = dyld_stubs imports - Pretty.$$ + $$ -- On recent versions of Darwin, the linker supports -- dead-stripping of code and data on a per-symbol basis. -- There's a hack to make this work in PprMach.pprNatCmmDecl. (if platformHasSubsectionsViaSymbols (targetPlatform dflags) - then Pretty.text ".subsections_via_symbols" - else Pretty.empty) - Pretty.$$ + then text ".subsections_via_symbols" + else empty) + $$ -- On recent GNU ELF systems one can mark an object file -- as not requiring an executable stack. If all objects -- linked into a program have this note then the program @@ -554,45 +548,43 @@ makeImportsDoc dflags imports -- security. GHC generated code does not need an executable -- stack so add the note in: (if platformHasGnuNonexecStack (targetPlatform dflags) - then Pretty.text ".section .note.GNU-stack,\"\",@progbits" - else Pretty.empty) - Pretty.$$ + then text ".section .note.GNU-stack,\"\",@progbits" + else empty) + $$ -- And just because every other compiler does, lets stick in -- an identifier directive: .ident "GHC x.y.z" (if platformHasIdentDirective (targetPlatform dflags) - then let compilerIdent = Pretty.text "GHC" Pretty.<+> - Pretty.text cProjectVersion - in Pretty.text ".ident" Pretty.<+> - Pretty.doubleQuotes compilerIdent - else Pretty.empty) + then let compilerIdent = text "GHC" <+> text cProjectVersion + in text ".ident" <+> doubleQuotes compilerIdent + else empty) where - -- Generate "symbol stubs" for all external symbols that might - -- come from a dynamic library. - dyld_stubs :: [CLabel] -> Pretty.Doc -{- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $ - map head $ group $ sort imps-} - - platform = targetPlatform dflags - arch = platformArch platform - os = platformOS platform - - -- (Hack) sometimes two Labels pretty-print the same, but have - -- different uniques; so we compare their text versions... - dyld_stubs imps - | needImportedSymbols arch os - = Pretty.vcat $ - (pprGotDeclaration arch os :) $ - map ( pprImportedSymbol platform . fst . head) $ - groupBy (\(_,a) (_,b) -> a == b) $ - sortBy (\(_,a) (_,b) -> compare a b) $ - map doPpr $ - imps - | otherwise - = Pretty.empty - - doPpr lbl = (lbl, renderWithStyle (pprCLabel platform lbl) astyle) - astyle = mkCodeStyle AsmStyle + -- Generate "symbol stubs" for all external symbols that might + -- come from a dynamic library. + dyld_stubs :: [CLabel] -> SDoc +{- dyld_stubs imps = vcat $ map pprDyldSymbolStub $ + map head $ group $ sort imps-} + + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + + -- (Hack) sometimes two Labels pretty-print the same, but have + -- different uniques; so we compare their text versions... + dyld_stubs imps + | needImportedSymbols arch os + = vcat $ + (pprGotDeclaration arch os :) $ + map ( pprImportedSymbol platform . fst . head) $ + groupBy (\(_,a) (_,b) -> a == b) $ + sortBy (\(_,a) (_,b) -> compare a b) $ + map doPpr $ + imps + | otherwise + = empty + + doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle) + astyle = mkCodeStyle AsmStyle -- ----------------------------------------------------------------------------- @@ -604,12 +596,12 @@ makeImportsDoc dflags imports -- such that as many of the local jumps as possible turn into -- fallthroughs. -sequenceTop - :: Instruction instr +sequenceTop + :: Instruction instr => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr sequenceTop _ top@(CmmData _ _) = top -sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = +sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks) -- The algorithm is very simple (and stupid): we make a graph out of @@ -622,36 +614,36 @@ sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = -- FYI, the classic layout for basic blocks uses postorder DFS; this -- algorithm is implemented in Hoopl. -sequenceBlocks - :: Instruction instr - => [NatBasicBlock instr] - -> [NatBasicBlock instr] +sequenceBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [NatBasicBlock instr] sequenceBlocks [] = [] -sequenceBlocks (entry:blocks) = +sequenceBlocks (entry:blocks) = seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks))) -- the first block is the entry point ==> it must remain at the start. -sccBlocks - :: Instruction instr - => [NatBasicBlock instr] - -> [SCC ( NatBasicBlock instr - , Unique - , [Unique])] +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [SCC ( NatBasicBlock instr + , Unique + , [Unique])] sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks) -- we're only interested in the last instruction of -- the block, and only if it has a single destination. -getOutEdges - :: Instruction instr - => [instr] -> [Unique] +getOutEdges + :: Instruction instr + => [instr] -> [Unique] -getOutEdges instrs - = case jumpDestsOfInstr (last instrs) of - [one] -> [getUnique one] - _many -> [] +getOutEdges instrs + = case jumpDestsOfInstr (last instrs) of + [one] -> [getUnique one] + _many -> [] mkNode :: (Instruction t) => GenBasicBlock t @@ -666,9 +658,9 @@ seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest) | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest' | otherwise = block : seqBlocks rest' where - (can_fallthrough, rest') = reorder next [] rest - -- TODO: we should do a better job for cycles; try to maximise the - -- fallthroughs within a loop. + (can_fallthrough, rest') = reorder next [] rest + -- TODO: we should do a better job for cycles; try to maximise the + -- fallthroughs within a loop. seqBlocks _ = panic "AsmCodegen:seqBlocks" reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)]) @@ -685,18 +677,18 @@ reorder id accum (b@(block,id',out) : rest) -- big, we have to work around this limitation. makeFarBranches - :: [NatBasicBlock PPC.Instr.Instr] - -> [NatBasicBlock PPC.Instr.Instr] + :: [NatBasicBlock PPC.Instr.Instr] + -> [NatBasicBlock PPC.Instr.Instr] makeFarBranches blocks | last blockAddresses < nearLimit = blocks | otherwise = zipWith handleBlock blockAddresses blocks where blockAddresses = scanl (+) 0 $ map blockLen blocks blockLen (BasicBlock _ instrs) = length instrs - + handleBlock addr (BasicBlock id instrs) = BasicBlock id (zipWith makeFar [addr..] instrs) - + makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt makeFar addr (PPC.Instr.BCC cond tgt) | abs (addr - targetAddr) >= nearLimit @@ -705,13 +697,13 @@ makeFarBranches blocks = PPC.Instr.BCC cond tgt where Just targetAddr = lookupUFM blockAddressMap tgt makeFar _ other = other - + nearLimit = 7000 -- 8192 instructions are allowed; let's keep some -- distance, as we have a few pseudo-insns that are -- pretty-printed as multiple instructions, -- and it's just not worth the effort to calculate -- things exactly - + blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses -- ----------------------------------------------------------------------------- @@ -720,7 +712,7 @@ makeFarBranches blocks -- Analyzes all native code and generates data sections for all jump -- table instructions. generateJumpTables - :: NcgImpl statics instr jumpDest + :: NcgImpl statics instr jumpDest -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] generateJumpTables ncgImpl xs = concatMap f xs where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs @@ -731,10 +723,10 @@ generateJumpTables ncgImpl xs = concatMap f xs -- Shortcut branches shortcutBranches - :: DynFlags + :: DynFlags -> NcgImpl statics instr jumpDest - -> [NatCmmDecl statics instr] - -> [NatCmmDecl statics instr] + -> [NatCmmDecl statics instr] + -> [NatCmmDecl statics instr] shortcutBranches dflags ncgImpl tops | optLevel dflags < 1 = tops -- only with -O or higher @@ -772,7 +764,7 @@ build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks))) -- build a mapping from BlockId to JumpDest for shorting branches mapping = foldl add emptyUFM shortcut_blocks add ufm (id,dest) = addToUFM ufm id dest - + apply_mapping :: NcgImpl statics instr jumpDest -> UniqFM jumpDest -> GenCmmDecl statics h (ListGraph instr) @@ -807,21 +799,21 @@ apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) -- Switching between the two monads whilst carrying along the same -- Unique supply breaks abstraction. Is that bad? -genMachCode - :: DynFlags +genMachCode + :: DynFlags -> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) - -> RawCmmDecl - -> UniqSM - ( [NatCmmDecl statics instr] - , [CLabel]) + -> RawCmmDecl + -> UniqSM + ( [NatCmmDecl statics instr] + , [CLabel]) genMachCode dflags cmmTopCodeGen cmm_top - = do { initial_us <- getUs - ; let initial_st = mkNatM_State initial_us 0 dflags - (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) - final_delta = natm_delta final_st - final_imports = natm_imports final_st - ; if final_delta == 0 + = do { initial_us <- getUs + ; let initial_st = mkNatM_State initial_us 0 dflags + (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) + final_delta = natm_delta final_st + final_imports = natm_imports final_st + ; if final_delta == 0 then return (new_tops, final_imports) else pprPanic "genMachCode: nonzero final delta" (int final_delta) } @@ -856,13 +848,11 @@ Ideas for other things we could do (put these in Hoopl please!): cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do - let platform = targetPlatform dflags - let reachable_blocks | dopt Opt_TryNewCodeGen dflags = blocks | otherwise = cmmEliminateDeadBlocks blocks -- The new codegen path has already eliminated unreachable blocks by now - blocks' <- mapM cmmBlockConFold (cmmMiniInline platform reachable_blocks) + blocks' <- mapM cmmBlockConFold (cmmMiniInline dflags reachable_blocks) return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) @@ -906,8 +896,8 @@ cmmStmtConFold stmt CmmAssign reg src -> do src' <- cmmExprConFold DataReference src return $ case src' of - CmmReg reg' | reg == reg' -> CmmNop - new_src -> CmmAssign reg new_src + CmmReg reg' | reg == reg' -> CmmNop + new_src -> CmmAssign reg new_src CmmStore addr src -> do addr' <- cmmExprConFold DataReference addr @@ -919,11 +909,15 @@ cmmStmtConFold stmt return $ CmmJump addr' live CmmCall target regs args returns - -> do target' <- case target of - CmmCallee e conv -> do - e' <- cmmExprConFold CallReference e - return $ CmmCallee e' conv - other -> return other + -> do target' <- case target of + CmmCallee e conv -> do + e' <- cmmExprConFold CallReference e + return $ CmmCallee e' conv + op@(CmmPrim _ Nothing) -> + return op + CmmPrim op (Just stmts) -> + do stmts' <- mapM cmmStmtConFold stmts + return $ CmmPrim op (Just stmts') args' <- mapM (\(CmmHinted arg hint) -> do arg' <- cmmExprConFold DataReference arg return (CmmHinted arg' hint)) args @@ -932,18 +926,17 @@ cmmStmtConFold stmt CmmCondBranch test dest -> do test' <- cmmExprConFold DataReference test dflags <- getDynFlags - let platform = targetPlatform dflags - return $ case test' of - CmmLit (CmmInt 0 _) -> - CmmComment (mkFastString ("deleted: " ++ - showSDoc (pprStmt platform stmt))) + return $ case test' of + CmmLit (CmmInt 0 _) -> + CmmComment (mkFastString ("deleted: " ++ + showSDoc dflags (pprStmt stmt))) - CmmLit (CmmInt _ _) -> CmmBranch dest - _other -> CmmCondBranch test' dest + CmmLit (CmmInt _ _) -> CmmBranch dest + _other -> CmmCondBranch test' dest - CmmSwitch expr ids - -> do expr' <- cmmExprConFold DataReference expr - return $ CmmSwitch expr' ids + CmmSwitch expr ids + -> do expr' <- cmmExprConFold DataReference expr + return $ CmmSwitch expr' ids other -> return other @@ -1003,7 +996,7 @@ cmmExprNative referenceKind expr = do CmmReg (CmmGlobal GCEnter1) | arch == ArchPPC && not opt_PIC -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) | arch == ArchPPC && not opt_PIC -> cmmExprNative referenceKind $ diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index e81ebfb901..64e37d0eae 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -77,10 +77,8 @@ import CLabel ( mkForeignLabel ) import StaticFlags ( opt_PIC, opt_Static ) import BasicTypes -import Pretty -import qualified Outputable +import Outputable -import Panic ( panic ) import DynFlags import FastString @@ -421,19 +419,6 @@ picRelative _ _ _ -------------------------------------------------------------------------------- --- utility function for pretty-printing asm-labels, --- copied from PprMach --- -asmSDoc :: Outputable.SDoc -> Doc -asmSDoc d - = Outputable.withPprStyleDoc - (Outputable.mkCodeStyle Outputable.AsmStyle) d - -pprCLabel_asm :: Platform -> CLabel -> Doc -pprCLabel_asm platform l - = asmSDoc (pprCLabel platform l) - - needImportedSymbols :: Arch -> OS -> Bool needImportedSymbols arch os | os == OSDarwin @@ -468,7 +453,7 @@ gotLabel -------------------------------------------------------------------------------- -- We don't need to declare any offset tables. -- However, for PIC on x86, we need a small helper function. -pprGotDeclaration :: Arch -> OS -> Doc +pprGotDeclaration :: Arch -> OS -> SDoc pprGotDeclaration ArchX86 OSDarwin | opt_PIC = vcat [ @@ -480,7 +465,7 @@ pprGotDeclaration ArchX86 OSDarwin ptext (sLit "\tret") ] pprGotDeclaration _ OSDarwin - = Pretty.empty + = empty -- pprGotDeclaration -- Output whatever needs to be output once per .s file. @@ -491,7 +476,7 @@ pprGotDeclaration arch os | osElfTarget os , arch /= ArchPPC_64 , not opt_PIC - = Pretty.empty + = empty | osElfTarget os , arch /= ArchPPC_64 @@ -511,21 +496,21 @@ pprGotDeclaration _ _ -- Whenever you change something in this assembler output, make sure -- the splitter in driver/split/ghc-split.lprl recognizes the new output -pprImportedSymbol :: Platform -> CLabel -> Doc +pprImportedSymbol :: Platform -> CLabel -> SDoc pprImportedSymbol platform@(Platform { platformArch = ArchPPC, platformOS = OSDarwin }) importedLbl | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl = case opt_PIC of False -> vcat [ ptext (sLit ".symbol_stub"), - ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, - ptext (sLit "\tlis r11,ha16(L") <> pprCLabel_asm platform lbl + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, + ptext (sLit "\tlis r11,ha16(L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr)"), - ptext (sLit "\tlwz r12,lo16(L") <> pprCLabel_asm platform lbl + ptext (sLit "\tlwz r12,lo16(L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr)(r11)"), ptext (sLit "\tmtctr r12"), - ptext (sLit "\taddi r11,r11,lo16(L") <> pprCLabel_asm platform lbl + ptext (sLit "\taddi r11,r11,lo16(L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr)"), ptext (sLit "\tbctr") ] @@ -534,32 +519,32 @@ pprImportedSymbol platform@(Platform { platformArch = ArchPPC, platformOS = OSDa ptext (sLit ".section __TEXT,__picsymbolstub1,") <> ptext (sLit "symbol_stubs,pure_instructions,32"), ptext (sLit "\t.align 2"), - ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, ptext (sLit "\tmflr r0"), - ptext (sLit "\tbcl 20,31,L0$") <> pprCLabel_asm platform lbl, - ptext (sLit "L0$") <> pprCLabel_asm platform lbl <> char ':', + ptext (sLit "\tbcl 20,31,L0$") <> pprCLabel platform lbl, + ptext (sLit "L0$") <> pprCLabel platform lbl <> char ':', ptext (sLit "\tmflr r11"), - ptext (sLit "\taddis r11,r11,ha16(L") <> pprCLabel_asm platform lbl - <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel_asm platform lbl <> char ')', + ptext (sLit "\taddis r11,r11,ha16(L") <> pprCLabel platform lbl + <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel platform lbl <> char ')', ptext (sLit "\tmtlr r0"), - ptext (sLit "\tlwzu r12,lo16(L") <> pprCLabel_asm platform lbl - <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel_asm platform lbl + ptext (sLit "\tlwzu r12,lo16(L") <> pprCLabel platform lbl + <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel platform lbl <> ptext (sLit ")(r11)"), ptext (sLit "\tmtctr r12"), ptext (sLit "\tbctr") ] $+$ vcat [ ptext (sLit ".lazy_symbol_pointer"), - ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, ptext (sLit "\t.long dyld_stub_binding_helper")] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl = vcat [ ptext (sLit ".non_lazy_symbol_pointer"), - char 'L' <> pprCLabel_asm platform lbl <> ptext (sLit "$non_lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, + char 'L' <> pprCLabel platform lbl <> ptext (sLit "$non_lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, ptext (sLit "\t.long\t0")] | otherwise @@ -572,13 +557,13 @@ pprImportedSymbol platform@(Platform { platformArch = ArchX86, platformOS = OSDa False -> vcat [ ptext (sLit ".symbol_stub"), - ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, - ptext (sLit "\tjmp *L") <> pprCLabel_asm platform lbl + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, + ptext (sLit "\tjmp *L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr"), - ptext (sLit "L") <> pprCLabel_asm platform lbl + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub_binder:"), - ptext (sLit "\tpushl $L") <> pprCLabel_asm platform lbl + ptext (sLit "\tpushl $L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr"), ptext (sLit "\tjmp dyld_stub_binding_helper") ] @@ -586,16 +571,16 @@ pprImportedSymbol platform@(Platform { platformArch = ArchX86, platformOS = OSDa vcat [ ptext (sLit ".section __TEXT,__picsymbolstub2,") <> ptext (sLit "symbol_stubs,pure_instructions,25"), - ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, ptext (sLit "\tcall ___i686.get_pc_thunk.ax"), ptext (sLit "1:"), - ptext (sLit "\tmovl L") <> pprCLabel_asm platform lbl + ptext (sLit "\tmovl L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr-1b(%eax),%edx"), ptext (sLit "\tjmp *%edx"), - ptext (sLit "L") <> pprCLabel_asm platform lbl + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub_binder:"), - ptext (sLit "\tlea L") <> pprCLabel_asm platform lbl + ptext (sLit "\tlea L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr-1b(%eax),%eax"), ptext (sLit "\tpushl %eax"), ptext (sLit "\tjmp dyld_stub_binding_helper") @@ -603,16 +588,16 @@ pprImportedSymbol platform@(Platform { platformArch = ArchX86, platformOS = OSDa $+$ vcat [ ptext (sLit ".section __DATA, __la_sym_ptr") <> (if opt_PIC then int 2 else int 3) <> ptext (sLit ",lazy_symbol_pointers"), - ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, - ptext (sLit "\t.long L") <> pprCLabel_asm platform lbl + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, + ptext (sLit "\t.long L") <> pprCLabel platform lbl <> ptext (sLit "$stub_binder")] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl = vcat [ ptext (sLit ".non_lazy_symbol_pointer"), - char 'L' <> pprCLabel_asm platform lbl <> ptext (sLit "$non_lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, + char 'L' <> pprCLabel platform lbl <> ptext (sLit "$non_lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, ptext (sLit "\t.long\t0")] | otherwise @@ -667,8 +652,8 @@ pprImportedSymbol platform importedLbl in vcat [ ptext (sLit ".section \".got2\", \"aw\""), - ptext (sLit ".LC_") <> pprCLabel_asm platform lbl <> char ':', - ptext symbolSize <+> pprCLabel_asm platform lbl ] + ptext (sLit ".LC_") <> pprCLabel platform lbl <> char ':', + ptext symbolSize <+> pprCLabel platform lbl ] -- PLT code stubs are generated automatically by the dynamic linker. _ -> empty diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 7b704cbe8f..422e1bbf89 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -57,6 +57,7 @@ import Data.Word import BasicTypes import FastString +import Util -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector @@ -104,7 +105,6 @@ basicBlockCodeGen (BasicBlock id stmts) = do = (instrs, blocks, CmmData sec dat:statics) mkBlocks instr (instrs,blocks,statics) = (instr:instrs, blocks, statics) - -- in return (BasicBlock id top : other_blocks, statics) stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock @@ -284,7 +284,6 @@ assignMem_I64Code addrTree valueTree = do -- Big-endian store mov_hi = ST II32 rhi hi_addr mov_lo = ST II32 rlo lo_addr - -- in return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) @@ -297,7 +296,6 @@ assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do r_src_hi = getHiVRegFromLo r_src_lo mov_lo = MR r_dst_lo r_src_lo mov_hi = MR r_dst_hi r_src_hi - -- in return ( vcode `snocOL` mov_lo `snocOL` mov_hi ) @@ -332,7 +330,6 @@ iselExpr64 (CmmLit (CmmInt i _)) = do LIS rhi (ImmInt half3), OR rlo rlo (RIImm $ ImmInt half2) ] - -- in return (ChildCode64 code rlo) iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do @@ -346,7 +343,6 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do code2 `appOL` toOL [ ADDC rlo r1lo r2lo, ADDE rhi r1hi r2hi ] - -- in return (ChildCode64 code rlo) iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do @@ -357,8 +353,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) rlo iselExpr64 expr - = do dflags <- getDynFlags - pprPanic "iselExpr64(powerpc)" (pprPlatform (targetPlatform dflags) expr) + = pprPanic "iselExpr64(powerpc)" (pprExpr expr) @@ -574,7 +569,7 @@ getRegister' _ (CmmLit lit) ] in return (Any (cmmTypeSize rep) code) -getRegister' dflags other = pprPanic "getRegister(ppc)" (pprExpr (targetPlatform dflags) other) +getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other) -- extend?Rep: wrap integer expression of type rep -- in a conversion to II32 @@ -898,9 +893,12 @@ genCCall' -} -genCCall' _ (CmmPrim MO_WriteBarrier) _ _ +genCCall' _ (CmmPrim MO_WriteBarrier _) _ _ = return $ unitOL LWSYNC +genCCall' _ (CmmPrim _ (Just stmts)) _ _ + = stmtsToInstrs stmts + genCCall' gcp target dest_regs argsAndHints = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen @@ -914,7 +912,7 @@ genCCall' gcp target dest_regs argsAndHints (labelOrExpr, reduceToFF32) <- case target of CmmCallee (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False) CmmCallee expr _ -> return (Right expr, False) - CmmPrim mop -> outOfLineMachOp mop + CmmPrim mop _ -> outOfLineMachOp mop let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 @@ -943,7 +941,7 @@ genCCall' gcp target dest_regs argsAndHints GCPLinux -> roundTo 16 finalStack -- need to remove alignment information - argsAndHints' | (CmmPrim mop) <- target, + argsAndHints' | CmmPrim mop _ <- target, (mop == MO_Memcpy || mop == MO_Memset || mop == MO_Memmove) @@ -1142,10 +1140,15 @@ genCCall' gcp target dest_regs argsAndHints MO_PopCnt w -> (fsLit $ popCntLabel w, False) - MO_WriteBarrier -> - panic $ "outOfLineCmmOp: MO_WriteBarrier not supported" - MO_Touch -> - panic $ "outOfLineCmmOp: MO_Touch not supported" + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported") -- ----------------------------------------------------------------------------- -- Generating a table-branch diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 26f06c373b..dcc348a6fc 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -6,22 +6,15 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PPC.Ppr ( - pprNatCmmDecl, - pprBasicBlock, - pprSectionHeader, - pprData, - pprInstr, - pprSize, - pprImm, - pprDataItem, + pprNatCmmDecl, + pprBasicBlock, + pprSectionHeader, + pprData, + pprInstr, + pprSize, + pprImm, + pprDataItem, ) where @@ -40,12 +33,10 @@ import OldCmm import CLabel -import Unique ( pprUnique, Uniquable(..) ) +import Unique ( pprUnique, Uniquable(..) ) import Platform -import Pretty import FastString -import qualified Outputable -import Outputable ( PlatformOutputable, panic ) +import Outputable import Data.Word import Data.Bits @@ -54,7 +45,7 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: Platform -> NatCmmDecl CmmStatics Instr -> Doc +pprNatCmmDecl :: Platform -> NatCmmDecl CmmStatics Instr -> SDoc pprNatCmmDecl platform (CmmData section dats) = pprSectionHeader platform section $$ pprDatas platform dats @@ -72,7 +63,7 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG pprSectionHeader platform Text $$ ( (if platformHasSubsectionsViaSymbols platform - then pprCLabel_asm platform (mkDeadStripPreventer info_lbl) <> char ':' + then ppr (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ vcat (map (pprData platform) info) $$ pprLabel platform info_lbl @@ -89,23 +80,23 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). text "\t.long " - <+> pprCLabel_asm platform info_lbl + <+> ppr info_lbl <+> char '-' - <+> pprCLabel_asm platform (mkDeadStripPreventer info_lbl) + <+> ppr (mkDeadStripPreventer info_lbl) else empty) -pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc +pprBasicBlock :: Platform -> NatBasicBlock Instr -> SDoc pprBasicBlock platform (BasicBlock blockid instrs) = pprLabel platform (mkAsmTempLabel (getUnique blockid)) $$ vcat (map (pprInstr platform) instrs) -pprDatas :: Platform -> CmmStatics -> Doc +pprDatas :: Platform -> CmmStatics -> SDoc pprDatas platform (Statics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: Platform -> CmmStatic -> Doc +pprData :: Platform -> CmmStatic -> SDoc pprData _ (CmmString str) = pprASCII str pprData platform (CmmUninitialised bytes) = ptext (sLit keyword) <> int bytes where keyword = case platformOS platform of @@ -113,53 +104,53 @@ pprData platform (CmmUninitialised bytes) = ptext (sLit keyword) <> int bytes _ -> ".skip " pprData platform (CmmStaticLit lit) = pprDataItem platform lit -pprGloblDecl :: Platform -> CLabel -> Doc -pprGloblDecl platform lbl +pprGloblDecl :: CLabel -> SDoc +pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm platform lbl + | otherwise = ptext (sLit ".globl ") <> ppr lbl -pprTypeAndSizeDecl :: Platform -> CLabel -> Doc +pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc pprTypeAndSizeDecl platform lbl | platformOS platform == OSLinux && externallyVisibleCLabel lbl = ptext (sLit ".type ") <> - pprCLabel_asm platform lbl <> ptext (sLit ", @object") + ppr lbl <> ptext (sLit ", @object") pprTypeAndSizeDecl _ _ = empty -pprLabel :: Platform -> CLabel -> Doc -pprLabel platform lbl = pprGloblDecl platform lbl +pprLabel :: Platform -> CLabel -> SDoc +pprLabel platform lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl platform lbl - $$ (pprCLabel_asm platform lbl <> char ':') + $$ (ppr lbl <> char ':') -pprASCII :: [Word8] -> Doc +pprASCII :: [Word8] -> SDoc pprASCII str = vcat (map do1 str) $$ do1 0 where - do1 :: Word8 -> Doc + do1 :: Word8 -> SDoc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance PlatformOutputable Instr where - pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr +instance Outputable Instr where + ppr instr = sdocWithPlatform $ \platform -> pprInstr platform instr -pprReg :: Platform -> Reg -> Doc +pprReg :: Platform -> Reg -> SDoc pprReg platform r = case r of RegReal (RealRegSingle i) -> ppr_reg_no i RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch" - RegVirtual (VirtualRegI u) -> text "%vI_" <> asmSDoc (pprUnique u) - RegVirtual (VirtualRegHi u) -> text "%vHi_" <> asmSDoc (pprUnique u) - RegVirtual (VirtualRegF u) -> text "%vF_" <> asmSDoc (pprUnique u) - RegVirtual (VirtualRegD u) -> text "%vD_" <> asmSDoc (pprUnique u) - RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> asmSDoc (pprUnique u) + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUnique u + RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUnique u + RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUnique u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUnique u + RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUnique u where - ppr_reg_no :: Int -> Doc + ppr_reg_no :: Int -> SDoc ppr_reg_no i = case platformOS platform of OSDarwin -> @@ -206,34 +197,34 @@ pprReg platform r -pprSize :: Size -> Doc +pprSize :: Size -> SDoc pprSize x = ptext (case x of - II8 -> sLit "b" - II16 -> sLit "h" - II32 -> sLit "w" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprSize: no match") - - -pprCond :: Cond -> Doc + II8 -> sLit "b" + II16 -> sLit "h" + II32 -> sLit "w" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + _ -> panic "PPC.Ppr.pprSize: no match") + + +pprCond :: Cond -> SDoc pprCond c = ptext (case c of { - ALWAYS -> sLit ""; - EQQ -> sLit "eq"; NE -> sLit "ne"; - LTT -> sLit "lt"; GE -> sLit "ge"; - GTT -> sLit "gt"; LE -> sLit "le"; - LU -> sLit "lt"; GEU -> sLit "ge"; - GU -> sLit "gt"; LEU -> sLit "le"; }) + ALWAYS -> sLit ""; + EQQ -> sLit "eq"; NE -> sLit "ne"; + LTT -> sLit "lt"; GE -> sLit "ge"; + GTT -> sLit "gt"; LE -> sLit "le"; + LU -> sLit "lt"; GEU -> sLit "ge"; + GU -> sLit "gt"; LEU -> sLit "le"; }) -pprImm :: Platform -> Imm -> Doc +pprImm :: Platform -> Imm -> SDoc pprImm _ (ImmInt i) = int i pprImm _ (ImmInteger i) = integer i -pprImm platform (ImmCLbl l) = pprCLabel_asm platform l -pprImm platform (ImmIndex l i) = pprCLabel_asm platform l <> char '+' <> int i +pprImm _ (ImmCLbl l) = ppr l +pprImm _ (ImmIndex l i) = ppr l <> char '+' <> int i pprImm _ (ImmLit s) = s pprImm _ (ImmFloat _) = ptext (sLit "naughty float immediate") @@ -259,7 +250,7 @@ pprImm platform (HA i) else pprImm platform i <> text "@ha" -pprAddr :: Platform -> AddrMode -> Doc +pprAddr :: Platform -> AddrMode -> SDoc pprAddr platform (AddrRegReg r1 r2) = pprReg platform r1 <+> ptext (sLit ", ") <+> pprReg platform r2 @@ -268,7 +259,7 @@ pprAddr platform (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pp pprAddr platform (AddrRegImm r1 imm) = hcat [ pprImm platform imm, char '(', pprReg platform r1, char ')' ] -pprSectionHeader :: Platform -> Section -> Doc +pprSectionHeader :: Platform -> Section -> SDoc pprSectionHeader platform seg = case seg of Text -> ptext (sLit ".text\n.align 2") @@ -290,25 +281,25 @@ pprSectionHeader platform seg where osDarwin = platformOS platform == OSDarwin -pprDataItem :: Platform -> CmmLit -> Doc +pprDataItem :: Platform -> CmmLit -> SDoc pprDataItem platform lit = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) where - imm = litToImm lit + imm = litToImm lit - ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm platform imm] + ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm platform imm] - ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm platform imm] + ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm platform imm] - ppr_item FF32 (CmmFloat r _) + ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs - ppr_item FF64 (CmmFloat r _) + ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs - ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm platform imm] + ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm platform imm] ppr_item II64 (CmmInt x _) = [ptext (sLit "\t.long\t") @@ -317,11 +308,11 @@ pprDataItem platform lit ptext (sLit "\t.long\t") <> int (fromIntegral (fromIntegral x :: Word32))] - ppr_item _ _ - = panic "PPC.Ppr.pprDataItem: no match" + ppr_item _ _ + = panic "PPC.Ppr.pprDataItem: no match" -pprInstr :: Platform -> Instr -> Doc +pprInstr :: Platform -> Instr -> SDoc pprInstr _ (COMMENT _) = empty -- nuke 'em {- @@ -342,149 +333,149 @@ pprInstr _ (LDATA _ _) {- pprInstr _ (SPILL reg slot) = hcat [ - ptext (sLit "\tSPILL"), - char '\t', - pprReg platform reg, - comma, - ptext (sLit "SLOT") <> parens (int slot)] + ptext (sLit "\tSPILL"), + char '\t', + pprReg platform reg, + comma, + ptext (sLit "SLOT") <> parens (int slot)] pprInstr _ (RELOAD slot reg) = hcat [ - ptext (sLit "\tRELOAD"), - char '\t', - ptext (sLit "SLOT") <> parens (int slot), - comma, - pprReg platform reg] + ptext (sLit "\tRELOAD"), + char '\t', + ptext (sLit "SLOT") <> parens (int slot), + comma, + pprReg platform reg] -} pprInstr platform (LD sz reg addr) = hcat [ - char '\t', - ptext (sLit "l"), - ptext (case sz of - II8 -> sLit "bz" - II16 -> sLit "hz" - II32 -> sLit "wz" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprInstr: no match" - ), + char '\t', + ptext (sLit "l"), + ptext (case sz of + II8 -> sLit "bz" + II16 -> sLit "hz" + II32 -> sLit "wz" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + _ -> panic "PPC.Ppr.pprInstr: no match" + ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprAddr platform addr + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprAddr platform addr ] pprInstr platform (LA sz reg addr) = hcat [ - char '\t', - ptext (sLit "l"), - ptext (case sz of - II8 -> sLit "ba" - II16 -> sLit "ha" - II32 -> sLit "wa" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprInstr: no match" - ), + char '\t', + ptext (sLit "l"), + ptext (case sz of + II8 -> sLit "ba" + II16 -> sLit "ha" + II32 -> sLit "wa" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + _ -> panic "PPC.Ppr.pprInstr: no match" + ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprAddr platform addr + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprAddr platform addr ] pprInstr platform (ST sz reg addr) = hcat [ - char '\t', - ptext (sLit "st"), - pprSize sz, + char '\t', + ptext (sLit "st"), + pprSize sz, case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprAddr platform addr + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprAddr platform addr ] pprInstr platform (STU sz reg addr) = hcat [ - char '\t', - ptext (sLit "st"), - pprSize sz, - ptext (sLit "u\t"), + char '\t', + ptext (sLit "st"), + pprSize sz, + ptext (sLit "u\t"), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', - pprReg platform reg, - ptext (sLit ", "), - pprAddr platform addr + pprReg platform reg, + ptext (sLit ", "), + pprAddr platform addr ] pprInstr platform (LIS reg imm) = hcat [ - char '\t', - ptext (sLit "lis"), - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprImm platform imm + char '\t', + ptext (sLit "lis"), + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprImm platform imm ] pprInstr platform (LI reg imm) = hcat [ - char '\t', - ptext (sLit "li"), - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprImm platform imm + char '\t', + ptext (sLit "li"), + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprImm platform imm ] pprInstr platform (MR reg1 reg2) | reg1 == reg2 = empty | otherwise = hcat [ - char '\t', - case targetClassOfReg platform reg1 of - RcInteger -> ptext (sLit "mr") - _ -> ptext (sLit "fmr"), - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2 + char '\t', + case targetClassOfReg platform reg1 of + RcInteger -> ptext (sLit "mr") + _ -> ptext (sLit "fmr"), + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2 ] pprInstr platform (CMP sz reg ri) = hcat [ - char '\t', - op, - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprRI platform ri + char '\t', + op, + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprRI platform ri ] where - op = hcat [ - ptext (sLit "cmp"), - pprSize sz, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i' - ] + op = hcat [ + ptext (sLit "cmp"), + pprSize sz, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] pprInstr platform (CMPL sz reg ri) = hcat [ - char '\t', - op, - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprRI platform ri + char '\t', + op, + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprRI platform ri ] where - op = hcat [ - ptext (sLit "cmpl"), - pprSize sz, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i' - ] -pprInstr platform (BCC cond blockid) = hcat [ - char '\t', - ptext (sLit "b"), - pprCond cond, - char '\t', - pprCLabel_asm platform lbl + op = hcat [ + ptext (sLit "cmpl"), + pprSize sz, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] +pprInstr _ (BCC cond blockid) = hcat [ + char '\t', + ptext (sLit "b"), + pprCond cond, + char '\t', + ppr lbl ] where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr platform (BCCFAR cond blockid) = vcat [ +pprInstr _ (BCCFAR cond blockid) = vcat [ hcat [ ptext (sLit "\tb"), pprCond (condNegate cond), @@ -492,46 +483,46 @@ pprInstr platform (BCCFAR cond blockid) = vcat [ ], hcat [ ptext (sLit "\tb\t"), - pprCLabel_asm platform lbl + ppr lbl ] ] where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr platform (JMP lbl) = hcat [ -- an alias for b that takes a CLabel - char '\t', - ptext (sLit "b"), - char '\t', - pprCLabel_asm platform lbl +pprInstr _ (JMP lbl) = hcat [ -- an alias for b that takes a CLabel + char '\t', + ptext (sLit "b"), + char '\t', + ppr lbl ] pprInstr platform (MTCTR reg) = hcat [ - char '\t', - ptext (sLit "mtctr"), - char '\t', - pprReg platform reg + char '\t', + ptext (sLit "mtctr"), + char '\t', + pprReg platform reg ] pprInstr _ (BCTR _ _) = hcat [ - char '\t', - ptext (sLit "bctr") + char '\t', + ptext (sLit "bctr") ] -pprInstr platform (BL lbl _) = hcat [ - ptext (sLit "\tbl\t"), - pprCLabel_asm platform lbl +pprInstr _ (BL lbl _) = hcat [ + ptext (sLit "\tbl\t"), + ppr lbl ] pprInstr _ (BCTRL _) = hcat [ - char '\t', - ptext (sLit "bctrl") + char '\t', + ptext (sLit "bctrl") ] pprInstr platform (ADD reg1 reg2 ri) = pprLogic platform (sLit "add") reg1 reg2 ri pprInstr platform (ADDIS reg1 reg2 imm) = hcat [ - char '\t', - ptext (sLit "addis"), - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2, - ptext (sLit ", "), - pprImm platform imm + char '\t', + ptext (sLit "addis"), + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2, + ptext (sLit ", "), + pprImm platform imm ] pprInstr platform (ADDC reg1 reg2 reg3) = pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3) @@ -552,17 +543,17 @@ pprInstr platform (MULLW_MayOflo reg1 reg2 reg3) = vcat [ ptext (sLit "2, 31, 31") ] ] - -- for some reason, "andi" doesn't exist. - -- we'll use "andi." instead. + -- for some reason, "andi" doesn't exist. + -- we'll use "andi." instead. pprInstr platform (AND reg1 reg2 (RIImm imm)) = hcat [ - char '\t', - ptext (sLit "andi."), - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2, - ptext (sLit ", "), - pprImm platform imm + char '\t', + ptext (sLit "andi."), + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2, + ptext (sLit ", "), + pprImm platform imm ] pprInstr platform (AND reg1 reg2 ri) = pprLogic platform (sLit "and") reg1 reg2 ri @@ -570,31 +561,39 @@ pprInstr platform (OR reg1 reg2 ri) = pprLogic platform (sLit "or") reg1 reg2 ri pprInstr platform (XOR reg1 reg2 ri) = pprLogic platform (sLit "xor") reg1 reg2 ri pprInstr platform (XORIS reg1 reg2 imm) = hcat [ - char '\t', - ptext (sLit "xoris"), - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2, - ptext (sLit ", "), - pprImm platform imm + char '\t', + ptext (sLit "xoris"), + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2, + ptext (sLit ", "), + pprImm platform imm ] pprInstr platform (EXTS sz reg1 reg2) = hcat [ - char '\t', - ptext (sLit "exts"), - pprSize sz, - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2 + char '\t', + ptext (sLit "exts"), + pprSize sz, + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2 ] pprInstr platform (NEG reg1 reg2) = pprUnary platform (sLit "neg") reg1 reg2 pprInstr platform (NOT reg1 reg2) = pprUnary platform (sLit "not") reg1 reg2 pprInstr platform (SLW reg1 reg2 ri) = pprLogic platform (sLit "slw") reg1 reg2 (limitShiftRI ri) + +pprInstr platform (SRW reg1 reg2 (RIImm (ImmInt i))) | i > 31 || i < 0 = + -- Handle the case where we are asked to shift a 32 bit register by + -- less than zero or more than 31 bits. We convert this into a clear + -- of the destination register. + -- Fixes ticket http://hackage.haskell.org/trac/ghc/ticket/5900 + pprInstr platform (XOR reg1 reg2 (RIReg reg2)) pprInstr platform (SRW reg1 reg2 ri) = pprLogic platform (sLit "srw") reg1 reg2 (limitShiftRI ri) + pprInstr platform (SRAW reg1 reg2 ri) = pprLogic platform (sLit "sraw") reg1 reg2 (limitShiftRI ri) pprInstr platform (RLWINM reg1 reg2 sh mb me) = hcat [ ptext (sLit "\trlwinm\t"), @@ -616,14 +615,14 @@ pprInstr platform (FDIV sz reg1 reg2 reg3) = pprBinaryF platform (sLit "fdiv") s pprInstr platform (FNEG reg1 reg2) = pprUnary platform (sLit "fneg") reg1 reg2 pprInstr platform (FCMP reg1 reg2) = hcat [ - char '\t', - ptext (sLit "fcmpu\tcr0, "), - -- Note: we're using fcmpu, not fcmpo - -- The difference is with fcmpo, compare with NaN is an invalid operation. - -- We don't handle invalid fp ops, so we don't care - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2 + char '\t', + ptext (sLit "fcmpu\tcr0, "), + -- Note: we're using fcmpu, not fcmpo + -- The difference is with fcmpo, compare with NaN is an invalid operation. + -- We don't handle invalid fp ops, so we don't care + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2 ] pprInstr platform (FCTIWZ reg1 reg2) = pprUnary platform (sLit "fctiwz") reg1 reg2 @@ -639,17 +638,17 @@ pprInstr _ (CRNOR dst src1 src2) = hcat [ ] pprInstr platform (MFCR reg) = hcat [ - char '\t', - ptext (sLit "mfcr"), - char '\t', - pprReg platform reg + char '\t', + ptext (sLit "mfcr"), + char '\t', + pprReg platform reg ] pprInstr platform (MFLR reg) = hcat [ - char '\t', - ptext (sLit "mflr"), - char '\t', - pprReg platform reg + char '\t', + ptext (sLit "mflr"), + char '\t', + pprReg platform reg ] pprInstr platform (FETCHPC reg) = vcat [ @@ -662,59 +661,59 @@ pprInstr _ LWSYNC = ptext (sLit "\tlwsync") -- pprInstr _ _ = panic "pprInstr (ppc)" -pprLogic :: Platform -> LitString -> Reg -> Reg -> RI -> Doc +pprLogic :: Platform -> LitString -> Reg -> Reg -> RI -> SDoc pprLogic platform op reg1 reg2 ri = hcat [ - char '\t', - ptext op, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i', - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2, - ptext (sLit ", "), - pprRI platform ri + char '\t', + ptext op, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i', + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2, + ptext (sLit ", "), + pprRI platform ri ] -pprUnary :: Platform -> LitString -> Reg -> Reg -> Doc +pprUnary :: Platform -> LitString -> Reg -> Reg -> SDoc pprUnary platform op reg1 reg2 = hcat [ - char '\t', - ptext op, - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2 + char '\t', + ptext op, + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2 ] -pprBinaryF :: Platform -> LitString -> Size -> Reg -> Reg -> Reg -> Doc +pprBinaryF :: Platform -> LitString -> Size -> Reg -> Reg -> Reg -> SDoc pprBinaryF platform op sz reg1 reg2 reg3 = hcat [ - char '\t', - ptext op, - pprFSize sz, - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2, - ptext (sLit ", "), - pprReg platform reg3 + char '\t', + ptext op, + pprFSize sz, + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2, + ptext (sLit ", "), + pprReg platform reg3 ] -pprRI :: Platform -> RI -> Doc +pprRI :: Platform -> RI -> SDoc pprRI platform (RIReg r) = pprReg platform r pprRI platform (RIImm r) = pprImm platform r -pprFSize :: Size -> Doc -pprFSize FF64 = empty -pprFSize FF32 = char 's' -pprFSize _ = panic "PPC.Ppr.pprFSize: no match" +pprFSize :: Size -> SDoc +pprFSize FF64 = empty +pprFSize FF32 = char 's' +pprFSize _ = panic "PPC.Ppr.pprFSize: no match" - -- limit immediate argument for shift instruction to range 0..32 - -- (yes, the maximum is really 32, not 31) + -- limit immediate argument for shift instruction to range 0..31 limitShiftRI :: RI -> RI -limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32) +limitShiftRI (RIImm (ImmInt i)) | i > 31 || i < 0 = + panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed." limitShiftRI x = x diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index 203709e7a3..fe4e06fcc5 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -66,9 +66,7 @@ import OldCmm import CLabel ( CLabel ) import Unique -import Pretty -import Outputable ( panic, SDoc ) -import qualified Outputable +import Outputable import Constants import FastBool import FastTypes @@ -136,10 +134,10 @@ mkVirtualReg u size regDotColor :: RealReg -> SDoc regDotColor reg = case classOfRealReg reg of - RcInteger -> Outputable.text "blue" - RcFloat -> Outputable.text "red" - RcDouble -> Outputable.text "green" - RcDoubleSSE -> Outputable.text "yellow" + RcInteger -> text "blue" + RcFloat -> text "red" + RcDouble -> text "green" + RcDoubleSSE -> text "yellow" -- immediates ------------------------------------------------------------------ @@ -147,7 +145,7 @@ data Imm = ImmInt Int | ImmInteger Integer -- Sigh. | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit Doc -- Simple string + | ImmLit SDoc -- Simple string | ImmIndex CLabel Int | ImmFloat Rational | ImmDouble Rational diff --git a/compiler/nativeGen/PprBase.hs b/compiler/nativeGen/PprBase.hs index b05d6be8a1..34a954b0fc 100644 --- a/compiler/nativeGen/PprBase.hs +++ b/compiler/nativeGen/PprBase.hs @@ -14,8 +14,6 @@ -- for details module PprBase ( - asmSDoc, - pprCLabel_asm, castFloatToWord8Array, castDoubleToWord8Array, floatToBytes, @@ -24,11 +22,6 @@ module PprBase ( where -import qualified Outputable -import Platform -import CLabel -import Pretty - -- castSTUArray has moved to Data.Array.Unsafe #if __GLASGOW_HASKELL__ >= 703 import Data.Array.Unsafe( castSTUArray ) @@ -43,16 +36,6 @@ import Data.Word -asmSDoc :: Outputable.SDoc -> Doc -asmSDoc d - = Outputable.withPprStyleDoc (Outputable.mkCodeStyle Outputable.AsmStyle) d - - -pprCLabel_asm :: Platform -> CLabel -> Doc -pprCLabel_asm platform l - = asmSDoc (pprCLabel platform l) - - -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 5b6b3b28a3..bae3de8f16 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -4,20 +4,13 @@ -- TODO: The colors in graphviz graphs for x86_64 and ppc could be nicer. -- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module RegAlloc.Graph.Main ( - regAlloc -) +module RegAlloc.Graph.Main ( + regAlloc +) where -import qualified GraphColor as Color +import qualified GraphColor as Color import RegAlloc.Liveness import RegAlloc.Graph.Spill import RegAlloc.Graph.SpillClean @@ -43,45 +36,45 @@ import Data.Maybe import Control.Monad -- | The maximum number of build\/spill cycles we'll allow. --- We should only need 3 or 4 cycles tops. --- If we run for any longer than this we're probably in an infinite loop, --- It's probably better just to bail out and report a bug at this stage. -maxSpinCount :: Int -maxSpinCount = 10 +-- We should only need 3 or 4 cycles tops. +-- If we run for any longer than this we're probably in an infinite loop, +-- It's probably better just to bail out and report a bug at this stage. +maxSpinCount :: Int +maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc - :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) - => DynFlags - -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation - -> UniqSet Int -- ^ the set of available spill slots. - -> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information. - -> UniqSM ( [NatCmmDecl statics instr], [RegAllocStats statics instr] ) + :: (Outputable statics, Outputable instr, Instruction instr) + => DynFlags + -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation + -> UniqSet Int -- ^ the set of available spill slots. + -> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information. + -> UniqSM ( [NatCmmDecl statics instr], [RegAllocStats statics instr] ) -- ^ code with registers allocated and stats for each stage of -- allocation - + regAlloc dflags regsFree slotsFree code = do - -- TODO: the regClass function is currently hard coded to the default target - -- architecture. Would prefer to determine this from dflags. - -- There are other uses of targetRegClass later in this module. - let platform = targetPlatform dflags - triv = trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform) - - (code_final, debug_codeGraphs, _) - <- regAlloc_spin dflags 0 - triv - regsFree slotsFree [] code - - return ( code_final - , reverse debug_codeGraphs ) + -- TODO: the regClass function is currently hard coded to the default target + -- architecture. Would prefer to determine this from dflags. + -- There are other uses of targetRegClass later in this module. + let platform = targetPlatform dflags + triv = trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform) + + (code_final, debug_codeGraphs, _) + <- regAlloc_spin dflags 0 + triv + regsFree slotsFree [] code + + return ( code_final + , reverse debug_codeGraphs ) regAlloc_spin :: (Instruction instr, - PlatformOutputable instr, - PlatformOutputable statics) + Outputable instr, + Outputable statics) => DynFlags -> Int -> Color.Triv VirtualReg RegClass RealReg @@ -95,302 +88,302 @@ regAlloc_spin :: (Instruction instr, regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code = do let platform = targetPlatform dflags - -- if any of these dump flags are turned on we want to hang on to - -- intermediate structures in the allocator - otherwise tell the - -- allocator to ditch them early so we don't end up creating space leaks. - let dump = or - [ dopt Opt_D_dump_asm_regalloc_stages dflags - , dopt Opt_D_dump_asm_stats dflags - , dopt Opt_D_dump_asm_conflicts dflags ] - - -- check that we're not running off down the garden path. - when (spinCount > maxSpinCount) - $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded." - ( text "It looks like the register allocator is stuck in an infinite loop." - $$ text "max cycles = " <> int maxSpinCount - $$ text "regsFree = " <> (hcat $ punctuate space $ map ppr - $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree) - $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) - - -- build a conflict graph from the code. - (graph :: Color.Graph VirtualReg RegClass RealReg) - <- {-# SCC "BuildGraph" #-} buildGraph code - - -- VERY IMPORTANT: - -- We really do want the graph to be fully evaluated _before_ we start coloring. - -- If we don't do this now then when the call to Color.colorGraph forces bits of it, - -- the heap will be filled with half evaluated pieces of graph and zillions of apply thunks. - -- - seqGraph graph `seq` return () - - - -- build a map of the cost of spilling each instruction - -- this will only actually be computed if we have to spill something. - let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo - $ map (slurpSpillCostInfo platform) code - - -- the function to choose regs to leave uncolored - let spill = chooseSpill spillCosts - - -- record startup state - let stat1 = - if spinCount == 0 - then Just $ RegAllocStatsStart - { raLiveCmm = code - , raGraph = graph - , raSpillCosts = spillCosts } - else Nothing - - -- try and color the graph - let (graph_colored, rsSpill, rmCoalesce) - = {-# SCC "ColorGraph" #-} - Color.colorGraph - (dopt Opt_RegsIterative dflags) - spinCount - regsFree triv spill graph - - -- rewrite regs in the code that have been coalesced - let patchF reg - | RegVirtual vr <- reg - = case lookupUFM rmCoalesce vr of - Just vr' -> patchF (RegVirtual vr') - Nothing -> reg - - | otherwise - = reg - - let code_coalesced - = map (patchEraseLive patchF) code - - - -- see if we've found a coloring - if isEmptyUniqSet rsSpill - then do - -- if -fasm-lint is turned on then validate the graph - let graph_colored_lint = - if dopt Opt_DoAsmLinting dflags - then Color.validateGraph (text "") - True -- require all nodes to be colored - graph_colored - else graph_colored - - -- patch the registers using the info in the graph - let code_patched = map (patchRegsFromGraph platform graph_colored_lint) code_coalesced - - -- clean out unneeded SPILL/RELOADs - let code_spillclean = map (cleanSpills platform) code_patched - - -- strip off liveness information, - -- and rewrite SPILL/RELOAD pseudos into real instructions along the way - let code_final = map (stripLive platform) code_spillclean - - -- record what happened in this stage for debugging - let stat = - RegAllocStatsColored - { raCode = code - , raGraph = graph - , raGraphColored = graph_colored_lint - , raCoalesced = rmCoalesce - , raCodeCoalesced = code_coalesced - , raPatched = code_patched - , raSpillClean = code_spillclean - , raFinal = code_final - , raSRMs = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean } - - - let statList = - if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs - else [] - - -- space leak avoidance - seqList statList `seq` return () - - return ( code_final - , statList - , graph_colored_lint) - - -- we couldn't find a coloring, time to spill something - else do - -- if -fasm-lint is turned on then validate the graph - let graph_colored_lint = - if dopt Opt_DoAsmLinting dflags - then Color.validateGraph (text "") - False -- don't require nodes to be colored - graph_colored - else graph_colored - - -- spill the uncolored regs - (code_spilled, slotsFree', spillStats) - <- regSpill code_coalesced slotsFree rsSpill - - -- recalculate liveness - -- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency - -- order required by computeLiveness. If they're not in the correct order - -- that function will panic. - code_relive <- mapM (regLiveness platform . reverseBlocksInTops) code_spilled - - -- record what happened in this stage for debugging - let stat = - RegAllocStatsSpill - { raCode = code - , raGraph = graph_colored_lint - , raCoalesced = rmCoalesce - , raSpillStats = spillStats - , raSpillCosts = spillCosts - , raSpilled = code_spilled } - - let statList = - if dump - then [stat] ++ maybeToList stat1 ++ debug_codeGraphs - else [] - - -- space leak avoidance - seqList statList `seq` return () - - regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree' - statList - code_relive + -- if any of these dump flags are turned on we want to hang on to + -- intermediate structures in the allocator - otherwise tell the + -- allocator to ditch them early so we don't end up creating space leaks. + let dump = or + [ dopt Opt_D_dump_asm_regalloc_stages dflags + , dopt Opt_D_dump_asm_stats dflags + , dopt Opt_D_dump_asm_conflicts dflags ] + + -- check that we're not running off down the garden path. + when (spinCount > maxSpinCount) + $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded." + ( text "It looks like the register allocator is stuck in an infinite loop." + $$ text "max cycles = " <> int maxSpinCount + $$ text "regsFree = " <> (hcat $ punctuate space $ map ppr + $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree) + $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) + + -- build a conflict graph from the code. + (graph :: Color.Graph VirtualReg RegClass RealReg) + <- {-# SCC "BuildGraph" #-} buildGraph code + + -- VERY IMPORTANT: + -- We really do want the graph to be fully evaluated _before_ we start coloring. + -- If we don't do this now then when the call to Color.colorGraph forces bits of it, + -- the heap will be filled with half evaluated pieces of graph and zillions of apply thunks. + -- + seqGraph graph `seq` return () + + + -- build a map of the cost of spilling each instruction + -- this will only actually be computed if we have to spill something. + let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo + $ map slurpSpillCostInfo code + + -- the function to choose regs to leave uncolored + let spill = chooseSpill spillCosts + + -- record startup state + let stat1 = + if spinCount == 0 + then Just $ RegAllocStatsStart + { raLiveCmm = code + , raGraph = graph + , raSpillCosts = spillCosts } + else Nothing + + -- try and color the graph + let (graph_colored, rsSpill, rmCoalesce) + = {-# SCC "ColorGraph" #-} + Color.colorGraph + (dopt Opt_RegsIterative dflags) + spinCount + regsFree triv spill graph + + -- rewrite regs in the code that have been coalesced + let patchF reg + | RegVirtual vr <- reg + = case lookupUFM rmCoalesce vr of + Just vr' -> patchF (RegVirtual vr') + Nothing -> reg + + | otherwise + = reg + + let code_coalesced + = map (patchEraseLive patchF) code + + + -- see if we've found a coloring + if isEmptyUniqSet rsSpill + then do + -- if -fasm-lint is turned on then validate the graph + let graph_colored_lint = + if dopt Opt_DoAsmLinting dflags + then Color.validateGraph (text "") + True -- require all nodes to be colored + graph_colored + else graph_colored + + -- patch the registers using the info in the graph + let code_patched = map (patchRegsFromGraph platform graph_colored_lint) code_coalesced + + -- clean out unneeded SPILL/RELOADs + let code_spillclean = map (cleanSpills platform) code_patched + + -- strip off liveness information, + -- and rewrite SPILL/RELOAD pseudos into real instructions along the way + let code_final = map (stripLive platform) code_spillclean + + -- record what happened in this stage for debugging + let stat = + RegAllocStatsColored + { raCode = code + , raGraph = graph + , raGraphColored = graph_colored_lint + , raCoalesced = rmCoalesce + , raCodeCoalesced = code_coalesced + , raPatched = code_patched + , raSpillClean = code_spillclean + , raFinal = code_final + , raSRMs = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean } + + + let statList = + if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else [] + + -- space leak avoidance + seqList statList `seq` return () + + return ( code_final + , statList + , graph_colored_lint) + + -- we couldn't find a coloring, time to spill something + else do + -- if -fasm-lint is turned on then validate the graph + let graph_colored_lint = + if dopt Opt_DoAsmLinting dflags + then Color.validateGraph (text "") + False -- don't require nodes to be colored + graph_colored + else graph_colored + + -- spill the uncolored regs + (code_spilled, slotsFree', spillStats) + <- regSpill code_coalesced slotsFree rsSpill + + -- recalculate liveness + -- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency + -- order required by computeLiveness. If they're not in the correct order + -- that function will panic. + code_relive <- mapM (regLiveness . reverseBlocksInTops) code_spilled + + -- record what happened in this stage for debugging + let stat = + RegAllocStatsSpill + { raCode = code + , raGraph = graph_colored_lint + , raCoalesced = rmCoalesce + , raSpillStats = spillStats + , raSpillCosts = spillCosts + , raSpilled = code_spilled } + + let statList = + if dump + then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else [] + + -- space leak avoidance + seqList statList `seq` return () + + regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree' + statList + code_relive -- | Build a graph from the liveness and coalesce information in this code. -buildGraph - :: Instruction instr - => [LiveCmmDecl statics instr] - -> UniqSM (Color.Graph VirtualReg RegClass RealReg) - +buildGraph + :: Instruction instr + => [LiveCmmDecl statics instr] + -> UniqSM (Color.Graph VirtualReg RegClass RealReg) + buildGraph code = do - -- Slurp out the conflicts and reg->reg moves from this code - let (conflictList, moveList) = - unzip $ map slurpConflicts code + -- Slurp out the conflicts and reg->reg moves from this code + let (conflictList, moveList) = + unzip $ map slurpConflicts code + + -- Slurp out the spill/reload coalesces + let moveList2 = map slurpReloadCoalesce code - -- Slurp out the spill/reload coalesces - let moveList2 = map slurpReloadCoalesce code + -- Add the reg-reg conflicts to the graph + let conflictBag = unionManyBags conflictList + let graph_conflict = foldrBag graphAddConflictSet Color.initGraph conflictBag - -- Add the reg-reg conflicts to the graph - let conflictBag = unionManyBags conflictList - let graph_conflict = foldrBag graphAddConflictSet Color.initGraph conflictBag + -- Add the coalescences edges to the graph. + let moveBag = unionBags (unionManyBags moveList2) (unionManyBags moveList) + let graph_coalesce = foldrBag graphAddCoalesce graph_conflict moveBag - -- Add the coalescences edges to the graph. - let moveBag = unionBags (unionManyBags moveList2) (unionManyBags moveList) - let graph_coalesce = foldrBag graphAddCoalesce graph_conflict moveBag - - return graph_coalesce + return graph_coalesce -- | Add some conflict edges to the graph. --- Conflicts between virtual and real regs are recorded as exclusions. -graphAddConflictSet - :: UniqSet Reg - -> Color.Graph VirtualReg RegClass RealReg - -> Color.Graph VirtualReg RegClass RealReg - +-- Conflicts between virtual and real regs are recorded as exclusions. +graphAddConflictSet + :: UniqSet Reg + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg + graphAddConflictSet set graph - = let virtuals = mkUniqSet - [ vr | RegVirtual vr <- uniqSetToList set ] - - graph1 = Color.addConflicts virtuals classOfVirtualReg graph + = let virtuals = mkUniqSet + [ vr | RegVirtual vr <- uniqSetToList set ] + + graph1 = Color.addConflicts virtuals classOfVirtualReg graph + + graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2) + graph1 + [ (vr, rr) + | RegVirtual vr <- uniqSetToList set + , RegReal rr <- uniqSetToList set] - graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2) - graph1 - [ (vr, rr) - | RegVirtual vr <- uniqSetToList set - , RegReal rr <- uniqSetToList set] + in graph2 - in graph2 - -- | Add some coalesence edges to the graph --- Coalesences between virtual and real regs are recorded as preferences. -graphAddCoalesce - :: (Reg, Reg) - -> Color.Graph VirtualReg RegClass RealReg - -> Color.Graph VirtualReg RegClass RealReg - +-- Coalesences between virtual and real regs are recorded as preferences. +graphAddCoalesce + :: (Reg, Reg) + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg + graphAddCoalesce (r1, r2) graph - | RegReal rr <- r1 - , RegVirtual vr <- r2 - = Color.addPreference (vr, classOfVirtualReg vr) rr graph - - | RegReal rr <- r2 - , RegVirtual vr <- r1 - = Color.addPreference (vr, classOfVirtualReg vr) rr graph - - | RegVirtual vr1 <- r1 - , RegVirtual vr2 <- r2 - = Color.addCoalesce - (vr1, classOfVirtualReg vr1) - (vr2, classOfVirtualReg vr2) - graph - - -- We can't coalesce two real regs, but there could well be existing - -- hreg,hreg moves in the input code. We'll just ignore these - -- for coalescing purposes. - | RegReal _ <- r1 - , RegReal _ <- r2 - = graph + | RegReal rr <- r1 + , RegVirtual vr <- r2 + = Color.addPreference (vr, classOfVirtualReg vr) rr graph + + | RegReal rr <- r2 + , RegVirtual vr <- r1 + = Color.addPreference (vr, classOfVirtualReg vr) rr graph + + | RegVirtual vr1 <- r1 + , RegVirtual vr2 <- r2 + = Color.addCoalesce + (vr1, classOfVirtualReg vr1) + (vr2, classOfVirtualReg vr2) + graph + + -- We can't coalesce two real regs, but there could well be existing + -- hreg,hreg moves in the input code. We'll just ignore these + -- for coalescing purposes. + | RegReal _ <- r1 + , RegReal _ <- r2 + = graph graphAddCoalesce _ _ - = panic "graphAddCoalesce: bogus" - + = panic "graphAddCoalesce: bogus" + -- | Patch registers in code using the reg -> reg mapping in this graph. -patchRegsFromGraph - :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) - => Platform -> Color.Graph VirtualReg RegClass RealReg - -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr +patchRegsFromGraph + :: (Outputable statics, Outputable instr, Instruction instr) + => Platform -> Color.Graph VirtualReg RegClass RealReg + -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr patchRegsFromGraph platform graph code = let - -- a function to lookup the hardreg for a virtual reg from the graph. - patchF reg - -- leave real regs alone. - | RegReal{} <- reg - = reg - - -- this virtual has a regular node in the graph. - | RegVirtual vr <- reg - , Just node <- Color.lookupNode graph vr - = case Color.nodeColor node of - Just color -> RegReal color - Nothing -> RegVirtual vr - - -- no node in the graph for this virtual, bad news. - | otherwise - = pprPanic "patchRegsFromGraph: register mapping failed." - ( text "There is no node in the graph for register " <> ppr reg - $$ pprPlatform platform code - $$ Color.dotGraph - (\_ -> text "white") - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - graph) - - in patchEraseLive patchF code - + -- a function to lookup the hardreg for a virtual reg from the graph. + patchF reg + -- leave real regs alone. + | RegReal{} <- reg + = reg + + -- this virtual has a regular node in the graph. + | RegVirtual vr <- reg + , Just node <- Color.lookupNode graph vr + = case Color.nodeColor node of + Just color -> RegReal color + Nothing -> RegVirtual vr + + -- no node in the graph for this virtual, bad news. + | otherwise + = pprPanic "patchRegsFromGraph: register mapping failed." + ( text "There is no node in the graph for register " <> ppr reg + $$ ppr code + $$ Color.dotGraph + (\_ -> text "white") + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + graph) + + in patchEraseLive patchF code + ----- -- for when laziness just isn't what you wanted... -- seqGraph :: Color.Graph VirtualReg RegClass RealReg -> () -seqGraph graph = seqNodes (eltsUFM (Color.graphMap graph)) +seqGraph graph = seqNodes (eltsUFM (Color.graphMap graph)) seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> () seqNodes ns = case ns of - [] -> () - (n : ns) -> seqNode n `seq` seqNodes ns + [] -> () + (n : ns) -> seqNode n `seq` seqNodes ns seqNode :: Color.Node VirtualReg RegClass RealReg -> () seqNode node - = seqVirtualReg (Color.nodeId node) - `seq` seqRegClass (Color.nodeClass node) - `seq` seqMaybeRealReg (Color.nodeColor node) - `seq` (seqVirtualRegList (uniqSetToList (Color.nodeConflicts node))) - `seq` (seqRealRegList (uniqSetToList (Color.nodeExclusions node))) - `seq` (seqRealRegList (Color.nodePreference node)) - `seq` (seqVirtualRegList (uniqSetToList (Color.nodeCoalesce node))) + = seqVirtualReg (Color.nodeId node) + `seq` seqRegClass (Color.nodeClass node) + `seq` seqMaybeRealReg (Color.nodeColor node) + `seq` (seqVirtualRegList (uniqSetToList (Color.nodeConflicts node))) + `seq` (seqRealRegList (uniqSetToList (Color.nodeExclusions node))) + `seq` (seqRealRegList (Color.nodePreference node)) + `seq` (seqVirtualRegList (uniqSetToList (Color.nodeCoalesce node))) seqVirtualReg :: VirtualReg -> () seqVirtualReg reg = reg `seq` () @@ -404,25 +397,25 @@ seqRegClass c = c `seq` () seqMaybeRealReg :: Maybe RealReg -> () seqMaybeRealReg mr = case mr of - Nothing -> () - Just r -> seqRealReg r + Nothing -> () + Just r -> seqRealReg r seqVirtualRegList :: [VirtualReg] -> () seqVirtualRegList rs = case rs of - [] -> () - (r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs + [] -> () + (r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs seqRealRegList :: [RealReg] -> () seqRealRegList rs = case rs of - [] -> () - (r : rs) -> seqRealReg r `seq` seqRealRegList rs + [] -> () + (r : rs) -> seqRealReg r `seq` seqRealRegList rs seqList :: [a] -> () seqList ls = case ls of - [] -> () - (r : rs) -> r `seq` seqList rs + [] -> () + (r : rs) -> r `seq` seqList rs diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 222e222c75..44e1ed7e0f 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -36,7 +36,6 @@ import UniqFM import UniqSet import Digraph (flattenSCCs) import Outputable -import Platform import State import Data.List (nub, minimumBy) @@ -70,12 +69,11 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) -- for each vreg, the number of times it was written to, read from, -- and the number of instructions it was live on entry to (lifetime) -- -slurpSpillCostInfo :: (PlatformOutputable instr, Instruction instr) - => Platform - -> LiveCmmDecl statics instr +slurpSpillCostInfo :: (Outputable instr, Instruction instr) + => LiveCmmDecl statics instr -> SpillCostInfo -slurpSpillCostInfo platform cmm +slurpSpillCostInfo cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () @@ -104,7 +102,7 @@ slurpSpillCostInfo platform cmm | otherwise = pprPanic "RegSpillCost.slurpSpillCostInfo" - (text "no liveness information on instruction " <> pprPlatform platform instr) + (text "no liveness information on instruction " <> ppr instr) countLIs rsLiveEntry (LiveInstr instr (Just live) : lis) = do diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 69be2f0ed6..32970336ad 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -72,12 +72,12 @@ data RegAllocStats statics instr , raFinal :: [NatCmmDecl statics instr] -- ^ final code , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code -instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutputable (RegAllocStats statics instr) where +instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where - pprPlatform platform (s@RegAllocStatsStart{}) - = text "# Start" + ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform -> + text "# Start" $$ text "# Native code with liveness information." - $$ pprPlatform platform (raLiveCmm s) + $$ ppr (raLiveCmm s) $$ text "" $$ text "# Initial register conflict graph." $$ Color.dotGraph @@ -88,11 +88,11 @@ instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutpu (raGraph s) - pprPlatform platform (s@RegAllocStatsSpill{}) - = text "# Spill" + ppr (s@RegAllocStatsSpill{}) = + text "# Spill" $$ text "# Code with liveness information." - $$ pprPlatform platform (raCode s) + $$ ppr (raCode s) $$ text "" $$ (if (not $ isNullUFM $ raCoalesced s) @@ -106,14 +106,14 @@ instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutpu $$ text "" $$ text "# Code with spills inserted." - $$ pprPlatform platform (raSpilled s) + $$ ppr (raSpilled s) - pprPlatform platform (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) - = text "# Colored" + ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = sdocWithPlatform $ \platform -> + text "# Colored" $$ text "# Code with liveness information." - $$ pprPlatform platform (raCode s) + $$ ppr (raCode s) $$ text "" $$ text "# Register conflict graph (colored)." @@ -132,19 +132,19 @@ instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutpu else empty) $$ text "# Native code after coalescings applied." - $$ pprPlatform platform (raCodeCoalesced s) + $$ ppr (raCodeCoalesced s) $$ text "" $$ text "# Native code after register allocation." - $$ pprPlatform platform (raPatched s) + $$ ppr (raPatched s) $$ text "" $$ text "# Clean out unneeded spill/reloads." - $$ pprPlatform platform (raSpillClean s) + $$ ppr (raSpillClean s) $$ text "" $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ pprPlatform platform (raFinal s) + $$ ppr (raFinal s) $$ text "" $$ text "# Score:" $$ (text "# spills inserted: " <> int spills) diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs index 6067f23ade..6cd3f00024 100644 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -107,13 +107,13 @@ trivColorable trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions | let !cALLOCATABLE_REGS_INTEGER = iUnbox (case platformArch platform of - ArchX86 -> 3 - ArchX86_64 -> 5 - ArchPPC -> 16 - ArchSPARC -> 14 - ArchPPC_64 -> panic "trivColorable ArchPPC_64" - ArchARM _ _ -> panic "trivColorable ArchARM" - ArchUnknown -> panic "trivColorable ArchUnknown") + ArchX86 -> 3 + ArchX86_64 -> 5 + ArchPPC -> 16 + ArchSPARC -> 14 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER (virtualRegSqueeze RcInteger) conflicts @@ -127,13 +127,13 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions | let !cALLOCATABLE_REGS_FLOAT = iUnbox (case platformArch platform of - ArchX86 -> 0 - ArchX86_64 -> 0 - ArchPPC -> 0 - ArchSPARC -> 22 - ArchPPC_64 -> panic "trivColorable ArchPPC_64" - ArchARM _ _ -> panic "trivColorable ArchARM" - ArchUnknown -> panic "trivColorable ArchUnknown") + ArchX86 -> 0 + ArchX86_64 -> 0 + ArchPPC -> 0 + ArchSPARC -> 22 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT (virtualRegSqueeze RcFloat) conflicts @@ -147,13 +147,13 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclus trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions | let !cALLOCATABLE_REGS_DOUBLE = iUnbox (case platformArch platform of - ArchX86 -> 6 - ArchX86_64 -> 0 - ArchPPC -> 26 - ArchSPARC -> 11 - ArchPPC_64 -> panic "trivColorable ArchPPC_64" - ArchARM _ _ -> panic "trivColorable ArchARM" - ArchUnknown -> panic "trivColorable ArchUnknown") + ArchX86 -> 6 + ArchX86_64 -> 0 + ArchPPC -> 26 + ArchSPARC -> 11 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE (virtualRegSqueeze RcDouble) conflicts @@ -167,13 +167,13 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions | let !cALLOCATABLE_REGS_SSE = iUnbox (case platformArch platform of - ArchX86 -> 8 - ArchX86_64 -> 10 - ArchPPC -> 0 - ArchSPARC -> 0 - ArchPPC_64 -> panic "trivColorable ArchPPC_64" - ArchARM _ _ -> panic "trivColorable ArchARM" - ArchUnknown -> panic "trivColorable ArchUnknown") + ArchX86 -> 8 + ArchX86_64 -> 10 + ArchPPC -> 0 + ArchSPARC -> 0 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE (virtualRegSqueeze RcDoubleSSE) conflicts diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index 6fbbd04fff..fd1fd272bd 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -68,11 +68,11 @@ instance FR SPARC.FreeRegs where maxSpillSlots :: Platform -> Int maxSpillSlots platform = case platformArch platform of - ArchX86 -> X86.Instr.maxSpillSlots True -- 32bit - ArchX86_64 -> X86.Instr.maxSpillSlots False -- not 32bit - ArchPPC -> PPC.Instr.maxSpillSlots - ArchSPARC -> SPARC.Instr.maxSpillSlots - ArchARM _ _ -> panic "maxSpillSlots ArchARM" - ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64" - ArchUnknown -> panic "maxSpillSlots ArchUnknown" + ArchX86 -> X86.Instr.maxSpillSlots True -- 32bit + ArchX86_64 -> X86.Instr.maxSpillSlots False -- not 32bit + ArchPPC -> PPC.Instr.maxSpillSlots + ArchSPARC -> SPARC.Instr.maxSpillSlots + ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" + ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64" + ArchUnknown -> panic "maxSpillSlots ArchUnknown" diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index fc0bde44a0..8c38fd1de6 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -127,7 +127,7 @@ import Control.Monad -- Allocate registers regAlloc - :: (PlatformOutputable instr, Instruction instr) + :: (Outputable instr, Instruction instr) => DynFlags -> LiveCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr, Maybe RegAllocStats) @@ -170,7 +170,7 @@ regAlloc _ (CmmProc _ _ _) -- an entry in the block map or it is the first block. -- linearRegAlloc - :: (PlatformOutputable instr, Instruction instr) + :: (Outputable instr, Instruction instr) => DynFlags -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block @@ -180,16 +180,16 @@ linearRegAlloc linearRegAlloc dflags first_id block_live sccs = let platform = targetPlatform dflags in case platformArch platform of - ArchX86 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs - ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs - ArchARM _ _ -> panic "linearRegAlloc ArchARM" - ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" - ArchUnknown -> panic "linearRegAlloc ArchUnknown" + ArchX86 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs + ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs + ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" + ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" linearRegAlloc' - :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + :: (FR freeRegs, Outputable instr, Instruction instr) => Platform -> freeRegs -> BlockId -- ^ the first block @@ -205,7 +205,7 @@ linearRegAlloc' platform initFreeRegs first_id block_live sccs return (blocks, stats) -linearRA_SCCs :: (FR freeRegs, Instruction instr, PlatformOutputable instr) +linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) => Platform -> BlockId -> BlockMap RegSet @@ -241,7 +241,7 @@ linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs) more sanity checking to guard against this eventuality. -} -process :: (FR freeRegs, Instruction instr, PlatformOutputable instr) +process :: (FR freeRegs, Instruction instr, Outputable instr) => Platform -> BlockId -> BlockMap RegSet @@ -286,7 +286,7 @@ process platform first_id block_live (b@(BasicBlock id _) : blocks) -- | Do register allocation on this basic block -- processBlock - :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + :: (FR freeRegs, Outputable instr, Instruction instr) => Platform -> BlockMap RegSet -- ^ live regs on entry to each basic block -> LiveBasicBlock instr -- ^ block to do register allocation on @@ -321,7 +321,7 @@ initBlock id -- | Do allocation for a sequence of instructions. linearRA - :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + :: (FR freeRegs, Outputable instr, Instruction instr) => Platform -> BlockMap RegSet -- ^ map of what vregs are live on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. @@ -350,7 +350,7 @@ linearRA platform block_live accInstr accFixups id (instr:instrs) -- | Do allocation for a single instruction. raInsn - :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + :: (FR freeRegs, Outputable instr, Instruction instr) => Platform -> BlockMap RegSet -- ^ map of what vregs are love on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. @@ -410,11 +410,11 @@ raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live)) (uniqSetToList $ liveDieWrite live) -raInsn platform _ _ _ instr - = pprPanic "raInsn" (text "no match for:" <> pprPlatform platform instr) +raInsn _ _ _ _ instr + = pprPanic "raInsn" (text "no match for:" <> ppr instr) -genRaInsn :: (FR freeRegs, Instruction instr, PlatformOutputable instr) +genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) => Platform -> BlockMap RegSet -> [instr] @@ -554,7 +554,7 @@ releaseRegs regs = do saveClobberedTemps - :: (PlatformOutputable instr, Instruction instr) + :: (Outputable instr, Instruction instr) => Platform -> [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn @@ -647,7 +647,7 @@ data SpillLoc = ReadMem StackSlot -- reading from register only in memory -- the list of free registers and free stack slots. allocateRegsAndSpill - :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + :: (FR freeRegs, Outputable instr, Instruction instr) => Platform -> Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out @@ -692,7 +692,7 @@ allocateRegsAndSpill platform reading keep spills alloc (r:rs) -- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY -allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, PlatformOutputable instr) +allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) => Platform -> Bool -> [VirtualReg] @@ -798,7 +798,7 @@ newLocation _ my_reg = InReg my_reg -- | Load up a spilled temporary if we need to (read from memory). loadTemp - :: (PlatformOutputable instr, Instruction instr) + :: (Outputable instr, Instruction instr) => Platform -> VirtualReg -- the temp being loaded -> SpillLoc -- the current location of this temp diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 0212e8cb16..5ceee3e242 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -171,13 +171,13 @@ type LiveBasicBlock instr = GenBasicBlock (LiveInstr instr) -instance PlatformOutputable instr - => PlatformOutputable (InstrSR instr) where +instance Outputable instr + => Outputable (InstrSR instr) where - pprPlatform platform (Instr realInstr) - = pprPlatform platform realInstr + ppr (Instr realInstr) + = ppr realInstr - pprPlatform _ (SPILL reg slot) + ppr (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), char ' ', @@ -185,7 +185,7 @@ instance PlatformOutputable instr comma, ptext (sLit "SLOT") <> parens (int slot)] - pprPlatform _ (RELOAD slot reg) + ppr (RELOAD slot reg) = hcat [ ptext (sLit "\tRELOAD"), char ' ', @@ -193,14 +193,14 @@ instance PlatformOutputable instr comma, ppr reg] -instance PlatformOutputable instr - => PlatformOutputable (LiveInstr instr) where +instance Outputable instr + => Outputable (LiveInstr instr) where - pprPlatform platform (LiveInstr instr Nothing) - = pprPlatform platform instr + ppr (LiveInstr instr Nothing) + = ppr instr - pprPlatform platform (LiveInstr instr (Just live)) - = pprPlatform platform instr + ppr (LiveInstr instr (Just live)) + = ppr instr $$ (nest 8 $ vcat [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) @@ -213,9 +213,9 @@ instance PlatformOutputable instr | isEmptyUniqSet regs = empty | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) -instance PlatformOutputable LiveInfo where - pprPlatform platform (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) - = (maybe empty (pprPlatform platform) mb_static) +instance Outputable LiveInfo where + ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) + = (maybe empty (ppr) mb_static) $$ text "# firstId = " <> ppr firstId $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) @@ -460,9 +460,7 @@ slurpReloadCoalesce live -- | Strip away liveness information, yielding NatCmmDecl stripLive - :: (PlatformOutputable statics, - PlatformOutputable instr, - Instruction instr) + :: (Outputable statics, Outputable instr, Instruction instr) => Platform -> LiveCmmDecl statics instr -> NatCmmDecl statics instr @@ -470,9 +468,7 @@ stripLive stripLive platform live = stripCmm live - where stripCmm :: (PlatformOutputable statics, - PlatformOutputable instr, - Instruction instr) + where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) => LiveCmmDecl statics instr -> NatCmmDecl statics instr stripCmm (CmmData sec ds) = CmmData sec ds stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) @@ -493,7 +489,7 @@ stripLive platform live -- If the proc has blocks but we don't know what the first one was, then we're dead. stripCmm proc - = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprPlatform platform proc) + = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) -- | Strip away liveness information from a basic block, -- and make real spill instructions out of SPILL, RELOAD pseudos along the way. @@ -666,25 +662,24 @@ sccBlocks blocks = stronglyConnCompFromEdgedVertices graph -- Annotate code with register liveness information -- regLiveness - :: (PlatformOutputable instr, Instruction instr) - => Platform - -> LiveCmmDecl statics instr + :: (Outputable instr, Instruction instr) + => LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr) -regLiveness _ (CmmData i d) - = returnUs $ CmmData i d +regLiveness (CmmData i d) + = return $ CmmData i d -regLiveness _ (CmmProc info lbl []) +regLiveness (CmmProc info lbl []) | LiveInfo static mFirst _ _ <- info - = returnUs $ CmmProc + = return $ CmmProc (LiveInfo static mFirst (Just mapEmpty) Map.empty) lbl [] -regLiveness platform (CmmProc info lbl sccs) +regLiveness (CmmProc info lbl sccs) | LiveInfo static mFirst _ liveSlotsOnEntry <- info - = let (ann_sccs, block_live) = computeLiveness platform sccs + = let (ann_sccs, block_live) = computeLiveness sccs - in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) + in return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) lbl ann_sccs @@ -746,21 +741,20 @@ reverseBlocksInTops top -- want for the next pass. -- computeLiveness - :: (PlatformOutputable instr, Instruction instr) - => Platform - -> [SCC (LiveBasicBlock instr)] + :: (Outputable instr, Instruction instr) + => [SCC (LiveBasicBlock instr)] -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers -- which are "dead after this instruction". BlockMap RegSet) -- blocks annontated with set of live registers -- on entry to the block. -computeLiveness platform sccs +computeLiveness sccs = case checkIsReverseDependent sccs of Nothing -> livenessSCCs emptyBlockMap [] sccs Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" (vcat [ text "SCCs aren't in reverse dependent order" , text "bad blockId" <+> ppr bad - , pprPlatform platform sccs]) + , ppr sccs]) livenessSCCs :: Instruction instr diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 4c295f11d5..e0656db9db 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -6,18 +6,11 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module SPARC.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - InstrBlock -) +module SPARC.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) where @@ -26,18 +19,19 @@ where #include "../includes/MachDeps.h" -- NCG stuff: +import SPARC.Base import SPARC.CodeGen.Sanity import SPARC.CodeGen.Amode import SPARC.CodeGen.CondCode import SPARC.CodeGen.Gen64 import SPARC.CodeGen.Gen32 -import SPARC.CodeGen.CCall import SPARC.CodeGen.Base -import SPARC.Ppr () +import SPARC.Ppr () import SPARC.Instr import SPARC.Imm import SPARC.AddrMode import SPARC.Regs +import SPARC.Stack import Instruction import Size import NCGMonad @@ -45,27 +39,29 @@ import NCGMonad -- Our intermediate code: import BlockId import OldCmm +import PIC +import Reg import CLabel +import CPrim -- The rest: +import BasicTypes import DynFlags -import StaticFlags ( opt_PIC ) +import FastString +import StaticFlags ( opt_PIC ) import OrdList import Outputable import Platform import Unique -import Control.Monad ( mapAndUnzipM ) +import Control.Monad ( mapAndUnzipM ) -- | Top level code generation cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) - = do - dflags <- getDynFlags - let platform = targetPlatform dflags - (nat_blocks,statics) <- mapAndUnzipM (basicBlockCodeGen platform) blocks + = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks let proc = CmmProc info lab (ListGraph $ concat nat_blocks) let tops = proc : concat statics @@ -77,34 +73,33 @@ cmmTopCodeGen (CmmData sec dat) = do -- | Do code generation on a single block of CMM code. --- code generation may introduce new basic block boundaries, which --- are indicated by the NEWBLOCK instruction. We must split up the --- instruction stream into basic blocks again. Also, we extract --- LDATAs here too. -basicBlockCodeGen :: Platform - -> CmmBasicBlock +-- code generation may introduce new basic block boundaries, which +-- are indicated by the NEWBLOCK instruction. We must split up the +-- instruction stream into basic blocks again. Also, we extract +-- LDATAs here too. +basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] , [NatCmmDecl CmmStatics Instr]) -basicBlockCodeGen platform cmm@(BasicBlock id stmts) = do +basicBlockCodeGen cmm@(BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts let - (top,other_blocks,statics) - = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) + (top,other_blocks,statics) + = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) - -- do intra-block sanity checking - blocksChecked - = map (checkBlock platform cmm) - $ BasicBlock id top : other_blocks + -- do intra-block sanity checking + blocksChecked + = map (checkBlock cmm) + $ BasicBlock id top : other_blocks return (blocksChecked, statics) @@ -118,32 +113,32 @@ stmtsToInstrs stmts stmtToInstrs :: CmmStmt -> NatM InstrBlock stmtToInstrs stmt = case stmt of - CmmNop -> return nilOL + CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src - | isFloatType ty -> assignReg_FltCode size reg src - | isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg - size = cmmTypeSize ty + | isFloatType ty -> assignReg_FltCode size reg src + | isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode size reg src + where ty = cmmRegType reg + size = cmmTypeSize ty CmmStore addr src - | isFloatType ty -> assignMem_FltCode size addr src - | isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src - size = cmmTypeSize ty + | isFloatType ty -> assignMem_FltCode size addr src + | isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode size addr src + where ty = cmmExprType src + size = cmmTypeSize ty CmmCall target result_regs args _ -> genCCall target result_regs args - CmmBranch id -> genBranch id - CmmCondBranch arg id -> genCondJump id arg - CmmSwitch arg ids -> genSwitch arg ids - CmmJump arg _ -> genJump arg + CmmBranch id -> genBranch id + CmmCondBranch arg id -> genCondJump id arg + CmmSwitch arg ids -> genSwitch arg ids + CmmJump arg _ -> genJump arg - CmmReturn + CmmReturn -> panic "stmtToInstrs: return statement should have been cps'd away" @@ -198,8 +193,8 @@ assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock assignReg_IntCode _ reg src = do r <- getRegister src return $ case r of - Any _ code -> code dst - Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst + Any _ code -> code dst + Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst where dst = getRegisterReg reg @@ -212,23 +207,23 @@ assignMem_FltCode pk addr src = do (src__2, code2) <- getSomeReg src tmp1 <- getNewRegNat pk let - pk__2 = cmmExprType src - code__2 = code1 `appOL` code2 `appOL` - if sizeToWidth pk == typeWidth pk__2 + pk__2 = cmmExprType src + code__2 = code1 `appOL` code2 `appOL` + if sizeToWidth pk == typeWidth pk__2 then unitOL (ST pk src__2 dst__2) - else toOL [ FxTOy (cmmTypeSize pk__2) pk src__2 tmp1 - , ST pk tmp1 dst__2] + else toOL [ FxTOy (cmmTypeSize pk__2) pk src__2 tmp1 + , ST pk tmp1 dst__2] return code__2 -- Floating point assignment to a register/temporary assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock assignReg_FltCode pk dstCmmReg srcCmmExpr = do srcRegister <- getRegister srcCmmExpr - let dstReg = getRegisterReg dstCmmReg + let dstReg = getRegisterReg dstCmmReg return $ case srcRegister of - Any _ code -> code dstReg - Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg + Any _ code -> code dstReg + Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg @@ -243,7 +238,7 @@ genJump (CmmLit (CmmLabel lbl)) genJump tree = do (target, code) <- getSomeReg tree - return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) + return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) -- ----------------------------------------------------------------------------- -- Unconditional branches @@ -272,7 +267,7 @@ allocator. genCondJump - :: BlockId -- the branch target + :: BlockId -- the branch target -> CmmExpr -- the condition on which to branch -> NatM InstrBlock @@ -281,7 +276,7 @@ genCondJump genCondJump bid bool = do CondCode is_float cond code <- getCondCode bool return ( - code `appOL` + code `appOL` toOL ( if is_float then [NOP, BF cond False bid, NOP] @@ -296,34 +291,358 @@ genCondJump bid bool = do genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock genSwitch expr ids - | opt_PIC - = error "MachCodeGen: sparc genSwitch PIC not finished\n" - - | otherwise - = do (e_reg, e_code) <- getSomeReg expr - - base_reg <- getNewRegNat II32 - offset_reg <- getNewRegNat II32 - dst <- getNewRegNat II32 - - label <- getNewLabelNat - - return $ e_code `appOL` - toOL - [ -- load base of jump table - SETHI (HI (ImmCLbl label)) base_reg - , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg - - -- the addrs in the table are 32 bits wide.. - , SLL e_reg (RIImm $ ImmInt 2) offset_reg - - -- load and jump to the destination - , LD II32 (AddrRegReg base_reg offset_reg) dst - , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label - , NOP ] + | opt_PIC + = error "MachCodeGen: sparc genSwitch PIC not finished\n" + + | otherwise + = do (e_reg, e_code) <- getSomeReg expr + + base_reg <- getNewRegNat II32 + offset_reg <- getNewRegNat II32 + dst <- getNewRegNat II32 + + label <- getNewLabelNat + + return $ e_code `appOL` + toOL + [ -- load base of jump table + SETHI (HI (ImmCLbl label)) base_reg + , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg + + -- the addrs in the table are 32 bits wide.. + , SLL e_reg (RIImm $ ImmInt 2) offset_reg + + -- load and jump to the destination + , LD II32 (AddrRegReg base_reg offset_reg) dst + , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label + , NOP ] generateJumpTableForInstr :: Instr -> Maybe (NatCmmDecl CmmStatics Instr) generateJumpTableForInstr (JMP_TBL _ ids label) = - let jumpTable = map jumpTableEntry ids - in Just (CmmData ReadOnlyData (Statics label jumpTable)) + let jumpTable = map jumpTableEntry ids + in Just (CmmData ReadOnlyData (Statics label jumpTable)) generateJumpTableForInstr _ = Nothing + + + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +{- + Now the biggest nightmare---calls. Most of the nastiness is buried in + @get_arg@, which moves the arguments to the correct registers/stack + locations. Apart from that, the code is easy. + + The SPARC calling convention is an absolute + nightmare. The first 6x32 bits of arguments are mapped into + %o0 through %o5, and the remaining arguments are dumped to the + stack, beginning at [%sp+92]. (Note that %o6 == %sp.) + + If we have to put args on the stack, move %o6==%sp down by + the number of words to go on the stack, to ensure there's enough space. + + According to Fraser and Hanson's lcc book, page 478, fig 17.2, + 16 words above the stack pointer is a word for the address of + a structure return value. I use this as a temporary location + for moving values from float to int regs. Certainly it isn't + safe to put anything in the 16 words starting at %sp, since + this area can get trashed at any time due to window overflows + caused by signal handlers. + + A final complication (if the above isn't enough) is that + we can't blithely calculate the arguments one by one into + %o0 .. %o5. Consider the following nested calls: + + fff a (fff b c) + + Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately + the inner call will itself use %o0, which trashes the value put there + in preparation for the outer call. Upshot: we need to calculate the + args into temporary regs, and move those to arg regs or onto the + stack only immediately prior to the call proper. Sigh. +-} + +genCCall + :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + + + +-- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream +-- are guaranteed to take place before writes afterwards (unlike on PowerPC). +-- Ref: Section 8.4 of the SPARC V9 Architecture manual. +-- +-- In the SPARC case we don't need a barrier. +-- +genCCall (CmmPrim (MO_WriteBarrier) _) _ _ + = do return nilOL + +genCCall (CmmPrim _ (Just stmts)) _ _ + = stmtsToInstrs stmts + +genCCall target dest_regs argsAndHints + = do + -- need to remove alignment information + let argsAndHints' | CmmPrim mop _ <- target, + (mop == MO_Memcpy || + mop == MO_Memset || + mop == MO_Memmove) + = init argsAndHints + + | otherwise + = argsAndHints + + -- strip hints from the arg regs + let args :: [CmmExpr] + args = map hintlessCmm argsAndHints' + + + -- work out the arguments, and assign them to integer regs + argcode_and_vregs <- mapM arg_to_int_vregs args + let (argcodes, vregss) = unzip argcode_and_vregs + let vregs = concat vregss + + let n_argRegs = length allArgRegs + let n_argRegs_used = min (length vregs) n_argRegs + + + -- deal with static vs dynamic call targets + callinsns <- case target of + CmmCallee (CmmLit (CmmLabel lbl)) _ -> + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + + CmmCallee expr _ + -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + + CmmPrim mop _ + -> do res <- outOfLineMachOp mop + lblOrMopExpr <- case res of + Left lbl -> do + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + + Right mopExpr -> do + (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + + return lblOrMopExpr + + let argcode = concatOL argcodes + + let (move_sp_down, move_sp_up) + = let diff = length vregs - n_argRegs + nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment + in if nn <= 0 + then (nilOL, nilOL) + else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) + + let transfer_code + = toOL (move_final vregs allArgRegs extraStackArgsHere) + + dflags <- getDynFlags + return + $ argcode `appOL` + move_sp_down `appOL` + transfer_code `appOL` + callinsns `appOL` + unitOL NOP `appOL` + move_sp_up `appOL` + assign_code (targetPlatform dflags) dest_regs + + +-- | Generate code to calculate an argument, and move it into one +-- or two integer vregs. +arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) +arg_to_int_vregs arg + + -- If the expr produces a 64 bit int, then we can just use iselExpr64 + | isWord64 (cmmExprType arg) + = do (ChildCode64 code r_lo) <- iselExpr64 arg + let r_hi = getHiVRegFromLo r_lo + return (code, [r_hi, r_lo]) + + | otherwise + = do (src, code) <- getSomeReg arg + let pk = cmmExprType arg + + case cmmTypeSize pk of + + -- Load a 64 bit float return value into two integer regs. + FF64 -> do + v1 <- getNewRegNat II32 + v2 <- getNewRegNat II32 + + let code2 = + code `snocOL` + FMOV FF64 src f0 `snocOL` + ST FF32 f0 (spRel 16) `snocOL` + LD II32 (spRel 16) v1 `snocOL` + ST FF32 f1 (spRel 16) `snocOL` + LD II32 (spRel 16) v2 + + return (code2, [v1,v2]) + + -- Load a 32 bit float return value into an integer reg + FF32 -> do + v1 <- getNewRegNat II32 + + let code2 = + code `snocOL` + ST FF32 src (spRel 16) `snocOL` + LD II32 (spRel 16) v1 + + return (code2, [v1]) + + -- Move an integer return value into its destination reg. + _ -> do + v1 <- getNewRegNat II32 + + let code2 = + code `snocOL` + OR False g0 (RIReg src) v1 + + return (code2, [v1]) + + +-- | Move args from the integer vregs into which they have been +-- marshalled, into %o0 .. %o5, and the rest onto the stack. +-- +move_final :: [Reg] -> [Reg] -> Int -> [Instr] + +-- all args done +move_final [] _ _ + = [] + +-- out of aregs; move to stack +move_final (v:vs) [] offset + = ST II32 v (spRel offset) + : move_final vs [] (offset+1) + +-- move into an arg (%o[0..5]) reg +move_final (v:vs) (a:az) offset + = OR False g0 (RIReg v) a + : move_final vs az offset + + +-- | Assign results returned from the call into their +-- desination regs. +-- +assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr + +assign_code _ [] = nilOL + +assign_code platform [CmmHinted dest _hint] + = let rep = localRegType dest + width = typeWidth rep + r_dest = getRegisterReg (CmmLocal dest) + + result + | isFloatType rep + , W32 <- width + = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest + + | isFloatType rep + , W64 <- width + = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest + + | not $ isFloatType rep + , W32 <- width + = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest + + | not $ isFloatType rep + , W64 <- width + , r_dest_hi <- getHiVRegFromLo r_dest + = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi + , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] + + | otherwise + = panic "SPARC.CodeGen.GenCCall: no match" + + in result + +assign_code _ _ + = panic "SPARC.CodeGen.GenCCall: no match" + + + +-- | Generate a call to implement an out-of-line floating point operation +outOfLineMachOp + :: CallishMachOp + -> NatM (Either CLabel CmmExpr) + +outOfLineMachOp mop + = do let functionName + = outOfLineMachOp_table mop + + dflags <- getDynFlags + mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference + $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction + + let mopLabelOrExpr + = case mopExpr of + CmmLit (CmmLabel lbl) -> Left lbl + _ -> Right mopExpr + + return mopLabelOrExpr + + +-- | Decide what C function to use to implement a CallishMachOp +-- +outOfLineMachOp_table + :: CallishMachOp + -> FastString + +outOfLineMachOp_table mop + = case mop of + MO_F32_Exp -> fsLit "expf" + MO_F32_Log -> fsLit "logf" + MO_F32_Sqrt -> fsLit "sqrtf" + MO_F32_Pwr -> fsLit "powf" + + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + + MO_F64_Exp -> fsLit "exp" + MO_F64_Log -> fsLit "log" + MO_F64_Sqrt -> fsLit "sqrt" + MO_F64_Pwr -> fsLit "pow" + + MO_F64_Sin -> fsLit "sin" + MO_F64_Cos -> fsLit "cos" + MO_F64_Tan -> fsLit "tan" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + + MO_Memcpy -> fsLit "memcpy" + MO_Memset -> fsLit "memset" + MO_Memmove -> fsLit "memmove" + + MO_PopCnt w -> fsLit $ popCntLabel w + + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + where unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs deleted file mode 100644 index 91351a2e18..0000000000 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ /dev/null @@ -1,343 +0,0 @@ --- | Generating C calls - -module SPARC.CodeGen.CCall ( - genCCall -) - -where - -import SPARC.CodeGen.Gen64 -import SPARC.CodeGen.Gen32 -import SPARC.CodeGen.Base -import SPARC.Stack -import SPARC.Instr -import SPARC.Imm -import SPARC.Regs -import SPARC.Base -import CPrim -import NCGMonad -import PIC -import Instruction -import Size -import Reg - -import OldCmm -import CLabel -import BasicTypes - -import OrdList -import DynFlags -import FastString -import Outputable -import Platform - -{- - Now the biggest nightmare---calls. Most of the nastiness is buried in - @get_arg@, which moves the arguments to the correct registers/stack - locations. Apart from that, the code is easy. - - The SPARC calling convention is an absolute - nightmare. The first 6x32 bits of arguments are mapped into - %o0 through %o5, and the remaining arguments are dumped to the - stack, beginning at [%sp+92]. (Note that %o6 == %sp.) - - If we have to put args on the stack, move %o6==%sp down by - the number of words to go on the stack, to ensure there's enough space. - - According to Fraser and Hanson's lcc book, page 478, fig 17.2, - 16 words above the stack pointer is a word for the address of - a structure return value. I use this as a temporary location - for moving values from float to int regs. Certainly it isn't - safe to put anything in the 16 words starting at %sp, since - this area can get trashed at any time due to window overflows - caused by signal handlers. - - A final complication (if the above isn't enough) is that - we can't blithely calculate the arguments one by one into - %o0 .. %o5. Consider the following nested calls: - - fff a (fff b c) - - Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately - the inner call will itself use %o0, which trashes the value put there - in preparation for the outer call. Upshot: we need to calculate the - args into temporary regs, and move those to arg regs or onto the - stack only immediately prior to the call proper. Sigh. --} - -genCCall - :: CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) - -> NatM InstrBlock - - - --- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream --- are guaranteed to take place before writes afterwards (unlike on PowerPC). --- Ref: Section 8.4 of the SPARC V9 Architecture manual. --- --- In the SPARC case we don't need a barrier. --- -genCCall (CmmPrim (MO_WriteBarrier)) _ _ - = do return nilOL - -genCCall target dest_regs argsAndHints - = do - -- need to remove alignment information - let argsAndHints' | (CmmPrim mop) <- target, - (mop == MO_Memcpy || - mop == MO_Memset || - mop == MO_Memmove) - = init argsAndHints - - | otherwise - = argsAndHints - - -- strip hints from the arg regs - let args :: [CmmExpr] - args = map hintlessCmm argsAndHints' - - - -- work out the arguments, and assign them to integer regs - argcode_and_vregs <- mapM arg_to_int_vregs args - let (argcodes, vregss) = unzip argcode_and_vregs - let vregs = concat vregss - - let n_argRegs = length allArgRegs - let n_argRegs_used = min (length vregs) n_argRegs - - - -- deal with static vs dynamic call targets - callinsns <- case target of - CmmCallee (CmmLit (CmmLabel lbl)) _ -> - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - CmmCallee expr _ - -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - CmmPrim mop - -> do res <- outOfLineMachOp mop - lblOrMopExpr <- case res of - Left lbl -> do - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - Right mopExpr -> do - (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - return lblOrMopExpr - - let argcode = concatOL argcodes - - let (move_sp_down, move_sp_up) - = let diff = length vregs - n_argRegs - nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment - in if nn <= 0 - then (nilOL, nilOL) - else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) - - let transfer_code - = toOL (move_final vregs allArgRegs extraStackArgsHere) - - dflags <- getDynFlags - return - $ argcode `appOL` - move_sp_down `appOL` - transfer_code `appOL` - callinsns `appOL` - unitOL NOP `appOL` - move_sp_up `appOL` - assign_code (targetPlatform dflags) dest_regs - - --- | Generate code to calculate an argument, and move it into one --- or two integer vregs. -arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs arg - - -- If the expr produces a 64 bit int, then we can just use iselExpr64 - | isWord64 (cmmExprType arg) - = do (ChildCode64 code r_lo) <- iselExpr64 arg - let r_hi = getHiVRegFromLo r_lo - return (code, [r_hi, r_lo]) - - | otherwise - = do (src, code) <- getSomeReg arg - let pk = cmmExprType arg - - case cmmTypeSize pk of - - -- Load a 64 bit float return value into two integer regs. - FF64 -> do - v1 <- getNewRegNat II32 - v2 <- getNewRegNat II32 - - let code2 = - code `snocOL` - FMOV FF64 src f0 `snocOL` - ST FF32 f0 (spRel 16) `snocOL` - LD II32 (spRel 16) v1 `snocOL` - ST FF32 f1 (spRel 16) `snocOL` - LD II32 (spRel 16) v2 - - return (code2, [v1,v2]) - - -- Load a 32 bit float return value into an integer reg - FF32 -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - ST FF32 src (spRel 16) `snocOL` - LD II32 (spRel 16) v1 - - return (code2, [v1]) - - -- Move an integer return value into its destination reg. - _ -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - OR False g0 (RIReg src) v1 - - return (code2, [v1]) - - --- | Move args from the integer vregs into which they have been --- marshalled, into %o0 .. %o5, and the rest onto the stack. --- -move_final :: [Reg] -> [Reg] -> Int -> [Instr] - --- all args done -move_final [] _ _ - = [] - --- out of aregs; move to stack -move_final (v:vs) [] offset - = ST II32 v (spRel offset) - : move_final vs [] (offset+1) - --- move into an arg (%o[0..5]) reg -move_final (v:vs) (a:az) offset - = OR False g0 (RIReg v) a - : move_final vs az offset - - --- | Assign results returned from the call into their --- desination regs. --- -assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr - -assign_code _ [] = nilOL - -assign_code platform [CmmHinted dest _hint] - = let rep = localRegType dest - width = typeWidth rep - r_dest = getRegisterReg (CmmLocal dest) - - result - | isFloatType rep - , W32 <- width - = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest - - | isFloatType rep - , W64 <- width - = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest - - | not $ isFloatType rep - , W32 <- width - = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest - - | not $ isFloatType rep - , W64 <- width - , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi - , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] - - | otherwise - = panic "SPARC.CodeGen.GenCCall: no match" - - in result - -assign_code _ _ - = panic "SPARC.CodeGen.GenCCall: no match" - - - --- | Generate a call to implement an out-of-line floating point operation -outOfLineMachOp - :: CallishMachOp - -> NatM (Either CLabel CmmExpr) - -outOfLineMachOp mop - = do let functionName - = outOfLineMachOp_table mop - - dflags <- getDynFlags - mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference - $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction - - let mopLabelOrExpr - = case mopExpr of - CmmLit (CmmLabel lbl) -> Left lbl - _ -> Right mopExpr - - return mopLabelOrExpr - - --- | Decide what C function to use to implement a CallishMachOp --- -outOfLineMachOp_table - :: CallishMachOp - -> FastString - -outOfLineMachOp_table mop - = case mop of - MO_F32_Exp -> fsLit "expf" - MO_F32_Log -> fsLit "logf" - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Pwr -> fsLit "powf" - - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" - MO_F32_Tan -> fsLit "tanf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - - MO_F64_Exp -> fsLit "exp" - MO_F64_Log -> fsLit "log" - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Pwr -> fsLit "pow" - - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" - MO_F64_Tan -> fsLit "tan" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - - MO_Memcpy -> fsLit "memcpy" - MO_Memset -> fsLit "memset" - MO_Memmove -> fsLit "memmove" - - MO_PopCnt w -> fsLit $ popCntLabel w - - MO_WriteBarrier -> - panic $ "outOfLineCmmOp: MO_WriteBarrier not supported here" - MO_Touch -> - panic $ "outOfLineCmmOp: MO_Touch not supported here" - diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index f02b7a45a8..74f20196df 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -26,7 +26,6 @@ import Size import OldCmm -import DynFlags import OrdList import Outputable @@ -62,11 +61,9 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _ -> do dflags <- getDynFlags - pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y])) + _ -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y])) -getCondCode other = do dflags <- getDynFlags - pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) other) +getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 5352281296..654875c497 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -201,8 +201,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) iselExpr64 expr - = do dflags <- getDynFlags - pprPanic "iselExpr64(sparc)" (pprPlatform (targetPlatform dflags) expr) + = pprPanic "iselExpr64(sparc)" (ppr expr) diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index 78dbb1b493..7eb8bb4a53 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -22,17 +22,15 @@ import Instruction import OldCmm import Outputable -import Platform -- | Enforce intra-block invariants. -- -checkBlock :: Platform - -> CmmBasicBlock +checkBlock :: CmmBasicBlock -> NatBasicBlock Instr -> NatBasicBlock Instr -checkBlock platform cmm block@(BasicBlock _ instrs) +checkBlock cmm block@(BasicBlock _ instrs) | checkBlockInstrs instrs = block @@ -40,9 +38,9 @@ checkBlock platform cmm block@(BasicBlock _ instrs) = pprPanic ("SPARC.CodeGen: bad block\n") ( vcat [ text " -- cmm -----------------\n" - , pprPlatform platform cmm + , ppr cmm , text " -- native code ---------\n" - , pprPlatform platform block ]) + , ppr block ]) checkBlockInstrs :: [Instr] -> Bool diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs index 74dc8e0041..eacc905122 100644 --- a/compiler/nativeGen/SPARC/Imm.hs +++ b/compiler/nativeGen/SPARC/Imm.hs @@ -19,8 +19,7 @@ import OldCmm import CLabel import BlockId -import Pretty -import Panic +import Outputable -- | An immediate value. -- Not all of these are directly representable by the machine. @@ -36,7 +35,7 @@ data Imm | ImmCLbl CLabel -- Simple string - | ImmLit Doc + | ImmLit SDoc | ImmIndex CLabel Int | ImmFloat Rational | ImmDouble Rational diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 5c811c5e3a..7fe1975f9d 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -45,17 +45,15 @@ import OldPprCmm() import CLabel import Unique ( Uniquable(..), pprUnique ) -import qualified Outputable -import Outputable (PlatformOutputable, panic) +import Outputable import Platform -import Pretty import FastString import Data.Word -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: Platform -> NatCmmDecl CmmStatics Instr -> Doc +pprNatCmmDecl :: Platform -> NatCmmDecl CmmStatics Instr -> SDoc pprNatCmmDecl platform (CmmData section dats) = pprSectionHeader section $$ pprDatas platform dats @@ -72,7 +70,7 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG pprSectionHeader Text $$ ( (if platformHasSubsectionsViaSymbols platform - then pprCLabel_asm platform (mkDeadStripPreventer info_lbl) <> char ':' + then pprCLabel platform (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ vcat (map (pprData platform) info) $$ pprLabel platform info_lbl @@ -89,70 +87,70 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). text "\t.long " - <+> pprCLabel_asm platform info_lbl + <+> pprCLabel platform info_lbl <+> char '-' - <+> pprCLabel_asm platform (mkDeadStripPreventer info_lbl) + <+> pprCLabel platform (mkDeadStripPreventer info_lbl) else empty) -pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc +pprBasicBlock :: Platform -> NatBasicBlock Instr -> SDoc pprBasicBlock platform (BasicBlock blockid instrs) = pprLabel platform (mkAsmTempLabel (getUnique blockid)) $$ vcat (map (pprInstr platform) instrs) -pprDatas :: Platform -> CmmStatics -> Doc +pprDatas :: Platform -> CmmStatics -> SDoc pprDatas platform (Statics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: Platform -> CmmStatic -> Doc +pprData :: Platform -> CmmStatic -> SDoc pprData _ (CmmString str) = pprASCII str pprData _ (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes pprData platform (CmmStaticLit lit) = pprDataItem platform lit -pprGloblDecl :: Platform -> CLabel -> Doc +pprGloblDecl :: Platform -> CLabel -> SDoc pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".global ") <> pprCLabel_asm platform lbl + | otherwise = ptext (sLit ".global ") <> pprCLabel platform lbl -pprTypeAndSizeDecl :: Platform -> CLabel -> Doc +pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc pprTypeAndSizeDecl platform lbl | platformOS platform == OSLinux && externallyVisibleCLabel lbl = ptext (sLit ".type ") <> - pprCLabel_asm platform lbl <> ptext (sLit ", @object") + pprCLabel platform lbl <> ptext (sLit ", @object") | otherwise = empty -pprLabel :: Platform -> CLabel -> Doc +pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl = pprGloblDecl platform lbl $$ pprTypeAndSizeDecl platform lbl - $$ (pprCLabel_asm platform lbl <> char ':') + $$ (pprCLabel platform lbl <> char ':') -pprASCII :: [Word8] -> Doc +pprASCII :: [Word8] -> SDoc pprASCII str = vcat (map do1 str) $$ do1 0 where - do1 :: Word8 -> Doc + do1 :: Word8 -> SDoc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance PlatformOutputable Instr where - pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr +instance Outputable Instr where + ppr instr = sdocWithPlatform $ \platform -> pprInstr platform instr -- | Pretty print a register. -pprReg :: Reg -> Doc +pprReg :: Reg -> SDoc pprReg reg = case reg of RegVirtual vr -> case vr of - VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u) - VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u) - VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u) - VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u) - VirtualRegSSE u -> text "%vSSE_" <> asmSDoc (pprUnique u) + VirtualRegI u -> text "%vI_" <> pprUnique u + VirtualRegHi u -> text "%vHi_" <> pprUnique u + VirtualRegF u -> text "%vF_" <> pprUnique u + VirtualRegD u -> text "%vD_" <> pprUnique u + VirtualRegSSE u -> text "%vSSE_" <> pprUnique u RegReal rr -> case rr of @@ -170,7 +168,7 @@ pprReg reg -- The definition has been unfolded so we get a jump-table in the -- object code. This function is called quite a lot when emitting the asm file.. -- -pprReg_ofRegNo :: Int -> Doc +pprReg_ofRegNo :: Int -> SDoc pprReg_ofRegNo i = ptext (case i of { @@ -210,7 +208,7 @@ pprReg_ofRegNo i -- | Pretty print a size for an instruction suffix. -pprSize :: Size -> Doc +pprSize :: Size -> SDoc pprSize x = ptext (case x of @@ -225,7 +223,7 @@ pprSize x -- | Pretty print a size for an instruction suffix. -- eg LD is 32bit on sparc, but LDD is 64 bit. -pprStSize :: Size -> Doc +pprStSize :: Size -> SDoc pprStSize x = ptext (case x of @@ -239,7 +237,7 @@ pprStSize x -- | Pretty print a condition code. -pprCond :: Cond -> Doc +pprCond :: Cond -> SDoc pprCond c = ptext (case c of @@ -262,7 +260,7 @@ pprCond c -- | Pretty print an address mode. -pprAddr :: Platform -> AddrMode -> Doc +pprAddr :: Platform -> AddrMode -> SDoc pprAddr platform am = case am of AddrRegReg r1 (RegReal (RealRegSingle 0)) @@ -290,13 +288,13 @@ pprAddr platform am -- | Pretty print an immediate value. -pprImm :: Platform -> Imm -> Doc +pprImm :: Platform -> Imm -> SDoc pprImm platform imm = case imm of ImmInt i -> int i ImmInteger i -> integer i - ImmCLbl l -> pprCLabel_asm platform l - ImmIndex l i -> pprCLabel_asm platform l <> char '+' <> int i + ImmCLbl l -> pprCLabel platform l + ImmIndex l i -> pprCLabel platform l <> char '+' <> int i ImmLit s -> s ImmConstantSum a b @@ -321,7 +319,7 @@ pprImm platform imm -- On SPARC all the data sections must be at least 8 byte aligned -- incase we store doubles in them. -- -pprSectionHeader :: Section -> Doc +pprSectionHeader :: Section -> SDoc pprSectionHeader seg = case seg of Text -> ptext (sLit ".text\n\t.align 4") @@ -334,7 +332,7 @@ pprSectionHeader seg -- | Pretty print a data item. -pprDataItem :: Platform -> CmmLit -> Doc +pprDataItem :: Platform -> CmmLit -> SDoc pprDataItem platform lit = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) where @@ -357,7 +355,7 @@ pprDataItem platform lit -- | Pretty print an instruction. -pprInstr :: Platform -> Instr -> Doc +pprInstr :: Platform -> Instr -> SDoc -- nuke comments. pprInstr _ (COMMENT _) @@ -527,7 +525,7 @@ pprInstr platform (BI cond b blockid) ptext (sLit "\tb"), pprCond cond, if b then pp_comma_a else empty, char '\t', - pprCLabel_asm platform (mkAsmTempLabel (getUnique blockid)) + pprCLabel platform (mkAsmTempLabel (getUnique blockid)) ] pprInstr platform (BF cond b blockid) @@ -535,7 +533,7 @@ pprInstr platform (BF cond b blockid) ptext (sLit "\tfb"), pprCond cond, if b then pp_comma_a else empty, char '\t', - pprCLabel_asm platform (mkAsmTempLabel (getUnique blockid)) + pprCLabel platform (mkAsmTempLabel (getUnique blockid)) ] pprInstr platform (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr platform addr) @@ -549,13 +547,13 @@ pprInstr _ (CALL (Right reg) n _) -- | Pretty print a RI -pprRI :: Platform -> RI -> Doc +pprRI :: Platform -> RI -> SDoc pprRI _ (RIReg r) = pprReg r pprRI platform (RIImm r) = pprImm platform r -- | Pretty print a two reg instruction. -pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc +pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> SDoc pprSizeRegReg name size reg1 reg2 = hcat [ char '\t', @@ -572,7 +570,7 @@ pprSizeRegReg name size reg1 reg2 -- | Pretty print a three reg instruction. -pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> SDoc pprSizeRegRegReg name size reg1 reg2 reg3 = hcat [ char '\t', @@ -590,7 +588,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3 -- | Pretty print an instruction of two regs and a ri. -pprRegRIReg :: Platform -> LitString -> Bool -> Reg -> RI -> Reg -> Doc +pprRegRIReg :: Platform -> LitString -> Bool -> Reg -> RI -> Reg -> SDoc pprRegRIReg platform name b reg1 ri reg2 = hcat [ char '\t', @@ -604,7 +602,7 @@ pprRegRIReg platform name b reg1 ri reg2 ] {- -pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc +pprRIReg :: LitString -> Bool -> RI -> Reg -> SDoc pprRIReg name b ri reg1 = hcat [ char '\t', @@ -617,18 +615,18 @@ pprRIReg name b ri reg1 -} {- -pp_ld_lbracket :: Doc +pp_ld_lbracket :: SDoc pp_ld_lbracket = ptext (sLit "\tld\t[") -} -pp_rbracket_comma :: Doc +pp_rbracket_comma :: SDoc pp_rbracket_comma = text "]," -pp_comma_lbracket :: Doc +pp_comma_lbracket :: SDoc pp_comma_lbracket = text ",[" -pp_comma_a :: Doc +pp_comma_a :: SDoc pp_comma_a = text ",a" diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index cbc4c17c39..13293deeee 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -50,35 +50,35 @@ import qualified SPARC.Regs as SPARC targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> FastInt targetVirtualRegSqueeze platform = case platformArch platform of - ArchX86 -> X86.virtualRegSqueeze - ArchX86_64 -> X86.virtualRegSqueeze - ArchPPC -> PPC.virtualRegSqueeze - ArchSPARC -> SPARC.virtualRegSqueeze - ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64" - ArchARM _ _ -> panic "targetVirtualRegSqueeze ArchARM" - ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" + ArchX86 -> X86.virtualRegSqueeze + ArchX86_64 -> X86.virtualRegSqueeze + ArchPPC -> PPC.virtualRegSqueeze + ArchSPARC -> SPARC.virtualRegSqueeze + ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64" + ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM" + ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt targetRealRegSqueeze platform = case platformArch platform of - ArchX86 -> X86.realRegSqueeze - ArchX86_64 -> X86.realRegSqueeze - ArchPPC -> PPC.realRegSqueeze - ArchSPARC -> SPARC.realRegSqueeze - ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64" - ArchARM _ _ -> panic "targetRealRegSqueeze ArchARM" - ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" + ArchX86 -> X86.realRegSqueeze + ArchX86_64 -> X86.realRegSqueeze + ArchPPC -> PPC.realRegSqueeze + ArchSPARC -> SPARC.realRegSqueeze + ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64" + ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM" + ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" targetClassOfRealReg :: Platform -> RealReg -> RegClass targetClassOfRealReg platform = case platformArch platform of - ArchX86 -> X86.classOfRealReg - ArchX86_64 -> X86.classOfRealReg - ArchPPC -> PPC.classOfRealReg - ArchSPARC -> SPARC.classOfRealReg - ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64" - ArchARM _ _ -> panic "targetClassOfRealReg ArchARM" - ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" + ArchX86 -> X86.classOfRealReg + ArchX86_64 -> X86.classOfRealReg + ArchPPC -> PPC.classOfRealReg + ArchSPARC -> SPARC.classOfRealReg + ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64" + ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" + ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" -- TODO: This should look at targetPlatform too targetWordSize :: Size @@ -87,24 +87,24 @@ targetWordSize = intSize wordWidth targetMkVirtualReg :: Platform -> Unique -> Size -> VirtualReg targetMkVirtualReg platform = case platformArch platform of - ArchX86 -> X86.mkVirtualReg - ArchX86_64 -> X86.mkVirtualReg - ArchPPC -> PPC.mkVirtualReg - ArchSPARC -> SPARC.mkVirtualReg - ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64" - ArchARM _ _ -> panic "targetMkVirtualReg ArchARM" - ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" + ArchX86 -> X86.mkVirtualReg + ArchX86_64 -> X86.mkVirtualReg + ArchPPC -> PPC.mkVirtualReg + ArchSPARC -> SPARC.mkVirtualReg + ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64" + ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM" + ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" targetRegDotColor :: Platform -> RealReg -> SDoc targetRegDotColor platform = case platformArch platform of - ArchX86 -> X86.regDotColor platform - ArchX86_64 -> X86.regDotColor platform - ArchPPC -> PPC.regDotColor - ArchSPARC -> SPARC.regDotColor - ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64" - ArchARM _ _ -> panic "targetRegDotColor ArchARM" - ArchUnknown -> panic "targetRegDotColor ArchUnknown" + ArchX86 -> X86.regDotColor platform + ArchX86_64 -> X86.regDotColor platform + ArchPPC -> PPC.regDotColor + ArchSPARC -> SPARC.regDotColor + ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64" + ArchARM _ _ _ -> panic "targetRegDotColor ArchARM" + ArchUnknown -> panic "targetRegDotColor ArchUnknown" targetClassOfReg :: Platform -> Reg -> RegClass diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index c68519522d..d480f78b1d 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -54,6 +54,7 @@ import FastString import FastBool ( isFastTrue ) import Constants ( wORD_SIZE ) import DynFlags +import Util import Control.Monad import Data.Bits @@ -129,7 +130,6 @@ basicBlockCodeGen (BasicBlock id stmts) = do = (instrs, blocks, CmmData sec dat:statics) mkBlocks instr (instrs,blocks,statics) = (instr:instrs, blocks, statics) - -- in return (BasicBlock id top : other_blocks, statics) @@ -306,7 +306,6 @@ assignMem_I64Code addrTree valueTree = do -- Little-endian store mov_lo = MOV II32 (OpReg rlo) (OpAddr addr) mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4))) - -- in return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) @@ -319,7 +318,6 @@ assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do r_src_hi = getHiVRegFromLo r_src_lo mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo) mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi) - -- in return ( vcode `snocOL` mov_lo `snocOL` mov_hi ) @@ -338,7 +336,6 @@ iselExpr64 (CmmLit (CmmInt i _)) = do MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) ] - -- in return (ChildCode64 code rlo) iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do @@ -347,7 +344,6 @@ iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do let mov_lo = MOV II32 (OpAddr addr) (OpReg rlo) mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi) - -- in return ( ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rlo @@ -369,7 +365,6 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do ADD II32 (OpImm (ImmInteger r)) (OpReg rlo), MOV II32 (OpReg r1hi) (OpReg rhi), ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ] - -- in return (ChildCode64 code rlo) iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do @@ -385,7 +380,6 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do ADD II32 (OpReg r2lo) (OpReg rlo), MOV II32 (OpReg r1hi) (OpReg rhi), ADC II32 (OpReg r2hi) (OpReg rhi) ] - -- in return (ChildCode64 code rlo) iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do @@ -400,8 +394,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do ) iselExpr64 expr - = do dflags <- getDynFlags - pprPanic "iselExpr64(i386)" (pprPlatform (targetPlatform dflags) expr) + = pprPanic "iselExpr64(i386)" (ppr expr) -------------------------------------------------------------------------------- @@ -717,7 +710,6 @@ getRegister' is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps -- compare against upper -- eax==0 if high part == sign extended low part ] - -- in return (Fixed size eax code) -------------------- @@ -735,7 +727,6 @@ getRegister' is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps code dst = x_code dst `snocOL` instr size (OpImm (litToImm lit)) (OpReg dst) - -- in return (Any size code) {- Case2: shift length is complex (non-immediate) @@ -761,7 +752,6 @@ getRegister' is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps code = x_code tmp `appOL` y_code ecx `snocOL` instr size (OpReg ecx) (OpReg tmp) - -- in return (Fixed size tmp code) -------------------- @@ -810,7 +800,6 @@ getRegister' is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps result | quotient = eax | otherwise = edx - -- in return (Fixed size result code) @@ -887,8 +876,7 @@ getRegister' _ (CmmLit lit) in return (Any size code) -getRegister' _ other = do dflags <- getDynFlags - pprPanic "getRegister(x86)" (pprPlatform (targetPlatform dflags) other) +getRegister' _ other = pprPanic "getRegister(x86)" (ppr other) intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr @@ -1154,7 +1142,6 @@ loadFloatAmode use_sse2 w addr addr_code = do if use_sse2 then MOV size (OpAddr addr) (OpReg dst) else GLD size addr dst - -- in return (Any (if use_sse2 then size else FF80) code) @@ -1228,11 +1215,9 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _other -> do dflags <- getDynFlags - pprPanic "getCondCode(x86,x86_64,sparc)" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y])) + _other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y])) -getCondCode other = do dflags <- getDynFlags - pprPanic "getCondCode(2)(x86,sparc)" (pprPlatform (targetPlatform dflags) other) +getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (ppr other) @@ -1285,7 +1270,6 @@ condIntCode' is32Bit cond x y | isOperand is32Bit y = do let code = x_code `appOL` y_code `snocOL` CMP (cmmTypeSize (cmmExprType x)) y_op (OpReg x_reg) - -- in return (CondCode False cond code) -- anything vs anything @@ -1296,7 +1280,6 @@ condIntCode' _ cond x y = do code = y_code `appOL` x_code `snocOL` CMP (cmmTypeSize (cmmExprType x)) (OpReg y_reg) x_op - -- in return (CondCode False cond code) @@ -1331,7 +1314,6 @@ condFltCode cond x y CMP (floatSize $ cmmExprWidth x) y_op (OpReg x_reg) -- NB(1): we need to use the unsigned comparison operators on the -- result of this comparison. - -- in return (CondCode True (condToUnsigned cond) code) -- ----------------------------------------------------------------------------- @@ -1519,7 +1501,7 @@ genCCall -- Unroll memcpy calls if the source and destination pointers are at -- least DWORD aligned and the number of bytes to copy isn't too -- large. Otherwise, call C's memcpy. -genCCall is32Bit (CmmPrim MO_Memcpy) _ +genCCall is32Bit (CmmPrim MO_Memcpy _) _ [CmmHinted dst _, CmmHinted src _, CmmHinted (CmmLit (CmmInt n _)) _, CmmHinted (CmmLit (CmmInt align _)) _] @@ -1562,7 +1544,7 @@ genCCall is32Bit (CmmPrim MO_Memcpy) _ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - i)) -genCCall _ (CmmPrim MO_Memset) _ +genCCall _ (CmmPrim MO_Memset _) _ [CmmHinted dst _, CmmHinted (CmmLit (CmmInt c _)) _, CmmHinted (CmmLit (CmmInt n _)) _, @@ -1601,11 +1583,11 @@ genCCall _ (CmmPrim MO_Memset) _ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - i)) -genCCall _ (CmmPrim MO_WriteBarrier) _ _ = return nilOL +genCCall _ (CmmPrim MO_WriteBarrier _) _ _ = return nilOL -- write barrier compiles to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. -genCCall is32Bit (CmmPrim (MO_PopCnt width)) dest_regs@[CmmHinted dst _] +genCCall is32Bit (CmmPrim (MO_PopCnt width) _) dest_regs@[CmmHinted dst _] args@[CmmHinted src _] = do sse4_2 <- sse4_2Enabled if sse4_2 @@ -1641,10 +1623,10 @@ genCCall32 :: CmmCallTarget -- function to call genCCall32 target dest_regs args = case (target, dest_regs) of -- void return type prim op - (CmmPrim op, []) -> + (CmmPrim op _, []) -> outOfLineCmmOp op Nothing args -- we only cope with a single result for foreign calls - (CmmPrim op, [r_hinted@(CmmHinted r _)]) -> do + (CmmPrim op _, [r_hinted@(CmmHinted r _)]) -> do l1 <- getNewLabelNat l2 <- getNewLabelNat sse2 <- sse2Enabled @@ -1673,9 +1655,86 @@ genCCall32 target dest_regs args = return (any (getRegisterReg False (CmmLocal r))) actuallyInlineFloatOp _ _ args - = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" + = panic $ "genCCall32.actuallyInlineFloatOp: bad number of arguments! (" ++ show (length args) ++ ")" - _ -> do + + (CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 True width dest_regs args + (CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 False width dest_regs args + (CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 False width dest_regs args + (CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + case args of + [CmmHinted arg_x _, CmmHinted arg_y _] -> + do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) + lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y]) + let size = intSize width + reg_l = getRegisterReg True (CmmLocal res_l) + reg_h = getRegisterReg True (CmmLocal res_h) + code = hCode reg_h `appOL` + lCode reg_l `snocOL` + ADC size (OpImm (ImmInteger 0)) (OpReg reg_h) + return code + _ -> panic "genCCall32: Wrong number of arguments/results for add2" + (CmmPrim (MO_U_Mul2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + case args of + [CmmHinted arg_x _, CmmHinted arg_y _] -> + do (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + let size = intSize width + reg_h = getRegisterReg True (CmmLocal res_h) + reg_l = getRegisterReg True (CmmLocal res_l) + code = y_code `appOL` + x_code rax `appOL` + toOL [MUL2 size y_reg, + MOV size (OpReg rdx) (OpReg reg_h), + MOV size (OpReg rax) (OpReg reg_l)] + return code + _ -> panic "genCCall32: Wrong number of arguments/results for add2" + + (CmmPrim _ (Just stmts), _) -> + stmtsToInstrs stmts + + _ -> genCCall32' target dest_regs args + + where divOp1 signed width results [CmmHinted arg_x _, CmmHinted arg_y _] + = divOp signed width results Nothing arg_x arg_y + divOp1 _ _ _ _ + = panic "genCCall32: Wrong number of arguments for divOp1" + divOp2 signed width results [CmmHinted arg_x_high _, + CmmHinted arg_x_low _, + CmmHinted arg_y _] + = divOp signed width results (Just arg_x_high) arg_x_low arg_y + divOp2 _ _ _ _ + = panic "genCCall64: Wrong number of arguments for divOp2" + divOp signed width [CmmHinted res_q _, CmmHinted res_r _] + m_arg_x_high arg_x_low arg_y + = do let size = intSize width + reg_q = getRegisterReg True (CmmLocal res_q) + reg_r = getRegisterReg True (CmmLocal res_r) + widen | signed = CLTD size + | otherwise = XOR size (OpReg rdx) (OpReg rdx) + instr | signed = IDIV + | otherwise = DIV + (y_reg, y_code) <- getRegOrMem arg_y + x_low_code <- getAnyReg arg_x_low + x_high_code <- case m_arg_x_high of + Just arg_x_high -> + getAnyReg arg_x_high + Nothing -> + return $ const $ unitOL widen + return $ y_code `appOL` + x_low_code rax `appOL` + x_high_code rdx `appOL` + toOL [instr size y_reg, + MOV size (OpReg rax) (OpReg reg_q), + MOV size (OpReg rdx) (OpReg reg_r)] + divOp _ _ _ _ _ _ + = panic "genCCall32: Wrong number of results for divOp" + +genCCall32' :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall32' target dest_regs args = do let -- Align stack to 16n for calls, assuming a starting stack -- alignment of 16n - word_size on procedure entry. Which we @@ -1692,7 +1751,6 @@ genCCall32 target dest_regs args = delta <- getDeltaNat MASSERT (delta == delta0 - tot_arg_size) - -- in -- deal with static vs dynamic call targets (callinsns,cconv) <- case target of @@ -1704,7 +1762,7 @@ genCCall32 target dest_regs args = -> do { (dyn_r, dyn_c) <- getSomeReg expr ; ASSERT( isWord32 (cmmExprType expr) ) return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } - CmmPrim _ + CmmPrim _ _ -> panic $ "genCCall: Can't handle CmmPrim call type here, error " ++ "probably because too many return values." @@ -1731,7 +1789,6 @@ genCCall32 target dest_regs args = ++ [DELTA delta0] ) - -- in setDeltaNat delta0 let @@ -1783,7 +1840,6 @@ genCCall32 target dest_regs args = setDeltaNat (delta - 8) let r_hi = getHiVRegFromLo r_lo - -- in return ( code `appOL` toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), PUSH II32 (OpReg r_lo), DELTA (delta - 8), @@ -1827,105 +1883,196 @@ genCCall64 :: CmmCallTarget -- function to call genCCall64 target dest_regs args = case (target, dest_regs) of - (CmmPrim op, []) -> + (CmmPrim op _, []) -> -- void return type prim op outOfLineCmmOp op Nothing args - (CmmPrim op, [res]) -> + (CmmPrim op _, [res]) -> -- we only cope with a single result for foreign calls outOfLineCmmOp op (Just res) args - _ -> do - -- load up the register arguments - (stack_args, aregs, fregs, load_args_code) - <- load_args args allArgRegs allFPArgRegs nilOL + (CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 True width dest_regs args + (CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 False width dest_regs args + (CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 False width dest_regs args + (CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + case args of + [CmmHinted arg_x _, CmmHinted arg_y _] -> + do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) + lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y]) + let size = intSize width + reg_l = getRegisterReg True (CmmLocal res_l) + reg_h = getRegisterReg True (CmmLocal res_h) + code = hCode reg_h `appOL` + lCode reg_l `snocOL` + ADC size (OpImm (ImmInteger 0)) (OpReg reg_h) + return code + _ -> panic "genCCall64: Wrong number of arguments/results for add2" + (CmmPrim (MO_U_Mul2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + case args of + [CmmHinted arg_x _, CmmHinted arg_y _] -> + do (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + let size = intSize width + reg_h = getRegisterReg True (CmmLocal res_h) + reg_l = getRegisterReg True (CmmLocal res_l) + code = y_code `appOL` + x_code rax `appOL` + toOL [MUL2 size y_reg, + MOV size (OpReg rdx) (OpReg reg_h), + MOV size (OpReg rax) (OpReg reg_l)] + return code + _ -> panic "genCCall64: Wrong number of arguments/results for add2" + + (CmmPrim _ (Just stmts), _) -> + stmtsToInstrs stmts + + _ -> + do dflags <- getDynFlags + let platform = targetPlatform dflags + genCCall64' platform target dest_regs args + + where divOp1 signed width results [CmmHinted arg_x _, CmmHinted arg_y _] + = divOp signed width results Nothing arg_x arg_y + divOp1 _ _ _ _ + = panic "genCCall64: Wrong number of arguments for divOp1" + divOp2 signed width results [CmmHinted arg_x_high _, + CmmHinted arg_x_low _, + CmmHinted arg_y _] + = divOp signed width results (Just arg_x_high) arg_x_low arg_y + divOp2 _ _ _ _ + = panic "genCCall64: Wrong number of arguments for divOp2" + divOp signed width [CmmHinted res_q _, CmmHinted res_r _] + m_arg_x_high arg_x_low arg_y + = do let size = intSize width + reg_q = getRegisterReg True (CmmLocal res_q) + reg_r = getRegisterReg True (CmmLocal res_r) + widen | signed = CLTD size + | otherwise = XOR size (OpReg rdx) (OpReg rdx) + instr | signed = IDIV + | otherwise = DIV + (y_reg, y_code) <- getRegOrMem arg_y + x_low_code <- getAnyReg arg_x_low + x_high_code <- case m_arg_x_high of + Just arg_x_high -> getAnyReg arg_x_high + Nothing -> return $ const $ unitOL widen + return $ y_code `appOL` + x_low_code rax `appOL` + x_high_code rdx `appOL` + toOL [instr size y_reg, + MOV size (OpReg rax) (OpReg reg_q), + MOV size (OpReg rdx) (OpReg reg_r)] + divOp _ _ _ _ _ _ + = panic "genCCall64: Wrong number of results for divOp" + +genCCall64' :: Platform + -> CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall64' platform target dest_regs args = do + -- load up the register arguments + (stack_args, int_regs_used, fp_regs_used, load_args_code) + <- + if platformOS platform == OSMinGW32 + then load_args_win args [] [] allArgRegs nilOL + else do (stack_args, aregs, fregs, load_args_code) + <- load_args args allIntArgRegs allFPArgRegs nilOL + let fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) + int_regs_used = reverse (drop (length aregs) (reverse allIntArgRegs)) + return (stack_args, int_regs_used, fp_regs_used, load_args_code) - let - fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) - int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) - arg_regs = [eax] ++ int_regs_used ++ fp_regs_used - -- for annotating the call instruction with - sse_regs = length fp_regs_used - tot_arg_size = arg_size * length stack_args - - - -- Align stack to 16n for calls, assuming a starting stack - -- alignment of 16n - word_size on procedure entry. Which we - -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] - (real_size, adjust_rsp) <- - if (tot_arg_size + wORD_SIZE) `rem` 16 == 0 - then return (tot_arg_size, nilOL) - else do -- we need to adjust... - delta <- getDeltaNat - setDeltaNat (delta - wORD_SIZE) - return (tot_arg_size + wORD_SIZE, toOL [ - SUB II64 (OpImm (ImmInt wORD_SIZE)) (OpReg rsp), - DELTA (delta - wORD_SIZE) ]) - - -- push the stack args, right to left - push_code <- push_args (reverse stack_args) nilOL - delta <- getDeltaNat + let + arg_regs_used = int_regs_used ++ fp_regs_used + arg_regs = [eax] ++ arg_regs_used + -- for annotating the call instruction with + sse_regs = length fp_regs_used + arg_stack_slots = if platformOS platform == OSMinGW32 + then length stack_args + length allArgRegs + else length stack_args + tot_arg_size = arg_size * arg_stack_slots + + + -- Align stack to 16n for calls, assuming a starting stack + -- alignment of 16n - word_size on procedure entry. Which we + -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] + (real_size, adjust_rsp) <- + if (tot_arg_size + wORD_SIZE) `rem` 16 == 0 + then return (tot_arg_size, nilOL) + else do -- we need to adjust... + delta <- getDeltaNat + setDeltaNat (delta - wORD_SIZE) + return (tot_arg_size + wORD_SIZE, toOL [ + SUB II64 (OpImm (ImmInt wORD_SIZE)) (OpReg rsp), + DELTA (delta - wORD_SIZE) ]) + + -- push the stack args, right to left + push_code <- push_args (reverse stack_args) nilOL + -- On Win64, we also have to leave stack space for the arguments + -- that we are passing in registers + lss_code <- if platformOS platform == OSMinGW32 + then leaveStackSpace (length allArgRegs) + else return nilOL + delta <- getDeltaNat + + -- deal with static vs dynamic call targets + (callinsns,_cconv) <- + case target of + CmmCallee (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) arg_regs), conv) + where fn_imm = ImmCLbl lbl + CmmCallee expr conv + -> do (dyn_r, dyn_c) <- getSomeReg expr + return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + CmmPrim _ _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." - -- deal with static vs dynamic call targets - (callinsns,_cconv) <- - case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) arg_regs), conv) - where fn_imm = ImmCLbl lbl - CmmCallee expr conv - -> do (dyn_r, dyn_c) <- getSomeReg expr - return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) - CmmPrim _ - -> panic $ "genCCall: Can't handle CmmPrim call type here, error " - ++ "probably because too many return values." + let + -- The x86_64 ABI requires us to set %al to the number of SSE2 + -- registers that contain arguments, if the called routine + -- is a varargs function. We don't know whether it's a + -- varargs function or not, so we have to assume it is. + -- + -- It's not safe to omit this assignment, even if the number + -- of SSE2 regs in use is zero. If %al is larger than 8 + -- on entry to a varargs function, seg faults ensue. + assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) + + let call = callinsns `appOL` + toOL ( + -- Deallocate parameters after call for ccall; + -- stdcall has callee do it, but is not supported on + -- x86_64 target (see #3336) + (if real_size==0 then [] else + [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) + ++ + [DELTA (delta + real_size)] + ) + setDeltaNat (delta + real_size) - let - -- The x86_64 ABI requires us to set %al to the number of SSE2 - -- registers that contain arguments, if the called routine - -- is a varargs function. We don't know whether it's a - -- varargs function or not, so we have to assume it is. - -- - -- It's not safe to omit this assignment, even if the number - -- of SSE2 regs in use is zero. If %al is larger than 8 - -- on entry to a varargs function, seg faults ensue. - assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) - - let call = callinsns `appOL` - toOL ( - -- Deallocate parameters after call for ccall; - -- stdcall has callee do it, but is not supported on - -- x86_64 target (see #3336) - (if real_size==0 then [] else - [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) - ++ - [DELTA (delta + real_size)] - ) - -- in - setDeltaNat (delta + real_size) + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [CmmHinted dest _hint] = + case typeWidth rep of + W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) + W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) + _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) + where + rep = localRegType dest + r_dest = getRegisterReg True (CmmLocal dest) + assign_code _many = panic "genCCall.assign_code many" - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [CmmHinted dest _hint] = - case typeWidth rep of - W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) - W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) - _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) - where - rep = localRegType dest - r_dest = getRegisterReg True (CmmLocal dest) - assign_code _many = panic "genCCall.assign_code many" - - return (load_args_code `appOL` - adjust_rsp `appOL` - push_code `appOL` - assign_eax sse_regs `appOL` - call `appOL` - assign_code dest_regs) + return (load_args_code `appOL` + adjust_rsp `appOL` + push_code `appOL` + lss_code `appOL` + assign_eax sse_regs `appOL` + call `appOL` + assign_code dest_regs) - where - arg_size = 8 -- always, at the mo + where arg_size = 8 -- always, at the mo load_args :: [CmmHinted CmmExpr] -> [Reg] -- int regs avail for args @@ -1956,15 +2103,43 @@ genCCall64 target dest_regs args = (args',ars,frs,code') <- load_args rest aregs fregs code return ((CmmHinted arg hint):args', ars, frs, code') + load_args_win :: [CmmHinted CmmExpr] + -> [Reg] -- used int regs + -> [Reg] -- used FP regs + -> [(Reg, Reg)] -- (int, FP) regs avail for args + -> InstrBlock + -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) + load_args_win args usedInt usedFP [] code + = return (args, usedInt, usedFP, code) + -- no more regs to use + load_args_win [] usedInt usedFP _ code + = return ([], usedInt, usedFP, code) + -- no more args to push + load_args_win ((CmmHinted arg _) : rest) usedInt usedFP + ((ireg, freg) : regs) code + | isFloatType arg_rep = do + arg_code <- getAnyReg arg + load_args_win rest (ireg : usedInt) (freg : usedFP) regs + (code `appOL` + arg_code freg `snocOL` + -- If we are calling a varargs function + -- then we need to define ireg as well + -- as freg + MOV II64 (OpReg freg) (OpReg ireg)) + | otherwise = do + arg_code <- getAnyReg arg + load_args_win rest (ireg : usedInt) usedFP regs + (code `appOL` arg_code ireg) + where + arg_rep = cmmExprType arg + push_args [] code = return code push_args ((CmmHinted arg _):rest) code | isFloatType arg_rep = do (arg_reg, arg_code) <- getSomeReg arg delta <- getDeltaNat setDeltaNat (delta-arg_size) - dflags <- getDynFlags - let platform = targetPlatform dflags - code' = code `appOL` arg_code `appOL` toOL [ + let code' = code `appOL` arg_code `appOL` toOL [ SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , DELTA (delta-arg_size), MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel platform 0))] @@ -1986,6 +2161,13 @@ genCCall64 target dest_regs args = arg_rep = cmmExprType arg width = typeWidth arg_rep + leaveStackSpace n = do + delta <- getDeltaNat + setDeltaNat (delta - n * arg_size) + return $ toOL [ + SUB II64 (OpImm (ImmInt (n * wORD_SIZE))) (OpReg rsp), + DELTA (delta - n * arg_size)] + -- | We're willing to inline and unroll memcpy/memset calls that touch -- at most these many bytes. This threshold is the same as the one -- used by GCC and LLVM. @@ -2051,10 +2233,15 @@ outOfLineCmmOp mop res args MO_PopCnt _ -> fsLit "popcnt" - MO_WriteBarrier -> - panic $ "outOfLineCmmOp: MO_WriteBarrier not supported here" - MO_Touch -> - panic $ "outOfLineCmmOp: MO_Touch not supported here" + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ "not supported here") -- ----------------------------------------------------------------------------- -- Generating a table-branch @@ -2112,7 +2299,6 @@ genSwitch expr ids code = e_code `appOL` toOL [ JMP_TBL op ids ReadOnlyData lbl ] - -- in return code generateJumpTableForInstr :: Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr) @@ -2151,7 +2337,6 @@ condIntReg cond x y = do SETCC cond (OpReg tmp), MOVZxL II8 (OpReg tmp) (OpReg dst) ] - -- in return (Any II32 code) @@ -2167,7 +2352,6 @@ condFltReg is32Bit cond x y = if_sse2 condFltReg_sse2 condFltReg_x87 SETCC cond (OpReg tmp), MOVZxL II8 (OpReg tmp) (OpReg dst) ] - -- in return (Any II32 code) condFltReg_sse2 = do @@ -2213,7 +2397,6 @@ condFltReg is32Bit cond x y = if_sse2 condFltReg_sse2 condFltReg_x87 AND II8 (OpReg tmp1) (OpReg tmp2), MOVZxL II8 (OpReg tmp2) (OpReg dst) ] - -- in return (Any II32 code) @@ -2292,7 +2475,6 @@ trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b code dst = b_code dst `snocOL` revinstr (OpImm (litToImm lit_a)) (OpReg dst) - -- in return (Any (intSize width) code) trivialCode' _ width instr _ a b @@ -2322,7 +2504,6 @@ genTrivialCode rep instr a b = do b_code `appOL` a_code dst `snocOL` instr b_op (OpReg dst) - -- in return (Any rep code) regClashesWithOp :: Reg -> Operand -> Bool @@ -2371,7 +2552,6 @@ trivialUFCode size instr x = do code dst = x_code `snocOL` instr x_reg dst - -- in return (Any size code) @@ -2396,7 +2576,6 @@ coerceInt2FP from to x = if_sse2 coerce_sse2 coerce_x87 n -> panic $ "coerceInt2FP.sse: unhandled width (" ++ show n ++ ")" code dst = x_code `snocOL` opc (intSize from) x_op dst - -- in return (Any (floatSize to) code) -- works even if the destination rep is <II32 @@ -2412,7 +2591,6 @@ coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87 ++ show n ++ ")" code dst = x_code `snocOL` opc x_reg dst -- ToDo: works for non-II32 reps? - -- in return (Any (intSize to) code) coerceFP2Int_sse2 = do @@ -2422,7 +2600,6 @@ coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87 n -> panic $ "coerceFP2Init.sse: unhandled width (" ++ show n ++ ")" code dst = x_code `snocOL` opc (intSize to) x_op dst - -- in return (Any (intSize to) code) -- works even if the destination rep is <II32 @@ -2438,7 +2615,6 @@ coerceFP2FP to x = do ++ show n ++ ")" | otherwise = GDTOF code dst = x_code `snocOL` opc x_reg dst - -- in return (Any (if use_sse2 then floatSize to else FF80) code) -------------------------------------------------------------------------------- diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 6cd218cc1e..18adee9915 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -188,6 +188,7 @@ data Instr | SUB Size Operand Operand | MUL Size Operand Operand + | MUL2 Size Operand -- %edx:%eax = operand * %rax | IMUL Size Operand Operand -- signed int mul | IMUL2 Size Operand -- %edx:%eax = operand * %eax @@ -332,6 +333,7 @@ x86_regUsageOfInstr instr IMUL _ src dst -> usageRM src dst IMUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] MUL _ src dst -> usageRM src dst + MUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] DIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] IDIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] AND _ src dst -> usageRM src dst @@ -473,6 +475,7 @@ x86_patchRegsOfInstr instr env IMUL sz src dst -> patch2 (IMUL sz) src dst IMUL2 sz src -> patch1 (IMUL2 sz) src MUL sz src dst -> patch2 (MUL sz) src dst + MUL2 sz src -> patch1 (MUL2 sz) src IDIV sz op -> patch1 (IDIV sz) op DIV sz op -> patch1 (DIV sz) op AND sz src dst -> patch2 (AND sz) src dst diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index f2560fb697..02f8efddae 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -36,10 +36,8 @@ import OldCmm import CLabel import Unique ( pprUnique, Uniquable(..) ) import Platform -import Pretty import FastString -import qualified Outputable -import Outputable (panic, PlatformOutputable) +import Outputable import Data.Word @@ -48,7 +46,7 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: Platform -> NatCmmDecl (Alignment, CmmStatics) Instr -> Doc +pprNatCmmDecl :: Platform -> NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc pprNatCmmDecl platform (CmmData section dats) = pprSectionHeader platform section $$ pprDatas platform dats @@ -66,7 +64,7 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG pprSectionHeader platform Text $$ ( (if platformHasSubsectionsViaSymbols platform - then pprCLabel_asm platform (mkDeadStripPreventer info_lbl) <> char ':' + then pprCLabel platform (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ vcat (map (pprData platform) info) $$ pprLabel platform info_lbl @@ -83,32 +81,32 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). text "\t.long " - <+> pprCLabel_asm platform info_lbl + <+> pprCLabel platform info_lbl <+> char '-' - <+> pprCLabel_asm platform (mkDeadStripPreventer info_lbl) + <+> pprCLabel platform (mkDeadStripPreventer info_lbl) else empty) $$ pprSizeDecl platform info_lbl -- | Output the ELF .size directive. -pprSizeDecl :: Platform -> CLabel -> Doc +pprSizeDecl :: Platform -> CLabel -> SDoc pprSizeDecl platform lbl | osElfTarget (platformOS platform) = - ptext (sLit "\t.size") <+> pprCLabel_asm platform lbl - <> ptext (sLit ", .-") <> pprCLabel_asm platform lbl + ptext (sLit "\t.size") <+> pprCLabel platform lbl + <> ptext (sLit ", .-") <> pprCLabel platform lbl | otherwise = empty -pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc +pprBasicBlock :: Platform -> NatBasicBlock Instr -> SDoc pprBasicBlock platform (BasicBlock blockid instrs) = pprLabel platform (mkAsmTempLabel (getUnique blockid)) $$ vcat (map (pprInstr platform) instrs) -pprDatas :: Platform -> (Alignment, CmmStatics) -> Doc +pprDatas :: Platform -> (Alignment, CmmStatics) -> SDoc pprDatas platform (align, (Statics lbl dats)) = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData platform) dats) -- TODO: could remove if align == 1 -pprData :: Platform -> CmmStatic -> Doc +pprData :: Platform -> CmmStatic -> SDoc pprData _ (CmmString str) = pprASCII str pprData platform (CmmUninitialised bytes) @@ -117,32 +115,32 @@ pprData platform (CmmUninitialised bytes) pprData platform (CmmStaticLit lit) = pprDataItem platform lit -pprGloblDecl :: Platform -> CLabel -> Doc +pprGloblDecl :: Platform -> CLabel -> SDoc pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm platform lbl + | otherwise = ptext (sLit ".globl ") <> pprCLabel platform lbl -pprTypeAndSizeDecl :: Platform -> CLabel -> Doc +pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc pprTypeAndSizeDecl platform lbl | osElfTarget (platformOS platform) && externallyVisibleCLabel lbl = ptext (sLit ".type ") <> - pprCLabel_asm platform lbl <> ptext (sLit ", @object") + pprCLabel platform lbl <> ptext (sLit ", @object") | otherwise = empty -pprLabel :: Platform -> CLabel -> Doc +pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl = pprGloblDecl platform lbl $$ pprTypeAndSizeDecl platform lbl - $$ (pprCLabel_asm platform lbl <> char ':') + $$ (pprCLabel platform lbl <> char ':') -pprASCII :: [Word8] -> Doc +pprASCII :: [Word8] -> SDoc pprASCII str = vcat (map do1 str) $$ do1 0 where - do1 :: Word8 -> Doc + do1 :: Word8 -> SDoc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Platform -> Int -> Doc +pprAlign :: Platform -> Int -> SDoc pprAlign platform bytes = ptext (sLit ".align ") <> int alignment where @@ -160,24 +158,24 @@ pprAlign platform bytes -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance PlatformOutputable Instr where - pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr +instance Outputable Instr where + ppr instr = sdocWithPlatform $ \platform -> pprInstr platform instr -pprReg :: Platform -> Size -> Reg -> Doc +pprReg :: Platform -> Size -> Reg -> SDoc pprReg platform s r = case r of RegReal (RealRegSingle i) -> if target32Bit platform then ppr32_reg_no s i else ppr64_reg_no s i RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" - RegVirtual (VirtualRegI u) -> text "%vI_" <> asmSDoc (pprUnique u) - RegVirtual (VirtualRegHi u) -> text "%vHi_" <> asmSDoc (pprUnique u) - RegVirtual (VirtualRegF u) -> text "%vF_" <> asmSDoc (pprUnique u) - RegVirtual (VirtualRegD u) -> text "%vD_" <> asmSDoc (pprUnique u) - RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> asmSDoc (pprUnique u) + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUnique u + RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUnique u + RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUnique u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUnique u + RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUnique u where - ppr32_reg_no :: Size -> Int -> Doc + ppr32_reg_no :: Size -> Int -> SDoc ppr32_reg_no II8 = ppr32_reg_byte ppr32_reg_no II16 = ppr32_reg_word ppr32_reg_no _ = ppr32_reg_long @@ -207,7 +205,7 @@ pprReg platform s r _ -> ppr_reg_float i }) - ppr64_reg_no :: Size -> Int -> Doc + ppr64_reg_no :: Size -> Int -> SDoc ppr64_reg_no II8 = ppr64_reg_byte ppr64_reg_no II16 = ppr64_reg_word ppr64_reg_no II32 = ppr64_reg_long @@ -280,7 +278,7 @@ ppr_reg_float i = case i of 38 -> sLit "%xmm14"; 39 -> sLit "%xmm15" _ -> sLit "very naughty x86 register" -pprSize :: Size -> Doc +pprSize :: Size -> SDoc pprSize x = ptext (case x of II8 -> sLit "b" @@ -292,7 +290,7 @@ pprSize x FF80 -> sLit "t" ) -pprSize_x87 :: Size -> Doc +pprSize_x87 :: Size -> SDoc pprSize_x87 x = ptext $ case x of FF32 -> sLit "s" @@ -300,7 +298,7 @@ pprSize_x87 x FF80 -> sLit "t" _ -> panic "X86.Ppr.pprSize_x87" -pprCond :: Cond -> Doc +pprCond :: Cond -> SDoc pprCond c = ptext (case c of { GEU -> sLit "ae"; LU -> sLit "b"; @@ -314,11 +312,11 @@ pprCond c ALWAYS -> sLit "mp"}) -pprImm :: Platform -> Imm -> Doc +pprImm :: Platform -> Imm -> SDoc pprImm _ (ImmInt i) = int i pprImm _ (ImmInteger i) = integer i -pprImm platform (ImmCLbl l) = pprCLabel_asm platform l -pprImm platform (ImmIndex l i) = pprCLabel_asm platform l <> char '+' <> int i +pprImm platform (ImmCLbl l) = pprCLabel platform l +pprImm platform (ImmIndex l i) = pprCLabel platform l <> char '+' <> int i pprImm _ (ImmLit s) = s pprImm _ (ImmFloat _) = ptext (sLit "naughty float immediate") @@ -330,7 +328,7 @@ pprImm platform (ImmConstantDiff a b) = pprImm platform a <> char '-' -pprAddr :: Platform -> AddrMode -> Doc +pprAddr :: Platform -> AddrMode -> SDoc pprAddr platform (ImmAddr imm off) = let pp_imm = pprImm platform imm in @@ -361,7 +359,7 @@ pprAddr platform (AddrBaseIndex base index displacement) ppr_disp imm = pprImm platform imm -pprSectionHeader :: Platform -> Section -> Doc +pprSectionHeader :: Platform -> Section -> SDoc pprSectionHeader platform seg = case platformOS platform of OSDarwin @@ -406,7 +404,7 @@ pprSectionHeader platform seg -pprDataItem :: Platform -> CmmLit -> Doc +pprDataItem :: Platform -> CmmLit -> SDoc pprDataItem platform lit = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) where @@ -466,7 +464,7 @@ pprDataItem platform lit -pprInstr :: Platform -> Instr -> Doc +pprInstr :: Platform -> Instr -> SDoc pprInstr _ (COMMENT _) = empty -- nuke 'em {- @@ -592,7 +590,7 @@ pprInstr _ (CLTD II64) = ptext (sLit "\tcqto") pprInstr platform (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand platform II8 op) pprInstr platform (JXX cond blockid) - = pprCondInstr (sLit "j") cond (pprCLabel_asm platform lab) + = pprCondInstr (sLit "j") cond (pprCLabel platform lab) where lab = mkAsmTempLabel (getUnique blockid) pprInstr platform (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm platform imm) @@ -609,6 +607,7 @@ pprInstr platform (IMUL2 sz op) = pprSizeOp platform (sLit "imul") sz op -- x86_64 only pprInstr platform (MUL size op1 op2) = pprSizeOpOp platform (sLit "mul") size op1 op2 +pprInstr platform (MUL2 size op) = pprSizeOp platform (sLit "mul") size op pprInstr platform (FDIV size op1 op2) = pprSizeOpOp platform (sLit "div") size op1 op2 @@ -861,7 +860,7 @@ pprInstr _ _ pprTrigOp :: Platform -> String -> Bool -> CLabel -> CLabel - -> Reg -> Reg -> Size -> Doc + -> Reg -> Reg -> Size -> SDoc pprTrigOp platform op -- fsin, fcos or fptan isTan -- we need a couple of extra steps if we're doing tan @@ -877,7 +876,7 @@ pprTrigOp platform hcat [gtab, text "fnstsw %ax"] $$ hcat [gtab, text "test $0x400,%eax"] $$ -- If we were in bounds then jump to the end - hcat [gtab, text "je " <> pprCLabel_asm platform l1] $$ + hcat [gtab, text "je " <> pprCLabel platform l1] $$ -- Otherwise we need to shrink the value. Start by -- loading pi, doubleing it (by adding it to itself), -- and then swapping pi with the value, so the value we @@ -887,16 +886,16 @@ pprTrigOp platform hcat [gtab, text "fxch %st(1)"] $$ -- Now we have a loop in which we make the value smaller, -- see if it's small enough, and loop if not - (pprCLabel_asm platform l2 <> char ':') $$ + (pprCLabel platform l2 <> char ':') $$ hcat [gtab, text "fprem1"] $$ -- My Debian libc uses fstsw here for the tan code, but I can't -- see any reason why it should need to be different for tan. hcat [gtab, text "fnstsw %ax"] $$ hcat [gtab, text "test $0x400,%eax"] $$ - hcat [gtab, text "jne " <> pprCLabel_asm platform l2] $$ + hcat [gtab, text "jne " <> pprCLabel platform l2] $$ hcat [gtab, text "fstp %st(1)"] $$ hcat [gtab, text op] $$ - (pprCLabel_asm platform l1 <> char ':') $$ + (pprCLabel platform l1 <> char ':') $$ -- Pop the 1.0 tan gave us (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$ -- Restore %eax @@ -907,29 +906,29 @@ pprTrigOp platform -------------------------- -- coerce %st(0) to the specified size -gcoerceto :: Size -> Doc +gcoerceto :: Size -> SDoc gcoerceto FF64 = empty gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; " gcoerceto _ = panic "X86.Ppr.gcoerceto: no match" -gpush :: Reg -> RegNo -> Doc +gpush :: Reg -> RegNo -> SDoc gpush reg offset = hcat [text "fld ", greg reg offset] -gpop :: Reg -> RegNo -> Doc +gpop :: Reg -> RegNo -> SDoc gpop reg offset = hcat [text "fstp ", greg reg offset] -greg :: Reg -> RegNo -> Doc +greg :: Reg -> RegNo -> SDoc greg reg offset = text "%st(" <> int (gregno reg - firstfake+offset) <> char ')' -gsemi :: Doc +gsemi :: SDoc gsemi = text " ; " -gtab :: Doc +gtab :: SDoc gtab = char '\t' -gsp :: Doc +gsp :: SDoc gsp = char ' ' gregno :: Reg -> RegNo @@ -937,12 +936,12 @@ gregno (RegReal (RealRegSingle i)) = i gregno _ = --pprPanic "gregno" (ppr other) 999 -- bogus; only needed for debug printing -pprG :: Platform -> Instr -> Doc -> Doc +pprG :: Platform -> Instr -> SDoc -> SDoc pprG platform fake actual = (char '#' <> pprGInstr platform fake) $$ actual -pprGInstr :: Platform -> Instr -> Doc +pprGInstr :: Platform -> Instr -> SDoc pprGInstr platform (GMOV src dst) = pprSizeRegReg platform (sLit "gmov") FF64 src dst pprGInstr platform (GLD sz src dst) = pprSizeAddrReg platform (sLit "gld") sz src dst pprGInstr platform (GST sz src dst) = pprSizeRegAddr platform (sLit "gst") sz src dst @@ -972,27 +971,27 @@ pprGInstr platform (GDIV sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gd pprGInstr _ _ = panic "X86.Ppr.pprGInstr: no match" -pprDollImm :: Platform -> Imm -> Doc +pprDollImm :: Platform -> Imm -> SDoc pprDollImm platform i = ptext (sLit "$") <> pprImm platform i -pprOperand :: Platform -> Size -> Operand -> Doc +pprOperand :: Platform -> Size -> Operand -> SDoc pprOperand platform s (OpReg r) = pprReg platform s r pprOperand platform _ (OpImm i) = pprDollImm platform i pprOperand platform _ (OpAddr ea) = pprAddr platform ea -pprMnemonic_ :: LitString -> Doc +pprMnemonic_ :: LitString -> SDoc pprMnemonic_ name = char '\t' <> ptext name <> space -pprMnemonic :: LitString -> Size -> Doc +pprMnemonic :: LitString -> Size -> SDoc pprMnemonic name size = char '\t' <> ptext name <> pprSize size <> space -pprSizeImmOp :: Platform -> LitString -> Size -> Imm -> Operand -> Doc +pprSizeImmOp :: Platform -> LitString -> Size -> Imm -> Operand -> SDoc pprSizeImmOp platform name size imm op1 = hcat [ pprMnemonic name size, @@ -1003,7 +1002,7 @@ pprSizeImmOp platform name size imm op1 ] -pprSizeOp :: Platform -> LitString -> Size -> Operand -> Doc +pprSizeOp :: Platform -> LitString -> Size -> Operand -> SDoc pprSizeOp platform name size op1 = hcat [ pprMnemonic name size, @@ -1011,7 +1010,7 @@ pprSizeOp platform name size op1 ] -pprSizeOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprSizeOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> SDoc pprSizeOpOp platform name size op1 op2 = hcat [ pprMnemonic name size, @@ -1021,7 +1020,7 @@ pprSizeOpOp platform name size op1 op2 ] -pprOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> SDoc pprOpOp platform name size op1 op2 = hcat [ pprMnemonic_ name, @@ -1031,7 +1030,7 @@ pprOpOp platform name size op1 op2 ] -pprSizeReg :: Platform -> LitString -> Size -> Reg -> Doc +pprSizeReg :: Platform -> LitString -> Size -> Reg -> SDoc pprSizeReg platform name size reg1 = hcat [ pprMnemonic name size, @@ -1039,7 +1038,7 @@ pprSizeReg platform name size reg1 ] -pprSizeRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> Doc +pprSizeRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> SDoc pprSizeRegReg platform name size reg1 reg2 = hcat [ pprMnemonic name size, @@ -1049,7 +1048,7 @@ pprSizeRegReg platform name size reg1 reg2 ] -pprRegReg :: Platform -> LitString -> Reg -> Reg -> Doc +pprRegReg :: Platform -> LitString -> Reg -> Reg -> SDoc pprRegReg platform name reg1 reg2 = hcat [ pprMnemonic_ name, @@ -1059,7 +1058,7 @@ pprRegReg platform name reg1 reg2 ] -pprSizeOpReg :: Platform -> LitString -> Size -> Operand -> Reg -> Doc +pprSizeOpReg :: Platform -> LitString -> Size -> Operand -> Reg -> SDoc pprSizeOpReg platform name size op1 reg2 = hcat [ pprMnemonic name size, @@ -1068,7 +1067,7 @@ pprSizeOpReg platform name size op1 reg2 pprReg platform (archWordSize (target32Bit platform)) reg2 ] -pprCondRegReg :: Platform -> LitString -> Size -> Cond -> Reg -> Reg -> Doc +pprCondRegReg :: Platform -> LitString -> Size -> Cond -> Reg -> Reg -> SDoc pprCondRegReg platform name size cond reg1 reg2 = hcat [ char '\t', @@ -1080,7 +1079,7 @@ pprCondRegReg platform name size cond reg1 reg2 pprReg platform size reg2 ] -pprSizeSizeRegReg :: Platform -> LitString -> Size -> Size -> Reg -> Reg -> Doc +pprSizeSizeRegReg :: Platform -> LitString -> Size -> Size -> Reg -> Reg -> SDoc pprSizeSizeRegReg platform name size1 size2 reg1 reg2 = hcat [ char '\t', @@ -1093,7 +1092,7 @@ pprSizeSizeRegReg platform name size1 size2 reg1 reg2 pprReg platform size2 reg2 ] -pprSizeSizeOpReg :: Platform -> LitString -> Size -> Size -> Operand -> Reg -> Doc +pprSizeSizeOpReg :: Platform -> LitString -> Size -> Size -> Operand -> Reg -> SDoc pprSizeSizeOpReg platform name size1 size2 op1 reg2 = hcat [ pprMnemonic name size2, @@ -1102,7 +1101,7 @@ pprSizeSizeOpReg platform name size1 size2 op1 reg2 pprReg platform size2 reg2 ] -pprSizeRegRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> Reg -> SDoc pprSizeRegRegReg platform name size reg1 reg2 reg3 = hcat [ pprMnemonic name size, @@ -1114,7 +1113,7 @@ pprSizeRegRegReg platform name size reg1 reg2 reg3 ] -pprSizeAddrReg :: Platform -> LitString -> Size -> AddrMode -> Reg -> Doc +pprSizeAddrReg :: Platform -> LitString -> Size -> AddrMode -> Reg -> SDoc pprSizeAddrReg platform name size op dst = hcat [ pprMnemonic name size, @@ -1124,7 +1123,7 @@ pprSizeAddrReg platform name size op dst ] -pprSizeRegAddr :: Platform -> LitString -> Size -> Reg -> AddrMode -> Doc +pprSizeRegAddr :: Platform -> LitString -> Size -> Reg -> AddrMode -> SDoc pprSizeRegAddr platform name size src op = hcat [ pprMnemonic name size, @@ -1134,7 +1133,7 @@ pprSizeRegAddr platform name size src op ] -pprShift :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprShift :: Platform -> LitString -> Size -> Operand -> Operand -> SDoc pprShift platform name size src dest = hcat [ pprMnemonic name size, @@ -1144,7 +1143,7 @@ pprShift platform name size src dest ] -pprSizeOpOpCoerce :: Platform -> LitString -> Size -> Size -> Operand -> Operand -> Doc +pprSizeOpOpCoerce :: Platform -> LitString -> Size -> Size -> Operand -> Operand -> SDoc pprSizeOpOpCoerce platform name size1 size2 op1 op2 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, pprOperand platform size1 op1, @@ -1153,7 +1152,7 @@ pprSizeOpOpCoerce platform name size1 size2 op1 op2 ] -pprCondInstr :: LitString -> Cond -> Doc -> Doc +pprCondInstr :: LitString -> Cond -> SDoc -> SDoc pprCondInstr name cond arg = hcat [ char '\t', ptext name, pprCond cond, space, arg] diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 68ab351e86..395f9140bd 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -16,6 +16,7 @@ module X86.Regs ( spRel, argRegs, allArgRegs, + allIntArgRegs, callClobberedRegs, allMachRegNos, classOfRealReg, @@ -56,8 +57,7 @@ import RegClass import BlockId import OldCmm import CLabel ( CLabel ) -import Pretty -import Outputable ( panic ) +import Outputable import Platform import FastTypes import FastBool @@ -127,7 +127,7 @@ data Imm = ImmInt Int | ImmInteger Integer -- Sigh. | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit Doc -- Simple string + | ImmLit SDoc -- Simple string | ImmIndex CLabel Int | ImmFloat Rational | ImmDouble Rational @@ -378,9 +378,6 @@ xmm13 = regSingle 37 xmm14 = regSingle 38 xmm15 = regSingle 39 -allFPArgRegs :: [Reg] -allFPArgRegs = map regSingle [firstxmm .. firstxmm+7] - ripRel :: Displacement -> AddrMode ripRel imm = AddrBaseIndex EABaseRip EAIndexNone imm @@ -406,7 +403,9 @@ xmm n = regSingle (firstxmm+n) -- horror show ----------------------------------------------------------------- freeReg :: RegNo -> FastBool globalRegMaybe :: GlobalReg -> Maybe RealReg -allArgRegs :: [Reg] +allArgRegs :: [(Reg, Reg)] +allIntArgRegs :: [Reg] +allFPArgRegs :: [Reg] callClobberedRegs :: [Reg] #if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH) @@ -625,16 +624,28 @@ globalRegMaybe _ = Nothing -- -#if i386_TARGET_ARCH -allArgRegs = panic "X86.Regs.allArgRegs: should not be used!" +#if defined(mingw32_HOST_OS) && x86_64_TARGET_ARCH -#elif x86_64_TARGET_ARCH -allArgRegs = map regSingle [rdi,rsi,rdx,rcx,r8,r9] +allArgRegs = zip (map regSingle [rcx,rdx,r8,r9]) + (map regSingle [firstxmm ..]) +allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined for this platform" +allFPArgRegs = panic "X86.Regs.allFPArgRegs: not defined for this platform" #else -allArgRegs = panic "X86.Regs.allArgRegs: not defined for this architecture" -#endif +allArgRegs = panic "X86.Regs.allArgRegs: not defined for this arch" + +# if i386_TARGET_ARCH +allIntArgRegs = panic "X86.Regs.allIntArgRegs: should not be used!" +# elif x86_64_TARGET_ARCH +allIntArgRegs = map regSingle [rdi,rsi,rdx,rcx,r8,r9] +# else +allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined for this arch" +# endif + +allFPArgRegs = map regSingle [firstxmm .. firstxmm+7] + +#endif -- | these are the regs which we cannot assume stay alive over a C call. @@ -661,8 +672,10 @@ callClobberedRegs freeReg _ = 0# globalRegMaybe _ = panic "X86.Regs.globalRegMaybe: not defined" -allArgRegs = panic "X86.Regs.globalRegMaybe: not defined" -callClobberedRegs = panic "X86.Regs.globalRegMaybe: not defined" +allArgRegs = panic "X86.Regs.allArgRegs: not defined" +allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined" +allFPArgRegs = panic "X86.Regs.allFPArgRegs: not defined" +callClobberedRegs = panic "X86.Regs.callClobberedRegs: not defined" #endif diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 6e74cfbc4a..114f7f6b32 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -56,6 +56,8 @@ module Lexer ( getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, traditionalRecordSyntaxEnabled, + typeLiteralsEnabled, + explicitNamespacesEnabled, addWarning, lexTokenStream ) where @@ -319,6 +321,10 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } "[" @varid "|" / { ifExtension qqEnabled } { lex_quasiquote_tok } + + -- qualified quasi-quote (#5555) + "[" @qual @varid "|" / { ifExtension qqEnabled } + { lex_qquasiquote_tok } } <0> { @@ -487,6 +493,7 @@ data Token | ITvect_prag | ITvect_scalar_prag | ITnovect_prag + | ITctype | ITdotdot -- reserved symbols | ITcolon @@ -559,7 +566,14 @@ data Token | ITidEscape FastString -- $x | ITparenEscape -- $( | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|] + | ITquasiQuote (FastString,FastString,RealSrcSpan) + -- ITquasiQuote(quoter, quote, loc) + -- represents a quasi-quote of the form + -- [quoter| quote |] + | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan) + -- ITqQuasiQuote(Qual, quoter, quote, loc) + -- represents a qualified quasi-quote of the form + -- [Qual.quoter| quote |] -- Arrow notation extension | ITproc @@ -644,7 +658,8 @@ reservedWordsFM = listToUFM $ ( "capi", ITcapiconv, bit cApiFfiBit), ( "prim", ITprimcallconv, bit ffiBit), - ( "rec", ITrec, bit recBit), + ( "rec", ITrec, bit arrowsBit .|. + bit recursiveDoBit), ( "proc", ITproc, bit arrowsBit) ] @@ -752,13 +767,17 @@ pop_and act span buf len = do _ <- popLexState nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool nextCharIs buf p = not (atEnd buf) && p (currentChar buf) +{-# INLINE nextCharIsNot #-} +nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIsNot buf p = not (nextCharIs buf p) + notFollowedBy :: Char -> AlexAccPred Int notFollowedBy char _ _ _ (AI _ buf) - = nextCharIs buf (/=char) + = nextCharIsNot buf (== char) notFollowedBySymbol :: AlexAccPred Int notFollowedBySymbol _ _ _ (AI _ buf) - = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~") + = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") -- We must reject doc comments as being ordinary comments everywhere. -- In some cases the doc comment will be selected as the lexeme due to @@ -768,13 +787,16 @@ notFollowedBySymbol _ _ _ (AI _ buf) isNormalComment :: AlexAccPred Int isNormalComment bits _ _ (AI _ buf) | haddockEnabled bits = notFollowedByDocOrPragma - | otherwise = nextCharIs buf (/='#') + | otherwise = nextCharIsNot buf (== '#') where notFollowedByDocOrPragma - = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#")) + = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) -spaceAndP :: StringBuffer -> (StringBuffer -> Bool) -> Bool -spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf)) +afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool +afterOptionalSpace buf p + = if nextCharIs buf (== ' ') + then p (snd (nextChar buf)) + else p buf atEOL :: AlexAccPred Int atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' @@ -1420,6 +1442,18 @@ getCharOrFail i = do -- ----------------------------------------------------------------------------- -- QuasiQuote +lex_qquasiquote_tok :: Action +lex_qquasiquote_tok span buf len = do + let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False + quoteStart <- getSrcLoc + quote <- lex_quasiquote quoteStart "" + end <- getSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) + (ITqQuasiQuote (qual, + quoter, + mkFastString (reverse quote), + mkRealSrcSpan quoteStart end))) + lex_quasiquote_tok :: Action lex_quasiquote_tok span buf len = do let quoter = tail (lexemeToString buf (len - 1)) @@ -1793,8 +1827,6 @@ inRulePragBit :: Int inRulePragBit = 19 rawTokenStreamBit :: Int rawTokenStreamBit = 20 -- producing a token stream with all comments included -recBit :: Int -recBit = 22 -- rec alternativeLayoutRuleBit :: Int alternativeLayoutRuleBit = 23 relaxedLayoutBit :: Int @@ -1805,6 +1837,11 @@ safeHaskellBit :: Int safeHaskellBit = 26 traditionalRecordSyntaxBit :: Int traditionalRecordSyntaxBit = 27 +typeLiteralsBit :: Int +typeLiteralsBit = 28 +explicitNamespacesBit :: Int +explicitNamespacesBit = 29 + always :: Int -> Bool always _ = True @@ -1848,6 +1885,11 @@ nondecreasingIndentation :: Int -> Bool nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit traditionalRecordSyntaxEnabled :: Int -> Bool traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit +typeLiteralsEnabled :: Int -> Bool +typeLiteralsEnabled flags = testBit flags typeLiteralsBit + +explicitNamespacesEnabled :: Int -> Bool +explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit -- PState for parsing options pragmas -- @@ -1894,8 +1936,6 @@ mkPState flags buf loc = .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags - .|. recBit `setBitIf` xopt Opt_DoRec flags - .|. recBit `setBitIf` xopt Opt_Arrows flags .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags @@ -1907,6 +1947,8 @@ mkPState flags buf loc = .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags .|. safeHaskellBit `setBitIf` safeImportsOn flags .|. traditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags + .|. typeLiteralsBit `setBitIf` xopt Opt_DataKinds flags + .|. explicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b @@ -1915,7 +1957,7 @@ mkPState flags buf loc = addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning = P $ \s@PState{messages=(ws,es), dflags=d} -> - let warning' = mkWarnMsg srcspan alwaysQualify warning + let warning' = mkWarnMsg d srcspan alwaysQualify warning ws' = if wopt option d then ws `snocBag` warning' else ws in POk s{messages=(ws', es)} () @@ -1960,7 +2002,7 @@ srcParseErr -> MsgDoc srcParseErr buf len = hcat [ if null token - then ptext (sLit "parse error (possibly incorrect indentation)") + then ptext (sLit "parse error (possibly incorrect indentation or mismatched brackets)") else hcat [ptext (sLit "parse error on input "), char '`', text token, char '\''] ] @@ -2287,7 +2329,8 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("nounpack", token ITnounpack_prag), ("ann", token ITann_prag), ("vectorize", token ITvect_prag), - ("novectorize", token ITnovect_prag)]) + ("novectorize", token ITnovect_prag), + ("ctype", token ITctype)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), ("notinline conlike", token (ITinline_prag NoInline ConLike)), @@ -2302,7 +2345,7 @@ dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToStr known_pragma :: Map String Action -> AlexAccPred Int known_pragma prags _ _ len (AI _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags) - && (nextCharIs buf (\c -> not (isAlphaNum c || c == '_'))) + && (nextCharIsNot buf (\c -> isAlphaNum c || c == '_')) clean_pragma :: String -> String clean_pragma prag = canon_ws (map toLower (unprefix prag)) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index c05f2e1e6b..21f8782f6f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -38,9 +38,7 @@ import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataC unboxedUnitTyCon, unboxedUnitDataCon, listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) import Type ( funTyCon ) -import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, - CCallConv(..), CCallTarget(..), defaultCCallConv - ) +import ForeignCall import OccName ( varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) import SrcLoc @@ -269,6 +267,7 @@ incorrect. '{-# VECTORISE' { L _ ITvect_prag } '{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag } '{-# NOVECTORISE' { L _ ITnovect_prag } + '{-# CTYPE' { L _ ITctype } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -351,6 +350,7 @@ TH_ID_SPLICE { L _ (ITidEscape _) } -- $x '$(' { L _ ITparenEscape } -- $( exp ) TH_TY_QUOTE { L _ ITtyQuote } -- ''T TH_QUASIQUOTE { L _ (ITquasiQuote _) } +TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } %monad { P } { >>= } { return } %lexer { lexer } { L _ ITeof } @@ -465,27 +465,29 @@ exp_doc :: { LIE RdrName } : docsection { L1 (case (unLoc $1) of (n, doc) -> IEGroup n doc) } | docnamed { L1 (IEDocNamed ((fst . unLoc) $1)) } | docnext { L1 (IEDoc (unLoc $1)) } - + + -- No longer allow things like [] and (,,,) to be exported -- They are built in syntax, always available export :: { LIE RdrName } - : qvar { L1 (IEVar (unLoc $1)) } - | oqtycon { L1 (IEThingAbs (unLoc $1)) } - | oqtycon '(' '..' ')' { LL (IEThingAll (unLoc $1)) } - | oqtycon '(' ')' { LL (IEThingWith (unLoc $1) []) } - | oqtycon '(' qcnames ')' { LL (IEThingWith (unLoc $1) (reverse $3)) } + : qcname_ext export_subspec { LL (mkModuleImpExp (unLoc $1) + (unLoc $2)) } | 'module' modid { LL (IEModuleContents (unLoc $2)) } -qcnames :: { [RdrName] } +export_subspec :: { Located ImpExpSubSpec } + : {- empty -} { L0 ImpExpAbs } + | '(' '..' ')' { LL ImpExpAll } + | '(' ')' { LL (ImpExpList []) } + | '(' qcnames ')' { LL (ImpExpList (reverse $2)) } + +qcnames :: { [RdrName] } -- A reversed list : qcnames ',' qcname_ext { unLoc $3 : $1 } | qcname_ext { [unLoc $1] } qcname_ext :: { Located RdrName } -- Variable or data constructor -- or tagged type constructor : qcname { $1 } - | 'type' qcon { sL (comb2 $1 $2) - (setRdrNameSpace (unLoc $2) - tcClsName) } + | 'type' qcname {% mkTypeImpExp (LL (unLoc $2)) } -- Cannot pull into qcname_ext, as qcname is also used in expression. qcname :: { Located RdrName } -- Variable or data constructor @@ -618,7 +620,7 @@ ty_decl :: { LTyClDecl RdrName } -- -- Note the use of type for the head; this allows -- infix type constructors to be declared - {% mkTySynonym (comb2 $1 $4) False $2 $4 } + {% mkTySynonym (comb2 $1 $4) $2 $4 } -- type family declarations | 'type' 'family' type opt_kind_sig @@ -627,18 +629,18 @@ ty_decl :: { LTyClDecl RdrName } {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) } -- ordinary data type or newtype declaration - | data_or_newtype tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2 - Nothing (reverse (unLoc $3)) (unLoc $4) } + | data_or_newtype capi_ctype tycl_hdr constrs deriving + {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 + Nothing (reverse (unLoc $4)) (unLoc $5) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty -- ordinary GADT declaration - | data_or_newtype tycl_hdr opt_kind_sig + | data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2 - (unLoc $3) (unLoc $4) (unLoc $5) } + {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 + (unLoc $4) (unLoc $5) (unLoc $6) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty @@ -648,29 +650,30 @@ ty_decl :: { LTyClDecl RdrName } inst_decl :: { LInstDecl RdrName } : 'instance' inst_type where_inst - { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) - in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) } + { let (binds, sigs, _, ats, _) = cvBindsAndSigs (unLoc $3) + in L (comb3 $1 $2 $3) (ClsInstD { cid_poly_ty = $2, cid_binds = binds + , cid_sigs = sigs, cid_fam_insts = ats }) } -- type instance declarations | 'type' 'instance' type '=' ctype -- Note the use of type for the head; this allows -- infix type constructors and type patterns - {% do { L loc d <- mkTySynonym (comb2 $1 $5) True $3 $5 - ; return (L loc (FamInstDecl d)) } } + {% do { L loc d <- mkFamInstSynonym (comb2 $1 $5) $3 $5 + ; return (L loc (FamInstD { lid_inst = d })) } } -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving - {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3 + {% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3 Nothing (reverse (unLoc $4)) (unLoc $5) - ; return (L loc (FamInstDecl d)) } } + ; return (L loc (FamInstD { lid_inst = d })) } } -- GADT instance declaration | data_or_newtype 'instance' tycl_hdr opt_kind_sig gadt_constrlist deriving - {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3 + {% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3 (unLoc $4) (unLoc $5) (unLoc $6) - ; return (L loc (FamInstDecl d)) } } + ; return (L loc (FamInstD { lid_inst = d })) } } -- Associated type family declarations -- @@ -681,43 +684,45 @@ inst_decl :: { LInstDecl RdrName } -- declarations without a kind signature cause parsing conflicts with empty -- data declarations. -- -at_decl_cls :: { LTyClDecl RdrName } - -- type family declarations +at_decl_cls :: { LHsDecl RdrName } + -- family declarations : 'type' type opt_kind_sig -- Note the use of type for the head; this allows - -- infix type constructors to be declared - {% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) } + -- infix type constructors to be declared. + {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) + ; return (L loc (TyClD decl)) } } + + | 'data' type opt_kind_sig + {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3) + ; return (L loc (TyClD decl)) } } -- default type instance | 'type' type '=' ctype -- Note the use of type for the head; this allows -- infix type constructors and type patterns - {% mkTySynonym (comb2 $1 $4) True $2 $4 } - - -- data/newtype family declaration - | 'data' type opt_kind_sig - {% mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3) } + {% do { L loc fid <- mkFamInstSynonym (comb2 $1 $4) $2 $4 + ; return (L loc (InstD (FamInstD { lid_inst = fid }))) } } -- Associated type instances -- -at_decl_inst :: { LTyClDecl RdrName } +at_decl_inst :: { LFamInstDecl RdrName } -- type instance declarations : 'type' type '=' ctype -- Note the use of type for the head; this allows -- infix type constructors and type patterns - {% mkTySynonym (comb2 $1 $4) True $2 $4 } + {% mkFamInstSynonym (comb2 $1 $4) $2 $4 } -- data/newtype instance declaration - | data_or_newtype tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) True $2 - Nothing (reverse (unLoc $3)) (unLoc $4) } + | data_or_newtype capi_ctype tycl_hdr constrs deriving + {% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 + Nothing (reverse (unLoc $4)) (unLoc $5) } -- GADT instance declaration - | data_or_newtype tycl_hdr opt_kind_sig + | data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) True $2 - (unLoc $3) (unLoc $4) (unLoc $5) } + {% mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 + (unLoc $4) (unLoc $5) (unLoc $6) } data_or_newtype :: { Located NewOrData } : 'data' { L1 DataType } @@ -738,6 +743,11 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } : context '=>' type { LL (Just $1, $3) } | type { L1 (Nothing, $1) } +capi_ctype :: { Maybe CType } +capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTRING $2))) (getSTRING $3)) } + | '{-# CTYPE' STRING '#-}' { Just (CType Nothing (getSTRING $2)) } + | { Nothing } + ----------------------------------------------------------------------------- -- Stand-alone deriving @@ -751,7 +761,7 @@ stand_alone_deriving :: { LDerivDecl RdrName } -- Declaration in class bodies -- decl_cls :: { Located (OrdList (LHsDecl RdrName)) } -decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) } +decl_cls : at_decl_cls { LL (unitOL $1) } | decl { $1 } -- A 'default' signature used with the generic-programming extension @@ -782,7 +792,7 @@ where_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed -- Declarations in instance bodies -- decl_inst :: { Located (OrdList (LHsDecl RdrName)) } -decl_inst : at_decl_inst { LL (unitOL (L1 (TyClD (unLoc $1)))) } +decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (FamInstD { lid_inst = unLoc $1 })))) } | decl { $1 } decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed @@ -867,7 +877,7 @@ rule_var_list :: { [RuleBndr RdrName] } rule_var :: { RuleBndr RdrName } : varid { RuleBndr $1 } - | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 } + | '(' varid '::' ctype ')' { RuleBndrSig $2 (mkHsWithBndrs $4) } ----------------------------------------------------------------------------- -- Warnings and deprecations (c.f. rules) @@ -1044,6 +1054,9 @@ typedoc :: { LHsType RdrName } | btype '->' ctypedoc { LL $ HsFunTy $1 $3 } | btype docprev '->' ctypedoc { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 } | btype '~' btype { LL $ HsEqTy $1 $3 } + -- see Note [Promotion] + | btype SIMPLEQUOTE qconop type { LL $ mkHsOpTy $1 $3 $4 } + | btype SIMPLEQUOTE varop type { LL $ mkHsOpTy $1 $3 $4 } btype :: { LHsType RdrName } : btype atype { LL $ HsAppTy $1 $2 } @@ -1072,6 +1085,8 @@ atype :: { LHsType RdrName } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) } | SIMPLEQUOTE '[' comma_types0 ']' { LL $ HsExplicitListTy placeHolderKind $3 } | '[' ctype ',' comma_types1 ']' { LL $ HsExplicitListTy placeHolderKind ($2 : $4) } + | INTEGER {% mkTyLit $ LL $ HsNumTy $ getINTEGER $1 } + | STRING {% mkTyLit $ LL $ HsStrTy $ getSTRING $1 } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b @@ -1097,8 +1112,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } | {- empty -} { [] } tv_bndr :: { LHsTyVarBndr RdrName } - : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4 placeHolderKind) } + : tyvar { L1 (UserTyVar (unLoc $1)) } + | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) } fds :: { Located [Located (FunDep RdrName)] } : {- empty -} { noLoc [] } @@ -1131,6 +1146,7 @@ akind :: { LHsKind RdrName } : '*' { L1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) } | '(' kind ')' { LL $ HsParTy $2 } | pkind { $1 } + | tyvar { L1 $ HsTyVar (unLoc $1) } pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion] : qtycon { L1 $ HsTyVar $ unLoc $1 } @@ -1349,6 +1365,10 @@ quasiquote :: { Located (HsQuasiQuote RdrName) } ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 ; quoterId = mkUnqual varName quoter } in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } + | TH_QQUASIQUOTE { let { loc = getLoc $1 + ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1 + ; quoterId = mkQual varName (qual, quoter) } + in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } exp :: { LHsExpr RdrName } : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } @@ -1562,7 +1582,8 @@ flattenedpquals :: { Located [LStmt RdrName] } -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr] + qss -> L1 [L1 $ ParStmt [ParStmtBlock qs undefined noSyntaxExpr | qs <- qss] + noSyntaxExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt } @@ -1741,10 +1762,10 @@ dbinds :: { Located [LIPBind RdrName] } -- | {- empty -} { [] } dbind :: { LIPBind RdrName } -dbind : ipvar '=' exp { LL (IPBind (unLoc $1) $3) } +dbind : ipvar '=' exp { LL (IPBind (Left (unLoc $1)) $3) } -ipvar :: { Located (IPName RdrName) } - : IPDUPVARID { L1 (IPName (mkUnqual varName (getIPDUPVARID $1))) } +ipvar :: { Located HsIPName } + : IPDUPVARID { L1 (HsIPName (getIPDUPVARID $1)) } ----------------------------------------------------------------------------- -- Warnings and deprecations @@ -1829,10 +1850,16 @@ tycon :: { Located RdrName } -- Unqualified qtyconsym :: { Located RdrName } : QCONSYM { L1 $! mkQual tcClsName (getQCONSYM $1) } + | QVARSYM { L1 $! mkQual tcClsName (getQVARSYM $1) } | tyconsym { $1 } +-- Does not include "!", because that is used for strictness marks +-- or ".", because that separates the quantified type vars from the rest tyconsym :: { Located RdrName } : CONSYM { L1 $! mkUnqual tcClsName (getCONSYM $1) } + | VARSYM { L1 $! mkUnqual tcClsName (getVARSYM $1) } + | '*' { L1 $! mkUnqual tcClsName (fsLit "*") } + ----------------------------------------------------------------------------- -- Operators @@ -1866,11 +1893,9 @@ qvaropm :: { Located RdrName } tyvar :: { Located RdrName } tyvar : tyvarid { $1 } - | '(' tyvarsym ')' { LL (unLoc $2) } tyvarop :: { Located RdrName } tyvarop : '`' tyvarid '`' { LL (unLoc $2) } - | tyvarsym { $1 } | '.' {% parseErrorSDoc (getLoc $1) (vcat [ptext (sLit "Illegal symbol '.' in type"), ptext (sLit "Perhaps you intended -XRankNTypes or similar flag"), @@ -1884,12 +1909,6 @@ tyvarid :: { Located RdrName } | 'safe' { L1 $! mkUnqual tvName (fsLit "safe") } | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") } -tyvarsym :: { Located RdrName } --- Does not include "!", because that is used for strictness marks --- or ".", because that separates the quantified type vars from the rest --- or "*", because that's used for kinds -tyvarsym : VARSYM { L1 $! mkUnqual tvName (getVARSYM $1) } - ----------------------------------------------------------------------------- -- Variables diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 3a786ea04b..edb8b50864 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -18,7 +18,7 @@ import OccName import TypeRep ( TyThing(..) ) import Type ( Kind, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, mkTyConApp + mkTyConApp ) import Kind( mkArrowKind ) import Name( Name, nameOccName, nameModule, mkExternalName, wiredInNameTyThing_maybe ) @@ -127,18 +127,18 @@ tdefs :: { [TyClDecl RdrName] } tdef :: { TyClDecl RdrName } : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';' - { TyData { tcdND = DataType, tcdCtxt = noLoc [] - , tcdLName = noLoc (ifaceExtRdrName $2) - , tcdTyVars = map toHsTvBndr $3 - , tcdTyPats = Nothing, tcdKindSig = Nothing - , tcdCons = $6, tcdDerivs = Nothing } } + { TyDecl { tcdLName = noLoc (ifaceExtRdrName $2) + , tcdTyVars = mkHsQTvs (map toHsTvBndr $3) + , tcdTyDefn = TyData { td_ND = DataType, td_ctxt = noLoc [] + , td_kindSig = Nothing + , td_cons = $6, td_derivs = Nothing } } } | '%newtype' q_tc_name tv_bndrs trep ';' - { let tc_rdr = ifaceExtRdrName $2 in - TyData { tcdND = NewType, tcdCtxt = noLoc [] - , tcdLName = noLoc tc_rdr - , tcdTyVars = map toHsTvBndr $3 - , tcdTyPats = Nothing, tcdKindSig = Nothing - , tcdCons = $4 (rdrNameOcc tc_rdr), tcdDerivs = Nothing } } + { let tc_rdr = ifaceExtRdrName $2 in + TyDecl { tcdLName = noLoc tc_rdr + , tcdTyVars = mkHsQTvs (map toHsTvBndr $3) + , tcdTyDefn = TyData { td_ND = NewType, td_ctxt = noLoc [] + , td_kindSig = Nothing + , td_cons = $4 (rdrNameOcc tc_rdr), td_derivs = Nothing } } } -- For a newtype we have to invent a fake data constructor name -- It doesn't matter what it is, because it won't be used @@ -278,7 +278,7 @@ exp :: { IfaceExpr } -- "InlineMe" -> IfaceNote IfaceInlineMe $3 -- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall - (CCallSpec (StaticTarget (mkFastString $2) Nothing) + (CCallSpec (StaticTarget (mkFastString $2) Nothing True) CCallConv PlaySafe)) $3 } @@ -375,16 +375,18 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName) ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toHsKind k) placeHolderKind +toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig + where + bsig = toHsKind k ifaceExtRdrName :: Name -> RdrName ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name) ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other) add_forall tv (L _ (HsForAllTy exp tvs cxt t)) - = noLoc $ HsForAllTy exp (tv:tvs) cxt t + = noLoc $ HsForAllTy exp (mkHsQTvs (tv : hsQTvBndrs tvs)) cxt t add_forall tv t - = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t + = noLoc $ HsForAllTy Explicit (mkHsQTvs [tv]) (noLoc []) t happyError :: P a happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 14778171f5..6da712ce44 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -5,15 +5,16 @@ Functions over HsSyn specialised to RdrName. \begin{code} module RdrHsSyn ( - extractHsTyRdrTyVars, - extractHsRhoRdrTyVars, extractGenericPatTyVars, - mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkHsSplice, mkTopSpliceDecl, - mkClassDecl, mkTyData, mkTyFamily, mkTySynonym, + mkClassDecl, + mkTyData, mkFamInstData, + mkTySynonym, mkFamInstSynonym, + mkTyFamily, splitCon, mkInlinePragma, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp + mkTyLit, cvBindGroup, cvBindsAndSigs, @@ -34,7 +35,6 @@ module RdrHsSyn ( checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkTyVars, -- [LHsType RdrName] -> P () - checkKindSigs, -- [LTyClDecl RdrName] -> P () checkPattern, -- HsExp -> P HsPat bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] @@ -45,12 +45,20 @@ module RdrHsSyn ( checkRecordSyntax, parseError, parseErrorSDoc, + + -- Help with processing exports + ImpExpSubSpec(..), + mkModuleImpExp, + mkTypeImpExp + ) where import HsSyn -- Lots of it import Class ( FunDep ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, - isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) + isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace, + rdrNameSpace ) +import OccName ( tcClsName, isVarNameSpace ) import Name ( Name ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, InlinePragma(..), InlineSpec(..) ) @@ -64,15 +72,15 @@ import PrelNames ( forall_tv_RDR ) import DynFlags import SrcLoc import OrdList ( OrdList, fromOL ) -import Bag ( Bag, emptyBag, consBag, foldrBag ) +import Bag ( Bag, emptyBag, consBag ) import Outputable import FastString import Maybes +import Util import Control.Applicative ((<$>)) import Control.Monad import Text.ParserCombinators.ReadP as ReadP -import Data.List ( nubBy, partition ) import Data.Char #include "HsVersions.h" @@ -81,82 +89,6 @@ import Data.Char %************************************************************************ %* * -\subsection{A few functions over HsSyn at RdrName} -%* * -%************************************************************************ - -extractHsTyRdrNames finds the free variables of a HsType -It's used when making the for-alls explicit. - -\begin{code} -extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName] -extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty []) - -extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName] -extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty []) - -extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName] --- This one takes the context and tau-part of a --- sigma type and returns their free type variables -extractHsRhoRdrTyVars ctxt ty - = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty []) - -extract_lctxt :: LHsContext RdrName -> [Located RdrName] -> [Located RdrName] -extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt) - -extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName] -extract_ltys tys acc = foldr extract_lty acc tys - --- IA0_NOTE: Should this function also return kind variables? --- (explicit kind poly) -extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName] -extract_lty (L loc ty) acc - = case ty of - HsTyVar tv -> extract_tv loc tv acc - HsBangTy _ ty -> extract_lty ty acc - HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds - HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsListTy ty -> extract_lty ty acc - HsPArrTy ty -> extract_lty ty acc - HsTupleTy _ tys -> extract_ltys tys acc - HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsIParamTy _ ty -> extract_lty ty acc - HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsOpTy ty1 (_, (L loc tv)) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) - HsParTy ty -> extract_lty ty acc - HsCoreTy {} -> acc -- The type is closed - HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables - HsSpliceTy {} -> acc -- Type splices mention no type variables - HsKindSig ty _ -> extract_lty ty acc - HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc) - HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $ - extract_lctxt cx (extract_lty ty [])) - where - locals = hsLTyVarNames tvs - HsDocTy ty _ -> extract_lty ty acc - HsExplicitListTy _ tys -> extract_ltys tys acc - HsExplicitTupleTy _ tys -> extract_ltys tys acc - HsWrapTy _ _ -> panic "extract_lty" - -extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName] -extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc - | otherwise = acc - -extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName] --- Get the type variables out of the type patterns in a bunch of --- possibly-generic bindings in a class declaration -extractGenericPatTyVars binds - = nubBy eqLocated (foldrBag get [] binds) - where - get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms - get _ acc = acc - - get_m _ acc = acc -\end{code} - - -%************************************************************************ -%* * \subsection{Construction functions for Rdr stuff} %* * %************************************************************************ @@ -179,44 +111,81 @@ mkClassDecl :: SrcSpan -> P (LTyClDecl RdrName) mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls - = do { let (binds, sigs, at_stuff, docs) = cvBindsAndSigs (unLoc where_cls) - (at_defs, ats) = partition (isTypeDecl . unLoc) at_stuff + = do { let (binds, sigs, ats, at_defs, docs) = cvBindsAndSigs (unLoc where_cls) cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams) <- checkTyClHdr tycl_hdr ; tyvars <- checkTyVars tycl_hdr tparams -- Only type vars allowed - ; checkKindSigs ats ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars, tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds, - tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs })) } + tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs, + tcdFVs = placeHolderNames })) } mkTyData :: SrcSpan -> NewOrData - -> Bool -- True <=> data family instance + -> Maybe CType -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (LTyClDecl RdrName) -mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv +mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr + ; tyvars <- checkTyVars tycl_hdr tparams + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars, + tcdTyDefn = defn, + tcdFVs = placeHolderNames })) } - ; checkDatatypeContext mcxt +mkFamInstData :: SrcSpan + -> NewOrData + -> Maybe CType + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) + -> Maybe (LHsKind RdrName) + -> [LConDecl RdrName] + -> Maybe [LHsType RdrName] + -> P (LFamInstDecl RdrName) +mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv + = do { (tc, tparams) <- checkTyClHdr tycl_hdr + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams + , fid_defn = defn, fid_fvs = placeHolderNames })) } + +mkDataDefn :: NewOrData + -> Maybe CType + -> Maybe (LHsContext RdrName) + -> Maybe (LHsKind RdrName) + -> [LConDecl RdrName] + -> Maybe [LHsType RdrName] + -> P (HsTyDefn RdrName) +mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + = do { checkDatatypeContext mcxt ; let cxt = fromMaybe (noLoc []) mcxt - ; (tyvars, typats) <- checkTParams is_family tycl_hdr tparams - ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc, - tcdTyVars = tyvars, tcdTyPats = typats, - tcdCons = data_cons, - tcdKindSig = ksig, tcdDerivs = maybe_deriv })) } + ; return (TyData { td_ND = new_or_data, td_cType = cType + , td_ctxt = cxt + , td_cons = data_cons + , td_kindSig = ksig + , td_derivs = maybe_deriv }) } mkTySynonym :: SrcSpan - -> Bool -- True <=> type family instances -> LHsType RdrName -- LHS -> LHsType RdrName -- RHS -> P (LTyClDecl RdrName) -mkTySynonym loc is_family lhs rhs +mkTySynonym loc lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs - ; (tyvars, typats) <- checkTParams is_family lhs tparams - ; return (L loc (TySynonym tc tyvars typats rhs)) } + ; tyvars <- checkTyVars lhs tparams + ; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars, + tcdTyDefn = TySynonym { td_synRhs = rhs }, + tcdFVs = placeHolderNames })) } + +mkFamInstSynonym :: SrcSpan + -> LHsType RdrName -- LHS + -> LHsType RdrName -- RHS + -> P (LFamInstDecl RdrName) +mkFamInstSynonym loc lhs rhs + = do { (tc, tparams) <- checkTyClHdr lhs + ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams + , fid_defn = TySynonym { td_synRhs = rhs } + , fid_fvs = placeHolderNames })) } mkTyFamily :: SrcSpan -> FamilyFlavour @@ -238,6 +207,19 @@ mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr Explicit) mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit) + + +mkTyLit :: Located (HsTyLit) -> P (LHsType RdrName) +mkTyLit l = + do allowed <- extension typeLiteralsEnabled + if allowed + then return (HsTyLit `fmap` l) + else parseErrorSDoc (getLoc l) + (text "Illegal literal in type (use -XDataKinds to enable):" <+> + ppr l) + + + \end{code} %************************************************************************ @@ -266,27 +248,31 @@ cvTopDecls decls = go (fromOL decls) cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName cvBindGroup binding = case cvBindsAndSigs binding of - (mbs, sigs, tydecls, _) -> ASSERT( null tydecls ) - ValBindsIn mbs sigs + (mbs, sigs, fam_ds, fam_insts, _) + -> ASSERT( null fam_ds && null fam_insts ) + ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl]) + -> (Bag ( LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName] + , [LFamInstDecl RdrName], [LDocDecl]) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also -- associated type declarations. They might also contain Haddock comments. cvBindsAndSigs fb = go (fromOL fb) where - go [] = (emptyBag, [], [], []) - go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs) - where (bs, ss, ts, docs) = go ds - go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs) + go [] = (emptyBag, [], [], [], []) + go (L l (SigD s) : ds) = (bs, L l s : ss, ts, fis, docs) + where (bs, ss, ts, fis, docs) = go ds + go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, fis, docs) where (b', ds') = getMonoBind (L l b) ds - (bs, ss, ts, docs) = go ds' - go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs) - where (bs, ss, ts, docs) = go ds - go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs) - where (bs, ss, ts, docs) = go ds - go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d) + (bs, ss, ts, fis, docs) = go ds' + go (L l (TyClD t@(TyFamily {})) : ds) = (bs, ss, L l t : ts, fis, docs) + where (bs, ss, ts, fis, docs) = go ds + go (L l (InstD (FamInstD { lid_inst = fi })) : ds) = (bs, ss, ts, L l fi : fis, docs) + where (bs, ss, ts, fis, docs) = go ds + go (L l (DocD d) : ds) = (bs, ss, ts, fis, (L l d) : docs) + where (bs, ss, ts, fis, docs) = go ds + go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d) ----------------------------------------------------------------------------- -- Group function bindings into equation groups @@ -383,7 +369,7 @@ mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty ; return (L loc (ConDecl { con_old_rec = True , con_name = data_con , con_explicit = Implicit - , con_qvars = [] + , con_qvars = mkHsQTvs [] , con_cxt = noLoc [] , con_details = RecCon flds , con_res = ResTyGADT res_ty @@ -397,7 +383,7 @@ mkSimpleConDecl name qvars cxt details = ConDecl { con_old_rec = False , con_name = name , con_explicit = Explicit - , con_qvars = qvars + , con_qvars = mkHsQTvs qvars , con_cxt = cxt , con_details = details , con_res = ResTyH98 @@ -460,46 +446,20 @@ we can bring x,y into scope. So: * For RecCon we do not \begin{code} -checkTParams :: Bool -- Type/data family - -> LHsType RdrName - -> [LHsType RdrName] - -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName]) --- checkTParams checks the type parameters of a data/newtype declaration --- There are two cases: --- --- a) Vanilla data/newtype decl. In that case --- - the type parameters should all be type variables --- - they may have a kind annotation --- --- b) Family data/newtype decl. In that case --- - The type parameters may be arbitrary types --- - We find the type-varaible binders by find the --- free type vars of those types --- - We make them all kind-sig-free binders (UserTyVar) --- If there are kind sigs in the type parameters, they --- will fix the binder's kind when we kind-check the --- type parameters -checkTParams is_family tycl_hdr tparams - | not is_family -- Vanilla case (a) - = do { tyvars <- checkTyVars tycl_hdr tparams - ; return (tyvars, Nothing) } - | otherwise -- Family case (b) - = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams) - ; return (tyvars, Just tparams) } - -checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P [LHsTyVarBndr RdrName] +checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName) -- Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). If the second argument is `False', -- only type variables are allowed and we raise an error on encountering a -- non-variable; otherwise, we allow non-variable arguments and return the -- entire list of parameters. -checkTyVars tycl_hdr tparms = mapM chk tparms +checkTyVars tycl_hdr tparms = do { tvs <- mapM chk tparms + ; return (mkHsQTvs tvs) } where -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return (L l (KindedTyVar tv k placeHolderKind)) + | isRdrTyVar tv = return (L l (KindedTyVar tv k)) chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) + | isRdrTyVar tv = return (L l (UserTyVar tv)) chk t@(L l _) = parseErrorSDoc l $ vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t) @@ -546,18 +506,6 @@ checkTyClHdr ty -- See Note [Unit tuples] in HsTypes go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) --- Check that associated type declarations of a class are all kind signatures. --- -checkKindSigs :: [LTyClDecl RdrName] -> P () -checkKindSigs = mapM_ check - where - check (L l tydecl) - | isFamilyDecl tydecl = return () - | isTypeDecl tydecl = return () - | otherwise - = parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" - $$ ppr tydecl) - checkContext :: LHsType RdrName -> P (LHsContext RdrName) checkContext (L l orig_t) = check orig_t @@ -634,7 +582,7 @@ checkAPat dynflags loc e0 = case e0 of let t' = case t of L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty other -> other - return (SigPatIn e t') + return (SigPatIn e (mkHsWithBndrs t')) -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ @@ -912,8 +860,8 @@ mkImport :: CCallConv -> P (HsDecl RdrName) mkImport cconv safety (L loc entity, v, ty) | cconv == PrimCallConv = do - let funcTarget = CFunction (StaticTarget entity Nothing) - importSpec = CImport PrimCallConv safety nilFS funcTarget + let funcTarget = CFunction (StaticTarget entity Nothing True) + importSpec = CImport PrimCallConv safety Nothing funcTarget return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) | otherwise = do @@ -933,27 +881,45 @@ parseCImport cconv safety nm str = parse = do skipSpaces r <- choice [ - string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)), - string "wrapper" >> return (mk nilFS CWrapper), - optional (string "static" >> skipSpaces) >> - (mk nilFS <$> cimp nm) +++ - (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm) + string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), + string "wrapper" >> return (mk Nothing CWrapper), + do optional (token "static" >> skipSpaces) + ((mk Nothing <$> cimp nm) +++ + (do h <- munch1 hdr_char + skipSpaces + mk (Just (Header (mkFastString h))) <$> cimp nm)) ] skipSpaces return r + token str = do _ <- string str + toks <- look + case toks of + c : _ + | id_char c -> pfail + _ -> return () + mk = CImport cconv safety hdr_char c = not (isSpace c) -- header files are filenames, which can contain -- pretty much any char (depending on the platform), -- so just accept any non-space character - id_char c = isAlphaNum c || c == '_' + id_first_char c = isAlpha c || c == '_' + id_char c = isAlphaNum c || c == '_' cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid) + +++ (do isFun <- case cconv of + CApiConv -> + option True + (do token "value" + skipSpaces + return False) + _ -> return True + cid' <- cid + return (CFunction (StaticTarget cid' Nothing isFun))) where cid = return nm +++ - (do c <- satisfy (\c -> isAlpha c || c == '_') + (do c <- satisfy id_first_char cs <- many (satisfy id_char) return (mkFastString (c:cs))) @@ -979,6 +945,32 @@ mkExtName :: RdrName -> CLabelString mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) \end{code} +-------------------------------------------------------------------------------- +-- Help with module system imports/exports + +\begin{code} +data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [ RdrName ] + +mkModuleImpExp :: RdrName -> ImpExpSubSpec -> IE RdrName +mkModuleImpExp name subs = + case subs of + ImpExpAbs + | isVarNameSpace (rdrNameSpace name) -> IEVar name + | otherwise -> IEThingAbs nameT + ImpExpAll -> IEThingAll nameT + ImpExpList xs -> IEThingWith nameT xs + + where + nameT = setRdrNameSpace name tcClsName + +mkTypeImpExp :: Located RdrName -> P (Located RdrName) +mkTypeImpExp name = + do allowed <- extension explicitNamespacesEnabled + if allowed + then return (fmap (`setRdrNameSpace` tcClsName) name) + else parseErrorSDoc (getLoc name) + (text "Illegal keyword 'type' (use -XExplicitNamespaces to enable)") +\end{code} ----------------------------------------------------------------------------- -- Misc utils diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index f959fb08d4..b3a2ad3ff1 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -14,6 +14,8 @@ module ForeignCall ( CCallSpec(..), CCallTarget(..), isDynamicTarget, CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, + + Header(..), CType(..), ) where import FastString @@ -125,6 +127,9 @@ data CCallTarget -- The first argument of the import is the name of a function pointer (an Addr#). -- Used when importing a label as "foreign import ccall "dynamic" ..." + Bool -- True => really a function + -- False => a value; only + -- allowed in CAPI imports | DynamicTarget deriving( Eq, Data, Typeable ) @@ -217,16 +222,39 @@ instance Outputable CCallSpec where gc_suf | playSafe safety = text "_GC" | otherwise = empty - ppr_fun (StaticTarget fn Nothing) - = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn - - ppr_fun (StaticTarget fn (Just pkgId)) - = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn + ppr_fun (StaticTarget fn mPkgId isFun) + = text (if isFun then "__pkg_ccall" + else "__pkg_ccall_value") + <> gc_suf + <+> (case mPkgId of + Nothing -> empty + Just pkgId -> ppr pkgId) + <+> pprCLabelString fn ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\"" \end{code} +\begin{code} +-- The filename for a C header file +newtype Header = Header FastString + deriving (Eq, Data, Typeable) + +instance Outputable Header where + ppr (Header h) = quotes $ ppr h + +-- | A C type, used in CAPI FFI calls +data CType = CType (Maybe Header) -- header to include for this type + FastString -- the type itself + deriving (Data, Typeable) + +instance Outputable CType where + ppr (CType mh ct) = hDoc <+> ftext ct + where hDoc = case mh of + Nothing -> empty + Just h -> ppr h +\end{code} + %************************************************************************ %* * @@ -275,10 +303,11 @@ instance Binary CCallSpec where return (CCallSpec aa ab ac) instance Binary CCallTarget where - put_ bh (StaticTarget aa ab) = do + put_ bh (StaticTarget aa ab ac) = do putByte bh 0 put_ bh aa put_ bh ab + put_ bh ac put_ bh DynamicTarget = do putByte bh 1 get bh = do @@ -286,7 +315,8 @@ instance Binary CCallTarget where case h of 0 -> do aa <- get bh ab <- get bh - return (StaticTarget aa ab) + ac <- get bh + return (StaticTarget aa ab ac) _ -> do return DynamicTarget instance Binary CCallConv where @@ -308,4 +338,16 @@ instance Binary CCallConv where 2 -> do return PrimCallConv 3 -> do return CmmCallConv _ -> do return CApiConv + +instance Binary CType where + put_ bh (CType mh fs) = do put_ bh mh + put_ bh fs + get bh = do mh <- get bh + fs <- get bh + return (CType mh fs) + +instance Binary Header where + put_ bh (Header h) = put_ bh h + get bh = do h <- get bh + return (Header h) \end{code} diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index e6eb83bea8..31749744e7 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -254,7 +254,9 @@ basicKnownKeyNames -- Integer integerTyConName, mkIntegerName, integerToWord64Name, integerToInt64Name, + word64ToIntegerName, int64ToIntegerName, plusIntegerName, timesIntegerName, smallIntegerName, + wordToIntegerName, integerToWordName, integerToIntName, minusIntegerName, negateIntegerName, eqIntegerName, neqIntegerName, absIntegerName, signumIntegerName, @@ -263,6 +265,7 @@ basicKnownKeyNames quotIntegerName, remIntegerName, floatFromIntegerName, doubleFromIntegerName, encodeFloatIntegerName, encodeDoubleIntegerName, + decodeDoubleIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, shiftLIntegerName, shiftRIntegerName, @@ -273,6 +276,18 @@ basicKnownKeyNames -- Other classes randomClassName, randomGenClassName, monadPlusClassName, + -- Type-level naturals + typeNatKindConName, + typeStringKindConName, + singIClassName, + typeNatLeqClassName, + typeNatAddTyFamName, + typeNatMulTyFamName, + typeNatExpTyFamName, + + -- Implicit parameters + ipClassName, + -- Annotation type checking toAnnotationWrapperName @@ -297,6 +312,9 @@ basicKnownKeyNames , guardMName , liftMName , mzipName + + -- GHCi Sandbox + , ghciIoClassName, ghciStepIoMName ] genericTyConNames :: [Name] @@ -325,7 +343,7 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, - gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING, + gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING, gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_CONC, gHC_IO, gHC_IO_Exception, @@ -333,17 +351,17 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS, dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, - cONTROL_EXCEPTION_BASE :: Module + cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_TYPES = mkPrimModule (fsLit "GHC.Types") -gHC_GENERICS = mkPrimModule (fsLit "GHC.Generics") gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") gHC_BASE = mkBaseModule (fsLit "GHC.Base") gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") +gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi") gHC_SHOW = mkBaseModule (fsLit "GHC.Show") gHC_READ = mkBaseModule (fsLit "GHC.Read") gHC_NUM = mkBaseModule (fsLit "GHC.Num") @@ -385,6 +403,9 @@ gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") rANDOM = mkBaseModule (fsLit "System.Random") gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") +gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics") +gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") +gHC_IP = mkBaseModule (fsLit "GHC.IP") gHC_PARR' :: Module gHC_PARR' = mkBaseModule (fsLit "GHC.PArr") @@ -526,7 +547,7 @@ unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name newStablePtr_RDR, wordDataCon_RDR :: RdrName newStablePtr_RDR = nameRdrName newStablePtrName -wordDataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W#") +wordDataCon_RDR = dataQual_RDR gHC_TYPES (fsLit "W#") bindIO_RDR, returnIO_RDR :: RdrName bindIO_RDR = nameRdrName bindIOName @@ -606,8 +627,10 @@ error_RDR = varQual_RDR gHC_ERR (fsLit "error") -- Generics (constructors and functions) u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, - prodDataCon_RDR, comp1DataCon_RDR, from_RDR, from1_RDR, - to_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR, + prodDataCon_RDR, comp1DataCon_RDR, + unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, + from_RDR, from1_RDR, to_RDR, to1_RDR, + datatypeName_RDR, moduleName_RDR, conName_RDR, conFixity_RDR, conIsRecord_RDR, noArityDataCon_RDR, arityDataCon_RDR, selName_RDR, prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, @@ -625,6 +648,11 @@ r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") +unPar1_RDR = varQual_RDR gHC_GENERICS (fsLit "unPar1") +unRec1_RDR = varQual_RDR gHC_GENERICS (fsLit "unRec1") +unK1_RDR = varQual_RDR gHC_GENERICS (fsLit "unK1") +unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1") + from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") to_RDR = varQual_RDR gHC_GENERICS (fsLit "to") @@ -825,7 +853,9 @@ negateName = methName gHC_NUM (fsLit "negate") negateClassOpKey integerTyConName, mkIntegerName, integerToWord64Name, integerToInt64Name, + word64ToIntegerName, int64ToIntegerName, plusIntegerName, timesIntegerName, smallIntegerName, + wordToIntegerName, integerToWordName, integerToIntName, minusIntegerName, negateIntegerName, eqIntegerName, neqIntegerName, absIntegerName, signumIntegerName, @@ -834,6 +864,7 @@ integerTyConName, mkIntegerName, quotIntegerName, remIntegerName, floatFromIntegerName, doubleFromIntegerName, encodeFloatIntegerName, encodeDoubleIntegerName, + decodeDoubleIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, shiftLIntegerName, shiftRIntegerName :: Name @@ -841,9 +872,12 @@ integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") int mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey +word64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "word64ToInteger") word64ToIntegerIdKey +int64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "int64ToInteger") int64ToIntegerIdKey plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey +wordToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "wordToInteger") wordToIntegerIdKey integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") integerToWordIdKey integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey @@ -865,6 +899,7 @@ floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey +decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey @@ -961,6 +996,11 @@ datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey +-- GHCi things +ghciIoClassName, ghciStepIoMName :: Name +ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey +ghciStepIoMName = methName gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey + -- IO things ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, failIOName :: Name @@ -989,8 +1029,8 @@ word8TyConName = tcQual gHC_WORD (fsLit "Word8") word8TyConKey word16TyConName = tcQual gHC_WORD (fsLit "Word16") word16TyConKey word32TyConName = tcQual gHC_WORD (fsLit "Word32") word32TyConKey word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey -wordTyConName = tcQual gHC_WORD (fsLit "Word") wordTyConKey -wordDataConName = conName gHC_WORD (fsLit "W#") wordDataConKey +wordTyConName = tcQual gHC_TYPES (fsLit "Word") wordTyConKey +wordDataConName = conName gHC_TYPES (fsLit "W#") wordDataConKey -- PrelPtr module ptrTyConName, funPtrTyConName :: Name @@ -1039,6 +1079,25 @@ randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey +-- Type-level naturals +typeNatKindConName, typeStringKindConName, + singIClassName, typeNatLeqClassName, + typeNatAddTyFamName, typeNatMulTyFamName, typeNatExpTyFamName :: Name +typeNatKindConName = tcQual gHC_TYPELITS (fsLit "Nat") typeNatKindConNameKey +typeStringKindConName = tcQual gHC_TYPELITS (fsLit "Symbol") + typeStringKindConNameKey +singIClassName = clsQual gHC_TYPELITS (fsLit "SingI") singIClassNameKey +typeNatLeqClassName = clsQual gHC_TYPELITS (fsLit "<=") typeNatLeqClassNameKey +typeNatAddTyFamName = tcQual gHC_TYPELITS (fsLit "+") typeNatAddTyFamNameKey +typeNatMulTyFamName = tcQual gHC_TYPELITS (fsLit "*") typeNatMulTyFamNameKey +typeNatExpTyFamName = tcQual gHC_TYPELITS (fsLit "^") typeNatExpTyFamNameKey + +-- Implicit parameters +ipClassName :: Name +ipClassName = clsQual gHC_IP (fsLit "IP") ipClassNameKey + + + -- dotnet interop objectTyConName :: Name objectTyConName = tcQual dOTNET (fsLit "Object") objectTyConKey @@ -1152,6 +1211,16 @@ gen1ClassKey = mkPreludeClassUnique 38 datatypeClassKey = mkPreludeClassUnique 39 constructorClassKey = mkPreludeClassUnique 40 selectorClassKey = mkPreludeClassUnique 41 + +singIClassNameKey, typeNatLeqClassNameKey :: Unique +singIClassNameKey = mkPreludeClassUnique 42 +typeNatLeqClassNameKey = mkPreludeClassUnique 43 + +ghciIoClassKey :: Unique +ghciIoClassKey = mkPreludeClassUnique 44 + +ipClassNameKey :: Unique +ipClassNameKey = mkPreludeClassUnique 45 \end{code} %************************************************************************ @@ -1255,19 +1324,16 @@ eitherTyConKey :: Unique eitherTyConKey = mkPreludeTyConUnique 84 -- Super Kinds constructors -tySuperKindTyConKey :: Unique -tySuperKindTyConKey = mkPreludeTyConUnique 85 +superKindTyConKey :: Unique +superKindTyConKey = mkPreludeTyConUnique 85 -- Kind constructors liftedTypeKindTyConKey, anyKindTyConKey, openTypeKindTyConKey, - unliftedTypeKindTyConKey, ubxTupleKindTyConKey, argTypeKindTyConKey, - constraintKindTyConKey :: Unique + unliftedTypeKindTyConKey, constraintKindTyConKey :: Unique anyKindTyConKey = mkPreludeTyConUnique 86 liftedTypeKindTyConKey = mkPreludeTyConUnique 87 openTypeKindTyConKey = mkPreludeTyConUnique 88 unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 -ubxTupleKindTyConKey = mkPreludeTyConUnique 90 -argTypeKindTyConKey = mkPreludeTyConUnique 91 constraintKindTyConKey = mkPreludeTyConUnique 92 -- Coercion constructors @@ -1334,6 +1400,16 @@ noSelTyConKey = mkPreludeTyConUnique 154 repTyConKey = mkPreludeTyConUnique 155 rep1TyConKey = mkPreludeTyConUnique 156 +-- Type-level naturals +typeNatKindConNameKey, typeStringKindConNameKey, + typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey + :: Unique +typeNatKindConNameKey = mkPreludeTyConUnique 160 +typeStringKindConNameKey = mkPreludeTyConUnique 161 +typeNatAddTyFamNameKey = mkPreludeTyConUnique 162 +typeNatMulTyFamNameKey = mkPreludeTyConUnique 163 +typeNatExpTyFamNameKey = mkPreludeTyConUnique 164 + ---------------- Template Haskell ------------------- -- USES TyConUniques 200-299 ----------------------------------------------------- @@ -1452,8 +1528,10 @@ otherwiseIdKey = mkPreludeMiscIdUnique 43 assertIdKey = mkPreludeMiscIdUnique 44 runSTRepIdKey = mkPreludeMiscIdUnique 45 -mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey, +mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey, + integerToWordIdKey, integerToIntIdKey, integerToWord64IdKey, integerToInt64IdKey, + word64ToIntegerIdKey, int64ToIntegerIdKey, plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, negateIntegerIdKey, eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey, @@ -1462,6 +1540,7 @@ mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey, quotIntegerIdKey, remIntegerIdKey, floatFromIntegerIdKey, doubleFromIntegerIdKey, encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey, + decodeDoubleIntegerIdKey, gcdIntegerIdKey, lcmIntegerIdKey, andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey, shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique @@ -1500,6 +1579,10 @@ xorIntegerIdKey = mkPreludeMiscIdUnique 91 complementIntegerIdKey = mkPreludeMiscIdUnique 92 shiftLIntegerIdKey = mkPreludeMiscIdUnique 93 shiftRIntegerIdKey = mkPreludeMiscIdUnique 94 +wordToIntegerIdKey = mkPreludeMiscIdUnique 95 +word64ToIntegerIdKey = mkPreludeMiscIdUnique 96 +int64ToIntegerIdKey = mkPreludeMiscIdUnique 97 +decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 98 rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 100 @@ -1610,31 +1693,16 @@ guardMIdKey = mkPreludeMiscIdUnique 194 liftMIdKey = mkPreludeMiscIdUnique 195 mzipIdKey = mkPreludeMiscIdUnique 196 +-- GHCi +ghciStepIoMClassOpKey :: Unique +ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 + ---------------- Template Haskell ------------------- -- USES IdUniques 200-499 ----------------------------------------------------- \end{code} - -%************************************************************************ -%* * -\subsection{Standard groups of types} -%* * -%************************************************************************ - -\begin{code} -kindKeys :: [Unique] -kindKeys = [ anyKindTyConKey - , liftedTypeKindTyConKey - , openTypeKindTyConKey - , unliftedTypeKindTyConKey - , ubxTupleKindTyConKey - , argTypeKindTyConKey - , constraintKindTyConKey ] -\end{code} - - %************************************************************************ %* * \subsection[Class-std-groups]{Standard groups of Prelude classes} diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index fc0c20ad48..dab34fc69d 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -18,6 +18,8 @@ module PrelRules ( primOpRules, builtinRules ) where #include "HsVersions.h" +import {-# SOURCE #-} MkId ( mkPrimOpId ) + import CoreSyn import MkCore import Id @@ -41,6 +43,7 @@ import FastString import StaticFlags ( opt_SimplExcessPrecision ) import Constants import BasicTypes +import Util import Data.Bits as Bits import Data.Int ( Int64 ) @@ -343,9 +346,9 @@ litEq op_name is_eq ru_fn = op_name, ru_nargs = 2, ru_try = rule_fn }] where - rule_fn _ [Lit lit, expr] = do_lit_eq lit expr - rule_fn _ [expr, Lit lit] = do_lit_eq lit expr - rule_fn _ _ = Nothing + rule_fn _ _ [Lit lit, expr] = do_lit_eq lit expr + rule_fn _ _ [expr, Lit lit] = do_lit_eq lit expr + rule_fn _ _ _ = Nothing do_lit_eq lit expr | litIsLifted lit @@ -373,8 +376,8 @@ boundsCmp op_name op = [ rule ] , ru_nargs = 2 , ru_try = rule_fn } - rule_fn _ [a, b] = mkRuleFn op a b - rule_fn _ _ = Nothing + rule_fn _ _ [a, b] = mkRuleFn op a b + rule_fn _ _ _ = Nothing data Comparison = Gt | Ge | Lt | Le @@ -435,7 +438,7 @@ mkBasicRule :: Name -> Int mkBasicRule op_name n_args rule_fn = [BuiltinRule { ru_name = occNameFS (nameOccName op_name), ru_fn = op_name, - ru_nargs = n_args, ru_try = rule_fn }] + ru_nargs = n_args, ru_try = \_ -> rule_fn }] oneLit :: Name -> (Literal -> Maybe CoreExpr) -> [CoreRule] @@ -612,23 +615,23 @@ builtinRules :: [CoreRule] builtinRules = [BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_append_lit }, + ru_nargs = 4, ru_try = \_ -> match_append_lit }, BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = match_eq_string }, + ru_nargs = 2, ru_try = \_ -> match_eq_string }, BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = match_inline }] + ru_nargs = 2, ru_try = \_ -> match_inline }] ++ builtinIntegerRules builtinIntegerRules :: [CoreRule] builtinIntegerRules = - [-- TODO: smallInteger rule - -- TODO: wordToInteger rule + [rule_IntToInteger "smallInteger" smallIntegerName, + rule_WordToInteger "wordToInteger" wordToIntegerName, + rule_Int64ToInteger "int64ToInteger" int64ToIntegerName, + rule_Word64ToInteger "word64ToInteger" word64ToIntegerName, rule_convert "integerToWord" integerToWordName mkWordLitWord, rule_convert "integerToInt" integerToIntName mkIntLitInt, rule_convert "integerToWord64" integerToWord64Name mkWord64LitWord64, - -- TODO: word64ToInteger rule rule_convert "integerToInt64" integerToInt64Name mkInt64LitInt64, - -- TODO: int64ToInteger rule rule_binop "plusInteger" plusIntegerName (+), rule_binop "minusInteger" minusIntegerName (-), rule_binop "timesInteger" timesIntegerName (*), @@ -649,7 +652,7 @@ builtinIntegerRules = rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, rule_convert "floatFromInteger" floatFromIntegerName mkFloatLitFloat, rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, - -- TODO: decodeDoubleInteger rule + rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, rule_convert "doubleFromInteger" doubleFromIntegerName mkDoubleLitDouble, rule_binop "gcdInteger" gcdIntegerName gcd, rule_binop "lcmInteger" lcmIntegerName lcm, @@ -658,10 +661,30 @@ builtinIntegerRules = rule_binop "xorInteger" xorIntegerName xor, rule_unop "complementInteger" complementIntegerName complement, rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL, - rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR] + rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR, + -- These rules below don't actually have to be built in, but if we + -- put them in the Haskell source then we'd have to duplicate them + -- between all Integer implementations + rule_smallIntegerToInt "smallIntegerToInt" integerToIntName, + rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp, + rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp, + rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp + ] where rule_convert str name convert = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_Integer_convert convert } + rule_IntToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_IntToInteger } + rule_WordToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_WordToInteger } + rule_Int64ToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Int64ToInteger } + rule_Word64ToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Word64ToInteger } rule_unop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_Integer_unop op } @@ -686,6 +709,15 @@ builtinIntegerRules = rule_encodeFloat str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_Int_encodeFloat op } + rule_decodeDouble str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_decodeDouble } + rule_smallIntegerToInt str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_smallIntegerToInt } + rule_smallIntegerTo str name primOp + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_smallIntegerTo primOp } --------------------------------------------------- -- The rule is this: @@ -749,108 +781,204 @@ match_inline _ _ = Nothing -- Integer rules +match_IntToInteger :: Id + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_IntToInteger id id_unf [xl] + | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl + = case idType id of + FunTy _ integerTy -> + Just (Lit (LitInteger x integerTy)) + _ -> + panic "match_IntToInteger: Id has the wrong type" +match_IntToInteger _ _ _ = Nothing + +match_WordToInteger :: Id + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_WordToInteger id id_unf [xl] + | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl + = case idType id of + FunTy _ integerTy -> + Just (Lit (LitInteger x integerTy)) + _ -> + panic "match_WordToInteger: Id has the wrong type" +match_WordToInteger _ _ _ = Nothing + +match_Int64ToInteger :: Id + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Int64ToInteger id id_unf [xl] + | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl + = case idType id of + FunTy _ integerTy -> + Just (Lit (LitInteger x integerTy)) + _ -> + panic "match_Int64ToInteger: Id has the wrong type" +match_Int64ToInteger _ _ _ = Nothing + +match_Word64ToInteger :: Id + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Word64ToInteger id id_unf [xl] + | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl + = case idType id of + FunTy _ integerTy -> + Just (Lit (LitInteger x integerTy)) + _ -> + panic "match_Word64ToInteger: Id has the wrong type" +match_Word64ToInteger _ _ _ = Nothing + match_Integer_convert :: Num a => (a -> Expr CoreBndr) + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_convert convert id_unf [xl] +match_Integer_convert convert _ id_unf [xl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl = Just (convert (fromInteger x)) -match_Integer_convert _ _ _ = Nothing +match_Integer_convert _ _ _ _ = Nothing match_Integer_unop :: (Integer -> Integer) + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_unop unop id_unf [xl] +match_Integer_unop unop _ id_unf [xl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl = Just (Lit (LitInteger (unop x) i)) -match_Integer_unop _ _ _ = Nothing +match_Integer_unop _ _ _ _ = Nothing match_Integer_binop :: (Integer -> Integer -> Integer) + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_binop binop id_unf [xl,yl] +match_Integer_binop binop _ id_unf [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl = Just (Lit (LitInteger (x `binop` y) i)) -match_Integer_binop _ _ _ = Nothing +match_Integer_binop _ _ _ _ = Nothing -- This helper is used for the quotRem and divMod functions match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer)) + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_divop_both divop id_unf [xl,yl] - | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl +match_Integer_divop_both divop _ id_unf [xl,yl] + | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 , (r,s) <- x `divop` y - = case idType i of - FunTy _ (FunTy _ integerTy) -> - Just $ mkConApp (tupleCon UnboxedTuple 2) - [Type integerTy, - Type integerTy, - Lit (LitInteger r i), - Lit (LitInteger s i)] - _ -> panic "match_Integer_divop_both: mkIntegerId has the wrong type" -match_Integer_divop_both _ _ _ = Nothing + = Just $ mkConApp (tupleCon UnboxedTuple 2) + [Type t, + Type t, + Lit (LitInteger r t), + Lit (LitInteger s t)] +match_Integer_divop_both _ _ _ _ = Nothing -- This helper is used for the quotRem and divMod functions match_Integer_divop_one :: (Integer -> Integer -> Integer) + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_divop_one divop id_unf [xl,yl] +match_Integer_divop_one divop _ id_unf [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 = Just (Lit (LitInteger (x `divop` y) i)) -match_Integer_divop_one _ _ _ = Nothing +match_Integer_divop_one _ _ _ _ = Nothing match_Integer_Int_binop :: (Integer -> Int -> Integer) + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_Int_binop binop id_unf [xl,yl] +match_Integer_Int_binop binop _ id_unf [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl = Just (Lit (LitInteger (x `binop` fromIntegral y) i)) -match_Integer_Int_binop _ _ _ = Nothing +match_Integer_Int_binop _ _ _ _ = Nothing match_Integer_binop_Bool :: (Integer -> Integer -> Bool) + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_binop_Bool binop id_unf [xl, yl] +match_Integer_binop_Bool binop _ id_unf [xl, yl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl = Just (if x `binop` y then trueVal else falseVal) -match_Integer_binop_Bool _ _ _ = Nothing +match_Integer_binop_Bool _ _ _ _ = Nothing match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_binop_Ordering binop id_unf [xl, yl] +match_Integer_binop_Ordering binop _ id_unf [xl, yl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl = Just $ case x `binop` y of LT -> ltVal EQ -> eqVal GT -> gtVal -match_Integer_binop_Ordering _ _ _ = Nothing +match_Integer_binop_Ordering _ _ _ _ = Nothing match_Integer_Int_encodeFloat :: RealFloat a => (a -> Expr CoreBndr) + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_Int_encodeFloat mkLit id_unf [xl,yl] +match_Integer_Int_encodeFloat mkLit _ id_unf [xl,yl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl = Just (mkLit $ encodeFloat x (fromInteger y)) -match_Integer_Int_encodeFloat _ _ _ = Nothing +match_Integer_Int_encodeFloat _ _ _ _ = Nothing + +match_decodeDouble :: Id + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_decodeDouble fn id_unf [xl] + | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl + = case idType fn of + FunTy _ (TyConApp _ [integerTy, intHashTy]) -> + case decodeFloat (fromRational x :: Double) of + (y, z) -> + Just $ mkConApp (tupleCon UnboxedTuple 2) + [Type integerTy, + Type intHashTy, + Lit (LitInteger y integerTy), + Lit (MachInt (toInteger z))] + _ -> + panic "match_decodeDouble: Id has the wrong type" +match_decodeDouble _ _ _ = Nothing + +match_smallIntegerToInt :: Id + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_smallIntegerToInt _ _ [App (Var x) y] + | idName x == smallIntegerName + = Just y +match_smallIntegerToInt _ _ _ = Nothing + +match_smallIntegerTo :: PrimOp + -> Id + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_smallIntegerTo primOp _ _ [App (Var x) y] + | idName x == smallIntegerName + = Just $ App (Var (mkPrimOpId primOp)) y +match_smallIntegerTo _ _ _ _ = Nothing \end{code} diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index 39bee1fb9d..b055376060 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -80,9 +80,6 @@ instance Ord PrimOp where instance Outputable PrimOp where ppr op = pprPrimOp op - -instance Show PrimOp where - showsPrec p op = showsPrecSDoc p (pprPrimOp op) \end{code} An @Enum@-derived list would be better; meanwhile... (ToDo) diff --git a/compiler/prelude/PrimOp.lhs-boot b/compiler/prelude/PrimOp.lhs-boot new file mode 100644 index 0000000000..5d003f2b51 --- /dev/null +++ b/compiler/prelude/PrimOp.lhs-boot @@ -0,0 +1,7 @@ + +\begin{code} +module PrimOp where + +data PrimOp +\end{code} + diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index a3c2c6bb83..1b8d96df35 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -21,23 +21,20 @@ module TysPrim( tyVarList, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTy, betaTy, gammaTy, deltaTy, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, - argAlphaTy, argAlphaTyVar, argAlphaTyVars, argBetaTy, argBetaTyVar, kKiVar, -- Kind constructors... - tySuperKindTyCon, tySuperKind, anyKindTyCon, - liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, + superKindTyCon, superKind, anyKindTyCon, liftedTypeKindTyCon, + openTypeKindTyCon, unliftedTypeKindTyCon, constraintKindTyCon, - tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName, + superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName, - ubxTupleKindTyConName, argTypeKindTyConName, constraintKindTyConName, -- Kinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, constraintKind, + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, + typeNatKind, typeStringKind, funTyCon, funTyConName, primTyCons, @@ -131,15 +128,14 @@ primTyCons , word32PrimTyCon , word64PrimTyCon , anyTyCon - , anyKindTyCon , eqPrimTyCon , liftedTypeKindTyCon , unliftedTypeKindTyCon , openTypeKindTyCon - , argTypeKindTyCon - , ubxTupleKindTyCon , constraintKindTyCon + , superKindTyCon + , anyKindTyCon ] mkPrimTc :: FastString -> Unique -> TyCon -> Name @@ -224,15 +220,8 @@ openAlphaTy, openBetaTy :: Type openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy = mkTyVarTy openBetaTyVar -argAlphaTyVars :: [TyVar] -argAlphaTyVar, argBetaTyVar :: TyVar -argAlphaTyVars@(argAlphaTyVar : argBetaTyVar : _) = tyVarList argTypeKind -argAlphaTy, argBetaTy :: Type -argAlphaTy = mkTyVarTy argAlphaTyVar -argBetaTy = mkTyVarTy argBetaTyVar - kKiVar :: KindVar -kKiVar = (tyVarList tySuperKind) !! 10 +kKiVar = (tyVarList superKind) !! 10 \end{code} @@ -281,38 +270,52 @@ funTyCon = mkFunTyCon funTyConName $ %* * %************************************************************************ +Note [SuperKind (BOX)] +~~~~~~~~~~~~~~~~~~~~~~ +Kinds are classified by "super-kinds". There is only one super-kind, namely BOX. + +Perhaps surprisingly we give BOX the kind BOX, thus BOX :: BOX +Reason: we want to have kind equalities, thus (without the kind applications) + keq :: * ~ * = Eq# <refl *> +Remember that + (~) :: forall (k:BOX). k -> k -> Constraint + (~#) :: forall (k:BOX). k -> k -> # + Eq# :: forall (k:BOX). forall (a:k) (b:k). (~#) k a b -> (~) k a b + +So the full defn of keq is + keq :: (~) BOX * * = Eq# BOX * * <refl *> + +So you can see it's convenient to have BOX:BOX + + \begin{code} -- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's -tySuperKindTyCon, anyKindTyCon, liftedTypeKindTyCon, +superKindTyCon, anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - ubxTupleKindTyCon, argTypeKindTyCon, constraintKindTyCon :: TyCon -tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName, +superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName, - ubxTupleKindTyConName, argTypeKindTyConName, constraintKindTyConName :: Name -tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName -anyKindTyCon = mkKindTyCon anyKindTyConName tySuperKind -liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind -openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind -unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind -ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind -argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind -constraintKindTyCon = mkKindTyCon constraintKindTyConName tySuperKind +superKindTyCon = mkKindTyCon superKindTyConName superKind + -- See Note [SuperKind (BOX)] + +anyKindTyCon = mkKindTyCon anyKindTyConName superKind +liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName superKind +openTypeKindTyCon = mkKindTyCon openTypeKindTyConName superKind +unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName superKind +constraintKindTyCon = mkKindTyCon constraintKindTyConName superKind -------------------------- -- ... and now their names -tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon -anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon +superKindTyConName = mkPrimTyConName (fsLit "BOX") superKindTyConKey superKindTyCon +anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon openTypeKindTyConName = mkPrimTyConName (fsLit "OpenKind") openTypeKindTyConKey openTypeKindTyCon unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon -ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon -argTypeKindTyConName = mkPrimTyConName (fsLit "ArgKind") argTypeKindTyConKey argTypeKindTyCon constraintKindTyConName = mkPrimTyConName (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon mkPrimTyConName :: FastString -> Unique -> TyCon -> Name @@ -330,17 +333,21 @@ kindTyConType :: TyCon -> Type kindTyConType kind = TyConApp kind [] -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind +anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, superKind :: Kind --- See Note [Any kinds] -anyKind = kindTyConType anyKindTyCon +superKind = kindTyConType superKindTyCon +anyKind = kindTyConType anyKindTyCon -- See Note [Any kinds] liftedTypeKind = kindTyConType liftedTypeKindTyCon unliftedTypeKind = kindTyConType unliftedTypeKindTyCon openTypeKind = kindTyConType openTypeKindTyCon -argTypeKind = kindTyConType argTypeKindTyCon -ubxTupleKind = kindTyConType ubxTupleKindTyCon constraintKind = kindTyConType constraintKindTyCon +typeNatKind :: Kind +typeNatKind = kindTyConType (mkKindTyCon typeNatKindConName superKind) + +typeStringKind :: Kind +typeStringKind = kindTyConType (mkKindTyCon typeStringKindConName superKind) + -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ mkArrowKind :: Kind -> Kind -> Kind mkArrowKind k1 k2 = FunTy k1 k2 @@ -348,9 +355,6 @@ mkArrowKind k1 k2 = FunTy k1 k2 -- | Iterated application of 'mkArrowKind' mkArrowKinds :: [Kind] -> Kind -> Kind mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds - -tySuperKind :: SuperKind -tySuperKind = kindTyConType tySuperKindTyCon \end{code} %************************************************************************ @@ -457,7 +461,7 @@ keep different state threads separate. It is represented by nothing at all. \begin{code} mkStatePrimTy :: Type -> Type -mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] +mkStatePrimTy ty = mkNakedTyConApp statePrimTyCon [ty] statePrimTyCon :: TyCon -- See Note [The State# TyCon] statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep @@ -503,17 +507,17 @@ arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRe mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName 1 PtrRep mkArrayPrimTy :: Type -> Type -mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt] +mkArrayPrimTy elt = mkNakedTyConApp arrayPrimTyCon [elt] byteArrayPrimTy :: Type byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon mkArrayArrayPrimTy :: Type mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon mkMutableArrayPrimTy :: Type -> Type -> Type -mkMutableArrayPrimTy s elt = mkTyConApp mutableArrayPrimTyCon [s, elt] +mkMutableArrayPrimTy s elt = mkNakedTyConApp mutableArrayPrimTyCon [s, elt] mkMutableByteArrayPrimTy :: Type -> Type -mkMutableByteArrayPrimTy s = mkTyConApp mutableByteArrayPrimTyCon [s] +mkMutableByteArrayPrimTy s = mkNakedTyConApp mutableByteArrayPrimTyCon [s] mkMutableArrayArrayPrimTy :: Type -> Type -mkMutableArrayArrayPrimTy s = mkTyConApp mutableArrayArrayPrimTyCon [s] +mkMutableArrayArrayPrimTy s = mkNakedTyConApp mutableArrayArrayPrimTyCon [s] \end{code} %************************************************************************ @@ -527,7 +531,7 @@ mutVarPrimTyCon :: TyCon mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep mkMutVarPrimTy :: Type -> Type -> Type -mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] +mkMutVarPrimTy s elt = mkNakedTyConApp mutVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -541,7 +545,7 @@ mVarPrimTyCon :: TyCon mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep mkMVarPrimTy :: Type -> Type -> Type -mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] +mkMVarPrimTy s elt = mkNakedTyConApp mVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -555,7 +559,7 @@ tVarPrimTyCon :: TyCon tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep mkTVarPrimTy :: Type -> Type -> Type -mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt] +mkTVarPrimTy s elt = mkNakedTyConApp tVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -569,7 +573,7 @@ stablePtrPrimTyCon :: TyCon stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep mkStablePtrPrimTy :: Type -> Type -mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] +mkStablePtrPrimTy ty = mkNakedTyConApp stablePtrPrimTyCon [ty] \end{code} %************************************************************************ @@ -583,7 +587,7 @@ stableNamePrimTyCon :: TyCon stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep mkStableNamePrimTy :: Type -> Type -mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty] +mkStableNamePrimTy ty = mkNakedTyConApp stableNamePrimTyCon [ty] \end{code} %************************************************************************ @@ -610,7 +614,7 @@ weakPrimTyCon :: TyCon weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep mkWeakPrimTy :: Type -> Type -mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v] +mkWeakPrimTy v = mkNakedTyConApp weakPrimTyCon [v] \end{code} %************************************************************************ @@ -711,5 +715,5 @@ anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) anyTypeOfKind :: Kind -> Type -anyTypeOfKind kind = mkTyConApp anyTyCon [kind] +anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind] \end{code} diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 162a7025c0..78e1f74b4d 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -48,14 +48,14 @@ module TysWiredIn ( wordTyCon, wordDataCon, wordTyConName, wordTy, -- * List - listTyCon, nilDataCon, consDataCon, + listTyCon, nilDataCon, consDataCon, consDataConName, listTyCon_RDR, consDataCon_RDR, listTyConName, mkListTy, mkPromotedListTy, -- * Tuples mkTupleTy, mkBoxedTupleTy, - tupleTyCon, promotedTupleTyCon, - tupleCon, + tupleTyCon, tupleCon, + promotedTupleTyCon, promotedTupleDataCon, unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, unboxedSingletonTyCon, unboxedSingletonDataCon, @@ -72,8 +72,6 @@ module TysWiredIn ( -- * Equality predicates eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon, - -- * Implicit parameter predicates - mkIPName ) where #include "HsVersions.h" @@ -85,23 +83,25 @@ import PrelNames import TysPrim -- others: -import Coercion import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) +import Type ( mkTyConApp ) import DataCon import Var import TyCon import TypeRep import RdrName import Name -import BasicTypes ( TupleSort(..), tupleSortBoxity, IPName(..), +import BasicTypes ( TupleSort(..), tupleSortBoxity, Arity, RecFlag(..), Boxity(..), HsBang(..) ) +import ForeignCall import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import Data.Array import FastString import Outputable import Config +import Util alpha_tyvar :: [TyVar] alpha_tyvar = [alphaTyVar] @@ -229,18 +229,19 @@ eqTyCon_RDR = nameRdrName eqTyConName %************************************************************************ \begin{code} -pcNonRecDataTyCon :: Name -> [TyVar] -> [DataCon] -> TyCon +pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon pcNonRecDataTyCon = pcTyCon False NonRecursive -pcRecDataTyCon :: Name -> [TyVar] -> [DataCon] -> TyCon +pcRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon pcRecDataTyCon = pcTyCon False Recursive -pcTyCon :: Bool -> RecFlag -> Name -> [TyVar] -> [DataCon] -> TyCon -pcTyCon is_enum is_rec name tyvars cons +pcTyCon :: Bool -> RecFlag -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon +pcTyCon is_enum is_rec name cType tyvars cons = tycon where tycon = mkAlgTyCon name (mkArrowKinds (map tyVarKind tyvars) liftedTypeKind) tyvars + cType [] -- No stupid theta (DataTyCon cons is_enum) NoParentTyCon @@ -250,9 +251,6 @@ pcTyCon is_enum is_rec name tyvars cons pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon pcDataCon = pcDataConWithFixity False -pcDataCon' :: Name -> Unique -> [TyVar] -> [Type] -> TyCon -> DataCon -pcDataCon' = pcDataConWithFixity' False - pcDataConWithFixity :: Bool -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique n)) -- The Name's unique is the first of two free uniques; @@ -326,6 +324,9 @@ tupleTyCon ConstraintTuple i = fst (factTupleArr ! i) promotedTupleTyCon :: TupleSort -> Arity -> TyCon promotedTupleTyCon sort i = buildPromotedTyCon (tupleTyCon sort i) +promotedTupleDataCon :: TupleSort -> Arity -> TyCon +promotedTupleDataCon sort i = buildPromotedDataCon (tupleCon sort i) + tupleCon :: TupleSort -> Arity -> DataCon tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially tupleCon BoxedTuple i = snd (boxedTupleArr ! i) @@ -347,12 +348,12 @@ mk_tuple sort arity = (tycon, tuple_con) tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind res_kind = case sort of BoxedTuple -> liftedTypeKind - UnboxedTuple -> ubxTupleKind + UnboxedTuple -> unliftedTypeKind ConstraintTuple -> constraintKind tyvars = take arity $ case sort of BoxedTuple -> alphaTyVars - UnboxedTuple -> argAlphaTyVars -- No nested unboxed tuples + UnboxedTuple -> openAlphaTyVars ConstraintTuple -> tyVarList constraintKind tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon @@ -388,38 +389,6 @@ unboxedPairDataCon :: DataCon unboxedPairDataCon = tupleCon UnboxedTuple 2 \end{code} -%************************************************************************ -%* * -\subsection[TysWiredIn-ImplicitParams]{Special type constructors for implicit parameters} -%* * -%************************************************************************ - -\begin{code} -mkIPName :: FastString - -> Unique -> Unique -> Unique -> Unique - -> IPName Name -mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip - where - name_ip = IPName tycon_name - - tycon_name = mkPrimTyConName ip tycon_u tycon - tycon = mkAlgTyCon tycon_name - (liftedTypeKind `mkArrowKind` constraintKind) - [alphaTyVar] - [] -- No stupid theta - (NewTyCon { data_con = datacon, - nt_rhs = mkTyVarTy alphaTyVar, - nt_etad_rhs = ([alphaTyVar], mkTyVarTy alphaTyVar), - nt_co = mkNewTypeCo co_ax_name tycon [alphaTyVar] (mkTyVarTy alphaTyVar) }) - (IPTyCon name_ip) - NonRecursive - False - - datacon_name = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "IPBox") datacon_u datacon - datacon = pcDataCon' datacon_name dc_wrk_u [alphaTyVar] [mkTyVarTy alphaTyVar] tycon - - co_ax_name = mkPrimTyConName ip co_ax_u tycon -\end{code} %************************************************************************ %* * @@ -432,6 +401,7 @@ eqTyCon :: TyCon eqTyCon = mkAlgTyCon eqTyConName (ForAllTy kv $ mkArrowKinds [k, k] constraintKind) [kv, a, b] + Nothing [] -- No stupid theta (DataTyCon [eqBoxDataCon] False) NoParentTyCon @@ -456,7 +426,8 @@ charTy :: Type charTy = mkTyConTy charTyCon charTyCon :: TyCon -charTyCon = pcNonRecDataTyCon charTyConName [] [charDataCon] +charTyCon = pcNonRecDataTyCon charTyConName (Just (CType Nothing (fsLit "HsChar"))) + [] [charDataCon] charDataCon :: DataCon charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon @@ -468,7 +439,7 @@ stringTy = mkListTy charTy -- convenience only integerTyCon :: TyCon integerTyCon = case cIntegerLibraryType of IntegerGMP -> - pcNonRecDataTyCon integerRealTyConName [] + pcNonRecDataTyCon integerRealTyConName Nothing [] [integerGmpSDataCon, integerGmpJDataCon] _ -> panic "Evaluated integerTyCon, but not using IntegerGMP" @@ -491,7 +462,7 @@ intTy :: Type intTy = mkTyConTy intTyCon intTyCon :: TyCon -intTyCon = pcNonRecDataTyCon intTyConName [] [intDataCon] +intTyCon = pcNonRecDataTyCon intTyConName (Just (CType Nothing (fsLit "HsInt"))) [] [intDataCon] intDataCon :: DataCon intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon \end{code} @@ -501,7 +472,7 @@ wordTy :: Type wordTy = mkTyConTy wordTyCon wordTyCon :: TyCon -wordTyCon = pcNonRecDataTyCon wordTyConName [] [wordDataCon] +wordTyCon = pcNonRecDataTyCon wordTyConName (Just (CType Nothing (fsLit "HsWord"))) [] [wordDataCon] wordDataCon :: DataCon wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon \end{code} @@ -511,7 +482,7 @@ floatTy :: Type floatTy = mkTyConTy floatTyCon floatTyCon :: TyCon -floatTyCon = pcNonRecDataTyCon floatTyConName [] [floatDataCon] +floatTyCon = pcNonRecDataTyCon floatTyConName (Just (CType Nothing (fsLit "HsFloat"))) [] [floatDataCon] floatDataCon :: DataCon floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon \end{code} @@ -521,7 +492,7 @@ doubleTy :: Type doubleTy = mkTyConTy doubleTyCon doubleTyCon :: TyCon -doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [doubleDataCon] +doubleTyCon = pcNonRecDataTyCon doubleTyConName (Just (CType Nothing (fsLit "HsDouble"))) [] [doubleDataCon] doubleDataCon :: DataCon doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon @@ -582,7 +553,8 @@ boolTy = mkTyConTy boolTyCon boolTyCon :: TyCon boolTyCon = pcTyCon True NonRecursive boolTyConName - [] [falseDataCon, trueDataCon] + (Just (CType Nothing (fsLit "HsBool"))) + [] [falseDataCon, trueDataCon] falseDataCon, trueDataCon :: DataCon falseDataCon = pcDataCon falseDataConName [] [] boolTyCon @@ -593,7 +565,7 @@ falseDataConId = dataConWorkId falseDataCon trueDataConId = dataConWorkId trueDataCon orderingTyCon :: TyCon -orderingTyCon = pcTyCon True NonRecursive orderingTyConName +orderingTyCon = pcTyCon True NonRecursive orderingTyConName Nothing [] [ltDataCon, eqDataCon, gtDataCon] ltDataCon, eqDataCon, gtDataCon :: DataCon @@ -627,7 +599,7 @@ mkListTy :: Type -> Type mkListTy ty = mkTyConApp listTyCon [ty] listTyCon :: TyCon -listTyCon = pcRecDataTyCon listTyConName alpha_tyvar [nilDataCon, consDataCon] +listTyCon = pcRecDataTyCon listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon] mkPromotedListTy :: Type -> Type mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty] @@ -729,7 +701,7 @@ mkPArrTy ty = mkTyConApp parrTyCon [ty] -- @PrelPArr@. -- parrTyCon :: TyCon -parrTyCon = pcNonRecDataTyCon parrTyConName alpha_tyvar [parrDataCon] +parrTyCon = pcNonRecDataTyCon parrTyConName Nothing alpha_tyvar [parrDataCon] parrDataCon :: DataCon parrDataCon = pcDataCon diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 48dd76873a..cddb62a7d5 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -210,6 +210,11 @@ primop IntRemOp "remInt#" Dyadic {Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}.} with can_fail = True +primop IntQuotRemOp "quotRemInt#" GenPrimOp + Int# -> Int# -> (# Int#, Int# #) + {Rounds towards zero.} + with can_fail = True + primop IntNegOp "negateInt#" Monadic Int# -> Int# primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) {Add with carry. First member of result is (wrapped) sum; @@ -264,17 +269,37 @@ primtype Word# primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word# with commutable = True +-- Returns (# high, low #) (or equivalently, (# carry, low #)) +primop WordAdd2Op "plusWord2#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with commutable = True + primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word# primop WordMulOp "timesWord#" Dyadic Word# -> Word# -> Word# with commutable = True +-- Returns (# high, low #) +primop WordMul2Op "timesWord2#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with commutable = True + primop WordQuotOp "quotWord#" Dyadic Word# -> Word# -> Word# with can_fail = True primop WordRemOp "remWord#" Dyadic Word# -> Word# -> Word# with can_fail = True +primop WordQuotRemOp "quotRemWord#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with can_fail = True + +-- Takes high word of dividend, then low word of dividend, then divisor. +-- Requires that high word is not divisible by divisor. +primop WordQuotRem2Op "quotRemWord2#" GenPrimOp + Word# -> Word# -> Word# -> (# Word#, Word# #) + with can_fail = True + primop AndOp "and#" Dyadic Word# -> Word# -> Word# with commutable = True @@ -1032,6 +1057,14 @@ primop CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp code_size = { primOpCodeSizeForeignCall + 4 } can_fail = True +primop SetByteArrayOp "setByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s + {Set the range of the MutableByteArray# to the specified character.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4 } + can_fail = True + ------------------------------------------------------------------------ section "Arrays of arrays" {Operations on {\tt ArrayArray\#}. An {\tt ArrayArray\#} contains references to {\em unpointed} @@ -1796,6 +1829,12 @@ primop MkWeakOp "mkWeak#" GenPrimOp has_side_effects = True out_of_line = True +primop MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp + o -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #) + with + has_side_effects = True + out_of_line = True + primop MkWeakForeignEnvOp "mkWeakForeignEnv#" GenPrimOp o -> b -> Addr# -> Addr# -> Int# -> Addr# -> State# RealWorld -> (# State# RealWorld, Weak# b #) with diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index a4d7d1a398..b342c31380 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -149,9 +149,9 @@ mkAutoCC id mod is_caf -- Unique. -- See bug #249, tests prof001, prof002, also #2411 str | isExternalName name = occNameFS (getOccName id) - | otherwise = mkFastString $ showSDoc $ - ftext (occNameFS (getOccName id)) - <> char '_' <> pprUnique (getUnique name) + | otherwise = occNameFS (getOccName id) + `appendFS` + mkFastString ('_' : show (getUnique name)) mkAllCafsCC :: Module -> SrcSpan -> CostCentre mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs index fa99a752d1..7e223f80e9 100644 --- a/compiler/profiling/ProfInit.hs +++ b/compiler/profiling/ProfInit.hs @@ -11,7 +11,6 @@ module ProfInit (profilingInitCode) where import CLabel import CostCentre import Outputable -import Platform import StaticFlags import FastString import Module @@ -22,8 +21,8 @@ import Module -- We must produce declarations for the cost-centres defined in this -- module; -profilingInitCode :: Platform -> Module -> CollectedCCs -> SDoc -profilingInitCode platform this_mod (local_CCs, ___extern_CCs, singleton_CCSs) +profilingInitCode :: Module -> CollectedCCs -> SDoc +profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs) | not opt_SccProfilingOn = empty | otherwise = vcat @@ -39,8 +38,8 @@ profilingInitCode platform this_mod (local_CCs, ___extern_CCs, singleton_CCSs) emitRegisterCC cc = ptext (sLit "extern CostCentre ") <> cc_lbl <> ptext (sLit "[];") $$ ptext (sLit "REGISTER_CC(") <> cc_lbl <> char ')' <> semi - where cc_lbl = pprPlatform platform (mkCCLabel cc) + where cc_lbl = ppr (mkCCLabel cc) emitRegisterCCS ccs = ptext (sLit "extern CostCentreStack ") <> ccs_lbl <> ptext (sLit "[];") $$ ptext (sLit "REGISTER_CCS(") <> ccs_lbl <> char ')' <> semi - where ccs_lbl = pprPlatform platform (mkCCSLabel ccs) + where ccs_lbl = ppr (mkCCSLabel ccs) diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs index 6fc44c1df9..a6fe565746 100644 --- a/compiler/profiling/SCCfinal.lhs +++ b/compiler/profiling/SCCfinal.lhs @@ -34,6 +34,7 @@ import Outputable import DynFlags import FastString import SrcLoc +import Util stgMassageForProfiling diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 969a517629..d3d16033eb 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -33,10 +33,9 @@ module RnBinds ( import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn -import RnHsSyn import TcRnMonad import TcEvidence ( emptyTcEvBinds ) -import RnTypes ( rnIPName, rnHsSigType, rnLHsType, checkPrecMatch ) +import RnTypes ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch ) import RnPat import RnEnv import DynFlags @@ -47,7 +46,7 @@ import RdrName ( RdrName, rdrNameOcc ) import SrcLoc import ListSetOps ( findDupsEq ) import BasicTypes ( RecFlag(..) ) -import Digraph ( SCC(..), stronglyConnCompFromEdgedVertices ) +import Digraph ( SCC(..) ) import Bag import Outputable import FastString @@ -171,21 +170,21 @@ rnTopBindsLHS :: MiniFixityEnv rnTopBindsLHS fix_env binds = rnValBindsLHS (topRecNameMaker fix_env) binds -rnTopBindsRHS :: HsValBindsLR Name RdrName +rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnTopBindsRHS binds +rnTopBindsRHS bound_names binds = do { is_boot <- tcIsHsBoot ; if is_boot then rnTopBindsBoot binds - else rnValBindsRHS TopSigCtxt binds } + else rnValBindsRHS (TopSigCtxt bound_names False) binds } rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures rnTopBindsBoot (ValBindsIn mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) - ; sigs' <- renameSigs HsBootCtxt sigs - ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) } + ; (sigs', fvs) <- renameSigs HsBootCtxt sigs + ; return (ValBindsOut [] sigs', usesOnly fvs) } rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b) \end{code} @@ -221,10 +220,9 @@ rnIPBinds (IPBinds ip_binds _no_dict_binds) = do return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s) rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars) -rnIPBind (IPBind n expr) = do - n' <- rnIPName n +rnIPBind (IPBind ~(Left n) expr) = do (expr',fvExpr) <- rnLExpr expr - return (IPBind n' expr', fvExpr) + return (IPBind (Left n) expr', fvExpr) \end{code} @@ -291,13 +289,13 @@ rnValBindsRHS :: HsSigCtxt -> RnM (HsValBinds Name, DefUses) rnValBindsRHS ctxt (ValBindsIn mbinds sigs) - = do { sigs' <- renameSigs ctxt sigs + = do { (sigs', sig_fvs) <- renameSigs ctxt sigs ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds ; case depAnalBinds binds_w_dus of (anal_binds, anal_dus) -> return (valbind', valbind'_dus) where valbind' = ValBindsOut anal_binds sigs' - valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs') + valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs -- Put the sig uses *after* the bindings -- so that the binders are removed from -- the uses in the sigs @@ -507,17 +505,9 @@ depAnalBinds :: Bag (LHsBind Name, [Name], Uses) depAnalBinds binds_w_dus = (map get_binds sccs, map get_du sccs) where - sccs = stronglyConnCompFromEdgedVertices edges - - keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..] - - edges = [ (node, key, [key | n <- nameSetToList uses, - Just key <- [lookupNameEnv key_map n] ]) - | (node@(_,_,uses), key) <- keyd_nodes ] - - key_map :: NameEnv Int -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | ((_, bndrs, _), key) <- keyd_nodes - , bndr <- bndrs ] + sccs = depAnal (\(_, defs, _) -> defs) + (\(_, _, uses) -> nameSetToList uses) + (bagToList binds_w_dus) get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus]) @@ -528,7 +518,6 @@ depAnalBinds binds_w_dus defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus] - --------------------- -- Bind the top-level forall'd type variables in the sigs. -- E.g f :: a -> a @@ -549,7 +538,7 @@ mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] where env :: NameEnv [Name] - env = mkNameEnv [ (name, map hsLTyVarName ltvs) + env = mkNameEnv [ (name, hsLKiTyVarNames ltvs) -- Kind variables and type variables | L _ (TypeSig names (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs , (L _ name) <- names] @@ -649,7 +638,7 @@ signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} renameSigs :: HsSigCtxt -> [LSig RdrName] - -> RnM [LSig Name] + -> RnM ([LSig Name], FreeVars) -- Renames the signatures and performs error checks renameSigs ctxt sigs = do { mapM_ dupSigDeclErr (findDupsEq overlapHsSig sigs) -- Duplicate @@ -662,12 +651,12 @@ renameSigs ctxt sigs -- op :: a -> a -- default op :: Eq a => a -> a - ; sigs' <- mapM (wrapLocM (renameSig ctxt)) sigs + ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' ; mapM_ misplacedSigErr bad_sigs -- Misplaced - ; return good_sigs } + ; return (good_sigs, sig_fvs) } ---------------------- -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory @@ -679,26 +668,26 @@ renameSigs ctxt sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name) +renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars) -- FixitySig is renamed elsewhere. renameSig _ (IdSig x) - = return (IdSig x) -- Actually this never occurs + = return (IdSig x, emptyFVs) -- Actually this never occurs renameSig ctxt sig@(TypeSig vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty - ; return (TypeSig new_vs new_ty) } + ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty + ; return (TypeSig new_vs new_ty, fvs) } renameSig ctxt sig@(GenericSig vs ty) = do { defaultSigs_on <- xoptM Opt_DefaultSignatures ; unless defaultSigs_on (addErr (defaultSigErr sig)) ; new_v <- mapM (lookupSigOccRn ctxt sig) vs - ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty - ; return (GenericSig new_v new_ty) } + ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty + ; return (GenericSig new_v new_ty, fvs) } renameSig _ (SpecInstSig ty) - = do { new_ty <- rnLHsType SpecInstSigCtx ty - ; return (SpecInstSig new_ty) } + = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty + ; return (SpecInstSig new_ty,fvs) } -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) @@ -706,18 +695,18 @@ renameSig _ (SpecInstSig ty) -- then the SPECIALISE pragma is ambiguous, unlike all other signatures renameSig ctxt sig@(SpecSig v ty inl) = do { new_v <- case ctxt of - TopSigCtxt -> lookupLocatedOccRn v - _ -> lookupSigOccRn ctxt sig v - ; new_ty <- rnHsSigType (quotes (ppr v)) ty - ; return (SpecSig new_v new_ty inl) } + TopSigCtxt {} -> lookupLocatedOccRn v + _ -> lookupSigOccRn ctxt sig v + ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty + ; return (SpecSig new_v new_ty inl, fvs) } renameSig ctxt sig@(InlineSig v s) = do { new_v <- lookupSigOccRn ctxt sig v - ; return (InlineSig new_v s) } + ; return (InlineSig new_v s, emptyFVs) } renameSig ctxt sig@(FixSig (FixitySig v f)) = do { new_v <- lookupSigOccRn ctxt sig v - ; return (FixSig (FixitySig new_v f)) } + ; return (FixSig (FixitySig new_v f), emptyFVs) } ppr_sig_bndrs :: [Located RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) @@ -733,14 +722,14 @@ okHsSig ctxt (L _ sig) (FixSig {}, InstDeclCtxt {}) -> False (FixSig {}, _) -> True - (IdSig {}, TopSigCtxt) -> True + (IdSig {}, TopSigCtxt {}) -> True (IdSig {}, InstDeclCtxt {}) -> True (IdSig {}, _) -> False (InlineSig {}, HsBootCtxt) -> False (InlineSig {}, _) -> True - (SpecSig {}, TopSigCtxt) -> True + (SpecSig {}, TopSigCtxt {}) -> True (SpecSig {}, LocalBindCtxt {}) -> True (SpecSig {}, InstDeclCtxt {}) -> True (SpecSig {}, _) -> False @@ -778,7 +767,6 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss ; return (Match pats' Nothing grhss', grhss_fvs) }} - -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc resSigErr ctxt match ty diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index ecd2cd3147..6b01da4722 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -14,13 +14,16 @@ module RnEnv ( newTopSrcBinder, lookupLocatedTopBndrRn, lookupTopBndrRn, - lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe, lookupPromotedOccRn, + lookupLocatedOccRn, lookupOccRn, + lookupLocalOccRn_maybe, + lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, - HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn, + HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, - lookupInstDeclBndr, lookupSubBndrOcc, greRdrName, + lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName, + greRdrName, lookupSubBndrGREs, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, @@ -31,16 +34,14 @@ module RnEnv ( MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv, addLocalFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, - bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, extendTyVarEnvFVRn, - checkDupRdrNames, checkDupAndShadowedRdrNames, - checkDupNames, checkDupAndShadowedNames, + checkDupRdrNames, checkShadowedRdrNames, + checkDupNames, checkDupAndShadowedNames, checkTupSize, addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg, - HsDocContext(..), docOfHsDocContext ) where @@ -49,7 +50,6 @@ module RnEnv ( import LoadIface ( loadInterfaceForName, loadSrcInterface ) import IfaceEnv import HsSyn -import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName import HscTypes import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage ) @@ -61,7 +61,8 @@ import NameEnv import Avail import Module ( ModuleName, moduleName ) import UniqFM -import DataCon ( dataConFieldLabels ) +import DataCon ( dataConFieldLabels, dataConTyCon ) +import TyCon ( isTupleTyCon, tyConArity ) import PrelNames ( mkUnboundName, rOOT_MAIN, forall_tv_RDR ) import ErrUtils ( MsgDoc ) import SrcLoc @@ -74,6 +75,7 @@ import FastString import Control.Monad import Data.List import qualified Data.Set as Set +import Constants ( mAX_TUPLE_SIZE ) \end{code} \begin{code} @@ -235,16 +237,44 @@ lookupTopBndrRn_maybe rdr_name lookupExactOcc :: Name -> RnM Name -- See Note [Looking up Exact RdrNames] lookupExactOcc name + | Just thing <- wiredInNameTyThing_maybe name + , Just tycon <- case thing of + ATyCon tc -> Just tc + ADataCon dc -> Just (dataConTyCon dc) + _ -> Nothing + , isTupleTyCon tycon + = do { checkTupSize (tyConArity tycon) + ; return name } + | isExternalName name = return name + | otherwise = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_Name env name + ; let -- See Note [Splicing Exact names] + main_occ = nameOccName name + demoted_occs = case demoteOccName main_occ of + Just occ -> [occ] + Nothing -> [] + gres = [ gre | occ <- main_occ : demoted_occs + , gre <- lookupGlobalRdrEnv env occ + , gre_name gre == name ] ; case gres of - [] -> return name + [] -> -- See Note [Splicing Exact names] + do { lcl_env <- getLocalRdrEnv + ; unless (name `inLocalRdrEnvScope` lcl_env) + (addErr exact_nm_err) + ; return name } + [gre] -> return (gre_name gre) _ -> pprPanic "lookupExactOcc" (ppr name $$ ppr gres) } + where + exact_nm_err = hang (ptext (sLit "The exact Name") <+> quotes (ppr name) <+> ptext (sLit "is not in scope")) + 2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ") + , ptext (sLit "perhaps via newName, but did not bind it") + , ptext (sLit "If that's it, then -ddump-splices might be useful") ]) + ----------------------------------------------- lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name -- This is called on the method name on the left-hand side of an @@ -271,6 +301,16 @@ lookupInstDeclBndr cls what rdr where doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls) + +----------------------------------------------- +lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name) +-- Used for TyData and TySynonym family instances only, +-- See Note [Family instance binders] +lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f RnBinds.rnMethodBind + = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr +lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* + = lookupLocatedOccRn tc_rdr + ----------------------------------------------- lookupConstructorFields :: Name -> RnM [Name] -- Look up the fields of a given constructor @@ -374,6 +414,40 @@ lookupSubBndrGREs env parent rdr_name parent_is _ _ = False \end{code} +Note [Family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family F a + data instance F T = X1 | X2 + +The 'data instance' decl has an *occurrence* of F (and T), and *binds* +X1 and X2. (This is unlike a normal data type declaration which would +bind F too.) So we want an AvailTC F [X1,X2]. + +Now consider a similar pair: + class C a where + data G a + instance C S where + data G S = Y1 | Y2 + +The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. + +But there is a small complication: in an instance decl, we don't use +qualified names on the LHS; instead we use the class to disambiguate. +Thus: + module M where + import Blib( G ) + class C a where + data G a + instance C S where + data G S = Y1 | Y2 +Even though there are two G's in scope (M.G and Blib.G), the occurence +of 'G' in the 'instance C S' decl is unambiguous, becuase C has only +one associated type called G. This is exactly what happens for methods, +and it is only consistent to do the same thing for types. That's the +role of the function lookupTcdName; the (Maybe Name) give the class of +the encloseing instance decl, if any. + Note [Looking up Exact RdrNames] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Exact RdrNames are generated by Template Haskell. See Note [Binders @@ -384,6 +458,7 @@ positions for constructors, TyCons etc. For example [d| data T = MkT Int |] when we splice in and Convert to HsSyn RdrName, we'll get data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... +These System names are generated by Convert.thRdrName But, constructors and the like need External Names, not System Names! So we do the following @@ -394,7 +469,7 @@ So we do the following * When looking up an occurrence of an Exact name, done in RnEnv.lookupExactOcc, we find the Name with the right unique in the - GlobalRdrEnv, and use the on from the envt -- it will be an + GlobalRdrEnv, and use the one from the envt -- it will be an External Name in the case of the data type/constructor above. * Exact names are also use for purely local binders generated @@ -406,6 +481,28 @@ So we do the following will find the Name is not in the GlobalRdrEnv, so we just use the Exact supplied Name. +Note [Splicing Exact names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the splice $(do { x <- newName "x"; return (VarE x) }) +This will generate a (HsExpr RdrName) term that mentions the +Exact RdrName "x_56" (or whatever), but does not bind it. So +when looking such Exact names we want to check that it's in scope, +otherwise the type checker will get confused. To do this we need to +keep track of all the Names in scope, and the LocalRdrEnv does just that; +we consult it with RdrName.inLocalRdrEnvScope. + +There is another wrinkle. With TH and -XDataKinds, consider + $( [d| data Nat = Zero + data T = MkT (Proxy 'Zero) |] ) +After splicing, but before renaming we get this: + data Nat_77{tc} = Zero_78{d} + data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) +THe occurrence of 'Zero in the data type for T has the right unique, +but it has a TcClsName name-space in its OccName. (This is set by +the ctxt_ns argument of Convert.thRdrName.) When we check that is +in scope in the GlobalRdrEnv, we need to look up the DataName namespace +too. (An alternative would be to make the GlobalRdrEnv also have +a Name -> GRE mapping.) Note [Usage for sub-bndrs] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -452,25 +549,38 @@ lookupOccRn rdr_name = do opt_name <- lookupOccRn_maybe rdr_name maybe (unboundName WL_Any rdr_name) return opt_name +lookupKindOccRn :: RdrName -> RnM Name +-- Looking up a name occurring in a kind +lookupKindOccRn rdr_name + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> unboundName WL_Any rdr_name } + -- lookupPromotedOccRn looks up an optionally promoted RdrName. -lookupPromotedOccRn :: RdrName -> RnM Name +lookupTypeOccRn :: RdrName -> RnM Name -- see Note [Demotion] -lookupPromotedOccRn rdr_name +lookupTypeOccRn rdr_name = do { mb_name <- lookupOccRn_maybe rdr_name ; case mb_name of { Just name -> return name ; - Nothing -> - - do { -- Maybe it's the name of a *data* constructor - data_kinds <- xoptM Opt_DataKinds - ; mb_demoted_name <- case demoteRdrName rdr_name of - Just demoted_rdr -> lookupOccRn_maybe demoted_rdr - Nothing -> return Nothing + Nothing -> lookup_demoted rdr_name } } + +lookup_demoted :: RdrName -> RnM Name +lookup_demoted rdr_name + | Just demoted_rdr <- demoteRdrName rdr_name + -- Maybe it's the name of a *data* constructor + = do { data_kinds <- xoptM Opt_DataKinds + ; mb_demoted_name <- lookupOccRn_maybe demoted_rdr ; case mb_demoted_name of Nothing -> unboundName WL_Any rdr_name Just demoted_name | data_kinds -> return demoted_name - | otherwise -> unboundNameX WL_Any rdr_name suggest_dk }}} + | otherwise -> unboundNameX WL_Any rdr_name suggest_dk } + + | otherwise + = unboundName WL_Any rdr_name + where suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") \end{code} @@ -591,28 +701,111 @@ lookupGreRn_help rdr_name lookup ; return (Just gre) } gres -> do { addNameClashErrRn rdr_name gres ; return (Just (head gres)) } } +\end{code} +%********************************************************* +%* * + Deprecations +%* * +%********************************************************* + +Note [Handling of deprecations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We report deprecations at each *occurrence* of the deprecated thing + (see Trac #5867) + +* We do not report deprectations for locally-definded names. For a + start, we may be exporting a deprecated thing. Also we may use a + deprecated thing in the defn of another deprecated things. We may + even use a deprecated thing in the defn of a non-deprecated thing, + when changing a module's interface. + +* addUsedRdrNames: we do not report deprecations for sub-binders: + - the ".." completion for records + - the ".." in an export item 'T(..)' + - the things exported by a module export 'module M' + +\begin{code} addUsedRdrName :: GlobalRdrElt -> RdrName -> RnM () -- Record usage of imported RdrNames addUsedRdrName gre rdr - | isLocalGRE gre = return () + | isLocalGRE gre = return () -- No call to warnIfDeprecated + -- See Note [Handling of deprecations] | otherwise = do { env <- getGblEnv - ; updMutVar (tcg_used_rdrnames env) + ; warnIfDeprecated gre + ; updMutVar (tcg_used_rdrnames env) (\s -> Set.insert rdr s) } addUsedRdrNames :: [RdrName] -> RnM () -- Record used sub-binders -- We don't check for imported-ness here, because it's inconvenient -- and not stritly necessary. +-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] addUsedRdrNames rdrs = do { env <- getGblEnv ; updMutVar (tcg_used_rdrnames env) (\s -> foldr Set.insert s rdrs) } ------------------------------- --- GHCi support ------------------------------- +warnIfDeprecated :: GlobalRdrElt -> RnM () +warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported (imp_spec : _) }) + = do { dflags <- getDynFlags + ; when (wopt Opt_WarnWarningsDeprecations dflags) $ + do { iface <- loadInterfaceForName doc name + ; case lookupImpDeprec iface gre of + Just txt -> addWarn (mk_msg txt) + Nothing -> return () } } + where + mk_msg txt = sep [ sep [ ptext (sLit "In the use of") + <+> pprNonVarNameSpace (occNameSpace (nameOccName name)) + <+> quotes (ppr name) + , parens imp_msg <> colon ] + , ppr txt ] + + name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name + imp_mod = importSpecModule imp_spec + imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra + extra | imp_mod == moduleName name_mod = empty + | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod + + doc = ptext (sLit "The name") <+> quotes (ppr name) <+> ptext (sLit "is mentioned explicitly") + +warnIfDeprecated _ = return () -- No deprecations for things defined locally + +lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt +lookupImpDeprec iface gre + = mi_warn_fn iface (gre_name gre) `mplus` -- Bleat if the thing, + case gre_par gre of -- or its parent, is warn'd + ParentIs p -> mi_warn_fn iface p + NoParent -> Nothing +\end{code} + +Note [Used names with interface not loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's (just) possible to to find a used +Name whose interface hasn't been loaded: + +a) It might be a WiredInName; in that case we may not load + its interface (although we could). + +b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger + These are seen as "used" by the renamer (if -XRebindableSyntax) + is on), but the typechecker may discard their uses + if in fact the in-scope fromRational is GHC.Read.fromRational, + (see tcPat.tcOverloadedLit), and the typechecker sees that the type + is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). + In that obscure case it won't force the interface in. + +In both cases we simply don't permit deprecations; +this is, after all, wired-in stuff. + +%********************************************************* +%* * + GHCi support +%* * +%********************************************************* + +\begin{code} -- A qualified name on the command line can refer to any module at all: we -- try to load the interface if we don't already have it. lookupQualifiedName :: RdrName -> RnM (Maybe Name) @@ -657,13 +850,36 @@ We don't want to say 'f' is out of scope; instead, we want to return the imported 'f', so that later on the reanamer will correctly report "misplaced type sig". +Note [Signatures for top level things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +data HsSigCtxt = ... | TopSigCtxt NameSet Bool | .... + +* The NameSet says what is bound in this group of bindings. + We can't use isLocalGRE from the GlobalRdrEnv, because of this: + f x = x + $( ...some TH splice... ) + f :: Int -> Int + When we encounter the signature for 'f', the binding for 'f' + will be in the GlobalRdrEnv, and will be a LocalDef. Yet the + signature is mis-placed + +* The Bool says whether the signature is ok for a class method + or record selector. Consider + infix 3 `f` -- Yes, ok + f :: C a => a -> a -- No, not ok + class C a where + f :: a -> a + \begin{code} data HsSigCtxt - = HsBootCtxt -- Top level of a hs-boot file - | TopSigCtxt -- At top level + = TopSigCtxt NameSet Bool -- At top level, binding these names + -- See Note [Signatures for top level things] + -- Bool <=> ok to give sig for + -- class method or record selctor | LocalBindCtxt NameSet -- In a local binding, binding these names | ClsDeclCtxt Name -- Class decl for this class | InstDeclCtxt Name -- Intsance decl for this class + | HsBootCtxt -- Top level of a hs-boot file lookupSigOccRn :: HsSigCtxt -> Sig RdrName @@ -695,11 +911,11 @@ lookupBindGroupOcc ctxt what rdr_name | otherwise = case ctxt of - HsBootCtxt -> lookup_top - TopSigCtxt -> lookup_top - LocalBindCtxt ns -> lookup_group ns - ClsDeclCtxt cls -> lookup_cls_op cls - InstDeclCtxt cls -> lookup_cls_op cls + HsBootCtxt -> lookup_top (const True) True + TopSigCtxt ns meth_ok -> lookup_top (`elemNameSet` ns) meth_ok + LocalBindCtxt ns -> lookup_group ns + ClsDeclCtxt cls -> lookup_cls_op cls + InstDeclCtxt cls -> lookup_cls_op cls where lookup_cls_op cls = do { env <- getGlobalRdrEnv @@ -713,21 +929,22 @@ lookupBindGroupOcc ctxt what rdr_name where doc = ptext (sLit "method of class") <+> quotes (ppr cls) - lookup_top + lookup_top keep_me meth_ok = do { env <- getGlobalRdrEnv - ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - ; case filter isLocalGRE gres of - [] | null gres -> bale_out_with empty - | otherwise -> bale_out_with (bad_msg (ptext (sLit "an imported value"))) + ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + ; case filter (keep_me . gre_name) all_gres of + [] | null all_gres -> bale_out_with empty + | otherwise -> bale_out_with local_msg (gre:_) - | ParentIs {} <- gre_par gre - -> bale_out_with (bad_msg (ptext (sLit "a record selector or class method"))) + | ParentIs {} <- gre_par gre + , not meth_ok + -> bale_out_with sub_msg | otherwise -> return (Right (gre_name gre)) } - lookup_group bound_names - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of + lookup_group bound_names -- Look in the local envt (not top level) + = do { local_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv local_env rdr_name of Just n | n `elemNameSet` bound_names -> return (Right n) | otherwise -> bale_out_with local_msg @@ -742,38 +959,51 @@ lookupBindGroupOcc ctxt what rdr_name local_msg = parens $ ptext (sLit "The") <+> what <+> ptext (sLit "must be given where") <+> quotes (ppr rdr_name) <+> ptext (sLit "is declared") - bad_msg thing = parens $ ptext (sLit "You cannot give a") <+> what - <+> ptext (sLit "for") <+> thing + sub_msg = parens $ ptext (sLit "You cannot give a") <+> what + <+> ptext (sLit "for a record selector or class method") --------------- -lookupLocalDataTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name] --- GHC extension: look up both the tycon and data con --- for con-like things. Used for top-level fixity signatures --- Complain if neither is in scope -lookupLocalDataTcNames bndr_set what rdr_name - | Just n <- isExact_maybe rdr_name - -- Special case for (:), which doesn't get into the GlobalRdrEnv - = do { n' <- lookupExactOcc n; return [n'] } -- For this we don't need to try the tycon too - | otherwise - = do { mb_gres <- mapM (lookupBindGroupOcc (LocalBindCtxt bndr_set) what) - (dataTcOccs rdr_name) - ; let (errs, names) = splitEithers mb_gres - ; when (null names) (addErr (head errs)) -- Bleat about one only - ; return names } +lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name] +-- GHC extension: look up both the tycon and data con or variable. +-- Used for top-level fixity signatures and deprecations. +-- Complain if neither is in scope. +-- See Note [Fixity signature lookup] +lookupLocalTcNames ctxt what rdr_name + = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) + ; let (errs, names) = splitEithers mb_gres + ; when (null names) $ addErr (head errs) -- Bleat about one only + ; return names } + where + lookup = lookupBindGroupOcc ctxt what dataTcOccs :: RdrName -> [RdrName] --- If the input is a data constructor, return both it and a type --- constructor. This is useful when we aren't sure which we are --- looking at. +-- Return both the given name and the same name promoted to the TcClsName +-- namespace. This is useful when we aren't sure which we are looking at. dataTcOccs rdr_name - | isDataOcc occ = [rdr_name, rdr_name_tc] - | otherwise = [rdr_name] - where - occ = rdrNameOcc rdr_name + | Just n <- isExact_maybe rdr_name + , not (isBuiltInSyntax n) -- See Note [dataTcOccs and Exact Names] + = [rdr_name] + | isDataOcc occ || isVarOcc occ + = [rdr_name, rdr_name_tc] + | otherwise + = [rdr_name] + where + occ = rdrNameOcc rdr_name rdr_name_tc = setRdrNameSpace rdr_name tcName \end{code} +Note [dataTcOccs and Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames can occur in code generated by Template Haskell, and generally +those references are, well, exact, so it's wrong to return the TyClsName too. +But there is an awkward exception for built-in syntax. Example in GHCi + :info [] +This parses as the Exact RdrName for nilDataCon, but we also want +the list type constructor. + +Note that setRdrNameSpace on an Exact name requires the Name to be External, +which it always is for built in syntax. %********************************************************* %* * @@ -781,6 +1011,26 @@ dataTcOccs rdr_name %* * %********************************************************* +Note [Fixity signature lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A fixity declaration like + + infixr 2 ? + +can refer to a value-level operator, e.g.: + + (?) :: String -> String -> String + +or a type-level operator, like: + + data (?) a b = A a | B b + +so we extend the lookup of the reader name '?' to the TcClsName namespace, as +well as the original namespace. + +The extended lookup is also used in other places, like resolution of +deprecation declarations, and lookup of names in GHCi. + \begin{code} -------------------------------- type FastStringEnv a = UniqFM a -- Keyed by FastString @@ -983,7 +1233,8 @@ bindLocatedLocalsRn :: [Located RdrName] -> ([Name] -> RnM a) -> RnM a bindLocatedLocalsRn rdr_names_w_loc enclosed_scope - = do { checkDupAndShadowedRdrNames rdr_names_w_loc + = do { checkDupRdrNames rdr_names_w_loc + ; checkShadowedRdrNames rdr_names_w_loc -- Make fresh Names and extend the environment ; names <- newLocalBndrsRn rdr_names_w_loc @@ -1018,42 +1269,6 @@ bindLocatedLocalsFV rdr_names enclosed_scope return (thing, delFVs names fvs) ------------------------------------- -bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a - -- Find the type variables in the pattern type - -- signatures that must be brought into scope -bindPatSigTyVars tys thing_inside - = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables - ; if not scoped_tyvars then - thing_inside [] - else - do { name_env <- getLocalRdrEnv - ; let locd_tvs = [ tv | ty <- tys - , tv <- extractHsTyRdrTyVars ty - , not (unLoc tv `elemLocalRdrEnv` name_env) ] - nubbed_tvs = nubBy eqLocated locd_tvs - -- The 'nub' is important. For example: - -- f (x :: t) (y :: t) = .... - -- We don't want to complain about binding t twice! - - ; bindLocatedLocalsRn nubbed_tvs thing_inside }} - -bindPatSigTyVarsFV :: [LHsType RdrName] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) -bindPatSigTyVarsFV tys thing_inside - = bindPatSigTyVars tys $ \ tvs -> - thing_inside `thenM` \ (result,fvs) -> - return (result, fvs `delListFromNameSet` tvs) - -bindSigTyVarsFV :: [Name] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) -bindSigTyVarsFV tvs thing_inside - = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables - ; if not scoped_tyvars then - thing_inside - else - bindLocalNamesFV tvs thing_inside } extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -- This function is used only in rnSourceDecl on InstDecl @@ -1077,11 +1292,10 @@ checkDupNames names -- See Note [Binders in Template Haskell] in Convert --------------------- -checkDupAndShadowedRdrNames :: [Located RdrName] -> RnM () -checkDupAndShadowedRdrNames loc_rdr_names - = do { checkDupRdrNames loc_rdr_names - ; envs <- getRdrEnvs - ; checkShadowedOccs envs loc_occs } +checkShadowedRdrNames :: [Located RdrName] -> RnM () +checkShadowedRdrNames loc_rdr_names + = do { envs <- getRdrEnvs + ; checkShadowedOccs envs loc_occs } where loc_occs = [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names] @@ -1148,24 +1362,19 @@ unboundName wl rdr = unboundNameX wl rdr empty unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name unboundNameX where_look rdr_name extra = do { show_helpful_errors <- doptM Opt_HelpfulErrors - ; let err = unknownNameErr rdr_name $$ extra + ; let what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + err = unknownNameErr what rdr_name $$ extra ; if not show_helpful_errors then addErr err else do { suggestions <- unknownNameSuggestErr where_look rdr_name ; addErr (err $$ suggestions) } - ; env <- getGlobalRdrEnv; - ; traceRn (vcat [unknownNameErr rdr_name, - ptext (sLit "Global envt is:"), - nest 3 (pprGlobalRdrEnv env)]) - ; return (mkUnboundName rdr_name) } -unknownNameErr :: RdrName -> SDoc -unknownNameErr rdr_name +unknownNameErr :: SDoc -> RdrName -> SDoc +unknownNameErr what rdr_name = vcat [ hang (ptext (sLit "Not in scope:")) - 2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - <+> quotes (ppr rdr_name)) + 2 (what <+> quotes (ppr rdr_name)) , extra ] where extra | rdr_name == forall_tv_RDR = perhapsForallMsg @@ -1179,14 +1388,15 @@ unknownNameSuggestErr :: WhereLooking -> RdrName -> RnM SDoc unknownNameSuggestErr where_look tried_rdr_name = do { local_env <- getLocalRdrEnv ; global_env <- getGlobalRdrEnv + ; dflags <- getDynFlags ; let all_possibilities :: [(String, (RdrName, HowInScope))] all_possibilities - = [ (showSDoc (ppr r), (r, Left loc)) + = [ (showPpr dflags r, (r, Left loc)) | (r,loc) <- local_possibilities local_env ] - ++ [ (showSDoc (ppr r), rp) | (r,rp) <- global_possibilities global_env ] + ++ [ (showPpr dflags r, rp) | (r,rp) <- global_possibilities global_env ] - suggest = fuzzyLookup (showSDoc (ppr tried_rdr_name)) all_possibilities + suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities perhaps = ptext (sLit "Perhaps you meant") extra_err = case suggest of [] -> empty @@ -1220,7 +1430,7 @@ unknownNameSuggestErr where_look tried_rdr_name | tried_is_qual = [] | not local_ok = [] | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name) - | name <- occEnvElts env + | name <- localRdrEnvElts env , let occ = nameOccName name , correct_name_space occ] @@ -1432,7 +1642,7 @@ dupNamesErr get_loc names where locs = map get_loc names big_loc = foldr1 combineSrcSpans locs - locations = ptext (sLit "Bound at:") <+> vcat (map ppr (sortLe (<=) locs)) + locations = ptext (sLit "Bound at:") <+> vcat (map ppr (sort locs)) kindSigErr :: Outputable a => a -> SDoc kindSigErr thing @@ -1453,6 +1663,15 @@ opDeclErr :: RdrName -> SDoc opDeclErr n = hang (ptext (sLit "Illegal declaration of a type or class operator") <+> quotes (ppr n)) 2 (ptext (sLit "Use -XTypeOperators to declare operators in type and declarations")) + +checkTupSize :: Int -> RnM () +checkTupSize tup_size + | tup_size <= mAX_TUPLE_SIZE + = return () + | otherwise + = addErr (sep [ptext (sLit "A") <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), + nest 2 (parens (ptext (sLit "max size is") <+> int mAX_TUPLE_SIZE)), + nest 2 (ptext (sLit "Workaround: use nested tuples or define a data type"))]) \end{code} @@ -1484,8 +1703,10 @@ data HsDocContext | SpliceTypeCtx (LHsType RdrName) | ClassInstanceCtx | VectDeclCtx (Located RdrName) + | GenericCtx SDoc -- Maybe we want to use this more! docOfHsDocContext :: HsDocContext -> SDoc +docOfHsDocContext (GenericCtx doc) = doc docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc docOfHsDocContext PatCtx = text "In a pattern type-signature" docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma" @@ -1505,5 +1726,4 @@ docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input") docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances") docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon) - \end{code} diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 7caae61027..d27ef98e80 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -34,8 +34,7 @@ import HsSyn import TcRnMonad import TcEnv ( thRnBrack ) import RnEnv -import RnTypes ( rnHsTypeFVs, rnSplice, rnIPName, checkTH, - mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) +import RnTypes import RnPat import DynFlags import BasicTypes ( FixityDirection(..) ) @@ -47,7 +46,7 @@ import RdrName import LoadIface ( loadInterfaceForName ) import UniqSet import Data.List -import Util ( isSingleton, snocView ) +import Util import ListSetOps ( removeDups ) import Outputable import SrcLoc @@ -112,8 +111,7 @@ rnExpr (HsVar v) finishHsVar name rnExpr (HsIPVar v) - = do v' <- rnIPName v - return (HsIPVar v', emptyFVs) + = return (HsIPVar v, emptyFVs) rnExpr (HsLit lit@(HsString s)) = do { @@ -270,7 +268,7 @@ rnExpr (RecordUpd expr rbinds _ _ _) fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig expr pty) - = do { (pty', fvTy) <- rnHsTypeFVs ExprWithTySigCtx pty + = do { (pty', fvTy) <- rnLHsType ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ rnLExpr expr ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } @@ -283,7 +281,7 @@ rnExpr (HsIf _ p b1 b2) ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsType a) - = rnHsTypeFVs HsTypeCtx a `thenM` \ (t, fvT) -> + = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> return (HsType t, fvT) rnExpr (ArithSeq _ seq) @@ -545,8 +543,8 @@ methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName -methodNamesStmt (LetStmt _) = emptyFVs -methodNamesStmt (ParStmt _ _ _ _) = emptyFVs +methodNamesStmt (LetStmt {}) = emptyFVs +methodNamesStmt (ParStmt {}) = emptyFVs methodNamesStmt (TransStmt {}) = emptyFVs -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error -- here so we just do what's convenient @@ -607,7 +605,7 @@ rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) -rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs TypBrCtx t +rnBracket (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t ; return (TypBr t', fvs) } rnBracket (DecBrL decls) @@ -754,7 +752,7 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside -- Step 3: Group together the segments to make bigger segments -- Invariant: in the result, no segment uses a variable -- bound in a later segment - grouped_segs = glomSegments segs_w_fwd_refs + grouped_segs = glomSegments ctxt segs_w_fwd_refs -- Step 4: Turn the segments into Stmts -- Use RecStmt when and only when there are fwd refs @@ -768,12 +766,12 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } -rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside +rnStmt ctxt (L loc (ParStmt segs _ _)) thing_inside = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName ; (return_op, fvs3) <- lookupStmtName ctxt returnMName - ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside - ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing) + ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside + ; return ( ([L loc (ParStmt segs' mzip_op bind_op)], thing) , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form @@ -811,27 +809,26 @@ rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form , trS_ret = return_op, trS_bind = bind_op , trS_fmap = fmap_op })], thing), all_fvs) } -type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts - rnParallelStmts :: forall thing. HsStmtContext Name - -> [ParSeg RdrName] + -> SyntaxExpr Name + -> [ParStmtBlock RdrName RdrName] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([ParSeg Name], thing), FreeVars) + -> RnM (([ParStmtBlock Name Name], thing), FreeVars) -- Note [Renaming parallel Stmts] -rnParallelStmts ctxt segs thing_inside +rnParallelStmts ctxt return_op segs thing_inside = do { orig_lcl_env <- getLocalRdrEnv ; rn_segs orig_lcl_env [] segs } where rn_segs :: LocalRdrEnv - -> [Name] -> [ParSeg RdrName] - -> RnM (([ParSeg Name], thing), FreeVars) + -> [Name] -> [ParStmtBlock RdrName RdrName] + -> RnM (([ParStmtBlock Name Name], thing), FreeVars) rn_segs _ bndrs_so_far [] = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far ; mapM_ dupErr dups ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') ; return (([], thing), fvs) } - rn_segs env bndrs_so_far ((stmts,_) : segs) + rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) <- rnStmts ctxt stmts $ \ bndrs -> setLocalRdrEnv env $ do @@ -839,7 +836,7 @@ rnParallelStmts ctxt segs thing_inside ; let used_bndrs = filter (`elemNameSet` fvs) bndrs ; return ((used_bndrs, segs', thing), fvs) } - ; let seg' = (stmts', used_bndrs) + ; let seg' = ParStmtBlock stmts' used_bndrs return_op ; return ((seg':segs', thing), fvs) } cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 @@ -974,7 +971,7 @@ rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec = rn_rec_stmts_lhs fix_env stmts -rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo +rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo @@ -1103,15 +1100,20 @@ addFwdRefs pairs -- { rec { x <- ...y...; p <- z ; y <- ...x... ; -- q <- x ; z <- y } ; -- r <- x } +-- +-- NB. June 7 2012: We only glom segments that appear in +-- an explicit mdo; and leave those found in "do rec"'s intact. +-- See http://hackage.haskell.org/trac/ghc/ticket/4148 for +-- the discussion leading to this design choice. -glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]] +glomSegments :: HsStmtContext Name -> [Segment (LStmt Name)] -> [Segment [LStmt Name]] -glomSegments [] = [] -glomSegments ((defs,uses,fwds,stmt) : segs) +glomSegments _ [] = [] +glomSegments ctxt ((defs,uses,fwds,stmt) : segs) -- Actually stmts will always be a singleton = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others where - segs' = glomSegments segs + segs' = glomSegments ctxt segs (extras, others) = grab uses segs' (ds, us, fs, ss) = unzip4 extras @@ -1129,7 +1131,9 @@ glomSegments ((defs,uses,fwds,stmt) : segs) = (reverse yeses, reverse noes) where (noes, yeses) = span not_needed (reverse dus) - not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) + not_needed (defs,_,_,_) = case ctxt of + MDoExpr -> not (intersectsNameSet defs uses) + _ -> False -- unless we're in mdo, we *need* everything ---------------------------------------------------- @@ -1161,15 +1165,17 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later %************************************************************************ \begin{code} -srcSpanPrimLit :: SrcSpan -> HsExpr Name -srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span)))) +srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr Name +srcSpanPrimLit dflags span + = HsLit (HsStringPrim (mkFastString (showSDocOneLine dflags (ppr span)))) mkAssertErrorExpr :: RnM (HsExpr Name) -- Return an expression for (assertError "Foo.hs:27") mkAssertErrorExpr - = getSrcSpanM `thenM` \ sloc -> - return (HsApp (L sloc (HsVar assertErrorName)) - (L sloc (srcSpanPrimLit sloc))) + = do sloc <- getSrcSpanM + dflags <- getDynFlags + return (HsApp (L sloc (HsVar assertErrorName)) + (L sloc (srcSpanPrimLit dflags sloc))) \end{code} Note [Adding the implicit parameter to 'assert'] @@ -1299,9 +1305,9 @@ okParStmt dflags ctxt stmt okDoStmt dflags ctxt stmt = case stmt of RecStmt {} - | Opt_DoRec `xopt` dflags -> isOK - | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' - | otherwise -> Just (ptext (sLit "Use -XDoRec")) + | Opt_RecursiveDo `xopt` dflags -> isOK + | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' + | otherwise -> Just (ptext (sLit "Use -XRecursiveDo")) BindStmt {} -> isOK LetStmt {} -> isOK ExprStmt {} -> isOK diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs deleted file mode 100644 index e2369bb776..0000000000 --- a/compiler/rename/RnHsSyn.lhs +++ /dev/null @@ -1,159 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1996-1998 -% -\section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer} - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module RnHsSyn( - -- Names - charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name, - extractHsTyVars, extractHsTyNames, extractHsTyNames_s, - extractFunDepNames, extractHsCtxtTyNames, - extractHsTyVarBndrNames, extractHsTyVarBndrNames_s, - - -- Free variables - hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs - ) where - -#include "HsVersions.h" - -import HsSyn -import Class ( FunDep ) -import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) -import Name ( Name, getName, isTyVarName ) -import NameSet -import BasicTypes ( TupleSort ) -import SrcLoc -import Panic ( panic ) -\end{code} - -%************************************************************************ -%* * -\subsection{Free variables} -%* * -%************************************************************************ - -These free-variable finders returns tycons and classes too. - -\begin{code} -charTyCon_name, listTyCon_name, parrTyCon_name :: Name -charTyCon_name = getName charTyCon -listTyCon_name = getName listTyCon -parrTyCon_name = getName parrTyCon - -tupleTyCon_name :: TupleSort -> Int -> Name -tupleTyCon_name sort n = getName (tupleTyCon sort n) - -extractHsTyVars :: LHsType Name -> NameSet -extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x) - -extractFunDepNames :: FunDep Name -> NameSet -extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2 - -extractHsTyNames :: LHsType Name -> NameSet --- Also extract names in kinds. -extractHsTyNames ty - = getl ty - where - getl (L _ ty) = get ty - - get (HsAppTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` getl ty - get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty - get (HsTupleTy _ tys) = extractHsTyNames_s tys - get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsIParamTy _ ty) = getl ty - get (HsEqTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsOpTy ty1 (_, op) ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) - get (HsParTy ty) = getl ty - get (HsBangTy _ ty) = getl ty - get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds) - get (HsTyVar tv) = unitNameSet tv - get (HsSpliceTy _ fvs _) = fvs - get (HsQuasiQuoteTy {}) = emptyNameSet - get (HsKindSig ty ki) = getl ty `unionNameSets` getl ki - get (HsForAllTy _ tvs - ctxt ty) = extractHsTyVarBndrNames_s tvs - (extractHsCtxtTyNames ctxt - `unionNameSets` getl ty) - get (HsDocTy ty _) = getl ty - get (HsCoreTy {}) = emptyNameSet -- This probably isn't quite right - -- but I don't think it matters - get (HsExplicitListTy _ tys) = extractHsTyNames_s tys - get (HsExplicitTupleTy _ tys) = extractHsTyNames_s tys - get (HsWrapTy {}) = panic "extractHsTyNames" - -extractHsTyNames_s :: [LHsType Name] -> NameSet -extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys - -extractHsCtxtTyNames :: LHsContext Name -> NameSet -extractHsCtxtTyNames (L _ ctxt) - = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt - -extractHsTyVarBndrNames :: LHsTyVarBndr Name -> NameSet -extractHsTyVarBndrNames (L _ (UserTyVar _ _)) = emptyNameSet -extractHsTyVarBndrNames (L _ (KindedTyVar _ ki _)) = extractHsTyNames ki - -extractHsTyVarBndrNames_s :: [LHsTyVarBndr Name] -> NameSet -> NameSet --- Update the name set 'body' by adding the names in the binders --- kinds and handling scoping. -extractHsTyVarBndrNames_s [] body = body -extractHsTyVarBndrNames_s (b:bs) body = - (extractHsTyVarBndrNames_s bs body `delFromNameSet` hsTyVarName (unLoc b)) - `unionNameSets` extractHsTyVarBndrNames b -\end{code} - - -%************************************************************************ -%* * -\subsection{Free variables of declarations} -%* * -%************************************************************************ - -Return the Names that must be in scope if we are to use this declaration. -In all cases this is set up for interface-file declarations: - - for class decls we ignore the bindings - - for instance decls likewise, plus the pragmas - - for rule decls, we ignore HsRules - - for data decls, we ignore derivings - - *** See "THE NAMING STORY" in HsDecls **** - -\begin{code} ----------------- -hsSigsFVs :: [LSig Name] -> FreeVars -hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs) - -hsSigFVs :: Sig Name -> FreeVars -hsSigFVs (TypeSig _ ty) = extractHsTyNames ty -hsSigFVs (GenericSig _ ty) = extractHsTyNames ty -hsSigFVs (SpecInstSig ty) = extractHsTyNames ty -hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty -hsSigFVs _ = emptyFVs - ----------------- -conDeclFVs :: LConDecl Name -> FreeVars -conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context, - con_details = details, con_res = res_ty})) - = extractHsTyVarBndrNames_s tyvars $ - extractHsCtxtTyNames context `plusFV` - conDetailsFVs details `plusFV` - conResTyFVs res_ty - -conResTyFVs :: ResType Name -> FreeVars -conResTyFVs ResTyH98 = emptyFVs -conResTyFVs (ResTyGADT ty) = extractHsTyNames ty - -conDetailsFVs :: HsConDeclDetails Name -> FreeVars -conDetailsFVs details = plusFVs (map bangTyFVs (hsConDeclArgTys details)) - -bangTyFVs :: LHsType Name -> FreeVars -bangTyFVs bty = extractHsTyNames (getBangType bty) -\end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index b1a61db2a2..22d7554952 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -7,8 +7,8 @@ module RnNames ( rnImports, getLocalNonValBinders, rnExports, extendGlobalRdrEnvRn, - gresFromAvails, lookupTcdName, - reportUnusedNames, finishWarnings, + gresFromAvails, + reportUnusedNames, ) where #include "HsVersions.h" @@ -406,7 +406,8 @@ extendGlobalRdrEnvRn avails new_fixities new_occs = map (nameOccName . gre_name) gres rdr_env_TH = transformGREs qual_gre new_occs rdr_env rdr_env_GHCi = delListFromOccEnv rdr_env new_occs - lcl_env1 = lcl_env { tcl_rdr = delListFromOccEnv (tcl_rdr lcl_env) new_occs } + + lcl_env1 = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs } (rdr_env2, lcl_env2) | shadowP = (rdr_env_TH, lcl_env1) | isGHCi = (rdr_env_GHCi, lcl_env1) | otherwise = (rdr_env, lcl_env) @@ -528,44 +529,24 @@ getLocalNonValBinders fixity_env ; names@(main_name : _) <- mapM newTopSrcBinder bndrs ; return (AvailTC main_name names) } + new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] + new_assoc (L _ (FamInstD { lid_inst = d })) + = do { avail <- new_ti Nothing d + ; return [avail] } + new_assoc (L _ (ClsInstD { cid_poly_ty = inst_ty, cid_fam_insts = ats })) + | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty + = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr + ; mapM (new_ti (Just cls_nm) . unLoc) ats } + | otherwise + = return [] -- Do not crash on ill-formed instances + -- Eg instance !Show Int Trac #3811c + new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo new_ti mb_cls ti_decl -- ONLY for type/data instances - = ASSERT( isFamInstDecl ti_decl ) - do { main_name <- lookupTcdName mb_cls ti_decl - ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl) + = do { main_name <- lookupFamInstName mb_cls (fid_tycon ti_decl) + ; sub_names <- mapM newTopSrcBinder (hsFamInstBinders ti_decl) ; return (AvailTC (unLoc main_name) sub_names) } -- main_name is not bound here! - - new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] - new_assoc (L _ (FamInstDecl d)) - = do { avail <- new_ti Nothing d - ; return [avail] } - new_assoc (L _ (ClsInstDecl inst_ty _ _ ats)) - = do { mb_cls_nm <- get_cls_parent inst_ty - ; mapM (new_ti mb_cls_nm . unLoc) ats } - where - get_cls_parent inst_ty - | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty - = setSrcSpan loc $ do { nm <- lookupGlobalOccRn cls_rdr; return (Just nm) } - | otherwise - = return Nothing - -lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) --- Used for TyData and TySynonym only, --- both ordinary ones and family instances --- See Note [Family instance binders] -lookupTcdName mb_cls tc_decl - | not (isFamInstDecl tc_decl) -- The normal case - = ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this - lookupLocatedTopBndrRn tc_rdr - - | Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind - = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr - - | otherwise -- Family instance; tc_rdr is an *occurrence* - = lookupLocatedOccRn tc_rdr - where - tc_rdr = tcdLName tc_decl \end{code} Note [Looking up family names in family instances] @@ -586,41 +567,6 @@ Solution is simple: process the type family declarations first, extend the environment, and then process the type instances. -Note [Family instance binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family F a - data instance F T = X1 | X2 - -The 'data instance' decl has an *occurrence* of F (and T), and *binds* -X1 and X2. (This is unlike a normal data type declaration which would -bind F too.) So we want an AvailTC F [X1,X2]. - -Now consider a similar pair: - class C a where - data G a - instance C S where - data G S = Y1 | Y2 - -The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. - -But there is a small complication: in an instance decl, we don't use -qualified names on the LHS; instead we use the class to disambiguate. -Thus: - module M where - import Blib( G ) - class C a where - data G a - instance C S where - data G S = Y1 | Y2 -Even though there are two G's in scope (M.G and Blib.G), the occurence -of 'G' in the 'instance C S' decl is unambiguous, becuase C has only -one associated type called G. This is exactly what happens for methods, -and it is only consistent to do the same thing for types. That's the -role of the function lookupTcdName; the (Maybe Name) give the class of -the encloseing instance decl, if any. - - %************************************************************************ %* * \subsection{Filtering imports} @@ -958,7 +904,11 @@ rnExports explicit_mod exports tcg_env@(TcGblEnv { tcg_mod = this_mod, tcg_rdr_env = rdr_env, tcg_imports = imports }) - = do { + = unsetWOptM Opt_WarnWarningsDeprecations $ + -- Do not report deprecations arising from the export + -- list, to avoid bleating about re-exporting a deprecated + -- thing (especially via 'module Foo' export item) + do { -- If the module header is omitted altogether, then behave -- as if the user had written "module Main(main) where..." -- EXCEPT in interactive mode, when we behave as if he had @@ -976,8 +926,7 @@ rnExports explicit_mod exports ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod ; let final_avails = nubAvails avails -- Combine families - ; traceRn (vcat [ text "rnExports: RdrEnv:" <+> ppr rdr_env - , text " Exports:" <+> ppr final_avails] ) + ; traceRn (text "rnExports: Exports:" <+> ppr final_avails) ; return (tcg_env { tcg_exports = final_avails, tcg_rn_exports = case tcg_rn_exports tcg_env of @@ -1230,96 +1179,6 @@ dupExport_ok n ie1 ie2 single _ = False \end{code} -%********************************************************* -%* * -\subsection{Deprecations} -%* * -%********************************************************* - -\begin{code} -finishWarnings :: DynFlags -> Maybe WarningTxt - -> TcGblEnv -> RnM TcGblEnv --- (a) Report usage of imports that are deprecated or have other warnings --- (b) If the whole module is warned about or deprecated, update tcg_warns --- All this happens only once per module -finishWarnings dflags mod_warn tcg_env - = do { (eps,hpt) <- getEpsAndHpt - ; ifWOptM Opt_WarnWarningsDeprecations $ - mapM_ (check hpt (eps_PIT eps)) all_gres - -- By this time, typechecking is complete, - -- so the PIT is fully populated - - -- Deal with a module deprecation; it overrides all existing warns - ; let new_warns = case mod_warn of - Just txt -> WarnAll txt - Nothing -> tcg_warns tcg_env - ; return (tcg_env { tcg_warns = new_warns }) } - where - used_names = allUses (tcg_dus tcg_env) - -- Report on all deprecated uses; hence allUses - all_gres = globalRdrEnvElts (tcg_rdr_env tcg_env) - - check hpt pit gre@(GRE {gre_name = name, gre_prov = Imported (imp_spec:_)}) - | name `elemNameSet` used_names - , Just deprec_txt <- lookupImpDeprec dflags hpt pit gre - = addWarnAt (importSpecLoc imp_spec) - (sep [ptext (sLit "In the use of") <+> - pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> - quotes (ppr name), - (parens imp_msg) <> colon, - (ppr deprec_txt) ]) - where - name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name - imp_mod = importSpecModule imp_spec - imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra - extra | imp_mod == moduleName name_mod = empty - | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod - - check _ _ _ = return () -- Local, or not used, or not deprectated - -- The Imported pattern-match: don't deprecate locally defined names - -- For a start, we may be exporting a deprecated thing - -- Also we may use a deprecated thing in the defn of another - -- deprecated things. We may even use a deprecated thing in - -- the defn of a non-deprecated thing, when changing a module's - -- interface - -lookupImpDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable - -> GlobalRdrElt -> Maybe WarningTxt --- The name is definitely imported, so look in HPT, PIT -lookupImpDeprec dflags hpt pit gre - = case lookupIfaceByModule dflags hpt pit mod of - Just iface -> mi_warn_fn iface name `mplus` -- Bleat if the thing, *or - case gre_par gre of - ParentIs p -> mi_warn_fn iface p -- its parent*, is warn'd - NoParent -> Nothing - - Nothing -> Nothing -- See Note [Used names with interface not loaded] - where - name = gre_name gre - mod = ASSERT2( isExternalName name, ppr name ) nameModule name -\end{code} - -Note [Used names with interface not loaded] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -By now all the interfaces should have been loaded, -because reportDeprecations happens after typechecking. -However, it's still (just) possible to to find a used -Name whose interface hasn't been loaded: - -a) It might be a WiredInName; in that case we may not load - its interface (although we could). - -b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger - These are seen as "used" by the renamer (if -XRebindableSyntax) - is on), but the typechecker may discard their uses - if in fact the in-scope fromRational is GHC.Read.fromRational, - (see tcPat.tcOverloadedLit), and the typechecker sees that the type - is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). - In that obscure case it won't force the interface in. - -In both cases we simply don't permit deprecations; -this is, after all, wired-in stuff. - %********************************************************* %* * @@ -1533,9 +1392,10 @@ printMinimalImports :: [ImportDeclUsage] -> RnM () printMinimalImports imports_w_usage = do { imports' <- mapM mk_minimal imports_w_usage ; this_mod <- getModule + ; dflags <- getDynFlags ; liftIO $ do { h <- openFile (mkFilename this_mod) WriteMode - ; printForUser h neverQualify (vcat (map ppr imports')) } + ; printForUser dflags h neverQualify (vcat (map ppr imports')) } -- The neverQualify is important. We are printing Names -- but they are in the context of an 'import' decl, and -- we never qualify things inside there @@ -1666,7 +1526,7 @@ dodgyImportWarn item = dodgyMsg (ptext (sLit "import")) item dodgyExportWarn :: Name -> SDoc dodgyExportWarn item = dodgyMsg (ptext (sLit "export")) item -dodgyMsg :: OutputableBndr n => SDoc -> n -> SDoc +dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc dodgyMsg kind tc = sep [ ptext (sLit "The") <+> kind <+> ptext (sLit "item") <+> quotes (ppr (IEThingAll tc)) <+> ptext (sLit "suggests that"), diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 7dd76bd4e6..e37860abb7 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -50,12 +50,11 @@ import RnEnv import RnTypes import DynFlags import PrelNames -import Constants ( mAX_TUPLE_SIZE ) import Name import NameSet import RdrName import BasicTypes -import Util ( notNull ) +import Util import ListSetOps ( removeDups ) import Outputable import SrcLoc @@ -162,6 +161,10 @@ matchNameMaker ctxt = LamMk report_unused StmtCtxt GhciStmt -> False _ -> True +rnHsSigCps :: HsWithBndrs (LHsType RdrName) -> CpsRn (HsWithBndrs (LHsType Name)) +rnHsSigCps sig + = CpsRn (rnHsBndrSig PatCtx sig) + newPatName :: NameMaker -> Located RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name = CpsRn (\ thing_inside -> @@ -232,11 +235,9 @@ rnPats :: HsMatchContext Name -- for error messages rnPats ctxt pats thing_inside = do { envs_before <- getRdrEnvs - -- (0) bring into scope all of the type variables bound by the patterns -- (1) rename the patterns, bringing into scope all of the term variables -- (2) then do the thing inside. - ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ - unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do + ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do { -- Check for duplicated and shadowed names -- Must do this *after* renaming the patterns -- See Note [Collect binders only after renaming] in HsUtils @@ -310,15 +311,10 @@ rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) -rnPatAndThen mk (SigPatIn pat ty) - = do { patsigs <- liftCps (xoptM Opt_ScopedTypeVariables) - ; if patsigs - then do { pat' <- rnLPatAndThen mk pat - ; ty' <- liftCpsFV (rnHsTypeFVs PatCtx ty) - ; return (SigPatIn pat' ty') } - else do { liftCps (addErr (patSigErr ty)) - ; rnPatAndThen mk (unLoc pat) } } - +rnPatAndThen mk (SigPatIn pat sig) + = do { pat' <- rnLPatAndThen mk pat + ; sig' <- rnHsSigCps sig + ; return (SigPatIn pat' sig') } rnPatAndThen mk (LitPat lit) | HsString s <- lit @@ -505,7 +501,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } = return [] rn_dotdot (Just {}) Nothing _flds -- ".." on record update = do { addErr (badDotDot ctxt); return [] } - rn_dotdot (Just n) (Just con) flds -- ".." on record con/pat + rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match = ASSERT( n == length flds ) do { loc <- getSrcSpanM -- Rather approximate ; dd_flag <- xoptM Opt_RecordWildCards @@ -529,11 +525,11 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } where rdr = mkRdrUnqual (nameOccName fld) - dot_dot_gres = [ gre + dot_dot_gres = [ head gres | fld <- con_fields , not (fld `elem` present_flds) - , let gres@(gre:_) = lookupGRE_Name rdr_env fld - , not (null gres) + , let gres = lookupGRE_Name rdr_env fld + , not (null gres) -- Check field is in scope , case ctxt of HsRecFieldCon {} -> arg_in_scope fld _other -> True ] @@ -629,15 +625,6 @@ rnOverLit lit@(OverLit {ol_val=val}) %************************************************************************ \begin{code} -checkTupSize :: Int -> RnM () -checkTupSize tup_size - | tup_size <= mAX_TUPLE_SIZE - = return () - | otherwise - = addErr (sep [ptext (sLit "A") <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), - nest 2 (parens (ptext (sLit "max size is") <+> int mAX_TUPLE_SIZE)), - nest 2 (ptext (sLit "Workaround: use nested tuples or define a data type"))]) - patSigErr :: Outputable a => a -> SDoc patSigErr ty = (ptext (sLit "Illegal signature in pattern:") <+> ppr ty) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 54f95016c7..595f4653d3 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -24,8 +24,6 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) import HsSyn import RdrName -import RdrHsSyn ( extractHsRhoRdrTyVars ) -import RnHsSyn import RnTypes import RnBinds import RnEnv @@ -43,8 +41,8 @@ import NameEnv import Avail import Outputable import Bag +import BasicTypes ( RuleName ) import FastString -import Util ( filterOut ) import SrcLoc import DynFlags import HscTypes ( HscEnv, hsc_dflags ) @@ -54,7 +52,6 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Control.Monad import Data.List( partition ) import Maybes( orElse ) -import Data.Maybe( isNothing ) \end{code} @rnSourceDecl@ `renames' declarations. @@ -117,9 +114,9 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, -- It uses the fixity env from (A) to bind fixities for view patterns. new_lhs <- rnTopBindsLHS local_fix_env val_decls ; -- bind the LHSes (and their fixities) in the global rdr environment - let { val_binders = collectHsValBinders new_lhs ; - all_bndr_set = addListToNameSet tc_bndrs val_binders ; - val_avails = map Avail val_binders } ; + let { val_binders = collectHsValBinders new_lhs ; + all_bndrs = addListToNameSet tc_bndrs val_binders ; + val_avails = map Avail val_binders } ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ; traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ; setEnvs (tcg_env, tcl_env) $ do { @@ -141,19 +138,19 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, -- (F) Rename Value declarations right-hand sides traceRn (text "Start rnmono") ; - (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ; + (rn_val_decls, bind_dus) <- rnTopBindsRHS all_bndrs new_lhs ; traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; -- (G) Rename Fixity and deprecations -- Rename fixity declarations and error if we try to -- fix something from another module (duplicates were checked in (A)) - rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ; + rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ; -- Rename deprec decls; -- check for duplicates and ensure that deprecated things are defined locally -- at the moment, we don't keep these around past renaming - rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ; + rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ; -- (H) Rename Everything else @@ -263,6 +260,9 @@ rnSrcFixityDecls bndr_set fix_decls = do fix_decls <- mapM rn_decl fix_decls return (concat fix_decls) where + sig_ctxt = TopSigCtxt bndr_set True + -- True <=> can give fixity for class decls and record selectors + rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name] -- GHC extension: look up both the tycon and data con -- for con-like things; hence returning a list @@ -271,7 +271,7 @@ rnSrcFixityDecls bndr_set fix_decls rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) = setSrcSpan name_loc $ -- this lookup will fail if the definition isn't local - do names <- lookupLocalDataTcNames bndr_set what rdr_name + do names <- lookupLocalTcNames sig_ctxt what rdr_name return [ L loc (FixitySig (L name_loc name) fixity) | name <- names ] what = ptext (sLit "fixity signature") @@ -304,9 +304,12 @@ rnSrcWarnDecls bndr_set decls ; pairs_s <- mapM (addLocM rn_deprec) decls ; return (WarnSome ((concat pairs_s))) } where + sig_ctxt = TopSigCtxt bndr_set True + -- True <=> Can give deprecations for class ops and record sels + rn_deprec (Warning rdr_name txt) -- ensures that the names are defined locally - = do { names <- lookupLocalDataTcNames bndr_set what rdr_name + = do { names <- lookupLocalTcNames sig_ctxt what rdr_name ; return [(nameOccName name, txt) | name <- names] } what = ptext (sLit "deprecation") @@ -356,7 +359,7 @@ rnAnnProvenance provenance = do \begin{code} rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars) rnDefaultDecl (DefaultDecl tys) - = do { (tys', fvs) <- mapFvRn (rnHsTypeFVs doc_str) tys + = do { (tys', fvs) <- rnLHsTypes doc_str tys ; return (DefaultDecl tys', fvs) } where doc_str = DefaultDeclCtx @@ -373,7 +376,7 @@ rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) rnHsForeignDecl (ForeignImport name ty _ spec) = do { topEnv :: HscEnv <- getTopEnv ; name' <- lookupLocatedTopBndrRn name - ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty + ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty -- Mark any PackageTarget style imports as coming from the current package ; let packageId = thisPackage $ hsc_dflags topEnv @@ -383,7 +386,7 @@ rnHsForeignDecl (ForeignImport name ty _ spec) rnHsForeignDecl (ForeignExport name ty _ spec) = do { name' <- lookupLocatedOccRn name - ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty + ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') } -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, @@ -407,8 +410,8 @@ patchCImportSpec packageId spec patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget patchCCallTarget packageId callTarget = case callTarget of - StaticTarget label Nothing - -> StaticTarget label (Just packageId) + StaticTarget label Nothing isFun + -> StaticTarget label (Just packageId) isFun _ -> callTarget @@ -424,31 +427,39 @@ patchCCallTarget packageId callTarget \begin{code} rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) -rnSrcInstDecl (FamInstDecl ty_decl) - = do { (ty_decl', fvs) <- rnTyClDecl Nothing ty_decl - ; return (FamInstDecl ty_decl', fvs) } +rnSrcInstDecl (FamInstD { lid_inst = fi }) + = do { (fi', fvs) <- rnFamInstDecl Nothing fi + ; return (FamInstD { lid_inst = fi' }, fvs) } -rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) +rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds + , cid_sigs = uprags, cid_fam_insts = ats }) -- Used for both source and interface file decls - = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty - ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' - (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags + = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty + ; case splitLHsInstDeclTy_maybe inst_ty' of { + Nothing -> return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds + , cid_sigs = [], cid_fam_insts = [] } + , inst_fvs) ; + Just (inst_tyvars, _, L _ cls,_) -> + + do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags + ktv_names = hsLKiTyVarNames inst_tyvars -- Rename the associated types, and type signatures -- Both need to have the instance type variables in scope + ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names) ; ((ats', other_sigs'), more_fvs) - <- extendTyVarEnvFVRn (map hsLTyVarName inst_tyvars) $ - do { (ats', at_fvs) <- rnATInsts cls ats - ; other_sigs' <- renameSigs (InstDeclCtxt cls) other_sigs + <- extendTyVarEnvFVRn ktv_names $ + do { (ats', at_fvs) <- rnATInstDecls cls inst_tyvars ats + ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs ; return ( (ats', other_sigs') - , at_fvs `plusFV` hsSigsFVs other_sigs') } + , at_fvs `plusFV` sig_fvs) } -- Rename the bindings -- The typechecker (not the renamer) checks that all -- the bindings are for the right class -- (Slightly strangely) when scoped type variables are on, the -- forall-d tyvars scope over the method bindings too - ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds inst_tyvars $ + ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $ rnMethodBinds cls (mkSigTvFn other_sigs') mbinds @@ -458,16 +469,16 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} -- works OK. That's why we did the partition game above -- - -- But the (unqualified) method names are in scope --- ; let binders = collectHsBindsBinders mbinds' - ; spec_inst_prags' <- -- bindLocalNames binders $ - renameSigs (InstDeclCtxt cls) spec_inst_prags + ; (spec_inst_prags', spec_inst_fvs) + <- renameSigs (InstDeclCtxt cls) spec_inst_prags ; let uprags' = spec_inst_prags' ++ other_sigs' - ; return (ClsInstDecl inst_ty' mbinds' uprags' ats', - meth_fvs `plusFV` more_fvs - `plusFV` hsSigsFVs spec_inst_prags' - `plusFV` extractHsTyNames inst_ty') } + all_fvs = meth_fvs `plusFV` more_fvs + `plusFV` spec_inst_fvs + `plusFV` inst_fvs + ; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds' + , cid_sigs = uprags', cid_fam_insts = ats' }, + all_fvs) } } } -- We return the renamed associated data type declarations so -- that they can be entered into the list of type declarations -- for the binding group, but we also keep a copy in the instance. @@ -478,33 +489,90 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- the instance context after renaming. This is a bit -- strange, but should not matter (and it would be more work -- to remove the context). + +rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars) +rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon + , fid_pats = HsWB { hswb_cts = pats } + , fid_defn = defn }) + = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon + ; let loc = case pats of + [] -> pprPanic "rnFamInstDecl" (ppr tycon) + (L loc _ : []) -> loc + (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps)) + (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats + + + ; rdr_env <- getLocalRdrEnv + ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names + ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names + -- All the free vars of the family patterns + -- with a sensible binding location + ; ((pats', defn'), fvs) + <- bindLocalNamesFV kv_names $ + bindLocalNamesFV tv_names $ + do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats + ; (defn', rhs_fvs) <- rnTyDefn tycon defn + + -- See Note [Renaming associated types] + ; let bad_tvs = case mb_cls of + Nothing -> [] + Just (_,cls_tvs) -> filter is_bad cls_tvs + is_bad tv = not (tv `elem` tv_names) && tv `elemNameSet` rhs_fvs + + ; unless (null bad_tvs) (badAssocRhs bad_tvs) + ; return ((pats', defn'), rhs_fvs `plusFV` pat_fvs) } + + + ; let all_fvs = fvs `addOneFV` unLoc tycon' + ; return ( FamInstDecl { fid_tycon = tycon' + , fid_pats = HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names } + , fid_defn = defn', fid_fvs = all_fvs } + , all_fvs ) } + -- type instance => use, hence addOneFV \end{code} Renaming of the associated types in instances. \begin{code} -rnATInsts :: Name -> [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) - -- NB: We allow duplicate associated-type decls; - -- See Note [Associated type instances] in TcInstDcls -rnATInsts cls atDecls = rnList rnATInst atDecls +rnATDecls :: Name -- Class + -> LHsTyVarBndrs Name + -> [LTyClDecl RdrName] + -> RnM ([LTyClDecl Name], FreeVars) +rnATDecls cls hs_tvs at_decls + = rnList (rnTyClDecl (Just (cls, tv_ns))) at_decls where - rnATInst tydecl@TyData {} = rnTyClDecl (Just cls) tydecl - rnATInst tydecl@TySynonym {} = rnTyClDecl (Just cls) tydecl - rnATInst tydecl = pprPanic "RnSource.rnATInsts: invalid AT instance" - (ppr (tcdName tydecl)) + tv_ns = hsLTyVarNames hs_tvs + -- Type variable binders (but NOT kind variables) + -- See Note [Renaming associated types] in RnTypes + +rnATInstDecls :: Name -- Class + -> LHsTyVarBndrs Name + -> [LFamInstDecl RdrName] + -> RnM ([LFamInstDecl Name], FreeVars) +-- Used for the family declarations and defaults in a class decl +-- and the family instance declarations in an instance +-- +-- NB: We allow duplicate associated-type decls; +-- See Note [Associated type instances] in TcInstDcls +rnATInstDecls cls hs_tvs at_insts + = rnList (rnFamInstDecl (Just (cls, tv_ns))) at_insts + where + tv_ns = hsLTyVarNames hs_tvs + -- Type variable binders (but NOT kind variables) + -- See Note [Renaming associated types] in RnTypes \end{code} For the method bindings in class and instance decls, we extend the type variable environment iff -fglasgow-exts \begin{code} -extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name] +extendTyVarEnvForMethodBinds :: [Name] -> RnM (Bag (LHsBind Name), FreeVars) -> RnM (Bag (LHsBind Name), FreeVars) -extendTyVarEnvForMethodBinds tyvars thing_inside +extendTyVarEnvForMethodBinds ktv_names thing_inside = do { scoped_tvs <- xoptM Opt_ScopedTypeVariables ; if scoped_tvs then - extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside + extendTyVarEnvFVRn ktv_names thing_inside else thing_inside } \end{code} @@ -520,8 +588,7 @@ rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) rnSrcDerivDecl (DerivDecl ty) = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr) - ; ty' <- rnLHsInstType (text "In a deriving declaration") ty - ; let fvs = extractHsTyNames ty' + ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty ; return (DerivDecl ty', fvs) } standaloneDerivErr :: SDoc @@ -539,36 +606,40 @@ standaloneDerivErr \begin{code} rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) - = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ - bindLocatedLocalsFV (map get_var vars) $ \ ids -> - do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids) - -- NB: The binders in a rule are always Ids - -- We don't (yet) support type variables - - ; (lhs', fv_lhs') <- rnLExpr lhs - ; (rhs', fv_rhs') <- rnLExpr rhs - - ; checkValidRule rule_name ids lhs' fv_lhs' - - ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', - fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') } + = do { let rdr_names_w_loc = map get_var vars + ; checkDupRdrNames rdr_names_w_loc + ; checkShadowedRdrNames rdr_names_w_loc + ; names <- newLocalBndrsRn rdr_names_w_loc + ; bindHsRuleVars rule_name vars names $ \ vars' -> + do { (lhs', fv_lhs') <- rnLExpr lhs + ; (rhs', fv_rhs') <- rnLExpr rhs + ; checkValidRule rule_name names lhs' fv_lhs' + ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', + fv_lhs' `plusFV` fv_rhs') } } where - doc = RuleCtx rule_name - - get_var (RuleBndr v) = v get_var (RuleBndrSig v _) = v + get_var (RuleBndr v) = v + +bindHsRuleVars :: RuleName -> [RuleBndr RdrName] -> [Name] + -> ([RuleBndr Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindHsRuleVars rule_name vars names thing_inside + = go vars names $ \ vars' -> + bindLocalNamesFV names (thing_inside vars') + where + doc = RuleCtx rule_name - rn_var (RuleBndr (L loc _), id) - = return (RuleBndr (L loc id), emptyFVs) - rn_var (RuleBndrSig (L loc _) t, id) - = do { (t', fvs) <- rnHsTypeFVs doc t - ; return (RuleBndrSig (L loc id) t', fvs) } + go (RuleBndr (L loc _) : vars) (n : ns) thing_inside + = go vars ns $ \ vars' -> + thing_inside (RuleBndr (L loc n) : vars') -badRuleVar :: FastString -> Name -> SDoc -badRuleVar name var - = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon, - ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> - ptext (sLit "does not appear on left hand side")] + go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside + = rnHsBndrSig doc bsig $ \ bsig' -> + go vars ns $ \ vars' -> + thing_inside (RuleBndrSig (L loc n) bsig' : vars') + + go [] [] thing_inside = thing_inside [] + go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) \end{code} Note [Rule LHS validity checking] @@ -628,6 +699,12 @@ validRuleLhs foralls lhs checkl_es es = foldr (mplus . checkl_e) Nothing es -} +badRuleVar :: FastString -> Name -> SDoc +badRuleVar name var + = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon, + ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> + ptext (sLit "does not appear on left hand side")] + badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc badRuleLhsErr name lhs bad_e = sep [ptext (sLit "Rule") <+> ftext name <> colon, @@ -685,8 +762,8 @@ rnHsVectDecl (HsVectClassIn cls) rnHsVectDecl (HsVectClassOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" rnHsVectDecl (HsVectInstIn instTy) - = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy - ; return (HsVectInstIn instTy', extractHsTyNames instTy') + = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy + ; return (HsVectInstIn instTy', fvs) } rnHsVectDecl (HsVectInstOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'" @@ -772,9 +849,10 @@ rnTyClDecls extra_deps tycl_ds ; return (map flattenSCC sccs, all_fvs) } -rnTyClDecl :: Maybe Name -- Just cls => this TyClDecl is nested - -- inside an *instance decl* for cls - -- used for associated types +rnTyClDecl :: Maybe (Name, [Name]) + -- Just (cls,tvs) => this TyClDecl is nested + -- inside an *instance decl* for cls + -- used for associated types -> TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars) rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) @@ -786,104 +864,52 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) -- and "data family"), both top level and (for an associated type) -- in a class decl rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars - , tcdFlavour = flav, tcdKind = kind }) - = bindQTvs fmly_doc mb_cls tyvars $ \tyvars' -> + , tcdFlavour = flav, tcdKindSig = kind }) + = bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' -> do { tycon' <- lookupLocatedTopBndrRn tycon - ; kind' <- rnLHsMaybeKind fmly_doc kind - ; let fv_kind = maybe emptyFVs extractHsTyNames kind' - fvs = extractHsTyVarBndrNames_s tyvars' fv_kind + ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars' - , tcdFlavour = flav, tcdKind = kind' } - , fvs) } - where fmly_doc = TyFamilyCtx tycon + , tcdFlavour = flav, tcdKindSig = kind' } + , fv_kind ) } + where + fmly_doc = TyFamilyCtx tycon + kvs = extractRdrKindSigVars kind --- "data", "newtype", "data instance, and "newtype instance" declarations +-- "data", "newtype" declarations -- both top level and (for an associated type) in an instance decl -rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, - tcdLName = tycon, tcdTyVars = tyvars, - tcdTyPats = typats, tcdCons = condecls, - tcdKindSig = sig, tcdDerivs = derivs} - = do { tycon' <- lookupTcdName mb_cls tydecl - ; sig' <- rnLHsMaybeKind data_doc sig - ; checkTc (h98_style || null (unLoc context)) - (badGadtStupidTheta tycon) - - ; ((tyvars', context', typats', derivs'), stuff_fvs) - <- bindQTvs data_doc mb_cls tyvars $ \ tyvars' -> do - -- Checks for distinct tyvars - { context' <- rnContext data_doc context - ; (typats', fvs1) <- rnTyPats data_doc tycon' typats - ; (derivs', fvs2) <- rn_derivs derivs - ; let fvs = fvs1 `plusFV` fvs2 `plusFV` - extractHsCtxtTyNames context' - `plusFV` maybe emptyFVs extractHsTyNames sig' - ; return ((tyvars', context', typats', derivs'), fvs) } - - -- For the constructor declarations, bring into scope the tyvars - -- bound by the header, but *only* in the H98 case - -- Reason: for GADTs, the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } - ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars' - | otherwise = [] - ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $ - rnConDecls condecls - -- No need to check for duplicate constructor decls - -- since that is done by RnNames.extendGlobalRdrEnvRn - - ; return (TyData {tcdND = new_or_data, tcdCtxt = context', - tcdLName = tycon', tcdTyVars = tyvars', - tcdTyPats = typats', tcdKindSig = sig', - tcdCons = condecls', tcdDerivs = derivs'}, - con_fvs `plusFV` stuff_fvs) - } - where - h98_style = case condecls of -- Note [Stupid theta] - L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False - _ -> True - - data_doc = TyDataCtx tycon - - rn_derivs Nothing = return (Nothing, emptyFVs) - rn_derivs (Just ds) = do { ds' <- rnLHsTypes data_doc ds - ; return (Just ds', extractHsTyNames_s ds') } - --- "type" and "type instance" declarations -rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name, - tcdTyPats = typats, tcdSynRhs = ty}) - = bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do - { -- Checks for distinct tyvars - name' <- lookupTcdName mb_cls tydecl - ; (typats',fvs1) <- rnTyPats syn_doc name' typats - ; (ty', fvs2) <- rnHsTypeFVs syn_doc ty - ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' - , tcdTyPats = typats', tcdSynRhs = ty'} - , extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) } - where - syn_doc = TySynCtx name - -rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, - tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, - tcdDocs = docs}) +rnTyClDecl mb_cls (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; let kvs = extractTyDefnKindVars defn + ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs) + ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) mb_cls kvs tyvars $ \ tyvars' -> + do { (defn', fvs) <- rnTyDefn tycon defn + ; return ((tyvars', defn'), fvs) } + ; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars' + , tcdTyDefn = defn', tcdFVs = fvs }, fvs) } + +rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls, + tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, + tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = docs}) = do { lcls' <- lookupLocatedTopBndrRn lcls ; let cls' = unLoc lcls' + kvs = [] -- No scoped kind vars except those in + -- kind signatures on the tyvars -- Tyvars scope over superclass context and method signatures ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs) - <- bindTyVarsFV cls_doc tyvars $ \ tyvars' -> do + <- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do -- Checks for distinct tyvars - { context' <- rnContext cls_doc context + { (context', cxt_fvs) <- rnContext cls_doc context ; fds' <- rnFds (docOfHsDocContext cls_doc) fds - ; let rn_at = rnTyClDecl (Just cls') - ; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats - ; sigs' <- renameSigs (ClsDeclCtxt cls') sigs - ; (at_defs', fv_at_defs) <- mapAndUnzipM (wrapLocFstM rn_at) at_defs - ; let fvs = extractHsCtxtTyNames context' `plusFV` - hsSigsFVs sigs' `plusFV` - plusFVs fv_ats `plusFV` - plusFVs fv_at_defs -- The fundeps have no free variables + ; (ats', fv_ats) <- rnATDecls cls' tyvars' ats + ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tyvars' at_defs + ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs + ; let fvs = cxt_fvs `plusFV` + sig_fvs `plusFV` + fv_ats `plusFV` + fv_at_defs ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) } -- No need to check for duplicate associated type decls @@ -907,7 +933,7 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. ; (mbinds', meth_fvs) - <- extendTyVarEnvForMethodBinds tyvars' $ + <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $ -- No need to check for duplicate method signatures -- since that is done by RnNames.extendGlobalRdrEnvRn -- and the methods are already in scope @@ -916,67 +942,63 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- Haddock docs ; docs' <- mapM (wrapLocM rnDocDecl) docs + ; let all_fvs = meth_fvs `plusFV` stuff_fvs ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', - tcdDocs = docs'}, - extractHsTyVarBndrNames_s tyvars' (meth_fvs `plusFV` stuff_fvs)) } + tcdDocs = docs', tcdFVs = all_fvs }, + all_fvs ) } where cls_doc = ClassDeclCtx lcls -bindQTvs :: HsDocContext -> Maybe Name -> [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindQTvs doc mb_cls tyvars thing_inside - | isNothing mb_cls -- Not associated - = bindTyVarsFV doc tyvars thing_inside - | otherwise -- Associated - = do { let tv_rdr_names = map hsLTyVarLocName tyvars - -- *All* the free vars of the family patterns - - -- Check for duplicated bindings - -- This test is irrelevant for data/type *instances*, where the tyvars - -- are the free tyvars of the patterns, and hence have no duplicates - -- But it's needed for data/type *family* decls - ; mapM_ dupBoundTyVar (findDupRdrNames tv_rdr_names) - - ; rdr_env <- getLocalRdrEnv - - ; tv_ns <- mapM (mk_tv_name rdr_env) tv_rdr_names - ; tyvars' <- zipWithM (\old new -> replaceLTyVarName old new (rnLHsKind doc)) tyvars tv_ns - ; (thing, fvs) <- bindLocalNamesFV tv_ns $ thing_inside tyvars' - - -- Check that the RHS of the decl mentions only type variables - -- bound on the LHS. For example, this is not ok - -- class C a b where - -- type F a x :: * - -- instance C (p,q) r where - -- type F (p,q) x = (x, r) -- BAD: mentions 'r' - -- c.f. Trac #5515 - ; let bad_tvs = filterNameSet (isTvOcc . nameOccName) fvs - ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs)) - - ; return (thing, fvs) } +rnTyDefn :: Located RdrName -> HsTyDefn RdrName -> RnM (HsTyDefn Name, FreeVars) +rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType + , td_ctxt = context, td_cons = condecls + , td_kindSig = sig, td_derivs = derivs }) + = do { checkTc (h98_style || null (unLoc context)) + (badGadtStupidTheta tycon) + + ; (sig', sig_fvs) <- rnLHsMaybeKind data_doc sig + ; (context', fvs1) <- rnContext data_doc context + ; (derivs', fvs3) <- rn_derivs derivs + + -- For the constructor declarations, drop the LocalRdrEnv + -- in the GADT case, where the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; let { zap_lcl_env | h98_style = \ thing -> thing + | otherwise = setLocalRdrEnv emptyLocalRdrEnv } + ; (condecls', con_fvs) <- zap_lcl_env $ + rnConDecls condecls + -- No need to check for duplicate constructor decls + -- since that is done by RnNames.extendGlobalRdrEnvRn + + ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` + con_fvs `plusFV` sig_fvs + ; return ( TyData { td_ND = new_or_data, td_cType = cType + , td_ctxt = context', td_kindSig = sig' + , td_cons = condecls', td_derivs = derivs' } + , all_fvs ) + } where - mk_tv_name :: LocalRdrEnv -> Located RdrName -> RnM Name - mk_tv_name rdr_env (L l tv_rdr) - = case lookupLocalRdrEnv rdr_env tv_rdr of - Just n -> return n - Nothing -> newLocalBndrRn (L l tv_rdr) + h98_style = case condecls of -- Note [Stupid theta] + L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False + _ -> True -badAssocRhs :: [Name] -> RnM () -badAssocRhs ns - = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") - <> plural ns - <+> pprWithCommas (quotes . ppr) ns) - 2 (ptext (sLit "All such variables must be bound on the LHS"))) + data_doc = TyDataCtx tycon -dupBoundTyVar :: [Located RdrName] -> RnM () -dupBoundTyVar (L loc tv : _) - = setSrcSpan loc $ - addErr (ptext (sLit "Illegal repeated type variable") <+> quotes (ppr tv)) -dupBoundTyVar [] = panic "dupBoundTyVar" + rn_derivs Nothing = return (Nothing, emptyFVs) + rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds + ; return (Just ds', fvs) } + +-- "type" and "type instance" declarations +rnTyDefn tycon (TySynonym { td_synRhs = ty }) + = do { (ty', rhs_fvs) <- rnLHsType syn_doc ty + ; return ( TySynonym { td_synRhs = ty' } + , rhs_fvs) } + where + syn_doc = TySynCtx tycon badGadtStupidTheta :: Located RdrName -> SDoc badGadtStupidTheta _ @@ -1014,13 +1036,13 @@ depAnalTyClDecls ds_w_fvs (L _ d, _) <- ds_w_fvs case d of ClassDecl { tcdLName = L _ cls_name - , tcdATs = ats } -> do - L _ assoc_decl <- ats - return (tcdName assoc_decl, cls_name) - TyData { tcdLName = L _ data_name - , tcdCons = cons } -> do - L _ dc <- cons - return (unLoc (con_name dc), data_name) + , tcdATs = ats } + -> do L _ assoc_decl <- ats + return (tcdName assoc_decl, cls_name) + TyDecl { tcdLName = L _ data_name + , tcdTyDefn = TyData { td_cons = cons } } + -> do L _ dc <- cons + return (unLoc (con_name dc), data_name) _ -> [] \end{code} @@ -1045,26 +1067,21 @@ is jolly confusing. See Trac #4875 %********************************************************* \begin{code} -rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars) --- Although, we are processing type patterns here, all type variables will --- already be in scope (they are the same as in the 'tcdTyVars' field of the --- type declaration to which these patterns belong) -rnTyPats _ _ Nothing - = return (Nothing, emptyFVs) -rnTyPats doc tc (Just typats) - = do { typats' <- rnLHsTypes doc typats - ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc) - -- type instance => use, hence addOneFV - ; return (Just typats', fvs) } +--------------- +badAssocRhs :: [Name] -> RnM () +badAssocRhs ns + = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") + <> plural ns + <+> pprWithCommas (quotes . ppr) ns) + 2 (ptext (sLit "All such variables must be bound on the LHS"))) +----------------- rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) -rnConDecls condecls - = do { condecls' <- mapM (wrapLocM rnConDecl) condecls - ; return (condecls', plusFVs (map conDeclFVs condecls')) } +rnConDecls = mapFvRn (wrapLocFstM rnConDecl) -rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) +rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs - , con_cxt = cxt, con_details = details + , con_cxt = lcxt@(L loc cxt), con_details = details , con_res = res_ty, con_doc = mb_doc , con_old_rec = old_rec, con_explicit = expl }) = do { addLocM checkConName name @@ -1075,39 +1092,39 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs -- For GADT syntax, the tvs are all the quantified tyvars -- Hence the 'filter' in the ResTyH98 case only ; rdr_env <- getLocalRdrEnv - ; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc - arg_tys = hsConDeclArgTys details - mentioned_tvs = case res_ty of - ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys) - ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) + ; let arg_tys = hsConDeclArgTys details + (free_kvs, free_tvs) = case res_ty of + ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys) + ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) -- With an Explicit forall, check for unused binders -- With Implicit, find the mentioned ones, and use them as binders ; new_tvs <- case expl of - Implicit -> return (userHsTyVarBndrs mentioned_tvs) - Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs mentioned_tvs + Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) + Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs ; return tvs } ; mb_doc' <- rnMbLHsDoc mb_doc - ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do - { new_context <- rnContext doc cxt - ; new_details <- rnConDeclDetails doc details - ; (new_details', new_res_ty) <- rnConResult doc (unLoc new_name) new_details res_ty + ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do + { (new_context, fvs1) <- rnContext doc lcxt + ; (new_details, fvs2) <- rnConDeclDetails doc details + ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context - , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }} + , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }, + fvs1 `plusFV` fvs2 `plusFV` fvs3) }} where doc = ConDeclCtx name - get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy HsBoxedTuple tys)) + get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) rnConResult :: HsDocContext -> Name -> HsConDetails (LHsType Name) [ConDeclField Name] - -> ResType RdrName + -> ResType (LHsType RdrName) -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], - ResType Name) -rnConResult _ _ details ResTyH98 = return (details, ResTyH98) + ResType (LHsType Name), FreeVars) +rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs) rnConResult doc con details (ResTyGADT ty) - = do { ty' <- rnLHsType doc ty + = do { (ty', fvs) <- rnLHsType doc ty ; let (arg_tys, res_ty) = splitHsFunType ty' -- We can finally split it up, -- now the renamer has dealt with fixities @@ -1119,7 +1136,7 @@ rnConResult doc con details (ResTyGADT ty) RecCon {} -> do { unless (null arg_tys) (addErr (badRecResTy (docOfHsDocContext doc))) - ; return (details, ResTyGADT res_ty) } + ; return (details, ResTyGADT res_ty, fvs) } PrefixCon {} | isSymOcc (getOccName con) -- See Note [Infix GADT cons] , [ty1,ty2] <- arg_tys @@ -1127,27 +1144,27 @@ rnConResult doc con details (ResTyGADT ty) ; return (if con `elemNameEnv` fix_env then InfixCon ty1 ty2 else PrefixCon arg_tys - , ResTyGADT res_ty) } + , ResTyGADT res_ty, fvs) } | otherwise - -> return (PrefixCon arg_tys, ResTyGADT res_ty) } + -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) } rnConDeclDetails :: HsDocContext -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] - -> RnM (HsConDetails (LHsType Name) [ConDeclField Name]) + -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], FreeVars) rnConDeclDetails doc (PrefixCon tys) - = do { new_tys <- mapM (rnLHsType doc) tys - ; return (PrefixCon new_tys) } + = do { (new_tys, fvs) <- rnLHsTypes doc tys + ; return (PrefixCon new_tys, fvs) } rnConDeclDetails doc (InfixCon ty1 ty2) - = do { new_ty1 <- rnLHsType doc ty1 - ; new_ty2 <- rnLHsType doc ty2 - ; return (InfixCon new_ty1 new_ty2) } + = do { (new_ty1, fvs1) <- rnLHsType doc ty1 + ; (new_ty2, fvs2) <- rnLHsType doc ty2 + ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } rnConDeclDetails doc (RecCon fields) - = do { new_fields <- rnConDeclFields doc fields + = do { (new_fields, fvs) <- rnConDeclFields doc fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn - ; return (RecCon new_fields) } + ; return (RecCon new_fields, fvs) } ------------------------------------------------- deprecRecSyntax :: ConDecl RdrName -> SDoc @@ -1216,10 +1233,10 @@ extendRecordFieldEnv tycl_decls inst_decls ; return $ unLoc x'} all_data_cons :: [ConDecl RdrName] - all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls + all_data_cons = [con | TyData { td_cons = cons } <- all_ty_defs , L _ con <- cons ] - all_tycl_decls = at_tycl_decls ++ concat tycl_decls - at_tycl_decls = instDeclFamInsts inst_decls -- Do not forget associated types! + all_ty_defs = [ defn | L _ (TyDecl { tcdTyDefn = defn }) <- concat tycl_decls ] + ++ map fid_defn (instDeclFamInsts inst_decls) -- Do not forget associated types! get_con (ConDecl { con_name = con, con_details = RecCon flds }) (RecFields env fld_set) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 3b86d0b38c..ed2144084a 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -15,8 +15,8 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, rnHsKind, rnLHsKind, rnLHsMaybeKind, - rnHsSigType, rnLHsInstType, rnHsTypeFVs, rnConDeclFields, - rnIPName, + rnHsSigType, rnLHsInstType, rnConDeclFields, + newTyVarNameRn, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, @@ -26,7 +26,9 @@ module RnTypes ( rnSplice, checkTH, -- Binding related stuff - bindTyVarsRn, bindTyVarsFV + bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig, + extractHsTyRdrTyVars, extractHsTysRdrTyVars, + extractRdrKindSigVars, extractTyDefnKindVars, filterInScope ) where import {-# SOURCE #-} RnExpr( rnLExpr ) @@ -36,12 +38,9 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) import DynFlags import HsSyn -import RdrHsSyn ( extractHsRhoRdrTyVars ) -import RnHsSyn ( extractHsTyNames, extractHsTyVarBndrNames_s ) import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import TcRnMonad -import IfaceEnv ( newIPName ) import RdrName import PrelNames import TysPrim ( funTyConName ) @@ -49,12 +48,14 @@ import Name import SrcLoc import NameSet -import Util ( filterOut ) -import BasicTypes ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFixity, +import Util +import BasicTypes ( compareFixity, funTyFixity, negateFixity, Fixity(..), FixityDirection(..) ) import Outputable import FastString -import Control.Monad ( unless, zipWithM ) +import Maybes +import Data.List ( nub ) +import Control.Monad ( unless, when ) #include "HsVersions.h" \end{code} @@ -69,23 +70,17 @@ to break several loop. %********************************************************* \begin{code} -rnHsTypeFVs :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnHsTypeFVs doc_str ty = do - ty' <- rnLHsType doc_str ty - return (ty', extractHsTyNames ty') - -rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) +rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. -rnHsSigType doc_str ty - = rnLHsType (TypeSigCtx doc_str) ty +rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty -rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) +rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -- Rename the type in an instance or standalone deriving decl rnLHsInstType doc_str ty - = do { ty' <- rnLHsType (TypeSigCtx doc_str) ty + = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty)) - ; return ty' } + ; return (ty', fvs) } where good_inst_ty | Just (_, _, L _ cls, _) <- splitLHsInstDeclTy_maybe ty @@ -101,59 +96,69 @@ want a gratuitous knot. \begin{code} rnLHsTyKi :: Bool -- True <=> renaming a type, False <=> a kind - -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name) -rnLHsTyKi isType doc = wrapLocM (rnHsTyKi isType doc) + -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsTyKi isType doc (L loc ty) + = setSrcSpan loc $ + do { (ty', fvs) <- rnHsTyKi isType doc ty + ; return (L loc ty', fvs) } -rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name) +rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) rnLHsType = rnLHsTyKi True -rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name) + +rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) rnLHsKind = rnLHsTyKi False -rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name)) -rnLHsMaybeKind _ Nothing = return Nothing -rnLHsMaybeKind doc (Just k) = do - k' <- rnLHsKind doc k - return (Just k') -rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name) +rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) + -> RnM (Maybe (LHsKind Name), FreeVars) +rnLHsMaybeKind _ Nothing + = return (Nothing, emptyFVs) +rnLHsMaybeKind doc (Just kind) + = do { (kind', fvs) <- rnLHsKind doc kind + ; return (Just kind', fvs) } + +rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) rnHsType = rnHsTyKi True -rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name) +rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars) rnHsKind = rnHsTyKi False -rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name) +rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) = ASSERT ( isType ) do +rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) + = ASSERT ( isType ) do -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} - name_env <- getLocalRdrEnv + rdr_env <- getLocalRdrEnv + loc <- getSrcSpanM let - mentioned = extractHsRhoRdrTyVars ctxt ty - - -- Don't quantify over type variables that are in scope; - -- when GlasgowExts is off, there usually won't be any, except for - -- class signatures: - -- class C a where { op :: a -> a } - forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned - tyvar_bndrs = userHsTyVarBndrs forall_tyvars - - rnForAll doc Implicit tyvar_bndrs ctxt ty - -rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau) + (forall_kvs, forall_tvs) = filterInScope rdr_env $ + extractHsTysRdrTyVars (ty:ctxt) + -- In for-all types we don't bring in scope + -- kind variables mentioned in kind signatures + -- (Well, not yet anyway....) + -- f :: Int -> T (a::k) -- Not allowed + + -- The filterInScope is to ensure that we don't quantify over + -- type variables that are in scope; when GlasgowExts is off, + -- there usually won't be any, except for class signatures: + -- class C a where { op :: a -> a } + tyvar_bndrs = userHsTyVarBndrs loc forall_tvs + + rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty + +rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau) = ASSERT ( isType ) do { -- Explicit quantification. -- Check that the forall'd tyvars are actually -- mentioned in the type, and produce a warning if not - let mentioned = extractHsRhoRdrTyVars ctxt tau + let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt) in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned - ; -- rnForAll does the rest - rnForAll doc Explicit forall_tyvars ctxt tau } + ; rnForAll doc Explicit kvs forall_tyvars lctxt tau } -rnHsTyKi isType _ (HsTyVar rdr_name) = do - -- We use lookupOccRn in kinds because all the names are in - -- TcClsName, and we don't want to look in DataName. - name <- (if isType then lookupPromotedOccRn else lookupOccRn) rdr_name - return (HsTyVar name) +rnHsTyKi isType _ (HsTyVar rdr_name) + = do { name <- rnTyVar isType rdr_name + ; return (HsTyVar name, unitFV name) } -- If we see (forall a . ty), without foralls on, the forall will give -- a sensible error message, but we don't want to complain about the dot too @@ -162,120 +167,157 @@ rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2) = ASSERT ( isType ) setSrcSpan loc $ do { ops_ok <- xoptM Opt_TypeOperators ; op' <- if ops_ok - then lookupPromotedOccRn op + then rnTyVar isType op else do { addErr (opTyErr op ty) ; return (mkUnboundName op) } -- Avoid double complaint ; let l_op' = L loc op' ; fix <- lookupTyFixityRn l_op' - ; ty1' <- rnLHsType doc ty1 - ; ty2' <- rnLHsType doc ty2 - ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) op' fix ty1' ty2' } + ; (ty1', fvs1) <- rnLHsType doc ty1 + ; (ty2', fvs2) <- rnLHsType doc ty2 + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) + op' fix ty1' ty2' + ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') } -rnHsTyKi isType doc (HsParTy ty) = do - ty' <- rnLHsTyKi isType doc ty - return (HsParTy ty') +rnHsTyKi isType doc (HsParTy ty) + = do { (ty', fvs) <- rnLHsTyKi isType doc ty + ; return (HsParTy ty', fvs) } rnHsTyKi isType doc (HsBangTy b ty) - = ASSERT ( isType ) do { ty' <- rnLHsType doc ty - ; return (HsBangTy b ty') } + = ASSERT ( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; return (HsBangTy b ty', fvs) } rnHsTyKi isType doc (HsRecTy flds) - = ASSERT ( isType ) do { flds' <- rnConDeclFields doc flds - ; return (HsRecTy flds') } + = ASSERT ( isType ) + do { (flds', fvs) <- rnConDeclFields doc flds + ; return (HsRecTy flds', fvs) } -rnHsTyKi isType doc (HsFunTy ty1 ty2) = do - ty1' <- rnLHsTyKi isType doc ty1 +rnHsTyKi isType doc (HsFunTy ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 -- Might find a for-all as the arg of a function type - ty2' <- rnLHsTyKi isType doc ty2 + ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 -- Or as the result. This happens when reading Prelude.hi -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements - if isType - then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' - else return (HsFunTy ty1' ty2') + ; res_ty <- if isType + then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' + else return (HsFunTy ty1' ty2') + ; return (res_ty, fvs1 `plusFV` fvs2) } -rnHsTyKi isType doc listTy@(HsListTy ty) = do - data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (dataKindsErr listTy)) - ty' <- rnLHsTyKi isType doc ty - return (HsListTy ty') +rnHsTyKi isType doc listTy@(HsListTy ty) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless (data_kinds || isType) (addErr (dataKindsErr listTy)) + ; (ty', fvs) <- rnLHsTyKi isType doc ty + ; return (HsListTy ty', fvs) } rnHsTyKi isType doc (HsKindSig ty k) - = ASSERT ( isType ) do { - ; kind_sigs_ok <- xoptM Opt_KindSignatures - ; unless kind_sigs_ok (addErr (kindSigErr ty)) - ; ty' <- rnLHsType doc ty - ; k' <- rnLHsKind doc k - ; return (HsKindSig ty' k') } + = ASSERT ( isType ) + do { kind_sigs_ok <- xoptM Opt_KindSignatures + ; unless kind_sigs_ok (badSigErr False doc ty) + ; (ty', fvs1) <- rnLHsType doc ty + ; (k', fvs2) <- rnLHsKind doc k + ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do - ty' <- rnLHsType doc ty - return (HsPArrTy ty') +rnHsTyKi isType doc (HsPArrTy ty) + = ASSERT ( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; return (HsPArrTy ty', fvs) } -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do - data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (dataKindsErr tupleTy)) - tys' <- mapM (rnLHsTyKi isType doc) tys - return (HsTupleTy tup_con tys') - -rnHsTyKi isType doc (HsAppTy ty1 ty2) = do - ty1' <- rnLHsTyKi isType doc ty1 - ty2' <- rnLHsTyKi isType doc ty2 - return (HsAppTy ty1' ty2') - -rnHsTyKi isType doc (HsIParamTy n ty) = ASSERT( isType ) do - ty' <- rnLHsType doc ty - n' <- rnIPName n - return (HsIParamTy n' ty') - -rnHsTyKi isType doc (HsEqTy ty1 ty2) = ASSERT( isType ) do - ty1' <- rnLHsType doc ty1 - ty2' <- rnLHsType doc ty2 - return (HsEqTy ty1' ty2') +rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless (data_kinds || isType) (addErr (dataKindsErr tupleTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys + ; return (HsTupleTy tup_con tys', fvs) } + +-- 1. Perhaps we should use a separate extension here? +-- 2. Check that the integer is positive? +rnHsTyKi isType _ tyLit@(HsTyLit t) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless (data_kinds || isType) (addErr (dataKindsErr tyLit)) + ; return (HsTyLit t, emptyFVs) } + +rnHsTyKi isType doc (HsAppTy ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 + ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 + ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) } + +rnHsTyKi isType doc (HsIParamTy n ty) + = ASSERT( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; return (HsIParamTy n ty', fvs) } + +rnHsTyKi isType doc (HsEqTy ty1 ty2) + = ASSERT( isType ) + do { (ty1', fvs1) <- rnLHsType doc ty1 + ; (ty2', fvs2) <- rnLHsType doc ty2 + ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } rnHsTyKi isType _ (HsSpliceTy sp _ k) - = ASSERT ( isType ) do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs - ; return (HsSpliceTy sp' fvs k) } + = ASSERT ( isType ) + do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs + ; return (HsSpliceTy sp' fvs k, fvs) } -rnHsTyKi isType doc (HsDocTy ty haddock_doc) = ASSERT ( isType ) do - ty' <- rnLHsType doc ty - haddock_doc' <- rnLHsDoc haddock_doc - return (HsDocTy ty' haddock_doc') +rnHsTyKi isType doc (HsDocTy ty haddock_doc) + = ASSERT ( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; haddock_doc' <- rnLHsDoc haddock_doc + ; return (HsDocTy ty' haddock_doc', fvs) } #ifndef GHCI rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty) #else -rnHsTyKi isType doc (HsQuasiQuoteTy qq) = ASSERT ( isType ) do { ty <- runQuasiQuoteType qq - ; rnHsType doc (unLoc ty) } +rnHsTyKi isType doc (HsQuasiQuoteTy qq) + = ASSERT ( isType ) + do { ty <- runQuasiQuoteType qq + ; rnHsType doc (unLoc ty) } #endif -rnHsTyKi isType _ (HsCoreTy ty) = ASSERT ( isType ) return (HsCoreTy ty) -rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi" -rnHsTyKi isType doc (HsExplicitListTy k tys) = - ASSERT( isType ) - do tys' <- mapM (rnLHsType doc) tys - return (HsExplicitListTy k tys') +rnHsTyKi isType _ (HsCoreTy ty) + = ASSERT ( isType ) + return (HsCoreTy ty, emptyFVs) + -- The emptyFVs probably isn't quite right + -- but I don't think it matters + +rnHsTyKi _ _ (HsWrapTy {}) + = panic "rnHsTyKi" + +rnHsTyKi isType doc (HsExplicitListTy k tys) + = ASSERT( isType ) + do { (tys', fvs) <- rnLHsTypes doc tys + ; return (HsExplicitListTy k tys', fvs) } + +rnHsTyKi isType doc (HsExplicitTupleTy kis tys) + = ASSERT( isType ) + do { (tys', fvs) <- rnLHsTypes doc tys + ; return (HsExplicitTupleTy kis tys', fvs) } + +-------------- +rnTyVar :: Bool -> RdrName -> RnM Name +rnTyVar is_type rdr_name + | is_type = lookupTypeOccRn rdr_name + | otherwise = lookupKindOccRn rdr_name -rnHsTyKi isType doc (HsExplicitTupleTy kis tys) = - ASSERT( isType ) - do tys' <- mapM (rnLHsType doc) tys - return (HsExplicitTupleTy kis tys') -------------- rnLHsTypes :: HsDocContext -> [LHsType RdrName] - -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name] -rnLHsTypes doc tys = mapM (rnLHsType doc) tys + -> RnM ([LHsType Name], FreeVars) +rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys \end{code} \begin{code} -rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName] - -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name) - -rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty +rnForAll :: HsDocContext -> HsExplicitFlag + -> [RdrName] -- Kind variables + -> LHsTyVarBndrs RdrName -- Type variables + -> LHsContext RdrName -> LHsType RdrName + -> RnM (HsType Name, FreeVars) + +rnForAll doc exp kvs forall_tyvars ctxt ty + | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt) + = rnHsType doc (unLoc ty) -- One reason for this case is that a type like Int# -- starts off as (HsForAllTy Nothing [] Int), in case -- there is some quantification. Now that we have quantified @@ -284,48 +326,149 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty -- get an error, because the body of a genuine for-all is -- of kind *. -rnForAll doc exp forall_tyvars ctxt ty - = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do - new_ctxt <- rnContext doc ctxt - new_ty <- rnLHsType doc ty - return (HsForAllTy exp new_tyvars new_ctxt new_ty) + | otherwise + = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars -> + do { (new_ctxt, fvs1) <- rnContext doc ctxt + ; (new_ty, fvs2) <- rnLHsType doc ty + ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) } -- Retain the same implicit/explicit flag as before -- so that we can later print it correctly -bindTyVarsFV :: HsDocContext -> [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindTyVarsFV doc tyvars thing_inside - = bindTyVarsRn doc tyvars $ \ tyvars' -> - do { (res, fvs) <- thing_inside tyvars' - ; return (res, extractHsTyVarBndrNames_s tyvars' fvs) } - -bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM a) - -> RnM a --- Haskell-98 binding of type variables; e.g. within a data type decl -bindTyVarsRn doc tyvar_names enclosed_scope - = bindLocatedLocalsRn located_tyvars $ \ names -> - do { kind_sigs_ok <- xoptM Opt_KindSignatures - ; unless (null kinded_tyvars || kind_sigs_ok) - (mapM_ (addErr . kindSigErr) kinded_tyvars) - ; tyvar_names' <- zipWithM replace tyvar_names names - ; enclosed_scope tyvar_names' } +--------------- +bindSigTyVarsFV :: [Name] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +-- Used just before renaming the defn of a function +-- with a separate type signature, to bring its tyvars into scope +-- With no -XScopedTypeVariables, this is a no-op +bindSigTyVarsFV tvs thing_inside + = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } + +--------------- +bindHsTyVars :: HsDocContext + -> Maybe a -- Just _ => an associated type decl + -> [RdrName] -- Kind variables from scope + -> LHsTyVarBndrs RdrName -- Type variables + -> (LHsTyVarBndrs Name -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +-- (a) Bring kind variables into scope +-- both (i) passed in (kv_bndrs) and (ii) mentioned in the kinds of tv_bndrs +-- (b) Bring type variables into scope +bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside + = do { rdr_env <- getLocalRdrEnv + ; let tvs = hsQTvBndrs tv_bndrs + kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs + , let (_, kvs) = extractHsTyRdrTyVars kind + , kv <- kvs ] + all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $ + nub (kv_bndrs ++ kvs_from_tv_bndrs) + ; poly_kind <- xoptM Opt_PolyKinds + ; unless (poly_kind || null all_kvs) + (addErr (badKindBndrs doc all_kvs)) + ; loc <- getSrcSpanM + ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs + ; bindLocalNamesFV kv_names $ + do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs + + rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) + rn_tv_bndr (L loc (UserTyVar rdr)) + = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr + ; return (L loc (UserTyVar nm), emptyFVs) } + rn_tv_bndr (L loc (KindedTyVar rdr kind)) + = do { sig_ok <- xoptM Opt_KindSignatures + ; unless sig_ok (badSigErr False doc kind) + ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr + ; (kind', fvs) <- rnLHsKind doc kind + ; return (L loc (KindedTyVar nm kind'), fvs) } + + -- Check for duplicate or shadowed tyvar bindrs + ; checkDupRdrNames tv_names_w_loc + ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) + + ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs + ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $ + do { env <- getLocalRdrEnv + ; traceRn (text "bhtv" <+> (ppr tvs $$ ppr all_kvs $$ ppr env)) + ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) } + ; return (res, fvs1 `plusFV` fvs2) } } + +newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name +newTyVarNameRn mb_assoc rdr_env loc rdr + | Just _ <- mb_assoc -- Use the same Name as the parent class decl + , Just n <- lookupLocalRdrEnv rdr_env rdr + = return n + | otherwise + = newLocalBndrRn (L loc rdr) + +-------------------------------- +rnHsBndrSig :: HsDocContext + -> HsWithBndrs (LHsType RdrName) + -> (HsWithBndrs (LHsType Name) -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside + = do { sig_ok <- xoptM Opt_ScopedTypeVariables + ; unless sig_ok (badSigErr True doc ty) + ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty + ; name_env <- getLocalRdrEnv + ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs + , not (tv `elemLocalRdrEnv` name_env) ] + ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs + , not (kv `elemLocalRdrEnv` name_env) ] + ; bindLocalNamesFV kv_names $ + bindLocalNamesFV tv_names $ + do { (ty', fvs1) <- rnLHsType doc ty + ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = tv_names }) + ; return (res, fvs1 `plusFV` fvs2) } } + +badKindBndrs :: HsDocContext -> [RdrName] -> SDoc +badKindBndrs doc kvs + = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs + <+> pprQuotedList kvs) + 2 (ptext (sLit "Perhaps you intended to use -XPolyKinds")) + , docOfHsDocContext doc ] + +badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM () +badSigErr is_type doc (L loc ty) + = setSrcSpan loc $ addErr $ + vcat [ hang (ptext (sLit "Illegal") <+> what + <+> ptext (sLit "signature:") <+> quotes (ppr ty)) + 2 (ptext (sLit "Perhaps you intended to use") <+> flag) + , docOfHsDocContext doc ] where - replace (L loc n1) n2 = replaceTyVarName n1 n2 (rnLHsKind doc) >>= return . L loc - located_tyvars = hsLTyVarLocNames tyvar_names - kinded_tyvars = [n | L _ (KindedTyVar n _ _) <- tyvar_names] + what | is_type = ptext (sLit "type") + | otherwise = ptext (sLit "kind") + flag | is_type = ptext (sLit "-XScopedTypeVariables") + | otherwise = ptext (sLit "-XKindSignatures") +\end{code} -rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] -> RnM [ConDeclField Name] -rnConDeclFields doc fields = mapM (rnField doc) fields +Note [Renaming associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check that the RHS of the decl mentions only type variables +bound on the LHS. For example, this is not ok + class C a b where + type F a x :: * + instance C (p,q) r where + type F (p,q) x = (x, r) -- BAD: mentions 'r' +c.f. Trac #5515 + +What makes it tricky is that the *kind* variable from the class *are* +in scope (Trac #5862): + class Category (x :: k -> k -> *) where + type Ob x :: k -> Constraint + id :: Ob x a => x a a + (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c +Here 'k' is in scope in the kind signature even though it's not +explicitly mentioned on the LHS of the type Ob declaration. + +We could force you to mention k explicitly, thus + class Category (x :: k -> k -> *) where + type Ob (x :: k -> k -> *) :: k -> Constraint +but it seems tiresome to do so. -rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name) -rnField doc (ConDeclField name ty haddock_doc) - = do { new_name <- lookupLocatedTopBndrRn name - ; new_ty <- rnLHsType doc ty - ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (ConDeclField new_name new_ty new_haddock_doc) } -\end{code} %********************************************************* %* * @@ -334,14 +477,21 @@ rnField doc (ConDeclField name ty haddock_doc) %********************************************************* \begin{code} -rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name) -rnContext doc = wrapLocM (rnContext' doc) +rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] + -> RnM ([ConDeclField Name], FreeVars) +rnConDeclFields doc fields = mapFvRn (rnField doc) fields -rnContext' :: HsDocContext -> HsContext RdrName -> RnM (HsContext Name) -rnContext' doc ctxt = mapM (rnLHsType doc) ctxt +rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars) +rnField doc (ConDeclField name ty haddock_doc) + = do { new_name <- lookupLocatedTopBndrRn name + ; (new_ty, fvs) <- rnLHsType doc ty + ; new_haddock_doc <- rnMbLHsDoc haddock_doc + ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) } -rnIPName :: IPName RdrName -> RnM (IPName Name) -rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n))) +rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnContext doc (L loc cxt) + = do { (cxt', fvs) <- rnLHsTypes doc cxt + ; return (L loc cxt', fvs) } \end{code} @@ -635,14 +785,13 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) %********************************************************* \begin{code} -warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [Located RdrName] -> TcM () -warnUnusedForAlls in_doc bound used +warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM () +warnUnusedForAlls in_doc bound mentioned_rdrs = ifWOptM Opt_WarnUnusedMatches $ mapM_ add_warn bound_but_not_used where bound_names = hsLTyVarLocNames bound bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names - mentioned_rdrs = map unLoc used add_warn (L loc tv) = addWarnAt loc $ @@ -703,7 +852,7 @@ rnSplice (HsSplice n expr) ; gbl_rdr <- getGlobalRdrEnv ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, isLocalGRE gre] - lcl_names = mkNameSet (occEnvElts lcl_rdr) + lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } @@ -713,7 +862,158 @@ checkTH _ _ = return () -- OK #else checkTH e what -- Raise an error in a stage-1 compiler = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> - ptext (sLit "illegal in a stage-1 compiler"), + ptext (sLit "requires GHC with interpreter support"), + ptext (sLit "Perhaps you are using a stage-1 compiler?"), nest 2 (ppr e)]) #endif \end{code} + +%************************************************************************ +%* * + Finding the free type variables of a (HsType RdrName) +%* * +%************************************************************************ + + +Note [Kind and type-variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type signature we may implicitly bind type varaible and, more +recently, kind variables. For example: + * f :: a -> a + f = ... + Here we need to find the free type variables of (a -> a), + so that we know what to quantify + + * class C (a :: k) where ... + This binds 'k' in ..., as well as 'a' + + * f (x :: a -> [a]) = .... + Here we bind 'a' in .... + + * f (x :: T a -> T (b :: k)) = ... + Here we bind both 'a' and the kind variable 'k' + + * type instance F (T (a :: Maybe k)) = ...a...k... + Here we want to constrain the kind of 'a', and bind 'k'. + +In general we want to walk over a type, and find + * Its free type variables + * The free kind variables of any kind signatures in the type + +Hence we returns a pair (kind-vars, type vars) +See also Note [HsBSig binder lists] in HsTypes + +\begin{code} +type FreeKiTyVars = ([RdrName], [RdrName]) + +filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars +filterInScope rdr_env (kvs, tvs) + = (filterOut in_scope kvs, filterOut in_scope tvs) + where + in_scope tv = tv `elemLocalRdrEnv` rdr_env + +extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars +-- extractHsTyRdrNames finds the free (kind, type) variables of a HsType +-- or the free (sort, kind) variables of a HsKind +-- It's used when making the for-alls explicit. +-- See Note [Kind and type-variable binders] +extractHsTyRdrTyVars ty + = case extract_lty ty ([],[]) of + (kvs, tvs) -> (nub kvs, nub tvs) + +extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars +-- See Note [Kind and type-variable binders] +extractHsTysRdrTyVars ty + = case extract_ltys ty ([],[]) of + (kvs, tvs) -> (nub kvs, nub tvs) + +extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName] +extractRdrKindSigVars Nothing = [] +extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[]))) + +extractTyDefnKindVars :: HsTyDefn RdrName -> [RdrName] +-- Get the scoped kind variables mentioned free in the constructor decls +-- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b) +-- Here k should scope over the whole definition +extractTyDefnKindVars (TySynonym { td_synRhs = ty}) + = fst (extractHsTyRdrTyVars ty) +extractTyDefnKindVars (TyData { td_ctxt = ctxt, td_kindSig = ksig + , td_cons = cons, td_derivs = derivs }) + = fst $ extract_lctxt ctxt $ + extract_mb extract_lkind ksig $ + extract_mb extract_ltys derivs $ + foldr (extract_con . unLoc) ([],[]) cons + where + extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc + extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs + , con_cxt = ctxt, con_details = details }) acc + = extract_hs_tv_bndrs qvs acc $ + extract_lctxt ctxt $ + extract_ltys (hsConDeclArgTys details) ([],[]) + + +extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_lctxt ctxt = extract_ltys (unLoc ctxt) + +extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars +extract_ltys tys acc = foldr extract_lty acc tys + +extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars +extract_mb _ Nothing acc = acc +extract_mb f (Just x) acc = f x acc + +extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of + (_, res_kvs) -> (res_kvs, acc_tvs) + -- Kinds shouldn't have sort signatures! + +extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_lty (L _ ty) acc + = case ty of + HsTyVar tv -> extract_tv tv acc + HsBangTy _ ty -> extract_lty ty acc + HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds + HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) + HsListTy ty -> extract_lty ty acc + HsPArrTy ty -> extract_lty ty acc + HsTupleTy _ tys -> extract_ltys tys acc + HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) + HsIParamTy _ ty -> extract_lty ty acc + HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) + HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc)) + HsParTy ty -> extract_lty ty acc + HsCoreTy {} -> acc -- The type is closed + HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables + HsSpliceTy {} -> acc -- Type splices mention no type variables + HsDocTy ty _ -> extract_lty ty acc + HsExplicitListTy _ tys -> extract_ltys tys acc + HsExplicitTupleTy _ tys -> extract_ltys tys acc + HsTyLit _ -> acc + HsWrapTy _ _ -> panic "extract_lty" + HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc) + HsForAllTy _ tvs cx ty -> extract_hs_tv_bndrs tvs acc $ + extract_lctxt cx $ + extract_lty ty ([],[]) + +extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars + -> FreeKiTyVars -> FreeKiTyVars +extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs }) + acc@(acc_kvs, acc_tvs) -- Note accumulator comes first + (body_kvs, body_tvs) + | null tvs + = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs) + | otherwise + = (outer_kvs ++ body_kvs, + outer_tvs ++ filterOut (`elem` local_tvs) body_tvs) + where + local_tvs = map hsLTyVarName tvs + -- Currently we don't have a syntax to explicitly bind + -- kind variables, so these are all type variables + + (outer_kvs, outer_tvs) = foldr extract_lkind acc [k | L _ (KindedTyVar _ k) <- tvs] + +extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_tv tv acc + | isRdrTyVar tv = case acc of (kvs,tvs) -> (kvs, tv : tvs) + | otherwise = acc +\end{code} diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 4a92f818d4..18c0178900 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -38,8 +38,7 @@ import CoreSubst import Var ( Var ) import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) import CoreUtils ( mkAltExpr - , exprIsTrivial, exprIsCheap ) -import DataCon ( isUnboxedTupleCon ) + , exprIsTrivial) import Type ( tyConAppArgs ) import CoreSyn import Outputable @@ -112,19 +111,6 @@ to the reverse CSE mapping if the scrutinee is a non-trivial expression. case binder -> scrutinee to the substitution -Note [Unboxed tuple case binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - case f x of t { (# a,b #) -> - case ... of - True -> f x - False -> 0 } - -We must not replace (f x) by t, because t is an unboxed-tuple binder. -Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is - f x --> (# a,b #) -That is why the CSEMap has pairs of expressions. - Note [CSE for INLINE and NOINLINE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We are careful to do no CSE inside functions that the user has marked as @@ -258,20 +244,6 @@ cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts' cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt] -cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)] - | isUnboxedTupleCon con - -- Unboxed tuples are special because the case binder isn't - -- a real value. See Note [Unboxed tuple case binders] - = [(DataAlt con, args'', tryForCSE new_env rhs)] - where - (env', args') = addBinders env args - args'' = map zapIdOccInfo args' -- They should all be ids - -- Same motivation for zapping as [Case binders 2] only this time - -- it's Note [Unboxed tuple case binders] - new_env | exprIsCheap scrut' = env' - | otherwise = extendCSEnv env' scrut' tup_value - tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr)) - cseAlts env scrut' bndr bndr' alts = map cse_alt alts where diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 829c2ca40f..b1429c5dbf 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -71,7 +71,6 @@ import CoreSyn import PprCore import CoreUtils import CoreLint ( lintCoreBindings ) -import PrelNames ( iNTERACTIVE ) import HscTypes import Module ( Module ) import DynFlags @@ -84,20 +83,22 @@ import Id ( Id ) import IOEnv hiding ( liftIO, failM, failWithM ) import qualified IOEnv ( liftIO ) import TcEnv ( tcLookupGlobal ) -import TcRnMonad ( TcM, initTc ) +import TcRnMonad ( initTcForLookup ) import Outputable import FastString import qualified ErrUtils as Err import Bag import Maybes +import SrcLoc import UniqSupply import UniqFM ( UniqFM, mapUFM, filterUFM ) import MonadUtils -import Util ( split, sortLe ) +import Util ( split ) import ListSetOps ( runs ) -import Data.List ( intersperse ) +import Data.List +import Data.Ord import Data.Dynamic import Data.IORef import Data.Map (Map) @@ -133,11 +134,11 @@ stuff before and after core passes, and do Core Lint when necessary. \begin{code} showPass :: DynFlags -> CoreToDo -> IO () -showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass)) +showPass dflags pass = Err.showPass dflags (showPpr dflags pass) endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () endPass dflags pass binds rules - = do { dumpPassResult dflags mb_flag (ppr pass) empty binds rules + = do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules ; lintPassResult dflags pass binds } where mb_flag = case coreDumpFlag pass of @@ -145,9 +146,9 @@ endPass dflags pass binds rules | dopt Opt_D_verbose_core2core dflags -> Just dflag _ -> Nothing -dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO () -dumpIfSet dump_me pass extra_info doc - = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc +dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () +dumpIfSet dflags dump_me pass extra_info doc + = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc dumpPassResult :: DynFlags -> Maybe DynFlag -- Just df => show details in a file whose @@ -158,18 +159,19 @@ dumpPassResult :: DynFlags -> IO () dumpPassResult dflags mb_flag hdr extra_info binds rules | Just dflag <- mb_flag - = Err.dumpSDoc dflags dflag (showSDoc hdr) dump_doc + = Err.dumpSDoc dflags dflag (showSDoc dflags hdr) dump_doc | otherwise - = Err.debugTraceMsg dflags 2 $ - (sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]) + = Err.debugTraceMsg dflags 2 size_doc -- Report result size -- This has the side effect of forcing the intermediate to be evaluated where - dump_doc = vcat [ text "Result size =" <+> int (coreBindsSize binds) - , extra_info - , blankLine + size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + + dump_doc = vcat [ nest 2 extra_info + , size_doc + , blankLine , pprCoreBindings binds , ppUnless (null rules) pp_rules ] pp_rules = vcat [ blankLine @@ -180,7 +182,7 @@ lintPassResult :: DynFlags -> CoreToDo -> CoreProgram -> IO () lintPassResult dflags pass binds = when (dopt Opt_DoCoreLinting dflags) $ do { let (warns, errs) = lintCoreBindings binds - ; Err.showPass dflags ("Core Linted result of " ++ showSDoc (ppr pass)) + ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) ; displayLintResults dflags pass warns errs binds } displayLintResults :: DynFlags -> CoreToDo @@ -188,10 +190,11 @@ displayLintResults :: DynFlags -> CoreToDo -> IO () displayLintResults dflags pass warns errs binds | not (isEmptyBag errs) - = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs - , ptext (sLit "*** Offending Program ***") - , pprCoreBindings binds - , ptext (sLit "*** End of Offense ***") ]) + = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + (vcat [ banner "errors", Err.pprMessageBag errs + , ptext (sLit "*** Offending Program ***") + , pprCoreBindings binds + , ptext (sLit "*** End of Offense ***") ]) ; Err.ghcExit dflags 1 } | not (isEmptyBag warns) @@ -202,7 +205,8 @@ displayLintResults dflags pass warns errs binds -- group. Only afer a round of simplification are they unravelled. , not opt_NoDebugOutput , showLintWarnings pass - = printDump (banner "warnings" $$ Err.pprMessageBag warns) + = log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + (banner "warnings" $$ Err.pprMessageBag warns) | otherwise = return () where @@ -307,7 +311,8 @@ instance Outputable CoreToDo where ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses") pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify n md) = ppr md <+> ptext (sLit "max-iterations=") <> int n +pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n + , ppr md ] pprPassDetails _ = empty \end{code} @@ -577,9 +582,8 @@ pprTickGroup :: [(Tick, Int)] -> SDoc pprTickGroup group@((tick1,_):_) = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) 2 (vcat [ int n <+> pprTickCts tick - | (tick,n) <- sortLe le group]) - where - le (_,n1) (_,n2) = n2 <= n1 -- We want largest first + -- flip as we want largest first + | (tick,n) <- sortBy (flip (comparing snd)) group]) pprTickGroup [] = panic "pprTickGroup" \end{code} @@ -1017,13 +1021,6 @@ dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM () dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str) \end{code} -\begin{code} - -initTcForLookup :: HscEnv -> TcM a -> IO a -initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE - -\end{code} - %************************************************************************ %* * diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 0601d7b7bf..5a462443e2 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -31,7 +31,7 @@ import Id ( isOneShotBndr, idType ) import Var import Type ( isUnLiftedType ) import VarSet -import Util ( zipEqual, zipWithEqual, count ) +import Util import UniqFM import Outputable \end{code} @@ -354,19 +354,27 @@ For @Case@, the possible ``drop points'' for the \tr{to_drop} bindings are: (a)~inside the scrutinee, (b)~inside one of the alternatives/default [default FVs always {\em first}!]. +Floating case expressions inward was added to fix Trac #5658: strict bindings +not floated in. In particular, this change allows array indexing operations, +which have a single DEFAULT alternative without any binders, to be floated +inward. SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed +scalars also need to be floated inward, but unpacks have a single non-DEFAULT +alternative that binds the elements of the tuple. We now therefore also support +floating in cases with a single alternative that may bind values. + \begin{code} -fiExpr to_drop (_, AnnCase scrut case_bndr _ [(DEFAULT,[],rhs)]) +fiExpr to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) | isUnLiftedType (idType case_bndr) , exprOkForSideEffects (deAnnotate scrut) = wrapFloats shared_binds $ fiExpr (case_float : rhs_binds) rhs where - case_float = FB (unitVarSet case_bndr) scrut_fvs - (FloatCase scrut' case_bndr DEFAULT []) + case_float = FB (mkVarSet (case_bndr : alt_bndrs)) scrut_fvs + (FloatCase scrut' case_bndr con alt_bndrs) scrut' = fiExpr scrut_binds scrut [shared_binds, scrut_binds, rhs_binds] = sepBindsByDropPoint False [freeVarsOf scrut, rhs_fvs] to_drop - rhs_fvs = freeVarsOf rhs `delVarSet` case_bndr + rhs_fvs = freeVarsOf rhs `delVarSetList` (case_bndr : alt_bndrs) scrut_fvs = freeVarsOf scrut fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 8056c0eceb..5a204f46b5 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -44,7 +44,7 @@ import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR ) import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import Unique import UniqFM -import Util ( mapAndUnzip, filterOut, fstOf3 ) +import Util import Bag import Outputable import FastString @@ -79,6 +79,14 @@ occurAnalysePgm this_mod active_rule imp_rules vects binds (rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects) -- The RULES and VECTORISE declarations keep things alive! + -- Note [Preventing loops due to imported functions rules] + imp_rules_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv + [ mapVarEnv (const maps_to) (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule) + | imp_rule <- imp_rules + , let maps_to = exprFreeIds (ru_rhs imp_rule) + `delVarSetList` ru_bndrs imp_rule + , arg <- ru_args imp_rule ] + go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) go _ [] = (initial_uds, []) @@ -86,7 +94,7 @@ occurAnalysePgm this_mod active_rule imp_rules vects binds = (final_usage, bind' ++ binds') where (bs_usage, binds') = go env binds - (final_usage, bind') = occAnalBind env env bind bs_usage + (final_usage, bind') = occAnalBind env env imp_rules_edges bind bs_usage occurAnalyseExpr :: CoreExpr -> CoreExpr -- Do occurrence analysis, and discard occurence info returned @@ -110,12 +118,13 @@ Bindings \begin{code} occAnalBind :: OccEnv -- The incoming OccEnv -> OccEnv -- Same, but trimmed by (binderOf bind) + -> IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs -> CoreBind -> UsageDetails -- Usage details of scope -> (UsageDetails, -- Of the whole let(rec) [CoreBind]) -occAnalBind env _ (NonRec binder rhs) body_usage +occAnalBind env _ imp_rules_edges (NonRec binder rhs) body_usage | isTyVar binder -- A type let; we don't gather usage info = (body_usage, [NonRec binder rhs]) @@ -123,15 +132,17 @@ occAnalBind env _ (NonRec binder rhs) body_usage = (body_usage, []) | otherwise -- It's mentioned in the body - = (body_usage' +++ rhs_usage3, [NonRec tagged_binder rhs']) + = (body_usage' +++ rhs_usage4, [NonRec tagged_binder rhs']) where (body_usage', tagged_binder) = tagBinder body_usage binder (rhs_usage1, rhs') = occAnalRhs env (Just tagged_binder) rhs rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder) rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder) -- See Note [Rules are extra RHSs] and Note [Rule dependency info] + rhs_usage4 = maybe rhs_usage3 (addIdOccs rhs_usage3) $ lookupVarEnv imp_rules_edges binder + -- See Note [Preventing loops due to imported functions rules] -occAnalBind _ env (Rec pairs) body_usage +occAnalBind _ env imp_rules_edges (Rec pairs) body_usage = foldr occAnalRec (body_usage, []) sccs -- For a recursive group, we -- * occ-analyse all the RHSs @@ -144,7 +155,7 @@ occAnalBind _ env (Rec pairs) body_usage sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR nodes nodes :: [Node Details] - nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env bndr_set) pairs + nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env imp_rules_edges bndr_set) pairs \end{code} Note [Dead code] @@ -404,6 +415,87 @@ It's up the programmer not to write silly rules like RULE f x = f x and the example above is just a more complicated version. +Note [Preventing loops due to imported functions rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + import GHC.Base (foldr) + + {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} + filter p xs = build (\c n -> foldr (filterFB c p) n xs) + filterFB c p = ... + + f = filter p xs + +Note that filter is not a loop-breaker, so what happens is: + f = filter p xs + = {inline} build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +We are in an infinite loop. + +A more elaborate example (that I actually saw in practice when I went to +mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: + {-# LANGUAGE Rank2Types #-} + module GHCList where + + import Prelude hiding (filter) + import GHC.Base (build) + + {-# INLINABLE filter #-} + filter :: (a -> Bool) -> [a] -> [a] + filter p [] = [] + filter p (x:xs) = if p x then x : filter p xs else filter p xs + + {-# NOINLINE [0] filterFB #-} + filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b + filterFB c p x r | p x = x `c` r + | otherwise = r + + {-# RULES + "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr + (filterFB c p) n xs) + "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p + #-} + +Then (because RULES are applied inside INLINABLE unfoldings, but inlinings +are not), the unfolding given to "filter" in the interface file will be: + filter p [] = [] + filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs + +Note that because this unfolding does not mention "filter", filter is not +marked as a strong loop breaker. Therefore at a use site in another module: + filter p xs + = {inline} + case xs of [] -> [] + (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs) + + build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +And we are in an infinite loop again, except that this time the loop is producing an +infinitely large *term* (an unrolling of filter) and so the simplifier finally +dies with "ticks exhausted" + +Because of this problem, we make a small change in the occurrence analyser +designed to mark functions like "filter" as strong loop breakers on the basis that: + 1. The RHS of filter mentions the local function "filterFB" + 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS + +So for each RULE for an *imported* function we are going to add +dependency edges between the *local* FVS of the rule LHS and the +*local* FVS of the rule RHS. We don't do anything special for RULES on +local functions because the standard occurrence analysis stuff is +pretty good at getting loop-breakerness correct there. + +It is important to note that even with this extra hack we aren't always going to get +things right. For example, it might be that the rule LHS mentions an imported Id, +and another module has a RULE that can rewrite that imported Id to one of our local +Ids. + Note [Specialising imported functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BUT for *automatically-generated* rules, the programmer can't be @@ -566,8 +658,8 @@ instance Outputable Details where , ptext (sLit "rule =") <+> ppr (nd_active_rule_fvs nd) ]) -makeNode :: OccEnv -> VarSet -> (Var, CoreExpr) -> Node Details -makeNode env bndr_set (bndr, rhs) +makeNode :: OccEnv -> IdEnv IdSet -> VarSet -> (Var, CoreExpr) -> Node Details +makeNode env imp_rules_edges bndr_set (bndr, rhs) = (details, varUnique bndr, keysUFM node_fvs) where details = ND { nd_bndr = bndr @@ -591,7 +683,9 @@ makeNode env bndr_set (bndr, rhs) is_active = occ_rule_act env :: Activation -> Bool rules = filterOut isBuiltinRule (idCoreRules bndr) rules_w_fvs :: [(Activation, VarSet)] -- Find the RHS fvs - rules_w_fvs = [ (ru_act rule, fvs) + rules_w_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) (lookupVarEnv imp_rules_edges bndr) + -- See Note [Preventing loops due to imported functions rules] + [ (ru_act rule, fvs) | rule <- rules , let fvs = exprFreeVars (ru_rhs rule) `delVarSetList` ru_bndrs rule @@ -1158,7 +1252,7 @@ occAnal env (Case scrut bndr ty alts) = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> let - alts_usage = foldr1 combineAltsUsageDetails alts_usage_s + alts_usage = foldr combineAltsUsageDetails emptyDetails alts_usage_s (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr total_usage = scrut_usage +++ alts_usage1 in @@ -1191,7 +1285,7 @@ occAnal env (Case scrut bndr ty alts) occAnal env (Let bind body) = case occAnal env_body body of { (body_usage, body') -> - case occAnalBind env env_body bind body_usage of { (final_usage, new_binds) -> + case occAnalBind env env_body emptyVarEnv bind body_usage of { (final_usage, new_binds) -> (final_usage, mkLets new_binds body') }} where env_body = trimOccEnv env (bindersOf bind) diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index beb64cb061..076df2e67c 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -68,7 +68,9 @@ import CoreArity ( exprBotStrictness_maybe ) import CoreFVs -- all of it import Coercion ( isCoVar ) import CoreSubst ( Subst, emptySubst, extendInScope, substBndr, substRecBndrs, - extendIdSubst, extendSubstWithVar, cloneBndr, cloneRecIdBndrs, substTy, substCo ) + extendIdSubst, extendSubstWithVar, cloneBndr, + cloneRecIdBndrs, substTy, substCo ) +import MkCore ( sortQuantVars ) import Id import IdInfo import Var @@ -78,8 +80,7 @@ import Literal ( litIsTrivial ) import Demand ( StrictSig, increaseStrictSigArity ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) -import Type ( isUnLiftedType, Type, sortQuantVars, mkPiTypes ) -import Kind ( kiVarsOfKinds ) +import Type ( isUnLiftedType, Type, mkPiTypes ) import BasicTypes ( Arity ) import UniqSupply import Util @@ -419,7 +420,10 @@ the inner loop. Things to note * We can't float a case to top level * It's worth doing this float even if we don't float - the case outside a value lambda + the case outside a value lambda. Example + case x of { + MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...) + If we floated the cases out we could eliminate one of them. * We only do this with a single-alternative case Note [Check the output scrutinee for okForSpec] @@ -814,7 +818,7 @@ lvlLamBndrs lvl bndrs \end{code} \begin{code} - -- Destintion level is the max Id level of the expression + -- Destination level is the max Id level of the expression -- (We'll abstract the type variables, if any.) destLevel :: LevelEnv -> VarSet -> Bool -> Maybe (Arity, StrictSig) -> Level destLevel env fvs is_function mb_bot @@ -826,6 +830,7 @@ destLevel env fvs is_function mb_bot , countFreeIds fvs <= n_args = tOP_LEVEL -- Send functions to top level; see -- the comments with isFunction + | otherwise = maxFvLevel isId env fvs -- Max over Ids only; the tyvars -- will be abstracted @@ -997,9 +1002,9 @@ abstractVars :: Level -> LevelEnv -> VarSet -> [Var] -- whose level is greater than the destination level -- These are the ones we are going to abstract out abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs - = map zap $ uniq $ sortQuantVars -- IA0_NOTE: centralizing sorting on variables + = map zap $ uniq $ sortQuantVars [var | fv <- varSetElems fvs - , var <- absVarsOf id_env fv + , var <- varSetElems (absVarsOf id_env fv) , abstract_me var ] -- NB: it's important to call abstract_me only on the OutIds the -- come from absVarsOf (not on fv, which is an InId) @@ -1022,7 +1027,7 @@ abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs setIdInfo v vanillaIdInfo | otherwise = v -absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var] +absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> VarSet -- If f is free in the expression, and f maps to poly_f a b c in the -- current substitution, then we must report a b c as candidate type -- variables @@ -1030,20 +1035,16 @@ absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var] -- Also, if x::a is an abstracted variable, then so is a; that is, -- we must look in x's type. What's more, if a mentions kind variables, -- we must also return those. - -- - -- And similarly if x is a coercion variable. absVarsOf id_env v - | isId v = [av2 | av1 <- lookup_avs v - , av2 <- add_tyvars av1] - | otherwise = ASSERT( isTyVar v ) [v] + | isId v, Just (abs_vars, _) <- lookupVarEnv id_env v + = foldr (unionVarSet . close) emptyVarSet abs_vars + | otherwise + = close v where - lookup_avs v = case lookupVarEnv id_env v of - Just (abs_vars, _) -> abs_vars - Nothing -> [v] - - add_tyvars v = v : (varSetElems tyvars ++ varSetElems kivars) - tyvars = varTypeTyVars v - kivars = kiVarsOfKinds (map tyVarKind (varSetElems tyvars)) + close :: Var -> VarSet -- Result include the input variable itself + close v = foldVarSet (unionVarSet . close) + (unitVarSet v) + (varTypeTyVars v) \end{code} \begin{code} diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 03ffb479db..4c51b304a9 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -25,7 +25,7 @@ import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, import PprCore ( pprCoreBindings, pprCoreExpr ) import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo -import CoreUtils ( coreBindsSize, exprSize ) +import CoreUtils ( coreBindsSize, coreBindsStats, exprSize ) import Simplify ( simplTopBinds, simplExpr ) import SimplUtils ( simplEnvForGHCi, activeRule ) import SimplEnv @@ -47,6 +47,7 @@ import DmdAnal ( dmdAnalPgm ) import WorkWrap ( wwTopBinds ) import Vectorise ( vectorise ) import FastString +import SrcLoc import Util import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) @@ -327,9 +328,10 @@ loadPlugins hsc_env loadPlugin :: HscEnv -> ModuleName -> IO Plugin loadPlugin hsc_env mod_name = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin") + dflags = hsc_dflags hsc_env ; mb_name <- lookupRdrNameInModule hsc_env mod_name plugin_rdr_name ; case mb_name of { - Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep + Nothing -> throwGhcException (CmdLineError $ showSDoc dflags $ hsep [ ptext (sLit "The module"), ppr mod_name , ptext (sLit "did not export the plugin name") , ppr plugin_rdr_name ]) ; @@ -338,7 +340,7 @@ loadPlugin hsc_env mod_name do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) ; case mb_plugin of - Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep + Nothing -> throwGhcException (CmdLineError $ showSDoc dflags $ hsep [ ptext (sLit "The value"), ppr name , ptext (sLit "did not have the type") , ppr pluginTyConName, ptext (sLit "as required")]) @@ -362,54 +364,54 @@ runCorePasses passes guts do_pass guts pass = do { dflags <- getDynFlags ; liftIO $ showPass dflags pass - ; guts' <- doCorePass pass guts + ; guts' <- doCorePass dflags pass guts ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts') ; return guts' } -doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts -doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} - simplifyPgm pass +doCorePass :: DynFlags -> CoreToDo -> ModGuts -> CoreM ModGuts +doCorePass _ pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} + simplifyPgm pass -doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} - doPass cseProgram +doCorePass _ CoreCSE = {-# SCC "CommonSubExpr" #-} + doPass cseProgram -doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} - doPassD liberateCase +doCorePass _ CoreLiberateCase = {-# SCC "LiberateCase" #-} + doPassD liberateCase -doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} - doPass floatInwards +doCorePass _ CoreDoFloatInwards = {-# SCC "FloatInwards" #-} + doPass floatInwards -doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} - doPassDUM (floatOutwards f) +doCorePass _ (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} + doPassDUM (floatOutwards f) -doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} - doPassU doStaticArgs +doCorePass _ CoreDoStaticArgs = {-# SCC "StaticArgs" #-} + doPassU doStaticArgs -doCorePass CoreDoStrictness = {-# SCC "Stranal" #-} - doPassDM dmdAnalPgm +doCorePass _ CoreDoStrictness = {-# SCC "Stranal" #-} + doPassDM dmdAnalPgm -doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} - doPassU wwTopBinds +doCorePass dflags CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} + doPassU (wwTopBinds dflags) -doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} - specProgram +doCorePass dflags CoreDoSpecialising = {-# SCC "Specialise" #-} + specProgram dflags -doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} - specConstrProgram +doCorePass _ CoreDoSpecConstr = {-# SCC "SpecConstr" #-} + specConstrProgram -doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} - vectorise +doCorePass _ CoreDoVectorisation = {-# SCC "Vectorise" #-} + vectorise -doCorePass CoreDoPrintCore = observe printCore -doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat -doCorePass CoreDoNothing = return -doCorePass (CoreDoPasses passes) = runCorePasses passes +doCorePass _ CoreDoPrintCore = observe printCore +doCorePass _ (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat +doCorePass _ CoreDoNothing = return +doCorePass _ (CoreDoPasses passes) = runCorePasses passes #ifdef GHCI -doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass +doCorePass _ (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass #endif -doCorePass pass = pprPanic "doCorePass" (ppr pass) +doCorePass _ pass = pprPanic "doCorePass" (ppr pass) \end{code} %************************************************************************ @@ -419,15 +421,17 @@ doCorePass pass = pprPanic "doCorePass" (ppr pass) %************************************************************************ \begin{code} -printCore :: a -> CoreProgram -> IO () -printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds) +printCore :: DynFlags -> CoreProgram -> IO () +printCore dflags binds + = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds) ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts ruleCheckPass current_phase pat guts = do rb <- getRuleBase dflags <- getDynFlags liftIO $ Err.showPass dflags "RuleCheck" - liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts)) + liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + (ruleCheckProgram current_phase pat rb (mg_binds guts)) return guts @@ -492,8 +496,8 @@ simplifyExpr dflags expr (expr', counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $ simplExprGently (simplEnvForGHCi dflags) expr - ; Err.dumpIfSet (dopt Opt_D_dump_simpl_stats dflags) - "Simplifier statistics" (pprSimplCount counts) + ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags) + "Simplifier statistics" (pprSimplCount counts) ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" (pprCoreExpr expr') @@ -555,7 +559,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) = do { (termination_msg, it_count, counts_out, guts') <- do_iteration us 1 [] binds rules - ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags) + ; Err.dumpIfSet dflags (dump_phase && dopt Opt_D_dump_simpl_stats dflags) "Simplifier statistics for following pass" (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", blankLine, @@ -581,11 +585,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations = WARN( debugIsOn && (max_iterations > 2) - , ptext (sLit "Simplifier baling out after") <+> int max_iterations - <+> ptext (sLit "iterations") - <+> (brackets $ hsep $ punctuate comma $ - map (int . simplCountN) (reverse counts_so_far)) - <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) ) + , hang (ptext (sLit "Simplifier baling out after") <+> int max_iterations + <+> ptext (sLit "iterations") + <+> (brackets $ hsep $ punctuate comma $ + map (int . simplCountN) (reverse counts_so_far))) + 2 (ptext (sLit "Size =") <+> ppr (coreBindsStats binds))) -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 8661d71e04..d6ba24d754 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -63,6 +63,7 @@ import BasicTypes import MonadUtils import Outputable import FastString +import Util import Data.List \end{code} diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index e025e6cb34..3b18540e87 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -65,7 +65,8 @@ data SimplTopEnv \begin{code} initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv) -> UniqSupply -- No init count; set to 0 - -> Int -- Size of the bindings + -> Int -- Size of the bindings, used to limit + -- the number of ticks we allow -> SimplM a -> (a, SimplCount) diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index ad6fe5488b..87aefbab89 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -24,7 +24,8 @@ module SimplUtils ( -- The continuation type SimplCont(..), DupFlag(..), ArgInfo(..), isSimplified, - contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, + contIsDupable, contResultType, contInputType, + contIsTrivial, contArgs, dropArgs, pushSimplifiedArgs, countValArgs, countArgs, addArgTo, mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, interestingCallContext, @@ -38,12 +39,12 @@ module SimplUtils ( import SimplEnv import CoreMonad ( SimplifierMode(..), Tick(..) ) +import MkCore ( sortQuantVars ) import DynFlags import StaticFlags import CoreSyn import qualified CoreSubst import PprCore -import DataCon ( dataConCannotMatch, dataConWorkId ) import CoreFVs import CoreUtils import CoreArity @@ -54,8 +55,8 @@ import Var import Demand import SimplMonad import Type hiding( substTy ) -import Coercion hiding( substCo ) -import TyCon +import Coercion hiding( substCo, substTy ) +import DataCon ( dataConWorkId ) import VarSet import BasicTypes import Util @@ -64,7 +65,7 @@ import Outputable import FastString import Pair -import Data.List +import Control.Monad ( when ) \end{code} @@ -96,7 +97,8 @@ Key points: \begin{code} data SimplCont - = Stop -- An empty context, or hole, [] + = Stop -- An empty context, or <hole> + OutType -- Type of the <hole> CallCtxt -- True <=> There is something interesting about -- the context, and hence the inliner -- should be a bit keener (see interestingCallContext) @@ -104,41 +106,43 @@ data SimplCont -- This is an argument of a function that has RULES -- Inlining the call might allow the rule to fire - | CoerceIt -- C `cast` co + | CoerceIt -- <hole> `cast` co OutCoercion -- The coercion simplified -- Invariant: never an identity coercion SimplCont - | ApplyTo -- C arg + | ApplyTo -- <hole> arg DupFlag -- See Note [DupFlag invariants] InExpr StaticEnv -- The argument and its static env SimplCont - | Select -- case C of alts + | Select -- case <hole> of alts DupFlag -- See Note [DupFlag invariants] - InId [InAlt] StaticEnv -- The case binder, alts, and subst-env + InId [InAlt] StaticEnv -- The case binder, alts type, alts, and subst-env SimplCont -- The two strict forms have no DupFlag, because we never duplicate them - | StrictBind -- (\x* \xs. e) C - InId [InBndr] -- let x* = [] in e + | StrictBind -- (\x* \xs. e) <hole> + InId [InBndr] -- let x* = <hole> in e InExpr StaticEnv -- is a special case SimplCont - | StrictArg -- f e1 ..en C + | StrictArg -- f e1 ..en <hole> ArgInfo -- Specifies f, e1..en, Whether f has rules, etc -- plus strictness flags for *further* args CallCtxt -- Whether *this* argument position is interesting SimplCont | TickIt - (Tickish Id) -- Tick tickish [] + (Tickish Id) -- Tick tickish <hole> SimplCont data ArgInfo = ArgInfo { - ai_fun :: Id, -- The function + ai_fun :: OutId, -- The function ai_args :: [OutExpr], -- ...applied to these args (which are in *reverse* order) + ai_type :: OutType, -- Type of (f a1 ... an) + ai_rules :: [CoreRule], -- Rules for this function ai_encl :: Bool, -- Flag saying whether this function @@ -154,16 +158,17 @@ data ArgInfo } addArgTo :: ArgInfo -> OutExpr -> ArgInfo -addArgTo ai arg = ai { ai_args = arg : ai_args ai } +addArgTo ai arg = ai { ai_args = arg : ai_args ai + , ai_type = applyTypeToArg (ai_type ai) arg } instance Outputable SimplCont where - ppr (Stop interesting) = ptext (sLit "Stop") <> brackets (ppr interesting) + ppr (Stop ty interesting) = ptext (sLit "Stop") <> brackets (ppr interesting) <+> ppr ty ppr (ApplyTo dup arg _ cont) = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg) - {- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont + {- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont ppr (StrictBind b _ _ _ cont) = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont ppr (StrictArg ai _ cont) = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ - (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont + (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont ppr (CoerceIt co cont) = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont ppr (TickIt t cont) = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont @@ -193,14 +198,14 @@ the following invariants hold \begin{code} ------------------- -mkBoringStop :: SimplCont -mkBoringStop = Stop BoringCtxt +mkBoringStop :: OutType -> SimplCont +mkBoringStop ty = Stop ty BoringCtxt -mkRhsStop :: SimplCont -- See Note [RHS of lets] in CoreUnfold -mkRhsStop = Stop (ArgCtxt False) +mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in CoreUnfold +mkRhsStop ty = Stop ty (ArgCtxt False) -mkLazyArgStop :: CallCtxt -> SimplCont -mkLazyArgStop cci = Stop cci +mkLazyArgStop :: OutType -> CallCtxt -> SimplCont +mkLazyArgStop ty cci = Stop ty cci ------------------- contIsRhsOrArg :: SimplCont -> Bool @@ -226,28 +231,28 @@ contIsTrivial (CoerceIt _ cont) = contIsTrivial cont contIsTrivial _ = False ------------------- -contResultType :: SimplEnv -> OutType -> SimplCont -> OutType -contResultType env ty cont - = go cont ty - where - subst_ty se ty = SimplEnv.substTy (se `setInScope` env) ty - subst_co se co = SimplEnv.substCo (se `setInScope` env) co - - go (Stop {}) ty = ty - go (CoerceIt co cont) _ = go cont (pSnd (coercionKind co)) - go (StrictBind _ bs body se cont) _ = go cont (subst_ty se (exprType (mkLams bs body))) - go (StrictArg ai _ cont) _ = go cont (funResultTy (argInfoResultTy ai)) - go (Select _ _ alts se cont) _ = go cont (subst_ty se (coreAltsType alts)) - go (ApplyTo _ arg se cont) ty = go cont (apply_to_arg ty arg se) - go (TickIt _ cont) ty = go cont ty - - apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg) - apply_to_arg ty (Coercion co_arg) se = applyCo ty (subst_co se co_arg) - apply_to_arg ty _ _ = funResultTy ty - -argInfoResultTy :: ArgInfo -> OutType -argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args }) - = foldr (\arg fn_ty -> applyTypeToArg fn_ty arg) (idType fun) args +contResultType :: SimplCont -> OutType +contResultType (Stop ty _) = ty +contResultType (CoerceIt _ k) = contResultType k +contResultType (StrictBind _ _ _ _ k) = contResultType k +contResultType (StrictArg _ _ k) = contResultType k +contResultType (Select _ _ _ _ k) = contResultType k +contResultType (ApplyTo _ _ _ k) = contResultType k +contResultType (TickIt _ k) = contResultType k + +contInputType :: SimplCont -> OutType +contInputType (Stop ty _) = ty +contInputType (CoerceIt co _) = pFst (coercionKind co) +contInputType (Select d b _ se _) = perhapsSubstTy d se (idType b) +contInputType (StrictBind b _ _ se _) = substTy se (idType b) +contInputType (StrictArg ai _ _) = funArgTy (ai_type ai) +contInputType (ApplyTo d e se k) = mkFunTy (perhapsSubstTy d se (exprType e)) (contInputType k) +contInputType (TickIt _ k) = contInputType k + +perhapsSubstTy :: DupFlag -> SimplEnv -> InType -> OutType +perhapsSubstTy dup_flag se ty + | isSimplified dup_flag = ty + | otherwise = substTy se ty ------------------- countValArgs :: SimplCont -> Int @@ -343,7 +348,7 @@ interestingCallContext cont interesting (StrictArg _ cci _) = cci interesting (StrictBind {}) = BoringCtxt - interesting (Stop cci) = cci + interesting (Stop _ cci) = cci interesting (TickIt _ cci) = interesting cci interesting (CoerceIt _ cont) = interesting cont -- If this call is the arg of a strict function, the context @@ -371,16 +376,19 @@ mkArgInfo :: Id mkArgInfo fun rules n_val_args call_cont | n_val_args < idArity fun -- Note [Unsaturated functions] - = ArgInfo { ai_fun = fun, ai_args = [], ai_rules = rules - , ai_encl = False + = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty + , ai_rules = rules, ai_encl = False , ai_strs = vanilla_stricts , ai_discs = vanilla_discounts } | otherwise - = ArgInfo { ai_fun = fun, ai_args = [], ai_rules = rules + = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty + , ai_rules = rules , ai_encl = interestingArgContext rules call_cont - , ai_strs = add_type_str (idType fun) arg_stricts + , ai_strs = add_type_str fun_ty arg_stricts , ai_discs = arg_discounts } where + fun_ty = idType fun + vanilla_discounts, arg_discounts :: [Int] vanilla_discounts = repeat 0 arg_discounts = case idUnfolding fun of @@ -466,7 +474,7 @@ interestingArgContext rules call_cont go (StrictArg _ cci _) = interesting cci go (StrictBind {}) = False -- ?? go (CoerceIt _ c) = go c - go (Stop cci) = interesting cci + go (Stop _ cci) = interesting cci go (TickIt _ c) = go c interesting (ArgCtxt rules) = rules @@ -1171,9 +1179,11 @@ findArity dflags bndr rhs old_arity | cur_arity <= old_arity = cur_arity | new_arity == cur_arity = cur_arity | otherwise = ASSERT( new_arity < cur_arity ) +#ifdef DEBUG pprTrace "Exciting arity" (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity , ppr rhs]) +#endif go new_arity where new_arity = exprEtaExpandArity dflags cheap_app rhs @@ -1494,97 +1504,19 @@ of the inner case y, which give us nowhere to go! \begin{code} prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) -prepareAlts scrut case_bndr' alts - = do { let (alts_wo_default, maybe_deflt) = findDefault alts - alt_cons = [con | (con,_,_) <- alts_wo_default] - imposs_deflt_cons = nub (imposs_cons ++ alt_cons) - -- "imposs_deflt_cons" are handled - -- EITHER by the context, - -- OR by a non-DEFAULT branch in this case expression. - - ; default_alts <- prepareDefault case_bndr' mb_tc_app - imposs_deflt_cons maybe_deflt - - ; let trimmed_alts = filterOut impossible_alt alts_wo_default - merged_alts = mergeAlts trimmed_alts default_alts - -- We need the mergeAlts in case the new default_alt - -- has turned into a constructor alternative. - -- The merge keeps the inner DEFAULT at the front, if there is one - -- and interleaves the alternatives in the right order - - ; return (imposs_deflt_cons, merged_alts) } +-- The returned alternatives can be empty, none are possible +prepareAlts scrut case_bndr' alts = do + us <- getUniquesM + -- Case binder is needed just for its type. Note that as an + -- OutId, it has maximum information; this is important. + -- Test simpl013 is an example + let (imposs_deflt_cons, refined_deflt, alts') = filterAlts us (varType case_bndr') imposs_cons alts + when refined_deflt $ tick (FillInCaseDefault case_bndr') + return (imposs_deflt_cons, alts') where - mb_tc_app = splitTyConApp_maybe (idType case_bndr') - Just (_, inst_tys) = mb_tc_app - imposs_cons = case scrut of Var v -> otherCons (idUnfolding v) _ -> [] - - impossible_alt :: CoreAlt -> Bool - impossible_alt (con, _, _) | con `elem` imposs_cons = True - impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con - impossible_alt _ = False - - -prepareDefault :: OutId -- Case binder; need just for its type. Note that as an - -- OutId, it has maximum information; this is important. - -- Test simpl013 is an example - -> Maybe (TyCon, [Type]) -- Type of scrutinee, decomposed - -> [AltCon] -- These cons can't happen when matching the default - -> Maybe InExpr -- Rhs - -> SimplM [InAlt] -- Still unsimplified - -- We use a list because it's what mergeAlts expects, - ---------- Fill in known constructor ----------- -prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) - | -- This branch handles the case where we are - -- scrutinisng an algebraic data type - isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. - , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: - -- case x of { DEFAULT -> e } - -- and we don't want to fill in a default for them! - , Just all_cons <- tyConDataCons_maybe tycon - , not (null all_cons) - -- This is a tricky corner case. If the data type has no constructors, - -- which GHC allows, then the case expression will have at most a default - -- alternative. We don't want to eliminate that alternative, because the - -- invariant is that there's always one alternative. It's more convenient - -- to leave - -- case x of { DEFAULT -> e } - -- as it is, rather than transform it to - -- error "case cant match" - -- which would be quite legitmate. But it's a really obscure corner, and - -- not worth wasting code on. - , let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type - impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con - = case filterOut impossible all_cons of - [] -> return [] -- Eliminate the default alternative - -- altogether if it can't match - - [con] -> -- It matches exactly one constructor, so fill it in - do { tick (FillInCaseDefault case_bndr) - ; us <- getUniquesM - ; let (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys - ; return [(DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)] } - - _ -> return [(DEFAULT, [], deflt_rhs)] - - | debugIsOn, isAlgTyCon tycon - , null (tyConDataCons tycon) - , not (isFamilyTyCon tycon || isAbstractTyCon tycon) - -- Check for no data constructors - -- This can legitimately happen for abstract types and type families, - -- so don't report that - = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon) - $ return [(DEFAULT, [], deflt_rhs)] - ---------- Catch-all cases ----------- -prepareDefault _case_bndr _bndr_ty _imposs_cons (Just deflt_rhs) - = return [(DEFAULT, [], deflt_rhs)] - -prepareDefault _case_bndr _bndr_ty _imposs_cons Nothing - = return [] -- No default branch \end{code} @@ -1665,14 +1597,14 @@ and similarly in cascade for all the join points! mkCase, mkCase1, mkCase2 :: DynFlags -> OutExpr -> OutId - -> [OutAlt] -- Alternatives in standard (increasing) order + -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order -> SimplM OutExpr -------------------------------------------------- -- 1. Merge Nested Cases -------------------------------------------------- -mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts) +mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) | dopt Opt_CaseMerge dflags , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs , inner_scrut_var == outer_bndr @@ -1698,7 +1630,7 @@ mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts) -- When we merge, we must ensure that e1 takes -- precedence over e2 as the value for A! - ; mkCase1 dflags scrut outer_bndr merged_alts + ; mkCase1 dflags scrut outer_bndr alts_ty merged_alts } -- Warning: don't call mkCase recursively! -- Firstly, there's no point, because inner alts have already had @@ -1706,13 +1638,13 @@ mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts) -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr -- in munge_rhs may put a case into the DEFAULT branch! -mkCase dflags scrut bndr alts = mkCase1 dflags scrut bndr alts +mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts -------------------------------------------------- -- 2. Eliminate Identity Case -------------------------------------------------- -mkCase1 _dflags scrut case_bndr alts -- Identity case +mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case | all identity_alt alts = do { tick (CaseIdentity case_bndr) ; return (re_cast scrut rhs1) } @@ -1741,32 +1673,30 @@ mkCase1 _dflags scrut case_bndr alts -- Identity case -- -- Don't worry about nested casts, because the simplifier combines them - ((_,_,rhs1):_) = alts - re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co re_cast scrut _ = scrut -------------------------------------------------- -- 3. Merge Identical Alternatives -------------------------------------------------- -mkCase1 dflags scrut case_bndr ((_con1,bndrs1,rhs1) : con_alts) +mkCase1 dflags scrut case_bndr alts_ty ((_con1,bndrs1,rhs1) : con_alts) | all isDeadBinder bndrs1 -- Remember the default , length filtered_alts < length con_alts -- alternative comes first -- Also Note [Dead binders] = do { tick (AltMerge case_bndr) - ; mkCase2 dflags scrut case_bndr alts' } + ; mkCase2 dflags scrut case_bndr alts_ty alts' } where alts' = (DEFAULT, [], rhs1) : filtered_alts filtered_alts = filter keep con_alts keep (_con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1) -mkCase1 dflags scrut bndr alts = mkCase2 dflags scrut bndr alts +mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts -------------------------------------------------- -- Catch-all -------------------------------------------------- -mkCase2 _dflags scrut bndr alts - = return (Case scrut bndr (coreAltsType alts) alts) +mkCase2 _dflags scrut bndr alts_ty alts + = return (Case scrut bndr alts_ty alts) \end{code} Note [Dead binders] diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 900d70c7de..115dd94bd4 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -24,7 +24,7 @@ import FamInstEnv ( FamInstEnv ) import Literal ( litIsLifted ) import Id import MkId ( seqId, realWorldPrimId ) -import MkCore ( mkImpossibleExpr ) +import MkCore ( mkImpossibleExpr, castBottomExpr ) import IdInfo import Name ( mkSystemVarName, isExternalName ) import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst ) @@ -49,6 +49,7 @@ import Data.List ( mapAccumL ) import Outputable import FastString import Pair +import Util \end{code} @@ -339,11 +340,14 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se -- f = /\a. \x. g a x -- should eta-reduce + ; (body_env, tvs') <- simplBinders rhs_env tvs -- See Note [Floating and type abstraction] in SimplUtils -- Simplify the RHS - ; (body_env1, body1) <- simplExprF body_env body mkRhsStop + ; let body_out_ty :: OutType + body_out_ty = substTy body_env (exprType body) + ; (body_env1, body1) <- simplExprF body_env body (mkRhsStop body_out_ty) -- ANF-ise a constructor or PAP rhs ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1 @@ -727,7 +731,7 @@ simplUnfolding :: SimplEnv-> TopLevelFlag simplUnfolding env _ _ _ (DFunUnfolding ar con ops) = return (DFunUnfolding ar con ops') where - ops' = map (substExpr (text "simplUnfolding") env) ops + ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops simplUnfolding env top_lvl id _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity @@ -879,7 +883,10 @@ might do the same again. \begin{code} simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr -simplExpr env expr = simplExprC env expr mkBoringStop +simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty) + where + expr_out_ty :: OutType + expr_out_ty = substTy env (exprType expr) simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr -- Simplify an expression, given a continuation @@ -941,7 +948,7 @@ simplExprF1 env expr@(Lam {}) cont zap b | isTyVar b = b | otherwise = zapLamIdInfo b -simplExprF1 env (Case scrut bndr _ alts) cont +simplExprF1 env (Case scrut bndr alts_ty alts) cont | sm_case_case (getMode env) = -- Simplify the scrutinee with a Select continuation simplExprF env scrut (Select NoDup bndr alts env cont) @@ -949,9 +956,11 @@ simplExprF1 env (Case scrut bndr _ alts) cont | otherwise = -- If case-of-case is off, simply simplify the case expression -- in a vanilla Stop context, and rebuild the result around it - do { case_expr' <- simplExprC env scrut - (Select NoDup bndr alts env mkBoringStop) + do { case_expr' <- simplExprC env scrut + (Select NoDup bndr alts env (mkBoringStop alts_out_ty)) ; rebuild env case_expr' cont } + where + alts_out_ty = substTy env alts_ty simplExprF1 env (Let (Rec pairs) body) cont = do { env' <- simplRecBndrs env (map fst pairs) @@ -1035,7 +1044,7 @@ simplTick env tickish expr cont where interesting_cont = case cont of - Select _ _ _ _ _ -> True + Select {} -> True _ -> False push_tick_inside t expr0 @@ -1105,7 +1114,7 @@ simplTick env tickish expr cont where (inc,outc) = splitCont c splitCont (CoerceIt co c) = (CoerceIt co inc, outc) where (inc,outc) = splitCont c - splitCont other = (mkBoringStop, other) + splitCont other = (mkBoringStop (contInputType other), other) getDoneId (DoneId id) = id getDoneId (DoneEx e) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst @@ -1157,18 +1166,18 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -- only the in-scope set and floats should matter rebuild env expr cont = case cont of - Stop {} -> return (env, expr) - CoerceIt co cont -> rebuild env (mkCast expr co) cont - -- NB: mkCast implements the (Coercion co |> g) optimisation - Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont - StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont - StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr - ; simplLam env' bs body cont } - ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification] - | isSimplified dup_flag -> rebuild env (App expr arg) cont - | otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg - ; rebuild env (App expr arg') cont } - TickIt t cont -> rebuild env (mkTick t expr) cont + Stop {} -> return (env, expr) + CoerceIt co cont -> rebuild env (mkCast expr co) cont + -- NB: mkCast implements the (Coercion co |> g) optimisation + Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont + StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont + StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr + ; simplLam env' bs body cont } + ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification] + | isSimplified dup_flag -> rebuild env (App expr arg) cont + | otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg + ; rebuild env (App expr arg') cont } + TickIt t cont -> rebuild env (mkTick t expr) cont \end{code} @@ -1380,7 +1389,7 @@ simplIdF env var cont --------------------------------------------------------- -- Dealing with a call site -completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) +completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplEnv, OutExpr) completeCall env var cont = do { ------------- Try inlining ---------------- dflags <- getDynFlags @@ -1413,10 +1422,10 @@ completeCall env var cont | not (dopt Opt_D_dump_inlinings dflags) = stuff | not (dopt Opt_D_verbose_core2core dflags) = if isExternalName (idName var) then - pprDefiniteTrace "Inlining done:" (ppr var) stuff + pprDefiniteTrace dflags "Inlining done:" (ppr var) stuff else stuff | otherwise - = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var)) + = pprDefiniteTrace dflags ("Inlining done: " ++ showSDocDump dflags (ppr var)) (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont]) stuff @@ -1437,21 +1446,17 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con -- the continuation, leaving just the bottoming expression. But the -- type might not be right, so we may have to add a coerce. | not (contIsTrivial cont) -- Only do this if there is a non-trivial - = return (env, mk_coerce res) -- contination to discard, else we do it - where -- again and again! + = return (env, castBottomExpr res cont_ty) -- contination to discard, else we do it + where -- again and again! res = mkApps (Var fun) (reverse rev_args) - res_ty = exprType res - cont_ty = contResultType env res_ty cont - co = mkUnsafeCo res_ty cont_ty - mk_coerce expr | cont_ty `eqType` res_ty = expr - | otherwise = mkCast expr co + cont_ty = contResultType cont rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont) = do { arg_ty' <- if isSimplified dup_flag then return arg_ty else simplType (se `setInScope` env) arg_ty ; rebuildCall env (info `addArgTo` Type arg_ty') cont } -rebuildCall env info@(ArgInfo { ai_encl = encl_rules +rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty , ai_strs = str:strs, ai_discs = disc:discs }) (ApplyTo dup_flag arg arg_se cont) | isSimplified dup_flag -- See Note [Avoid redundant simplification] @@ -1469,7 +1474,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules -- have to be very careful about bogus strictness through -- floating a demanded let. = do { arg' <- simplExprC (arg_se `setInScope` env) arg - (mkLazyArgStop cci) + (mkLazyArgStop (funArgTy fun_ty) cci) ; rebuildCall env (addArgTo info' arg') cont } where info' = info { ai_strs = strs, ai_discs = discs } @@ -1568,10 +1573,10 @@ tryRules env rules fn args call_cont , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff | not (dopt Opt_D_dump_rule_rewrites dflags) - = pprDefiniteTrace "Rule fired:" (ftext (ru_name rule)) stuff + = pprDefiniteTrace dflags "Rule fired:" (ftext (ru_name rule)) stuff | otherwise - = pprDefiniteTrace "Rule fired" + = pprDefiniteTrace dflags "Rule fired" (vcat [text "Rule:" <+> ftext (ru_name rule), text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)), text "After: " <+> pprCoreExpr rule_rhs, @@ -1668,6 +1673,22 @@ not want to transform to in blah because that builds an unnecessary thunk. +Note [Case elimination: unlifted case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case a +# b of r -> ...r... +Then we do case-elimination (to make a let) followed by inlining, +to get + .....(a +# b).... +If we have + case indexArray# a i of r -> ...r... +we might like to do the same, and inline the (indexArray# a i). +But indexArray# is not okForSpeculation, so we don't build a let +in rebuildCase (lest it get floated *out*), so the inlining doesn't +happen either. + +This really isn't a big deal I think. The let can be + Further notes about case elimination ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1788,6 +1809,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont | otherwise = exprOkForSpeculation scrut -- The case-binder is alive, but we may be able -- turn the case into a let, if the expression is ok-for-spec + -- See Note [Case elimination: unlifted case] ok_for_spec = exprOkForSpeculation scrut is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect @@ -1832,16 +1854,14 @@ reallyRebuildCase env scrut case_bndr alts cont -- Simplify the alternatives ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont - -- Check for empty alternatives - ; if null alts' then missingAlt env case_bndr alts cont - else do - { dflags <- getDynFlags - ; case_expr <- mkCase dflags scrut' case_bndr' alts' + ; dflags <- getDynFlags + ; let alts_ty' = contResultType dup_cont + ; case_expr <- mkCase dflags scrut' case_bndr' alts_ty' alts' -- Notice that rebuild gets the in-scope set from env', not alt_env -- (which in any case is only build in simplAlts) -- The case binder *not* scope over the whole returned case-expression - ; rebuild env' case_expr nodup_cont } } + ; rebuild env' case_expr nodup_cont } \end{code} simplCaseBinder checks whether the scrutinee is a variable, v. If so, @@ -1929,10 +1949,10 @@ simplAlts :: SimplEnv -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation -- Like simplExpr, this just returns the simplified alternatives; -- it does not return an environment +-- The returned alternatives can be empty, none are possible simplAlts env scrut case_bndr alts cont' - = -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $ - do { let env0 = zapFloats env + = do { let env0 = zapFloats env ; (env1, case_bndr1) <- simplBinder env0 case_bndr @@ -1941,11 +1961,14 @@ simplAlts env scrut case_bndr alts cont' case_bndr case_bndr1 alts ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts + -- NB: it's possible that the returned in_alts is empty: this is handled + -- by the caller (rebuildCase) in the missingAlt function ; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing } ; alts' <- mapM (simplAlt alt_env' mb_var_scrut imposs_deflt_cons case_bndr' cont') in_alts - ; return (scrut', case_bndr', alts') } + ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $ + return (scrut', case_bndr', alts') } ------------------------------------ @@ -2162,11 +2185,9 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExp -- an inner case has no accessible alternatives before -- it "sees" that the entire branch of an outer case is -- inaccessible. So we simply put an error case here instead. -missingAlt env case_bndr alts cont +missingAlt env case_bndr _ cont = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr ) - return (env, mkImpossibleExpr res_ty) - where - res_ty = contResultType env (substTy env (coreAltsType alts)) cont + return (env, mkImpossibleExpr (contResultType cont)) \end{code} @@ -2194,7 +2215,7 @@ prepareCaseCont :: SimplEnv prepareCaseCont env alts cont | many_alts alts = mkDupableCont env cont - | otherwise = return (env, cont, mkBoringStop) + | otherwise = return (env, cont, mkBoringStop (contResultType cont)) where many_alts :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative many_alts [] = False -- See Note [Bottom alternatives] @@ -2223,7 +2244,7 @@ mkDupableCont :: SimplEnv -> SimplCont mkDupableCont env cont | contIsDupable cont - = return (env, cont, mkBoringStop) + = return (env, cont, mkBoringStop (contResultType cont)) mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn @@ -2233,10 +2254,10 @@ mkDupableCont env (CoerceIt ty cont) -- Duplicating ticks for now, not sure if this is good or not mkDupableCont env cont@(TickIt{}) - = return (env, mkBoringStop, cont) + = return (env, mkBoringStop (contInputType cont), cont) mkDupableCont env cont@(StrictBind {}) - = return (env, mkBoringStop, cont) + = return (env, mkBoringStop (contInputType cont), cont) -- See Note [Duplicating StrictBind] mkDupableCont env (StrictArg info cci cont) @@ -2263,7 +2284,7 @@ mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _) | all isDeadBinder bs -- InIds && not (isUnLiftedType (idType case_bndr)) -- Note [Single-alternative-unlifted] - = return (env, mkBoringStop, cont) + = return (env, mkBoringStop (contInputType cont), cont) mkDupableCont env (Select _ case_bndr alts se cont) = -- e.g. (case [...hole...] of { pi -> ei }) @@ -2280,6 +2301,7 @@ mkDupableCont env (Select _ case_bndr alts se cont) -- And this is important: see Note [Fusing case continuations] ; let alt_env = se `setInScope` env' + ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts -- Safe to say that there are no handled-cons for the DEFAULT case @@ -2296,7 +2318,8 @@ mkDupableCont env (Select _ case_bndr alts se cont) ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts' ; return (env'', -- Note [Duplicated env] - Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop, + Select OkToDup case_bndr' alts'' (zapSubstEnv env'') + (mkBoringStop (contInputType nodup_cont)), nodup_cont) } diff --git a/compiler/simplStg/SRT.lhs b/compiler/simplStg/SRT.lhs index bd2fb5e211..0d474c5b63 100644 --- a/compiler/simplStg/SRT.lhs +++ b/compiler/simplStg/SRT.lhs @@ -20,7 +20,7 @@ import Bitmap import Outputable -import Util +import Data.List \end{code} \begin{code} @@ -148,7 +148,7 @@ constructSRT table (SRTEntries entries) where ints = map (expectJust "constructSRT" . lookupVarEnv table) (varSetElems entries) - sorted_ints = sortLe (<=) ints + sorted_ints = sort ints offset = head sorted_ints bitmap_entries = map (subtract offset) sorted_ints len = last bitmap_entries + 1 diff --git a/compiler/simplStg/SimplStg.lhs b/compiler/simplStg/SimplStg.lhs index b5b55fc291..635df3ce41 100644 --- a/compiler/simplStg/SimplStg.lhs +++ b/compiler/simplStg/SimplStg.lhs @@ -21,13 +21,15 @@ import CostCentre ( CollectedCCs ) import SCCfinal ( stgMassageForProfiling ) import StgLint ( lintStgBindings ) import StgStats ( showStgStats ) +import UnariseStg ( unarise ) import SRT ( computeSRTs ) import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..), getStgToDo ) import Id ( Id ) import Module ( Module ) -import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn, showPass ) +import ErrUtils +import SrcLoc import UniqSupply ( mkSplitUniqSupply, splitUniqSupply ) import Outputable \end{code} @@ -44,17 +46,19 @@ stg2stg dflags module_name binds ; us <- mkSplitUniqSupply 'g' ; doIfSet_dyn dflags Opt_D_verbose_stg2stg - (printDump (text "VERBOSE STG-TO-STG:")) + (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:")) ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds -- Do the main business! + ; let (us0, us1) = splitUniqSupply us' ; (processed_binds, _, cost_centres) - <- foldl_mn do_stg_pass (binds', us', ccs) (getStgToDo dflags) + <- foldl_mn do_stg_pass (binds', us0, ccs) (getStgToDo dflags) + ; let un_binds = unarise us1 processed_binds ; let srt_binds - | dopt Opt_TryNewCodeGen dflags = zip processed_binds (repeat []) - | otherwise = computeSRTs processed_binds + | dopt Opt_TryNewCodeGen dflags = zip un_binds (repeat []) + | otherwise = computeSRTs un_binds ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (pprStgBindingsWithSRTs srt_binds) diff --git a/compiler/simplStg/UnariseStg.lhs b/compiler/simplStg/UnariseStg.lhs new file mode 100644 index 0000000000..ac439ebfd3 --- /dev/null +++ b/compiler/simplStg/UnariseStg.lhs @@ -0,0 +1,167 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-2012 +% + +Note [Unarisation] +~~~~~~~~~~~~~~~~~~ + +The idea of this pass is to translate away *all* unboxed-tuple binders. So for example: + +f (x :: (# Int, Bool #)) = f x + f (# 1, True #) + ==> +f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True + +It is important that we do this at the STG level and NOT at the core level +because it would be very hard to make this pass Core-type-preserving. + +STG fed to the code generators *must* be unarised because the code generators do +not support unboxed tuple binders natively. + + +Note [Unarisation and arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Because of unarisation, the arity that will be recorded in the generated info table +for an Id may be larger than the idArity. Instead we record what we call the RepArity, +which is the Arity taking into account any expanded arguments, and corresponds to +the number of (possibly-void) *registers* arguments will arrive in. + +\begin{code} +module UnariseStg (unarise) where + +#include "HsVersions.h" + +import CoreSyn +import StgSyn +import VarEnv +import UniqSupply +import Id +import MkId (realWorldPrimId) +import Type +import TysWiredIn +import DataCon +import VarSet +import OccName +import Name +import Util +import Outputable +import BasicTypes + + +-- | A mapping from unboxed-tuple binders to the Ids they were expanded to. +-- +-- INVARIANT: Ids in the range don't have unboxed tuple types. +-- +-- Those in-scope variables without unboxed-tuple types are not present in +-- the domain of the mapping at all. +type UnariseEnv = VarEnv [Id] + +ubxTupleId0 :: Id +ubxTupleId0 = dataConWorkId (tupleCon UnboxedTuple 0) + +unarise :: UniqSupply -> [StgBinding] -> [StgBinding] +unarise us binds = zipWith (\us -> unariseBinding us init_env) (listSplitUniqSupply us) binds + where -- See Note [Nullary unboxed tuple] in Type.lhs + init_env = unitVarEnv ubxTupleId0 [realWorldPrimId] + +unariseBinding :: UniqSupply -> UnariseEnv -> StgBinding -> StgBinding +unariseBinding us rho bind = case bind of + StgNonRec x rhs -> StgNonRec x (unariseRhs us rho rhs) + StgRec xrhss -> StgRec $ zipWith (\us (x, rhs) -> (x, unariseRhs us rho rhs)) (listSplitUniqSupply us) xrhss + +unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs +unariseRhs us rho rhs = case rhs of + StgRhsClosure ccs b_info fvs update_flag srt args expr + -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag (unariseSRT rho srt) args' (unariseExpr us' rho' expr) + where (us', rho', args') = unariseIdBinders us rho args + StgRhsCon ccs con args + -> StgRhsCon ccs con (unariseArgs rho args) + +unariseExpr :: UniqSupply -> UnariseEnv -> StgExpr -> StgExpr +unariseExpr us rho e = case e of + -- Particularly important where (##) is concerned (Note [The nullary (# #) constructor]) + StgApp f [] | UbxTupleRep tys <- repType (idType f) + -> StgConApp (tupleCon UnboxedTuple (length tys)) (map StgVarArg (unariseId rho f)) + StgApp f args -> StgApp f (unariseArgs rho args) + StgLit l -> StgLit l + StgConApp dc args | isUnboxedTupleCon dc -> StgConApp (tupleCon UnboxedTuple (length args')) args' + | otherwise -> StgConApp dc args' + where args' = unariseArgs rho args + StgOpApp op args ty -> StgOpApp op (unariseArgs rho args) ty + StgLam xs e -> StgLam xs' (unariseExpr us' rho' e) + where (us', rho', xs') = unariseIdBinders us rho xs + StgCase e case_lives alts_lives bndr srt alt_ty alts + -> StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives) (unariseLives rho alts_lives) bndr (unariseSRT rho srt) alt_ty' alts' + where (us1, us2) = splitUniqSupply us + (alt_ty', alts') = case repType (idType bndr) of + UbxTupleRep tys -> case alts of + (DEFAULT, [], [], e):_ -> (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys, uses, unariseExpr us2' rho' e)]) + where (us2', rho', ys) = unariseIdBinder us2 rho bndr + uses = replicate (length ys) (not (isDeadBinder bndr)) + n = length tys + [(DataAlt _, ys, uses, e)] -> (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys', uses', unariseExpr us2' rho'' e)]) + where (us2', rho', ys', uses') = unariseUsedIdBinders us2 rho ys uses + rho'' = extendVarEnv rho' bndr ys' + n = length ys' + _ -> panic "unariseExpr: strange unboxed tuple alts" + UnaryRep _ -> (alt_ty, zipWith (\us alt -> unariseAlt us rho alt) (listSplitUniqSupply us2) alts) + StgLet bind e -> StgLet (unariseBinding us1 rho bind) (unariseExpr us2 rho e) + where (us1, us2) = splitUniqSupply us + StgLetNoEscape live_in_let live_in_bind bind e + -> StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind) (unariseBinding us1 rho bind) (unariseExpr us2 rho e) + where (us1, us2) = splitUniqSupply us + StgSCC cc bump_entry push_cc e -> StgSCC cc bump_entry push_cc (unariseExpr us rho e) + StgTick mod tick_n e -> StgTick mod tick_n (unariseExpr us rho e) + +unariseAlt :: UniqSupply -> UnariseEnv -> StgAlt -> StgAlt +unariseAlt us rho (con, xs, uses, e) = (con, xs', uses', unariseExpr us' rho' e) + where (us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses + +unariseSRT :: UnariseEnv -> SRT -> SRT +unariseSRT _ NoSRT = NoSRT +unariseSRT rho (SRTEntries ids) = SRTEntries (concatMapVarSet (unariseId rho) ids) +unariseSRT _ (SRT {}) = panic "unariseSRT" + +unariseLives :: UnariseEnv -> StgLiveVars -> StgLiveVars +unariseLives rho ids = concatMapVarSet (unariseId rho) ids + +unariseArgs :: UnariseEnv -> [StgArg] -> [StgArg] +unariseArgs rho = concatMap (unariseArg rho) + +unariseArg :: UnariseEnv -> StgArg -> [StgArg] +unariseArg rho (StgVarArg x) = map StgVarArg (unariseId rho x) +unariseArg _ (StgLitArg l) = [StgLitArg l] + +unariseIds :: UnariseEnv -> [Id] -> [Id] +unariseIds rho = concatMap (unariseId rho) + +unariseId :: UnariseEnv -> Id -> [Id] +unariseId rho x = case lookupVarEnv rho x of + Just ys -> ASSERT2(case repType (idType x) of UbxTupleRep _ -> True; _ -> x == ubxTupleId0, text "unariseId: not unboxed tuple" <+> ppr x) + ys + Nothing -> ASSERT2(case repType (idType x) of UbxTupleRep _ -> False; _ -> True, text "unariseId: was unboxed tuple" <+> ppr x) + [x] + +unariseUsedIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> [Bool] -> (UniqSupply, UnariseEnv, [Id], [Bool]) +unariseUsedIdBinders us rho xs uses = case mapAccumL2 (\us rho (x, use) -> third3 (map (flip (,) use)) $ unariseIdBinder us rho x) + us rho (zipEqual "unariseUsedIdBinders" xs uses) of + (us', rho', xs_usess) -> uncurry ((,,,) us' rho') (unzip (concat xs_usess)) + +unariseIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> (UniqSupply, UnariseEnv, [Id]) +unariseIdBinders us rho xs = third3 concat $ mapAccumL2 unariseIdBinder us rho xs + +unariseIdBinder :: UniqSupply -> UnariseEnv -> Id -> (UniqSupply, UnariseEnv, [Id]) +unariseIdBinder us rho x = case repType (idType x) of + UnaryRep _ -> (us, rho, [x]) + UbxTupleRep tys -> let (us0, us1) = splitUniqSupply us + ys = unboxedTupleBindersFrom us0 x tys + rho' = extendVarEnv rho x ys + in (us1, rho', ys) + +unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id] +unboxedTupleBindersFrom us x tys = zipWith (mkSysLocal fs) (uniqsFromSupply us) tys + where fs = occNameFS (getOccName x) + +concatMapVarSet :: (Var -> [Var]) -> VarSet -> VarSet +concatMapVarSet f xs = mkVarSet [x' | x <- varSetElems xs, x' <- f x] +\end{code}
\ No newline at end of file diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 8e55be48fd..498302a5e9 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -4,74 +4,68 @@ \section[CoreRules]{Transformation rules} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Functions for collecting together and applying rewrite rules to a module. -- The 'CoreRule' datatype itself is declared elsewhere. module Rules ( - -- * RuleBase - RuleBase, - - -- ** Constructing - emptyRuleBase, mkRuleBase, extendRuleBaseList, - unionRuleBase, pprRuleBase, - - -- ** Checking rule applications - ruleCheckProgram, + -- * RuleBase + RuleBase, + + -- ** Constructing + emptyRuleBase, mkRuleBase, extendRuleBaseList, + unionRuleBase, pprRuleBase, + + -- ** Checking rule applications + ruleCheckProgram, -- ** Manipulating 'SpecInfo' rules - mkSpecInfo, extendSpecInfo, addSpecInfo, - addIdSpecialisations, - - -- * Misc. CoreRule helpers - rulesOfBinds, getRules, pprRulesForUser, - + mkSpecInfo, extendSpecInfo, addSpecInfo, + addIdSpecialisations, + + -- * Misc. CoreRule helpers + rulesOfBinds, getRules, pprRulesForUser, + lookupRule, mkRule, roughTopNames ) where #include "HsVersions.h" -import CoreSyn -- All of it +import CoreSyn -- All of it import CoreSubst import OccurAnal ( occurAnalyseExpr ) -import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars ) +import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars ) import CoreUtils ( exprType, eqExpr ) -import PprCore ( pprRules ) +import PprCore ( pprRules ) import Type ( Type ) -import TcType ( tcSplitTyConApp_maybe ) +import TcType ( tcSplitTyConApp_maybe ) import Coercion -import CoreTidy ( tidyRules ) +import CoreTidy ( tidyRules ) import Id -import IdInfo ( SpecInfo( SpecInfo ) ) +import IdInfo ( SpecInfo( SpecInfo ) ) import VarEnv import VarSet -import Name ( Name, NamedThing(..) ) +import Name ( Name, NamedThing(..) ) import NameEnv -import Unify ( ruleMatchTyX, MatchEnv(..) ) -import BasicTypes ( Activation, CompilerPhase, isActive ) -import StaticFlags ( opt_PprStyle_Debug ) +import Unify ( ruleMatchTyX, MatchEnv(..) ) +import BasicTypes ( Activation, CompilerPhase, isActive ) +import StaticFlags ( opt_PprStyle_Debug ) import Outputable import FastString import Maybes import Bag import Util import Data.List +import Data.Ord \end{code} Note [Overall plumbing for rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * After the desugarer: - The ModGuts initially contains mg_rules :: [CoreRule] of - locally-declared rules for imported Ids. + locally-declared rules for imported Ids. - Locally-declared rules for locally-declared Ids are attached to the IdInfo for that Id. See Note [Attach rules to local ids] in DsBinds - + * TidyPgm strips off all the rules from local Ids and adds them to mg_rules, so that the ModGuts has *all* the locally-declared rules. @@ -87,7 +81,7 @@ Note [Overall plumbing for rules] ghc --make compiles one module after another. During simplification, interface files may get demand-loaded, - as the simplifier explores the unfoldings for Ids it has in + as the simplifier explores the unfoldings for Ids it has in its hand. (Via an unsafePerformIO; the EPS is really a cache.) That in turn may make the EPS rule-base grow. In contrast, the HPT never grows in this way. @@ -119,8 +113,8 @@ Note [Overall plumbing for rules] pacakges, but we don't. Same for type-class instances.] * So in the outer simplifier loop, we combine (b-d) into a single - RuleBase, reading - (b) from the ModGuts, + RuleBase, reading + (b) from the ModGuts, (c) from the CoreMonad, and (d) from its mutable variable [Of coures this means that we won't see new EPS rules that come in @@ -129,9 +123,9 @@ Note [Overall plumbing for rules] %************************************************************************ -%* * +%* * \subsection[specialisation-IdInfo]{Specialisation info about an @Id@} -%* * +%* * %************************************************************************ A @CoreRule@ holds details of one rule for an @Id@, which @@ -139,12 +133,12 @@ includes its specialisations. For example, if a rule for @f@ contains the mapping: \begin{verbatim} - forall a b d. [Type (List a), Type b, Var d] ===> f' a b + forall a b d. [Type (List a), Type b, Var d] ===> f' a b \end{verbatim} then when we find an application of f to matching types, we simply replace it by the matching RHS: \begin{verbatim} - f (List Int) Bool dict ===> f' Int Bool + f (List Int) Bool dict ===> f' Int Bool \end{verbatim} All the stuff about how many dictionaries to discard, and what types to apply the specialised function to, are handled by the fact that the @@ -154,29 +148,29 @@ There is one more exciting case, which is dealt with in exactly the same way. If the specialised value is unboxed then it is lifted at its definition site and unlifted at its uses. For example: - pi :: forall a. Num a => a + pi :: forall a. Num a => a might have a specialisation - [Int#] ===> (case pi' of Lift pi# -> pi#) + [Int#] ===> (case pi' of Lift pi# -> pi#) where pi' :: Lift Int# is the specialised version of pi. \begin{code} -mkRule :: Bool -> Bool -> RuleName -> Activation +mkRule :: Bool -> Bool -> RuleName -> Activation -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule --- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'CoreSyn.CoreRule' mkRule is_auto is_local name act fn bndrs args rhs = Rule { ru_name = name, ru_fn = fn, ru_act = act, - ru_bndrs = bndrs, ru_args = args, - ru_rhs = occurAnalyseExpr rhs, - ru_rough = roughTopNames args, - ru_auto = is_auto, ru_local = is_local } + ru_bndrs = bndrs, ru_args = args, + ru_rhs = occurAnalyseExpr rhs, + ru_rough = roughTopNames args, + ru_auto = is_auto, ru_local = is_local } -------------- roughTopNames :: [CoreExpr] -> [Maybe Name] --- ^ Find the \"top\" free names of several expressions. +-- ^ Find the \"top\" free names of several expressions. -- Such names are either: -- -- 1. The function finally being applied to in an application chain @@ -184,37 +178,37 @@ roughTopNames :: [CoreExpr] -> [Maybe Name] -- -- 2. The 'TyCon' if the expression is a 'Type' -- --- This is used for the fast-match-check for rules; --- if the top names don't match, the rest can't +-- This is used for the fast-match-check for rules; +-- if the top names don't match, the rest can't roughTopNames args = map roughTopName args roughTopName :: CoreExpr -> Maybe Name roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of Just (tc,_) -> Just (getName tc) Nothing -> Nothing -roughTopName (Coercion _) = Nothing +roughTopName (Coercion _) = Nothing roughTopName (App f _) = roughTopName f -roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] +roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] , isDataConWorkId f || idArity f > 0 = Just (idName f) roughTopName _ = Nothing ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool -- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ --- definitely can't match @tpl@ by instantiating @tpl@. --- It's only a one-way match; unlike instance matching we +-- definitely can't match @tpl@ by instantiating @tpl@. +-- It's only a one-way match; unlike instance matching we -- don't consider unification. --- +-- -- Notice that [_$_] --- @ruleCantMatch [Nothing] [Just n2] = False@ +-- @ruleCantMatch [Nothing] [Just n2] = False@ -- Reason: a template variable can be instantiated by a constant -- Also: --- @ruleCantMatch [Just n1] [Nothing] = False@ +-- @ruleCantMatch [Just n1] [Nothing] = False@ -- Reason: a local variable @v@ in the actuals might [_$_] ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as -ruleCantMatch _ _ = False +ruleCantMatch _ _ = False \end{code} Note [Care with roughTopName] @@ -223,19 +217,19 @@ Consider this module M where { x = a:b } module N where { ...f x... RULE f (p:q) = ... } -You'd expect the rule to match, because the matcher can +You'd expect the rule to match, because the matcher can look through the unfolding of 'x'. So we must avoid roughTopName returning 'M.x' for the call (f x), or else it'll say "can't match" and we won't even try!! However, suppose we have - RULE g (M.h x) = ... - foo = ...(g (M.k v)).... + RULE g (M.h x) = ... + foo = ...(g (M.k v)).... where k is a *function* exported by M. We never really match functions (lambdas) except by name, so in this case it seems like a good idea to treat 'M.k' as a roughTopName of the call. - + \begin{code} pprRulesForUser :: [CoreRule] -> SDoc -- (a) tidy the rules @@ -246,17 +240,15 @@ pprRulesForUser :: [CoreRule] -> SDoc pprRulesForUser rules = withPprStyle defaultUserStyle $ pprRules $ - sortLe le_rule $ + sortBy (comparing ru_name) $ tidyRules emptyTidyEnv rules - where - le_rule r1 r2 = ru_name r1 <= ru_name r2 \end{code} %************************************************************************ -%* * - SpecInfo: the rules in an IdInfo -%* * +%* * + SpecInfo: the rules in an IdInfo +%* * %************************************************************************ \begin{code} @@ -270,7 +262,7 @@ extendSpecInfo (SpecInfo rs1 fvs1) rs2 = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1) addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo -addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) +addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2) addIdSpecialisations :: Id -> [CoreRule] -> Id @@ -298,7 +290,7 @@ The rules for an Id come from two places: (a) the ones it is born with, stored inside the Id iself (idCoreRules fn), (b) rules added in other modules, stored in the global RuleBase (imp_rules) -It's tempting to think that +It's tempting to think that - LocalIds have only (a) - non-LocalIds have only (b) @@ -308,21 +300,21 @@ but that isn't quite right: even when they are imported - The rules in PrelRules.builtinRules should be active even - in the module defining the Id (when it's a LocalId), but + in the module defining the Id (when it's a LocalId), but the rules are kept in the global RuleBase %************************************************************************ -%* * - RuleBase -%* * +%* * + RuleBase +%* * %************************************************************************ \begin{code} -- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules type RuleBase = NameEnv [CoreRule] - -- The rules are are unordered; - -- we sort out any overlaps on lookup + -- The rules are are unordered; + -- we sort out any overlaps on lookup emptyRuleBase :: RuleBase emptyRuleBase = emptyNameEnv @@ -342,15 +334,15 @@ extendRuleBase rule_base rule = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule pprRuleBase :: RuleBase -> SDoc -pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) - | rs <- nameEnvElts rules ] +pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- nameEnvElts rules ] \end{code} %************************************************************************ -%* * - Matching -%* * +%* * + Matching +%* * %************************************************************************ \begin{code} @@ -358,35 +350,35 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) -- supplied rules to this instance of an application in a given -- context, returning the rule applied and the resulting expression if -- successful. -lookupRule :: (Activation -> Bool) -- When rule is active - -> IdUnfoldingFun -- When Id can be unfolded +lookupRule :: (Activation -> Bool) -- When rule is active + -> IdUnfoldingFun -- When Id can be unfolded -> InScopeSet - -> Id -> [CoreExpr] - -> [CoreRule] -> Maybe (CoreRule, CoreExpr) + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -- See Note [Extra args in rule matching] -- See comments on matchRule lookupRule is_active id_unf in_scope fn args rules = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ case go [] rules of - [] -> Nothing - (m:ms) -> Just (findBest (fn,args) m ms) + [] -> Nothing + (m:ms) -> Just (findBest (fn,args) m ms) where rough_args = map roughTopName args go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] - go ms [] = ms - go ms (r:rs) = case (matchRule is_active id_unf in_scope args rough_args r) of - Just e -> go ((r,e):ms) rs - Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ - -- ppr [ (arg_id, unfoldingTemplate unf) + go ms [] = ms + go ms (r:rs) = case (matchRule fn is_active id_unf in_scope args rough_args r) of + Just e -> go ((r,e):ms) rs + Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ + -- ppr [ (arg_id, unfoldingTemplate unf) -- | Var arg_id <- args -- , let unf = idUnfolding arg_id -- , isCheapUnfolding unf] ) - go ms rs + go ms rs findBest :: (Id, [CoreExpr]) - -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) + -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) -- All these pairs matched the expression -- Return the pair the the most specific rule -- The (fn,args) is just for overlap reporting @@ -396,15 +388,15 @@ findBest target (rule1,ans1) ((rule2,ans2):prs) | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs | debugIsOn = let pp_rule rule - | opt_PprStyle_Debug = ppr rule - | otherwise = doubleQuotes (ftext (ru_name rule)) - in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" - (vcat [if opt_PprStyle_Debug then - ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args) - else empty, - ptext (sLit "Rule 1:") <+> pp_rule rule1, - ptext (sLit "Rule 2:") <+> pp_rule rule2]) $ - findBest target (rule1,ans1) prs + | opt_PprStyle_Debug = ppr rule + | otherwise = doubleQuotes (ftext (ru_name rule)) + in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" + (vcat [if opt_PprStyle_Debug then + ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args) + else empty, + ptext (sLit "Rule 1:") <+> pp_rule rule1, + ptext (sLit "Rule 2:") <+> pp_rule rule2]) $ + findBest target (rule1,ans1) prs | otherwise = findBest target (rule1,ans1) prs where (fn,args) = target @@ -415,7 +407,7 @@ isMoreSpecific :: CoreRule -> CoreRule -> Bool -- anything else, because we want user-define rules to "win" -- In particular, class ops have a built-in rule, but we -- any user-specific rules to win --- eg (Trac #4397) +-- eg (Trac #4397) -- truncate :: (RealFrac a, Integral b) => a -> b -- {-# RULES "truncate/Double->Int" truncate = double2Int #-} -- double2Int :: Double -> Int @@ -423,28 +415,28 @@ isMoreSpecific :: CoreRule -> CoreRule -> Bool isMoreSpecific (BuiltinRule {}) _ = False isMoreSpecific (Rule {}) (BuiltinRule {}) = True isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) - (Rule { ru_bndrs = bndrs2, ru_args = args2 }) + (Rule { ru_bndrs = bndrs2, ru_args = args2 }) = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1) where - id_unfolding_fun _ = NoUnfolding -- Don't expand in templates + id_unfolding_fun _ = NoUnfolding -- Don't expand in templates in_scope = mkInScopeSet (mkVarSet bndrs1) - -- Actually we should probably include the free vars - -- of rule1's args, but I can't be bothered + -- Actually we should probably include the free vars + -- of rule1's args, but I can't be bothered noBlackList :: Activation -> Bool -noBlackList _ = False -- Nothing is black listed +noBlackList _ = False -- Nothing is black listed \end{code} Note [Extra args in rule matching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we find a matching rule, we return (Just (rule, rhs)), +If we find a matching rule, we return (Just (rule, rhs)), but the rule firing has only consumed as many of the input args as the ruleArity says. It's up to the caller to keep track of any left-over args. E.g. if you call - lookupRule ... f [e1, e2, e3] + lookupRule ... f [e1, e2, e3] and it returns Just (r, rhs), where r has ruleArity 2 then the real rewrite is - f e1 e2 e3 ==> rhs e3 + f e1 e2 e3 ==> rhs e3 You might think it'd be cleaner for lookupRule to deal with the leftover arguments, by applying 'rhs' to them, but the main call @@ -453,10 +445,10 @@ to lookupRule are the result of a lazy substitution \begin{code} ------------------------------------ -matchRule :: (Activation -> Bool) -> IdUnfoldingFun +matchRule :: Id -> (Activation -> Bool) -> IdUnfoldingFun -> InScopeSet - -> [CoreExpr] -> [Maybe Name] - -> CoreRule -> Maybe CoreExpr + -> [CoreExpr] -> [Maybe Name] + -> CoreRule -> Maybe CoreExpr -- If (matchRule rule args) returns Just (name,rhs) -- then (f args) matches the rule, and the corresponding @@ -464,53 +456,53 @@ matchRule :: (Activation -> Bool) -> IdUnfoldingFun -- -- The bndrs and rhs is occurrence-analysed -- --- Example +-- Example -- -- The rule --- forall f g x. map f (map g x) ==> map (f . g) x +-- forall f g x. map f (map g x) ==> map (f . g) x -- is stored --- CoreRule "map/map" --- [f,g,x] -- tpl_vars --- [f,map g x] -- tpl_args --- map (f.g) x) -- rhs --- +-- CoreRule "map/map" +-- [f,g,x] -- tpl_vars +-- [f,map g x] -- tpl_args +-- map (f.g) x) -- rhs +-- -- Then the call: matchRule the_rule [e1,map e2 e3] --- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) +-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) -- -- Any 'surplus' arguments in the input are simply put on the end -- of the output. -matchRule _is_active id_unf _in_scope args _rough_args - (BuiltinRule { ru_try = match_fn }) +matchRule fn _is_active id_unf _in_scope args _rough_args + (BuiltinRule { ru_try = match_fn }) -- Built-in rules can't be switched off, it seems - = case match_fn id_unf args of - Just expr -> Just expr - Nothing -> Nothing + = case match_fn fn id_unf args of + Just expr -> Just expr + Nothing -> Nothing -matchRule is_active id_unf in_scope args rough_args +matchRule _ is_active id_unf in_scope args rough_args (Rule { ru_act = act, ru_rough = tpl_tops, - ru_bndrs = tpl_vars, ru_args = tpl_args, - ru_rhs = rhs }) - | not (is_active act) = Nothing + ru_bndrs = tpl_vars, ru_args = tpl_args, + ru_rhs = rhs }) + | not (is_active act) = Nothing | ruleCantMatch tpl_tops rough_args = Nothing | otherwise = case matchN id_unf in_scope tpl_vars tpl_args args of - Nothing -> Nothing - Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $ - rule_fn `mkApps` tpl_vals) + Nothing -> Nothing + Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $ + rule_fn `mkApps` tpl_vals) where rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs) - -- We could do this when putting things into the rulebase, I guess + -- We could do this when putting things into the rulebase, I guess --------------------------------------- -matchN :: IdUnfoldingFun +matchN :: IdUnfoldingFun -> InScopeSet -- ^ In-scope variables - -> [Var] -- ^ Match template type variables - -> [CoreExpr] -- ^ Match template - -> [CoreExpr] -- ^ Target; can have more elements than the template - -> Maybe (BindWrapper, -- Floated bindings; see Note [Matching lets] - [CoreExpr]) --- For a given match template and context, find bindings to wrap around + -> [Var] -- ^ Match template type variables + -> [CoreExpr] -- ^ Match template + -> [CoreExpr] -- ^ Target; can have more elements than the template + -> Maybe (BindWrapper, -- Floated bindings; see Note [Matching lets] + [CoreExpr]) +-- For a given match template and context, find bindings to wrap around -- the entire result and what should be substituted for each template variable. -- Fail if there are two few actual arguments from the target to match the template @@ -525,11 +517,11 @@ matchN id_unf in_scope tmpl_vars tmpl_es target_es init_menv = RV { rv_tmpls = mkVarSet tmpl_vars', rv_lcl = init_rn_env , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) , rv_unf = id_unf } - - go _ subst [] _ = Just subst - go _ _ _ [] = Nothing -- Fail if too few actual args + + go _ subst [] _ = Just subst + go _ _ _ [] = Nothing -- Fail if too few actual args go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e - ; go menv subst1 ts es } + ; go menv subst1 ts es } lookup_tmpl :: RuleSubst -> Var -> CoreExpr lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var' @@ -540,21 +532,21 @@ matchN id_unf in_scope tmpl_vars tmpl_es target_es Just ty -> Type ty Nothing -> unbound tmpl_var' - unbound var = pprPanic "Template variable unbound in rewrite rule" - (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es) + unbound var = pprPanic "Template variable unbound in rewrite rule" + (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es) \end{code} Note [Template binders] ~~~~~~~~~~~~~~~~~~~~~~~ Consider the following match: - Template: forall x. f x - Target: f (x+1) -This should succeed, because the template variable 'x' has -nothing to do with the 'x' in the target. + Template: forall x. f x + Target: f (x+1) +This should succeed, because the template variable 'x' has +nothing to do with the 'x' in the target. On reflection, this case probably does just work, but this might not - Template: forall x. f (\x.x) - Target: f (\y.y) + Template: forall x. f (\x.x) + Target: f (\y.y) Here we want to clone when we find the \x, but to know that x must be in scope To achive this, we use rnBndrL to rename the template variables if @@ -562,14 +554,14 @@ necessary; the renamed ones are the tmpl_vars' %************************************************************************ -%* * +%* * The main matcher -%* * +%* * %************************************************************************ --------------------------------------------- - The inner workings of matching - --------------------------------------------- + The inner workings of matching + --------------------------------------------- \begin{code} -- * The domain of the TvSubstEnv and IdSubstEnv are the template @@ -601,19 +593,19 @@ emptyRuleSubst :: RuleSubst emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv , rs_binds = \e -> e, rs_bndrs = emptyVarSet } --- At one stage I tried to match even if there are more --- template args than real args. +-- At one stage I tried to match even if there are more +-- template args than real args. --- I now think this is probably a bad idea. --- Should the template (map f xs) match (map g)? I think not. --- For a start, in general eta expansion wastes work. --- SLPJ July 99 +-- I now think this is probably a bad idea. +-- Should the template (map f xs) match (map g)? I think not. +-- For a start, in general eta expansion wastes work. +-- SLPJ July 99 match :: RuleEnv -> RuleSubst - -> CoreExpr -- Template - -> CoreExpr -- Target + -> CoreExpr -- Template + -> CoreExpr -- Target -> Maybe RuleSubst -- See the notes with Unify.match, which matches types @@ -621,14 +613,14 @@ match :: RuleEnv -- Interesting examples: -- Consider matching --- \x->f against \f->f +-- \x->f against \f->f -- When we meet the lambdas we must remember to rename f to f' in the -- second expresion. The RnEnv2 does that. -- --- Consider matching --- forall a. \b->b against \a->3 --- We must rename the \a. Otherwise when we meet the lambdas we --- might substitute [a/b] in the template, and then erroneously +-- Consider matching +-- forall a. \b->b against \a->3 +-- We must rename the \a. Otherwise when we meet the lambdas we +-- might substitute [a/b] in the template, and then erroneously -- succeed in matching what looks like the template variable 'a' against 3. -- The Var case follows closely what happens in Unify.match @@ -641,30 +633,30 @@ match renv subst e1 (Var v2) -- Note [Expanding variables] where v2' = lookupRnInScope rn_env v2 rn_env = rv_lcl renv - -- Notice that we look up v2 in the in-scope set - -- See Note [Lookup in-scope] - -- No need to apply any renaming first (hence no rnOccR) - -- because of the not-inRnEnvR + -- Notice that we look up v2 in the in-scope set + -- See Note [Lookup in-scope] + -- No need to apply any renaming first (hence no rnOccR) + -- because of the not-inRnEnvR match renv subst e1 (Let bind e2) | okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] = match (renv { rv_fltR = flt_subst' }) (subst { rs_binds = rs_binds subst . Let bind' , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) - e1 e2 + e1 e2 where flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) (flt_subst', bind') = substBind flt_subst bind new_bndrs = bindersOf bind' {- Disabled: see Note [Matching cases] below -match renv (tv_subst, id_subst, binds) e1 +match renv (tv_subst, id_subst, binds) e1 (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) - | exprOkForSpeculation scrut -- See Note [Matching cases] + | exprOkForSpeculation scrut -- See Note [Matching cases] , okToFloat rn_env bndrs (exprFreeVars scrut) = match (renv { me_env = rn_env' }) (tv_subst, id_subst, binds . case_wrap) - e1 rhs + e1 rhs where rn_env = me_env renv rn_env' = extendRnInScopeList rn_env bndrs @@ -677,8 +669,8 @@ match _ subst (Lit lit1) (Lit lit2) = Just subst match renv subst (App f1 a1) (App f2 a2) - = do { subst' <- match renv subst f1 f2 - ; match renv subst' a1 a2 } + = do { subst' <- match renv subst f1 f2 + ; match renv subst' a1 a2 } match renv subst (Lam x1 e1) (Lam x2 e2) = match renv' subst e1 e2 @@ -687,9 +679,9 @@ match renv subst (Lam x1 e1) (Lam x2 e2) , rv_fltR = delBndr (rv_fltR renv) x2 } -- This rule does eta expansion --- (\x.M) ~ N iff M ~ N x +-- (\x.M) ~ N iff M ~ N x -- It's important that this is *after* the let rule, --- so that (\x.M) ~ (let y = e in \y.N) +-- so that (\x.M) ~ (let y = e in \y.N) -- does the let thing, and then gets the lam/lam rule above match renv subst (Lam x1 e1) e2 = match renv' subst e1 (App e2 (varToCoreExpr new_x)) @@ -698,7 +690,7 @@ match renv subst (Lam x1 e1) e2 renv' = renv { rv_lcl = rn_env' } -- Eta expansion the other way --- M ~ (\y.N) iff M y ~ N +-- M ~ (\y.N) iff M y ~ N match renv subst e1 (Lam x2 e2) = match renv' subst (App e1 (varToCoreExpr new_x)) e2 where @@ -706,11 +698,11 @@ match renv subst e1 (Lam x2 e2) renv' = renv { rv_lcl = rn_env' } match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) - = do { subst1 <- match_ty renv subst ty1 ty2 - ; subst2 <- match renv subst1 e1 e2 + = do { subst1 <- match_ty renv subst ty1 ty2 + ; subst2 <- match renv subst1 e1 e2 ; let renv' = rnMatchBndr2 renv subst x1 x2 ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted - } + } match renv subst (Type ty1) (Type ty2) = match_ty renv subst ty1 ty2 @@ -718,8 +710,8 @@ match renv subst (Coercion co1) (Coercion co2) = match_co renv subst co1 co2 match renv subst (Cast e1 co1) (Cast e2 co2) - = do { subst1 <- match_co renv subst co1 co2 - ; match renv subst1 e1 e2 } + = do { subst1 <- match_co renv subst co1 co2 + ; match renv subst1 e1 e2 } -- Everything else fails match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ @@ -727,13 +719,13 @@ match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text ------------- match_co :: RuleEnv - -> RuleSubst - -> Coercion - -> Coercion - -> Maybe RuleSubst + -> RuleSubst + -> Coercion + -> Coercion + -> Maybe RuleSubst match_co renv subst (CoVarCo cv) co = match_var renv subst cv (Coercion co) -match_co _ _ co1 _ +match_co _ _ co1 _ = pprTrace "match_co baling out" (ppr co1) Nothing ------------- @@ -748,10 +740,10 @@ rnMatchBndr2 renv subst x1 x2 ------------------------------------------ match_alts :: RuleEnv - -> RuleSubst - -> [CoreAlt] -- Template - -> [CoreAlt] -- Target - -> Maybe RuleSubst + -> RuleSubst + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe RuleSubst match_alts _ subst [] [] = return subst match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) @@ -774,10 +766,10 @@ okToFloat rn_env bind_fvs ------------------------------------------ match_var :: RuleEnv - -> RuleSubst - -> Var -- Template - -> CoreExpr -- Target - -> Maybe RuleSubst + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) subst v1 e2 | v1' `elemVarSet` tmpls @@ -796,24 +788,24 @@ match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) where v1' = rnOccL rn_env v1 - -- If the template is - -- forall x. f x (\x -> x) = ... - -- Then the x inside the lambda isn't the - -- template x, so we must rename first! + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! ------------------------------------------ match_tmpl_var :: RuleEnv -> RuleSubst - -> Var -- Template - -> CoreExpr -- Target - -> Maybe RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) v1' e2 | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2)) = Nothing -- Occurs check failure - -- e.g. match forall a. (\x-> a x) against (\y. y y) + -- e.g. match forall a. (\x-> a x) against (\y. y y) | Just e1' <- lookupVarEnv id_subst v1' = if eqExpr (rnInScopeSet rn_env) e1' e2' @@ -822,15 +814,15 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) | otherwise = -- Note [Matching variable types] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- However, we must match the *types*; e.g. - -- forall (c::Char->Int) (x::Char). + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- However, we must match the *types*; e.g. + -- forall (c::Char->Int) (x::Char). -- f (c x) = "RULE FIRED" - -- We must only match on args that have the right type - -- It's actually quite difficult to come up with an example that shows - -- you need type matching, esp since matching is left-to-right, so type - -- args get matched first. But it's possible (e.g. simplrun008) and - -- this is the Right Thing to do + -- We must only match on args that have the right type + -- It's actually quite difficult to come up with an example that shows + -- you need type matching, esp since matching is left-to-right, so type + -- args get matched first. But it's possible (e.g. simplrun008) and + -- this is the Right Thing to do do { subst' <- match_ty renv subst (idType v1') (exprType e2) ; return (subst' { rs_id_subst = id_subst' }) } where @@ -844,14 +836,14 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) ------------------------------------------ match_ty :: RuleEnv - -> RuleSubst - -> Type -- Template - -> Type -- Target - -> Maybe RuleSubst + -> RuleSubst + -> Type -- Template + -> Type -- Target + -> Maybe RuleSubst -- Matching Core types: use the matcher in TcType. --- Notice that we treat newtypes as opaque. For example, suppose --- we have a specialised version of a function at a newtype, say --- newtype T = MkT Int +-- Notice that we treat newtypes as opaque. For example, suppose +-- we have a specialised version of a function at a newtype, say +-- newtype T = MkT Int -- We only want to replace (f T) with f', not (f Int). match_ty renv subst ty1 ty2 @@ -873,16 +865,16 @@ This is the key reason for "constructor-like" Ids. If we have {-# RULE f (g x) = h x #-} then in the term let v = g 3 in ....(f v).... -we want to make the rule fire, to replace (f v) with (h 3). +we want to make the rule fire, to replace (f v) with (h 3). Note [Do not expand locally-bound variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do *not* expand locally-bound variables, else there's a worry that the unfolding might mention variables that are themselves renamed. Example - case x of y { (p,q) -> ...y... } -Don't expand 'y' to (p,q) because p,q might themselves have been -renamed. Essentially we only expand unfoldings that are "outside" + case x of y { (p,q) -> ...y... } +Don't expand 'y' to (p,q) because p,q might themselves have been +renamed. Essentially we only expand unfoldings that are "outside" the entire match. Hence, (a) the guard (not (isLocallyBoundR v2)) @@ -898,11 +890,11 @@ patterns] in SpecConstr Note [Matching lets] ~~~~~~~~~~~~~~~~~~~~ Matching a let-expression. Consider - RULE forall x. f (g x) = <rhs> + RULE forall x. f (g x) = <rhs> and target expression - f (let { w=R } in g E)) + f (let { w=R } in g E)) Then we'd like the rule to match, to generate - let { w=R } in (\x. <rhs>) E + let { w=R } in (\x. <rhs>) E In effect, we want to float the let-binding outward, to enable the match to happen. This is the WHOLE REASON for accumulating bindings in the RuleSubst @@ -951,60 +943,60 @@ Note [Matching cases] ~~~~~~~~~~~~~~~~~~~~~ {- NOTE: This idea is currently disabled. It really only works if the primops involved are OkForSpeculation, and, since - they have side effects readIntOfAddr and touch are not. - Maybe we'll get back to this later . -} - + they have side effects readIntOfAddr and touch are not. + Maybe we'll get back to this later . -} + Consider f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> - case touch# fp s# of { _ -> + case touch# fp s# of { _ -> I# n# } } ) -This happened in a tight loop generated by stream fusion that -Roman encountered. We'd like to treat this just like the let +This happened in a tight loop generated by stream fusion that +Roman encountered. We'd like to treat this just like the let case, because the primops concerned are ok-for-speculation. That is, we'd like to behave as if it had been case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> - case touch# fp s# of { _ -> + case touch# fp s# of { _ -> f (I# n# } } ) - + Note [Lookup in-scope] ~~~~~~~~~~~~~~~~~~~~~~ Consider this example - foo :: Int -> Maybe Int -> Int - foo 0 (Just n) = n - foo m (Just n) = foo (m-n) (Just n) + foo :: Int -> Maybe Int -> Int + foo 0 (Just n) = n + foo m (Just n) = foo (m-n) (Just n) SpecConstr sees this fragment: - case w_smT of wild_Xf [Just A] { - Data.Maybe.Nothing -> lvl_smf; - Data.Maybe.Just n_acT [Just S(L)] -> - case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> - \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf - }}; + case w_smT of wild_Xf [Just A] { + Data.Maybe.Nothing -> lvl_smf; + Data.Maybe.Just n_acT [Just S(L)] -> + case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> + \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + }}; and correctly generates the rule - RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# - sc_snn :: GHC.Prim.Int#} - \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) - = \$s\$wfoo_sno y_amr sc_snn ;] + RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# + sc_snn :: GHC.Prim.Int#} + \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) + = \$s\$wfoo_sno y_amr sc_snn ;] BUT we must ensure that this rule matches in the original function! Note that the call to \$wfoo is - \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf During matching we expand wild_Xf to (Just n_acT). But then we must also expand n_acT to (I# y_amr). And we can only do that if we look up n_acT in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding -at all. +at all. That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' is so important. %************************************************************************ -%* * - Rule-check the program -%* * +%* * + Rule-check the program +%* * %************************************************************************ We want to know what sites have rules that could have fired but didn't. @@ -1018,27 +1010,27 @@ ruleCheckProgram :: CompilerPhase -- ^ Rule activation test -> RuleBase -- ^ Database of rules -> CoreProgram -- ^ Bindings to check in -> SDoc -- ^ Resulting check message -ruleCheckProgram phase rule_pat rule_base binds +ruleCheckProgram phase rule_pat rule_base binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise = vcat [text "Rule check results:", - line, - vcat [ p $$ line | p <- bagToList results ] - ] + line, + vcat [ p $$ line | p <- bagToList results ] + ] where env = RuleCheckEnv { rc_is_active = isActive phase - , rc_id_unf = idUnfolding -- Not quite right - -- Should use activeUnfolding + , rc_id_unf = idUnfolding -- Not quite right + -- Should use activeUnfolding , rc_pattern = rule_pat , rc_rule_base = rule_base } results = unionManyBags (map (ruleCheckBind env) binds) line = text (replicate 20 '-') - + data RuleCheckEnv = RuleCheckEnv { - rc_is_active :: Activation -> Bool, + rc_is_active :: Activation -> Bool, rc_id_unf :: IdUnfoldingFun, - rc_pattern :: String, + rc_pattern :: String, rc_rule_base :: RuleBase } @@ -1048,8 +1040,8 @@ ruleCheckBind env (NonRec _ r) = ruleCheck env r ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc -ruleCheck _ (Var _) = emptyBag -ruleCheck _ (Lit _) = emptyBag +ruleCheck _ (Var _) = emptyBag +ruleCheck _ (Lit _) = emptyBag ruleCheck _ (Type _) = emptyBag ruleCheck _ (Coercion _) = emptyBag ruleCheck env (App f a) = ruleCheckApp env (App f a) [] @@ -1057,8 +1049,8 @@ ruleCheck env (Tick _ e) = ruleCheck env e ruleCheck env (Cast e _) = ruleCheck env e ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e ruleCheck env (Lam _ e) = ruleCheck env e -ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` - unionManyBags [ruleCheck env r | (_,_,r) <- as] +ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck env r | (_,_,r) <- as] ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) @@ -1073,16 +1065,16 @@ ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc ruleCheckFun env fn args | null name_match_rules = emptyBag - | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) + | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) where name_match_rules = filter match (getRules (rc_rule_base env) fn) match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc ruleAppCheck_help env fn args rules - = -- The rules match the pattern, so we want to print something + = -- The rules match the pattern, so we want to print something vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), - vcat (map check_rule rules)] + vcat (map check_rule rules)] where n_args = length args i_args = args `zip` [1::Int ..] @@ -1091,32 +1083,32 @@ ruleAppCheck_help env fn args rules check_rule rule = rule_herald rule <> colon <+> rule_info rule rule_herald (BuiltinRule { ru_name = name }) - = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name) + = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name) rule_herald (Rule { ru_name = name }) - = ptext (sLit "Rule") <+> doubleQuotes (ftext name) + = ptext (sLit "Rule") <+> doubleQuotes (ftext name) rule_info rule - | Just _ <- matchRule noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule - = text "matches (which is very peculiar!)" + | Just _ <- matchRule fn noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule + = text "matches (which is very peculiar!)" rule_info (BuiltinRule {}) = text "does not match" - rule_info (Rule { ru_act = act, - ru_bndrs = rule_bndrs, ru_args = rule_args}) - | not (rc_is_active env act) = text "active only in later phase" - | n_args < n_rule_args = text "too few arguments" - | n_mismatches == n_rule_args = text "no arguments match" - | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" - | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" - where - n_rule_args = length rule_args - n_mismatches = length mismatches - mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, - not (isJust (match_fn rule_arg arg))] - - lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars + rule_info (Rule { ru_act = act, + ru_bndrs = rule_bndrs, ru_args = rule_args}) + | not (rc_is_active env act) = text "active only in later phase" + | n_args < n_rule_args = text "too few arguments" + | n_mismatches == n_rule_args = text "no arguments match" + | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" + | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" + where + n_rule_args = length rule_args + n_mismatches = length mismatches + mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, + not (isJust (match_fn rule_arg arg))] + + lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg - where + where in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) renv = RV { rv_lcl = mkRnEnv2 in_scope , rv_tmpls = mkVarSet rule_bndrs diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index d2c07bcc1b..995d6212ce 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -627,7 +627,8 @@ specConstrProgram guts %************************************************************************ \begin{code} -data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold +data ScEnv = SCE { sc_dflags :: DynFlags, + sc_size :: Maybe Int, -- Size threshold sc_count :: Maybe Int, -- Max # of specialisations for any one fn -- See Note [Avoiding exponential blowup] sc_force :: Bool, -- Force specialisation? @@ -672,7 +673,8 @@ instance Outputable Value where --------------------- initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv initScEnv dflags anns - = SCE { sc_size = specConstrThreshold dflags, + = SCE { sc_dflags = dflags, + sc_size = specConstrThreshold dflags, sc_count = specConstrCount dflags, sc_force = False, sc_subst = emptySubst, @@ -1023,7 +1025,7 @@ scExpr' env (Case scrut b ty alts) where sc_con_app con args scrut' -- Known constructor; simplify = do { let (_, bs, rhs) = findAlt con alts - `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts)) + `orElse` (DEFAULT, [], mkImpossibleExpr ty) alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) ; scExpr alt_env' rhs } @@ -1034,7 +1036,7 @@ scExpr' env (Case scrut b ty alts) ; (alt_usgs, alt_occs, alts') <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts - ; let scrut_occ = foldr1 combineOcc alt_occs -- Never empty + ; let scrut_occ = foldr combineOcc NoOcc alt_occs scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ -- The combined usage of the scrutinee is given -- by scrut_occ, which is passed to scScrut, which @@ -1384,7 +1386,8 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) fn_name = idName fn fn_loc = nameSrcSpan fn_name spec_occ = mkSpecOcc (nameOccName fn_name) - rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number)) + dflags = sc_dflags env + rule_name = mkFastString ("SC:" ++ showSDoc dflags (ppr fn <> int rule_number)) spec_name = mkInternalName spec_uniq spec_occ fn_loc -- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $ -- return () diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index a452593a3e..6892c9c6ad 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -4,13 +4,6 @@ \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Specialise ( specProgram ) where #include "HsVersions.h" @@ -19,34 +12,37 @@ import Id import TcType import Type import CoreMonad -import CoreSubst +import CoreSubst import CoreUnfold import VarSet import VarEnv import CoreSyn import Rules -import CoreUtils ( exprIsTrivial, applyTypeToArgs ) -import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) -import UniqSupply ( UniqSM, initUs_, MonadUnique(..) ) +import CoreUtils ( exprIsTrivial, applyTypeToArgs ) +import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) +import UniqSupply import Name -import MkId ( voidArgId, realWorldPrimId ) -import Maybes ( catMaybes, isJust ) -import BasicTypes +import MkId ( voidArgId, realWorldPrimId ) +import Maybes ( catMaybes, isJust ) +import BasicTypes import HscTypes import Bag +import DynFlags import Util import Outputable import FastString +import State +import Control.Monad import Data.Map (Map) import qualified Data.Map as Map import qualified FiniteMap as Map \end{code} %************************************************************************ -%* * +%* * \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} -%* * +%* * %************************************************************************ These notes describe how we implement specialisation to eliminate @@ -73,8 +69,8 @@ The basic idea ~~~~~~~~~~~~~~ Suppose we have - let f = <f_rhs> - in <body> + let f = <f_rhs> + in <body> and suppose f is overloaded. @@ -94,9 +90,9 @@ partial applications.) STEP 2: EQUIVALENCES So now we have a collection of calls to f: - f t1 t2 d1 d2 - f t3 t4 d3 d4 - ... + f t1 t2 d1 d2 + f t3 t4 d3 d4 + ... Notice that f may take several type arguments. To avoid ambiguity, we say that f is called at type t1/t2 and t3/t4. @@ -108,7 +104,7 @@ STEP 3: SPECIALISATION For each equivalence class, choose a representative (f t1 t2 d1 d2), and create a local instance of f, defined thus: - f@t1/t2 = <f_rhs> t1 t2 d1 d2 + f@t1/t2 = <f_rhs> t1 t2 d1 d2 f_rhs presumably has some big lambdas and dictionary lambdas, so lots of simplification will now result. However we don't actually *do* that @@ -132,15 +128,15 @@ its right-hand side, can we? But it's ok. The type checker *always* creates non-recursive definitions for overloaded recursive functions. For example: - f x = f (x+x) -- Yes I know its silly + f x = f (x+x) -- Yes I know its silly becomes - f a (d::Num a) = let p = +.sel a d - in - letrec fl (y::a) = fl (p y y) - in - fl + f a (d::Num a) = let p = +.sel a d + in + letrec fl (y::a) = fl (p y y) + in + fl We still have recusion for non-overloaded functions which we speciailise, but the recursive call should get specialised to the @@ -159,19 +155,19 @@ t1/t2. There are two possibilities: of f. In this case there's no problem, we proceed just as before. A common example is as follows. Here's the Haskell: - g y = let f x = x+x - in f y + f y + g y = let f x = x+x + in f y + f y After typechecking we have - g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x - in +.sel a d (f a d y) (f a d y) + g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x + in +.sel a d (f a d y) (f a d y) Notice that the call to f is at type type "a"; a non-constant type. Both calls to f are at the same type, so we can specialise to give: - g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x - in +.sel a d (f@a y) (f@a y) + g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x + in +.sel a d (f@a y) (f@a y) (b) The other case is when the type variables in the instance types @@ -181,9 +177,9 @@ but "a" is not in scope at the definition of +.sel. Can we do anything? Yes, we can "common them up", a sort of limited common sub-expression deal. This would give: - g a (d::Num a) (y::a) = let +.sel@a = +.sel a d - f@a (x::a) = +.sel@a x x - in +.sel@a (f@a y) (f@a y) + g a (d::Num a) (y::a) = let +.sel@a = +.sel a d + f@a (x::a) = +.sel@a x x + in +.sel@a (f@a y) (f@a y) This can save work, and can't be spotted by the type checker, because the two instances of +.sel weren't originally at the same type. @@ -209,7 +205,7 @@ Polymorphism 2 -- Overloading ~~~~~~~~~~~~~~ Consider a function whose most general type is - f :: forall a b. Ord a => [a] -> b -> b + f :: forall a b. Ord a => [a] -> b -> b There is really no point in making a version of g at Int/Int and another at Int/Bool, because it's only instancing the type variable "a" which @@ -223,7 +219,7 @@ Then when taking equivalence classes in STEP 2, we ignore the type args corresponding to unconstrained type variable. In STEP 3 we make polymorphic versions. Thus: - f@t1/ = /\b -> <f_rhs> t1 b d1 d2 + f@t1/ = /\b -> <f_rhs> t1 b d1 d2 We do this. @@ -232,9 +228,9 @@ Dictionary floating ~~~~~~~~~~~~~~~~~~~ Consider this - f a (d::Num a) = let g = ... - in - ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... + f a (d::Num a) = let g = ... + in + ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... Here, g is only called at one type, but the dictionary isn't in scope at the definition point for g. Usually the type checker would build a @@ -244,26 +240,26 @@ outwards along with call instances. Consider - f x = let g p q = p==q - h r s = (r+s, g r s) - in - h x x + f x = let g p q = p==q + h r s = (r+s, g r s) + in + h x x Before specialisation, leaving out type abstractions we have - f df x = let g :: Eq a => a -> a -> Bool - g dg p q = == dg p q - h :: Num a => a -> a -> (a, Bool) - h dh r s = let deq = eqFromNum dh - in (+ dh r s, g deq r s) - in - h df x x + f df x = let g :: Eq a => a -> a -> Bool + g dg p q = == dg p q + h :: Num a => a -> a -> (a, Bool) + h dh r s = let deq = eqFromNum dh + in (+ dh r s, g deq r s) + in + h df x x After specialising h we get a specialised version of h, like this: - h' r s = let deq = eqFromNum df - in (+ df r s, g deq r s) + h' r s = let deq = eqFromNum df + in (+ df r s, g deq r s) But we can't naively make an instance for g from this, because deq is not in scope at the defn of g. Instead, we have to float out the (new) defn of deq @@ -275,13 +271,13 @@ User SPECIALIZE pragmas Specialisation pragmas can be digested by the type checker, and implemented by adding extra definitions along with that of f, in the same way as before - f@t1/t2 = <f_rhs> t1 t2 d1 d2 + f@t1/t2 = <f_rhs> t1 t2 d1 d2 Indeed the pragmas *have* to be dealt with by the type checker, because only it knows how to build the dictionaries d1 and d2! For example - g :: Ord a => [a] -> [a] - {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} + g :: Ord a => [a] -> [a] + {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} Here, the specialised version of g is an application of g's rhs to the Ord dictionary for (Tree Int), which only the type checker can conjure @@ -293,7 +289,7 @@ Problem. The type checker doesn't have to hand a convenient <f_rhs>, because it is buried in a complex (as-yet-un-desugared) binding group. Maybe we should say - f@t1/t2 = f* t1 t2 d1 d2 + f@t1/t2 = f* t1 t2 d1 d2 where f* is the Id f with an IdInfo which says "inline me regardless!". Indeed all the specialisation could be done in this way. @@ -303,17 +299,17 @@ any in-scope let-bound thing. Again, the pragma should permit polymorphism in unconstrained variables: - h :: Ord a => [a] -> b -> b - {-# SPECIALIZE h :: [Int] -> b -> b #-} + h :: Ord a => [a] -> b -> b + {-# SPECIALIZE h :: [Int] -> b -> b #-} We *insist* that all overloaded type variables are specialised to ground types, (and hence there can be no context inside a SPECIALIZE pragma). We *permit* unconstrained type variables to be specialised to - - a ground type - - or left as a polymorphic type variable + - a ground type + - or left as a polymorphic type variable but nothing in between. So - {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} + {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} is *illegal*. (It can be handled, but it adds complication, and gains the programmer nothing.) @@ -323,20 +319,20 @@ SPECIALISING INSTANCE DECLARATIONS ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider - instance Foo a => Foo [a] where - ... - {-# SPECIALIZE instance Foo [Int] #-} + instance Foo a => Foo [a] where + ... + {-# SPECIALIZE instance Foo [Int] #-} The original instance decl creates a dictionary-function definition: - dfun.Foo.List :: forall a. Foo a -> Foo [a] + dfun.Foo.List :: forall a. Foo a -> Foo [a] The SPECIALIZE pragma just makes a specialised copy, just as for ordinary function definitions: - dfun.Foo.List@Int :: Foo [Int] - dfun.Foo.List@Int = dfun.Foo.List Int dFooInt + dfun.Foo.List@Int :: Foo [Int] + dfun.Foo.List@Int = dfun.Foo.List Int dFooInt The information about what instance of the dfun exist gets added to the dfun's IdInfo in the same way as a user-defined function too. @@ -380,19 +376,19 @@ Partial specialisation by pragmas ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What about partial specialisation: - k :: (Ord a, Eq b) => [a] -> b -> b -> [a] - {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} + k :: (Ord a, Eq b) => [a] -> b -> b -> [a] + {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} or even - {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} + {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} Seems quite reasonable. Similar things could be done with instance decls: - instance (Foo a, Foo b) => Foo (a,b) where - ... - {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} - {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} + instance (Foo a, Foo b) => Foo (a,b) where + ... + {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} + {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} Ho hum. Things are complex enough without this. I pass. @@ -404,14 +400,14 @@ The simplifier has to be able to take advantage of the specialisation. * When the simplifier finds an application of a polymorphic f, it looks in f's IdInfo in case there is a suitable instance to call instead. This converts - f t1 t2 d1 d2 ===> f_t1_t2 + f t1 t2 d1 d2 ===> f_t1_t2 Note that the dictionaries get eaten up too! * Dictionary selection operations on constant dictionaries must be short-circuited: - +.sel Int d ===> +Int + +.sel Int d ===> +Int The obvious way to do this is in the same way as other specialised calls: +.sel has inside it some IdInfo which tells that if it's applied @@ -423,13 +419,13 @@ methods. * Exactly the same applies if a superclass dictionary is being extracted: - Eq.sel Int d ===> dEqInt + Eq.sel Int d ===> dEqInt * Something similar applies to dictionary construction too. Suppose dfun.Eq.List is the function taking a dictionary for (Eq a) to one for (Eq [a]). Then we want - dfun.Eq.List Int d ===> dEq.List_Int + dfun.Eq.List Int d ===> dEq.List_Int Where does the Eq [Int] dictionary come from? It is built in response to a SPECIALIZE pragma on the Eq [a] instance decl. @@ -445,15 +441,15 @@ What does the specialisation IdInfo look like? The SpecEnv of an Id maps a list of types (the template) to an expression - [Type] |-> Expr + [Type] |-> Expr For example, if f has this SpecInfo: - [Int, a] -> \d:Ord Int. f' a + [Int, a] -> \d:Ord Int. f' a it means that we can replace the call - f Int t ===> (\d. f' t) + f Int t ===> (\d. f' t) This chucks one dictionary away and proceeds with the specialised version of f, namely f'. @@ -464,14 +460,14 @@ What can't be done this way? There is no way, post-typechecker, to get a dictionary for (say) Eq a from a dictionary for Eq [a]. So if we find - ==.sel [t] d + ==.sel [t] d we can't transform to - eqList (==.sel t d') + eqList (==.sel t d') where - eqList :: (a->a->Bool) -> [a] -> [a] -> Bool + eqList :: (a->a->Bool) -> [a] -> [a] -> Bool Of course, we currently have no way to automatically derive eqList, nor to connect it to the Eq [a] instance decl, but you @@ -485,7 +481,7 @@ A note about non-tyvar dictionaries ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some Ids have types like - forall a,b,c. Eq a -> Ord [a] -> tau + forall a,b,c. Eq a -> Ord [a] -> tau This seems curious at first, because we usually only have dictionary args whose types are of the form (C a) where a is a type variable. @@ -495,47 +491,47 @@ type constructor T. Should we specialise wrt this compound-type dictionary? We used to say "no", saying: - "This is a heuristic judgement, as indeed is the fact that we - specialise wrt only dictionaries. We choose *not* to specialise - wrt compound dictionaries because at the moment the only place - they show up is in instance decls, where they are simply plugged - into a returned dictionary. So nothing is gained by specialising - wrt them." + "This is a heuristic judgement, as indeed is the fact that we + specialise wrt only dictionaries. We choose *not* to specialise + wrt compound dictionaries because at the moment the only place + they show up is in instance decls, where they are simply plugged + into a returned dictionary. So nothing is gained by specialising + wrt them." But it is simpler and more uniform to specialise wrt these dicts too; -and in future GHC is likely to support full fledged type signatures +and in future GHC is likely to support full fledged type signatures like - f :: Eq [(a,b)] => ... + f :: Eq [(a,b)] => ... %************************************************************************ -%* * +%* * \subsubsection{The new specialiser} -%* * +%* * %************************************************************************ Our basic game plan is this. For let(rec) bound function - f :: (C a, D c) => (a,b,c,d) -> Bool + f :: (C a, D c) => (a,b,c,d) -> Bool -* Find any specialised calls of f, (f ts ds), where +* Find any specialised calls of f, (f ts ds), where ts are the type arguments t1 .. t4, and ds are the dictionary arguments d1 .. d2. * Add a new definition for f1 (say): - f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 + f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 Note that we abstract over the unconstrained type arguments. * Add the mapping - [t1,b,t3,d] |-> \d1 d2 -> f1 b d + [t1,b,t3,d] |-> \d1 d2 -> f1 b d to the specialisations of f. This will be used by the - simplifier to replace calls - (f t1 t2 t3 t4) da db + simplifier to replace calls + (f t1 t2 t3 t4) da db by - (\d1 d1 -> f1 t2 t4) da db + (\d1 d1 -> f1 t2 t4) da db All the stuff about how many dictionaries to discard, and what types to apply the specialised function to, are handled by the fact that the @@ -548,7 +544,7 @@ We don't build *partial* specialisations for f. For example: Here, little is gained by making a specialised copy of f. There's a distinct danger that the specialised version would -first build a dictionary for (Eq b, Eq c), and then select the (==) +first build a dictionary for (Eq b, Eq c), and then select the (==) method from it! Even if it didn't, not a great deal is saved. We do, however, generate polymorphic, but not overloaded, specialisations: @@ -556,43 +552,43 @@ We do, however, generate polymorphic, but not overloaded, specialisations: f :: Eq a => [a] -> b -> b -> b {#- SPECIALISE f :: [Int] -> b -> b -> b #-} -Hence, the invariant is this: +Hence, the invariant is this: - *** no specialised version is overloaded *** + *** no specialised version is overloaded *** %************************************************************************ -%* * +%* * \subsubsection{The exported function} -%* * +%* * %************************************************************************ \begin{code} -specProgram :: ModGuts -> CoreM ModGuts -specProgram guts +specProgram :: DynFlags -> ModGuts -> CoreM ModGuts +specProgram dflags guts = do { hpt_rules <- getRuleBase ; let local_rules = mg_rules guts rule_base = extendRuleBaseList hpt_rules (mg_rules guts) - -- Specialise the bindings of this module - ; (binds', uds) <- runSpecM (go (mg_binds guts)) + -- Specialise the bindings of this module + ; (binds', uds) <- runSpecM dflags (go (mg_binds guts)) - -- Specialise imported functions - ; (new_rules, spec_binds) <- specImports emptyVarSet rule_base uds + -- Specialise imported functions + ; (new_rules, spec_binds) <- specImports dflags emptyVarSet rule_base uds ; let final_binds | null spec_binds = binds' | otherwise = Rec (flattenBinds spec_binds) : binds' - -- Note [Glom the bindings if imported functions are specialised] + -- Note [Glom the bindings if imported functions are specialised] ; return (guts { mg_binds = final_binds , mg_rules = new_rules ++ local_rules }) } where - -- We need to start with a Subst that knows all the things - -- that are in scope, so that the substitution engine doesn't - -- accidentally re-use a unique that's already in use - -- Easiest thing is to do it all at once, as if all the top-level - -- decls were mutually recursive - top_subst = mkEmptySubst $ mkInScopeSet $ mkVarSet $ + -- We need to start with a Subst that knows all the things + -- that are in scope, so that the substitution engine doesn't + -- accidentally re-use a unique that's already in use + -- Easiest thing is to do it all at once, as if all the top-level + -- decls were mutually recursive + top_subst = mkEmptySubst $ mkInScopeSet $ mkVarSet $ bindersOfBinds $ mg_binds guts go [] = return ([], emptyUDs) @@ -600,65 +596,67 @@ specProgram guts (bind', uds') <- specBind top_subst bind uds return (bind' ++ binds', uds') -specImports :: VarSet -- Don't specialise these ones - -- See Note [Avoiding recursive specialisation] - -> RuleBase -- Rules from this module and the home package - -- (but not external packages, which can change) - -> UsageDetails -- Calls for imported things, and floating bindings +specImports :: DynFlags + -> VarSet -- Don't specialise these ones + -- See Note [Avoiding recursive specialisation] + -> RuleBase -- Rules from this module and the home package + -- (but not external packages, which can change) + -> UsageDetails -- Calls for imported things, and floating bindings -> CoreM ( [CoreRule] -- New rules , [CoreBind] ) -- Specialised bindings and floating bindings -- See Note [Specialise imported INLINABLE things] -specImports done rb uds +specImports dflags done rb uds = do { let import_calls = varEnvElts (ud_calls uds) ; (rules, spec_binds) <- go rb import_calls ; return (rules, wrapDictBinds (ud_binds uds) spec_binds) } where go _ [] = return ([], []) go rb (CIS fn calls_for_fn : other_calls) - = do { (rules1, spec_binds1) <- specImport done rb fn (Map.toList calls_for_fn) + = do { (rules1, spec_binds1) <- specImport dflags done rb fn (Map.toList calls_for_fn) ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } -specImport :: VarSet -- Don't specialise these - -- See Note [Avoiding recursive specialisation] - -> RuleBase -- Rules from this module - -> Id -> [CallInfo] -- Imported function and calls for it +specImport :: DynFlags + -> VarSet -- Don't specialise these + -- See Note [Avoiding recursive specialisation] + -> RuleBase -- Rules from this module + -> Id -> [CallInfo] -- Imported function and calls for it -> CoreM ( [CoreRule] -- New rules , [CoreBind] ) -- Specialised bindings -specImport done rb fn calls_for_fn +specImport dflags done rb fn calls_for_fn | fn `elemVarSet` done = return ([], []) -- No warning. This actually happens all the time - -- when specialising a recursive function, becuase - -- the RHS of the specialised function contains a recursive - -- call to the original function + -- when specialising a recursive function, becuase + -- the RHS of the specialised function contains a recursive + -- call to the original function | isInlinablePragma (idInlinePragma fn) , Just rhs <- maybeUnfoldingTemplate (realIdUnfolding fn) = do { -- Get rules from the external package state - -- We keep doing this in case we "page-fault in" - -- more rules as we go along + -- We keep doing this in case we "page-fault in" + -- more rules as we go along ; hsc_env <- getHscEnv - ; eps <- liftIO $ hscEPS hsc_env + ; eps <- liftIO $ hscEPS hsc_env ; let full_rb = unionRuleBase rb (eps_rule_base eps) - rules_for_fn = getRules full_rb fn + rules_for_fn = getRules full_rb fn - ; (rules1, spec_pairs, uds) <- runSpecM $ + ; (rules1, spec_pairs, uds) <- runSpecM dflags $ specCalls emptySubst rules_for_fn calls_for_fn fn rhs ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] - -- After the rules kick in we may get recursion, but - -- we rely on a global GlomBinds to sort that out later + -- After the rules kick in we may get recursion, but + -- we rely on a global GlomBinds to sort that out later -- See Note [Glom the bindings if imported functions are specialised] - - -- Now specialise any cascaded calls - ; (rules2, spec_binds2) <- specImports (extendVarSet done fn) - (extendRuleBaseList rb rules1) - uds + + -- Now specialise any cascaded calls + ; (rules2, spec_binds2) <- specImports dflags (extendVarSet done fn) + (extendRuleBaseList rb rules1) + uds ; return (rules2 ++ rules1, spec_binds2 ++ spec_binds1) } | otherwise = WARN( True, ptext (sLit "specImport discard") <+> ppr fn <+> ppr calls_for_fn ) - return ([], []) + return ([], []) \end{code} Note [Specialise imported INLINABLE things] @@ -669,7 +667,7 @@ Moreover, we risk lots of orphan modules from vigorous specialisation. Note [Glom the bindings if imported functions are specialised] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an imported, *recursive*, INLINABLE function +Suppose we have an imported, *recursive*, INLINABLE function f :: Eq a => a -> a f = /\a \d x. ...(f a d)... In the module being compiled we have @@ -695,13 +693,13 @@ When we specialise 'f' we may find new overloaded calls to 'g', 'h' in specialise f any more! It's possible that f's RHS might have a recursive yet-more-specialised call, so we'd diverge in that case. And if the call is to the same type, one specialisation is enough. -Avoiding this recursive specialisation loop is the reason for the +Avoiding this recursive specialisation loop is the reason for the 'done' VarSet passed to specImports and specImport. %************************************************************************ -%* * +%* * \subsubsection{@specExpr@: the main function} -%* * +%* * %************************************************************************ \begin{code} @@ -710,10 +708,10 @@ specVar subst v = lookupIdSubst (text "specVar") subst v specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) -- We carry a substitution down: --- a) we must clone any binding that might float outwards, --- to avoid name clashes --- b) we carry a type substitution to use when analysing --- the RHS of specialised bindings (no type-let!) +-- a) we must clone any binding that might float outwards, +-- to avoid name clashes +-- b) we carry a type substitution to use when analysing +-- the RHS of specialised bindings (no type-let!) ---------------- First the easy cases -------------------- specExpr subst (Type ty) = return (Type (CoreSubst.substTy subst ty), emptyUDs) @@ -738,30 +736,30 @@ specExpr subst expr@(App {}) go (Var f) args = case specVar subst f of Var f' -> return (Var f', mkCallUDs f' args) - e' -> return (e', emptyUDs) -- I don't expect this! - go other _ = specExpr subst other + e' -> return (e', emptyUDs) -- I don't expect this! + go other _ = specExpr subst other ---------------- Lambda/case require dumping of usage details -------------------- specExpr subst e@(Lam _ _) = do (body', uds) <- specExpr subst' body - let (free_uds, dumped_dbs) = dumpUDs bndrs' uds + let (free_uds, dumped_dbs) = dumpUDs bndrs' uds return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds) where (bndrs, body) = collectBinders e (subst', bndrs') = substBndrs subst bndrs - -- More efficient to collect a group of binders together all at once - -- and we don't want to split a lambda group with dumped bindings + -- More efficient to collect a group of binders together all at once + -- and we don't want to split a lambda group with dumped bindings -specExpr subst (Case scrut case_bndr ty alts) +specExpr subst (Case scrut case_bndr ty alts) = do { (scrut', scrut_uds) <- specExpr subst scrut - ; (scrut'', case_bndr', alts', alts_uds) - <- specCase subst scrut' case_bndr alts + ; (scrut'', case_bndr', alts', alts_uds) + <- specCase subst scrut' case_bndr alts ; return (Case scrut'' case_bndr' (CoreSubst.substTy subst ty) alts' , scrut_uds `plusUDs` alts_uds) } ---------------- Finally, let is the interesting case -------------------- specExpr subst (Let bind body) = do - -- Clone binders + -- Clone binders (rhs_subst, body_subst, bind') <- cloneBindSM subst bind -- Deal with the body @@ -780,15 +778,15 @@ specTickish subst (Breakpoint ix ids) -- should never happen, but it's harmless to drop them anyway. specTickish _ other_tickish = other_tickish -specCase :: Subst - -> CoreExpr -- Scrutinee, already done +specCase :: Subst + -> CoreExpr -- Scrutinee, already done -> Id -> [CoreAlt] - -> SpecM ( CoreExpr -- New scrutinee - , Id - , [CoreAlt] + -> SpecM ( CoreExpr -- New scrutinee + , Id + , [CoreAlt] , UsageDetails) specCase subst scrut' case_bndr [(con, args, rhs)] - | isDictId case_bndr -- See Note [Floating dictionaries out of cases] + | isDictId case_bndr -- See Note [Floating dictionaries out of cases] , interestingDict scrut' , not (isDeadBinder case_bndr && null sc_args') = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') @@ -797,17 +795,17 @@ specCase subst scrut' case_bndr [(con, args, rhs)] [(con, args', Var sc_arg')] | sc_arg' <- sc_args' ] - -- Extend the substitution for RHS to map the *original* binders - -- to their floated verions. Attach an unfolding to these floated - -- binders so they look interesting to interestingDict - mb_sc_flts :: [Maybe DictId] + -- Extend the substitution for RHS to map the *original* binders + -- to their floated verions. Attach an unfolding to these floated + -- binders so they look interesting to interestingDict + mb_sc_flts :: [Maybe DictId] mb_sc_flts = map (lookupVarEnv clone_env) args' clone_env = zipVarEnv sc_args' (zipWith add_unf sc_args_flt sc_rhss) subst_prs = (case_bndr, Var (add_unf case_bndr_flt scrut')) - : [ (arg, Var sc_flt) + : [ (arg, Var sc_flt) | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] subst_rhs' = extendIdSubstList subst_rhs subst_prs - + ; (rhs', rhs_uds) <- specExpr subst_rhs' rhs ; let scrut_bind = mkDB (NonRec case_bndr_flt scrut') case_bndr_set = unitVarSet case_bndr_flt @@ -821,7 +819,7 @@ specCase subst scrut' case_bndr [(con, args, rhs)] where (subst_rhs, (case_bndr':args')) = substBndrs subst (case_bndr:args) sc_args' = filter is_flt_sc_arg args' - + clone_me bndr = do { uniq <- getUniqueM ; return (mkUserLocal occ uniq ty loc) } where @@ -836,7 +834,7 @@ specCase subst scrut' case_bndr [(con, args, rhs)] arg_set = mkVarSet args' is_flt_sc_arg var = isId var && not (isDeadBinder var) - && isDictTy var_ty + && isDictTy var_ty && not (tyVarsOfType var_ty `intersectsVarSet` arg_set) where var_ty = idType var @@ -861,9 +859,9 @@ Consider g = \d. case d of { MkD sc ... -> ...(f sc)... } Naively we can't float d2's binding out of the case expression, because 'sc' is bound by the case, and that in turn means we can't -specialise f, which seems a pity. +specialise f, which seems a pity. -So we invert the case, by floating out a binding +So we invert the case, by floating out a binding for 'sc_flt' thus: sc_flt = case d of { MkD sc ... -> sc } Now we can float the call instance for 'f'. Indeed this is just @@ -872,7 +870,7 @@ but case is more efficient, and necessary with equalities. So it's good to work with both. You might think that this won't make any difference, because the -call instance will only get nuked by the \d. BUT if 'g' itself is +call instance will only get nuked by the \d. BUT if 'g' itself is specialised, then transitively we should be able to specialise f. In general, given @@ -887,17 +885,17 @@ The "_flt" things are the floated binds; we use the current substitution to substitute sc -> sc_flt in the RHS %************************************************************************ -%* * +%* * Dealing with a binding -%* * +%* * %************************************************************************ \begin{code} -specBind :: Subst -- Use this for RHSs - -> CoreBind - -> UsageDetails -- Info on how the scope of the binding - -> SpecM ([CoreBind], -- New bindings - UsageDetails) -- And info to pass upstream +specBind :: Subst -- Use this for RHSs + -> CoreBind + -> UsageDetails -- Info on how the scope of the binding + -> SpecM ([CoreBind], -- New bindings + UsageDetails) -- And info to pass upstream -- Returned UsageDetails: -- No calls for binders of this bind @@ -906,29 +904,29 @@ specBind rhs_subst (NonRec fn rhs) body_uds ; (fn', spec_defns, body_uds1) <- specDefn rhs_subst body_uds fn rhs ; let pairs = spec_defns ++ [(fn', rhs')] - -- fn' mentions the spec_defns in its rules, - -- so put the latter first + -- fn' mentions the spec_defns in its rules, + -- so put the latter first combined_uds = body_uds1 `plusUDs` rhs_uds - -- This way round a call in rhs_uds of a function f - -- at type T will override a call of f at T in body_uds1; and - -- that is good because it'll tend to keep "earlier" calls - -- See Note [Specialisation of dictionary functions] + -- This way round a call in rhs_uds of a function f + -- at type T will override a call of f at T in body_uds1; and + -- that is good because it'll tend to keep "earlier" calls + -- See Note [Specialisation of dictionary functions] - (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds - -- See Note [From non-recursive to recursive] + (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds + -- See Note [From non-recursive to recursive] final_binds | isEmptyBag dump_dbs = [NonRec b r | (b,r) <- pairs] | otherwise = [Rec (flattenDictBinds dump_dbs pairs)] - ; if float_all then - -- Rather than discard the calls mentioning the bound variables - -- we float this binding along with the others - return ([], free_uds `snocDictBinds` final_binds) + ; if float_all then + -- Rather than discard the calls mentioning the bound variables + -- we float this binding along with the others + return ([], free_uds `snocDictBinds` final_binds) else - -- No call in final_uds mentions bound variables, - -- so we can just leave the binding here - return (final_binds, free_uds) } + -- No call in final_uds mentions bound variables, + -- so we can just leave the binding here + return (final_binds, free_uds) } specBind rhs_subst (Rec pairs) body_uds @@ -936,14 +934,14 @@ specBind rhs_subst (Rec pairs) body_uds = do { let (bndrs,rhss) = unzip pairs ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_subst) rhss ; let scope_uds = body_uds `plusUDs` rhs_uds - -- Includes binds and calls arising from rhss + -- Includes binds and calls arising from rhss ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_subst scope_uds pairs ; (bndrs3, spec_defns3, uds3) <- if null spec_defns1 -- Common case: no specialisation - then return (bndrs1, [], uds1) - else do { -- Specialisation occurred; do it again + then return (bndrs1, [], uds1) + else do { -- Specialisation occurred; do it again (bndrs2, spec_defns2, uds2) <- specDefns rhs_subst uds1 (bndrs1 `zip` rhss) ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) } @@ -951,20 +949,20 @@ specBind rhs_subst (Rec pairs) body_uds ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3 bind = Rec (flattenDictBinds dumped_dbs $ spec_defns3 ++ zip bndrs3 rhss') - + ; if float_all then - return ([], final_uds `snocDictBind` bind) + return ([], final_uds `snocDictBind` bind) else - return ([bind], final_uds) } + return ([bind], final_uds) } --------------------------- specDefns :: Subst - -> UsageDetails -- Info on how it is used in its scope - -> [(Id,CoreExpr)] -- The things being bound and their un-processed RHS - -> SpecM ([Id], -- Original Ids with RULES added - [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions + -> UsageDetails -- Info on how it is used in its scope + -> [(Id,CoreExpr)] -- The things being bound and their un-processed RHS + -> SpecM ([Id], -- Original Ids with RULES added + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions -- Specialise a list of bindings (the contents of a Rec), but flowing usages -- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } @@ -981,81 +979,81 @@ specDefns subst uds ((bndr,rhs):pairs) --------------------------- specDefn :: Subst - -> UsageDetails -- Info on how it is used in its scope - -> Id -> CoreExpr -- The thing being bound and its un-processed RHS - -> SpecM (Id, -- Original Id with added RULES - [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions + -> UsageDetails -- Info on how it is used in its scope + -> Id -> CoreExpr -- The thing being bound and its un-processed RHS + -> SpecM (Id, -- Original Id with added RULES + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions specDefn subst body_uds fn rhs = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds rules_for_me = idCoreRules fn - ; (rules, spec_defns, spec_uds) <- specCalls subst rules_for_me + ; (rules, spec_defns, spec_uds) <- specCalls subst rules_for_me calls_for_me fn rhs ; return ( fn `addIdSpecialisations` rules , spec_defns , body_uds_without_me `plusUDs` spec_uds) } - -- It's important that the `plusUDs` is this way - -- round, because body_uds_without_me may bind - -- dictionaries that are used in calls_for_me passed - -- to specDefn. So the dictionary bindings in - -- spec_uds may mention dictionaries bound in - -- body_uds_without_me + -- It's important that the `plusUDs` is this way + -- round, because body_uds_without_me may bind + -- dictionaries that are used in calls_for_me passed + -- to specDefn. So the dictionary bindings in + -- spec_uds may mention dictionaries bound in + -- body_uds_without_me --------------------------- specCalls :: Subst - -> [CoreRule] -- Existing RULES for the fn - -> [CallInfo] - -> Id -> CoreExpr - -> SpecM ([CoreRule], -- New RULES for the fn - [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails) -- New usage details from the specialised RHSs + -> [CoreRule] -- Existing RULES for the fn + -> [CallInfo] + -> Id -> CoreExpr + -> SpecM ([CoreRule], -- New RULES for the fn + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- New usage details from the specialised RHSs -- This function checks existing rules, and does not create -- duplicate ones. So the caller does not need to do this filtering. -- See 'already_covered' specCalls subst rules_for_me calls_for_me fn rhs - -- The first case is the interesting one + -- The first case is the interesting one | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas - && rhs_ids `lengthAtLeast` n_dicts -- and enough dict args - && notNull calls_for_me -- And there are some calls to specialise + && rhs_ids `lengthAtLeast` n_dicts -- and enough dict args + && notNull calls_for_me -- And there are some calls to specialise && not (isNeverActive (idInlineActivation fn)) - -- Don't specialise NOINLINE things - -- See Note [Auto-specialisation and RULES] + -- Don't specialise NOINLINE things + -- See Note [Auto-specialisation and RULES] --- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small --- See Note [Inline specialisation] for why we do not --- switch off specialisation for inline functions +-- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small +-- See Note [Inline specialisation] for why we do not +-- switch off specialisation for inline functions = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr rules_for_me) $ do { stuff <- mapM spec_call calls_for_me ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff) ; return (spec_rules, spec_defns, plusUDList spec_uds) } - | otherwise -- No calls or RHS doesn't fit our preconceptions - = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") + | otherwise -- No calls or RHS doesn't fit our preconceptions + = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") <+> ppr fn $$ _trace_doc ) - -- Note [Specialisation shape] - -- pprTrace "specDefn: none" (ppr fn $$ ppr calls_for_me) $ + -- Note [Specialisation shape] + -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ return ([], [], emptyUDs) where - _trace_doc = vcat [ ppr rhs_tyvars, ppr n_tyvars - , ppr rhs_ids, ppr n_dicts - , ppr (idInlineActivation fn) ] + _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars + , ppr rhs_ids, ppr n_dicts + , ppr (idInlineActivation fn) ] - fn_type = idType fn - fn_arity = idArity fn - fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here + fn_type = idType fn + fn_arity = idArity fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here (tyvars, theta, _) = tcSplitSigmaTy fn_type - n_tyvars = length tyvars - n_dicts = length theta + n_tyvars = length tyvars + n_dicts = length theta inl_prag = idInlinePragma fn inl_act = inlinePragmaActivation inl_prag is_local = isLocalId fn - -- Figure out whether the function has an INLINE pragma - -- See Note [Inline specialisations] + -- Figure out whether the function has an INLINE pragma + -- See Note [Inline specialisations] spec_arity = unfoldingArity fn_unf - n_dicts -- Arity of the *specialised* inline rule @@ -1063,130 +1061,136 @@ specCalls subst rules_for_me calls_for_me fn rhs rhs_dict_ids = take n_dicts rhs_ids body = mkLams (drop n_dicts rhs_ids) rhs_body - -- Glue back on the non-dict lambdas + -- Glue back on the non-dict lambdas already_covered :: [CoreExpr] -> Bool - already_covered args -- Note [Specialisations already covered] - = isJust (lookupRule (const True) realIdUnfolding - (substInScope subst) - fn args rules_for_me) - - mk_ty_args :: [Maybe Type] -> [CoreExpr] - mk_ty_args call_ts = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts - where - mk_ty_arg rhs_tyvar Nothing = Type (mkTyVarTy rhs_tyvar) - mk_ty_arg _ (Just ty) = Type ty + already_covered args -- Note [Specialisations already covered] + = isJust (lookupRule (const True) realIdUnfolding + (substInScope subst) + fn args rules_for_me) + + mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr] + mk_ty_args [] poly_tvs + = ASSERT( null poly_tvs ) [] + mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs) + = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs + mk_ty_args (Just ty : call_ts) poly_tvs + = Type ty : mk_ty_args call_ts poly_tvs + mk_ty_args (Nothing : _) [] = panic "mk_ty_args" ---------------------------------------------------------- - -- Specialise to one particular call pattern + -- Specialise to one particular call pattern spec_call :: CallInfo -- Call instance - -> SpecM (Maybe ((Id,CoreExpr), -- Specialised definition - UsageDetails, -- Usage details from specialised body - CoreRule)) -- Info for the Id's SpecEnv + -> SpecM (Maybe ((Id,CoreExpr), -- Specialised definition + UsageDetails, -- Usage details from specialised body + CoreRule)) -- Info for the Id's SpecEnv spec_call (CallKey call_ts, (call_ds, _)) = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts ) - - -- Suppose f's defn is f = /\ a b c -> \ d1 d2 -> rhs + + -- Suppose f's defn is f = /\ a b c -> \ d1 d2 -> rhs -- Supppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2] - -- Construct the new binding - -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs) - -- PLUS the usage-details - -- { d1' = dx1; d2' = dx2 } - -- where d1', d2' are cloned versions of d1,d2, with the type substitution - -- applied. These auxiliary bindings just avoid duplication of dx1, dx2 - -- - -- Note that the substitution is applied to the whole thing. - -- This is convenient, but just slightly fragile. Notably: - -- * There had better be no name clashes in a/b/c + -- Construct the new binding + -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs) + -- PLUS the usage-details + -- { d1' = dx1; d2' = dx2 } + -- where d1', d2' are cloned versions of d1,d2, with the type substitution + -- applied. These auxiliary bindings just avoid duplication of dx1, dx2 + -- + -- Note that the substitution is applied to the whole thing. + -- This is convenient, but just slightly fragile. Notably: + -- * There had better be no name clashes in a/b/c do { let - -- poly_tyvars = [b] in the example above - -- spec_tyvars = [a,c] - -- ty_args = [t1,b,t3] - poly_tyvars = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] - spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts] - spec_ty_args = map snd spec_tv_binds - ty_args = mk_ty_args call_ts - rhs_subst = CoreSubst.extendTvSubstList subst spec_tv_binds - - ; (rhs_subst1, inst_dict_ids) <- newDictBndrs rhs_subst rhs_dict_ids - -- Clone rhs_dicts, including instantiating their types - - ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $ - (my_zipEqual rhs_dict_ids inst_dict_ids call_ds) - inst_args = ty_args ++ map Var inst_dict_ids - - ; if already_covered inst_args then - return Nothing - else do - { -- Figure out the type of the specialised function - let body_ty = applyTypeToArgs rhs fn_type inst_args - (lam_args, app_args) -- Add a dummy argument if body_ty is unlifted - | isUnLiftedType body_ty -- C.f. WwLib.mkWorkerArgs - = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId]) - | otherwise = (poly_tyvars, poly_tyvars) - spec_id_ty = mkPiTypes lam_args body_ty - + -- poly_tyvars = [b] in the example above + -- spec_tyvars = [a,c] + -- ty_args = [t1,b,t3] + spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts] + spec_ty_args = map snd spec_tv_binds + subst1 = CoreSubst.extendTvSubstList subst spec_tv_binds + (rhs_subst, poly_tyvars) + = CoreSubst.substBndrs subst1 + [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] + + ; (rhs_subst1, inst_dict_ids) <- newDictBndrs rhs_subst rhs_dict_ids + -- Clone rhs_dicts, including instantiating their types + + ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $ + (my_zipEqual rhs_dict_ids inst_dict_ids call_ds) + ty_args = mk_ty_args call_ts poly_tyvars + inst_args = ty_args ++ map Var inst_dict_ids + + ; if already_covered inst_args then + return Nothing + else do + { -- Figure out the type of the specialised function + let body_ty = applyTypeToArgs rhs fn_type inst_args + (lam_args, app_args) -- Add a dummy argument if body_ty is unlifted + | isUnLiftedType body_ty -- C.f. WwLib.mkWorkerArgs + = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId]) + | otherwise = (poly_tyvars, poly_tyvars) + spec_id_ty = mkPiTypes lam_args body_ty + ; spec_f <- newSpecIdSM fn spec_id_ty ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body) - ; let - -- The rule to put in the function's specialisation is: - -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b - rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args)) - spec_env_rule = mkRule True {- Auto generated -} is_local + ; dflags <- getDynFlags + ; let + -- The rule to put in the function's specialisation is: + -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b + rule_name = mkFastString ("SPEC " ++ showSDocDump dflags (ppr fn <+> ppr spec_ty_args)) + spec_env_rule = mkRule True {- Auto generated -} is_local rule_name - inl_act -- Note [Auto-specialisation and RULES] - (idName fn) - (poly_tyvars ++ inst_dict_ids) - inst_args - (mkVarApps (Var spec_f) app_args) - - -- Add the { d1' = dx1; d2' = dx2 } usage stuff - final_uds = foldr consDictBind rhs_uds dx_binds - - -------------------------------------- - -- Add a suitable unfolding if the spec_inl_prag says so - -- See Note [Inline specialisations] - spec_inl_prag - | not is_local && isStrongLoopBreaker (idOccInfo fn) - = neverInlinePragma -- See Note [Specialising imported functions] in OccurAnal - | otherwise - = case inl_prag of - InlinePragma { inl_inline = Inlinable } + inl_act -- Note [Auto-specialisation and RULES] + (idName fn) + (poly_tyvars ++ inst_dict_ids) + inst_args + (mkVarApps (Var spec_f) app_args) + + -- Add the { d1' = dx1; d2' = dx2 } usage stuff + final_uds = foldr consDictBind rhs_uds dx_binds + + -------------------------------------- + -- Add a suitable unfolding if the spec_inl_prag says so + -- See Note [Inline specialisations] + spec_inl_prag + | not is_local && isStrongLoopBreaker (idOccInfo fn) + = neverInlinePragma -- See Note [Specialising imported functions] in OccurAnal + | otherwise + = case inl_prag of + InlinePragma { inl_inline = Inlinable } -> inl_prag { inl_inline = EmptyInlineSpec } - _ -> inl_prag + _ -> inl_prag - spec_unf + spec_unf = case inlinePragmaSpec spec_inl_prag of Inline -> mkInlineUnfolding (Just spec_arity) spec_rhs Inlinable -> mkInlinableUnfolding spec_rhs _ -> NoUnfolding - -------------------------------------- - -- Adding arity information just propagates it a bit faster - -- See Note [Arity decrease] in Simplify - -- Copy InlinePragma information from the parent Id. - -- So if f has INLINE[1] so does spec_f - spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts) + -------------------------------------- + -- Adding arity information just propagates it a bit faster + -- See Note [Arity decrease] in Simplify + -- Copy InlinePragma information from the parent Id. + -- So if f has INLINE[1] so does spec_f + spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts) `setInlinePragma` spec_inl_prag `setIdUnfolding` spec_unf - ; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } } + ; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } } where - my_zipEqual xs ys zs - | debugIsOn && not (equalLength xs ys && equalLength ys zs) + my_zipEqual xs ys zs + | debugIsOn && not (equalLength xs ys && equalLength ys zs) = pprPanic "my_zipEqual" (vcat [ ppr xs, ppr ys - , ppr fn <+> ppr call_ts - , ppr (idType fn), ppr theta - , ppr n_dicts, ppr rhs_dict_ids - , ppr rhs]) - | otherwise = zip3 xs ys zs + , ppr fn <+> ppr call_ts + , ppr (idType fn), ppr theta + , ppr n_dicts, ppr rhs_dict_ids + , ppr rhs]) + | otherwise = zip3 xs ys zs bindAuxiliaryDicts - :: Subst - -> [(DictId,DictId,CoreExpr)] -- (orig_dict, inst_dict, dx) - -> (Subst, -- Substitute for all orig_dicts - [CoreBind]) -- Auxiliary bindings + :: Subst + -> [(DictId,DictId,CoreExpr)] -- (orig_dict, inst_dict, dx) + -> (Subst, -- Substitute for all orig_dicts + [CoreBind]) -- Auxiliary bindings -- Bind any dictionary arguments to fresh names, to preserve sharing -- Substitution already substitutes orig_dict -> inst_dict bindAuxiliaryDicts subst triples = go subst [] triples @@ -1195,29 +1199,29 @@ bindAuxiliaryDicts subst triples = go subst [] triples go subst binds ((d, dx_id, dx) : pairs) | exprIsTrivial dx = go (extendIdSubst subst d dx) binds pairs -- No auxiliary binding necessary - -- Note that we bind the *original* dict in the substitution, - -- overriding any d->dx_id binding put there by substBndrs + -- Note that we bind the *original* dict in the substitution, + -- overriding any d->dx_id binding put there by substBndrs | otherwise = go subst_w_unf (NonRec dx_id dx : binds) pairs where dx_id1 = dx_id `setIdUnfolding` mkSimpleUnfolding dx - subst_w_unf = extendIdSubst subst d (Var dx_id1) - -- Important! We're going to substitute dx_id1 for d - -- and we want it to look "interesting", else we won't gather *any* - -- consequential calls. E.g. - -- f d = ...g d.... - -- If we specialise f for a call (f (dfun dNumInt)), we'll get - -- a consequent call (g d') with an auxiliary definition - -- d' = df dNumInt - -- We want that consequent call to look interesting - -- - -- Again, note that we bind the *original* dict in the substitution, - -- overriding any d->dx_id binding put there by substBndrs + subst_w_unf = extendIdSubst subst d (Var dx_id1) + -- Important! We're going to substitute dx_id1 for d + -- and we want it to look "interesting", else we won't gather *any* + -- consequential calls. E.g. + -- f d = ...g d.... + -- If we specialise f for a call (f (dfun dNumInt)), we'll get + -- a consequent call (g d') with an auxiliary definition + -- d' = df dNumInt + -- We want that consequent call to look interesting + -- + -- Again, note that we bind the *original* dict in the substitution, + -- overriding any d->dx_id binding put there by substBndrs \end{code} Note [From non-recursive to recursive] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even in the non-recursive case, if any dict-binds depend on 'fn' we might +Even in the non-recursive case, if any dict-binds depend on 'fn' we might have built a recursive knot f a d x = <blah> @@ -1233,7 +1237,7 @@ The we generate Here the recursion is only through the RULE. - + Note [Specialisation of dictionary functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is a nasty example that bit us badly: see Trac #3591 @@ -1250,7 +1254,7 @@ Here is a nasty example that bit us badly: see Trac #3591 d1 :: Eq [T] = $p1 d2 d3 :: C [T] = dfun T d1 -None of these definitions is recursive. What happened was that we +None of these definitions is recursive. What happened was that we generated a specialisation: RULE forall d. dfun T d = dT :: C [T] @@ -1274,8 +1278,8 @@ But look at this: class C a where { foo,bar :: [a] -> [a] } - instance C Int where - foo x = r_bar x + instance C Int where + foo x = r_bar x bar xs = reverse xs r_bar :: C a => [a] -> [a] @@ -1288,8 +1292,8 @@ That translates to: Rec { $fCInt :: C Int = MkC foo_help reverse foo_help (xs::[Int]) = r_bar Int $fCInt xs } -The call (r_bar $fCInt) mentions $fCInt, - which mentions foo_help, +The call (r_bar $fCInt) mentions $fCInt, + which mentions foo_help, which mentions r_bar But we DO want to specialise r_bar at Int: @@ -1297,11 +1301,11 @@ But we DO want to specialise r_bar at Int: foo_help (xs::[Int]) = r_bar Int $fCInt xs r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) - RULE r_bar Int _ = r_bar_Int + RULE r_bar Int _ = r_bar_Int r_bar_Int xs = bar Int $fCInt (xs ++ xs) } - + Note that, because of its RULE, r_bar joins the recursive group. (In this case it'll unravel a short moment later.) @@ -1317,7 +1321,7 @@ Consider let rec { f x = ...g x'... ; g y = ...f y'.... } in f 'a' -Here we specialise 'f' at Char; but that is very likely to lead to +Here we specialise 'f' at Char; but that is very likely to lead to a specialisation of 'g' at Char. We must do the latter, else the whole point of specialisation is lost. @@ -1335,12 +1339,12 @@ So we use the following heuristic: the RHSs back in the bottom, as it were In effect, the ordering maxmimises the effectiveness of each sweep, -and we do just two sweeps. This should catch almost every case of +and we do just two sweeps. This should catch almost every case of monomorphic recursion -- the exception could be a very knotted-up recursion with multiple cycles tied up together. This plan is implemented in the Rec case of specBindItself. - + Note [Specialisations already covered] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We obviously don't want to generate two specialisations for the same @@ -1373,13 +1377,13 @@ Consider: Suppose that auto-specialisation makes a specialised version of g::Int->Int That version won't appear in the LHS of the RULE for f. So if the specialisation rule fires too early, the rule for f may -never fire. +never fire. It might be possible to add new rules, to "complete" the rewrite system. Thus when adding - RULE forall d. g Int d = g_spec + RULE forall d. g Int d = g_spec also add - RULE f g_spec = 0 + RULE f g_spec = 0 But that's a bit complicated. For now we ask the programmer's help, by *copying the INLINE activation pragma* to the auto-specialised @@ -1395,23 +1399,23 @@ Note [Specialisation shape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We only specialise a function if it has visible top-level lambdas corresponding to its overloading. E.g. if - f :: forall a. Eq a => .... + f :: forall a. Eq a => .... then its body must look like - f = /\a. \d. ... + f = /\a. \d. ... Reason: when specialising the body for a call (f ty dexp), we want to substitute dexp for d, and pick up specialised calls in the body of f. This doesn't always work. One example I came across was this: - newtype Gen a = MkGen{ unGen :: Int -> a } + newtype Gen a = MkGen{ unGen :: Int -> a } - choose :: Eq a => a -> Gen a - choose n = MkGen (\r -> n) + choose :: Eq a => a -> Gen a + choose n = MkGen (\r -> n) - oneof = choose (1::Int) + oneof = choose (1::Int) It's a silly exapmle, but we get - choose = /\a. g `cast` co + choose = /\a. g `cast` co where choose doesn't have any dict arguments. Thus far I have not tried to fix this (wait till there's a real example). @@ -1435,10 +1439,10 @@ modules) the specialised version wasn't INLINEd. After all, the programmer said INLINE! You might wonder why we don't just not-specialise INLINE functions. -It's because even INLINE functions are sometimes not inlined, when +It's because even INLINE functions are sometimes not inlined, when they aren't applied to interesting arguments. But perhaps the type arguments alone are enough to specialise (even though the args are too -boring to trigger inlining), and it's certainly better to call the +boring to trigger inlining), and it's certainly better to call the specialised version. Why (b)? See Trac #4874 for persuasive examples. Suppose we have @@ -1462,45 +1466,45 @@ INLINABLE. See Trac #4874. %************************************************************************ -%* * +%* * \subsubsection{UsageDetails and suchlike} -%* * +%* * %************************************************************************ \begin{code} -data UsageDetails +data UsageDetails = MkUD { - ud_binds :: !(Bag DictBind), - -- Floated dictionary bindings - -- The order is important; - -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 - -- (Remember, Bags preserve order in GHC.) + ud_binds :: !(Bag DictBind), + -- Floated dictionary bindings + -- The order is important; + -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 + -- (Remember, Bags preserve order in GHC.) - ud_calls :: !CallDetails + ud_calls :: !CallDetails - -- INVARIANT: suppose bs = bindersOf ud_binds - -- Then 'calls' may *mention* 'bs', + -- INVARIANT: suppose bs = bindersOf ud_binds + -- Then 'calls' may *mention* 'bs', -- but there should be no calls *for* bs } instance Outputable UsageDetails where ppr (MkUD { ud_binds = dbs, ud_calls = calls }) - = ptext (sLit "MkUD") <+> braces (sep (punctuate comma - [ptext (sLit "binds") <+> equals <+> ppr dbs, - ptext (sLit "calls") <+> equals <+> ppr calls])) + = ptext (sLit "MkUD") <+> braces (sep (punctuate comma + [ptext (sLit "binds") <+> equals <+> ppr dbs, + ptext (sLit "calls") <+> equals <+> ppr calls])) type DictBind = (CoreBind, VarSet) - -- The set is the free vars of the binding - -- both tyvars and dicts + -- The set is the free vars of the binding + -- both tyvars and dicts type DictExpr = CoreExpr emptyUDs :: UsageDetails emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyVarEnv } ------------------------------------------------------------- +------------------------------------------------------------ type CallDetails = IdEnv CallInfoSet -newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argument +newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argument -- CallInfo uses a Map, thereby ensuring that -- we record only one call instance for any key @@ -1508,9 +1512,9 @@ newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argu -- The list of types and dictionaries is guaranteed to -- match the type of f data CallInfoSet = CIS Id (Map CallKey ([DictExpr], VarSet)) - -- Range is dict args and the vars of the whole - -- call (including tyvars) - -- [*not* include the main id itself, of course] + -- Range is dict args and the vars of the whole + -- call (including tyvars) + -- [*not* include the main id itself, of course] type CallInfo = (CallKey, ([DictExpr], VarSet)) @@ -1528,11 +1532,11 @@ instance Eq CallKey where instance Ord CallKey where compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2 - where - cmp Nothing Nothing = EQ - cmp Nothing (Just _) = LT - cmp (Just _) Nothing = GT - cmp (Just t1) (Just t2) = cmpType t1 t2 + where + cmp Nothing Nothing = EQ + cmp Nothing (Just _) = LT + cmp (Just _) Nothing = GT + cmp (Just t1) (Just t2) = cmpType t1 t2 unionCalls :: CallDetails -> CallDetails -> CallDetails unionCalls c1 c2 = plusVarEnv_C unionCallInfoSet c1 c2 @@ -1546,39 +1550,39 @@ callDetailsFVs calls = foldVarEnv (unionVarSet . callInfoFVs) emptyVarSet calls callInfoFVs :: CallInfoSet -> VarSet callInfoFVs (CIS _ call_info) = Map.foldRight (\(_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info ------------------------------------------------------------- +------------------------------------------------------------ singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails -singleCall id tys dicts - = MkUD {ud_binds = emptyBag, - ud_calls = unitVarEnv id $ CIS id $ +singleCall id tys dicts + = MkUD {ud_binds = emptyBag, + ud_calls = unitVarEnv id $ CIS id $ Map.singleton (CallKey tys) (dicts, call_fvs) } where call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs tys_fvs = tyVarsOfTypes (catMaybes tys) - -- The type args (tys) are guaranteed to be part of the dictionary - -- types, because they are just the constrained types, - -- and the dictionary is therefore sure to be bound - -- inside the binding for any type variables free in the type; - -- hence it's safe to neglect tyvars free in tys when making - -- the free-var set for this call - -- BUT I don't trust this reasoning; play safe and include tys_fvs - -- - -- We don't include the 'id' itself. + -- The type args (tys) are guaranteed to be part of the dictionary + -- types, because they are just the constrained types, + -- and the dictionary is therefore sure to be bound + -- inside the binding for any type variables free in the type; + -- hence it's safe to neglect tyvars free in tys when making + -- the free-var set for this call + -- BUT I don't trust this reasoning; play safe and include tys_fvs + -- + -- We don't include the 'id' itself. mkCallUDs :: Id -> [CoreExpr] -> UsageDetails -mkCallUDs f args +mkCallUDs f args | not (want_calls_for f) -- Imported from elsewhere - || null theta -- Not overloaded - || not (all isClassPred theta) - -- Only specialise if all overloading is on class params. - -- In ptic, with implicit params, the type args - -- *don't* say what the value of the implicit param is! + || null theta -- Not overloaded + || not (all isClassPred theta) + -- Only specialise if all overloading is on class params. + -- In ptic, with implicit params, the type args + -- *don't* say what the value of the implicit param is! || not (spec_tys `lengthIs` n_tyvars) || not ( dicts `lengthIs` n_dicts) - || not (any interestingDict dicts) -- Note [Interesting dictionary arguments] + || not (any interestingDict dicts) -- Note [Interesting dictionary arguments] -- See also Note [Specialisations already covered] = -- pprTrace "mkCallUDs: discarding" _trace_doc - emptyUDs -- Not overloaded, or no specialisation wanted + emptyUDs -- Not overloaded, or no specialisation wanted | otherwise = -- pprTrace "mkCallUDs: keeping" _trace_doc @@ -1587,16 +1591,16 @@ mkCallUDs f args _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts , ppr (map interestingDict dicts)] (tyvars, theta, _) = tcSplitSigmaTy (idType f) - constrained_tyvars = tyVarsOfTypes theta - n_tyvars = length tyvars - n_dicts = length theta + constrained_tyvars = tyVarsOfTypes theta + n_tyvars = length tyvars + n_dicts = length theta spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args] dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)] - - mk_spec_ty tyvar ty - | tyvar `elemVarSet` constrained_tyvars = Just ty - | otherwise = Nothing + + mk_spec_ty tyvar ty + | tyvar `elemVarSet` constrained_tyvars = Just ty + | otherwise = Nothing want_calls_for f = isLocalId f || isInlinablePragma (idInlinePragma f) \end{code} @@ -1604,32 +1608,32 @@ mkCallUDs f args Note [Interesting dictionary arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this - \a.\d:Eq a. let f = ... in ...(f d)... + \a.\d:Eq a. let f = ... in ...(f d)... There really is not much point in specialising f wrt the dictionary d, because the code for the specialised f is not improved at all, because d is lambda-bound. We simply get junk specialisations. -What is "interesting"? Just that it has *some* structure. +What is "interesting"? Just that it has *some* structure. \begin{code} interestingDict :: CoreExpr -> Bool -- A dictionary argument is interesting if it has *some* structure interestingDict (Var v) = hasSomeUnfolding (idUnfolding v) - || isDataConWorkId v -interestingDict (Type _) = False + || isDataConWorkId v +interestingDict (Type _) = False interestingDict (Coercion _) = False interestingDict (App fn (Type _)) = interestingDict fn interestingDict (App fn (Coercion _)) = interestingDict fn interestingDict (Tick _ a) = interestingDict a -interestingDict (Cast e _) = interestingDict e +interestingDict (Cast e _) = interestingDict e interestingDict _ = True \end{code} \begin{code} plusUDs :: UsageDetails -> UsageDetails -> UsageDetails plusUDs (MkUD {ud_binds = db1, ud_calls = calls1}) - (MkUD {ud_binds = db2, ud_calls = calls2}) - = MkUD { ud_binds = db1 `unionBags` db2 + (MkUD {ud_binds = db2, ud_calls = calls2}) + = MkUD { ud_binds = db1 `unionBags` db2 , ud_calls = calls1 `unionCalls` calls2 } plusUDList :: [UsageDetails] -> UsageDetails @@ -1644,18 +1648,18 @@ mkDB bind = (bind, bind_fvs bind) bind_fvs :: CoreBind -> VarSet bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) -bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs - where - bndrs = map fst prs - rhs_fvs = unionVarSets (map pair_fvs prs) +bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs + where + bndrs = map fst prs + rhs_fvs = unionVarSets (map pair_fvs prs) pair_fvs :: (Id, CoreExpr) -> VarSet pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr - -- Don't forget variables mentioned in the - -- rules of the bndr. C.f. OccAnal.addRuleUsage - -- Also tyvars mentioned in its type; they may not appear in the RHS - -- type T a = Int - -- x :: T a = 3 + -- Don't forget variables mentioned in the + -- rules of the bndr. C.f. OccAnal.addRuleUsage + -- Also tyvars mentioned in its type; they may not appear in the RHS + -- type T a = Int + -- x :: T a = 3 flattenDictBinds :: Bag DictBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] flattenDictBinds dbs pairs @@ -1667,7 +1671,7 @@ flattenDictBinds dbs pairs snocDictBinds :: UsageDetails -> [CoreBind] -> UsageDetails -- Add ud_binds to the tail end of the bindings in uds snocDictBinds uds dbs - = uds { ud_binds = ud_binds uds `unionBags` + = uds { ud_binds = ud_binds uds `unionBags` foldr (consBag . mkDB) emptyBag dbs } consDictBind :: CoreBind -> UsageDetails -> UsageDetails @@ -1703,8 +1707,8 @@ dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) bndr_set = mkVarSet bndrs (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor - deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be - -- no calls for any of the dicts in dump_dbs + deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be + -- no calls for any of the dicts in dump_dbs dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool) -- Used at a lambda or case binder; just dump anything mentioning the binder @@ -1721,24 +1725,24 @@ dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) = -- pprTrace ("callsForMe") - -- (vcat [ppr fn, - -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), + -- (vcat [ppr fn, + -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), -- text "Orig calls =" <+> ppr orig_calls, - -- text "Dep set =" <+> ppr dep_set, + -- text "Dep set =" <+> ppr dep_set, -- text "Calls for me =" <+> ppr calls_for_me]) $ (uds_without_me, calls_for_me) where uds_without_me = MkUD { ud_binds = orig_dbs, ud_calls = delVarEnv orig_calls fn } calls_for_me = case lookupVarEnv orig_calls fn of - Nothing -> [] - Just (CIS _ calls) -> filter_dfuns (Map.toList calls) + Nothing -> [] + Just (CIS _ calls) -> filter_dfuns (Map.toList calls) dep_set = foldlBag go (unitVarSet fn) orig_dbs go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set = extendVarSetList dep_set (bindersOf db) | otherwise = dep_set - -- Note [Specialisation of dictionary functions] + -- Note [Specialisation of dictionary functions] filter_dfuns | isDFunId fn = filter ok_call | otherwise = \cs -> cs @@ -1749,21 +1753,21 @@ splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) -- Returns (free_dbs, dump_dbs, dump_set) splitDictBinds dbs bndr_set = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs - -- Important that it's foldl not foldr; - -- we're accumulating the set of dumped ids in dump_set + -- Important that it's foldl not foldr; + -- we're accumulating the set of dumped ids in dump_set where split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs) - | dump_idset `intersectsVarSet` fvs -- Dump it - = (free_dbs, dump_dbs `snocBag` db, - extendVarSetList dump_idset (bindersOf bind)) + | dump_idset `intersectsVarSet` fvs -- Dump it + = (free_dbs, dump_dbs `snocBag` db, + extendVarSetList dump_idset (bindersOf bind)) - | otherwise -- Don't dump it - = (free_dbs `snocBag` db, dump_dbs, dump_idset) + | otherwise -- Don't dump it + = (free_dbs `snocBag` db, dump_dbs, dump_idset) ---------------------- deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails --- Remove calls *mentioning* bs +-- Remove calls *mentioning* bs deleteCallsMentioning bs calls = mapVarEnv filter_calls calls where @@ -1778,17 +1782,45 @@ deleteCallsFor bs calls = delVarEnvList calls bs %************************************************************************ -%* * +%* * \subsubsection{Boring helper functions} -%* * +%* * %************************************************************************ \begin{code} -type SpecM a = UniqSM a - -runSpecM:: SpecM a -> CoreM a -runSpecM spec = do { us <- getUniqueSupplyM - ; return (initUs_ us spec) } +newtype SpecM a = SpecM (State SpecState a) + +data SpecState = SpecState { + spec_uniq_supply :: UniqSupply, + spec_dflags :: DynFlags + } + +instance Monad SpecM where + SpecM x >>= f = SpecM $ do y <- x + case f y of + SpecM z -> + z + return x = SpecM $ return x + fail str = SpecM $ fail str + +instance MonadUnique SpecM where + getUniqueSupplyM + = SpecM $ do st <- get + let (us1, us2) = splitUniqSupply $ spec_uniq_supply st + put $ st { spec_uniq_supply = us2 } + return us1 + +instance HasDynFlags SpecM where + getDynFlags = SpecM $ liftM spec_dflags get + +runSpecM :: DynFlags -> SpecM a -> CoreM a +runSpecM dflags (SpecM spec) + = do us <- getUniqueSupplyM + let initialState = SpecState { + spec_uniq_supply = us, + spec_dflags = dflags + } + return $ evalState spec initialState mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) mapAndCombineSM _ [] = return ([], emptyUDs) @@ -1812,42 +1844,42 @@ cloneBindSM subst (Rec pairs) = do newDictBndrs :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr]) -- Make up completely fresh binders for the dictionaries -- Their bindings are going to float outwards -newDictBndrs subst bndrs +newDictBndrs subst bndrs = do { bndrs' <- mapM new bndrs - ; let subst' = extendIdSubstList subst + ; let subst' = extendIdSubstList subst [(d, Var d') | (d,d') <- bndrs `zip` bndrs'] ; return (subst', bndrs' ) } where new b = do { uniq <- getUniqueM - ; let n = idName b + ; let n = idName b ty' = CoreSubst.substTy subst (idType b) ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) } newSpecIdSM :: Id -> Type -> SpecM Id -- Give the new Id a similar occurrence name to the old one newSpecIdSM old_id new_ty - = do { uniq <- getUniqueM - ; let name = idName old_id - new_occ = mkSpecOcc (nameOccName name) - new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name) + = do { uniq <- getUniqueM + ; let name = idName old_id + new_occ = mkSpecOcc (nameOccName name) + new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name) ; return new_id } \end{code} - Old (but interesting) stuff about unboxed bindings - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Old (but interesting) stuff about unboxed bindings + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What should we do when a value is specialised to a *strict* unboxed value? - map_*_* f (x:xs) = let h = f x - t = map f xs - in h:t + map_*_* f (x:xs) = let h = f x + t = map f xs + in h:t Could convert let to case: - map_*_Int# f (x:xs) = case f x of h# -> - let t = map f xs - in h#:t + map_*_Int# f (x:xs) = case f x of h# -> + let t = map f xs + in h#:t This may be undesirable since it forces evaluation here, but the value may not be used in all branches of the body. In the general case this @@ -1860,10 +1892,10 @@ implementation cannot handle unboxed values at the top level. Solution: Lift the binding of the unboxed value and extract it when it is used: - map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h# - t = map f xs - in case h of - _Lift h# -> h#:t + map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h# + t = map f xs + in case h of + _Lift h# -> h#:t Now give it to the simplifier and the _Lifting will be optimised away. @@ -1876,20 +1908,20 @@ In particular, the value will only be evaluted in the branches of the program which use it, rather than being forced at the point where the value is bound. For example: - filtermap_*_* p f (x:xs) - = let h = f x - t = ... - in case p x of - True -> h:t - False -> t + filtermap_*_* p f (x:xs) + = let h = f x + t = ... + in case p x of + True -> h:t + False -> t ==> - filtermap_*_Int# p f (x:xs) - = let h = case (f x) of h# -> _Lift h# - t = ... - in case p x of - True -> case h of _Lift h# - -> h#:t - False -> t + filtermap_*_Int# p f (x:xs) + = let h = case (f x) of h# -> _Lift h# + t = ... + in case p x of + True -> case h of _Lift h# + -> h#:t + False -> t The binding for h can still be inlined in the one branch and the _Lifting eliminated. diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 98e5303b02..6dc091961a 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -277,7 +277,7 @@ mkTopStgRhs :: DynFlags -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs -mkTopStgRhs _ rhs_fvs srt binder_info (StgLam _ bndrs body) +mkTopStgRhs _ rhs_fvs srt binder_info (StgLam bndrs body) = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant @@ -343,7 +343,7 @@ coreToStgExpr expr@(Lam _ _) fvs = args' `minusFVBinders` body_fvs escs = body_escs `delVarSetList` args' result_expr | null args' = body - | otherwise = StgLam (exprType expr) args' body + | otherwise = StgLam args' body return (result_expr, fvs, escs) @@ -363,6 +363,18 @@ coreToStgExpr (Cast expr _) -- Cases require a little more real work. +coreToStgExpr (Case scrut _ _ []) + = coreToStgExpr scrut + -- See Note [Empty case alternatives] in CoreSyn If the case + -- alternatives are empty, the scrutinee must diverge or raise an + -- exception, so we can just dive into it. + -- + -- Of course this may seg-fault if the scrutinee *does* return. A + -- belt-and-braces approach would be to move this case into the + -- code generator, and put a return point anyway that calls a + -- runtime system error function. + + coreToStgExpr (Case scrut bndr _ alts) = do (alts2, alts_fvs, alts_escs) <- extendVarEnvLne [(bndr, LambdaBound)] $ do @@ -442,15 +454,15 @@ coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) \begin{code} mkStgAltType :: Id -> [CoreAlt] -> AltType -mkStgAltType bndr alts - = case tyConAppTyCon_maybe (repType (idType bndr)) of - Just tc | isUnboxedTupleTyCon tc -> UbxTupAlt tc - | isUnLiftedTyCon tc -> PrimAlt tc - | isAbstractTyCon tc -> look_for_better_tycon - | isAlgTyCon tc -> AlgAlt tc - | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) - PolyAlt - Nothing -> PolyAlt +mkStgAltType bndr alts = case repType (idType bndr) of + UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of + Just tc | isUnLiftedTyCon tc -> PrimAlt tc + | isAbstractTyCon tc -> look_for_better_tycon + | isAlgTyCon tc -> AlgAlt tc + | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) + PolyAlt + Nothing -> PolyAlt + UbxTupleRep rep_tys -> UbxTupAlt (length rep_tys) where _is_poly_alt_tycon tc @@ -545,7 +557,7 @@ coreToStgApp _ f args = do StgOpApp (StgPrimOp op) args' res_ty -- A call to some primitive Cmm function. - FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _)) + FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId) True) PrimCallConv _)) -> ASSERT( saturated ) StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty @@ -611,7 +623,8 @@ coreToStgArgs (arg : args) = do -- Non-type argument arg_ty = exprType arg stg_arg_ty = stgArgType stg_arg bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty)) - || (typePrimRep arg_ty /= typePrimRep stg_arg_ty) + || (map typePrimRep (flattenRepType (repType arg_ty)) + /= map typePrimRep (flattenRepType (repType stg_arg_ty))) -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted), -- and pass it to a function expecting an HValue (arg_ty). This is ok because -- we can treat an unlifted value as lifted. But the other way round @@ -771,7 +784,7 @@ mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs mkStgRhs _ _ _ (StgConApp con args) = StgRhsCon noCCS con args -mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body) +mkStgRhs rhs_fvs srt binder_info (StgLam bndrs body) = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index ea1fab7eea..852202f5f7 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -4,13 +4,6 @@ \section[StgLint]{A ``lint'' pass to check for Stg correctness} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgLint ( lintStgBindings ) where import StgSyn @@ -33,6 +26,7 @@ import SrcLoc import Outputable import FastString import Control.Monad +import Data.Function #include "HsVersions.h" \end{code} @@ -90,7 +84,6 @@ lintStgBindings whodunnit binds lintStgArg :: StgArg -> LintM (Maybe Type) lintStgArg (StgLitArg lit) = return (Just (literalType lit)) lintStgArg (StgVarArg v) = lintStgVar v -lintStgArg a = pprPanic "lintStgArg" (ppr a) lintStgVar :: Id -> LintM (Maybe Kind) lintStgVar v = do checkInScope v @@ -121,10 +114,10 @@ lint_binds_help (binder, rhs) (mkUnLiftedTyMsg binder rhs) -- Check match to RHS type - -- Actually we *can't* check the RHS type, because - -- unsafeCoerce means it really might not match at all - -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce... - -- case maybe_rhs_ty of + -- Actually we *can't* check the RHS type, because + -- unsafeCoerce means it really might not match at all + -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce... + -- case maybe_rhs_ty of -- Nothing -> return () -- Just rhs_ty -> checkTys binder_ty -- rhs_ty @@ -182,7 +175,7 @@ lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args return res_ty -lintStgExpr (StgLam _ bndrs _) = do +lintStgExpr (StgLam bndrs _) = do addErrL (ptext (sLit "Unexpected StgLam") <+> ppr bndrs) return Nothing @@ -203,18 +196,19 @@ lintStgExpr (StgSCC _ _ _ expr) = lintStgExpr expr lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do _ <- MaybeT $ lintStgExpr scrut - MaybeT $ liftM Just $ + in_scope <- MaybeT $ liftM Just $ case alts_type of - AlgAlt tc -> check_bndr tc - PrimAlt tc -> check_bndr tc - UbxTupAlt tc -> check_bndr tc - PolyAlt -> return () + AlgAlt tc -> check_bndr tc >> return True + PrimAlt tc -> check_bndr tc >> return True + UbxTupAlt _ -> return False -- Binder is always dead in this case + PolyAlt -> return True - MaybeT $ addInScopeVars [bndr] $ + MaybeT $ addInScopeVars [bndr | in_scope] $ lintStgAlts alts scrut_ty where - scrut_ty = idType bndr - check_bndr tc = case tyConAppTyCon_maybe (repType scrut_ty) of + scrut_ty = idType bndr + UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple + check_bndr tc = case tyConAppTyCon_maybe scrut_rep of Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr Nothing -> addErrL bad_bndr where @@ -237,8 +231,8 @@ lintStgAlts alts scrut_ty = do return (Just first_ty) where -- check ty = checkTys first_ty ty (mkCaseAltMsg alts) - -- We can't check that the alternatives have the - -- same type, becuase they don't, with unsafeCoerce# + -- We can't check that the alternatives have the + -- same type, becuase they don't, with unsafeCoerce# lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type) lintAlt _ (DEFAULT, _, _, rhs) @@ -398,8 +392,8 @@ checkFunApp fun_ty arg_tys msg where (mb_ty, mb_msg) = cfa True fun_ty arg_tys - cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? - , Maybe MsgDoc) -- Errors? + cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? + , Maybe MsgDoc) -- Errors? cfa accurate fun_ty [] -- Args have run out; that's fine = (if accurate then Just fun_ty else Nothing, Nothing) @@ -438,28 +432,31 @@ stgEqType :: Type -> Type -> Bool -- Fundamentally this is a losing battle because of unsafeCoerce stgEqType orig_ty1 orig_ty2 - = go rep_ty1 rep_ty2 + = gos (repType orig_ty1) (repType orig_ty2) where - rep_ty1 = deepRepType orig_ty1 - rep_ty2 = deepRepType orig_ty2 + gos :: RepType -> RepType -> Bool + gos (UbxTupleRep tys1) (UbxTupleRep tys2) + = equalLength tys1 tys2 && and (zipWith go tys1 tys2) + gos (UnaryRep ty1) (UnaryRep ty2) = go ty1 ty2 + gos _ _ = False + + go :: UnaryType -> UnaryType -> Bool go ty1 ty2 | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1 , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2 , let res = if tc1 == tc2 - then equalLength tc_args1 tc_args2 - && and (zipWith go tc_args1 tc_args2) - else -- TyCons don't match; but don't bleat if either is a - -- family TyCon because a coercion might have made it - -- equal to something else - (isFamilyTyCon tc1 || isFamilyTyCon tc2) + then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` repType) tc_args1 tc_args2) + else -- TyCons don't match; but don't bleat if either is a + -- family TyCon because a coercion might have made it + -- equal to something else + (isFamilyTyCon tc1 || isFamilyTyCon tc2) = if res then True else - pprTrace "stgEqType: unequal" (vcat [ppr orig_ty1, ppr orig_ty2, ppr rep_ty1 - , ppr rep_ty2, ppr ty1, ppr ty2]) + pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2]) False | otherwise = True -- Conservatively say "fine". - -- Type variables in particular + -- Type variables in particular checkInScope :: Id -> LintM () checkInScope id = LintM $ \loc scope errs diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index defec7516b..3e801c6328 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -35,7 +35,7 @@ module StgSyn ( -- utils stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, - isDllConApp, isStgTypeArg, + isDllConApp, stgArgType, pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, @@ -67,6 +67,7 @@ import Type ( Type ) import Type ( typePrimRep ) import UniqSet import Unique ( Unique ) +import Util import VarSet ( IdSet, isEmptyVarSet ) \end{code} @@ -99,11 +100,6 @@ data GenStgBinding bndr occ data GenStgArg occ = StgVarArg occ | StgLitArg Literal - | StgTypeArg Type -- For when we want to preserve all type info - -isStgTypeArg :: StgArg -> Bool -isStgTypeArg (StgTypeArg _) = True -isStgTypeArg _ = False -- | Does this constructor application refer to -- anything in a different *Windows* DLL? @@ -114,6 +110,8 @@ isDllConApp dflags con args = isDllName this_pkg (dataConName con) || any is_dll_arg args | otherwise = False where + -- NB: typePrimRep is legit because any free variables won't have + -- unlifted type (there are no unlifted things at top level) is_dll_arg :: StgArg -> Bool is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v)) && isDllName this_pkg (idName v) @@ -144,7 +142,6 @@ isAddrRep _ = False stgArgType :: StgArg -> Type stgArgType (StgVarArg v) = idType v stgArgType (StgLitArg lit) = literalType lit -stgArgType (StgTypeArg _) = panic "stgArgType called on stgTypeArg" \end{code} %************************************************************************ @@ -212,8 +209,6 @@ finished it encodes (\x -> e) as (let f = \x -> e in f) \begin{code} | StgLam - Type -- Type of whole lambda (useful when - -- making a binder for it) [bndr] StgExpr -- Body of lambda \end{code} @@ -520,7 +515,7 @@ type GenStgAlt bndr occ data AltType = PolyAlt -- Polymorphic (a type variable) - | UbxTupAlt TyCon -- Unboxed tuple + | UbxTupAlt Int -- Unboxed tuple of this arity | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts \end{code} @@ -636,11 +631,11 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he likes terminators instead... Ditto for case alternatives. \begin{code} -pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) +pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgBinding bndr bdee -> SDoc pprGenStgBinding (StgNonRec bndr rhs) - = hang (hsep [ppr bndr, equals]) + = hang (hsep [pprBndr LetBind bndr, equals]) 4 ((<>) (ppr rhs) semi) pprGenStgBinding (StgRec pairs) @@ -648,7 +643,7 @@ pprGenStgBinding (StgRec pairs) map (ppr_bind) pairs ++ [ifPprDebug $ ptext $ sLit "{- StgRec (end) -}"] where ppr_bind (bndr, expr) - = hang (hsep [ppr bndr, equals]) + = hang (hsep [pprBndr LetBind bndr, equals]) 4 ((<>) (ppr expr) semi) pprStgBinding :: StgBinding -> SDoc @@ -657,7 +652,7 @@ pprStgBinding bind = pprGenStgBinding bind pprStgBindings :: [StgBinding] -> SDoc pprStgBindings binds = vcat (map pprGenStgBinding binds) -pprGenStgBindingWithSRT :: (Outputable bndr, Outputable bdee, Ord bdee) +pprGenStgBindingWithSRT :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc pprGenStgBindingWithSRT (bind,srts) = vcat $ pprGenStgBinding bind : map pprSRT srts @@ -670,24 +665,23 @@ pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds) instance (Outputable bdee) => Outputable (GenStgArg bdee) where ppr = pprStgArg -instance (Outputable bndr, Outputable bdee, Ord bdee) +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) => Outputable (GenStgBinding bndr bdee) where ppr = pprGenStgBinding -instance (Outputable bndr, Outputable bdee, Ord bdee) +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) => Outputable (GenStgExpr bndr bdee) where ppr = pprStgExpr -instance (Outputable bndr, Outputable bdee, Ord bdee) +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) => Outputable (GenStgRhs bndr bdee) where ppr rhs = pprStgRhs rhs pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc pprStgArg (StgVarArg var) = ppr var pprStgArg (StgLitArg con) = ppr con -pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty -pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) +pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgExpr bndr bdee -> SDoc -- special case pprStgExpr (StgLit lit) = ppr lit @@ -702,9 +696,11 @@ pprStgExpr (StgConApp con args) pprStgExpr (StgOpApp op args _) = hsep [ pprStgOp op, brackets (interppSP args)] -pprStgExpr (StgLam _ bndrs body) - =sep [ char '\\' <+> ppr bndrs <+> ptext (sLit "->"), +pprStgExpr (StgLam bndrs body) + = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs) + <+> ptext (sLit "->"), pprStgExpr body ] + where ppr_list = brackets . fsep . punctuate comma -- special case: let v = <very specific thing> -- in @@ -767,7 +763,7 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) = sep [sep [ptext (sLit "case"), nest 4 (hsep [pprStgExpr expr, ifPprDebug (dcolon <+> ppr alt_type)]), - ptext (sLit "of"), ppr bndr, char '{'], + ptext (sLit "of"), pprBndr CaseBind bndr, char '{'], ifPprDebug ( nest 4 ( hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), @@ -777,10 +773,10 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) nest 2 (vcat (map pprStgAlt alts)), char '}'] -pprStgAlt :: (Outputable bndr, Outputable occ, Ord occ) +pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ) => GenStgAlt bndr occ -> SDoc pprStgAlt (con, params, _use_mask, expr) - = hang (hsep [ppr con, interppSP params, ptext (sLit "->")]) + = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), ptext (sLit "->")]) 4 (ppr expr <> semi) pprStgOp :: StgOp -> SDoc @@ -790,7 +786,7 @@ pprStgOp (StgFCallOp op _) = ppr op instance Outputable AltType where ppr PolyAlt = ptext (sLit "Polymorphic") - ppr (UbxTupAlt tc) = ptext (sLit "UbxTup") <+> ppr tc + ppr (UbxTupAlt n) = ptext (sLit "UbxTup") <+> ppr n ppr (AlgAlt tc) = ptext (sLit "Alg") <+> ppr tc ppr (PrimAlt tc) = ptext (sLit "Prim") <+> ppr tc @@ -802,7 +798,7 @@ pprStgLVs lvs else hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"] -pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) +pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgRhs bndr bdee -> SDoc -- special case diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 0bfd025410..ddeb1aa864 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -44,7 +44,7 @@ import UniqFM ( addToUFM_Directly, lookupUFM_Directly, minusUFM, filterUFM ) import Type ( isUnLiftedType, eqType, tyConAppTyCon_maybe ) import Coercion ( coercionKind ) -import Util ( mapAndUnzip, lengthIs, zipEqual ) +import Util import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, RecFlag(..), isRec, isMarkedStrict ) import Maybes ( orElse, expectJust ) @@ -277,7 +277,7 @@ dmdAnal env dmd (Case scrut case_bndr ty alts) = let (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd) alts (scrut_ty, scrut') = dmdAnal env evalDmd scrut - (alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr + (alt_ty, case_bndr') = annotateBndr (foldr lubType botDmdType alt_tys) case_bndr res_ty = alt_ty `bothType` scrut_ty in -- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut @@ -592,7 +592,7 @@ mkSigTy top_lvl rec_flag id rhs dmd_ty maybe_id_dmd = idDemandInfo_maybe id -- Is Nothing the first time round - thunk_cpr_ok + thunk_cpr_ok -- See Note [CPR for thunks] | isTopLevel top_lvl = False -- Top level things don't get -- their demandInfo set at all | isRec rec_flag = False -- Ditto recursive things @@ -601,8 +601,8 @@ mkSigTy top_lvl rec_flag id rhs dmd_ty -- See notes below \end{code} -The thunk_cpr_ok stuff [CPR-AND-STRICTNESS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [CPR for thunks] +~~~~~~~~~~~~~~~~~~~~~ If the rhs is a thunk, we usually forget the CPR info, because it is presumably shared (else it would have been inlined, and so we'd lose sharing if w/w'd it into a function). E.g. @@ -662,8 +662,8 @@ have a CPR in it or not. Simple solution: NB: strictly_demanded is never true of a top-level Id, or of a recursive Id. -The Nothing case in thunk_cpr_ok [CPR-AND-STRICTNESS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Optimistic in the Nothing case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Demand info now has a 'Nothing' state, just like strictness info. The analysis works from 'dangerous' towards a 'safe' state; so we start with botSig for 'Nothing' strictness infos, and we start with @@ -1010,8 +1010,7 @@ extendSigsWithLam :: AnalEnv -> Id -> AnalEnv extendSigsWithLam env id = case idDemandInfo_maybe id of Nothing -> extendAnalEnv NotTopLevel env id cprSig - -- Optimistic in the Nothing case; - -- See notes [CPR-AND-STRICTNESS] + -- See Note [Optimistic in the Nothing case] Just (Eval (Prod _)) -> extendAnalEnv NotTopLevel env id cprSig _ -> env \end{code} diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 2c365887bc..e5013debd1 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -24,10 +24,11 @@ import IdInfo import Demand import UniqSupply import BasicTypes +import DynFlags import VarEnv ( isEmptyVarEnv ) import Maybes ( orElse ) import WwLib -import Util ( lengthIs, notNull ) +import Util import Outputable import MonadUtils @@ -61,11 +62,11 @@ info for exported values). \end{enumerate} \begin{code} -wwTopBinds :: UniqSupply -> CoreProgram -> CoreProgram +wwTopBinds :: DynFlags -> UniqSupply -> CoreProgram -> CoreProgram -wwTopBinds us top_binds +wwTopBinds dflags us top_binds = initUs_ us $ do - top_binds' <- mapM wwBind top_binds + top_binds' <- mapM (wwBind dflags) top_binds return (concat top_binds') \end{code} @@ -79,23 +80,24 @@ wwTopBinds us top_binds turn. Non-recursive case first, then recursive... \begin{code} -wwBind :: CoreBind +wwBind :: DynFlags + -> CoreBind -> UniqSM [CoreBind] -- returns a WwBinding intermediate form; -- the caller will convert to Expr/Binding, -- as appropriate. -wwBind (NonRec binder rhs) = do - new_rhs <- wwExpr rhs - new_pairs <- tryWW NonRecursive binder new_rhs +wwBind dflags (NonRec binder rhs) = do + new_rhs <- wwExpr dflags rhs + new_pairs <- tryWW dflags NonRecursive binder new_rhs return [NonRec b e | (b,e) <- new_pairs] -- Generated bindings must be non-recursive -- because the original binding was. -wwBind (Rec pairs) +wwBind dflags (Rec pairs) = return . Rec <$> concatMapM do_one pairs where - do_one (binder, rhs) = do new_rhs <- wwExpr rhs - tryWW Recursive binder new_rhs + do_one (binder, rhs) = do new_rhs <- wwExpr dflags rhs + tryWW dflags Recursive binder new_rhs \end{code} @wwExpr@ basically just walks the tree, looking for appropriate @@ -104,36 +106,36 @@ matching by looking for strict arguments of the correct type. @wwExpr@ is a version that just returns the ``Plain'' Tree. \begin{code} -wwExpr :: CoreExpr -> UniqSM CoreExpr +wwExpr :: DynFlags -> CoreExpr -> UniqSM CoreExpr -wwExpr e@(Type {}) = return e -wwExpr e@(Coercion {}) = return e -wwExpr e@(Lit {}) = return e -wwExpr e@(Var {}) = return e +wwExpr _ e@(Type {}) = return e +wwExpr _ e@(Coercion {}) = return e +wwExpr _ e@(Lit {}) = return e +wwExpr _ e@(Var {}) = return e -wwExpr (Lam binder expr) - = Lam binder <$> wwExpr expr +wwExpr dflags (Lam binder expr) + = Lam binder <$> wwExpr dflags expr -wwExpr (App f a) - = App <$> wwExpr f <*> wwExpr a +wwExpr dflags (App f a) + = App <$> wwExpr dflags f <*> wwExpr dflags a -wwExpr (Tick note expr) - = Tick note <$> wwExpr expr +wwExpr dflags (Tick note expr) + = Tick note <$> wwExpr dflags expr -wwExpr (Cast expr co) = do - new_expr <- wwExpr expr +wwExpr dflags (Cast expr co) = do + new_expr <- wwExpr dflags expr return (Cast new_expr co) -wwExpr (Let bind expr) - = mkLets <$> wwBind bind <*> wwExpr expr +wwExpr dflags (Let bind expr) + = mkLets <$> wwBind dflags bind <*> wwExpr dflags expr -wwExpr (Case expr binder ty alts) = do - new_expr <- wwExpr expr +wwExpr dflags (Case expr binder ty alts) = do + new_expr <- wwExpr dflags expr new_alts <- mapM ww_alt alts return (Case new_expr binder ty new_alts) where ww_alt (con, binders, rhs) = do - new_rhs <- wwExpr rhs + new_rhs <- wwExpr dflags rhs return (con, binders, new_rhs) \end{code} @@ -237,7 +239,8 @@ so that it becomes active in an importing module at the same time that it appears in the first place in the defining module. \begin{code} -tryWW :: RecFlag +tryWW :: DynFlags + -> RecFlag -> Id -- The fn binder -> CoreExpr -- The bound rhs; its innards -- are already ww'd @@ -246,7 +249,7 @@ tryWW :: RecFlag -- the orig "wrapper" lives on); -- if two, then a worker and a -- wrapper. -tryWW is_rec fn_id rhs +tryWW dflags is_rec fn_id rhs | isNeverActive inline_act -- No point in worker/wrappering if the thing is never inlined! -- Because the no-inline prag will prevent the wrapper ever @@ -259,11 +262,11 @@ tryWW is_rec fn_id rhs -- See Note [Thunk splitting] = ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive checkSize new_fn_id rhs $ - splitThunk new_fn_id rhs + splitThunk dflags new_fn_id rhs | is_fun && worthSplittingFun wrap_dmds res_info = checkSize new_fn_id rhs $ - splitFun new_fn_id fn_info wrap_dmds res_info rhs + splitFun dflags new_fn_id fn_info wrap_dmds res_info rhs | otherwise = return [ (new_fn_id, rhs) ] @@ -312,13 +315,13 @@ checkSize fn_id rhs thing_inside inline_rule = mkInlineUnfolding Nothing rhs --------------------- -splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var +splitFun :: DynFlags -> Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var -> UniqSM [(Id, CoreExpr)] -splitFun fn_id fn_info wrap_dmds res_info rhs +splitFun dflags fn_id fn_info wrap_dmds res_info rhs = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) (do { -- The arity should match the signature - (work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots + (work_demands, wrap_fn, work_fn) <- mkWwBodies dflags fun_ty wrap_dmds res_info one_shots ; work_uniq <- getUniqueM ; let work_rhs = work_fn rhs @@ -439,9 +442,9 @@ then the splitting will go deeper too. -- --> x = let x = e in -- case x of (a,b) -> let x = (a,b) in x -splitThunk :: Var -> Expr Var -> UniqSM [(Var, Expr Var)] -splitThunk fn_id rhs = do - (_, wrap_fn, work_fn) <- mkWWstr [fn_id] +splitThunk :: DynFlags -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] +splitThunk dflags fn_id rhs = do + (_, wrap_fn, work_fn) <- mkWWstr dflags [fn_id] return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] \end{code} @@ -501,12 +504,13 @@ unboxed thing to f, and have it reboxed in the error cases....] the function and the name of its worker, and we want to make its body (the wrapper). \begin{code} -mkWrapper :: Type -- Wrapper type +mkWrapper :: DynFlags + -> Type -- Wrapper type -> StrictSig -- Wrapper strictness info -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id -mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) = do - (_, wrap_fn, _) <- mkWwBodies fun_ty demands res_info noOneShotInfo +mkWrapper dflags fun_ty (StrictSig (DmdType _ demands res_info)) = do + (_, wrap_fn, _) <- mkWwBodies dflags fun_ty demands res_info noOneShotInfo return wrap_fn noOneShotInfo :: [Bool] diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 4b18b8ba7d..0ed650bff4 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -37,6 +37,7 @@ import UniqSupply import Unique import Util ( zipWithEqual ) import Outputable +import DynFlags import FastString \end{code} @@ -109,7 +110,8 @@ the unusable strictness-info into the interfaces. @mkWwBodies@ is called when doing the worker\/wrapper split inside a module. \begin{code} -mkWwBodies :: Type -- Type of original function +mkWwBodies :: DynFlags + -> Type -- Type of original function -> [Demand] -- Strictness of original function -> DmdResult -- Info about function result -> [Bool] -- One-shot-ness of the function @@ -128,20 +130,15 @@ mkWwBodies :: Type -- Type of original function -- let x = (a,b) in -- E -mkWwBodies fun_ty demands res_info one_shots +mkWwBodies dflags fun_ty demands res_info one_shots = do { let arg_info = demands `zip` (one_shots ++ repeat False) ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info - ; (work_args, wrap_fn_str, work_fn_str) <- mkWWstr wrap_args + ; (work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags wrap_args - -- Don't do CPR if the worker doesn't have any value arguments - -- Then the worker is just a constant, so we don't want to unbox it. - ; (wrap_fn_cpr, work_fn_cpr, _cpr_res_ty) - <- if any isId work_args then - mkWWcpr res_ty res_info - else - return (id, id, res_ty) + -- Do CPR w/w. See Note [Always do CPR w/w] + ; (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) <- mkWWcpr res_ty res_info - ; let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty + ; let (work_lam_args, work_call_args) = mkWorkerArgs work_args cpr_res_ty ; return ([idDemandInfo v | v <- work_call_args, isId v], wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) } @@ -154,6 +151,18 @@ mkWwBodies fun_ty demands res_info one_shots -- fw from being inlined into f's RHS \end{code} +Note [Always do CPR w/w] +~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we refrained from doing CPR w/w for thunks, on the grounds that +we might duplicate work. But that is already handled by the demand analyser, +which doesn't give the CPR proprety if w/w might waste work: see +Note [CPR for thunks] in DmdAnal. + +And if something *has* been given the CPR property and we don't w/w, it's +a disaster, because then the enclosing function might say it has the CPR +property, but now doesn't and there a cascade of disaster. A good example +is Trac #5920. + %************************************************************************ %* * @@ -313,7 +322,8 @@ That's why we carry the TvSubst through mkWWargs %************************************************************************ \begin{code} -mkWWstr :: [Var] -- Wrapper args; have their demand info on them +mkWWstr :: DynFlags + -> [Var] -- Wrapper args; have their demand info on them -- *Includes type variables* -> UniqSM ([Var], -- Worker args CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call @@ -323,12 +333,12 @@ mkWWstr :: [Var] -- Wrapper args; have their demand info on them CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, -- and lacking its lambdas. -- This fn does the reboxing -mkWWstr [] +mkWWstr _ [] = return ([], nop_fn, nop_fn) -mkWWstr (arg : args) = do - (args1, wrap_fn1, work_fn1) <- mkWWstr_one arg - (args2, wrap_fn2, work_fn2) <- mkWWstr args +mkWWstr dflags (arg : args) = do + (args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags arg + (args2, wrap_fn2, work_fn2) <- mkWWstr dflags args return (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2) ---------------------- @@ -337,8 +347,8 @@ mkWWstr (arg : args) = do -- brings into scope work_args (via cases) -- * work_fn assumes work_args are in scope, a -- brings into scope wrap_arg (via lets) -mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -mkWWstr_one arg +mkWWstr_one :: DynFlags -> Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) +mkWWstr_one dflags arg | isTyVar arg = return ([arg], nop_fn, nop_fn) @@ -348,7 +358,7 @@ mkWWstr_one arg -- Absent case. We can't always handle absence for arbitrary -- unlifted types, so we need to choose just the cases we can -- (that's what mk_absent_let does) - Abs | Just work_fn <- mk_absent_let arg + Abs | Just work_fn <- mk_absent_let dflags arg -> return ([], nop_fn, work_fn) -- Unpack case @@ -362,7 +372,7 @@ mkWWstr_one arg unbox_fn = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con rebox_fn = Let (NonRec arg con_app) con_app = mkProductBox unpk_args (idType arg) - (worker_args, wrap_fn, work_fn) <- mkWWstr unpk_args_w_ds + (worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) -- Don't pass the arg, rebox instead @@ -526,8 +536,8 @@ every primitive type, so the function is partial. using a literal will do.] \begin{code} -mk_absent_let :: Id -> Maybe (CoreExpr -> CoreExpr) -mk_absent_let arg +mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr) +mk_absent_let dflags arg | not (isUnLiftedType arg_ty) = Just (Let (NonRec arg abs_rhs)) | Just tc <- tyConAppTyCon_maybe arg_ty @@ -541,7 +551,7 @@ mk_absent_let arg where arg_ty = idType arg abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg - msg = showSDocDebug (ppr arg <+> ppr (idType arg)) + msg = showSDocDebug dflags (ppr arg <+> ppr (idType arg)) mk_seq_case :: Id -> CoreExpr -> CoreExpr mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)] diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index c873c631da..b6370b5c92 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -24,12 +24,11 @@ import TyCon import DynFlags import Name import Module -import SrcLoc import Outputable import UniqFM +import VarSet import FastString -import VarSet ( varSetElems ) -import Util( filterOut ) +import Util import Maybes import Control.Monad import Data.Map (Map) @@ -84,6 +83,9 @@ instance Eq ModulePair where instance Ord ModulePair where mp1 `compare` mp2 = canon mp1 `compare` canon mp2 +instance Outputable ModulePair where + ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2) + -- Sets of module pairs -- type ModulePairSet = Map ModulePair () @@ -174,11 +176,12 @@ tcLookupFamInst tycon tys = return Nothing | otherwise = do { instEnv <- tcGetFamInstEnvs - ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ ppr instEnv) - ; case lookupFamInstEnv instEnv tycon tys of - [] -> return Nothing + ; let mb_match = lookupFamInstEnv instEnv tycon tys + ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ ppr mb_match $$ ppr instEnv) + ; case mb_match of + [] -> return Nothing ((fam_inst, rep_tys):_) - -> return $ Just (fam_inst, rep_tys) + -> return $ Just (fam_inst, rep_tys) } tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) @@ -251,30 +254,28 @@ addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamIns addLocalFamInst (home_fie, my_fis) fam_inst -- home_fie includes home package and this module -- my_fies is just the ones from this module - = do { isGHCi <- getIsGHCi + = do { traceTc "addLocalFamInst" (ppr fam_inst) + ; isGHCi <- getIsGHCi -- In GHCi, we *override* any identical instances -- that are also defined in the interactive context - ; let (home_fie', my_fis') - | isGHCi = (deleteFromFamInstEnv home_fie fam_inst, - filterOut (identicalFamInst fam_inst) my_fis) - | otherwise = (home_fie, my_fis) + ; let (home_fie', my_fis') + | isGHCi = ( deleteFromFamInstEnv home_fie fam_inst + , filterOut (identicalFamInst fam_inst) my_fis) + | otherwise = (home_fie, my_fis) -- Load imported instances, so that we report -- overlaps correctly ; eps <- getEps - ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars fam_inst)) ; let inst_envs = (eps_fam_inst_env eps, home_fie') - conflicts = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs home_fie'' = extendFamInstEnv home_fie fam_inst -- Check for conflicting instance decls - ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs) - ; case conflicts of - [] -> return (home_fie'', fam_inst : my_fis') - dup : _ -> do { conflictInstErr fam_inst (fst dup) - ; return (home_fie, my_fis) } - } + ; no_conflict <- checkForConflicts inst_envs fam_inst + ; if no_conflict then + return (home_fie'', fam_inst : my_fis') + else + return (home_fie, my_fis) } \end{code} %************************************************************************ @@ -287,8 +288,8 @@ Check whether a single family instance conflicts with those in two instance environments (one for the EPS and one for the HPT). \begin{code} -checkForConflicts :: FamInstEnvs -> FamInst -> TcM () -checkForConflicts inst_envs famInst +checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool +checkForConflicts inst_envs fam_inst = do { -- To instantiate the family instance type, extend the instance -- envt with completely fresh template variables -- This is important because the template variables must @@ -297,23 +298,28 @@ checkForConflicts inst_envs famInst -- We use tcInstSkolType because we don't want to allocate -- fresh *meta* type variables. - ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars famInst)) - ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs - ; unless (null conflicts) $ - conflictInstErr famInst (fst (head conflicts)) - } + ; (_, skol_tvs) <- tcInstSkolTyVars (coAxiomTyVars (famInstAxiom fam_inst)) + ; let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs + no_conflicts = null conflicts + ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs) + ; unless no_conflicts $ + conflictInstErr fam_inst (fst (head conflicts)) + ; return no_conflicts } conflictInstErr :: FamInst -> FamInst -> TcRn () conflictInstErr famInst conflictingFamInst - = addFamInstLoc famInst $ - addErr (hang (ptext (sLit "Conflicting family instance declarations:")) - 2 (pprFamInsts [famInst, conflictingFamInst])) - -addFamInstLoc :: FamInst -> TcRn a -> TcRn a -addFamInstLoc famInst thing_inside - = setSrcSpan (mkSrcSpan loc loc) thing_inside - where - loc = getSrcLoc famInst + = addFamInstsErr (ptext (sLit "Conflicting family instance declarations:")) + [famInst, conflictingFamInst] + +addFamInstsErr :: SDoc -> [FamInst] -> TcRn () +addFamInstsErr herald insts + = setSrcSpan (getSrcSpan (head sorted)) $ + addErr (hang herald 2 (pprFamInsts sorted)) + where + sorted = sortWith getSrcLoc insts + -- The sortWith just arranges that instances are dislayed in order + -- of source location, which reduced wobbling in error messages, + -- and is better for users tcGetFamInstEnvs :: TcM FamInstEnvs -- Gets both the external-package inst-env diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index a194d748ed..bbad59ec6e 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -83,10 +83,11 @@ emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar] emitWanteds origin theta = mapM (emitWanted origin) theta emitWanted :: CtOrigin -> TcPredType -> TcM EvVar -emitWanted origin pred = do { loc <- getCtLoc origin - ; ev <- newWantedEvVar pred - ; emitFlat (mkNonCanonical ev (Wanted loc)) - ; return ev } +emitWanted origin pred + = do { loc <- getCtLoc origin + ; ev <- newWantedEvVar pred + ; emitFlat (mkNonCanonical (Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev })) + ; return ev } newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) -- Used when Name is the wired-in name for a wired-in class method, @@ -152,8 +153,7 @@ deeplySkolemise deeplySkolemise ty | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys - ; tvs1 <- tcInstSkolTyVars tvs - ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs1) + ; (subst, tvs1) <- tcInstSkolTyVars tvs ; ev_vars1 <- newEvVars (substTheta subst theta) ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty') ; return ( mkWpLams ids1 @@ -219,7 +219,7 @@ instCallConstraints _ [] = return idHsWrapper instCallConstraints origin (pred : preds) | Just (ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut - = do { traceTc "instCallConstraints" $ ppr (mkEqPred (ty1, ty2)) + = do { traceTc "instCallConstraints" $ ppr (mkEqPred ty1 ty2) ; co <- unifyType ty1 ty2 ; co_fn <- instCallConstraints origin preds ; return (co_fn <.> WpEvApp (EvCoercion co)) } @@ -475,25 +475,28 @@ traceDFuns ispecs funDepErr :: ClsInst -> [ClsInst] -> TcRn () funDepErr ispec ispecs - = addDictLoc ispec $ - addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:")) - 2 (pprInstances (ispec:ispecs))) + = addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:")) + (ispec : ispecs) + dupInstErr :: ClsInst -> ClsInst -> TcRn () dupInstErr ispec dup_ispec - = addDictLoc ispec $ - addErr (hang (ptext (sLit "Duplicate instance declarations:")) - 2 (pprInstances [ispec, dup_ispec])) + = addClsInstsErr (ptext (sLit "Duplicate instance declarations:")) + [ispec, dup_ispec] + overlappingInstErr :: ClsInst -> ClsInst -> TcRn () overlappingInstErr ispec dup_ispec - = addDictLoc ispec $ - addErr (hang (ptext (sLit "Overlapping instance declarations:")) - 2 (pprInstances [ispec, dup_ispec])) - -addDictLoc :: ClsInst -> TcRn a -> TcRn a -addDictLoc ispec thing_inside - = setSrcSpan (mkSrcSpan loc loc) thing_inside - where - loc = getSrcLoc ispec + = addClsInstsErr (ptext (sLit "Overlapping instance declarations:")) + [ispec, dup_ispec] + +addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () +addClsInstsErr herald ispecs + = setSrcSpan (getSrcSpan (head sorted)) $ + addErr (hang herald 2 (pprInstances sorted)) + where + sorted = sortWith getSrcLoc ispecs + -- The sortWith just arranges that instances are dislayed in order + -- of source location, which reduced wobbling in error messages, + -- and is better for users \end{code} %************************************************************************ @@ -513,22 +516,20 @@ hasEqualities :: [EvVar] -> Bool hasEqualities givens = any (has_eq . evVarPred) givens where has_eq = has_eq' . classifyPredType - + + -- See Note [Float Equalities out of Implications] in TcSimplify has_eq' (EqPred {}) = True - has_eq' (IPPred {}) = False has_eq' (ClassPred cls _tys) = any has_eq (classSCTheta cls) has_eq' (TuplePred ts) = any has_eq ts has_eq' (IrredPred _) = True -- Might have equalities in it after reduction? ---------------- Getting free tyvars ------------------------- - tyVarsOfCt :: Ct -> TcTyVarSet tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys) tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys -tyVarsOfCt (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty tyVarsOfCt (CIrredEvCan { cc_ty = ty }) = tyVarsOfType ty -tyVarsOfCt (CNonCanonical { cc_id = ev }) = tyVarsOfEvVar ev +tyVarsOfCt (CNonCanonical { cc_ev = fl }) = tyVarsOfType (ctEvPred fl) tyVarsOfCDict :: Ct -> TcTyVarSet tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys @@ -562,21 +563,29 @@ tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet ---------------- Tidying ------------------------- tidyCt :: TidyEnv -> Ct -> Ct +-- Used only in error reporting -- Also converts it to non-canonical tidyCt env ct - = CNonCanonical { cc_id = tidyEvVar env (cc_id ct) - , cc_flavor = tidyFlavor env (cc_flavor ct) + = CNonCanonical { cc_ev = tidy_flavor env (cc_ev ct) , cc_depth = cc_depth ct } + where + tidy_flavor :: TidyEnv -> CtEvidence -> CtEvidence + -- NB: we do not tidy the ctev_evtm/var field because we don't + -- show it in error messages + tidy_flavor env ctev@(Given { ctev_gloc = gloc, ctev_pred = pred }) + = ctev { ctev_gloc = tidyGivenLoc env gloc + , ctev_pred = tidyType env pred } + tidy_flavor env ctev@(Wanted { ctev_pred = pred }) + = ctev { ctev_pred = tidyType env pred } + tidy_flavor env ctev@(Derived { ctev_pred = pred }) + = ctev { ctev_pred = tidyType env pred } tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = setVarType var (tidyType env (varType var)) -tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor -tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk -tidyFlavor _ fl = fl - tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc -tidyGivenLoc env (CtLoc skol span ctxt) = CtLoc (tidySkolemInfo env skol) span ctxt +tidyGivenLoc env (CtLoc skol span ctxt) + = CtLoc (tidySkolemInfo env skol) span ctxt tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty) @@ -592,17 +601,20 @@ tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) tidySkolemInfo _ info = info ---------------- Substitution ------------------------- +-- This is used only in TcSimpify, for substituations that are *also* +-- reflected in the unification variables. So we don't substitute +-- in the evidence. + substCt :: TvSubst -> Ct -> Ct -- Conservatively converts it to non-canonical: -- Postcondition: if the constraint does not get rewritten substCt subst ct - | ev <- cc_id ct, pty <- evVarPred (cc_id ct) + | pty <- ctPred ct , sty <- substTy subst pty = if sty `eqType` pty then - ct { cc_flavor = substFlavor subst (cc_flavor ct) } + ct { cc_ev = substFlavor subst (cc_ev ct) } else - CNonCanonical { cc_id = setVarType ev sty - , cc_flavor = substFlavor subst (cc_flavor ct) + CNonCanonical { cc_ev = substFlavor subst (cc_ev ct) , cc_depth = cc_depth ct } substWC :: TvSubst -> WantedConstraints -> WantedConstraints @@ -626,12 +638,20 @@ substImplication subst implic@(Implic { ic_skols = tvs substEvVar :: TvSubst -> EvVar -> EvVar substEvVar subst var = setVarType var (substTy subst (varType var)) -substFlavor :: TvSubst -> CtFlavor -> CtFlavor -substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk -substFlavor _ fl = fl +substFlavor :: TvSubst -> CtEvidence -> CtEvidence +substFlavor subst ctev@(Given { ctev_gloc = gloc, ctev_pred = pred }) + = ctev { ctev_gloc = substGivenLoc subst gloc + , ctev_pred = substTy subst pred } + +substFlavor subst ctev@(Wanted { ctev_pred = pred }) + = ctev { ctev_pred = substTy subst pred } + +substFlavor subst ctev@(Derived { ctev_pred = pty }) + = ctev { ctev_pred = substTy subst pty } substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc -substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt +substGivenLoc subst (CtLoc skol span ctxt) + = CtLoc (substSkolemInfo subst skol) span ctxt substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty) diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 2934cda94b..e15b2adc6e 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -138,7 +138,7 @@ tc_cmd env (HsIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not -- the return value. - ; [r_tv] <- tcInstSkolTyVars [alphaTyVar] + ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] ; let r_ty = mkTyVarTy r_tv ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty ; checkTc (not (r_tv `elemVarSet` tyVarsOfType pred_ty)) @@ -245,7 +245,7 @@ tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..] - ; [w_tv] <- tcInstSkolTyVars [alphaTyVar] + ; (_, [w_tv]) <- tcInstSkolTyVars [alphaTyVar] ; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point -- a ((w,t1) .. tn) t diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index e14bd49458..5eb8e150ef 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -6,9 +6,10 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, - tcHsBootSigs, tcPolyBinds, + tcHsBootSigs, tcPolyBinds, tcPolyCheck, PragFun, tcSpecPrags, tcVectDecls, mkPragFun, - TcSigInfo(..), SigFun, mkSigFun, + TcSigInfo(..), TcSigFun, + instTcTySig, instTcTySigFromId, badBootDeclErr ) where import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) @@ -44,6 +45,9 @@ import Util import BasicTypes import Outputable import FastString +import Type(mkStrLitTy) +import Class(classTyCon) +import PrelNames(ipClassName) import Control.Monad @@ -82,6 +86,65 @@ type-checking the LHS of course requires that the binder is in scope. At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is + + * Bind any variable for which we have a type signature + to an Id with a polymorphic type. Then when type-checking + the RHSs we'll make a full polymorphic call. + +This fine, but if you aren't a bit careful you end up with a horrendous +amount of partial application and (worse) a huge space leak. For example: + + f :: Eq a => [a] -> [a] + f xs = ...f... + +If we don't take care, after typechecking we get + + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... + +Notice the the stupid construction of (f a d), which is of course +identical to the function we're executing. In this case, the +polymorphic recursion isn't being used (but that's a very common case). +This can lead to a massive space leak, from the following top-level defn +(post-typechecking) + + ff :: [Int] -> [Int] + ff = f Int dEqInt + +Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but +f' is another thunk which evaluates to the same thing... and you end +up with a chain of identical values all hung onto by the CAF ff. + + ff = f Int dEqInt + + = let f' = f Int dEqInt in \ys. ...f'... + + = let f' = let f' = f Int dEqInt in \ys. ...f'... + in \ys. ...f'... + +Etc. + +NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), +which would make the space leak go away in this case + +Solution: when typechecking the RHSs we always have in hand the +*monomorphic* Ids for each binding. So we just need to make sure that +if (Method f a d) shows up in the constraints emerging from (...f...) +we just use the monomorphic Id. We achieve this by adding monomorphic Ids +to the "givens" when simplifying constraints. That's what the "lies_avail" +is doing. + +Then we get + + f = /\a -> \d::Eq a -> letrec + fm = \ys:[a] -> ...fm... + in + fm + \begin{code} tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv) -- The TcGblEnv contains the new tcg_binds and tcg_spects @@ -147,7 +210,9 @@ tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds" tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside - = do { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds + = do { ipClass <- tcLookupClass ipClassName + ; (given_ips, ip_binds') <- + mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds -- If the binding binds ?x = E, we must now -- discharge any ?x constraints in expr_lie @@ -157,16 +222,28 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) } where - ips = [ip | L _ (IPBind ip _) <- ip_binds] + ips = [ip | L _ (IPBind (Left ip) _) <- ip_binds] -- I wonder if we should do these one at at time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind (IPBind ip expr) - = do { ty <- newFlexiTyVarTy argTypeKind - ; ip_id <- newIP ip ty + tc_ip_bind ipClass (IPBind (Left ip) expr) + = do { ty <- newFlexiTyVarTy openTypeKind + ; let p = mkStrLitTy $ hsIPNameFS ip + ; ip_id <- newDict ipClass [ p, ty ] ; expr' <- tcMonoExpr expr ty - ; return (ip_id, (IPBind (IPName ip_id) expr')) } + ; let d = toDict ipClass p ty `fmap` expr' + ; return (ip_id, (IPBind (Right ip_id) d)) } + tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind" + + -- Coerces a `t` into a dictionry for `IP "x" t`. + -- co : t -> IP "x" t + toDict ipClass x ty = + case unwrapNewTyCon_maybe (classTyCon ipClass) of + Just (_,_,ax) -> HsWrap $ WpCast $ mkTcSymCo $ mkTcAxInstCo ax [x,ty] + Nothing -> panic "The dictionary for `IP` is not a newtype?" + + \end{code} Note [Implicit parameter untouchables] @@ -191,16 +268,9 @@ tcValBinds :: TopLevelFlag tcValBinds top_lvl binds sigs thing_inside = do { -- Typecheck the signature - ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) - ; ty_sigs = filter isTypeLSig sigs - ; sig_fn = mkSigFun ty_sigs } + (poly_ids, sig_fn) <- tcTySigs sigs - ; poly_ids <- concat <$> checkNoErrs (mapAndRecoverM tcTySig ty_sigs) - -- No recovery from bad signatures, because the type sigs - -- may bind type variables, so proceeding without them - -- can lead to a cascade of errors - -- ToDo: this means we fall over immediately if any type sig - -- is wrong, which is over-conservative, see Trac bug #745 + ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) -- Extend the envt right away with all -- the Ids declared with type signatures @@ -211,7 +281,7 @@ tcValBinds top_lvl binds sigs thing_inside ; return (binds', thing) } ------------------------ -tcBindGroups :: TopLevelFlag -> SigFun -> PragFun +tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun -> [(RecFlag, LHsBinds Name)] -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) -- Typecheck a whole lot of value bindings, @@ -232,7 +302,7 @@ tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside ------------------------ tc_group :: forall thing. - TopLevelFlag -> SigFun -> PragFun + TopLevelFlag -> TcSigFun -> PragFun -> (RecFlag, LHsBinds Name) -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) @@ -276,7 +346,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive ------------------------ -mkEdges :: SigFun -> LHsBinds Name +mkEdges :: TcSigFun -> LHsBinds Name -> [(LHsBind Name, BKey, [BKey])] type BKey = Int -- Just number off the bindings @@ -303,7 +373,7 @@ bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds" bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind" ------------------------ -tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun +tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures @@ -326,26 +396,29 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list -- Set up main recover; take advantage of any type sigs { traceTc "------------------------------------------------" empty - ; traceTc "Bindings for" (ppr binder_names) + ; traceTc "Bindings for {" (ppr binder_names) - -- Instantiate the polytypes of any binders that have signatures - -- (as determined by sig_fn), returning a TcSigInfo for each - ; tc_sig_fn <- tcInstSigs sig_fn binder_names +-- -- Instantiate the polytypes of any binders that have signatures +-- -- (as determined by sig_fn), returning a TcSigInfo for each +-- ; tc_sig_fn <- tcInstSigs sig_fn binder_names ; dflags <- getDynFlags ; type_env <- getLclTypeEnv ; let plan = decideGeneralisationPlan dflags type_env - binder_names bind_list tc_sig_fn + binder_names bind_list sig_fn ; traceTc "Generalisation plan" (ppr plan) - ; result@(_, poly_ids, _) <- case plan of - NoGen -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list - InferGen mn cl -> tcPolyInfer mn cl tc_sig_fn prag_fn rec_tc bind_list + ; result@(tc_binds, poly_ids, _) <- case plan of + NoGen -> tcPolyNoGen sig_fn prag_fn rec_tc bind_list + InferGen mn cl -> tcPolyInfer mn cl sig_fn prag_fn rec_tc bind_list CheckGen sig -> tcPolyCheck sig prag_fn rec_tc bind_list -- Check whether strict bindings are ok -- These must be non-recursive etc, and are not generalised -- They desugar to a case expression in the end - ; checkStrictBinds top_lvl rec_group bind_list poly_ids + ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids + ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group + , vcat [ppr id <+> ppr (idType id) | id <- poly_ids] + ]) ; return result } where @@ -371,7 +444,7 @@ tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list ; return (binds', mono_ids', NotTopLevel) } where tc_mono_info (name, _, mono_id) - = do { mono_ty' <- zonkTcTypeCarefully (idType mono_id) + = do { mono_ty' <- zonkTcType (idType mono_id) -- Zonk, mainly to expose unboxed types to checkStrictBinds ; let mono_id' = setIdType mono_id mono_ty' ; _specs <- tcSpecPrags mono_id' (prag_fn name) @@ -390,16 +463,17 @@ tcPolyCheck :: TcSigInfo -> PragFun -- There is just one binding, -- it binds a single variable, -- it has a signature, -tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_scoped = scoped - , sig_theta = theta, sig_tau = tau }) +tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped + , sig_theta = theta, sig_tau = tau, sig_loc = loc }) prag_fn rec_tc bind_list - = do { loc <- getSrcSpanM - ; ev_vars <- newEvVars theta + = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau) prag_sigs = prag_fn (idName poly_id) + ; tvs <- mapM (skolemiseSigTv . snd) tvs_w_scoped ; (ev_binds, (binds', [mono_info])) - <- checkConstraints skol_info tvs ev_vars $ - tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $ + <- setSrcSpan loc $ + checkConstraints skol_info tvs ev_vars $ + tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $ tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list ; spec_prags <- tcSpecPrags poly_id prag_sigs @@ -428,12 +502,14 @@ tcPolyInfer -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list - = do { ((binds', mono_infos), wanted) + = do { (((binds', mono_infos), untch), wanted) <- captureConstraints $ + captureUntouchables $ tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos] - ; (qtvs, givens, mr_bites, ev_binds) <- simplifyInfer closed mono name_taus wanted + ; (qtvs, givens, mr_bites, ev_binds) <- + simplifyInfer closed mono name_taus (untch,wanted) ; theta <- zonkTcThetaType (map evVarPred givens) ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos @@ -471,7 +547,7 @@ mkExport :: PragFun -- Pre-condition: the qtvs and theta are already zonked mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id) - = do { mono_ty <- zonkTcTypeCarefully (idType mono_id) + = do { mono_ty <- zonkTcType (idType mono_id) ; let inferred_poly_ty = mkSigmaTy my_tvs theta mono_ty my_tvs = filter (`elemVarSet` used_tvs) qtvs used_tvs = tyVarsOfTypes theta `unionVarSet` tyVarsOfType mono_ty @@ -747,7 +823,7 @@ scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must b -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages -recoveryCode :: [Name] -> SigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag) +recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag) recoveryCode binder_names sig_fn = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) ; poly_ids <- mapM mk_dummy binder_names @@ -889,7 +965,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matc = do { mono_id <- newSigLetBndr no_gen name sig ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) } | otherwise - = do { mono_ty <- newFlexiTyVarTy argTypeKind + = do { mono_ty <- newFlexiTyVarTy openTypeKind ; mono_id <- newNoSigLetBndr no_gen name mono_ty ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) } @@ -945,161 +1021,6 @@ getMonoBindInfo tc_binds \end{code} -%************************************************************************ -%* * - Generalisation -%* * -%************************************************************************ - -unifyCtxts checks that all the signature contexts are the same -The type signatures on a mutually-recursive group of definitions -must all have the same context (or none). - -The trick here is that all the signatures should have the same -context, and we want to share type variables for that context, so that -all the right hand sides agree a common vocabulary for their type -constraints - -We unify them because, with polymorphic recursion, their types -might not otherwise be related. This is a rather subtle issue. - -\begin{code} -{- -unifyCtxts :: [TcSigInfo] -> TcM () --- Post-condition: the returned Insts are full zonked -unifyCtxts [] = return () -unifyCtxts (sig1 : sigs) - = do { traceTc "unifyCtxts" (ppr (sig1 : sigs)) - ; mapM_ unify_ctxt sigs } - where - theta1 = sig_theta sig1 - unify_ctxt :: TcSigInfo -> TcM () - unify_ctxt sig@(TcSigInfo { sig_theta = theta }) - = setSrcSpan (sig_loc sig) $ - addErrCtxt (sigContextsCtxt sig1 sig) $ - do { mk_cos <- unifyTheta theta1 theta - ; -- Check whether all coercions are identity coercions - -- That can happen if we have, say - -- f :: C [a] => ... - -- g :: C (F a) => ... - -- where F is a type function and (F a ~ [a]) - -- Then unification might succeed with a coercion. But it's much - -- much simpler to require that such signatures have identical contexts - checkTc (isReflMkCos mk_cos) - (ptext (sLit "Mutually dependent functions have syntactically distinct contexts")) - } - ------------------------------------------------ -sigContextsCtxt :: TcSigInfo -> TcSigInfo -> SDoc -sigContextsCtxt sig1 sig2 - = vcat [ptext (sLit "When matching the contexts of the signatures for"), - nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), - ppr id2 <+> dcolon <+> ppr (idType id2)]), - ptext (sLit "The signature contexts in a mutually recursive group should all be identical")] - where - id1 = sig_id sig1 - id2 = sig_id sig2 --} -\end{code} - - -@getTyVarsToGen@ decides what type variables to generalise over. - -For a "restricted group" -- see the monomorphism restriction -for a definition -- we bind no dictionaries, and -remove from tyvars_to_gen any constrained type variables - -*Don't* simplify dicts at this point, because we aren't going -to generalise over these dicts. By the time we do simplify them -we may well know more. For example (this actually came up) - f :: Array Int Int - f x = array ... xs where xs = [1,2,3,4,5] -We don't want to generate lots of (fromInt Int 1), (fromInt Int 2) -stuff. If we simplify only at the f-binding (not the xs-binding) -we'll know that the literals are all Ints, and we can just produce -Int literals! - -Find all the type variables involved in overloading, the -"constrained_tyvars". These are the ones we *aren't* going to -generalise. We must be careful about doing this: - - (a) If we fail to generalise a tyvar which is not actually - constrained, then it will never, ever get bound, and lands - up printed out in interface files! Notorious example: - instance Eq a => Eq (Foo a b) where .. - Here, b is not constrained, even though it looks as if it is. - Another, more common, example is when there's a Method inst in - the LIE, whose type might very well involve non-overloaded - type variables. - [NOTE: Jan 2001: I don't understand the problem here so I'm doing - the simple thing instead] - - (b) On the other hand, we mustn't generalise tyvars which are constrained, - because we are going to pass on out the unmodified LIE, with those - tyvars in it. They won't be in scope if we've generalised them. - -So we are careful, and do a complete simplification just to find the -constrained tyvars. We don't use any of the results, except to -find which tyvars are constrained. - -Note [Polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The game plan for polymorphic recursion in the code above is - - * Bind any variable for which we have a type signature - to an Id with a polymorphic type. Then when type-checking - the RHSs we'll make a full polymorphic call. - -This fine, but if you aren't a bit careful you end up with a horrendous -amount of partial application and (worse) a huge space leak. For example: - - f :: Eq a => [a] -> [a] - f xs = ...f... - -If we don't take care, after typechecking we get - - f = /\a -> \d::Eq a -> let f' = f a d - in - \ys:[a] -> ...f'... - -Notice the the stupid construction of (f a d), which is of course -identical to the function we're executing. In this case, the -polymorphic recursion isn't being used (but that's a very common case). -This can lead to a massive space leak, from the following top-level defn -(post-typechecking) - - ff :: [Int] -> [Int] - ff = f Int dEqInt - -Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but -f' is another thunk which evaluates to the same thing... and you end -up with a chain of identical values all hung onto by the CAF ff. - - ff = f Int dEqInt - - = let f' = f Int dEqInt in \ys. ...f'... - - = let f' = let f' = f Int dEqInt in \ys. ...f'... - in \ys. ...f'... - -Etc. - -NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), -which would make the space leak go away in this case - -Solution: when typechecking the RHSs we always have in hand the -*monomorphic* Ids for each binding. So we just need to make sure that -if (Method f a d) shows up in the constraints emerging from (...f...) -we just use the monomorphic Id. We achieve this by adding monomorphic Ids -to the "givens" when simplifying constraints. That's what the "lies_avail" -is doing. - -Then we get - - f = /\a -> \d::Eq a -> letrec - fm = \ys:[a] -> ...fm... - in - fm %************************************************************************ %* * @@ -1142,7 +1063,6 @@ However, we do *not* support this Currently, we simply make Opt_ScopedTypeVariables imply Opt_RelaxedPolyRec - Note [More instantiated than scoped] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There may be more instantiated type variables than lexically-scoped @@ -1194,70 +1114,65 @@ For example: it's all cool; each signature has distinct type variables from the renamer.) \begin{code} -type SigFun = Name -> Maybe ([Name], SrcSpan) - -- Maps a let-binder to the list of - -- type variables brought into scope - -- by its type signature, plus location - -- Nothing => no type signature - -mkSigFun :: [LSig Name] -> SigFun --- Search for a particular type signature --- Precondition: the sigs are all type sigs --- Precondition: no duplicates -mkSigFun sigs = lookupNameEnv env +tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun) +tcTySigs hs_sigs + = do { ty_sigs <- concat <$> checkNoErrs (mapAndRecoverM tcTySig hs_sigs) + -- No recovery from bad signatures, because the type sigs + -- may bind type variables, so proceeding without them + -- can lead to a cascade of errors + -- ToDo: this means we fall over immediately if any type sig + -- is wrong, which is over-conservative, see Trac bug #745 + ; let env = mkNameEnv [(idName (sig_id sig), sig) | sig <- ty_sigs] + ; return (map sig_id ty_sigs, lookupNameEnv env) } + +tcTySig :: LSig Name -> TcM [TcSigInfo] +tcTySig (L loc (IdSig id)) + = do { sig <- instTcTySigFromId loc id + ; return [sig] } +tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty)) + = setSrcSpan loc $ + do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty + ; mapM (instTcTySig hs_ty sigma_ty) (map unLoc names) } +tcTySig _ = return [] + +instTcTySigFromId :: SrcSpan -> Id -> TcM TcSigInfo +instTcTySigFromId loc id + = do { (tvs, theta, tau) <- tcInstType inst_sig_tyvars (idType id) + ; return (TcSigInfo { sig_id = id, sig_loc = loc + , sig_tvs = [(Nothing, tv) | tv <- tvs] + , sig_theta = theta, sig_tau = tau }) } where - env = mkNameEnv (concatMap mk_pair sigs) - mk_pair (L loc (IdSig id)) = [(idName id, ([], loc))] - mk_pair (L loc (TypeSig lnames lhs_ty)) = map f lnames + -- Hack: in an instance decl we use the selector id as + -- the template; but we do *not* want the SrcSpan on the Name of + -- those type variables to refer to the class decl, rather to + -- the instance decl + inst_sig_tyvars tvs = tcInstSigTyVars (map set_loc tvs) + set_loc tv = setTyVarName tv (mkInternalName (nameUnique n) (nameOccName n) loc) where - f (L _ name) = (name, (hsExplicitTvs lhs_ty, loc)) - mk_pair _ = [] - -- The scoped names are the ones explicitly mentioned - -- in the HsForAll. (There may be more in sigma_ty, because - -- of nested type synonyms. See Note [More instantiated than scoped].) - -- See Note [Only scoped tyvars are in the TyVarEnv] -\end{code} + n = tyVarName tv + +instTcTySig :: LHsType Name -> TcType -- HsType and corresponding TcType + -> Name -> TcM TcSigInfo +instTcTySig hs_ty@(L loc _) sigma_ty name + = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty + ; return (TcSigInfo { sig_id = poly_id, sig_loc = loc + , sig_tvs = zipEqual "instTcTySig" scoped_tvs inst_tvs + , sig_theta = theta, sig_tau = tau }) } + where + poly_id = mkLocalId name sigma_ty -\begin{code} -tcTySig :: LSig Name -> TcM [TcId] -tcTySig (L span (TypeSig names@(L _ name1 : _) ty)) - = setSrcSpan span $ - do { sigma_ty <- tcHsSigType (FunSigCtxt name1) ty - ; return [ mkLocalId name sigma_ty | L _ name <- names ] } -tcTySig (L _ (IdSig id)) - = return [id] -tcTySig s = pprPanic "tcTySig" (ppr s) + scoped_names = hsExplicitTvs hs_ty + (sig_tvs,_) = tcSplitForAllTys sigma_ty -------------------- -tcInstSigs :: SigFun -> [Name] -> TcM TcSigFun -tcInstSigs sig_fn bndrs - = do { prs <- mapMaybeM (tcInstSig sig_fn use_skols) bndrs - ; return (lookupNameEnv (mkNameEnv prs)) } - where - use_skols = isSingleton bndrs -- See Note [Signature skolems] + scoped_tvs :: [Maybe Name] + scoped_tvs = mk_scoped scoped_names sig_tvs -tcInstSig :: SigFun -> Bool -> Name -> TcM (Maybe (Name, TcSigInfo)) --- For use_skols :: Bool see Note [Signature skolems] --- --- We must instantiate with fresh uniques, --- (see Note [Instantiate sig with fresh variables]) --- although we keep the same print-name. - -tcInstSig sig_fn use_skols name - | Just (scoped_tvs, loc) <- sig_fn name - = do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into - -- scope when starting the binding group - ; let poly_ty = idType poly_id - ; (tvs, theta, tau) <- if use_skols - then tcInstType tcInstSkolTyVars poly_ty - else tcInstType tcInstSigTyVars poly_ty - ; let sig = TcSigInfo { sig_id = poly_id - , sig_scoped = scoped_tvs - , sig_tvs = tvs, sig_theta = theta, sig_tau = tau - , sig_loc = loc } - ; return (Just (name, sig)) } - | otherwise - = return Nothing + mk_scoped :: [Name] -> [TyVar] -> [Maybe Name] + mk_scoped [] tvs = [Nothing | _ <- tvs] + mk_scoped (n:ns) (tv:tvs) + | n == tyVarName tv = Just n : mk_scoped ns tvs + | otherwise = Nothing : mk_scoped (n:ns) tvs + mk_scoped (n:ns) [] = pprPanic "mk_scoped" (ppr name $$ ppr (n:ns) $$ ppr hs_ty $$ ppr sigma_ty) ------------------------------- data GeneralisationPlan @@ -1268,7 +1183,8 @@ data GeneralisationPlan Bool -- True <=> bindings mention only variables with closed types -- See Note [Bindings with closed types] in TcRnTypes - | CheckGen TcSigInfo -- Explicit generalisation; there is an AbsBinds + | CheckGen TcSigInfo -- One binding with a signature + -- Explicit generalisation; there is an AbsBinds -- A consequence of the no-AbsBinds choice (NoGen) is that there is -- no "polymorphic Id" and "monmomorphic Id"; there is just the one @@ -1313,8 +1229,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line ATyVar {} -> False -- In-scope type variables AGlobal {} -> True -- are not closed! - AThing {} -> pprPanic "is_closed_id" (ppr name) - ANothing {} -> pprPanic "is_closed_id" (ppr name) + _ -> pprPanic "is_closed_id" (ppr name) | otherwise = WARN( isInternalName name, ppr name ) True -- The free-var set for a top level binding mentions @@ -1348,21 +1263,32 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn ------------------- checkStrictBinds :: TopLevelFlag -> RecFlag - -> [LHsBind Name] -> [Id] + -> [LHsBind Name] + -> LHsBinds TcId -> [Id] -> TcM () -- Check that non-overloaded unlifted bindings are -- a) non-recursive, -- b) not top level, -- c) not a multiple-binding group (more or less implied by (a)) -checkStrictBinds top_lvl rec_group binds poly_ids +checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids | unlifted || bang_pat = do { checkTc (isNotTopLevel top_lvl) - (strictBindErr "Top-level" unlifted binds) + (strictBindErr "Top-level" unlifted orig_binds) ; checkTc (isNonRec rec_group) - (strictBindErr "Recursive" unlifted binds) - ; checkTc (isSingleton binds) - (strictBindErr "Multiple" unlifted binds) + (strictBindErr "Recursive" unlifted orig_binds) + + ; checkTc (all is_monomorphic (bagToList tc_binds)) + (polyBindErr orig_binds) + -- data Ptr a = Ptr Addr# + -- f x = let p@(Ptr y) = ... in ... + -- Here the binding for 'p' is polymorphic, but does + -- not mix with an unlifted binding for 'y'. You should + -- use a bang pattern. Trac #6078. + + ; checkTc (isSingleton orig_binds) + (strictBindErr "Multiple" unlifted orig_binds) + -- This should be a checkTc, not a warnTc, but as of GHC 6.11 -- the versions of alex and happy available have non-conforming -- templates, so the GHC build fails if it's an error: @@ -1373,31 +1299,40 @@ checkStrictBinds top_lvl rec_group binds poly_ids -- Warn about this, but not about -- x# = 4# +# 1# -- (# a, b #) = ... - (unliftedMustBeBang binds) } + (unliftedMustBeBang orig_binds) } | otherwise - = return () + = traceTc "csb2" (ppr poly_ids) >> + return () where unlifted = any is_unlifted poly_ids - bang_pat = any (isBangHsBind . unLoc) binds - lifted_pat = any (isLiftedPatBind . unLoc) binds + bang_pat = any (isBangHsBind . unLoc) orig_binds + lifted_pat = any (isLiftedPatBind . unLoc) orig_binds + is_unlifted id = case tcSplitForAllTys (idType id) of (_, rho) -> isUnLiftedType rho + is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })) + = null tvs && null evs + is_monomorphic _ = True + unliftedMustBeBang :: [LHsBind Name] -> SDoc unliftedMustBeBang binds = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:") - 2 (pprBindList binds) + 2 (vcat (map ppr binds)) + +polyBindErr :: [LHsBind Name] -> SDoc +polyBindErr binds + = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings")) + 2 (vcat [vcat (map ppr binds), + ptext (sLit "Probable fix: use a bang pattern")]) strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc strictBindErr flavour unlifted binds = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) - 2 (pprBindList binds) + 2 (vcat (map ppr binds)) where msg | unlifted = ptext (sLit "bindings for unlifted types") | otherwise = ptext (sLit "bang-pattern bindings") - -pprBindList :: [LHsBind Name] -> SDoc -pprBindList binds = vcat (map ppr binds) \end{code} diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 426fbe7a68..284d0218f5 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -7,14 +7,13 @@ -- for details module TcCanonical( - canonicalize, + canonicalize, flatten, flattenMany, occurCheckExpand, + FlattenMode (..), StopOrContinue (..) ) where #include "HsVersions.h" -import BasicTypes ( IPName ) -import TcErrors import TcRnTypes import TcType import Type @@ -23,11 +22,10 @@ import TcEvidence import Class import TyCon import TypeRep -import Name ( Name ) import Var import VarEnv import Outputable -import Control.Monad ( when, unless, zipWithM ) +import Control.Monad ( when ) import MonadUtils import Control.Applicative ( (<|>) ) @@ -36,8 +34,13 @@ import VarSet import TcSMonad import FastString -import Data.Maybe ( isNothing ) +import Util + +import TysWiredIn ( eqTyCon ) + +import Data.Maybe ( isJust, fromMaybe ) +-- import Data.List ( zip4 ) \end{code} @@ -111,16 +114,19 @@ andWhenContinue tcs1 tcs2 Note [Caching for canonicals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Our plan with pre-canonicalization is to be able to solve a constraint really fast from existing -bindings in TcEvBinds. So one may think that the condition (isCNonCanonical) is not necessary. -However consider the following setup: +Our plan with pre-canonicalization is to be able to solve a constraint +really fast from existing bindings in TcEvBinds. So one may think that +the condition (isCNonCanonical) is not necessary. However consider +the following setup: InertSet = { [W] d1 : Num t } WorkList = { [W] d2 : Num t, [W] c : t ~ Int} -Now, we prioritize equalities, but in our concrete example (should_run/mc17.hs) the first (d2) constraint -is dealt with first, because (t ~ Int) is an equality that only later appears in the worklist since it is -pulled out from a nested implication constraint. So, let's examine what happens: +Now, we prioritize equalities, but in our concrete example +(should_run/mc17.hs) the first (d2) constraint is dealt with first, +because (t ~ Int) is an equality that only later appears in the +worklist since it is pulled out from a nested implication +constraint. So, let's examine what happens: - We encounter work item (d2 : Num t) @@ -129,27 +135,33 @@ pulled out from a nested implication constraint. So, let's examine what happens: d2 := d1 and we discard d2 from the worklist. The inert set remains unaffected. - - Now the equation ([W] c : t ~ Int) is encountered and kicks-out (d1 : Num t) from the inerts. - Then that equation gets spontaneously solved, perhaps. We end up with: + - Now the equation ([W] c : t ~ Int) is encountered and kicks-out + (d1 : Num t) from the inerts. Then that equation gets + spontaneously solved, perhaps. We end up with: InertSet : { [G] c : t ~ Int } WorkList : { [W] d1 : Num t} - - Now we examine (d1), we observe that there is a binding for (Num t) in the evidence binds and - we set: + - Now we examine (d1), we observe that there is a binding for (Num + t) in the evidence binds and we set: d1 := d2 and end up in a loop! -Now, the constraints that get kicked out from the inert set are always Canonical, so by restricting -the use of the pre-canonicalizer to NonCanonical constraints we eliminate this danger. Moreover, for -canonical constraints we already have good caching mechanisms (effectively the interaction solver) -and we are interested in reducing things like superclasses of the same non-canonical constraint being -generated hence I don't expect us to lose a lot by introducing the (isCNonCanonical) restriction. +Now, the constraints that get kicked out from the inert set are always +Canonical, so by restricting the use of the pre-canonicalizer to +NonCanonical constraints we eliminate this danger. Moreover, for +canonical constraints we already have good caching mechanisms +(effectively the interaction solver) and we are interested in reducing +things like superclasses of the same non-canonical constraint being +generated hence I don't expect us to lose a lot by introducing the +(isCNonCanonical) restriction. -A similar situation can arise in TcSimplify, at the end of the solve_wanteds function, where constraints -from the inert set are returned as new work -- our substCt ensures however that if they are not rewritten -by subst, they remain canonical and hence we will not attempt to solve them from the EvBinds. If on the -other hand they did get rewritten and are now non-canonical they will still not match the EvBinds, so we -are again good. +A similar situation can arise in TcSimplify, at the end of the +solve_wanteds function, where constraints from the inert set are +returned as new work -- our substCt ensures however that if they are +not rewritten by subst, they remain canonical and hence we will not +attempt to solve them from the EvBinds. If on the other hand they did +get rewritten and are now non-canonical they will still not match the +EvBinds, so we are again good. @@ -159,214 +171,122 @@ are again good. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ canonicalize :: Ct -> TcS StopOrContinue -canonicalize ct@(CNonCanonical { cc_id = ev, cc_flavor = fl, cc_depth = d }) +canonicalize ct@(CNonCanonical { cc_ev = fl, cc_depth = d }) = do { traceTcS "canonicalize (non-canonical)" (ppr ct) ; {-# SCC "canEvVar" #-} - canEvVar ev (classifyPredType (evVarPred ev)) d fl } + canEvVar d fl (classifyPredType (ctPred ct)) } -canonicalize (CDictCan { cc_id = ev, cc_depth = d - , cc_flavor = fl +canonicalize (CDictCan { cc_depth = d + , cc_ev = fl , cc_class = cls , cc_tyargs = xis }) = {-# SCC "canClass" #-} - canClass d fl ev cls xis -- Do not add any superclasses -canonicalize (CTyEqCan { cc_id = ev, cc_depth = d - , cc_flavor = fl + canClass d fl cls xis -- Do not add any superclasses +canonicalize (CTyEqCan { cc_depth = d + , cc_ev = fl , cc_tyvar = tv , cc_rhs = xi }) = {-# SCC "canEqLeafTyVarLeftRec" #-} - canEqLeafTyVarLeftRec d fl ev tv xi + canEqLeafTyVarLeftRec d fl tv xi -canonicalize (CFunEqCan { cc_id = ev, cc_depth = d - , cc_flavor = fl +canonicalize (CFunEqCan { cc_depth = d + , cc_ev = fl , cc_fun = fn , cc_tyargs = xis1 , cc_rhs = xi2 }) = {-# SCC "canEqLeafFunEqLeftRec" #-} - canEqLeafFunEqLeftRec d fl ev (fn,xis1) xi2 - -canonicalize (CIPCan { cc_id = ev, cc_depth = d - , cc_flavor = fl - , cc_ip_nm = nm - , cc_ip_ty = xi }) - = canIP d fl ev nm xi -canonicalize (CIrredEvCan { cc_id = ev, cc_flavor = fl + canEqLeafFunEqLeftRec d fl (fn,xis1) xi2 + +canonicalize (CIrredEvCan { cc_ev = fl , cc_depth = d , cc_ty = xi }) - = canIrred d fl ev xi + = canIrred d fl xi -canEvVar :: EvVar -> PredTree - -> SubGoalDepth -> CtFlavor -> TcS StopOrContinue +canEvVar :: SubGoalDepth + -> CtEvidence + -> PredTree + -> TcS StopOrContinue -- Called only for non-canonical EvVars -canEvVar ev pred_classifier d fl +canEvVar d fl pred_classifier = case pred_classifier of - ClassPred cls tys -> canClass d fl ev cls tys - `andWhenContinue` emit_superclasses - EqPred ty1 ty2 -> canEq d fl ev ty1 ty2 - `andWhenContinue` emit_kind_constraint - IPPred nm ty -> canIP d fl ev nm ty - IrredPred ev_ty -> canIrred d fl ev ev_ty - TuplePred tys -> canTuple d fl ev tys - where emit_superclasses ct@(CDictCan {cc_id = v_new - , cc_tyargs = xis_new, cc_class = cls }) - -- Add superclasses of this one here, See Note [Adding superclasses]. - -- But only if we are not simplifying the LHS of a rule. - = do { sctxt <- getTcSContext - ; unless (simplEqsOnly sctxt) $ - newSCWorkFromFlavored d v_new fl cls xis_new - -- Arguably we should "seq" the coercions if they are derived, - -- as we do below for emit_kind_constraint, to allow errors in - -- superclasses to be executed if deferred to runtime! - ; continueWith ct } - emit_superclasses _ = panic "emit_superclasses of non-class!" - - emit_kind_constraint ct@(CTyEqCan { cc_id = ev, cc_depth = d - , cc_flavor = fl, cc_tyvar = tv - , cc_rhs = ty }) - = do_emit_kind_constraint ct ev d fl (mkTyVarTy tv) ty - - emit_kind_constraint ct@(CFunEqCan { cc_id = ev, cc_depth = d - , cc_flavor = fl - , cc_fun = fn, cc_tyargs = xis1 - , cc_rhs = xi2 }) - = do_emit_kind_constraint ct ev d fl (mkTyConApp fn xis1) xi2 - emit_kind_constraint ct = continueWith ct - - do_emit_kind_constraint ct eqv d fl ty1 ty2 - | compatKind k1 k2 = continueWith ct - | otherwise - = do { keqv <- forceNewEvVar kind_co_fl (mkEqPred (k1,k2)) - ; eqv' <- forceNewEvVar fl (mkEqPred (ty1,ty2)) - ; _fl <- case fl of - Wanted {}-> setEvBind eqv - (mkEvKindCast eqv' (mkTcCoVarCo keqv)) fl - Given {} -> setEvBind eqv' - (mkEvKindCast eqv (mkTcCoVarCo keqv)) fl - Derived {} -> return fl - - ; canEq_ d kind_co_fl keqv k1 k2 -- Emit kind equality - ; continueWith (ct { cc_id = eqv' }) } - where k1 = typeKind ty1 - k2 = typeKind ty2 - ctxt = mkKindErrorCtxtTcS ty1 k1 ty2 k2 - -- Always create a Wanted kind equality even if - -- you are decomposing a given constraint. - -- NB: DV finds this reasonable for now. Maybe we - -- have to revisit. - kind_co_fl - | Given (CtLoc _sk_info src_span err_ctxt) _ <- fl - = let orig = TypeEqOrigin (UnifyOrigin ty1 ty2) - ctloc = pushErrCtxtSameOrigin ctxt $ - CtLoc orig src_span err_ctxt - in Wanted ctloc - | Wanted ctloc <- fl - = Wanted (pushErrCtxtSameOrigin ctxt ctloc) - | Derived ctloc <- fl - = Derived (pushErrCtxtSameOrigin ctxt ctloc) - | otherwise - = panic "do_emit_kind_constraint: non-CtLoc inside!" - - --- Tuple canonicalisation --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -canTuple :: SubGoalDepth -- Depth - -> CtFlavor -> EvVar -> [PredType] -> TcS StopOrContinue -canTuple d fl ev tys - = do { traceTcS "can_pred" (text "TuplePred!") - ; evs <- zipWithM can_pred_tup_one tys [0..] - ; if (isWanted fl) then - do {_unused_fl <- setEvBind ev (EvTupleMk evs) fl - ; return Stop } - else return Stop } - where - can_pred_tup_one ty n - = do { evc <- newEvVar fl ty - ; let ev' = evc_the_evvar evc - ; fl' <- if isGivenOrSolved fl then - setEvBind ev' (EvTupleSel ev n) fl - else return fl - ; when (isNewEvVar evc) $ - addToWork (canEvVar ev' (classifyPredType (evVarPred ev')) d fl') - ; return ev' } - --- Implicit Parameter Canonicalization --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -canIP :: SubGoalDepth -- Depth - -> CtFlavor -> EvVar - -> IPName Name -> Type -> TcS StopOrContinue --- Precondition: EvVar is implicit parameter evidence -canIP d fl v nm ty - = -- Note [Canonical implicit parameter constraints] explains why it's - -- possible in principle to not flatten, but since flattening applies - -- the inert substitution we choose to flatten anyway. - do { (xi,co) <- flatten d fl (mkIPPred nm ty) - ; let no_flattening = isTcReflCo co - ; if no_flattening then - let IPPred _ xi_in = classifyPredType xi - in continueWith $ CIPCan { cc_id = v, cc_flavor = fl - , cc_ip_nm = nm, cc_ip_ty = xi_in - , cc_depth = d } - else do { evc <- newEvVar fl xi - ; let v_new = evc_the_evvar evc - IPPred _ ip_xi = classifyPredType xi - ; fl_new <- case fl of - Wanted {} -> setEvBind v (EvCast v_new co) fl - Given {} -> setEvBind v_new (EvCast v (mkTcSymCo co)) fl - Derived {} -> return fl - ; if isNewEvVar evc then - continueWith $ CIPCan { cc_id = v_new - , cc_flavor = fl_new, cc_ip_nm = nm - , cc_ip_ty = ip_xi - , cc_depth = d } - else return Stop } } + ClassPred cls tys -> canClassNC d fl cls tys + EqPred ty1 ty2 -> canEqNC d fl ty1 ty2 + IrredPred ev_ty -> canIrred d fl ev_ty + TuplePred tys -> canTuple d fl tys \end{code} -Note [Canonical implicit parameter constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type in a canonical implicit parameter constraint doesn't need to -be a xi (type-function-free type) since we can defer the flattening -until checking this type for equality with another type. If we -encounter two IP constraints with the same name, they MUST have the -same type, and at that point we can generate a flattened equality -constraint between the types. (On the other hand, the types in two -class constraints for the same class MAY be equal, so they need to be -flattened in the first place to facilitate comparing them.) + +%************************************************************************ +%* * +%* Tuple Canonicalization +%* * +%************************************************************************ + \begin{code} +canTuple :: SubGoalDepth -- Depth + -> CtEvidence -> [PredType] -> TcS StopOrContinue +canTuple d fl tys + = do { traceTcS "can_pred" (text "TuplePred!") + ; let xcomp = EvTupleMk + xdecomp x = zipWith (\_ i -> EvTupleSel x i) tys [0..] + ; ctevs <- xCtFlavor fl tys (XEvTerm xcomp xdecomp) + ; mapM_ add_to_work ctevs + ; return Stop } + where + add_to_work fl = addToWork $ canEvVar d fl (classifyPredType (ctEvPred fl)) +\end{code} --- Class Canonicalization --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -canClass :: SubGoalDepth -- Depth - -> CtFlavor -> EvVar - -> Class -> [Type] -> TcS StopOrContinue +%************************************************************************ +%* * +%* Class Canonicalization +%* * +%************************************************************************ + +\begin{code} +canClass, canClassNC + :: SubGoalDepth -- Depth + -> CtEvidence + -> Class -> [Type] -> TcS StopOrContinue -- Precondition: EvVar is class evidence --- Note: Does NOT add superclasses, but the /caller/ is responsible for adding them! -canClass d fl v cls tys + +-- The canClassNC version is used on non-canonical constraints +-- and adds superclasses. The plain canClass version is used +-- for already-canonical class constraints (but which might have +-- been subsituted or somthing), and hence do not need superclasses + +canClassNC d fl cls tys + = canClass d fl cls tys + `andWhenContinue` emitSuperclasses + +canClass d fl cls tys = do { -- sctx <- getTcSContext - ; (xis, cos) <- flattenMany d fl tys + ; (xis, cos) <- flattenMany d FMFullFlatten fl tys ; let co = mkTcTyConAppCo (classTyCon cls) cos xi = mkClassPred cls xis - - ; let no_flattening = all isTcReflCo cos - -- No flattening, continue with canonical - ; if no_flattening then - continueWith $ CDictCan { cc_id = v, cc_flavor = fl - , cc_tyargs = xis, cc_class = cls - , cc_depth = d } - -- Flattening happened - else do { evc <- newEvVar fl xi - ; let v_new = evc_the_evvar evc - ; fl_new <- case fl of - Wanted {} -> setEvBind v (EvCast v_new co) fl - Given {} -> setEvBind v_new (EvCast v (mkTcSymCo co)) fl - Derived {} -> return fl - -- Continue only if flat constraint is new - ; if isNewEvVar evc then - continueWith $ CDictCan { cc_id = v_new, cc_flavor = fl_new - , cc_tyargs = xis, cc_class = cls - , cc_depth = d } - else return Stop } } + + ; mb <- rewriteCtFlavor fl xi co + + ; case mb of + Just new_fl -> + let (ClassPred cls xis_for_dict) = classifyPredType (ctEvPred new_fl) + in continueWith $ + CDictCan { cc_ev = new_fl + , cc_tyargs = xis_for_dict, cc_class = cls, cc_depth = d } + Nothing -> return Stop } + +emitSuperclasses :: Ct -> TcS StopOrContinue +emitSuperclasses ct@(CDictCan { cc_depth = d, cc_ev = fl + , cc_tyargs = xis_new, cc_class = cls }) + -- Add superclasses of this one here, See Note [Adding superclasses]. + -- But only if we are not simplifying the LHS of a rule. + = do { newSCWorkFromFlavored d fl cls xis_new + -- Arguably we should "seq" the coercions if they are derived, + -- as we do below for emit_kind_constraint, to allow errors in + -- superclasses to be executed if deferred to runtime! + ; continueWith ct } +emitSuperclasses _ = panic "emit_superclasses of non-class!" \end{code} Note [Adding superclasses] @@ -435,52 +355,39 @@ happen. \begin{code} newSCWorkFromFlavored :: SubGoalDepth -- Depth - -> EvVar -> CtFlavor -> Class -> [Xi] -> TcS () + -> CtEvidence -> Class -> [Xi] -> TcS () -- Returns superclasses, see Note [Adding superclasses] -newSCWorkFromFlavored d ev flavor cls xis +newSCWorkFromFlavored d flavor cls xis | isDerived flavor = return () -- Deriveds don't yield more superclasses because we will -- add them transitively in the case of wanteds. - - | Just gk <- isGiven_maybe flavor - = case gk of - GivenOrig -> do { let sc_theta = immSuperClasses cls xis - ; sc_vars <- mapM (newEvVar flavor) sc_theta - ; sc_cts <- zipWithM (\scv ev_trm -> - do { let sc_evvar = evc_the_evvar scv - ; _unused_fl <- setEvBind sc_evvar ev_trm flavor - -- unused because it's the same - ; return $ - CNonCanonical { cc_id = sc_evvar - , cc_flavor = flavor - , cc_depth = d }}) - sc_vars [EvSuperClass ev n | n <- [0..]] - -- Emit now, canonicalize later in a lazier fashion - ; traceTcS "newSCWorkFromFlavored" $ - text "Emitting superclass work:" <+> ppr sc_cts - ; updWorkListTcS $ appendWorkListCt sc_cts } - GivenSolved {} -> return () - -- Seems very dangerous to add the superclasses for dictionaries that may be - -- partially solved because we may end up with evidence loops. + + | isGiven flavor + = do { let sc_theta = immSuperClasses cls xis + xev = XEvTerm { ev_comp = panic "Can't compose for given!" + , ev_decomp = \x -> zipWith (\_ i -> EvSuperClass x i) sc_theta [0..] } + ; ctevs <- xCtFlavor flavor sc_theta xev + ; emit_sc_flavs d ctevs } | isEmptyVarSet (tyVarsOfTypes xis) - = return () -- Wanteds with no variables yield no deriveds. + = return () -- Wanteds/Derived with no variables yield no deriveds. -- See Note [Improvement from Ground Wanteds] - | otherwise -- Wanted case, just add those SC that can lead to improvement. + | otherwise -- Wanted/Derived case, just add those SC that can lead to improvement. = do { let sc_rec_theta = transSuperClasses cls xis - impr_theta = filter is_improvement_pty sc_rec_theta - Wanted wloc = flavor - ; sc_cts <- mapM (\pty -> do { scv <- newEvVar (Derived wloc) pty - ; if isNewEvVar scv then - return [ CNonCanonical { cc_id = evc_the_evvar scv - , cc_flavor = Derived wloc - , cc_depth = d } ] - else return [] } - ) impr_theta - ; let sc_cts_flat = concat sc_cts - ; traceTcS "newSCWorkFromFlavored" (text "Emitting superclass work:" <+> ppr sc_cts_flat) - ; updWorkListTcS $ appendWorkListCt sc_cts_flat } + impr_theta = filter is_improvement_pty sc_rec_theta + xev = panic "Derived's are not supposed to transform evidence!" + der_ev = Derived { ctev_wloc = ctev_wloc flavor, ctev_pred = ctev_pred flavor } + ; ctevs <- xCtFlavor der_ev impr_theta xev + ; emit_sc_flavs d ctevs } + +emit_sc_flavs :: SubGoalDepth -> [CtEvidence] -> TcS () +emit_sc_flavs d fls + = do { traceTcS "newSCWorkFromFlavored" $ + text "Emitting superclass work:" <+> ppr sc_cts + ; updWorkListTcS $ appendWorkListCt sc_cts } + where + sc_cts = map (\fl -> CNonCanonical { cc_ev = fl, cc_depth = d }) fls is_improvement_pty :: PredType -> Bool -- Either it's an equality, or has some functional dependency @@ -489,45 +396,38 @@ is_improvement_pty ty = go (classifyPredType ty) go (EqPred {}) = True go (ClassPred cls _tys) = not $ null fundeps where (_,fundeps) = classTvsFds cls - go (IPPred {}) = False go (TuplePred ts) = any is_improvement_pty ts go (IrredPred {}) = True -- Might have equalities after reduction? \end{code} +%************************************************************************ +%* * +%* Irreducibles canonicalization +%* * +%************************************************************************ + \begin{code} --- Irreducibles canonicalization --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ canIrred :: SubGoalDepth -- Depth - -> CtFlavor -> EvVar -> TcType -> TcS StopOrContinue + -> CtEvidence -> TcType -> TcS StopOrContinue -- Precondition: ty not a tuple and no other evidence form -canIrred d fl v ty +canIrred d fl ty = do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) - ; (xi,co) <- flatten d fl ty -- co :: xi ~ ty + ; (xi,co) <- flatten d FMFullFlatten fl ty -- co :: xi ~ ty ; let no_flattening = xi `eqType` ty -- In this particular case it is not safe to -- say 'isTcReflCo' because the new constraint may -- be reducible! - ; if no_flattening then - continueWith $ CIrredEvCan { cc_id = v, cc_flavor = fl - , cc_ty = xi, cc_depth = d } - else do - { -- Flattening consults and applies family equations from the - -- inerts, so 'xi' may become reducible. So just recursively - -- canonicalise the resulting evidence variable - evc <- newEvVar fl xi - ; let v' = evc_the_evvar evc - ; fl' <- case fl of - Wanted {} -> setEvBind v (EvCast v' co) fl - Given {} -> setEvBind v' (EvCast v (mkTcSymCo co)) fl - Derived {} -> return fl - - ; if isNewEvVar evc then - canEvVar v' (classifyPredType (evVarPred v')) d fl' - else - return Stop } - } + ; mb <- rewriteCtFlavor fl xi co + ; case mb of + Just new_fl + | no_flattening + -> continueWith $ + CIrredEvCan { cc_ev = new_fl, cc_ty = xi, cc_depth = d } + | otherwise + -> canEvVar d new_fl (classifyPredType (ctEvPred new_fl)) + Nothing -> return Stop } \end{code} @@ -541,7 +441,8 @@ Note [Flattening] ~~~~~~~~~~~~~~~~~~~~ flatten ty ==> (xi, cc) where - xi has no type functions + xi has no type functions, unless they appear under ForAlls + cc = Auxiliary given (equality) constraints constraining the fresh type variables in xi. Evidence for these is always the identity coercion, because internally the @@ -578,16 +479,21 @@ unexpanded synonym. \begin{code} +data FlattenMode = FMSubstOnly + | FMFullFlatten + -- Flatten a bunch of types all at once. flattenMany :: SubGoalDepth -- Depth - -> CtFlavor -> [Type] -> TcS ([Xi], [TcCoercion]) + -> FlattenMode + -> CtEvidence -> [Type] -> TcS ([Xi], [TcCoercion]) -- Coercions :: Xi ~ Type -- Returns True iff (no flattening happened) -flattenMany d ctxt tys +-- NB: The EvVar inside the flavor is unused, we merely want Given/Solved/Derived/Wanted info +flattenMany d f ctxt tys = -- pprTrace "flattenMany" empty $ go tys where go [] = return ([],[]) - go (ty:tys) = do { (xi,co) <- flatten d ctxt ty + go (ty:tys) = do { (xi,co) <- flatten d f ctxt ty ; (xis,cos) <- go tys ; return (xi:xis,co:cos) } @@ -595,34 +501,155 @@ flattenMany d ctxt tys -- the new type-function-free type, and a collection of new equality -- constraints. See Note [Flattening] for more detail. flatten :: SubGoalDepth -- Depth - -> CtFlavor -> TcType -> TcS (Xi, TcCoercion) + -> FlattenMode + -> CtEvidence -> TcType -> TcS (Xi, TcCoercion) -- Postcondition: Coercion :: Xi ~ TcType -flatten d ctxt ty +flatten d f ctxt ty | Just ty' <- tcView ty - = do { (xi, co) <- flatten d ctxt ty' + = do { (xi, co) <- flatten d f ctxt ty' ; return (xi,co) } -flatten d ctxt (TyVarTy tv) +flatten _ _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi) + +flatten d f ctxt (TyVarTy tv) + = flattenTyVar d f ctxt tv + +flatten d f ctxt (AppTy ty1 ty2) + = do { (xi1,co1) <- flatten d f ctxt ty1 + ; (xi2,co2) <- flatten d f ctxt ty2 + ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) } + +flatten d f ctxt (FunTy ty1 ty2) + = do { (xi1,co1) <- flatten d f ctxt ty1 + ; (xi2,co2) <- flatten d f ctxt ty2 + ; return (mkFunTy xi1 xi2, mkTcFunCo co1 co2) } + +flatten d f fl (TyConApp tc tys) + -- For a normal type constructor or data family application, we just + -- recursively flatten the arguments. + | not (isSynFamilyTyCon tc) + = do { (xis,cos) <- flattenMany d f fl tys + ; return (mkTyConApp tc xis, mkTcTyConAppCo tc cos) } + + -- Otherwise, it's a type function application, and we have to + -- flatten it away as well, and generate a new given equality constraint + -- between the application and a newly generated flattening skolem variable. + | otherwise + = ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated + do { (xis, cos) <- flattenMany d f fl tys + ; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis + -- The type function might be *over* saturated + -- in which case the remaining arguments should + -- be dealt with by AppTys + fam_ty = mkTyConApp tc xi_args + + ; (ret_co, rhs_xi, ct) <- + case f of + FMSubstOnly -> + return (mkTcReflCo fam_ty, fam_ty, []) + FMFullFlatten -> + do { flat_cache <- getFlatCache + ; case lookupTM fam_ty flat_cache of + Just ct + | let ctev = cc_ev ct + , ctev `canRewrite` fl + -> -- You may think that we can just return (cc_rhs ct) but not so. + -- return (mkTcCoVarCo (ctId ct), cc_rhs ct, []) + -- The cached constraint resides in the cache so we have to flatten + -- the rhs to make sure we have applied any inert substitution to it. + -- Alternatively we could be applying the inert substitution to the + -- cache as well when we interact an equality with the inert. + -- The design choice is: do we keep the flat cache rewritten or not? + -- For now I say we don't keep it fully rewritten. + do { traceTcS "flatten/flat-cache hit" $ ppr ct + ; let rhs_xi = cc_rhs ct + ; (flat_rhs_xi,co) <- flatten (cc_depth ct) f ctev rhs_xi + ; let final_co = evTermCoercion (ctEvTerm ctev) + `mkTcTransCo` mkTcSymCo co + ; return (final_co, flat_rhs_xi,[]) } + + _ | isGiven fl -- Given: make new flatten skolem + -> do { traceTcS "flatten/flat-cache miss" $ empty + ; rhs_xi_var <- newFlattenSkolemTy fam_ty + ; let co = mkTcReflCo fam_ty + new_fl = Given { ctev_gloc = ctev_gloc fl + , ctev_pred = mkTcEqPred fam_ty rhs_xi_var + , ctev_evtm = EvCoercion co } + ct = CFunEqCan { cc_ev = new_fl + , cc_fun = tc + , cc_tyargs = xi_args + , cc_rhs = rhs_xi_var + , cc_depth = d } + -- Update the flat cache + ; updFlatCache ct + ; return (co, rhs_xi_var, [ct]) } + | otherwise -- Wanted or Derived: make new unification variable + -> do { traceTcS "flatten/flat-cache miss" $ empty + ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty) + ; let pred = mkTcEqPred fam_ty rhs_xi_var + wloc = ctev_wloc fl + ; mw <- newWantedEvVar wloc pred + ; case mw of + Fresh ctev -> + do { let ct = CFunEqCan { cc_ev = ctev + , cc_fun = tc + , cc_tyargs = xi_args + , cc_rhs = rhs_xi_var + , cc_depth = d } + -- Update the flat cache: just an optimisation! + ; updFlatCache ct + ; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var, [ct]) } + Cached {} -> panic "flatten TyConApp, var must be fresh!" } + } + -- Emit the flat constraints + ; updWorkListTcS $ appendWorkListEqs ct + ; let (cos_args, cos_rest) = splitAt (tyConArity tc) cos + ; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable + -- cf Trac #5655 + , mkTcAppCos (mkTcSymCo ret_co `mkTcTransCo` mkTcTyConAppCo tc cos_args) $ + cos_rest + ) + } + +flatten d _f ctxt ty@(ForAllTy {}) +-- We allow for-alls when, but only when, no type function +-- applications inside the forall involve the bound type variables. + = do { let (tvs, rho) = splitForAllTys ty + ; (rho', co) <- flatten d FMSubstOnly ctxt rho + ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } + +\end{code} + +\begin{code} +flattenTyVar :: SubGoalDepth + -> FlattenMode + -> CtEvidence -> TcTyVar -> TcS (Xi, TcCoercion) +-- "Flattening" a type variable means to apply the substitution to it +flattenTyVar d f ctxt tv = do { ieqs <- getInertEqs ; let mco = tv_eq_subst (fst ieqs) tv -- co : v ~ ty ; case mco of -- Done, but make sure the kind is zonked Nothing -> do { let knd = tyVarKind tv - ; (new_knd,_kind_co) <- flatten d ctxt knd + ; (new_knd,_kind_co) <- flatten d f ctxt knd ; let ty = mkTyVarTy (setVarType tv new_knd) ; return (ty, mkTcReflCo ty) } -- NB recursive call. - -- Why? See Note [Non-idempotent inert substitution] - -- Actually, I think applying the substition just twice will suffice + -- Why? Because inert subst. non-idempotent, Note [Detailed InertCans Invariants] + -- In fact, because of flavors, it couldn't possibly be idempotent, + -- this is explained in Note [Non-idempotent inert substitution] Just (co,ty) -> - do { (ty_final,co') <- flatten d ctxt ty + do { (ty_final,co') <- flatten d f ctxt ty ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } } - where tv_eq_subst subst tv - | Just (ct,co) <- lookupVarEnv subst tv - , cc_flavor ct `canRewrite` ctxt - = Just (co,cc_rhs ct) - | otherwise = Nothing - + where + tv_eq_subst subst tv + | Just ct <- lookupVarEnv subst tv + , let ctev = cc_ev ct + , ctev `canRewrite` ctxt + = Just (evTermCoercion (ctEvTerm ctev), cc_rhs ct) + -- NB: even if ct is Derived we are not going to + -- touch the actual coercion so we are fine. + | otherwise = Nothing \end{code} Note [Non-idempotent inert substitution] @@ -632,7 +659,7 @@ The inert substitution is not idempotent in the broad sense. It is only idempote that it cannot rewrite the RHS of other inert equalities any further. An example of such an inert substitution is: - [Ś] g1 : ta8 ~ ta4 + [G] g1 : ta8 ~ ta4 [W] g2 : ta4 ~ a5Fj Observe that the wanted cannot rewrite the solved goal, despite the fact that ta4 appears on @@ -651,270 +678,203 @@ should). For this reason, when we reach to flatten a type variable, we flatten it recursively, so that we can make sure that the inert substitution /is/ fully applied. -This insufficient rewriting was the reason for #5668. +Insufficient (non-recursive) rewriting was the reason for #5668. \begin{code} - -flatten d ctxt (AppTy ty1 ty2) - = do { (xi1,co1) <- flatten d ctxt ty1 - ; (xi2,co2) <- flatten d ctxt ty2 - ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) } - -flatten d ctxt (FunTy ty1 ty2) - = do { (xi1,co1) <- flatten d ctxt ty1 - ; (xi2,co2) <- flatten d ctxt ty2 - ; return (mkFunTy xi1 xi2, mkTcFunCo co1 co2) } - -flatten d fl (TyConApp tc tys) - -- For a normal type constructor or data family application, we just - -- recursively flatten the arguments. - | not (isSynFamilyTyCon tc) - = do { (xis,cos) <- flattenMany d fl tys - ; return (mkTyConApp tc xis, mkTcTyConAppCo tc cos) } - - -- Otherwise, it's a type function application, and we have to - -- flatten it away as well, and generate a new given equality constraint - -- between the application and a newly generated flattening skolem variable. - | otherwise - = ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated - do { (xis, cos) <- flattenMany d fl tys - ; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis - -- The type function might be *over* saturated - -- in which case the remaining arguments should - -- be dealt with by AppTys - fam_ty = mkTyConApp tc xi_args - ; (ret_co, rhs_xi, ct) <- - do { is_cached <- getCachedFlatEq tc xi_args fl Any - ; case is_cached of - Just (rhs_xi,ret_eq) -> - do { traceTcS "is_cached!" $ ppr ret_eq - ; return (ret_eq, rhs_xi, []) } - Nothing - | isGivenOrSolved fl -> - do { rhs_xi_var <- newFlattenSkolemTy fam_ty - ; (fl',eqv) - <- newGivenEqVar fl fam_ty rhs_xi_var (mkTcReflCo fam_ty) - ; let ct = CFunEqCan { cc_id = eqv - , cc_flavor = fl' -- Given - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_xi_var - , cc_depth = d } - -- Update the flat cache: just an optimisation! - ; updateFlatCache eqv fl' tc xi_args rhs_xi_var WhileFlattening - ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) } - | otherwise -> - -- Derived or Wanted: make a new /unification/ flatten variable - do { rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty) - ; let wanted_flavor = mkWantedFlavor fl - ; evc <- newEqVar wanted_flavor fam_ty rhs_xi_var - ; let eqv = evc_the_evvar evc -- Not going to be cached - ct = CFunEqCan { cc_id = eqv - , cc_flavor = wanted_flavor - -- Always Wanted, not Derived - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_xi_var - , cc_depth = d } - -- Update the flat cache: just an optimisation! - ; updateFlatCache eqv fl tc xi_args rhs_xi_var WhileFlattening - ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) } } - - -- Emit the flat constraints - ; updWorkListTcS $ appendWorkListEqs ct - - ; let (cos_args, cos_rest) = splitAt (tyConArity tc) cos - ; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable - -- cf Trac #5655 - , mkTcAppCos (mkTcSymCo ret_co `mkTcTransCo` mkTcTyConAppCo tc cos_args) - cos_rest - ) } - - -flatten d ctxt ty@(ForAllTy {}) --- We allow for-alls when, but only when, no type function --- applications inside the forall involve the bound type variables. - = do { let (tvs, rho) = splitForAllTys ty - ; when (under_families tvs rho) $ wrapErrTcS $ flattenForAllErrorTcS ctxt ty - ; (rho', co) <- flatten d ctxt rho - ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } - - where under_families tvs rho - = go (mkVarSet tvs) rho - where go _bound (TyVarTy _tv) = False - go bound (TyConApp tc tys) - | isSynFamilyTyCon tc - , (args,rest) <- splitAt (tyConArity tc) tys - = (tyVarsOfTypes args `intersectsVarSet` bound) || any (go bound) rest - | otherwise = any (go bound) tys - go bound (FunTy arg res) = go bound arg || go bound res - go bound (AppTy fun arg) = go bound fun || go bound arg - go bound (ForAllTy tv ty) = go (bound `extendVarSet` tv) ty - - -getCachedFlatEq :: TyCon -> [Xi] -> CtFlavor - -> FlatEqOrigin - -> TcS (Maybe (Xi, TcCoercion)) --- Returns a coercion between (TyConApp tc xi_args ~ xi) if such an inert item exists --- But also applies the substitution to the item via calling flatten recursively -getCachedFlatEq tc xi_args fl feq_origin - = do { let pty = mkTyConApp tc xi_args - ; traceTcS "getCachedFlatEq" $ ppr (mkTyConApp tc xi_args) - ; flat_cache <- getTcSEvVarFlatCache - ; inerts <- getTcSInerts - ; case lookupFunEq pty fl (inert_funeqs inerts) of - Nothing - -> lookup_in_flat_cache pty flat_cache - res -> return res } - where lookup_in_flat_cache pty flat_cache - = case lookupTM pty flat_cache of - Just (co',(xi',fl',when_generated)) -- ev' :: (TyConApp tc xi_args) ~ xi' - | fl' `canRewrite` fl - , feq_origin `origin_matches` when_generated - -> do { traceTcS "getCachedFlatEq" $ text "success!" - ; (xi'',co) <- flatten 0 fl' xi' -- co :: xi'' ~ xi' - -- The only purpose of this flattening is to apply the - -- inert substitution (since everything in the flat cache - -- by construction will have a family-free RHS. - ; return $ Just (xi'', co' `mkTcTransCo` (mkTcSymCo co)) } - _ -> do { traceTcS "getCachedFlatEq" $ text "failure!" <+> pprEvVarCache flat_cache - ; return Nothing } - ----------------- addToWork :: TcS StopOrContinue -> TcS () addToWork tcs_action = tcs_action >>= stop_or_emit where stop_or_emit Stop = return () stop_or_emit (ContinueWith ct) = updWorkListTcS $ extendWorkListCt ct +\end{code} + -canEqEvVarsCreated :: SubGoalDepth - -> [CtFlavor] -> [EvVarCreated] -> [Type] -> [Type] - -> TcS StopOrContinue -canEqEvVarsCreated _d _fl [] _ _ = return Stop -canEqEvVarsCreated d (fl:fls) (evc:evcs) (ty1:tys1) (ty2:tys2) - | isNewEvVar evc - = let do_one evc0 sy1 sy2 - | isNewEvVar evc0 - = canEq_ d fl (evc_the_evvar evc0) sy1 sy2 - | otherwise = return () - in do { _unused <- zipWith3M do_one evcs tys1 tys2 - ; canEq d fl (evc_the_evvar evc) ty1 ty2 } - | otherwise - = canEqEvVarsCreated d fls evcs tys1 tys2 -canEqEvVarsCreated _ _ _ _ _ = return Stop - - -canEq_ :: SubGoalDepth - -> CtFlavor -> EqVar -> Type -> Type -> TcS () -canEq_ d fl eqv ty1 ty2 = addToWork (canEq d fl eqv ty1 ty2) - -canEq :: SubGoalDepth - -> CtFlavor -> EqVar -> Type -> Type -> TcS StopOrContinue -canEq _d fl eqv ty1 ty2 +%************************************************************************ +%* * +%* Equalities +%* * +%************************************************************************ + +\begin{code} +canEqEvVarsCreated :: SubGoalDepth + -> [CtEvidence] -> TcS StopOrContinue +canEqEvVarsCreated _d [] = return Stop +canEqEvVarsCreated d (quad:quads) + = mapM_ (addToWork . do_quad) quads >> do_quad quad + -- Add all but one to the work list + -- and return the first (if any) for futher processing + where do_quad fl = let EqPred ty1 ty2 = classifyPredType $ ctEvPred fl + in canEqNC d fl ty1 ty2 + -- Note the "NC": these are fresh equalities so we must be + -- careful to add their kind constraints + +------------------------- +canEqNC, canEq + :: SubGoalDepth + -> CtEvidence + -> Type -> Type -> TcS StopOrContinue + +canEqNC d fl ty1 ty2 + = canEq d fl ty1 ty2 + `andWhenContinue` emitKindConstraint + +canEq _d fl ty1 ty2 | eqType ty1 ty2 -- Dealing with equality here avoids -- later spurious occurs checks for a~a - = do { when (isWanted fl) $ - do { _ <- setEqBind eqv (mkTcReflCo ty1) fl; return () } - ; return Stop } + = if isWanted fl then + setEvBind (ctev_evar fl) (EvCoercion (mkTcReflCo ty1)) >> return Stop + else + return Stop -- If one side is a variable, orient and flatten, -- WITHOUT expanding type synonyms, so that we tend to -- substitute a ~ Age rather than a ~ Int when @type Age = Int@ -canEq d fl eqv ty1@(TyVarTy {}) ty2 - = canEqLeaf d fl eqv ty1 ty2 -canEq d fl eqv ty1 ty2@(TyVarTy {}) - = canEqLeaf d fl eqv ty1 ty2 +canEq d fl ty1@(TyVarTy {}) ty2 + = canEqLeaf d fl ty1 ty2 +canEq d fl ty1 ty2@(TyVarTy {}) + = canEqLeaf d fl ty1 ty2 -- See Note [Naked given applications] -canEq d fl eqv ty1 ty2 - | Just ty1' <- tcView ty1 = canEq d fl eqv ty1' ty2 - | Just ty2' <- tcView ty2 = canEq d fl eqv ty1 ty2' +canEq d fl ty1 ty2 + | Just ty1' <- tcView ty1 = canEq d fl ty1' ty2 + | Just ty2' <- tcView ty2 = canEq d fl ty1 ty2' -canEq d fl eqv ty1@(TyConApp fn tys) ty2 +canEq d fl ty1@(TyConApp fn tys) ty2 | isSynFamilyTyCon fn, length tys == tyConArity fn - = canEqLeaf d fl eqv ty1 ty2 -canEq d fl eqv ty1 ty2@(TyConApp fn tys) + = canEqLeaf d fl ty1 ty2 +canEq d fl ty1 ty2@(TyConApp fn tys) | isSynFamilyTyCon fn, length tys == tyConArity fn - = canEqLeaf d fl eqv ty1 ty2 + = canEqLeaf d fl ty1 ty2 -canEq d fl eqv ty1 ty2 +canEq d fl ty1 ty2 | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1 , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2 , isDecomposableTyCon tc1 && isDecomposableTyCon tc2 = -- Generate equalities for each of the corresponding arguments if (tc1 /= tc2 || length tys1 /= length tys2) -- Fail straight away for better error messages - then canEqFailure d fl eqv - else do { - let (kis1, tys1') = span isKind tys1 - (_kis2, tys2') = span isKind tys2 - kicos = map mkTcReflCo kis1 - - ; argeqvs <- zipWithM (newEqVar fl) tys1' tys2' - ; fls <- case fl of - Wanted {} -> - do { _ <- setEqBind eqv - (mkTcTyConAppCo tc1 (kicos ++ map (mkTcCoVarCo . evc_the_evvar) argeqvs)) fl - ; return (map (\_ -> fl) argeqvs) } - Given {} -> - let do_one argeqv n = setEqBind (evc_the_evvar argeqv) - (mkTcNthCo n (mkTcCoVarCo eqv)) fl - in zipWithM do_one argeqvs [(length kicos)..] - Derived {} -> return (map (\_ -> fl) argeqvs) - - ; canEqEvVarsCreated d fls argeqvs tys1' tys2' } + then canEqFailure d fl + else + do { let xcomp xs = EvCoercion (mkTcTyConAppCo tc1 (map evTermCoercion xs)) + xdecomp x = zipWith (\_ i -> EvCoercion $ mkTcNthCo i (evTermCoercion x)) tys1 [0..] + xev = XEvTerm xcomp xdecomp + ; ctevs <- xCtFlavor fl (zipWith mkTcEqPred tys1 tys2) xev + ; canEqEvVarsCreated d ctevs } -- See Note [Equality between type applications] -- Note [Care with type applications] in TcUnify -canEq d fl eqv ty1 ty2 -- e.g. F a b ~ Maybe c +canEq d fl ty1 ty2 -- e.g. F a b ~ Maybe c -- where F has arity 1 | Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = canEqAppTy d fl eqv s1 t1 s2 t2 - -canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {}) - | tcIsForAllTy s1, tcIsForAllTy s2, - Wanted {} <- fl - = canEqFailure d fl eqv + = canEqAppTy d fl s1 t1 s2 t2 + +canEq d fl s1@(ForAllTy {}) s2@(ForAllTy {}) + | tcIsForAllTy s1, tcIsForAllTy s2 + , Wanted { ctev_wloc = loc, ctev_evar = orig_ev } <- fl + = do { let (tvs1,body1) = tcSplitForAllTys s1 + (tvs2,body2) = tcSplitForAllTys s2 + ; if not (equalLength tvs1 tvs2) then + canEqFailure d fl + else + do { traceTcS "Creating implication for polytype equality" $ ppr fl + ; deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2) + ; return Stop } } | otherwise - = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2) + = do { traceTcS "Ommitting decomposition of given polytype equality" $ + pprEq s1 s2 ; return Stop } +canEq d fl _ _ = canEqFailure d fl -canEq d fl eqv _ _ = canEqFailure d fl eqv - +------------------------ -- Type application canEqAppTy :: SubGoalDepth - -> CtFlavor -> EqVar -> Type -> Type -> Type -> Type + -> CtEvidence + -> Type -> Type -> Type -> Type -> TcS StopOrContinue -canEqAppTy d fl eqv s1 t1 s2 t2 +canEqAppTy d fl s1 t1 s2 t2 = ASSERT( not (isKind t1) && not (isKind t2) ) - if isGivenOrSolved fl then + if isGiven fl then do { traceTcS "canEq (app case)" $ text "Ommitting decomposition of given equality between: " <+> ppr (AppTy s1 t1) <+> text "and" <+> ppr (AppTy s2 t2) -- We cannot decompose given applications -- because we no longer have 'left' and 'right' ; return Stop } - else - do { evc1 <- newEqVar fl s1 s2 - ; evc2 <- newEqVar fl t1 t2 - ; let eqv1 = evc_the_evvar evc1 - eqv2 = evc_the_evvar evc2 - - ; when (isWanted fl) $ - do { _ <- setEqBind eqv (mkTcAppCo (mkTcCoVarCo eqv1) (mkTcCoVarCo eqv2)) fl - ; return () } - - ; canEqEvVarsCreated d [fl,fl] [evc1,evc2] [s1,t1] [s2,t2] } - -canEqFailure :: SubGoalDepth - -> CtFlavor -> EvVar -> TcS StopOrContinue -canEqFailure d fl eqv - = do { when (isWanted fl) (delCachedEvVar eqv fl) - -- See Note [Combining insoluble constraints] - ; emitFrozenError fl eqv d - ; return Stop } + else + do { let xevcomp [x,y] = EvCoercion (mkTcAppCo (evTermCoercion x) (evTermCoercion y)) + xevcomp _ = error "canEqAppTy: can't happen" -- Can't happen + xev = XEvTerm { ev_comp = xevcomp + , ev_decomp = error "canEqAppTy: can't happen" } + ; ctevs <- xCtFlavor fl [mkTcEqPred s1 s2, mkTcEqPred t1 t2] xev + ; canEqEvVarsCreated d ctevs } + +canEqFailure :: SubGoalDepth -> CtEvidence -> TcS StopOrContinue +canEqFailure d fl = emitFrozenError fl d >> return Stop + +------------------------ +emitKindConstraint :: Ct -> TcS StopOrContinue +emitKindConstraint ct + = case ct of + CTyEqCan { cc_depth = d + , cc_ev = fl, cc_tyvar = tv + , cc_rhs = ty } + -> emit_kind_constraint d fl (mkTyVarTy tv) ty + + CFunEqCan { cc_depth = d + , cc_ev = fl + , cc_fun = fn, cc_tyargs = xis1 + , cc_rhs = xi2 } + -> emit_kind_constraint d fl (mkTyConApp fn xis1) xi2 + + _ -> continueWith ct + where + emit_kind_constraint d fl ty1 ty2 + | compatKind k1 k2 -- True when ty1,ty2 are themselves kinds, + = continueWith ct -- because then k1, k2 are BOX + + | otherwise + = ASSERT( isKind k1 && isKind k2 ) + do { kev <- + do { mw <- newWantedEvVar kind_co_wloc (mkEqPred k1 k2) + ; case mw of + Cached ev_tm -> return ev_tm + Fresh ctev -> do { addToWork (canEq d ctev k1 k2) + ; return (ctEvTerm ctev) } } + + ; let xcomp [x] = mkEvKindCast x (evTermCoercion kev) + xcomp _ = panic "emit_kind_constraint:can't happen" + xdecomp x = [mkEvKindCast x (evTermCoercion kev)] + xev = XEvTerm xcomp xdecomp + + ; ctevs <- xCtFlavor_cache False fl [mkTcEqPred ty1 ty2] xev + -- Important: Do not cache original as Solved since we are supposed to + -- solve /exactly/ the same constraint later! Example: + -- (alpha :: kappa0) + -- (T :: *) + -- Equality is: (alpha ~ T), so we will emitConstraint (kappa0 ~ *) but + -- we don't want to say that (alpha ~ T) is now Solved! + + ; case ctevs of + [] -> return Stop + [new_ctev] -> continueWith (ct { cc_ev = new_ctev }) + _ -> panic "emitKindConstraint" } + where + k1 = typeKind ty1 + k2 = typeKind ty2 + ctxt = mkKindErrorCtxtTcS ty1 k1 ty2 k2 + + -- Always create a Wanted kind equality even if + -- you are decomposing a given constraint. + -- NB: DV finds this reasonable for now. Maybe we have to revisit. + kind_co_wloc = pushErrCtxtSameOrigin ctxt wanted_loc + wanted_loc = case fl of + Wanted { ctev_wloc = wloc } -> wloc + Derived { ctev_wloc = wloc } -> wloc + Given { ctev_gloc = gloc } -> setCtLocOrigin gloc orig + orig = TypeEqOrigin (UnifyOrigin ty1 ty2) \end{code} Note [Combining insoluble constraints] @@ -1064,13 +1024,6 @@ data TypeClassifier | FunCls TyCon [Type] -- ^ Type function, exactly saturated | OtherCls TcType -- ^ Neither of the above -{- Useless these days! -unClassify :: TypeClassifier -> TcType -unClassify (VarCls tv) = TyVarTy tv -unClassify (FskCls tv) = TyVarTy tv -unClassify (FunCls fn tys) = TyConApp fn tys -unClassify (OtherCls ty) = ty --} classify :: TcType -> TypeClassifier @@ -1089,7 +1042,7 @@ classify ty | Just ty' <- tcView ty = OtherCls ty -- See note [Canonical ordering for equality constraints]. -reOrient :: CtFlavor -> TypeClassifier -> TypeClassifier -> Bool +reOrient :: CtEvidence -> TypeClassifier -> TypeClassifier -> Bool -- (t1 `reOrient` t2) responds True -- iff we should flip to (t2~t1) -- We try to say False if possible, to minimise evidence generation @@ -1126,7 +1079,7 @@ reOrient _fl (FskCls {}) (OtherCls {}) = False ------------------ canEqLeaf :: SubGoalDepth -- Depth - -> CtFlavor -> EqVar + -> CtEvidence -> Type -> Type -> TcS StopOrContinue -- Canonicalizing "leaf" equality constraints which cannot be @@ -1136,264 +1089,167 @@ canEqLeaf :: SubGoalDepth -- Depth -- Preconditions: -- * one of the two arguments is variable or family applications -- * the two types are not equal (looking through synonyms) -canEqLeaf d fl eqv s1 s2 +canEqLeaf d fl s1 s2 | cls1 `re_orient` cls2 - = do { traceTcS "canEqLeaf (reorienting)" $ ppr eqv <+> dcolon <+> pprEq s1 s2 - ; delCachedEvVar eqv fl - ; evc <- newEqVar fl s2 s1 - ; let eqv' = evc_the_evvar evc - ; fl' <- case fl of - Wanted {} -> setEqBind eqv (mkTcSymCo (mkTcCoVarCo eqv')) fl - Given {} -> setEqBind eqv' (mkTcSymCo (mkTcCoVarCo eqv)) fl - Derived {} -> return fl - ; if isNewEvVar evc then - do { canEqLeafOriented d fl' eqv' s2 s1 } - else return Stop - } + = do { traceTcS "canEqLeaf (reorienting)" $ ppr fl <+> dcolon <+> pprEq s1 s2 + ; let xcomp [x] = EvCoercion (mkTcSymCo (evTermCoercion x)) + xcomp _ = panic "canEqLeaf: can't happen" + xdecomp x = [EvCoercion (mkTcSymCo (evTermCoercion x))] + xev = XEvTerm xcomp xdecomp + ; ctevs <- xCtFlavor fl [mkTcEqPred s2 s1] xev + ; case ctevs of + [] -> return Stop + [ctev] -> canEqLeafOriented d ctev s2 s1 + _ -> panic "canEqLeaf" } + | otherwise - = do { traceTcS "canEqLeaf" $ ppr (mkEqPred (s1,s2)) - ; canEqLeafOriented d fl eqv s1 s2 } + = do { traceTcS "canEqLeaf" $ ppr (mkTcEqPred s1 s2) + ; canEqLeafOriented d fl s1 s2 } where re_orient = reOrient fl cls1 = classify s1 cls2 = classify s2 canEqLeafOriented :: SubGoalDepth -- Depth - -> CtFlavor -> EqVar + -> CtEvidence -> TcType -> TcType -> TcS StopOrContinue -- By now s1 will either be a variable or a type family application -canEqLeafOriented d fl eqv s1 s2 - = can_eq_split_lhs d fl eqv s1 s2 - where can_eq_split_lhs d fl eqv s1 s2 +canEqLeafOriented d fl s1 s2 + = can_eq_split_lhs d fl s1 s2 + where can_eq_split_lhs d fl s1 s2 | Just (fn,tys1) <- splitTyConApp_maybe s1 - = canEqLeafFunEqLeftRec d fl eqv (fn,tys1) s2 + = canEqLeafFunEqLeftRec d fl (fn,tys1) s2 | Just tv <- getTyVar_maybe s1 - = canEqLeafTyVarLeftRec d fl eqv tv s2 + = canEqLeafTyVarLeftRec d fl tv s2 | otherwise = pprPanic "canEqLeafOriented" $ - text "Non-variable or non-family equality LHS" <+> - ppr eqv <+> dcolon <+> ppr (evVarPred eqv) + text "Non-variable or non-family equality LHS" <+> ppr (ctEvPred fl) canEqLeafFunEqLeftRec :: SubGoalDepth - -> CtFlavor - -> EqVar + -> CtEvidence -> (TyCon,[TcType]) -> TcType -> TcS StopOrContinue -canEqLeafFunEqLeftRec d fl eqv (fn,tys1) ty2 -- eqv :: F tys1 ~ ty2 +canEqLeafFunEqLeftRec d fl (fn,tys1) ty2 -- fl :: F tys1 ~ ty2 = do { traceTcS "canEqLeafFunEqLeftRec" $ pprEq (mkTyConApp fn tys1) ty2 ; (xis1,cos1) <- {-# SCC "flattenMany" #-} - flattenMany d fl tys1 -- Flatten type function arguments - -- cos1 :: xis1 ~ tys1 - --- ; inerts <- getTcSInerts --- ; let fam_eqs = inert_funeqs inerts - - ; let flat_ty = mkTyConApp fn xis1 - - ; is_cached <- getCachedFlatEq fn xis1 fl WhenSolved - -- Lookup if we have solved this goal already -{- - ; let is_cached = {-# SCC "lookupFunEq" #-} - lookupFunEq flat_ty fl fam_eqs --} - ; let no_flattening = all isTcReflCo cos1 - - ; if no_flattening && isNothing is_cached then - canEqLeafFunEqLeft d fl eqv (fn,xis1) ty2 - else do - { let (final_co, final_ty) - | no_flattening -- Just in inerts - , Just (rhs_ty, ret_eq) <- is_cached - = (mkTcSymCo ret_eq, rhs_ty) - | Nothing <- is_cached -- Just flattening - = (mkTcTyConAppCo fn cos1, flat_ty) - | Just (rhs_ty, ret_eq) <- is_cached -- Both - = (mkTcSymCo ret_eq `mkTcTransCo` mkTcTyConAppCo fn cos1, rhs_ty) - | otherwise = panic "No flattening and not cached!" - ; delCachedEvVar eqv fl - ; evc <- newEqVar fl final_ty ty2 - ; let new_eqv = evc_the_evvar evc - ; fl' <- case fl of - Wanted {} -> setEqBind eqv - (mkTcSymCo final_co `mkTcTransCo` (mkTcCoVarCo new_eqv)) fl - Given {} -> setEqBind new_eqv (final_co `mkTcTransCo` (mkTcCoVarCo eqv)) fl - Derived {} -> return fl - ; if isNewEvVar evc then - if isNothing is_cached then - {-# SCC "canEqLeafFunEqLeft" #-} - canEqLeafFunEqLeft d fl' new_eqv (fn,xis1) ty2 - else - canEq (d+1) fl' new_eqv final_ty ty2 - else return Stop - } - } - -lookupFunEq :: PredType -> CtFlavor -> TypeMap Ct -> Maybe (TcType, TcCoercion) -lookupFunEq pty fl fam_eqs = lookup_funeq pty fam_eqs - where lookup_funeq pty fam_eqs - | Just ct <- lookupTM pty fam_eqs - , cc_flavor ct `canRewrite` fl - = Just (cc_rhs ct, mkTcCoVarCo (cc_id ct)) - | otherwise - = Nothing + flattenMany d FMFullFlatten fl tys1 -- Flatten type function arguments + -- cos1 :: xis1 ~ tys1 + + ; let fam_head = mkTyConApp fn xis1 + -- Fancy higher-dimensional coercion between equalities! + ; let co = mkTcTyConAppCo eqTyCon $ + [mkTcReflCo (defaultKind $ typeKind ty2), mkTcTyConAppCo fn cos1, mkTcReflCo ty2] + -- Why defaultKind? Same reason as the comment on TcType/mkTcEqPred. I trully hate this (DV) + -- co :: (F xis1 ~ ty2) ~ (F tys1 ~ ty2) + + ; mb <- rewriteCtFlavor fl (mkTcEqPred fam_head ty2) co + ; case mb of + Nothing -> return Stop + Just new_fl -> canEqLeafFunEqLeft d new_fl (fn,xis1) ty2 } + canEqLeafFunEqLeft :: SubGoalDepth -- Depth - -> CtFlavor -> EqVar -> (TyCon,[Xi]) + -> CtEvidence + -> (TyCon,[Xi]) -> TcType -> TcS StopOrContinue -- Precondition: No more flattening is needed for the LHS -canEqLeafFunEqLeft d fl eqv (fn,xis1) s2 +canEqLeafFunEqLeft d fl (fn,xis1) s2 = {-# SCC "canEqLeafFunEqLeft" #-} do { traceTcS "canEqLeafFunEqLeft" $ pprEq (mkTyConApp fn xis1) s2 ; (xi2,co2) <- {-# SCC "flatten" #-} - flatten d fl s2 -- co2 :: xi2 ~ s2 - ; let no_flattening_happened = isTcReflCo co2 - ; if no_flattening_happened then - continueWith $ CFunEqCan { cc_id = eqv - , cc_flavor = fl - , cc_fun = fn - , cc_tyargs = xis1 - , cc_rhs = xi2 - , cc_depth = d } - else do { delCachedEvVar eqv fl - ; evc <- - {-# SCC "newEqVar" #-} - newEqVar fl (mkTyConApp fn xis1) xi2 - ; let new_eqv = evc_the_evvar evc -- F xis1 ~ xi2 - new_cv = mkTcCoVarCo new_eqv - cv = mkTcCoVarCo eqv -- F xis1 ~ s2 - ; fl' <- case fl of - Wanted {} -> setEqBind eqv (new_cv `mkTcTransCo` co2) fl - Given {} -> setEqBind new_eqv (cv `mkTcTransCo` mkTcSymCo co2) fl - Derived {} -> return fl - ; if isNewEvVar evc then - do { continueWith $ - CFunEqCan { cc_id = new_eqv - , cc_flavor = fl' - , cc_fun = fn - , cc_tyargs = xis1 - , cc_rhs = xi2 - , cc_depth = d } } - else return Stop } } + flatten d FMFullFlatten fl s2 -- co2 :: xi2 ~ s2 + + ; let fam_head = mkTyConApp fn xis1 + -- Fancy coercion between equalities! But it should just work! + ; let co = mkTcTyConAppCo eqTyCon $ [ mkTcReflCo (defaultKind $ typeKind s2) + , mkTcReflCo fam_head, co2 ] + -- Why defaultKind? Same reason as the comment at TcType/mkTcEqPred + -- co :: (F xis1 ~ xi2) ~ (F xis1 ~ s2) + -- new pred old pred + ; mb <- rewriteCtFlavor fl (mkTcEqPred fam_head xi2) co + ; case mb of + Nothing -> return Stop + Just new_fl -> continueWith $ + CFunEqCan { cc_ev = new_fl, cc_depth = d + , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } } canEqLeafTyVarLeftRec :: SubGoalDepth - -> CtFlavor -> EqVar + -> CtEvidence -> TcTyVar -> TcType -> TcS StopOrContinue -canEqLeafTyVarLeftRec d fl eqv tv s2 -- eqv :: tv ~ s2 +canEqLeafTyVarLeftRec d fl tv s2 -- fl :: tv ~ s2 = do { traceTcS "canEqLeafTyVarLeftRec" $ pprEq (mkTyVarTy tv) s2 - ; (xi1,co1) <- flatten d fl (mkTyVarTy tv) -- co1 :: xi1 ~ tv - ; case isTcReflCo co1 of - True -- If reflco and variable, just go on - | Just tv' <- getTyVar_maybe xi1 - -> canEqLeafTyVarLeft d fl eqv tv' s2 - _ -> -- If not a variable or not refl co, must rewrite and go on - do { delCachedEvVar eqv fl - ; evc <- newEqVar fl xi1 s2 -- new_ev :: xi1 ~ s2 - ; let new_ev = evc_the_evvar evc - ; fl' <- case fl of - Wanted {} -> setEqBind eqv - (mkTcSymCo co1 `mkTcTransCo` mkTcCoVarCo new_ev) fl - Given {} -> setEqBind new_ev - (co1 `mkTcTransCo` mkTcCoVarCo eqv) fl - Derived {} -> return fl - ; if isNewEvVar evc then - do { canEq d fl' new_ev xi1 s2 } - else return Stop - } - } - + ; (xi1,co1) <- flattenTyVar d FMFullFlatten fl tv -- co1 :: xi1 ~ tv + ; let is_still_var = isJust (getTyVar_maybe xi1) + + ; traceTcS "canEqLeafTyVarLeftRec2" $ empty + + ; let co = mkTcTyConAppCo eqTyCon $ [ mkTcReflCo (defaultKind $ typeKind s2) + , co1, mkTcReflCo s2] + -- co :: (xi1 ~ s2) ~ (tv ~ s2) + ; mb <- rewriteCtFlavor_cache (if is_still_var then False else True) fl (mkTcEqPred xi1 s2) co + -- See Note [Caching loops] + + ; traceTcS "canEqLeafTyVarLeftRec3" $ empty + + ; case mb of + Nothing -> return Stop + Just new_fl -> + case getTyVar_maybe xi1 of + Just tv' -> canEqLeafTyVarLeft d new_fl tv' s2 + Nothing -> canEq d new_fl xi1 s2 } + canEqLeafTyVarLeft :: SubGoalDepth -- Depth - -> CtFlavor -> EqVar + -> CtEvidence -> TcTyVar -> TcType -> TcS StopOrContinue -- Precondition LHS is fully rewritten from inerts (but not RHS) -canEqLeafTyVarLeft d fl eqv tv s2 -- eqv : tv ~ s2 - = do { traceTcS "canEqLeafTyVarLeft" (pprEq (mkTyVarTy tv) s2) - ; (xi2, co) <- flatten d fl s2 -- Flatten RHS co : xi2 ~ s2 - - ; let no_flattening_happened = isTcReflCo co - +canEqLeafTyVarLeft d fl tv s2 -- eqv : tv ~ s2 + = do { let tv_ty = mkTyVarTy tv + ; traceTcS "canEqLeafTyVarLeft" (pprEq tv_ty s2) + ; (xi2, co2) <- flatten d FMFullFlatten fl s2 -- Flatten RHS co:xi2 ~ s2 + ; traceTcS "canEqLeafTyVarLeft" (nest 2 (vcat [ text "tv =" <+> ppr tv , text "s2 =" <+> ppr s2 , text "xi2 =" <+> ppr xi2])) - -- Flattening the RHS may reveal an identity coercion, which should - -- not be reported as occurs check error! - ; let is_same_tv - | Just tv' <- getTyVar_maybe xi2, tv' == tv - = True - | otherwise = False - ; if is_same_tv then - do { delCachedEvVar eqv fl - ; when (isWanted fl) $ - do { _ <- setEqBind eqv co fl; return () } - ; return Stop } - else - do { -- Do an occurs check, and return a possibly - -- unfolded version of the RHS, if we had to - -- unfold any type synonyms to get rid of tv. - occ_check_result <- canOccursCheck fl tv xi2 - - ; let xi2' - | Just xi2_unfolded <- occ_check_result - = xi2_unfolded - | otherwise = xi2 - - - ; if no_flattening_happened then - if isNothing occ_check_result then - canEqFailure d fl (setVarType eqv $ mkEqPred (mkTyVarTy tv, xi2')) - else - continueWith $ CTyEqCan { cc_id = eqv - , cc_flavor = fl - , cc_tyvar = tv - , cc_rhs = xi2' - , cc_depth = d } - else -- Flattening happened, in any case we have to create new variable - -- even if we report an occurs check error - do { delCachedEvVar eqv fl - ; evc <- newEqVar fl (mkTyVarTy tv) xi2' - ; let eqv' = evc_the_evvar evc -- eqv' : tv ~ xi2' - cv = mkTcCoVarCo eqv -- cv : tv ~ s2 - cv' = mkTcCoVarCo eqv' -- cv': tv ~ xi2' - ; fl' <- case fl of - Wanted {} -> setEqBind eqv (cv' `mkTcTransCo` co) fl -- tv ~ xi2' ~ s2 - Given {} -> setEqBind eqv' (cv `mkTcTransCo` mkTcSymCo co) fl -- tv ~ s2 ~ xi2' - Derived {} -> return fl - - ; if isNewEvVar evc then - if isNothing occ_check_result then - canEqFailure d fl eqv' - else continueWith CTyEqCan { cc_id = eqv' - , cc_flavor = fl' - , cc_tyvar = tv - , cc_rhs = xi2' - , cc_depth = d } - else - return Stop } } } - - --- See Note [Type synonyms and canonicalization]. --- Check whether the given variable occurs in the given type. We may --- have needed to do some type synonym unfolding in order to get rid --- of the variable, so we also return the unfolded version of the --- type, which is guaranteed to be syntactically free of the given --- type variable. If the type is already syntactically free of the --- variable, then the same type is returned. --- --- Precondition: the two types are not equal (looking though synonyms) -canOccursCheck :: CtFlavor -> TcTyVar -> Xi -> TcS (Maybe Xi) -canOccursCheck _gw tv xi = return (expandAway tv xi) + -- Reflexivity exposed through flattening + ; if tv_ty `eqType` xi2 then + when (isWanted fl) (setEvBind (ctev_evar fl) (EvCoercion co2)) >> + return Stop + else do + -- Not reflexivity but maybe an occurs error + { let occ_check_result = occurCheckExpand tv xi2 + xi2' = fromMaybe xi2 occ_check_result + + not_occ_err = isJust occ_check_result + -- Delicate: don't want to cache as solved a constraint with occurs error! + co = mkTcTyConAppCo eqTyCon $ + [mkTcReflCo (defaultKind $ typeKind s2), mkTcReflCo tv_ty, co2] + ; mb <- rewriteCtFlavor_cache not_occ_err fl (mkTcEqPred tv_ty xi2') co + ; case mb of + Just new_fl -> if not_occ_err then + continueWith $ + CTyEqCan { cc_ev = new_fl, cc_depth = d + , cc_tyvar = tv, cc_rhs = xi2' } + else + canEqFailure d new_fl + Nothing -> return Stop + } } \end{code} -@expandAway tv xi@ expands synonyms in xi just enough to get rid of -occurrences of tv, if that is possible; otherwise, it returns Nothing. +Note [Occurs check expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +@occurCheckExpand tv xi@ expands synonyms in xi just enough to get rid +of occurrences of tv outside type function arguments, if that is +possible; otherwise, it returns Nothing. + For example, suppose we have type F a b = [a] Then - expandAway b (F Int b) = Just [Int] + occurCheckExpand b (F Int b) = Just [Int] but - expandAway a (F a Int) = Nothing + occurCheckExpand a (F a Int) = Nothing We don't promise to do the absolute minimum amount of expanding necessary, but we try not to do expansions we don't need to. We @@ -1401,47 +1257,61 @@ prefer doing inner expansions first. For example, type F a b = (a, Int, a, [a]) type G b = Char We have - expandAway b (F (G b)) = F Char + occurCheckExpand b (F (G b)) = F Char even though we could also expand F to get rid of b. +See also Note [Type synonyms and canonicalization]. + \begin{code} -expandAway :: TcTyVar -> Xi -> Maybe Xi -expandAway tv t@(TyVarTy tv') - | tv == tv' = Nothing - | otherwise = Just t -expandAway tv xi - | not (tv `elemVarSet` tyVarsOfType xi) = Just xi -expandAway tv (AppTy ty1 ty2) - = do { ty1' <- expandAway tv ty1 - ; ty2' <- expandAway tv ty2 - ; return (mkAppTy ty1' ty2') } --- mkAppTy <$> expandAway tv ty1 <*> expandAway tv ty2 -expandAway tv (FunTy ty1 ty2) - = do { ty1' <- expandAway tv ty1 - ; ty2' <- expandAway tv ty2 - ; return (mkFunTy ty1' ty2') } --- mkFunTy <$> expandAway tv ty1 <*> expandAway tv ty2 -expandAway tv ty@(ForAllTy {}) - = let (tvs,rho) = splitForAllTys ty - tvs_knds = map tyVarKind tvs - in if tv `elemVarSet` tyVarsOfTypes tvs_knds then - -- Can't expand away the kinds unless we create - -- fresh variables which we don't want to do at this point. - Nothing - else do { rho' <- expandAway tv rho - ; return (mkForAllTys tvs rho') } --- For a type constructor application, first try expanding away the --- offending variable from the arguments. If that doesn't work, next --- see if the type constructor is a type synonym, and if so, expand --- it and try again. -expandAway tv ty@(TyConApp tc tys) - = (mkTyConApp tc <$> mapM (expandAway tv) tys) <|> (tcView ty >>= expandAway tv) +occurCheckExpand :: TcTyVar -> Type -> Maybe Type +-- Check whether the given variable occurs in the given type. We may +-- have needed to do some type synonym unfolding in order to get rid +-- of the variable, so we also return the unfolded version of the +-- type, which is guaranteed to be syntactically free of the given +-- type variable. If the type is already syntactically free of the +-- variable, then the same type is returned. +occurCheckExpand tv ty + | not (tv `elemVarSet` tyVarsOfType ty) = Just ty + | otherwise = go ty + where + go t@(TyVarTy tv') | tv == tv' = Nothing + | otherwise = Just t + go ty@(LitTy {}) = return ty + go (AppTy ty1 ty2) = do { ty1' <- go ty1 + ; ty2' <- go ty2 + ; return (mkAppTy ty1' ty2') } + -- mkAppTy <$> go ty1 <*> go ty2 + go (FunTy ty1 ty2) = do { ty1' <- go ty1 + ; ty2' <- go ty2 + ; return (mkFunTy ty1' ty2') } + -- mkFunTy <$> go ty1 <*> go ty2 + go ty@(ForAllTy {}) + | tv `elemVarSet` tyVarsOfTypes tvs_knds = Nothing + -- Can't expand away the kinds unless we create + -- fresh variables which we don't want to do at this point. + | otherwise = do { rho' <- go rho + ; return (mkForAllTys tvs rho') } + where + (tvs,rho) = splitForAllTys ty + tvs_knds = map tyVarKind tvs + + -- For a type constructor application, first try expanding away the + -- offending variable from the arguments. If that doesn't work, next + -- see if the type constructor is a type synonym, and if so, expand + -- it and try again. + go ty@(TyConApp tc tys) + | isSynFamilyTyCon tc -- It's ok for tv to occur under a type family application + = return ty -- Eg. (a ~ F a) is not an occur-check error + -- NB This case can't occur during canonicalisation, + -- because the arg is a Xi-type, but can occur in the + -- call from TcErrors + | otherwise + = (mkTyConApp tc <$> mapM go tys) <|> (tcView ty >>= go) \end{code} Note [Type synonyms and canonicalization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We treat type synonym applications as xi types, that is, they do not count as type function applications. However, we do need to be a bit careful with type synonyms: like type functions they may not be diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index ac1895fe35..209215e8ec 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -15,7 +15,7 @@ Typechecking class declarations module TcClassDcl ( tcClassSigs, tcClassDecl2, findMethodBind, instantiateMethod, tcInstanceMethodBody, - mkGenericDefMethBind, + HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs, tcAddDeclCtxt, badMethodErr ) where @@ -40,13 +40,12 @@ import NameEnv import NameSet import Var import Outputable -import DynFlags -import ErrUtils import SrcLoc import Maybes import BasicTypes import Bag import FastString +import Util import Control.Monad \end{code} @@ -98,7 +97,9 @@ tcClassSigs :: Name -- Name of the class -> TcM ([TcMethInfo], -- Exactly one for each method NameEnv Type) -- Types of the generic-default methods tcClassSigs clas sigs def_methods - = do { gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs + = do { traceTc "tcClassSigs 1" (ppr clas) + + ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs ; let gen_dm_env = mkNameEnv gen_dm_prs ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs @@ -112,6 +113,7 @@ tcClassSigs clas sigs def_methods | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] -- Generic signature without value binding + ; traceTc "tcClassSigs 2" (ppr clas) ; return (op_info, gen_dm_env) } where vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs] @@ -120,7 +122,9 @@ tcClassSigs clas sigs def_methods dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] tc_sig genop_env (op_names, op_hs_ty) - = do { op_ty <- tcHsType op_hs_ty -- Class tyvars already in scope + = do { traceTc "ClsSig 1" (ppr op_names) + ; op_ty <- tcClassSigType op_hs_ty -- Class tyvars already in scope + ; traceTc "ClsSig 2" (ppr op_names) ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] } where f nm | nm `elemNameEnv` genop_env = GenericDM @@ -128,7 +132,7 @@ tcClassSigs clas sigs def_methods | otherwise = NoDM tc_gen_sig (op_names, gen_hs_ty) - = do { gen_op_ty <- tcHsType gen_hs_ty + = do { gen_op_ty <- tcClassSigType gen_hs_ty ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] } \end{code} @@ -160,8 +164,8 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, ; let (tyvars, _, _, op_items) = classBigSig clas prag_fn = mkPragFun sigs default_binds - sig_fn = mkSigFun sigs - clas_tyvars = tcSuperSkolTyVars tyvars + sig_fn = mkHsSigFun sigs + clas_tyvars = snd (tcSuperSkolTyVars tyvars) pred = mkClassPred clas (mkTyVarTys clas_tyvars) ; this_dict <- newEvVar pred @@ -178,7 +182,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name - -> SigFun -> PragFun -> ClassOpItem + -> HsSigFun -> PragFun -> ClassOpItem -> TcM (LHsBinds TcId) -- Generate code for polymorphic default methods only (hence DefMeth) -- (Generic default methods have turned into instance decls by now.) @@ -186,7 +190,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -- default method for every class op, regardless of whether or not -- the programmer supplied an explicit default decl for the class. -- (If necessary we can fix that, but we don't have a convenient Id to hand.) -tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) +tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) = case dm_info of NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags ; return emptyBag } @@ -195,7 +199,6 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) where sel_name = idName sel_id prags = prag_fn sel_name - dm_sig_fn _ = sig_fn sel_name dm_bind = findMethodBind sel_name binds_in `orElse` pprPanic "tcDefMeth" (ppr sel_id) @@ -212,44 +215,44 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) -- Base the local_dm_name on the selector name, because -- type errors from tcInstanceMethodBody come from here - ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars) - local_dm_id = mkLocalId local_dm_name local_dm_ty ; dm_id_w_inline <- addInlinePrags dm_id prags ; spec_prags <- tcSpecPrags dm_id prags + ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars) + hs_ty = lookupHsSig hs_sig_fn sel_name + `orElse` pprPanic "tc_dm" (ppr sel_name) + + ; local_dm_sig <- instTcTySig hs_ty local_dm_ty local_dm_name ; warnTc (not (null spec_prags)) (ptext (sLit "Ignoring SPECIALISE pragmas on default method") <+> quotes (ppr sel_name)) ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict] - dm_id_w_inline local_dm_id dm_sig_fn + dm_id_w_inline local_dm_sig IsDefaultMethod dm_bind ; return (unitBag tc_bind) } --------------- tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] - -> Id -> Id - -> SigFun -> TcSpecPrags -> LHsBind Name + -> Id -> TcSigInfo + -> TcSpecPrags -> LHsBind Name -> TcM (LHsBind Id) tcInstanceMethodBody skol_info tyvars dfun_ev_vars - meth_id local_meth_id - meth_sig_fn specs - (L loc bind) + meth_id local_meth_sig + specs (L loc bind) = do { -- Typecheck the binding, first extending the envt -- so that when tcInstSig looks up the local_meth_id to find -- its signature, we'll find it in the environment - let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) + let local_meth_id = sig_id local_meth_sig + lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind - ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id))) ; (ev_binds, (tc_bind, _, _)) <- checkConstraints skol_info tyvars dfun_ev_vars $ tcExtendIdEnv [local_meth_id] $ - tcPolyBinds TopLevel meth_sig_fn no_prag_fn - NonRecursive NonRecursive - [lm_bind] + tcPolyCheck local_meth_sig no_prag_fn NonRecursive [lm_bind] ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id , abe_mono = local_meth_id, abe_prags = specs } @@ -289,6 +292,20 @@ instantiateMethod clas sel_id inst_tys --------------------------- +type HsSigFun = NameEnv (LHsType Name) + +emptyHsSigs :: HsSigFun +emptyHsSigs = emptyNameEnv + +mkHsSigFun :: [LSig Name] -> HsSigFun +mkHsSigFun sigs = mkNameEnv [(n, hs_ty) + | L _ (TypeSig ns hs_ty) <- sigs + , L _ n <- ns ] + +lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name) +lookupHsSig = lookupNameEnv + +--------------------------- findMethodBind :: Name -- Selector name -> LHsBinds Name -- A group of bindings -> Maybe (LHsBind Name) -- The binding @@ -330,52 +347,6 @@ This makes the error messages right. %************************************************************************ %* * - Extracting generic instance declaration from class declarations -%* * -%************************************************************************ - -@getGenericInstances@ extracts the generic instance declarations from a class -declaration. For exmaple - - class C a where - op :: a -> a - - op{ x+y } (Inl v) = ... - op{ x+y } (Inr v) = ... - op{ x*y } (v :*: w) = ... - op{ 1 } Unit = ... - -gives rise to the instance declarations - - instance C (x+y) where - op (Inl v) = ... - op (Inr v) = ... - - instance C (x*y) where - op (v :*: w) = ... - - instance C 1 where - op Unit = ... - -\begin{code} -mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name) -mkGenericDefMethBind clas inst_tys sel_id dm_name - = -- A generic default method - -- If the method is defined generically, we only have to call the - -- dm_name. - do { dflags <- getDynFlags - ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" - (vcat [ppr clas <+> ppr inst_tys, - nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) - - ; return (noLoc $ mkTopFunBind (noLoc (idName sel_id)) - [mkSimpleMatch [] rhs]) } - where - rhs = nlHsVar dm_name -\end{code} - -%************************************************************************ -%* * Error messages %* * %************************************************************************ @@ -385,18 +356,7 @@ tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a tcAddDeclCtxt decl thing_inside = addErrCtxt ctxt thing_inside where - thing | isClassDecl decl = "class" - | isTypeDecl decl = "type synonym" ++ maybeInst - | isDataDecl decl = if tcdND decl == NewType - then "newtype" ++ maybeInst - else "data type" ++ maybeInst - | isFamilyDecl decl = "family" - | otherwise = panic "tcAddDeclCtxt/thing" - - maybeInst | isFamInstDecl decl = " instance" - | otherwise = "" - - ctxt = hsep [ptext (sLit "In the"), text thing, + ctxt = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl, ptext (sLit "declaration for"), quotes (ppr (tcdName decl))] badMethodErr :: Outputable a => a -> Name -> SDoc diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 7751ae49d2..dd797ab274 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -23,6 +23,7 @@ import DynFlags import TcRnMonad import FamInst import TcEnv +import TcTyClsDecls( tcFamTyPats, tcAddFamInstCtxt ) import TcClassDcl( tcAddDeclCtxt ) -- Small helper import TcGenDeriv -- Deriv stuff import TcGenGenerics @@ -61,6 +62,7 @@ import FastString import Bag import Control.Monad +import Data.List \end{code} %************************************************************************ @@ -315,33 +317,42 @@ tcDeriving tycl_decls inst_decls deriv_decls ; traceTc "tcDeriving" (ppr is_boot) ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls + -- for each type, determine the auxliary declarations that are common + -- to multiple derivations involving that type (e.g. Generic and + -- Generic1 should use the same TcGenGenerics.MetaTyCons) + ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map (either id id) early_specs + ; overlap_flag <- getOverlapFlag ; let (infer_specs, given_specs) = splitEithers early_specs - ; insts1 <- mapM (genInst True overlap_flag) given_specs + ; insts1 <- mapM (genInst True overlap_flag commonAuxs) given_specs + -- the stand-alone derived instances (@insts1@) are used when inferring + -- the contexts for "deriving" clauses' instances (@infer_specs@) ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $ inferInstanceContexts overlap_flag infer_specs - ; insts2 <- mapM (genInst False overlap_flag) final_specs + ; insts2 <- mapM (genInst False overlap_flag commonAuxs) final_specs ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2) ; loc <- getSrcSpanM ; let (binds, newTyCons, famInsts, extraInstances) = - genAuxBinds loc (unionManyBags deriv_stuff) + genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff)) + ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds - ; dflags <- getDynFlags - ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds newTyCons famInsts)) + ; dflags <- getDynFlags + ; unless (isEmptyBag inst_info) $ + liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + (ddump_deriving inst_info rn_binds newTyCons famInsts)) - ; let all_tycons = map ATyCon (bagToList newTyCons) - ; gbl_env <- tcExtendGlobalEnv all_tycons $ - tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $ - tcExtendLocalFamInstEnv (bagToList famInsts) $ - tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv + ; let all_tycons = map ATyCon (bagToList newTyCons) + ; gbl_env <- tcExtendGlobalEnv all_tycons $ + tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $ + tcExtendLocalFamInstEnv (bagToList famInsts) $ + tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv - ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) } + ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) } where ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name -> Bag TyCon -- ^ Empty data constructors @@ -359,6 +370,25 @@ tcDeriving tycl_decls inst_decls deriv_decls hangP s x = text "" $$ hang (ptext (sLit s)) 2 x + + +-- As of 24 April 2012, this only shares MetaTyCons between derivations of +-- Generic and Generic1; thus the types and logic are quite simple. +type CommonAuxiliary = MetaTyCons +type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type? +commonAuxiliaries :: [DerivSpec] -> TcM (CommonAuxiliaries, BagDerivStuff) +commonAuxiliaries = foldM snoc ([], emptyBag) where + snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon}) + | getUnique cls `elem` [genClassKey, gen1ClassKey] = + extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm) + | otherwise = return acc + where extendComAux m -- don't run m if its already in the accumulator + | any ((rep_tycon ==) . fst) cas = return acc + | otherwise = do (ca, new_stuff) <- m + return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff) + + + -- Prints the representable type family instance pprRepTy :: FamInst -> SDoc pprRepTy fi @@ -446,27 +476,58 @@ makeDerivSpecs :: Bool -> [LDerivDecl Name] -> TcM [EarlyDerivSpec] makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls - | is_boot -- No 'deriving' at all in hs-boot files - = do { mapM_ add_deriv_err deriv_locs - ; return [] } - | otherwise - = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata - ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls - ; return (eqns1 ++ eqns2) } + = do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls + ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls + ; eqns3 <- mapAndRecoverM deriveStandalone deriv_decls + ; let eqns = eqns1 ++ eqns2 ++ eqns3 + ; if is_boot then -- No 'deriving' at all in hs-boot files + do { unless (null eqns) (add_deriv_err (head eqns)) + ; return [] } + else return eqns } where - extractTyDataPreds decls - = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds] + add_deriv_err eqn + = setSrcSpan loc $ + addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) + 2 (ptext (sLit "Use an instance declaration instead"))) + where + loc = case eqn of { Left ds -> ds_loc ds; Right ds -> ds_loc ds } - all_tydata :: [(LHsType Name, LTyClDecl Name)] - -- Derived predicate paired with its data type declaration - all_tydata = extractTyDataPreds (instDeclFamInsts inst_decls ++ tycl_decls) +------------------------------------------------------------------ +deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec] +deriveTyDecl (L _ decl@(TyDecl { tcdLName = L _ tc_name + , tcdTyDefn = TyData { td_derivs = Just preds } })) + = tcAddDeclCtxt decl $ + do { tc <- tcLookupTyCon tc_name + ; let tvs = tyConTyVars tc + tys = mkTyVarTys tvs + ; mapM (deriveTyData tvs tc tys) preds } + +deriveTyDecl _ = return [] + +------------------------------------------------------------------ +deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec] +deriveInstDecl (L _ (FamInstD { lid_inst = fam_inst })) + = deriveFamInst fam_inst +deriveInstDecl (L _ (ClsInstD { cid_fam_insts = fam_insts })) + = concatMapM (deriveFamInst . unLoc) fam_insts - deriv_locs = map (getLoc . snd) all_tydata - ++ map getLoc deriv_decls +------------------------------------------------------------------ +deriveFamInst :: FamInstDecl Name -> TcM [EarlyDerivSpec] +deriveFamInst decl@(FamInstDecl { fid_tycon = L _ tc_name, fid_pats = pats + , fid_defn = TyData { td_derivs = Just preds } }) + = tcAddFamInstCtxt decl $ + do { fam_tc <- tcLookupTyCon tc_name + ; tcFamTyPats fam_tc pats (\_ -> return ()) $ \ tvs' pats' _ -> + mapM (deriveTyData tvs' fam_tc pats') preds } + -- Tiresomely we must figure out the "lhs", which is awkward for type families + -- E.g. data T a b = .. deriving( Eq ) + -- Here, the lhs is (T a b) + -- data instance TF Int b = ... deriving( Eq ) + -- Here, the lhs is (TF Int b) + -- But if we just look up the tycon_name, we get is the *family* + -- tycon, but not pattern types -- they are in the *rep* tycon. - add_deriv_err loc = setSrcSpan loc $ - addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) - 2 (ptext (sLit "Use an instance declaration instead"))) +deriveFamInst _ = return [] ------------------------------------------------------------------ deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec @@ -495,16 +556,14 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) (Just theta) } ------------------------------------------------------------------ -deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec +deriveTyData :: [TyVar] -> TyCon -> [Type] + -> LHsType Name -- The deriving predicate + -> TcM EarlyDerivSpec -- The deriving clause of a data or newtype declaration -deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, - tcdTyVars = tv_names, - tcdTyPats = ty_pats })) +deriveTyData tvs tc tc_args (L loc deriv_pred) = setSrcSpan loc $ -- Use the location of the 'deriving' item - tcAddDeclCtxt decl $ - do { (tvs, tc, tc_args) <- get_lhs ty_pats - ; tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention - -- the type variables for the type constructor + tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention + -- the type variables for the type constructor do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred -- The "deriv_pred" is a LHsType to take account of the fact that for @@ -512,8 +571,8 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, -- Given data T a b c = ... deriving( C d ), -- we want to drop type variables from T so that (C d (T a)) is well-kinded - ; let cls_tyvars = classTyVars cls - kind = tyVarKind (last cls_tyvars) + ; let cls_tyvars = classTyVars cls + kind = tyVarKind (last cls_tyvars) (arg_kinds, _) = splitKindFunTys kind n_args_to_drop = length arg_kinds n_args_to_keep = tyConArity tc - n_args_to_drop @@ -522,7 +581,10 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, inst_ty_kind = typeKind inst_ty dropped_tvs = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop) univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs) - `minusVarSet` dropped_tvs + `minusVarSet` dropped_tvs + + ; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$ + pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty) -- Check that the result really is well-kinded ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind)) @@ -544,26 +606,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0) (typeFamilyPapErr tc cls cls_tys inst_ty) - ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } } - where - -- Tiresomely we must figure out the "lhs", which is awkward for type families - -- E.g. data T a b = .. deriving( Eq ) - -- Here, the lhs is (T a b) - -- data instance TF Int b = ... deriving( Eq ) - -- Here, the lhs is (TF Int b) - -- But if we just look up the tycon_name, we get is the *family* - -- tycon, but not pattern types -- they are in the *rep* tycon. - get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name - ; let tvs = tyConTyVars tc - ; return (tvs, tc, mkTyVarTys tvs) } - -- JPM: to fix - get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats - ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app - ; let (tc, tc_args) = tcSplitTyConApp tc_app - ; return (tvs, tc, tc_args) } - -deriveTyData _other - = panic "derivTyData" -- Caller ensures that only TyData can happen + ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } \end{code} Note [Deriving, type families, and partial applications] @@ -618,7 +661,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta mk_alg_eqn tycon tc_args | className cls `elem` typeableClassNames = do { dflags <- getDynFlags - ; case checkTypeableConditions (dflags, tycon) of + ; case checkTypeableConditions (dflags, tycon, tc_args) of Just err -> bale_out err Nothing -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta } @@ -673,7 +716,7 @@ mkDataTypeEqn :: CtOrigin mkDataTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta - = case checkSideConditions dflags mtheta cls cls_tys rep_tc of + = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of -- NB: pass the *representation* tycon to checkSideConditions CanDerive -> go_for_it NonDerivableClass -> bale_out (nonStdErr cls) @@ -688,8 +731,11 @@ mk_data_eqn :: CtOrigin -> [TyVar] -> Class mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta = do { dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM + -- TODO NSF 9 April 2012: only recover from the anticipated + -- "base:Data.Functor.Functor could not be found" error + ; (_, functorClass_maybe) <- tryTc $ tcLookupClass functorClassName ; let inst_tys = [mkTyConApp tycon tc_args] - inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args + inferred_constraints = inferConstraints functorClass_maybe tvs cls inst_tys rep_tc rep_tc_args spec = DS { ds_loc = loc, ds_orig = orig , ds_name = dfun_name, ds_tvs = tvs , ds_cls = cls, ds_tys = inst_tys @@ -733,23 +779,29 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta , ds_theta = mtheta `orElse` [], ds_newtype = False }) } ---------------------- -inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType +inferConstraints :: Maybe Class -> -- the base:Functor class, if in scope + [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType -- Generate a sufficiently large set of constraints that typechecking the -- generated method definitions should succeed. This set will be simplified -- before being used in the instance declaration -inferConstraints _ cls inst_tys rep_tc rep_tc_args +inferConstraints functorClass_maybe _ cls inst_tys rep_tc rep_tc_args -- Generic constraints are easy | cls `hasKey` genClassKey = [] + | cls `hasKey` gen1ClassKey + = ASSERT (length rep_tc_tvs > 0) + con_arg_constraints functorClass_maybe (get_gen1_constrained_tys last_tv) -- The others are a bit more complicated | otherwise = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc ) stupid_constraints ++ extra_constraints - ++ sc_constraints ++ con_arg_constraints + ++ sc_constraints + ++ con_arg_constraints (Just cls) get_std_constrained_tys where -- Constraints arising from the arguments of each constructor - con_arg_constraints - = [ mkClassPred cls [arg_ty] + con_arg_constraints Nothing _ = [] + con_arg_constraints (Just cls') get_constrained_tys + = [ mkClassPred cls' [arg_ty] | data_con <- tyConDataCons rep_tc, arg_ty <- ASSERT( isVanillaDataCon data_con ) get_constrained_tys $ @@ -764,14 +816,15 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args -- (b) The rep_tc_args will be one short is_functor_like = getUnique cls `elem` functorLikeClassKeys - get_constrained_tys :: [Type] -> [Type] - get_constrained_tys tys + get_std_constrained_tys :: [Type] -> [Type] + get_std_constrained_tys tys | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys | otherwise = tys rep_tc_tvs = tyConTyVars rep_tc last_tv = last rep_tc_tvs - all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv] + all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like + = rep_tc_args ++ [mkTyVarTy last_tv] | otherwise = rep_tc_args -- Constraints arising from superclasses @@ -827,10 +880,12 @@ data DerivStatus = CanDerive | DerivableClassError SDoc -- Standard class, but can't do it | NonDerivableClass -- Non-standard class -checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] -> TyCon -> DerivStatus -checkSideConditions dflags mtheta cls cls_tys rep_tc +checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] + -> TyCon -> [Type] -- tycon and its parameters + -> DerivStatus +checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args | Just cond <- sideConditions mtheta cls - = case (cond (dflags, rep_tc)) of + = case (cond (dflags, rep_tc, rep_tc_args)) of Just err -> DerivableClassError err -- Class-specific error Nothing | null cls_tys -> CanDerive -- All derivable classes are unary, so -- cls_tys (the type args other than last) @@ -865,17 +920,19 @@ sideConditions mtheta cls cond_functorOK False) | cls_key == genClassKey = Just (cond_RepresentableOk `andCond` checkFlag Opt_DeriveGeneric) + | cls_key == gen1ClassKey = Just (cond_Representable1Ok `andCond` + checkFlag Opt_DeriveGeneric) | otherwise = Nothing where cls_key = getUnique cls cond_std = cond_stdOK mtheta -type Condition = (DynFlags, TyCon) -> Maybe SDoc - -- first Bool is whether or not we are allowed to derive Data and Typeable - -- second Bool is whether or not we are allowed to derive Functor - -- TyCon is the *representation* tycon if the - -- data type is an indexed one - -- Nothing => OK +type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc + -- first Bool is whether or not we are allowed to derive Data and Typeable + -- second Bool is whether or not we are allowed to derive Functor + -- TyCon is the *representation* tycon if the data type is an indexed one + -- [Type] are the type arguments to the (representation) TyCon + -- Nothing => OK orCond :: Condition -> Condition -> Condition orCond c1 c2 tc @@ -896,7 +953,7 @@ cond_stdOK (Just _) _ = Nothing -- Don't check these conservative conditions for -- standalone deriving; just generate the code -- and let the typechecker handle the result -cond_stdOK Nothing (_, rep_tc) +cond_stdOK Nothing (_, rep_tc, _) | null data_cons = Just (no_cons_why rep_tc $$ suggestion) | not (null con_whys) = Just (vcat con_whys $$ suggestion) | otherwise = Nothing @@ -916,7 +973,10 @@ no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "must have at least one data constructor") cond_RepresentableOk :: Condition -cond_RepresentableOk (_,t) = canDoGenerics t +cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args + +cond_Representable1Ok :: Condition +cond_Representable1Ok (_, tc, tc_args) = canDoGenerics1 tc tc_args cond_enumOrProduct :: Class -> Condition cond_enumOrProduct cls = cond_isEnumeration `orCond` @@ -925,7 +985,7 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond` cond_args :: Class -> Condition -- For some classes (eg Eq, Ord) we allow unlifted arg types -- by generating specilaised code. For others (eg Data) we don't. -cond_args cls (_, tc) +cond_args cls (_, tc, _) = case bad_args of [] -> Nothing (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls)) @@ -948,7 +1008,7 @@ cond_args cls (_, tc) cond_isEnumeration :: Condition -cond_isEnumeration (_, rep_tc) +cond_isEnumeration (_, rep_tc, _) | isEnumerationTyCon rep_tc = Nothing | otherwise = Just why where @@ -958,7 +1018,7 @@ cond_isEnumeration (_, rep_tc) -- See Note [Enumeration types] in TyCon cond_isProduct :: Condition -cond_isProduct (_, rep_tc) +cond_isProduct (_, rep_tc, _) | isProductTyCon rep_tc = Nothing | otherwise = Just why where @@ -969,9 +1029,9 @@ cond_typeableOK :: Condition -- OK for Typeable class -- Currently: (a) args all of kind * -- (b) 7 or fewer args -cond_typeableOK (_, tc) +cond_typeableOK (_, tc, _) | tyConArity tc > 7 = Just too_many - | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tc)) + | not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc)) = Just bad_kind | otherwise = Nothing where @@ -990,7 +1050,7 @@ cond_functorOK :: Bool -> Condition -- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) -- (d) optionally: don't use function types -- (e) no "stupid context" on data type -cond_functorOK allowFunctions (_, rep_tc) +cond_functorOK allowFunctions (_, rep_tc, _) | null tc_tvs = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) <+> ptext (sLit "must have some type parameters")) @@ -1030,7 +1090,7 @@ cond_functorOK allowFunctions (_, rep_tc) wrong_arg = ptext (sLit "must use the type variable only as the last argument of a data type") checkFlag :: ExtensionFlag -> Condition -checkFlag flag (dflags, _) +checkFlag flag (dflags, _, _) | xopt flag dflags = Nothing | otherwise = Just why where @@ -1051,11 +1111,11 @@ std_class_via_iso clas non_iso_class :: Class -> Bool --- *Never* derive Read, Show, Typeable, Data, Generic by isomorphism, +-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1 by isomorphism, -- even with -XGeneralizedNewtypeDeriving non_iso_class cls = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey - , genClassKey] ++ typeableClassKeys) + , genClassKey, gen1ClassKey] ++ typeableClassKeys) typeableClassKeys :: [Unique] typeableClassKeys = map getUnique typeableClassNames @@ -1124,7 +1184,7 @@ mkNewTypeEqn orig dflags tvs else Left spec) } | otherwise - = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of + = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of CanDerive -> go_for_it -- Use the standard H98 method DerivableClassError msg -- Error with standard class | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd) @@ -1347,7 +1407,7 @@ inferInstanceContexts oflag infer_specs -- Claim: the result instance declaration is guaranteed valid -- Hence no need to call: -- checkValidInstance tyvars theta clas inst_tys - ; return (sortLe (\p1 p2 -> cmpType p1 p2 /= GT) theta) } -- Canonicalise before returning the solution + ; return (sortBy cmpType theta) } -- Canonicalise before returning the solution where the_pred = mkClassPred clas inst_tys @@ -1444,8 +1504,9 @@ the renamer. What a great hack! -- genInst :: Bool -- True <=> standalone deriving -> OverlapFlag + -> CommonAuxiliaries -> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff) -genInst standalone_deriv oflag +genInst standalone_deriv oflag comauxs spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = theta, ds_newtype = is_newtype , ds_name = name, ds_cls = clas }) @@ -1457,6 +1518,7 @@ genInst standalone_deriv oflag = do { fix_env <- getFixityEnv ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name) fix_env clas name rep_tycon + (lookup rep_tycon comauxs) ; let inst_info = InstInfo { iSpec = inst_spec , iBinds = VanillaInst meth_binds [] standalone_deriv } @@ -1481,31 +1543,41 @@ genInst standalone_deriv oflag -- co : N [(b,b)] ~ Tree (b,b) genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon + -> Maybe CommonAuxiliary -> TcM (LHsBinds RdrName, BagDerivStuff) -genDerivStuff loc fix_env clas name tycon +genDerivStuff loc fix_env clas name tycon comaux_maybe | className clas `elem` typeableClassNames = return (gen_Typeable_binds loc tycon, emptyBag) - | classKey clas == genClassKey -- Special case because monadic - = gen_Generic_binds tycon (nameModule name) + | ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic + = let gk = if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One + Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst + in do + (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule name) + return (binds, DerivFamInst faminst `consBag` emptyBag) | otherwise -- Non-monadic generators - = case assocMaybe gen_list (getUnique clas) of + = do dflags <- getDynFlags + case assocMaybe (gen_list dflags) (getUnique clas) of Just gen_fn -> return (gen_fn loc tycon) Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas) where - gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] - gen_list = [(eqClassKey, gen_Eq_binds) - ,(ordClassKey, gen_Ord_binds) - ,(enumClassKey, gen_Enum_binds) - ,(boundedClassKey, gen_Bounded_binds) - ,(ixClassKey, gen_Ix_binds) - ,(showClassKey, gen_Show_binds fix_env) - ,(readClassKey, gen_Read_binds fix_env) - ,(dataClassKey, gen_Data_binds) - ,(functorClassKey, gen_Functor_binds) - ,(foldableClassKey, gen_Foldable_binds) - ,(traversableClassKey, gen_Traversable_binds) + ck = classKey clas + + gen_list :: DynFlags + -> [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] + gen_list dflags + = [(eqClassKey, gen_Eq_binds) + ,(ordClassKey, gen_Ord_binds) + ,(enumClassKey, gen_Enum_binds) + ,(boundedClassKey, gen_Bounded_binds) + ,(ixClassKey, gen_Ix_binds) + ,(showClassKey, gen_Show_binds fix_env) + ,(readClassKey, gen_Read_binds fix_env) + ,(dataClassKey, gen_Data_binds dflags) + ,(functorClassKey, gen_Functor_binds) + ,(foldableClassKey, gen_Foldable_binds) + ,(traversableClassKey, gen_Traversable_binds) ] \end{code} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index ae320ce692..fce17affaa 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -7,7 +7,7 @@ module TcEnv( TyThing(..), TcTyThing(..), TcId, -- Instance environment, and InstInfo type - InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails, + InstInfo(..), iDFunId, pprInstInfoDetails, simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, InstBindings(..), @@ -20,13 +20,14 @@ module TcEnv( tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom, -- Local environment - tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv, + tcExtendKindEnv, tcExtendTcTyThingEnv, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendGhciEnv, tcExtendLetEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcLookup, tcLookupLocated, tcLookupLocalIds, - tcLookupId, tcLookupTyVar, getScopedTyVarBinds, - getInLocalScope, + tcLookupId, tcLookupTyVar, + tcLookupLcl_maybe, + getScopedTyVarBinds, getInLocalScope, wrongThingErr, pprBinders, tcExtendRecEnv, -- For knot-tying @@ -71,14 +72,15 @@ import TypeRep import Class import Name import NameEnv +import VarEnv import HscTypes import DynFlags import SrcLoc import BasicTypes import Outputable -import Unique import FastString import ListSetOps +import Util \end{code} @@ -103,29 +105,27 @@ tcLookupGlobal :: Name -> TcM TyThing -- In GHCi, we may make command-line bindings (ghci> let x = True) -- that bind a GlobalId, but with an InternalName tcLookupGlobal name - = do { env <- getGblEnv - - -- Try local envt + = do { -- Try local envt + env <- getGblEnv ; case lookupNameEnv (tcg_type_env env) name of { Just thing -> return thing ; - Nothing -> do + Nothing -> - -- Try global envt - { hsc_env <- getTopEnv - ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) - ; case mb_thing of { - Just thing -> return thing ; - Nothing -> do - -- Should it have been in the local envt? - { case nameModule_maybe name of - Nothing -> notFound name -- Internal names can happen in GHCi + case nameModule_maybe name of { + Nothing -> notFound name ; -- Internal names can happen in GHCi Just mod | mod == tcg_mod env -- Names from this module - -> notFound name -- should be in tcg_type_env - | otherwise - -> tcImportDecl name -- Go find it in an interface - }}}}} + -> notFound name -- should be in tcg_type_env + | otherwise -> do + + -- Try home package table and external package table + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of + Just thing -> return thing + Nothing -> tcImportDecl name -- Go find it in an interface + }}}} tcLookupField :: Name -> TcM Id -- Returns the selector Id tcLookupField name @@ -275,6 +275,11 @@ tcExtendRecEnv gbl_stuff thing_inside tcLookupLocated :: Located Name -> TcM TcTyThing tcLookupLocated = addLocM tcLookup +tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) +tcLookupLcl_maybe name + = do { local_env <- getLclTypeEnv + ; return (lookupNameEnv local_env name) } + tcLookup :: Name -> TcM TcTyThing tcLookup name = do local_env <- getLclTypeEnv @@ -283,11 +288,11 @@ tcLookup name = do Nothing -> AGlobal <$> tcLookupGlobal name tcLookupTyVar :: Name -> TcM TcTyVar -tcLookupTyVar name = do - thing <- tcLookup name - case thing of - ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty) - _ -> pprPanic "tcLookupTyVar" (ppr name) +tcLookupTyVar name + = do { thing <- tcLookup name + ; case thing of + ATyVar _ tv -> return tv + _ -> pprPanic "tcLookupTyVar" (ppr name) } tcLookupId :: Name -> TcM Id -- Used when we aren't interested in the binding level, nor refinement. @@ -304,9 +309,9 @@ tcLookupId name = do tcLookupLocalIds :: [Name] -> TcM [TcId] -- We expect the variables to all be bound, and all at -- the same level as the lookup. Only used in one place... -tcLookupLocalIds ns = do - env <- getLclEnv - return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns) +tcLookupLocalIds ns + = do { env <- getLclEnv + ; return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns) } where lookup lenv lvl name = case lookupNameEnv lenv name of @@ -323,35 +328,42 @@ getInLocalScope = do { lcl_env <- getLclTypeEnv \begin{code} tcExtendTcTyThingEnv :: [(Name, TcTyThing)] -> TcM r -> TcM r tcExtendTcTyThingEnv things thing_inside - = updLclEnv upd thing_inside - where - upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env things + = updLclEnv (extend_local_env things) thing_inside tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r -tcExtendKindEnv things thing_inside - = updLclEnv upd thing_inside - where - upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things] - -tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r -tcExtendKindEnvTvs bndrs thing_inside - = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs) - (thing_inside bndrs) +tcExtendKindEnv name_kind_prs + = tcExtendTcTyThingEnv [(n, AThing k) | (n,k) <- name_kind_prs] +----------------------- +-- Scoped type and kind variables tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside - = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside + = tcExtendTyVarEnv2 [(tyVarName tv, tv) | tv <- tvs] thing_inside -tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r +tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r tcExtendTyVarEnv2 binds thing_inside - = tc_extend_local_env [(name, ATyVar name ty) | (name, ty) <- binds] thing_inside - -getScopedTyVarBinds :: TcM [(Name, TcType)] + = tc_extend_local_env [(name, ATyVar name tv) | (name, tv) <- binds] $ + do { env <- getLclEnv + ; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) } + ; setLclEnv env' thing_inside } + where + add_tidy_tvs env = foldl add env binds + + -- We initialise the "tidy-env", used for tidying types before printing, + -- by building a reverse map from the in-scope type variables to the + -- OccName that the programmer originally used for them + add :: TidyEnv -> (Name, TcTyVar) -> TidyEnv + add (env,subst) (name, tyvar) + = case tidyOccName env (nameOccName name) of + (env', occ') -> (env', extendVarEnv subst tyvar tyvar') + where + tyvar' = setTyVarName tyvar name' + name' = tidyNameOcc name occ' + +getScopedTyVarBinds :: TcM [(Name, TcTyVar)] getScopedTyVarBinds = do { lcl_env <- getLclEnv - ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] } + ; return [(name, tv) | ATyVar name tv <- nameEnvElts (tcl_env lcl_env)] } \end{code} @@ -398,8 +410,8 @@ tcExtendGhciEnv ids thing_inside | id <- ids] thing_inside where - is_top id | isEmptyVarSet (tcTyVarsOfType (idType id)) = TopLevel - | otherwise = NotTopLevel + is_top id | isEmptyVarSet (tyVarsOfType (idType id)) = TopLevel + | otherwise = NotTopLevel tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a @@ -414,9 +426,7 @@ tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a tc_extend_local_env extra_env thing_inside = do { traceTc "env2" (ppr extra_env) ; env1 <- getLclEnv - ; let le' = extendNameEnvList (tcl_env env1) extra_env - rdr_env' = extendLocalRdrEnvList (tcl_rdr env1) (map fst extra_env) - env2 = env1 {tcl_env = le', tcl_rdr = rdr_env'} + ; let env2 = extend_local_env extra_env env1 ; env3 <- extend_gtvs env2 ; setLclEnv env3 thing_inside } where @@ -435,8 +445,10 @@ tc_extend_local_env extra_env thing_inside emptyVarSet NotTopLevel -> id_tvs where - id_tvs = tcTyVarsOfType (idType id) - get_tvs (_, ATyVar _ ty) = tcTyVarsOfType ty -- See Note [Global TyVars] + id_tvs = tyVarsOfType (idType id) + get_tvs (_, ATyVar _ tv) -- See Note [Global TyVars] + = tyVarsOfType (tyVarKind tv) `extendVarSet` tv + get_tvs other = pprPanic "get_tvs" (ppr other) -- Note [Global TyVars] @@ -446,6 +458,14 @@ tc_extend_local_env extra_env thing_inside -- Here, g mustn't be generalised. This is also important during -- class and instance decls, when we mustn't generalise the class tyvars -- when typechecking the methods. + -- + -- Nor must we generalise g over any kind variables free in r's kind + +extend_local_env :: [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv +-- Extend the local TcTypeEnv *and* the local LocalRdrEnv simultaneously +extend_local_env pairs env@(TcLclEnv { tcl_rdr = rdr_env, tcl_env = type_env }) + = env { tcl_rdr = extendLocalRdrEnvList rdr_env (map fst pairs) + , tcl_env = extendNameEnvList type_env pairs } tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet) tcExtendGlobalTyVars gtv_var extra_global_tvs @@ -498,10 +518,7 @@ checkWellStaged pp_thing bind_lvl use_lvl = return () -- E.g. \x -> [| $(f x) |] | bind_lvl == outerLevel -- GHC restriction on top level splices - = failWithTc $ - sep [ptext (sLit "GHC stage restriction:") <+> pp_thing, - nest 2 (vcat [ ptext (sLit "is used in a top-level splice or annotation,") - , ptext (sLit "and must be imported, not defined locally")])] + = stageRestrictionError pp_thing | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) @@ -509,6 +526,13 @@ checkWellStaged pp_thing bind_lvl use_lvl hsep [ptext (sLit "is bound at stage") <+> ppr bind_lvl, ptext (sLit "but used at stage") <+> ppr use_lvl] +stageRestrictionError :: SDoc -> TcM a +stageRestrictionError pp_thing + = failWithTc $ + sep [ ptext (sLit "GHC stage restriction:") + , nest 2 (vcat [ pp_thing <+> ptext (sLit "is used in a top-level splice or annotation,") + , ptext (sLit "and must be imported, not defined locally")])] + topIdLvl :: Id -> ThLevel -- Globals may either be imported, or may be from an earlier "chunk" -- (separated by declaration splices) of this module. The former @@ -553,15 +577,13 @@ thTopLevelId id = isGlobalId id || isExternalName (idName id) %************************************************************************ \begin{code} -tcGetDefaultTys :: Bool -- True <=> interactive context - -> TcM ([Type], -- Default types +tcGetDefaultTys :: TcM ([Type], -- Default types (Bool, -- True <=> Use overloaded strings Bool)) -- True <=> Use extended defaulting rules -tcGetDefaultTys interactive +tcGetDefaultTys = do { dflags <- getDynFlags ; let ovl_strings = xopt Opt_OverloadedStrings dflags - extended_defaults = interactive - || xopt Opt_ExtendedDefaultRules dflags + extended_defaults = xopt Opt_ExtendedDefaultRules dflags -- See also Trac #1974 flags = (ovl_strings, extended_defaults) @@ -647,17 +669,10 @@ data InstBindings a -- See Note [Newtype deriving and unused constructors] -- in TcDeriv -pprInstInfo :: InstInfo a -> SDoc -pprInstInfo info = hang (ptext (sLit "instance")) - 2 (sep [ ifPprDebug (pprForAll tvs) - , pprThetaArrowTy theta, ppr tau - , ptext (sLit "where")]) - where - (tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info)) - - pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc -pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info)) +pprInstInfoDetails info + = hang (pprInstanceHdr (iSpec info) <+> ptext (sLit "where")) + 2 (details (iBinds info)) where details (VanillaInst b _ _) = pprLHsBinds b details (NewTypeDerived {}) = text "Derived from the representation type" @@ -720,8 +735,7 @@ mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM mkStableIdFromString str sig_ty loc occ_wrapper = do uniq <- newUnique mod <- getModule - let uniq_str = showSDoc (pprUnique uniq) :: String - occ = mkVarOcc (str ++ '_' : uniq_str) :: OccName + let occ = mkVarOcc (str ++ '_' : show uniq) :: OccName gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name id = mkExportedLocalId gnm sig_ty :: Id return id @@ -745,19 +759,35 @@ pprBinders bndrs = pprWithCommas ppr bndrs notFound :: Name -> TcM TyThing notFound name - = do { (_gbl,lcl) <- getEnvs - ; failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> + = do { lcl_env <- getLclEnv + ; let stage = tcl_th_ctxt lcl_env + ; case stage of -- See Note [Out of scope might be a staging error] + Splice -> stageRestrictionError (quotes (ppr name)) + _ -> failWithTc $ + vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> ptext (sLit "is not in scope during type checking, but it passed the renamer"), - ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl)] + ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl_env)] -- Take case: printing the whole gbl env can -- cause an infnite loop, in the case where we -- are in the middle of a recursive TyCon/Class group; -- so let's just not print it! Getting a loop here is -- very unhelpful, because it hides one compiler bug with another - ) } + } wrongThingErr :: String -> TcTyThing -> Name -> TcM a wrongThingErr expected thing name = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> ptext (sLit "used as a") <+> text expected) \end{code} + +Note [Out of scope might be a staging error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + x = 3 + data T = MkT $(foo x) + +This is really a staging error, because we can't run code involving 'x'. +But in fact the type checker processes types first, so 'x' won't even be +in the type envt when we look for it in $(foo x). So inside splices we +report something missing from the type env as a staging error. +See Trac #5752 and #5795.
\ No newline at end of file diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 56a42e7eed..1a5811b531 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -10,8 +10,6 @@ module TcErrors( reportUnsolved, ErrEnv, warnDefaulting, - unifyCtxt, - misMatchMsg, flattenForAllErrorTcS, solverDepthErrorTcS @@ -19,6 +17,7 @@ module TcErrors( #include "HsVersions.h" +import TcCanonical( occurCheckExpand ) import TcRnMonad import TcMType import TcType @@ -39,13 +38,12 @@ import VarEnv import Bag import Maybes import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg ) +import SrcLoc ( noSrcSpan ) import Util import FastString import Outputable import DynFlags import Data.List ( partition, mapAccumL ) -import Data.Either ( partitionEithers ) --- import Control.Monad ( when ) \end{code} %************************************************************************ @@ -86,7 +84,8 @@ reportUnsolved runtimeCoercionErrors wanted , cec_tidy = tidy_env , cec_defer = defer } - ; traceTc "reportUnsolved" (ppr free_tvs $$ ppr wanted) + ; traceTc "reportUnsolved:" (vcat [ pprTvBndrs (varSetElems free_tvs) + , ppr wanted ]) ; reportWanteds err_ctxt wanted @@ -160,16 +159,16 @@ reportTidyWanteds ctxt insols flats implics deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Ct -> TcM () deferToRuntime ev_binds_var ctxt mk_err_msg ct - | Wanted loc <- cc_flavor ct + | Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct = do { err <- setCtLoc loc $ mk_err_msg ctxt ct - ; let ev_id = cc_id ct - err_msg = pprLocErrMsg err - err_fs = mkFastString $ showSDoc $ + ; dflags <- getDynFlags + ; let err_msg = pprLocErrMsg err + err_fs = mkFastString $ showSDoc dflags $ err_msg $$ text "(deferred type error)" -- Create the binding - ; addTcEvBind ev_binds_var ev_id (EvDelayedError (idType ev_id) err_fs) + ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) -- And emit a warning ; reportWarning (makeIntoWarning err) } @@ -232,7 +231,7 @@ type Reporter = [Ct] -> TcM () mkReporter :: (Ct -> TcM ErrMsg) -> [Ct] -> TcM () -- Reports errors one at a time -mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_flavor ct) $ +mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_ev ct) $ mk_err ct; ; reportError err }) @@ -256,9 +255,10 @@ tryReporters reporters deflt cts mkFlatErr :: ReportErrCtxt -> Ct -> TcM ErrMsg -- Context is already set mkFlatErr ctxt ct -- The constraint is always wanted + | isIPPred (ctPred ct) = mkIPErr ctxt [ct] + | otherwise = case classifyPredType (ctPred ct) of ClassPred {} -> mkDictErr ctxt [ct] - IPPred {} -> mkIPErr ctxt [ct] IrredPred {} -> mkIrredErr ctxt [ct] EqPred {} -> mkEqErr1 ctxt ct TuplePred {} -> panic "mkFlat" @@ -290,9 +290,10 @@ reportFlatErrs ctxt cts go [] dicts ips irreds = (dicts, ips, irreds) go (ct:cts) dicts ips irreds + | isIPPred (ctPred ct) = go cts dicts (ct:ips) irreds + | otherwise = case classifyPredType (ctPred ct) of ClassPred {} -> go cts (ct:dicts) ips irreds - IPPred {} -> go cts dicts (ct:ips) irreds IrredPred {} -> go cts dicts ips (ct:irreds) _ -> panic "mkFlat" -- TuplePreds should have been expanded away by the constraint @@ -317,15 +318,15 @@ groupErrs mk_err (ct1 : rest) ; reportError err ; groupErrs mk_err others } where - flavor = cc_flavor ct1 + flavor = cc_ev ct1 cts = ct1 : friends (friends, others) = partition is_friend rest - is_friend friend = cc_flavor friend `same_group` flavor + is_friend friend = cc_ev friend `same_group` flavor - same_group :: CtFlavor -> CtFlavor -> Bool - same_group (Given l1 _) (Given l2 _) = same_loc l1 l2 - same_group (Derived l1) (Derived l2) = same_loc l1 l2 - same_group (Wanted l1) (Wanted l2) = same_loc l1 l2 + same_group :: CtEvidence -> CtEvidence -> Bool + same_group (Given {ctev_gloc = l1}) (Given {ctev_gloc = l2}) = same_loc l1 l2 + same_group (Wanted {ctev_wloc = l1}) (Wanted {ctev_wloc = l2}) = same_loc l1 l2 + same_group (Derived {ctev_wloc = l1}) (Derived {ctev_wloc = l2}) = same_loc l1 l2 same_group _ _ = False same_loc :: CtLoc o -> CtLoc o -> Bool @@ -333,7 +334,7 @@ groupErrs mk_err (ct1 : rest) -- Add the "arising from..." part to a message about bunch of dicts addArising :: CtOrigin -> SDoc -> SDoc -addArising orig msg = msg $$ nest 2 (pprArising orig) +addArising orig msg = hang msg 2 (pprArising orig) pprWithArising :: [Ct] -> (WantedLoc, SDoc) -- Print something like @@ -345,8 +346,8 @@ pprWithArising [] = panic "pprWithArising" pprWithArising (ct:cts) | null cts - = (loc, hang (pprEvVarTheta [cc_id ct]) - 2 (pprArising (ctLocOrigin (ctWantedLoc ct)))) + = (loc, addArising (ctLocOrigin (ctWantedLoc ct)) + (pprTheta [ctPred ct])) | otherwise = (loc, vcat (map ppr_one (ct:cts))) where @@ -426,22 +427,24 @@ mkEqErr _ [] = panic "mkEqErr" mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg -- Wanted constraints only! mkEqErr1 ctxt ct - = case cc_flavor ct of - Given gl gk -> mkEqErr_help ctxt2 ct False ty1 ty2 - where - ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ - inaccessible_msg gl gk } - - flav -> do { let orig = ctLocOrigin (getWantedLoc flav) - ; (ctxt1, orig') <- zonkTidyOrigin ctxt orig - ; mk_err ctxt1 orig' } + = if isGiven flav then + let ctx2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg flav } + in mkEqErr_help ctx2 ct False ty1 ty2 + else + do { let orig = ctLocOrigin (getWantedLoc flav) + ; (ctxt1, orig') <- zonkTidyOrigin ctxt orig + ; mk_err ctxt1 orig' } where - -- If a GivenSolved then we should not report inaccessible code - inaccessible_msg loc GivenOrig = hang (ptext (sLit "Inaccessible code in")) - 2 (ppr (ctLocOrigin loc)) - inaccessible_msg _ _ = empty - (ty1, ty2) = getEqPredTys (evVarPred (cc_id ct)) + flav = cc_ev ct + + inaccessible_msg (Given { ctev_gloc = loc }) + = hang (ptext (sLit "Inaccessible code in")) + 2 (ppr (ctLocOrigin loc)) + -- If a Solved then we should not report inaccessible code + inaccessible_msg _ = empty + + (ty1, ty2) = getEqPredTys (ctPred ct) -- If the types in the error message are the same as the types -- we are unifying, don't add the extra expected/actual message @@ -456,17 +459,20 @@ mkEqErr1 ctxt ct msg = mkExpectedActualMsg exp act mk_err ctxt1 _ = mkEqErr_help ctxt1 ct False ty1 ty2 -mkEqErr_help :: ReportErrCtxt - -> Ct - -> Bool -- True <=> Types are correct way round; - -- report "expected ty1, actual ty2" - -- False <=> Just report a mismatch without orientation - -- The ReportErrCtxt has expected/actual - -> TcType -> TcType -> TcM ErrMsg +mkEqErr_help, reportEqErr + :: ReportErrCtxt + -> Ct + -> Bool -- True <=> Types are correct way round; + -- report "expected ty1, actual ty2" + -- False <=> Just report a mismatch without orientation + -- The ReportErrCtxt has expected/actual + -> TcType -> TcType -> TcM ErrMsg mkEqErr_help ctxt ct oriented ty1 ty2 | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt ct oriented tv1 ty2 | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt ct oriented tv2 ty1 - | otherwise -- Neither side is a type variable + | otherwise = reportEqErr ctxt ct oriented ty1 ty2 + +reportEqErr ctxt ct oriented ty1 ty2 = do { ctxt' <- mkEqInfoMsg ctxt ct ty1 ty2 ; mkErrorReport ctxt' (misMatchOrCND ctxt' ct oriented ty1 ty2) } @@ -481,11 +487,11 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2 -- So tv is a meta tyvar, and presumably it is -- an *untouchable* meta tyvar, else it'd have been unified - | not (k2 `isSubKind` k1) -- Kind error + | not (k2 `tcIsSubKind` k1) -- Kind error = mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) -- Occurs check - | tv1 `elemVarSet` tyVarsOfType ty2 + | isNothing (occurCheckExpand tv1 ty2) = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2 (sep [ppr ty1, char '=', ppr ty2]) in mkErrorReport ctxt occCheckMsg @@ -525,21 +531,10 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2 ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } | otherwise - = pprTrace "mkTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $ - panic "mkTyVarEqErr" - -- I don't think this should happen, and if it does I want to know - -- Trac #5130 happened because an actual type error was not - -- reported at all! So not reporting is pretty dangerous. - -- - -- OLD, OUT OF DATE COMMENT - -- This can happen, by a recursive decomposition of frozen - -- occurs check constraints - -- Example: alpha ~ T Int alpha has frozen. - -- Then alpha gets unified to T beta gamma - -- So now we have T beta gamma ~ T Int (T beta gamma) - -- Decompose to (beta ~ Int, gamma ~ T beta gamma) - -- The (gamma ~ T beta gamma) is the occurs check, but - -- the (beta ~ Int) isn't an error at all. So return () + = reportEqErr ctxt ct oriented (mkTyVarTy tv1) ty2 + -- This *can* happen (Trac #6123, and test T2627b) + -- Consider an ambiguous top-level constraint (a ~ F a) + -- Not an occurs check, becuase F is a type function. where k1 = tyVarKind tv1 k2 = typeKind ty2 @@ -571,20 +566,19 @@ misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc misMatchOrCND ctxt ct oriented ty1 ty2 | null givens || (isRigid ty1 && isRigid ty2) || - isGivenOrSolved (cc_flavor ct) + isGiven (cc_ev ct) -- If the equality is unconditionally insoluble -- or there is no context, don't report the context = misMatchMsg oriented ty1 ty2 | otherwise - = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig) + = couldNotDeduce givens ([mkEqPred ty1 ty2], orig) where givens = getUserGivens ctxt orig = TypeEqOrigin (UnifyOrigin ty1 ty2) couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc couldNotDeduce givens (wanteds, orig) - = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds) - 2 (pprArising orig) + = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds) , vcat (pp_givens givens)] pp_givens :: [([EvVar], GivenLoc)] -> [SDoc] @@ -621,11 +615,14 @@ tyVarExtraInfoMsg implics ty | otherwise -- Normal case = empty - where - ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful - ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"), - sep [ppr info, ptext (sLit "at") <+> ppr loc]] + ppr_skol given_loc tv_loc + = case skol_info of + UnkSkol -> ptext (sLit "is an unknown type variable") + _ -> sep [ ptext (sLit "is a rigid type variable bound by"), + sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]] + where + skol_info = ctLocOrigin given_loc kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy kindErrorMsg ty1 ty2 @@ -637,12 +634,6 @@ kindErrorMsg ty1 ty2 k2 = typeKind ty2 -------------------- -unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc) -unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env - = do { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty - ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty - ; return (env2, mkExpectedActualMsg exp_ty' act_ty') } - misMatchMsg :: Bool -> TcType -> TcType -> SDoc -- Types are already tidy -- If oriented then ty1 is expected, ty2 is actual misMatchMsg oriented ty1 ty2 @@ -658,8 +649,8 @@ misMatchMsg oriented ty1 ty2 mkExpectedActualMsg :: Type -> Type -> SDoc mkExpectedActualMsg exp_ty act_ty - = vcat [ text "Expected type" <> colon <+> ppr exp_ty - , text " Actual type" <> colon <+> ppr act_ty ] + = vcat [ text "Expected type:" <+> ppr exp_ty + , text " Actual type:" <+> ppr act_ty ] \end{code} Note [Non-injective type functions] @@ -682,108 +673,120 @@ Warn of loopy local equalities that were dropped. \begin{code} mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkDictErr ctxt cts - = do { inst_envs <- tcGetInstEnvs - ; stuff <- mapM (mkOverlap ctxt inst_envs orig) cts - ; let (non_overlaps, overlap_errs) = partitionEithers stuff - ; if null non_overlaps - then mkErrorReport ctxt (vcat overlap_errs) - else do - { (ctxt', is_ambig, ambig_msg) <- mkAmbigMsg ctxt cts - ; mkErrorReport ctxt' - (vcat [ mkNoInstErr givens non_overlaps orig - , ambig_msg - , mk_no_inst_fixes is_ambig non_overlaps]) } } + = ASSERT( not (null cts) ) + do { inst_envs <- tcGetInstEnvs + ; lookups <- mapM (lookup_cls_inst inst_envs) cts + ; let (no_inst_cts, overlap_cts) = partition is_no_inst lookups + + -- Report definite no-instance errors, + -- or (iff there are none) overlap errors + -- But we report only one of them (hence 'head') becuase they all + -- have the same source-location origin, to try avoid a cascade + -- of error from one location + ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) + ; mkErrorReport ctxt err } where - (ct1:_) = cts - orig = ctLocOrigin (ctWantedLoc ct1) - - givens = getUserGivens ctxt - - mk_no_inst_fixes is_ambig cts - | null givens = show_fixes (fixes2 ++ fixes3) - | otherwise = show_fixes (fixes1 ++ fixes2 ++ fixes3) + no_givens = null (getUserGivens ctxt) + is_no_inst (ct, (matches, unifiers, _)) + = no_givens + && null matches + && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyVarsOfCt ct))) + + lookup_cls_inst inst_envs ct + = do { tys_flat <- mapM quickFlattenTy tys + -- Note [Flattening in error message generation] + ; return (ct, lookupInstEnv inst_envs clas tys_flat) } where - min_wanteds = map ctPred cts - instance_dicts = filterOut isTyVarClassPred min_wanteds - -- Insts for which it is worth suggesting an adding an - -- instance declaration. Exclude tyvar dicts. - - fixes2 = case instance_dicts of - [] -> [] - [_] -> [sep [ptext (sLit "add an instance declaration for"), - pprTheta instance_dicts]] - _ -> [sep [ptext (sLit "add instance declarations for"), - pprTheta instance_dicts]] - fixes3 = case orig of - DerivOrigin -> [drv_fix] - _ -> [] + (clas, tys) = getClassPredTys (ctPred ct) - drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"), - nest 2 $ ptext (sLit "so you can specify the instance context yourself")] +mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) + -> TcM (ReportErrCtxt, SDoc) +-- Report an overlap error if this class constraint results +-- from an overlap (returning Left clas), otherwise return (Right pred) +mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) + | null matches -- No matches but perhaps several unifiers + = do { (ctxt', is_ambig, ambig_msg) <- mkAmbigMsg ctxt [ct] + ; return (ctxt', cannot_resolve_msg is_ambig ambig_msg) } - fixes1 | not is_ambig - , (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt) - = [sep [ ptext (sLit "add") <+> pprTheta min_wanteds - <+> ptext (sLit "to the context of") - , nest 2 $ ppr_skol orig $$ - vcat [ ptext (sLit "or") <+> ppr_skol orig - | orig <- origs ] - ] ] - | otherwise = [] + | not safe_haskell -- Some matches => overlap errors + = return (ctxt, overlap_msg) - ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc) - ppr_skol skol_info = ppr skol_info + | otherwise + = return (ctxt, safe_haskell_msg) + where + orig = ctLocOrigin (ctWantedLoc ct) + pred = ctPred ct + (clas, tys) = getClassPredTys pred + ispecs = [ispec | (ispec, _) <- matches] + givens = getUserGivens ctxt + all_tyvars = all isTyVarTy tys + + cannot_resolve_msg has_ambig_tvs ambig_msg + = vcat [ addArising orig (no_inst_herald <+> pprParendType pred) + , vcat (pp_givens givens) + , if has_ambig_tvs && (not (null unifiers) || not (null givens)) + then ambig_msg $$ potential_msg + else empty + , show_fixes (inst_decl_fixes + ++ add_to_ctxt_fixes has_ambig_tvs + ++ drv_fixes) ] + + potential_msg + | null unifiers = empty + | otherwise + = hang (if isSingleton unifiers + then ptext (sLit "Note: there is a potential instance available:") + else ptext (sLit "Note: there are several potential instances:")) + 2 (ppr_insts unifiers) + + add_to_ctxt_fixes has_ambig_tvs + | not has_ambig_tvs && all_tyvars + , (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt) + = [sep [ ptext (sLit "add") <+> pprParendType pred + <+> ptext (sLit "to the context of") + , nest 2 $ ppr_skol orig $$ + vcat [ ptext (sLit "or") <+> ppr_skol orig + | orig <- origs ] ] ] + | otherwise = [] + + ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc) + ppr_skol skol_info = ppr skol_info -- Do not suggest adding constraints to an *inferred* type signature! - get_good_orig ic = case ctLocOrigin (ic_loc ic) of + get_good_orig ic = case ctLocOrigin (ic_loc ic) of SigSkol (InfSigCtxt {}) _ -> Nothing origin -> Just origin + no_inst_herald + | null givens && null matches = ptext (sLit "No instance for") + | otherwise = ptext (sLit "Could not deduce") - show_fixes :: [SDoc] -> SDoc - show_fixes [] = empty - show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:") - , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] - -mkNoInstErr :: [UserGiven] -> [Ct] -> CtOrigin -> SDoc -mkNoInstErr givens cts orig - | null givens -- Top level - = addArising orig $ - ptext (sLit "No instance") <> plural cts - <+> ptext (sLit "for") <+> pprTheta theta - - | otherwise - = couldNotDeduce givens (theta, orig) - where - theta = map ctPred cts + inst_decl_fixes + | all_tyvars = [] + | otherwise = [ sep [ ptext (sLit "add an instance declaration for") + , pprParendType pred] ] -mkOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin - -> Ct -> TcM (Either Ct SDoc) --- Report an overlap error if this class constraint results --- from an overlap (returning Left clas), otherwise return (Right pred) -mkOverlap ctxt inst_envs orig ct - = do { tys_flat <- mapM quickFlattenTy tys - -- Note [Flattening in error message generation] + drv_fixes = case orig of + DerivOrigin -> [drv_fix] + _ -> [] - ; case lookupInstEnv inst_envs clas tys_flat of - ([], _, _) -> return (Left ct) -- No match - res -> return (Right (mk_overlap_msg res)) } - where - (clas, tys) = getClassPredTys (ctPred ct) + drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,")) + 2 (ptext (sLit "so you can specify the instance context yourself")) -- Normal overlap error - mk_overlap_msg (matches, unifiers, False) + overlap_msg = ASSERT( not (null matches) ) vcat [ addArising orig (ptext (sLit "Overlapping instances for") <+> pprType (mkClassPred clas tys)) - , sep [ptext (sLit "Matching instances") <> colon, - nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] , if not (null matching_givens) then - sep [ptext (sLit "Matching givens (or their superclasses)") <> colon + sep [ptext (sLit "Matching givens (or their superclasses):") , nest 2 (vcat matching_givens)] else empty + , sep [ptext (sLit "Matching instances:"), + nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] + , if null matching_givens && isSingleton matches && null unifiers then -- Intuitively, some given matched the wanted in their -- flattened or rewritten (from given equalities) form @@ -791,7 +794,7 @@ mkOverlap ctxt inst_envs orig ct -- constraints are non-flat and non-rewritten so we -- simply report back the whole given -- context. Accelerate Smart.hs showed this problem. - sep [ ptext (sLit "There exists a (perhaps superclass) match") <> colon + sep [ ptext (sLit "There exists a (perhaps superclass) match:") , nest 2 (vcat (pp_givens givens))] else empty @@ -827,13 +830,13 @@ mkOverlap ctxt inst_envs orig ct -> any ev_var_matches (immSuperClasses clas' tys') Nothing -> False - -- Overlap error because of Safe Haskell (first match should be the most - -- specific match) - mk_overlap_msg (matches, _unifiers, True) + -- Overlap error because of Safe Haskell (first + -- match should be the most specific match) + safe_haskell_msg = ASSERT( length matches > 1 ) vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") <+> pprType (mkClassPred clas tys)) - , sep [ptext (sLit "The matching instance is") <> colon, + , sep [ptext (sLit "The matching instance is:"), nest 2 (pprInstance $ head ispecs)] , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only" , ptext $ sLit "overlap instances from the same module, however it" @@ -841,8 +844,21 @@ mkOverlap ctxt inst_envs orig ct , nest 2 (vcat [pprInstances $ tail ispecs]) ] ] - where - ispecs = [ispec | (ispec, _) <- matches] + +show_fixes :: [SDoc] -> SDoc +show_fixes [] = empty +show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:") + , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] + +ppr_insts :: [ClsInst] -> SDoc +ppr_insts insts + = pprInstances (take 3 insts) $$ dot_dot_message + where + n_extra = length insts - 3 + dot_dot_message + | n_extra <= 0 = empty + | otherwise = ptext (sLit "...plus") + <+> speakNOf n_extra (ptext (sLit "other")) ---------------------- quickFlattenTy :: TcType -> TcM TcType @@ -850,6 +866,7 @@ quickFlattenTy :: TcType -> TcM TcType quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty' quickFlattenTy ty@(TyVarTy {}) = return ty quickFlattenTy ty@(ForAllTy {}) = return ty -- See +quickFlattenTy ty@(LitTy {}) = return ty -- Don't flatten because of the danger or removing a bound variable quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1 ; fy2 <- quickFlattenTy ty2 @@ -938,14 +955,15 @@ mkAmbigMsg ctxt cts -- if it is not already set! ] -getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo +getSkolemInfo :: [Implication] -> TcTyVar -> GivenLoc -- Get the skolem info for a type variable -- from the implication constraint that binds it getSkolemInfo [] tv = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv ) - UnkSkol + CtLoc UnkSkol noSrcSpan [] + getSkolemInfo (implic:implics) tv - | tv `elem` ic_skols implic = ctLocOrigin (ic_loc implic) + | tv `elem` ic_skols implic = ic_loc implic | otherwise = getSkolemInfo implics tv ----------------------- @@ -992,20 +1010,21 @@ find_thing tidy_env ignore_it (ATcId { tct_id = id }) ppr (getSrcLoc id)))] ; return (tidy_env', Just msg) } } -find_thing tidy_env ignore_it (ATyVar tv ty) - = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty +find_thing tidy_env ignore_it (ATyVar name tv) + = do { ty <- zonkTcTyVar tv + ; let (tidy_env1, tidy_ty) = tidyOpenType tidy_env ty ; if ignore_it tidy_ty then return (tidy_env, Nothing) else do { let -- The name tv is scoped, so we don't need to tidy it - msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff + msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr name) <+> eq_stuff , nest 2 bound_at] eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty - , getOccName tv == getOccName tv' = empty + , getOccName name == getOccName tv' = empty | otherwise = equals <+> ppr tidy_ty -- It's ok to use Type.getTyVar_maybe because ty is zonked by now - bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv) + bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc name) ; return (tidy_env1, Just msg) } } @@ -1045,7 +1064,20 @@ solverDepthErrorTcS depth stack | null stack -- Shouldn't happen unless you say -fcontext-stack=0 = failWith msg | otherwise - = setCtFlavorLoc (cc_flavor top_item) $ + = setCtFlavorLoc (cc_ev top_item) $ + do { zstack <- mapM zonkCt stack + ; env0 <- tcInitTidyEnv + ; let zstack_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet zstack + tidy_env = tidyFreeTyVars env0 zstack_tvs + tidy_cts = map (tidyCt tidy_env) zstack + ; failWithTcM (tidy_env, hang msg 2 (vcat (map (ppr . ctPred) tidy_cts))) } + where + top_item = head stack + msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth + , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] + +{- DV: Changing this because Derived's no longer have ids ... Kind of a corner case ... + = setCtFlavorLoc (cc_ev top_item) $ do { ev_vars <- mapM (zonkEvVar . cc_id) stack ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars) @@ -1055,8 +1087,10 @@ solverDepthErrorTcS depth stack top_item = head stack msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] +-} + -flattenForAllErrorTcS :: CtFlavor -> TcType -> TcM a +flattenForAllErrorTcS :: CtEvidence -> TcType -> TcM a flattenForAllErrorTcS fl ty = setCtFlavorLoc fl $ do { env0 <- tcInitTidyEnv @@ -1073,10 +1107,10 @@ flattenForAllErrorTcS fl ty %************************************************************************ \begin{code} -setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a -setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing -setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing -setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing +setCtFlavorLoc :: CtEvidence -> TcM a -> TcM a +setCtFlavorLoc (Wanted { ctev_wloc = loc }) thing = setCtLoc loc thing +setCtFlavorLoc (Derived { ctev_wloc = loc }) thing = setCtLoc loc thing +setCtFlavorLoc (Given { ctev_gloc = loc }) thing = setCtLoc loc thing \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index e18bb0c6a2..09704fbfd1 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -17,6 +17,7 @@ module TcEvidence ( EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, EvTerm(..), mkEvCast, evVarsOfTerm, mkEvKindCast, + EvLit(..), evTermCoercion, -- TcCoercion TcCoercion(..), @@ -35,7 +36,7 @@ import Var import PprCore () -- Instance OutputableBndr TyVar import TypeRep -- Knows type representation import TcType -import Type( tyConAppArgN, getEqPredTys_maybe, tyConAppTyCon_maybe ) +import Type( tyConAppArgN, getEqPredTys_maybe, tyConAppTyCon_maybe, getEqPredTys ) import TysPrim( funTyCon ) import TyCon import PrelNames @@ -101,6 +102,7 @@ data TcCoercion | TcSymCo TcCoercion | TcTransCo TcCoercion TcCoercion | TcNthCo Int TcCoercion + | TcCastCo TcCoercion TcCoercion -- co1 |> co2 | TcLetCo TcEvBinds TcCoercion deriving (Data.Data, Data.Typeable) @@ -198,6 +200,8 @@ tcCoercionKind co = go co where go (TcRefl ty) = Pair ty ty go (TcLetCo _ co) = go co + go (TcCastCo _ co) = case getEqPredTys (pSnd (go co)) of + (ty1,ty2) -> Pair ty1 ty2 go (TcTyConAppCo tc cos) = mkTyConApp tc <$> (sequenceA $ map go cos) go (TcAppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 go (TcForAllCo tv co) = mkForAllTy tv <$> go co @@ -205,8 +209,8 @@ tcCoercionKind co = go co go (TcCoVarCo cv) = eqVarKind cv go (TcAxiomInstCo ax tys) = Pair (substTyWith (co_ax_tvs ax) tys (co_ax_lhs ax)) (substTyWith (co_ax_tvs ax) tys (co_ax_rhs ax)) - go (TcSymCo co) = swap $ go co - go (TcTransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) + go (TcSymCo co) = swap (go co) + go (TcTransCo co1 co2) = Pair (pFst (go co1)) (pSnd (go co2)) go (TcNthCo d co) = tyConAppArgN d <$> go co -- c.f. Coercion.coercionKind @@ -218,7 +222,7 @@ eqVarKind cv | Just (tc, [_kind,ty1,ty2]) <- tcSplitTyConApp_maybe (varType cv) = ASSERT (tc `hasKey` eqTyConKey) Pair ty1 ty2 - | otherwise = panic "eqVarKind, non coercion variable" + | otherwise = pprPanic "eqVarKind, non coercion variable" (ppr cv <+> dcolon <+> ppr (varType cv)) coVarsOfTcCo :: TcCoercion -> VarSet -- Only works on *zonked* coercions, because of TcLetCo @@ -228,6 +232,7 @@ coVarsOfTcCo tc_co go (TcRefl _) = emptyVarSet go (TcTyConAppCo _ cos) = foldr (unionVarSet . go) emptyVarSet cos go (TcAppCo co1 co2) = go co1 `unionVarSet` go co2 + go (TcCastCo co1 co2) = go co1 `unionVarSet` go co2 go (TcForAllCo _ co) = go co go (TcInstCo co _) = go co go (TcCoVarCo v) = unitVarSet v @@ -237,7 +242,8 @@ coVarsOfTcCo tc_co go (TcNthCo _ co) = go co go (TcLetCo (EvBinds bs) co) = foldrBag (unionVarSet . go_bind) (go co) bs `minusVarSet` get_bndrs bs - go (TcLetCo {}) = pprPanic "coVarsOfTcCo called on non-zonked TcCoercion" (ppr tc_co) + go (TcLetCo {}) = emptyVarSet -- Harumph. This does legitimately happen in the call + -- to evVarsOfTerm in the DEBUG check of setEvBind -- We expect only coercion bindings go_bind :: EvBind -> VarSet @@ -262,6 +268,7 @@ liftTcCoSubstWith tvs cos ty Nothing -> mkTcReflCo ty go (AppTy t1 t2) = mkTcAppCo (go t1) (go t2) go (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys) + go ty@(LitTy {}) = mkTcReflCo ty go (ForAllTy tv ty) = mkTcForAllCo tv (go ty) go (FunTy t1 t2) = mkTcFunCo (go t1) (go t2) \end{code} @@ -287,6 +294,8 @@ ppr_co p (TcLetCo bs co) = maybeParen p TopPrec $ sep [ptext (sLit "let") <+> braces (ppr bs), ppr co] ppr_co p (TcAppCo co1 co2) = maybeParen p TyConPrec $ pprTcCo co1 <+> ppr_co TyConPrec co2 +ppr_co p (TcCastCo co1 co2) = maybeParen p FunPrec $ + ppr_co FunPrec co1 <+> ptext (sLit "|>") <+> ppr_co FunPrec co2 ppr_co p co@(TcForAllCo {}) = ppr_forall_co p co ppr_co p (TcInstCo co ty) = maybeParen p TyConPrec $ pprParendTcCo co <> ptext (sLit "@") <> pprType ty @@ -447,35 +456,68 @@ evBindMapBinds bs data EvBind = EvBind EvVar EvTerm data EvTerm - = EvId EvId -- Term-level variable-to-variable bindings - -- (no coercion variables! they come via EvCoercion) + = EvId EvId -- Any sort of evidence Id, including coercions - | EvCoercion TcCoercion -- (Boxed) coercion bindings + | EvCoercion TcCoercion -- (Boxed) coercion bindings + -- See Note [Coercion evidence terms] - | EvCast EvVar TcCoercion -- d |> co + | EvCast EvTerm TcCoercion -- d |> co | EvDFunApp DFunId -- Dictionary instance application - [Type] [EvVar] + [Type] [EvTerm] - | EvTupleSel EvId Int -- n'th component of the tuple + | EvTupleSel EvTerm Int -- n'th component of the tuple, 0-indexed - | EvTupleMk [EvId] -- tuple built from this stuff + | EvTupleMk [EvTerm] -- tuple built from this stuff | EvDelayedError Type FastString -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime] -- in TcSimplify - | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and + | EvSuperClass EvTerm Int -- n'th superclass. Used for both equalities and -- dictionaries, even though the former have no -- selector Id. We count up from _0_ - | EvKindCast EvVar TcCoercion -- See Note [EvKindCast] - + + | EvKindCast EvTerm TcCoercion -- See Note [EvKindCast] + + | EvLit EvLit -- Dictionary for class "SingI" for type lits. + -- Note [EvLit] + deriving( Data.Data, Data.Typeable) + + +data EvLit + = EvNum Integer + | EvStr FastString + deriving( Data.Data, Data.Typeable) + \end{code} +Note [Coecion evidence terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that a coercion variable (v :: t1 ~ t2) can be represented as an EvTerm +in two different ways: + EvId v + EvCoercion (TcCoVarCo v) + +An alternative would be + +* To establish the invariant that coercions are represented only + by EvCoercion + +* To maintain the invariant by smart constructors. Eg + mkEvCast (EvCoercion c1) c2 = EvCoercion (TcCastCo c1 c2) + mkEvCast t c = EvCast t c + +We do quite often need to get a TcCoercion from an EvTerm; see +'evTermCoercion'. Notice that as well as EvId and EvCoercion it may see +an EvCast. + +I don't think it matters much... but maybe we'll find a good reason to +do one or the other. + Note [EvKindCast] ~~~~~~~~~~~~~~~~~ - EvKindCast g kco is produced when we have a constraint (g : s1 ~ s2) but the kinds of s1 and s2 (k1 and k2 respectively) don't match but are rather equal by a coercion. You may think that this coercion will @@ -485,8 +527,7 @@ that coercion will be an 'error' term, which we want to evaluate rather than silently forget about! The relevant (and only) place where such a coercion is produced in -the simplifier is in emit_kind_constraint in TcCanonical. - +the simplifier is in TcCanonical.emitKindConstraint. Note [EvBinds/EvTerm] ~~~~~~~~~~~~~~~~~~~~~ @@ -506,15 +547,52 @@ Conclusion: a new wanted coercion variable should be made mutable. from super classes will be "given" and hence rigid] +Note [EvLit] +~~~~~~~~~~~~ +A part of the type-level literals implementation is the class "SingI", +which provides a "smart" constructor for defining singleton values. + +newtype Sing n = Sing (SingRep n) + +class SingI n where + sing :: Sing n + +type family SingRep a +type instance SingRep (a :: Nat) = Integer +type instance SingRep (a :: Symbol) = String + +Conceptually, this class has infinitely many instances: + +instance Sing 0 where sing = Sing 0 +instance Sing 1 where sing = Sing 1 +instance Sing 2 where sing = Sing 2 +instance Sing "hello" where sing = Sing "hello" +... + +In practice, we solve "SingI" predicates in the type-checker because we can't +have infinately many instances. The evidence (aka "dictionary") +for "SingI (n :: Nat)" is of the form "EvLit (EvNum n)". + +We make the following assumptions about dictionaries in GHC: + 1. The "dictionary" for classes with a single method---like SingI---is + a newtype for the type of the method, so using a evidence amounts + to a coercion, and + 2. Newtypes use the same representation as their definition types. + +So, the evidence for "SingI" is just a value of the representation type, +wrapped in two newtype constructors: one to make it into a "Sing" value, +and another to make it into "SingI" evidence. + + \begin{code} -mkEvCast :: EvVar -> TcCoercion -> EvTerm +mkEvCast :: EvTerm -> TcCoercion -> EvTerm mkEvCast ev lco - | isTcReflCo lco = EvId ev + | isTcReflCo lco = ev | otherwise = EvCast ev lco -mkEvKindCast :: EvVar -> TcCoercion -> EvTerm +mkEvKindCast :: EvTerm -> TcCoercion -> EvTerm mkEvKindCast ev lco - | isTcReflCo lco = EvId ev + | isTcReflCo lco = ev | otherwise = EvKindCast ev lco emptyTcEvBinds :: TcEvBinds @@ -525,16 +603,28 @@ isEmptyTcEvBinds (EvBinds b) = isEmptyBag b isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" -evVarsOfTerm :: EvTerm -> [EvVar] -evVarsOfTerm (EvId v) = [v] -evVarsOfTerm (EvCoercion co) = varSetElems (coVarsOfTcCo co) -evVarsOfTerm (EvDFunApp _ _ evs) = evs -evVarsOfTerm (EvTupleSel v _) = [v] -evVarsOfTerm (EvSuperClass v _) = [v] -evVarsOfTerm (EvCast v co) = v : varSetElems (coVarsOfTcCo co) -evVarsOfTerm (EvTupleMk evs) = evs -evVarsOfTerm (EvDelayedError _ _) = [] -evVarsOfTerm (EvKindCast v co) = v : varSetElems (coVarsOfTcCo co) +evTermCoercion :: EvTerm -> TcCoercion +-- Applied only to EvTerms of type (s~t) +-- See Note [Coercion evidence terms] +evTermCoercion (EvId v) = mkTcCoVarCo v +evTermCoercion (EvCoercion co) = co +evTermCoercion (EvCast tm co) = TcCastCo (evTermCoercion tm) co +evTermCoercion tm = pprPanic "evTermCoercion" (ppr tm) + +evVarsOfTerm :: EvTerm -> VarSet +evVarsOfTerm (EvId v) = unitVarSet v +evVarsOfTerm (EvCoercion co) = coVarsOfTcCo co +evVarsOfTerm (EvDFunApp _ _ evs) = evVarsOfTerms evs +evVarsOfTerm (EvTupleSel v _) = evVarsOfTerm v +evVarsOfTerm (EvSuperClass v _) = evVarsOfTerm v +evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co +evVarsOfTerm (EvTupleMk evs) = evVarsOfTerms evs +evVarsOfTerm (EvDelayedError _ _) = emptyVarSet +evVarsOfTerm (EvKindCast v co) = coVarsOfTcCo co `unionVarSet` evVarsOfTerm v +evVarsOfTerm (EvLit _) = emptyVarSet + +evVarsOfTerms :: [EvTerm] -> VarSet +evVarsOfTerms = foldr (unionVarSet . evVarsOfTerm) emptyVarSet \end{code} @@ -594,7 +684,12 @@ instance Outputable EvTerm where ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] + ppr (EvLit l) = ppr l ppr (EvDelayedError ty msg) = ptext (sLit "error") <+> sep [ char '@' <> ppr ty, ppr msg ] + +instance Outputable EvLit where + ppr (EvNum n) = integer n + ppr (EvStr s) = text (show s) \end{code} diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index abcff85d7d..f3c238bd66 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -46,7 +46,6 @@ import DataCon import Name import TyCon import Type -import Kind( splitKiTyVars ) import TcEvidence import Var import VarSet @@ -64,6 +63,7 @@ import ErrUtils import Outputable import FastString import Control.Monad +import Class(classTyCon) \end{code} %************************************************************************ @@ -179,15 +179,23 @@ tcExpr (NegApp expr neg_expr) res_ty ; expr' <- tcMonoExpr expr res_ty ; return (NegApp expr' neg_expr') } -tcExpr (HsIPVar ip) res_ty - = do { let origin = IPOccOrigin ip - -- Implicit parameters must have a *tau-type* not a - -- type scheme. We enforce this by creating a fresh - -- type variable as its type. (Because res_ty may not - -- be a tau-type.) - ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple - ; ip_var <- emitWanted origin (mkIPPred ip ip_ty) - ; tcWrapResult (HsIPVar (IPName ip_var)) ip_ty res_ty } +tcExpr (HsIPVar x) res_ty + = do { let origin = IPOccOrigin x + ; ipClass <- tcLookupClass ipClassName + {- Implicit parameters must have a *tau-type* not a. + type scheme. We enforce this by creating a fresh + type variable as its type. (Because res_ty may not + be a tau-type.) -} + ; ip_ty <- newFlexiTyVarTy openTypeKind + ; let ip_name = mkStrLitTy (hsIPNameFS x) + ; ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty]) + ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty } + where + -- Coerces a dictionry for `IP "x" t` into `t`. + fromDict ipClass x ty = + case unwrapNewTyCon_maybe (classTyCon ipClass) of + Just (_,_,ax) -> HsWrap $ WpCast $ mkTcAxInstCo ax [x,ty] + Nothing -> panic "The dictionary for `IP` is not a newtype?" tcExpr (HsLam match) res_ty = do { (co_fn, match') <- tcMatchLambda match res_ty @@ -199,7 +207,7 @@ tcExpr (ExprWithTySig expr sig_ty) res_ty -- Remember to extend the lexical type-variable environment ; (gen_fn, expr') <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty -> - tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ + tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` skol_tvs) $ -- See Note [More instantiated than scoped] in TcBinds tcMonoExprNC expr res_ty @@ -345,7 +353,7 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty | otherwise = -- The tup_args are a mixture of Present and Missing (for tuple sections) do { let kind = case boxity of { Boxed -> liftedTypeKind - ; Unboxed -> argTypeKind } + ; Unboxed -> openTypeKind } arity = length tup_args tup_tc = tupleTyCon (boxityNormalTupleSort boxity) arity @@ -648,25 +656,25 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty -- ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons is_fixed_tv tv = tv `elemVarSet` fixed_tvs - mk_inst_ty subst tv result_inst_ty - | is_fixed_tv tv = return result_inst_ty -- Same as result type - | otherwise = newFlexiTyVarTy (subst (tyVarKind tv)) -- Fresh type, of correct kind - - ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs - - ; let (con1_r_kvs, con1_r_tvs) = splitKiTyVars con1_tvs - n_kinds = length con1_r_kvs - (result_inst_r_kis, result_inst_r_tys) = splitAt n_kinds result_inst_tys - ; scrut_inst_r_kis <- zipWithM (mk_inst_ty (TcType.substTy (zipTopTvSubst [] []))) con1_r_kvs result_inst_r_kis - -- IA0_NOTE: we have to build the kind substitution - ; let kind_subst = TcType.substTy (zipTopTvSubst con1_r_kvs scrut_inst_r_kis) - ; scrut_inst_r_tys <- zipWithM (mk_inst_ty kind_subst) con1_r_tvs result_inst_r_tys - - ; let scrut_inst_tys = scrut_inst_r_kis ++ scrut_inst_r_tys - rec_res_ty = TcType.substTy result_inst_env con1_res_ty - con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys - scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys - scrut_ty = TcType.substTy scrut_subst con1_res_ty + + mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType) + -- Deals with instantiation of kind variables + -- c.f. TcMType.tcInstTyVarsX + mk_inst_ty subst (tv, result_inst_ty) + | is_fixed_tv tv -- Same as result type + = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) + | otherwise -- Fresh type, of correct kind + = do { new_ty <- newFlexiTyVarTy (TcType.substTy subst (tyVarKind tv)) + ; return (extendTvSubst subst tv new_ty, new_ty) } + + ; (_, result_inst_tys, result_subst) <- tcInstTyVars con1_tvs + + ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst + (con1_tvs `zip` result_inst_tys) + + ; let rec_res_ty = TcType.substTy result_subst con1_res_ty + scrut_ty = TcType.substTy scrut_subst con1_res_ty + con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys ; co_res <- unifyType rec_res_ty res_ty @@ -833,6 +841,10 @@ tcApp (L loc (HsVar fun)) args res_ty , [arg] <- args = tcTagToEnum loc fun arg res_ty + | fun `hasKey` seqIdKey + , [arg1,arg2] <- args + = tcSeq loc fun arg1 arg2 res_ty + tcApp fun args res_ty = do { -- Type-check the function ; (fun1, fun_tau) <- tcInferFun fun @@ -892,7 +904,7 @@ tcInferFun fun -- Zonk the function type carefully, to expose any polymorphism -- E.g. (( \(x::forall a. a->a). blah ) e) -- We can see the rank-2 type of the lambda in time to genrealise e - ; fun_ty' <- zonkTcTypeCarefully fun_ty + ; fun_ty' <- zonkTcType fun_ty ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty' ; return (mkLHsWrap wrap fun, rho) } @@ -1119,6 +1131,18 @@ constructors of F [Int] but here we have to do it explicitly. It's all grotesquely complicated. \begin{code} +tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name + -> TcRhoType -> TcM (HsExpr TcId) +-- (seq e1 e2) :: res_ty +-- We need a special typing rule because res_ty can be unboxed +tcSeq loc fun_name arg1 arg2 res_ty + = do { fun <- tcLookupId fun_name + ; (arg1', arg1_ty) <- tcInfer (tcMonoExpr arg1) + ; arg2' <- tcMonoExpr arg2 res_ty + ; let fun' = L loc (HsWrap ty_args (HsVar fun)) + ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty + ; return (HsApp (L loc (HsApp fun' arg1')) arg2') } + tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId) -- tagToEnum# :: forall a. Int# -> a -- See Note [tagToEnum#] Urgh! diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index c009343b32..90a174081c 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -48,6 +48,7 @@ import Platform import SrcLoc import Bag import FastString +import Util import Control.Monad \end{code} @@ -122,15 +123,10 @@ normaliseFfiType' env ty0 = go [] ty0 panic "normaliseFfiType': Got more GREs than expected" _ -> return False - when (not newtypeOK) $ - -- later: stop_here - addWarnTc (ptext (sLit "newtype") <+> quotes (ppr tc) <+> - ptext (sLit "is used in an FFI declaration,") $$ - ptext (sLit "but its constructor is not in scope.") $$ - ptext (sLit "This will become an error in GHC 7.6.1.")) - - let nt_co = mkAxInstCo (newTyConCo tc) tys - add_co nt_co rec_nts' nt_rhs + if newtypeOK + then do let nt_co = mkAxInstCo (newTyConCo tc) tys + add_co nt_co rec_nts' nt_rhs + else children_only | isFamilyTyCon tc -- Expand open tycons , (co, ty) <- normaliseTcApp env tc tys @@ -138,11 +134,7 @@ normaliseFfiType' env ty0 = go [] ty0 = add_co co rec_nts ty | otherwise - = return (mkReflCo ty, ty) - -- If we have reached an ordinary (non-newtype) type constructor, - -- we are done. Note that we don't need to normalise the arguments, - -- because whether an FFI type is legal or not depends only on - -- the top-level type constructor (e.g. "Ptr a" is valid for all a). + = children_only where tc_key = getUnique tc children_only = do xs <- mapM (go rec_nts) tys @@ -166,8 +158,8 @@ normaliseFfiType' env ty0 = go [] ty0 = do (coi,nty1) <- go rec_nts ty1 return (mkForAllCo tyvar coi, ForAllTy tyvar nty1) - go _ ty@(TyVarTy _) - = return (Refl ty, ty) + go _ ty@(TyVarTy {}) = return (Refl ty, ty) + go _ ty@(LitTy {}) = return (Refl ty, ty) add_co co rec_nts ty = do (co', ty') <- go rec_nts ty @@ -212,46 +204,46 @@ tcFImport d = pprPanic "tcFImport" (ppr d) \begin{code} tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _)) +tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh l@(CLabel _)) = ASSERT( null arg_tys ) - do { checkCg checkCOrAsmOrLlvmOrInterp - ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty) - ; return idecl } -- NB check res_ty not sig_ty! - -- In case sig_ty is (forall a. ForeignPtr a) - -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do + do checkCg checkCOrAsmOrLlvmOrInterp + -- NB check res_ty not sig_ty! + -- In case sig_ty is (forall a. ForeignPtr a) + check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty) + cconv' <- checkCConv cconv + return (CImport cconv' safety mh l) + +tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do -- Foreign wrapper (former f.e.d.) - -- The type must be of the form ft -> IO (FunPtr ft), where ft is a - -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well - -- as ft -> IO Addr is accepted, too. The use of the latter two forms - -- is DEPRECATED, though. + -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid + -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. + -- The use of the latter form is DEPRECATED, though. checkCg checkCOrAsmOrLlvmOrInterp - checkCConv cconv + cconv' <- checkCConv cconv case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty - checkForeignRes mustBeIO checkSafe isFFIDynResultTy res_ty - -- ToDo: Why are res1_ty and res_ty not equal? + checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty _ -> addErrTc (illegalForeignTyErr empty sig_ty) - return idecl + return (CImport cconv' safety mh CWrapper) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target)) | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp - checkCConv cconv - case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr + cconv' <- checkCConv cconv + case arg_tys of -- The first arg must be Ptr or FunPtr [] -> do check False (illegalForeignTyErr empty sig_ty) - return idecl (arg1_ty:arg_tys) -> do dflags <- getDynFlags - check (isFFIDynArgumentTy arg1_ty) + let curried_res_ty = foldr FunTy res_ty arg_tys + check (isFFIDynTy curried_res_ty arg1_ty) (illegalForeignTyErr argument arg1_ty) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - return idecl + return $ CImport cconv' safety mh (CFunction target) | cconv == PrimCallConv = do dflags <- getDynFlags check (xopt Opt_GHCForeignImportPrim dflags) @@ -266,19 +258,24 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar return idecl | otherwise = do -- Normal foreign import checkCg checkCOrAsmOrLlvmOrDotNetOrInterp - checkCConv cconv + cconv' <- checkCConv cconv checkCTarget target dflags <- getDynFlags checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty checkMissingAmpersand dflags arg_tys res_ty - return idecl + case target of + StaticTarget _ _ False + | not (null arg_tys) -> + addErrTc (text "`value' imports cannot have function types") + _ -> return () + return $ CImport cconv' safety mh (CFunction target) -- This makes a convenient place to check -- that the C identifier is valid for C checkCTarget :: CCallTarget -> TcM () -checkCTarget (StaticTarget str _) = do +checkCTarget (StaticTarget str _ _) = do checkCg checkCOrAsmOrLlvmOrDotNetOrInterp check (isCLabelString str) (badCName str) @@ -319,7 +316,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) (norm_co, norm_sig_ty) <- normaliseFfiType sig_ty - tcCheckFEType norm_sig_ty spec + spec' <- tcCheckFEType norm_sig_ty spec -- we're exporting a function, but at a type possibly more -- constrained than its declared/inferred type. Hence the need @@ -331,20 +328,21 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) -- is *stable* (i.e. the compiler won't change it later), -- because this name will be referred to by the C code stub. id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec) + return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec') tcFExport d = pprPanic "tcFExport" (ppr d) \end{code} ------------ Checking argument types for foreign export ---------------------- \begin{code} -tcCheckFEType :: Type -> ForeignExport -> TcM () +tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do checkCg checkCOrAsmOrLlvm check (isCLabelString str) (badCName str) - checkCConv cconv + cconv' <- checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty + return (CExport (CExportStatic str cconv')) where -- Drop the foralls before inspecting n -- the structure of the foreign type. @@ -453,15 +451,19 @@ checkCg check = do Calling conventions \begin{code} -checkCConv :: CCallConv -> TcM () -checkCConv CCallConv = return () -checkCConv CApiConv = return () +checkCConv :: CCallConv -> TcM CCallConv +checkCConv CCallConv = return CCallConv +checkCConv CApiConv = return CApiConv checkCConv StdCallConv = do dflags <- getDynFlags let platform = targetPlatform dflags - unless (platformArch platform == ArchX86) $ - -- This is a warning, not an error. see #3336 - addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") -checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'") + if platformArch platform == ArchX86 + then return StdCallConv + else do -- This is a warning, not an error. see #3336 + when (wopt Opt_WarnUnsupportedCallingConventions dflags) $ + addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + return CCallConv +checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") + return PrimCallConv checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 70d841e5ed..0566192353 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -11,7 +11,9 @@ This module is nominally ``subordinate'' to @TcDeriv@, which is the This is where we do all the grimy bindings' generation. \begin{code} -{-# OPTIONS -fno-warn-tabs -XScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See @@ -47,6 +49,7 @@ import BasicTypes import DataCon import Name +import DynFlags import HscTypes import PrelInfo import FamInstEnv( FamInst ) @@ -1267,11 +1270,12 @@ we generate \begin{code} -gen_Data_binds :: SrcSpan +gen_Data_binds :: DynFlags + -> SrcSpan -> TyCon -> (LHsBinds RdrName, -- The method bindings BagDerivStuff) -- Auxiliary bindings -gen_Data_binds loc tycon +gen_Data_binds dflags loc tycon = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] `unionBags` gcast_binds, -- Auxiliary definitions: the data type and constructors @@ -1291,7 +1295,7 @@ gen_Data_binds loc tycon sig_ty = nlHsTyVar dataType_RDR constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon] rhs = nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) + `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr tycon))) `nlHsApp` nlList constrs genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName) diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 1fbb7df856..8745f8e612 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -6,6 +6,7 @@ The deriving code for the Generic class (equivalent to the code in TcGenDeriv, for other classes) \begin{code} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and @@ -14,8 +15,10 @@ The deriving code for the Generic class -- for details -module TcGenGenerics (canDoGenerics, gen_Generic_binds) where - +module TcGenGenerics (canDoGenerics, canDoGenerics1, + GenericKind(..), + MetaTyCons, genGenericMetaTyCons, + gen_Generic_binds, get_gen1_constrained_tys) where import DynFlags import HsSyn @@ -40,9 +43,14 @@ import HscTypes import BuildTyCl import SrcLoc import Bag +import VarSet (elemVarSet) import Outputable import FastString import UniqSupply +import Util + +import Control.Monad (mplus) +import qualified State as S #include "HsVersions.h" \end{code} @@ -61,18 +69,14 @@ For the generic representation we need to generate: \end{itemize} \begin{code} -gen_Generic_binds :: TyCon -> Module - -> TcM (LHsBinds RdrName, BagDerivStuff) -gen_Generic_binds tc mod = do - { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod - ; metaInsts <- genDtMeta (tc, metaTyCons) - ; return ( mkBindsRep tc - , (DerivFamInst rep0TyInst) - `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons)) - `unionBags` metaInsts)) } - -genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, FamInst) -genGenericRepExtras tc mod = +gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module + -> TcM (LHsBinds RdrName, FamInst) +gen_Generic_binds gk tc metaTyCons mod = do + repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod + return (mkBindsRep gk tc, repTyInsts) + +genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff) +genGenericMetaTyCons tc mod = do uniqS <- newUniqueSupply let -- Uniques for everyone @@ -99,7 +103,7 @@ genGenericRepExtras tc mod = | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ] mkTyCon name = ASSERT( isExternalName name ) - buildAlgTyCon name [] [] distinctAbstractTyConRhs + buildAlgTyCon name [] Nothing [] distinctAbstractTyConRhs NonRecursive False NoParentTyCon let metaDTyCon = mkTyCon d_name @@ -108,14 +112,13 @@ genGenericRepExtras tc mod = | s_namesC <- s_names ] metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons - - rep0_tycon <- tc_mkRepTyCon tc metaDts mod - + -- pprTrace "rep0" (ppr rep0_tycon) $ - return (metaDts, rep0_tycon) + (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts -genDtMeta :: (TyCon, MetaTyCons) -> TcM BagDerivStuff -genDtMeta (tc,metaDts) = +-- both the tycon declarations and related instances +metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff +metaTyConsToDerivStuff tc metaDts = do loc <- getSrcSpanM dflags <- getDynFlags dClas <- tcLookupClass datatypeClassName @@ -171,7 +174,8 @@ genDtMeta (tc,metaDts) = ASSERT (and (zipWith (>=) (map length l1) (map length l2))) [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] - return (listToBag (d_mkInst : c_mkInst ++ concat s_mkInst)) + return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts) + `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst) \end{code} %************************************************************************ @@ -181,25 +185,47 @@ genDtMeta (tc,metaDts) = %************************************************************************ \begin{code} -canDoGenerics :: TyCon -> Maybe SDoc +get_gen1_constrained_tys :: TyVar -> [Type] -> [Type] +-- called by TcDeriv.inferConstraints; generates a list of types, each of which +-- must be a Functor in order for the Generic1 instance to work. +get_gen1_constrained_tys argVar = + concatMap $ argTyFold argVar $ ArgTyAlg { + ata_rec0 = const [], + ata_par1 = [], ata_rec1 = const [], + ata_comp = (:)} + + + +canDoGenerics :: TyCon -> [Type] -> Maybe SDoc -- Called on source-code data types, to see if we should generate -- generic functions for them. -- Nothing == yes -- Just s == no, because of `s` -canDoGenerics tycon - = mergeErrors ( +canDoGenerics tc tc_args + = mergeErrors ( -- We do not support datatypes with context - (if (not (null (tyConStupidTheta tycon))) - then (Just (ppr tycon <+> text "must not have a datatype context")) - else Nothing) - -- We don't like type families - : (if (isFamilyTyCon tycon) - then (Just (ppr tycon <+> text "must not be a family instance")) - else Nothing) + (if (not (null (tyConStupidTheta tc))) + then (Just (tc_name <+> text "must not have a datatype context")) + else Nothing) : + -- The type should not be instantiated (see #5939) + -- Data family indices can be instantiated; the `tc_args` here are the + -- representation tycon args + (if (all isTyVarTy tc_args) + then Nothing + else Just (tc_name <+> text "must not be instantiated;" <+> + text "try deriving `" <> tc_name <+> tc_tys <> + text "' instead")) -- See comment below - : (map bad_con (tyConDataCons tycon))) + : (map bad_con (tyConDataCons tc))) where + -- The tc can be a representation tycon. When we want to display it to the + -- user (in an error message) we should print its parent + (tc_name, tc_tys) = case tyConParent tc of + FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr + (tys ++ drop (length tys) tc_args))) + _ -> (ppr tc, hsep (map ppr tc_args)) + -- If any of the constructor has an unboxed type as argument, -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types @@ -213,13 +239,109 @@ canDoGenerics tycon -- Nor can we do the job if it's an existential data constructor, -- Nor if the args are polymorphic types (I don't think) bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) - - mergeErrors :: [Maybe SDoc] -> Maybe SDoc - mergeErrors [] = Nothing - mergeErrors ((Just s):t) = case mergeErrors t of - Nothing -> Just s - Just s' -> Just (s <> text ", and" $$ s') - mergeErrors (Nothing :t) = mergeErrors t + +mergeErrors :: [Maybe SDoc] -> Maybe SDoc +mergeErrors [] = Nothing +mergeErrors ((Just s):t) = case mergeErrors t of + Nothing -> Just s + Just s' -> Just (s <> text ", and" $$ s') +mergeErrors (Nothing :t) = mergeErrors t + +canDoGenerics1 :: TyCon -> [Type] -> Maybe SDoc +-- Called on source-code data types, to see if we should generate +-- generic functions for them. +-- Nothing == yes +-- Just s == no, because of `s` + +-- (derived from TcDeriv.cond_functorOK; also checks canDoGenerics) + +-- OK for Generic1/Rep1 +-- Currently: (a) at least one argument +-- (b) don't use argument contravariantly +-- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) +-- (d) no "stupid context" on data type +-- (e) not instantiated (except for data family indices) +canDoGenerics1 tc tc_args = canDoGenerics tc tc_args + `mplus` S.evalState (canDoGenerics1_w tc) [] + +-- the state is which tycons we have entered; it avoids divergence when we +-- recur (robust against mutual recursion) +canDoGenerics1_w :: TyCon -> S.State [Name] (Maybe SDoc) +canDoGenerics1_w rep_tc + | null tc_tvs + = return $ Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "must have some type parameters")) + + | not (null bad_stupid_theta) + = return $ Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta) + + | otherwise + = (mergeErrors . concat) `fmap` mapM check_con data_cons + where + tc_tvs = tyConTyVars rep_tc + Just (_, last_tv) = snocView tc_tvs + bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) + is_bad pred = last_tv `elemVarSet` tyVarsOfType pred + + data_cons = tyConDataCons rep_tc + check_con con = case check_vanilla con of + j@(Just _) -> return [j] + Nothing -> mapM snd $ foldDataConArgs (ft_check con) con + + bad :: DataCon -> SDoc -> SDoc + bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg + + check_vanilla :: DataCon -> Maybe SDoc + check_vanilla con | isVanillaDataCon con = Nothing + | otherwise = Just (bad con existential) + + -- the Bool is if the parameter occurs in the type + ft_check :: DataCon -> FFoldType (Bool, S.State [Name] (Maybe SDoc)) + ft_check con = FT { ft_triv = bmzero, ft_var = (True, return Nothing) + , ft_co_var = (True, return $ Just $ bad con covariant) + -- NB foldDataConArgs caters to Functor/Foldable/etc, + -- which treat applications of functions and tuples + -- specially. But we just treat them like normal + -- applications, so we must compensate with extra logic + -- to ensure that the variable only occurs as the last + -- argument. + , ft_fun = \x y -> if fst x then (True, return $ Just $ bad con wrong_arg) + else x `bmplus` y + , ft_tup = \_ xs -> + if not (null xs) && any fst (init xs) + then (True, return $ Just $ bad con wrong_arg) + else foldr bmplus bmzero xs + , ft_ty_app = \ty x -> bmplus x $ (,) False $ + if fst x then representable ty else return Nothing + , ft_bad_app = (True, return $ Just $ bad con wrong_arg) + , ft_forall = \_ -> id } + + bmzero = (False, return Nothing) + bmplus (b1, m1) (b2, m2) = (b1 || b2, m1 >>= maybe m2 (return . Just)) + + representable :: Type -> S.State [Name] (Maybe SDoc) + representable ty = case tcSplitTyConApp_maybe ty of + Nothing -> return Nothing + -- if it's a type constructor, it has to be representable + Just (tc, tc_args) -> do + let n = tyConName tc + s <- S.get + -- internally assume that recursive occurrences are OK + if n `elem` s then return Nothing else do + S.put (n : s) + fmap {-maybe-} (\_ -> bad_app tc) -- don't give the message, just name what wasn't representable + `fmap` {-state-} case canDoGenerics tc tc_args of + j@(Just _) -> return j + -- only check Generic1 if it passes Generic + Nothing -> canDoGenerics1_w tc + + existential = (ptext . sLit) "must not have existential arguments" + covariant = (ptext . sLit) "must not use the last type parameter in a function argument" + wrong_arg = (ptext . sLit) "must use the last type parameter only as the last argument of a data type, newtype, or (->)" + bad_app tc = (ptext . sLit) "must not apply type constructors that cannot be represented with `Rep1' (such as `" <> ppr (tyConName tc) + <> (ptext . sLit) "') to arguments that involve the last type parameter" + \end{code} %************************************************************************ @@ -232,89 +354,212 @@ canDoGenerics tycon type US = Int -- Local unique supply, just a plain Int type Alt = (LPat RdrName, LHsExpr RdrName) +-- GenericKind serves to mark if a datatype derives Generic (Gen0) or +-- Generic1 (Gen1). +data GenericKind = Gen0 | Gen1 + +-- as above, but with a payload of the TyCon's name for "the" parameter +data GenericKind_ = Gen0_ | Gen1_ TyVar + +-- as above, but using a single datacon's name for "the" parameter +data GenericKind_DC = Gen0_DC | Gen1_DC TyVar + +forgetArgVar :: GenericKind_DC -> GenericKind +forgetArgVar Gen0_DC = Gen0 +forgetArgVar Gen1_DC{} = Gen1 + +-- When working only within a single datacon, "the" parameter's name should +-- match that datacon's name for it. +gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC +gk2gkDC Gen0_ _ = Gen0_DC +gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d + + + -- Bindings for the Generic instance -mkBindsRep :: TyCon -> LHsBinds RdrName -mkBindsRep tycon = - unitBag (L loc (mkFunBind (L loc from_RDR) from_matches)) +mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName +mkBindsRep gk tycon = + unitBag (L loc (mkFunBind (L loc from01_RDR) from_matches)) `unionBags` - unitBag (L loc (mkFunBind (L loc to_RDR) to_matches)) + unitBag (L loc (mkFunBind (L loc to01_RDR) to_matches)) where from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ] loc = srcLocSpan (getSrcLoc tycon) datacons = tyConDataCons tycon + (from01_RDR, to01_RDR) = case gk of + Gen0 -> (from_RDR, to_RDR) + Gen1 -> (from1_RDR, to1_RDR) + -- Recurse over the sum first from_alts, to_alts :: [Alt] - (from_alts, to_alts) = mkSum (1 :: US) tycon datacons + (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons + where gk_ = case gk of + Gen0 -> Gen0_ + Gen1 -> ASSERT (length tyvars >= 1) + Gen1_ (last tyvars) + where tyvars = tyConTyVars tycon -------------------------------------------------------------------------------- --- The type instance synonym and synonym +-- The type synonym instance and synonym -- type instance Rep (D a b) = Rep_D a b -- type Rep_D a b = ...representation type for D ... -------------------------------------------------------------------------------- -tc_mkRepTyCon :: TyCon -- The type to generate representation for +tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 + -> TyCon -- The type to generate representation for -> MetaTyCons -- Metadata datatypes to refer to -> Module -- Used as the location of the new RepTy -> TcM FamInst -- Generated representation0 coercion -tc_mkRepTyCon tycon metaDts mod = --- Consider the example input tycon `D`, where data D a b = D_ a - do { -- `rep0` = GHC.Generics.Rep (type family) - rep0 <- tcLookupTyCon repTyConName +tc_mkRepFamInsts gk tycon metaDts mod = + -- Consider the example input tycon `D`, where data D a b = D_ a + -- Also consider `R:DInt`, where { data family D x y :: * -> * + -- ; data instance D Int a b = D_ a } + do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family) + rep <- case gk of + Gen0 -> tcLookupTyCon repTyConName + Gen1 -> tcLookupTyCon rep1TyConName - -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; rep0Ty <- tc_mkRepTy tycon metaDts + ; let -- `tyvars` = [a,b] + (tyvars, gk_) = case gk of + Gen0 -> (all_tyvars, Gen0_) + Gen1 -> ASSERT (not $ null all_tyvars) + (init all_tyvars, Gen1_ $ last all_tyvars) + where all_tyvars = tyConTyVars tycon + + tyvar_args = mkTyVarTys tyvars + + appT = case tyConFamInst_maybe tycon of + -- `appT` = D Int a b (data families case) + Just (famtycon, apps) -> + -- `fam` = D + -- `apps` = [Int, a] + let allApps = apps ++ + drop (length apps + length tyvars + - tyConArity famtycon) tyvar_args + in [mkTyConApp famtycon allApps] + -- `appT` = D a b (normal case) + Nothing -> [mkTyConApp tycon tyvar_args] + + -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * + ; repTy <- tc_mkRepTy gk_ tycon metaDts -- `rep_name` is a name we generate for the synonym - ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon))) - (nameSrcSpan (tyConName tycon)) - - ; let -- `tyvars` = [a,b] - tyvars = tyConTyVars tycon + ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R + in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon))) + (nameSrcSpan (tyConName tycon)) - -- `appT` = D a b - appT = [mkTyConApp tycon (mkTyVarTys tyvars)] - ; return $ mkSynFamInst rep_name tyvars rep0 appT rep0Ty + ; return $ mkSynFamInst rep_name tyvars rep appT repTy } - - -------------------------------------------------------------------------------- -- Type representation -------------------------------------------------------------------------------- -tc_mkRepTy :: -- The type to generate representation for - TyCon +-- | See documentation of 'argTyFold'; that function uses the fields of this +-- type to interpret the structure of a type when that type is considered as an +-- argument to a constructor that is being represented with 'Rep1'. +data ArgTyAlg a = ArgTyAlg + { ata_rec0 :: (Type -> a) + , ata_par1 :: a, ata_rec1 :: (Type -> a) + , ata_comp :: (Type -> a -> a) + } + +-- | @argTyFold@ implements a generalised and safer variant of the @arg@ +-- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@ +-- is conceptually equivalent to: +-- +-- > arg t = case t of +-- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t +-- > App f [t'] | +-- representable1 f && +-- t' == argVar -> Rec1 f +-- > App f [t'] | +-- representable1 f && +-- t' has tyvars -> f :.: (arg t') +-- > _ -> Rec0 t +-- +-- where @argVar@ is the last type variable in the data type declaration we are +-- finding the representation for. +-- +-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to +-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and +-- @:.:@. +-- +-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for +-- some data types. The problematic case is when @t@ is an application of a +-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the +-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in +-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some +-- representable1 checks have been relaxed, and others were moved to +-- @canDoGenerics1@. +argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a +argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, + ata_par1 = mkPar1, ata_rec1 = mkRec1, + ata_comp = mkComp}) = + -- mkRec0 is the default; use it if there is no interesting structure + -- (e.g. occurrences of parameters or recursive occurrences) + \t -> maybe (mkRec0 t) id $ go t where + go :: Type -> -- type to fold through + Maybe a -- the result (e.g. representation type), unless it's trivial + go t = isParam `mplus` isApp where + + isParam = do -- handles parameters + t' <- getTyVar_maybe t + Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter + else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0 + + isApp = do -- handles applications + (phi, beta) <- tcSplitAppTy_maybe t + + let interesting = argVar `elemVarSet` exactTyVarsOfType beta + + -- Does it have no interesting structure to represent? + if not interesting then Nothing + else -- Is the argument the parameter? Special case for mkRec1. + if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi + else mkComp phi `fmap` go beta -- It must be a composition. + + +tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 + GenericKind_ + -- The type to generate representation for + -> TyCon -- Metadata datatypes to refer to -> MetaTyCons -- Generated representation0 type -> TcM Type -tc_mkRepTy tycon metaDts = +tc_mkRepTy gk_ tycon metaDts = do d1 <- tcLookupTyCon d1TyConName c1 <- tcLookupTyCon c1TyConName s1 <- tcLookupTyCon s1TyConName nS1 <- tcLookupTyCon noSelTyConName rec0 <- tcLookupTyCon rec0TyConName - par0 <- tcLookupTyCon par0TyConName + rec1 <- tcLookupTyCon rec1TyConName + par1 <- tcLookupTyCon par1TyConName u1 <- tcLookupTyCon u1TyConName v1 <- tcLookupTyCon v1TyConName plus <- tcLookupTyCon sumTyConName times <- tcLookupTyCon prodTyConName + comp <- tcLookupTyCon compTyConName let mkSum' a b = mkTyConApp plus [a,b] mkProd a b = mkTyConApp times [a,b] + mkComp a b = mkTyConApp comp [a,b] mkRec0 a = mkTyConApp rec0 [a] - mkPar0 a = mkTyConApp par0 [a] + mkRec1 a = mkTyConApp rec1 [a] + mkPar1 = mkTyConTy par1 mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)] - mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a) + mkC i d a = mkTyConApp c1 [d, prod i (dataConInstOrigArgTys a $ mkTyVarTys $ tyConTyVars tycon) (null (dataConFieldLabels a))] -- This field has no label mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a] -- This field has a label mkS False d a = mkTyConApp s1 [d, a] + -- Sums and products are done in the same way for both Rep and Rep1 sumP [] = mkTyConTy v1 sumP l = ASSERT (length metaCTyCons == length l) foldBal mkSum' [ mkC i d a @@ -330,12 +575,21 @@ tc_mkRepTy tycon metaDts = | (d,t) <- zip (metaSTyCons !! i) l ] arg :: Type -> Type -> Bool -> Type - arg d t b = mkS b d (recOrPar t (getTyVar_maybe t)) - -- Argument is not a type variable, use Rec0 - recOrPar t Nothing = mkRec0 t - -- Argument is a type variable, use Par0 - recOrPar t (Just _) = mkPar0 t + arg d t b = mkS b d $ case gk_ of + -- Here we previously used Par0 if t was a type variable, but we + -- realized that we can't always guarantee that we are wrapping-up + -- all type variables in Par0. So we decided to stop using Par0 + -- altogether, and use Rec0 all the time. + Gen0_ -> mkRec0 t + Gen1_ argVar -> argPar argVar t + where + -- Builds argument represention for Rep1 (more complicated due to + -- the presence of composition). + argPar argVar = argTyFold argVar $ ArgTyAlg + {ata_rec0 = mkRec0, ata_par1 = mkPar1, + ata_rec1 = mkRec1, ata_comp = mkComp} + metaDTyCon = mkTyConTy (metaD metaDts) metaCTyCons = map mkTyConTy (metaC metaDts) metaSTyCons = map (map mkTyConTy) (metaS metaDts) @@ -397,66 +651,91 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) datacons = tyConDataCons tycon datasels = map dataConFieldLabels datacons - dtName_matches = mkStringLHS . showPpr . nameOccName . tyConName - $ tycon + tyConName_user = case tyConFamInst_maybe tycon of + Just (ptycon, _) -> tyConName ptycon + Nothing -> tyConName tycon + + dtName_matches = mkStringLHS . occNameString . nameOccName + $ tyConName_user moduleName_matches = mkStringLHS . moduleNameString . moduleName . nameModule . tyConName $ tycon - conName_matches c = mkStringLHS . showPpr . nameOccName + conName_matches c = mkStringLHS . occNameString . nameOccName . dataConName $ c conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] - selName_matches s = mkStringLHS (showPpr (nameOccName s)) + selName_matches s = mkStringLHS (occNameString (nameOccName s)) -------------------------------------------------------------------------------- -- Dealing with sums -------------------------------------------------------------------------------- -mkSum :: US -- Base for generating unique names +mkSum :: GenericKind_ -- Generic or Generic1? + -> US -- Base for generating unique names -> TyCon -- The type constructor -> [DataCon] -- The data constructors -> ([Alt], -- Alternatives for the T->Trep "from" function [Alt]) -- Alternatives for the Trep->T "to" function -- Datatype without any constructors -mkSum _us tycon [] = ([from_alt], [to_alt]) +mkSum _ _ tycon [] = ([from_alt], [to_alt]) where from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom)) to_alt = (mkM1_P nlWildPat, makeError errMsgTo) -- These M1s are meta-information for the datatype makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s)) - errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon - errMsgTo = "No values for empty datatype " ++ showPpr tycon + tyConStr = occNameString (nameOccName (tyConName tycon)) + errMsgFrom = "No generic representation for empty datatype " ++ tyConStr + errMsgTo = "No values for empty datatype " ++ tyConStr -- Datatype with at least one constructor -mkSum us _tycon datacons = - unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ] +mkSum gk_ us _ datacons = + -- switch the payload of gk_ to be datacon-centric instead of tycon-centric + unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d + | (d,i) <- zip datacons [1..] ] -- Build the sum for a particular constructor -mk1Sum :: US -- Base for generating unique names +mk1Sum :: GenericKind_DC -- Generic or Generic1? + -> US -- Base for generating unique names -> Int -- The index of this constructor -> Int -- Total number of constructors -> DataCon -- The data constructor -> (Alt, -- Alternative for the T->Trep "from" function Alt) -- Alternative for the Trep->T "to" function -mk1Sum us i n datacon = (from_alt, to_alt) +mk1Sum gk_ us i n datacon = (from_alt, to_alt) where - n_args = dataConSourceArity datacon -- Existentials already excluded + gk = forgetArgVar gk_ + + -- Existentials already excluded + argTys = dataConOrigArgTys datacon + n_args = dataConSourceArity datacon - datacon_vars = map mkGenericLocal [us .. us+n_args-1] + datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys + datacon_vars = map fst datacon_varTys us' = us + n_args datacon_rdr = getRdrName datacon - app_exp = nlHsVarApps datacon_rdr datacon_vars from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) - from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars)) + from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys)) - to_alt = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs) + to_alt = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs) -- These M1s are meta-information for the datatype - to_alt_rhs = app_exp + to_alt_rhs = case gk_ of + Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars + Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys + where + argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where + converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = const $ nlHsVar unK1_RDR, + ata_par1 = nlHsVar unPar1_RDR, + ata_rec1 = const $ nlHsVar unRec1_RDR, + ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv) + `nlHsCompose` nlHsVar unComp1_RDR} + + -- Generates the L1/R1 sum pattern genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName @@ -481,34 +760,47 @@ genLR_E i n e -------------------------------------------------------------------------------- -- Build a product expression -mkProd_E :: US -- Base for unique names - -> [RdrName] -- List of variables matched on the lhs +mkProd_E :: GenericKind_DC -- Generic or Generic1? + -> US -- Base for unique names + -> [(RdrName, Type)] -- List of variables matched on the lhs and their types -> LHsExpr RdrName -- Resulting product expression -mkProd_E _ [] = mkM1_E (nlHsVar u1DataCon_RDR) -mkProd_E _ vars = mkM1_E (foldBal prod appVars) - -- These M1s are meta-information for the constructor +mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR) +mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars) + -- These M1s are meta-information for the constructor where - appVars = map wrapArg_E vars + appVars = map (wrapArg_E gk_) varTys prod a b = prodDataCon_RDR `nlHsApps` [a,b] -wrapArg_E :: RdrName -> LHsExpr RdrName -wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v]) - -- This M1 is meta-information for the selector +wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName +wrapArg_E Gen0_DC (var, _) = mkM1_E (k1DataCon_RDR `nlHsVarApps` [var]) + -- This M1 is meta-information for the selector +wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar var + -- This M1 is meta-information for the selector + where converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = const $ nlHsVar k1DataCon_RDR, + ata_par1 = nlHsVar par1DataCon_RDR, + ata_rec1 = const $ nlHsVar rec1DataCon_RDR, + ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` + (nlHsVar fmap_RDR `nlHsApp` cnv)} + + -- Build a product pattern -mkProd_P :: US -- Base for unique names +mkProd_P :: GenericKind -- Gen0 or Gen1 + -> US -- Base for unique names -> [RdrName] -- List of variables to match -> LPat RdrName -- Resulting product pattern -mkProd_P _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) -mkProd_P _ vars = mkM1_P (foldBal prod appVars) - -- These M1s are meta-information for the constructor +mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) +mkProd_P gk _ vars = mkM1_P (foldBal prod appVars) + -- These M1s are meta-information for the constructor where - appVars = map wrapArg_P vars + appVars = map (wrapArg_P gk) vars prod a b = prodDataCon_RDR `nlConPat` [a,b] - -wrapArg_P :: RdrName -> LPat RdrName -wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v]) - -- This M1 is meta-information for the selector + +wrapArg_P :: GenericKind -> RdrName -> LPat RdrName +wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v]) + -- This M1 is meta-information for the selector +wrapArg_P Gen1 v = m1DataCon_RDR `nlConVarPat` [v] mkGenericLocal :: US -> RdrName mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) @@ -519,6 +811,9 @@ mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e mkM1_P :: LPat RdrName -> LPat RdrName mkM1_P p = m1DataCon_RDR `nlConPat` [p] +nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +nlHsCompose x y = compose_RDR `nlHsApps` [x, y] + -- | Variant of foldr1 for producing balanced lists foldBal :: (a -> a -> a) -> [a] -> a foldBal op = foldBal' op (error "foldBal: empty list") diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 73361aefaa..aa444715b0 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -26,27 +26,25 @@ module TcHsSyn ( -- re-exported from TcMonad TcId, TcIdSet, - zonkTopDecls, zonkTopExpr, zonkTopLExpr, mkZonkTcTyVar, - zonkId, zonkTopBndrs + zonkTopDecls, zonkTopExpr, zonkTopLExpr, + zonkTopBndrs, zonkTyBndrsX, + emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv, + zonkTcTypeToType, zonkTcTypeToTypes ) where #include "HsVersions.h" --- friends: -import HsSyn -- oodles of it - --- others: +import HsSyn import Id - import TcRnMonad import PrelNames +import TypeRep -- We can see the representation of types import TcType -import TcMType +import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar ) import TcEvidence import TysPrim import TysWiredIn import Type -import Kind import DataCon import Name import NameSet @@ -61,6 +59,7 @@ import SrcLoc import Bag import FastString import Outputable +import Util -- import Data.Traversable( traverse ) \end{code} @@ -165,14 +164,6 @@ hsOverLitName (HsIsString {}) = fromStringName %* * %************************************************************************ -\begin{code} --- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> TcM TcId -zonkId id - = zonkTcType (idType id) `thenM` \ ty' -> - returnM (Id.setIdType id ty') -\end{code} - The rest of the zonking is done *after* typechecking. The main zonking pass runs over the bindings @@ -199,7 +190,7 @@ data ZonkEnv = ZonkEnv UnboundTyVarZonker (TyVarEnv TyVar) -- - (IdEnv Var) -- What variables are in scope + (IdEnv Var) -- What variables are in scope -- Maps an Id or EvVar to its zonked version; both have the same Name -- Note that all evidence (coercion variables as well as dictionaries) -- are kept in the ZonkEnv @@ -211,7 +202,10 @@ instance Outputable ZonkEnv where emptyZonkEnv :: ZonkEnv -emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv emptyVarEnv +emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping + +mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv +mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids @@ -225,6 +219,9 @@ extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env +mkTyVarZonkEnv :: [TyVar] -> ZonkEnv +mkTyVarZonkEnv tvs = ZonkEnv zonkTypeZapping (mkVarEnv [(tv,tv) | tv <- tvs]) emptyVarEnv + setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env @@ -293,14 +290,12 @@ zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar]) zonkTyBndrsX = mapAccumLM zonkTyBndrX zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar) +-- This guarantees to return a TyVar (not a TcTyVar) +-- then we add it to the envt, so all occurrences are replaced zonkTyBndrX env tv - = do { tv' <- zonkTyBndr env tv - ; return (extendTyZonkEnv1 env tv', tv') } - -zonkTyBndr :: ZonkEnv -> TyVar -> TcM TyVar -zonkTyBndr env tv = do { ki <- zonkTcTypeToType env (tyVarKind tv) - ; return (setVarType tv ki) } + ; let tv' = mkTyVar (tyVarName tv) ki + ; return (extendTyZonkEnv1 env tv', tv') } \end{code} @@ -364,7 +359,7 @@ zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs)) zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds -> let - env1 = extendIdZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds] + env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds] in zonkTcEvBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) -> returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds)) @@ -544,8 +539,8 @@ zonkLExpr env expr = wrapLocM (zonkExpr env) expr zonkExpr env (HsVar id) = returnM (HsVar (zonkIdOcc env id)) -zonkExpr env (HsIPVar id) - = returnM (HsIPVar (mapIPName (zonkIdOcc env) id)) +zonkExpr _ (HsIPVar id) + = returnM (HsIPVar id) zonkExpr env (HsLit (HsRat f ty)) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -776,19 +771,18 @@ zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s ; return (env2, s' : ss') } zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id) -zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op) - = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs -> - let - new_binders = concat (map snd new_stmts_w_bndrs) - env1 = extendIdZonkEnv env new_binders - in - zonkExpr env1 mzip_op `thenM` \ new_mzip -> - zonkExpr env1 bind_op `thenM` \ new_bind -> - zonkExpr env1 return_op `thenM` \ new_return -> - return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return) +zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op) + = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs + ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs] + env1 = extendIdZonkEnv env new_binders + ; new_mzip <- zonkExpr env1 mzip_op + ; new_bind <- zonkExpr env1 bind_op + ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) } where - zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) -> - returnM (new_stmts, zonkIdOccs env1 bndrs) + zonk_branch (ParStmtBlock stmts bndrs return_op) + = do { (env1, new_stmts) <- zonkStmts env stmts + ; new_return <- zonkExpr env1 return_op + ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) } zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id @@ -868,8 +862,9 @@ zonkRecFields env (HsRecFields flds dd) ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) } ------------------------------------------------------------------------- -mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b) -mapIPNameTc f (IPName n) = f n `thenM` \ r -> returnM (IPName r) +mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b) +mapIPNameTc _ (Left x) = returnM (Left x) +mapIPNameTc f (Right x) = f x `thenM` \ r -> returnM (Right r) \end{code} @@ -1044,7 +1039,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) ; let final_bndrs :: [RuleBndr Var] final_bndrs = map (RuleBndr . noLoc) - (varSetElemsKvsFirst unbound_tkvs) + (varSetElemsKvsFirst unbound_tkvs) ++ new_bndrs ; return $ @@ -1102,20 +1097,24 @@ zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) return (EvId (zonkIdOcc env v)) zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcLCoToLCo env co ; return (EvCoercion co') } -zonkEvTerm env (EvCast v co) = ASSERT( isId v) - do { co' <- zonkTcLCoToLCo env co - ; return (mkEvCast (zonkIdOcc env v) co') } - -zonkEvTerm env (EvKindCast v co) = ASSERT( isId v) - do { co' <- zonkTcLCoToLCo env co - ; return (mkEvKindCast (zonkIdOcc env v) co') } - -zonkEvTerm env (EvTupleSel v n) = return (EvTupleSel (zonkIdOcc env v) n) -zonkEvTerm env (EvTupleMk vs) = return (EvTupleMk (map (zonkIdOcc env) vs)) -zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) +zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm + ; co' <- zonkTcLCoToLCo env co + ; return (mkEvCast tm' co') } + +zonkEvTerm env (EvKindCast v co) = do { v' <- zonkEvTerm env v + ; co' <- zonkTcLCoToLCo env co + ; return (mkEvKindCast v' co') } + +zonkEvTerm env (EvTupleSel tm n) = do { tm' <- zonkEvTerm env tm + ; return (EvTupleSel tm' n) } +zonkEvTerm env (EvTupleMk tms) = do { tms' <- mapM (zonkEvTerm env) tms + ; return (EvTupleMk tms') } +zonkEvTerm _ (EvLit l) = return (EvLit l) +zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d + ; return (EvSuperClass d' n) } zonkEvTerm env (EvDFunApp df tys tms) = do { tys' <- zonkTcTypeToTypes env tys - ; let tms' = map (zonkEvVarOcc env) tms + ; tms' <- mapM (zonkEvTerm env) tms ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } zonkEvTerm env (EvDelayedError ty msg) = do { ty' <- zonkTcTypeToType env ty @@ -1153,16 +1152,17 @@ zonkEvBind env (EvBind var term) | Just ty <- isTcReflCo_maybe co -> do { zty <- zonkTcTypeToType env ty - ; let var' = setVarType var (mkEqPred (zty,zty)) + ; let var' = setVarType var (mkEqPred zty zty) ; return (EvBind var' (EvCoercion (mkTcReflCo zty))) } -- Fast path for variable-variable bindings -- NB: could be optimized further! (e.g. SymCo cv) | Just cv <- getTcCoVar_maybe co - -> do { let cv' = zonkIdOcc env cv -- Just lazily look up + -> do { let cv' = zonkIdOcc env cv -- Just lazily look up term' = EvCoercion (TcCoVarCo cv') var' = setVarType var (varType cv') ; return (EvBind var' term') } + -- Ugly safe and slow path _ -> do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var ; term' <- zonkEvTerm env term @@ -1250,36 +1250,58 @@ DV, TODO: followup on this note mentioning new examples I will add to perf/ \begin{code} -mkZonkTcTyVar :: (TcTyVar -> TcM Type) -- What to do for an *mutable Flexi* var - -> (TcTyVar -> Type) -- What to do for an immutable var - -> TcTyVar -> TcM TcType -mkZonkTcTyVar unbound_mvar_fn unbound_ivar_fn - = zonk_tv - where - zonk_tv tv - = ASSERT( isTcTyVar tv ) - case tcTyVarDetails tv of - SkolemTv {} -> return (unbound_ivar_fn tv) - RuntimeUnk {} -> return (unbound_ivar_fn tv) - FlatSkol ty -> zonkType zonk_tv ty +zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType +zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv + | isTcTyVar tv + = case tcTyVarDetails tv of + SkolemTv {} -> lookup_in_env + RuntimeUnk {} -> lookup_in_env + FlatSkol ty -> zonkTcTypeToType env ty MetaTv _ ref -> do { cts <- readMutVar ref ; case cts of Flexi -> do { kind <- {-# SCC "zonkKind1" #-} - zonkType zonk_tv (tyVarKind tv) - ; unbound_mvar_fn (setTyVarKind tv kind) } - Indirect ty -> do { zty <- zonkType zonk_tv ty + zonkTcTypeToType env (tyVarKind tv) + ; zonk_unbound_tyvar (setTyVarKind tv kind) } + Indirect ty -> do { zty <- zonkTcTypeToType env ty -- Small optimisation: shortern-out indirect steps -- so that the old type may be more easily collected. ; writeMutVar ref (Indirect zty) ; return zty } } + | otherwise + = lookup_in_env + where + lookup_in_env -- Look up in the env just as we do for Ids + = case lookupVarEnv tv_env tv of + Nothing -> return (mkTyVarTy tv) + Just tv' -> return (mkTyVarTy tv') zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type -zonkTcTypeToType (ZonkEnv zonk_unbound_tyvar tv_env _id_env) - = zonkType (mkZonkTcTyVar zonk_unbound_tyvar zonk_bound_tyvar) +zonkTcTypeToType env ty + = go ty where - zonk_bound_tyvar tv = case lookupVarEnv tv_env tv of - Nothing -> mkTyVarTy tv - Just tv' -> mkTyVarTy tv' + go (TyConApp tc tys) = do tys' <- mapM go tys + return (TyConApp tc tys') + + go (LitTy n) = return (LitTy n) + + go (FunTy arg res) = do arg' <- go arg + res' <- go res + return (FunTy arg' res') + + go (AppTy fun arg) = do fun' <- go fun + arg' <- go arg + return (mkAppTy fun' arg') + -- NB the mkAppTy; we might have instantiated a + -- type variable to a type constructor, so we need + -- to pull the TyConApp to the top. + + -- The two interesting cases! + go (TyVarTy tv) = zonkTyVarOcc env tv + + go (ForAllTy tv ty) = ASSERT( isImmutableTyVar tv ) do + do { (env', tv') <- zonkTyBndrX env tv + ; ty' <- zonkTcTypeToType env' ty + ; return (ForAllTy tv' ty') } zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type] zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys @@ -1289,7 +1311,7 @@ zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker -- Works on both types and kinds zonkTvCollecting unbound_tv_set tv = do { poly_kinds <- xoptM Opt_PolyKinds - ; if isKiVar tv && not poly_kinds then defaultKindVarToStar tv + ; if isKindVar tv && not poly_kinds then defaultKindVarToStar tv else do { tv' <- zonkQuantifiedTyVar tv ; tv_set <- readMutVar unbound_tv_set @@ -1301,10 +1323,10 @@ zonkTypeZapping :: UnboundTyVarZonker -- It zaps unbound type variables to (), or some other arbitrary type -- Works on both types and kinds zonkTypeZapping tv - = do { let ty = if isKiVar tv + = do { let ty = if isKindVar tv -- ty is actually a kind, zonk to AnyK then anyKind - else anyTypeOfKind (tyVarKind tv) + else anyTypeOfKind (defaultKind (tyVarKind tv)) ; writeMetaTyVar tv ty ; return ty } @@ -1327,6 +1349,8 @@ zonkTcLCoToLCo env co go (TcAxiomInstCo ax tys) = do { tys' <- zonkTcTypeToTypes env tys; return (TcAxiomInstCo ax tys') } go (TcAppCo co1 co2) = do { co1' <- go co1; co2' <- go co2 ; return (mkTcAppCo co1' co2') } + go (TcCastCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (TcCastCo co1' co2') } go (TcSymCo co) = do { co' <- go co; return (mkTcSymCo co') } go (TcNthCo n co) = do { co' <- go co; return (mkTcNthCo n co') } go (TcTransCo co1 co2) = do { co1' <- go co1; co2' <- go co2 diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 66b74388b3..7808c6b44c 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -14,24 +14,26 @@ module TcHsType ( tcHsSigType, tcHsSigTypeNC, tcHsDeriv, tcHsVectInst, - tcHsInstHead, tcHsQuantifiedType, + tcHsInstHead, UserTypeCtxt(..), - -- Kind checking - kcHsTyVars, kcHsSigType, kcHsLiftedSigType, - kcLHsType, kcCheckLHsType, kcHsContext, kcApps, - kindGeneralizeKind, kindGeneralizeKinds, + -- Type checking type and class decls + kcTyClTyVars, tcTyClTyVars, + tcHsConArgType, tcDataKindSig, + tcClassSigType, - -- Sort checking - scDsLHsKind, scDsLHsMaybeKind, - - -- Typechecking kinded types - tcHsType, tcCheckHsType, - tcHsKindedContext, tcHsKindedType, tcHsBangType, - tcTyVarBndrs, tcTyVarBndrsKindGen, dsHsType, - tcDataKindSig, tcTyClTyVars, + -- Kind-checking types + -- No kind generalisation, no checkValidType + kcHsTyVarBndrs, tcHsTyVarBndrs, + tcHsLiftedType, tcHsOpenType, + tcLHsType, tcCheckLHsType, + tcHsContext, tcInferApps, tcHsArgTys, ExpKind(..), ekConstraint, expArgKind, checkExpectedKind, + bindScopedKindVars, kindGeneralize, + + -- Sort-checking kinds + tcLHsKind, -- Pattern type signatures tcHsPatSigType, tcPatSig @@ -40,40 +42,41 @@ module TcHsType ( #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ -import {-# SOURCE #-} TcSplice( kcSpliceType ) +import {-# SOURCE #-} TcSplice( tcSpliceType ) #endif import HsSyn -import RnHsSyn +import TcHsSyn ( zonkTcTypeToType, emptyZonkEnv ) import TcRnMonad import RnEnv ( dataKindsErr ) -import TcHsSyn ( mkZonkTcTyVar ) import TcEvidence( HsWrapper ) import TcEnv import TcMType import TcUnify import TcIface import TcType -import {- Kind parts of -} Type +import Type import Kind +import TypeRep( mkNakedTyConApp ) import Var import VarSet import TyCon import DataCon import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) import Class -import RdrName ( rdrNameSpace, nameRdrName ) import Name -import NameSet +import NameEnv import TysWiredIn import BasicTypes import SrcLoc import DynFlags ( ExtensionFlag( Opt_DataKinds ) ) -import Util import UniqSupply import Outputable import FastString -import Control.Monad ( unless ) +import Util + +import Control.Monad ( unless, when, zipWithM ) +import PrelNames(ipClassName) \end{code} @@ -155,105 +158,68 @@ the TyCon being defined. %************************************************************************ %* * -\subsection{Checking types} + Check types AND do validity checking %* * %************************************************************************ \begin{code} tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type - -- Do kind checking, and hoist for-alls to the top -- NB: it's important that the foralls that come from the top-level -- HsForAllTy in hs_ty occur *first* in the returned type. -- See Note [Scoped] with TcSigInfo -tcHsSigType ctxt hs_ty +tcHsSigType ctxt hs_ty = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $ tcHsSigTypeNC ctxt hs_ty -tcHsSigTypeNC ctxt hs_ty - = do { kinded_ty <- case expectedKindInCtxt ctxt of - Nothing -> fmap fst (kc_lhs_type_fresh hs_ty) - Just k -> kc_lhs_type hs_ty (EK k (ptext (sLit "Expected"))) +tcHsSigTypeNC ctxt (L loc hs_ty) + = setSrcSpan loc $ -- The "In the type..." context + -- comes from the caller; hence "NC" + do { kind <- case expectedKindInCtxt ctxt of + Nothing -> newMetaKindVar + Just k -> return k -- The kind is checked by checkValidType, and isn't necessarily -- of kind * in a Template Haskell quote eg [t| Maybe |] - ; ty <- tcHsKindedType kinded_ty - ; checkValidType ctxt ty - ; return ty } --- Like tcHsType, but takes an expected kind -tcCheckHsType :: LHsType Name -> Kind -> TcM Type -tcCheckHsType hs_ty exp_kind - = do { kinded_ty <- kcCheckLHsType hs_ty (EK exp_kind (ptext (sLit "Expected"))) - ; ty <- tcHsKindedType kinded_ty - ; return ty } + -- Generalise here: see Note [ generalisation] + ; ty <- tcCheckHsTypeAndGen hs_ty kind -tcHsType :: LHsType Name -> TcM Type --- kind check and desugar --- no validity checking because of knot-tying -tcHsType hs_ty - = do { (kinded_ty, _) <- kc_lhs_type_fresh hs_ty - ; ty <- tcHsKindedType kinded_ty - ; return ty } + -- Zonk to expose kind information to checkValidType + ; ty <- zonkTcType ty + ; checkValidType ctxt ty + ; return ty } +----------------- tcHsInstHead :: UserTypeCtxt -> LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type]) --- Typecheck an instance head. We can't use --- tcHsSigType, because it's not a valid user type. +-- Like tcHsSigTypeNC, but for an instance head. tcHsInstHead ctxt lhs_ty@(L loc hs_ty) - = setSrcSpan loc $ -- No need for an "In the type..." context - -- because that comes from the caller - do { kinded_ty <- kc_hs_type hs_ty ekConstraint - ; ty <- ds_type kinded_ty - ; let (tvs, theta, tau) = tcSplitSigmaTy ty - ; case getClassPredTys_maybe tau of - Nothing -> failWithTc (ptext (sLit "Malformed instance type")) - Just (clas,tys) -> do { checkValidInstance ctxt lhs_ty tvs theta clas tys - ; return (tvs, theta, clas, tys) } } - -tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type) --- Behave very like type-checking (HsForAllTy sig_tvs hs_ty), --- except that we want to keep the tvs separate -tcHsQuantifiedType tv_names hs_ty - = kcHsTyVars tv_names $ \ tv_names' -> - do { kc_ty <- kcHsSigType hs_ty - ; tcTyVarBndrs tv_names' $ \ tvs -> - do { ty <- dsHsType kc_ty - ; return (tvs, ty) } } - --- Used for the deriving(...) items -tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type]) -tcHsDeriv = tc_hs_deriv [] - -tc_hs_deriv :: [LHsTyVarBndr Name] -> HsType Name - -> TcM ([TyVar], Class, [Type]) -tc_hs_deriv tv_names1 (HsForAllTy _ tv_names2 (L _ []) (L _ ty)) - = -- Funny newtype deriving form - -- forall a. C [a] - -- where C has arity 2. Hence can't use regular functions - tc_hs_deriv (tv_names1 ++ tv_names2) ty - -tc_hs_deriv tv_names ty - | Just (cls_name, hs_tys) <- splitHsClassTy_maybe ty - = kcHsTyVars tv_names $ \ tv_names' -> - do { cls_kind <- kcClass cls_name - ; (tys, _res_kind) <- kcApps cls_name cls_kind hs_tys - ; tcTyVarBndrsKindGen tv_names' $ \ tyvars -> - do { arg_tys <- dsHsTypes tys - ; cls <- tcLookupClass cls_name - ; return (tyvars, cls, arg_tys) }} + = setSrcSpan loc $ -- The "In the type..." context comes from the caller + do { ty <- tcCheckHsTypeAndGen hs_ty constraintKind + ; ty <- zonkTcType ty + ; checkValidInstance ctxt lhs_ty ty } - | otherwise - = failWithTc (ptext (sLit "Illegal deriving item") <+> ppr ty) +----------------- +tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type]) +-- Like tcHsSigTypeNC, but for the ...deriving( ty ) clause +tcHsDeriv hs_ty + = do { kind <- newMetaKindVar + ; ty <- tcCheckHsTypeAndGen hs_ty kind + -- Funny newtype deriving form + -- forall a. C [a] + -- where C has arity 2. Hence any-kinded result + ; ty <- zonkTcType ty + ; let (tvs, pred) = splitForAllTys ty + ; case getClassPredTys_maybe pred of + Just (cls, tys) -> return (tvs, cls, tys) + Nothing -> failWithTc (ptext (sLit "Illegal deriving item") <+> quotes (ppr hs_ty)) } -- Used for 'VECTORISE [SCALAR] instance' declarations -- tcHsVectInst :: LHsType Name -> TcM (Class, [Type]) tcHsVectInst ty | Just (L _ cls_name, tys) <- splitLHsClassTy_maybe ty - = do { cls_kind <- kcClass cls_name - ; (tys, _res_kind) <- kcApps cls_name cls_kind tys - ; arg_tys <- dsHsTypes tys - ; cls <- tcLookupClass cls_name - ; return (cls, arg_tys) - } + = do { (cls, cls_kind) <- tcClass cls_name + ; (arg_tys, _res_kind) <- tcInferApps cls_name cls_kind tys + ; return (cls, arg_tys) } | otherwise = failWithTc $ ptext (sLit "Malformed instance type") \end{code} @@ -262,365 +228,488 @@ tcHsVectInst ty type and class declarations, when we have to separate kind-checking, desugaring, and validity checking -\begin{code} -kcHsSigType, kcHsLiftedSigType :: LHsType Name -> TcM (LHsType Name) - -- Used for type signatures -kcHsSigType ty = addKcTypeCtxt ty $ kcArgType ty -kcHsLiftedSigType ty = addKcTypeCtxt ty $ kcLiftedType ty - -tcHsKindedType :: LHsType Name -> TcM Type - -- Don't do kind checking, nor validity checking. - -- This is used in type and class decls, where kinding is - -- done in advance, and validity checking is done later - -- [Validity checking done later because of knot-tying issues.] -tcHsKindedType hs_ty = dsHsType hs_ty - -tcHsBangType :: LHsType Name -> TcM Type --- Permit a bang, but discard it --- Input type has already been kind-checked -tcHsBangType (L _ (HsBangTy _ ty)) = tcHsKindedType ty -tcHsBangType ty = tcHsKindedType ty - -tcHsKindedContext :: LHsContext Name -> TcM ThetaType --- Used when we are expecting a ClassContext (i.e. no implicit params) --- Does not do validity checking, like tcHsKindedType -tcHsKindedContext hs_theta = addLocM (mapM dsHsType) hs_theta -\end{code} - %************************************************************************ %* * - The main kind checker: kcHsType + The main kind checker: no validity checks here %* * %************************************************************************ First a couple of simple wrappers for kcHsType \begin{code} +tcClassSigType :: LHsType Name -> TcM Type +tcClassSigType lhs_ty@(L _ hs_ty) + = addTypeCtxt lhs_ty $ + do { ty <- tcCheckHsTypeAndGen hs_ty liftedTypeKind + ; zonkTcTypeToType emptyZonkEnv ty } + +tcHsConArgType :: NewOrData -> LHsType Name -> TcM Type +-- Permit a bang, but discard it +tcHsConArgType NewType bty = tcHsLiftedType (getBangType bty) + -- Newtypes can't have bangs, but we don't check that + -- until checkValidDataCon, so do not want to crash here + +tcHsConArgType DataType bty = tcHsOpenType (getBangType bty) + -- Can't allow an unlifted type for newtypes, because we're effectively + -- going to remove the constructor while coercing it to a lifted type. + -- And newtypes can't be bang'd + --------------------------- -kcLiftedType :: LHsType Name -> TcM (LHsType Name) --- The type ty must be a *lifted* *type* -kcLiftedType ty = kc_lhs_type ty ekLifted - -kcArgs :: SDoc -> [LHsType Name] -> Kind -> TcM [LHsType Name] -kcArgs what tys kind - = sequence [ kc_lhs_type ty (expArgKind what kind n) - | (ty,n) <- tys `zip` [1..] ] +tcHsArgTys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType] +tcHsArgTys what tys kinds + = sequence [ addTypeCtxt ty $ + tc_lhs_type ty (expArgKind what kind n) + | (ty,kind,n) <- zip3 tys kinds [1..] ] + +tc_hs_arg_tys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType] +-- Just like tcHsArgTys but without the addTypeCtxt +tc_hs_arg_tys what tys kinds + = sequence [ tc_lhs_type ty (expArgKind what kind n) + | (ty,kind,n) <- zip3 tys kinds [1..] ] --------------------------- -kcArgType :: LHsType Name -> TcM (LHsType Name) --- The type ty must be an *arg* *type* (lifted or unlifted) -kcArgType ty = kc_lhs_type ty ekArg +tcHsOpenType, tcHsLiftedType :: LHsType Name -> TcM TcType +-- Used for type signatures +-- Do not do validity checking +tcHsOpenType ty = addTypeCtxt ty $ tc_lhs_type ty ekOpen +tcHsLiftedType ty = addTypeCtxt ty $ tc_lhs_type ty ekLifted + +-- Like tcHsType, but takes an expected kind +tcCheckLHsType :: LHsType Name -> Kind -> TcM Type +tcCheckLHsType hs_ty exp_kind + = addTypeCtxt hs_ty $ + tc_lhs_type hs_ty (EK exp_kind (ptext (sLit "Expected"))) + +tcLHsType :: LHsType Name -> TcM (TcType, TcKind) +-- Called from outside: set the context +tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type ty) --------------------------- -kcCheckLHsType :: LHsType Name -> ExpKind -> TcM (LHsType Name) -kcCheckLHsType ty kind = addKcTypeCtxt ty $ kc_lhs_type ty kind +tcCheckHsTypeAndGen :: HsType Name -> Kind -> TcM Type +-- Input type is HsType, not LhsType; the caller adds the context +-- Typecheck a type signature, and kind-generalise it +-- The result is not necessarily zonked, and has not been checked for validity +tcCheckHsTypeAndGen hs_ty kind + = do { ty <- tc_hs_type hs_ty (EK kind (ptext (sLit "Expected"))) + ; kvs <- kindGeneralize (tyVarsOfType ty) + ; return (mkForAllTys kvs ty) } \end{code} -Like tcExpr, kc_hs_type takes an expected kind which it unifies with +Like tcExpr, tc_hs_type takes an expected kind which it unifies with the kind it figures out. When we don't know what kind to expect, we use -kc_lhs_type_fresh, to first create a new meta kind variable and use that as +tc_lhs_type_fresh, to first create a new meta kind variable and use that as the expected kind. \begin{code} -kcLHsType :: LHsType Name -> TcM (LHsType Name, TcKind) --- Called from outside: set the context -kcLHsType ty = addKcTypeCtxt ty (kc_lhs_type_fresh ty) - -kc_lhs_type_fresh :: LHsType Name -> TcM (LHsType Name, TcKind) -kc_lhs_type_fresh ty = do - kv <- newMetaKindVar - r <- kc_lhs_type ty (EK kv (ptext (sLit "Expected"))) - return (r, kv) - -kc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [LHsType Name] -kc_lhs_types tys_w_kinds = mapM (uncurry kc_lhs_type) tys_w_kinds - -kc_lhs_type :: LHsType Name -> ExpKind -> TcM (LHsType Name) -kc_lhs_type (L span ty) exp_kind +tc_infer_lhs_type :: LHsType Name -> TcM (TcType, TcKind) +tc_infer_lhs_type ty = + do { kv <- newMetaKindVar + ; r <- tc_lhs_type ty (EK kv (ptext (sLit "Expected"))) + ; return (r, kv) } + +tc_lhs_type :: LHsType Name -> ExpKind -> TcM TcType +tc_lhs_type (L span ty) exp_kind = setSrcSpan span $ - do { traceTc "kc_lhs_type" (ppr ty <+> ppr exp_kind) - ; ty' <- kc_hs_type ty exp_kind - ; return (L span ty') } - -kc_hs_type :: HsType Name -> ExpKind -> TcM (HsType Name) -kc_hs_type (HsParTy ty) exp_kind = do - ty' <- kc_lhs_type ty exp_kind - return (HsParTy ty') - -kc_hs_type (HsTyVar name) exp_kind = do - (ty, k) <- kcTyVar name - checkExpectedKind ty k exp_kind - return ty - -kc_hs_type (HsListTy ty) exp_kind = do - ty' <- kcLiftedType ty - checkExpectedKind ty liftedTypeKind exp_kind - return (HsListTy ty') - -kc_hs_type (HsPArrTy ty) exp_kind = do - ty' <- kcLiftedType ty - checkExpectedKind ty liftedTypeKind exp_kind - return (HsPArrTy ty') - -kc_hs_type (HsKindSig ty sig_k) exp_kind = do - sig_k' <- scDsLHsKind sig_k - ty' <- kc_lhs_type ty - (EK sig_k' (ptext (sLit "An enclosing kind signature specified"))) - checkExpectedKind ty sig_k' exp_kind - return (HsKindSig ty' sig_k) + do { traceTc "tc_lhs_type:" (ppr ty $$ ppr exp_kind) + ; tc_hs_type ty exp_kind } + +tc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [TcType] +tc_lhs_types tys_w_kinds = mapM (uncurry tc_lhs_type) tys_w_kinds + +------------------------------------------ +tc_hs_type :: HsType Name -> ExpKind -> TcM TcType +tc_hs_type (HsParTy ty) exp_kind = tc_lhs_type ty exp_kind +tc_hs_type (HsDocTy ty _) exp_kind = tc_lhs_type ty exp_kind +tc_hs_type (HsQuasiQuoteTy {}) _ = panic "tc_hs_type: qq" -- Eliminated by renamer +tc_hs_type (HsBangTy {}) _ = panic "tc_hs_type: bang" -- Unwrapped by con decls +tc_hs_type (HsRecTy _) _ = panic "tc_hs_type: record" -- Unwrapped by con decls + -- Record types (which only show up temporarily in constructor + -- signatures) should have been removed by now + +---------- Functions and applications +tc_hs_type hs_ty@(HsTyVar name) exp_kind + = do { (ty, k) <- tcTyVar name + ; checkExpectedKind hs_ty k exp_kind + ; return ty } + +tc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt) + = do { ty1' <- tc_lhs_type ty1 (EK openTypeKind ctxt) + ; ty2' <- tc_lhs_type ty2 (EK openTypeKind ctxt) + ; checkExpectedKind ty liftedTypeKind exp_kind + ; return (mkFunTy ty1' ty2') } + +tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind + = do { (op', op_kind) <- tcTyVar op + ; tys' <- tcCheckApps hs_ty l_op op_kind [ty1,ty2] exp_kind + ; return (mkNakedAppTys op' tys') } + -- mkNakedAppTys: see Note [Zonking inside the knot] + +tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind + = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] + ; (fun_ty', fun_kind) <- tc_infer_lhs_type fun_ty + ; arg_tys' <- tcCheckApps hs_ty fun_ty fun_kind arg_tys exp_kind + ; return (mkNakedAppTys fun_ty' arg_tys') } + -- mkNakedAppTys: see Note [Zonking inside the knot] + +--------- Foralls +tc_hs_type (HsForAllTy _ hs_tvs context ty) exp_kind + = tcHsTyVarBndrs hs_tvs $ \ tvs' -> + -- Do not kind-generalise here! See Note [Kind generalisation] + do { ctxt' <- tcHsContext context + ; ty' <- tc_lhs_type ty exp_kind + -- Why exp_kind? See Note [Body kind of forall] + ; return (mkSigmaTy tvs' ctxt' ty') } + +--------- Lists, arrays, and tuples +tc_hs_type hs_ty@(HsListTy elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type elt_ty ekLifted + ; checkExpectedKind hs_ty liftedTypeKind exp_kind + ; checkWiredInTyCon listTyCon + ; return (mkListTy tau_ty) } + +tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type elt_ty ekLifted + ; checkExpectedKind hs_ty liftedTypeKind exp_kind + ; checkWiredInTyCon parrTyCon + ; return (mkPArrTy tau_ty) } -- See Note [Distinguishing tuple kinds] in HsTypes -kc_hs_type ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt) - | isConstraintOrLiftedKind exp_k -- (NB: not zonking, to avoid left-right bias) - = do { tys' <- kcArgs (ptext (sLit "a tuple")) tys exp_k - ; return $ if isConstraintKind exp_k - then HsTupleTy HsConstraintTuple tys' - else HsTupleTy HsBoxedTuple tys' } +-- See Note [Inferring tuple kinds] +tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt) + -- (NB: not zonking before looking at exp_k, to avoid left-right bias) + | isConstraintKind exp_k = tc_tuple hs_ty HsConstraintTuple tys exp_kind + | isLiftedTypeKind exp_k = tc_tuple hs_ty HsBoxedTuple tys exp_kind | otherwise - -- It is not clear from the context if it's * or Constraint, - -- so we infer the kind from the arguments = do { k <- newMetaKindVar - ; tys' <- kcArgs (ptext (sLit "a tuple")) tys k + ; tau_tys <- tc_hs_arg_tys (ptext (sLit "a tuple")) tys (repeat k) ; k' <- zonkTcKind k - ; if isConstraintKind k' - then do { checkExpectedKind ty k' exp_kind - ; return (HsTupleTy HsConstraintTuple tys') } - -- If it's not clear from the arguments that it's Constraint, then - -- it must be *. Check the arguments again to give good error messages + ; if isConstraintKind k' then + finish_tuple hs_ty HsConstraintTuple tau_tys exp_kind + else if isLiftedTypeKind k' then + finish_tuple hs_ty HsBoxedTuple tau_tys exp_kind + else + tc_tuple hs_ty HsBoxedTuple tys exp_kind } + -- It's not clear what the kind is, so assume *, and + -- check the arguments again to give good error messages -- in eg. `(Maybe, Maybe)` - else do { tys'' <- kcArgs (ptext (sLit "a tuple")) tys liftedTypeKind - ; checkExpectedKind ty liftedTypeKind exp_kind - ; return (HsTupleTy HsBoxedTuple tys'') } } -{- -Note that we will still fail to infer the correct kind in this case: - type T a = ((a,a), D a) - type family D :: Constraint -> Constraint +tc_hs_type hs_ty@(HsTupleTy tup_sort tys) exp_kind + = tc_tuple hs_ty tup_sort tys exp_kind + +--------- Promoted lists and tuples +tc_hs_type hs_ty@(HsExplicitListTy _k tys) exp_kind + = do { tks <- mapM tc_infer_lhs_type tys + ; let taus = map fst tks + ; kind <- unifyKinds (ptext (sLit "In a promoted list")) tks + ; checkExpectedKind hs_ty (mkPromotedListTy kind) exp_kind + ; return (foldr (mk_cons kind) (mk_nil kind) taus) } + where + mk_cons k a b = mkTyConApp (buildPromotedDataCon consDataCon) [k, a, b] + mk_nil k = mkTyConApp (buildPromotedDataCon nilDataCon) [k] + +tc_hs_type hs_ty@(HsExplicitTupleTy _ tys) exp_kind + = do { tks <- mapM tc_infer_lhs_type tys + ; let n = length tys + kind_con = promotedTupleTyCon BoxedTuple n + ty_con = promotedTupleDataCon BoxedTuple n + (taus, ks) = unzip tks + tup_k = mkTyConApp kind_con ks + ; checkExpectedKind hs_ty tup_k exp_kind + ; return (mkTyConApp ty_con (ks ++ taus)) } + +--------- Constraint types +tc_hs_type ipTy@(HsIParamTy n ty) exp_kind + = do { ty' <- tc_lhs_type ty + (EK liftedTypeKind (ptext (sLit "The type argument of the implicit parameter had"))) + ; checkExpectedKind ipTy constraintKind exp_kind + ; ipClass <- tcLookupClass ipClassName + ; let n' = mkStrLitTy $ hsIPNameFS n + ; return (mkClassPred ipClass [n',ty']) + } + +tc_hs_type ty@(HsEqTy ty1 ty2) exp_kind + = do { (ty1', kind1) <- tc_infer_lhs_type ty1 + ; (ty2', kind2) <- tc_infer_lhs_type ty2 + ; checkExpectedKind ty2 kind2 + (EK kind1 (ptext (sLit "The left argument of the equality predicate had"))) + ; checkExpectedKind ty constraintKind exp_kind + ; return (mkNakedTyConApp eqTyCon [kind1, ty1', ty2']) } + +--------- Misc +tc_hs_type (HsKindSig ty sig_k) exp_kind + = do { sig_k' <- tcLHsKind sig_k + ; checkExpectedKind ty sig_k' exp_kind + ; tc_lhs_type ty + (EK sig_k' (ptext (sLit "An enclosing kind signature specified"))) } + +tc_hs_type (HsCoreTy ty) exp_kind + = do { checkExpectedKind ty (typeKind ty) exp_kind + ; return ty } -While kind checking T, we do not yet know the kind of D, so we will default the -kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. --} -kc_hs_type ty@(HsTupleTy tup_sort tys) exp_kind - = do { tys' <- kcArgs cxt_doc tys arg_kind - ; checkExpectedKind ty out_kind exp_kind - ; return (HsTupleTy tup_sort tys') } +#ifdef GHCI /* Only if bootstrapped */ +-- This looks highly suspect to me +-- It will really only be fixed properly when we do the TH +-- reorganisation so that type splices happen in the renamer +tc_hs_type hs_ty@(HsSpliceTy sp fvs _) exp_kind + = do { s <- getStage + ; traceTc "tc_hs_type: splice" (ppr sp $$ ppr s) + ; (ty, kind) <- tcSpliceType sp fvs + ; checkExpectedKind hs_ty kind exp_kind +-- -- See Note [Kind of a type splice] + ; return ty } +#else +tc_hs_type ty@(HsSpliceTy {}) _exp_kind + = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) +#endif + +tc_hs_type (HsWrapTy {}) _exp_kind + = panic "tc_hs_type HsWrapTy" -- We kind checked something twice + +tc_hs_type hs_ty@(HsTyLit tl) exp_kind = do + let (ty,k) = case tl of + HsNumTy n -> (mkNumLitTy n, typeNatKind) + HsStrTy s -> (mkStrLitTy s, typeStringKind) + checkExpectedKind hs_ty k exp_kind + return ty + +--------------------------- +tc_tuple :: HsType Name -> HsTupleSort -> [LHsType Name] -> ExpKind -> TcM TcType +-- Invariant: tup_sort is not HsBoxedOrConstraintTuple +tc_tuple hs_ty tup_sort tys exp_kind + = do { tau_tys <- tc_hs_arg_tys cxt_doc tys (repeat arg_kind) + ; finish_tuple hs_ty tup_sort tau_tys exp_kind } where arg_kind = case tup_sort of HsBoxedTuple -> liftedTypeKind - HsUnboxedTuple -> argTypeKind + HsUnboxedTuple -> openTypeKind HsConstraintTuple -> constraintKind - _ -> panic "kc_hs_type arg_kind" - out_kind = case tup_sort of - HsUnboxedTuple -> ubxTupleKind - _ -> arg_kind + _ -> panic "tc_hs_type arg_kind" cxt_doc = case tup_sort of HsBoxedTuple -> ptext (sLit "a tuple") HsUnboxedTuple -> ptext (sLit "an unboxed tuple") HsConstraintTuple -> ptext (sLit "a constraint tuple") - _ -> panic "kc_hs_type tup_sort" - -kc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt) = do - ty1' <- kc_lhs_type ty1 (EK argTypeKind ctxt) - ty2' <- kc_lhs_type ty2 (EK openTypeKind ctxt) - checkExpectedKind ty liftedTypeKind exp_kind - return (HsFunTy ty1' ty2') - -kc_hs_type ty@(HsOpTy ty1 (_, l_op@(L loc op)) ty2) exp_kind = do - (wop, op_kind) <- kcTyVar op - [ty1',ty2'] <- kcCheckApps l_op op_kind [ty1,ty2] ty exp_kind - let op' = case wop of - HsTyVar name -> (WpKiApps [], L loc name) - HsWrapTy wrap (HsTyVar name) -> (wrap, L loc name) - _ -> panic "kc_hs_type HsOpTy" - return (HsOpTy ty1' op' ty2') - -kc_hs_type ty@(HsAppTy ty1 ty2) exp_kind = do - let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] - (fun_ty', fun_kind) <- kc_lhs_type_fresh fun_ty - arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind - return (mkHsAppTys fun_ty' arg_tys') - -kc_hs_type ipTy@(HsIParamTy n ty) exp_kind = do - ty' <- kc_lhs_type ty - (EK liftedTypeKind - (ptext (sLit "The type argument of the implicit parameter had"))) - checkExpectedKind ipTy constraintKind exp_kind - return (HsIParamTy n ty') - -kc_hs_type ty@(HsEqTy ty1 ty2) exp_kind = do - (ty1', kind1) <- kc_lhs_type_fresh ty1 - (ty2', kind2) <- kc_lhs_type_fresh ty2 - checkExpectedKind ty2 kind2 - (EK kind1 (ptext (sLit "The left argument of the equality predicate had"))) - checkExpectedKind ty constraintKind exp_kind - return (HsEqTy ty1' ty2') - -kc_hs_type (HsCoreTy ty) exp_kind = do - checkExpectedKind ty (typeKind ty) exp_kind - return (HsCoreTy ty) - -kc_hs_type (HsForAllTy exp tv_names context ty) exp_kind - = kcHsTyVars tv_names $ \ tv_names' -> - do { ctxt' <- kcHsContext context - ; ty' <- kc_lhs_type ty exp_kind - -- The body of a forall is usually a type, but in principle - -- there's no reason to prohibit *unlifted* types. - -- In fact, GHC can itself construct a function with an - -- unboxed tuple inside a for-all (via CPR analyis; see - -- typecheck/should_compile/tc170). - -- - -- Moreover in instance heads we get forall-types with - -- kind Constraint. - -- - -- Really we should check that it's a type of value kind - -- {*, Constraint, #}, but I'm not doing that yet - -- Example that should be rejected: - -- f :: (forall (a:*->*). a) Int - ; return (HsForAllTy exp tv_names' ctxt' ty') } - -kc_hs_type (HsBangTy b ty) exp_kind - = do { ty' <- kc_lhs_type ty exp_kind - ; return (HsBangTy b ty') } - -kc_hs_type ty@(HsRecTy _) _exp_kind - = failWithTc (ptext (sLit "Unexpected record type") <+> ppr ty) - -- Record types (which only show up temporarily in constructor signatures) - -- should have been removed by now - -#ifdef GHCI /* Only if bootstrapped */ -kc_hs_type (HsSpliceTy sp fvs _) exp_kind = do - (ty, k) <- kcSpliceType sp fvs - checkExpectedKind ty k exp_kind - return ty -#else -kc_hs_type ty@(HsSpliceTy {}) _exp_kind = - failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) -#endif + _ -> panic "tc_hs_type tup_sort" -kc_hs_type (HsQuasiQuoteTy {}) _exp_kind = - panic "kc_hs_type" -- Eliminated by renamer - --- Remove the doc nodes here, no need to worry about the location since --- it's the same for a doc node and its child type node -kc_hs_type (HsDocTy ty _) exp_kind - = kc_hs_type (unLoc ty) exp_kind - -kc_hs_type ty@(HsExplicitListTy _k tys) exp_kind - = do { ty_k_s <- mapM kc_lhs_type_fresh tys - ; kind <- unifyKinds (ptext (sLit "In a promoted list")) ty_k_s - ; checkExpectedKind ty (mkPromotedListTy kind) exp_kind - ; return (HsExplicitListTy kind (map fst ty_k_s)) } - -kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do - ty_k_s <- mapM kc_lhs_type_fresh tys - let tycon = promotedTupleTyCon BoxedTuple (length tys) - tupleKi = mkTyConApp tycon (map snd ty_k_s) - checkExpectedKind ty tupleKi exp_kind - return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s)) - -kc_hs_type (HsWrapTy {}) _exp_kind = - panic "kc_hs_type HsWrapTy" -- We kind checked something twice +finish_tuple :: HsType Name -> HsTupleSort -> [TcType] -> ExpKind -> TcM TcType +finish_tuple hs_ty tup_sort tau_tys exp_kind + = do { checkExpectedKind hs_ty res_kind exp_kind + ; checkWiredInTyCon tycon + ; return (mkTyConApp tycon tau_tys) } + where + tycon = tupleTyCon con (length tau_tys) + con = case tup_sort of + HsUnboxedTuple -> UnboxedTuple + HsBoxedTuple -> BoxedTuple + HsConstraintTuple -> ConstraintTuple + _ -> panic "tc_hs_type HsTupleTy" + + res_kind = case tup_sort of + HsUnboxedTuple -> unliftedTypeKind + HsBoxedTuple -> liftedTypeKind + HsConstraintTuple -> constraintKind + _ -> panic "tc_hs_type arg_kind" --------------------------- -kcApps :: Outputable a +tcInferApps :: Outputable a => a -> TcKind -- Function kind -> [LHsType Name] -- Arg types - -> TcM ([LHsType Name], TcKind) -- Kind-checked args -kcApps the_fun fun_kind args - = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) 1 fun_kind args - ; args' <- kc_lhs_types args_w_kinds + -> TcM ([TcType], TcKind) -- Kind-checked args +tcInferApps the_fun fun_kind args + = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) fun_kind args + ; args' <- tc_lhs_types args_w_kinds ; return (args', res_kind) } -kcCheckApps :: Outputable a => a -> TcKind -> [LHsType Name] - -> HsType Name -- The type being checked (for err messages only) - -> ExpKind -- Expected kind - -> TcM ([LHsType Name]) -kcCheckApps the_fun fun_kind args ty exp_kind - = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) 1 fun_kind args - ; args_w_kinds' <- kc_lhs_types args_w_kinds - ; checkExpectedKind ty res_kind exp_kind - ; return args_w_kinds' } - +tcCheckApps :: Outputable a + => HsType Name -- The type being checked (for err messages only) + -> a -- The function + -> TcKind -> [LHsType Name] -- Fun kind and arg types + -> ExpKind -- Expected kind + -> TcM [TcType] +tcCheckApps hs_ty the_fun fun_kind args exp_kind + = do { (arg_tys, res_kind) <- tcInferApps the_fun fun_kind args + ; checkExpectedKind hs_ty res_kind exp_kind + ; return arg_tys } --------------------------- -splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) -splitFunKind _ _ fk [] = return ([], fk) -splitFunKind the_fun arg_no fk (arg:args) - = do { mb_fk <- matchExpectedFunKind fk - ; case mb_fk of - Nothing -> failWithTc too_many_args - Just (ak,fk') -> do { (aks, rk) <- splitFunKind the_fun (arg_no+1) fk' args - ; return ((arg - ,expArgKind (quotes the_fun) ak arg_no) - :aks ,rk) } } +splitFunKind :: SDoc -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) +splitFunKind the_fun fun_kind args + = go 1 fun_kind args where + go _ fk [] = return ([], fk) + go arg_no fk (arg:args) + = do { mb_fk <- matchExpectedFunKind fk + ; case mb_fk of + Nothing -> failWithTc too_many_args + Just (ak,fk') -> do { (aks, rk) <- go (arg_no+1) fk' args + ; let exp_kind = expArgKind (quotes the_fun) ak arg_no + ; return ((arg, exp_kind) : aks, rk) } } + too_many_args = quotes the_fun <+> ptext (sLit "is applied to too many type arguments") + --------------------------- -kcHsContext :: LHsContext Name -> TcM (LHsContext Name) -kcHsContext ctxt = wrapLocM (mapM kcHsLPredType) ctxt +tcHsContext :: LHsContext Name -> TcM [PredType] +tcHsContext ctxt = mapM tcHsLPredType (unLoc ctxt) -kcHsLPredType :: LHsType Name -> TcM (LHsType Name) -kcHsLPredType pred = kc_lhs_type pred ekConstraint +tcHsLPredType :: LHsType Name -> TcM PredType +tcHsLPredType pred = tc_lhs_type pred ekConstraint --------------------------- -kcTyVar :: Name -> TcM (HsType Name, TcKind) +tcTyVar :: Name -> TcM (TcType, TcKind) -- See Note [Type checking recursive type and class declarations] -- in TcTyClsDecls -kcTyVar name -- Could be a tyvar, a tycon, or a datacon +tcTyVar name -- Could be a tyvar, a tycon, or a datacon = do { traceTc "lk1" (ppr name) ; thing <- tcLookup name ; traceTc "lk2" (ppr name <+> ppr thing) ; case thing of - ATyVar _ ty -> wrap_mono (typeKind ty) - AThing kind -> wrap_poly kind - AGlobal (ATyCon tc) -> wrap_poly (tyConKind tc) - AGlobal (ADataCon dc) -> kcDataCon dc >>= wrap_poly - _ -> wrongThingErr "type" thing name } + ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) + + AThing kind -> do { tc <- get_loopy_tc name + ; inst_tycon (mkNakedTyConApp tc) kind } + -- mkNakedTyConApp: see Note [Zonking inside the knot] + + AGlobal (ATyCon tc) -> inst_tycon (mkTyConApp tc) (tyConKind tc) + + AGlobal (ADataCon dc) + | isPromotableType ty -> inst_tycon (mkTyConApp tc) (tyConKind tc) + | otherwise -> failWithTc (quotes (ppr dc) <+> ptext (sLit "of type") + <+> quotes (ppr ty) <+> ptext (sLit "is not promotable")) + where + ty = dataConUserType dc + tc = buildPromotedDataCon dc + + AFamDataCon -> bad_promote (ptext (sLit "it comes from a data family instance")) + ARecDataCon -> bad_promote (ptext (sLit "it is defined and used in the same recursive group")) + + _ -> wrongThingErr "type" thing name } where - wrap_mono kind = do { traceTc "lk3" (ppr name <+> dcolon <+> ppr kind) - ; return (HsTyVar name, kind) } - wrap_poly kind - | null kvs = wrap_mono kind + bad_promote reason + = failWithTc (hang (ptext (sLit "You can't use data constructor") <+> quotes (ppr name) + <+> ptext (sLit "here")) + 2 (parens reason)) + + get_loopy_tc name + = do { env <- getGblEnv + ; case lookupNameEnv (tcg_type_env env) name of + Just (ATyCon tc) -> return tc + _ -> return (aThingErr "tcTyVar" name) } + + inst_tycon :: ([Type] -> Type) -> Kind -> TcM (Type, Kind) + -- Instantiate the polymorphic kind + -- Lazy in the TyCon + inst_tycon mk_tc_app kind + | null kvs + = return (mk_tc_app [], ki_body) | otherwise = do { traceTc "lk4" (ppr name <+> dcolon <+> ppr kind) - ; kvs' <- mapM (const newMetaKindVar) kvs - ; let ki = substKiWith kvs kvs' ki_body - ; return (HsWrapTy (WpKiApps kvs') (HsTyVar name), ki) } - where (kvs, ki_body) = splitForAllTys kind - --- IA0_TODO: this function should disapear, and use the dcPromoted field of DataCon -kcDataCon :: DataCon -> TcM TcKind -kcDataCon dc = do - let ty = dataConUserType dc - unless (isPromotableType ty) $ promoteErr dc ty - let ki = promoteType ty - traceTc "prm" (ppr ty <+> ptext (sLit "~~>") <+> ppr ki) - return ki - where - promoteErr dc ty = failWithTc (quotes (ppr dc) <+> ptext (sLit "of type") - <+> quotes (ppr ty) <+> ptext (sLit "is not promotable")) - -kcClass :: Name -> TcM TcKind -kcClass cls = do -- Must be a class - thing <- tcLookup cls - case thing of - AThing kind -> return kind - AGlobal (ATyCon tc) - | Just cls <- tyConClass_maybe tc -> return (tyConKind (classTyCon cls)) - _ -> wrongThingErr "class" thing cls + ; ks <- mapM (const newMetaKindVar) kvs + ; return (mk_tc_app ks, substKiWith kvs ks ki_body) } + where + (kvs, ki_body) = splitForAllTys kind + +tcClass :: Name -> TcM (Class, TcKind) +tcClass cls -- Must be a class + = do { thing <- tcLookup cls + ; case thing of + AThing kind -> return (aThingErr "tcClass" cls, kind) + AGlobal (ATyCon tc) + | Just cls <- tyConClass_maybe tc + -> return (cls, tyConKind tc) + _ -> wrongThingErr "class" thing cls } + + +aThingErr :: String -> Name -> b +-- The type checker for types is sometimes called simply to +-- do *kind* checking; and in that case it ignores the type +-- returned. Which is a good thing since it may not be available yet! +aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x) \end{code} +Note [Zonking inside the knot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are checking the argument types of a data constructor. We +must zonk the types before making the DataCon, because once built we +can't change it. So we must traverse the type. -%************************************************************************ -%* * - Desugaring -%* * -%************************************************************************ +BUT the parent TyCon is knot-tied, so we can't look at it yet. + +So we must be careful not to use "smart constructors" for types that +look at the TyCon or Class involved. Hence the use of mkNakedXXX +functions. + +This is sadly delicate. + +Note [Body kind of a forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The body of a forall is usually a type, but in principle +there's no reason to prohibit *unlifted* types. +In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all (via CPR analyis; see +typecheck/should_compile/tc170). + +Moreover in instance heads we get forall-types with +kind Constraint. + +Moreover if we have a signature + f :: Int# +then we represent it as (HsForAll Implicit [] [] Int#). And this must +be legal! We can't drop the empty forall until *after* typechecking +the body because of kind polymorphism: + Typeable :: forall k. k -> Constraint + data Apply f t = Apply (f t) + -- Apply :: forall k. (k -> *) -> k -> * + instance Typeable Apply where ... +Then the dfun has type + df :: forall k. Typeable ((k->*) -> k -> *) (Apply k) + + f :: Typeable Apply + + f :: forall (t:k->*) (a:k). t a -> t a + + class C a b where + op :: a b -> Typeable Apply + + data T a = MkT (Typeable Apply) + | T2 a + T :: * -> * + MkT :: forall k. (Typeable ((k->*) -> k -> *) (Apply k)) -> T a + + f :: (forall (k:BOX). forall (t:: k->*) (a:k). t a -> t a) -> Int + f :: (forall a. a -> Typeable Apply) -> Int + +So we *must* keep the HsForAll on the instance type + HsForAll Implicit [] [] (Typeable Apply) +so that we do kind generalisation on it. + +Really we should check that it's a type of value kind +{*, Constraint, #}, but I'm not doing that yet +Example that should be rejected: + f :: (forall (a:*->*). a) Int + +Note [Inferring tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, +we try to figure out whether it's a tuple of kind * or Constraint. + Step 1: look at the expected kind + Step 2: infer argument kinds + +If after Step 2 it's not clear from the arguments that it's +Constraint, then it must be *. Once having decided that we re-check +the Check the arguments again to give good error messages +in eg. `(Maybe, Maybe)` + +Note that we will still fail to infer the correct kind in this case: + + type T a = ((a,a), D a) + type family D :: Constraint -> Constraint + +While kind checking T, we do not yet know the kind of D, so we will default the +kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. Note [Desugaring types] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -654,116 +743,6 @@ Moreover (a) spurious ! annotations. (b) a class used as a type -\begin{code} - -zonkTcKindToKind :: TcKind -> TcM Kind --- When zonking a TcKind to a kind we instantiate kind variables to AnyK -zonkTcKindToKind = zonkType (mkZonkTcTyVar (\ _ -> return anyKind) mkTyVarTy) - -dsHsType :: LHsType Name -> TcM Type --- All HsTyVarBndrs in the intput type are kind-annotated --- See Note [Desugaring types] -dsHsType ty = ds_type (unLoc ty) - -ds_type :: HsType Name -> TcM Type --- See Note [Desugaring types] -ds_type ty@(HsTyVar _) - = ds_app ty [] - -ds_type (HsParTy ty) -- Remove the parentheses markers - = dsHsType ty - -ds_type ty@(HsBangTy {}) -- No bangs should be here - = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty) - -ds_type ty@(HsRecTy {}) -- No bangs should be here - = failWithTc (ptext (sLit "Unexpected record type:") <+> ppr ty) - -ds_type (HsKindSig ty _) - = dsHsType ty -- Kind checking done already - -ds_type (HsListTy ty) = do - tau_ty <- dsHsType ty - checkWiredInTyCon listTyCon - return (mkListTy tau_ty) - -ds_type (HsPArrTy ty) = do - tau_ty <- dsHsType ty - checkWiredInTyCon parrTyCon - return (mkPArrTy tau_ty) - -ds_type (HsTupleTy hs_con tys) = do - con <- case hs_con of - HsUnboxedTuple -> return UnboxedTuple - HsBoxedTuple -> return BoxedTuple - HsConstraintTuple -> return ConstraintTuple - _ -> panic "ds_type HsTupleTy" - -- failWithTc (ptext (sLit "Unexpected tuple component kind:") <+> ppr kind') - let tycon = tupleTyCon con (length tys) - tau_tys <- dsHsTypes tys - checkWiredInTyCon tycon - return (mkTyConApp tycon tau_tys) - -ds_type (HsFunTy ty1 ty2) = do - tau_ty1 <- dsHsType ty1 - tau_ty2 <- dsHsType ty2 - return (mkFunTy tau_ty1 tau_ty2) - -ds_type (HsOpTy ty1 (wrap, (L span op)) ty2) = - setSrcSpan span (ds_app (HsWrapTy wrap (HsTyVar op)) [ty1,ty2]) - -ds_type ty@(HsAppTy _ _) - = ds_app ty [] - -ds_type (HsIParamTy n ty) = do - tau_ty <- dsHsType ty - return (mkIPPred n tau_ty) - -ds_type (HsEqTy ty1 ty2) = do - tau_ty1 <- dsHsType ty1 - tau_ty2 <- dsHsType ty2 - return (mkEqPred (tau_ty1, tau_ty2)) - -ds_type (HsForAllTy _ tv_names ctxt ty) - = tcTyVarBndrsKindGen tv_names $ \ tyvars -> do - theta <- mapM dsHsType (unLoc ctxt) - tau <- dsHsType ty - return (mkSigmaTy tyvars theta tau) - -ds_type (HsDocTy ty _) -- Remove the doc comment - = dsHsType ty - -ds_type (HsSpliceTy _ _ kind) - = do { kind' <- zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind) mkTyVarTy) - kind - -- See Note [Kind of a type splice] - ; newFlexiTyVarTy kind' } - -ds_type (HsQuasiQuoteTy {}) = panic "ds_type" -- Eliminated by renamer -ds_type (HsCoreTy ty) = return ty - -ds_type (HsExplicitListTy kind tys) = do - kind' <- zonkTcKindToKind kind - ds_tys <- mapM dsHsType tys - return $ - foldr (\a b -> mkTyConApp (buildPromotedDataCon consDataCon) [kind', a, b]) - (mkTyConApp (buildPromotedDataCon nilDataCon) [kind']) ds_tys - -ds_type (HsExplicitTupleTy kis tys) = do - MASSERT( length kis == length tys ) - kis' <- mapM zonkTcKindToKind kis - tys' <- mapM dsHsType tys - return $ mkTyConApp (buildPromotedDataCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') - -ds_type (HsWrapTy (WpKiApps kappas) ty) = do - tau <- ds_type ty - kappas' <- mapM zonkTcKindToKind kappas - return (mkAppTys tau kappas') - -dsHsTypes :: [LHsType Name] -> TcM [Type] -dsHsTypes arg_tys = mapM dsHsType arg_tys -\end{code} - Note [Kind of a type splice] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider these terms, each with TH type splice inside: @@ -783,41 +762,13 @@ Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -ds_app :: HsType Name -> [LHsType Name] -> TcM Type -ds_app (HsAppTy ty1 ty2) tys - = ds_app (unLoc ty1) (ty2:tys) - -ds_app ty tys = do - arg_tys <- dsHsTypes tys - case ty of - HsTyVar fun -> ds_var_app fun arg_tys - _ -> do fun_ty <- ds_type ty - return (mkAppTys fun_ty arg_tys) - -ds_var_app :: Name -> [Type] -> TcM Type --- See Note [Type checking recursive type and class declarations] --- in TcTyClsDecls -ds_var_app name arg_tys - | isTvNameSpace (rdrNameSpace (nameRdrName name)) - = do { thing <- tcLookup name - ; case thing of - ATyVar _ ty -> return (mkAppTys ty arg_tys) - _ -> wrongThingErr "type" thing name } - - | otherwise - = do { thing <- tcLookupGlobal name - ; case thing of - ATyCon tc -> return (mkTyConApp tc arg_tys) - ADataCon dc -> return (mkTyConApp (buildPromotedDataCon dc) arg_tys) - _ -> wrongThingErr "type" (AGlobal thing) name } - -addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a +addTypeCtxt :: LHsType Name -> TcM a -> TcM a -- Wrap a context around only if we want to show that contexts. -- Omit invisble ones and ones user's won't grok -addKcTypeCtxt (L _ other_ty) thing = addErrCtxt (typeCtxt other_ty) thing - -typeCtxt :: HsType Name -> SDoc -typeCtxt ty = ptext (sLit "In the type") <+> quotes (ppr ty) +addTypeCtxt (L _ ty) thing + = addErrCtxt doc thing + where + doc = ptext (sLit "In the type") <+> quotes (ppr ty) \end{code} %************************************************************************ @@ -842,16 +793,48 @@ then we'd also need since we only have BOX for a super kind) \begin{code} -kcHsTyVars :: [LHsTyVarBndr Name] - -> ([LHsTyVarBndr Name] -> TcM r) -- These binders are kind-annotated - -- They scope over the thing inside - -> TcM r -kcHsTyVars tvs thing_inside - = do { kinded_tvs <- mapM (wrapLocM kcHsTyVar) tvs - ; tcExtendKindEnvTvs kinded_tvs thing_inside } - -kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) --- Return a *kind-annotated* binder, whose PostTcKind is +bindScopedKindVars :: [Name] -> ([KindVar] -> TcM a) -> TcM a +-- Given some tyvar binders like [a (b :: k -> *) (c :: k)] +-- bind each scoped kind variable (k in this case) to a fresh +-- kind skolem variable +bindScopedKindVars kv_ns thing_inside + = tcExtendTyVarEnv kvs (thing_inside kvs) + where + kvs = map mkKindSigVar kv_ns + +kcHsTyVarBndrs :: Bool -- Default UserTyVar to * + -> LHsTyVarBndrs Name + -> ([TcKind] -> TcM r) + -> TcM r +kcHsTyVarBndrs default_to_star (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside + = bindScopedKindVars kvs $ \ _ -> + do { nks <- mapM (kc_hs_tv . unLoc) hs_tvs + ; tcExtendKindEnv nks (thing_inside (map snd nks)) } + where + kc_hs_tv :: HsTyVarBndr Name -> TcM (Name, TcKind) + kc_hs_tv (UserTyVar n) + = do { mb_thing <- tcLookupLcl_maybe n + ; kind <- case mb_thing of + Just (AThing k) -> return k + _ | default_to_star -> return liftedTypeKind + | otherwise -> newMetaKindVar + ; return (n, kind) } + kc_hs_tv (KindedTyVar n k) + = do { kind <- tcLHsKind k + ; return (n, kind) } + +tcHsTyVarBndrs :: LHsTyVarBndrs Name + -> ([TyVar] -> TcM r) + -> TcM r +-- Bind the type variables to skolems, each with a meta-kind variable kind +tcHsTyVarBndrs (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside + = bindScopedKindVars kvs $ \ _ -> + do { tvs <- mapM tcHsTyVarBndr hs_tvs + ; traceTc "tcHsTyVarBndrs" (ppr hs_tvs $$ ppr tvs) + ; tcExtendTyVarEnv tvs (thing_inside tvs) } + +tcHsTyVarBndr :: LHsTyVarBndr Name -> TcM TyVar +-- Return a type variable -- initialised with a kind variable. -- Typically the Kind inside the KindedTyVar will be a tyvar with a mutable kind -- in it. We aren't yet sure whether the binder is a *type* variable or a *kind* @@ -862,49 +845,63 @@ kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) -- instance C (a,b) where -- type F (a,b) c = ... -- Here a,b will be in scope when processing the associated type instance for F. -kcHsTyVar tyvar = do in_scope <- getInLocalScope - if in_scope (hsTyVarName tyvar) - then do inscope_tyvar <- tcLookupTyVar (hsTyVarName tyvar) - return (UserTyVar (tyVarName inscope_tyvar) - (tyVarKind inscope_tyvar)) - else kcHsTyVar' tyvar - where - kcHsTyVar' (UserTyVar name _) = UserTyVar name <$> newMetaKindVar - kcHsTyVar' (KindedTyVar name kind _) = do - kind' <- scDsLHsKind kind - return (KindedTyVar name kind kind') +tcHsTyVarBndr (L _ hs_tv) + = do { let name = hsTyVarName hs_tv + ; mb_tv <- tcLookupLcl_maybe name + ; case mb_tv of { + Just (ATyVar _ tv) -> return tv ; + _ -> do + { kind <- case hs_tv of + UserTyVar {} -> newMetaKindVar + KindedTyVar _ kind -> tcLHsKind kind + ; return (mkTcTyVar name kind (SkolemTv False)) } } } ------------------ -tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking - -> ([TyVar] -> TcM r) - -> TcM r --- Used when type-checking types/classes/type-decls --- Brings into scope immutable TyVars, not mutable ones that require later zonking --- Fix #5426: avoid abstraction over kinds containing # or (#) -tcTyVarBndrs bndrs thing_inside = do - tyvars <- mapM (zonk . hsTyVarNameKind . unLoc) bndrs - tcExtendTyVarEnv tyvars (thing_inside tyvars) - where - zonk (name, kind) - = do { kind' <- zonkTcKind kind - ; checkTc (noHashInKind kind') (ptext (sLit "Kind signature contains # or (#)")) - ; return (mkTyVar name kind') } - -tcTyVarBndrsKindGen :: [LHsTyVarBndr Name] -> ([TyVar] -> TcM r) -> TcM r --- tcTyVarBndrsKindGen [(f :: ?k -> *), (a :: ?k)] thing_inside --- calls thing_inside with [(k :: BOX), (f :: k -> *), (a :: k)] -tcTyVarBndrsKindGen bndrs thing_inside - = do { let kinds = map (hsTyVarKind . unLoc) bndrs - ; (kvs, zonked_kinds) <- kindGeneralizeKinds kinds - ; let tyvars = zipWith mkTyVar (map hsLTyVarName bndrs) zonked_kinds - ktvs = kvs ++ tyvars -- See Note [Kinds of quantified type variables] - ; traceTc "tcTyVarBndrsKindGen" (ppr (bndrs, kvs, tyvars)) - ; tcExtendTyVarEnv ktvs (thing_inside ktvs) } +kindGeneralize :: TyVarSet -> TcM [KindVar] +kindGeneralize tkvs + = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked + ; tidy_env <- tcInitTidyEnv + ; tkvs <- zonkTyVarsAndFV tkvs + ; let kvs_to_quantify = filter isKindVar (varSetElems (tkvs `minusVarSet` gbl_tvs)) + -- Any type varaibles in tkvs will be in scope, + -- and hence in gbl_tvs, so after removing gbl_tvs + -- we should only have kind variables left + -- + -- BUT there is a smelly case (to be fixed when TH is reorganised) + -- f t = [| e :: $t |] + -- When typechecking the body of the bracket, we typecheck $t to a + -- unification variable 'alpha', with no biding forall. We don't + -- want to kind-quantify it! + + (_, tidy_kvs_to_quantify) = tidyTyVarBndrs tidy_env kvs_to_quantify + -- We do not get a later chance to tidy! + + ; ASSERT2 (all isKindVar kvs_to_quantify, ppr kvs_to_quantify $$ ppr tkvs) + -- This assertion is obviosy true because of the filter isKindVar + -- but we'll remove that when reorganising TH, and then the assertion + -- will mean something + zonkQuantifiedTyVars tidy_kvs_to_quantify } \end{code} +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do kind generalisation only at the outer level of a type signature. +For example, consider + T :: forall k. k -> * + f :: (forall a. T a -> Int) -> Int +When kind-checking f's type signature we generalise the kind at +the outermost level, thus: + f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! +and *not* at the inner forall: + f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! +Reason: same as for HM inference on value level declarations, +we want to infer the most general type. The f2 type signature +would be *less applicable* than f1, becuase it requires a more +polymorphic argument. + Note [Kinds of quantified type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyVarBndrsKindGen quantifies over a specified list of type variables, +tcTyVarBndrsGen quantifies over a specified list of type variables, *and* over the kind variables mentioned in the kinds of those tyvars. Note that we must zonk those kinds (obviously) but less obviously, we @@ -919,22 +916,75 @@ Reason: we're going to turn this into a for-all type, which the type checker will then instantiate, and instantiate does not look through unification variables! -Hence using zonked_kinds when forming 'tyvars'. +Hence using zonked_kinds when forming tvs'. \begin{code} -tcTyClTyVars :: Name -> [LHsTyVarBndr Name] -- LHS of the type or class decl +-------------------- +-- getInitialKind has made a suitably-shaped kind for the type or class +-- Unpack it, and attribute those kinds to the type variables +-- Extend the env with bindings for the tyvars, taken from +-- the kind of the tycon/class. Give it to the thing inside, and +-- check the result kind matches +kcLookupKind :: Name -> TcM Kind +kcLookupKind nm + = do { tc_ty_thing <- tcLookup nm + ; case tc_ty_thing of + AThing k -> return k + AGlobal (ATyCon tc) -> return (tyConKind tc) + _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) } + +kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> (TcKind -> TcM a) -> TcM a +-- Used for the type variables of a type or class decl, +-- when doing the initial kind-check. +kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside + = bindScopedKindVars kvs $ \ _ -> + do { tc_kind <- kcLookupKind name + ; let (arg_ks, res_k) = splitKindFunTysN (length hs_tvs) tc_kind + -- There should be enough arrows, because + -- getInitialKinds used the tcdTyVars + ; name_ks <- zipWithM kc_tv hs_tvs arg_ks + ; tcExtendKindEnv name_ks (thing_inside res_k) } + where + kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind) + kc_tv (L _ (UserTyVar n)) exp_k + = do { check_in_scope n exp_k + ; return (n, exp_k) } + kc_tv (L _ (KindedTyVar n hs_k)) exp_k + = do { k <- tcLHsKind hs_k + ; _ <- unifyKind k exp_k + ; check_in_scope n exp_k + ; return (n, k) } + + check_in_scope :: Name -> Kind -> TcM () + -- In an associated type decl, the type variable may already + -- be in scope; in that case we want to make sure it matches + -- any signature etc here + check_in_scope n exp_k + = do { mb_thing <- tcLookupLcl_maybe n + ; case mb_thing of + Nothing -> return () + Just (AThing k) -> discardResult (unifyKind k exp_k) + Just thing -> pprPanic "check_in_scope" (ppr thing) } + +----------------------- +tcTyClTyVars :: Name -> LHsTyVarBndrs Name -- LHS of the type or class decl -> ([TyVar] -> Kind -> TcM a) -> TcM a --- tcTyClTyVars T [a,b] calls thing_inside with --- [k1,k2,a,b] (k2 -> *) where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> * +-- Used for the type variables of a type or class decl, +-- on the second pass when constructing the final result +-- (tcTyClTyVars T [a,b] thing_inside) +-- where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> * +-- calls thing_inside with arguments +-- [k1,k2,a,b] (k2 -> *) +-- having also extended the type environment with bindings +-- for k1,k2,a,b -- -- No need to freshen the k's because they are just skolem -- constants here, and we are at top level anyway. tcTyClTyVars tycon tyvars thing_inside = do { thing <- tcLookup tycon - ; let { kind = - case thing of - AThing kind -> kind - _ -> panic "tcTyClTyVars" + ; let { kind = case thing of + AThing kind -> kind + _ -> panic "tcTyClTyVars" -- We only call tcTyClTyVars during typechecking in -- TcTyClDecls, where the local env is extended with -- the generalized_env (mapping Names to AThings). @@ -945,38 +995,6 @@ tcTyClTyVars tycon tyvars thing_inside ; all_vs = kvs ++ tvs } ; tcExtendTyVarEnv all_vs (thing_inside all_vs res) } --- Used when generalizing binders and type family patterns --- It takes a kind from the type checker (like `k0 -> *`), and returns the --- final, kind-generalized kind (`forall k::BOX. k -> *`) -kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind]) --- INVARIANT: the returned kinds are zonked, and --- mention the returned kind variables -kindGeneralizeKinds kinds - = do { -- Quantify over kind variables free in - -- the kinds, and *not* in the environment - ; zonked_kinds <- mapM zonkTcKind kinds - ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; let kvs_to_quantify = tyVarsOfTypes zonked_kinds - `minusVarSet` gbl_tvs - - ; kvs <- ASSERT2 (all isKiVar (varSetElems kvs_to_quantify), ppr kvs_to_quantify) - zonkQuantifiedTyVars kvs_to_quantify - - -- Zonk the kinds again, to pick up either the kind - -- variables we quantify over, or *, depending on whether - -- zonkQuantifiedTyVars decided to generalise (which in - -- turn depends on PolyKinds) - ; final_kinds <- mapM zonkTcKind zonked_kinds - - ; traceTc "generalizeKind" ( ppr kinds <+> ppr kvs_to_quantify - <+> ppr kvs <+> ppr final_kinds) - ; return (kvs, final_kinds) } - -kindGeneralizeKind :: TcKind -> TcM ( [KindVar] -- these were flexi kind vars - , Kind ) -- this is the old kind where flexis got zonked -kindGeneralizeKind kind = do - (kvs, [kind']) <- kindGeneralizeKinds [kind] - return (kvs, kind') ----------------------------------- tcDataKindSig :: Kind -> TcM [TyVar] @@ -1070,40 +1088,45 @@ Historical note: \begin{code} tcHsPatSigType :: UserTypeCtxt - -> LHsType Name -- The type signature - -> TcM ([TyVar], -- Newly in-scope type variables - Type) -- The signature + -> HsWithBndrs (LHsType Name) -- The type signature + -> TcM ( Type -- The signature + , [(Name, TcTyVar)] ) -- The new bit of type environment, binding + -- the scoped type variables -- Used for type-checking type signatures in -- (a) patterns e.g f (x::Int) = e -- (b) result signatures e.g. g x :: Int = e -- (c) RULE forall bndrs e.g. forall (x::Int). f x = x -tcHsPatSigType ctxt hs_ty +tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, hswb_tvs = sig_tvs }) = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $ - do { -- Find the type variables that are mentioned in the type - -- but not already in scope. These are the ones that - -- should be bound by the pattern signature - in_scope <- getInLocalScope - ; let span = getLoc hs_ty - sig_tvs = userHsTyVarBndrs $ map (L span) $ - filterOut in_scope $ - nameSetToList (extractHsTyVars hs_ty) - - ; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty + do { kvs <- mapM new_kv sig_kvs + ; tvs <- mapM new_tv sig_tvs + ; let ktv_binds = (sig_kvs `zip` kvs) ++ (sig_tvs `zip` tvs) + ; sig_ty <- tcExtendTyVarEnv2 ktv_binds $ + tcHsLiftedType hs_ty + ; sig_ty <- zonkTcType sig_ty ; checkValidType ctxt sig_ty - ; return (tyvars, sig_ty) - } + ; return (sig_ty, ktv_binds) } + where + new_kv name = new_tkv name superKind + new_tv name = do { kind <- newMetaKindVar + ; new_tkv name kind } + + new_tkv name kind -- See Note [Pattern signature binders] + = case ctxt of + RuleSigCtxt {} -> return (mkTcTyVar name kind (SkolemTv False)) + _ -> newSigTyVar name kind -- See Note [Unifying SigTvs] tcPatSig :: UserTypeCtxt - -> LHsType Name + -> HsWithBndrs (LHsType Name) -> TcSigmaType - -> TcM (TcType, -- The type to use for "inside" the signature - [(Name, TcType)], -- The new bit of type environment, binding - -- the scoped type variables - HsWrapper) -- Coercion due to unification with actual ty - -- Of shape: res_ty ~ sig_ty + -> TcM (TcType, -- The type to use for "inside" the signature + [(Name, TcTyVar)], -- The new bit of type environment, binding + -- the scoped type variables + HsWrapper) -- Coercion due to unification with actual ty + -- Of shape: res_ty ~ sig_ty tcPatSig ctxt sig res_ty - = do { (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig + = do { (sig_ty, sig_tvs) <- tcHsPatSigType ctxt sig -- sig_tvs are the type variables free in 'sig', -- and not already in scope. These are the ones -- that should be brought into scope @@ -1112,17 +1135,16 @@ tcPatSig ctxt sig res_ty -- Just do the subsumption check and return wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty ; return (sig_ty, [], wrap) - } else do { + } else do -- Type signature binds at least one scoped type variable -- A pattern binding cannot bind scoped type variables - -- The renamer fails with a name-out-of-scope error - -- if a pattern binding tries to bind a type variable, - -- So we just have an ASSERT here - ; let in_pat_bind = case ctxt of + -- It is more convenient to make the test here + -- than in the renamer + { let in_pat_bind = case ctxt of BindPatSigCtxt -> True _ -> False - ; ASSERT( not in_pat_bind || null sig_tvs ) return () + ; when in_pat_bind (addErr (patBindSigErr sig_tvs)) -- Check that all newly-in-scope tyvars are in fact -- constrained by the pattern. This catches tiresome @@ -1131,37 +1153,65 @@ tcPatSig ctxt sig res_ty -- f :: Int -> Int -- f (x :: T a) = ... -- Here 'a' doesn't get a binding. Sigh - ; let bad_tvs = filterOut (`elemVarSet` exactTyVarsOfType sig_ty) sig_tvs + ; let bad_tvs = [ tv | (_, tv) <- sig_tvs + , not (tv `elemVarSet` exactTyVarsOfType sig_ty) ] ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs) -- Now do a subsumption check of the pattern signature against res_ty - ; sig_tvs' <- tcInstSigTyVars sig_tvs - ; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty - sig_tv_tys' = mkTyVarTys sig_tvs' - ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty' - - -- Check that each is bound to a distinct type variable, - -- and one that is not already in scope - ; binds_in_scope <- getScopedTyVarBinds - ; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys' - ; check binds_in_scope tv_binds - + ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty + -- Phew! - ; return (sig_ty', tv_binds, wrap) + ; return (sig_ty, sig_tvs, wrap) } } - where - check _ [] = return () - check in_scope ((n,ty):rest) = do { check_one in_scope n ty - ; check ((n,ty):in_scope) rest } - - check_one in_scope n ty - = checkTc (null dups) (dupInScope n (head dups) ty) - -- Must not bind to the same type variable - -- as some other in-scope type variable - where - dups = [n' | (n',ty') <- in_scope, eqType ty' ty] + +patBindSigErr :: [(Name, TcTyVar)] -> SDoc +patBindSigErr sig_tvs + = hang (ptext (sLit "You cannot bind scoped type variable") <> plural sig_tvs + <+> pprQuotedList (map fst sig_tvs)) + 2 (ptext (sLit "in a pattern binding signature")) \end{code} +Note [Pattern signature binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = forall a. T a (a->Int) + f (T x (f :: a->Int) = blah) + +Here + * The pattern (T p1 p2) creates a *skolem* type variable 'a_sk', + It must be a skolem so that that it retains its identity, and + TcErrors.getSkolemInfo can therreby find the binding site for the skolem. + + * The type signature pattern (f :: a->Int) binds "a" -> a_sig in the envt + + * Then unificaiton makes a_sig := a_sk + +That's why we must make a_sig a SigTv, not a SkolemTv, so that it can unify to a_sk. + +For RULE binders, though, things are a bit different (yuk). + RULE "foo" forall (x::a) (y::[a]). f x y = ... +Here this really is the binding site of the type variable so we'd like +to use a skolem, so that we get a complaint if we unify two of them +together. + +Note [Unifying SigTvs] +~~~~~~~~~~~~~~~~~~~~~~ +ALAS we have no decent way of avoiding two SigTvs getting unified. +Consider + f (x::(a,b)) (y::c)) = [fst x, y] +Here we'd really like to complain that 'a' and 'c' are unified. But +for the reasons above we can't make a,b,c into skolems, so they +are just SigTvs that can unify. And indeed, this would be ok, + f x (y::c) = case x of + (x1 :: a1, True) -> [x,y] + (x1 :: a2, False) -> [x,y,y] +Here the type of x's first component is called 'a1' in one branch and +'a2' in the other. We could try insisting on the same OccName, but +they definitely won't have the sane lexical Name. + +I think we could solve this by recording in a SigTv a list of all the +in-scope varaibles that it should not unify with, but it's fiddly. + %************************************************************************ %* * @@ -1184,9 +1234,9 @@ data ExpKind = EK TcKind SDoc instance Outputable ExpKind where ppr (EK k _) = ptext (sLit "Expected kind:") <+> ppr k -ekLifted, ekArg, ekConstraint :: ExpKind +ekLifted, ekOpen, ekConstraint :: ExpKind ekLifted = EK liftedTypeKind (ptext (sLit "Expected")) -ekArg = EK argTypeKind (ptext (sLit "Expected")) +ekOpen = EK openTypeKind (ptext (sLit "Expected")) ekConstraint = EK constraintKind (ptext (sLit "Expected")) -- Build an ExpKind for arguments @@ -1195,13 +1245,13 @@ expArgKind exp kind arg_no = EK kind (ptext (sLit "The") <+> speakNth arg_no <+> ptext (sLit "argument of") <+> exp <+> ptext (sLit "should have")) -unifyKinds :: SDoc -> [(LHsType Name, TcKind)] -> TcM TcKind -unifyKinds fun act_kinds = do - kind <- newMetaKindVar - let checkArgs (arg_no, (ty, act_kind)) = - checkExpectedKind ty act_kind (expArgKind (quotes fun) kind arg_no) - mapM_ checkArgs (zip [1..] act_kinds) - return kind +unifyKinds :: SDoc -> [(TcType, TcKind)] -> TcM TcKind +unifyKinds fun act_kinds + = do { kind <- newMetaKindVar + ; let check (arg_no, (ty, act_kind)) + = checkExpectedKind ty act_kind (expArgKind (quotes fun) kind arg_no) + ; mapM_ check (zip [1..] act_kinds) + ; return kind } checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM () -- A fancy wrapper for 'unifyKind', which tries @@ -1271,65 +1321,58 @@ checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do %* * %************************************************************************ -scDsLHsKind converts a user-written kind to an internal, sort-checked kind. +tcLHsKind converts a user-written kind to an internal, sort-checked kind. It does sort checking and desugaring at the same time, in one single pass. It fails when the kinds are not well-formed (eg. data A :: * Int), or if there are non-promotable or non-fully applied kinds. \begin{code} -scDsLHsKind :: LHsKind Name -> TcM Kind -scDsLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ - sc_ds_lhs_kind k +tcLHsKind :: LHsKind Name -> TcM Kind +tcLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ + tc_lhs_kind k -scDsLHsMaybeKind :: Maybe (LHsKind Name) -> TcM (Maybe Kind) -scDsLHsMaybeKind Nothing = return Nothing -scDsLHsMaybeKind (Just k) = do k' <- scDsLHsKind k - return (Just k') - -sc_ds_lhs_kind :: LHsKind Name -> TcM Kind -sc_ds_lhs_kind (L span ki) = setSrcSpan span (sc_ds_hs_kind ki) +tc_lhs_kind :: LHsKind Name -> TcM Kind +tc_lhs_kind (L span ki) = setSrcSpan span (tc_hs_kind ki) -- The main worker -sc_ds_hs_kind :: HsKind Name -> TcM Kind -sc_ds_hs_kind k@(HsTyVar _) = sc_ds_app k [] -sc_ds_hs_kind k@(HsAppTy _ _) = sc_ds_app k [] +tc_hs_kind :: HsKind Name -> TcM Kind +tc_hs_kind k@(HsTyVar _) = tc_kind_app k [] +tc_hs_kind k@(HsAppTy _ _) = tc_kind_app k [] -sc_ds_hs_kind (HsParTy ki) = sc_ds_lhs_kind ki +tc_hs_kind (HsParTy ki) = tc_lhs_kind ki -sc_ds_hs_kind (HsFunTy ki1 ki2) = - do kappa_ki1 <- sc_ds_lhs_kind ki1 - kappa_ki2 <- sc_ds_lhs_kind ki2 +tc_hs_kind (HsFunTy ki1 ki2) = + do kappa_ki1 <- tc_lhs_kind ki1 + kappa_ki2 <- tc_lhs_kind ki2 return (mkArrowKind kappa_ki1 kappa_ki2) -sc_ds_hs_kind (HsListTy ki) = - do kappa <- sc_ds_lhs_kind ki +tc_hs_kind (HsListTy ki) = + do kappa <- tc_lhs_kind ki checkWiredInTyCon listTyCon return $ mkPromotedListTy kappa -sc_ds_hs_kind (HsTupleTy _ kis) = - do kappas <- mapM sc_ds_lhs_kind kis +tc_hs_kind (HsTupleTy _ kis) = + do kappas <- mapM tc_lhs_kind kis checkWiredInTyCon tycon return $ mkTyConApp tycon kappas where tycon = promotedTupleTyCon BoxedTuple (length kis) -- Argument not kind-shaped -sc_ds_hs_kind k = panic ("sc_ds_hs_kind: " ++ showPpr k) +tc_hs_kind k = pprPanic "tc_hs_kind" (ppr k) -- Special case for kind application -sc_ds_app :: HsKind Name -> [LHsKind Name] -> TcM Kind -sc_ds_app (HsAppTy ki1 ki2) kis = sc_ds_app (unLoc ki1) (ki2:kis) -sc_ds_app (HsTyVar tc) kis = - do arg_kis <- mapM sc_ds_lhs_kind kis - sc_ds_var_app tc arg_kis -sc_ds_app ki _ = failWithTc (quotes (ppr ki) <+> +tc_kind_app :: HsKind Name -> [LHsKind Name] -> TcM Kind +tc_kind_app (HsAppTy ki1 ki2) kis = tc_kind_app (unLoc ki1) (ki2:kis) +tc_kind_app (HsTyVar tc) kis = do { arg_kis <- mapM tc_lhs_kind kis + ; tc_kind_var_app tc arg_kis } +tc_kind_app ki _ = failWithTc (quotes (ppr ki) <+> ptext (sLit "is not a kind constructor")) --- IA0_TODO: With explicit kind polymorphism I might need to add ATyVar -sc_ds_var_app :: Name -> [Kind] -> TcM Kind +tc_kind_var_app :: Name -> [Kind] -> TcM Kind -- Special case for * and Constraint kinds -- They are kinds already, so we don't need to promote them -sc_ds_var_app name arg_kis +tc_kind_var_app name arg_kis | name == liftedTypeKindTyConName || name == constraintKindTyConName = do { unless (null arg_kis) @@ -1337,34 +1380,47 @@ sc_ds_var_app name arg_kis ; thing <- tcLookup name ; case thing of AGlobal (ATyCon tc) -> return (mkTyConApp tc []) - _ -> panic "sc_ds_var_app 1" } + _ -> panic "tc_kind_var_app 1" } -- General case -sc_ds_var_app name arg_kis = do - (_errs, mb_thing) <- tryTc (tcLookup name) - case mb_thing of - Just (AGlobal (ATyCon tc)) - | isAlgTyCon tc || isTupleTyCon tc -> do - data_kinds <- xoptM Opt_DataKinds - unless data_kinds $ addErr (dataKindsErr name) - case isPromotableTyCon tc of - Just n | n == length arg_kis -> - return (mkTyConApp (buildPromotedTyCon tc) arg_kis) - Just _ -> err tc "is not fully applied" - Nothing -> err tc "is not promotable" - - -- It is in scope, but not what we expected - Just thing -> wrongThingErr "promoted type" thing name - - -- It is not in scope, but it passed the renamer: staging error - Nothing -> ASSERT2 ( isTyConName name, ppr name ) - failWithTc (ptext (sLit "Promoted kind") <+> - quotes (ppr name) <+> - ptext (sLit "used in a mutually recursive group")) +tc_kind_var_app name arg_kis + = do { (_errs, mb_thing) <- tryTc (tcLookup name) + ; case mb_thing of + Just (AGlobal (ATyCon tc)) + -> do { data_kinds <- xoptM Opt_DataKinds + ; unless data_kinds $ addErr (dataKindsErr name) + ; case isPromotableTyCon tc of + Just n | n == length arg_kis -> + return (mkTyConApp (buildPromotedTyCon tc) arg_kis) + Just _ -> err tc "is not fully applied" + Nothing -> err tc "is not promotable" } + + -- A lexically scoped kind variable + Just (ATyVar _ kind_var) + | not (isKindVar kind_var) + -> failWithTc (ptext (sLit "Type variable") <+> quotes (ppr kind_var) + <+> ptext (sLit "used as a kind")) + | not (null arg_kis) -- Kind variables always have kind BOX, + -- so cannot be applied to anything + -> failWithTc (ptext (sLit "Kind variable") <+> quotes (ppr name) + <+> ptext (sLit "cannot appear in a function position")) + | otherwise + -> return (mkAppTys (mkTyVarTy kind_var) arg_kis) + + -- It is in scope, but not what we expected + Just thing -> wrongThingErr "promoted type" thing name + + -- It is not in scope, but it passed the renamer: staging error + Nothing + -> -- ASSERT2 ( isTyConName name, ppr name ) + do { env <- getLclEnv + ; traceTc "tc_kind_var_app" (ppr name $$ ppr (tcl_env env)) + ; failWithTc (ptext (sLit "Promoted kind") <+> + quotes (ppr name) <+> + ptext (sLit "used in a mutually recursive group")) } } where err tc msg = failWithTc (quotes (ppr tc) <+> ptext (sLit "of kind") <+> quotes (ppr (tyConKind tc)) <+> ptext (sLit msg)) - \end{code} %************************************************************************ @@ -1393,11 +1449,5 @@ badPatSigTvs sig_ty bad_tvs ptext (sLit "but are actually discarded by a type synonym") ] , ptext (sLit "To fix this, expand the type synonym") , ptext (sLit "[Note: I hope to lift this restriction in due course]") ] - -dupInScope :: Name -> Name -> Type -> SDoc -dupInScope n n' _ - = hang (ptext (sLit "The scoped type variables") <+> quotes (ppr n) <+> ptext (sLit "and") <+> quotes (ppr n')) - 2 (vcat [ptext (sLit "are bound to the same type (variable)"), - ptext (sLit "Distinct scoped type variables must be distinct")]) \end{code} diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 89a034ba18..9eb747ad51 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -19,8 +19,12 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where import HsSyn import TcBinds -import TcTyClsDecls -import TcClassDcl +import TcTyClsDecls( tcAddImplicits, tcAddFamInstCtxt, tcSynFamInstDecl, + wrongKindOfFamily, tcFamTyPats, kcTyDefn, dataDeclChecks, + tcConDecls, checkValidTyCon, badATErr, wrongATArgErr ) +import TcClassDcl( tcClassDecl2, + HsSigFun, lookupHsSig, mkHsSigFun, emptyHsSigs, + findMethodBind, instantiateMethod, tcInstanceMethodBody ) import TcPat ( addInlinePrags ) import TcRnMonad import TcMType @@ -35,6 +39,7 @@ import TcEnv import TcHsType import TcUnify import MkCore ( nO_METHOD_BINDING_ERROR_ID ) +import CoreSyn ( DFunArg(..) ) import Type import TcEvidence import TyCon @@ -45,12 +50,13 @@ import VarEnv import VarSet ( mkVarSet, subVarSet, varSetElems ) import Pair import CoreUnfold ( mkDFunUnfolding ) -import CoreSyn ( Expr(Var), CoreExpr, varToCoreExpr ) +import CoreSyn ( Expr(Var), CoreExpr ) import PrelNames ( typeableClassNames ) import Bag import BasicTypes import DynFlags +import ErrUtils import FastString import Id import MkId @@ -370,30 +376,31 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- (they recover, so that we get more than one error each -- round) - -- (1) Do class and family instance declarations - ; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1 inst_decls + -- Do class and family instance declarations + ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls + ; let (local_infos_s, fam_insts_s) = unzip stuff + local_infos = concat local_infos_s + fam_insts = concat fam_insts_s + ; addClsInsts local_infos $ + addFamInsts fam_insts $ - ; let { (local_infos_s, fam_insts_s) = unzip inst_decl_stuff - ; all_fam_insts = concat fam_insts_s - ; local_infos = concat local_infos_s } - - -- (2) Next, construct the instance environment so far, consisting of - -- (a) local instance decls - -- (b) local family instance decls - ; addClsInsts local_infos $ - addFamInsts all_fam_insts $ do - - -- (3) Compute instances from "deriving" clauses; + do { -- Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance -- decl, so it needs to know about all the instances possible -- NB: class instance declarations can contain derivings as -- part of associated data type declarations - { failIfErrsM -- If the addInsts stuff gave any errors, don't + failIfErrsM -- If the addInsts stuff gave any errors, don't -- try the deriving stuff, because that may give -- more errors still + ; traceTc "tcDeriving" empty + ; th_stage <- getStage -- See Note [Deriving inside TH brackets ] ; (gbl_env, deriv_inst_info, deriv_binds) - <- tcDeriving tycl_decls inst_decls deriv_decls + <- if isBrackStage th_stage + then do { gbl_env <- getGblEnv + ; return (gbl_env, emptyBag, emptyValBindsOut) } + else tcDeriving tycl_decls inst_decls deriv_decls + -- Check that if the module is compiled with -XSafe, there are no -- hand written instances of Typeable as then unsafe casts could be @@ -426,7 +433,8 @@ addFamInsts :: [FamInst] -> TcM a -> TcM a addFamInsts fam_insts thing_inside = tcExtendLocalFamInstEnv fam_insts $ tcExtendGlobalEnvImplicit things $ - do { tcg_env <- tcAddImplicits things + do { traceTc "addFamInsts" (pprFamInsts fam_insts) + ; tcg_env <- tcAddImplicits things ; setGblEnv tcg_env thing_inside } where axioms = map famInstAxiom fam_insts @@ -434,20 +442,38 @@ addFamInsts fam_insts thing_inside things = map ATyCon tycons ++ map ACoAxiom axioms \end{code} +Note [Deriving inside TH brackets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a declaration bracket + [d| data T = A | B deriving( Show ) |] + +there is really no point in generating the derived code for deriving( +Show) and then type-checking it. This will happen at the call site +anyway, and the type check should never fail! Moreover (Trac #6005) +the scoping of the generated code inside the bracket does not seem to +work out. + +The easy solution is simply not to generate the derived instances at +all. (A less brutal solution would be to generate them with no +bindings.) This will become moot when we shift to the new TH plan, so +the brutal solution will do. + + \begin{code} -tcLocalInstDecl1 :: LInstDecl Name - -> TcM ([InstInfo Name], [FamInst]) +tcLocalInstDecl :: LInstDecl Name + -> TcM ([InstInfo Name], [FamInst]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context -tcLocalInstDecl1 (L loc (FamInstDecl decl)) +tcLocalInstDecl (L loc (FamInstD { lid_inst = decl })) = setSrcSpan loc $ - tcAddDeclCtxt decl $ + tcAddFamInstCtxt decl $ do { fam_inst <- tcFamInstDecl TopLevel decl ; return ([], [fam_inst]) } -tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats)) +tcLocalInstDecl (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds + , cid_sigs = uprags, cid_fam_insts = ats })) = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ @@ -466,7 +492,7 @@ tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats)) -- Check for missing associated types and build them -- from their defaults (if available) - ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats + ; let defined_ats = mkNameSet $ map famInstDeclName ats mk_deflt_at_instances :: ClassATItem -> TcM [FamInst] mk_deflt_at_instances (fam_tc, defs) @@ -520,12 +546,12 @@ lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM FamInst +tcFamInstDecl :: TopLevelFlag -> FamInstDecl Name -> TcM FamInst tcFamInstDecl top_lvl decl = do { -- Type family instances require -XTypeFamilies -- and can't (currently) be in an hs-boot file ; traceTc "tcFamInstDecl" (ppr decl) - ; let fam_tc_lname = tcdLName decl + ; let fam_tc_lname = fid_tycon decl ; type_families <- xoptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; checkTc type_families $ badFamInstDecl fam_tc_lname @@ -542,10 +568,11 @@ tcFamInstDecl top_lvl decl -- This is where type and data decls are treated separately ; tcFamInstDecl1 fam_tc decl } -tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM FamInst +tcFamInstDecl1 :: TyCon -> FamInstDecl Name -> TcM FamInst -- "type instance" -tcFamInstDecl1 fam_tc (decl@TySynonym {}) +tcFamInstDecl1 fam_tc decl@(FamInstDecl { fid_tycon = fam_tc_name + , fid_defn = TySynonym {} }) = do { -- (1) do the work of verifying the synonym ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl @@ -553,21 +580,23 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {}) ; checkValidFamInst t_typats t_rhs -- (3) construct representation tycon - ; rep_tc_name <- newFamInstAxiomName (tcdLName decl) t_typats + ; rep_tc_name <- newFamInstAxiomName fam_tc_name t_typats ; return (mkSynFamInst rep_tc_name t_tvs fam_tc t_typats t_rhs) } -- "newtype instance" and "data instance" -tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt - , tcdTyVars = tvs, tcdTyPats = Just pats - , tcdCons = cons}) +tcFamInstDecl1 fam_tc + (FamInstDecl { fid_pats = pats + , fid_tycon = fam_tc_name + , fid_defn = defn@TyData { td_ND = new_or_data, td_cType = cType + , td_ctxt = ctxt, td_cons = cons } }) = do { -- Check that the family declaration is for the right kind checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Kind check type patterns - ; tcFamTyPats fam_tc tvs pats (\_always_star -> kcDataDecl decl) $ - \tvs' pats' resultKind -> do + ; tcFamTyPats fam_tc pats (kcTyDefn defn) $ + \tvs' pats' res_kind -> do -- Check that left-hand side contains no type family applications -- (vanilla synonyms are fine, though, and we checked for @@ -575,13 +604,13 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt { mapM_ checkTyFamFreeness pats' -- Result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (isLiftedTypeKind resultKind) $ tooFewParmsErr (tyConArity fam_tc) + ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc) - ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt - ; dataDeclChecks (tcdName decl) new_or_data stupid_theta cons + ; stupid_theta <- tcHsContext ctxt + ; dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons -- Construct representation tycon - ; rep_tc_name <- newFamInstTyConName (tcdLName decl) pats' + ; rep_tc_name <- newFamInstTyConName fam_tc_name pats' ; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc ; let ex_ok = True -- Existentials ok for type families! orig_res_ty = mkTyConApp fam_tc pats' @@ -595,7 +624,7 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) ; let fam_inst = mkDataFamInst axiom_name tvs' fam_tc pats' rep_tc parent = FamInstTyCon (famInstAxiom fam_inst) fam_tc pats' - rep_tc = buildAlgTyCon rep_tc_name tvs' stupid_theta tc_rhs + rep_tc = buildAlgTyCon rep_tc_name tvs' cType stupid_theta tc_rhs Recursive h98_syntax parent -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a @@ -612,17 +641,15 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False _ -> True -tcFamInstDecl1 _ d = pprPanic "tcFamInstDecl1" (ppr d) - ---------------- -tcAssocDecl :: Class -- ^ Class of associated type - -> VarEnv Type -- ^ Instantiation of class TyVars - -> LTyClDecl Name -- ^ RHS +tcAssocDecl :: Class -- ^ Class of associated type + -> VarEnv Type -- ^ Instantiation of class TyVars + -> LFamInstDecl Name -- ^ RHS -> TcM FamInst tcAssocDecl clas mini_env (L loc decl) = setSrcSpan loc $ - tcAddDeclCtxt decl $ + tcAddFamInstCtxt decl $ do { fam_inst <- tcFamInstDecl NotTopLevel decl ; let (fam_tc, at_tys) = famInstLHS fam_inst @@ -705,13 +732,13 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- See Note [Subtle interaction of recursion and overlap] -- and Note [Binding when looking up instances] ; let (clas, inst_tys) = tcSplitDFunHead inst_head - (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas + (class_tyvars, sc_theta, _, op_items) = classBigSig clas sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta + ; dfun_ev_vars <- newEvVars dfun_theta - ; (sc_args, sc_binds) - <- mapAndUnzipM (tcSuperClass inst_tyvars dfun_ev_vars) - (sc_sels `zip` sc_theta') + ; (sc_binds, sc_ev_vars, sc_dfun_args) + <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta' -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] @@ -744,20 +771,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 con_app_tys = wrapId (mkWpTyApps inst_tys) (dataConWrapId dict_constr) - con_app_scs = mkHsWrap (mkWpEvApps (map mk_sc_ev_term sc_args)) con_app_tys + con_app_scs = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys con_app_args = foldl mk_app con_app_scs $ map (wrapId arg_wrapper) meth_ids mk_app :: HsExpr Id -> HsExpr Id -> HsExpr Id mk_app fun arg = HsApp (L loc fun) (L loc arg) - mk_sc_ev_term :: EvVar -> EvTerm - mk_sc_ev_term sc - | null inst_tv_tys - , null dfun_ev_vars = EvId sc - | otherwise = EvDFunApp sc inst_tv_tys dfun_ev_vars - - inst_tv_tys = mkTyVarTys inst_tyvars + inst_tv_tys = mkTyVarTys inst_tyvars arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys -- Do not inline the dfun; instead give it a magic DFunFunfolding @@ -770,9 +791,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty dfun_args `setInlinePragma` dfunInlinePragma - dfun_args :: [CoreExpr] - dfun_args = map varToCoreExpr sc_args ++ - map Var meth_ids + dfun_args :: [DFunArg CoreExpr] + dfun_args = sc_dfun_args ++ map (DFunPolyArg . Var) meth_ids export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun , abe_mono = self_dict, abe_prags = noSpecPrags } @@ -780,12 +800,11 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] - , abs_ev_binds = emptyTcEvBinds + , abs_ev_binds = sc_binds , abs_binds = unitBag dict_bind } ; return (unitBag (L loc main_bind) `unionBags` - listToBag meth_binds `unionBags` - unionManyBags sc_binds) + listToBag meth_binds) } where dfun_ty = idType dfun_id @@ -793,65 +812,87 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) loc = getSrcSpan dfun_id ------------------------------ -checkInstSig :: Class -> [TcType] -> LSig Name -> TcM () --- Check that any type signatures have exactly the right type -checkInstSig clas inst_tys (L loc (TypeSig names@(L _ name1:_) hs_ty)) - = setSrcSpan loc $ - do { inst_sigs <- xoptM Opt_InstanceSigs - ; if inst_sigs then - do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty - ; mapM_ (check sigma_ty) names } - else - addErrTc (misplacedInstSig names hs_ty) } +tcSuperClasses :: DFunId -> [TcTyVar] -> [EvVar] -> TcThetaType + -> TcM (TcEvBinds, [EvVar], [DFunArg CoreExpr]) +-- See Note [Silent superclass arguments] +tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta + = do { -- Check that all superclasses can be deduced from + -- the originally-specified dfun arguments + ; (sc_binds, sc_evs) <- checkConstraints InstSkol inst_tyvars orig_ev_vars $ + emitWanteds ScOrigin sc_theta + + ; if null inst_tyvars && null dfun_ev_vars + then return (sc_binds, sc_evs, map (DFunPolyArg . Var) sc_evs) + else return (emptyTcEvBinds, sc_lam_args, sc_dfun_args) } where - check sigma_ty (L _ n) - = do { sel_id <- tcLookupId n - ; let meth_ty = instantiateMethod clas sel_id inst_tys - ; checkTc (sigma_ty `eqType` meth_ty) - (badInstSigErr n meth_ty) } - -checkInstSig _ _ _ = return () + n_silent = dfunNSilent dfun_id + n_tv_args = length inst_tyvars + orig_ev_vars = drop n_silent dfun_ev_vars + + (sc_lam_args, sc_dfun_args) = unzip (map (find n_tv_args dfun_ev_vars) sc_theta) + find _ [] pred + = pprPanic "tcInstDecl2" (ppr dfun_id $$ ppr (idType dfun_id) $$ ppr pred) + find i (ev:evs) pred + | pred `eqPred` evVarPred ev = (ev, DFunLamArg i) + | otherwise = find (i+1) evs pred + +---------------------- +mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] + -> [TcType] -> Id -> TcM (TcId, TcSigInfo) +mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id + = do { uniq <- newUnique + ; loc <- getSrcSpanM + ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name + ; local_meth_name <- newLocalName sel_name + -- Base the local_meth_name on the selector name, becuase + -- type errors from tcInstanceMethodBody come from here + + ; local_meth_sig <- case lookupHsSig sig_fn sel_name of + Just hs_ty -- There is a signature in the instance declaration + -> do { sig_ty <- check_inst_sig hs_ty + ; instTcTySig hs_ty sig_ty local_meth_name } + + Nothing -- No type signature + -> instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) + -- Absent a type sig, there are no new scoped type variables here + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = <rhs> } + -- In <rhs>, 'c' is scope but 'b' is not! + + ; let meth_id = mkLocalId meth_name meth_ty + ; return (meth_id, local_meth_sig) } + where + sel_name = idName sel_id + local_meth_ty = instantiateMethod clas sel_id inst_tys + meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty + + -- Check that any type signatures have exactly the right type + check_inst_sig hs_ty@(L loc _) + = setSrcSpan loc $ + do { sig_ty <- tcHsSigType (FunSigCtxt sel_name) hs_ty + ; inst_sigs <- xoptM Opt_InstanceSigs + ; if inst_sigs then + checkTc (sig_ty `eqType` local_meth_ty) + (badInstSigErr sel_name local_meth_ty) + else + addErrTc (misplacedInstSig sel_name hs_ty) + ; return sig_ty } badInstSigErr :: Name -> Type -> SDoc badInstSigErr meth ty = hang (ptext (sLit "Method signature does not match class; it should be")) 2 (pprPrefixName meth <+> dcolon <+> ppr ty) -misplacedInstSig :: [Located Name] -> LHsType Name -> SDoc -misplacedInstSig names hs_ty +misplacedInstSig :: Name -> LHsType Name -> SDoc +misplacedInstSig name hs_ty = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:")) - 2 (hang (hsep $ punctuate comma (map (pprPrefixName . unLoc) names)) + 2 (hang (pprPrefixName name) 2 (dcolon <+> ppr hs_ty)) , ptext (sLit "(Use -XInstanceSigs to allow this)") ] ------------------------------ -tcSuperClass :: [TcTyVar] -> [EvVar] - -> (Id, PredType) - -> TcM (TcId, LHsBinds TcId) - --- Build a top level decl like --- sc_op = /\a \d. let sc = ... in --- sc --- and return sc_op, that binding - -tcSuperClass tyvars ev_vars (sc_sel, sc_pred) - = do { (ev_binds, sc_dict) - <- newImplication InstSkol tyvars ev_vars $ - emitWanted ScOrigin sc_pred - - ; uniq <- newUnique - ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes ev_vars (varType sc_dict) - sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq - (getName sc_sel) - sc_op_id = mkLocalId sc_op_name sc_op_ty - sc_op_bind = mkVarBind sc_op_id (L noSrcSpan $ wrapId sc_wrapper sc_dict) - sc_wrapper = mkWpTyLams tyvars - <.> mkWpLams ev_vars - <.> mkWpLet ev_binds - - ; return (sc_op_id, unitBag sc_op_bind) } - ------------------------------- tcSpecInstPrags :: DFunId -> InstBindings Name -> TcM ([Located TcSpecPrag], PragFun) tcSpecInstPrags _ (NewTypeDerived {}) @@ -863,8 +904,17 @@ tcSpecInstPrags dfun_id (VanillaInst binds uprags _) ; return (spec_inst_prags, mkPragFun uprags binds) } \end{code} -Note [Superclass loop avoidance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Silent superclass arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #3731, #4809, #5751, #5913, #6117, which all +describe somewhat more complicated situations, but ones +encountered in practice. + + THE PROBLEM + +The problem is that it is all too easy to create a class whose +superclass is bottom when it should not be. + Consider the following (extreme) situation: class C a => D a where ... instance D [a] => D [a] where ... @@ -879,10 +929,51 @@ argument: dfun :: forall a. D [a] -> D [a] dfun = \d::D [a] -> MkD (scsel d) .. -Rather, we want to get it by finding an instance for (C [a]). We -achieve this by - not making the superclasses of a "wanted" - available for solving wanted constraints. +Otherwise if we later encounter a situation where +we have a [Wanted] dw::D [a] we might solve it thus: + dw := dfun dw +Which is all fine except that now ** the superclass C is bottom **! + + THE SOLUTION + +Our solution to this problem "silent superclass arguments". We pass +to each dfun some ``silent superclass arguments’’, which are the +immediate superclasses of the dictionary we are trying to +construct. In our example: + dfun :: forall a. C [a] -> D [a] -> D [a] + dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... +Notice teh extra (dc :: C [a]) argument compared to the previous version. + +This gives us: + + ----------------------------------------------------------- + DFun Superclass Invariant + ~~~~~~~~~~~~~~~~~~~~~~~~ + In the body of a DFun, every superclass argument to the + returned dictionary is + either * one of the arguments of the DFun, + or * constant, bound at top level + ----------------------------------------------------------- + +This net effect is that it is safe to treat a dfun application as +wrapping a dictionary constructor around its arguments (in particular, +a dfun never picks superclasses from the arguments under the +dictionary constructor). No superclass is hidden inside a dfun +application. + +The extra arguments required to satisfy the DFun Superclass Invariant +always come first, and are called the "silent" arguments. DFun types +are built (only) by MkId.mkDictFunId, so that is where we decide +what silent arguments are to be added. + +In our example, if we had [Wanted] dw :: D [a] we would get via the instance: + dw := dfun d1 d2 + [Wanted] (d1 :: C [a]) + [Wanted] (d2 :: D [a]) + +And now, though we *can* solve: + d2 := dw +That's fine; and we solve d1:C[a] separately. Test case SCLoop tests this fix. @@ -930,7 +1021,7 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty) = addErrCtxt (spec_ctxt prag) $ do { let name = idName dfun_id ; (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty - ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys + ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt (idType dfun_id) spec_dfun_ty @@ -968,58 +1059,60 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar] tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys (spec_inst_prags, prag_fn) op_items (VanillaInst binds sigs standalone_deriv) - = do { mapM_ (checkInstSig clas inst_tys) sigs - ; mapAndUnzipM tc_item op_items } + = do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) + ; let hs_sig_fn = mkHsSigFun sigs + ; mapAndUnzipM (tc_item hs_sig_fn) op_items } where ---------------------- - tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id) - tc_item (sel_id, dm_info) + tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id) + tc_item sig_fn (sel_id, dm_info) = case findMethodBind (idName sel_id) binds of - Just user_bind -> tc_body sel_id standalone_deriv user_bind + Just user_bind -> tc_body sig_fn sel_id standalone_deriv user_bind Nothing -> traceTc "tc_def" (ppr sel_id) >> - tc_default sel_id dm_info + tc_default sig_fn sel_id dm_info ---------------------- - tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id) - tc_body sel_id generated_code rn_bind + tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id) + tc_body sig_fn sel_id generated_code rn_bind = add_meth_ctxt sel_id generated_code rn_bind $ - do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id - ; let sel_name = idName sel_id - prags = prag_fn (idName sel_id) + do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id)) + ; (meth_id, local_meth_sig) <- setSrcSpan (getLoc rn_bind) $ + mkMethIds sig_fn clas tyvars dfun_ev_vars + inst_tys sel_id + ; let prags = prag_fn (idName sel_id) ; meth_id1 <- addInlinePrags meth_id prags ; spec_prags <- tcSpecPrags meth_id1 prags ; bind <- tcInstanceMethodBody InstSkol tyvars dfun_ev_vars - meth_id1 local_meth_id - (mk_meth_sig_fn sel_name) + meth_id1 local_meth_sig (mk_meth_spec_prags meth_id1 spec_prags) rn_bind ; return (meth_id1, bind) } ---------------------- - tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id) + tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id) - tc_default sel_id (GenDefMeth dm_name) + tc_default sig_fn sel_id (GenDefMeth dm_name) = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name - ; tc_body sel_id False {- Not generated code? -} meth_bind } + ; tc_body sig_fn sel_id False {- Not generated code? -} meth_bind } - tc_default sel_id NoDefMeth -- No default method at all + tc_default sig_fn sel_id NoDefMeth -- No default method at all = do { traceTc "tc_def: warn" (ppr sel_id) ; warnMissingMethodOrAT "method" (idName sel_id) - ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars + ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id + ; dflags <- getDynFlags ; return (meth_id, mkVarBind meth_id $ - mkLHsWrap lam_wrapper error_rhs) } + mkLHsWrap lam_wrapper (error_rhs dflags)) } where - error_rhs = L loc $ HsApp error_fun error_msg + error_rhs dflags = L loc $ HsApp error_fun (error_msg dflags) error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID - error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string))) + error_msg dflags = L loc (HsLit (HsStringPrim (mkFastString (error_string dflags)))) meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) - error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) + error_string dflags = showSDoc dflags (hcat [ppr loc, text "|", ppr sel_id ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars - tc_default sel_id (DefMeth dm_name) -- A polymorphic default method + tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method = do { -- Build the typechecked version directly, -- without calling typecheck_method; -- see Note [Default methods in instances] @@ -1030,15 +1123,16 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; self_dict <- newDict clas inst_tys ; let self_ev_bind = EvBind self_dict - (EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars) + (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars)) - ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars + ; (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; dm_id <- tcLookupId dm_name ; let dm_inline_prag = idInlinePragma dm_id rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $ HsVar dm_id + local_meth_id = sig_id local_meth_sig meth_bind = mkVarBind local_meth_id (L loc rhs) meth_id1 = meth_id `setInlinePragma` dm_inline_prag -- Copy the inline pragma (if any) from the default @@ -1080,19 +1174,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys = [ L loc (SpecPrag meth_id wrap inl) | L loc (SpecPrag _ wrap inl) <- spec_inst_prags] - loc = getSrcSpan dfun_id - sig_fn = mkSigFun sigs - mk_meth_sig_fn sel_name _meth_name - = case sig_fn sel_name of - Nothing -> Just ([],loc) - Just r -> Just r - -- The orElse 'Just' says "yes, in effect there's always a type sig" - -- But there are no scoped type variables from local_method_id - -- Only the ones from the instance decl itself, which are already - -- in scope. Example: - -- class C a where { op :: forall b. Eq b => ... } - -- instance C [c] where { op = <rhs> } - -- In <rhs>, 'c' is scope but 'b' is not! + loc = getSrcSpan dfun_id -- For instance decls that come from standalone deriving clauses -- we want to print out the full source code if there's an error @@ -1143,14 +1225,16 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- co : [p] ~ T p co = mkTcSymCo (mkTcInstCos coi (mkTyVarTys tyvars)) + sig_fn = emptyHsSigs ---------------- tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId) tc_item (rep_ev_binds, rep_d) (sel_id, _) - = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id + = do { (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars + inst_tys sel_id - ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id + ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id + local_meth_id = sig_id local_meth_sig meth_bind = mkVarBind local_meth_id (L loc meth_rhs) export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id , abe_mono = local_meth_id, abe_prags = noSpecPrags } @@ -1173,22 +1257,21 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho `orElse` pprPanic "tcInstanceMethods" (ppr sel_id) ----------------------- -mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId) -mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - = do { uniq <- newUnique - ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name - ; local_meth_name <- newLocalName sel_name - -- Base the local_meth_name on the selector name, becuase - -- type errors from tcInstanceMethodBody come from here - - ; let meth_id = mkLocalId meth_name meth_ty - local_meth_id = mkLocalId local_meth_name local_meth_ty - ; return (meth_id, local_meth_id) } +------------------ +mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name) +mkGenericDefMethBind clas inst_tys sel_id dm_name + = -- A generic default method + -- If the method is defined generically, we only have to call the + -- dm_name. + do { dflags <- getDynFlags + ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" + (vcat [ppr clas <+> ppr inst_tys, + nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) + + ; return (noLoc $ mkTopFunBind (noLoc (idName sel_id)) + [mkSimpleMatch [] rhs]) } where - local_meth_ty = instantiateMethod clas sel_id inst_tys - meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty - sel_name = idName sel_id + rhs = nlHsVar dm_name ---------------------- wrapId :: HsWrapper -> id -> HsExpr id diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 3b46af4573..adff5ea182 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -22,15 +22,13 @@ import Unify import FamInstEnv import Coercion( mkAxInstRHS ) -import Id import Var - import TcType +import PrelNames (singIClassName) import Class import TyCon import Name -import IParam import FunDeps @@ -46,16 +44,17 @@ import Maybes( orElse ) import Bag import Control.Monad ( foldM ) -import TrieMap import VarEnv import qualified Data.Traversable as Traversable +import Data.Maybe ( isJust ) -import Control.Monad( when ) -import Pair ( pSnd ) +import Control.Monad( when, unless ) +import Pair () import UniqFM import FastString ( sLit ) import DynFlags +import Util \end{code} ********************************************************************** * * @@ -88,61 +87,28 @@ If in Step 1 no such element exists, we have exceeded our context-stack depth and will simply fail. \begin{code} -solveInteractCts :: [Ct] -> TcS () +solveInteractCts :: [Ct] -> TcS (Bag Implication) +-- Returns a bag of residual implications that have arisen while solving +-- this particular worklist. solveInteractCts cts - = do { evvar_cache <- getTcSEvVarCacheMap - ; (cts_thinner, new_evvar_cache) <- add_cts_in_cache evvar_cache cts - ; traceTcS "solveInteractCts" (vcat [ text "cts_original =" <+> ppr cts, - text "cts_thinner =" <+> ppr cts_thinner - ]) - ; setTcSEvVarCacheMap new_evvar_cache - ; updWorkListTcS (appendWorkListCt cts_thinner) >> solveInteract } - - where - add_cts_in_cache evvar_cache cts - = do { ctxt <- getTcSContext - ; foldM (solve_or_cache (simplEqsOnly ctxt)) ([],evvar_cache) cts } - - solve_or_cache :: Bool -- Solve equalities only, not classes etc - -> ([Ct],TypeMap (EvVar,CtFlavor)) - -> Ct - -> TcS ([Ct],TypeMap (EvVar,CtFlavor)) - solve_or_cache eqs_only (acc_cts,acc_cache) ct - | dont_cache eqs_only (classifyPredType pred_ty) - = return (ct:acc_cts,acc_cache) - - | Just (ev',fl') <- lookupTM pred_ty acc_cache - , fl' `canSolve` fl - , isWanted fl - = do { _ <- setEvBind ev (EvId ev') fl - ; return (acc_cts,acc_cache) } - - | otherwise -- If it's a given keep it in the work list, even if it exists in the cache! - = return (ct:acc_cts, alterTM pred_ty (\_ -> Just (ev,fl)) acc_cache) - where fl = cc_flavor ct - ev = cc_id ct - pred_ty = ctPred ct - - dont_cache :: Bool -> PredTree -> Bool - -- Do not use the cache, not update it, if this is true - dont_cache _ (IPPred {}) = True -- IPPreds have subtle shadowing - dont_cache _ (EqPred ty1 ty2) -- Report Int ~ Bool errors separately - | Just tc1 <- tyConAppTyCon_maybe ty1 - , Just tc2 <- tyConAppTyCon_maybe ty2 - , tc1 /= tc2 - = isDecomposableTyCon tc1 && isDecomposableTyCon tc2 - | otherwise = False - dont_cache eqs_only _ = eqs_only - -- If we are simplifying equalities only, - -- do not cache non-equalities - -- See Note [Simplifying RULE lhs constraints] in TcSimplify - -solveInteractGiven :: GivenLoc -> [EvVar] -> TcS () + = do { traceTcS "solveInteractCtS" (vcat [ text "cts =" <+> ppr cts ]) + ; updWorkListTcS (appendWorkListCt cts) >> solveInteract + ; impls <- getTcSImplics + ; updTcSImplics (const emptyBag) -- Nullify residual implications + ; return impls } + +solveInteractGiven :: GivenLoc -> [EvVar] -> TcS (Bag Implication) +-- In principle the givens can kick out some wanteds from the inert +-- resulting in solving some more wanted goals here which could emit +-- implications. That's why I return a bag of implications. Not sure +-- if this can happen in practice though. solveInteractGiven gloc evs = solveInteractCts (map mk_noncan evs) - where mk_noncan ev = CNonCanonical { cc_id = ev - , cc_flavor = Given gloc GivenOrig - , cc_depth = 0 } + where + mk_noncan ev = CNonCanonical { cc_ev = Given { ctev_gloc = gloc + , ctev_evtm = EvId ev + , ctev_pred = evVarPred ev } + , cc_depth = 0 } -- The main solver loop implements Note [Basic Simplifier Plan] --------------------------------------------------------------- @@ -250,7 +216,8 @@ React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canoni \begin{code} thePipeline :: [(String,SimplifierStage)] -thePipeline = [ ("canonicalization", canonicalizationStage) +thePipeline = [ ("lookup-in-inerts", lookupInInertsStage) + , ("canonicalization", canonicalizationStage) , ("spontaneous solve", spontaneousSolveStage) , ("interact with inerts", interactWithInertsStage) , ("top-level reactions", topReactionsStage) ] @@ -259,11 +226,27 @@ thePipeline = [ ("canonicalization", canonicalizationStage) \begin{code} +-- A quick lookup everywhere to see if we know about this constraint +-------------------------------------------------------------------- +lookupInInertsStage :: SimplifierStage +lookupInInertsStage ct + | Wanted { ctev_evar = ev_id, ctev_pred = pred } <- cc_ev ct + = do { is <- getTcSInerts + ; case lookupInInerts is pred of + Just ctev + | not (isDerived ctev) + -> do { setEvBind ev_id (ctEvTerm ctev) + ; return Stop } + _ -> continueWith ct } + | otherwise -- I could do something like that for givens + -- as well I suppose but it is not a big deal + = continueWith ct + + -- The canonicalization stage, see TcCanonical for details ---------------------------------------------------------- canonicalizationStage :: SimplifierStage canonicalizationStage = TcCanonical.canonicalize - \end{code} ********************************************************************************* @@ -289,14 +272,9 @@ Case 1: In Rewriting Equalities (function rewriteEqLHS) canonicalize (xi1 ~ xi2) if (b) comes from the inert set, or (xi2 ~ xi1) if (a) comes from the inert set. - This choice is implemented using the WhichComesFromInert flag. - Case 2: Functional Dependencies Again, we should prefer, if possible, the inert variables on the RHS -Case 3: IP improvement work - We must always rewrite so that the inert type is on the right. - \begin{code} spontaneousSolveStage :: SimplifierStage spontaneousSolveStage workItem @@ -311,8 +289,7 @@ spontaneousSolveStage workItem spont_solve (SPSolved workItem') -- Post: workItem' must be equality = do { bumpStepCountTcS ; traceFireTcS (cc_depth workItem) $ - ptext (sLit "Spontaneous") - <+> parens (ppr (cc_flavor workItem)) <+> ppr workItem + ptext (sLit "Spontaneous:") <+> ppr workItem -- NB: will add the item in the inerts ; kickOutRewritableInerts workItem' @@ -326,124 +303,108 @@ kickOutRewritableInerts :: Ct -> TcS () -- The rewritable end up in the worklist kickOutRewritableInerts ct = {-# SCC "kickOutRewritableInerts" #-} - do { (wl,ieqs) <- {-# SCC "kick_out_rewritable" #-} + do { traceTcS "kickOutRewritableInerts" $ text "workitem = " <+> ppr ct + ; (wl,ieqs) <- {-# SCC "kick_out_rewritable" #-} modifyInertTcS (kick_out_rewritable ct) + ; traceTcS "Kicked out the following constraints" $ ppr wl + ; is <- getTcSInerts + ; traceTcS "Remaining inerts are" $ ppr is - -- Step 1: Rewrite as many of the inert_eqs on the spot! - -- NB: if it is a solved constraint just use the cached evidence - - ; let ct_coercion = getCtCoercion ct + -- Step 1: Rewrite as many of the inert_eqs on the spot! + -- NB: if it is a given constraint just use the cached evidence + -- to optimize e.g. mkRefl coercions from spontaneously solved cts. + ; bnds <- getTcEvBindsMap + ; let ct_coercion = getCtCoercion bnds ct ; new_ieqs <- {-# SCC "rewriteInertEqsFromInertEq" #-} - rewriteInertEqsFromInertEq (cc_tyvar ct,ct_coercion, cc_flavor ct) ieqs - ; modifyInertTcS (\is -> ((), is { inert_eqs = new_ieqs })) - - -- Step 2: Add the new guy in + rewriteInertEqsFromInertEq (cc_tyvar ct, + ct_coercion,cc_ev ct) ieqs + ; let upd_eqs is = is { inert_cans = new_ics } + where ics = inert_cans is + new_ics = ics { inert_eqs = new_ieqs } + ; modifyInertTcS (\is -> ((), upd_eqs is)) + + ; is <- getTcSInerts + ; traceTcS "Final inerts are" $ ppr is + + -- Step 2: Add the new guy in ; updInertSetTcS ct ; traceTcS "Kick out" (ppr ct $$ ppr wl) ; updWorkListTcS (unionWorkList wl) } -rewriteInertEqsFromInertEq :: (TcTyVar, TcCoercion, CtFlavor) -- A new substitution - -> TyVarEnv (Ct, TcCoercion) -- All inert equalities - -> TcS (TyVarEnv (Ct,TcCoercion)) -- The new inert equalities -rewriteInertEqsFromInertEq (subst_tv, subst_co, subst_fl) ieqs --- The goal: traverse the inert equalities and rewrite some of them, dropping some others --- back to the worklist. This is delicate, see Note [Delicate equality kick-out] +rewriteInertEqsFromInertEq :: (TcTyVar, TcCoercion, CtEvidence) -- A new substitution + -> TyVarEnv Ct -- All the inert equalities + -> TcS (TyVarEnv Ct) -- The new inert equalities +rewriteInertEqsFromInertEq (subst_tv, _subst_co, subst_fl) ieqs +-- The goal: traverse the inert equalities and throw some of them back to the worklist +-- if you have to rewrite and recheck them for occurs check errors. +-- To see which ones we must throw out see Note [Delicate equality kick-out] = do { mieqs <- Traversable.mapM do_one ieqs ; traceTcS "Original inert equalities:" (ppr ieqs) ; let flatten_justs elem venv - | Just (act,aco) <- elem = extendVarEnv venv (cc_tyvar act) (act,aco) + | Just act <- elem = extendVarEnv venv (cc_tyvar act) act | otherwise = venv final_ieqs = foldVarEnv flatten_justs emptyVarEnv mieqs ; traceTcS "Remaining inert equalities:" (ppr final_ieqs) ; return final_ieqs } - where do_one (ct,inert_co) + where do_one ct | subst_fl `canRewrite` fl && (subst_tv `elemVarSet` tyVarsOfCt ct) - -- Annoyingly inefficient, but we can't simply check - -- that isReflCo co because of cached solved ReflCo evidence. - = if fl `canRewrite` subst_fl then - -- If also the inert can rewrite the subst it's totally safe - -- to rewrite on the spot - do { (ct',inert_co') <- rewrite_on_the_spot (ct,inert_co) - ; return $ Just (ct',inert_co') } + = if fl `canRewrite` subst_fl then + -- If also the inert can rewrite the subst then there is no danger of + -- occurs check errors sor keep it there. No need to rewrite the inert equality + -- (as we did in the past) because of point (8) of + -- Note [Detailed InertCans Invariants] and + return (Just ct) + -- used to be: rewrite_on_the_spot ct >>= ( return . Just ) else -- We have to throw inert back to worklist for occurs checks - do { updWorkListTcS (extendWorkListEq ct) - ; return Nothing } + updWorkListTcS (extendWorkListEq ct) >> return Nothing | otherwise -- Just keep it there - = return $ Just (ct,inert_co) + = return (Just ct) where - -- We have new guy co : tv ~ something - -- and old inert {wanted} cv : tv' ~ rhs[tv] - -- We want to rewrite to - -- {wanted} cv' : tv' ~ rhs[something] - -- cv = cv' ; rhs[Sym co] - -- - rewrite_on_the_spot (ct,_inert_co) - = do { let rhs' = pSnd (tcCoercionKind co) - ; delCachedEvVar ev fl - ; evc <- newEqVar fl (mkTyVarTy tv) rhs' - ; let ev' = evc_the_evvar evc - ; let evco' = mkTcCoVarCo ev' - ; fl' <- if isNewEvVar evc then - do { case fl of - Wanted {} - -> setEqBind ev (evco' `mkTcTransCo` mkTcSymCo co) fl - Given {} - -> setEqBind ev' (mkTcCoVarCo ev `mkTcTransCo` co) fl - Derived {} - -> return fl } - else - if isWanted fl then - setEqBind ev (evco' `mkTcTransCo` mkTcSymCo co) fl - else return fl - ; let ct' = ct { cc_id = ev', cc_flavor = fl', cc_rhs = rhs' } - ; return (ct',evco') } - ev = cc_id ct - fl = cc_flavor ct - tv = cc_tyvar ct - rhs = cc_rhs ct - co = liftTcCoSubstWith [subst_tv] [subst_co] rhs - -kick_out_rewritable :: Ct -> InertSet -> ((WorkList,TyVarEnv (Ct,TcCoercion)), InertSet) --- Returns ALL equalities, to be dealt with later -kick_out_rewritable ct (IS { inert_eqs = eqmap - , inert_eq_tvs = inscope - , inert_dicts = dictmap - , inert_ips = ipmap - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_frozen = frozen - } ) - = ((kicked_out, eqmap), remaining) + fl = cc_ev ct + +kick_out_rewritable :: Ct + -> InertSet + -> ((WorkList, TyVarEnv Ct),InertSet) +-- Post: returns ALL inert equalities, to be dealt with later +-- +kick_out_rewritable ct is@(IS { inert_cans = + IC { inert_eqs = eqmap + , inert_eq_tvs = inscope + , inert_dicts = dictmap + , inert_funeqs = funeqmap + , inert_irreds = irreds } + , inert_frozen = frozen }) + = ((kicked_out,eqmap), remaining) where + rest_out = fro_out `andCts` dicts_out `andCts` irs_out kicked_out = WorkList { wl_eqs = [] , wl_funeqs = bagToList feqs_out - , wl_rest = bagToList (fro_out `andCts` dicts_out - `andCts` ips_out `andCts` irs_out) } + , wl_rest = bagToList rest_out } - remaining = IS { inert_eqs = emptyVarEnv - , inert_eq_tvs = inscope -- keep the same, safe and cheap - , inert_dicts = dicts_in - , inert_ips = ips_in - , inert_funeqs = feqs_in - , inert_irreds = irs_in - , inert_frozen = fro_in - } - - fl = cc_flavor ct + remaining = is { inert_cans = IC { inert_eqs = emptyVarEnv + , inert_eq_tvs = inscope + -- keep the same, safe and cheap + , inert_dicts = dicts_in + , inert_funeqs = feqs_in + , inert_irreds = irs_in } + , inert_frozen = fro_in } + -- NB: Notice that don't rewrite + -- inert_solved, inert_flat_cache and inert_solved_funeqs + -- optimistically. But when we lookup we have to take the + -- subsitution into account + fl = cc_ev ct tv = cc_tyvar ct - - (ips_out, ips_in) = partitionCCanMap rewritable ipmap - (feqs_out, feqs_in) = partitionCtTypeMap rewritable funeqmap + (feqs_out, feqs_in) = partCtFamHeadMap rewritable funeqmap (dicts_out, dicts_in) = partitionCCanMap rewritable dictmap (irs_out, irs_in) = partitionBag rewritable irreds (fro_out, fro_in) = partitionBag rewritable frozen - rewritable ct = (fl `canRewrite` cc_flavor ct) && + rewritable ct = (fl `canRewrite` cc_ev ct) && (tv `elemVarSet` tyVarsOfCt ct) -- NB: tyVarsOfCt will return the type -- variables /and the kind variables/ that are @@ -462,25 +423,24 @@ Note [Delicate equality kick-out] Delicate: When kicking out rewritable constraints, it would be safe to simply kick out all rewritable equalities, but instead we only kick out those -that, when rewritten, may result in occur-check errors. We rewrite the -rest on the spot. Example: +that, when rewritten, may result in occur-check errors. Example: - WorkItem = [S] a ~ b + WorkItem = [G] a ~ b Inerts = { [W] b ~ [a] } Now at this point the work item cannot be further rewritten by the -inert (due to the weaker inert flavor), so we are examining if we can -instead rewrite the inert from the workitem. But if we rewrite it on -the spot we have to recanonicalize because of the danger of occurs -errors. On the other hand if the inert flavor was just as powerful or -more powerful than the workitem flavor, the work-item could not have -reached this stage (because it would have already been rewritten by -the inert). +inert (due to the weaker inert flavor). Instead the workitem can +rewrite the inert leading to potential occur check errors. So we must +kick the inert out. On the other hand, if the inert flavor was as +powerful or more powerful than the workitem flavor, the work-item could +not have reached this stage (because it would have already been +rewritten by the inert). The coclusion is: we kick out the 'dangerous' equalities that may -require recanonicalization (occurs checks) and the rest we rewrite -unconditionally without further checks, on-the-spot with function -rewriteInertEqsFromInertEq. +require recanonicalization (occurs checks) and the rest we keep +there in the inerts without further checks. +In the past we used to rewrite-on-the-spot those equalities that we keep in, +but this is no longer necessary see Note [Non-idempotent inert substitution]. \begin{code} data SPSolveResult = SPCantSolve @@ -493,21 +453,21 @@ data SPSolveResult = SPCantSolve -- touchable unification variable. -- See Note [Touchables and givens] trySpontaneousSolve :: WorkItem -> TcS SPSolveResult -trySpontaneousSolve workItem@(CTyEqCan { cc_id = eqv, cc_flavor = gw +trySpontaneousSolve workItem@(CTyEqCan { cc_ev = gw , cc_tyvar = tv1, cc_rhs = xi, cc_depth = d }) - | isGivenOrSolved gw + | isGiven gw = return SPCantSolve | Just tv2 <- tcGetTyVar_maybe xi = do { tch1 <- isTouchableMetaTyVar tv1 ; tch2 <- isTouchableMetaTyVar tv2 ; case (tch1, tch2) of - (True, True) -> trySpontaneousEqTwoWay d eqv gw tv1 tv2 - (True, False) -> trySpontaneousEqOneWay d eqv gw tv1 xi - (False, True) -> trySpontaneousEqOneWay d eqv gw tv2 (mkTyVarTy tv1) + (True, True) -> trySpontaneousEqTwoWay d gw tv1 tv2 + (True, False) -> trySpontaneousEqOneWay d gw tv1 xi + (False, True) -> trySpontaneousEqOneWay d gw tv2 (mkTyVarTy tv1) _ -> return SPCantSolve } | otherwise = do { tch1 <- isTouchableMetaTyVar tv1 - ; if tch1 then trySpontaneousEqOneWay d eqv gw tv1 xi + ; if tch1 then trySpontaneousEqOneWay d gw tv1 xi else do { traceTcS "Untouchable LHS, can't spontaneously solve workitem:" $ ppr workItem ; return SPCantSolve } @@ -520,29 +480,28 @@ trySpontaneousSolve _ = return SPCantSolve ---------------- trySpontaneousEqOneWay :: SubGoalDepth - -> EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult + -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult -- tv is a MetaTyVar, not untouchable -trySpontaneousEqOneWay d eqv gw tv xi +trySpontaneousEqOneWay d gw tv xi | not (isSigTyVar tv) || isTyVarTy xi - = solveWithIdentity d eqv gw tv xi + = solveWithIdentity d gw tv xi | otherwise -- Still can't solve, sig tyvar and non-variable rhs = return SPCantSolve ---------------- trySpontaneousEqTwoWay :: SubGoalDepth - -> EqVar -> CtFlavor -> TcTyVar -> TcTyVar -> TcS SPSolveResult + -> CtEvidence -> TcTyVar -> TcTyVar -> TcS SPSolveResult -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here -trySpontaneousEqTwoWay d eqv gw tv1 tv2 - = do { let k1_sub_k2 = k1 `isSubKind` k2 +trySpontaneousEqTwoWay d gw tv1 tv2 + = do { let k1_sub_k2 = k1 `tcIsSubKind` k2 ; if k1_sub_k2 && nicer_to_update_tv2 - then solveWithIdentity d eqv gw tv2 (mkTyVarTy tv1) - else solveWithIdentity d eqv gw tv1 (mkTyVarTy tv2) } + then solveWithIdentity d gw tv2 (mkTyVarTy tv1) + else solveWithIdentity d gw tv1 (mkTyVarTy tv2) } where k1 = tyVarKind tv1 k2 = tyVarKind tv2 nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2) - \end{code} Note [Kind errors] @@ -618,33 +577,46 @@ unification variables as RHS of type family equations: F xis ~ alpha. ---------------- solveWithIdentity :: SubGoalDepth - -> EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult + -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult -- Solve with the identity coercion -- Precondition: kind(xi) is a sub-kind of kind(tv) --- Precondition: CtFlavor is Wanted or Derived +-- Precondition: CtEvidence is Wanted or Derived -- See [New Wanted Superclass Work] to see why solveWithIdentity -- must work for Derived as well as Wanted -- Returns: workItem where -- workItem = the new Given constraint -solveWithIdentity d eqv wd tv xi - = do { traceTcS "Sneaky unification:" $ - vcat [text "Coercion variable: " <+> ppr eqv <+> ppr wd, - text "Coercion: " <+> pprEq (mkTyVarTy tv) xi, - text "Left Kind is : " <+> ppr (typeKind (mkTyVarTy tv)), - text "Right Kind is : " <+> ppr (typeKind xi) - ] - - ; setWantedTyBind tv xi - ; let refl_xi = mkTcReflCo xi - - ; let solved_fl = mkSolvedFlavor wd UnkSkol (EvCoercion refl_xi) - ; (_,eqv_given) <- newGivenEqVar solved_fl (mkTyVarTy tv) xi refl_xi - - ; when (isWanted wd) $ do { _ <- setEqBind eqv refl_xi wd; return () } - -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)' - ; return $ SPSolved (CTyEqCan { cc_id = eqv_given - , cc_flavor = solved_fl - , cc_tyvar = tv, cc_rhs = xi, cc_depth = d }) } +-- +-- NB: No need for an occurs check here, because solveWithIdentity always +-- arises from a CTyEqCan, a *canonical* constraint. Its invariants +-- say that in (a ~ xi), the type variable a does not appear in xi. +-- See TcRnTypes.Ct invariants. +solveWithIdentity d wd tv xi + = do { let tv_ty = mkTyVarTy tv + ; traceTcS "Sneaky unification:" $ + vcat [text "Constraint:" <+> ppr wd, + text "Coercion:" <+> pprEq tv_ty xi, + text "Left Kind is:" <+> ppr (typeKind tv_ty), + text "Right Kind is:" <+> ppr (typeKind xi) ] + + ; let xi' = defaultKind xi + -- We only instantiate kind unification variables + -- with simple kinds like *, not OpenKind or ArgKind + -- cf TcUnify.uUnboundKVar + + ; setWantedTyBind tv xi' + ; let refl_evtm = EvCoercion (mkTcReflCo xi') + refl_pred = mkTcEqPred tv_ty xi' + + ; when (isWanted wd) $ + setEvBind (ctev_evar wd) refl_evtm + + ; let given_fl = Given { ctev_gloc = mkGivenLoc (ctev_wloc wd) UnkSkol + , ctev_pred = refl_pred + , ctev_evtm = refl_evtm } + + ; return $ + SPSolved (CTyEqCan { cc_ev = given_fl + , cc_tyvar = tv, cc_rhs = xi', cc_depth = d }) } \end{code} @@ -654,6 +626,8 @@ solveWithIdentity d eqv wd tv xi * * ********************************************************************************* +Note [ + Note [The Solver Invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We always add Givens first. So you might think that the solver has @@ -680,7 +654,7 @@ or, equivalently, then there is no reaction \begin{code} --- Interaction result of WorkItem <~> AtomicInert +-- Interaction result of WorkItem <~> Ct data InteractResult = IRWorkItemConsumed { ir_fire :: String } @@ -703,21 +677,19 @@ interactWithInertsStage :: WorkItem -> TcS StopOrContinue -- Precondition: if the workitem is a CTyEqCan then it will not be able to -- react with anything at this stage. interactWithInertsStage wi - = do { ctxt <- getTcSContext - ; if simplEqsOnly ctxt then - return (ContinueWith wi) - else - extractRelevantInerts wi >>= - foldlBagM interact_next (ContinueWith wi) } + = do { traceTcS "interactWithInerts" $ text "workitem = " <+> ppr wi + ; rels <- extractRelevantInerts wi + ; traceTcS "relevant inerts are:" $ ppr rels + ; foldlBagM interact_next (ContinueWith wi) rels } where interact_next Stop atomic_inert = updInertSetTcS atomic_inert >> return Stop interact_next (ContinueWith wi) atomic_inert = do { ir <- doInteractWithInert atomic_inert wi ; let mk_msg rule keep_doc - = text rule <+> keep_doc - <+> vcat [ ptext (sLit "Inert =") <+> ppr atomic_inert - , ptext (sLit "Work =") <+> ppr wi ] + = vcat [ text rule <+> keep_doc + , ptext (sLit "InertItem =") <+> ppr atomic_inert + , ptext (sLit "WorkItem =") <+> ppr wi ] ; case ir of IRWorkItemConsumed { ir_fire = rule } -> do { bumpStepCountTcS @@ -734,15 +706,17 @@ interactWithInertsStage wi -> do { updInertSetTcS atomic_inert ; return (ContinueWith wi) } } - + +\end{code} + +\begin{code} -------------------------------------------- -data WhichComesFromInert = LeftComesFromInert | RightComesFromInert doInteractWithInert :: Ct -> Ct -> TcS InteractResult -- Identical class constraints. doInteractWithInert - inertItem@(CDictCan { cc_id = d1, cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 }) - workItem@(CDictCan { cc_id = _d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 }) + inertItem@(CDictCan { cc_ev = fl1, cc_class = cls1, cc_tyargs = tys1 }) + workItem@(CDictCan { cc_ev = fl2, cc_class = cls2, cc_tyargs = tys2 }) | cls1 == cls2 = do { let pty1 = mkClassPred cls1 tys1 @@ -752,162 +726,206 @@ doInteractWithInert ; traceTcS "doInteractWithInert" (vcat [ text "inertItem = " <+> ppr inertItem , text "workItem = " <+> ppr workItem ]) - - ; any_fundeps - <- if isGivenOrSolved fl1 && isGivenOrSolved fl2 then return Nothing - -- NB: We don't create fds for given (and even solved), have not seen a useful - -- situation for these and even if we did we'd have to be very careful to only - -- create Derived's and not Wanteds. - - else do { let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc - ; wloc <- get_workitem_wloc fl2 - ; rewriteWithFunDeps fd_eqns tys2 wloc } - -- See Note [Efficient Orientation], [When improvement happens] - + + ; let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc + ; any_fundeps <- rewriteWithFunDeps fd_eqns tys2 fl2 + -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok + -- NB: We do create FDs for given to report insoluble equations that arise + -- from pairs of Givens, and also because of floating when we approximate + -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs + -- Also see Note [When improvement happens] + -- + ; case any_fundeps of -- No Functional Dependencies Nothing - | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem + | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" fl1 workItem | otherwise -> irKeepGoing "NOP" -- Actual Functional Dependencies - Just (_rewritten_tys2,_cos2,fd_work) + Just (_rewritten_tys2, fd_work) -- Standard thing: create derived fds and keep on going. Importantly we don't -- throw workitem back in the worklist because this can cause loops. See #5236. -> do { emitFDWorkAsDerived fd_work (cc_depth workItem) ; irKeepGoing "Cls/Cls (new fundeps)" } -- Just keep going without droping the inert } - where get_workitem_wloc (Wanted wl) = return wl - get_workitem_wloc (Derived wl) = return wl - get_workitem_wloc (Given {}) = pprPanic "Unexpected given workitem!" $ - vcat [ text "Work item =" <+> ppr workItem - , text "Inert item=" <+> ppr inertItem - ] - --- Two pieces of irreducible evidence: if their types are *exactly identical* we can --- rewrite them. We can never improve using this: if we want ty1 :: Constraint and have --- ty2 :: Constraint it clearly does not mean that (ty1 ~ ty2) -doInteractWithInert (CIrredEvCan { cc_id = id1, cc_flavor = ifl, cc_ty = ty1 }) + +-- Two pieces of irreducible evidence: if their types are *exactly identical* +-- we can rewrite them. We can never improve using this: +-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not +-- mean that (ty1 ~ ty2) +doInteractWithInert (CIrredEvCan { cc_ev = ifl, cc_ty = ty1 }) workItem@(CIrredEvCan { cc_ty = ty2 }) | ty1 `eqType` ty2 - = solveOneFromTheOther "Irred/Irred" (EvId id1,ifl) workItem - --- Two implicit parameter constraints. If the names are the same, --- but their types are not, we generate a wanted type equality --- that equates the type (this is "improvement"). --- However, we don't actually need the coercion evidence, --- so we just generate a fresh coercion variable that isn't used anywhere. -doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 }) - workItem@(CIPCan { cc_flavor = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 }) - | nm1 == nm2 && isGivenOrSolved wfl && isGivenOrSolved ifl - = -- See Note [Overriding implicit parameters] - -- Dump the inert item, override totally with the new one - -- Do not require type equality - -- For example, given let ?x::Int = 3 in let ?x::Bool = True in ... - -- we must *override* the outer one with the inner one - irInertConsumed "IP/IP (override inert)" - - | nm1 == nm2 && ty1 `eqType` ty2 - = solveOneFromTheOther "IP/IP" (EvId id1,ifl) workItem - - | nm1 == nm2 - = -- See Note [When improvement happens] - do { let flav = Wanted (combineCtLoc ifl wfl) - ; eqv <- newEqVar flav ty2 ty1 -- See Note [Efficient Orientation] - ; when (isNewEvVar eqv) $ - (let ct = CNonCanonical { cc_id = evc_the_evvar eqv - , cc_flavor = flav - , cc_depth = cc_depth workItem } - in updWorkListTcS (extendWorkListEq ct)) - - ; case wfl of - Given {} -> pprPanic "Unexpected given IP" (ppr workItem) - Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem) - Wanted {} -> - do { _ <- setEvBind (cc_id workItem) - (mkEvCast id1 (mkTcSymCo (mkTcTyConAppCo (ipTyCon nm1) [mkTcCoVarCo (evc_the_evvar eqv)]))) wfl - ; irWorkItemConsumed "IP/IP (solved by rewriting)" } } - -doInteractWithInert (CFunEqCan { cc_id = eqv1, cc_flavor = fl1, cc_fun = tc1 - , cc_tyargs = args1, cc_rhs = xi1, cc_depth = d1 }) - (CFunEqCan { cc_id = eqv2, cc_flavor = fl2, cc_fun = tc2 - , cc_tyargs = args2, cc_rhs = xi2, cc_depth = d2 }) + = solveOneFromTheOther "Irred/Irred" ifl workItem + +doInteractWithInert ii@(CFunEqCan { cc_ev = fl1, cc_fun = tc1 + , cc_tyargs = args1, cc_rhs = xi1, cc_depth = d1 }) + wi@(CFunEqCan { cc_ev = fl2, cc_fun = tc2 + , cc_tyargs = args2, cc_rhs = xi2, cc_depth = d2 }) +{- ToDo: Check with Dimitrios | lhss_match - , Just (GivenSolved {}) <- isGiven_maybe fl1 -- Inert is solved and we can simply ignore it - -- when workitem is given/solved - , isGivenOrSolved fl2 + , isSolved fl1 -- Inert is solved and we can simply ignore it + -- when workitem is given/solved + , isGiven fl2 = irInertConsumed "FunEq/FunEq" - | lhss_match - , Just (GivenSolved {}) <- isGiven_maybe fl2 -- Workitem is solved and we can ignore it when - -- the inert is given/solved - , isGivenOrSolved fl1 + | lhss_match + , isSolved fl2 -- Workitem is solved and we can ignore it when + -- the inert is given/solved + , isGiven fl1 = irWorkItemConsumed "FunEq/FunEq" +-} + | fl1 `canSolve` fl2 && lhss_match - = do { rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,d2,fl2,xi2) + = do { traceTcS "interact with inerts: FunEq/FunEq" $ + vcat [ text "workItem =" <+> ppr wi + , text "inertItem=" <+> ppr ii ] + + ; let xev = XEvTerm xcomp xdecomp + -- xcomp : [(xi2 ~ xi1)] -> (F args ~ xi2) + xcomp [x] = EvCoercion (co1 `mkTcTransCo` mk_sym_co x) + xcomp _ = panic "No more goals!" + -- xdecomp : (F args ~ xi2) -> [(xi2 ~ xi1)] + xdecomp x = [EvCoercion (mk_sym_co x `mkTcTransCo` co1)] + + ; ctevs <- xCtFlavor_cache False fl2 [mkTcEqPred xi2 xi1] xev + -- Why not simply xCtFlavor? See Note [Cache-caused loops] + -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation] + ; add_to_work d2 ctevs ; irWorkItemConsumed "FunEq/FunEq" } | fl2 `canSolve` fl1 && lhss_match - = do { rewriteEqLHS RightComesFromInert (eqv2,xi2) (eqv1,d1,fl1,xi1) + = do { traceTcS "interact with inerts: FunEq/FunEq" $ + vcat [ text "workItem =" <+> ppr wi + , text "inertItem=" <+> ppr ii ] + + ; let xev = XEvTerm xcomp xdecomp + -- xcomp : [(xi2 ~ xi1)] -> [(F args ~ xi1)] + xcomp [x] = EvCoercion (co2 `mkTcTransCo` evTermCoercion x) + xcomp _ = panic "No more goals!" + -- xdecomp : (F args ~ xi1) -> [(xi2 ~ xi1)] + xdecomp x = [EvCoercion (mkTcSymCo co2 `mkTcTransCo` evTermCoercion x)] + + ; ctevs <- xCtFlavor_cache False fl1 [mkTcEqPred xi2 xi1] xev + -- Why not simply xCtFlavor? See Note [Cache-caused loops] + -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation] + + ; add_to_work d1 ctevs ; irInertConsumed "FunEq/FunEq"} where + add_to_work d [ctev] = updWorkListTcS $ extendWorkListEq $ + CNonCanonical {cc_ev = ctev, cc_depth = d} + add_to_work _ _ = return () + lhss_match = tc1 == tc2 && eqTypes args1 args2 + co1 = evTermCoercion $ ctEvTerm fl1 + co2 = evTermCoercion $ ctEvTerm fl2 + mk_sym_co x = mkTcSymCo (evTermCoercion x) + +doInteractWithInert _ _ = irKeepGoing "NOP" + +\end{code} + + +Note [Shadowing of Implicit Parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider the following example: + +f :: (?x :: Char) => Char +f = let ?x = 'a' in ?x + +The "let ?x = ..." generates an implication constraint of the form: + +?x :: Char => ?x :: Char + +Furthermore, the signature for `f` also generates an implication +constraint, so we end up with the following nested implication: + +?x :: Char => (?x :: Char => ?x :: Char) + +Note that the wanted (?x :: Char) constraint may be solved in +two incompatible ways: either by using the parameter from the +signature, or by using the local definition. Our intention is +that the local definition should "shadow" the parameter of the +signature, and we implement this as follows: when we add a new +given implicit parameter to the inert set, it replaces any existing +givens for the same implicit parameter. + +This works for the normal cases but it has an odd side effect +in some pathological programs like this: + +-- This is accepted, the second parameter shadows +f1 :: (?x :: Int, ?x :: Char) => Char +f1 = ?x + +-- This is rejected, the second parameter shadows +f2 :: (?x :: Int, ?x :: Char) => Int +f2 = ?x + +Both of these are actually wrong: when we try to use either one, +we'll get two incompatible wnated constraints (?x :: Int, ?x :: Char), +which would lead to an error. + +I can think of two ways to fix this: + + 1. Simply disallow multiple constratits for the same implicit + parameter---this is never useful, and it can be detected completely + syntactically. + + 2. Move the shadowing machinery to the location where we nest + implications, and add some code here that will produce an + error if we get multiple givens for the same implicit parameter. + + -doInteractWithInert _ _ = irKeepGoing "NOP" -rewriteEqLHS :: WhichComesFromInert -> (EqVar,Xi) -> (EqVar,SubGoalDepth,CtFlavor,Xi) -> TcS () --- Used to ineract two equalities of the following form: --- First Equality: co1: (XXX ~ xi1) --- Second Equality: cv2: (XXX ~ xi2) --- Where the cv1 `canRewrite` cv2 equality --- We have an option of creating new work (xi1 ~ xi2) OR (xi2 ~ xi1), --- See Note [Efficient Orientation] for that -rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,d,gw,xi2) - = do { delCachedEvVar eqv2 gw -- Similarly to canonicalization! - ; evc <- newEqVar gw xi2 xi1 - ; let eqv2' = evc_the_evvar evc - ; gw' <- case gw of - Wanted {} - -> setEqBind eqv2 - (mkTcCoVarCo eqv1 `mkTcTransCo` mkTcSymCo (mkTcCoVarCo eqv2')) gw - Given {} - -> setEqBind eqv2' - (mkTcSymCo (mkTcCoVarCo eqv2) `mkTcTransCo` mkTcCoVarCo eqv1) gw - Derived {} - -> return gw - ; when (isNewEvVar evc) $ - updWorkListTcS (extendWorkListEq (CNonCanonical { cc_id = eqv2' - , cc_flavor = gw' - , cc_depth = d } ) ) } - -rewriteEqLHS RightComesFromInert (eqv1,xi1) (eqv2,d,gw,xi2) - = do { delCachedEvVar eqv2 gw -- Similarly to canonicalization! - ; evc <- newEqVar gw xi1 xi2 - ; let eqv2' = evc_the_evvar evc - ; gw' <- case gw of - Wanted {} - -> setEqBind eqv2 - (mkTcCoVarCo eqv1 `mkTcTransCo` mkTcCoVarCo eqv2') gw - Given {} - -> setEqBind eqv2' - (mkTcSymCo (mkTcCoVarCo eqv1) `mkTcTransCo` mkTcCoVarCo eqv2) gw - Derived {} - -> return gw - - ; when (isNewEvVar evc) $ - updWorkListTcS (extendWorkListEq (CNonCanonical { cc_id = eqv2' - , cc_flavor = gw' - , cc_depth = d } ) ) } - -solveOneFromTheOther :: String -- Info - -> (EvTerm, CtFlavor) -- Inert + + + +Note [Cache-caused loops] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very dangerous to cache a rewritten wanted family equation as 'solved' in our +solved cache (which is the default behaviour or xCtFlavor), because the interaction +may not be contributing towards a solution. Here is an example: + +Initial inert set: + [W] g1 : F a ~ beta1 +Work item: + [W] g2 : F a ~ beta2 +The work item will react with the inert yielding the _same_ inert set plus: + i) Will set g2 := g1 `cast` g3 + ii) Will add to our solved cache that [S] g2 : F a ~ beta2 + iii) Will emit [W] g3 : beta1 ~ beta2 +Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 +and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it +will set + g1 := g ; sym g3 +and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but +remember that we have this in our solved cache, and it is ... g2! In short we +created the evidence loop: + + g2 := g1 ; g3 + g3 := refl + g1 := g2 ; sym g3 + +To avoid this situation we do not cache as solved any workitems (or inert) +which did not really made a 'step' towards proving some goal. Solved's are +just an optimization so we don't lose anything in terms of completeness of +solving. + +\begin{code} + +solveOneFromTheOther :: String -- Info + -> CtEvidence -- Inert -> Ct -- WorkItem -> TcS InteractResult -- Preconditions: -- 1) inert and work item represent evidence for the /same/ predicate -- 2) ip/class/irred evidence (no coercions) only -solveOneFromTheOther info (ev_term,ifl) workItem +solveOneFromTheOther info ifl workItem | isDerived wfl = irWorkItemConsumed ("Solved[DW] " ++ info) @@ -916,21 +934,23 @@ solveOneFromTheOther info (ev_term,ifl) workItem -- so it's safe to continue on from this point = irInertConsumed ("Solved[DI] " ++ info) - | Just (GivenSolved {}) <- isGiven_maybe ifl, isGivenOrSolved wfl +{- ToDo: Check with Dimitrios + | isSolved ifl, isGiven wfl -- Same if the inert is a GivenSolved -- just get rid of it = irInertConsumed ("Solved[SI] " ++ info) +-} | otherwise = ASSERT( ifl `canSolve` wfl ) -- Because of Note [The Solver Invariant], plus Derived dealt with - do { when (isWanted wfl) $ do { _ <- setEvBind wid ev_term wfl; return () } + do { case wfl of + Wanted { ctev_evar = ev_id } -> setEvBind ev_id (ctEvTerm ifl) + _ -> return () -- Overwrite the binding, if one exists -- If both are Given, we already have evidence; no need to duplicate ; irWorkItemConsumed ("Solved " ++ info) } where - wfl = cc_flavor workItem - wid = cc_id workItem - + wfl = cc_ev workItem \end{code} Note [Superclasses and recursive dictionaries] @@ -1299,46 +1319,47 @@ now!). \begin{code} rewriteWithFunDeps :: [Equation] -> [Xi] - -> WantedLoc - -> TcS (Maybe ([Xi], [TcCoercion], [(EvVar,WantedLoc)])) + -> CtEvidence + -> TcS (Maybe ([Xi], [CtEvidence])) -- Not quite a WantedEvVar unfortunately -- Because our intention could be to make -- it derived at the end of the day -- NB: The flavor of the returned EvVars will be decided by the caller -- Post: returns no trivial equalities (identities) and all EvVars returned are fresh -rewriteWithFunDeps eqn_pred_locs xis wloc +rewriteWithFunDeps eqn_pred_locs xis fl = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs - ; let fd_ev_pos :: [(Int,(EqVar,WantedLoc))] + ; let fd_ev_pos :: [(Int,CtEvidence)] fd_ev_pos = concat fd_ev_poss - (rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis) + rewritten_xis = rewriteDictParams fd_ev_pos xis ; if null fd_ev_pos then return Nothing - else return (Just (rewritten_xis, cos, map snd fd_ev_pos)) } + else return (Just (rewritten_xis, map snd fd_ev_pos)) } + where wloc | Given { ctev_gloc = gl } <- fl + = setCtLocOrigin gl FunDepOrigin + | otherwise + = ctev_wloc fl -instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))] +instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,CtEvidence)] -- Post: Returns the position index as well as the corresponding FunDep equality -instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs +instFunDepEqn wl (FDEqn { fd_qtvs = tvs, fd_eqs = eqs , fd_pred1 = d1, fd_pred2 = d2 }) - = do { let tvs = varSetElems qtvs - ; tvs' <- mapM instFlexiTcS tvs -- IA0_TODO: we might need to do kind substitution - ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs') + = do { (subst, _) <- instFlexiTcS tvs -- Takes account of kind substitution ; foldM (do_one subst) [] eqs } where do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 }) = let sty1 = Type.substTy subst ty1 sty2 = Type.substTy subst ty2 in if eqType sty1 sty2 then return ievs -- Return no trivial equalities - else do { eqv <- newEqVar (Derived wl) sty1 sty2 -- Create derived or cached by deriveds - ; let wl' = push_ctx wl - ; if isNewEvVar eqv then - return $ (i,(evc_the_evvar eqv,wl')):ievs - else -- We are eventually going to emit FD work back in the work list so + else do { mb_eqv <- newDerived (push_ctx wl) (mkTcEqPred sty1 sty2) + ; case mb_eqv of + Just ctev -> return $ (i,ctev):ievs + Nothing -> return ievs } + -- We are eventually going to emit FD work back in the work list so -- it is important that we only return the /freshly created/ and not -- some existing equality! - return ievs } - push_ctx :: WantedLoc -> WantedLoc push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc + mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc) mkEqnMsg (pred1,from1) (pred2,from2) tidy_env @@ -1351,34 +1372,30 @@ mkEqnMsg (pred1,from1) (pred2,from2) tidy_env nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])] ; return (tidy_env, msg) } -rewriteDictParams :: [(Int,(EqVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty) - -> [Type] -- A sequence of types: tys - -> [(Type, TcCoercion)] -- Returns: [(ty', co : ty' ~ ty)] +rewriteDictParams :: [(Int,CtEvidence)] -- A set of coercions : (pos, ty' ~ ty) + -> [Type] -- A sequence of types: tys + -> [Type] rewriteDictParams param_eqs tys = zipWith do_one tys [0..] where - do_one :: Type -> Int -> (Type, TcCoercion) + do_one :: Type -> Int -> Type do_one ty n = case lookup n param_eqs of - Just wev -> (get_fst_ty wev, mkTcCoVarCo (fst wev)) - Nothing -> (ty, mkTcReflCo ty) -- Identity + Just wev -> get_fst_ty wev + Nothing -> ty - get_fst_ty (wev,_wloc) - | Just (ty1, _) <- getEqPredTys_maybe (evVarPred wev ) + get_fst_ty ctev + | Just (ty1, _) <- getEqPredTys_maybe (ctEvPred ctev) = ty1 | otherwise = panic "rewriteDictParams: non equality fundep!?" -emitFDWorkAsDerived :: [(EvVar,WantedLoc)] +emitFDWorkAsDerived :: [CtEvidence] -- All Derived -> SubGoalDepth -> TcS () emitFDWorkAsDerived evlocs d - = updWorkListTcS $ appendWorkListEqs fd_cts - where fd_cts = map mk_fd_ct evlocs - mk_fd_ct (v,wl) = CNonCanonical { cc_id = v - , cc_flavor = Derived wl - , cc_depth = d } - - + = updWorkListTcS $ appendWorkListEqs (map mk_fd_ct evlocs) + where + mk_fd_ct der_ev = CNonCanonical { cc_ev = der_ev, cc_depth = d } \end{code} @@ -1400,19 +1417,15 @@ topReactionsStage workItem tryTopReact :: WorkItem -> TcS StopOrContinue tryTopReact wi = do { inerts <- getTcSInerts - ; ctxt <- getTcSContext - ; if simplEqsOnly ctxt then return (ContinueWith wi) -- or Stop? - else - do { tir <- doTopReact inerts wi - ; case tir of - NoTopInt - -> return (ContinueWith wi) - SomeTopInt rule what_next - -> do { bumpStepCountTcS - ; traceFireTcS (cc_depth wi) $ - ptext (sLit "Top react:") <+> text rule - ; return what_next } - } } + ; tir <- doTopReact inerts wi + ; case tir of + NoTopInt -> return (ContinueWith wi) + SomeTopInt rule what_next + -> do { bumpStepCountTcS + ; traceFireTcS (cc_depth wi) $ + vcat [ ptext (sLit "Top react:") <+> text rule + , text "WorkItem =" <+> ppr wi ] + ; return what_next } } data TopInteractResult = NoTopInt @@ -1420,154 +1433,166 @@ data TopInteractResult doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult - --- The work item does not react with the inert set, so try interaction --- with top-level instances --- NB: The place to add superclasses in *not* --- in doTopReact stage. Instead superclasses are added in the worklist --- as part of the canonicalisation process. See Note [Adding superclasses]. - - --- Given dictionary --- See Note [Given constraint that matches an instance declaration] -doTopReact _inerts (CDictCan { cc_flavor = Given {} }) - = return NoTopInt -- NB: Superclasses already added since it's canonical - --- Derived dictionary: just look for functional dependencies -doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc - , cc_class = cls, cc_tyargs = xis }) - = do { instEnvs <- getInstEnvs - ; let fd_eqns = improveFromInstEnv instEnvs - (mkClassPred cls xis, pprArisingAt loc) - ; m <- rewriteWithFunDeps fd_eqns xis loc - ; case m of - Nothing -> return NoTopInt - Just (xis',_,fd_work) -> - let workItem' = workItem { cc_tyargs = xis' } - -- Deriveds are not supposed to have identity (cc_id is unused!) - in do { emitFDWorkAsDerived fd_work (cc_depth workItem) - ; return $ - SomeTopInt { tir_rule = "Derived Cls fundeps" - , tir_new_item = ContinueWith workItem' } } - } - --- Wanted dictionary -doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) - , cc_id = dict_id - , cc_class = cls, cc_tyargs = xis - , cc_depth = depth }) - -- See Note [MATCHING-SYNONYMS] +-- The work item does not react with the inert set, so try interaction with top-level +-- instances. Note: +-- +-- (a) The place to add superclasses in not here in doTopReact stage. +-- Instead superclasses are added in the worklist as part of the +-- canonicalization process. See Note [Adding superclasses]. +-- +-- (b) See Note [Given constraint that matches an instance declaration] +-- for some design decisions for given dictionaries. + +doTopReact inerts workItem@(CDictCan { cc_ev = fl + , cc_class = cls, cc_tyargs = xis, cc_depth = depth }) = do { traceTcS "doTopReact" (ppr workItem) - ; instEnvs <- getInstEnvs - ; let fd_eqns = improveFromInstEnv instEnvs - (mkClassPred cls xis, pprArisingAt loc) - - ; any_fundeps <- rewriteWithFunDeps fd_eqns xis loc - ; case any_fundeps of - -- No Functional Dependencies - Nothing -> - do { lkup_inst_res <- matchClassInst inerts cls xis loc - ; case lkup_inst_res of - GenInst wtvs ev_term - -> doSolveFromInstance wtvs ev_term - NoInstance - -> return NoTopInt - } - -- Actual Functional Dependencies - Just (_xis',_cos,fd_work) -> + ; instEnvs <- getInstEnvs + ; let fd_eqns = improveFromInstEnv instEnvs (mkClassPred cls xis, arising_sdoc) + + ; m <- rewriteWithFunDeps fd_eqns xis fl + ; case m of + Just (_xis',fd_work) -> do { emitFDWorkAsDerived fd_work (cc_depth workItem) ; return SomeTopInt { tir_rule = "Dict/Top (fundeps)" - , tir_new_item = ContinueWith workItem } } } - - where doSolveFromInstance :: [EvVar] -> EvTerm -> TcS TopInteractResult - -- Precondition: evidence term matches the predicate of cc_id of workItem - doSolveFromInstance evs ev_term - | null evs - = do { traceTcS "doTopReact/found nullary instance for" (ppr dict_id) - ; _ <- setEvBind dict_id ev_term fl - ; return $ - SomeTopInt { tir_rule = "Dict/Top (solved, no new work)" - , tir_new_item = Stop } } -- Don't put him in the inerts - | otherwise - = do { traceTcS "doTopReact/found non-nullary instance for" (ppr dict_id) - ; _ <- setEvBind dict_id ev_term fl - -- Solved and new wanted work produced, you may cache the - -- (tentatively solved) dictionary as Solved given. --- ; let _solved = workItem { cc_flavor = solved_fl } --- solved_fl = mkSolvedFlavor fl UnkSkol - ; let mk_new_wanted ev - = CNonCanonical { cc_id = ev, cc_flavor = fl - , cc_depth = depth + 1 } - ; updWorkListTcS (appendWorkListCt (map mk_new_wanted evs)) - ; return $ - SomeTopInt { tir_rule = "Dict/Top (solved, more work)" - , tir_new_item = Stop } - } --- , tir_new_item = ContinueWith solved } } -- Cache in inerts the Solved item - --- Type functions -doTopReact _inerts (CFunEqCan { cc_flavor = fl }) - | Just (GivenSolved {}) <- isGiven_maybe fl - = return NoTopInt -- If Solved, no more interactions should happen + , tir_new_item = ContinueWith workItem } } + Nothing + | isWanted fl + -> do { lkup_inst_res <- matchClassInst inerts cls xis (getWantedLoc fl) + ; case lkup_inst_res of + GenInst wtvs ev_term -> + addToSolved fl >> doSolveFromInstance wtvs ev_term + NoInstance -> return NoTopInt } + | otherwise + -> return NoTopInt } + where + arising_sdoc + | isGiven fl = pprArisingAt $ getGivenLoc fl + | otherwise = pprArisingAt $ getWantedLoc fl + + dict_id = ctEvId fl + + doSolveFromInstance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult + -- Precondition: evidence term matches the predicate workItem + doSolveFromInstance evs ev_term + | null evs + = do { traceTcS "doTopReact/found nullary instance for" $ + ppr dict_id + ; setEvBind dict_id ev_term + ; return $ + SomeTopInt { tir_rule = "Dict/Top (solved, no new work)" + , tir_new_item = Stop } } + | otherwise + = do { traceTcS "doTopReact/found non-nullary instance for" $ + ppr dict_id + ; setEvBind dict_id ev_term + ; let mk_new_wanted ev + = CNonCanonical { cc_ev = ev + , cc_depth = depth + 1 } + ; updWorkListTcS (appendWorkListCt (map mk_new_wanted evs)) + ; return $ + SomeTopInt { tir_rule = "Dict/Top (solved, more work)" + , tir_new_item = Stop } } + -- Otherwise, it's a Given, Derived, or Wanted -doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl +doTopReact _inerts workItem@(CFunEqCan { cc_ev = fl, cc_depth = d , cc_fun = tc, cc_tyargs = args, cc_rhs = xi }) - = ASSERT (isSynFamilyTyCon tc) -- No associated data families have reached that far + = ASSERT (isSynFamilyTyCon tc) -- No associated data families have reached that far do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS] ; case match_res of Nothing -> return NoTopInt Just (famInst, rep_tys) - -> do { let coe_ax = famInstAxiom famInst - rhs_ty = mkAxInstRHS coe_ax rep_tys - coe = mkTcAxInstCo coe_ax rep_tys - ; case fl of - Wanted {} -> do { evc <- newEqVar fl rhs_ty xi -- Wanted version - ; let eqv' = evc_the_evvar evc - ; let coercion = coe `mkTcTransCo` mkTcCoVarCo eqv' - ; _ <- setEqBind eqv coercion fl - ; when (isNewEvVar evc) $ - (let ct = CNonCanonical { cc_id = eqv' - , cc_flavor = fl - , cc_depth = cc_depth workItem + 1} - in updWorkListTcS (extendWorkListEq ct)) - - ; let _solved = workItem { cc_flavor = solved_fl } - solved_fl = mkSolvedFlavor fl UnkSkol (EvCoercion coercion) - - ; updateFlatCache eqv solved_fl tc args xi WhenSolved - - ; return $ - SomeTopInt { tir_rule = "Fun/Top (solved, more work)" - , tir_new_item = Stop } } - -- , tir_new_item = ContinueWith solved } } - -- Cache in inerts the Solved item - - Given {} -> do { (fl',eqv') <- newGivenEqVar fl xi rhs_ty $ - mkTcSymCo (mkTcCoVarCo eqv) `mkTcTransCo` coe - ; let ct = CNonCanonical { cc_id = eqv' - , cc_flavor = fl' - , cc_depth = cc_depth workItem + 1} - ; updWorkListTcS (extendWorkListEq ct) - ; return $ - SomeTopInt { tir_rule = "Fun/Top (given)" - , tir_new_item = ContinueWith workItem } } - Derived {} -> do { evc <- newEvVar fl (mkEqPred (xi, rhs_ty)) - ; let eqv' = evc_the_evvar evc - ; when (isNewEvVar evc) $ - (let ct = CNonCanonical { cc_id = eqv' - , cc_flavor = fl - , cc_depth = cc_depth workItem + 1 } - in updWorkListTcS (extendWorkListEq ct)) - ; return $ - SomeTopInt { tir_rule = "Fun/Top (derived)" - , tir_new_item = Stop } } - } - } - - + -> do { mb_already_solved <- lkpSolvedFunEqCache (mkTyConApp tc args) + ; traceTcS "doTopReact: Family instance matches" $ + vcat [ text "solved-fun-cache" <+> if isJust mb_already_solved + then text "hit" else text "miss" + , text "workItem =" <+> ppr workItem ] + ; let (coe,rhs_ty) + | Just ctev <- mb_already_solved + , not (isDerived ctev) + = ASSERT( isEqPred (ctEvPred ctev) ) + (evTermCoercion (ctEvTerm ctev), snd (getEqPredTys (ctEvPred ctev))) + | otherwise + = let coe_ax = famInstAxiom famInst + in (mkTcAxInstCo coe_ax rep_tys, + mkAxInstRHS coe_ax rep_tys) + + xdecomp x = [EvCoercion (mkTcSymCo coe `mkTcTransCo` evTermCoercion x)] + xcomp [x] = EvCoercion (coe `mkTcTransCo` evTermCoercion x) + xcomp _ = panic "No more goals!" + + xev = XEvTerm xcomp xdecomp + ; ctevs <- xCtFlavor fl [mkTcEqPred rhs_ty xi] xev + ; case ctevs of + [ctev] -> updWorkListTcS $ extendWorkListEq $ + CNonCanonical { cc_ev = ctev + , cc_depth = d+1 } + ctevs -> -- No subgoal (because it's cached) + ASSERT( null ctevs) return () + + ; unless (isDerived fl) $ + do { addSolvedFunEq fl + ; addToSolved fl } + ; return $ SomeTopInt { tir_rule = "Fun/Top" + , tir_new_item = Stop } } } + -- Any other work item does not react with any top-level equations doTopReact _inerts _workItem = return NoTopInt + + +lkpSolvedFunEqCache :: TcType -> TcS (Maybe CtEvidence) +lkpSolvedFunEqCache fam_head + = do { (_subst,_inscope) <- getInertEqs + ; fun_cache <- getTcSInerts >>= (return . inert_solved_funeqs) + ; traceTcS "lkpFunEqCache" $ vcat [ text "fam_head =" <+> ppr fam_head + , text "funeq cache =" <+> ppr fun_cache ] + ; return (lookupFamHead fun_cache fam_head) } + +{- ToDo; talk to Dimitrios. I have no idea what is happening here + + ; rewrite_cached (lookupFamHead fun_cache fam_head) } +-- The two different calls do not seem to make a significant difference in +-- terms of hit/miss rate for many memory-critical/performance tests but the +-- latter blows up the space on the heap somehow ... It maybe the niFixTvSubst. +-- So, I am simply disabling it for now, until we investigate a bit more. +-- lookupTypeMap_mod subst cc_rhs fam_head (unCtFamHeadMap fun_cache) } + + where rewrite_cached Nothing = return Nothing + rewrite_cached (Just ct@(CFunEqCan { cc_ev = fl, cc_depth = d + , cc_fun = tc, cc_tyargs = xis + , cc_rhs = xi})) + = do { (xis_subst,cos) <- flattenMany d FMFullFlatten fl xis + -- cos :: xis_subst ~ xis + ; (xi_subst,co) <- flatten d FMFullFlatten fl xi + -- co :: xi_subst ~ xi + ; let flat_fam_head = mkTyConApp tc xis_subst + + ; unless (flat_fam_head `eqType` fam_head) $ + pprPanic "lkpFunEqCache" (vcat [ text "Cached (solved) constraint =" <+> ppr ct + , text "Flattened constr. head =" <+> ppr flat_fam_head ]) + ; traceTcS "lkpFunEqCache" $ text "Flattened constr. rhs = " <+> ppr xi_subst + + + ; let new_pty = mkTcEqPred (mkTyConApp tc xis_subst) xi_subst + new_co = mkTcTyConAppCo eqTyCon [ mkTcReflCo (defaultKind $ typeKind xi_subst) + , mkTcTyConAppCo tc cos + , co ] + -- new_co :: (F xis_subst ~ xi_subst) ~ (F xis ~ xi) + -- new_co = (~) <k> (F cos) co + ; new_fl <- rewriteCtFlavor fl new_pty new_co + ; case new_fl of + Nothing + -> return Nothing -- Strange: cached? + Just fl' + -> return $ + Just (CFunEqCan { cc_ev = fl' + , cc_depth = d + , cc_fun = tc + , cc_tyargs = xis_subst + , cc_rhs = xi_subst }) } + rewrite_cached (Just other_ct) + = pprPanic "lkpFunEqCache:not family equation!" $ ppr other_ct +-} \end{code} @@ -1575,7 +1600,7 @@ Note [FunDep and implicit parameter reactions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Currently, our story of interacting two dictionaries (or a dictionary and top-level instances) for functional dependencies, and implicit -paramters, is that we simply produce new wanted equalities. So for example +paramters, is that we simply produce new Derived equalities. So for example class D a b | a -> b where ... Inert: @@ -1584,16 +1609,20 @@ paramters, is that we simply produce new wanted equalities. So for example d2 :w D Int alpha We generate the extra work item - cv :w alpha ~ Bool - where 'cv' is currently unused. However, this new item reacts with d2, + cv :d alpha ~ Bool + where 'cv' is currently unused. However, this new item can perhaps be + spontaneously solved to become given and react with d2, discharging it in favour of a new constraint d2' thus: d2' :w D Int Bool d2 := d2' |> D Int cv Now d2' can be discharged from d1 We could be more aggressive and try to *immediately* solve the dictionary -using those extra equalities. With the same inert set and work item we -might dischard d2 directly: +using those extra equalities, but that requires those equalities to carry +evidence and derived do not carry evidence. + +If that were the case with the same inert set and work item we might dischard +d2 directly: cv :w alpha ~ Bool d2 := d1 |> D Int cv @@ -1614,7 +1643,6 @@ Then it is solvable, but its very hard to detect this on the spot. It's exactly the same with implicit parameters, except that the "aggressive" approach would be much easier to implement. - Note [When improvement happens] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We fire an improvement rule when @@ -1622,15 +1650,11 @@ We fire an improvement rule when * Two constraints match (modulo the fundep) e.g. C t1 t2, C t1 t3 where C a b | a->b The two match because the first arg is identical - - * At least one is not Given. If they are both given, we don't fire - the reaction because we have no way of constructing evidence for a - new equality nor does it seem right to create a new wanted goal - (because the goal will most likely contain untouchables, which - can't be solved anyway)! -Note that we *do* fire the improvement if one is Given and one is Derived. -The latter can be a superclass of a wanted goal. Example (tcfail138) +Note that we *do* fire the improvement if one is Given and one is Derived (e.g. a +superclass of a Wanted goal) or if both are Given. + +Example (tcfail138) class L a b | a -> b class (G a, L a b) => C a b @@ -1646,6 +1670,9 @@ Use the instance decl to get The (C a b') is inert, so we generate its Derived superclasses (L a b'), and now we need improvement between that derived superclass an the Given (L a b) +Test typecheck/should_fail/FDsFromGivens also shows why it's a good idea to +emit Derived FDs for givens as well. + Note [Overriding implicit parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1770,56 +1797,69 @@ NB: The desugarer needs be more clever to deal with equalities \begin{code} data LookupInstResult = NoInstance - | GenInst [EvVar] EvTerm + | GenInst [CtEvidence] EvTerm matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult + +matchClassInst _ clas [ _, ty ] _ + | className clas == singIClassName + , Just n <- isNumLitTy ty = return $ GenInst [] $ EvLit $ EvNum n + + | className clas == singIClassName + , Just s <- isStrLitTy ty = return $ GenInst [] $ EvLit $ EvStr s + + matchClassInst inerts clas tys loc - = do { let pred = mkClassPred clas tys + = do { dflags <- getDynFlags + ; let pred = mkClassPred clas tys + incoherent_ok = xopt Opt_IncoherentInstances dflags ; mb_result <- matchClass clas tys ; untch <- getUntouchables + ; traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr pred + , text "inerts=" <+> ppr inerts + , text "untouchables=" <+> ppr untch ] ; case mb_result of MatchInstNo -> return NoInstance MatchInstMany -> return NoInstance -- defer any reactions of a multitude until -- we learn more about the reagent MatchInstSingle (_,_) - | given_overlap untch -> - do { traceTcS "Delaying instance application" $ + | not incoherent_ok && given_overlap untch + -> -- see Note [Instance and Given overlap] + do { traceTcS "Delaying instance application" $ vcat [ text "Workitem=" <+> pprType (mkClassPred clas tys) , text "Relevant given dictionaries=" <+> ppr givens_for_this_clas ] - ; return NoInstance -- see Note [Instance and Given overlap] + ; return NoInstance } MatchInstSingle (dfun_id, mb_inst_tys) -> do { checkWellStagedDFun pred dfun_id loc - -- It's possible that not all the tyvars are in - -- the substitution, tenv. For example: - -- instance C X a => D X where ... - -- (presumably there's a functional dependency in class C) - -- Hence mb_inst_tys :: Either TyVar TcType + -- mb_inst_tys :: Maybe TcType + -- See Note [DFunInstType: instantiating types] in InstEnv - ; tys <- instDFunTypes mb_inst_tys - ; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys) + ; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys + ; let (theta, _) = tcSplitPhiTy dfun_phi ; if null theta then return (GenInst [] (EvDFunApp dfun_id tys [])) else do - { evc_vars <- instDFunConstraints theta (Wanted loc) - ; let ev_vars = map evc_the_evvar evc_vars - new_ev_vars = [evc_the_evvar evc | evc <- evc_vars, isNewEvVar evc] + { evc_vars <- instDFunConstraints loc theta + ; let new_ev_vars = freshGoals evc_vars -- new_ev_vars are only the real new variables that can be emitted - ; return $ GenInst new_ev_vars (EvDFunApp dfun_id tys ev_vars) } - } + dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars) + ; return $ GenInst new_ev_vars dfun_app } } } where givens_for_this_clas :: Cts givens_for_this_clas - = lookupUFM (cts_given (inert_dicts inerts)) clas `orElse` emptyCts + = lookupUFM (cts_given (inert_dicts $ inert_cans inerts)) clas + `orElse` emptyCts given_overlap :: TcsUntouchables -> Bool given_overlap untch = anyBag (matchable untch) givens_for_this_clas - matchable untch (CDictCan { cc_class = clas_g, cc_tyargs = sys, cc_flavor = fl }) - | Just GivenOrig <- isGiven_maybe fl + matchable untch (CDictCan { cc_class = clas_g, cc_tyargs = sys + , cc_ev = fl }) + | isGiven fl = ASSERT( clas_g == clas ) case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv && tv `elemVarSet` tyVarsOfTypes tys @@ -1862,6 +1902,9 @@ This is arguably not easy to appear in practice due to our aggressive prioritiza of equality solving over other constraints, but it is possible. I've added a test case in typecheck/should-compile/GivenOverlapping.hs +We ignore the overlap problem if -XIncoherentInstances is in force: see +Trac #6002 for a worked-out example where this makes a difference. + Moreover notice that our goals here are different than the goals of the top-level overlapping checks. There we are interested in validating the following principle: @@ -1871,7 +1914,3 @@ overlapping checks. There we are interested in validating the following principl But for the Given Overlap check our goal is just related to completeness of constraint solving. - - - - diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index f63ec5125f..4e6f499db1 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -24,7 +24,7 @@ module TcMType ( newFlexiTyVar, newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] - newMetaKindVar, newMetaKindVars, + newMetaKindVar, newMetaKindVars, mkKindSigVar, mkTcTyVarName, newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, @@ -33,14 +33,14 @@ module TcMType ( -------------------------------- -- Creating new evidence variables newEvVar, newEvVars, - newEq, newIP, newDict, + newEq, newDict, newWantedEvVar, newWantedEvVars, newTcEvBinds, addTcEvBind, -------------------------------- -- Instantiation - tcInstTyVars, tcInstSigTyVars, + tcInstTyVars, tcInstSigTyVars, newSigTyVar, tcInstType, tcInstSkolTyVars, tcInstSuperSkolTyVars, tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX, @@ -59,19 +59,16 @@ module TcMType ( -------------------------------- -- Zonking - zonkType, zonkKind, zonkTcPredType, - zonkTcTypeCarefully, skolemiseUnboundMetaTyVar, - zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar, + zonkTcPredType, + skolemiseSigTv, skolemiseUnboundMetaTyVar, + zonkTcTyVar, zonkTcTyVars, zonkTyVarsAndFV, zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcKind, defaultKindVarToStar, zonkCt, zonkCts, - zonkImplication, zonkEvVar, zonkWC, + zonkImplication, zonkEvVar, zonkWC, zonkId, - zonkTcTypeAndSubst, tcGetGlobalTyVars, - - compatKindTcM, isSubKindTcM ) where #include "HsVersions.h" @@ -88,7 +85,6 @@ import Var -- others: import HsSyn -- HsType import TcRnMonad -- TcType, amongst others -import IParam import Id import FunDeps import Name @@ -98,7 +94,6 @@ import DynFlags import Util import Maybes import ListSetOps -import BasicTypes import SrcLoc import Outputable import FastString @@ -118,12 +113,16 @@ import Data.List ( (\\), partition, mapAccumL ) \begin{code} newMetaKindVar :: TcM TcKind -newMetaKindVar = do { uniq <- newUnique - ; ref <- newMutVar Flexi - ; return (mkTyVarTy (mkMetaKindVar uniq ref)) } +newMetaKindVar = do { uniq <- newUnique + ; ref <- newMutVar Flexi + ; return (mkTyVarTy (mkMetaKindVar uniq ref)) } newMetaKindVars :: Int -> TcM [TcKind] newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ()) + +mkKindSigVar :: Name -> KindVar +-- Use the specified name; don't clone it +mkKindSigVar n = mkTcTyVar n superKind (SkolemTv False) \end{code} @@ -153,12 +152,7 @@ newEvVar ty = do { name <- newName (predTypeOccName ty) newEq :: TcType -> TcType -> TcM EvVar newEq ty1 ty2 = do { name <- newName (mkVarOccFS (fsLit "cobox")) - ; return (mkLocalId name (mkEqPred (ty1, ty2))) } - -newIP :: IPName Name -> TcType -> TcM IpId -newIP ip ty - = do { name <- newName (mkVarOccFS (ipFastString ip)) - ; return (mkLocalId name (mkIPPred ip ty)) } + ; return (mkLocalId name (mkTcEqPred ty1 ty2)) } newDict :: Class -> [TcType] -> TcM DictId newDict cls tys @@ -168,7 +162,6 @@ newDict cls tys predTypeOccName :: PredType -> OccName predTypeOccName ty = case classifyPredType ty of ClassPred cls _ -> mkDictOcc (getOccName cls) - IPPred ip _ -> mkVarOccFS (ipFastString ip) EqPred _ _ -> mkVarOccFS (fsLit "cobox") TuplePred _ -> mkVarOccFS (fsLit "tup") IrredPred _ -> mkVarOccFS (fsLit "irred") @@ -182,7 +175,7 @@ predTypeOccName ty = case classifyPredType ty of %************************************************************************ \begin{code} -tcInstType :: ([TyVar] -> TcM [TcTyVar]) -- How to instantiate the type variables +tcInstType :: ([TyVar] -> TcM (TvSubst, [TcTyVar])) -- How to instantiate the type variables -> TcType -- Type to instantiate -> TcM ([TcTyVar], TcThetaType, TcType) -- Result -- (type vars (excl coercion vars), preds (incl equalities), rho) @@ -194,14 +187,8 @@ tcInstType inst_tyvars ty in return ([], theta, tau) - (tyvars, rho) -> do { tyvars' <- inst_tyvars tyvars - - ; let tenv = zipTopTvSubst tyvars (mkTyVarTys tyvars') - -- Either the tyvars are freshly made, by inst_tyvars, - -- or any nested foralls have different binders. - -- Either way, zipTopTvSubst is ok - - ; let (theta, tau) = tcSplitPhiTy (substTy tenv rho) + (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars + ; let (theta, tau) = tcSplitPhiTy (substTy subst rho) ; return (tyvars', theta, tau) } tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType) @@ -210,12 +197,12 @@ tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType) -- be in the type environment: it is lexically scoped. tcSkolDFunType ty = tcInstType (\tvs -> return (tcSuperSkolTyVars tvs)) ty -tcSuperSkolTyVars :: [TyVar] -> [TcTyVar] +tcSuperSkolTyVars :: [TyVar] -> (TvSubst, [TcTyVar]) -- Make skolem constants, but do *not* give them new names, as above -- Moreover, make them "super skolems"; see comments with superSkolemTv -- see Note [Kind substitution when instantiating] -- Precondition: tyvars should be ordered (kind vars first) -tcSuperSkolTyVars = snd . mapAccumL tcSuperSkolTyVar (mkTopTvSubst []) +tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar (mkTopTvSubst []) tcSuperSkolTyVar :: TvSubst -> TyVar -> (TvSubst, TcTyVar) tcSuperSkolTyVar subst tv @@ -241,14 +228,11 @@ tcInstSkolTyVar overlappable subst tyvar occ = nameOccName old_name kind = substTy subst (tyVarKind tyvar) -tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) --- Precondition: tyvars should be ordered (kind vars first) --- see Note [Kind substitution when instantiating] -tcInstSkolTyVars' isSuperSkol = mapAccumLM (tcInstSkolTyVar isSuperSkol) - -- Wrappers -tcInstSkolTyVars, tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar] -tcInstSkolTyVars = fmap snd . tcInstSkolTyVars' False (mkTopTvSubst []) +tcInstSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) +tcInstSkolTyVars = tcInstSkolTyVarsX (mkTopTvSubst []) + +tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar] tcInstSuperSkolTyVars = fmap snd . tcInstSkolTyVars' True (mkTopTvSubst []) tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX @@ -256,28 +240,38 @@ tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX tcInstSkolTyVarsX subst = tcInstSkolTyVars' False subst tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst +tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) +-- Precondition: tyvars should be ordered (kind vars first) +-- see Note [Kind substitution when instantiating] +tcInstSkolTyVars' isSuperSkol = mapAccumLM (tcInstSkolTyVar isSuperSkol) + tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type with fresh skolem constants -- Binding location comes from the monad tcInstSkolType ty = tcInstType tcInstSkolTyVars ty -tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar] +tcInstSigTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) -- Make meta SigTv type variables for patten-bound scoped type varaibles -- We use SigTvs for them, so that they can't unify with arbitrary types -- Precondition: tyvars should be ordered (kind vars first) -- see Note [Kind substitution when instantiating] -tcInstSigTyVars = fmap snd . mapAccumLM tcInstSigTyVar (mkTopTvSubst []) +tcInstSigTyVars = mapAccumLM tcInstSigTyVar (mkTopTvSubst []) + -- The tyvars are freshly made, by tcInstSigTyVar + -- So mkTopTvSubst [] is ok tcInstSigTyVar :: TvSubst -> TyVar -> TcM (TvSubst, TcTyVar) tcInstSigTyVar subst tv + = do { new_tv <- newSigTyVar (tyVarName tv) (substTy subst (tyVarKind tv)) + ; return (extendTvSubst subst tv (mkTyVarTy new_tv), new_tv) } + +newSigTyVar :: Name -> Kind -> TcM TcTyVar +newSigTyVar name kind = do { uniq <- newMetaUnique ; ref <- newMutVar Flexi - ; let name = setNameUnique (tyVarName tv) uniq + ; let name' = setNameUnique name uniq -- Use the same OccName so that the tidy-er -- doesn't rename 'a' to 'a0' etc - kind = substTy subst (tyVarKind tv) - new_tv = mkTcTyVar name kind (MetaTv SigTv ref) - ; return (extendTvSubst subst tv (mkTyVarTy new_tv), new_tv) } + ; return (mkTcTyVar name' kind (MetaTv SigTv ref)) } \end{code} Note [Kind substitution when instantiating] @@ -389,7 +383,7 @@ writeMetaTyVarRef tyvar ref ty ; writeMutVar ref (Indirect ty) ; when ( not (isPredTy tv_kind) -- Don't check kinds for updates to coercion variables - && not (zonked_ty_kind `isSubKind` zonked_tv_kind)) + && not (zonked_ty_kind `tcIsSubKind` zonked_tv_kind)) $ WARN( True, hang (text "Ill-kinded update to meta tyvar") 2 ( ppr tyvar <+> text "::" <+> ppr tv_kind <+> text ":=" @@ -419,22 +413,26 @@ newFlexiTyVarTy kind = do newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) -tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst) +tcInstTyVars :: [TKVar] -> TcM ([TcTyVar], [TcType], TvSubst) -- Instantiate with META type variables +-- Note that this works for a sequence of kind and type +-- variables. Eg [ (k:BOX), (a:k->k) ] +-- Gives [ (k7:BOX), (a8:k7->k7) ] tcInstTyVars tyvars = tcInstTyVarsX emptyTvSubst tyvars -- emptyTvSubst has an empty in-scope set, but that's fine here -- Since the tyvars are freshly made, they cannot possibly be -- captured by any existing for-alls. -tcInstTyVarsX :: TvSubst -> [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst) +tcInstTyVarsX :: TvSubst -> [TKVar] -> TcM ([TcTyVar], [TcType], TvSubst) +-- The "X" part is because of extending the substitution tcInstTyVarsX subst tyvars = - do { (subst', tyvars') <- mapAccumLM tcInstTyVar subst tyvars + do { (subst', tyvars') <- mapAccumLM tcInstTyVarX subst tyvars ; return (tyvars', mkTyVarTys tyvars', subst') } -tcInstTyVar :: TvSubst -> TyVar -> TcM (TvSubst, TcTyVar) +tcInstTyVarX :: TvSubst -> TKVar -> TcM (TvSubst, TcTyVar) -- Make a new unification variable tyvar whose Name and Kind come from -- an existing TyVar. We substitute kind variables in the kind. -tcInstTyVar subst tyvar +tcInstTyVarX subst tyvar = do { uniq <- newMetaUnique ; ref <- newMutVar Flexi ; let name = mkSystemName uniq (getOccName tyvar) @@ -446,27 +444,6 @@ tcInstTyVar subst tyvar %************************************************************************ %* * - MetaTvs: SigTvs -%* * -%************************************************************************ - -\begin{code} -zonkSigTyVar :: TcTyVar -> TcM TcTyVar -zonkSigTyVar sig_tv - | isSkolemTyVar sig_tv - = return sig_tv -- Happens in the call in TcBinds.checkDistinctTyVars - | otherwise - = ASSERT( isSigTyVar sig_tv ) - do { ty <- zonkTcTyVar sig_tv - ; return (tcGetTyVar "zonkSigTyVar" ty) } - -- 'ty' is bound to be a type variable, because SigTvs - -- can only be unified with type variables -\end{code} - - - -%************************************************************************ -%* * \subsection{Zonking -- the exernal interfaces} %* * %************************************************************************ @@ -480,88 +457,35 @@ tcGetGlobalTyVars :: TcM TcTyVarSet tcGetGlobalTyVars = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv ; gbl_tvs <- readMutVar gtv_var - ; gbl_tvs' <- zonkTcTyVarsAndFV gbl_tvs + ; gbl_tvs' <- zonkTyVarsAndFV gbl_tvs ; writeMutVar gtv_var gbl_tvs' ; return gbl_tvs' } + where \end{code} ----------------- Type variables \begin{code} +zonkTyVar :: TyVar -> TcM TcType +-- Works on TyVars and TcTyVars +zonkTyVar tv | isTcTyVar tv = zonkTcTyVar tv + | otherwise = return (mkTyVarTy tv) + -- Hackily, when typechecking type and class decls + -- we have TyVars in scopeadded (only) in + -- TcHsType.tcTyClTyVars, but it seems + -- painful to make them into TcTyVars there + +zonkTyVarsAndFV :: TyVarSet -> TcM TyVarSet +zonkTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTyVar (varSetElems tyvars) + zonkTcTyVars :: [TcTyVar] -> TcM [TcType] zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars -zonkTcTyVarsAndFV :: TcTyVarSet -> TcM TcTyVarSet -zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar (varSetElems tyvars) - ----------------- Types -zonkTcTypeCarefully :: TcType -> TcM TcType --- Do not zonk type variables free in the environment -zonkTcTypeCarefully ty = zonkTcType ty -- I think this function is out of date - -{- - = do { env_tvs <- tcGetGlobalTyVars - ; zonkType (zonk_tv env_tvs) ty } - where - zonk_tv env_tvs tv - | tv `elemVarSet` env_tvs - = return (TyVarTy tv) - | otherwise - = ASSERT( isTcTyVar tv ) - case tcTyVarDetails tv of - SkolemTv {} -> return (TyVarTy tv) - RuntimeUnk {} -> return (TyVarTy tv) - FlatSkol ty -> zonkType (zonk_tv env_tvs) ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> return (TyVarTy tv) - Indirect ty -> zonkType (zonk_tv env_tvs) ty } --} - -zonkTcType :: TcType -> TcM TcType --- Simply look through all Flexis -zonkTcType ty = zonkType zonkTcTyVar ty - -zonkTcTyVar :: TcTyVar -> TcM TcType --- Simply look through all Flexis -zonkTcTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) do - case tcTyVarDetails tv of - SkolemTv {} -> zonk_kind_and_return - RuntimeUnk {} -> zonk_kind_and_return - FlatSkol ty -> zonkTcType ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_kind_and_return - Indirect ty -> zonkTcType ty } - where - zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv - ; return (TyVarTy z_tv) } - zonkTyVarKind :: TyVar -> TcM TyVar zonkTyVarKind tv = do { kind' <- zonkTcKind (tyVarKind tv) ; return (setTyVarKind tv kind') } -zonkTcTypeAndSubst :: TvSubst -> TcType -> TcM TcType --- Zonk, and simultaneously apply a non-necessarily-idempotent substitution -zonkTcTypeAndSubst subst ty = zonkType zonk_tv ty - where - zonk_tv tv - = do { z_tv <- updateTyVarKindM zonkTcKind tv - ; ASSERT ( isTcTyVar tv ) - case tcTyVarDetails tv of - SkolemTv {} -> return (TyVarTy z_tv) - RuntimeUnk {} -> return (TyVarTy z_tv) - FlatSkol ty -> zonkType zonk_tv ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_flexi z_tv - Indirect ty -> zonkType zonk_tv ty } } - zonk_flexi tv - = case lookupTyVar subst tv of - Just ty -> zonkType zonk_tv ty - Nothing -> return (TyVarTy tv) - zonkTcTypes :: [TcType] -> TcM [TcType] zonkTcTypes tys = mapM zonkTcType tys @@ -579,15 +503,14 @@ zonkTcPredType = zonkTcType defaultKindVarToStar :: TcTyVar -> TcM Kind -- We have a meta-kind: unify it with '*' defaultKindVarToStar kv - = do { ASSERT ( isKiVar kv && isMetaTyVar kv ) + = do { ASSERT ( isKindVar kv && isMetaTyVar kv ) writeMetaTyVar kv liftedTypeKind ; return liftedTypeKind } -zonkQuantifiedTyVars :: TcTyVarSet -> TcM [TcTyVar] --- Precondition: a kind variable occurs before a type --- variable mentioning it in its kind +zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TcTyVar] +-- A kind variable k may occur *after* a tyvar mentioning k in its kind zonkQuantifiedTyVars tyvars - = do { let (kvs, tvs) = partitionKiTyVars (varSetElems tyvars) + = do { let (kvs, tvs) = partition isKindVar tyvars ; poly_kinds <- xoptM Opt_PolyKinds ; if poly_kinds then mapM zonkQuantifiedTyVar (kvs ++ tvs) @@ -655,6 +578,17 @@ skolemiseUnboundMetaTyVar tv details ; writeMetaTyVar tv (mkTyVarTy final_tv) ; return final_tv } + +skolemiseSigTv :: TcTyVar -> TcM TcTyVar +-- In TcBinds we create SigTvs for type signatures +-- but for singleton groups we want them to really be skolems +-- which do not unify with each other +skolemiseSigTv tv + = ASSERT2( isSigTyVar tv, ppr tv ) + do { writeMetaTyVarRef tv (metaTvRef tv) (mkTyVarTy skol_tv) + ; return skol_tv } + where + skol_tv = setTcTyVarDetails tv (SkolemTv False) \end{code} \begin{code} @@ -685,18 +619,24 @@ zonkWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) zonkCt :: Ct -> TcM Ct -- Zonking a Ct conservatively gives back a CNonCanonical zonkCt ct - = do { v' <- zonkEvVar (cc_id ct) - ; fl' <- zonkFlavor (cc_flavor ct) + = do { fl' <- zonkCtEvidence (cc_ev ct) ; return $ - CNonCanonical { cc_id = v' - , cc_flavor = fl' + CNonCanonical { cc_ev = fl' , cc_depth = cc_depth ct } } zonkCts :: Cts -> TcM Cts zonkCts = mapBagM zonkCt -zonkFlavor :: CtFlavor -> TcM CtFlavor -zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) } -zonkFlavor fl = return fl +zonkCtEvidence :: CtEvidence -> TcM CtEvidence +zonkCtEvidence ctev@(Given { ctev_gloc = loc, ctev_pred = pred }) + = do { loc' <- zonkGivenLoc loc + ; pred' <- zonkTcType pred + ; return (ctev { ctev_gloc = loc', ctev_pred = pred'}) } +zonkCtEvidence ctev@(Wanted { ctev_pred = pred }) + = do { pred' <- zonkTcType pred + ; return (ctev { ctev_pred = pred' }) } +zonkCtEvidence ctev@(Derived { ctev_pred = pred }) + = do { pred' <- zonkTcType pred + ; return (ctev { ctev_pred = pred' }) } zonkGivenLoc :: GivenLoc -> TcM GivenLoc -- GivenLocs may have unification variables inside them! @@ -783,28 +723,32 @@ simplifier knows how to deal with. %************************************************************************ %* * -\subsection{Zonking -- the main work-horses: zonkType, zonkTyVar} +\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} %* * %* For internal use only! * %* * %************************************************************************ \begin{code} +-- zonkId is used *during* typechecking just to zonk the Id's type +zonkId :: TcId -> TcM TcId +zonkId id + = do { ty' <- zonkTcType (idType id) + ; return (Id.setIdType id ty') } + -- For unbound, mutable tyvars, zonkType uses the function given to it -- For tyvars bound at a for-all, zonkType zonks them to an immutable -- type variable and zonks the kind too -zonkKind :: (TcTyVar -> TcM Kind) -> TcKind -> TcM Kind -zonkKind = zonkType - -zonkType :: (TcTyVar -> TcM Type) -- What to do with TcTyVars - -> TcType -> TcM Type -zonkType zonk_tc_tyvar ty +zonkTcType :: TcType -> TcM TcType +zonkTcType ty = go ty where go (TyConApp tc tys) = do tys' <- mapM go tys return (TyConApp tc tys') + go (LitTy n) = return (LitTy n) + go (FunTy arg res) = do arg' <- go arg res' <- go res return (FunTy arg' res') @@ -817,14 +761,30 @@ zonkType zonk_tc_tyvar ty -- to pull the TyConApp to the top. -- The two interesting cases! - go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar - | otherwise = TyVarTy <$> updateTyVarKindM zonkTcKind tyvar + go (TyVarTy tyvar) | isTcTyVar tyvar = zonkTcTyVar tyvar + | otherwise = TyVarTy <$> updateTyVarKindM go tyvar -- Ordinary (non Tc) tyvars occur inside quantified types - go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do + go (ForAllTy tyvar ty) = ASSERT2( isImmutableTyVar tyvar, ppr tyvar ) do ty' <- go ty - tyvar' <- updateTyVarKindM zonkTcKind tyvar + tyvar' <- updateTyVarKindM go tyvar return (ForAllTy tyvar' ty') + +zonkTcTyVar :: TcTyVar -> TcM TcType +-- Simply look through all Flexis +zonkTcTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) do + case tcTyVarDetails tv of + SkolemTv {} -> zonk_kind_and_return + RuntimeUnk {} -> zonk_kind_and_return + FlatSkol ty -> zonkTcType ty + MetaTv _ ref -> do { cts <- readMutVar ref + ; case cts of + Flexi -> zonk_kind_and_return + Indirect ty -> zonkTcType ty } + where + zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv + ; return (TyVarTy z_tv) } \end{code} @@ -836,19 +796,6 @@ zonkType zonk_tc_tyvar ty %************************************************************************ \begin{code} -compatKindTcM :: Kind -> Kind -> TcM Bool -compatKindTcM k1 k2 - = do { k1' <- zonkTcKind k1 - ; k2' <- zonkTcKind k2 - ; return $ k1' `isSubKind` k2' || k2' `isSubKind` k1' } - -isSubKindTcM :: Kind -> Kind -> TcM Bool -isSubKindTcM k1 k2 - = do { k1' <- zonkTcKind k1 - ; k2' <- zonkTcKind k2 - ; return $ k1' `isSubKind` k2' } - -------------- zonkTcKind :: TcKind -> TcM TcKind zonkTcKind k = zonkTcType k \end{code} @@ -894,100 +841,113 @@ expectedKindInCtxt :: UserTypeCtxt -> Maybe Kind expectedKindInCtxt (TySynCtxt _) = Nothing -- Any kind will do expectedKindInCtxt ThBrackCtxt = Nothing expectedKindInCtxt GhciCtxt = Nothing -expectedKindInCtxt ResSigCtxt = Just openTypeKind -expectedKindInCtxt ExprSigCtxt = Just openTypeKind expectedKindInCtxt (ForSigCtxt _) = Just liftedTypeKind -expectedKindInCtxt _ = Just argTypeKind +expectedKindInCtxt InstDeclCtxt = Just constraintKind +expectedKindInCtxt SpecInstCtxt = Just constraintKind +expectedKindInCtxt _ = Just openTypeKind checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context -checkValidType ctxt ty = do - traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) - unboxed <- xoptM Opt_UnboxedTuples - rank2 <- xoptM Opt_Rank2Types - rankn <- xoptM Opt_RankNTypes - polycomp <- xoptM Opt_PolymorphicComponents - constraintKinds <- xoptM Opt_ConstraintKinds - let - gen_rank n | rankn = ArbitraryRank - | rank2 = Rank 2 - | otherwise = Rank n - rank - = case ctxt of - DefaultDeclCtxt-> MustBeMonoType - ResSigCtxt -> MustBeMonoType - LamPatSigCtxt -> gen_rank 0 - BindPatSigCtxt -> gen_rank 0 - TySynCtxt _ -> gen_rank 0 - - ExprSigCtxt -> gen_rank 1 - FunSigCtxt _ -> gen_rank 1 - InfSigCtxt _ -> ArbitraryRank -- Inferred type - ConArgCtxt _ | polycomp -> gen_rank 2 - -- We are given the type of the entire - -- constructor, hence rank 1 - | otherwise -> gen_rank 1 - - ForSigCtxt _ -> gen_rank 1 - SpecInstCtxt -> gen_rank 1 - ThBrackCtxt -> gen_rank 1 - GhciCtxt -> ArbitraryRank +-- Not used for instance decls; checkValidInstance instead +checkValidType ctxt ty + = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) + ; rank2_flag <- xoptM Opt_Rank2Types + ; rankn_flag <- xoptM Opt_RankNTypes + ; polycomp <- xoptM Opt_PolymorphicComponents + ; constraintKinds <- xoptM Opt_ConstraintKinds + ; let gen_rank :: Rank -> Rank + gen_rank r | rankn_flag = ArbitraryRank + | rank2_flag = r2 + | otherwise = r + + rank2 = gen_rank r2 + rank1 = gen_rank r1 + rank0 = gen_rank r0 + + r0 = rankZeroMonoType + r1 = LimitedRank True r0 + r2 = LimitedRank True r1 + + rank + = case ctxt of + DefaultDeclCtxt-> MustBeMonoType + ResSigCtxt -> MustBeMonoType + LamPatSigCtxt -> rank0 + BindPatSigCtxt -> rank0 + RuleSigCtxt _ -> rank1 + TySynCtxt _ -> rank0 + + ExprSigCtxt -> rank1 + FunSigCtxt _ -> rank1 + InfSigCtxt _ -> ArbitraryRank -- Inferred type + ConArgCtxt _ | polycomp -> rank2 + -- We are given the type of the entire + -- constructor, hence rank 1 + | otherwise -> rank1 + + ForSigCtxt _ -> rank1 + SpecInstCtxt -> rank1 + ThBrackCtxt -> rank1 + GhciCtxt -> ArbitraryRank _ -> panic "checkValidType" - -- Can't happen; not used for *user* sigs + -- Can't happen; not used for *user* sigs - actual_kind = typeKind ty + actual_kind = typeKind ty - kind_ok = case expectedKindInCtxt ctxt of - Nothing -> True - Just k -> tcIsSubKind actual_kind k - - ubx_tup - | not unboxed = UT_NotOk - | otherwise = case ctxt of - TySynCtxt _ -> UT_Ok - ExprSigCtxt -> UT_Ok - ThBrackCtxt -> UT_Ok - GhciCtxt -> UT_Ok - _ -> UT_NotOk + kind_ok = case expectedKindInCtxt ctxt of + Nothing -> True + Just k -> tcIsSubKind actual_kind k -- Check the internal validity of the type itself - check_type rank ubx_tup ty + ; check_type rank ty -- Check that the thing has kind Type, and is lifted if necessary -- Do this second, because we can't usefully take the kind of an -- ill-formed type such as (a~Int) - checkTc kind_ok (kindErr actual_kind) + ; checkTc kind_ok (kindErr actual_kind) -- Check that the thing does not have kind Constraint, -- if -XConstraintKinds isn't enabled - unless constraintKinds - $ checkTc (not (isConstraintKind actual_kind)) (predTupleErr ty) + ; unless constraintKinds $ + checkTc (not (isConstraintKind actual_kind)) (predTupleErr ty) + } checkValidMonoType :: Type -> TcM () checkValidMonoType ty = check_mono_type MustBeMonoType ty \end{code} +Note [Higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~ +Technically + Int -> forall a. a->a +is still a rank-1 type, but it's not Haskell 98 (Trac #5957). So the +validity checker allow a forall after an arrow only if we allow it +before -- that is, with Rank2Types or RankNTypes \begin{code} data Rank = ArbitraryRank -- Any rank ok - | MustBeMonoType -- Monotype regardless of flags - | TyConArgMonoType -- Monotype but could be poly if -XImpredicativeTypes - | SynArgMonoType -- Monotype but could be poly if -XLiberalTypeSynonyms - | Rank Int -- Rank n, but could be more with -XRankNTypes -decRank :: Rank -> Rank -- Function arguments -decRank (Rank 0) = Rank 0 -decRank (Rank n) = Rank (n-1) -decRank other_rank = other_rank + | LimitedRank -- Note [Higher rank types] + Bool -- Forall ok at top + Rank -- Use for function arguments -nonZeroRank :: Rank -> Bool -nonZeroRank ArbitraryRank = True -nonZeroRank (Rank n) = n>0 -nonZeroRank _ = False + | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype + + | MustBeMonoType -- Monotype regardless of flags ----------------------------------------- -data UbxTupFlag = UT_Ok | UT_NotOk - -- The "Ok" version means "ok if UnboxedTuples is on" +rankZeroMonoType, tyConArgMonoType, synArgMonoType :: Rank +rankZeroMonoType = MonoType (ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types")) +tyConArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use -XImpredicativeTypes")) +synArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use -XLiberalTypeSynonyms")) + +funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result +funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) +funArgResRank other_rank = (other_rank, other_rank) + +forAllAllowed :: Rank -> Bool +forAllAllowed ArbitraryRank = True +forAllAllowed (LimitedRank forall_ok _) = forall_ok +forAllAllowed _ = False ---------------------------------------- check_mono_type :: Rank -> KindOrType -> TcM () -- No foralls anywhere @@ -995,38 +955,40 @@ check_mono_type :: Rank -> KindOrType -> TcM () -- No foralls anywhere check_mono_type rank ty | isKind ty = return () -- IA0_NOTE: Do we need to check kinds? | otherwise - = do { check_type rank UT_NotOk ty + = do { check_type rank ty ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } -check_type :: Rank -> UbxTupFlag -> Type -> TcM () +check_type :: Rank -> Type -> TcM () -- The args say what the *type context* requires, independent -- of *flag* settings. You test the flag settings at usage sites. -- -- Rank is allowed rank for function args -- Rank 0 means no for-alls anywhere -check_type rank ubx_tup ty +check_type rank ty | not (null tvs && null theta) - = do { checkTc (nonZeroRank rank) (forAllTyErr rank ty) + = do { checkTc (forAllAllowed rank) (forAllTyErr rank ty) -- Reject e.g. (Maybe (?x::Int => Int)), -- with a decent error message ; check_valid_theta SigmaCtxt theta - ; check_type rank ubx_tup tau -- Allow foralls to right of arrow + ; check_type rank tau -- Allow foralls to right of arrow ; checkAmbiguity tvs theta (tyVarsOfType tau) } where (tvs, theta, tau) = tcSplitSigmaTy ty -check_type _ _ (TyVarTy _) = return () +check_type _ (TyVarTy _) = return () -check_type rank _ (FunTy arg_ty res_ty) - = do { check_type (decRank rank) UT_NotOk arg_ty - ; check_type rank UT_Ok res_ty } +check_type rank (FunTy arg_ty res_ty) + = do { check_type arg_rank arg_ty + ; check_type res_rank res_ty } + where + (arg_rank, res_rank) = funArgResRank rank -check_type rank _ (AppTy ty1 ty2) +check_type rank (AppTy ty1 ty2) = do { check_arg_type rank ty1 ; check_arg_type rank ty2 } -check_type rank ubx_tup ty@(TyConApp tc tys) +check_type rank ty@(TyConApp tc tys) | isSynTyCon tc = do { -- Check that the synonym has enough args -- This applies equally to open and closed synonyms @@ -1040,40 +1002,38 @@ check_type rank ubx_tup ty@(TyConApp tc tys) ; liberal <- xoptM Opt_LiberalTypeSynonyms ; if not liberal || isSynFamilyTyCon tc then -- For H98 and synonym families, do check the type args - mapM_ (check_mono_type SynArgMonoType) tys + mapM_ (check_mono_type synArgMonoType) tys else -- In the liberal case (only for closed syns), expand then check case tcView ty of - Just ty' -> check_type rank ubx_tup ty' + Just ty' -> check_type rank ty' Nothing -> pprPanic "check_tau_type" (ppr ty) } | isUnboxedTupleTyCon tc = do { ub_tuples_allowed <- xoptM Opt_UnboxedTuples - ; checkTc (ubx_tup_ok ub_tuples_allowed) ubx_tup_msg + ; checkTc ub_tuples_allowed ubx_tup_msg ; impred <- xoptM Opt_ImpredicativeTypes - ; let rank' = if impred then ArbitraryRank else TyConArgMonoType + ; let rank' = if impred then ArbitraryRank else tyConArgMonoType -- c.f. check_arg_type -- However, args are allowed to be unlifted, or -- more unboxed tuples, so can't use check_arg_ty - ; mapM_ (check_type rank' UT_Ok) tys } + ; mapM_ (check_type rank') tys } | otherwise = mapM_ (check_arg_type rank) tys where - ubx_tup_ok ub_tuples_allowed = case ubx_tup of - UT_Ok -> ub_tuples_allowed - _ -> False - n_args = length tys tc_arity = tyConArity tc arity_msg = arityErr "Type synonym" (tyConName tc) tc_arity n_args ubx_tup_msg = ubxArgTyErr ty -check_type _ _ ty = pprPanic "check_type" (ppr ty) +check_type _ (LitTy {}) = return () + +check_type _ ty = pprPanic "check_type" (ppr ty) ---------------------------------------- check_arg_type :: Rank -> KindOrType -> TcM () @@ -1102,13 +1062,13 @@ check_arg_type rank ty ; let rank' = case rank of -- Predictive => must be monotype MustBeMonoType -> MustBeMonoType -- Monotype, regardless _other | impred -> ArbitraryRank - | otherwise -> TyConArgMonoType + | otherwise -> tyConArgMonoType -- Make sure that MustBeMonoType is propagated, -- so that we don't suggest -XImpredicativeTypes in -- (Ord (forall a.a)) => a -> a -- and so that if it Must be a monotype, we check that it is! - ; check_type rank' UT_NotOk ty + ; check_type rank' ty ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } -- NB the isUnLiftedType test also checks for -- T State# @@ -1122,10 +1082,9 @@ forAllTyErr rank ty , suggestion ] where suggestion = case rank of - Rank _ -> ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types") - TyConArgMonoType -> ptext (sLit "Perhaps you intended to use -XImpredicativeTypes") - SynArgMonoType -> ptext (sLit "Perhaps you intended to use -XLiberalTypeSynonyms") - _ -> empty -- Polytype is always illegal + LimitedRank {} -> ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types") + MonoType d -> d + _ -> empty -- Polytype is always illegal unliftedArgErr, ubxArgTyErr :: Type -> SDoc unliftedArgErr ty = sep [ptext (sLit "Illegal unlifted type:"), ppr ty] @@ -1212,26 +1171,13 @@ check_pred_ty' dflags _ctxt (EqPred ty1 ty2) = do { -- Equational constraints are valid in all contexts if type -- families are permitted ; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags) - (eqPredTyErr (mkEqPred (ty1, ty2))) + (eqPredTyErr (mkEqPred ty1 ty2)) -- Check the form of the argument types ; checkValidMonoType ty1 ; checkValidMonoType ty2 } -check_pred_ty' _ _ctxt (IPPred _ ty) = checkValidMonoType ty - -- Contrary to GHC 7.2 and below, we allow implicit parameters not only - -- in type signatures but also in instance decls, superclasses etc - -- The reason we didn't allow implicit params in instances is a bit - -- subtle: - -- If we allowed instance (?x::Int, Eq a) => Foo [a] where ... - -- then when we saw (e :: (?x::Int) => t) it would be unclear how to - -- discharge all the potential usas of the ?x in e. For example, a - -- constraint Foo [Int] might come out of e,and applying the - -- instance decl would show up two uses of ?x. - -- - -- Happily this is not an issue in the new constraint solver. - check_pred_ty' dflags ctxt t@(TuplePred ts) = do { checkTc (xopt Opt_ConstraintKinds dflags) (predTupleErr (predTreePredType t)) @@ -1283,38 +1229,6 @@ check_class_pred_tys dflags ctxt kts flexible_contexts = xopt Opt_FlexibleContexts dflags undecidable_ok = xopt Opt_UndecidableInstances dflags -{- -Note [Kind polymorphic type classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -class C f where - empty :: f a --- C :: forall k. k -> Constraint --- empty :: forall (a :: k). f a - -MultiParam: -~~~~~~~~~~~ - -instance C Maybe where - empty = Nothing - -The dictionary gets type [C * Maybe] even if it's not a MultiParam -type class. - -Flexible: -~~~~~~~~~ - -data D a = D --- D :: forall k. k -> * - -instance C D where - empty = D - -The dictionary gets type [C * (D *)]. IA0_TODO it should be -generalized actually. - --} - ------------------------- tyvar_head :: Type -> Bool tyvar_head ty -- Haskell 98 allows predicates of form @@ -1325,21 +1239,77 @@ tyvar_head ty -- Haskell 98 allows predicates of form Nothing -> False \end{code} -Check for ambiguity -~~~~~~~~~~~~~~~~~~~ - forall V. P => tau -is ambiguous if P contains generic variables -(i.e. one of the Vs) that are not mentioned in tau - -However, we need to take account of functional dependencies -when we speak of 'mentioned in tau'. Example: - class C a b | a -> b where ... -Then the type - forall x y. (C x y) => x -is not ambiguous because x is mentioned and x determines y - -NB; the ambiguity check is only used for *user* types, not for types -coming from inteface files. The latter can legitimately have +Note [Kind polymorphic type classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +MultiParam check: + + class C f where... -- C :: forall k. k -> Constraint + instance C Maybe where... + + The dictionary gets type [C * Maybe] even if it's not a MultiParam + type class. + +Flexibility check: + + class C f where... -- C :: forall k. k -> Constraint + data D a = D a + instance C D where + + The dictionary gets type [C * (D *)]. IA0_TODO it should be + generalized actually. + +Note [The ambiguity check for type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +checkAmbiguity is a check on user-supplied type signatures. It is +*purely* there to report functions that cannot possibly be called. So for +example we want to reject: + f :: C a => Int +The idea is there can be no legal calls to 'f' because every call will +give rise to an ambiguous constraint. We could soundly omit the +ambiguity check on type signatures entirely, at the expense of +delaying ambiguity errors to call sites. + +What about this, though? + g :: C [a] => Int +Is every call to 'g' ambiguous? After all, we might have + intance C [a] where ... +at the call site. So maybe that type is ok! Indeed even f's +quintessentially ambiguous type might, just possibly be callable: +with -XUndecidableInstances we could have + instance C a where ... +and now a call could be legal after all! (But only with -XUndecidableInstances!) + +What about things like this: + class D a b | a -> b where .. + h :: D Int b => Int +The Int may well fix 'b' at the call site, so that signature should +not be rejected. Moreover, using *visible* fundeps is too +conservative. Consider + class X a b where ... + class D a b | a -> b where ... + instance D a b => X [a] b where... + h :: X a b => a -> a +Here h's type looks ambiguous in 'b', but here's a legal call: + ...(h [True])... +That gives rise to a (X [Bool] beta) constraint, and using the +instance means we need (D Bool beta) and that fixes 'beta' via D's +fundep! + + So I think the only types we can reject as *definitely* ambiguous are ones like this + f :: (Cambig, Cnonambig) => tau +where + * 'Cambig', 'Cnonambig' are each a set of constraints. + * fv(Cambig) does not intersect fv( Cnonambig => tau ) + * The constraints in 'Cambig' are all of form (C a b c) + where a,b,c are type variables + * 'Cambig' is non-empty + * '-XUndecidableInstances' is not on. + +And that is what checkAmbiguity does. See Trac #6134. + + +Side note: the ambiguity check is only used for *user* types, not for +types coming from inteface files. The latter can legitimately have ambiguous types. Example class S a where s :: a -> (Int,Int) @@ -1351,33 +1321,51 @@ ambiguous types. Example Here the worker for f gets the type fw :: forall a. S a => Int -> (# Int, Int #) -If the list of tv_names is empty, we have a monotype, and then we -don't need to check for ambiguity either, because the test can't fail -(see is_ambig). +Note [Implicit parameters and ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only a *class* predicate can give rise to ambiguity +An *implicit parameter* cannot. For example: + foo :: (?x :: [a]) => Int + foo = length ?x +is fine. The call site will suppply a particular 'x' + +Furthermore, the type variables fixed by an implicit parameter +propagate to the others. E.g. + foo :: (Show a, ?x::[a]) => Int + foo = show (?x++?x) +The type of foo looks ambiguous. But it isn't, because at a call site +we might have + let ?x = 5::Int in foo +and all is well. In effect, implicit parameters are, well, parameters, +so we can take their type variables into account as part of the +"tau-tvs" stuff. This is done in the function 'FunDeps.grow'. -In addition, GHC insists that at least one type variable -in each constraint is in V. So we disallow a type like - forall a. Eq b => b -> b -even in a scope where b is in scope. \begin{code} checkAmbiguity :: [TyVar] -> ThetaType -> TyVarSet -> TcM () +-- Note [The ambiguity check for type signatures] checkAmbiguity forall_tyvars theta tau_tyvars - = mapM_ complain (filter is_ambig theta) + = do { undecidable_instances <- xoptM Opt_UndecidableInstances + ; unless undecidable_instances $ + mapM_ ambigErr (filter is_ambig candidates) } where - complain pred = addErrTc (ambigErr pred) - extended_tau_vars = growThetaTyVars theta tau_tyvars - -- See Note [Implicit parameters and ambiguity] in TcSimplify - is_ambig pred = isClassPred pred && - any ambig_var (varSetElems (tyVarsOfType pred)) + is_candidate pred + | Just (_, tys) <- getClassPredTys_maybe pred + , all isTyVarTy tys = True + | otherwise = False + + forall_tv_set = mkVarSet forall_tyvars + (candidates, others) = partition is_candidate theta + unambig_vars = growThetaTyVars theta (tau_tyvars `unionVarSet` tyVarsOfTypes others) - ambig_var ct_var = (ct_var `elem` forall_tyvars) && - not (ct_var `elemVarSet` extended_tau_vars) + is_ambig pred = (tyVarsOfType pred `minusVarSet` unambig_vars) + `intersectsVarSet` forall_tv_set -ambigErr :: PredType -> SDoc +ambigErr :: PredType -> TcM () ambigErr pred - = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprType pred), + = addErrTc $ + sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprType pred), nest 2 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$ ptext (sLit "must be reachable from the type after the '=>'"))] \end{code} @@ -1402,39 +1390,14 @@ growThetaTyVars theta tvs growPredTyVars :: TcPredType -> TyVarSet -- The set to extend - -> TyVarSet -- TyVars of the predicate if it intersects - -- the set, or is implicit parameter -growPredTyVars pred tvs = go (classifyPredType pred) + -> TyVarSet -- TyVars of the predicate if it intersects the set, +growPredTyVars pred tvs + | pred_tvs `intersectsVarSet` tvs = pred_tvs + | otherwise = emptyVarSet where - grow pred_tvs | pred_tvs `intersectsVarSet` tvs = pred_tvs - | otherwise = emptyVarSet - - go (IPPred _ ty) = tyVarsOfType ty -- See Note [Implicit parameters and ambiguity] - go (ClassPred _ tys) = grow (tyVarsOfTypes tys) - go (EqPred ty1 ty2) = grow (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2) - go (TuplePred ts) = unionVarSets (map (go . classifyPredType) ts) - go (IrredPred ty) = grow (tyVarsOfType ty) + pred_tvs = tyVarsOfType pred \end{code} -Note [Implicit parameters and ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Only a *class* predicate can give rise to ambiguity -An *implicit parameter* cannot. For example: - foo :: (?x :: [a]) => Int - foo = length ?x -is fine. The call site will suppply a particular 'x' - -Furthermore, the type variables fixed by an implicit parameter -propagate to the others. E.g. - foo :: (Show a, ?x::[a]) => Int - foo = show (?x++?x) -The type of foo looks ambiguous. But it isn't, because at a call site -we might have - let ?x = 5::Int in foo -and all is well. In effect, implicit parameters are, well, parameters, -so we can take their type variables into account as part of the -"tau-tvs" stuff. This is done in the function 'FunDeps.grow'. - \begin{code} checkThetaCtxt :: UserTypeCtxt -> ThetaType -> SDoc @@ -1486,26 +1449,27 @@ We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () -checkValidInstHead ctxt clas tys +checkValidInstHead ctxt clas cls_args = do { dflags <- getDynFlags -- Check language restrictions; -- but not for SPECIALISE isntance pragmas + ; let ty_args = dropWhile isKind cls_args ; unless spec_inst_prag $ do { checkTc (xopt Opt_TypeSynonymInstances dflags || - all tcInstHeadTyNotSynonym tys) - (instTypeErr pp_pred head_type_synonym_msg) + all tcInstHeadTyNotSynonym ty_args) + (instTypeErr clas cls_args head_type_synonym_msg) ; checkTc (xopt Opt_FlexibleInstances dflags || - all tcInstHeadTyAppAllTyVars tys) - (instTypeErr pp_pred head_type_args_tyvars_msg) + all tcInstHeadTyAppAllTyVars ty_args) + (instTypeErr clas cls_args head_type_args_tyvars_msg) ; checkTc (xopt Opt_MultiParamTypeClasses dflags || - isSingleton (dropWhile isKind tys)) -- IA0_NOTE: only count type arguments - (instTypeErr pp_pred head_one_type_msg) } + isSingleton ty_args) -- Only count type arguments + (instTypeErr clas cls_args head_one_type_msg) } -- May not contain type family applications - ; mapM_ checkTyFamFreeness tys + ; mapM_ checkTyFamFreeness ty_args - ; mapM_ checkValidMonoType tys + ; mapM_ checkValidMonoType ty_args -- For now, I only allow tau-types (not polytypes) in -- the head of an instance decl. -- E.g. instance C (forall a. a->a) is rejected @@ -1516,7 +1480,6 @@ checkValidInstHead ctxt clas tys where spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False } - pp_pred = pprClassPred clas tys head_type_synonym_msg = parens ( text "All instance types must be of the form (T t1 ... tn)" $$ text "where T is not a synonym." $$ @@ -1532,10 +1495,11 @@ checkValidInstHead ctxt clas tys text "Only one type can be given in an instance head." $$ text "Use -XMultiParamTypeClasses if you want to allow more.") -instTypeErr :: SDoc -> SDoc -> SDoc -instTypeErr pp_ty msg - = sep [ptext (sLit "Illegal instance declaration for") <+> quotes pp_ty, - nest 2 msg] +instTypeErr :: Class -> [Type] -> SDoc -> SDoc +instTypeErr cls tys msg + = hang (ptext (sLit "Illegal instance declaration for") + <+> quotes (pprClassPred cls tys)) + 2 msg \end{code} validDeivPred checks for OK 'deriving' context. See Note [Exotic @@ -1552,12 +1516,15 @@ not converge. See Trac #5287. \begin{code} validDerivPred :: TyVarSet -> PredType -> Bool -validDerivPred tv_set ty = case getClassPredTys_maybe ty of - Just (_, tys) | let fvs = fvTypes tys - -> hasNoDups fvs - && sizeTypes tys == length fvs - && all (`elemVarSet` tv_set) fvs - _ -> False +validDerivPred tv_set pred + = case classifyPredType pred of + ClassPred _ tys -> hasNoDups fvs + && sizeTypes tys == length fvs + && all (`elemVarSet` tv_set) fvs + TuplePred ps -> all (validDerivPred tv_set) ps + _ -> True -- Non-class predicates are ok + where + fvs = fvType pred \end{code} @@ -1568,25 +1535,33 @@ validDerivPred tv_set ty = case getClassPredTys_maybe ty of %************************************************************************ \begin{code} -checkValidInstance :: UserTypeCtxt -> LHsType Name -> [TyVar] -> ThetaType - -> Class -> [TcType] -> TcM () -checkValidInstance ctxt hs_type tyvars theta clas inst_tys - = setSrcSpan (getLoc hs_type) $ +checkValidInstance :: UserTypeCtxt -> LHsType Name -> Type + -> TcM ([TyVar], ThetaType, Class, [Type]) +checkValidInstance ctxt hs_type ty + = do { let (tvs, theta, tau) = tcSplitSigmaTy ty + ; case getClassPredTys_maybe tau of { + Nothing -> failWithTc (ptext (sLit "Malformed instance type")) ; + Just (clas,inst_tys) -> do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys) ; checkValidTheta ctxt theta - ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys) + -- The Termination and Coverate Conditions -- Check that instance inference will terminate (if we care) -- For Haskell 98 this will already have been done by checkValidTheta, -- but as we may be using other extensions we need to check. + -- + -- Note that the Termination Condition is *more conservative* than + -- the checkAmbiguity test we do on other type signatures + -- e.g. Bar a => Bar Int is ambiguous, but it also fails + -- the termination condition, because 'a' appears more often + -- in the constraint than in the head ; undecidable_ok <- xoptM Opt_UndecidableInstances ; unless undecidable_ok $ - mapM_ addErrTc (checkInstTermination inst_tys theta) - - -- The Coverage Condition - ; checkTc (undecidable_ok || checkInstCoverage clas inst_tys) - (instTypeErr (pprClassPred clas inst_tys) msg) - } + do { checkInstTermination inst_tys theta + ; checkTc (checkInstCoverage clas inst_tys) + (instTypeErr clas inst_tys msg) } + + ; return (tvs, theta, clas, inst_tys) } } } where msg = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"), undecidableMsg]) @@ -1618,19 +1593,19 @@ The underlying idea is that \begin{code} -checkInstTermination :: [TcType] -> ThetaType -> [MsgDoc] +checkInstTermination :: [TcType] -> ThetaType -> TcM () checkInstTermination tys theta - = mapCatMaybes check theta + = mapM_ check theta where fvs = fvTypes tys size = sizeTypes tys check pred | not (null (fvType pred \\ fvs)) - = Just (predUndecErr pred nomoreMsg $$ parens undecidableMsg) + = addErrTc (predUndecErr pred nomoreMsg $$ parens undecidableMsg) | sizePred pred >= size - = Just (predUndecErr pred smallerMsg $$ parens undecidableMsg) + = addErrTc (predUndecErr pred smallerMsg $$ parens undecidableMsg) | otherwise - = Nothing + = return () predUndecErr :: PredType -> SDoc -> SDoc predUndecErr pred msg = sep [msg, @@ -1668,7 +1643,7 @@ checkValidFamInst typats rhs mapM_ addErrTc (checkFamInstRhs typats (tcTyFamInsts rhs)) } --- Make sure that each type family instance is +-- Make sure that each type family application is -- (1) strictly smaller than the lhs, -- (2) mentions no type variable more often than the lhs, and -- (3) does not contain any further type family instances. @@ -1738,6 +1713,7 @@ fvType :: Type -> [TyVar] fvType ty | Just exp_ty <- tcView ty = fvType exp_ty fvType (TyVarTy tv) = [tv] fvType (TyConApp _ tys) = fvTypes tys +fvType (LitTy {}) = [] fvType (FunTy arg res) = fvType arg ++ fvType res fvType (AppTy fun arg) = fvType fun ++ fvType arg fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty) @@ -1748,8 +1724,9 @@ fvTypes tys = concat (map fvType tys) sizeType :: Type -> Int -- Size of a type: the number of variables and constructors sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty -sizeType (TyVarTy _) = 1 +sizeType (TyVarTy {}) = 1 sizeType (TyConApp _ tys) = sizeTypes tys + 1 +sizeType (LitTy {}) = 1 sizeType (FunTy arg res) = sizeType arg + sizeType res + 1 sizeType (AppTy fun arg) = sizeType fun + sizeType arg sizeType (ForAllTy _ ty) = sizeType ty @@ -1761,17 +1738,22 @@ sizeTypes xs = sum (map sizeType tys) -- Size of a predicate -- --- We are considering whether *class* constraints terminate --- Once we get into an implicit parameter or equality we --- can't get back to a class constraint, so it's safe --- to say "size 0". See Trac #4200. +-- We are considering whether class constraints terminate. +-- Equality constraints and constraints for the implicit +-- parameter class always termiante so it is safe to say "size 0". +-- (Implicit parameter constraints always terminate because +-- there are no instances for them---they are only solved by +-- "local instances" in expressions). +-- See Trac #4200. sizePred :: PredType -> Int -sizePred ty = go (classifyPredType ty) +sizePred ty = goClass ty where + goClass p | isIPPred p = 0 + | otherwise = go (classifyPredType p) + go (ClassPred _ tys') = sizeTypes tys' - go (IPPred {}) = 0 go (EqPred {}) = 0 - go (TuplePred ts) = sum (map (go . classifyPredType) ts) + go (TuplePred ts) = sum (map goClass ts) go (IrredPred ty) = sizeType ty \end{code} diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index acdc8389be..2941a17092 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -31,7 +31,6 @@ import TcMType import TcType import TcBinds import TcUnify -import TcErrors ( misMatchMsg ) import Name import TysWiredIn import Id @@ -398,21 +397,21 @@ tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } -- ParStmt: See notes with tcMcStmt -tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside +tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _) elt_ty thing_inside = do { (pairs', thing) <- loop bndr_stmts_s - ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) } + ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr, thing) } where -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing) loop [] = do { thing <- thing_inside elt_ty ; return ([], thing) } -- matching in the branches - loop ((stmts, names) : pairs) + loop (ParStmtBlock stmts names _ : pairs) = do { (stmts', (ids, pairs', thing)) <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> do { ids <- tcLookupLocalIds names ; (pairs', thing) <- loop pairs ; return (ids, pairs', thing) } - ; return ( (stmts', ids) : pairs', thing ) } + ; return ( ParStmtBlock stmts' ids noSyntaxExpr : pairs', thing ) } tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts , trS_bndrs = bindersMap @@ -675,7 +674,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap -- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call -- -> m (st1, (st2, st3)) -- -tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside +tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op) res_ty thing_inside = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind ; m_ty <- newFlexiTyVarTy star_star_kind @@ -687,14 +686,10 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty - ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $ - mkForAllTy alphaTyVar $ - alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy) - - ; (pairs', thing) <- loop m_ty bndr_stmts_s + ; (blocks', thing) <- loop m_ty bndr_stmts_s -- Typecheck bind: - ; let tys = map (mkBigCoreVarTupTy . snd) pairs' + ; let tys = [ mkBigCoreVarTupTy bs | ParStmtBlock _ bs _ <- blocks'] tuple_ty = mk_tuple_ty tys ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ @@ -702,7 +697,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi `mkFunTy` (tuple_ty `mkFunTy` res_ty) `mkFunTy` res_ty - ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) } + ; return (ParStmt blocks' mzip_op' bind_op', thing) } where mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys @@ -713,31 +708,19 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi loop _ [] = do { thing <- thing_inside res_ty ; return ([], thing) } -- matching in the branches - loop m_ty ((stmts, names) : pairs) + loop m_ty (ParStmtBlock stmts names return_op : pairs) = do { -- type dummy since we don't know all binder types yet - ty_dummy <- newFlexiTyVarTy liftedTypeKind - ; (stmts', (ids, pairs', thing)) - <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' -> + id_tys <- mapM (const (newFlexiTyVarTy liftedTypeKind)) names + ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreTupTy id_tys + ; (stmts', (ids, return_op', pairs', thing)) + <- tcStmtsAndThen ctxt tcMcStmt stmts m_tup_ty $ \m_tup_ty' -> do { ids <- tcLookupLocalIds names - ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreVarTupTy ids - - ; check_same m_tup_ty res_ty' - ; check_same m_tup_ty ty_dummy - + ; let tup_ty = mkBigCoreVarTupTy ids + ; return_op' <- tcSyntaxOp MCompOrigin return_op + (tup_ty `mkFunTy` m_tup_ty') ; (pairs', thing) <- loop m_ty pairs - ; return (ids, pairs', thing) } - ; return ( (stmts', ids) : pairs', thing ) } - - -- Check that the types match up. - -- This is a grevious hack. They always *will* match - -- If (>>=) and (>>) are polymorpic in the return type, - -- but we don't have any good way to incorporate the coercion - -- so for now we just check that it's the identity - check_same actual expected - = do { co <- unifyType actual expected - ; unless (isTcReflCo co) $ - failWithMisMatch [UnifyOrigin { uo_expected = expected - , uo_actual = actual }] } + ; return (ids, return_op', pairs', thing) } + ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) } tcMcStmt _ stmt _ _ = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) @@ -877,22 +860,5 @@ checkArgs fun (MatchGroup (match1:matches) _) args_in_match :: LMatch Name -> Int args_in_match (L _ (Match pats _ _)) = length pats checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty - -failWithMisMatch :: [EqOrigin] -> TcM a --- Generate the message when two types fail to match, --- going to some trouble to make it helpful. --- We take the failing types from the top of the origin stack --- rather than reporting the particular ones we are looking --- at right now -failWithMisMatch (item:origin) - = wrapEqCtxt origin $ - do { ty_act <- zonkTcType (uo_actual item) - ; ty_exp <- zonkTcType (uo_expected item) - ; env0 <- tcInitTidyEnv - ; let (env1, pp_exp) = tidyOpenType env0 ty_exp - (env2, pp_act) = tidyOpenType env1 ty_act - ; failWithTcM (env2, misMatchMsg True pp_exp pp_act) } -failWithMisMatch [] - = panic "failWithMisMatch" \end{code} diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index f1f502d967..468cab56ad 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -36,7 +36,6 @@ import TcUnify import TcHsType import TysWiredIn import TcEvidence -import StaticFlags import TyCon import DataCon import PrelNames @@ -138,12 +137,11 @@ data TcSigInfo = TcSigInfo { sig_id :: TcId, -- *Polymorphic* binder for this value... - sig_scoped :: [Name], -- Scoped type variables - -- 1-1 correspondence with a prefix of sig_tvs - -- However, may be fewer than sig_tvs; - -- see Note [More instantiated than scoped] - sig_tvs :: [TcTyVar], -- Instantiated type variables - -- See Note [Instantiate sig] + sig_tvs :: [(Maybe Name, TcTyVar)], + -- Instantiated type and kind variables + -- Just n <=> this skolem is lexically in scope with name n + -- See Note [Kind vars in sig_tvs] + -- See Note [More instantiated than scoped] in TcBinds sig_theta :: TcThetaType, -- Instantiated theta @@ -155,9 +153,20 @@ data TcSigInfo instance Outputable TcSigInfo where ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau}) - = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau + = ppr id <+> dcolon <+> vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau) + , ppr (map fst tyvars) ] \end{code} +Note [Kind vars in sig_tvs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With kind polymorphism a signature like + f :: forall f a. f a -> f a +may actuallly give rise to + f :: forall k. forall (f::k -> *) (a:k). f a -> f a +So the sig_tvs will be [k,f,a], but only f,a are scoped. +So the scoped ones are not necessarily the *inital* ones! + + Note [sig_tau may be polymorphic] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that "sig_tau" might actually be a polymorphic type, @@ -242,12 +251,14 @@ newNoSigLetBndr (LetGblBndr prags) name ty ---------- addInlinePrags :: TcId -> [LSig Name] -> TcM TcId addInlinePrags poly_id prags - = tc_inl inl_sigs + = do { traceTc "addInlinePrags" (ppr poly_id $$ ppr prags) + ; tc_inl inl_sigs } where inl_sigs = filter isInlineLSig prags tc_inl [] = return poly_id tc_inl (L loc (InlineSig _ prag) : other_inls) = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline) + ; traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) ; return (poly_id `setInlinePragma` prag) } tc_inl _ = panic "tc_inl" @@ -264,32 +275,7 @@ warnPrags id bad_sigs herald ----------------- mkLocalBinder :: Name -> TcType -> TcM TcId mkLocalBinder name ty - = do { checkUnboxedTuple ty $ - ptext (sLit "The variable") <+> quotes (ppr name) - ; return (Id.mkLocalId name ty) } - -checkUnboxedTuple :: TcType -> SDoc -> TcM () --- Check for an unboxed tuple type --- f = (# True, False #) --- Zonk first just in case it's hidden inside a meta type variable --- (This shows up as a (more obscure) kind error --- in the 'otherwise' case of tcMonoBinds.) -checkUnboxedTuple ty what - = do { zonked_ty <- zonkTcTypeCarefully ty - ; checkTc (not (isUnboxedTupleType zonked_ty)) - (unboxedTupleErr what zonked_ty) } - -------------------- -{- Only needed if we re-add Method constraints -bindInstsOfPatId :: TcId -> TcM a -> TcM (a, TcEvBinds) -bindInstsOfPatId id thing_inside - | not (isOverloadedTy (idType id)) - = do { res <- thing_inside; return (res, emptyTcEvBinds) } - | otherwise - = do { (res, lie) <- captureConstraints thing_inside - ; binds <- bindLocalMethods lie [id] - ; return (res, binds) } --} + = return (Id.mkLocalId name ty) \end{code} Note [Polymorphism and pattern bindings] @@ -413,9 +399,7 @@ tc_pat _ p@(QuasiQuotePat _) _ _ = pprPanic "Should never see QuasiQuotePat in type checker" (ppr p) tc_pat _ (WildPat _) pat_ty thing_inside - = do { checkUnboxedTuple pat_ty $ - ptext (sLit "A wild-card pattern") - ; res <- thing_inside + = do { res <- thing_inside ; return (WildPat pat_ty, res) } tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside @@ -431,11 +415,9 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside -- If you fix it, don't forget the bindInstsOfPatIds! ; return (mkHsWrapPatCo co (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } -tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside - = do { checkUnboxedTuple overall_pat_ty $ - ptext (sLit "The view pattern") <+> ppr vpat - - -- Morally, expr must have type `forall a1...aN. OPT' -> B` +tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside + = do { + -- Morally, expr must have type `forall a1...aN. OPT' -> B` -- where overall_pat_ty is an instance of OPT'. -- Here, we infer a rho type for it, -- which replaces the leading foralls and constraints @@ -486,6 +468,8 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) pat_ty ; (pats', res) <- tc_lpats penv pats arg_tys thing_inside + ; dflags <- getDynFlags + -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) -- so that we can experiment with lazy tuple-matching. -- This is a pretty odd place to make the switch, but @@ -494,7 +478,7 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside -- pat_ty /= pat_ty iff coi /= IdCo unmangled_result = TuplePat pats' boxity pat_ty' possibly_mangled_result - | opt_IrrefutableTuples && + | dopt Opt_IrrefutableTuples dflags && isBoxed boxity = LazyPat (noLoc unmangled_result) | otherwise = unmangled_result @@ -1060,9 +1044,4 @@ lazyUnliftedPatErr pat = failWithTc $ hang (ptext (sLit "A lazy (~) pattern cannot contain unlifted types:")) 2 (ppr pat) - -unboxedTupleErr :: SDoc -> Type -> SDoc -unboxedTupleErr what ty - = hang (what <+> ptext (sLit "cannot have an unboxed tuple type:")) - 2 (ppr ty) \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 8a5aab5437..fa87eb119c 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -12,6 +12,7 @@ module TcRnDriver ( tcRnLookupRdrName, getModuleInterface, tcRnDeclsi, + isGHCiMonad, #endif tcRnLookupName, tcRnGetInfo, @@ -24,6 +25,7 @@ module TcRnDriver ( import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif +import TypeRep import DynFlags import StaticFlags import HsSyn @@ -80,6 +82,7 @@ import TcType ( orphNamesOfDFunHead ) import Inst ( tcGetInstEnvs ) import Data.List ( sortBy ) import Data.IORef ( readIORef ) +import Data.Ord #ifdef GHCI import TcType ( isUnitTy, isTauTy ) @@ -150,7 +153,16 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcg_env <- {-# SCC "tcRnImports" #-} tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ; - setGblEnv tcg_env $ do { + + -- If the whole module is warned about or deprecated + -- (via mod_deprec) record that in tcg_warns. If we do thereby add + -- a WarnAll, it will override any subseqent depracations added to tcg_warns + let { tcg_env1 = case mod_deprec of + Just txt -> tcg_env { tcg_warns = WarnAll txt } + Nothing -> tcg_env + } ; + + setGblEnv tcg_env1 $ do { -- Load the hi-boot interface for this module, if any -- We do this now so that the boot_names can be passed @@ -171,16 +183,6 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcRnSrcDecls boot_iface local_decls ; setGblEnv tcg_env $ do { - -- Report the use of any deprecated things - -- We do this *before* processsing the export list so - -- that we don't bleat about re-exporting a deprecated - -- thing (especially via 'module Foo' export item) - -- That is, only uses in the *body* of the module are complained about - traceRn (text "rn3") ; - failIfErrsM ; -- finishWarnings crashes sometimes - -- as a result of typechecker repairs (e.g. unboundNames) - tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ; - -- Process the export list traceRn (text "rn4a: before exports"); tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; @@ -339,6 +341,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Just discard the auxiliary bindings; they are generated -- only for Haskell source code, and should already be in Core tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; + safe_mode <- liftIO $ finalSafeMode (hsc_dflags hsc_env) tcg_env ; dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ; setGblEnv tcg_env $ do { @@ -366,20 +369,21 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_fam_insts = tcg_fam_insts tcg_env, mg_inst_env = tcg_inst_env tcg_env, mg_fam_inst_env = tcg_fam_inst_env tcg_env, - mg_rules = [], - mg_vect_decls = [], - mg_anns = [], - mg_binds = core_binds, + mg_rules = [], + mg_vect_decls = [], + mg_anns = [], + mg_binds = core_binds, -- Stubs - mg_rdr_env = emptyGlobalRdrEnv, - mg_fix_env = emptyFixityEnv, - mg_warns = NoWarnings, - mg_foreign = NoStubs, - mg_hpc_info = emptyHpcInfo False, - mg_modBreaks = emptyModBreaks, - mg_vect_info = noVectInfo, - mg_trust_pkg = False, + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_warns = NoWarnings, + mg_foreign = NoStubs, + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo, + mg_safe_haskell = safe_mode, + mg_trust_pkg = False, mg_dependent_files = dep_files } } ; @@ -548,17 +552,10 @@ tcRnHsBootDecls decls ; mapM_ (badBootDecl "rule") rule_decls ; mapM_ (badBootDecl "vect") vect_decls - -- Typecheck type/class decls + -- Typecheck type/class/isntance decls ; traceTc "Tc2 (boot)" empty - ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls - ; setGblEnv tcg_env $ do { - - -- Typecheck instance decls - -- Family instance declarations are rejected here - ; traceTc "Tc3" empty ; (tcg_env, inst_infos, _deriv_binds) - <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls - + <- tcTyClsInstDecls emptyModDetails tycl_decls inst_decls deriv_decls ; setGblEnv tcg_env $ do { -- Typecheck value declarations @@ -580,7 +577,7 @@ tcRnHsBootDecls decls } ; setGlobalTypeEnv gbl_env type_env2 - }}} + }} ; traceTc "boot" (ppr lie); return gbl_env } badBootDecl :: String -> Located decl -> TcM () @@ -894,14 +891,11 @@ tcTopSrcDecls boot_details -- The latter come in via tycl_decls traceTc "Tc2 (src)" empty ; - tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; - setGblEnv tcg_env $ do { - -- Source-language instances, including derivings, -- and import the supporting declarations traceTc "Tc3" empty ; (tcg_env, inst_infos, deriv_binds) - <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls; + <- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ; setGblEnv tcg_env $ do { -- Foreign import declarations next. @@ -961,9 +955,55 @@ tcTopSrcDecls boot_details , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; return (tcg_env', tcl_env) - }}}}}}} + }}}}}} + +--------------------------- +tcTyClsInstDecls :: ModDetails + -> [TyClGroup Name] + -> [LInstDecl Name] + -> [LDerivDecl Name] + -> TcM (TcGblEnv, -- The full inst env + [InstInfo Name], -- Source-code instance decls to process; + -- contains all dfuns for this module + HsValBinds Name) -- Supporting bindings for derived instances + +tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls + = tcExtendTcTyThingEnv [(con, AFamDataCon) | lid <- inst_decls + , con <- get_cons lid ] $ + -- Note [AFamDataCon: not promoting data family constructors] + do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + ; setGblEnv tcg_env $ + tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls } + where + -- get_cons extracts the *constructor* bindings of the declaration + get_cons :: LInstDecl Name -> [Name] + get_cons (L _ (FamInstD { lid_inst = fid })) = get_fi_cons fid + get_cons (L _ (ClsInstD { cid_fam_insts = fids })) = concatMap (get_fi_cons . unLoc) fids + + get_fi_cons :: FamInstDecl Name -> [Name] + get_fi_cons (FamInstDecl { fid_defn = TyData { td_cons = cons } }) + = map (unLoc . con_name . unLoc) cons + get_fi_cons (FamInstDecl {}) = [] \end{code} +Note [AFamDataCon: not promoting data family constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T Int = MkT + data Proxy (a :: k) + data S = MkS (Proxy 'MkT) + +Is it ok to use the promoted data family instance constructor 'MkT' in +the data declaration for S? No, we don't allow this. It *might* make +sense, but at least it would mean that we'd have to interleave +typechecking instances and data types, whereas at present we do data +types *then* instances. + +So to check for this we put in the TcLclEnv a binding for all the family +constructors, bound to AFamDataCon, so that if we trip over 'MkT' when +type checking 'S' we'll produce a decent error message. + %************************************************************************ %* * @@ -1156,6 +1196,7 @@ setInteractiveContext hsc_env icxt thing_inside (mkNameSet (concatMap snd con_fields)) -- setting tcg_field_env is necessary to make RecordWildCards work -- (test: ghci049) + , tcg_fix_env = ic_fix_env icxt }) $ tcExtendGhciEnv visible_tmp_ids $ -- Note [GHCi temporary Ids] @@ -1168,13 +1209,13 @@ setInteractiveContext hsc_env icxt thing_inside -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName - -> IO (Messages, Maybe ([Id], LHsExpr Id)) + -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv)) tcRnStmt hsc_env ictxt rdr_stmt = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { -- The real work is done here - (bound_ids, tc_expr) <- tcUserStmt rdr_stmt ; + ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; zonked_expr <- zonkTopLExpr tc_expr ; zonked_ids <- zonkTopBndrs bound_ids ; @@ -1209,7 +1250,7 @@ tcRnStmt hsc_env ictxt rdr_stmt (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, text "Typechecked expr" <+> ppr zonked_expr]) ; - return (global_ids, zonked_expr) + return (global_ids, zonked_expr, fix_env) } where bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), @@ -1278,13 +1319,15 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p -- for more details. We do this lifting by trying different ways ('plans') of -- lifting the code into the IO monad and type checking each plan until one -- succeeds. -tcUserStmt :: LStmt RdrName -> TcM PlanResult +tcUserStmt :: LStmt RdrName -> TcM (PlanResult, FixityEnv) -- An expression typed at the prompt is treated very specially tcUserStmt (L loc (ExprStmt expr _ _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! + ; ghciStep <- getGhciStepIO ; uniq <- newUnique + ; interPrintName <- getInteractivePrintName ; let fresh_it = itName uniq loc matches = [mkMatch [] rn_expr emptyLocalBinds] -- [it = expr] @@ -1293,25 +1336,33 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) -- free variables, and they in turn may have free type variables -- (if we are at a breakpoint, say). We must put those free vars - -- [let it = expr] let_stmt = L loc $ LetStmt $ HsValBinds $ ValBindsOut [(NonRecursive,unitBag the_bind)] [] + -- [it <- e] - bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) rn_expr + bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) + (nlHsApp ghciStep rn_expr) (HsVar bindIOName) noSyntaxExpr + -- [; print it] - print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) + print_it = L loc $ ExprStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) (HsVar thenIOName) noSyntaxExpr placeHolderType -- The plans are: -- A. [it <- e; print it] but not if it::() -- B. [it <- e] -- C. [let it = e; print it] - ; runPlans [ -- Plan A + -- + -- Ensure that type errors don't get deferred when type checking the + -- naked expression. Deferring type errors here is unhelpful because the + -- expression gets evaluated right away anyway. It also would potentially + -- emit two redundant type-error warnings, one from each plan. + ; plan <- unsetDOptM Opt_DeferTypeErrors $ runPlans [ + -- Plan A do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] ; it_ty <- zonkTcType (idType it_id) - ; when (isUnitTy it_ty) failM + ; when (isUnitTy $ it_ty) failM ; return stuff }, -- Plan B; a naked bind statment @@ -1324,31 +1375,41 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) -- This two-step story is very clunky, alas do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) --- checkNoErrs defeats the error recovery of let-bindings - ; tcGhciStmts [let_stmt, print_it] } - ]} + ; tcGhciStmts [let_stmt, print_it] } ] + + ; fix_env <- getFixityEnv + ; return (plan, fix_env) } tcUserStmt rdr_stmt@(L loc _) - = do { (([rn_stmt], _), fvs) <- checkNoErrs $ - rnStmts GhciStmt [rdr_stmt] $ \_ -> - return ((), emptyFVs) ; - -- Don't try to typecheck if the renamer fails! + = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ + rnStmts GhciStmt [rdr_stmt] $ \_ -> do + fix_env <- getFixityEnv + return (fix_env, emptyFVs) + -- Don't try to typecheck if the renamer fails! ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; rnDump (ppr rn_stmt) ; + ; ghciStep <- getGhciStepIO + ; let gi_stmt + | (L loc (BindStmt pat expr op1 op2)) <- rn_stmt + = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2 + | otherwise = rn_stmt + ; opt_pr_flag <- doptM Opt_PrintBindResult ; let print_result_plan | opt_pr_flag -- The flag says "print result" - , [v] <- collectLStmtBinders rn_stmt -- One binder - = [mk_print_result_plan rn_stmt v] + , [v] <- collectLStmtBinders gi_stmt -- One binder + = [mk_print_result_plan gi_stmt v] | otherwise = [] -- The plans are: -- [stmt; print v] if one binder and not v::() -- [stmt] otherwise - ; runPlans (print_result_plan ++ [tcGhciStmts [rn_stmt]]) } + ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) + ; return (plan, fix_env) } where - mk_print_result_plan rn_stmt v - = do { stuff@([v_id], _) <- tcGhciStmts [rn_stmt, print_v] + mk_print_result_plan stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] ; v_ty <- zonkTcType (idType v_id) ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } @@ -1403,6 +1464,43 @@ tcGhciStmts stmts return (ids, mkHsDictLet (EvBinds const_binds) $ noLoc (HsDo GhciStmt stmts io_ret_ty)) } + +-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) +getGhciStepIO :: TcM (LHsExpr Name) +getGhciStepIO = do + ghciTy <- getGHCiMonad + fresh_a <- newUnique + let a_tv = mkTcTyVarName fresh_a (fsLit "a") + ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) + ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) + + stepTy :: LHsType Name -- Renamed, so needs all binders in place + stepTy = noLoc $ HsForAllTy Implicit + (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)] + , hsq_kvs = [] }) + (noLoc []) + (nlHsFunTy ghciM ioM) + step = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy + return step + +isGHCiMonad :: HscEnv -> InteractiveContext -> String -> IO (Messages, Maybe Name) +isGHCiMonad hsc_env ictxt ty + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env ictxt $ do + rdrEnv <- getGlobalRdrEnv + let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) + case occIO of + Just [n] -> do + let name = gre_name n + ghciClass <- tcLookupClass ghciIoClassName + userTyCon <- tcLookupTyCon name + let userTy = TyConApp userTyCon [] + _ <- tcLookupInstance ghciClass [userTy] + return name + + Just _ -> failWithTc $ text "Ambigous type!" + Nothing -> failWithTc $ text ("Can't find type:" ++ ty) + \end{code} tcRnExpr just finds the type of an expression @@ -1423,13 +1521,14 @@ tcRnExpr hsc_env ictxt rdr_expr -- it might have a rank-2 type (e.g. :t runST) uniq <- newUnique ; let { fresh_it = itName uniq (getLoc rdr_expr) } ; - ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; + (((_tc_expr, res_ty), untch), lie) <- captureConstraints $ + captureUntouchables (tcInferRho rn_expr) ; ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ {-# SCC "simplifyInfer" #-} simplifyInfer True {- Free vars are closed -} False {- No MR for now -} [(fresh_it, res_ty)] - lie ; + (untch,lie) ; _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; @@ -1458,7 +1557,7 @@ tcRnType hsc_env ictxt normalise rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { - rn_type <- rnLHsType GHCiCtx rdr_type ; + (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type ; failIfErrsM ; -- Now kind-check the type @@ -1743,7 +1842,7 @@ pprModGuts (ModGuts { mg_tcs = tcs ppr_types :: [ClsInst] -> TypeEnv -> SDoc ppr_types insts type_env - = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids) + = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids) where dfun_ids = map instanceDFunId insts ids = [id | id <- typeEnvIds type_env, want_sig id] @@ -1782,17 +1881,15 @@ ppr_fam_insts fam_insts = ppr_sigs :: [Var] -> SDoc ppr_sigs ids -- Print type signatures; sort by OccName - = vcat (map ppr_sig (sortLe le_sig ids)) + = vcat (map ppr_sig (sortBy (comparing getOccName) ids)) where - le_sig id1 id2 = getOccName id1 <= getOccName id2 - ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id)) + ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id))) ppr_tydecls :: [TyCon] -> SDoc ppr_tydecls tycons -- Print type constructor info; sort by OccName - = vcat (map ppr_tycon (sortLe le_sig tycons)) + = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons)) where - le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon)) ppr_rules :: [CoreRule] -> SDoc diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 351a3e25d0..f68599898e 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -44,12 +44,12 @@ import UniqSupply import Unique import UniqFM import DynFlags +import Maybes import StaticFlags import FastString import Panic import Util -import System.IO import Data.IORef import qualified Data.Set as Set import Control.Monad @@ -147,6 +147,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcl_th_ctxt = topStage, tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, + tcl_tidy = emptyTidyEnv, tcl_tyvars = tvs_var, tcl_lie = lie_var, tcl_meta = meta_var, @@ -185,6 +186,9 @@ initTcPrintErrors -- Used from the interactive loop only -> IO (Messages, Maybe r) initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo + +initTcForLookup :: HscEnv -> TcM a -> IO a +initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE \end{code} %************************************************************************ @@ -220,6 +224,9 @@ initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside %************************************************************************ \begin{code} +discardResult :: TcM a -> TcM () +discardResult a = a >> return () + getTopEnv :: TcRnIf gbl lcl HscEnv getTopEnv = do { env <- getEnv; return (env_top env) } @@ -425,9 +432,9 @@ traceTc = traceTcN 1 traceTcN :: Int -> String -> SDoc -> TcRn () traceTcN level herald doc - | level <= opt_TraceLevel = traceOptTcRn Opt_D_dump_tc_trace $ - hang (text herald) 2 doc - | otherwise = return () + = do dflags <- getDynFlags + when (level <= traceLevel dflags) $ + traceOptTcRn Opt_D_dump_tc_trace $ hang (text herald) 2 doc traceRn, traceSplice :: SDoc -> TcRn () traceRn = traceOptTcRn Opt_D_dump_rn_trace @@ -440,7 +447,8 @@ traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything traceOptIf flag doc = ifDOptM flag $ - liftIO (printForUser stderr alwaysQualify doc) + do dflags <- getDynFlags + liftIO (printInfoForUser dflags alwaysQualify doc) traceOptTcRn :: DynFlag -> SDoc -> TcRn () -- Output the message, with current location if opt_PprStyle_Debug @@ -455,7 +463,7 @@ traceOptTcRn flag doc = ifDOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; dflags <- getDynFlags - ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } + ; liftIO (printInfoForUser dflags (mkPrintUnqualified dflags rdr_env) doc) } debugDumpTcRn :: SDoc -> TcRn () debugDumpTcRn doc | opt_NoDebugOutput = return () @@ -482,6 +490,12 @@ setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_ins getIsGHCi :: TcRn Bool getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) } +getGHCiMonad :: TcRn Name +getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } + +getInteractivePrintName :: TcRn Name +getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } + tcIsHsBoot :: TcRn Bool tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } @@ -624,7 +638,7 @@ mkLongErrAt loc msg extra = do { traceTc "Adding error:" (mkLocMessage SevError loc (msg $$ extra)) ; rdr_env <- getGlobalRdrEnv ; dflags <- getDynFlags ; - return $ mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } + return $ mkLongErrMsg dflags loc (mkPrintUnqualified dflags rdr_env) msg extra } addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError @@ -906,33 +920,14 @@ add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () add_warn_at loc msg extra_info = do { rdr_env <- getGlobalRdrEnv ; dflags <- getDynFlags ; - let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) + let { warn = mkLongWarnMsg dflags loc (mkPrintUnqualified dflags rdr_env) msg extra_info } ; reportWarning warn } -\end{code} - ------------------------------------ - Tidying - -We initialise the "tidy-env", used for tidying types before printing, -by building a reverse map from the in-scope type variables to the -OccName that the programmer originally used for them -\begin{code} tcInitTidyEnv :: TcM TidyEnv tcInitTidyEnv = do { lcl_env <- getLclEnv - ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty) - | ATyVar name ty <- nameEnvElts (tcl_env lcl_env) - , tcIsTyVarTy ty ] - ; return (foldl add emptyTidyEnv nm_tv_prs) } - where - add (env,subst) (name, tyvar) - = case tidyOccName env (nameOccName name) of - (env', occ') -> (env', extendVarEnv subst tyvar tyvar') - where - tyvar' = setTyVarName tyvar name' - name' = tidyNameOcc name occ' + ; return (tcl_tidy lcl_env) } \end{code} ----------------------------------- @@ -1030,12 +1025,17 @@ emitFlats :: Cts -> TcM () emitFlats cts = do { lie_var <- getConstraintVar ; updTcRef lie_var (`addFlats` cts) } - + emitImplication :: Implication -> TcM () emitImplication ct = do { lie_var <- getConstraintVar ; updTcRef lie_var (`addImplics` unitBag ct) } +emitWC :: WantedConstraints -> TcM () +emitWC wc + = do { emitFlats (keepWanted (wc_flat wc)) + ; emitImplications (wc_impl wc) } + emitImplications :: Bag Implication -> TcM () emitImplications ct = do { lie_var <- getConstraintVar ; @@ -1127,8 +1127,17 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) %************************************************************************ \begin{code} +-- | Mark that safe inference has failed recordUnsafeInfer :: TcM () recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False + +-- | Figure out the final correct safe haskell mode +finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode +finalSafeMode dflags tcg_env = do + safeInf <- readIORef (tcg_safeInfer tcg_env) + return $ if safeInferOn dflags && not safeInf + then Sf_None + else safeHaskell dflags \end{code} @@ -1219,7 +1228,8 @@ failIfM :: MsgDoc -> IfL a failIfM msg = do { env <- getLclEnv ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; liftIO (printErrs full_msg defaultErrStyle) + ; dflags <- getDynFlags + ; liftIO (log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) full_msg) ; failM } -------------------- @@ -1246,15 +1256,15 @@ forkM_maybe doc thing_inside -- Bleat about errors in the forked thread, if -ddump-if-trace is on -- Otherwise we silently discard errors. Errors can legitimately -- happen when compiling interface signatures (see tcInterfaceSigs) - ifDOptM Opt_D_dump_if_trace - (print_errs (hang (text "forkM failed:" <+> doc) - 2 (text (show exn)))) + ifDOptM Opt_D_dump_if_trace $ do + dflags <- getDynFlags + let msg = hang (text "forkM failed:" <+> doc) + 2 (text (show exn)) + liftIO $ log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg ; traceIf (text "} ending fork (badly)" <+> doc) ; return Nothing } }} - where - print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle) forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 8ff3ce3f76..1ed3d0d198 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -51,13 +51,13 @@ module TcRnTypes( Untouchables(..), inTouchableRange, isNoUntouchables, -- Canonical constraints - Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, - singleCt, extendCts, isEmptyCts, isCTyEqCan, - isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, + Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, keepWanted, + singleCt, extendCts, isEmptyCts, isCTyEqCan, isCFunEqCan, + isCDictCan_Maybe, isCFunEqCan_Maybe, isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, - isGivenCt_maybe, isGivenOrSolvedCt, - ctWantedLoc, - SubGoalDepth, mkNonCanonical, ctPred, + isGivenCt, + ctWantedLoc, ctEvidence, + SubGoalDepth, mkNonCanonical, ctPred, ctEvPred, ctEvTerm, ctEvId, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, andWC, addFlats, addImplics, mkFlatWC, @@ -65,16 +65,15 @@ module TcRnTypes( Implication(..), CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin, CtOrigin(..), EqOrigin(..), - WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt, + WantedLoc, GivenLoc, pushErrCtxt, pushErrCtxtSameOrigin, SkolemInfo(..), - CtFlavor(..), pprFlavorArising, - mkSolvedFlavor, mkGivenFlavor, mkWantedFlavor, - isWanted, isGivenOrSolved, isGiven_maybe, isSolved, - isDerived, getWantedLoc, canSolve, canRewrite, - combineCtLoc, + CtEvidence(..), pprFlavorArising, + mkGivenLoc, + isWanted, isGiven, + isDerived, getWantedLoc, getGivenLoc, canSolve, canRewrite, -- Pretty printing pprEvVarTheta, pprWantedsWithLocs, @@ -90,7 +89,7 @@ module TcRnTypes( import HsSyn import HscTypes -import TcEvidence( EvBind, EvBindsVar, EvTerm ) +import TcEvidence import Type import Class ( Class ) import TyCon ( TyCon ) @@ -120,6 +119,7 @@ import DynFlags import Outputable import ListSetOps import FastString +import Util import Data.Set (Set) @@ -225,8 +225,8 @@ data TcGblEnv -- Updated at intervals (e.g. after dealing with types and classes) tcg_inst_env :: InstEnv, - -- ^ Instance envt for /home-package/ modules; Includes the dfuns in - -- tcg_insts + -- ^ Instance envt for all /home-package/ modules; + -- Includes the dfuns in tcg_insts tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances -- Now a bunch of things about this module that are simply @@ -323,8 +323,9 @@ data TcGblEnv tcg_main :: Maybe Name, -- ^ The Name of the main -- function, if this module is -- the main module. - tcg_safeInfer :: TcRef Bool -- Has the typechecker infered this - -- module as -XSafe (Safe Haskell) + tcg_safeInfer :: TcRef Bool -- Has the typechecker + -- inferred this module + -- as -XSafe (Safe Haskell) } data RecFieldEnv @@ -429,6 +430,9 @@ data TcLclEnv -- Changes as we move inside an expression tcl_env :: TcTypeEnv, -- The local type environment: Ids and -- TyVars defined in this module + + tcl_tidy :: TidyEnv, -- Used for tidying types; contains all + -- in-scope type variables (but not term variables) tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars" -- Namely, the in-scope TyVars bound in tcl_env, @@ -566,8 +570,8 @@ data TcTyThing tct_closed :: TopLevelFlag, -- See Note [Bindings with closed types] tct_level :: ThLevel } - | ATyVar Name TcType -- The type to which the lexically scoped type vaiable - -- is currently refined. We only need the Name + | ATyVar Name TcTyVar -- The type variable to which the lexically scoped type + -- variable is bound. We only need the Name -- for error-message purposes; it is the corresponding -- Name in the domain of the envt @@ -576,27 +580,11 @@ data TcTyThing -- Can be a mono-kind or a poly-kind; in TcTyClsDcls see -- Note [Type checking recursive type and class declarations] - | ANothing -- see Note [ANothing] - -{- -Note [ANothing] -~~~~~~~~~~~~~~~ - -We don't want to allow promotion in a strongly connected component -when kind checking. - -Consider: - data T f = K (f (K Any)) - -When kind checking the `data T' declaration the local env contains the -mappings: - T -> AThing <some initial kind> - K -> ANothing - -ANothing is only used for DataCons, and only used during type checking -in tcTyClGroup. --} + | AFamDataCon -- Data constructor for a data family + -- See Note [AFamDataCon: not promoting data family constructors] in TcRnDriver + | ARecDataCon -- Data constructor in a reuursive loop + -- See Note [ARecDataCon: recusion and promoting data constructors] in TcTyClsDecls instance Outputable TcTyThing where -- Debugging only ppr (AGlobal g) = pprTyThing g @@ -607,16 +595,19 @@ instance Outputable TcTyThing where -- Debugging only <+> ppr (tct_level elt)) ppr (ATyVar tv _) = text "Type variable" <+> quotes (ppr tv) ppr (AThing k) = text "AThing" <+> ppr k - ppr ANothing = text "ANothing" + ppr AFamDataCon = text "AFamDataCon" + ppr ARecDataCon = text "ARecDataCon" pprTcTyThingCategory :: TcTyThing -> SDoc pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing pprTcTyThingCategory (ATyVar {}) = ptext (sLit "Type variable") pprTcTyThingCategory (ATcId {}) = ptext (sLit "Local identifier") pprTcTyThingCategory (AThing {}) = ptext (sLit "Kinded thing") -pprTcTyThingCategory ANothing = ptext (sLit "Opaque thing") +pprTcTyThingCategory AFamDataCon = ptext (sLit "Family data con") +pprTcTyThingCategory ARecDataCon = ptext (sLit "Recursive data con") \end{code} + Note [Bindings with closed types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -829,10 +820,15 @@ instance Outputable WhereFrom where \begin{code} --- Types without any type functions inside. However, note that xi --- types CAN contain unexpanded type synonyms; however, the --- (transitive) expansions of those type synonyms will not contain any --- type functions. +-- The syntax of xi types: +-- xi ::= a | T xis | xis -> xis | ... | forall a. tau +-- Two important notes: +-- (i) No type families, unless we are under a ForAll +-- (ii) Note that xi types can contain unexpanded type synonyms; +-- however, the (transitive) expansions of those type synonyms +-- will not contain any type functions, unless we are under a ForAll. +-- We enforce the structure of Xi types when we flatten (TcCanonical) + type Xi = Type -- In many comments, "xi" ranges over Xi type Cts = Bag Ct @@ -843,8 +839,7 @@ type SubGoalDepth = Int -- An ever increasing number used to restrict data Ct -- Atomic canonical constraints = CDictCan { -- e.g. Num xi - cc_id :: EvVar, - cc_flavor :: CtFlavor, + cc_ev :: CtEvidence, cc_class :: Class, cc_tyargs :: [Xi], @@ -852,21 +847,11 @@ data Ct -- See Note [WorkList] } - | CIPCan { -- ?x::tau - -- See note [Canonical implicit parameter constraints]. - cc_id :: EvVar, - cc_flavor :: CtFlavor, - cc_ip_nm :: IPName Name, - cc_ip_ty :: TcTauType, -- Not a Xi! See same not as above - cc_depth :: SubGoalDepth -- See Note [WorkList] - } - | CIrredEvCan { -- These stand for yet-unknown predicates - cc_id :: EvVar, - cc_flavor :: CtFlavor, + cc_ev :: CtEvidence, cc_ty :: Xi, -- cc_ty is flat hence it may only be of the form (tv xi1 xi2 ... xin) -- Since, if it were a type constructor application, that'd make the - -- whole constraint a CDictCan, CIPCan, or CTyEqCan. And it can't be + -- whole constraint a CDictCan, or CTyEqCan. And it can't be -- a type family application either because it's a Xi type. cc_depth :: SubGoalDepth -- See Note [WorkList] } @@ -877,8 +862,7 @@ data Ct -- * typeKind xi `compatKind` typeKind tv -- See Note [Spontaneous solving and kind compatibility] -- * We prefer unification variables on the left *JUST* for efficiency - cc_id :: EvVar, - cc_flavor :: CtFlavor, + cc_ev :: CtEvidence, cc_tyvar :: TcTyVar, cc_rhs :: Xi, @@ -888,8 +872,7 @@ data Ct | CFunEqCan { -- F xis ~ xi -- Invariant: * isSynFamilyTyCon cc_fun -- * typeKind (F xis) `compatKind` typeKind xi - cc_id :: EvVar, - cc_flavor :: CtFlavor, + cc_ev :: CtEvidence, cc_fun :: TyCon, -- A type function cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated cc_rhs :: Xi, -- *never* over-saturated (because if so @@ -900,34 +883,45 @@ data Ct } | CNonCanonical { -- See Note [NonCanonical Semantics] - cc_id :: EvVar, - cc_flavor :: CtFlavor, + cc_ev :: CtEvidence, cc_depth :: SubGoalDepth } \end{code} \begin{code} -mkNonCanonical :: EvVar -> CtFlavor -> Ct -mkNonCanonical ev flav = CNonCanonical { cc_id = ev, cc_flavor = flav, cc_depth = 0} +mkNonCanonical :: CtEvidence -> Ct +mkNonCanonical flav = CNonCanonical { cc_ev = flav, cc_depth = 0} + +ctEvidence :: Ct -> CtEvidence +ctEvidence = cc_ev ctPred :: Ct -> PredType -ctPred (CNonCanonical { cc_id = v }) = evVarPred v +ctPred ct = ctEvPred (cc_ev ct) + +keepWanted :: Cts -> Cts +keepWanted = filterBag isWantedCt + -- DV: there used to be a note here that read: + -- ``Important: use fold*r*Bag to preserve the order of the evidence variables'' + -- DV: Is this still relevant? + +-- ToDo Check with Dimitrios +{- +ctPred (CNonCanonical { cc_ev = fl }) = ctEvPred fl ctPred (CDictCan { cc_class = cls, cc_tyargs = xis }) = mkClassPred cls xis ctPred (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) - = mkEqPred (mkTyVarTy tv, xi) + = mkTcEqPred (mkTyVarTy tv) xi ctPred (CFunEqCan { cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 }) - = mkEqPred(mkTyConApp fn xis1, xi2) -ctPred (CIPCan { cc_ip_nm = nm, cc_ip_ty = xi }) - = mkIPPred nm xi + = mkTcEqPred (mkTyConApp fn xis1) xi2 ctPred (CIrredEvCan { cc_ty = xi }) = xi +-} \end{code} %************************************************************************ %* * - CtFlavor + CtEvidence The "flavor" of a canonical constraint %* * %************************************************************************ @@ -935,20 +929,17 @@ ctPred (CIrredEvCan { cc_ty = xi }) = xi \begin{code} ctWantedLoc :: Ct -> WantedLoc -- Only works for Wanted/Derived -ctWantedLoc ct = ASSERT2( not (isGivenOrSolved (cc_flavor ct)), ppr ct ) - getWantedLoc (cc_flavor ct) +ctWantedLoc ct = ASSERT2( not (isGiven (cc_ev ct)), ppr ct ) + getWantedLoc (cc_ev ct) isWantedCt :: Ct -> Bool -isWantedCt ct = isWanted (cc_flavor ct) - -isDerivedCt :: Ct -> Bool -isDerivedCt ct = isDerived (cc_flavor ct) +isWantedCt = isWanted . cc_ev -isGivenCt_maybe :: Ct -> Maybe GivenKind -isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct) +isGivenCt :: Ct -> Bool +isGivenCt = isGiven . cc_ev -isGivenOrSolvedCt :: Ct -> Bool -isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct) +isDerivedCt :: Ct -> Bool +isDerivedCt = isDerived . cc_ev isCTyEqCan :: Ct -> Bool isCTyEqCan (CTyEqCan {}) = True @@ -959,10 +950,6 @@ isCDictCan_Maybe :: Ct -> Maybe Class isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls isCDictCan_Maybe _ = Nothing -isCIPCan_Maybe :: Ct -> Maybe (IPName Name) -isCIPCan_Maybe (CIPCan {cc_ip_nm = nm }) = Just nm -isCIPCan_Maybe _ = Nothing - isCIrredEvCan :: Ct -> Bool isCIrredEvCan (CIrredEvCan {}) = True isCIrredEvCan _ = False @@ -971,6 +958,10 @@ isCFunEqCan_Maybe :: Ct -> Maybe TyCon isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc isCFunEqCan_Maybe _ = Nothing +isCFunEqCan :: Ct -> Bool +isCFunEqCan (CFunEqCan {}) = True +isCFunEqCan _ = False + isCNonCanonical :: Ct -> Bool isCNonCanonical (CNonCanonical {}) = True isCNonCanonical _ = False @@ -978,16 +969,13 @@ isCNonCanonical _ = False \begin{code} instance Outputable Ct where - ppr ct = ppr (cc_flavor ct) <> braces (ppr (cc_depth ct)) - <+> ppr ev_var <+> dcolon <+> ppr (ctPred ct) - <+> parens (text ct_sort) - where ev_var = cc_id ct - ct_sort = case ct of + ppr ct = ppr (cc_ev ct) <+> + braces (ppr (cc_depth ct)) <+> parens (text ct_sort) + where ct_sort = case ct of CTyEqCan {} -> "CTyEqCan" CFunEqCan {} -> "CFunEqCan" CNonCanonical {} -> "CNonCanonical" CDictCan {} -> "CDictCan" - CIPCan {} -> "CIPCan" CIrredEvCan {} -> "CIrredEvCan" \end{code} @@ -1220,57 +1208,80 @@ pprWantedsWithLocs wcs %* * %************************************************************************ +Note [Evidence field of CtEvidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During constraint solving we never look at the type of ctev_evtm, or +ctev_evar; instead we look at the cte_pred field. The evtm/evar field +may be un-zonked. + \begin{code} -data CtFlavor - = Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds - | Derived WantedLoc -- Derived's are just hints for unifications - | Wanted WantedLoc -- We have no evidence bindings for this constraint. - -data GivenKind - = GivenOrig -- Originates in some given, such as signature or pattern match - | GivenSolved (Maybe EvTerm) - -- Is given as result of being solved, maybe provisionally on - -- some other wanted constraints. We cache the evidence term - -- sometimes here as well /as well as/ in the EvBinds, - -- see Note [Optimizing Spontaneously Solved Coercions] - -instance Outputable CtFlavor where - ppr (Given _ GivenOrig) = ptext (sLit "[G]") - ppr (Given _ (GivenSolved {})) = ptext (sLit "[S]") -- Print [S] for Given/Solved's - ppr (Wanted {}) = ptext (sLit "[W]") - ppr (Derived {}) = ptext (sLit "[D]") - -getWantedLoc :: CtFlavor -> WantedLoc -getWantedLoc (Wanted wl) = wl -getWantedLoc (Derived wl) = wl -getWantedLoc flav@(Given {}) = pprPanic "getWantedLoc" (ppr flav) - -pprFlavorArising :: CtFlavor -> SDoc -pprFlavorArising (Derived wl) = pprArisingAt wl -pprFlavorArising (Wanted wl) = pprArisingAt wl -pprFlavorArising (Given gl _) = pprArisingAt gl - -isWanted :: CtFlavor -> Bool +data CtEvidence -- Rename to CtEvidence + = Given { ctev_gloc :: GivenLoc + , ctev_pred :: TcPredType + , ctev_evtm :: EvTerm } -- See Note [Evidence field of CtEvidence] + -- Truly given, not depending on subgoals + -- NB: Spontaneous unifications belong here + -- DV TODOs: (i) Consider caching actual evidence _term_ + -- (ii) Revisit Note [Optimizing Spontaneously Solved Coercions] + + | Wanted { ctev_wloc :: WantedLoc + , ctev_pred :: TcPredType + , ctev_evar :: EvVar } -- See Note [Evidence field of CtEvidence] + -- Wanted goal + + | Derived { ctev_wloc :: WantedLoc + , ctev_pred :: TcPredType } + -- A goal that we don't really have to solve and can't immediately + -- rewrite anything other than a derived (there's no evidence!) + -- but if we do manage to solve it may help in solving other goals. + +ctEvPred :: CtEvidence -> TcPredType +-- The predicate of a flavor +ctEvPred = ctev_pred + +ctEvTerm :: CtEvidence -> EvTerm +ctEvTerm (Given { ctev_evtm = tm }) = tm +ctEvTerm (Wanted { ctev_evar = ev }) = EvId ev +ctEvTerm ctev@(Derived {}) = pprPanic "ctEvTerm: derived constraint cannot have id" + (ppr ctev) + +ctEvId :: CtEvidence -> TcId +ctEvId (Wanted { ctev_evar = ev }) = ev +ctEvId ctev = pprPanic "ctEvId:" (ppr ctev) + +instance Outputable CtEvidence where + ppr fl = case fl of + Given {} -> ptext (sLit "[G]") <+> ppr (ctev_evtm fl) <+> ppr_pty + Wanted {} -> ptext (sLit "[W]") <+> ppr (ctev_evar fl) <+> ppr_pty + Derived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty + where ppr_pty = dcolon <+> ppr (ctEvPred fl) + +getWantedLoc :: CtEvidence -> WantedLoc +-- Precondition: Wanted or Derived +getWantedLoc fl = ctev_wloc fl + +getGivenLoc :: CtEvidence -> GivenLoc +-- Precondition: Given +getGivenLoc fl = ctev_gloc fl + +pprFlavorArising :: CtEvidence -> SDoc +pprFlavorArising (Given { ctev_gloc = gl }) = pprArisingAt gl +pprFlavorArising ctev = pprArisingAt (ctev_wloc ctev) + + +isWanted :: CtEvidence -> Bool isWanted (Wanted {}) = True -isWanted _ = False - -isGivenOrSolved :: CtFlavor -> Bool -isGivenOrSolved (Given {}) = True -isGivenOrSolved _ = False - -isSolved :: CtFlavor -> Bool -isSolved (Given _ (GivenSolved {})) = True -isSolved _ = False +isWanted _ = False -isGiven_maybe :: CtFlavor -> Maybe GivenKind -isGiven_maybe (Given _ gk) = Just gk -isGiven_maybe _ = Nothing +isGiven :: CtEvidence -> Bool +isGiven (Given {}) = True +isGiven _ = False -isDerived :: CtFlavor -> Bool +isDerived :: CtEvidence -> Bool isDerived (Derived {}) = True -isDerived _ = False +isDerived _ = False -canSolve :: CtFlavor -> CtFlavor -> Bool +canSolve :: CtEvidence -> CtEvidence -> Bool -- canSolve ctid1 ctid2 -- The constraint ctid1 can be used to solve ctid2 -- "to solve" means a reaction where the active parts of the two constraints match. @@ -1284,37 +1295,16 @@ canSolve :: CtFlavor -> CtFlavor -> Bool canSolve (Given {}) _ = True canSolve (Wanted {}) (Derived {}) = True canSolve (Wanted {}) (Wanted {}) = True -canSolve (Derived {}) (Derived {}) = True -- Important: derived can't solve wanted/given -canSolve _ _ = False -- (There is no *evidence* for a derived.) +canSolve (Derived {}) (Derived {}) = True -- Derived can't solve wanted/given +canSolve _ _ = False -- No evidence for a derived, anyway -canRewrite :: CtFlavor -> CtFlavor -> Bool --- canRewrite ctid1 ctid2 --- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 +canRewrite :: CtEvidence -> CtEvidence -> Bool +-- canRewrite ct1 ct2 +-- The equality constraint ct1 can be used to rewrite inside ct2 canRewrite = canSolve -combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc --- Precondition: At least one of them should be wanted -combineCtLoc (Wanted loc) _ = loc -combineCtLoc _ (Wanted loc) = loc -combineCtLoc (Derived loc ) _ = loc -combineCtLoc _ (Derived loc ) = loc -combineCtLoc _ _ = panic "combineCtLoc: both given" - -mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor --- To be called when we actually solve a wanted/derived (perhaps leaving residual goals) -mkSolvedFlavor (Wanted loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) -mkSolvedFlavor (Derived loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) -mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl - -mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor -mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig -mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig -mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl - -mkWantedFlavor :: CtFlavor -> CtFlavor -mkWantedFlavor (Wanted loc) = Wanted loc -mkWantedFlavor (Derived loc) = Wanted loc -mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl) +mkGivenLoc :: WantedLoc -> SkolemInfo -> GivenLoc +mkGivenLoc wl sk = setCtLocOrigin wl sk \end{code} %************************************************************************ @@ -1392,7 +1382,7 @@ data SkolemInfo | ArrowSkol -- An arrow form (see TcArrows) - | IPSkol [IPName Name] -- Binding site of an implicit parameter + | IPSkol [HsIPName] -- Binding site of an implicit parameter | RuleSkol RuleName -- The LHS of a RULE @@ -1460,7 +1450,7 @@ data CtOrigin | TypeEqOrigin EqOrigin - | IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter + | IPOccOrigin HsIPName -- Occurrence of an implicit parameter | LiteralOrigin (HsOverLit Name) -- Occurrence of a literal | NegateOrigin -- Occurrence of syntactic negation diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index f4dafcbeee..4f2dab07fe 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -23,8 +23,13 @@ import TcType import TcHsType import TcExpr import TcEnv +import TcEvidence( TcEvBinds(..) ) +import Type import Id +import NameEnv( emptyNameEnv ) import Name +import Var +import VarSet import SrcLoc import Outputable import FastString @@ -47,6 +52,82 @@ an example (test simplCore/should_compile/rule2.hs) produced by Roman: He wanted the rule to typecheck. +Note [Simplifying RULE constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On the LHS of transformation rules we only simplify only equalities, +but not dictionaries. We want to keep dictionaries unsimplified, to +serve as the available stuff for the RHS of the rule. We *do* want to +simplify equalities, however, to detect ill-typed rules that cannot be +applied. + +Implementation: the TcSFlags carried by the TcSMonad controls the +amount of simplification, so simplifyRuleLhs just sets the flag +appropriately. + +Example. Consider the following left-hand side of a rule + f (x == y) (y > z) = ... +If we typecheck this expression we get constraints + d1 :: Ord a, d2 :: Eq a +We do NOT want to "simplify" to the LHS + forall x::a, y::a, z::a, d1::Ord a. + f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... +Instead we want + forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. + f ((==) d2 x y) ((>) d1 y z) = ... + +Here is another example: + fromIntegral :: (Integral a, Num b) => a -> b + {-# RULES "foo" fromIntegral = id :: Int -> Int #-} +In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But +we *dont* want to get + forall dIntegralInt. + fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int +because the scsel will mess up RULE matching. Instead we want + forall dIntegralInt, dNumInt. + fromIntegral Int Int dIntegralInt dNumInt = id Int + +Even if we have + g (x == y) (y == z) = .. +where the two dictionaries are *identical*, we do NOT WANT + forall x::a, y::a, z::a, d1::Eq a + f ((==) d1 x y) ((>) d1 y z) = ... +because that will only match if the dict args are (visibly) equal. +Instead we want to quantify over the dictionaries separately. + +In short, simplifyRuleLhs must *only* squash equalities, leaving +all dicts unchanged, with absolutely no sharing. + +Also note that we can't solve the LHS constraints in isolation: +Example foo :: Ord a => a -> a + foo_spec :: Int -> Int + {-# RULE "foo" foo = foo_spec #-} +Here, it's the RHS that fixes the type variable + +HOWEVER, under a nested implication things are different +Consider + f :: (forall a. Eq a => a->a) -> Bool -> ... + {-# RULES "foo" forall (v::forall b. Eq b => b->b). + f b True = ... + #-} +Here we *must* solve the wanted (Eq a) from the given (Eq a) +resulting from skolemising the agument type of g. So we +revert to SimplCheck when going under an implication. + + +------------------------ So the plan is this ----------------------- + +* Step 1: Simplify the LHS and RHS constraints all together in one bag + We do this to discover all unification equalities + +* Step 2: Zonk the ORIGINAL lhs constraints, and partition them into + the ones we will quantify over, and the others + +* Step 3: Decide on the type varialbes to quantify over + +* Step 4: Simplify the LHS and RHS constraints separately, using the + quantified constraint sas givens + + \begin{code} tcRules :: [LRuleDecl Name] -> TcM [LRuleDecl TcId] tcRules decls = mapM (wrapLocM tcRule) decls @@ -58,80 +139,92 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- Note [Typechecking rules] ; vars <- tcRuleBndrs hs_bndrs - ; let (id_bndrs, tv_bndrs) = partition isId vars - ; (lhs', lhs_lie, rhs', rhs_lie, _rule_ty) - <- tcExtendTyVarEnv tv_bndrs $ - tcExtendIdEnv id_bndrs $ - do { ((lhs', rule_ty), lhs_lie) <- captureConstraints (tcInferRho lhs) - ; (rhs', rhs_lie) <- captureConstraints (tcMonoExpr rhs rule_ty) - ; return (lhs', lhs_lie, rhs', rhs_lie, rule_ty) } - - ; (lhs_dicts, lhs_ev_binds, rhs_ev_binds) - <- simplifyRule name tv_bndrs lhs_lie rhs_lie - - -- IMPORTANT! We *quantify* over any dicts that appear in the LHS - -- Reason: - -- (a) The particular dictionary isn't important, because its value - -- depends only on the type - -- e.g gcd Int $fIntegralInt - -- Here we'd like to match against (gcd Int any_d) for any 'any_d' - -- - -- (b) We'd like to make available the dictionaries bound - -- on the LHS in the RHS, so quantifying over them is good - -- See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS - + ; let (id_bndrs, tv_bndrs) = partition (isId . snd) vars + ; (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) + <- tcExtendTyVarEnv2 tv_bndrs $ + tcExtendIdEnv2 id_bndrs $ + do { ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) + ; (rhs', rhs_wanted) <- captureConstraints (tcMonoExpr rhs rule_ty) + ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) } + + ; (lhs_evs, other_lhs_wanted) <- simplifyRule name lhs_wanted rhs_wanted + + -- Now figure out what to quantify over + -- c.f. TcSimplify.simplifyInfer -- We quantify over any tyvars free in *either* the rule -- *or* the bound variables. The latter is important. Consider -- ss (x,(y,z)) = (x,z) -- RULE: forall v. fst (ss v) = fst v -- The type of the rhs of the rule is just a, but v::(a,(b,c)) -- - -- We also need to get the free tyvars of the LHS; but we do that + -- We also need to get the completely-uconstrained tyvars of + -- the LHS, lest they otherwise get defaulted to Any; but we do that -- during zonking (see TcHsSyn.zonkRule) - ; let tpl_ids = lhs_dicts ++ id_bndrs -{- + ; let tpl_ids = lhs_evs ++ map snd id_bndrs forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids) - - -- Now figure out what to quantify over - -- c.f. TcSimplify.simplifyInfer - ; zonked_forall_tvs <- zonkTcTyVarsAndFV forall_tvs + ; zonked_forall_tvs <- zonkTyVarsAndFV forall_tvs ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; let extra_bound_tvs = zonked_forall_tvs - `minusVarSet` gbl_tvs - `delVarSetList` tv_bndrs - ; qtvs <- zonkQuantifiedTyVars (varSetElems extra_bound_tvs) - ; let all_tvs = tv_bndrs ++ qtvs - ; (kvs, _kinds) <- kindGeneralizeKinds $ map tyVarKind all_tvs --} - - -- The tv_bndrs are already skolems, so no need to zonk them + ; let tvs_to_quantify = varSetElems (zonked_forall_tvs `minusVarSet` gbl_tvs) + ; qkvs <- kindGeneralize $ tyVarsOfTypes (map tyVarKind tvs_to_quantify) + ; qtvs <- zonkQuantifiedTyVars tvs_to_quantify + ; let qtkvs = qkvs ++ qtvs + ; traceTc "tcRule" (vcat [ doubleQuotes (ftext name) + , ppr forall_tvs + , ppr qtvs + , ppr rule_ty + , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] + ]) + + -- Simplify the RHS constraints + ; loc <- getCtLoc (RuleSkol name) + ; rhs_binds_var <- newTcEvBinds + ; emitImplication $ Implic { ic_untch = NoUntouchables + , ic_env = emptyNameEnv + , ic_skols = qtkvs + , ic_given = lhs_evs + , ic_wanted = rhs_wanted + , ic_insol = insolubleWC rhs_wanted + , ic_binds = rhs_binds_var + , ic_loc = loc } + + -- For the LHS constraints we must solve the remaining constraints + -- (a) so that we report insoluble ones + -- (b) so that we bind any soluble ones + ; lhs_binds_var <- newTcEvBinds + ; emitImplication $ Implic { ic_untch = NoUntouchables + , ic_env = emptyNameEnv + , ic_skols = qtkvs + , ic_given = lhs_evs + , ic_wanted = other_lhs_wanted + , ic_insol = insolubleWC other_lhs_wanted + , ic_binds = lhs_binds_var + , ic_loc = loc } + ; return (HsRule name act - (map (RuleBndr . noLoc) (tv_bndrs ++ tpl_ids)) - (mkHsDictLet lhs_ev_binds lhs') fv_lhs - (mkHsDictLet rhs_ev_binds rhs') fv_rhs) } + (map (RuleBndr . noLoc) (qtkvs ++ tpl_ids)) + (mkHsDictLet (TcEvBinds lhs_binds_var) lhs') fv_lhs + (mkHsDictLet (TcEvBinds rhs_binds_var) rhs') fv_rhs) } -tcRuleBndrs :: [RuleBndr Name] -> TcM [Var] +tcRuleBndrs :: [RuleBndr Name] -> TcM [(Name, Var)] tcRuleBndrs [] = return [] -tcRuleBndrs (RuleBndr var : rule_bndrs) +tcRuleBndrs (RuleBndr (L _ name) : rule_bndrs) = do { ty <- newFlexiTyVarTy openTypeKind ; vars <- tcRuleBndrs rule_bndrs - ; return (mkLocalId (unLoc var) ty : vars) } -tcRuleBndrs (RuleBndrSig var rn_ty : rule_bndrs) + ; return ((name, mkLocalId name ty) : vars) } +tcRuleBndrs (RuleBndrSig (L _ name) rn_ty : rule_bndrs) -- e.g x :: a->a -- The tyvar 'a' is brought into scope first, just as if you'd written -- a::*, x :: a->a - = do { let ctxt = FunSigCtxt (unLoc var) - ; (tyvars, ty) <- tcHsPatSigType ctxt rn_ty - ; let skol_tvs = tcSuperSkolTyVars tyvars - id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty - id = mkLocalId (unLoc var) id_ty + = do { let ctxt = RuleSigCtxt name + ; (id_ty, skol_tvs) <- tcHsPatSigType ctxt rn_ty + ; let id = mkLocalId name id_ty -- The type variables scope over subsequent bindings; yuk - ; vars <- tcExtendTyVarEnv skol_tvs $ + ; vars <- tcExtendTyVarEnv2 skol_tvs $ tcRuleBndrs rule_bndrs - ; return (skol_tvs ++ id : vars) } + ; return (skol_tvs ++ (name, id) : vars) } ruleCtxt :: FastString -> SDoc ruleCtxt name = ptext (sLit "When checking the transformation rule") <+> diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 660007d7c5..f0c69c5819 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -16,60 +16,66 @@ module TcSMonad ( extendWorkListEq, extendWorkListNonEq, extendWorkListCt, appendWorkListCt, appendWorkListEqs, unionWorkList, selectWorkItem, - getTcSWorkList, updWorkListTcS, updWorkListTcS_return, keepWanted, + getTcSWorkList, updWorkListTcS, updWorkListTcS_return, + getTcSWorkListTvs, + + getTcSImplics, updTcSImplics, emitTcSImplication, Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDicts, emitFrozenError, - isWanted, isGivenOrSolved, isDerived, - isGivenOrSolvedCt, isGivenCt_maybe, - isWantedCt, isDerivedCt, pprFlavorArising, + isWanted, isDerived, + isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising, - isFlexiTcsTv, + isFlexiTcsTv, instFlexiTcSHelperTcS, canRewrite, canSolve, - combineCtLoc, mkSolvedFlavor, mkGivenFlavor, - mkWantedFlavor, - ctWantedLoc, + mkGivenLoc, ctWantedLoc, - TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality + TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality traceFireTcS, bumpStepCountTcS, doWithInert, tryTcS, nestImplicTcS, recoverTcS, wrapErrTcS, wrapWarnTcS, - SimplContext(..), isInteractive, simplEqsOnly, performDefaulting, - - -- Creation of evidence variables - newEvVar, forceNewEvVar, delCachedEvVar, updateFlatCache, flushFlatCache, - newGivenEqVar, - newEqVar, newKindConstraint, - EvVarCreated (..), isNewEvVar, FlatEqOrigin ( .. ), origin_matches, - - -- Setting evidence variables - setEqBind, + -- Getting and setting the flattening cache + getFlatCache, updFlatCache, addToSolved, addSolvedFunEq, + + deferTcSForAllEq, + setEvBind, - + XEvTerm(..), + MaybeNew (..), isFresh, freshGoals, getEvTerms, + + xCtFlavor, -- Transform a CtEvidence during a step + rewriteCtFlavor, -- Specialized version of xCtFlavor for coercions + newWantedEvVar, instDFunConstraints, + newDerived, + xCtFlavor_cache, rewriteCtFlavor_cache, + + -- Creation of evidence variables setWantedTyBind, getInstEnvs, getFamInstEnvs, -- Getting the environments getTopEnv, getGblEnv, getTcEvBinds, getUntouchables, - getTcEvBindsMap, getTcSContext, getTcSTyBinds, getTcSTyBindsMap, - getTcSEvVarCacheMap, getTcSEvVarFlatCache, setTcSEvVarCacheMap, pprEvVarCache, + getTcEvBindsMap, getTcSTyBinds, getTcSTyBindsMap, + newFlattenSkolemTy, -- Flatten skolems -- Inerts - InertSet(..), + InertSet(..), InertCans(..), getInertEqs, getCtCoercion, - emptyInert, getTcSInerts, updInertSet, extractUnsolved, + emptyInert, getTcSInerts, lookupInInerts, + extractUnsolved, extractUnsolvedTcS, modifyInertTcS, updInertSetTcS, partitionCCanMap, partitionEqMap, getRelevantCts, extractRelevantInerts, - CCanMap (..), CtTypeMap, pprCtTypeMap, mkPredKeyForTypeMap, partitionCtTypeMap, - + CCanMap(..), CtTypeMap, CtFamHeadMap, CtPredMap, + PredMap, FamHeadMap, + partCtFamHeadMap, lookupFamHead, + filterSolved, - instDFunTypes, -- Instantiation - instDFunConstraints, + instDFunType, -- Instantiation newFlexiTcSTy, instFlexiTcS, compatKind, mkKindErrorCtxtTcS, @@ -93,7 +99,6 @@ module TcSMonad ( #include "HsVersions.h" import HscTypes -import BasicTypes import Inst import InstEnv @@ -129,12 +134,15 @@ import TcRnTypes import Unique import UniqFM -import Maybes ( orElse ) +#ifdef DEBUG +import Digraph +#endif +import Maybes ( orElse, catMaybes ) + -import Control.Monad( when ) +import Control.Monad( when, zipWithM ) import StaticFlags( opt_PprStyle_Debug ) import Data.IORef - import TrieMap \end{code} @@ -142,7 +150,7 @@ import TrieMap \begin{code} compatKind :: Kind -> Kind -> Bool -compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 +compatKind k1 k2 = k1 `tcIsSubKind` k2 || k2 `tcIsSubKind` k1 mkKindErrorCtxtTcS :: Type -> Kind -> Type -> Kind @@ -191,7 +199,10 @@ better rewrite it as much as possible before reporting it as an error to the use \begin{code} -- See Note [WorkList] -data WorkList = WorkList { wl_eqs :: [Ct], wl_funeqs :: [Ct], wl_rest :: [Ct] } +data WorkList = WorkList { wl_eqs :: [Ct] + , wl_funeqs :: [Ct] + , wl_rest :: [Ct] + } unionWorkList :: WorkList -> WorkList -> WorkList @@ -200,6 +211,7 @@ unionWorkList new_wl orig_wl = , wl_funeqs = wl_funeqs new_wl ++ wl_funeqs orig_wl , wl_rest = wl_rest new_wl ++ wl_rest orig_wl } + extendWorkListEq :: Ct -> WorkList -> WorkList -- Extension by equality extendWorkListEq ct wl @@ -210,12 +222,13 @@ extendWorkListEq ct wl extendWorkListNonEq :: Ct -> WorkList -> WorkList -- Extension by non equality -extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } +extendWorkListNonEq ct wl + = wl { wl_rest = ct : wl_rest wl } extendWorkListCt :: Ct -> WorkList -> WorkList -- Agnostic extendWorkListCt ct wl - | isEqVar (cc_id ct) = extendWorkListEq ct wl + | isEqPred (ctPred ct) = extendWorkListEq ct wl | otherwise = extendWorkListNonEq ct wl appendWorkListCt :: [Ct] -> WorkList -> WorkList @@ -231,7 +244,7 @@ isEmptyWorkList wl = null (wl_eqs wl) && null (wl_rest wl) && null (wl_funeqs wl) emptyWorkList :: WorkList -emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = []} +emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = [] } workListFromEq :: Ct -> WorkList workListFromEq ct = extendWorkListEq ct emptyWorkList @@ -241,8 +254,8 @@ workListFromNonEq ct = extendWorkListNonEq ct emptyWorkList workListFromCt :: Ct -> WorkList -- Agnostic -workListFromCt ct | isEqVar (cc_id ct) = workListFromEq ct - | otherwise = workListFromNonEq ct +workListFromCt ct | isEqPred (ctPred ct) = workListFromEq ct + | otherwise = workListFromNonEq ct selectWorkItem :: WorkList -> (Maybe Ct, WorkList) @@ -260,68 +273,8 @@ instance Outputable WorkList where , text "WorkList (rest) = " <+> ppr (wl_rest wl) ] -keepWanted :: Cts -> Cts -keepWanted = filterBag isWantedCt - -- DV: there used to be a note here that read: - -- ``Important: use fold*r*Bag to preserve the order of the evidence variables'' - -- DV: Is this still relevant? - -\end{code} - -%************************************************************************ -%* * -%* Inert sets * -%* * -%* * -%************************************************************************ - - -Note [InertSet invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An InertSet is a bag of canonical constraints, with the following invariants: - - 1 No two constraints react with each other. - - A tricky case is when there exists a given (solved) dictionary - constraint and a wanted identical constraint in the inert set, but do - not react because reaction would create loopy dictionary evidence for - the wanted. See note [Recursive dictionaries] - - 2 Given equalities form an idempotent substitution [none of the - given LHS's occur in any of the given RHS's or reactant parts] - - 3 Wanted equalities also form an idempotent substitution - - 4 The entire set of equalities is acyclic. - - 5 Wanted dictionaries are inert with the top-level axiom set - - 6 Equalities of the form tv1 ~ tv2 always have a touchable variable - on the left (if possible). - - 7 No wanted constraints tv1 ~ tv2 with tv1 touchable. Such constraints - will be marked as solved right before being pushed into the inert set. - See note [Touchables and givens]. - - 8 No Given constraint mentions a touchable unification variable, but - Given/Solved may do so. - - 9 Given constraints will also have their superclasses in the inert set, - but Given/Solved will not. - -Note that 6 and 7 are /not/ enforced by canonicalization but rather by -insertion in the inert list, ie by TcInteract. - -During the process of solving, the inert set will contain some -previously given constraints, some wanted constraints, and some given -constraints which have arisen from solving wanted constraints. For -now we do not distinguish between given and solved constraints. - -Note that we must switch wanted inert items to given when going under an -implication constraint (when in top-level inference mode). - -\begin{code} +-- Canonical constraint maps data CCanMap a = CCanMap { cts_given :: UniqFM Cts -- Invariant: all Given , cts_derived :: UniqFM Cts @@ -339,7 +292,7 @@ emptyCCanMap = CCanMap { cts_given = emptyUFM, cts_derived = emptyUFM, cts_wante updCCanMap:: Uniquable a => (a,Ct) -> CCanMap a -> CCanMap a updCCanMap (a,ct) cmap - = case cc_flavor ct of + = case cc_ev ct of Wanted {} -> cmap { cts_wanted = insert_into (cts_wanted cmap) } Given {} -> cmap { cts_given = insert_into (cts_given cmap) } Derived {} -> cmap { cts_derived = insert_into (cts_derived cmap) } @@ -359,11 +312,24 @@ getRelevantCts a cmap where lookup map = lookupUFM map a `orElse` emptyCts +lookupCCanMap :: Uniquable a => a -> (CtEvidence -> Bool) -> CCanMap a -> Maybe CtEvidence +lookupCCanMap a pick_me map + = findEvidence pick_me possible_cts + where + possible_cts = lookupUFM (cts_given map) a `plus` ( + lookupUFM (cts_wanted map) a `plus` ( + lookupUFM (cts_derived map) a `plus` emptyCts)) -getCtTypeMapRelevants :: PredType -> TypeMap Ct -> (Cts, TypeMap Ct) -getCtTypeMapRelevants key_pty tmap - = partitionCtTypeMap (\ct -> mkPredKeyForTypeMap ct `eqType` key_pty) tmap + plus Nothing cts2 = cts2 + plus (Just cts1) cts2 = cts1 `unionBags` cts2 +findEvidence :: (CtEvidence -> Bool) -> Cts -> Maybe CtEvidence +findEvidence pick_me cts + = foldrBag pick Nothing cts + where + pick :: Ct -> Maybe CtEvidence -> Maybe CtEvidence + pick ct deflt | let ctev = cc_ev ct, pick_me ctev = Just ctev + | otherwise = deflt partitionCCanMap :: (Ct -> Bool) -> CCanMap a -> (Cts,CCanMap a) -- All constraints that /match/ the predicate go in the bag, the rest remain in the map @@ -396,119 +362,253 @@ extractUnsolvedCMap cmap = in (wntd `unionBags` derd, cmap { cts_wanted = emptyUFM, cts_derived = emptyUFM }) --- See Note [InertSet invariants] -data InertSet - = IS { inert_eqs :: TyVarEnv (Ct,TcCoercion) - -- Must all be CTyEqCans! If an entry exists of the form: - -- a |-> ct,co - -- Then ct = CTyEqCan { cc_tyvar = a, cc_rhs = xi } - -- And co : a ~ xi - , inert_eq_tvs :: InScopeSet -- Invariant: superset of inert_eqs tvs - - , inert_dicts :: CCanMap Class -- Dictionaries only, index is the class - , inert_ips :: CCanMap (IPName Name) -- Implicit parameters - -- NB: We do not want to use TypeMaps here because functional dependencies - -- will only match on the class but not the type. Similarly IPs match on the - -- name but not on the whole datatype - - , inert_funeqs :: CtTypeMap -- Map from family heads to CFunEqCan constraints - - , inert_irreds :: Cts -- Irreducible predicates - , inert_frozen :: Cts -- All non-canonicals are kept here (as frozen errors) - } +-- Maps from PredTypes to Constraints +type CtTypeMap = TypeMap Ct +type CtPredMap = PredMap Ct +type CtFamHeadMap = FamHeadMap Ct -type CtTypeMap = TypeMap Ct +newtype PredMap a = PredMap { unPredMap :: TypeMap a } -- Indexed by TcPredType +newtype FamHeadMap a = FamHeadMap { unFamHeadMap :: TypeMap a } -- Indexed by family head -pprCtTypeMap :: TypeMap Ct -> SDoc -pprCtTypeMap ctmap = ppr (foldTM (:) ctmap []) +instance Outputable a => Outputable (PredMap a) where + ppr (PredMap m) = ppr (foldTM (:) m []) + +instance Outputable a => Outputable (FamHeadMap a) where + ppr (FamHeadMap m) = ppr (foldTM (:) m []) ctTypeMapCts :: TypeMap Ct -> Cts ctTypeMapCts ctmap = foldTM (\ct cts -> extendCts cts ct) ctmap emptyCts -mkPredKeyForTypeMap :: Ct -> PredType --- Create a key from a constraint to use in the inert CtTypeMap. --- The only interesting case is for family applications, where the --- key is not the whole PredType of cc_id, but rather the family --- equality left hand side (head) -mkPredKeyForTypeMap (CFunEqCan { cc_fun = fn, cc_tyargs = xis }) - = mkTyConApp fn xis -mkPredKeyForTypeMap ct - = evVarPred (cc_id ct) - -partitionCtTypeMap :: (Ct -> Bool) - -> TypeMap Ct -> (Cts, TypeMap Ct) --- Kick out the ones that match the predicate and keep the rest in the typemap -partitionCtTypeMap f ctmap - = foldTM upd_acc ctmap (emptyBag,ctmap) - where upd_acc ct (cts,acc_map) +lookupFamHead :: FamHeadMap a -> TcType -> Maybe a +lookupFamHead (FamHeadMap m) key = lookupTM key m + +partCtFamHeadMap :: (Ct -> Bool) + -> CtFamHeadMap + -> (Cts, CtFamHeadMap) +partCtFamHeadMap f ctmap + = let (cts,tymap_final) = foldTM upd_acc tymap_inside (emptyBag, tymap_inside) + in (cts, FamHeadMap tymap_final) + where + tymap_inside = unFamHeadMap ctmap + upd_acc ct (cts,acc_map) | f ct = (extendCts cts ct, alterTM ct_key (\_ -> Nothing) acc_map) | otherwise = (cts,acc_map) - where ct_key = mkPredKeyForTypeMap ct + where ct_key | EqPred ty1 _ <- classifyPredType (ctPred ct) + = ty1 + | otherwise + = panic "partCtFamHeadMap, encountered non equality!" + +filterSolved :: (CtEvidence -> Bool) -> PredMap CtEvidence -> PredMap CtEvidence +filterSolved p (PredMap mp) = PredMap (foldTM upd mp emptyTM) + where upd a m = if p a then alterTM (ctEvPred a) (\_ -> Just a) m + else m +\end{code} +%************************************************************************ +%* * +%* Inert Sets * +%* * +%* * +%************************************************************************ + +\begin{code} +-- All Given (fully known) or Wanted or Derived +-- See Note [Detailed InertCans Invariants] for more +data InertCans + = IC { inert_eqs :: TyVarEnv Ct + -- Must all be CTyEqCans! If an entry exists of the form: + -- a |-> ct,co + -- Then ct = CTyEqCan { cc_tyvar = a, cc_rhs = xi } + -- And co : a ~ xi + , inert_eq_tvs :: InScopeSet + -- Superset of the type variables of inert_eqs + , inert_dicts :: CCanMap Class + -- Dictionaries only, index is the class + -- NB: index is /not/ the whole type because FD reactions + -- need to match the class but not necessarily the whole type. + , inert_funeqs :: CtFamHeadMap + -- Family equations, index is the whole family head type. + , inert_irreds :: Cts + -- Irreducible predicates + } + + +\end{code} + +Note [Detailed InertCans Invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The InertCans represents a collection of constraints with the following properties: + 1 All canonical + 2 All Given or Wanted or Derived. No (partially) Solved + 3 No two dictionaries with the same head + 4 No two family equations with the same head + NB: This is enforced by construction since we use a CtFamHeadMap for inert_funeqs + 5 Family equations inert wrt top-level family axioms + 6 Dictionaries have no matching top-level instance + + 7 Non-equality constraints are fully rewritten with respect to the equalities (CTyEqCan) + + 8 Equalities _do_not_ form an idempotent substitution but they are guarranteed to not have + any occurs errors. Additional notes: + + - The lack of idempotence of the inert substitution implies that we must make sure + that when we rewrite a constraint we apply the substitution /recursively/ to the + types involved. Currently the one AND ONLY way in the whole constraint solver + that we rewrite types and constraints wrt to the inert substitution is + TcCanonical/flattenTyVar. + + - In the past we did try to have the inert substituion as idempotent as possible but + this would only be true for constraints of the same flavor, so in total the inert + substitution could not be idempotent, due to flavor-related issued. + Note [Non-idempotent inert substitution] explains what is going on. + + - Whenever a constraint ends up in the worklist we do recursively apply exhaustively + the inert substitution to it to check for occurs errors but if an equality is already + in the inert set and we can guarantee that adding a new equality will not cause the + first equality to have an occurs check then we do not rewrite the inert equality. + This happens in TcInteract, rewriteInertEqsFromInertEq. + + See Note [Delicate equality kick-out] to see which inert equalities can safely stay + in the inert set and which must be kicked out to be rewritten and re-checked for + occurs errors. + + 9 Given family or dictionary constraints don't mention touchable unification variables + +Note [Solved constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When we take a step to simplify a constraint 'c', we call the original constraint "solved". +For example: Wanted: ev :: [s] ~ [t] + New goal: ev1 :: s ~ t + Then 'ev' is now "solved". + +The reason for all this is simply to avoid re-solving goals we have solved already. + +* A solved Wanted may depend on as-yet-unsolved goals, so (for example) we should not + use it to rewrite a Given; in that sense the solved goal is still a Wanted + +* A solved Given is just given + +* A solved Derived is possible; purpose is to avoid creating tons of identical + Derived goals. -instance Outputable InertSet where - ppr is = vcat [ vcat (map ppr (varEnvElts (inert_eqs is))) - , vcat (map ppr (Bag.bagToList $ inert_irreds is)) - , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts is))) - , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips is))) - , vcat (map ppr (Bag.bagToList $ ctTypeMapCts (inert_funeqs is))) - , text "Frozen errors =" <+> -- Clearly print frozen errors - braces (vcat (map ppr (Bag.bagToList $ inert_frozen is))) - , text "Warning: Not displaying cached (solved) constraints" - ] - -emptyInert :: InertSet -emptyInert = IS { inert_eqs = emptyVarEnv - , inert_eq_tvs = emptyInScopeSet - , inert_frozen = emptyCts - , inert_irreds = emptyCts - , inert_dicts = emptyCCanMap - , inert_ips = emptyCCanMap - , inert_funeqs = emptyTM - } + +\begin{code} +-- The Inert Set +data InertSet + = IS { inert_cans :: InertCans + -- Canonical Given, Wanted, Derived (no Solved) + -- Sometimes called "the inert set" + + , inert_frozen :: Cts + -- Frozen errors (as non-canonicals) + + , inert_flat_cache :: CtFamHeadMap + -- All ``flattening equations'' are kept here. + -- Always canonical CTyFunEqs (Given or Wanted only!) + -- Key is by family head. We use this field during flattening only + -- Not necessarily inert wrt top-level equations (or inert_cans) + + , inert_solved_funeqs :: FamHeadMap CtEvidence -- Of form co :: F xis ~ xi + , inert_solved :: PredMap CtEvidence -- All others + -- These two fields constitute a cache of solved (only!) constraints + -- See Note [Solved constraints] + -- - Constraints of form (F xis ~ xi) live in inert_solved_funeqs, + -- all the others are in inert_solved + -- - Used to avoid creating a new EvVar when we have a new goal that we + -- have solvedin the past + -- - Stored not necessarily as fully rewritten + -- (ToDo: rewrite lazily when we lookup) + } -type AtomicInert = Ct +instance Outputable InertCans where + ppr ics = vcat [ vcat (map ppr (varEnvElts (inert_eqs ics))) + , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts ics))) + , vcat (map ppr (Bag.bagToList $ + ctTypeMapCts (unFamHeadMap $ inert_funeqs ics))) + , vcat (map ppr (Bag.bagToList $ inert_irreds ics)) + ] + +instance Outputable InertSet where + ppr is = vcat [ ppr $ inert_cans is + , text "Frozen errors =" <+> -- Clearly print frozen errors + braces (vcat (map ppr (Bag.bagToList $ inert_frozen is))) + , text "Solved and cached" <+> + int (foldTypeMap (\_ x -> x+1) 0 + (unPredMap $ inert_solved is)) <+> + text "more constraints" ] -updInertSet :: InertSet -> AtomicInert -> InertSet +emptyInert :: InertSet +emptyInert + = IS { inert_cans = IC { inert_eqs = emptyVarEnv + , inert_eq_tvs = emptyInScopeSet + , inert_dicts = emptyCCanMap + , inert_funeqs = FamHeadMap emptyTM + , inert_irreds = emptyCts } + , inert_frozen = emptyCts + , inert_flat_cache = FamHeadMap emptyTM + , inert_solved = PredMap emptyTM + , inert_solved_funeqs = FamHeadMap emptyTM } + +updSolvedSet :: InertSet -> CtEvidence -> InertSet +updSolvedSet is item + = let pty = ctEvPred item + upd_solved Nothing = Just item + upd_solved (Just _existing_solved) = Just item + -- .. or Just existing_solved? Is this even possible to happen? + in is { inert_solved = + PredMap $ + alterTM pty upd_solved (unPredMap $ inert_solved is) } + + +updInertSet :: InertSet -> Ct -> InertSet -- Add a new inert element to the inert set. updInertSet is item - | isCTyEqCan item - = let upd_err a b = pprPanic "updInertSet" $ - vcat [ text "Multiple inert equalities:" - , text "Old (already inert):" <+> ppr a - , text "Trying to insert :" <+> ppr b - ] - - -- If evidence is cached, pick it up from the flavor! - coercion = getCtCoercion item - - eqs' = extendVarEnv_C upd_err (inert_eqs is) - (cc_tyvar item) - (item, coercion) - inscope' = extendInScopeSetSet (inert_eq_tvs is) (tyVarsOfCt item) - in is { inert_eqs = eqs', inert_eq_tvs = inscope' } - - | Just x <- isCIPCan_Maybe item -- IP - = is { inert_ips = updCCanMap (x,item) (inert_ips is) } - | isCIrredEvCan item -- Presently-irreducible evidence - = is { inert_irreds = inert_irreds is `Bag.snocBag` item } - - - | Just cls <- isCDictCan_Maybe item -- Dictionary - = is { inert_dicts = updCCanMap (cls,item) (inert_dicts is) } - - | Just _tc <- isCFunEqCan_Maybe item -- Function equality - = let pty = mkPredKeyForTypeMap item - upd_funeqs Nothing = Just item - upd_funeqs (Just _alredy_there) = panic "updInertSet: item already there!" - in is { inert_funeqs = alterTM pty upd_funeqs (inert_funeqs is) } - - | otherwise + | isCNonCanonical item + -- NB: this may happen if we decide to kick some frozen error + -- out to rewrite him. Frozen errors are just NonCanonicals = is { inert_frozen = inert_frozen is `Bag.snocBag` item } - -updInertSetTcS :: AtomicInert -> TcS () + + | otherwise + -- A canonical Given, Wanted, or Derived + = is { inert_cans = upd_inert_cans (inert_cans is) item } + + where upd_inert_cans :: InertCans -> Ct -> InertCans + -- Precondition: item /is/ canonical + upd_inert_cans ics item + | isCTyEqCan item + = let upd_err a b = pprPanic "updInertSet" $ + vcat [ text "Multiple inert equalities:" + , text "Old (already inert):" <+> ppr a + , text "Trying to insert :" <+> ppr b ] + + eqs' = extendVarEnv_C upd_err (inert_eqs ics) + (cc_tyvar item) item + inscope' = extendInScopeSetSet (inert_eq_tvs ics) + (tyVarsOfCt item) + + in ics { inert_eqs = eqs', inert_eq_tvs = inscope' } + + | isCIrredEvCan item -- Presently-irreducible evidence + = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item } + + | Just cls <- isCDictCan_Maybe item -- Dictionary + = ics { inert_dicts = updCCanMap (cls,item) (inert_dicts ics) } + + | Just _tc <- isCFunEqCan_Maybe item -- Function equality + = let fam_head = mkTyConApp (cc_fun item) (cc_tyargs item) + upd_funeqs Nothing = Just item + upd_funeqs (Just _already_there) + = panic "updInertSet: item already there!" + in ics { inert_funeqs = FamHeadMap + (alterTM fam_head upd_funeqs $ + (unFamHeadMap $ inert_funeqs ics)) } + | otherwise + = pprPanic "upd_inert set: can't happen! Inserting " $ + ppr item + +updInertSetTcS :: Ct -> TcS () -- Add a new item in the inerts of the monad updInertSetTcS item = do { traceTcS "updInertSetTcs {" $ @@ -519,6 +619,32 @@ updInertSetTcS item ; traceTcS "updInertSetTcs }" $ empty } +addToSolved :: CtEvidence -> TcS () +-- Add a new item in the solved set of the monad +addToSolved item + | isIPPred (ctEvPred item) -- Never cache "solved" implicit parameters (not sure why!) + = return () + | otherwise + = do { traceTcS "updSolvedSetTcs {" $ + text "Trying to insert new solved item:" <+> ppr item + + ; modifyInertTcS (\is -> ((), updSolvedSet is item)) + + ; traceTcS "updSolvedSetTcs }" $ empty } + +addSolvedFunEq :: CtEvidence -> TcS () +addSolvedFunEq fun_eq + = modifyInertTcS $ \inert -> ((), upd_inert inert) + where + upd_inert inert + = let slvd = unFamHeadMap (inert_solved_funeqs inert) + in inert { inert_solved_funeqs = + FamHeadMap (alterTM key upd_funeqs slvd) } + upd_funeqs Nothing = Just fun_eq + upd_funeqs (Just _ct) = Just fun_eq + -- Or _ct? depends on which caches more steps of computation + key = ctEvPred fun_eq + modifyInertTcS :: (InertSet -> (a,InertSet)) -> TcS a -- Modify the inert set with the supplied function modifyInertTcS upd @@ -528,11 +654,11 @@ modifyInertTcS upd ; wrapTcS (TcM.writeTcRef is_var new_inert) ; return a } + extractUnsolvedTcS :: TcS (Cts,Cts) -- Extracts frozen errors and remaining unsolved and sets the -- inert set to be the remaining! -extractUnsolvedTcS = - modifyInertTcS extractUnsolved +extractUnsolvedTcS = modifyInertTcS extractUnsolved extractUnsolved :: InertSet -> ((Cts,Cts), InertSet) -- Postcondition @@ -549,33 +675,45 @@ extractUnsolved :: InertSet -> ((Cts,Cts), InertSet) -- -----------|----------------------------------------------------------------- -- is_solved | Whatever remains from the inert after removing the previous two. -- ----------------------------------------------------------------------------- -extractUnsolved is@(IS {inert_eqs = eqs, inert_irreds = irreds}) - = let is_solved = is { inert_eqs = solved_eqs - , inert_eq_tvs = inert_eq_tvs is - , inert_dicts = solved_dicts - , inert_ips = solved_ips - , inert_irreds = solved_irreds - , inert_frozen = emptyCts - , inert_funeqs = solved_funeqs +extractUnsolved (IS { inert_cans = IC { inert_eqs = eqs + , inert_eq_tvs = eq_tvs + , inert_irreds = irreds + , inert_funeqs = funeqs + , inert_dicts = dicts + } + , inert_frozen = frozen + , inert_solved = solved + , inert_flat_cache = flat_cache + , inert_solved_funeqs = funeq_cache + }) + + = let is_solved = IS { inert_cans = IC { inert_eqs = solved_eqs + , inert_eq_tvs = eq_tvs + , inert_dicts = solved_dicts + , inert_irreds = solved_irreds + , inert_funeqs = solved_funeqs } + , inert_frozen = emptyCts -- All out + + -- At some point, I used to flush all the solved, in + -- fear of evidence loops. But I think we are safe, + -- flushing is why T3064 had become slower + , inert_solved = solved -- PredMap emptyTM + , inert_flat_cache = flat_cache -- FamHeadMap emptyTM + , inert_solved_funeqs = funeq_cache -- FamHeadMap emptyTM } - in ((inert_frozen is, unsolved), is_solved) + in ((frozen, unsolved), is_solved) - where solved_eqs = filterVarEnv_Directly (\_ (ct,_) -> isGivenOrSolvedCt ct) eqs - unsolved_eqs = foldVarEnv (\(ct,_co) cts -> cts `extendCts` ct) emptyCts $ + where solved_eqs = filterVarEnv_Directly (\_ ct -> isGivenCt ct) eqs + unsolved_eqs = foldVarEnv (\ct cts -> cts `extendCts` ct) emptyCts $ eqs `minusVarEnv` solved_eqs - (unsolved_irreds, solved_irreds) = Bag.partitionBag (not.isGivenOrSolvedCt) irreds - (unsolved_ips, solved_ips) = extractUnsolvedCMap (inert_ips is) - (unsolved_dicts, solved_dicts) = extractUnsolvedCMap (inert_dicts is) - - (unsolved_funeqs, solved_funeqs) = extractUnsolvedCtTypeMap (inert_funeqs is) + (unsolved_irreds, solved_irreds) = Bag.partitionBag (not.isGivenCt) irreds + (unsolved_dicts, solved_dicts) = extractUnsolvedCMap dicts + (unsolved_funeqs, solved_funeqs) = partCtFamHeadMap (not . isGivenCt) funeqs unsolved = unsolved_eqs `unionBags` unsolved_irreds `unionBags` - unsolved_ips `unionBags` unsolved_dicts `unionBags` unsolved_funeqs + unsolved_dicts `unionBags` unsolved_funeqs -extractUnsolvedCtTypeMap :: TypeMap Ct -> (Cts,TypeMap Ct) -extractUnsolvedCtTypeMap - = partitionCtTypeMap (not . isGivenOrSolved . cc_flavor) extractRelevantInerts :: Ct -> TcS Cts @@ -583,23 +721,71 @@ extractRelevantInerts :: Ct -> TcS Cts -- this constraint. The monad is left with the 'thinner' inerts. -- NB: This function contains logic specific to the constraint solver, maybe move there? extractRelevantInerts wi - = modifyInertTcS (extract_inert_relevants wi) - where extract_inert_relevants (CDictCan {cc_class = cl}) is = - let (cts,dict_map) = getRelevantCts cl (inert_dicts is) - in (cts, is { inert_dicts = dict_map }) - extract_inert_relevants (CFunEqCan {cc_fun = tc, cc_tyargs = xis}) is = - let (cts,feqs_map) = getCtTypeMapRelevants (mkTyConApp tc xis) (inert_funeqs is) - in (cts, is { inert_funeqs = feqs_map }) - extract_inert_relevants (CIPCan { cc_ip_nm = nm } ) is = - let (cts, ips_map) = getRelevantCts nm (inert_ips is) - in (cts, is { inert_ips = ips_map }) - extract_inert_relevants (CIrredEvCan { }) is = - let cts = inert_irreds is - in (cts, is { inert_irreds = emptyCts }) - extract_inert_relevants _ is = (emptyCts,is) + = modifyInertTcS (extract_relevants wi) + where extract_relevants wi is + = let (cts,ics') = extract_ics_relevants wi (inert_cans is) + in (cts, is { inert_cans = ics' }) + + extract_ics_relevants (CDictCan {cc_class = cl}) ics = + let (cts,dict_map) = getRelevantCts cl (inert_dicts ics) + in (cts, ics { inert_dicts = dict_map }) + extract_ics_relevants ct@(CFunEqCan {}) ics = + let (cts,feqs_map) = + let funeq_map = unFamHeadMap $ inert_funeqs ics + fam_head = mkTyConApp (cc_fun ct) (cc_tyargs ct) + lkp = lookupTM fam_head funeq_map + new_funeq_map = alterTM fam_head xtm funeq_map + xtm Nothing = Nothing + xtm (Just _ct) = Nothing + in case lkp of + Nothing -> (emptyCts, funeq_map) + Just ct -> (singleCt ct, new_funeq_map) + in (cts, ics { inert_funeqs = FamHeadMap feqs_map }) + extract_ics_relevants (CIrredEvCan { }) ics = + let cts = inert_irreds ics + in (cts, ics { inert_irreds = emptyCts }) + extract_ics_relevants _ ics = (emptyCts,ics) + + +lookupInInerts :: InertSet -> TcPredType -> Maybe CtEvidence +-- Is this exact predicate type cached in the solved or canonicals of the InertSet +lookupInInerts (IS { inert_solved = solved, inert_cans = ics }) pty + = case lookupInSolved solved pty of + Just ctev -> return ctev + Nothing -> lookupInInertCans ics pty + +lookupInSolved :: PredMap CtEvidence -> TcPredType -> Maybe CtEvidence +-- Returns just if exactly this predicate type exists in the solved. +lookupInSolved tm pty = lookupTM pty $ unPredMap tm + +lookupInInertCans :: InertCans -> TcPredType -> Maybe CtEvidence +-- Returns Just if exactly this pred type exists in the inert canonicals +lookupInInertCans ics pty + = case (classifyPredType pty) of + ClassPred cls _ + -> lookupCCanMap cls (\ct -> ctEvPred ct `eqType` pty) (inert_dicts ics) + + EqPred ty1 _ty2 + | Just tv <- getTyVar_maybe ty1 -- Tyvar equation + , Just ct <- lookupVarEnv (inert_eqs ics) tv + , let ctev = ctEvidence ct + , ctEvPred ctev `eqType` pty + -> Just ctev + + | Just _ <- splitTyConApp_maybe ty1 -- Family equation + , Just ct <- lookupTM ty1 (unFamHeadMap $ inert_funeqs ics) + , let ctev = ctEvidence ct + , ctEvPred ctev `eqType` pty + -> Just ctev + + IrredPred {} -> findEvidence (\ct -> ctEvPred ct `eqType` pty) (inert_irreds ics) + + _other -> Nothing -- NB: No caching for IPs \end{code} + + %************************************************************************ %* * %* The TcS solver monad * @@ -623,14 +809,9 @@ added. This is initialised from the innermost implication constraint. data TcSEnv = TcSEnv { tcs_ev_binds :: EvBindsVar, - tcs_evvar_cache :: IORef EvVarCache, - -- Evidence bindings and a cache from predicate types to the created evidence - -- variables. The scope of the cache will be the same as the scope of tcs_ev_binds - + tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)), -- Global type bindings - - tcs_context :: SimplContext, tcs_untch :: TcsUntouchables, @@ -638,36 +819,13 @@ data TcSEnv tcs_count :: IORef Int, -- Global step count tcs_inerts :: IORef InertSet, -- Current inert set - tcs_worklist :: IORef WorkList -- Current worklist - - - -- TcSEnv invariant: the tcs_evvar_cache is a superset of tcs_inerts, tcs_worklist, tcs_ev_binds which must - -- all be disjoint with each other. + tcs_worklist :: IORef WorkList, -- Current worklist + + -- Residual implication constraints that are generated + -- while solving the current worklist. + tcs_implics :: IORef (Bag Implication) } -data EvVarCache - = EvVarCache { evc_cache :: TypeMap (EvVar,CtFlavor) - -- Map from PredTys to Evidence variables - -- used to avoid creating new goals - , evc_flat_cache :: TypeMap (TcCoercion,(Xi,CtFlavor,FlatEqOrigin)) - -- Map from family-free heads (F xi) to family-free types. - -- Useful during flattening to share flatten skolem generation - -- The boolean flag: - -- True <-> This equation was generated originally during flattening - -- False <-> This equation was generated by having solved a goal - } - -data FlatEqOrigin = WhileFlattening -- Was it generated during flattening? - | WhenSolved -- Was it generated when a family equation was solved? - | Any - -origin_matches :: FlatEqOrigin -> FlatEqOrigin -> Bool -origin_matches Any _ = True -origin_matches WhenSolved WhenSolved = True -origin_matches WhileFlattening WhileFlattening = True -origin_matches _ _ = False - - type TcsUntouchables = (Untouchables,TcTyVarSet) -- Like the TcM Untouchables, -- but records extra TcsTv variables generated during simplification @@ -675,34 +833,6 @@ type TcsUntouchables = (Untouchables,TcTyVarSet) \end{code} \begin{code} -data SimplContext - = SimplInfer SDoc -- Inferring type of a let-bound thing - | SimplRuleLhs RuleName -- Inferring type of a RULE lhs - | SimplInteractive -- Inferring type at GHCi prompt - | SimplCheck SDoc -- Checking a type signature or RULE rhs - -instance Outputable SimplContext where - ppr (SimplInfer d) = ptext (sLit "SimplInfer") <+> d - ppr (SimplCheck d) = ptext (sLit "SimplCheck") <+> d - ppr (SimplRuleLhs n) = ptext (sLit "SimplRuleLhs") <+> doubleQuotes (ftext n) - ppr SimplInteractive = ptext (sLit "SimplInteractive") - -isInteractive :: SimplContext -> Bool -isInteractive SimplInteractive = True -isInteractive _ = False - -simplEqsOnly :: SimplContext -> Bool --- Simplify equalities only, not dictionaries --- This is used for the LHS of rules; ee --- Note [Simplifying RULE lhs constraints] in TcSimplify -simplEqsOnly (SimplRuleLhs {}) = True -simplEqsOnly _ = False - -performDefaulting :: SimplContext -> Bool -performDefaulting (SimplInfer {}) = False -performDefaulting (SimplRuleLhs {}) = False -performDefaulting SimplInteractive = True -performDefaulting (SimplCheck {}) = True --------------- newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } @@ -756,31 +886,25 @@ traceFireTcS depth doc <> brackets (int depth) <+> doc ; TcM.dumpTcRn msg } -runTcS :: SimplContext - -> Untouchables -- Untouchables - -> InertSet -- Initial inert set - -> WorkList -- Initial work list - -> TcS a -- What to run - -> TcM (a, Bag EvBind) -runTcS context untouch is wl tcs +runTcSWithEvBinds :: EvBindsVar + -> TcS a + -> TcM a +runTcSWithEvBinds ev_binds_var tcs = do { ty_binds_var <- TcM.newTcRef emptyVarEnv - ; ev_cache_var <- TcM.newTcRef $ - EvVarCache { evc_cache = emptyTM, evc_flat_cache = emptyTM } - ; ev_binds_var <- TcM.newTcEvBinds + ; impl_var <- TcM.newTcRef emptyBag ; step_count <- TcM.newTcRef 0 ; inert_var <- TcM.newTcRef is ; wl_var <- TcM.newTcRef wl ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_evvar_cache = ev_cache_var , tcs_ty_binds = ty_binds_var - , tcs_context = context , tcs_untch = (untouch, emptyVarSet) -- No Tcs untouchables yet , tcs_count = step_count , tcs_ic_depth = 0 , tcs_inerts = inert_var - , tcs_worklist = wl_var } + , tcs_worklist = wl_var + , tcs_implics = impl_var } -- Run the computation ; res <- unTcS tcs env @@ -788,38 +912,64 @@ runTcS context untouch is wl tcs ; ty_binds <- TcM.readTcRef ty_binds_var ; mapM_ do_unification (varEnvElts ty_binds) - ; when debugIsOn $ do { - count <- TcM.readTcRef step_count - ; when (opt_PprStyle_Debug && count > 0) $ - TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") - <+> int count <+> ppr context) - } + ; when debugIsOn $ + do { count <- TcM.readTcRef step_count + ; when (opt_PprStyle_Debug && count > 0) $ + TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count ) } -- And return ; ev_binds <- TcM.getTcEvBinds ev_binds_var - ; return (res, ev_binds) } + ; checkForCyclicBinds ev_binds + ; return res } where do_unification (tv,ty) = TcM.writeMetaTyVar tv ty + untouch = NoUntouchables + is = emptyInert + wl = emptyWorkList + +runTcS :: TcS a -- What to run + -> TcM (a, Bag EvBind) +runTcS tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; res <- runTcSWithEvBinds ev_binds_var tcs + ; ev_binds <- TcM.getTcEvBinds ev_binds_var + ; return (res, ev_binds) } + +checkForCyclicBinds :: Bag EvBind -> TcM () +#ifndef DEBUG +checkForCyclicBinds _ = return () +#else +checkForCyclicBinds ev_binds + | null cycles + = return () + | null coercion_cycles + = TcM.traceTc "Cycle in evidence binds" $ ppr cycles + | otherwise + = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles + where + cycles :: [[EvBind]] + cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVertices edges] + + coercion_cycles = [c | c <- cycles, any is_co_bind c] + is_co_bind (EvBind b _) = isEqVar b + edges :: [(EvBind, EvVar, [EvVar])] + edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds] +#endif doWithInert :: InertSet -> TcS a -> TcS a doWithInert inert (TcS action) = TcS $ \env -> do { new_inert_var <- TcM.newTcRef inert - ; orig_cache_var <- TcM.readTcRef (tcs_evvar_cache env) - ; new_cache_var <- TcM.newTcRef orig_cache_var - ; action (env { tcs_inerts = new_inert_var - , tcs_evvar_cache = new_cache_var }) } - + ; action (env { tcs_inerts = new_inert_var }) } nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds - , tcs_evvar_cache = orig_evvar_cache_var , tcs_untch = (_outer_range, outer_tcs) , tcs_count = count , tcs_ic_depth = idepth - , tcs_context = ctxt , tcs_inerts = inert_var - , tcs_worklist = wl_var } -> + , tcs_worklist = wl_var + , tcs_implics = _impl_var } -> do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs) -- The inner_range should be narrower than the outer one -- (thus increasing the set of untouchables) but @@ -829,36 +979,35 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) -- Inherit the inerts from the outer scope ; orig_inerts <- TcM.readTcRef inert_var ; new_inert_var <- TcM.newTcRef orig_inerts - - -- Inherit EvVar cache - ; orig_evvar_cache <- TcM.readTcRef orig_evvar_cache_var - ; evvar_cache <- TcM.newTcRef orig_evvar_cache - + -- Inherit residual implications from outer scope (?) or create + -- fresh var? +-- ; orig_implics <- TcM.readTcRef impl_var + ; new_implics_var <- TcM.newTcRef emptyBag + ; let nest_env = TcSEnv { tcs_ev_binds = ref - , tcs_evvar_cache = evvar_cache , tcs_ty_binds = ty_binds , tcs_untch = inner_untch , tcs_count = count , tcs_ic_depth = idepth+1 - , tcs_context = ctxtUnderImplic ctxt , tcs_inerts = new_inert_var , tcs_worklist = wl_var -- NB: worklist is going to be empty anyway, -- so reuse the same ref cell + , tcs_implics = new_implics_var } - ; thing_inside nest_env } + ; res <- thing_inside nest_env + + -- Perform a check that the thing_inside did not cause cycles + ; ev_binds <- TcM.getTcEvBinds ref + ; checkForCyclicBinds ev_binds + + ; return res } recoverTcS :: TcS a -> TcS a -> TcS a recoverTcS (TcS recovery_code) (TcS thing_inside) = TcS $ \ env -> TcM.recoverM (recovery_code env) (thing_inside env) -ctxtUnderImplic :: SimplContext -> SimplContext --- See Note [Simplifying RULE lhs constraints] in TcSimplify -ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule") - <+> doubleQuotes (ftext n)) -ctxtUnderImplic ctxt = ctxt - tryTcS :: TcS a -> TcS a -- Like runTcS, but from within the TcS monad -- Completely afresh inerts and worklist, be careful! @@ -871,12 +1020,7 @@ tryTcS tcs ; ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_binds_var <- TcM.newTcEvBinds - ; ev_binds_cache_var <- TcM.newTcRef (EvVarCache emptyTM emptyTM) - -- Empty cache: Don't inherit cache from above, see - -- Note [tryTcS for defaulting] in TcSimplify - ; let env1 = env { tcs_ev_binds = ev_binds_var - , tcs_evvar_cache = ev_binds_cache_var , tcs_ty_binds = ty_binds_var , tcs_inerts = is_var , tcs_worklist = wl_var } @@ -895,9 +1039,26 @@ getTcSWorkListRef = TcS (return . tcs_worklist) getTcSInerts :: TcS InertSet getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) + +getTcSImplicsRef :: TcS (IORef (Bag Implication)) +getTcSImplicsRef = TcS (return . tcs_implics) + +getTcSImplics :: TcS (Bag Implication) +getTcSImplics = getTcSImplicsRef >>= wrapTcS . (TcM.readTcRef) + getTcSWorkList :: TcS WorkList getTcSWorkList = getTcSWorkListRef >>= wrapTcS . (TcM.readTcRef) + +getTcSWorkListTvs :: TcS TyVarSet +-- Return the variables of the worklist +getTcSWorkListTvs + = do { wl <- getTcSWorkList + ; return $ + cts_tvs (wl_eqs wl) `unionVarSet` cts_tvs (wl_funeqs wl) `unionVarSet` cts_tvs (wl_rest wl) } + where cts_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet + + updWorkListTcS :: (WorkList -> WorkList) -> TcS () updWorkListTcS f = updWorkListTcS_return (\w -> ((),f w)) @@ -909,15 +1070,26 @@ updWorkListTcS_return f ; let (res,new_work) = f wl_curr ; wrapTcS (TcM.writeTcRef wl_var new_work) ; return res } + -emitFrozenError :: CtFlavor -> EvVar -> SubGoalDepth -> TcS () +updTcSImplics :: (Bag Implication -> Bag Implication) -> TcS () +updTcSImplics f + = do { impl_ref <- getTcSImplicsRef + ; implics <- wrapTcS (TcM.readTcRef impl_ref) + ; let new_implics = f implics + ; wrapTcS (TcM.writeTcRef impl_ref new_implics) } + +emitTcSImplication :: Implication -> TcS () +emitTcSImplication imp = updTcSImplics (consBag imp) + + +emitFrozenError :: CtEvidence -> SubGoalDepth -> TcS () -- Emits a non-canonical constraint that will stand for a frozen error in the inerts. -emitFrozenError fl ev depth - = do { traceTcS "Emit frozen error" (ppr ev <+> dcolon <+> ppr (evVarPred ev)) +emitFrozenError fl depth + = do { traceTcS "Emit frozen error" (ppr (ctEvPred fl)) ; inert_ref <- getTcSInertsRef ; inerts <- wrapTcS (TcM.readTcRef inert_ref) - ; let ct = CNonCanonical { cc_id = ev - , cc_flavor = fl + ; let ct = CNonCanonical { cc_ev = fl , cc_depth = depth } inerts_new = inerts { inert_frozen = extendCts (inert_frozen inerts) ct } ; wrapTcS (TcM.writeTcRef inert_ref inerts_new) } @@ -925,37 +1097,27 @@ emitFrozenError fl ev depth instance HasDynFlags TcS where getDynFlags = wrapTcS getDynFlags -getTcSContext :: TcS SimplContext -getTcSContext = TcS (return . tcs_context) getTcEvBinds :: TcS EvBindsVar getTcEvBinds = TcS (return . tcs_ev_binds) -getTcSEvVarCache :: TcS (IORef EvVarCache) -getTcSEvVarCache = TcS (return . tcs_evvar_cache) - -flushFlatCache :: TcS () -flushFlatCache - = do { cache_var <- getTcSEvVarCache - ; the_cache <- wrapTcS $ TcM.readTcRef cache_var - ; wrapTcS $ TcM.writeTcRef cache_var (the_cache { evc_flat_cache = emptyTM }) } - - -getTcSEvVarCacheMap :: TcS (TypeMap (EvVar,CtFlavor)) -getTcSEvVarCacheMap = do { cache_var <- getTcSEvVarCache - ; the_cache <- wrapTcS $ TcM.readTcRef cache_var - ; return (evc_cache the_cache) } - -getTcSEvVarFlatCache :: TcS (TypeMap (TcCoercion,(Type,CtFlavor,FlatEqOrigin))) -getTcSEvVarFlatCache = do { cache_var <- getTcSEvVarCache - ; the_cache <- wrapTcS $ TcM.readTcRef cache_var - ; return (evc_flat_cache the_cache) } - -setTcSEvVarCacheMap :: TypeMap (EvVar,CtFlavor) -> TcS () -setTcSEvVarCacheMap cache = do { cache_var <- getTcSEvVarCache - ; orig_cache <- wrapTcS $ TcM.readTcRef cache_var - ; let new_cache = orig_cache { evc_cache = cache } - ; wrapTcS $ TcM.writeTcRef cache_var new_cache } +getFlatCache :: TcS CtTypeMap +getFlatCache = getTcSInerts >>= (return . unFamHeadMap . inert_flat_cache) + +updFlatCache :: Ct -> TcS () +-- Pre: constraint is a flat family equation (equal to a flatten skolem) +updFlatCache flat_eq@(CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = xis }) + = modifyInertTcS upd_inert_cache + where upd_inert_cache is = ((), is { inert_flat_cache = FamHeadMap new_fc }) + where new_fc = alterTM pred_key upd_cache fc + fc = unFamHeadMap $ inert_flat_cache is + pred_key = mkTyConApp tc xis + upd_cache (Just ct) | cc_ev ct `canSolve` fl = Just ct + upd_cache (Just _ct) = Just flat_eq + upd_cache Nothing = Just flat_eq +updFlatCache other_ct = pprPanic "updFlatCache: non-family constraint" $ + ppr other_ct + getUntouchables :: TcS TcsUntouchables getUntouchables = TcS (return . tcs_untch) @@ -966,16 +1128,11 @@ getTcSTyBinds = TcS (return . tcs_ty_binds) getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType)) getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) - getTcEvBindsMap :: TcS EvBindMap getTcEvBindsMap = do { EvBindsVar ev_ref _ <- getTcEvBinds ; wrapTcS $ TcM.readTcRef ev_ref } - -setEqBind :: EqVar -> TcCoercion -> CtFlavor -> TcS CtFlavor -setEqBind eqv co fl = setEvBind eqv (EvCoercion co) fl - setWantedTyBind :: TcTyVar -> TcType -> TcS () -- Add a type binding -- We never do this twice! @@ -991,41 +1148,6 @@ setWantedTyBind tv ty ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } } -setEvBind :: EvVar -> EvTerm -> CtFlavor -> TcS CtFlavor --- If the flavor is Solved, we cache the new evidence term inside the returned flavor --- see Note [Optimizing Spontaneously Solved Coercions] -setEvBind ev t fl - = do { tc_evbinds <- getTcEvBinds - ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t - -#ifdef DEBUG - ; binds <- getTcEvBindsMap - ; let cycle = any (reaches binds) (evVarsOfTerm t) - ; when cycle (fail_if_co_loop binds) -#endif - ; return $ - case fl of - Given gl (GivenSolved _) - -> Given gl (GivenSolved (Just t)) - _ -> fl - } - -#ifdef DEBUG - where fail_if_co_loop binds - = pprTrace "setEvBind" (vcat [ text "Cycle in evidence binds, evvar =" <+> ppr ev - , ppr (evBindMapBinds binds) ]) $ - when (isEqVar ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!")) - - reaches :: EvBindMap -> Var -> Bool - -- Does this evvar reach ev? - reaches ebm ev0 = go ev0 - where go ev0 - | ev0 == ev = True - | Just (EvBind _ evtrm) <- lookupEvBind ebm ev0 - = any go (evVarsOfTerm evtrm) - | otherwise = False -#endif - \end{code} Note [Optimizing Spontaneously Solved Coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1078,11 +1200,8 @@ warnTcS loc warn_if doc | warn_if = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc | otherwise = return () -getDefaultInfo :: TcS (SimplContext, [Type], (Bool, Bool)) -getDefaultInfo - = do { ctxt <- getTcSContext - ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt)) - ; return (ctxt, tys, flags) } +getDefaultInfo :: TcS ([Type], (Bool, Bool)) +getDefaultInfo = wrapTcS TcM.tcGetDefaultTys -- Just get some environments needed for instance looking up and matching -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1112,7 +1231,7 @@ checkWellStagedDFun pred dfun_id loc bind_lvl = TcM.topIdLvl dfun_id pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprType $ mkEqPred (ty1,ty2) +pprEq ty1 ty2 = pprType $ mkEqPred ty1 ty2 isTouchableMetaTyVar :: TcTyVar -> TcS Bool isTouchableMetaTyVar tv @@ -1125,7 +1244,7 @@ isTouchableMetaTyVar_InRange (untch,untch_tcs) tv case tcTyVarDetails tv of MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs) -- See Note [Touchable meta type variables] - MetaTv {} -> inTouchableRange untch tv + MetaTv {} -> inTouchableRange untch tv && not (tv `elemVarSet` untch_tcs) _ -> False @@ -1153,33 +1272,45 @@ newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty newFlattenSkolemTyVar :: TcType -> TcS TcTyVar newFlattenSkolemTyVar ty - = do { tv <- wrapTcS $ do { uniq <- TcM.newUnique - ; let name = TcM.mkTcTyVarName uniq (fsLit "f") - ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } - ; traceTcS "New Flatten Skolem Born" $ - (ppr tv <+> text "[:= " <+> ppr ty <+> text "]") + = do { tv <- wrapTcS $ + do { uniq <- TcM.newUnique + ; let name = TcM.mkTcTyVarName uniq (fsLit "f") + ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } + ; traceTcS "New Flatten Skolem Born" $ + ppr tv <+> text "[:= " <+> ppr ty <+> text "]" ; return tv } -- Instantiations -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -instDFunTypes :: [Either TyVar TcType] -> TcS [TcType] -instDFunTypes mb_inst_tys - = mapM inst_tv mb_inst_tys +instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcType) +instDFunType dfun_id mb_inst_tys + = wrapTcS $ go dfun_tvs mb_inst_tys (mkTopTvSubst []) where - inst_tv :: Either TyVar TcType -> TcS Type - inst_tv (Left tv) = mkTyVarTy <$> instFlexiTcS tv - inst_tv (Right ty) = return ty - -instDFunConstraints :: TcThetaType -> CtFlavor -> TcS [EvVarCreated] -instDFunConstraints preds fl - = mapM (newEvVar fl) preds - -instFlexiTcS :: TyVar -> TcS TcTyVar --- Like TcM.instMetaTyVar but the variable that is created is always --- touchable; we are supposed to guess its instantiation. + (dfun_tvs, dfun_phi) = tcSplitForAllTys (idType dfun_id) + + go :: [TyVar] -> [DFunInstType] -> TvSubst -> TcM ([TcType], TcType) + go [] [] subst = return ([], substTy subst dfun_phi) + go (tv:tvs) (Just ty : mb_tys) subst + = do { (tys, phi) <- go tvs mb_tys (extendTvSubst subst tv ty) + ; return (ty : tys, phi) } + go (tv:tvs) (Nothing : mb_tys) subst + = do { ty <- instFlexiTcSHelper (tyVarName tv) (substTy subst (tyVarKind tv)) + -- Don't forget to instantiate the kind! + -- cf TcMType.tcInstTyVarX + ; (tys, phi) <- go tvs mb_tys (extendTvSubst subst tv ty) + ; return (ty : tys, phi) } + go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr mb_inst_tys) + +instFlexiTcS :: [TKVar] -> TcS (TvSubst, [TcType]) +-- Like TcM.instMetaTyVar but the variable that is created is +-- always touchable; we are supposed to guess its instantiation. -- See Note [Touchable meta type variables] -instFlexiTcS tv = instFlexiTcSHelper (tyVarName tv) (tyVarKind tv) +instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs) + where + inst_one subst tv = do { ty' <- instFlexiTcSHelper (tyVarName tv) + (substTy subst (tyVarKind tv)) + ; return (extendTvSubst subst tv ty', ty') } newFlexiTcSTy :: Kind -> TcS TcType newFlexiTcSTy knd @@ -1195,165 +1326,220 @@ isFlexiTcsTv tv | MetaTv TcsTv _ <- tcTyVarDetails tv = True | otherwise = False -newKindConstraint :: TcTyVar -> Kind -> CtFlavor -> TcS EvVarCreated --- Create new wanted CoVar that constrains the type to have the specified kind. -newKindConstraint tv knd fl - = do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd - ; let ty_k = mkTyVarTy tv_k - ; eqv <- newEqVar fl (mkTyVarTy tv) ty_k - ; return eqv } - -instFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar +instFlexiTcSHelper :: Name -> Kind -> TcM TcType instFlexiTcSHelper tvname tvkind - = wrapTcS $ - do { uniq <- TcM.newUnique + = do { uniq <- TcM.newUnique ; ref <- TcM.newMutVar Flexi ; let name = setNameUnique tvname uniq kind = tvkind - ; return (mkTcTyVar name kind (MetaTv TcsTv ref)) } + ; return (mkTyVarTy (mkTcTyVar name kind (MetaTv TcsTv ref))) } + +instFlexiTcSHelperTcS :: Name -> Kind -> TcS TcType +instFlexiTcSHelperTcS n k = wrapTcS (instFlexiTcSHelper n k) + +-- Creating and setting evidence variables and CtFlavors +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data XEvTerm = + XEvTerm { ev_comp :: [EvTerm] -> EvTerm + -- How to compose evidence + , ev_decomp :: EvTerm -> [EvTerm] + -- How to decompose evidence + } + +data MaybeNew = Fresh CtEvidence | Cached EvTerm + +isFresh :: MaybeNew -> Bool +isFresh (Fresh {}) = True +isFresh _ = False + +getEvTerm :: MaybeNew -> EvTerm +getEvTerm (Fresh ctev) = ctEvTerm ctev +getEvTerm (Cached tm) = tm + +getEvTerms :: [MaybeNew] -> [EvTerm] +getEvTerms = map getEvTerm + +freshGoals :: [MaybeNew] -> [CtEvidence] +freshGoals mns = [ ctev | Fresh ctev <- mns ] + +setEvBind :: EvVar -> EvTerm -> TcS () +setEvBind the_ev tm + = do { traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr the_ev + , text "tm =" <+> ppr tm ] + ; tc_evbinds <- getTcEvBinds + ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm } + +newGivenEvVar :: GivenLoc -> TcPredType -> EvTerm -> TcS CtEvidence +-- Make a new variable of the given PredType, +-- immediately bind it to the given term +-- and return its CtEvidence +newGivenEvVar gloc pred rhs + = do { new_ev <- wrapTcS $ TcM.newEvVar pred + ; setEvBind new_ev rhs + ; return (Given { ctev_gloc = gloc, ctev_pred = pred, ctev_evtm = EvId new_ev }) } + +newWantedEvVar :: WantedLoc -> TcPredType -> TcS MaybeNew +newWantedEvVar loc pty + = do { is <- getTcSInerts + ; case lookupInInerts is pty of + Just ctev | not (isDerived ctev) + -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev + ; return (Cached (ctEvTerm ctev)) } + _ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty + ; traceTcS "newWantedEvVar/cache miss" $ ppr new_ev + ; let ctev = Wanted { ctev_wloc = loc + , ctev_pred = pty + , ctev_evar = new_ev } + ; return (Fresh ctev) } } + +newDerived :: WantedLoc -> TcPredType -> TcS (Maybe CtEvidence) +-- Returns Nothing if cached, +-- Just pred if not cached +newDerived loc pty + = do { is <- getTcSInerts + ; case lookupInInerts is pty of + Just {} -> return Nothing + _ -> return (Just Derived { ctev_wloc = loc + , ctev_pred = pty }) } + +instDFunConstraints :: WantedLoc -> TcThetaType -> TcS [MaybeNew] +instDFunConstraints wl = mapM (newWantedEvVar wl) +\end{code} + --- Superclasses and recursive dictionaries --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [xCFlavor] +~~~~~~~~~~~~~~~ +A call might look like this: -data EvVarCreated - = EvVarCreated { evc_is_new :: Bool -- True iff the variable was just created - , evc_the_evvar :: EvVar } -- The actual evidence variable could be cached or new - -isNewEvVar :: EvVarCreated -> Bool -isNewEvVar = evc_is_new - -newEvVar :: CtFlavor -> TcPredType -> TcS EvVarCreated --- Post: If Given then evc_is_new is True --- Hence it is safe to do a setEvBind right after a newEvVar with a Given flavor --- NB: newEvVar may temporarily break the TcSEnv invariant but it is expected in --- the call sites for this invariant to be quickly restored. -newEvVar fl pty - | isGivenOrSolved fl -- Create new variable and update the cache - = do { -{- We lose a lot of time if we enable this check: - eref <- getTcSEvVarCache - ; ecache <- wrapTcS (TcM.readTcRef eref) - ; case lookupTM pty (evc_cache ecache) of - Just (_,cached_fl) - | cached_fl `canSolve` fl - -> pprTrace "Interesting: given newEvVar, missed caching opportunity!" empty $ - return () - _ -> return () --} - new <- forceNewEvVar fl pty - ; return (EvVarCreated True new) } - - | otherwise -- Otherwise lookup first - = {-# SCC "newEvVarWanted" #-} - do { eref <- getTcSEvVarCache - ; ecache <- wrapTcS (TcM.readTcRef eref) - ; case lookupTM pty (evc_cache ecache) of - Just (cached_evvar, cached_flavor) - | cached_flavor `canSolve` fl -- NB: - -- We want to use the cache /only/ if he can solve - -- the workitem. If cached_flavor is Derived - -- but we have a real Wanted, we want to create - -- new evidence, otherwise we are in danger to - -- have unsolved goals in the end. - -- (Remember: Derived's are just unification hints - -- but they don't come with guarantees - -- that they can be solved and we don't - -- quantify over them. - -> do { traceTcS "newEvVar: already cached, doing nothing" - (ppr (evc_cache ecache)) - ; return (EvVarCreated False cached_evvar) } - _ -- Not cached or cached with worse flavor - -> do { new <- force_new_ev_var eref ecache fl pty - ; return (EvVarCreated True new) } } - -forceNewEvVar :: CtFlavor -> TcPredType -> TcS EvVar --- Create a new EvVar, regardless of whether or not the --- cache already contains one like it, and update the cache -forceNewEvVar fl pty - = do { eref <- getTcSEvVarCache - ; ecache <- wrapTcS (TcM.readTcRef eref) - ; force_new_ev_var eref ecache fl pty } - -force_new_ev_var :: IORef EvVarCache -> EvVarCache -> CtFlavor -> TcPredType -> TcS EvVar --- Create a new EvVar, and update the cache with it -force_new_ev_var eref ecache fl pty - = wrapTcS $ - do { TcM.traceTc "newEvVar" $ text "updating cache" + xCtFlavor ev subgoal-preds evidence-transformer + + ev is Given => use ev_decomp to create new Givens for subgoal-preds, + and return them - ; new_evvar <-TcM.newEvVar pty - -- This is THE PLACE where we finally call TcM.newEvVar + ev is Wanted => create new wanteds for subgoal-preds, + use ev_comp to bind ev, + return fresh wanteds (ie ones not cached in inert_cans or solved) + + ev is Derived => create new deriveds for subgoal-preds + (unless cached in inert_cans or solved) + +Note: The [CtEvidence] returned is a subset of the subgoal-preds passed in + Ones that are already cached are not returned + +Example + ev : Tree a b ~ Tree c d + xCtFlavor ev [a~c, b~d] (XEvTerm { ev_comp = \[c1 c2]. <Tree> c1 c2 + , ev_decomp = \c. [nth 1 c, nth 2 c] }) + (\fresh-goals. stuff) + +\begin{code} +xCtFlavor :: CtEvidence -- Original flavor + -> [TcPredType] -- New predicate types + -> XEvTerm -- Instructions about how to manipulate evidence + -> TcS [CtEvidence] +xCtFlavor = xCtFlavor_cache True + +xCtFlavor_cache :: Bool -- True = if wanted add to the solved bag! + -> CtEvidence -- Original flavor + -> [TcPredType] -- New predicate types + -> XEvTerm -- Instructions about how to manipulate evidence + -> TcS [CtEvidence] + +xCtFlavor_cache _ (Given { ctev_gloc = gl, ctev_evtm = tm }) ptys xev + = ASSERT( equalLength ptys (ev_decomp xev tm) ) + zipWithM (newGivenEvVar gl) ptys (ev_decomp xev tm) + -- For Givens we make new EvVars and bind them immediately. We don't worry + -- about caching, but we don't expect complicated calculations among Givens. + -- It is important to bind each given: + -- class (a~b) => C a b where .... + -- f :: C a b => .... + -- Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. + -- But that superclass selector can't (yet) appear in a coercion + -- (see evTermCoercion), so the easy thing is to bind it to an Id + +xCtFlavor_cache cache ctev@(Wanted { ctev_wloc = wl, ctev_evar = evar }) ptys xev + = do { new_evars <- mapM (newWantedEvVar wl) ptys + ; setEvBind evar (ev_comp xev (getEvTerms new_evars)) + + -- Add the now-solved wanted constraint to the cache + ; when cache $ addToSolved ctev + + ; return (freshGoals new_evars) } + +xCtFlavor_cache _ (Derived { ctev_wloc = wl }) ptys _xev + = do { ders <- mapM (newDerived wl) ptys + ; return (catMaybes ders) } + +----------------------------- +rewriteCtFlavor :: CtEvidence + -> TcPredType -- new predicate + -> TcCoercion -- new ~ old + -> TcS (Maybe CtEvidence) +{- + rewriteCtFlavor old_fl new_pred co +Main purpose: create a new identity (flavor) for new_pred; + unless new_pred is cached already +* Returns a new_fl : new_pred, with same wanted/given/derived flag as old_fl +* If old_fl was wanted, create a binding for old_fl, in terms of new_fl +* If old_fl was given, AND not cached, create a binding for new_fl, in terms of old_fl +* Returns Nothing if new_fl is already cached + + + Old evidence New predicate is Return new evidence + flavour of same flavor + ------------------------------------------------------------------- + Wanted Already solved or in inert Nothing + or Derived Not Just new_evidence + + Given Already in inert Nothing + Not Just new_evidence + + Solved NEVER HAPPENS +-} - ; let new_cache = updateCache ecache (new_evvar,fl,pty) - ; TcM.writeTcRef eref new_cache - ; return new_evvar } +rewriteCtFlavor = rewriteCtFlavor_cache True +-- Returns Just new_fl iff either (i) 'co' is reflexivity +-- or (ii) 'co' is not reflexivity, and 'new_pred' not cached +-- In either case, there is nothing new to do with new_fl + +rewriteCtFlavor_cache :: Bool + -> CtEvidence + -> TcPredType -- new predicate + -> TcCoercion -- new ~ old + -> TcS (Maybe CtEvidence) +-- If derived, don't even look at the coercion +-- NB: this allows us to sneak away with ``error'' thunks for +-- coercions that come from derived ids (which don't exist!) +rewriteCtFlavor_cache _cache (Derived { ctev_wloc = wl }) pty_new _co + = newDerived wl pty_new + +rewriteCtFlavor_cache _cache (Given { ctev_gloc = gl, ctev_evtm = old_tm }) pty_new co + = return (Just (Given { ctev_gloc = gl, ctev_pred = pty_new, ctev_evtm = new_tm })) + where + new_tm = mkEvCast old_tm (mkTcSymCo co) -- mkEvCase optimises ReflCo + +rewriteCtFlavor_cache cache ctev@(Wanted { ctev_wloc = wl, ctev_evar = evar, ctev_pred = pty_old }) pty_new co + | isTcReflCo co -- If just reflexivity then you may re-use the same variable + = return (Just (if pty_old `eqType` pty_new + then ctev + else ctev { ctev_pred = pty_new })) + -- If the old and new types compare equal (eqType looks through synonyms) + -- then retain the old type, so that error messages come out mentioning synonyms -updateCache :: EvVarCache -> (EvVar,CtFlavor,Type) -> EvVarCache -updateCache ecache (ev,fl,pty) - | IPPred {} <- classifier - = ecache | otherwise - = ecache { evc_cache = ecache' } - where classifier = classifyPredType pty - ecache' = alterTM pty (\_ -> Just (ev,fl)) $ - evc_cache ecache - -delCachedEvVar :: EvVar -> CtFlavor -> TcS () -delCachedEvVar ev _fl - = {-# SCC "delCachedEvVarOther" #-} - do { eref <- getTcSEvVarCache - ; ecache <- wrapTcS (TcM.readTcRef eref) - ; wrapTcS $ TcM.writeTcRef eref (delFromCache ecache ev) } - -delFromCache :: EvVarCache -> EvVar -> EvVarCache -delFromCache (EvVarCache { evc_cache = ecache - , evc_flat_cache = flat_cache }) ev - = EvVarCache { evc_cache = ecache', evc_flat_cache = flat_cache } - where ecache' = alterTM pty x_del ecache - x_del Nothing = Nothing - x_del r@(Just (ev0,_)) - | ev0 == ev = Nothing - | otherwise = r - pty = evVarPred ev - - - -updateFlatCache :: EvVar -> CtFlavor - -> TyCon -> [Xi] -> TcType - -> FlatEqOrigin - -> TcS () -updateFlatCache ev fl fn xis rhs_ty feq_origin - = do { eref <- getTcSEvVarCache - ; ecache <- wrapTcS (TcM.readTcRef eref) - ; let flat_cache = evc_flat_cache ecache - new_flat_cache = alterTM fun_ty x_flat_cache flat_cache - new_evc = ecache { evc_flat_cache = new_flat_cache } - ; wrapTcS $ TcM.writeTcRef eref new_evc } - where x_flat_cache _ = Just (mkTcCoVarCo ev,(rhs_ty,fl,feq_origin)) - fun_ty = mkTyConApp fn xis - - -pprEvVarCache :: TypeMap (TcCoercion,a) -> SDoc -pprEvVarCache tm = ppr (foldTM mk_pair tm []) - where mk_pair (co,_) cos = (co, tcCoercionKind co) : cos - - -newGivenEqVar :: CtFlavor -> TcType -> TcType -> TcCoercion -> TcS (CtFlavor,EvVar) --- Pre: fl is Given -newGivenEqVar fl ty1 ty2 co - = do { ecv <- newEqVar fl ty1 ty2 - ; let v = evc_the_evvar ecv -- Will be a new EvVar by post of newEvVar - ; fl' <- setEvBind v (EvCoercion co) fl - ; return (fl',v) } - -newEqVar :: CtFlavor -> TcType -> TcType -> TcS EvVarCreated -newEqVar fl ty1 ty2 - = newEvVar fl (mkEqPred (ty1,ty2)) - - -\end{code} - - -\begin{code} + = do { new_evar <- newWantedEvVar wl pty_new + ; setEvBind evar (mkEvCast (getEvTerm new_evar) co) + + -- Add the now-solved wanted constraint to the cache + ; when cache $ addToSolved ctev + + ; case new_evar of + Fresh ctev -> return (Just ctev) + _ -> return Nothing } + + + -- Matching and looking up classes and family instances -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1363,32 +1549,32 @@ data MatchInstResult mi | MatchInstMany -- Multiple matching instances -matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcType])) +matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Maybe TcType])) -- Look up a class constraint in the instance environment matchClass clas tys = do { let pred = mkClassPred clas tys ; instEnvs <- getInstEnvs ; case lookupInstEnv instEnvs clas tys of { - ([], unifs, _) -- Nothing matches - -> do { traceTcS "matchClass not matching" - (vcat [ text "dict" <+> ppr pred, - text "unifs" <+> ppr unifs ]) + ([], _unifs, _) -- Nothing matches + -> do { traceTcS "matchClass not matching" $ + vcat [ text "dict" <+> ppr pred + , ppr instEnvs ] + ; return MatchInstNo } ; ([(ispec, inst_tys)], [], _) -- A single match -> do { let dfun_id = is_dfun ispec - ; traceTcS "matchClass success" - (vcat [text "dict" <+> ppr pred, - text "witness" <+> ppr dfun_id - <+> ppr (idType dfun_id) ]) + ; traceTcS "matchClass success" $ + vcat [text "dict" <+> ppr pred, + text "witness" <+> ppr dfun_id + <+> ppr (idType dfun_id) ] -- Record that this dfun is needed ; return $ MatchInstSingle (dfun_id, inst_tys) } ; - (matches, unifs, _) -- More than one matches - -> do { traceTcS "matchClass multiple matches, deferring choice" - (vcat [text "dict" <+> ppr pred, - text "matches" <+> ppr matches, - text "unifs" <+> ppr unifs]) + (matches, _unifs, _) -- More than one matches + -> do { traceTcS "matchClass multiple matches, deferring choice" $ + vcat [text "dict" <+> ppr pred, + text "matches" <+> ppr matches] ; return MatchInstMany } } @@ -1398,26 +1584,87 @@ matchFam :: TyCon -> [Type] -> TcS (Maybe (FamInst, [Type])) matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args \end{code} +\begin{code} +-- Deferring forall equalities as implications +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +deferTcSForAllEq :: (WantedLoc,EvVar) -- Original wanted equality flavor + -> ([TyVar],TcType) -- ForAll tvs1 body1 + -> ([TyVar],TcType) -- ForAll tvs2 body2 + -> TcS () +-- Some of this functionality is repeated from TcUnify, +-- consider having a single place where we create fresh implications. +deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2) + = do { (subst1, skol_tvs) <- wrapTcS $ TcM.tcInstSkolTyVars tvs1 + ; let tys = mkTyVarTys skol_tvs + phi1 = Type.substTy subst1 body1 + phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2 + skol_info = UnifyForAllSkol skol_tvs phi1 + ; mev <- newWantedEvVar loc (mkTcEqPred phi1 phi2) + ; coe_inside <- case mev of + Cached ev_tm -> return (evTermCoercion ev_tm) + Fresh ctev -> do { ev_binds_var <- wrapTcS $ TcM.newTcEvBinds + ; let ev_binds = TcEvBinds ev_binds_var + new_ct = mkNonCanonical ctev + new_co = evTermCoercion (ctEvTerm ctev) + ; lcl_env <- wrapTcS $ TcM.getLclTypeEnv + ; loc <- wrapTcS $ TcM.getCtLoc skol_info + ; let wc = WC { wc_flat = singleCt new_ct + , wc_impl = emptyBag + , wc_insol = emptyCts } + imp = Implic { ic_untch = all_untouchables + , ic_env = lcl_env + , ic_skols = skol_tvs + , ic_given = [] + , ic_wanted = wc + , ic_insol = False + , ic_binds = ev_binds_var + , ic_loc = loc } + ; updTcSImplics (consBag imp) + ; return (TcLetCo ev_binds new_co) } + + ; setEvBind orig_ev $ + EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs) + } + where all_untouchables = TouchableRange u u + u = idUnique orig_ev -- HACK: empty range + +\end{code} + + -- Rewriting with respect to the inert equalities -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} - -getInertEqs :: TcS (TyVarEnv (Ct,TcCoercion), InScopeSet) +getInertEqs :: TcS (TyVarEnv Ct, InScopeSet) getInertEqs = do { inert <- getTcSInerts - ; return (inert_eqs inert, inert_eq_tvs inert) } - -getCtCoercion :: Ct -> TcCoercion --- Precondition: A CTyEqCan. -getCtCoercion ct - | Just (GivenSolved (Just (EvCoercion co))) <- maybe_given - = co - | otherwise - = mkTcCoVarCo (setVarType (cc_id ct) (ctPred ct)) - -- NB: The variable could be rewritten by a spontaneously - -- solved, so it is not safe to simply do a mkTcCoVarCo (cc_id ct) - -- Instead we use the most accurate type, given by ctPred c - where maybe_given = isGiven_maybe (cc_flavor ct) + ; let ics = inert_cans inert + ; return (inert_eqs ics, inert_eq_tvs ics) } + +getCtCoercion :: EvBindMap -> Ct -> TcCoercion +-- Precondition: A CTyEqCan which is either Wanted or Given, never Derived or Solved! +getCtCoercion _bs ct + = ASSERT( not (isDerivedCt ct) ) + evTermCoercion (ctEvTerm (ctEvidence ct)) +{- ToDo: check with Dimitrios that we can dump this stuff + WARNING: if we *do* need this stuff, we need to think again about cyclic bindings. + = case lookupEvBind bs cc_id of + -- Given and bound to a coercion term + Just (EvBind _ (EvCoercion co)) -> co + -- NB: The constraint could have been rewritten due to spontaneous + -- unifications but because we are optimizing away mkRefls the evidence + -- variable may still have type (alpha ~ [beta]). The constraint may + -- however have a more accurate type (alpha ~ [Int]) (where beta ~ Int has + -- been previously solved by spontaneous unification). So if we are going + -- to use the evidence variable for rewriting other constraints, we'd better + -- make sure it's of the right type! + -- Always the ctPred type is more accurate, so we just pick that type + + _ -> mkTcCoVarCo (setVarType cc_id (ctPred ct)) + + where + cc_id = ctId ct +-} +\end{code} -\end{code}
\ No newline at end of file diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 39a0ab7985..2c4d318335 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -22,13 +22,14 @@ import TcSMonad import TcInteract import Inst import Unify ( niFixTvSubst, niSubstTvSet ) +import Type ( classifyPredType, PredTree(..), isIPPred_maybe ) import Var +import Unique import VarSet import VarEnv import TcEvidence import TypeRep import Name -import NameEnv ( emptyNameEnv ) import Bag import ListSetOps import Util @@ -39,9 +40,9 @@ import BasicTypes ( RuleName ) import Control.Monad ( when ) import Outputable import FastString -import TrieMap +import TrieMap () -- DV: for now import DynFlags - +import Data.Maybe ( mapMaybe ) \end{code} @@ -51,32 +52,117 @@ import DynFlags * * ********************************************************************************* + \begin{code} + + simplifyTop :: WantedConstraints -> TcM (Bag EvBind) -- Simplify top-level constraints -- Usually these will be implications, -- but when there is nothing to quantify we don't wrap -- in a degenerate implication, so we do that here instead simplifyTop wanteds - = simplifyCheck (SimplCheck (ptext (sLit "top level"))) wanteds + = do { ev_binds_var <- newTcEvBinds + + ; zonked_wanteds <- zonkWC wanteds + ; wc_first_go <- runTcSWithEvBinds ev_binds_var $ solveWanteds zonked_wanteds + ; cts <- applyTyVarDefaulting wc_first_go + -- See Note [Top-level Defaulting Plan] + + ; let wc_for_loop = wc_first_go { wc_flat = wc_flat wc_first_go `unionBags` cts } + + ; traceTc "simpl_top_loop {" $ text "zonked_wc =" <+> ppr zonked_wanteds + ; simpl_top_loop ev_binds_var wc_for_loop } + + where simpl_top_loop ev_binds_var wc + | isEmptyWC wc + = do { traceTc "simpl_top_loop }" empty + ; TcRnMonad.getTcEvBinds ev_binds_var } + | otherwise + = do { wc_residual <- runTcSWithEvBinds ev_binds_var $ solveWanteds wc + ; let wc_flat_approximate = approximateWC wc_residual + ; (dflt_eqs,_unused_bind) <- runTcS $ + applyDefaultingRules wc_flat_approximate + -- See Note [Top-level Defaulting Plan] + ; if isEmptyBag dflt_eqs then + do { traceTc "simpl_top_loop }" empty + ; report_and_finish ev_binds_var wc_residual } + else + simpl_top_loop ev_binds_var $ + wc_residual { wc_flat = wc_flat wc_residual `unionBags` dflt_eqs } } + + report_and_finish ev_binds_var wc_residual + = do { eb1 <- TcRnMonad.getTcEvBinds ev_binds_var + ; traceTc "reportUnsolved {" empty + -- See Note [Deferring coercion errors to runtime] + ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors + ; eb2 <- reportUnsolved runtimeCoercionErrors wc_residual + ; traceTc "reportUnsolved }" empty + ; return (eb1 `unionBags` eb2) } +\end{code} + +Note [Top-level Defaulting Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We have considered two design choices for where/when to apply defaulting. + (i) Do it in SimplCheck mode only /whenever/ you try to solve some + flat constraints, maybe deep inside the context of implications. + This used to be the case in GHC 7.4.1. + (ii) Do it in a tight loop at simplifyTop, once all other constraint has + finished. This is the current story. + +Option (i) had many disadvantages: + a) First it was deep inside the actual solver, + b) Second it was dependent on the context (Infer a type signature, + or Check a type signature, or Interactive) since we did not want + to always start defaulting when inferring (though there is an exception to + this see Note [Default while Inferring]) + c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs: + f :: Int -> Bool + f x = const True (\y -> let w :: a -> a + w a = const a (y+1) + in w y) + We will get an implication constraint (for beta the type of y): + [untch=beta] forall a. 0 => Num beta + which we really cannot default /while solving/ the implication, since beta is + untouchable. + +Instead our new defaulting story is to pull defaulting out of the solver loop and +go with option (i), implemented at SimplifyTop. Namely: + - First have a go at solving the residual constraint of the whole program + - Try to approximate it with a flat constraint + - Figure out derived defaulting equations for that flat constraint + - Go round the loop again if you did manage to get some equations + +Now, that has to do with class defaulting. However there exists type variable /kind/ +defaulting. Again this is done at the top-level and the plan is: + - At the top-level, once you had a go at solving the constraint, do + figure out /all/ the touchable unification variables of the wanted contraints. + - Apply defaulting to their kinds + +More details in Note [DefaultTyVar]. + +\begin{code} ------------------ simplifyAmbiguityCheck :: Name -> WantedConstraints -> TcM (Bag EvBind) simplifyAmbiguityCheck name wanteds - = simplifyCheck (SimplCheck (ptext (sLit "ambiguity check for") <+> ppr name)) wanteds + = traceTc "simplifyAmbiguityCheck" (text "name =" <+> ppr name) >> + simplifyCheck wanteds ------------------ simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) simplifyInteractive wanteds - = simplifyCheck SimplInteractive wanteds + = traceTc "simplifyInteractive" empty >> + simplifyTop wanteds ------------------ simplifyDefault :: ThetaType -- Wanted; has no type variables in it -> TcM () -- Succeeds iff the constraint is soluble simplifyDefault theta - = do { wanted <- newFlatWanteds DefaultOrigin theta - ; _ignored_ev_binds <- simplifyCheck (SimplCheck (ptext (sLit "defaults"))) - (mkFlatWC wanted) + = do { traceTc "simplifyInteractive" empty + ; wanted <- newFlatWanteds DefaultOrigin theta + ; _ignored_ev_binds <- simplifyCheck (mkFlatWC wanted) ; return () } \end{code} @@ -97,23 +183,22 @@ simplifyDeriv :: CtOrigin -- Simplify 'wanted' as much as possibles -- Fail if not possible simplifyDeriv orig pred tvs theta - = do { tvs_skols <- tcInstSkolTyVars tvs -- Skolemize + = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize -- The constraint solving machinery -- expects *TcTyVars* not TyVars. -- We use *non-overlappable* (vanilla) skolems -- See Note [Overlap and deriving] - ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols - subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs + ; let subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs skol_set = mkVarSet tvs_skols - doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred) + doc = ptext (sLit "deriving") <+> parens (ppr pred) ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) - ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted) + ; traceTc "simplifyDeriv" $ + vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ] ; (residual_wanted, _ev_binds1) - <- runTcS (SimplInfer doc) NoUntouchables emptyInert emptyWorkList $ - solveWanteds $ mkFlatWC wanted + <- runTcS $ solveWanteds (mkFlatWC wanted) ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) -- See Note [Exotic derived instance contexts] @@ -229,143 +314,190 @@ simplifyInfer :: Bool -> Bool -- Apply monomorphism restriction -> [(Name, TcTauType)] -- Variables to be generalised, -- and their tau-types - -> WantedConstraints + -> (Untouchables, WantedConstraints) -> TcM ([TcTyVar], -- Quantify over these type variables [EvVar], -- ... and these constraints Bool, -- The monomorphism restriction did something -- so the results type is not as general as -- it could be TcEvBinds) -- ... binding these evidence variables -simplifyInfer _top_lvl apply_mr name_taus wanteds +simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) | isEmptyWC wanteds = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; zonked_taus <- zonkTcTypes (map snd name_taus) - ; let tvs_to_quantify = tyVarsOfTypes zonked_taus `minusVarSet` gbl_tvs + ; let tvs_to_quantify = varSetElems (tyVarsOfTypes zonked_taus `minusVarSet` gbl_tvs) -- tvs_to_quantify can contain both kind and type vars -- See Note [Which variables to quantify] ; qtvs <- zonkQuantifiedTyVars tvs_to_quantify ; return (qtvs, [], False, emptyTcEvBinds) } | otherwise - = do { zonked_wanteds <- zonkWC wanteds - ; zonked_taus <- zonkTcTypes (map snd name_taus) + = do { runtimeCoercionErrors <- doptM Opt_DeferTypeErrors ; gbl_tvs <- tcGetGlobalTyVars - ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors + ; zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus)) + ; zonked_wanteds <- zonkWC wanteds ; traceTc "simplifyInfer {" $ vcat [ ptext (sLit "names =") <+> ppr (map fst name_taus) - , ptext (sLit "taus (zonked) =") <+> ppr zonked_taus + , ptext (sLit "taus =") <+> ppr (map snd name_taus) + , ptext (sLit "tau_tvs (zonked) =") <+> ppr zonked_tau_tvs , ptext (sLit "gbl_tvs =") <+> ppr gbl_tvs , ptext (sLit "closed =") <+> ppr _top_lvl , ptext (sLit "apply_mr =") <+> ppr apply_mr + , ptext (sLit "untch =") <+> ppr untch , ptext (sLit "wanted =") <+> ppr zonked_wanteds ] - -- Step 1 - -- Make a guess at the quantified type variables - -- Then split the constraints on the baisis of those tyvars - -- to avoid unnecessarily simplifying a class constraint - -- See Note [Avoid unecessary constraint simplification] - ; let zonked_tau_tvs = tyVarsOfTypes zonked_taus - proto_qtvs = growWanteds gbl_tvs zonked_wanteds $ - zonked_tau_tvs `minusVarSet` gbl_tvs - (perhaps_bound, surely_free) - = partitionBag (quantifyMe proto_qtvs) (wc_flat zonked_wanteds) - - ; traceTc "simplifyInfer proto" $ vcat - [ ptext (sLit "zonked_tau_tvs =") <+> ppr zonked_tau_tvs - , ptext (sLit "proto_qtvs =") <+> ppr proto_qtvs - , ptext (sLit "surely_fref =") <+> ppr surely_free - ] + -- Historical note: Before step 2 we used to have a + -- HORRIBLE HACK described in Note [Avoid unecessary + -- constraint simplification] but, as described in Trac + -- #4361, we have taken in out now. That's why we start + -- with step 2! - ; emitFlats surely_free - ; traceTc "sinf" $ vcat - [ ptext (sLit "perhaps_bound =") <+> ppr perhaps_bound - , ptext (sLit "surely_free =") <+> ppr surely_free - ] + -- Step 2) First try full-blown solving - -- Step 2 - -- Now simplify the possibly-bound constraints - ; let ctxt = SimplInfer (ppr (map fst name_taus)) - ; (simpl_results, tc_binds) - <- runTcS ctxt NoUntouchables emptyInert emptyWorkList $ - simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound }) - - -- Fail fast if there is an insoluble constraint, - -- unless we are deferring errors to runtime - ; when (not runtimeCoercionErrors && insolubleWC simpl_results) $ - do { _ev_binds <- reportUnsolved False simpl_results - ; failM } - - -- Step 3 - -- Split again simplified_perhaps_bound, because some unifications - -- may have happened, and emit the free constraints. - ; gbl_tvs <- tcGetGlobalTyVars - ; zonked_tau_tvs <- zonkTcTyVarsAndFV zonked_tau_tvs - ; zonked_flats <- zonkCts (wc_flat simpl_results) + -- NB: we must gather up all the bindings from doing + -- this solving; hence (runTcSWithEvBinds ev_binds_var). + -- And note that since there are nested implications, + -- calling solveWanteds will side-effect their evidence + -- bindings, so we can't just revert to the input + -- constraint. + ; ev_binds_var <- newTcEvBinds + ; wanted_transformed <- runTcSWithEvBinds ev_binds_var $ + solveWanteds zonked_wanteds + + -- Step 3) Fail fast if there is an insoluble constraint, + -- unless we are deferring errors to runtime + ; when (not runtimeCoercionErrors && insolubleWC wanted_transformed) $ + do { _ev_binds <- reportUnsolved False wanted_transformed; failM } + + -- Step 4) Candidates for quantification are an approximation of wanted_transformed + ; let quant_candidates = approximateWC wanted_transformed + -- NB: Already the fixpoint of any unifications that may have happened + -- NB: We do not do any defaulting when inferring a type, this can lead + -- to less polymorphic types, see Note [Default while Inferring] + + -- Step 5) Minimize the quantification candidates + ; (quant_candidates_transformed, _extra_binds) + <- runTcS $ solveWanteds $ WC { wc_flat = quant_candidates + , wc_impl = emptyBag + , wc_insol = emptyBag } + + -- Step 6) Final candidates for quantification + ; let final_quant_candidates :: Bag PredType + final_quant_candidates = mapBag ctPred $ + keepWanted (wc_flat quant_candidates_transformed) + -- NB: Already the fixpoint of any unifications that may have happened + + ; gbl_tvs <- tcGetGlobalTyVars -- TODO: can we just use untch instead of gbl_tvs? + ; zonked_tau_tvs <- zonkTyVarsAndFV zonked_tau_tvs + + ; traceTc "simplifyWithApprox" $ + vcat [ ptext (sLit "final_quant_candidates =") <+> ppr final_quant_candidates + , ptext (sLit "gbl_tvs=") <+> ppr gbl_tvs + , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs ] + ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs - poly_qtvs = growWantedEVs gbl_tvs zonked_flats init_tvs - (pbound, pfree) = partitionBag (quantifyMe poly_qtvs) zonked_flats - + poly_qtvs = growPreds gbl_tvs id final_quant_candidates init_tvs + + pbound = filterBag (quantifyMe poly_qtvs id) final_quant_candidates + + ; traceTc "simplifyWithApprox" $ + vcat [ ptext (sLit "pbound =") <+> ppr pbound ] + -- Monomorphism restriction - mr_qtvs = init_tvs `minusVarSet` constrained_tvs - constrained_tvs = tyVarsOfCts zonked_flats + ; let mr_qtvs = init_tvs `minusVarSet` constrained_tvs + constrained_tvs = tyVarsOfBag tyVarsOfType final_quant_candidates mr_bites = apply_mr && not (isEmptyBag pbound) - (qtvs, (bound, free)) - | mr_bites = (mr_qtvs, (emptyBag, zonked_flats)) - | otherwise = (poly_qtvs, (pbound, pfree)) - ; emitFlats free + (qtvs, bound) + | mr_bites = (mr_qtvs, emptyBag) + | otherwise = (poly_qtvs, pbound) + ; if isEmptyVarSet qtvs && isEmptyBag bound - then ASSERT( isEmptyBag (wc_insol simpl_results) ) - do { traceTc "} simplifyInfer/no quantification" empty - ; emitImplications (wc_impl simpl_results) - ; return ([], [], mr_bites, EvBinds tc_binds) } + then ASSERT( isEmptyBag (wc_insol wanted_transformed) ) + do { traceTc "} simplifyInfer/no quantification" empty + ; emitWC wanted_transformed + ; return ([], [], mr_bites, TcEvBinds ev_binds_var) } else do + { traceTc "simplifyApprox" $ + ptext (sLit "bound are =") <+> ppr bound + -- Step 4, zonk quantified variables - { let minimal_flat_preds = mkMinimalBySCs $ - map ctPred $ bagToList bound + ; let minimal_flat_preds = mkMinimalBySCs $ bagToList bound skol_info = InferSkol [ (name, mkSigmaTy [] minimal_flat_preds ty) | (name, ty) <- name_taus ] -- Don't add the quantified variables here, because -- they are also bound in ic_skols and we want them to be -- tidied uniformly - ; qtvs_to_return <- zonkQuantifiedTyVars qtvs + ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems qtvs) - -- Step 5 - -- Minimize `bound' and emit an implication + -- Step 7) Emit an implication ; minimal_bound_ev_vars <- mapM TcMType.newEvVar minimal_flat_preds - ; ev_binds_var <- newTcEvBinds - ; mapBagM_ (\(EvBind evar etrm) -> addTcEvBind ev_binds_var evar etrm) - tc_binds ; lcl_env <- getLclTypeEnv ; gloc <- getCtLoc skol_info - ; let implic = Implic { ic_untch = NoUntouchables + ; let implic = Implic { ic_untch = untch , ic_env = lcl_env , ic_skols = qtvs_to_return , ic_given = minimal_bound_ev_vars - , ic_wanted = simpl_results { wc_flat = bound } + , ic_wanted = wanted_transformed , ic_insol = False , ic_binds = ev_binds_var , ic_loc = gloc } ; emitImplication implic + ; traceTc "} simplifyInfer/produced residual implication for quantification" $ vcat [ ptext (sLit "implic =") <+> ppr implic -- ic_skols, ic_given give rest of result , ptext (sLit "qtvs =") <+> ppr qtvs_to_return - , ptext (sLit "spb =") <+> ppr zonked_flats + , ptext (sLit "spb =") <+> ppr final_quant_candidates , ptext (sLit "bound =") <+> ppr bound ] - - ; return ( qtvs_to_return, minimal_bound_ev_vars , mr_bites, TcEvBinds ev_binds_var) } } + where \end{code} +Note [Note [Default while Inferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our current plan is that defaulting only happens at simplifyTop and +not simplifyInfer. This may lead to some insoluble deferred constraints +Example: + +instance D g => C g Int b + +constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha +type inferred = gamma -> gamma + +Now, if we try to default (alpha := Int) we will be able to refine the implication to + (forall b. 0 => C gamma Int b) +which can then be simplified further to + (forall b. 0 => D gamma) +Finally we /can/ approximate this implication with (D gamma) and infer the quantified +type: forall g. D g => g -> g + +Instead what will currently happen is that we will get a quantified type +(forall g. g -> g) and an implication: + forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha + +which, even if the simplifyTop defaults (alpha := Int) we will still be left with an +unsolvable implication: + forall g. 0 => (forall b. 0 => D g) + +The concrete example would be: + h :: C g a s => g -> a -> ST s a + f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1) + +But it is quite tedious to do defaulting and resolve the implication constraints and +we have not observed code breaking because of the lack of defaulting in inference so +we don't do it for now. + + + Note [Minimize by Superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -377,88 +509,35 @@ from superclass selection from Ord alpha. This minimization is what mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint to check the original wanted. -\begin{code} - -simplifyWithApprox :: WantedConstraints -> TcS WantedConstraints --- Post: returns only wanteds (no deriveds) -simplifyWithApprox wanted - = do { traceTcS "simplifyApproxLoop" (ppr wanted) - - ; let all_flats = wc_flat wanted `unionBags` keepWanted (wc_insol wanted) - ; solveInteractCts $ bagToList all_flats - ; unsolved_implics <- simpl_loop 1 (wc_impl wanted) - - ; let (residual_implics,floats) = approximateImplications unsolved_implics - -- Solve extra stuff for real: notice that all the extra unsolved constraints will - -- be in the inerts of the monad, so we are OK - ; traceTcS "simplifyApproxLoop" $ text "Calling solve_wanteds!" - ; wants_or_ders <- solve_wanteds (WC { wc_flat = floats -- They are floated so they are not in the evvar cache - , wc_impl = residual_implics - , wc_insol = emptyBag }) - ; return $ - wants_or_ders { wc_flat = keepWanted (wc_flat wants_or_ders) } } +\begin{code} -approximateImplications :: Bag Implication -> (Bag Implication, Cts) --- Extracts any nested constraints that don't mention the skolems -approximateImplications impls - = do_bag (float_implic emptyVarSet) impls +approximateWC :: WantedConstraints -> Cts +approximateWC wc = float_wc emptyVarSet wc where - do_bag :: forall a b c. (a -> (Bag b, Bag c)) -> Bag a -> (Bag b, Bag c) - do_bag f = foldrBag (plus . f) (emptyBag, emptyBag) - plus :: forall b c. (Bag b, Bag c) -> (Bag b, Bag c) -> (Bag b, Bag c) - plus (a1,b1) (a2,b2) = (a1 `unionBags` a2, b1 `unionBags` b2) - - float_implic :: TyVarSet -> Implication -> (Bag Implication, Cts) + float_wc :: TcTyVarSet -> WantedConstraints -> Cts + float_wc skols (WC { wc_flat = flat, wc_impl = implic }) = floats1 `unionBags` floats2 + where floats1 = do_bag (float_flat skols) flat + floats2 = do_bag (float_implic skols) implic + + float_implic :: TcTyVarSet -> Implication -> Cts float_implic skols imp - = (unitBag (imp { ic_wanted = wanted' }), floats) - where - (wanted', floats) = float_wc (skols `extendVarSetList` ic_skols imp) (ic_wanted imp) + = float_wc (skols `extendVarSetList` ic_skols imp) (ic_wanted imp) + + float_flat :: TcTyVarSet -> Ct -> Cts + float_flat skols ct + | tyVarsOfCt ct `disjointVarSet` skols + , isWantedCt ct = singleCt ct + | otherwise = emptyCts + + do_bag :: (a -> Bag c) -> Bag a -> Bag c + do_bag f = foldrBag (unionBags.f) emptyBag - float_wc skols wc@(WC { wc_flat = flat, wc_impl = implic }) - = (wc { wc_flat = flat', wc_impl = implic' }, floats1 `unionBags` floats2) - where - (flat', floats1) = do_bag (float_flat skols) flat - (implic', floats2) = do_bag (float_implic skols) implic - float_flat :: TcTyVarSet -> Ct -> (Cts, Cts) - float_flat skols ct - | tyVarsOfCt ct `disjointVarSet` skols = (emptyBag, unitBag ct) - | otherwise = (unitBag ct, emptyBag) \end{code} \begin{code} --- (growX gbls wanted tvs) grows a seed 'tvs' against the --- X-constraint 'wanted', nuking the 'gbls' at each stage --- It's conservative in that if the seed could *possibly* --- grow to include a type variable, then it does - -growWanteds :: TyVarSet -> WantedConstraints -> TyVarSet -> TyVarSet -growWanteds gbl_tvs wc = fixVarSet (growWC gbl_tvs wc) - -growWantedEVs :: TyVarSet -> Cts -> TyVarSet -> TyVarSet -growWantedEVs gbl_tvs ws tvs - | isEmptyBag ws = tvs - | otherwise = fixVarSet (growPreds gbl_tvs ctPred ws) tvs - --------- Helper functions, do not do fixpoint ------------------------ -growWC :: TyVarSet -> WantedConstraints -> TyVarSet -> TyVarSet -growWC gbl_tvs wc = growImplics gbl_tvs (wc_impl wc) . - growPreds gbl_tvs ctPred (wc_flat wc) . - growPreds gbl_tvs ctPred (wc_insol wc) - -growImplics :: TyVarSet -> Bag Implication -> TyVarSet -> TyVarSet -growImplics gbl_tvs implics tvs - = foldrBag grow_implic tvs implics - where - grow_implic implic tvs - = grow tvs `delVarSetList` ic_skols implic - where - grow = growWC gbl_tvs (ic_wanted implic) . - growPreds gbl_tvs evVarPred (listToBag (ic_given implic)) - -- We must grow from givens too; see test IPRun - growPreds :: TyVarSet -> (a -> PredType) -> Bag a -> TyVarSet -> TyVarSet growPreds gbl_tvs get_pred items tvs = foldrBag extend tvs items @@ -468,22 +547,28 @@ growPreds gbl_tvs get_pred items tvs -------------------- quantifyMe :: TyVarSet -- Quantifying over these - -> Ct - -> Bool -- True <=> quantify over this wanted -quantifyMe qtvs ct + -> (a -> PredType) + -> a -> Bool -- True <=> quantify over this wanted +quantifyMe qtvs toPred ct | isIPPred pred = True -- Note [Inheriting implicit parameters] | otherwise = tyVarsOfType pred `intersectsVarSet` qtvs where - pred = ctPred ct + pred = toPred ct \end{code} Note [Avoid unecessary constraint simplification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -------- NB NB NB (Jun 12) ------------- + This note not longer applies; see the notes with Trac #4361. + But I'm leaving it in here so we remember the issue.) + ---------------------------------------- When inferring the type of a let-binding, with simplifyInfer, -try to avoid unnecessariliy simplifying class constraints. +try to avoid unnecessarily simplifying class constraints. Doing so aids sharing, but it also helps with delicate situations like + instance C t => C [t] where .. + f :: C [t] => .... f x = let g y = ...(constraint C [t])... in ... @@ -527,138 +612,59 @@ over implicit parameters. See the predicate isFreeWhenInferring. * * *********************************************************************************** -Note [Simplifying RULE lhs constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -On the LHS of transformation rules we only simplify only equalities, -but not dictionaries. We want to keep dictionaries unsimplified, to -serve as the available stuff for the RHS of the rule. We *do* want to -simplify equalities, however, to detect ill-typed rules that cannot be -applied. - -Implementation: the TcSFlags carried by the TcSMonad controls the -amount of simplification, so simplifyRuleLhs just sets the flag -appropriately. - -Example. Consider the following left-hand side of a rule - f (x == y) (y > z) = ... -If we typecheck this expression we get constraints - d1 :: Ord a, d2 :: Eq a -We do NOT want to "simplify" to the LHS - forall x::a, y::a, z::a, d1::Ord a. - f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... -Instead we want - forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. - f ((==) d2 x y) ((>) d1 y z) = ... +See note [Simplifying RULE consraints] in TcRule -Here is another example: - fromIntegral :: (Integral a, Num b) => a -> b - {-# RULES "foo" fromIntegral = id :: Int -> Int #-} -In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But -we *dont* want to get - forall dIntegralInt. - fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int -because the scsel will mess up RULE matching. Instead we want - forall dIntegralInt, dNumInt. - fromIntegral Int Int dIntegralInt dNumInt = id Int - -Even if we have - g (x == y) (y == z) = .. -where the two dictionaries are *identical*, we do NOT WANT - forall x::a, y::a, z::a, d1::Eq a - f ((==) d1 x y) ((>) d1 y z) = ... -because that will only match if the dict args are (visibly) equal. -Instead we want to quantify over the dictionaries separately. - -In short, simplifyRuleLhs must *only* squash equalities, leaving -all dicts unchanged, with absolutely no sharing. - -HOWEVER, under a nested implication things are different -Consider - f :: (forall a. Eq a => a->a) -> Bool -> ... - {-# RULES "foo" forall (v::forall b. Eq b => b->b). - f b True = ... - #-} -Here we *must* solve the wanted (Eq a) from the given (Eq a) -resulting from skolemising the agument type of g. So we -revert to SimplCheck when going under an implication. +Note [RULE quanfification over equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Decideing which equalities to quantify over is tricky: + * We do not want to quantify over insoluble equalities (Int ~ Bool) + (a) because we prefer to report a LHS type error + (b) because if such things end up in 'givens' we get a bogus + "inaccessible code" error + + * But we do want to quantify over things like (a ~ F b), where + F is a type function. + +The difficulty is that it's hard to tell what is insoluble! +So we see whether the simplificaiotn step yielded any type errors, +and if so refrain from quantifying over *any* equalites. \begin{code} simplifyRule :: RuleName - -> [TcTyVar] -- Explicit skolems -> WantedConstraints -- Constraints from LHS -> WantedConstraints -- Constraints from RHS - -> TcM ([EvVar], -- LHS dicts - TcEvBinds, -- Evidence for LHS - TcEvBinds) -- Evidence for RHS --- See Note [Simplifying RULE lhs constraints] -simplifyRule name tv_bndrs lhs_wanted rhs_wanted - = do { loc <- getCtLoc (RuleSkol name) - ; zonked_lhs <- zonkWC lhs_wanted - ; let untch = NoUntouchables - -- We allow ourselves to unify environment - -- variables; hence *no untouchables* + -> TcM ([EvVar], WantedConstraints) -- LHS evidence varaibles +-- See Note [Simplifying RULE constraints] in TcRule +simplifyRule name lhs_wanted rhs_wanted + = do { zonked_all <- zonkWC (lhs_wanted `andWC` rhs_wanted) + ; let doc = ptext (sLit "LHS of rule") <+> doubleQuotes (ftext name) + + -- We allow ourselves to unify environment + -- variables: runTcS runs with NoUntouchables + ; (resid_wanted, _) <- runTcS (solveWanteds zonked_all) - ; (lhs_results, lhs_binds) - <- runTcS (SimplRuleLhs name) untch emptyInert emptyWorkList $ - solveWanteds zonked_lhs + ; zonked_lhs <- zonkWC lhs_wanted - ; traceTc "simplifyRule" $ - vcat [ text "zonked_lhs" <+> ppr zonked_lhs - , text "lhs_results" <+> ppr lhs_results - , text "lhs_binds" <+> ppr lhs_binds - , text "rhs_wanted" <+> ppr rhs_wanted ] + ; let (q_cts, non_q_cts) = partitionBag quantify_me (wc_flat zonked_lhs) + quantify_me -- Note [RULE quantification over equalities] + | insolubleWC resid_wanted = quantify_insol + | otherwise = quantify_normal + quantify_insol ct = not (isEqPred (ctPred ct)) - -- Don't quantify over equalities (judgement call here) - ; let (eqs, dicts) = partitionBag (isEqPred . ctPred) - (wc_flat lhs_results) - lhs_dicts = map cc_id (bagToList dicts) - -- Dicts and implicit parameters + quantify_normal ct + | EqPred t1 t2 <- classifyPredType (ctPred ct) + = not (t1 `eqType` t2) + | otherwise + = True + + ; traceTc "simplifyRule" $ + vcat [ doc + , text "zonked_lhs" <+> ppr zonked_lhs + , text "q_cts" <+> ppr q_cts ] - -- Fail if we have not got down to unsolved flats - ; ev_binds_var <- newTcEvBinds - ; emitImplication $ Implic { ic_untch = untch - , ic_env = emptyNameEnv - , ic_skols = tv_bndrs - , ic_given = lhs_dicts - , ic_wanted = lhs_results { wc_flat = eqs } - , ic_insol = insolubleWC lhs_results - , ic_binds = ev_binds_var - , ic_loc = loc } - - -- Notice that we simplify the RHS with only the explicitly - -- introduced skolems, allowing the RHS to constrain any - -- unification variables. - -- Then, and only then, we call zonkQuantifiedTypeVariables - -- Example foo :: Ord a => a -> a - -- foo_spec :: Int -> Int - -- {-# RULE "foo" foo = foo_spec #-} - -- Here, it's the RHS that fixes the type variable - - -- So we don't want to make untouchable the type - -- variables in the envt of the RHS, because they include - -- the template variables of the RULE - - -- Hence the rather painful ad-hoc treatement here - ; rhs_binds_var@(EvBindsVar evb_ref _) <- newTcEvBinds - ; let doc = ptext (sLit "rhs of rule") <+> doubleQuotes (ftext name) - ; rhs_binds1 <- simplifyCheck (SimplCheck doc) $ - WC { wc_flat = emptyBag - , wc_insol = emptyBag - , wc_impl = unitBag $ - Implic { ic_untch = NoUntouchables - , ic_env = emptyNameEnv - , ic_skols = tv_bndrs - , ic_given = lhs_dicts - , ic_wanted = rhs_wanted - , ic_insol = insolubleWC rhs_wanted - , ic_binds = rhs_binds_var - , ic_loc = loc } } - ; rhs_binds2 <- readTcRef evb_ref - - ; return ( lhs_dicts - , EvBinds lhs_binds - , EvBinds (rhs_binds1 `unionBags` evBindMapBinds rhs_binds2)) } + ; return ( map (ctEvId . ctEvidence) (bagToList q_cts) + , zonked_lhs { wc_flat = non_q_cts }) } \end{code} @@ -669,8 +675,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted *********************************************************************************** \begin{code} -simplifyCheck :: SimplContext - -> WantedConstraints -- Wanted +simplifyCheck :: WantedConstraints -- Wanted -> TcM (Bag EvBind) -- Solve a single, top-level implication constraint -- e.g. typically one created from a top-level type signature @@ -684,22 +689,22 @@ simplifyCheck :: SimplContext -- an implication constraint for g at all.) -- -- Fails if can't solve something in the input wanteds -simplifyCheck ctxt wanteds +simplifyCheck wanteds = do { wanteds <- zonkWC wanteds ; traceTc "simplifyCheck {" (vcat [ ptext (sLit "wanted =") <+> ppr wanteds ]) - ; (unsolved, eb1) - <- runTcS ctxt NoUntouchables emptyInert emptyWorkList $ - solveWanteds wanteds + ; (unsolved, eb1) <- runTcS (solveWanteds wanteds) ; traceTc "simplifyCheck }" $ ptext (sLit "unsolved =") <+> ppr unsolved + ; traceTc "reportUnsolved {" empty -- See Note [Deferring coercion errors to runtime] ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors ; eb2 <- reportUnsolved runtimeCoercionErrors unsolved - + ; traceTc "reportUnsolved }" empty + ; return (eb1 `unionBags` eb2) } \end{code} @@ -746,13 +751,15 @@ solveWanteds :: WantedConstraints -> TcS WantedConstraints -- Returns: residual constraints, plus evidence bindings -- NB: When we are called from TcM there are no inerts to pass down to TcS solveWanteds wanted - = do { wc_out <- solve_wanteds wanted + = do { (_,wc_out) <- solve_wanteds wanted ; let wc_ret = wc_out { wc_flat = keepWanted (wc_flat wc_out) } -- Discard Derived ; return wc_ret } solve_wanteds :: WantedConstraints - -> TcS WantedConstraints -- NB: wc_flats may be wanted *or* derived now + -> TcS (TvSubst, WantedConstraints) + -- NB: wc_flats may be wanted *or* derived now + -- Returns the flattening substitution as well in case we need to apply it solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols }) = do { traceTcS "solveWanteds {" (ppr wanted) @@ -763,12 +770,20 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols -- of a waste, but the code is simple, and the program is -- wrong anyway! + -- DV: why only keepWanted? We make sure that we never float out + -- whatever constraints can yield equalities, including class + -- constraints with functional dependencies and hence all the derived + -- that were potentially insoluble will be re-generated. + -- (It would not hurt though to just keep the wanted and the derived) + -- See Note [The HasEqualities Predicate] in Inst.lhs + ; let all_flats = flats `unionBags` keepWanted insols - ; solveInteractCts $ bagToList all_flats + + ; impls_from_flats <- solveInteractCts $ bagToList all_flats -- solve_wanteds iterates when it is able to float equalities -- out of one or more of the implications. - ; unsolved_implics <- simpl_loop 1 implics + ; unsolved_implics <- simpl_loop 1 (implics `unionBags` impls_from_flats) ; (insoluble_flats,unsolved_flats) <- extractUnsolvedTcS @@ -786,10 +801,15 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols -- See Note [Solving Family Equations] -- NB: remaining_flats has already had subst applied + ; traceTcS "solveWanteds finished with" $ + vcat [ text "remaining_unsolved_flats =" <+> ppr remaining_unsolved_flats + , text "subst =" <+> ppr subst + ] + ; return $ - WC { wc_flat = mapBag (substCt subst) remaining_unsolved_flats - , wc_impl = mapBag (substImplication subst) unsolved_implics - , wc_insol = mapBag (substCt subst) insoluble_flats } + (subst, WC { wc_flat = mapBag (substCt subst) remaining_unsolved_flats + , wc_impl = mapBag (substImplication subst) unsolved_implics + , wc_insol = mapBag (substCt subst) insoluble_flats }) } simpl_loop :: Int @@ -803,27 +823,21 @@ simpl_loop n implics ; inerts <- getTcSInerts ; let ((_,unsolved_flats),_) = extractUnsolved inerts - - ; ecache_pre <- getTcSEvVarCacheMap - ; let pr = ppr ((\k z m -> foldTM k m z) (:) [] ecache_pre) - ; traceTcS "ecache_pre" $ pr - - ; improve_eqs <- if not (isEmptyBag implic_eqs) - then return implic_eqs - else applyDefaultingRules unsolved_flats - - ; ecache_post <- getTcSEvVarCacheMap - ; let po = ppr ((\k z m -> foldTM k m z) (:) [] ecache_post) - ; traceTcS "ecache_po" $ po - + + ; let improve_eqs = implic_eqs + -- NB: improve_eqs used to contain defaulting equations HERE but + -- defaulting now happens only at simplifyTop and not deep inside + -- simpl_loop! See Note [Top-level Defaulting Plan] + ; traceTcS "solveWanteds: simpl_loop end" $ vcat [ text "improve_eqs =" <+> ppr improve_eqs , text "unsolved_flats =" <+> ppr unsolved_flats , text "unsolved_implics =" <+> ppr unsolved_implics ] ; if isEmptyBag improve_eqs then return unsolved_implics - else do { solveInteractCts $ bagToList improve_eqs - ; simpl_loop (n+1) unsolved_implics } } + else do { impls_from_eqs <- solveInteractCts $ bagToList improve_eqs + ; simpl_loop (n+1) (unsolved_implics `unionBags` + impls_from_eqs)} } solveNestedImplications :: Bag Implication -> TcS (Cts, Bag Implication) @@ -834,18 +848,37 @@ solveNestedImplications implics = return (emptyBag, emptyBag) | otherwise = do { inerts <- getTcSInerts + ; traceTcS "solveNestedImplications starting, inerts are:" $ ppr inerts + ; let ((_insoluble_flats, unsolved_flats),thinner_inerts) = extractUnsolved inerts - + ; traceTcS "solveNestedImplications starting, more info:" $ + vcat [ text "inerts = " <+> ppr inerts + , text "insoluble_flats = " <+> ppr _insoluble_flats + , text "unsolved_flats = " <+> ppr unsolved_flats + , text "thinner_inerts = " <+> ppr thinner_inerts ] + ; (implic_eqs, unsolved_implics) <- doWithInert thinner_inerts $ do { let pushed_givens = givens_from_wanteds unsolved_flats - tcs_untouchables = filterVarSet isFlexiTcsTv $ - tyVarsOfCts unsolved_flats + tcs_untouchables + = foldr (unionVarSet . tyVarsOfCt) emptyVarSet pushed_givens + -- Typically pushed_givens is very small, consists + -- only of unsolved equalities, so no inefficiency + -- danger. + + -- See Note [Preparing inert set for implications] -- Push the unsolved wanteds inwards, but as givens ; traceTcS "solveWanteds: preparing inerts for implications {" $ vcat [ppr tcs_untouchables, ppr pushed_givens] - ; solveInteractCts pushed_givens + ; impls_from_givens <- solveInteractCts pushed_givens + + ; MASSERT (isEmptyBag impls_from_givens) + -- impls_from_givens must be empty, since we are reacting givens + -- with givens, and they can never generate extra implications + -- from decomposition of ForAll types. (Whereas wanteds can, see + -- TcCanonical, canEq ForAll-ForAll case) + ; traceTcS "solveWanteds: } now doing nested implications {" empty ; flatMapBagPairM (solveImplication tcs_untouchables) implics } @@ -861,7 +894,11 @@ solveNestedImplications implics where givens_from_wanteds = foldrBag get_wanted [] get_wanted cc rest_givens | pushable_wanted cc - = let this_given = cc { cc_flavor = mkGivenFlavor (cc_flavor cc) UnkSkol } + = let fl = ctEvidence cc + gfl = Given { ctev_gloc = setCtLocOrigin (ctev_wloc fl) UnkSkol + , ctev_evtm = EvId (ctev_evar fl) + , ctev_pred = ctev_pred fl } + this_given = cc { cc_ev = gfl } in this_given : rest_givens | otherwise = rest_givens @@ -884,19 +921,25 @@ solveImplication tcs_untouchables , ic_given = givens , ic_wanted = wanteds , ic_loc = loc }) - = nestImplicTcS ev_binds (untch, tcs_untouchables) $ + = shadowIPs givens $ -- See Note [Shadowing of Implicit Parameters] + nestImplicTcS ev_binds (untch, tcs_untouchables) $ recoverTcS (return (emptyBag, emptyBag)) $ -- Recover from nested failures. Even the top level is -- just a bunch of implications, so failing at the first one is bad do { traceTcS "solveImplication {" (ppr imp) -- Solve flat givens - ; solveInteractGiven loc givens - + ; impls_from_givens <- solveInteractGiven loc givens + ; MASSERT (isEmptyBag impls_from_givens) + -- Simplify the wanteds - ; WC { wc_flat = unsolved_flats - , wc_impl = unsolved_implics - , wc_insol = insols } <- solve_wanteds wanteds + ; (_flat_subst, + WC { wc_flat = unsolved_flats + , wc_impl = unsolved_implics + , wc_insol = insols }) <- solve_wanteds wanteds + -- NB: Not solveWanteds because we need the derived equalities, + -- which may not be solvable (due to touchability) in this implication + -- but may become solvable by spontantenous unification outside. ; let (res_flat_free, res_flat_bound) = floatEqualities skols givens unsolved_flats @@ -928,7 +971,6 @@ floatEqualities skols can_given wantders | hasEqualities can_given = (emptyBag, wantders) -- Note [Float Equalities out of Implications] | otherwise = partitionBag is_floatable wantders - where skol_set = mkVarSet skols is_floatable :: Ct -> Bool is_floatable ct @@ -944,6 +986,7 @@ floatEqualities skols can_given wantders | FlatSkol ty <- tcTyVarDetails tv = tvs_under_fsks ty | otherwise = unitVarSet tv tvs_under_fsks (TyConApp _ tys) = unionVarSets (map tvs_under_fsks tys) + tvs_under_fsks (LitTy {}) = emptyVarSet tvs_under_fsks (FunTy arg res) = tvs_under_fsks arg `unionVarSet` tvs_under_fsks res tvs_under_fsks (AppTy fun arg) = tvs_under_fsks fun `unionVarSet` tvs_under_fsks arg tvs_under_fsks (ForAllTy tv ty) -- The kind of a coercion binder @@ -953,6 +996,31 @@ floatEqualities skols can_given wantders inner_tvs `unionVarSet` tvs_under_fsks (tyVarKind tv) where inner_tvs = tvs_under_fsks ty + +shadowIPs :: [EvVar] -> TcS a -> TcS a +shadowIPs gs m + | null shadowed = m + | otherwise = do is <- getTcSInerts + doWithInert (purgeShadowed is) m + where + shadowed = mapMaybe isIP gs + + isIP g = do p <- evVarPred_maybe g + (x,_) <- isIPPred_maybe p + return x + + isShadowedCt ct = isShadowedEv (ctEvidence ct) + isShadowedEv ev = case isIPPred_maybe (ctEvPred ev) of + Just (x,_) -> x `elem` shadowed + _ -> False + + purgeShadowed is = is { inert_cans = purgeCans (inert_cans is) + , inert_solved = purgeSolved (inert_solved is) + } + + purgeDicts = snd . partitionCCanMap isShadowedCt + purgeCans ics = ics { inert_dicts = purgeDicts (inert_dicts ics) } + purgeSolved = filterSolved (not . isShadowedEv) \end{code} Note [Preparing inert set for implications] @@ -1039,41 +1107,155 @@ constraints nonetheless. Note [Extra TcsTv untouchables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Furthemore, we record the inert set simplifier-generated unification -variables of the TcsTv kind (such as variables from instance that have -been applied, or unification flattens). These variables must be passed -to the implications as extra untouchable variables. Otherwise we have -the danger of double unifications. Example (from trac ticket #4494): - (F Int ~ uf) /\ (forall a. C a => F Int ~ beta) +Whenever we are solving a bunch of flat constraints, they may contain +the following sorts of 'touchable' unification variables: + + (i) Born-touchables in that scope + + (ii) Simplifier-generated unification variables, such as unification + flatten variables + + (iii) Touchables that have been floated out from some nested + implications, see Note [Float Equalities out of Implications]. + +Now, once we are done with solving these flats and have to move inwards to +the nested implications (perhaps for a second time), we must consider all the +extra variables (categories (ii) and (iii) above) as untouchables for the +implication. Otherwise we have the danger or double unifications, as well +as the danger of not ``seing'' some unification. Example (from Trac #4494): + + (F Int ~ uf) /\ [untch=beta](forall a. C a => F Int ~ beta) -In this example, beta is touchable inside the implication. The first -solveInteract step leaves 'uf' ununified. Then we move inside the -implication where a new constraint +In this example, beta is touchable inside the implication. The +first solveInteract step leaves 'uf' ununified. Then we move inside +the implication where a new constraint uf ~ beta emerges. We may spontaneously solve it to get uf := beta, so the whole implication disappears but when we pop out again we are left with (F Int ~ uf) which will be unified by our final solveCTyFunEqs stage and uf will get unified *once more* to (F Int). -The solution is to record the TcsTvs (i.e. the simplifier-generated -unification variables) that are generated when solving the flats, and -make them untouchables for the nested implication. In the example -above uf would become untouchable, so beta would be forced to be -unified as beta := uf. - -NB: A consequence is that every simplifier-generated TcsTv variable - that gets floated out of an implication becomes now untouchable - next time we go inside that implication to solve any residual - constraints. In effect, by floating an equality out of the - implication we are committing to have it solved in the outside. +The solution is to record the unification variables of the flats, +and make them untouchables for the nested implication. In the +example above uf would become untouchable, so beta would be forced +to be unified as beta := uf. Note [Float Equalities out of Implications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to float equalities out of vanilla existentials, but *not* out -of GADT pattern matches. +For ordinary pattern matches (including existentials) we float +equalities out of implications, for instance: + data T where + MkT :: Eq a => a -> T + f x y = case x of MkT _ -> (y::Int) +We get the implication constraint (x::T) (y::alpha): + forall a. [untouchable=alpha] Eq a => alpha ~ Int +We want to float out the equality into a scope where alpha is no +longer untouchable, to solve the implication! + +But we cannot float equalities out of implications whose givens may +yield or contain equalities: + + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a + + h :: T a -> a -> Int + + f x y = case x of + T1 -> y::Int + T2 -> y::Bool + T3 -> h x y + +We generate constraint, for (x::T alpha) and (y :: beta): + [untouchables = beta] (alpha ~ Int => beta ~ Int) -- From 1st branch + [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch + (alpha ~ beta) -- From 3rd branch + +If we float the equality (beta ~ Int) outside of the first implication and +the equality (beta ~ Bool) out of the second we get an insoluble constraint. +But if we just leave them inside the implications we unify alpha := beta and +solve everything. + +Principle: + We do not want to float equalities out which may need the given *evidence* + to become soluble. + +Consequence: classes with functional dependencies don't matter (since there is +no evidence for a fundep equality), but equality superclasses do matter (since +they carry evidence). + +Notice that, due to Note [Extra TcSTv Untouchables], the free unification variables +of an equality that is floated out of an implication become effectively untouchables +for the leftover implication. This is absolutely necessary. Consider the following +example. We start with two implications and a class with a functional dependency. + +class C x y | x -> y +instance C [a] [a] + +(I1) [untch=beta]forall b. 0 => F Int ~ [beta] +(I2) [untch=beta]forall b. 0 => F Int ~ [[alpha]] /\ C beta [b] + +We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. +They may react to yield that (beta := [alpha]) which can then be pushed inwards +the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that +(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable +beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: + +class C x y | x -> y where + op :: x -> y -> () + +instance C [a] [a] + +type family F a :: * + +h :: F Int -> () +h = undefined + +data TEx where + TEx :: a -> TEx + + +f (x::beta) = + let g1 :: forall b. b -> () + g1 _ = h [x] + g2 z = case z of TEx y -> (h [[undefined]], op x [y]) + in (g1 '3', g2 undefined) + +Note [Shadowing of Implicit Parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example: + +f :: (?x :: Char) => Char +f = let ?x = 'a' in ?x + +The "let ?x = ..." generates an implication constraint of the form: + +?x :: Char => ?x :: Char + +Furthermore, the signature for `f` also generates an implication +constraint, so we end up with the following nested implication: +?x :: Char => (?x :: Char => ?x :: Char) + +Note that the wanted (?x :: Char) constraint may be solved in +two incompatible ways: either by using the parameter from the +signature, or by using the local definition. Our intention is +that the local definition should "shadow" the parameter of the +signature, and we implement this as follows: when we nest implications, +we remove any implicit parameters in the outer implication, that +have the same name as givens of the inner implication. + +Here is another variation of the example: + +f :: (?x :: Int) => Char +f = let ?x = 'x' in ?x + +This program should also be accepted: the two constraints `?x :: Int` +and `?x :: Char` never exist in the same context, so they don't get to +interact to cause failure. \begin{code} solveCTyFunEqs :: Cts -> TcS (TvSubst, Cts) @@ -1092,23 +1274,22 @@ solveCTyFunEqs cts ; return (niFixTvSubst ni_subst, unsolved_can_cts) } where - solve_one (cv,tv,ty) = do { setWantedTyBind tv ty - ; _ <- setEqBind cv (mkTcReflCo ty) $ - (Wanted $ panic "Met an already solved function equality!") - ; return () -- Don't care about flavors etc this is - -- the last thing happening - } - + solve_one (Wanted { ctev_evar = cv }, tv, ty) + = setWantedTyBind tv ty >> setEvBind cv (EvCoercion (mkTcReflCo ty)) + solve_one (Derived {}, tv, ty) + = setWantedTyBind tv ty + solve_one arg + = pprPanic "solveCTyFunEqs: can't solve a /given/ family equation!" $ ppr arg ------------ -type FunEqBinds = (TvSubstEnv, [(CoVar, TcTyVar, TcType)]) +type FunEqBinds = (TvSubstEnv, [(CtEvidence, TcTyVar, TcType)]) -- The TvSubstEnv is not idempotent, but is loop-free -- See Note [Non-idempotent substitution] in Unify emptyFunEqBinds :: FunEqBinds emptyFunEqBinds = (emptyVarEnv, []) -extendFunEqBinds :: FunEqBinds -> CoVar -> TcTyVar -> TcType -> FunEqBinds -extendFunEqBinds (tv_subst, cv_binds) cv tv ty - = (extendVarEnv tv_subst tv ty, (cv, tv, ty):cv_binds) +extendFunEqBinds :: FunEqBinds -> CtEvidence -> TcTyVar -> TcType -> FunEqBinds +extendFunEqBinds (tv_subst, cv_binds) fl tv ty + = (extendVarEnv tv_subst tv ty, (fl, tv, ty):cv_binds) ------------ getSolvableCTyFunEqs :: TcsUntouchables @@ -1120,8 +1301,7 @@ getSolvableCTyFunEqs untch cts dflt_funeq :: (Cts, FunEqBinds) -> Ct -> (Cts, FunEqBinds) dflt_funeq (cts_in, feb@(tv_subst, _)) - (CFunEqCan { cc_id = cv - , cc_flavor = fl + (CFunEqCan { cc_ev = fl , cc_fun = tc , cc_tyargs = xis , cc_rhs = xi }) @@ -1130,7 +1310,7 @@ getSolvableCTyFunEqs untch cts , isTouchableMetaTyVar_InRange untch tv -- And it's a *touchable* unification variable - , typeKind xi `isSubKind` tyVarKind tv + , typeKind xi `tcIsSubKind` tyVarKind tv -- Must do a small kind check since TcCanonical invariants -- on family equations only impose compatibility, not subkinding @@ -1140,8 +1320,8 @@ getSolvableCTyFunEqs untch cts , not (tv `elemVarSet` niSubstTvSet tv_subst (tyVarsOfTypes xis)) -- Occurs check: see Note [Solving Family Equations], Point 2 - = ASSERT ( not (isGivenOrSolved fl) ) - (cts_in, extendFunEqBinds feb cv tv (mkTyConApp tc xis)) + = ASSERT ( not (isGiven fl) ) + (cts_in, extendFunEqBinds feb fl tv (mkTyConApp tc xis)) dflt_funeq (cts_in, fun_eq_binds) ct = (cts_in `extendCts` ct, fun_eq_binds) @@ -1173,37 +1353,6 @@ When is it ok to do so? * Defaulting and disamgiguation * * * ********************************************************************************* - -Basic plan behind applyDefaulting rules: - - Step 1: - Split wanteds into defaultable groups, `groups' and the rest `rest_wanted' - For each defaultable group, do: - For each possible substitution for [alpha |-> tau] where `alpha' is the - group's variable, do: - 1) Make up new TcEvBinds - 2) Extend TcS with (groupVariable - 3) given_inert <- solveOne inert (given : a ~ tau) - 4) (final_inert,unsolved) <- solveWanted (given_inert) (group_constraints) - 5) if unsolved == empty then - sneakyUnify a |-> tau - write the evidence bins - return (final_inert ++ group_constraints,[]) - -- will contain the info (alpha |-> tau)!! - goto next defaultable group - if unsolved <> empty then - throw away evidence binds - try next substitution - If you've run out of substitutions for this group, too bad, you failed - return (inert,group) - goto next defaultable group - - Step 2: - Collect all the (canonical-cts, wanteds) gathered this way. - - Do a solveGiven over the canonical-cts to make sure they are inert ------------------------------------------------------------------------------------------- - - \begin{code} applyDefaultingRules :: Cts -- All wanteds -> TcS Cts -- All wanteds again! @@ -1215,22 +1364,17 @@ applyDefaultingRules wanteds | otherwise = do { traceTcS "applyDefaultingRules { " $ text "wanteds =" <+> ppr wanteds - ; untch <- getUntouchables - ; tv_cts <- mapM (defaultTyVar untch) $ - varSetElems (tyVarsOfCDicts wanteds) - - ; info@(_, default_tys, _) <- getDefaultInfo - ; let groups = findDefaultableGroups info untch wanteds + + ; info@(default_tys, _) <- getDefaultInfo + ; let groups = findDefaultableGroups info wanteds ; traceTcS "findDefaultableGroups" $ vcat [ text "groups=" <+> ppr groups - , text "untouchables=" <+> ppr untch , text "info=" <+> ppr info ] ; deflt_cts <- mapM (disambigGroup default_tys) groups ; traceTcS "applyDefaultingRules }" $ - vcat [ text "Tyvar defaults =" <+> ppr tv_cts - , text "Type defaults =" <+> ppr deflt_cts] + vcat [ text "Type defaults =" <+> ppr deflt_cts] - ; return (unionManyBags deflt_cts `unionBags` unionManyBags tv_cts) } + ; return (unionManyBags deflt_cts) } \end{code} Note [tryTcS in defaulting] @@ -1259,50 +1403,90 @@ in the cache! \begin{code} ------------------ -defaultTyVar :: TcsUntouchables -> TcTyVar -> TcS Cts --- defaultTyVar is used on any un-instantiated meta type variables to --- default the kind of OpenKind and ArgKind etc to *. This is important to --- ensure that instance declarations match. For example consider --- instance Show (a->b) --- foo x = show (\_ -> True) --- Then we'll get a constraint (Show (p ->q)) where p has kind ArgKind, --- and that won't match the typeKind (*) in the instance decl. --- See test tc217. --- --- We look only at touchable type variables. No further constraints --- are going to affect these type variables, so it's time to do it by --- hand. However we aren't ready to default them fully to () or --- whatever, because the type-class defaulting rules have yet to run. - -defaultTyVar untch the_tv - | isTouchableMetaTyVar_InRange untch the_tv - , not (k `eqKind` default_k) - = tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting] +touchablesOfWC :: WantedConstraints -> TcTyVarSet +-- See Note [Extra Tcs Untouchables] to see why we carry a TcsUntouchables +-- instead of just using the Untouchable range have in our hands. +touchablesOfWC = go (NoUntouchables, emptyVarSet) + where go :: TcsUntouchables -> WantedConstraints -> TcTyVarSet + go untch (WC { wc_flat = flats, wc_impl = impls }) + = filterVarSet is_touchable flat_tvs `unionVarSet` + foldrBag (unionVarSet . (go_impl $ untch_for_impls untch)) emptyVarSet impls + where is_touchable = isTouchableMetaTyVar_InRange untch + flat_tvs = tyVarsOfCts flats + untch_for_impls (r,uset) = (r, uset `unionVarSet` flat_tvs) + go_impl (_rng,set) implic = go (ic_untch implic,set) (ic_wanted implic) + +applyTyVarDefaulting :: WantedConstraints -> TcM Cts +applyTyVarDefaulting wc = runTcS do_dflt >>= (return . fst) + where do_dflt = do { tv_cts <- mapM defaultTyVar $ + varSetElems (touchablesOfWC wc) + ; return (unionManyBags tv_cts) } + +defaultTyVar :: TcTyVar -> TcS Cts +-- Precondition: a touchable meta-variable +defaultTyVar the_tv + | not (k `eqKind` default_k) + -- Why tryTcS? See Note [tryTcS in defaulting] + = tryTcS $ do { let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk - fl = Wanted loc - ; eqv <- TcSMonad.newKindConstraint the_tv default_k fl - ; if isNewEvVar eqv then - return $ unitBag (CNonCanonical { cc_id = evc_the_evvar eqv - , cc_flavor = fl, cc_depth = 0 }) + ; ty_k <- instFlexiTcSHelperTcS (tyVarName the_tv) default_k + ; md <- newDerived loc (mkTcEqPred (mkTyVarTy the_tv) ty_k) + -- Why not directly newDerived loc (mkTcEqPred k default_k)? + -- See Note [DefaultTyVar] + ; let cts + | Just der_ev <- md = [mkNonCanonical der_ev] + | otherwise = [] + + ; implics_from_defaulting <- solveInteractCts cts + ; MASSERT (isEmptyBag implics_from_defaulting) + + ; (_,unsolved) <- extractUnsolvedTcS + ; if isEmptyBag (keepWanted unsolved) then return (listToBag cts) else return emptyBag } - | otherwise - = return emptyBag -- The common case + | otherwise = return emptyBag -- The common case where k = tyVarKind the_tv default_k = defaultKind k +\end{code} + +Note [DefaultTyVar] +~~~~~~~~~~~~~~~~~~~ +defaultTyVar is used on any un-instantiated meta type variables to +default the kind of OpenKind and ArgKind etc to *. This is important +to ensure that instance declarations match. For example consider + + instance Show (a->b) + foo x = show (\_ -> True) + +Then we'll get a constraint (Show (p ->q)) where p has kind ArgKind, +and that won't match the typeKind (*) in the instance decl. See tests +tc217 and tc175. + +We look only at touchable type variables. No further constraints +are going to affect these type variables, so it's time to do it by +hand. However we aren't ready to default them fully to () or +whatever, because the type-class defaulting rules have yet to run. + +An important point is that if the type variable tv has kind k and the +default is default_k we do not simply generate [D] (k ~ default_k) because: + + (1) k may be ArgKind and default_k may be * so we will fail + + (2) We need to rewrite all occurrences of the tv to be a type + variable with the right kind and we choose to do this by rewriting + the type variable /itself/ by a new variable which does have the + right kind. + +\begin{code} ---------------- findDefaultableGroups - :: ( SimplContext - , [Type] + :: ( [Type] , (Bool,Bool) ) -- (Overloaded strings, extended default rules) - -> TcsUntouchables -- Untouchable -> Cts -- Unsolved -> [[(Ct,TcTyVar)]] -findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults)) - untch wanteds - | not (performDefaulting ctxt) = [] +findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds | null default_tys = [] | otherwise = filter is_defaultable_group (equivClasses cmp_tv unaries) where @@ -1324,13 +1508,8 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults)) is_defaultable_group ds@((_,tv):_) = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] b2 = not (tv `elemVarSet` bad_tvs) - b3 = isTouchableMetaTyVar_InRange untch tv b4 = defaultable_classes [cc_class cc | (cc,_) <- ds] - in (b1 && b2 && b3 && b4) - {- pprTrace "is_defaultable_group" (vcat [ text "isTyConable " <+> ppr tv <+> ppr b1 - , text "is not in bad " <+> ppr tv <+> ppr b2 - , text "is touchable " <+> ppr tv <+> ppr b3 - , text "is defaultable" <+> ppr tv <+> ppr b4 ]) -} + in (b1 && b2 && b4) is_defaultable_group [] = panic "defaultable_group" defaultable_classes clss @@ -1360,18 +1539,26 @@ disambigGroup [] _grp disambigGroup (default_ty:default_tys) group = do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty) ; success <- tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting] - do { let der_flav = mk_derived_flavor (cc_flavor the_ct) - ; derived_eq <- tryTcS $ - -- I need a new tryTcS because we will call solveInteractCts below! - do { eqv <- TcSMonad.newEqVar der_flav (mkTyVarTy the_tv) default_ty - ; return [ CNonCanonical { cc_id = evc_the_evvar eqv - , cc_flavor = der_flav, cc_depth = 0 } ] } - ; traceTcS "disambigGroup (solving) {" - (text "trying to solve constraints along with default equations ...") - ; solveInteractCts (derived_eq ++ wanteds) + do { derived_eq <- tryTcS $ + -- I need a new tryTcS because we will call solveInteractCts below! + do { md <- newDerived (ctev_wloc the_fl) + (mkTcEqPred (mkTyVarTy the_tv) default_ty) + -- ctev_wloc because constraint is not Given! + ; case md of + Nothing -> return [] + Just ctev -> return [ mkNonCanonical ctev ] } + + ; traceTcS "disambigGroup (solving) {" $ + text "trying to solve constraints along with default equations ..." + ; implics_from_defaulting <- + solveInteractCts (derived_eq ++ wanteds) + ; MASSERT (isEmptyBag implics_from_defaulting) + -- I am not certain if any implications can be generated + -- but I am letting this fail aggressively if this ever happens. + ; (_,unsolved) <- extractUnsolvedTcS - ; traceTcS "disambigGroup (solving) }" - (text "disambigGroup unsolved =" <+> ppr (keepWanted unsolved)) + ; traceTcS "disambigGroup (solving) }" $ + text "disambigGroup unsolved =" <+> ppr (keepWanted unsolved) ; if isEmptyBag (keepWanted unsolved) then -- Don't care about Derived's return (Just $ listToBag derived_eq) else @@ -1388,10 +1575,8 @@ disambigGroup (default_ty:default_tys) group ; disambigGroup default_tys group } } where ((the_ct,the_tv):_) = group + the_fl = cc_ev the_ct wanteds = map fst group - mk_derived_flavor :: CtFlavor -> CtFlavor - mk_derived_flavor (Wanted loc) = Derived loc - mk_derived_flavor _ = panic "Asked to disambiguate given or derived!" \end{code} Note [Avoiding spurious errors] @@ -1420,10 +1605,12 @@ newFlatWanteds :: CtOrigin -> ThetaType -> TcM [Ct] newFlatWanteds orig theta = do { loc <- getCtLoc orig ; mapM (inst_to_wanted loc) theta } - where inst_to_wanted loc pty - = do { v <- newWantedEvVar pty + where + inst_to_wanted loc pty + = do { v <- TcMType.newWantedEvVar pty ; return $ - CNonCanonical { cc_id = v - , cc_flavor = Wanted loc + CNonCanonical { cc_ev = Wanted { ctev_evar = v + , ctev_wloc = loc + , ctev_pred = pty } , cc_depth = 0 } } -\end{code}
\ No newline at end of file +\end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 86e98551fb..4f3731ae0d 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -7,7 +7,7 @@ TcSplice: Template Haskell splices \begin{code} -module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, +module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, lookupThName_maybe, runQuasiQuoteExpr, runQuasiQuotePat, runQuasiQuoteDecl, runQuasiQuoteType, @@ -66,7 +66,7 @@ import Serialized import ErrUtils import SrcLoc import Outputable -import Util ( dropList ) +import Util import Data.List ( mapAccumL ) import Pair import Unique @@ -286,7 +286,7 @@ The predicate we use is TcEnv.thTopLevelId. tcBracket :: HsBracket Name -> TcRhoType -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) -kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind) +tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) -- None of these functions add constraints to the LIE lookupThName_maybe :: TH.Name -> TcM (Maybe Name) @@ -302,7 +302,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x) -kcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) +tcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n) @@ -390,7 +390,9 @@ tc_bracket _ (ExpBr expr) -- Result type is ExpQ (= Q Exp) tc_bracket _ (TypBr typ) - = do { _ <- tcHsSigTypeNC ThBrackCtxt typ + = do { _ <- tcLHsType typ -- Do not check type validity; we can have a bracket + -- inside a "knot" where things are not yet settled + -- eg data T a = MkT $(foo [t| a |]) ; tcMetaTy typeQTyConName } -- Result type is Type (= Q Typ) @@ -468,11 +470,9 @@ tcTopSplice expr res_ty ; expr2 <- runMetaE zonked_q_expr ; showSplice "expression" expr (ppr expr2) - -- Rename it, but bale out if there are errors - -- otherwise the type checker just gives more spurious errors ; addErrCtxt (spliceResultDoc expr) $ do - { (exp3, _fvs) <- checkNoErrs (rnLExpr expr2) - + { (exp3, _fvs) <- checkNoErrs $ rnLExpr expr2 + -- checkNoErrs: see Note [Renamer errors] ; exp4 <- tcMonoExpr exp3 res_ty ; return (unLoc exp4) } } @@ -507,6 +507,13 @@ tcTopSpliceExpr tc_action ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') } \end{code} +Note [Renamer errors] +~~~~~~~~~~~~~~~~~~~~~ +It's important to wrap renamer calls in checkNoErrs, because the +renamer does not fail for out of scope variables etc. Instead it +returns a bogus term/type, so that it can report more than one error. +We don't want the type checker to see these bogus unbound variables. + %************************************************************************ %* * @@ -517,12 +524,12 @@ tcTopSpliceExpr tc_action Very like splicing an expression, but we don't yet share code. \begin{code} -kcSpliceType splice@(HsSplice name hs_expr) fvs +tcSpliceType (HsSplice name hs_expr) _ = setSrcSpan (getLoc hs_expr) $ do { stage <- getStage ; case stage of { - Splice -> kcTopSpliceType hs_expr ; - Comp -> kcTopSpliceType hs_expr ; + Splice -> tcTopSpliceType hs_expr ; + Comp -> tcTopSpliceType hs_expr ; Brack pop_level ps_var lie_var -> do -- See Note [How brackets and nested splices are handled] @@ -541,12 +548,13 @@ kcSpliceType splice@(HsSplice name hs_expr) fvs -- but $(h 4) :: a i.e. any type, of any kind ; kind <- newMetaKindVar - ; return (HsSpliceTy splice fvs kind, kind) + ; ty <- newFlexiTyVarTy kind + ; return (ty, kind) }}} -kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind) +tcTopSpliceType :: LHsExpr Name -> TcM (TcType, TcKind) -- Note [How top-level splices are handled] -kcTopSpliceType expr +tcTopSpliceType expr = do { meta_ty <- tcMetaTy typeQTyConName -- Typecheck the expression @@ -556,13 +564,11 @@ kcTopSpliceType expr ; hs_ty2 <- runMetaT zonked_q_expr ; showSplice "type" expr (ppr hs_ty2) - -- Rename it, but bale out if there are errors - -- otherwise the type checker just gives more spurious errors ; addErrCtxt (spliceResultDoc expr) $ do { let doc = SpliceTypeCtx hs_ty2 - ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2) - ; (ty4, kind) <- kcLHsType hs_ty3 - ; return (unLoc ty4, kind) }} + ; (hs_ty3, _fvs) <- checkNoErrs $ rnLHsType doc hs_ty2 + -- checkNoErrs: see Note [Renamer errors] + ; tcLHsType hs_ty3 }} \end{code} %************************************************************************ @@ -829,7 +835,7 @@ runMeta show_code run_and_convert expr ; either_hval <- tryM $ liftIO $ HscMain.hscCompileCoreExpr hsc_env src_span ds_expr ; case either_hval of { - Left exn -> failWithTc (mk_msg "compile and link" exn) ; + Left exn -> fail_with_exn "compile and link" exn ; Right hval -> do { -- Coerce it to Q t, and run it @@ -857,12 +863,16 @@ runMeta show_code run_and_convert expr Right v -> return v Left se -> case fromException se of Just IOEnvFailure -> failM -- Error already in Tc monad - _ -> failWithTc (mk_msg "run" se) -- Exception + _ -> fail_with_exn "run" se -- Exception }}} where - mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", - nest 2 (text (Panic.showException exn)), - if show_code then nest 2 (text "Code:" <+> ppr expr) else empty] + -- see Note [Concealed TH exceptions] + fail_with_exn phase exn = do + exn_msg <- liftIO $ Panic.safeShowException exn + let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", + nest 2 (text exn_msg), + if show_code then nest 2 (text "Code:" <+> ppr expr) else empty] + failWithTc msg \end{code} Note [Exceptions in TH] @@ -894,6 +904,21 @@ like that. Here's how it's processed: - other errors, we add an error to the bag and then fail +Note [Concealed TH exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When displaying the error message contained in an exception originated from TH +code, we need to make sure that the error message itself does not contain an +exception. For example, when executing the following splice: + + $( error ("foo " ++ error "bar") ) + +the message for the outer exception is a thunk which will throw the inner +exception when evaluated. + +For this reason, we display the message of a TH exception using the +'safeShowException' function, which recursively catches any exception thrown +when showing an error message. + To call runQ in the Tc monad, we need to make TcM an instance of Quasi: @@ -976,7 +1001,7 @@ illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (withou \begin{code} reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] reifyInstances th_nm th_tys - = addErrCtxt (ptext (sLit "In reifyInstances") + = addErrCtxt (ptext (sLit "In the argument of reifyInstances:") <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ do { thing <- getThing th_nm ; case thing of @@ -1005,9 +1030,10 @@ reifyInstances th_nm th_tys <+> int tc_arity <> rparen)) ; loc <- getSrcSpanM ; rdr_tys <- mapM (cvt loc) th_tys -- Convert to HsType RdrName - ; rn_tys <- rnLHsTypes doc rdr_tys -- Rename to HsType Name - ; (tys, _res_k) <- kcApps tc (tyConKind tc) rn_tys - ; mapM dsHsType tys } + ; (rn_tys, _fvs) <- checkNoErrs $ rnLHsTypes doc rdr_tys -- Rename to HsType Name + -- checkNoErrs: see Note [Renamer errors] + ; (tys, _res_k) <- tcInferApps tc (tyConKind tc) rn_tys + ; return tys } cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName) cvt loc th_ty = case convertToHsType loc th_ty of @@ -1157,13 +1183,12 @@ reifyThing (ATcId {tct_id = id}) ; fix <- reifyFixity (idName id) ; return (TH.VarI (reifyName id) ty2 Nothing fix) } -reifyThing (ATyVar tv ty) - = do { ty1 <- zonkTcType ty - ; ty2 <- reifyType ty1 - ; return (TH.TyVarI (reifyName tv) ty2) } +reifyThing (ATyVar tv tv1) + = do { ty1 <- zonkTcTyVar tv1 + ; ty2 <- reifyType ty1 + ; return (TH.TyVarI (reifyName tv) ty2) } -reifyThing (AThing {}) = panic "reifyThing AThing" -reifyThing ANothing = panic "reifyThing ANothing" +reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) ------------------------------ reifyAxiom :: CoAxiom -> TcM TH.Info @@ -1271,12 +1296,13 @@ reifyClass cls ------------------------------ reifyClassInstance :: ClsInst -> TcM TH.Dec reifyClassInstance i - = do { cxt <- reifyCxt theta + = do { cxt <- reifyCxt (drop n_silent theta) ; thtypes <- reifyTypes types ; let head_ty = foldl TH.AppT (TH.ConT (reifyName cls)) thtypes ; return $ (TH.InstanceD cxt head_ty []) } where (_tvs, theta, cls, types) = instanceHead i + n_silent = dfunNSilent (instanceDFunId i) ------------------------------ reifyFamilyInstance :: FamInst -> TcM TH.Dec @@ -1303,6 +1329,7 @@ reifyFamilyInstance fi reifyType :: TypeRep.Type -> TcM TH.Type -- Monadic only because of failure reifyType ty@(ForAllTy _ _) = reify_for_all ty +reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) } @@ -1319,6 +1346,10 @@ reify_for_all ty where (tvs, cxt, tau) = tcSplitSigmaTy ty +reifyTyLit :: TypeRep.TyLit -> TcM TH.TyLit +reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) +reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) + reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType @@ -1327,10 +1358,27 @@ reifyKind ki = do { let (kis, ki') = splitKindFunTys ki ; ki'_rep <- reifyNonArrowKind ki' ; kis_rep <- mapM reifyKind kis - ; return (foldr TH.ArrowK ki'_rep kis_rep) } + ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) } where - reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarK - | otherwise = noTH (sLit "this kind") (ppr k) + reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT + | isConstraintKind k = return TH.ConstraintT + reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v)) + reifyNonArrowKind (ForAllTy _ k) = reifyKind k + reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis + reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1 + ; k2' <- reifyKind k2 + ; return (TH.AppT k1' k2') + } + reifyNonArrowKind k = noTH (sLit "this kind") (ppr k) + +reify_kc_app :: TyCon -> [TypeRep.Kind] -> TcM TH.Kind +reify_kc_app kc kis + = fmap (foldl TH.AppT r_kc) (mapM reifyKind kis) + where + r_kc | isPromotedTyCon kc && + isTupleTyCon (promotedTyCon kc) = TH.TupleT (tyConArity kc) + | kc `hasKey` listTyConKey = TH.ListT + | otherwise = TH.ConT (reifyName kc) reifyCxt :: [PredType] -> TcM [TH.Pred] reifyCxt = mapM reifyPred @@ -1345,7 +1393,7 @@ reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam = panic "TcSplice.reifyFamFlavour: not a type family" reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr] -reifyTyVars = mapM reifyTyVar +reifyTyVars = mapM reifyTyVar . filter isTypeVar where reifyTyVar tv | isLiftedTypeKind kind = return (TH.PlainTV name) | otherwise = do kind' <- reifyKind kind @@ -1356,18 +1404,35 @@ reifyTyVars = mapM reifyTyVar reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type reify_tc_app tc tys - = do { tys' <- reifyTypes tys + = do { tys' <- reifyTypes (removeKinds (tyConKind tc) tys) ; return (foldl TH.AppT r_tc tys') } where - r_tc | isTupleTyCon tc = TH.TupleT (tyConArity tc) - | tc `hasKey` listTyConKey = TH.ListT - | otherwise = TH.ConT (reifyName tc) + arity = tyConArity tc + r_tc | isTupleTyCon tc = if isPromotedDataCon tc + then TH.PromotedTupleT arity + else TH.TupleT arity + | tc `hasKey` listTyConKey = TH.ListT + | tc `hasKey` nilDataConKey = TH.PromotedNilT + | tc `hasKey` consDataConKey = TH.PromotedConsT + | otherwise = TH.ConT (reifyName tc) + removeKinds :: Kind -> [TypeRep.Type] -> [TypeRep.Type] + removeKinds (FunTy k1 k2) (h:t) + | isSuperKind k1 = removeKinds k2 t + | otherwise = h : removeKinds k2 t + removeKinds (ForAllTy v k) (h:t) + | isSuperKind (varType v) = removeKinds k t + | otherwise = h : removeKinds k t + removeKinds _ tys = tys reifyPred :: TypeRep.PredType -> TcM TH.Pred -reifyPred ty = case classifyPredType ty of +reifyPred ty + -- We could reify the implicit paramter as a class but it seems + -- nicer to support them properly... + | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty) + | otherwise + = case classifyPredType ty of ClassPred cls tys -> do { tys' <- reifyTypes tys ; return $ TH.ClassP (reifyName cls) tys' } - IPPred _ _ -> noTH (sLit "implicit parameters") (ppr ty) EqPred ty1 ty2 -> do { ty1' <- reifyType ty1 ; ty2' <- reifyType ty2 ; return $ TH.EqualP ty1' ty2' diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index 18a31b0b93..de14aa3b95 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -1,12 +1,12 @@ \begin{code} module TcSplice where import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, - HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl ) + HsExpr, LHsType, LHsExpr, LPat, LHsDecl ) import Name ( Name ) import NameSet ( FreeVars ) import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) -import TcType ( TcRhoType, TcKind ) +import TcType ( TcRhoType, TcType, TcKind ) import Annotations ( Annotation, CoreAnnTarget ) import qualified Language.Haskell.TH as TH @@ -14,8 +14,7 @@ tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) -kcSpliceType :: HsSplice Name -> FreeVars - -> TcM (HsType Name, TcKind) +tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) tcBracket :: HsBracket Name -> TcRhoType diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 95d7d236a7..a22697d217 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -18,9 +18,9 @@ module TcTyClsDecls ( -- Functions used by TcInstDcls to check -- data/type family instance declarations - kcDataDecl, tcConDecls, dataDeclChecks, checkValidTyCon, + kcTyDefn, tcConDecls, dataDeclChecks, checkValidTyCon, tcSynFamInstDecl, tcFamTyPats, - wrongKindOfFamily, badATErr, wrongATArgErr + tcAddFamInstCtxt, wrongKindOfFamily, badATErr, wrongATArgErr ) where #include "HsVersions.h" @@ -31,6 +31,7 @@ import BuildTyCl import TcUnify import TcRnMonad import TcEnv +import TcHsSyn import TcBinds( tcRecSelBinds ) import TcTyDecls import TcClassDcl @@ -77,7 +78,6 @@ import Data.List Note [Grouping of type and class declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly connected component of mutually dependent types and classes. We kind check and type check each group separately to enhance kind polymorphism. Take the @@ -104,7 +104,7 @@ tcTyAndClassDecls :: ModDetails tcTyAndClassDecls boot_details tyclds_s = checkNoErrs $ -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade - fold_env tyclds_s -- type check each group in dependency order folding the global env + fold_env tyclds_s -- Type check each group in dependency order folding the global env where fold_env :: [TyClGroup Name] -> TcM TcGblEnv fold_env [] = getGblEnv @@ -219,11 +219,11 @@ So we infer their kinds in dependency order We need to kind check all types in the mutually recursive group before we know the kind of the type variables. For example: -class C a where - op :: D b => a -> b -> b + class C a where + op :: D b => a -> b -> b -class D c where - bop :: (Monad c) => ... + class D c where + bop :: (Monad c) => ... Here, the kind of the locally-polymorphic type variable "b" depends on *all the uses of class D*. For example, the use of @@ -268,86 +268,109 @@ kcTyClGroup decls -- Step 1: Bind kind variables for non-synonyms ; let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls - ; initial_kinds <- concatMapM getInitialKinds non_syn_decls - ; tcExtendTcTyThingEnv initial_kinds $ do - - -- Step 2: kind-check the synonyms, and extend envt - { tcl_env <- kcSynDecls (calcSynCycles syn_decls) - ; setLclEnv tcl_env $ do + ; initial_kinds <- getInitialKinds TopLevel non_syn_decls - -- Step 3: kind-check the synonyms - { mapM_ (wrapLocM kcTyClDecl) non_syn_decls + ; traceTc "kcTyClGroup: initial kinds" (ppr initial_kinds) + ; tcl_env <- tcExtendTcTyThingEnv initial_kinds $ do + do { -- Step 2: kind-check the synonyms, and extend envt + tcl_env <- kcSynDecls (calcSynCycles syn_decls) + -- Step 3: kind-check the synonyms + ; setLclEnv tcl_env $ + do { mapM_ kcLTyClDecl non_syn_decls + ; getLclTypeEnv } } -- Step 4: generalisation -- Kind checking done for this group -- Now we have to kind generalize the flexis - ; mapM generalise (tyClsBinders decls) }}} + ; res <- mapM (generalise tcl_env) (tyClsBinders decls) + + ; traceTc "kcTyClGroup result" (ppr res) + ; return res } where - generalise :: Name -> TcM (Name, Kind) - generalise name + generalise :: TcTypeEnv -> Name -> TcM (Name, Kind) + -- For polymorphic things this is a no-op + generalise kind_env name = do { traceTc "Generalise type of" (ppr name) - ; thing <- tcLookup name - ; let kc_kind = case thing of - AThing k -> k - _ -> pprPanic "kcTyClGroup" (ppr thing) - ; (kvs, kc_kind') <- kindGeneralizeKind kc_kind + ; let kc_kind = case lookupNameEnv kind_env name of + Just (AThing k) -> k + _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env) + ; kvs <- kindGeneralize (tyVarsOfType kc_kind) + ; kc_kind' <- zonkTcKind kc_kind ; return (name, mkForAllTys kvs kc_kind') } -getInitialKinds :: LTyClDecl Name -> TcM [(Name, TcTyThing)] +getInitialKinds :: TopLevelFlag -> [LTyClDecl Name] -> TcM [(Name, TcTyThing)] +getInitialKinds top_lvl = concatMapM (addLocM (getInitialKind top_lvl)) + +getInitialKind :: TopLevelFlag -> TyClDecl Name -> TcM [(Name, TcTyThing)] -- Allocate a fresh kind variable for each TyCon and Class -- For each tycon, return (tc, AThing k) -- where k is the kind of tc, derived from the LHS -- of the definition (and probably including -- kind unification variables) -- Example: data T a b = ... --- return (T, kv1 -> kv2 -> *) +-- return (T, kv1 -> kv2 -> kv3) -- -- ALSO for each datacon, return (dc, ANothing) -- See Note [ANothing] in TcRnTypes +-- +-- No family instances are passed to getInitialKinds + +getInitialKind top_lvl (TyFamily { tcdLName = L _ name, tcdTyVars = ktvs, tcdKindSig = ksig }) + | isTopLevel top_lvl + = kcHsTyVarBndrs True ktvs $ \ arg_kinds -> + do { res_k <- case ksig of + Just k -> tcLHsKind k + Nothing -> return liftedTypeKind + ; let body_kind = mkArrowKinds arg_kinds res_k + kvs = varSetElems (tyVarsOfType body_kind) + ; return [ (name, AThing (mkForAllTys kvs body_kind)) ] } -getInitialKinds (L _ decl) - = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl) - ; res_kind <- mk_res_kind decl - ; let main_pair = (tcdName decl, AThing (mkArrowKinds arg_kinds res_kind)) - ; inner_pairs <- get_inner_kinds decl - ; return (main_pair : inner_pairs) } - where - mk_arg_kind (UserTyVar _ _) = newMetaKindVar - mk_arg_kind (KindedTyVar _ kind _) = scDsLHsKind kind - - mk_res_kind (TyFamily { tcdKind = Just kind }) = scDsLHsKind kind - mk_res_kind (TyData { tcdKindSig = Just kind }) = scDsLHsKind kind - -- On GADT-style declarations we allow a kind signature - -- data T :: *->* where { ... } - mk_res_kind (ClassDecl {}) = return constraintKind - mk_res_kind _ = return liftedTypeKind - - get_inner_kinds :: TyClDecl Name -> TcM [(Name,TcTyThing)] - get_inner_kinds (TyData { tcdCons = cons }) - = return [ (unLoc (con_name con), ANothing) | L _ con <- cons ] - get_inner_kinds (ClassDecl { tcdATs = ats }) - = concatMapM getInitialKinds ats - get_inner_kinds _ - = return [] - -kcLookupKind :: Located Name -> TcM Kind -kcLookupKind nm = do - tc_ty_thing <- tcLookupLocated nm - case tc_ty_thing of - AThing k -> return k - AGlobal (ATyCon tc) -> return (tyConKind tc) - _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) + | otherwise + = kcHsTyVarBndrs False ktvs $ \ arg_kinds -> + do { res_k <- case ksig of + Just k -> tcLHsKind k + Nothing -> newMetaKindVar + ; return [ (name, AThing (mkArrowKinds arg_kinds res_k)) ] } + +getInitialKind _ (ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats }) + = kcHsTyVarBndrs False ktvs $ \ arg_kinds -> + do { inner_prs <- getInitialKinds NotTopLevel ats + ; let main_pr = (name, AThing (mkArrowKinds arg_kinds constraintKind)) + ; return (main_pr : inner_prs) } + +getInitialKind top_lvl decl@(TyDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdTyDefn = defn }) + | TyData { td_kindSig = Just ksig, td_cons = cons } <- defn + = ASSERT( isTopLevel top_lvl ) + kcHsTyVarBndrs True ktvs $ \ arg_kinds -> + do { res_k <- tcLHsKind ksig + ; let body_kind = mkArrowKinds arg_kinds res_k + kvs = varSetElems (tyVarsOfType body_kind) + main_pr = (name, AThing (mkForAllTys kvs body_kind)) + inner_prs = [(unLoc (con_name con), ARecDataCon) | L _ con <- cons ] + -- See Note [ARecDataCon: Recusion and promoting data constructors] + ; return (main_pr : inner_prs) } + + | TyData { td_cons = cons } <- defn + = kcHsTyVarBndrs False ktvs $ \ arg_kinds -> + do { let main_pr = (name, AThing (mkArrowKinds arg_kinds liftedTypeKind)) + inner_prs = [(unLoc (con_name con), ARecDataCon) | L _ con <- cons ] + -- See Note [ARecDataCon: Recusion and promoting data constructors] + ; return (main_pr : inner_prs) } + + | otherwise = pprPanic "getInitialKind" (ppr decl) + +getInitialKind _ (ForeignType { tcdLName = L _ name }) + = return [(name, AThing liftedTypeKind)] ---------------- -kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM (TcLclEnv) -- Kind bindings +kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM TcLclEnv -- Kind bindings kcSynDecls [] = getLclEnv kcSynDecls (group : groups) = do { nk <- kcSynDecl1 group ; tcExtendKindEnv [nk] (kcSynDecls groups) } ----------------- kcSynDecl1 :: SCC (LTyClDecl Name) -> TcM (Name,TcKind) -- Kind bindings kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl @@ -356,139 +379,80 @@ kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM } -- of out-of-scope tycons kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind) -kcSynDecl decl -- Vanilla type synonyoms only, not family instances +kcSynDecl decl@(TyDecl { tcdTyVars = hs_tvs, tcdLName = L _ name + , tcdTyDefn = TySynonym { td_synRhs = rhs } }) + -- Returns a possibly-unzonked kind = tcAddDeclCtxt decl $ - kcHsTyVars (tcdTyVars decl) $ \ k_tvs -> - do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) - <+> brackets (ppr k_tvs)) - ; (_, rhs_kind) <- kcLHsType (tcdSynRhs decl) - ; traceTc "kcd2" (ppr (tcdName decl)) - ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs - ; return (tcdName decl, tc_kind) } + kcHsTyVarBndrs False hs_tvs $ \ ks -> + do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs) + <+> brackets (ppr ks)) + ; (_, rhs_kind) <- tcLHsType rhs + ; traceTc "kcd2" (ppr name) + ; let tc_kind = mkArrowKinds ks rhs_kind + ; return (name, tc_kind) } +kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl) ------------------------------------------------------------------------ +kcLTyClDecl :: LTyClDecl Name -> TcM () + -- See Note [Kind checking for type and class decls] +kcLTyClDecl (L loc decl) + = setSrcSpan loc $ tcAddDeclCtxt decl $ kcTyClDecl decl + kcTyClDecl :: TyClDecl Name -> TcM () -- This function is used solely for its side effect on kind variables -kcTyClDecl (ForeignType {}) - = return () -kcTyClDecl decl@(TyFamily {}) - = kcFamilyDecl [] decl -- the empty list signals a toplevel decl +kcTyClDecl decl@(TyDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdTyDefn = defn }) + | TyData { td_cons = cons, td_kindSig = Just _ } <- defn + = mapM_ (wrapLocM kcConDecl) cons -- Ignore the td_ctxt; heavily deprecated and inconvenient -kcTyClDecl decl@(TyData {}) - = ASSERT2( not . isFamInstDecl $ decl, ppr decl ) -- must not be a family instance - kcTyClDeclBody decl $ \_ -> kcDataDecl decl + | TyData { td_ctxt = ctxt, td_cons = cons } <- defn + = kcTyClTyVars name hs_tvs $ \ _res_k -> + do { _ <- tcHsContext ctxt + ; mapM_ (wrapLocM kcConDecl) cons } -kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) - = kcTyClDeclBody decl $ \ tvs' -> - do { discardResult (kcHsContext ctxt) - ; mapM_ (wrapLocM (kcFamilyDecl tvs')) ats - ; mapM_ (wrapLocM kc_sig) sigs } - where - kc_sig (TypeSig _ op_ty) = discardResult (kcHsLiftedSigType op_ty) - kc_sig (GenericSig _ op_ty) = discardResult (kcHsLiftedSigType op_ty) - kc_sig _ = return () + | otherwise = pprPanic "kcTyClDecl" (ppr decl) -kcTyClDecl (TySynonym {}) -- Type synonyms are never passed to kcTyClDecl - = panic "kcTyClDecl TySynonym" - --------------------- -kcTyClDeclBody :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> TcM a) - -> TcM a --- getInitialKind has made a suitably-shaped kind for the type or class --- Unpack it, and attribute those kinds to the type variables --- Extend the env with bindings for the tyvars, taken from --- the kind of the tycon/class. Give it to the thing inside, and --- check the result kind matches -kcTyClDeclBody decl thing_inside - = tcAddDeclCtxt decl $ - do { tc_kind <- kcLookupKind (tcdLName decl) - ; let (kinds, _) = splitKindFunTys tc_kind - hs_tvs = tcdTyVars decl - kinded_tvs = ASSERT( length kinds >= length hs_tvs ) - zipWith add_kind hs_tvs kinds - ; tcExtendKindEnvTvs kinded_tvs thing_inside } +kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs + , tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) + = kcTyClTyVars name hs_tvs $ \ _res_k -> + do { _ <- tcHsContext ctxt + ; mapM_ (wrapLocM kcTyClDecl) ats + ; mapM_ (wrapLocM kc_sig) sigs } where - add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k) - add_kind (L loc (KindedTyVar n hsk _)) k = L loc (KindedTyVar n hsk k) + kc_sig (TypeSig _ op_ty) = discardResult (tcHsLiftedType op_ty) + kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty) + kc_sig _ = return () -------------------- --- Kind check a data declaration, assuming that we already extended the --- kind environment with the type variables of the left-hand side (these --- kinded type variables are also passed as the second parameter). --- -kcDataDecl :: TyClDecl Name -> TcM () -kcDataDecl (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) - = do { _ <- kcHsContext ctxt - ; _ <- mapM (wrapLocM (kcConDecl new_or_data)) cons - ; return () } -kcDataDecl d = pprPanic "kcDataDecl" (ppr d) +kcTyClDecl (ForeignType {}) = return () +kcTyClDecl (TyFamily {}) = return () ------------------- -kcConDecl :: NewOrData -> ConDecl Name -> TcM (ConDecl Name) - -- doc comments are typechecked to Nothing here -kcConDecl new_or_data con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs - , con_cxt = ex_ctxt, con_details = details, con_res = res }) +kcConDecl :: ConDecl Name -> TcM () +kcConDecl (ConDecl { con_name = name, con_qvars = ex_tvs + , con_cxt = ex_ctxt, con_details = details, con_res = res }) = addErrCtxt (dataConCtxt name) $ - kcHsTyVars ex_tvs $ \ex_tvs' -> - do { ex_ctxt' <- kcHsContext ex_ctxt - ; details' <- kc_con_details details - ; res' <- case res of - ResTyH98 -> return ResTyH98 - ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } - ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt' - , con_details = details', con_res = res' }) } - where - kc_con_details (PrefixCon btys) - = do { btys' <- mapM kc_larg_ty btys - ; return (PrefixCon btys') } - kc_con_details (InfixCon bty1 bty2) - = do { bty1' <- kc_larg_ty bty1 - ; bty2' <- kc_larg_ty bty2 - ; return (InfixCon bty1' bty2') } - kc_con_details (RecCon fields) - = do { fields' <- mapM kc_field fields - ; return (RecCon fields') } - - kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty - ; return (ConDeclField fld bty' d) } - - kc_larg_ty bty = case new_or_data of - DataType -> kcHsSigType bty - NewType -> kcHsLiftedSigType bty - -- Can't allow an unlifted type for newtypes, because we're effectively - -- going to remove the constructor while coercing it to a lifted type. - -- And newtypes can't be bang'd + kcHsTyVarBndrs False ex_tvs $ \ _ -> + do { _ <- tcHsContext ex_ctxt + ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details) + ; _ <- tcConRes res + ; return () } +\end{code} -------------------- --- Kind check a family declaration or type family default declaration. --- -kcFamilyDecl :: [LHsTyVarBndr Name] -- tyvars of enclosing class decl if any - -> TyClDecl Name -> TcM () -kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) - = kcTyClDeclBody decl $ \tvs' -> - do { mapM_ unifyClassParmKinds tvs' - ; discardResult (scDsLHsMaybeKind kind) } - where - unifyClassParmKinds (L _ tv) - | (n,k) <- hsTyVarNameKind tv - , Just classParmKind <- lookup n classTyKinds - = let ctxt = ptext ( sLit "When kind checking family declaration") - <+> ppr (tcdLName decl) - in addErrCtxt ctxt $ unifyKind k classParmKind >> return () - | otherwise = return () - classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs] - -kcFamilyDecl _ (TySynonym {}) = return () - -- We don't have to do anything here for type family defaults: - -- tcClassATs will use tcAssocDecl to check them -kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) +Note [ARecDataCon: Recusion and promoting data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to allow promotion in a strongly connected component +when kind checking. -------------------- -discardResult :: TcM a -> TcM () -discardResult a = a >> return () -\end{code} +Consider: + data T f = K (f (K Any)) + +When kind checking the `data T' declaration the local env contains the +mappings: + T -> AThing <some initial kind> + K -> ARecDataCon + +ANothing is only used for DataCons, and only used during type checking +in tcTyClGroup. %************************************************************************ @@ -551,7 +515,7 @@ tcTyClDecl calc_isrec (L loc decl) -- "type family" declarations tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] tcTyClDecl1 parent _calc_isrec - (TyFamily {tcdFlavour = TypeFamily, tcdLName = L _ tc_name, tcdTyVars = tvs}) + (TyFamily {tcdFlavour = TypeFamily, tcdLName = L _ tc_name, tcdTyVars = tvs}) = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { traceTc "type family:" (ppr tc_name) ; checkFamFlag tc_name @@ -566,70 +530,37 @@ tcTyClDecl1 parent _calc_isrec ; checkFamFlag tc_name ; extra_tvs <- tcDataKindSig kind ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - tycon = buildAlgTyCon tc_name final_tvs [] + tycon = buildAlgTyCon tc_name final_tvs Nothing [] DataFamilyTyCon Recursive True parent ; return [ATyCon tycon] } -- "type" synonym declaration -tcTyClDecl1 _parent _calc_isrec - (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) - = ASSERT( isNoParent _parent ) - tcTyClTyVars tc_name tvs $ \ tvs' kind -> do - { rhs_ty' <- tcCheckHsType rhs_ty kind - ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') - kind NoParentTyCon - ; return [ATyCon tycon] } - - -- "newtype" and "data" - -- NB: not used for newtype/data instances (whether associated or not) tcTyClDecl1 _parent calc_isrec - (TyData { tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs - , tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons }) + (TyDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdTyDefn = defn }) + = ASSERT( isNoParent _parent ) - let is_rec = calc_isrec tc_name - h98_syntax = consUseH98Syntax cons in - tcTyClTyVars tc_name tvs $ \ tvs' kind -> do - { extra_tvs <- tcDataKindSig kind - ; let final_tvs = tvs' ++ extra_tvs - ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt - ; kind_signatures <- xoptM Opt_KindSignatures - ; existential_ok <- xoptM Opt_ExistentialQuantification - ; gadt_ok <- xoptM Opt_GADTs - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context - - -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name) - - ; dataDeclChecks tc_name new_or_data stupid_theta cons - - ; tycon <- fixM $ \ tycon -> do - { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) - ; data_cons <- tcConDecls new_or_data ex_ok tycon (final_tvs, res_ty) cons - ; tc_rhs <- - if null cons && is_boot -- In a hs-boot file, empty cons means - then return totallyAbstractTyConRhs -- "don't know"; hence totally Abstract - else case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs tc_name tycon (head data_cons) - ; return (buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs - is_rec (not h98_syntax) NoParentTyCon) } - ; return [ATyCon tycon] } + tcTyClTyVars tc_name tvs $ \ tvs' kind -> + tcTyDefn calc_isrec tc_name tvs' kind defn tcTyClDecl1 _parent calc_isrec (ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs - , tcdCtxt = ctxt, tcdMeths = meths - , tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats, tcdATDefs = at_defs }) + , tcdCtxt = ctxt, tcdMeths = meths + , tcdFDs = fundeps, tcdSigs = sigs + , tcdATs = ats, tcdATDefs = at_defs }) = ASSERT( isNoParent _parent ) do { (tvs', ctxt', fds', sig_stuff, gen_dm_env) <- tcTyClTyVars class_name tvs $ \ tvs' kind -> do { MASSERT( isConstraintKind kind ) - ; ctxt' <- tcHsKindedContext =<< kcHsContext ctxt - ; fds' <- mapM (addLocM tc_fundep) fundeps + + ; ctxt' <- tcHsContext ctxt + ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt' + -- Squeeze out any kind unification variables + + ; fds' <- mapM (addLocM tc_fundep) fundeps ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths ; return (tvs', ctxt', fds', sig_stuff, gen_dm_env) } + ; clas <- fixM $ \ clas -> do { let -- This little knot is just so we can get -- hold of the name of the class TyCon, which we @@ -638,8 +569,6 @@ tcTyClDecl1 _parent calc_isrec tc_isrec = calc_isrec tycon_name ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs - -- NB: 'ats' only contains "type family" and "data family" declarations - -- and 'at_defs' only contains associated-type defaults ; buildClass False {- Must include unfoldings for selectors -} class_name tvs' ctxt' fds' at_stuff @@ -669,6 +598,55 @@ tcTyClDecl1 _ _ = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] \end{code} +\begin{code} +tcTyDefn :: (Name -> RecFlag) -> Name + -> [TyVar] -> Kind + -> HsTyDefn Name -> TcM [TyThing] + -- NB: not used for newtype/data instances (whether associated or not) +tcTyDefn _calc_isrec tc_name tvs kind (TySynonym { td_synRhs = hs_ty }) + = do { env <- getLclEnv + ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) + ; rhs_ty <- tcCheckLHsType hs_ty kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; tycon <- buildSynTyCon tc_name tvs (SynonymTyCon rhs_ty) + kind NoParentTyCon + ; return [ATyCon tycon] } + +tcTyDefn calc_isrec tc_name tvs kind + (TyData { td_ND = new_or_data, td_cType = cType + , td_ctxt = ctxt, td_kindSig = mb_ksig + , td_cons = cons }) + = do { extra_tvs <- tcDataKindSig kind + ; let is_rec = calc_isrec tc_name + h98_syntax = consUseH98Syntax cons + final_tvs = tvs ++ extra_tvs + ; stupid_theta <- tcHsContext ctxt + ; kind_signatures <- xoptM Opt_KindSignatures + ; existential_ok <- xoptM Opt_ExistentialQuantification + ; gadt_ok <- xoptM Opt_GADTs + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context + + -- Check that we don't use kind signatures without Glasgow extensions + ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name) + + ; dataDeclChecks tc_name new_or_data stupid_theta cons + + ; tycon <- fixM $ \ tycon -> do + { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) + ; data_cons <- tcConDecls new_or_data ex_ok tycon (final_tvs, res_ty) cons + ; tc_rhs <- + if null cons && is_boot -- In a hs-boot file, empty cons means + then return totallyAbstractTyConRhs -- "don't know"; hence totally Abstract + else case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs tc_name tycon (head data_cons) + ; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs + is_rec (not h98_syntax) NoParentTyCon) } + ; return [ATyCon tycon] } +\end{code} + %************************************************************************ %* * Typechecking associated types (in class decls) @@ -696,20 +674,21 @@ Note that: tcClassATs :: Name -- The class name (not knot-tied) -> TyConParent -- The class parent of this associated type -> [LTyClDecl Name] -- Associated types. All FamTyCon - -> [LTyClDecl Name] -- Associated type defaults. All SynTyCon + -> [LFamInstDecl Name] -- Associated type defaults. All SynTyCon -> TcM [ClassATItem] tcClassATs class_name parent ats at_defs = do { -- Complain about associated type defaults for non associated-types sequence_ [ failWithTc (badATErr class_name n) - | n <- map (tcdName . unLoc) at_defs + | L _ n <- map (fid_tycon . unLoc) at_defs , not (n `elemNameSet` at_names) ] ; mapM tc_at ats } where at_names = mkNameSet (map (tcdName . unLoc) ats) - at_defs_map :: NameEnv [LTyClDecl Name] + at_defs_map :: NameEnv [LFamInstDecl Name] -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' - at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv (tcdName (unLoc at_def)) [at_def]) + at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv + (famInstDeclName at_def) [at_def]) emptyNameEnv at_defs tc_at at = do { [ATyCon fam_tc] <- addLocM (tcTyClDecl1 parent @@ -719,39 +698,58 @@ tcClassATs class_name parent ats at_defs ; atd <- mapM (tcDefaultAssocDecl fam_tc) at_defs ; return (fam_tc, atd) } - ------------------------- tcDefaultAssocDecl :: TyCon -- ^ Family TyCon - -> LTyClDecl Name -- ^ RHS + -> LFamInstDecl Name -- ^ RHS -> TcM ATDefault -- ^ Type checked RHS and free TyVars tcDefaultAssocDecl fam_tc (L loc decl) = setSrcSpan loc $ - tcAddDefaultAssocDeclCtxt (tcdName decl) $ + tcAddFamInstCtxt decl $ do { traceTc "tcDefaultAssocDecl" (ppr decl) ; (at_tvs, at_tys, at_rhs) <- tcSynFamInstDecl fam_tc decl ; return (ATD at_tvs at_tys at_rhs loc) } -- We check for well-formedness and validity later, in checkValidClass -------------------------- -tcSynFamInstDecl :: TyCon -> TyClDecl Name -> TcM ([TyVar], [Type], Type) -tcSynFamInstDecl fam_tc (TySynonym { tcdTyVars = tvs, tcdTyPats = Just pats - , tcdSynRhs = rhs }) +------------------------- +tcSynFamInstDecl :: TyCon -> FamInstDecl Name -> TcM ([TyVar], [Type], Type) +-- Placed here because type family instances appear as +-- default decls in class declarations +tcSynFamInstDecl fam_tc + (FamInstDecl { fid_pats = pats, fid_defn = defn@(TySynonym { td_synRhs = hs_ty }) }) = do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; let kc_rhs rhs kind = kcCheckLHsType rhs (EK kind (ptext (sLit "Expected"))) - - ; tcFamTyPats fam_tc tvs pats (kc_rhs rhs) - $ \tvs' pats' res_kind -> do - - { rhs' <- kc_rhs rhs res_kind - ; rhs'' <- tcHsKindedType rhs' - - ; return (tvs', pats', rhs'') } } + ; tcFamTyPats fam_tc pats (kcTyDefn defn) $ \tvs' pats' res_kind -> + do { rhs_ty <- tcCheckLHsType hs_ty res_kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; traceTc "tcSynFamInstDecl" (ppr fam_tc <+> (ppr tvs' $$ ppr pats' $$ ppr rhs_ty)) + ; return (tvs', pats', rhs_ty) } } tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl) +kcTyDefn :: HsTyDefn Name -> TcKind -> TcM () +-- Used for 'data instance' and 'type instance' only +-- Ordinary 'data' and 'type' are handed by kcTyClDec and kcSynDecls resp +kcTyDefn (TyData { td_ctxt = ctxt, td_cons = cons, td_kindSig = mb_kind }) res_k + = do { _ <- tcHsContext ctxt + ; mapM_ (wrapLocM kcConDecl) cons + ; kcResultKind mb_kind res_k } + +kcTyDefn (TySynonym { td_synRhs = rhs_ty }) res_k + = discardResult (tcCheckLHsType rhs_ty res_k) + +------------------ +kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM () +kcResultKind Nothing res_k + = discardResult (unifyKind res_k liftedTypeKind) + -- type family F a + -- defaults to type family F a :: * +kcResultKind (Just k ) res_k + = do { k' <- tcLHsKind k + ; discardResult (unifyKind k' res_k) } + ------------------------- -- Kind check type patterns and kind annotate the embedded type variables. +-- type instance F [a] = rhs -- -- * Here we check that a type instance matches its kind signature, but we do -- not check whether there is a pattern for each type index; the latter @@ -759,10 +757,10 @@ tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl) ----------------- tcFamTyPats :: TyCon - -> [LHsTyVarBndr Name] -> [LHsType Name] - -> (TcKind -> TcM any) -- Kind checker for RHS + -> HsWithBndrs [LHsType Name] -- Patterns + -> (TcKind -> TcM ()) -- Kind checker for RHS -- result is ignored - -> ([KindVar] -> [TcKind] -> Kind -> TcM a) + -> ([TKVar] -> [TcType] -> Kind -> TcM a) -> TcM a -- Check the type patterns of a type or data family instance -- type instance F <pat1> <pat2> = <type> @@ -775,49 +773,57 @@ tcFamTyPats :: TyCon -- In that case, the type variable 'a' will *already be in scope* -- (and, if C is poly-kinded, so will its kind parameter). -tcFamTyPats fam_tc tyvars pats kind_checker thing_inside - = kcHsTyVars tyvars $ \tvs -> - do { let (fam_kvs, body) = splitForAllTys (tyConKind fam_tc) - - -- A family instance must have exactly the same number of type +tcFamTyPats fam_tc (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) + kind_checker thing_inside + = do { -- A family instance must have exactly the same number of type -- parameters as the family declaration. You can't write -- type family F a :: * -> * -- type instance F Int y = y -- because then the type (F Int) would be like (\y.y) - ; let fam_arity = tyConArity fam_tc - length fam_kvs - ; checkTc (length pats == fam_arity) $ + ; let (fam_kvs, fam_body) = splitForAllTys (tyConKind fam_tc) + fam_arity = tyConArity fam_tc - length fam_kvs + ; checkTc (length arg_pats == fam_arity) $ wrongNumberOfParmsErr fam_arity -- Instantiate with meta kind vars ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs - ; let body' = substKiWith fam_kvs fam_arg_kinds body - (kinds, resKind) = splitKindFunTysN fam_arity body' - ; typats <- zipWithM kcCheckLHsType pats - [ expArgKind (quotes (ppr fam_tc)) kind n - | (kind,n) <- kinds `zip` [1..]] - - -- Kind check the "thing inside"; this just works by - -- side-effecting any kind unification variables - ; _ <- kind_checker resKind - - -- Type check indexed data type declaration - -- We kind generalize the kind patterns since they contain - -- all the meta kind variables + ; loc <- getSrcSpanM + ; let (arg_kinds, res_kind) + = splitKindFunTysN fam_arity $ + substKiWith fam_kvs fam_arg_kinds fam_body + hs_tvs = HsQTvs { hsq_kvs = kvars + , hsq_tvs = userHsTyVarBndrs loc tvars } + + -- Kind-check and quantify -- See Note [Quantifying over family patterns] - ; tcTyVarBndrsKindGen tvs $ \tvs' -> do { - - ; (t_kvs, fam_arg_kinds') <- kindGeneralizeKinds fam_arg_kinds - ; k_typats <- mapM tcHsKindedType typats - - ; thing_inside (t_kvs ++ tvs') (fam_arg_kinds' ++ k_typats) resKind } - } + ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ -> + do { kind_checker res_kind + ; tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds } + ; let all_args = fam_arg_kinds ++ typats + + -- Find free variables (after zonking) + ; tkvs <- zonkTyVarsAndFV (tyVarsOfTypes all_args) + + -- Turn them into skolems, so that we don't subsequently + -- replace a meta kind var with AnyK + ; qtkvs <- zonkQuantifiedTyVars (varSetElems tkvs) + + -- Zonk the patterns etc into the Type world + ; (ze, qtkvs') <- zonkTyBndrsX emptyZonkEnv qtkvs + ; all_args' <- zonkTcTypeToTypes ze all_args + ; res_kind' <- zonkTcTypeToType ze res_kind + + ; traceTc "tcFamPats" (pprTvBndrs qtkvs' $$ ppr all_args' $$ ppr res_kind') + ; tcExtendTyVarEnv qtkvs' $ + thing_inside qtkvs' all_args' res_kind' } \end{code} Note [Quantifying over family patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to quantify over two different lots of kind variables: -First, the ones that come from tcTyVarBndrsKindGen, as usual +First, the ones that come from the kinds of the tyvar args of +tcTyVarBndrsKindGen, as usual data family Dist a -- Proxy :: forall k. k -> * @@ -827,13 +833,34 @@ First, the ones that come from tcTyVarBndrsKindGen, as usual -- The 'k' comes from the tcTyVarBndrsKindGen (a::k) Second, the ones that come from the kind argument of the type family -which we pick up using kindGeneralizeKinds: +which we pick up using the (tyVarsOfTypes typats) in the result of +the thing_inside of tcHsTyvarBndrsGen. -- Any :: forall k. k data instance Dist Any = DA -- Generates data DistAny k = DA -- ax7 k :: Dist k (Any k) ~ DistAny k -- The 'k' comes from kindGeneralizeKinds (Any k) +Note [Quantified kind variables of a family pattern] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider type family KindFam (p :: k1) (q :: k1) + data T :: Maybe k1 -> k2 -> * + type instance KindFam (a :: Maybe k) b = T a b -> Int +The HsBSig for the family patterns will be ([k], [a]) + +Then in the family instance we want to + * Bring into scope [ "k" -> k:BOX, "a" -> a:k ] + * Kind-check the RHS + * Quantify the type instance over k and k', as well as a,b, thus + type instance [k, k', a:Maybe k, b:k'] + KindFam (Maybe k) k' a b = T k k' a b -> Int + +Notice that in the third step we quantify over all the visibly-mentioned +type variables (a,b), but also over the implicitly mentioned kind varaibles +(k, k'). In this case one is bound explicitly but often there will be +none. The role of the kind signature (a :: Maybe k) is to add a constraint +that 'a' must have that kind, and to bring 'k' into scope. + Note [Associated type instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We allow this: @@ -888,18 +915,18 @@ dataDeclChecks tc_name new_or_data stupid_theta cons -- Check that the stupid theta is empty for a GADT-style declaration ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) - -- Check that a newtype has exactly one constructor - -- Do this before checking for empty data decls, so that - -- we don't suggest -XEmptyDataDecls for newtypes - ; checkTc (new_or_data == DataType || isSingleton cons) + -- Check that a newtype has exactly one constructor + -- Do this before checking for empty data decls, so that + -- we don't suggest -XEmptyDataDecls for newtypes + ; checkTc (new_or_data == DataType || isSingleton cons) (newtypeConError tc_name (length cons)) - -- Check that there's at least one condecl, - -- or else we're reading an hs-boot file, or -XEmptyDataDecls - ; empty_data_decls <- xoptM Opt_EmptyDataDecls - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc (not (null cons) || empty_data_decls || is_boot) - (emptyConDeclsErr tc_name) } + -- Check that there's at least one condecl, + -- or else we're reading an hs-boot file, or -XEmptyDataDecls + ; empty_data_decls <- xoptM Opt_EmptyDataDecls + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; checkTc (not (null cons) || empty_data_decls || is_boot) + (emptyConDeclsErr tc_name) } ----------------------------------- tcConDecls :: NewOrData -> Bool -> TyCon -> ([TyVar], Type) @@ -915,40 +942,83 @@ tcConDecl :: NewOrData -> TcM DataCon tcConDecl new_or_data existential_ok rep_tycon res_tmpl -- Data types - con@(ConDecl {con_name = name}) - = do - { ConDecl { con_qvars = tvs, con_cxt = ctxt - , con_details = details, con_res = res_ty } - <- kcConDecl new_or_data con - ; addErrCtxt (dataConCtxt name) $ - tcTyVarBndrsKindGen tvs $ \ tvs' -> do - { ctxt' <- tcHsKindedContext ctxt - ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) - (badExistential name) - ; traceTc "tcConDecl 1" (ppr con) - ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty - ; let - tc_datacon is_infix field_lbls btys - = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys - ; traceTc "tcConDecl 3" (ppr name) - - ; buildDataCon (unLoc name) is_infix - stricts field_lbls - univ_tvs ex_tvs eq_preds ctxt' arg_tys - res_ty' rep_tycon } + con@(ConDecl { con_name = name + , con_qvars = hs_tvs, con_cxt = hs_ctxt + , con_details = hs_details, con_res = hs_res_ty }) + = addErrCtxt (dataConCtxt name) $ + do { traceTc "tcConDecl 1" (ppr name) + ; (tvs, ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) + <- tcHsTyVarBndrs hs_tvs $ \ tvs -> + do { ctxt <- tcHsContext hs_ctxt + ; details <- tcConArgs new_or_data hs_details + ; res_ty <- tcConRes hs_res_ty + ; let (is_infix, field_lbls, btys) = details + (arg_tys, stricts) = unzip btys + ; return (tvs, ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) } + + ; let pretend_res_ty = case res_ty of + ResTyH98 -> unitTy + ResTyGADT ty -> ty + pretend_con_ty = mkSigmaTy tvs ctxt (mkFunTys arg_tys pretend_res_ty) + -- This pretend_con_ty stuff is just a convenient way to get the + -- free kind variables of the type, for kindGeneralize to work on + + -- Generalise the kind variables (returning quantifed TcKindVars) + -- and quanify the type variables (substiting their kinds) + ; kvs <- kindGeneralize (tyVarsOfType pretend_con_ty) + ; tvs <- zonkQuantifiedTyVars tvs + + -- Zonk to Types + ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv (kvs ++ tvs) + ; arg_tys <- zonkTcTypeToTypes ze arg_tys + ; ctxt <- zonkTcTypeToTypes ze ctxt + ; res_ty <- case res_ty of + ResTyH98 -> return ResTyH98 + ResTyGADT ty -> ResTyGADT <$> zonkTcTypeToType ze ty + + ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) + (badExistential name) + + ; let (univ_tvs, ex_tvs, eq_preds, res_ty') + = rejigConRes res_tmpl qtkvs res_ty + + ; traceTc "tcConDecl 3" (ppr name) + ; buildDataCon (unLoc name) is_infix + stricts field_lbls + univ_tvs ex_tvs eq_preds ctxt arg_tys + res_ty' rep_tycon -- NB: we put data_tc, the type constructor gotten from the -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. + } - ; traceTc "tcConDecl 2" (ppr name) - ; case details of - PrefixCon btys -> tc_datacon False [] btys - InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] - RecCon fields -> tc_datacon False field_names btys - where - field_names = map (unLoc . cd_fld_name) fields - btys = map cd_fld_type fields - } } +tcConArgs :: NewOrData -> HsConDeclDetails Name -> TcM (Bool, [Name], [(TcType, HsBang)]) +tcConArgs new_or_data (PrefixCon btys) + = do { btys' <- mapM (tcConArg new_or_data) btys + ; return (False, [], btys') } +tcConArgs new_or_data (InfixCon bty1 bty2) + = do { bty1' <- tcConArg new_or_data bty1 + ; bty2' <- tcConArg new_or_data bty2 + ; return (True, [], [bty1', bty2']) } +tcConArgs new_or_data (RecCon fields) + = do { btys' <- mapM (tcConArg new_or_data) btys + ; return (False, field_names, btys') } + where + field_names = map (unLoc . cd_fld_name) fields + btys = map cd_fld_type fields + +tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsBang) +tcConArg new_or_data bty + = do { traceTc "tcConArg 1" (ppr bty) + ; arg_ty <- tcHsConArgType new_or_data bty + ; traceTc "tcConArg 2" (ppr bty) + ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) + ; return (arg_ty, strict_mark) } + +tcConRes :: ResType (LHsType Name) -> TcM (ResType Type) +tcConRes ResTyH98 = return ResTyH98 +tcConRes (ResTyGADT res_ty) = do { res_ty' <- tcHsLiftedType res_ty + ; return (ResTyGADT res_ty') } -- Example -- data instance T (b,c) where @@ -959,26 +1029,26 @@ tcConDecl new_or_data existential_ok rep_tycon res_tmpl -- Data types -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 -- In this case orig_res_ty = T (e,e) -tcResultType :: ([TyVar], Type) -- Template for result type; e.g. +rejigConRes :: ([TyVar], Type) -- Template for result type; e.g. -- data instance T [a] b c = ... -- gives template ([a,b,c], T [a] b c) -> [TyVar] -- where MkT :: forall x y z. ... - -> ResType Name - -> TcM ([TyVar], -- Universal - [TyVar], -- Existential (distinct OccNames from univs) - [(TyVar,Type)], -- Equality predicates - Type) -- Typechecked return type + -> ResType Type + -> ([TyVar], -- Universal + [TyVar], -- Existential (distinct OccNames from univs) + [(TyVar,Type)], -- Equality predicates + Type) -- Typechecked return type -- We don't check that the TyCon given in the ResTy is -- the same as the parent tycon, because we are in the middle -- of a recursive knot; so it's postponed until checkValidDataCon -tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98 - = return (tmpl_tvs, dc_tvs, [], res_ty) +rejigConRes (tmpl_tvs, res_ty) dc_tvs ResTyH98 + = (tmpl_tvs, dc_tvs, [], res_ty) -- In H98 syntax the dc_tvs are the existential ones -- data T a b c = forall d e. MkT ... -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs -tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) +rejigConRes (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) -- E.g. data T [a] b c where -- MkT :: forall x y z. T [(x,y)] z z -- Then we generate @@ -988,8 +1058,9 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) -- z -- Existentials are the leftover type vars: [x,y] -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z) - = do { res_ty' <- tcHsKindedType res_ty - ; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty' + = (univ_tvs, ex_tvs, eq_spec, res_ty) + where + Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty -- This 'Just' pattern is sure to match, because if not -- checkValidDataCon will complain first. The 'subst' -- should not be looked at until after checkValidDataCon @@ -998,20 +1069,18 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) -- /Lazily/ figure out the univ_tvs etc -- Each univ_tv is either a dc_tv or a tmpl_tv - (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs - choose tmpl (univs, eqs) - | Just ty <- lookupTyVar subst tmpl - = case tcGetTyVar_maybe ty of - Just tv | not (tv `elem` univs) - -> (tv:univs, eqs) - _other -> (new_tmpl:univs, (new_tmpl,ty):eqs) - where -- see Note [Substitution in template variables kinds] - new_tmpl = updateTyVarKind (substTy subst) tmpl - | otherwise = pprPanic "tcResultType" (ppr res_ty) - ex_tvs = dc_tvs `minusList` univ_tvs - - ; return (univ_tvs, ex_tvs, eq_spec, res_ty') } - where + (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs + choose tmpl (univs, eqs) + | Just ty <- lookupTyVar subst tmpl + = case tcGetTyVar_maybe ty of + Just tv | not (tv `elem` univs) + -> (tv:univs, eqs) + _other -> (new_tmpl:univs, (new_tmpl,ty):eqs) + where -- see Note [Substitution in template variables kinds] + new_tmpl = updateTyVarKind (substTy subst) tmpl + | otherwise = pprPanic "tcResultType" (ppr res_ty) + ex_tvs = dc_tvs `minusList` univ_tvs + -- NB: tmpl_tvs and dc_tvs are distinct, but -- we want them to be *visibly* distinct, both for -- interface files and general confusion. So rename @@ -1070,10 +1139,10 @@ consUseH98Syntax _ = True conRepresentibleWithH98Syntax :: ConDecl Name -> Bool conRepresentibleWithH98Syntax (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 }) - = null tvs && null (unLoc ctxt) + = null (hsQTvBndrs tvs) && null (unLoc ctxt) conRepresentibleWithH98Syntax (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) }) - = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs) + = null (unLoc ctxt) && f t (hsLTyVarNames tvs) where -- Each type variable should be used exactly once in the -- result type, and the result type must just be the type -- constructor applied to type variables @@ -1083,13 +1152,6 @@ conRepresentibleWithH98Syntax f _ _ = False ------------------- -tcConArg :: LHsType Name -> TcM (TcType, HsBang) -tcConArg bty - = do { traceTc "tcConArg 1" (ppr bty) - ; arg_ty <- tcHsBangType bty - ; traceTc "tcConArg 2" (ppr bty) - ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) - ; return (arg_ty, strict_mark) } -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or @@ -1106,12 +1168,17 @@ chooseBoxingStrategy arg_ty bang else return HsStrict } HsNoUnpack -> return HsStrict HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas + ; let bang = can_unbox HsUnpackFailed arg_ty + ; if omit_prags && bang == HsUnpack + then return HsStrict + else return bang } -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on -- See Trac #5252: unpacking means we must not conceal the -- representation of the argument type - ; if omit_prags then return HsStrict - else return (can_unbox HsUnpackFailed arg_ty) } - HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) + -- However: even when OmitInterfacePragmas is on, we still want + -- to know if we have HsUnpackFailed, because we omit a + -- warning in that case (#3966) + HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) -- Source code never has shtes where can_unbox :: HsBang -> TcType -> HsBang @@ -1224,6 +1291,7 @@ checkValidTyCon tc = case synTyConRhs tc of SynFamilyTyCon {} -> return () SynonymTyCon ty -> checkValidType syn_ctxt ty + | otherwise = do { -- Check the context on the data decl ; traceTc "cvtc1" (ppr tc) @@ -1299,6 +1367,7 @@ checkValidDataCon tc con ; let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) actual_res_ty = dataConOrigResTy con + ; traceTc "checkValidDataCon" (ppr con $$ ppr tc $$ ppr tc_tvs $$ ppr res_ty_tmpl) ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) res_ty_tmpl actual_res_ty)) @@ -1310,7 +1379,12 @@ checkValidDataCon tc con -- Reason: it's really the argument of an equality constraint ; checkValidType ctxt (dataConUserType con) ; when (isNewTyCon tc) (checkNewDataCon con) + ; mapM_ check_bang (dataConStrictMarks con `zip` [1..]) + + ; checkTc (not (any (isKindVar . fst) (dataConEqSpec con))) + (badGadtKindCon con) + ; traceTc "Done validity of data con" (ppr con <+> ppr (dataConRepType con)) } where @@ -1364,7 +1438,7 @@ checkValidClass cls ; mapM_ check_at_defs at_stuff } where (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls - unary = isSingleton (snd (splitKiTyVars tyvars)) -- IA0_NOTE: only count type arguments + unary = count isTypeVar tyvars == 1 -- Ignore kind variables check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do @@ -1406,9 +1480,9 @@ checkValidClass cls -- type variable. What a mess! check_at_defs (fam_tc, defs) - = do mapM_ (\(ATD _tvs pats rhs _loc) -> checkValidFamInst pats rhs) defs - tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ - mapM_ (check_loc_at_def fam_tc) defs + = do { mapM_ (\(ATD _tvs pats rhs _loc) -> checkValidFamInst pats rhs) defs + ; tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ + mapM_ (check_loc_at_def fam_tc) defs } check_loc_at_def fam_tc (ATD _tvs pats _rhs loc) -- Set the location for each of the default declarations @@ -1481,11 +1555,11 @@ mkRecSelBinds tycons mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) mkRecSelBind (tycon, sel_name) - = (L sel_loc (IdSig sel_id), unitBag (L sel_loc sel_bind)) + = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) where - sel_loc = getSrcSpan tycon - sel_id = Var.mkExportedLocalVar rec_details sel_name - sel_ty vanillaIdInfo + loc = getSrcSpan sel_name + sel_id = Var.mkExportedLocalVar rec_details sel_name + sel_ty vanillaIdInfo rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } -- Find a representative constructor, con1 @@ -1512,23 +1586,23 @@ mkRecSelBind (tycon, sel_name) -- where cons_w_field = [C2,C7] sel_bind | is_naughty = mkTopFunBind sel_lname [mkSimpleMatch [] unit_rhs] | otherwise = mkTopFunBind sel_lname (map mk_match cons_w_field ++ deflt) - mk_match con = mkSimpleMatch [noLoc (mk_sel_pat con)] - (noLoc (HsVar field_var)) - mk_sel_pat con = ConPatIn (noLoc (getName con)) (RecCon rec_fields) + mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] + (L loc (HsVar field_var)) + mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = HsRecField { hsRecFieldId = sel_lname - , hsRecFieldArg = nlVarPat field_var + , hsRecFieldArg = L loc (VarPat field_var) , hsRecPun = False } - sel_lname = L sel_loc sel_name - field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) sel_loc + sel_lname = L loc sel_name + field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc -- Add catch-all default case unless the case is exhaustive -- We do this explicitly so that we get a nice error message that -- mentions this particular record selector deflt | not (any is_unused all_cons) = [] - | otherwise = [mkSimpleMatch [nlWildPat] - (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID)) - (nlHsLit msg_lit))] + | otherwise = [mkSimpleMatch [L loc (WildPat placeHolderType)] + (mkHsApp (L loc (HsVar (getName rEC_SEL_ERROR_ID))) + (L loc (HsLit msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we @@ -1651,6 +1725,14 @@ tcAddDefaultAssocDeclCtxt name thing_inside ctxt = hsep [ptext (sLit "In the type synonym instance default declaration for"), quotes (ppr name)] +tcAddFamInstCtxt :: FamInstDecl Name -> TcM a -> TcM a +tcAddFamInstCtxt (FamInstDecl { fid_tycon = tc, fid_defn = defn }) thing_inside + = addErrCtxt ctxt thing_inside + where + ctxt = hsep [ptext (sLit "In the") <+> pprTyDefnFlavour defn + <+> ptext (sLit "instance declaration for"), + quotes (ppr tc)] + resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc resultTypeMisMatch field_name con1 con2 = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, @@ -1703,17 +1785,18 @@ recClsErr cycles = addErr (sep [ptext (sLit "Cycle in class declaration (via superclasses):"), nest 2 (hsep (intersperse (text "->") (map ppr cycles)))]) -sortLocated :: [Located a] -> [Located a] -sortLocated things = sortLe le things - where - le (L l1 _) (L l2 _) = l1 <= l2 - badDataConTyCon :: DataCon -> Type -> Type -> SDoc badDataConTyCon data_con res_ty_tmpl actual_res_ty = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+> ptext (sLit "returns type") <+> quotes (ppr actual_res_ty)) 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl)) +badGadtKindCon :: DataCon -> SDoc +badGadtKindCon data_con + = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) + <+> ptext (sLit "cannot be GADT-like in its *kind* arguments")) + 2 (ppr data_con <+> dcolon <+> ppr (dataConUserType data_con)) + badATErr :: Name -> Name -> SDoc badATErr clas op = hsep [ptext (sLit "Class"), quotes (ppr clas), @@ -1776,12 +1859,7 @@ wrongATArgErr ty instTy = , ptext (sLit "Found") <+> quotes (ppr ty) <+> ptext (sLit "but expected") <+> quotes (ppr instTy) ] -{- -tooManyParmsErr :: Name -> SDoc -tooManyParmsErr tc_name - = ptext (sLit "Family instance has too many parameters:") <+> - quotes (ppr tc_name) --} + wrongNumberOfParmsErr :: Arity -> SDoc wrongNumberOfParmsErr exp_arity = ptext (sLit "Number of parameters must match family declaration; expected") diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index f5d880d8fa..00fce7267e 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -25,7 +25,6 @@ module TcTyDecls( import TypeRep import HsSyn -import RnHsSyn import Class import Type import HscTypes @@ -62,7 +61,7 @@ We check for type synonym and class cycles on the *source* code. Main reasons: a) Otherwise we'd need a special function to extract type-synonym tycons - from a type, whereas we have extractHsTyNames already + from a type, whereas we already have the free vars pinned on the decl b) If we checked for type synonym loops after building the TyCon, we can't do a hoistForAllTys on the type synonym rhs, (else we fall into @@ -110,12 +109,9 @@ synTyConsOfType ty \begin{code} mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])] -mkSynEdges syn_decls = [ (ldecl, unLoc (tcdLName decl), - mk_syn_edges (tcdSynRhs decl)) - | ldecl@(L _ decl) <- syn_decls ] - where - mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), - not (isTyVarName tc) ] +mkSynEdges syn_decls = [ (ldecl, name, nameSetToList fvs) + | ldecl@(L _ (TyDecl { tcdLName = L _ name + , tcdFVs = fvs })) <- syn_decls ] calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges @@ -237,7 +233,8 @@ calcClassCycles cls | otherwise = flip (foldr (expandType seen path)) tys - expandType _ _ (TyVarTy _) = id + expandType _ _ (TyVarTy {}) = id + expandType _ _ (LitTy {}) = id expandType seen path (AppTy t1 t2) = expandType seen path t1 . expandType seen path t2 expandType seen path (FunTy t1 t2) = expandType seen path t1 . expandType seen path t2 expandType seen path (ForAllTy _tv t) = expandType seen path t @@ -472,7 +469,8 @@ tcTyConsOfType ty where go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim go ty | Just ty' <- tcView ty = go ty' - go (TyVarTy _) = emptyNameEnv + go (TyVarTy {}) = emptyNameEnv + go (LitTy {}) = emptyNameEnv go (TyConApp tc tys) = go_tc tc tys go (AppTy a b) = go a `plusNameEnv` go b go (FunTy a b) = go a `plusNameEnv` go b diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index fa59db97da..5e050e5465 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -37,10 +37,11 @@ module TcType ( isSigTyVar, isOverlappableTyVar, isTyConableTyVar, isAmbiguousTyVar, metaTvRef, isFlexi, isIndirect, isRuntimeUnkSkol, + isTypeVar, isKindVar, -------------------------------- -- Builders - mkPhiTy, mkSigmaTy, + mkPhiTy, mkSigmaTy, mkTcEqPred, -------------------------------- -- Splitters @@ -88,7 +89,7 @@ module TcType ( tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, tidyOpenKind, - tidyTyVarBndr, tidyFreeTyVars, + tidyTyVarBndr, tidyTyVarBndrs, tidyFreeTyVars, tidyOpenTyVar, tidyOpenTyVars, tidyTyVarOcc, tidyTopType, @@ -101,8 +102,7 @@ module TcType ( isFFIImportResultTy, -- :: DynFlags -> Type -> Bool isFFIExportResultTy, -- :: Type -> Bool isFFIExternalTy, -- :: Type -> Bool - isFFIDynArgumentTy, -- :: Type -> Bool - isFFIDynResultTy, -- :: Type -> Bool + isFFIDynTy, -- :: Type -> Type -> Bool isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool isFFILabelTy, -- :: Type -> Bool @@ -115,10 +115,10 @@ module TcType ( -------------------------------- -- Rexported from Kind Kind, typeKind, - unliftedTypeKind, liftedTypeKind, argTypeKind, + unliftedTypeKind, liftedTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, - isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind, + tcIsSubKind, splitKindFunTys, defaultKind, mkMetaKindVar, -------------------------------- @@ -130,10 +130,10 @@ module TcType ( mkTyVarTy, mkTyVarTys, mkTyConTy, isClassPred, isEqPred, isIPPred, - mkClassPred, mkIPPred, + mkClassPred, isDictLikeTy, tcSplitDFunTy, tcSplitDFunHead, - mkEqPred, + mkEqPred, -- Type substitutions TvSubst(..), -- Representation visible to a few friends @@ -152,7 +152,7 @@ module TcType ( tyVarsOfType, tyVarsOfTypes, tcTyVarsOfType, tcTyVarsOfTypes, - pprKind, pprParendKind, + pprKind, pprParendKind, pprSigmaType, pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTheta, pprThetaArrowTy, pprClassPred @@ -173,7 +173,9 @@ import TyCon -- others: import DynFlags -import Name hiding (varName) +import Name -- hiding (varName) + -- We use this to make dictionaries for type literals. + -- Perhaps there's a better way to do this? import NameSet import VarEnv import PrelNames @@ -350,6 +352,8 @@ data UserTypeCtxt -- f (x::t) = ... | BindPatSigCtxt -- Type sig in pattern binding pattern -- (x::t, y) = e + | RuleSigCtxt Name -- LHS of a RULE forall + -- RULE "foo" forall (x :: a -> a). f (Just x) = ... | ResSigCtxt -- Result type sig -- f x :: t = .... | ForSigCtxt Name -- Foreign import or export signature @@ -388,11 +392,7 @@ mkKindName unique = mkSystemName unique kind_var_occ mkMetaKindVar :: Unique -> IORef MetaDetails -> MetaKindVar mkMetaKindVar u r - = mkTcTyVar (mkKindName u) - tySuperKind -- not sure this is right, - -- do we need kind vars for - -- coercions? - (MetaTv TauTv r) + = mkTcTyVar (mkKindName u) superKind (MetaTv TauTv r) kind_var_occ :: OccName -- Just one for all MetaKindVars -- They may be jiggled by tidying @@ -419,6 +419,7 @@ pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig") pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n) pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n) +pprUserTypeCtxt (RuleSigCtxt n) = ptext (sLit "a RULE for") <+> quotes (ppr n) 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) @@ -451,6 +452,9 @@ Tidying is here becuase it has a special case for FlatSkol -- an interface file. -- -- It doesn't change the uniques at all, just the print names. +tidyTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) +tidyTyVarBndrs env tvs = mapAccumL tidyTyVarBndr env tvs + tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) tidyTyVarBndr tidy_env@(occ_env, subst) tyvar = case tidyOccName occ_env occ1 of @@ -529,6 +533,7 @@ tidyTypes env tys = map (tidyType env) tys --------------- tidyType :: TidyEnv -> Type -> Type +tidyType _ (LitTy n) = LitTy n tidyType env (TyVarTy tv) = tidyTyVarOcc env tv tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys in args `seqList` TyConApp tycon args @@ -604,18 +609,19 @@ tidyCos env = map (tidyCo env) %************************************************************************ \begin{code} - --- | Finds type family instances occuring in a type after expanding synonyms. +-- | Finds outermost type-family applications occuring in a type, +-- after expanding synonyms. tcTyFamInsts :: Type -> [(TyCon, [Type])] tcTyFamInsts ty | Just exp_ty <- tcView ty = tcTyFamInsts exp_ty -tcTyFamInsts (TyVarTy _) = [] +tcTyFamInsts (TyVarTy _) = [] tcTyFamInsts (TyConApp tc tys) - | isSynFamilyTyCon tc = [(tc, tys)] + | isSynFamilyTyCon tc = [(tc, tys)] | otherwise = concat (map tcTyFamInsts tys) -tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 -tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 -tcTyFamInsts (ForAllTy _ ty) = tcTyFamInsts ty +tcTyFamInsts (LitTy {}) = [] +tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 +tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 +tcTyFamInsts (ForAllTy _ ty) = tcTyFamInsts ty \end{code} %************************************************************************ @@ -662,6 +668,7 @@ exactTyVarsOfType ty go ty | Just ty' <- tcView ty = go ty' -- This is the key line go (TyVarTy tv) = unitVarSet tv go (TyConApp _ tys) = exactTyVarsOfTypes tys + go (LitTy {}) = emptyVarSet go (FunTy arg res) = go arg `unionVarSet` go res go (AppTy fun arg) = go fun `unionVarSet` go arg go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar @@ -772,6 +779,23 @@ mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) mkPhiTy :: [PredType] -> Type -> Type mkPhiTy theta ty = foldr mkFunTy ty theta + +mkTcEqPred :: TcType -> TcType -> Type +-- During type checking we build equalities between +-- type variables with OpenKind or ArgKind. Ultimately +-- they will all settle, but we want the equality predicate +-- itself to have kind '*'. I think. +-- +-- But for now we call mkTyConApp, not mkEqPred, because the invariants +-- of the latter might not be satisfied during type checking. +-- Notably when we form an equalty (a : OpenKind) ~ (Int : *) +-- +-- But this is horribly delicate: what about type variables +-- that turn out to be bound to Int#? +mkTcEqPred ty1 ty2 + = mkTyConApp eqTyCon [k, ty1, ty2] + where + k = defaultKind (typeKind ty1) \end{code} @isTauTy@ tests for nested for-alls. It should not be called on a boxy type. @@ -797,9 +821,14 @@ getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty' getDFunTyKey (TyVarTy tv) = getOccName tv getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (LitTy x) = getDFunTyLitKey x getDFunTyKey (AppTy fun _) = getDFunTyKey fun getDFunTyKey (FunTy _ _) = getOccName funTyCon getDFunTyKey (ForAllTy _ t) = getDFunTyKey t + +getDFunTyLitKey :: TyLit -> OccName +getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) +getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm \end{code} @@ -1062,9 +1091,6 @@ shallowPredTypePredTree ev_ty () | tc `hasKey` eqTyConKey , let [_, ty1, ty2] = tys -> EqPred ty1 ty2 - () | Just ip <- tyConIP_maybe tc - , let [ty] = tys - -> IPPred ip ty () | isTupleTyCon tc -> TuplePred tys _ -> IrredPred ev_ty @@ -1099,7 +1125,7 @@ mkMinimalBySCs ptys = [ ploc | ploc <- ptys , ploc `not_in_preds` rec_scs ] where rec_scs = concatMap trans_super_classes ptys - not_in_preds p ps = null (filter (eqPred p) ps) + not_in_preds p ps = not (any (eqPred p) ps) trans_super_classes pred -- Superclasses of pred, excluding pred itself = case classifyPredType pred of @@ -1155,7 +1181,7 @@ isOverloadedTy _ = False \begin{code} isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, - isUnitTy, isCharTy :: Type -> Bool + isUnitTy, isCharTy, isAnyTy :: Type -> Bool isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isIntegerTy = is_tc integerTyConKey @@ -1164,6 +1190,7 @@ isWordTy = is_tc wordTyConKey isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey isCharTy = is_tc charTyConKey +isAnyTy = is_tc anyTyConKey isStringTy :: Type -> Bool isStringTy ty @@ -1207,6 +1234,7 @@ tcTyVarsOfType :: Type -> TcTyVarSet tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv else emptyVarSet tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys +tcTyVarsOfType (LitTy {}) = emptyVarSet tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar @@ -1231,6 +1259,7 @@ orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty' orphNamesOfType (TyVarTy _) = emptyNameSet orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon `unionNameSets` orphNamesOfTypes tys +orphNamesOfType (LitTy {}) = emptyNameSet orphNamesOfType (FunTy arg res) = orphNamesOfType arg `unionNameSets` orphNamesOfType res orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSets` orphNamesOfType arg orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty @@ -1314,26 +1343,33 @@ isFFIImportResultTy 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 = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] - -isFFIDynResultTy :: Type -> Bool --- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr, --- or a newtype of either. -isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] +isFFIDynTy :: Type -> Type -> Bool +-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of +-- either, and the wrapped function type must be equal to the given type. +-- We assume that all types have been run through normalizeFfiType, so we don't +-- need to worry about expanding newtypes here. +isFFIDynTy expected ty + -- Note [Foreign import dynamic] + -- In the example below, expected would be 'CInt -> IO ()', while ty would + -- be 'FunPtr (CDouble -> IO ())'. + | Just (tc, [ty']) <- splitTyConApp_maybe ty + , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] + , eqType ty' expected + = True + | otherwise + = False isFFILabelTy :: Type -> Bool --- The type of a foreign label must be Ptr, FunPtr, Addr, --- or a newtype of either. +-- The type of a foreign label must be Ptr, FunPtr, 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. +-- Currently they must all be simple unlifted types, or the well-known type +-- Any, which can be used to pass the address to a Haskell object on the heap to +-- the foreign function. isFFIPrimArgumentTy dflags ty - = checkRepTyCon (legalFIPrimArgTyCon dflags) ty + = isAnyTy ty || checkRepTyCon (legalFIPrimArgTyCon dflags) ty isFFIPrimResultTy :: DynFlags -> Type -> Bool -- Checks for valid result type for a 'foreign import prim' @@ -1375,6 +1411,21 @@ checkRepTyConKey keys = checkRepTyCon (\tc -> tyConUnique tc `elem` keys) \end{code} +Note [Foreign import dynamic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign +type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. + +We use isFFIDynTy to check whether a signature is well-formed. For example, +given a (illegal) declaration like: + +foreign import ccall "dynamic" + foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () + +isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried +result type 'CInt -> IO ()', and return False, as they are not equal. + + ---------------------------------------------- These chaps do the work; they are not exported ---------------------------------------------- diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index a6e1db183c..29f46f629c 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -16,7 +16,7 @@ Type subsumption and unification module TcUnify ( -- Full-blown subsumption tcWrapResult, tcSubType, tcGen, - checkConstraints, newImplication, sigCtxt, + checkConstraints, newImplication, -- Various unifications unifyType, unifyTypeList, unifyTheta, unifyKind, unifyKindEq, @@ -31,7 +31,6 @@ module TcUnify ( matchExpectedFunTys, matchExpectedFunKind, wrapFunResCoercion, - wrapEqCtxt, -------------------------------- -- Errors @@ -43,7 +42,6 @@ module TcUnify ( import HsSyn import TypeRep -import TcErrors ( unifyCtxt ) import TcMType import TcIface import TcRnMonad @@ -161,7 +159,7 @@ matchExpectedFunTys herald arity orig_ty ------------ defer n_req fun_ty = addErrCtxtM mk_ctxt $ - do { arg_tys <- newFlexiTyVarTys n_req argTypeKind + do { arg_tys <- newFlexiTyVarTys n_req openTypeKind ; res_ty <- newFlexiTyVarTy openTypeKind ; co <- unifyType fun_ty (mkFunTys arg_tys res_ty) ; return (co, arg_tys, res_ty) } @@ -535,7 +533,9 @@ uType_defer items ty1 ty2 = ASSERT( not (null items) ) do { eqv <- newEq ty1 ty2 ; loc <- getCtLoc (TypeEqOrigin (last items)) - ; emitFlat (mkNonCanonical eqv (Wanted loc)) + ; let ctev = Wanted { ctev_wloc = loc, ctev_evar = eqv + , ctev_pred = mkTcEqPred ty1 ty2 } + ; emitFlat $ mkNonCanonical ctev -- Error trace only -- NB. do *not* call mkErrInfo unless tracing is on, because @@ -614,7 +614,11 @@ uType_np origin orig_ty1 orig_ty2 | tc1 == tc2, length tys1 == length tys2 = do { cos <- zipWithM (uType origin) tys1 tys2 ; return $ mkTcTyConAppCo tc1 cos } - + + go (LitTy m) ty@(LitTy n) + | m == n + = return $ mkTcReflCo ty + -- See Note [Care with type applications] -- Do not decompose FunTy against App; -- it's often a type error, so leave it for the constraint solver @@ -650,12 +654,11 @@ unifySigmaTy origin ty1 ty2 (tvs2, body2) = tcSplitForAllTys ty2 ; defer_or_continue (not (equalLength tvs1 tvs2)) $ do { - skol_tvs <- tcInstSkolTyVars tvs1 + (subst1, skol_tvs) <- tcInstSkolTyVars tvs1 -- Get location from monad, not from tvs1 ; let tys = mkTyVarTys skol_tvs - in_scope = mkInScopeSet (mkVarSet skol_tvs) - phi1 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1 - phi2 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2 + phi1 = Type.substTy subst1 body1 + phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2 skol_info = UnifyForAllSkol skol_tvs phi1 ; (ev_binds, co) <- checkConstraints skol_info skol_tvs [] $ @@ -885,6 +888,7 @@ checkTauTvUpdate tv ty = Just (TyConApp tc tys') | isSynTyCon tc, Just ty_expanded <- tcView this_ty = ok ty_expanded -- See Note [Type synonyms and the occur check] + ok ty@(LitTy {}) = Just ty ok (FunTy arg res) | Just arg' <- ok arg, Just res' <- ok res = Just (FunTy arg' res') ok (AppTy fun arg) | Just fun' <- ok fun, Just arg' <- ok arg @@ -1001,15 +1005,6 @@ we return a made-up TcTyVarDetails, but I think it works smoothly. pushOrigin :: TcType -> TcType -> [EqOrigin] -> [EqOrigin] pushOrigin ty_act ty_exp origin = UnifyOrigin { uo_actual = ty_act, uo_expected = ty_exp } : origin - ---------------- -wrapEqCtxt :: [EqOrigin] -> TcM a -> TcM a --- Build a suitable error context from the origin and do the thing inside --- The "couldn't match" error comes from the innermost item on the stack, --- and, if there is more than one item, the "Expected/inferred" part --- comes from the outermost item -wrapEqCtxt [] thing_inside = thing_inside -wrapEqCtxt items thing_inside = addErrCtxtM (unifyCtxt (last items)) thing_inside \end{code} @@ -1083,8 +1078,12 @@ unifyKind :: TcKind -- k1 (actual) -> TcM Ordering -- Returns the relation between the kinds -- LT <=> k1 is a sub-kind of k2 -unifyKind (TyVarTy kv1) k2 = uKVar False kv1 k2 -unifyKind k1 (TyVarTy kv2) = uKVar True kv2 k1 +-- unifyKind deals with the top-level sub-kinding story +-- but recurses into the simpler unifyKindEq for any sub-terms +-- The sub-kinding stuff only applies at top level + +unifyKind (TyVarTy kv1) k2 = uKVar False unifyKind EQ kv1 k2 +unifyKind k1 (TyVarTy kv2) = uKVar True unifyKind EQ kv2 k1 unifyKind k1 k2 -- See Note [Expanding synonyms during unification] | Just k1' <- tcView k1 = unifyKind k1' k2 @@ -1099,24 +1098,44 @@ unifyKind k1@(TyConApp kc1 []) k2@(TyConApp kc2 []) unifyKind k1 k2 = do { unifyKindEq k1 k2; return EQ } -- In all other cases, let unifyKindEq do the work -uKVar :: Bool -> MetaKindVar -> TcKind -> TcM Ordering -uKVar isFlipped kv1 k2 - | isMetaTyVar kv1 +uKVar :: Bool -> (TcKind -> TcKind -> TcM a) -> a + -> MetaKindVar -> TcKind -> TcM a +uKVar isFlipped unify_kind eq_res kv1 k2 + | isTcTyVar kv1, isMetaTyVar kv1 -- See Note [Unifying kind variables] = do { mb_k1 <- readMetaTyVar kv1 ; case mb_k1 of - Flexi -> uUnboundKVar kv1 k2 >> return EQ - Indirect k1 -> unifyKind k1 k2 } - | TyVarTy kv2 <- k2, isMetaTyVar kv2 - = uKVar (not isFlipped) kv2 (TyVarTy kv1) - | TyVarTy kv2 <- k2, kv1 == kv2 = return EQ + Flexi -> do { uUnboundKVar kv1 k2; return eq_res } + Indirect k1 -> if isFlipped then unify_kind k2 k1 + else unify_kind k1 k2 } + | TyVarTy kv2 <- k2, kv1 == kv2 + = return eq_res + + | TyVarTy kv2 <- k2, isTcTyVar kv2, isMetaTyVar kv2 + = uKVar (not isFlipped) unify_kind eq_res kv2 (TyVarTy kv1) + | otherwise = if isFlipped then unifyKindMisMatch k2 (TyVarTy kv1) else unifyKindMisMatch (TyVarTy kv1) k2 +{- Note [Unifying kind variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather hackily, kind variables can be TyVars not just TcTyVars. +Main reason is in + data instance T (D (x :: k)) = ...con-decls... +Here we bring into scope a kind variable 'k', and use it in the +con-decls. BUT the con-decls will be finished and frozen, and +are not amenable to subsequent substitution, so it makes sense +to have the *final* kind-variable (a KindVar, not a TcKindVar) in +scope. So at least during kind unification we can encounter a +KindVar. + +Hence the isTcTyVar tests before using isMetaTyVar. +-} + --------------------------- unifyKindEq :: TcKind -> TcKind -> TcM () -unifyKindEq (TyVarTy kv1) k2 = uKVarEq False kv1 k2 -unifyKindEq k1 (TyVarTy kv2) = uKVarEq True kv2 k1 +unifyKindEq (TyVarTy kv1) k2 = uKVar False unifyKindEq () kv1 k2 +unifyKindEq k1 (TyVarTy kv2) = uKVar True unifyKindEq () kv2 k1 unifyKindEq (FunTy a1 r1) (FunTy a2 r2) = do { unifyKindEq a1 a2; unifyKindEq r1 r2 } @@ -1131,27 +1150,10 @@ unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s) unifyKindEq k1 k2 = unifyKindMisMatch k1 k2 ---------------- --- For better error messages, we record whether we've flipped the kinds --- during the process. -uKVarEq :: Bool -> MetaKindVar -> TcKind -> TcM () -uKVarEq isFlipped kv1 k2 - | isMetaTyVar kv1 - = do { mb_k1 <- readMetaTyVar kv1 - ; case mb_k1 of - Flexi -> uUnboundKVar kv1 k2 - Indirect k1 -> unifyKindEq k1 k2 } - | TyVarTy kv2 <- k2, isMetaTyVar kv2 - = uKVarEq (not isFlipped) kv2 (TyVarTy kv1) - | TyVarTy kv2 <- k2, kv1 == kv2 = return () - | otherwise = if isFlipped - then unifyKindMisMatch k2 (TyVarTy kv1) - else unifyKindMisMatch (TyVarTy kv1) k2 - ----------------- uUnboundKVar :: MetaKindVar -> TcKind -> TcM () uUnboundKVar kv1 k2@(TyVarTy kv2) | kv1 == kv2 = return () - | isMetaTyVar kv2 -- Distinct kind variables + | isTcTyVar kv2, isMetaTyVar kv2 -- Distinct kind variables = do { mb_k2 <- readMetaTyVar kv2 ; case mb_k2 of Indirect k2 -> uUnboundKVar kv1 k2 @@ -1161,7 +1163,7 @@ uUnboundKVar kv1 k2@(TyVarTy kv2) uUnboundKVar kv1 non_var_k2 = do { k2' <- zonkTcKind non_var_k2 ; kindOccurCheck kv1 k2' - ; let k2'' = kindSimpleKind k2' + ; let k2'' = defaultKind k2' -- MetaKindVars must be bound only to simple kinds ; writeMetaTyVar kv1 k2'' } @@ -1172,13 +1174,6 @@ kindOccurCheck kv1 k2 -- k2 is zonked then failWithTc (kindOccurCheckErr kv1 k2) else return () -kindSimpleKind :: Kind -> SimpleKind --- (kindSimpleKind k) returns a simple kind k' such that k' <= k -kindSimpleKind k - | isOpenTypeKind k = liftedTypeKind - | isArgTypeKind k = liftedTypeKind - | otherwise = k - mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) mkKindErrorCtxt ty1 ty2 k1 k2 env0 = let (env1, ty1') = tidyOpenType env0 ty1 @@ -1210,131 +1205,3 @@ kindOccurCheckErr tyvar ty = hang (ptext (sLit "Occurs check: cannot construct the infinite kind:")) 2 (sep [ppr tyvar, char '=', ppr ty]) \end{code} - -%************************************************************************ -%* * -\subsection{Checking signature type variables} -%* * -%************************************************************************ - -@checkSigTyVars@ checks that a set of universally quantified type varaibles -are not mentioned in the environment. In particular: - - (a) Not mentioned in the type of a variable in the envt - eg the signature for f in this: - - g x = ... where - f :: a->[a] - f y = [x,y] - - Here, f is forced to be monorphic by the free occurence of x. - - (d) Not (unified with another type variable that is) in scope. - eg f x :: (r->r) = (\y->y) :: forall a. a->r - when checking the expression type signature, we find that - even though there is nothing in scope whose type mentions r, - nevertheless the type signature for the expression isn't right. - - Another example is in a class or instance declaration: - class C a where - op :: forall b. a -> b - op x = x - Here, b gets unified with a - -Before doing this, the substitution is applied to the signature type variable. - --- \begin{code} -checkSigTyVars :: [TcTyVar] -> TcM () -checkSigTyVars sig_tvs = check_sig_tyvars emptyVarSet sig_tvs - -checkSigTyVarsWrt :: TcTyVarSet -> [TcTyVar] -> TcM () --- The extra_tvs can include boxy type variables; --- e.g. TcMatches.tcCheckExistentialPat -checkSigTyVarsWrt extra_tvs sig_tvs - = do { extra_tvs' <- zonkTcTyVarsAndFV extra_tvs - ; check_sig_tyvars extra_tvs' sig_tvs } - -check_sig_tyvars - :: TcTyVarSet -- Global type variables. The universally quantified - -- tyvars should not mention any of these - -- Guaranteed already zonked. - -> [TcTyVar] -- Universally-quantified type variables in the signature - -- Guaranteed to be skolems - -> TcM () -check_sig_tyvars _ [] - = return () -check_sig_tyvars extra_tvs sig_tvs - = ASSERT( all isTcTyVar sig_tvs && all isSkolemTyVar sig_tvs ) - do { gbl_tvs <- tcGetGlobalTyVars - ; traceTc "check_sig_tyvars" $ vcat - [ text "sig_tys" <+> ppr sig_tvs - , text "gbl_tvs" <+> ppr gbl_tvs - , text "extra_tvs" <+> ppr extra_tvs] - - ; let env_tvs = gbl_tvs `unionVarSet` extra_tvs - ; when (any (`elemVarSet` env_tvs) sig_tvs) - (bleatEscapedTvs env_tvs sig_tvs sig_tvs) - } - -bleatEscapedTvs :: TcTyVarSet -- The global tvs - -> [TcTyVar] -- The possibly-escaping type variables - -> [TcTyVar] -- The zonked versions thereof - -> TcM () --- Complain about escaping type variables --- We pass a list of type variables, at least one of which --- escapes. The first list contains the original signature type variable, --- while the second contains the type variable it is unified to (usually itself) -bleatEscapedTvs globals sig_tvs zonked_tvs - = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_tvs) = tidyOpenTyVars env0 sig_tvs - (env2, tidy_zonked_tvs) = tidyOpenTyVars env1 zonked_tvs - - ; (env3, msgs) <- foldlM check (env2, []) (tidy_tvs `zip` tidy_zonked_tvs) - ; failWithTcM (env3, main_msg $$ nest 2 (vcat msgs)) } - where - main_msg = ptext (sLit "Inferred type is less polymorphic than expected") - - check (tidy_env, msgs) (sig_tv, zonked_tv) - | not (zonked_tv `elemVarSet` globals) = return (tidy_env, msgs) - | otherwise - = do { lcl_env <- getLclTypeEnv - ; (tidy_env1, globs) <- findGlobals (unitVarSet zonked_tv) lcl_env tidy_env - ; return (tidy_env1, escape_msg sig_tv zonked_tv globs : msgs) } - ------------------------ -escape_msg :: Var -> Var -> [SDoc] -> SDoc -escape_msg sig_tv zonked_tv globs - | notNull globs - = vcat [sep [msg, ptext (sLit "is mentioned in the environment:")], - nest 2 (vcat globs)] - | otherwise - = msg <+> ptext (sLit "escapes") - -- Sigh. It's really hard to give a good error message - -- all the time. One bad case is an existential pattern match. - -- We rely on the "When..." context to help. - where - msg = ptext (sLit "Quantified type variable") <+> quotes (ppr sig_tv) <+> is_bound_to - is_bound_to - | sig_tv == zonked_tv = empty - | otherwise = ptext (sLit "is unified with") <+> quotes (ppr zonked_tv) <+> ptext (sLit "which") --- \end{code} - -These two context are used with checkSigTyVars - -\begin{code} -sigCtxt :: Id -> [TcTyVar] -> TcThetaType -> TcTauType - -> TidyEnv -> TcM (TidyEnv, MsgDoc) -sigCtxt id sig_tvs sig_theta sig_tau tidy_env = do - actual_tau <- zonkTcType sig_tau - let - (env1, tidy_sig_tvs) = tidyOpenTyVars tidy_env sig_tvs - (env2, tidy_sig_rho) = tidyOpenType env1 (mkPhiTy sig_theta sig_tau) - (env3, tidy_actual_tau) = tidyOpenType env2 actual_tau - sub_msg = vcat [ptext (sLit "Signature type: ") <+> pprType (mkForAllTys tidy_sig_tvs tidy_sig_rho), - ptext (sLit "Type to generalise:") <+> pprType tidy_actual_tau - ] - msg = vcat [ptext (sLit "When trying to generalise the type inferred for") <+> quotes (ppr id), - nest 2 sub_msg] - - return (env3, msg) -\end{code} diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index 992fde7920..136ecec81a 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -237,9 +237,6 @@ instance NamedThing Class where instance Outputable Class where ppr c = ppr (getName c) -instance Show Class where - showsPrec p c = showsPrecSDoc p (ppr c) - instance Outputable DefMeth where ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n ppr (GenDefMeth n) = ptext (sLit "Generic default method") <+> ppr n diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 735b3e3e3b..42e54ba47b 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -30,7 +30,7 @@ module Coercion ( -- ** Constructing coercions mkReflCo, mkCoVarCo, mkAxInstCo, mkAxInstRHS, - mkPiCo, mkPiCos, + mkPiCo, mkPiCos, mkCoCast, mkSymCo, mkTransCo, mkNthCo, mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo, mkForAllCo, mkUnsafeCo, @@ -404,7 +404,7 @@ ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ pprCo co1 <+> ppr_co TyConPrec co2 ppr_co p co@(ForAllCo {}) = ppr_forall_co p co ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) -ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos +ppr_co p (AxiomInstCo con cos) = angleBrackets (pprTypeNameApp p ppr_co (getName con) cos) ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $ ppr_co FunPrec co1 @@ -441,7 +441,8 @@ ppr_forall_co p ty \begin{code} pprCoAxiom :: CoAxiom -> SDoc pprCoAxiom ax - = sep [ ptext (sLit "axiom") <+> ppr ax <+> ppr (co_ax_tvs ax) + = sep [ ptext (sLit "axiom") <+> + sep [ ppr ax, nest 2 (pprTvBndrs (co_ax_tvs ax)) ] , nest 2 (dcolon <+> pprEqPred (Pair (co_ax_lhs ax) (co_ax_rhs ax))) ] \end{code} @@ -504,7 +505,7 @@ coVarKind cv -- | Makes a coercion type from two types: the types whose equality -- is proven by the relevant 'Coercion' mkCoercionType :: Type -> Type -> Type -mkCoercionType = curry mkPrimEqType +mkCoercionType = mkPrimEqPred isReflCo :: Coercion -> Bool isReflCo (Refl {}) = True @@ -671,6 +672,18 @@ mkPiCos vs co = foldr mkPiCo co vs mkPiCo :: Var -> Coercion -> Coercion mkPiCo v co | isTyVar v = mkForAllCo v co | otherwise = mkFunCo (mkReflCo (varType v)) co + +mkCoCast :: Coercion -> Coercion -> Coercion +-- (mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# t1) ~# (s2 ~# t2) +mkCoCast c g + = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 + where + -- g :: (s1 ~# s2) ~# (t1 ~# t2) + -- g1 :: s1 ~# t1 + -- g2 :: s2 ~# t2 + [_reflk, g1, g2] = decomposeCo 3 g + -- Remember, (~#) :: forall k. k -> k -> * + -- so it takes *three* arguments, not two \end{code} %************************************************************************ @@ -950,6 +963,7 @@ ty_co_subst subst ty go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty) where (subst', v') = liftCoSubstTyVarBndr subst v + go ty@(LitTy {}) = mkReflCo ty liftCoSubstTyVar :: LiftCoSubst -> TyVar -> Maybe Coercion liftCoSubstTyVar (LCS _ cenv) tv = lookupVarEnv cenv tv diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 2952912b39..c7b9dedd37 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -13,7 +13,7 @@ FamInstEnv: Type checked family instance declarations -- for details module FamInstEnv ( - FamInst(..), FamFlavor(..), famInstAxiom, famInstTyVars, + FamInst(..), FamFlavor(..), famInstAxiom, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, famInstLHS, pprFamInst, pprFamInstHdr, pprFamInsts, @@ -124,9 +124,6 @@ dataFamInstRepTyCon fi = case fi_flavor fi of DataFamilyInst tycon -> tycon SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) - -famInstTyVars :: FamInst -> TyVarSet -famInstTyVars = fi_tvs \end{code} \begin{code} @@ -158,7 +155,9 @@ pprFamInstHdr (FamInst {fi_axiom = axiom, fi_flavor = flavor}) | isTyConAssoc fam_tc = empty | otherwise = ptext (sLit "instance") - pprHead = pprTypeApp fam_tc tys + pprHead = sep [ ifPprDebug (ptext (sLit "forall") + <+> pprTvBndrs (coAxiomTyVars axiom)) + , pprTypeApp fam_tc tys ] pprTyConSort = case flavor of SynFamilyInst -> ptext (sLit "type") DataFamilyInst tycon @@ -490,7 +489,7 @@ lookup_fam_inst_env' match_fun one_sided ie fam tys n_tys = length tys extra_tys = drop arity tys (match_tys, add_extra_tys) - | arity > n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys) + | arity < n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys) | otherwise = (tys, \res_tys -> res_tys) -- The second case is the common one, hence functional representation @@ -654,6 +653,7 @@ normaliseType env ty | Just ty' <- coreView ty = normaliseType env ty' normaliseType env (TyConApp tc tys) = normaliseTcApp env tc tys +normaliseType _env ty@(LitTy {}) = (Refl ty, ty) normaliseType env (AppTy ty1 ty2) = let (coi1,nty1) = normaliseType env ty1 (coi2,nty2) = normaliseType env ty2 diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs index 8a158139cc..ab1007f29d 100644 --- a/compiler/types/FunDeps.lhs +++ b/compiler/types/FunDeps.lhs @@ -28,7 +28,9 @@ module FunDeps ( import Name import Var import Class +import Id( idType ) import Type +import TcType( tcSplitDFunTy ) import Unify import InstEnv import VarSet @@ -208,7 +210,7 @@ Finally, the position parameters will help us rewrite the wanted constraint ``on type Pred_Loc = (PredType, SDoc) -- SDoc says where the Pred comes from data Equation - = FDEqn { fd_qtvs :: TyVarSet -- Instantiate these to fresh unification vars + = FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars to fresh unification vars , fd_eqs :: [FDEq] -- and then make these equal , fd_pred1, fd_pred2 :: Pred_Loc } -- The Equation arose from -- combining these two constraints @@ -216,6 +218,10 @@ data Equation data FDEq = FDEq { fd_pos :: Int -- We use '0' for the first position , fd_ty_left :: Type , fd_ty_right :: Type } + +instance Outputable FDEq where + ppr (FDEq { fd_pos = p, fd_ty_left = tyl, fd_ty_right = tyr }) + = parens (int p <> comma <+> ppr tyl <> comma <+> ppr tyr) \end{code} Given a bunch of predicates that must hold, such as @@ -282,7 +288,7 @@ improveFromAnother pred1@(ty1, _) pred2@(ty2, _) | Just (cls1, tys1) <- getClassPredTys_maybe ty1 , Just (cls2, tys2) <- getClassPredTys_maybe ty2 , tys1 `lengthAtLeast` 2 && cls1 == cls2 - = [ FDEqn { fd_qtvs = emptyVarSet, fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2 } + = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2 } | let (cls_tvs, cls_fds) = classTvsFds cls1 , fd <- cls_fds , let (ltys1, rs1) = instFD fd cls_tvs tys1 @@ -299,7 +305,7 @@ improveFromAnother _ _ = [] pprEquation :: Equation -> SDoc pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) - = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr (varSetElems qtvs)), + = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr qtvs), nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 | (FDEq _ t1 t2) <- pairs])] improveFromInstEnv :: (InstEnv,InstEnv) @@ -316,7 +322,7 @@ improveFromInstEnv inst_env pred@(ty, _) , let (cls_tvs, cls_fds) = classTvsFds cls instances = classInstances inst_env cls rough_tcs = roughMatchTcs tys - = [ FDEqn { fd_qtvs = qtvs, fd_eqs = eqs, fd_pred1 = p_inst, fd_pred2=pred } + = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs, fd_pred1 = p_inst, fd_pred2=pred } | fd <- cls_fds -- Iterate through the fundeps first, -- because there often are none! , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs @@ -324,25 +330,27 @@ improveFromInstEnv inst_env pred@(ty, _) -- Remember that instanceCantMatch treats both argumnents -- symmetrically, so it's ok to trim the rough_tcs, -- rather than trimming each inst_tcs in turn - , ispec@(ClsInst { is_tvs = qtvs, is_tys = tys_inst, - is_tcs = inst_tcs }) <- instances - , not (instanceCantMatch inst_tcs trimmed_tcs) - , let p_inst = (mkClassPred cls tys_inst, + , ispec <- instances + , (meta_tvs, eqs) <- checkClsFD fd cls_tvs ispec + emptyVarSet tys trimmed_tcs -- NB: orientation + , let p_inst = (mkClassPred cls (is_tys ispec), sep [ ptext (sLit "arising from the dependency") <+> quotes (pprFunDep fd) , ptext (sLit "in the instance declaration") <+> pprNameDefnLoc (getName ispec)]) - , (qtvs, eqs) <- checkClsFD qtvs fd cls_tvs tys_inst tys -- NB: orientation - , not (null eqs) ] improveFromInstEnv _ _ = [] -checkClsFD :: TyVarSet -- Quantified type variables; see note below - -> FunDep TyVar -> [TyVar] -- One functional dependency from the class - -> [Type] -> [Type] - -> [(TyVarSet, [FDEq])] +checkClsFD :: FunDep TyVar -> [TyVar] -- One functional dependency from the class + -> ClsInst -- An instance template + -> TyVarSet -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate + -- TyVarSet are extra tyvars that can be instantiated + -> [([TyVar], [FDEq])] + +checkClsFD fd clas_tvs + (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst, is_dfun = dfun }) + extra_qtvs tys_actual rough_tcs_actual -checkClsFD qtvs fd clas_tvs tys1 tys2 -- 'qtvs' are the quantified type variables, the ones which an be instantiated -- to make the types match. For example, given -- class C a b | a->b where ... @@ -351,8 +359,8 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- and an Inst of form (C (Maybe t1) t2), -- then we will call checkClsFD with -- --- qtvs = {x}, tys1 = [Maybe x, Tree x] --- tys2 = [Maybe t1, t2] +-- is_qtvs = {x}, is_tys = [Maybe x, Tree x] +-- tys_actual = [Maybe t1, t2] -- -- We can instantiate x to t1, and then we want to force -- (Tree x) [t1/x] ~ t2 @@ -364,10 +372,14 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- This function is also used by InstEnv.badFunDeps, which needs to *unify* -- For the one-sided matching case, the qtvs are just from the template, -- so we get matching --- - = ASSERT2( length tys1 == length tys2 && - length tys1 == length clas_tvs - , ppr tys1 <+> ppr tys2 ) + + | instanceCantMatch rough_tcs_inst rough_tcs_actual + = [] -- Filter out ones that can't possibly match, + + | otherwise + = ASSERT2( length tys_inst == length tys_actual && + length tys_inst == length clas_tvs + , ppr tys_inst <+> ppr tys_actual ) case tcUnifyTys bind_fn ltys1 ltys2 of Nothing -> [] @@ -387,8 +399,11 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- so we would produce no FDs, which is clearly wrong. -> [] + | null fdeqs + -> [] + | otherwise - -> [(qtvs', fdeqs)] + -> [(meta_tvs, fdeqs)] -- We could avoid this substTy stuff by producing the eqn -- (qtvs, ls1++rs1, ls2++rs2) -- which will re-do the ls1/ls2 unification when the equation is @@ -405,8 +420,10 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- eqType again, since we know for sure that /at least one/ -- equation in there is useful) - qtvs' = filterVarSet (`notElemTvSubst` subst) qtvs - -- qtvs' are the quantified type variables + (dfun_tvs, _, _, _) = tcSplitDFunTy (idType dfun) + meta_tvs = [ setVarType tv (substTy subst (varType tv)) + | tv <- dfun_tvs, tv `notElemTvSubst` subst ] + -- meta_tvs are the quantified type variables -- that have not been substituted out -- -- Eg. class C a b | a -> b @@ -414,12 +431,21 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- Given constraint C Int z -- we generate the equation -- ({y}, [y], z) + -- + -- But note (a) we get them from the dfun_id, so they are *in order* + -- because the kind variables may be mentioned in the + -- type variabes' kinds + -- (b) we must apply 'subst' to the kinds, in case we have + -- matched out a kind variable, but not a type variable + -- whose kind mentions that kind variable! + -- Trac #6015, #6068 where - bind_fn tv | tv `elemVarSet` qtvs = BindMe - | otherwise = Skolem + bind_fn tv | tv `elemVarSet` qtvs = BindMe + | tv `elemVarSet` extra_qtvs = BindMe + | otherwise = Skolem - (ltys1, rtys1) = instFD fd clas_tvs tys1 - (ltys2, irs2) = instFD_WithPos fd clas_tvs tys2 + (ltys1, rtys1) = instFD fd clas_tvs tys_inst + (ltys2, irs2) = instFD_WithPos fd clas_tvs tys_actual \end{code} @@ -525,13 +551,8 @@ badFunDeps cls_insts clas ins_tv_set ins_tys = nubBy eq_inst $ [ ispec | fd <- fds, -- fds is often empty, so do this first! let trimmed_tcs = trimRoughMatchTcs clas_tvs fd rough_tcs, - ispec@(ClsInst { is_tcs = inst_tcs, is_tvs = tvs, - is_tys = tys }) <- cls_insts, - -- Filter out ones that can't possibly match, - -- based on the head of the fundep - not (instanceCantMatch inst_tcs trimmed_tcs), - notNull (checkClsFD (tvs `unionVarSet` ins_tv_set) - fd clas_tvs tys ins_tys) + ispec <- cls_insts, + notNull (checkClsFD fd clas_tvs ispec ins_tv_set ins_tys trimmed_tcs) ] where (clas_tvs, fds) = classTvsFds clas diff --git a/compiler/types/IParam.lhs b/compiler/types/IParam.lhs deleted file mode 100644 index 67d46c3a82..0000000000 --- a/compiler/types/IParam.lhs +++ /dev/null @@ -1,41 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1998 -% - -\begin{code} -module IParam ( - ipFastString, ipTyConName, ipTyCon, ipCoAxiom - ) where - -#include "HsVersions.h" - -import Name -import TyCon (CoAxiom, TyCon, newTyConCo_maybe) -import Type - -import BasicTypes (IPName(..), ipNameName) -import FastString -import Outputable -\end{code} - -\begin{code} -ipFastString :: IPName Name -> FastString -ipFastString = occNameFS . nameOccName . ipTyConName - -ipTyConName :: IPName Name -> Name -ipTyConName = ipNameName - -ipTyCon :: IPName Name -> TyCon -ipTyCon ip = case wiredInNameTyThing_maybe (ipTyConName ip) of - Just (ATyCon tc) -> tc - _ -> pprPanic "ipTyCon" (ppr ip) - -ipCoAxiom :: IPName Name -> CoAxiom -ipCoAxiom ip = case newTyConCo_maybe (ipTyCon ip) of - Just ax -> ax - _ -> pprPanic "ipCoAxiom" (ppr ip) - --- The IParam DataCon never gets any code generated for it, so it's --- a bit dangerous to actually make use of it, hence no ipDataCon function -\end{code} diff --git a/compiler/types/IParam.lhs-boot b/compiler/types/IParam.lhs-boot deleted file mode 100644 index 34acf1a5da..0000000000 --- a/compiler/types/IParam.lhs-boot +++ /dev/null @@ -1,10 +0,0 @@ -\begin{code} -module IParam where - -import Name -import BasicTypes -import {-# SOURCE #-} TyCon (TyCon) - -ipTyConName :: IPName Name -> Name -ipTyCon :: IPName Name -> TyCon -\end{code}
\ No newline at end of file diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 1e99775906..388846b8ee 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -8,8 +8,8 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module InstEnv ( - DFunId, OverlapFlag(..), - ClsInst(..), pprInstance, pprInstanceHdr, pprInstances, + DFunId, OverlapFlag(..), InstMatch, ClsInstLookupResult, + ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, instanceHead, mkLocalInstance, mkImportedInstance, instanceDFunId, setInstanceDFunId, instanceRoughTcs, @@ -32,9 +32,9 @@ import Outputable import ErrUtils import BasicTypes import UniqFM +import Util import Id import FastString - import Data.Data ( Data, Typeable ) import Data.Maybe ( isJust, isNothing ) \end{code} @@ -122,7 +122,8 @@ instanceDFunId = is_dfun setInstanceDFunId :: ClsInst -> DFunId -> ClsInst setInstanceDFunId ispec dfun - = ASSERT( idType dfun `eqType` idType (is_dfun ispec) ) + = ASSERT2( idType dfun `eqType` idType (is_dfun ispec) + , ppr dfun $$ ppr (idType dfun) $$ ppr (is_dfun ispec) $$ ppr (idType (is_dfun ispec)) ) -- We need to create the cached fields afresh from -- the new dfun id. In particular, the is_tvs in -- the ClsInst must match those in the dfun! @@ -153,13 +154,16 @@ pprInstance ispec -- * pprInstanceHdr is used in VStudio to populate the ClassView tree pprInstanceHdr :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration -pprInstanceHdr ispec@(ClsInst { is_flag = flag }) - = ptext (sLit "instance") <+> ppr flag - <+> sep [pprThetaArrowTy theta, ppr res_ty] +pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) + = getPprStyle $ \ sty -> + let theta_to_print + | debugStyle sty = theta + | otherwise = drop (dfunNSilent dfun) theta + in ptext (sLit "instance") <+> ppr flag + <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty] where - dfun = is_dfun ispec (_, theta, res_ty) = tcSplitSigmaTy (idType dfun) - -- Print without the for-all, which the programmer doesn't write + -- Print without the for-all, which the programmer doesn't write pprInstances :: [ClsInst] -> SDoc pprInstances ispecs = vcat (map pprInstance ispecs) @@ -427,23 +431,30 @@ the env is kept ordered, the first match must be the only one. The thing we are looking up can have an arbitrary "flexi" part. \begin{code} -type InstTypes = [Either TyVar Type] - -- Right ty => Instantiate with this type - -- Left tv => Instantiate with any type of this tyvar's kind - -type InstMatch = (ClsInst, InstTypes) +type DFunInstType = Maybe Type + -- Just ty => Instantiate with this type + -- Nothing => Instantiate with any type of this tyvar's kind + -- See Note [DFunInstType: instantiating types] + +type InstMatch = (ClsInst, [DFunInstType]) + +type ClsInstLookupResult + = ( [InstMatch] -- Successful matches + , [ClsInst] -- These don't match but do unify + , Bool) -- True if error condition caused by + -- SafeHaskell condition. \end{code} -Note [InstTypes: instantiating types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [DFunInstType: instantiating types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A successful match is an ClsInst, together with the types at which the dfun_id in the ClsInst should be instantiated The instantiating types are (Either TyVar Type)s because the dfun might have some tyvars that *only* appear in arguments dfun :: forall a b. C a b, Ord b => D [a] When we match this against D [ty], we return the instantiating types - [Right ty, Left b] -where the 'Left b' indicates that 'b' can be freely instantiated. + [Just ty, Nothing] +where the 'Nothing' indicates that 'b' can be freely instantiated. (The caller instantiates it to a flexi type variable, which will presumably later become fixed via functional dependencies.) @@ -462,12 +473,9 @@ lookupUniqueInstEnv instEnv cls tys | otherwise -> Left $ ptext (sLit "flexible type variable:") <+> (ppr $ mkTyConApp (classTyCon cls) tys) where - inst_tys' = [ty | Right ty <- inst_tys] - noFlexiVar = all isRight inst_tys + inst_tys' = [ty | Just ty <- inst_tys] + noFlexiVar = all isJust inst_tys _other -> Left $ ptext (sLit "instance not found") <+> (ppr $ mkTyConApp (classTyCon cls) tys) - where - isRight (Left _) = False - isRight (Right _) = True lookupInstEnv' :: InstEnv -- InstEnv to look in -> Class -> [Type] -- What we are looking for @@ -526,21 +534,18 @@ lookupInstEnv' ie cls tys Nothing -> find ms us rest ---------------- - lookup_tv :: TvSubst -> TyVar -> Either TyVar Type - -- See Note [InstTypes: instantiating types] + lookup_tv :: TvSubst -> TyVar -> DFunInstType + -- See Note [DFunInstType: instantiating types] lookup_tv subst tv = case lookupTyVar subst tv of - Just ty -> Right ty - Nothing -> Left tv + Just ty -> Just ty + Nothing -> Nothing --------------- -- This is the common way to call this function. lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env - -> Class -> [Type] -- What we are looking for - -> ([InstMatch], -- Successful matches - [ClsInst], -- These don't match but do unify - Bool) -- True if error condition caused by - -- SafeHaskell condition. - + -> Class -> [Type] -- What we are looking for + -> ClsInstLookupResult + lookupInstEnv (pkg_ie, home_ie) cls tys = (safe_matches, all_unifs, safe_fail) where diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index e919297717..5f567eba36 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -12,20 +12,19 @@ module Kind ( -- * Main data type - Kind, typeKind, + SuperKind, Kind, typeKind, -- Kinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, constraintKind, + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, + typeNatKind, typeStringKind, -- Kind constructors... anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, - unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, - constraintKindTyCon, + unliftedTypeKindTyCon, constraintKindTyCon, -- Super Kinds - tySuperKind, tySuperKindTyCon, + superKind, superKindTyCon, pprKind, pprParendKind, @@ -35,19 +34,18 @@ module Kind ( -- ** Predicates on Kinds isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isUbxTupleKind, isArgTypeKind, isConstraintKind, - isConstraintOrLiftedKind, isKind, - isSuperKind, noHashInKind, + isConstraintKind, isConstraintOrLiftedKind, isKind, isKindVar, + isSuperKind, isSuperKindTyCon, isLiftedTypeKindCon, isConstraintKindCon, isAnyKind, isAnyKindCon, + okArrowArgKind, okArrowResultKind, - isSubArgTypeKind, tcIsSubArgTypeKind, - isSubOpenTypeKind, tcIsSubOpenTypeKind, - isSubKind, tcIsSubKind, defaultKind, - isSubKindCon, tcIsSubKindCon, isSubOpenTypeKindCon, + isSubOpenTypeKind, + isSubKind, isSubKindCon, + tcIsSubKind, tcIsSubKindCon, + defaultKind, -- ** Functions on variables - isKiVar, splitKiTyVars, partitionKiTyVars, kiVarsOfKind, kiVarsOfKinds ) where @@ -59,38 +57,10 @@ import {-# SOURCE #-} Type ( typeKind, substKiWith, eqKind ) import TypeRep import TysPrim import TyCon -import Var import VarSet import PrelNames import Outputable - -import Data.List ( partition ) -\end{code} - -%************************************************************************ -%* * - Predicates over Kinds -%* * -%************************************************************************ - -\begin{code} -------------------- --- Lastly we need a few functions on Kinds - -isLiftedTypeKindCon :: TyCon -> Bool -isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey - --- This checks that its argument does not contain # or (#). --- It is used in tcTyVarBndrs. -noHashInKind :: Kind -> Bool -noHashInKind (TyVarTy {}) = True -noHashInKind (FunTy k1 k2) = noHashInKind k1 && noHashInKind k2 -noHashInKind (ForAllTy _ ki) = noHashInKind ki -noHashInKind (TyConApp kc kis) - = not (kc `hasKey` unliftedTypeKindTyConKey) - && not (kc `hasKey` ubxTupleKindTyConKey) - && all noHashInKind kis -noHashInKind _ = panic "noHashInKind" +import Util \end{code} %************************************************************************ @@ -135,41 +105,29 @@ synTyConResKind :: TyCon -> Kind synTyConResKind tycon = kindAppResult (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon)) -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind, +isOpenTypeKind, isUnliftedTypeKind, isConstraintKind, isAnyKind, isConstraintOrLiftedKind :: Kind -> Bool -isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, - isUnliftedTypeKindCon, isSubArgTypeKindCon, tcIsSubArgTypeKindCon, - isSubOpenTypeKindCon, tcIsSubOpenTypeKindCon, isConstraintKindCon, - isAnyKindCon :: TyCon -> Bool +isOpenTypeKindCon, isUnliftedTypeKindCon, + isSubOpenTypeKindCon, isConstraintKindCon, + isLiftedTypeKindCon, isAnyKindCon :: TyCon -> Bool -isAnyKindCon tc = tyConUnique tc == anyKindTyConKey + +isLiftedTypeKindCon tc = tyConUnique tc == liftedTypeKindTyConKey +isAnyKindCon tc = tyConUnique tc == anyKindTyConKey +isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey +isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey +isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey isAnyKind (TyConApp tc _) = isAnyKindCon tc isAnyKind _ = False -isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey - isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc isOpenTypeKind _ = False -isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey - -isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc -isUbxTupleKind _ = False - -isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey - -isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc -isArgTypeKind _ = False - -isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey - isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc isUnliftedTypeKind _ = False -isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey - isConstraintKind (TyConApp tc _) = isConstraintKindCon tc isConstraintKind _ = False @@ -177,103 +135,107 @@ isConstraintOrLiftedKind (TyConApp tc _) = isConstraintKindCon tc || isLiftedTypeKindCon tc isConstraintOrLiftedKind _ = False --- Subkinding +-------------------------------------------- +-- Kinding for arrow (->) +-- Says when a kind is acceptable on lhs or rhs of an arrow +-- arg -> res + +okArrowArgKindCon, okArrowResultKindCon :: TyCon -> Bool +okArrowArgKindCon kc + | isLiftedTypeKindCon kc = True + | isUnliftedTypeKindCon kc = True + | isConstraintKindCon kc = True + | otherwise = False + +okArrowResultKindCon = okArrowArgKindCon + +okArrowArgKind, okArrowResultKind :: Kind -> Bool +okArrowArgKind (TyConApp kc []) = okArrowArgKindCon kc +okArrowArgKind _ = False + +okArrowResultKind (TyConApp kc []) = okArrowResultKindCon kc +okArrowResultKind _ = False + +----------------------------------------- +-- Subkinding -- The tc variants are used during type-checking, where we don't want the -- Constraint kind to be a subkind of anything -- After type-checking (in core), Constraint is a subkind of argTypeKind -isSubOpenTypeKind, tcIsSubOpenTypeKind :: Kind -> Bool +isSubOpenTypeKind :: Kind -> Bool -- ^ True of any sub-kind of OpenTypeKind isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc isSubOpenTypeKind _ = False --- ^ True of any sub-kind of OpenTypeKind -tcIsSubOpenTypeKind (TyConApp kc []) = tcIsSubOpenTypeKindCon kc -tcIsSubOpenTypeKind _ = False - isSubOpenTypeKindCon kc - | isSubArgTypeKindCon kc = True - | isUbxTupleKindCon kc = True - | isOpenTypeKindCon kc = True - | otherwise = False - -tcIsSubOpenTypeKindCon kc - | tcIsSubArgTypeKindCon kc = True - | isUbxTupleKindCon kc = True - | isOpenTypeKindCon kc = True - | otherwise = False - -isSubArgTypeKindCon kc - | isUnliftedTypeKindCon kc = True - | isLiftedTypeKindCon kc = True - | isArgTypeKindCon kc = True - | isConstraintKindCon kc = True - | otherwise = False - -tcIsSubArgTypeKindCon kc - | isConstraintKindCon kc = False - | otherwise = isSubArgTypeKindCon kc - -isSubArgTypeKind, tcIsSubArgTypeKind :: Kind -> Bool --- ^ True of any sub-kind of ArgTypeKind -isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc -isSubArgTypeKind _ = False - -tcIsSubArgTypeKind (TyConApp kc []) = tcIsSubArgTypeKindCon kc -tcIsSubArgTypeKind _ = False - --- | Is this a super-kind (i.e. a type-of-kinds)? -isSuperKind :: Type -> Bool -isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc -isSuperKind _ = False + = isOpenTypeKindCon kc + || isUnliftedTypeKindCon kc + || isLiftedTypeKindCon kc + || isConstraintKindCon kc -- Needed for error (Num a) "blah" + -- and so that (Ord a -> Eq a) is well-kinded + -- and so that (# Eq a, Ord b #) is well-kinded -- | Is this a kind (i.e. a type-of-types)? isKind :: Kind -> Bool isKind k = isSuperKind (typeKind k) -isSubKind, tcIsSubKind :: Kind -> Kind -> Bool -isSubKind = isSubKind' False -tcIsSubKind = isSubKind' True - --- The first argument denotes whether we are in the type-checking phase or not -isSubKind' :: Bool -> Kind -> Kind -> Bool +isSubKind :: Kind -> Kind -> Bool -- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ -isSubKind' duringTc (FunTy a1 r1) (FunTy a2 r2) - = (isSubKind' duringTc a2 a1) && (isSubKind' duringTc r1 r2) +isSuperKindTyCon :: TyCon -> Bool +isSuperKindTyCon tc = tc `hasKey` superKindTyConKey + +isSubKind (FunTy a1 r1) (FunTy a2 r2) + = (isSubKind a2 a1) && (isSubKind r1 r2) -isSubKind' duringTc k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) - | isPromotedTypeTyCon kc1 || isPromotedTypeTyCon kc2 +isSubKind k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) + | isPromotedTyCon kc1 || isPromotedTyCon kc2 -- handles promoted kinds (List *, Nat, etc.) - = eqKind k1 k2 + = eqKind k1 k2 | isSuperKindTyCon kc1 || isSuperKindTyCon kc2 -- handles BOX - = WARN( not (isSuperKindTyCon kc2 && isSuperKindTyCon kc2 - && null k1s && null k2s), + = ASSERT2( isSuperKindTyCon kc2 && isSuperKindTyCon kc2 + && null k1s && null k2s, ppr kc1 <+> ppr kc2 ) - kc1 == kc2 + True -- If one is BOX, the other must be too | otherwise = -- handles usual kinds (*, #, (#), etc.) ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 ) - if duringTc then kc1 `tcIsSubKindCon` kc2 - else kc1 `isSubKindCon` kc2 + kc1 `isSubKindCon` kc2 -isSubKind' _duringTc k1 k2 = eqKind k1 k2 +isSubKind k1 k2 = eqKind k1 k2 isSubKindCon :: TyCon -> TyCon -> Bool -- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ isSubKindCon kc1 kc2 - | kc1 == kc2 = True - | isSubArgTypeKindCon kc1 && isArgTypeKindCon kc2 = True - | isSubOpenTypeKindCon kc1 && isOpenTypeKindCon kc2 = True - | otherwise = False + | kc1 == kc2 = True + | isOpenTypeKindCon kc2 = isSubOpenTypeKindCon kc1 + | otherwise = False + +------------------------- +-- Hack alert: we need a tiny variant for the typechecker +-- Reason: f :: Int -> (a~b) +-- g :: forall (c::Constraint). Int -> c +-- We want to reject these, even though Constraint is +-- a sub-kind of OpenTypeKind. It must be a sub-kind of OpenTypeKind +-- *after* the typechecker +-- a) So that (Ord a -> Eq a) is a legal type +-- b) So that the simplifer can generate (error (Eq a) "urk") +-- +-- Easiest way to reject is simply to make Constraint not +-- below OpenTypeKind when type checking + +tcIsSubKind :: Kind -> Kind -> Bool +tcIsSubKind k1 k2 + | isConstraintKind k1 = isConstraintKind k2 + | otherwise = isSubKind k1 k2 tcIsSubKindCon :: TyCon -> TyCon -> Bool tcIsSubKindCon kc1 kc2 - | kc1 == kc2 = True - | isConstraintKindCon kc1 || isConstraintKindCon kc2 = False - | otherwise = isSubKindCon kc1 kc2 + | isConstraintKindCon kc1 = isConstraintKindCon kc2 + | otherwise = isSubKindCon kc1 kc2 +------------------------- defaultKind :: Kind -> Kind -- ^ Used when generalising: default OpenKind and ArgKind to *. -- See "Type#kind_subtyping" for more information on what that means @@ -290,21 +252,11 @@ defaultKind :: Kind -> Kind -- because that would allow a call like (f 3#) as well as (f True), -- and the calling conventions differ. -- This defaulting is done in TcMType.zonkTcTyVarBndr. -defaultKind k - | tcIsSubOpenTypeKind k = liftedTypeKind - | otherwise = k - -splitKiTyVars :: [TyVar] -> ([KindVar], [TyVar]) --- Precondition: kind variables should precede type variables --- Postcondition: appending the two result lists gives the input! -splitKiTyVars = span (isSuperKind . tyVarKind) - -partitionKiTyVars :: [TyVar] -> ([KindVar], [TyVar]) -partitionKiTyVars = partition (isSuperKind . tyVarKind) - --- Checks if this "type or kind" variable is a kind variable -isKiVar :: TyVar -> Bool -isKiVar v = isSuperKind (varType v) +-- +-- The test is really whether the kind is strictly above '*' +defaultKind (TyConApp kc _args) + | isOpenTypeKindCon kc = ASSERT( null _args ) liftedTypeKind +defaultKind k = k -- Returns the free kind variables in a kind kiVarsOfKind :: Kind -> VarSet diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index 4880e68a3a..7d707c33c4 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -26,6 +26,7 @@ import Outputable import Pair import Maybes( allMaybes ) import FastString +import Util \end{code} %************************************************************************ diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index e2c192f435..147e16dbe1 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -6,88 +6,82 @@ The @TyCon@ datatype \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TyCon( -- * Main TyCon data types - TyCon, FieldLabel, + TyCon, FieldLabel, - AlgTyConRhs(..), visibleDataCons, + AlgTyConRhs(..), visibleDataCons, TyConParent(..), isNoParent, - SynTyConRhs(..), + SynTyConRhs(..), - -- ** Coercion axiom constructors - CoAxiom(..), + -- ** Coercion axiom constructors + CoAxiom(..), coAxiomName, coAxiomArity, coAxiomTyVars, coAxiomLHS, coAxiomRHS, isImplicitCoAxiom, -- ** Constructing TyCons - mkAlgTyCon, - mkClassTyCon, - mkIParamTyCon, - mkFunTyCon, - mkPrimTyCon, - mkKindTyCon, - mkLiftedPrimTyCon, - mkTupleTyCon, - mkSynTyCon, - mkSuperKindTyCon, + mkAlgTyCon, + mkClassTyCon, + mkFunTyCon, + mkPrimTyCon, + mkKindTyCon, + mkLiftedPrimTyCon, + mkTupleTyCon, + mkSynTyCon, mkForeignTyCon, - mkPromotedDataTyCon, - mkPromotedTyCon, + mkPromotedDataCon, + mkPromotedTyCon, -- ** Predicates on TyCons isAlgTyCon, - isClassTyCon, isFamInstTyCon, - isFunTyCon, + isClassTyCon, isFamInstTyCon, + isFunTyCon, isPrimTyCon, - isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isSynTyCon, isClosedSynTyCon, - isSuperKindTyCon, isDecomposableTyCon, - isForeignTyCon, tyConHasKind, - isPromotedDataTyCon, isPromotedTypeTyCon, + isDecomposableTyCon, + isForeignTyCon, + isPromotedDataCon, isPromotedTyCon, - isInjectiveTyCon, - isDataTyCon, isProductTyCon, isEnumerationTyCon, + isInjectiveTyCon, + isDataTyCon, isProductTyCon, isEnumerationTyCon, isNewTyCon, isAbstractTyCon, isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon, isUnLiftedTyCon, - isGadtSyntaxTyCon, isDistinctTyCon, isDistinctAlgRhs, - isTyConAssoc, tyConAssoc_maybe, - isRecursiveTyCon, - isImplicitTyCon, + isGadtSyntaxTyCon, isDistinctTyCon, isDistinctAlgRhs, + isTyConAssoc, tyConAssoc_maybe, + isRecursiveTyCon, + isImplicitTyCon, -- ** Extracting information out of TyCons - tyConName, - tyConKind, - tyConUnique, - tyConTyVars, - tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe, - tyConFamilySize, - tyConStupidTheta, - tyConArity, + tyConName, + tyConKind, + tyConUnique, + tyConTyVars, + tyConCType, tyConCType_maybe, + tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe, + tyConFamilySize, + tyConStupidTheta, + tyConArity, tyConParent, - tyConTuple_maybe, tyConClass_maybe, tyConIP_maybe, - tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, + tyConTuple_maybe, tyConClass_maybe, + tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, synTyConDefn, synTyConRhs, synTyConType, tyConExtName, -- External name for foreign types - algTyConRhs, - newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, + algTyConRhs, + newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, tupleTyConBoxity, tupleTyConSort, tupleTyConArity, + promotedDataCon, promotedTyCon, -- ** Manipulating TyCons - tcExpandTyCon_maybe, coreExpandTyCon_maybe, - makeTyConAbstract, - newTyConCo, newTyConCo_maybe, + tcExpandTyCon_maybe, coreExpandTyCon_maybe, + makeTyConAbstract, + newTyConCo, newTyConCo_maybe, + pprPromotionQuote, -- * Primitive representations of Types - PrimRep(..), - tyConPrimRep, + PrimRep(..), + tyConPrimRep, primRepSizeW ) where @@ -95,11 +89,11 @@ module TyCon( import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) -import {-# SOURCE #-} IParam ( ipTyConName ) import Var import Class import BasicTypes +import ForeignCall import Name import PrelNames import Maybes @@ -112,7 +106,7 @@ import Data.Typeable (Typeable) \end{code} ----------------------------------------------- - Notes about type families + Notes about type families ----------------------------------------------- Note [Type synonym families] @@ -120,9 +114,9 @@ Note [Type synonym families] * Type synonym families, also known as "type functions", map directly onto the type functions in FC: - type family F a :: * - type instance F Int = Bool - ..etc... + type family F a :: * + type instance F Int = Bool + ..etc... * Reply "yes" to isSynFamilyTyCon, and isFamilyTyCon @@ -133,15 +127,15 @@ Note [Type synonym families] family. * Type functions can't appear in the LHS of a type function: - type instance F (F Int) = ... -- BAD! + type instance F (F Int) = ... -- BAD! * Translation of type family decl: - type family F a :: * + type family F a :: * translates to a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon * Translation of type family decl: - type family F a :: * + type family F a :: * translates to a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon @@ -155,51 +149,49 @@ Note [Data type families] See also Note [Wrappers for data instance tycons] in MkId.lhs * Data type families are declared thus - data family T a :: * - data instance T Int = T1 | T2 Bool + data family T a :: * + data instance T Int = T1 | T2 Bool Here T is the "family TyCon". * Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon -* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon - * The user does not see any "equivalent types" as he did with type synonym families. He just sees constructors with types - T1 :: T Int - T2 :: Bool -> T Int + T1 :: T Int + T2 :: Bool -> T Int * Here's the FC version of the above declarations: - data T a - data R:TInt = T1 | T2 Bool - axiom ax_ti : T Int ~ R:TInt + data T a + data R:TInt = T1 | T2 Bool + axiom ax_ti : T Int ~ R:TInt The R:TInt is the "representation TyCons". It has an AlgTyConParent of - FamInstTyCon T [Int] ax_ti + FamInstTyCon T [Int] ax_ti -* The data contructor T2 has a wrapper (which is what the +* The data contructor T2 has a wrapper (which is what the source-level "T2" invokes): - $WT2 :: Bool -> T Int - $WT2 b = T2 b `cast` sym ax_ti + $WT2 :: Bool -> T Int + $WT2 b = T2 b `cast` sym ax_ti * A data instance can declare a fully-fledged GADT: - data instance T (a,b) where + data instance T (a,b) where X1 :: T (Int,Bool) - X2 :: a -> b -> T (a,b) + X2 :: a -> b -> T (a,b) Here's the FC version of the above declaration: - data R:TPair a where - X1 :: R:TPair Int Bool - X2 :: a -> b -> R:TPair a b - axiom ax_pr :: T (a,b) ~ R:TPair a b + data R:TPair a where + X1 :: R:TPair Int Bool + X2 :: a -> b -> R:TPair a b + axiom ax_pr :: T (a,b) ~ R:TPair a b - $WX1 :: forall a b. a -> b -> T (a,b) - $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) + $WX1 :: forall a b. a -> b -> T (a,b) + $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) The R:TPair are the "representation TyCons". We have a bit of work to do, to unpick the result types of the @@ -208,24 +200,24 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs The representation TyCon R:TList, has an AlgTyConParent of - FamInstTyCon T [(a,b)] ax_pr + FamInstTyCon T [(a,b)] ax_pr * Notice that T is NOT translated to a FC type function; it just becomes a "data type" with no constructors, which can be coerced inot into R:TInt, R:TPair by the axioms. These axioms axioms come into play when (and *only* when) you - - use a data constructor - - do pattern matching + - use a data constructor + - do pattern matching Rather like newtype, in fact As a result - T behaves just like a data type so far as decomposition is concerned - - (T Int) is not implicitly converted to R:TInt during type inference. + - (T Int) is not implicitly converted to R:TInt during type inference. Indeed the latter type is unknown to the programmer. - - There *is* an instance for (T Int) in the type-family instance + - There *is* an instance for (T Int) in the type-family instance environment, but it is only used for overlap checking - It's fine to have T in the LHS of a type function: @@ -235,14 +227,14 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs should not think of a data family T as a *type function* at all, not even an injective one! We can't allow even injective type functions on the LHS of a type function: - type family injective G a :: * - type instance F (G Int) = Bool + type family injective G a :: * + type instance F (G Int) = Bool is no good, even if G is injective, because consider - type instance G Int = Bool - type instance F Bool = Char + type instance G Int = Bool + type instance F Bool = Char So a data type family is not an injective type function. It's just a - data type with some axioms that connect it to other data types. + data type with some axioms that connect it to other data types. Note [Associated families and their parent class] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -250,18 +242,18 @@ Note [Associated families and their parent class] that they have a TyConParent of AssocFamilyTyCon, which identifies the parent class. -However there is an important sharing relationship between +However there is an important sharing relationship between * the tyConTyVars of the parent Class * the tyConTyvars of the associated TyCon class C a b where data T p a - type F a q b + type F a q b Here the 'a' and 'b' are shared with the 'Class'; that is, they have the same Unique. - -This is important. In an instance declaration we expect + +This is important. In an instance declaration we expect * all the shared variables to be instantiated the same way * the non-shared variables of the associated type should not be instantiated at all @@ -271,9 +263,9 @@ This is important. In an instance declaration we expect type F [x] q (Tree y) = (x,y,q) %************************************************************************ -%* * +%* * \subsection{The data type} -%* * +%* * %************************************************************************ \begin{code} @@ -292,78 +284,81 @@ This is important. In an instance declaration we expect data TyCon = -- | The function type constructor, @(->)@ FunTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind, + tyConArity :: Arity } -- | Algebraic type constructors, which are defined to be those -- arising @data@ type and @newtype@ declarations. All these -- constructors are lifted and boxed. See 'AlgTyConRhs' for more -- information. - | AlgTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, + | AlgTyCon { + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind, + tyConArity :: Arity, - tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the type constructor. + tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the type constructor. -- Invariant: length tyvars = arity - -- Precisely, this list scopes over: - -- - -- 1. The 'algTcStupidTheta' - -- 2. The cached types in 'algTyConRhs.NewTyCon' - -- 3. The family instance types if present - -- - -- Note that it does /not/ scope over the data constructors. - - algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT syntax? - -- If so, that doesn't mean it's a true GADT; - -- only that the "where" form was used. + -- Precisely, this list scopes over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in 'algTyConRhs.NewTyCon' + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data constructors. + tyConCType :: Maybe CType, -- The C type that should be used + -- for this type when using the FFI + -- and CAPI + + algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT syntax? + -- If so, that doesn't mean it's a true GADT; + -- only that the "where" form was used. -- This field is used only to guide pretty-printing - algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type -- (always empty for GADTs). - -- A \"stupid theta\" is the context to the left - -- of an algebraic type declaration, - -- e.g. @Eq a@ in the declaration + -- A \"stupid theta\" is the context to the left + -- of an algebraic type declaration, + -- e.g. @Eq a@ in the declaration -- @data Eq a => T a ...@. - algTcRhs :: AlgTyConRhs, -- ^ Contains information about the + algTcRhs :: AlgTyConRhs, -- ^ Contains information about the -- data constructors of the algebraic type - algTcRec :: RecFlag, -- ^ Tells us whether the data type is part + algTcRec :: RecFlag, -- ^ Tells us whether the data type is part -- of a mutually-recursive group or not - - algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon' - -- for derived 'TyCon's representing class - -- or family instances, respectively. + + algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon' + -- for derived 'TyCon's representing class + -- or family instances, respectively. -- See also 'synTcParent' } - -- | Represents the infinite family of tuple type constructors, + -- | Represents the infinite family of tuple type constructors, -- @()@, @(a,b)@, @(# a, b #)@ etc. | TupleTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, - tyConTupleSort :: TupleSort, - tyConTyVars :: [TyVar], - dataCon :: DataCon -- ^ Corresponding tuple data constructor + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind, + tyConArity :: Arity, + tyConTupleSort :: TupleSort, + tyConTyVars :: [TyVar], + dataCon :: DataCon -- ^ Corresponding tuple data constructor } -- | Represents type synonyms | SynTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind, + tyConArity :: Arity, - tyConTyVars :: [TyVar], -- Bound tyvars + tyConTyVars :: [TyVar], -- Bound tyvars - synTcRhs :: SynTyConRhs, -- ^ Contains information about the + synTcRhs :: SynTyConRhs, -- ^ Contains information about the -- expansion of the synonym synTcParent :: TyConParent -- ^ Gives the family declaration 'TyCon' @@ -374,53 +369,41 @@ data TyCon -- | Primitive types; cannot be defined in Haskell. This includes -- the usual suspects (such as @Int#@) as well as foreign-imported -- types and kinds - | PrimTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance - -- of the arity of a primtycon is! - - primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are - -- boxed (represented by pointers). This 'PrimRep' - -- holds that information. - -- Only relevant if tc_kind = * - - isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted + | PrimTyCon { + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind, + tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance + -- of the arity of a primtycon is! + + primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are + -- boxed (represented by pointers). This 'PrimRep' + -- holds that information. + -- Only relevant if tc_kind = * + + isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted -- (may not contain bottom) - -- but foreign-imported ones may be lifted + -- but foreign-imported ones may be lifted - tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, + tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, -- holds the name of the imported thing } - -- | Super-kinds. These are "kinds-of-kinds" and are never seen in - -- Haskell source programs. There are only two super-kinds: TY (aka - -- "box"), which is the super-kind of kinds that construct types - -- eventually, and CO (aka "diamond"), which is the super-kind of - -- kinds that just represent coercions. - -- - -- Super-kinds have no kind themselves, and have arity zero - | SuperKindTyCon { - tyConUnique :: Unique, - tyConName :: Name - } - -- | Represents promoted data constructor. - | PromotedDataTyCon { -- See Note [Promoted data constructors] - tyConUnique :: Unique, -- ^ Same Unique as the data constructor - tyConName :: Name, -- ^ Same Name as the data constructor - tyConArity :: Arity, - tc_kind :: Kind, -- ^ Translated type of the data constructor + | PromotedDataCon { -- See Note [Promoted data constructors] + tyConUnique :: Unique, -- ^ Same Unique as the data constructor + tyConName :: Name, -- ^ Same Name as the data constructor + tyConArity :: Arity, + tc_kind :: Kind, -- ^ Translated type of the data constructor dataCon :: DataCon -- ^ Corresponding data constructor } -- | Represents promoted type constructor. - | PromotedTypeTyCon { - tyConUnique :: Unique, -- ^ Same Unique as the type constructor - tyConName :: Name, -- ^ Same Name as the type constructor - tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times - tc_kind :: Kind, -- ^ Always tySuperKind + | PromotedTyCon { + tyConUnique :: Unique, -- ^ Same Unique as the type constructor + tyConName :: Name, -- ^ Same Name as the type constructor + tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times + tc_kind :: Kind, -- ^ Always TysPrim.superKind ty_con :: TyCon -- ^ Corresponding type constructor } @@ -436,14 +419,14 @@ data AlgTyConRhs -- it's represented by a pointer. Used when we export a data type -- abstractly into an .hi file. = AbstractTyCon - Bool -- True <=> It's definitely a distinct data type, - -- equal only to itself; ie not a newtype - -- False <=> Not sure - -- See Note [AbstractTyCon and type equality] + Bool -- True <=> It's definitely a distinct data type, + -- equal only to itself; ie not a newtype + -- False <=> Not sure + -- See Note [AbstractTyCon and type equality] -- | Represents an open type family without a fixed right hand -- side. Additional instances can appear at any time. - -- + -- -- These are introduced by either a top level declaration: -- -- > data T a :: * @@ -458,42 +441,42 @@ data AlgTyConRhs -- declaration. This includes data types with no constructors at -- all. | DataTyCon { - data_cons :: [DataCon], - -- ^ The data type constructors; can be empty if the user - -- declares the type to have no constructors - -- - -- INVARIANT: Kept in order of increasing 'DataCon' tag - -- (see the tag assignment in DataCon.mkDataCon) - - is_enum :: Bool -- ^ Cached value: is this an enumeration type? + data_cons :: [DataCon], + -- ^ The data type constructors; can be empty if the user + -- declares the type to have no constructors + -- + -- INVARIANT: Kept in order of increasing 'DataCon' tag + -- (see the tag assignment in DataCon.mkDataCon) + + is_enum :: Bool -- ^ Cached value: is this an enumeration type? -- See Note [Enumeration types] } -- | Information about those 'TyCon's derived from a @newtype@ declaration | NewTyCon { - data_con :: DataCon, -- ^ The unique constructor for the @newtype@. + data_con :: DataCon, -- ^ The unique constructor for the @newtype@. -- It has no existentials - nt_rhs :: Type, -- ^ Cached value: the argument type of the constructor, - -- which is just the representation type of the 'TyCon' - -- (remember that @newtype@s do not exist at runtime + nt_rhs :: Type, -- ^ Cached value: the argument type of the constructor, + -- which is just the representation type of the 'TyCon' + -- (remember that @newtype@s do not exist at runtime -- so need a different representation type). - -- - -- The free 'TyVar's of this type are the 'tyConTyVars' + -- + -- The free 'TyVar's of this type are the 'tyConTyVars' -- from the corresponding 'TyCon' - nt_etad_rhs :: ([TyVar], Type), - -- ^ Same as the 'nt_rhs', but this time eta-reduced. - -- Hence the list of 'TyVar's in this field may be - -- shorter than the declared arity of the 'TyCon'. - - -- See Note [Newtype eta] - nt_co :: CoAxiom -- The axiom coercion that creates the @newtype@ from + nt_etad_rhs :: ([TyVar], Type), + -- ^ Same as the 'nt_rhs', but this time eta-reduced. + -- Hence the list of 'TyVar's in this field may be + -- shorter than the declared arity of the 'TyCon'. + + -- See Note [Newtype eta] + nt_co :: CoAxiom -- The axiom coercion that creates the @newtype@ from -- the representation 'Type'. - + -- See Note [Newtype coercions] -- Invariant: arity = #tvs in nt_etad_rhs; - -- See Note [Newtype eta] + -- See Note [Newtype eta] -- Watch out! If any newtypes become transparent -- again check Trac #1072. } @@ -509,67 +492,62 @@ TODO -- that visibility in this sense does not correspond to visibility in -- the context of any particular user program! visibleDataCons :: AlgTyConRhs -> [DataCon] -visibleDataCons (AbstractTyCon {}) = [] -visibleDataCons DataFamilyTyCon {} = [] +visibleDataCons (AbstractTyCon {}) = [] +visibleDataCons DataFamilyTyCon {} = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] -- ^ Both type classes as well as family instances imply implicit -- type constructors. These implicit type constructors refer to their parent -- structure (ie, the class or family from which they derive) using a type of --- the following form. We use 'TyConParent' for both algebraic and synonym +-- the following form. We use 'TyConParent' for both algebraic and synonym -- types, but the variant 'ClassTyCon' will only be used by algebraic 'TyCon's. -data TyConParent +data TyConParent = -- | An ordinary type constructor has no parent. NoParentTyCon -- | Type constructors representing a class dictionary. -- See Note [ATyCon for classes] in TypeRep | ClassTyCon - Class -- INVARIANT: the classTyCon of this Class is the current tycon - - -- | Associated type of a implicit parameter. - | IPTyCon - (IPName Name) + Class -- INVARIANT: the classTyCon of this Class is the current tycon - -- | An *associated* type of a class. - | AssocFamilyTyCon - Class -- The class in whose declaration the family is declared - -- See Note [Associated families and their parent class] + -- | An *associated* type of a class. + | AssocFamilyTyCon + Class -- The class in whose declaration the family is declared + -- See Note [Associated families and their parent class] -- | Type constructors representing an instance of a *data* family. Parameters: -- -- 1) The type family in question -- -- 2) Instance types; free variables are the 'tyConTyVars' - -- of the current 'TyCon' (not the family one). INVARIANT: + -- of the current 'TyCon' (not the family one). INVARIANT: -- the number of types matches the arity of the family 'TyCon' -- -- 3) A 'CoTyCon' identifying the representation -- type with the type instance family - | FamInstTyCon -- See Note [Data type families] + | FamInstTyCon -- See Note [Data type families] CoAxiom -- The coercion constructor, -- always of kind T ty1 ty2 ~ R:T a b c - -- where T is the family TyCon, + -- where T is the family TyCon, -- and R:T is the representation TyCon (ie this one) -- and a,b,c are the tyConTyVars of this TyCon -- Cached fields of the CoAxiom, but adjusted to -- use the tyConTyVars of this TyCon - TyCon -- The family TyCon - [Type] -- Argument types (mentions the tyConTyVars of this TyCon) - -- Match in length the tyConTyVars of the family TyCon + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- Match in length the tyConTyVars of the family TyCon - -- E.g. data intance T [a] = ... - -- gives a representation tycon: - -- data R:TList a = ... - -- axiom co a :: T [a] ~ R:TList a - -- with R:TList's algTcParent = FamInstTyCon T [a] co + -- E.g. data intance T [a] = ... + -- gives a representation tycon: + -- data R:TList a = ... + -- axiom co a :: T [a] ~ R:TList a + -- with R:TList's algTcParent = FamInstTyCon T [a] co instance Outputable TyConParent where ppr NoParentTyCon = text "No parent" ppr (ClassTyCon cls) = text "Class parent" <+> ppr cls - ppr (IPTyCon n) = text "IP parent" <+> ppr n ppr (AssocFamilyTyCon cls) = text "Class parent (assoc. family)" <+> ppr cls ppr (FamInstTyCon _ tc tys) = text "Family parent (family instance)" <+> ppr tc <+> sep (map ppr tys) @@ -578,7 +556,6 @@ okParent :: Name -> TyConParent -> Bool okParent _ NoParentTyCon = True okParent tc_name (AssocFamilyTyCon cls) = tc_name `elem` map tyConName (classATs cls) okParent tc_name (ClassTyCon cls) = tc_name == tyConName (classTyCon cls) -okParent tc_name (IPTyCon ip) = tc_name == ipTyConName ip okParent _ (FamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys isNoParent :: TyConParent -> Bool @@ -590,9 +567,9 @@ isNoParent _ = False -- | Information pertaining to the expansion of a type synonym (@type@) data SynTyConRhs = -- | An ordinary type synonyn. - SynonymTyCon - Type -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. - -- It acts as a template for the expansion when the 'TyCon' + SynonymTyCon + Type -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. + -- It acts as a template for the expansion when the 'TyCon' -- is applied to some types. -- | A type synonym family e.g. @type family F x y :: * -> *@ @@ -602,7 +579,7 @@ data SynTyConRhs Note [Promoted data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A data constructor can be promoted to become a type constructor, -via the PromotedDataTyCon alternative in TyCon. +via the PromotedTyCon alternative in TyCon. * Only "vanilla" data constructors are promoted; ones with no GADT stuff, no existentials, etc. We might generalise this later. @@ -614,17 +591,17 @@ via the PromotedDataTyCon alternative in TyCon. * The *kind* of a promoted DataCon may be polymorphic. Example: type of DataCon Just :: forall (a:*). a -> Maybe a kind of (promoted) tycon Just :: forall (a:box). a -> Maybe a - The kind is not identical to the type, because of the */box + The kind is not identical to the type, because of the */box kind signature on the forall'd variable; so the tc_kind field of - PromotedDataTyCon is not identical to the dataConUserType of the + PromotedTyCon is not identical to the dataConUserType of the DataCon. But it's the same modulo changing the variable kinds, - done by Kind.promoteType. + done by Kind.promoteType. * Small note: We promote the *user* type of the DataCon. Eg data T = MkT {-# UNPACK #-} !(Bool, Bool) The promoted kind is MkT :: (Bool,Bool) -> T - *not* + *not* MkT :: Bool -> Bool -> T Note [Enumeration types] @@ -655,7 +632,7 @@ example, newtype T a = MkT (a -> a) -the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. +the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. In the case that the right hand side is a type application ending with the same type variables as the left hand side, we @@ -667,54 +644,54 @@ then we would generate the arity 0 axiom CoS : S ~ []. The primary reason we do this is to make newtype deriving cleaner. In the paper we'd write - axiom CoT : (forall t. T t) ~ (forall t. [t]) + axiom CoT : (forall t. T t) ~ (forall t. [t]) and then when we used CoT at a particular type, s, we'd say - CoT @ s + CoT @ s which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) Note [Newtype eta] ~~~~~~~~~~~~~~~~~~ Consider - newtype Parser m a = MkParser (Foogle m a) + newtype Parser m a = MkParser (Foogle m a) Are these two types equal (to Core)? - Monad (Parser m) - Monad (Foogle m) + Monad (Parser m) + Monad (Foogle m) Well, yes. But to see that easily we eta-reduce the RHS type of Parser, in this case to ([], Froogle), so that even unsaturated applications -of Parser will work right. This eta reduction is done when the type +of Parser will work right. This eta reduction is done when the type constructor is built, and cached in NewTyCon. The cached field is only used in coreExpandTyCon_maybe. - + Here's an example that I think showed up in practice Source code: - newtype T a = MkT [a] - newtype Foo m = MkFoo (forall a. m a -> Int) + newtype T a = MkT [a] + newtype Foo m = MkFoo (forall a. m a -> Int) + + w1 :: Foo [] + w1 = ... - w1 :: Foo [] - w1 = ... - - w2 :: Foo T - w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) + w2 :: Foo T + w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) After desugaring, and discarding the data constructors for the newtypes, we get: - w2 :: Foo T - w2 = w1 + w2 :: Foo T + w2 = w1 And now Lint complains unless Foo T == Foo [], and that requires T==[] This point carries over to the newtype coercion, because we need to -say - w2 = w1 `cast` Foo CoT +say + w2 = w1 `cast` Foo CoT -so the coercion tycon CoT must have - kind: T ~ [] - and arity: 0 +so the coercion tycon CoT must have + kind: T ~ [] + and arity: 0 %************************************************************************ -%* * +%* * Coercion axioms -%* * +%* * %************************************************************************ \begin{code} @@ -723,7 +700,7 @@ data CoAxiom = CoAxiom -- Type equality axiom. { co_ax_unique :: Unique -- unique identifier , co_ax_name :: Name -- name for pretty-printing - , co_ax_tvs :: [TyVar] -- bound type variables + , co_ax_tvs :: [TyVar] -- bound type variables , co_ax_lhs :: Type -- left-hand side of the equality , co_ax_rhs :: Type -- right-hand side of the equality , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" @@ -761,9 +738,9 @@ See also Note [Implicit TyThings] in HscTypes %************************************************************************ -%* * +%* * \subsection{PrimRep} -%* * +%* * %************************************************************************ A PrimRep is somewhat similar to a CgRep (see codeGen/SMRep) and a @@ -787,11 +764,11 @@ and clearly defined purpose: data PrimRep = VoidRep | PtrRep - | IntRep -- ^ Signed, word-sized value - | WordRep -- ^ Unsigned, word-sized value - | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) - | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) - | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use 'PtrRep') + | IntRep -- ^ Signed, word-sized value + | WordRep -- ^ Unsigned, word-sized value + | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) + | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) + | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use 'PtrRep') | FloatRep | DoubleRep deriving( Eq, Show ) @@ -813,9 +790,9 @@ primRepSizeW VoidRep = 0 \end{code} %************************************************************************ -%* * +%* * \subsection{TyCon Construction} -%* * +%* * %************************************************************************ Note: the TyCon constructors all take a Kind as one argument, even though @@ -826,15 +803,15 @@ So we compromise, and move their Kind calculation to the call site. \begin{code} -- | Given the name of the function type constructor and it's kind, create the --- corresponding 'TyCon'. It is reccomended to use 'TypeRep.funTyCon' if you want +-- corresponding 'TyCon'. It is reccomended to use 'TypeRep.funTyCon' if you want -- this functionality mkFunTyCon :: Name -> Kind -> TyCon -mkFunTyCon name kind - = FunTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tc_kind = kind, - tyConArity = 2 +mkFunTyCon name kind + = FunTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tc_kind = kind, + tyConArity = 2 } -- | This is the making of an algebraic 'TyCon'. Notably, you have to @@ -843,86 +820,84 @@ mkFunTyCon name kind -- module) mkAlgTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' - -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'. + -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'. -- Arity is inferred from the length of this list + -> Maybe CType -- ^ The C type this type corresponds to + -- when using the CAPI FFI -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' -> AlgTyConRhs -- ^ Information about dat aconstructors -> TyConParent -> RecFlag -- ^ Is the 'TyCon' recursive? -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> TyCon -mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn - = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tc_kind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - algTcStupidTheta = stupid, - algTcRhs = rhs, - algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, - algTcRec = is_rec, - algTcGadtSyntax = gadt_syn +mkAlgTyCon name kind tyvars cType stupid rhs parent is_rec gadt_syn + = AlgTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tc_kind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + tyConCType = cType, + algTcStupidTheta = stupid, + algTcRhs = rhs, + algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, + algTcRec = is_rec, + algTcGadtSyntax = gadt_syn } -- | Simpler specialization of 'mkAlgTyCon' for classes mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon mkClassTyCon name kind tyvars rhs clas is_rec = - mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False + mkAlgTyCon name kind tyvars Nothing [] rhs (ClassTyCon clas) is_rec False --- | Simpler specialization of 'mkAlgTyCon' for implicit paramaters -mkIParamTyCon :: Name -> Kind -> TyVar -> AlgTyConRhs -> RecFlag -> TyCon -mkIParamTyCon name kind tyvar rhs is_rec = - mkAlgTyCon name kind [tyvar] [] rhs NoParentTyCon is_rec False - -mkTupleTyCon :: Name +mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' -> Arity -- ^ Arity of the tuple -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' - -> DataCon + -> DataCon -> TupleSort -- ^ Whether the tuple is boxed or unboxed -> TyCon mkTupleTyCon name kind arity tyvars con sort = TupleTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tc_kind = kind, - tyConArity = arity, - tyConTupleSort = sort, - tyConTyVars = tyvars, - dataCon = con + tyConUnique = nameUnique name, + tyConName = name, + tc_kind = kind, + tyConArity = arity, + tyConTupleSort = sort, + tyConTyVars = tyvars, + dataCon = con } -- ^ Foreign-imported (.NET) type constructors are represented -- as primitive, but /lifted/, 'TyCons' for now. They are lifted -- because the Haskell type @T@ representing the (foreign) .NET -- type @T@ is actually implemented (in ILX) as a @thunk<T>@ -mkForeignTyCon :: Name +mkForeignTyCon :: Name -> Maybe FastString -- ^ Name of the foreign imported thing, maybe - -> Kind - -> Arity + -> Kind + -> Arity -> TyCon mkForeignTyCon name ext_name kind arity = PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tc_kind = kind, - tyConArity = arity, - primTyConRep = PtrRep, -- they all do - isUnLifted = False, - tyConExtName = ext_name + tyConName = name, + tyConUnique = nameUnique name, + tc_kind = kind, + tyConArity = arity, + primTyConRep = PtrRep, -- they all do + isUnLifted = False, + tyConExtName = ext_name } -- | Create an unlifted primitive 'TyCon', such as @Int#@ mkPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon mkPrimTyCon name kind arity rep - = mkPrimTyCon' name kind arity rep True + = mkPrimTyCon' name kind arity rep True -- | Kind constructors mkKindTyCon :: Name -> Kind -> TyCon mkKindTyCon name kind - = mkPrimTyCon' name kind 0 VoidRep True + = mkPrimTyCon' name kind 0 VoidRep True -- | Create a lifted primitive 'TyCon' such as @RealWorld@ mkLiftedPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon @@ -932,42 +907,35 @@ mkLiftedPrimTyCon name kind arity rep mkPrimTyCon' :: Name -> Kind -> Arity -> PrimRep -> Bool -> TyCon mkPrimTyCon' name kind arity rep is_unlifted = PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tc_kind = kind, - tyConArity = arity, - primTyConRep = rep, - isUnLifted = is_unlifted, - tyConExtName = Nothing + tyConName = name, + tyConUnique = nameUnique name, + tc_kind = kind, + tyConArity = arity, + primTyConRep = rep, + isUnLifted = is_unlifted, + tyConExtName = Nothing } -- | Create a type synonym 'TyCon' mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs -> TyConParent -> TyCon mkSynTyCon name kind tyvars rhs parent - = SynTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tc_kind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - synTcRhs = rhs, + = SynTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tc_kind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + synTcRhs = rhs, synTcParent = parent } --- | Create a super-kind 'TyCon' -mkSuperKindTyCon :: Name -> TyCon -- Super kinds always have arity zero -mkSuperKindTyCon name - = SuperKindTyCon { - tyConName = name, - tyConUnique = nameUnique name - } - -- | Create a promoted data constructor 'TyCon' --- Somewhat dodgily, we give it the same Name --- as the data constructor itself -mkPromotedDataTyCon :: DataCon -> Name -> Unique -> Kind -> Arity -> TyCon -mkPromotedDataTyCon con name unique kind arity - = PromotedDataTyCon { +-- Somewhat dodgily, we give it the same Name +-- as the data constructor itself; when we pretty-print +-- the TyCon we add a quote; see the Outputable TyCon instance +mkPromotedDataCon :: DataCon -> Name -> Unique -> Kind -> Arity -> TyCon +mkPromotedDataCon con name unique kind arity + = PromotedDataCon { tyConName = name, tyConUnique = unique, tyConArity = arity, @@ -976,11 +944,11 @@ mkPromotedDataTyCon con name unique kind arity } -- | Create a promoted type constructor 'TyCon' --- Somewhat dodgily, we give it the same Name +-- Somewhat dodgily, we give it the same Name -- as the type constructor itself mkPromotedTyCon :: TyCon -> Kind -> TyCon mkPromotedTyCon tc kind - = PromotedTypeTyCon { + = PromotedTyCon { tyConName = getName tc, tyConUnique = getUnique tc, tyConArity = tyConArity tc, @@ -1001,7 +969,7 @@ isAbstractTyCon _ = False -- | Make an algebraic 'TyCon' abstract. Panics if the supplied 'TyCon' is not algebraic makeTyConAbstract :: TyCon -> TyCon -makeTyConAbstract tc@(AlgTyCon { algTcRhs = rhs }) +makeTyConAbstract tc@(AlgTyCon { algTcRhs = rhs }) = tc { algTcRhs = AbstractTyCon (isDistinctAlgRhs rhs) } makeTyConAbstract tc = pprPanic "makeTyConAbstract" (ppr tc) @@ -1015,7 +983,7 @@ isPrimTyCon _ = False isUnLiftedTyCon :: TyCon -> Bool isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted}) = is_unlifted isUnLiftedTyCon (TupleTyCon {tyConTupleSort = sort}) = not (isBoxed (tupleSortBoxity sort)) -isUnLiftedTyCon _ = False +isUnLiftedTyCon _ = False -- | Returns @True@ if the supplied 'TyCon' resulted from either a -- @data@ or @newtype@ declaration @@ -1025,30 +993,30 @@ isAlgTyCon (TupleTyCon {}) = True isAlgTyCon _ = False isDataTyCon :: TyCon -> Bool --- ^ Returns @True@ for data types that are /definitely/ represented by --- heap-allocated constructors. These are scrutinised by Core-level +-- ^ Returns @True@ for data types that are /definitely/ represented by +-- heap-allocated constructors. These are scrutinised by Core-level -- @case@ expressions, and they get info tables allocated for them. --- +-- -- Generally, the function will be true for all @data@ types and false -- for @newtype@s, unboxed tuples and type family 'TyCon's. But it is -- not guaranteed to return @True@ in all cases that it could. --- +-- -- NB: for a data type family, only the /instance/ 'TyCon's -- get an info table. The family declaration 'TyCon' does not isDataTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of + DataTyCon {} -> True + NewTyCon {} -> False DataFamilyTyCon {} -> False - DataTyCon {} -> True - NewTyCon {} -> False - AbstractTyCon {} -> False -- We don't know, so return False + AbstractTyCon {} -> False -- We don't know, so return False isDataTyCon (TupleTyCon {tyConTupleSort = sort}) = isBoxed (tupleSortBoxity sort) isDataTyCon _ = False --- | 'isDistinctTyCon' is true of 'TyCon's that are equal only to +-- | 'isDistinctTyCon' is true of 'TyCon's that are equal only to -- themselves, even via coercions (except for unsafeCoerce). -- This excludes newtypes, type functions, type synonyms. --- It relates directly to the FC consistency story: --- If the axioms are consistent, +-- It relates directly to the FC consistency story: +-- If the axioms are consistent, -- and co : S tys ~ T tys, and S,T are "distinct" TyCons, -- then S=T. -- Cf Note [Pruning dead case alternatives] in Unify @@ -1057,11 +1025,11 @@ isDistinctTyCon (AlgTyCon {algTcRhs = rhs}) = isDistinctAlgRhs rhs isDistinctTyCon (FunTyCon {}) = True isDistinctTyCon (TupleTyCon {}) = True isDistinctTyCon (PrimTyCon {}) = True -isDistinctTyCon (PromotedDataTyCon {}) = True +isDistinctTyCon (PromotedDataCon {}) = True isDistinctTyCon _ = False isDistinctAlgRhs :: AlgTyConRhs -> Bool -isDistinctAlgRhs (DataTyCon {}) = True +isDistinctAlgRhs (DataTyCon {}) = True isDistinctAlgRhs (DataFamilyTyCon {}) = True isDistinctAlgRhs (AbstractTyCon distinct) = distinct isDistinctAlgRhs (NewTyCon {}) = False @@ -1075,33 +1043,33 @@ isNewTyCon _ = False -- into, and (possibly) a coercion from the representation type to the @newtype@. -- Returns @Nothing@ if this is not possible. unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom) -unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, - algTcRhs = NewTyCon { nt_co = co, - nt_rhs = rhs }}) - = Just (tvs, rhs, co) +unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, + algTcRhs = NewTyCon { nt_co = co, + nt_rhs = rhs }}) + = Just (tvs, rhs, co) unwrapNewTyCon_maybe _ = Nothing isProductTyCon :: TyCon -> Bool -- | A /product/ 'TyCon' must both: -- -- 1. Have /one/ constructor --- +-- -- 2. /Not/ be existential --- --- However other than this there are few restrictions: they may be @data@ or @newtype@ +-- +-- However other than this there are few restrictions: they may be @data@ or @newtype@ -- 'TyCon's of any boxity and may even be recursive. isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of - DataTyCon{ data_cons = [data_con] } - -> isVanillaDataCon data_con - NewTyCon {} -> True - _ -> False -isProductTyCon (TupleTyCon {}) = True + DataTyCon{ data_cons = [data_con] } + -> isVanillaDataCon data_con + NewTyCon {} -> True + _ -> False +isProductTyCon (TupleTyCon {}) = True isProductTyCon _ = False -- | Is this a 'TyCon' representing a type synonym (@type@)? isSynTyCon :: TyCon -> Bool isSynTyCon (SynTyCon {}) = True -isSynTyCon _ = False +isSynTyCon _ = False -- As for newtypes, it is in some contexts important to distinguish between -- closed synonyms and synonym families, as synonym families have no unique @@ -1130,7 +1098,7 @@ isEnumerationTyCon _ = False isFamilyTyCon :: TyCon -> Bool isFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon {}}) = True isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True -isFamilyTyCon _ = False +isFamilyTyCon _ = False -- | Is this a synonym 'TyCon' that can have may have further instances appear? isSynFamilyTyCon :: TyCon -> Bool @@ -1150,12 +1118,12 @@ isClosedSynTyCon tycon = isSynTyCon tycon && not (isFamilyTyCon tycon) -- T ty1 ~ T ty2 => ty1 ~ ty2 isInjectiveTyCon :: TyCon -> Bool isInjectiveTyCon tc = not (isSynTyCon tc) - -- Ultimately we may have injective associated types + -- Ultimately we may have injective associated types -- in which case this test will become more interesting - -- + -- -- It'd be unusual to call isInjectiveTyCon on a regular H98 - -- type synonym, because you should probably have expanded it first - -- But regardless, it's not injective! + -- type synonym, because you should probably have expanded it first + -- But regardless, it's not injective! -- | Are we able to extract informationa 'TyVar' to class argument list -- mappping from a given 'TyCon'? @@ -1215,20 +1183,25 @@ isForeignTyCon :: TyCon -> Bool isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True isForeignTyCon _ = False --- | Is this a super-kind 'TyCon'? -isSuperKindTyCon :: TyCon -> Bool -isSuperKindTyCon (SuperKindTyCon {}) = True -isSuperKindTyCon _ = False +-- | Is this a PromotedDataCon? +isPromotedDataCon :: TyCon -> Bool +isPromotedDataCon (PromotedDataCon {}) = True +isPromotedDataCon _ = False --- | Is this a PromotedDataTyCon? -isPromotedDataTyCon :: TyCon -> Bool -isPromotedDataTyCon (PromotedDataTyCon {}) = True -isPromotedDataTyCon _ = False +-- | Is this a PromotedTyCon? +isPromotedTyCon :: TyCon -> Bool +isPromotedTyCon (PromotedTyCon {}) = True +isPromotedTyCon _ = False + +-- | Retrieves the promoted DataCon if this is a PromotedDataTyCon; +-- Panics otherwise +promotedDataCon :: TyCon -> DataCon +promotedDataCon = dataCon --- | Is this a PromotedTypeTyCon? -isPromotedTypeTyCon :: TyCon -> Bool -isPromotedTypeTyCon (PromotedTypeTyCon {}) = True -isPromotedTypeTyCon _ = False +-- | Retrieves the promoted TypeCon if this is a PromotedTypeTyCon; +-- Panics otherwise +promotedTyCon :: TyCon -> TyCon +promotedTyCon = ty_con -- | Identifies implicit tycons that, in particular, do not go into interface -- files (because they are implicitly reconstructed when the interface is @@ -1237,58 +1210,62 @@ isPromotedTypeTyCon _ = False -- Note that: -- -- * Associated families are implicit, as they are re-constructed from --- the class declaration in which they reside, and +-- the class declaration in which they reside, and -- -- * Family instances are /not/ implicit as they represent the instance body -- (similar to a @dfun@ does that for a class instance). isImplicitTyCon :: TyCon -> Bool -isImplicitTyCon tycon +isImplicitTyCon tycon | isTyConAssoc tycon = True | isSynTyCon tycon = False | isAlgTyCon tycon = isTupleTyCon tycon | otherwise = True - -- 'otherwise' catches: FunTyCon, PrimTyCon, - -- PromotedDataCon, PomotedTypeTyCon, SuperKindTyCon + -- 'otherwise' catches: FunTyCon, PrimTyCon, + -- PromotedDataCon, PomotedTypeTyCon + +tyConCType_maybe :: TyCon -> Maybe CType +tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc +tyConCType_maybe _ = Nothing \end{code} ----------------------------------------------- --- Expand type-constructor applications +-- Expand type-constructor applications ----------------------------------------------- \begin{code} -tcExpandTyCon_maybe, coreExpandTyCon_maybe - :: TyCon - -> [tyco] -- ^ Arguments to 'TyCon' - -> Maybe ([(TyVar,tyco)], - Type, - [tyco]) -- ^ Returns a 'TyVar' substitution, the body type +tcExpandTyCon_maybe, coreExpandTyCon_maybe + :: TyCon + -> [tyco] -- ^ Arguments to 'TyCon' + -> Maybe ([(TyVar,tyco)], + Type, + [tyco]) -- ^ Returns a 'TyVar' substitution, the body type -- of the synonym (not yet substituted) and any arguments -- remaining from the application --- ^ Used to create the view the /typechecker/ has on 'TyCon's. +-- ^ Used to create the view the /typechecker/ has on 'TyCon's. -- We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe' -tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, - synTcRhs = SynonymTyCon rhs }) tys +tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, + synTcRhs = SynonymTyCon rhs }) tys = expand tvs rhs tys tcExpandTyCon_maybe _ _ = Nothing --------------- --- ^ Used to create the view /Core/ has on 'TyCon's. We expand +-- ^ Used to create the view /Core/ has on 'TyCon's. We expand -- not only closed synonyms like 'tcExpandTyCon_maybe', -- but also non-recursive @newtype@s coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys ---------------- -expand :: [TyVar] -> Type -- Template - -> [a] -- Args - -> Maybe ([(TyVar,a)], Type, [a]) -- Expansion +expand :: [TyVar] -> Type -- Template + -> [a] -- Args + -> Maybe ([(TyVar,a)], Type, [a]) -- Expansion expand tvs rhs tys = case n_tvs `compare` length tys of - LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys) - EQ -> Just (tvs `zip` tys, rhs, []) + LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys) + EQ -> Just (tvs `zip` tys, rhs, []) GT -> Nothing where n_tvs = length tvs @@ -1296,12 +1273,7 @@ expand tvs rhs tys \begin{code} tyConKind :: TyCon -> Kind -tyConKind (SuperKindTyCon {}) = pprPanic "tyConKind" empty -tyConKind tc = tc_kind tc - -tyConHasKind :: TyCon -> Bool -tyConHasKind (SuperKindTyCon {}) = False -tyConHasKind _ = True +tyConKind = tc_kind -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors -- could be found @@ -1315,17 +1287,17 @@ tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] tyConDataCons_maybe :: TyCon -> Maybe [DataCon] tyConDataCons_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = cons }}) = Just cons tyConDataCons_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just [con] -tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] +tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] tyConDataCons_maybe _ = Nothing -- | Determine the number of value constructors a 'TyCon' has. Panics if the 'TyCon' -- is not algebraic or a tuple tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon {data_cons = cons}}) = +tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon {data_cons = cons}}) = length cons tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1 tyConFamilySize (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = 0 -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (TupleTyCon {}) = 1 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) -- | Extract an 'AlgTyConRhs' with information about data constructors from an algebraic or tuple @@ -1355,11 +1327,11 @@ newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) -- is not a @newtype@, returns @Nothing@ newTyConCo_maybe :: TyCon -> Maybe CoAxiom newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co -newTyConCo_maybe _ = Nothing +newTyConCo_maybe _ = Nothing newTyConCo :: TyCon -> CoAxiom newTyConCo tc = case newTyConCo_maybe tc of - Just co -> co + Just co -> co Nothing -> pprPanic "newTyConCo" (ppr tc) -- | Find the primitive representation of a 'TyCon' @@ -1373,7 +1345,7 @@ tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep -- an algebraic type declaration, e.g. @Eq a@ in the declaration @data Eq a => T a ...@ tyConStupidTheta :: TyCon -> [PredType] tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid -tyConStupidTheta (TupleTyCon {}) = [] +tyConStupidTheta (TupleTyCon {}) = [] tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \end{code} @@ -1381,7 +1353,7 @@ tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) -- | Extract the 'TyVar's bound by a type synonym and the corresponding (unsubstituted) right hand side. -- If the given 'TyCon' is not a type synonym, panics synTyConDefn :: TyCon -> ([TyVar], Type) -synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) +synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) = (tyvars, ty) synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) @@ -1389,15 +1361,15 @@ synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) -- if the given 'TyCon' is not a type synonym synTyConRhs :: TyCon -> SynTyConRhs synTyConRhs (SynTyCon {synTcRhs = rhs}) = rhs -synTyConRhs tc = pprPanic "synTyConRhs" (ppr tc) +synTyConRhs tc = pprPanic "synTyConRhs" (ppr tc) -- | Find the expansion of the type synonym represented by the given 'TyCon'. The free variables of this -- type will typically include those 'TyVar's bound by the 'TyCon'. Panics if the 'TyCon' is not that of -- a type synonym synTyConType :: TyCon -> Type synTyConType tc = case synTcRhs tc of - SynonymTyCon t -> t - _ -> pprPanic "synTyConType" (ppr tc) + SynonymTyCon t -> t + _ -> pprPanic "synTyConType" (ppr tc) \end{code} \begin{code} @@ -1406,10 +1378,10 @@ synTyConType tc = case synTcRhs tc of -- has more than one constructor, or represents a primitive or function type constructor then -- @Nothing@ is returned. In any other case, the function panics tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon -tyConSingleDataCon_maybe (TupleTyCon {dataCon = c}) = Just c +tyConSingleDataCon_maybe (TupleTyCon {dataCon = c}) = Just c tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = [c] }}) = Just c tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = c }}) = Just c -tyConSingleDataCon_maybe _ = Nothing +tyConSingleDataCon_maybe _ = Nothing \end{code} \begin{code} @@ -1428,12 +1400,6 @@ tyConTuple_maybe :: TyCon -> Maybe TupleSort tyConTuple_maybe (TupleTyCon {tyConTupleSort = sort}) = Just sort tyConTuple_maybe _ = Nothing --- | If this 'TyCon' is that for implicit parameter, return the IP it is for. --- Otherwise returns @Nothing@ -tyConIP_maybe :: TyCon -> Maybe (IPName Name) -tyConIP_maybe (AlgTyCon {algTcParent = IPTyCon ip}) = Just ip -tyConIP_maybe _ = Nothing - ---------------------------------------------------------------------------- tyConParent :: TyCon -> TyConParent tyConParent (AlgTyCon {algTcParent = parent}) = parent @@ -1462,7 +1428,7 @@ tyConFamInst_maybe tc FamInstTyCon _ f ts -> Just (f, ts) _ -> Nothing --- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents +-- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents -- a coercion identifying the representation type with the type instance family. -- Otherwise, return @Nothing@ tyConFamilyCoercion_maybe :: TyCon -> Maybe CoAxiom @@ -1474,9 +1440,9 @@ tyConFamilyCoercion_maybe tc %************************************************************************ -%* * +%* * \subsection[TyCon-instances]{Instance declarations for @TyCon@} -%* * +%* * %************************************************************************ @TyCon@s are compared by comparing their @Unique@s. @@ -1491,16 +1457,25 @@ instance Eq TyCon where instance Ord TyCon where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } compare a b = getUnique a `compare` getUnique b instance Uniquable TyCon where getUnique tc = tyConUnique tc instance Outputable TyCon where - ppr tc = ppr (tyConName tc) + -- At the moment a promoted TyCon has the same Name as its + -- corresponding TyCon, so we add the quote to distinguish it here + ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) + +pprPromotionQuote :: TyCon -> SDoc +pprPromotionQuote (PromotedDataCon {}) = char '\'' -- Quote promoted DataCons in types +pprPromotionQuote (PromotedTyCon {}) = ifPprDebug (char '\'') +pprPromotionQuote _ = empty -- However, we don't quote TyCons in kinds + -- e.g. type family T a :: Bool -> * + -- cf Trac #5952. Except with -dppr-debug instance NamedThing TyCon where getName = tyConName @@ -1515,13 +1490,13 @@ instance Data.Data TyCon where instance Eq CoAxiom where a == b = case (a `compare` b) of { EQ -> True; _ -> False } a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - + instance Ord CoAxiom where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = getUnique a `compare` getUnique b + compare a b = getUnique a `compare` getUnique b instance Uniquable CoAxiom where getUnique = co_ax_unique diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index a344fd151b..1099303e48 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -27,7 +27,7 @@ module Type ( -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, - mkAppTy, mkAppTys, splitAppTy, splitAppTys, + mkAppTy, mkAppTys, mkNakedAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, repSplitAppTy_maybe, mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, @@ -41,6 +41,9 @@ module Type ( mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, mkPiKinds, mkPiType, mkPiTypes, applyTy, applyTys, applyTysD, isForAllTy, dropForAlls, + + mkNumLitTy, isNumLitTy, + mkStrLitTy, isStrLitTy, -- (Newtypes) newTyConInstRhs, carefullySplitNewType_maybe, @@ -48,21 +51,20 @@ module Type ( -- Pred types mkFamilyTyConApp, isDictLikeTy, - mkEqPred, mkClassPred, - mkIPPred, - noParenPred, isClassPred, isEqPred, isIPPred, - mkPrimEqType, - + mkEqPred, mkPrimEqPred, + mkClassPred, + noParenPred, isClassPred, isEqPred, isIPPred, isIPPred_maybe, + -- Deconstructing predicate types PredTree(..), predTreePredType, classifyPredType, getClassPredTys, getClassPredTys_maybe, getEqPredTys, getEqPredTys_maybe, - getIPPredTy_maybe, -- ** Common type constructors funTyCon, -- ** Predicates on types + isTypeVar, isKindVar, isTyVarTy, isFunTy, isDictTy, isPredTy, isKindTy, -- (Lifting and boxity) @@ -78,18 +80,16 @@ module Type ( -- ** Common Kinds and SuperKinds anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, constraintKind, - tySuperKind, + constraintKind, superKind, -- ** Common Kind type constructors liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, - anyKindTyCon, + constraintKindTyCon, anyKindTyCon, -- * Type free variables tyVarsOfType, tyVarsOfTypes, expandTypeSynonyms, - typeSize, varSetElemsKvsFirst, sortQuantVars, + typeSize, varSetElemsKvsFirst, -- * Type comparison eqType, eqTypeX, eqTypes, cmpType, cmpTypes, @@ -101,12 +101,10 @@ module Type ( -- * Other views onto Types coreView, tcView, - repType, deepRepType, + UnaryType, RepType(..), flattenRepType, repType, -- * Type representation for the code generator - PrimRep(..), - - typePrimRep, + typePrimRep, typeRepArity, -- * Main type substitution data types TvSubstEnv, -- Representation widely visible @@ -130,7 +128,8 @@ module Type ( substKiWith, substKisWith, -- * Pretty-printing - pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, + pprTvBndr, pprTvBndrs, pprForAll, pprSigmaType, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprSourceTyCon, ) where @@ -152,21 +151,21 @@ import Class import TyCon import TysPrim import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy ) -import PrelNames ( eqTyConKey ) +import PrelNames ( eqTyConKey, ipClassName ) -- others -import {-# SOURCE #-} IParam ( ipTyCon ) import Unique ( Unique, hasKey ) -import BasicTypes ( IPName(..) ) -import Name ( Name ) +import BasicTypes ( Arity, RepArity ) import NameSet import StaticFlags import Util import Outputable import FastString +import Data.List ( partition ) import Maybes ( orElse ) import Data.Maybe ( isJust ) +import Control.Monad ( guard ) infixr 3 `mkFunTy` -- Associates to the right \end{code} @@ -277,8 +276,9 @@ expandTypeSynonyms ty = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') | otherwise = TyConApp tc (map go tys) + go (LitTy l) = LitTy l go (TyVarTy tv) = TyVarTy tv - go (AppTy t1 t2) = AppTy (go t1) (go t2) + go (AppTy t1 t2) = mkAppTy (go t1) (go t2) go (FunTy t1 t2) = FunTy (go t1) (go t2) go (ForAllTy tv t) = ForAllTy tv (go t) \end{code} @@ -324,11 +324,8 @@ invariant: use it. \begin{code} -- | Applies a type to another, as in e.g. @k a@ mkAppTy :: Type -> Type -> Type -mkAppTy orig_ty1 orig_ty2 - = mk_app orig_ty1 - where - mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) - mk_app _ = AppTy orig_ty1 orig_ty2 +mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) +mkAppTy ty1 ty2 = AppTy ty1 ty2 -- Note that the TyConApp could be an -- under-saturated type synonym. GHC allows that; e.g. -- type Foo k = k a -> k a @@ -339,18 +336,14 @@ mkAppTy orig_ty1 orig_ty2 -- but once the type synonyms are expanded all is well mkAppTys :: Type -> [Type] -> Type -mkAppTys orig_ty1 [] = orig_ty1 - -- This check for an empty list of type arguments - -- avoids the needless loss of a type synonym constructor. - -- For example: mkAppTys Rational [] - -- returns to (Ratio Integer), which has needlessly lost - -- the Rational part. -mkAppTys orig_ty1 orig_tys2 - = mk_app orig_ty1 - where - mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) - -- mkTyConApp: see notes with mkAppTy - mk_app _ = foldl AppTy orig_ty1 orig_tys2 +mkAppTys ty1 [] = ty1 +mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) +mkAppTys ty1 tys2 = foldl AppTy ty1 tys2 + +mkNakedAppTys :: Type -> [Type] -> Type +mkNakedAppTys ty1 [] = ty1 +mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2) +mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2 ------------- splitAppTy_maybe :: Type -> Maybe (Type, Type) @@ -403,6 +396,27 @@ splitAppTys ty = split ty ty [] \end{code} + LitTy + ~~~~~ + +\begin{code} +mkNumLitTy :: Integer -> Type +mkNumLitTy n = LitTy (NumTyLit n) + +isNumLitTy :: Type -> Maybe Integer +isNumLitTy (LitTy (NumTyLit n)) = Just n +isNumLitTy _ = Nothing + +mkStrLitTy :: FastString -> Type +mkStrLitTy s = LitTy (StrTyLit s) + +isStrLitTy :: Type -> Maybe FastString +isStrLitTy (LitTy (StrTyLit s)) = Just s +isStrLitTy _ = Nothing + +\end{code} + + --------------------------------------------------------------------- FunTy ~~~~~ @@ -478,6 +492,16 @@ funArgTy ty = pprPanic "funArgTy" (ppr ty) ~~~~~~~~ \begin{code} +-- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon, [ty1,ty2] <- tys + = FunTy ty1 ty2 + + | otherwise + = TyConApp tycon tys + -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. @@ -585,7 +609,27 @@ newtype at outermost level; and bale out if we see it again. Representation types ~~~~~~~~~~~~~~~~~~~~ +Note [Nullary unboxed tuple] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We represent the nullary unboxed tuple as the unary (but void) type State# RealWorld. +The reason for this is that the ReprArity is never less than the Arity (as it would +otherwise be for a function type like (# #) -> Int). + +As a result, ReprArity is always strictly positive if Arity is. This is important +because it allows us to distinguish at runtime between a thunk and a function + takes a nullary unboxed tuple as an argument! + \begin{code} +type UnaryType = Type + +data RepType = UbxTupleRep [UnaryType] -- INVARIANT: never an empty list (see Note [Nullary unboxed tuple]) + | UnaryRep UnaryType + +flattenRepType :: RepType -> [UnaryType] +flattenRepType (UbxTupleRep tys) = tys +flattenRepType (UnaryRep ty) = [ty] + -- | Looks through: -- -- 1. For-alls @@ -594,29 +638,11 @@ newtype at outermost level; and bale out if we see it again. -- 4. All newtypes, including recursive ones, but not newtype families -- -- It's useful in the back end of the compiler. -repType :: Type -> Type +repType :: Type -> RepType repType ty = go emptyNameSet ty where - go :: NameSet -> Type -> Type - go rec_nts ty -- Expand predicates and synonyms - | Just ty' <- coreView ty - = go rec_nts ty' - - go rec_nts (ForAllTy _ ty) -- Drop foralls - = go rec_nts ty - - go rec_nts (TyConApp tc tys) -- Expand newtypes - | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys - = go rec_nts' ty' - - go _ ty = ty - -deepRepType :: Type -> Type --- Same as repType, but looks recursively -deepRepType ty - = go emptyNameSet ty - where + go :: NameSet -> Type -> RepType go rec_nts ty -- Expand predicates and synonyms | Just ty' <- coreView ty = go rec_nts ty' @@ -628,12 +654,12 @@ deepRepType ty | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys = go rec_nts' ty' - -- Apply recursively; this is the "deep" bit - go rec_nts (TyConApp tc tys) = TyConApp tc (map (go rec_nts) tys) - go rec_nts (AppTy ty1 ty2) = mkAppTy (go rec_nts ty1) (go rec_nts ty2) - go rec_nts (FunTy ty1 ty2) = FunTy (go rec_nts ty1) (go rec_nts ty2) + | isUnboxedTupleTyCon tc + = if null tys + then UnaryRep realWorldStatePrimTy -- See Note [Nullary unboxed tuple] + else UbxTupleRep (concatMap (flattenRepType . go rec_nts) tys) - go _ ty = ty + go _ ty = UnaryRep ty carefullySplitNewType_maybe :: NameSet -> TyCon -> [Type] -> Maybe (NameSet,Type) -- Return the representation of a newtype, unless @@ -653,15 +679,23 @@ carefullySplitNewType_maybe rec_nts tc tys -- ToDo: this could be moved to the code generator, using splitTyConApp instead -- of inspecting the type directly. --- | Discovers the primitive representation of a more abstract 'Type' --- Only applied to types of values -typePrimRep :: Type -> PrimRep -typePrimRep ty = case repType ty of - TyConApp tc _ -> tyConPrimRep tc - FunTy _ _ -> PtrRep - AppTy _ _ -> PtrRep -- See Note [AppTy rep] - TyVarTy _ -> PtrRep - _ -> pprPanic "typePrimRep" (ppr ty) +-- | Discovers the primitive representation of a more abstract 'UnaryType' +typePrimRep :: UnaryType -> PrimRep +typePrimRep ty + = case repType ty of + UbxTupleRep _ -> pprPanic "typePrimRep: UbxTupleRep" (ppr ty) + UnaryRep rep -> case rep of + TyConApp tc _ -> tyConPrimRep tc + FunTy _ _ -> PtrRep + AppTy _ _ -> PtrRep -- See Note [AppTy rep] + TyVarTy _ -> PtrRep + _ -> pprPanic "typePrimRep: UnaryRep" (ppr ty) + +typeRepArity :: Arity -> Type -> RepArity +typeRepArity 0 _ = 0 +typeRepArity n ty = case repType ty of + UnaryRep (FunTy ty1 ty2) -> length (flattenRepType (repType ty1)) + typeRepArity (n - 1) ty2 + _ -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty)) \end{code} Note [AppTy rep] @@ -689,8 +723,8 @@ mkPiKinds :: [TyVar] -> Kind -> Kind -- returns forall k1 k2. (k1 -> *) -> k2 mkPiKinds [] res = res mkPiKinds (tv:tvs) res - | isKiVar tv = ForAllTy tv (mkPiKinds tvs res) - | otherwise = FunTy (tyVarKind tv) (mkPiKinds tvs res) + | isKindVar tv = ForAllTy tv (mkPiKinds tvs res) + | otherwise = FunTy (tyVarKind tv) (mkPiKinds tvs res) mkPiType :: Var -> Type -> Type -- ^ Makes a @(->)@ type or a forall type, depending @@ -803,7 +837,7 @@ noParenPred :: PredType -> Bool -- C a => a -> a -- a~b => a -> b -- But (?x::Int) => Int -> Int -noParenPred p = isClassPred p || isEqPred p +noParenPred p = not (isIPPred p) && isClassPred p || isEqPred p isPredTy :: Type -> Bool isPredTy ty @@ -820,9 +854,17 @@ isClassPred ty = case tyConAppTyCon_maybe ty of isEqPred ty = case tyConAppTyCon_maybe ty of Just tyCon -> tyCon `hasKey` eqTyConKey _ -> False + isIPPred ty = case tyConAppTyCon_maybe ty of - Just tyCon | Just _ <- tyConIP_maybe tyCon -> True - _ -> False + Just tyCon -> tyConName tyCon == ipClassName + _ -> False + +isIPPred_maybe :: Type -> Maybe (FastString, Type) +isIPPred_maybe ty = + do (tc,[t1,t2]) <- splitTyConApp_maybe ty + guard (tyConName tc == ipClassName) + x <- isStrLitTy t1 + return (x,t2) \end{code} Make PredTypes @@ -830,28 +872,19 @@ Make PredTypes --------------------- Equality types --------------------------------- \begin{code} -- | Creates a type equality predicate -mkEqPred :: (Type, Type) -> PredType -mkEqPred (ty1, ty2) - -- IA0_TODO: The caller should give the kind. - = WARN ( not (k `eqKind` defaultKind k), ppr (k, ty1, ty2) ) +mkEqPred :: Type -> Type -> PredType +mkEqPred ty1 ty2 + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) TyConApp eqTyCon [k, ty1, ty2] - where k = defaultKind (typeKind ty1) --- where k = typeKind ty1 + where + k = typeKind ty1 -mkPrimEqType :: (Type, Type) -> Type -mkPrimEqType (ty1, ty2) - -- IA0_TODO: The caller should give the kind. - = WARN ( not (k `eqKind` defaultKind k), ppr (k, ty1, ty2) ) +mkPrimEqPred :: Type -> Type -> Type +mkPrimEqPred ty1 ty2 + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) TyConApp eqPrimTyCon [k, ty1, ty2] - where k = defaultKind (typeKind ty1) --- where k = typeKind ty1 -\end{code} - ---------------------- Implicit parameters --------------------------------- - -\begin{code} -mkIPPred :: IPName Name -> Type -> PredType -mkIPPred ip ty = TyConApp (ipTyCon ip) [ty] + where + k = typeKind ty1 \end{code} --------------------- Dictionary types --------------------------------- @@ -906,14 +939,12 @@ Decomposing PredType \begin{code} data PredTree = ClassPred Class [Type] | EqPred Type Type - | IPPred (IPName Name) Type | TuplePred [PredType] | IrredPred PredType predTreePredType :: PredTree -> PredType predTreePredType (ClassPred clas tys) = mkClassPred clas tys -predTreePredType (EqPred ty1 ty2) = mkEqPred (ty1, ty2) -predTreePredType (IPPred ip ty) = mkIPPred ip ty +predTreePredType (EqPred ty1 ty2) = mkEqPred ty1 ty2 predTreePredType (TuplePred tys) = mkBoxedTupleTy tys predTreePredType (IrredPred ty) = ty @@ -924,9 +955,6 @@ classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of Just (tc, tys) | tc `hasKey` eqTyConKey , let [_, ty1, ty2] = tys -> EqPred ty1 ty2 - Just (tc, tys) | Just ip <- tyConIP_maybe tc - , let [ty] = tys - -> IPPred ip ty Just (tc, tys) | isTupleTyCon tc -> TuplePred tys _ -> IrredPred ev_ty @@ -944,19 +972,17 @@ getClassPredTys_maybe ty = case splitTyConApp_maybe ty of _ -> Nothing getEqPredTys :: PredType -> (Type, Type) -getEqPredTys ty = case getEqPredTys_maybe ty of - Just (ty1, ty2) -> (ty1, ty2) - Nothing -> pprPanic "getEqPredTys" (ppr ty) +getEqPredTys ty + = case splitTyConApp_maybe ty of + Just (tc, (_ : ty1 : ty2 : tys)) -> ASSERT( tc `hasKey` eqTyConKey && null tys ) + (ty1, ty2) + _ -> pprPanic "getEqPredTys" (ppr ty) getEqPredTys_maybe :: PredType -> Maybe (Type, Type) -getEqPredTys_maybe ty = case splitTyConApp_maybe ty of - Just (tc, [_, ty1, ty2]) | tc `hasKey` eqTyConKey -> Just (ty1, ty2) - _ -> Nothing - -getIPPredTy_maybe :: PredType -> Maybe (IPName Name, Type) -getIPPredTy_maybe ty = case splitTyConApp_maybe ty of - Just (tc, [ty1]) | Just ip <- tyConIP_maybe tc -> Just (ip, ty1) - _ -> Nothing +getEqPredTys_maybe ty + = case splitTyConApp_maybe ty of + Just (tc, [_, ty1, ty2]) | tc `hasKey` eqTyConKey -> Just (ty1, ty2) + _ -> Nothing \end{code} %************************************************************************ @@ -967,7 +993,8 @@ getIPPredTy_maybe ty = case splitTyConApp_maybe ty of \begin{code} typeSize :: Type -> Int -typeSize (TyVarTy _) = 1 +typeSize (LitTy {}) = 1 +typeSize (TyVarTy {}) = 1 typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 typeSize (ForAllTy _ t) = 1 + typeSize t @@ -975,23 +1002,10 @@ typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) varSetElemsKvsFirst :: VarSet -> [TyVar] -- {k1,a,k2,b} --> [k1,k2,a,b] -varSetElemsKvsFirst set = uncurry (++) $ partitionKiTyVars (varSetElems set) - -sortQuantVars :: [Var] -> [Var] --- Sort the variables so the true kind then type variables come first -sortQuantVars = sortLe le +varSetElemsKvsFirst set + = kvs ++ tvs where - v1 `le` v2 = case (is_tv v1, is_tv v2) of - (True, False) -> True - (False, True) -> False - (True, True) -> - case (is_kv v1, is_kv v2) of - (True, False) -> True - (False, True) -> False - _ -> v1 <= v2 -- Same family - (False, False) -> v1 <= v2 - is_tv v = isTyVar v - is_kv v = isSuperKind (tyVarKind v) + (kvs, tvs) = partition isKindVar (varSetElems set) \end{code} @@ -1124,6 +1138,7 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of \begin{code} seqType :: Type -> () +seqType (LitTy n) = n `seq` () seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 @@ -1197,20 +1212,27 @@ cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX (rnBndr2 env tv1 cmpTypeX env (AppTy s1 t1) (AppTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` cmpTypesX env tys1 tys2 +cmpTypeX _ (LitTy l1) (LitTy l2) = compare l1 l2 - -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy + -- Deal with the rest: TyVarTy < AppTy < FunTy < LitTy < TyConApp < ForAllTy < PredTy cmpTypeX _ (AppTy _ _) (TyVarTy _) = GT cmpTypeX _ (FunTy _ _) (TyVarTy _) = GT cmpTypeX _ (FunTy _ _) (AppTy _ _) = GT +cmpTypeX _ (LitTy _) (TyVarTy _) = GT +cmpTypeX _ (LitTy _) (AppTy _ _) = GT +cmpTypeX _ (LitTy _) (FunTy _ _) = GT + cmpTypeX _ (TyConApp _ _) (TyVarTy _) = GT cmpTypeX _ (TyConApp _ _) (AppTy _ _) = GT cmpTypeX _ (TyConApp _ _) (FunTy _ _) = GT +cmpTypeX _ (TyConApp _ _) (LitTy _) = GT cmpTypeX _ (ForAllTy _ _) (TyVarTy _) = GT cmpTypeX _ (ForAllTy _ _) (AppTy _ _) = GT cmpTypeX _ (ForAllTy _ _) (FunTy _ _) = GT +cmpTypeX _ (ForAllTy _ _) (LitTy _) = GT cmpTypeX _ (ForAllTy _ _) (TyConApp _ _) = GT cmpTypeX _ _ _ = LT @@ -1450,6 +1472,7 @@ subst_ty :: TvSubst -> Type -> Type subst_ty subst ty = go ty where + go (LitTy n) = n `seq` LitTy n go (TyVarTy tv) = substTyVar subst tv go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args @@ -1543,25 +1566,33 @@ type SimpleKind = Kind \begin{code} typeKind :: Type -> Kind typeKind (TyConApp tc tys) - | isPromotedTypeTyCon tc - = ASSERT( tyConArity tc == length tys ) tySuperKind + | isPromotedTyCon tc + = ASSERT( tyConArity tc == length tys ) superKind | otherwise = kindAppResult (tyConKind tc) tys typeKind (AppTy fun arg) = kindAppResult (typeKind fun) [arg] +typeKind (LitTy l) = typeLiteralKind l typeKind (ForAllTy _ ty) = typeKind ty typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (FunTy _arg res) +typeKind _ty@(FunTy _arg res) -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), -- not unliftedTypKind (#) -- The only things that can be after a function arrow are -- (a) types (of kind openTypeKind or its sub-kinds) -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) | isSuperKind k = k - | otherwise = ASSERT( isSubOpenTypeKind k ) liftedTypeKind + | otherwise = ASSERT2( isSubOpenTypeKind k, ppr _ty $$ ppr k ) liftedTypeKind where k = typeKind res + +typeLiteralKind :: TyLit -> Kind +typeLiteralKind l = + case l of + NumTyLit _ -> typeNatKind + StrTyLit _ -> typeStringKind + \end{code} Kind inference diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 26526abbf0..327ac78d71 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -4,6 +4,16 @@ % \section[TypeRep]{Type - friends' interface} +Note [The Type-related module hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Class + TyCon imports Class + TypeRep + TysPrim imports TypeRep ( including mkTyConTy ) + Kind imports TysPrim ( mainly for primitive kinds ) + Type imports Kind + Coercion imports Type + \begin{code} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. @@ -18,18 +28,19 @@ module TypeRep ( TyThing(..), Type(..), + TyLit(..), KindOrType, Kind, SuperKind, PredType, ThetaType, -- Synonyms -- Functions over types - mkTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys, - isLiftedTypeKind, + mkNakedTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys, + isLiftedTypeKind, isSuperKind, isTypeVar, isKindVar, -- Pretty-printing - pprType, pprParendType, pprTypeApp, - pprTyThing, pprTyThingCategory, + pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, + pprTyThing, pprTyThingCategory, pprSigmaType, pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, + pprKind, pprParendKind, pprTyLit, Prec(..), maybeParen, pprTcApp, pprTypeNameApp, pprPrefixApp, pprArrowChain, ppr_type, @@ -59,6 +70,8 @@ import PrelNames import Outputable import FastString import Pair +import StaticFlags( opt_PprStyle_Debug ) +import Util -- libraries import qualified Data.Data as Data hiding ( TyCon ) @@ -112,8 +125,18 @@ data Type Var -- Type or kind variable Type -- ^ A polymorphic type + | LitTy TyLit -- ^ Type literals are simillar to type constructors. + deriving (Data.Data, Data.Typeable) + +-- NOTE: Other parts of the code assume that type literals do not contain +-- types or type variables. +data TyLit + = NumTyLit Integer + | StrTyLit FastString + deriving (Eq, Ord, Data.Data, Data.Typeable) + type KindOrType = Type -- See Note [Arguments to type constructors] -- | The key type representing kinds in the compiler. @@ -136,9 +159,7 @@ Note [The kind invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~ The kinds # UnliftedTypeKind - ArgKind super-kind of *, # - (#) UbxTupleKind - OpenKind super-kind of ArgKind, ubxTupleKind + OpenKind super-kind of *, # can never appear under an arrow or type constructor in a kind; they can only be at the top level of a kind. It follows that primitive TyCons, @@ -244,24 +265,36 @@ mkTyVarTy = TyVarTy mkTyVarTys :: [TyVar] -> [Type] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy --- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments. --- Applies its arguments to the constructor from left to right -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon, [ty1,ty2] <- tys - = FunTy ty1 ty2 - - | otherwise - = TyConApp tycon tys +mkNakedTyConApp :: TyCon -> [Type] -> Type +-- Builds a TyConApp +-- * without being strict in TyCon, +-- * the TyCon should never be a saturated FunTyCon +-- Type.mkTyConApp is the usual one +mkNakedTyConApp tc tys + = TyConApp (ASSERT( not (isFunTyCon tc && length tys == 2) ) tc) tys -- | Create the plain type constructor type which has been applied to no type arguments at all. mkTyConTy :: TyCon -> Type -mkTyConTy tycon = mkTyConApp tycon [] +mkTyConTy tycon = TyConApp tycon [] +\end{code} +Some basic functions, put here to break loops eg with the pretty printer + +\begin{code} isLiftedTypeKind :: Kind -> Bool --- This function is here because it's used in the pretty printer isLiftedTypeKind (TyConApp tc []) = tc `hasKey` liftedTypeKindTyConKey isLiftedTypeKind _ = False + +-- | Is this a super-kind (i.e. a type-of-kinds)? +isSuperKind :: Type -> Bool +isSuperKind (TyConApp skc []) = skc `hasKey` superKindTyConKey +isSuperKind _ = False + +isTypeVar :: Var -> Bool +isTypeVar v = isTKVar v && not (isSuperKind (varType v)) + +isKindVar :: Var -> Bool +isKindVar v = isTKVar v && isSuperKind (varType v) \end{code} @@ -279,9 +312,11 @@ tyVarsOfType :: Type -> VarSet -- kind variable {k} tyVarsOfType (TyVarTy v) = unitVarSet v tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys +tyVarsOfType (LitTy {}) = emptyVarSet tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar + `unionVarSet` tyVarsOfType (tyVarKind tyvar) tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys @@ -450,6 +485,9 @@ pprType, pprParendType :: Type -> SDoc pprType ty = ppr_type TopPrec ty pprParendType ty = ppr_type TyConPrec ty +pprTyLit :: TyLit -> SDoc +pprTyLit = ppr_tylit TopPrec + pprKind, pprParendKind :: Kind -> SDoc pprKind = pprType pprParendKind = pprParendType @@ -510,22 +548,27 @@ pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) instance Outputable Type where ppr ty = pprType ty -instance Outputable name => OutputableBndr (IPName name) where - pprBndr _ n = ppr n -- Simple for now - pprInfixOcc n = ppr n - pprPrefixOcc n = ppr n +instance Outputable TyLit where + ppr = pprTyLit ------------------ -- OK, here's the main printer ppr_type :: Prec -> Type -> SDoc ppr_type _ (TyVarTy tv) = ppr_tvar tv + +ppr_type _ (TyConApp tc [LitTy (StrTyLit n),ty]) + | tc `hasKey` ipClassNameKey + = char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty + ppr_type p (TyConApp tc tys) = pprTcApp p ppr_type tc tys +ppr_type p (LitTy l) = ppr_tylit p l +ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty + ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ pprType t1 <+> ppr_type TyConPrec t2 -ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty ppr_type p fun_ty@(FunTy ty1 ty2) | isPredTy ty1 = ppr_forall_type p fun_ty @@ -537,10 +580,28 @@ ppr_type p fun_ty@(FunTy ty1 ty2) | not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] + ppr_forall_type :: Prec -> Type -> SDoc ppr_forall_type p ty - = maybeParen p FunPrec $ - sep [pprForAll tvs, pprThetaArrowTy ctxt, pprType tau] + = maybeParen p FunPrec $ (ppr_sigma_type True ty) + +ppr_tvar :: TyVar -> SDoc +ppr_tvar tv -- Note [Infix type variables] + = parenSymOcc (getOccName tv) (ppr tv) + +ppr_tylit :: Prec -> TyLit -> SDoc +ppr_tylit _ tl = + case tl of + NumTyLit n -> integer n + StrTyLit s -> text (show s) + +------------------- +ppr_sigma_type :: Bool -> Type -> SDoc +-- Bool <=> Show the foralls +ppr_sigma_type show_foralls ty + = sep [ if show_foralls then pprForAll tvs else empty + , pprThetaArrowTy ctxt + , pprType tau ] where (tvs, rho) = split1 [] ty (ctxt, tau) = split2 [] rho @@ -551,14 +612,16 @@ ppr_forall_type p ty split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2 split2 ps ty = (reverse ps, ty) -ppr_tvar :: TyVar -> SDoc -ppr_tvar tv -- Note [Infix type variables] - = parenSymOcc (getOccName tv) (ppr tv) -------------------- +pprSigmaType :: Type -> SDoc +pprSigmaType ty = ppr_sigma_type opt_PprStyle_Debug ty + pprForAll :: [TyVar] -> SDoc pprForAll [] = empty -pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot +pprForAll tvs = ptext (sLit "forall") <+> pprTvBndrs tvs <> dot + +pprTvBndrs :: [TyVar] -> SDoc +pprTvBndrs tvs = sep (map pprTvBndr tvs) pprTvBndr :: TyVar -> SDoc pprTvBndr tv @@ -597,47 +660,48 @@ pprTcApp _ _ tc [] -- No brackets for SymOcc | otherwise = empty pprTcApp _ pp tc [ty] - | tc `hasKey` listTyConKey = brackets (pp TopPrec ty) - | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pp TopPrec ty <> ptext (sLit ":]") - | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*") - | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#") - | tc `hasKey` openTypeKindTyConKey = ptext (sLit "OpenKind") - | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)") - | tc `hasKey` argTypeKindTyConKey = ptext (sLit "ArgKind") - | Just n <- tyConIP_maybe tc = ppr n <> ptext (sLit "::") <> pp TopPrec ty + | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) + | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) pprTcApp p pp tc tys | isTupleTyCon tc && tyConArity tc == length tys - = tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) - | tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because - -- its not a SymOcc so won't get printed infix - , [_, ty1,ty2] <- tys - = pprInfixApp p pp (getName tc) ty1 ty2 + = pprPromotionQuote tc <> + tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) + + | not opt_PprStyle_Debug + , tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because + , [_, ty1,ty2] <- tys -- with kind polymorphism it has 3 args, so won't get printed infix + -- With -dppr-debug switch this off so we can see the kind + = pprInfixApp p pp (ppr tc) ty1 ty2 + | otherwise - = pprTypeNameApp p pp (getName tc) tys + = ppr_type_name_app p pp (ppr tc) (isSymOcc (getOccName tc)) tys ---------------- pprTypeApp :: NamedThing a => a -> [Type] -> SDoc -- The first arg is the tycon, or sometimes class -- Print infix if the tycon/class looks like an operator -pprTypeApp tc tys = pprTypeNameApp TopPrec ppr_type (getName tc) tys +pprTypeApp tc tys + = pprTypeNameApp TopPrec ppr_type (getName tc) tys pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc -- Used for classes and coercions as well as types; that's why it's separate from pprTcApp -pprTypeNameApp p pp tc tys +pprTypeNameApp p pp name tys + = ppr_type_name_app p pp (ppr name) (isSymOcc (getOccName name)) tys + +ppr_type_name_app :: Prec -> (Prec -> a -> SDoc) -> SDoc -> Bool -> [a] -> SDoc +ppr_type_name_app p pp pp_tc is_sym_occ tys | is_sym_occ -- Print infix if possible , [ty1,ty2] <- tys -- We know nothing of precedence though - = pprInfixApp p pp tc ty1 ty2 + = pprInfixApp p pp pp_tc ty1 ty2 | otherwise - = pprPrefixApp p (pprPrefixVar is_sym_occ (ppr tc)) (map (pp TyConPrec) tys) - where - is_sym_occ = isSymOcc (getOccName tc) + = pprPrefixApp p (pprPrefixVar is_sym_occ pp_tc) (map (pp TyConPrec) tys) ---------------- -pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> Name -> a -> a -> SDoc -pprInfixApp p pp tc ty1 ty2 +pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> SDoc -> a -> a -> SDoc +pprInfixApp p pp pp_tc ty1 ty2 = maybeParen p FunPrec $ - sep [pp FunPrec ty1, pprInfixVar True (ppr tc) <+> pp FunPrec ty2] + sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2] pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $ diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 7d648aef7e..de4f3fe865 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -156,9 +156,6 @@ match :: MatchEnv -- For the most part this is pushed downwards -- in-scope set of the RnEnv2 -> Type -> Type -- Template and target respectively -> Maybe TvSubstEnv --- This matcher works on core types; that is, it ignores PredTypes --- Watch out if newtypes become transparent agin! --- this matcher must respect newtypes match menv subst ty1 ty2 | Just ty1' <- coreView ty1 = match menv subst ty1' ty2 | Just ty2' <- coreView ty2 = match menv subst ty1 ty2' @@ -202,6 +199,8 @@ match menv subst (AppTy ty1a ty1b) ty2 = do { subst' <- match menv subst ty1a ty2a ; match menv subst' ty1b ty2b } +match _ subst (LitTy x) (LitTy y) | x == y = return subst + match _ _ _ _ = Nothing @@ -342,6 +341,8 @@ typesCantMatch prs = any (\(s,t) -> cant_match s t) prs | Just (f1, a1) <- repSplitAppTy_maybe ty1 = cant_match f1 f2 || cant_match a1 a2 + cant_match (LitTy x) (LitTy y) = x /= y + cant_match _ _ = False -- Safe! -- Things we could add; @@ -456,6 +457,8 @@ unify subst ty1 (AppTy ty2a ty2b) = do { subst' <- unify subst ty1a ty2a ; unify subst' ty1b ty2b } +unify subst (LitTy x) (LitTy y) | x == y = return subst + unify _ ty1 ty2 = failWith (misMatch ty1 ty2) -- ForAlls?? @@ -513,36 +516,29 @@ uUnrefined subst tv1 ty2 (TyVarTy tv2) = uUnrefined subst tv1 ty' ty' | otherwise - -- So both are unrefined; next, see if the kinds force the direction - = case (k1_sub_k2, k2_sub_k1) of - (True, True) -> choose subst - (True, False) -> bindTv subst tv2 ty1 - (False, True) -> bindTv subst tv1 ty2 - (False, False) -> do - { subst' <- unify subst k1 k2 - ; choose subst' } - where subst_kind = mkTvSubst (mkInScopeSet (tyVarsOfTypes [k1,k2])) subst - k1 = substTy subst_kind (tyVarKind tv1) - k2 = substTy subst_kind (tyVarKind tv2) - k1_sub_k2 = k1 `isSubKind` k2 - k2_sub_k1 = k2 `isSubKind` k1 - ty1 = TyVarTy tv1 - bind subst tv ty = return $ extendVarEnv subst tv ty - choose subst = do - { b1 <- tvBindFlag tv1 - ; b2 <- tvBindFlag tv2 - ; case (b1, b2) of - (BindMe, _) -> bind subst tv1 ty2 - (Skolem, Skolem) -> failWith (misMatch ty1 ty2) - (Skolem, _) -> bind subst tv2 ty1 } + + = do { -- So both are unrefined; unify the kinds + ; subst' <- unify subst (tyVarKind tv1) (tyVarKind tv2) + + -- And then bind one or the other, + -- depending on which is bindable + -- NB: unlike TcUnify we do not have an elaborate sub-kinding + -- story. That is relevant only during type inference, and + -- (I very much hope) is not relevant here. + ; b1 <- tvBindFlag tv1 + ; b2 <- tvBindFlag tv2 + ; let ty1 = TyVarTy tv1 + ; case (b1, b2) of + (Skolem, Skolem) -> failWith (misMatch ty1 ty2) + (BindMe, _) -> return (extendVarEnv subst' tv1 ty2) + (_, BindMe) -> return (extendVarEnv subst' tv2 ty1) } uUnrefined subst tv1 ty2 ty2' -- ty2 is not a type variable | tv1 `elemVarSet` niSubstTvSet subst (tyVarsOfType ty2') = failWith (occursCheck tv1 ty2) -- Occurs check - | not (k2 `isSubKind` k1) - = failWith (kindMisMatch tv1 ty2) -- Kind check | otherwise - = bindTv subst tv1 ty2 -- Bind tyvar to the synonym if poss + = do { subst' <- unify subst k1 k2 + ; bindTv subst' tv1 ty2 } -- Bind tyvar to the synonym if poss where k1 = tyVarKind tv1 k2 = typeKind ty2' @@ -623,13 +619,6 @@ lengthMisMatch tys1 tys2 = sep [ptext (sLit "Can't match unequal length lists"), nest 2 (ppr tys1), nest 2 (ppr tys2) ] -kindMisMatch :: TyVar -> Type -> SDoc -kindMisMatch tv1 t2 - = vcat [ptext (sLit "Can't match kinds") <+> quotes (ppr (tyVarKind tv1)) <+> - ptext (sLit "and") <+> quotes (ppr (typeKind t2)), - ptext (sLit "when matching") <+> quotes (ppr tv1) <+> - ptext (sLit "with") <+> quotes (ppr t2)] - occursCheck :: TyVar -> Type -> SDoc occursCheck tv ty = hang (ptext (sLit "Can't construct the infinite type")) diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index feb4be50c1..77bd190fa9 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -267,9 +267,6 @@ expandBin (BinMem _ _ sz_r arr_r) off = do copyBytes new old sz writeFastMutInt sz_r sz' writeIORef arr_r arr' - when False $ -- disabled - hPutStrLn stderr ("Binary: expanding to size: " ++ show sz') - return () expandBin (BinIO _ _ _) _ = return () -- no need to expand a file, we'll assume they expand by themselves. diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index 1bb460674c..9ae84a7897 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -47,7 +47,7 @@ module Digraph( ------------------------------------------------------------------------------ -import Util ( sortLe, minWith, count ) +import Util ( minWith, count ) import Outputable import Maybes ( expectJust ) import MonadUtils ( allM ) @@ -59,7 +59,8 @@ import Control.Monad.ST -- std interfaces import Data.Maybe import Data.Array -import Data.List ( (\\) ) +import Data.List hiding (transpose) +import Data.Ord import Data.Array.ST import qualified Data.Map as Map import qualified Data.Set as Set @@ -140,8 +141,7 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte max_v = length nodes - 1 bounds = (0, max_v) :: (Vertex, Vertex) - sorted_nodes = let n1 `le` n2 = (key_extractor n1 `compare` key_extractor n2) /= GT - in sortLe le nodes + sorted_nodes = sortBy (comparing key_extractor) nodes numbered_nodes = zipWith (,) [0..] sorted_nodes key_map = array bounds [(i, key_extractor node) | (i, node) <- numbered_nodes] @@ -240,9 +240,6 @@ flattenSCC (CyclicSCC vs) = vs instance Outputable a => Outputable (SCC a) where ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) -instance PlatformOutputable a => PlatformOutputable (SCC a) where - pprPlatform platform (AcyclicSCC v) = text "NONREC" $$ (nest 3 (pprPlatform platform v)) - pprPlatform platform (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map (pprPlatform platform) vs))) \end{code} %************************************************************************ @@ -429,12 +426,6 @@ instance Show a => Show (Tree a) where showTree :: Show a => Tree a -> String showTree = drawTree . mapTree show -instance Show a => Show (Forest a) where - showsPrec _ f s = showForest f ++ s - -showForest :: Show a => Forest a -> String -showForest = unlines . map showTree - drawTree :: Tree String -> String drawTree = unlines . draw diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs index 28196eba2b..db5bcad629 100644 --- a/compiler/utils/Exception.hs +++ b/compiler/utils/Exception.hs @@ -6,12 +6,10 @@ module Exception ) where -import Prelude hiding (catch) - import Control.Exception catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO = catch +catchIO = Control.Exception.catch handleIO :: (IOException -> IO a) -> IO a -> IO a handleIO = flip catchIO @@ -75,7 +73,7 @@ class Monad m => ExceptionMonad m where return r instance ExceptionMonad IO where - gcatch = catch + gcatch = Control.Exception.catch gmask f = mask (\x -> f x) gblock = block gunblock = unblock diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index c37fc26f72..2c94de75f9 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -3,10 +3,6 @@ % \begin{code} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS -fno-warn-unused-imports #-} --- XXX GHC 6.9 seems to be confused by unpackCString# being used only in --- a RULE - {-# OPTIONS_GHC -O -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -106,7 +102,6 @@ import Data.Maybe ( isJust ) import Data.Char ( ord ) import GHC.IO ( IO(..) ) -import GHC.Ptr ( Ptr(..) ) #if __GLASGOW_HASKELL__ >= 701 import Foreign.Safe diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs index b9ed3e2643..7ba8efbd03 100644 --- a/compiler/utils/GraphColor.hs +++ b/compiler/utils/GraphColor.hs @@ -1,22 +1,13 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Graph Coloring. --- This is a generic graph coloring library, abstracted over the type of --- the node keys, nodes and colors. +-- This is a generic graph coloring library, abstracted over the type of +-- the node keys, nodes and colors. -- -module GraphColor ( - module GraphBase, - module GraphOps, - module GraphPpr, - colorGraph +module GraphColor ( + module GraphBase, + module GraphOps, + module GraphPpr, + colorGraph ) where @@ -28,325 +19,351 @@ import GraphPpr import Unique import UniqFM import UniqSet -import Outputable +import Outputable import Data.Maybe import Data.List - + -- | Try to color a graph with this set of colors. --- Uses Chaitin's algorithm to color the graph. --- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes --- are pushed onto a stack and removed from the graph. --- Once this process is complete the graph can be colored by removing nodes from --- the stack (ie in reverse order) and assigning them colors different to their neighbors. +-- Uses Chaitin's algorithm to color the graph. +-- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes +-- are pushed onto a stack and removed from the graph. +-- Once this process is complete the graph can be colored by removing nodes from +-- the stack (ie in reverse order) and assigning them colors different to their neighbors. -- colorGraph - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq color, Eq cls, Ord k - , Outputable k, Outputable cls, Outputable color) - => Bool -- ^ whether to do iterative coalescing - -> Int -- ^ how many times we've tried to color this graph so far. - -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to color. - - -> ( Graph k cls color -- the colored graph. - , UniqSet k -- the set of nodes that we couldn't find a color for. - , UniqFM k ) -- map of regs (r1 -> r2) that were coaleced - -- r1 should be replaced by r2 in the source + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Eq cls, Ord k + , Outputable k, Outputable cls, Outputable color) + => Bool -- ^ whether to do iterative coalescing + -> Int -- ^ how many times we've tried to color this graph so far. + -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to color. + + -> ( Graph k cls color -- the colored graph. + , UniqSet k -- the set of nodes that we couldn't find a color for. + , UniqFM k ) -- map of regs (r1 -> r2) that were coaleced + -- r1 should be replaced by r2 in the source colorGraph iterative spinCount colors triv spill graph0 = let - -- If we're not doing iterative coalescing then do an aggressive coalescing first time - -- around and then conservative coalescing for subsequent passes. - -- - -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if - -- there is a lot of register pressure and we do it on every round then it can make the - -- graph less colorable and prevent the algorithm from converging in a sensible number - -- of cycles. - -- - (graph_coalesced, kksCoalesce1) - = if iterative - then (graph0, []) - else if spinCount == 0 - then coalesceGraph True triv graph0 - else coalesceGraph False triv graph0 - - -- run the scanner to slurp out all the trivially colorable nodes - -- (and do coalescing if iterative coalescing is enabled) - (ksTriv, ksProblems, kksCoalesce2) - = colorScan iterative triv spill graph_coalesced - - -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. - -- We need to apply all the coalescences found by the scanner to the original - -- graph before doing assignColors. - -- - -- Because we've got the whole, non-pruned graph here we turn on aggressive coalecing - -- to force all the (conservative) coalescences found during scanning. - -- - (graph_scan_coalesced, _) - = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 - - -- color the trivially colorable nodes - -- during scanning, keys of triv nodes were added to the front of the list as they were found - -- this colors them in the reverse order, as required by the algorithm. - (graph_triv, ksNoTriv) - = assignColors colors graph_scan_coalesced ksTriv - - -- try and color the problem nodes - -- problem nodes are the ones that were left uncolored because they weren't triv. - -- theres a change we can color them here anyway. - (graph_prob, ksNoColor) - = assignColors colors graph_triv ksProblems - - -- if the trivially colorable nodes didn't color then something is probably wrong - -- with the provided triv function. + -- If we're not doing iterative coalescing then do an aggressive coalescing first time + -- around and then conservative coalescing for subsequent passes. + -- + -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if + -- there is a lot of register pressure and we do it on every round then it can make the + -- graph less colorable and prevent the algorithm from converging in a sensible number + -- of cycles. -- - in if not $ null ksNoTriv - then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty - ( empty - $$ text "ksTriv = " <> ppr ksTriv - $$ text "ksNoTriv = " <> ppr ksNoTriv - $$ text "colors = " <> ppr colors - $$ empty - $$ dotGraph (\_ -> text "white") triv graph_triv) - - else ( graph_prob - , mkUniqSet ksNoColor -- the nodes that didn't color (spills) - , if iterative - then (listToUFM kksCoalesce2) - else (listToUFM kksCoalesce1)) - + (graph_coalesced, kksCoalesce1) + = if iterative + then (graph0, []) + else if spinCount == 0 + then coalesceGraph True triv graph0 + else coalesceGraph False triv graph0 + + -- run the scanner to slurp out all the trivially colorable nodes + -- (and do coalescing if iterative coalescing is enabled) + (ksTriv, ksProblems, kksCoalesce2) + = colorScan iterative triv spill graph_coalesced + + -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. + -- We need to apply all the coalescences found by the scanner to the original + -- graph before doing assignColors. + -- + -- Because we've got the whole, non-pruned graph here we turn on aggressive coalecing + -- to force all the (conservative) coalescences found during scanning. + -- + (graph_scan_coalesced, _) + = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 + + -- color the trivially colorable nodes + -- during scanning, keys of triv nodes were added to the front of the list as they were found + -- this colors them in the reverse order, as required by the algorithm. + (graph_triv, ksNoTriv) + = assignColors colors graph_scan_coalesced ksTriv + + -- try and color the problem nodes + -- problem nodes are the ones that were left uncolored because they weren't triv. + -- theres a change we can color them here anyway. + (graph_prob, ksNoColor) + = assignColors colors graph_triv ksProblems + + -- if the trivially colorable nodes didn't color then something is probably wrong + -- with the provided triv function. + -- + in if not $ null ksNoTriv + then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty + ( empty + $$ text "ksTriv = " <> ppr ksTriv + $$ text "ksNoTriv = " <> ppr ksNoTriv + $$ text "colors = " <> ppr colors + $$ empty + $$ dotGraph (\_ -> text "white") triv graph_triv) + + else ( graph_prob + , mkUniqSet ksNoColor -- the nodes that didn't color (spills) + , if iterative + then (listToUFM kksCoalesce2) + else (listToUFM kksCoalesce1)) + -- | Scan through the conflict graph separating out trivially colorable and --- potentially uncolorable (problem) nodes. +-- potentially uncolorable (problem) nodes. -- --- Checking whether a node is trivially colorable or not is a resonably expensive operation, --- so after a triv node is found and removed from the graph it's no good to return to the 'start' --- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. +-- Checking whether a node is trivially colorable or not is a resonably expensive operation, +-- so after a triv node is found and removed from the graph it's no good to return to the 'start' +-- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. -- --- To ward against this, during each pass through the graph we collect up a list of triv nodes --- that were found, and only remove them once we've finished the pass. The more nodes we can delete --- at once the more likely it is that nodes we've already checked will become trivially colorable --- for the next pass. +-- To ward against this, during each pass through the graph we collect up a list of triv nodes +-- that were found, and only remove them once we've finished the pass. The more nodes we can delete +-- at once the more likely it is that nodes we've already checked will become trivially colorable +-- for the next pass. -- --- TODO: add work lists to finding triv nodes is easier. --- If we've just scanned the graph, and removed triv nodes, then the only --- nodes that we need to rescan are the ones we've removed edges from. +-- TODO: add work lists to finding triv nodes is easier. +-- If we've just scanned the graph, and removed triv nodes, then the only +-- nodes that we need to rescan are the ones we've removed edges from. colorScan - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool -- ^ whether to do iterative coalescing - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to scan + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool -- ^ whether to do iterative coalescing + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to scan - -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce + -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce colorScan iterative triv spill graph - = colorScan_spin iterative triv spill graph [] [] [] + = colorScan_spin iterative triv spill graph [] [] [] + +colorScan_spin + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) colorScan_spin iterative triv spill graph - ksTriv ksSpill kksCoalesce - - -- if the graph is empty then we're done - | isNullUFM $ graphMap graph - = (ksTriv, ksSpill, reverse kksCoalesce) - - -- Simplify: - -- Look for trivially colorable nodes. - -- If we can find some then remove them from the graph and go back for more. - -- - | nsTrivFound@(_:_) - <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - - -- for iterative coalescing we only want non-move related - -- nodes here - && (not iterative || isEmptyUniqSet (nodeCoalesce node))) - $ graph - - , ksTrivFound <- map nodeId nsTrivFound - , graph2 <- foldr (\k g -> let Just g' = delNode k g - in g') - graph ksTrivFound - - = colorScan_spin iterative triv spill graph2 - (ksTrivFound ++ ksTriv) - ksSpill - kksCoalesce - - -- Coalesce: - -- If we're doing iterative coalescing and no triv nodes are avaliable - -- then it's time for a coalescing pass. - | iterative - = case coalesceGraph False triv graph of - - -- we were able to coalesce something - -- go back to Simplify and see if this frees up more nodes to be trivially colorable. - (graph2, kksCoalesceFound @(_:_)) - -> colorScan_spin iterative triv spill graph2 - ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) - - -- Freeze: - -- nothing could be coalesced (or was triv), - -- time to choose a node to freeze and give up on ever coalescing it. - (graph2, []) - -> case freezeOneInGraph graph2 of - - -- we were able to freeze something - -- hopefully this will free up something for Simplify - (graph3, True) - -> colorScan_spin iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- we couldn't find something to freeze either - -- time for a spill - (graph3, False) - -> colorScan_spill iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- spill time - | otherwise - = colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce + ksTriv ksSpill kksCoalesce + + -- if the graph is empty then we're done + | isNullUFM $ graphMap graph + = (ksTriv, ksSpill, reverse kksCoalesce) + + -- Simplify: + -- Look for trivially colorable nodes. + -- If we can find some then remove them from the graph and go back for more. + -- + | nsTrivFound@(_:_) + <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + + -- for iterative coalescing we only want non-move related + -- nodes here + && (not iterative || isEmptyUniqSet (nodeCoalesce node))) + $ graph + + , ksTrivFound <- map nodeId nsTrivFound + , graph2 <- foldr (\k g -> let Just g' = delNode k g + in g') + graph ksTrivFound + + = colorScan_spin iterative triv spill graph2 + (ksTrivFound ++ ksTriv) + ksSpill + kksCoalesce + + -- Coalesce: + -- If we're doing iterative coalescing and no triv nodes are avaliable + -- then it's time for a coalescing pass. + | iterative + = case coalesceGraph False triv graph of + + -- we were able to coalesce something + -- go back to Simplify and see if this frees up more nodes to be trivially colorable. + (graph2, kksCoalesceFound @(_:_)) + -> colorScan_spin iterative triv spill graph2 + ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) + + -- Freeze: + -- nothing could be coalesced (or was triv), + -- time to choose a node to freeze and give up on ever coalescing it. + (graph2, []) + -> case freezeOneInGraph graph2 of + + -- we were able to freeze something + -- hopefully this will free up something for Simplify + (graph3, True) + -> colorScan_spin iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- we couldn't find something to freeze either + -- time for a spill + (graph3, False) + -> colorScan_spill iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- spill time + | otherwise + = colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce -- Select: -- we couldn't find any triv nodes or things to freeze or coalesce, --- and the graph isn't empty yet.. We'll have to choose a spill --- candidate and leave it uncolored. +-- and the graph isn't empty yet.. We'll have to choose a spill +-- candidate and leave it uncolored. -- +colorScan_spill + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce + ksTriv ksSpill kksCoalesce + + = let kSpill = spill graph + Just graph' = delNode kSpill graph + in colorScan_spin iterative triv spill graph' + ksTriv (kSpill : ksSpill) kksCoalesce - = let kSpill = spill graph - Just graph' = delNode kSpill graph - in colorScan_spin iterative triv spill graph' - ksTriv (kSpill : ksSpill) kksCoalesce - -- | Try to assign a color to all these nodes. -assignColors - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq color, Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> [k] -- ^ nodes to assign a color to. - -> ( Graph k cls color -- the colored graph - , [k]) -- the nodes that didn't color. +assignColors + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> [k] -- ^ nodes to assign a color to. + -> ( Graph k cls color -- the colored graph + , [k]) -- the nodes that didn't color. + +assignColors colors graph ks + = assignColors' colors graph [] ks + + where assignColors' _ graph prob [] + = (graph, prob) -assignColors colors graph ks - = assignColors' colors graph [] ks + assignColors' colors graph prob (k:ks) + = case assignColor colors k graph of - where assignColors' _ graph prob [] - = (graph, prob) + -- couldn't color this node + Nothing -> assignColors' colors graph (k : prob) ks - assignColors' colors graph prob (k:ks) - = case assignColor colors k graph of + -- this node colored ok, so do the rest + Just graph' -> assignColors' colors graph' prob ks - -- couldn't color this node - Nothing -> assignColors' colors graph (k : prob) ks - -- this node colored ok, so do the rest - Just graph' -> assignColors' colors graph' prob ks + assignColor colors u graph + | Just c <- selectColor colors graph u + = Just (setColor u c graph) + | otherwise + = Nothing - assignColor colors u graph - | Just c <- selectColor colors graph u - = Just (setColor u c graph) - | otherwise - = Nothing - - -- | Select a color for a certain node --- taking into account preferences, neighbors and exclusions. --- returns Nothing if no color can be assigned to this node. +-- taking into account preferences, neighbors and exclusions. +-- returns Nothing if no color can be assigned to this node. -- selectColor - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq color, Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> k -- ^ key of the node to select a color for. - -> Maybe color - -selectColor colors graph u - = let -- lookup the node - Just node = lookupNode graph u - - -- lookup the available colors for the class of this node. - colors_avail - = case lookupUFM colors (nodeClass node) of - Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) - Just cs -> cs - - -- find colors we can't use because they're already being used - -- by a node that conflicts with this one. - Just nsConflicts - = sequence - $ map (lookupNode graph) - $ uniqSetToList - $ nodeConflicts node - - colors_conflict = mkUniqSet - $ catMaybes - $ map nodeColor nsConflicts - - -- the prefs of our neighbors - colors_neighbor_prefs - = mkUniqSet - $ concat $ map nodePreference nsConflicts - - -- colors that are still valid for us - colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) - colors_ok = minusUniqSet colors_ok_ex colors_conflict - - -- the colors that we prefer, and are still ok - colors_ok_pref = intersectUniqSets - (mkUniqSet $ nodePreference node) colors_ok - - -- the colors that we could choose while being nice to our neighbors - colors_ok_nice = minusUniqSet - colors_ok colors_neighbor_prefs - - -- the best of all possible worlds.. - colors_ok_pref_nice - = intersectUniqSets - colors_ok_nice colors_ok_pref - - -- make the decision - chooseColor - - -- everyone is happy, yay! - | not $ isEmptyUniqSet colors_ok_pref_nice - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) - (nodePreference node) - = Just c - - -- we've got one of our preferences - | not $ isEmptyUniqSet colors_ok_pref - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) - (nodePreference node) - = Just c - - -- it wasn't a preference, but it was still ok - | not $ isEmptyUniqSet colors_ok - , c : _ <- uniqSetToList colors_ok - = Just c - - -- no colors were available for us this time. - -- looks like we're going around the loop again.. - | otherwise - = Nothing - - in chooseColor + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> k -- ^ key of the node to select a color for. + -> Maybe color + +selectColor colors graph u + = let -- lookup the node + Just node = lookupNode graph u + + -- lookup the available colors for the class of this node. + colors_avail + = case lookupUFM colors (nodeClass node) of + Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) + Just cs -> cs + + -- find colors we can't use because they're already being used + -- by a node that conflicts with this one. + Just nsConflicts + = sequence + $ map (lookupNode graph) + $ uniqSetToList + $ nodeConflicts node + + colors_conflict = mkUniqSet + $ catMaybes + $ map nodeColor nsConflicts + + -- the prefs of our neighbors + colors_neighbor_prefs + = mkUniqSet + $ concat $ map nodePreference nsConflicts + + -- colors that are still valid for us + colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) + colors_ok = minusUniqSet colors_ok_ex colors_conflict + + -- the colors that we prefer, and are still ok + colors_ok_pref = intersectUniqSets + (mkUniqSet $ nodePreference node) colors_ok + + -- the colors that we could choose while being nice to our neighbors + colors_ok_nice = minusUniqSet + colors_ok colors_neighbor_prefs + + -- the best of all possible worlds.. + colors_ok_pref_nice + = intersectUniqSets + colors_ok_nice colors_ok_pref + + -- make the decision + chooseColor + + -- everyone is happy, yay! + | not $ isEmptyUniqSet colors_ok_pref_nice + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) + (nodePreference node) + = Just c + + -- we've got one of our preferences + | not $ isEmptyUniqSet colors_ok_pref + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) + (nodePreference node) + = Just c + + -- it wasn't a preference, but it was still ok + | not $ isEmptyUniqSet colors_ok + , c : _ <- uniqSetToList colors_ok + = Just c + + -- no colors were available for us this time. + -- looks like we're going around the loop again.. + | otherwise + = Nothing + + in chooseColor diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs index 69d4943fb0..7bf3ecdffb 100644 --- a/compiler/utils/GraphOps.hs +++ b/compiler/utils/GraphOps.hs @@ -1,28 +1,20 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Basic operations on graphs. -- module GraphOps ( - addNode, delNode, getNode, lookupNode, modNode, - size, - union, - addConflict, delConflict, addConflicts, - addCoalesce, delCoalesce, - addExclusion, addExclusions, - addPreference, - coalesceNodes, coalesceGraph, - freezeNode, freezeOneInGraph, freezeAllInGraph, - scanGraph, - setColor, - validateGraph, - slurpNodeConflictCount + addNode, delNode, getNode, lookupNode, modNode, + size, + union, + addConflict, delConflict, addConflicts, + addCoalesce, delCoalesce, + addExclusion, addExclusions, + addPreference, + coalesceNodes, coalesceGraph, + freezeNode, freezeOneInGraph, freezeAllInGraph, + scanGraph, + setColor, + validateGraph, + slurpNodeConflictCount ) where @@ -33,610 +25,641 @@ import Unique import UniqSet import UniqFM -import Data.List hiding (union) +import Data.List hiding (union) import Data.Maybe -- | Lookup a node from the graph. -lookupNode - :: Uniquable k - => Graph k cls color - -> k -> Maybe (Node k cls color) +lookupNode + :: Uniquable k + => Graph k cls color + -> k -> Maybe (Node k cls color) -lookupNode graph k - = lookupUFM (graphMap graph) k +lookupNode graph k + = lookupUFM (graphMap graph) k -- | Get a node from the graph, throwing an error if it's not there getNode - :: Uniquable k - => Graph k cls color - -> k -> Node k cls color + :: Uniquable k + => Graph k cls color + -> k -> Node k cls color getNode graph k = case lookupUFM (graphMap graph) k of - Just node -> node - Nothing -> panic "ColorOps.getNode: not found" + Just node -> node + Nothing -> panic "ColorOps.getNode: not found" -- | Add a node to the graph, linking up its edges addNode :: Uniquable k - => k -> Node k cls color - -> Graph k cls color -> Graph k cls color - + => k -> Node k cls color + -> Graph k cls color -> Graph k cls color + addNode k node graph - = let - -- add back conflict edges from other nodes to this one - map_conflict - = foldUniqSet - (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) - (graphMap graph) - (nodeConflicts node) - - -- add back coalesce edges from other nodes to this one - map_coalesce - = foldUniqSet - (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) - map_conflict - (nodeCoalesce node) - - in graph - { graphMap = addToUFM map_coalesce k node} - + = let + -- add back conflict edges from other nodes to this one + map_conflict + = foldUniqSet + (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) + (graphMap graph) + (nodeConflicts node) + + -- add back coalesce edges from other nodes to this one + map_coalesce + = foldUniqSet + (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) + map_conflict + (nodeCoalesce node) + + in graph + { graphMap = addToUFM map_coalesce k node} + -- | Delete a node and all its edges from the graph. delNode :: (Uniquable k, Outputable k) - => k -> Graph k cls color -> Maybe (Graph k cls color) + => k -> Graph k cls color -> Maybe (Graph k cls color) delNode k graph - | Just node <- lookupNode graph k - = let -- delete conflict edges from other nodes to this one. - graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph - $ uniqSetToList (nodeConflicts node) - - -- delete coalesce edge from other nodes to this one. - graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 - $ uniqSetToList (nodeCoalesce node) - - -- delete the node - graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 - - in Just graph3 - - | otherwise - = Nothing + | Just node <- lookupNode graph k + = let -- delete conflict edges from other nodes to this one. + graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph + $ uniqSetToList (nodeConflicts node) + + -- delete coalesce edge from other nodes to this one. + graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 + $ uniqSetToList (nodeCoalesce node) + + -- delete the node + graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 + + in Just graph3 + + | otherwise + = Nothing -- | Modify a node in the graph. --- returns Nothing if the node isn't present. +-- returns Nothing if the node isn't present. -- modNode :: Uniquable k - => (Node k cls color -> Node k cls color) - -> k -> Graph k cls color -> Maybe (Graph k cls color) + => (Node k cls color -> Node k cls color) + -> k -> Graph k cls color -> Maybe (Graph k cls color) modNode f k graph = case lookupNode graph k of - Just Node{} - -> Just - $ graphMapModify - (\fm -> let Just node = lookupUFM fm k - node' = f node - in addToUFM fm k node') - graph + Just Node{} + -> Just + $ graphMapModify + (\fm -> let Just node = lookupUFM fm k + node' = f node + in addToUFM fm k node') + graph - Nothing -> Nothing + Nothing -> Nothing -- | Get the size of the graph, O(n) -size :: Uniquable k - => Graph k cls color -> Int - -size graph - = sizeUFM $ graphMap graph - +size :: Uniquable k + => Graph k cls color -> Int + +size graph + = sizeUFM $ graphMap graph + -- | Union two graphs together. -union :: Uniquable k - => Graph k cls color -> Graph k cls color -> Graph k cls color - -union graph1 graph2 - = Graph - { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } +union :: Uniquable k + => Graph k cls color -> Graph k cls color -> Graph k cls color + +union graph1 graph2 + = Graph + { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } -- | Add a conflict between nodes to the graph, creating the nodes required. --- Conflicts are virtual regs which need to be colored differently. +-- Conflicts are virtual regs which need to be colored differently. addConflict - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color addConflict (u1, c1) (u2, c2) - = let addNeighbor u c u' - = adjustWithDefaultUFM - (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) - (newNode u c) { nodeConflicts = unitUniqSet u' } - u - - in graphMapModify - ( addNeighbor u1 c1 u2 - . addNeighbor u2 c2 u1) - - + = let addNeighbor u c u' + = adjustWithDefaultUFM + (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) + (newNode u c) { nodeConflicts = unitUniqSet u' } + u + + in graphMapModify + ( addNeighbor u1 c1 u2 + . addNeighbor u2 c2 u1) + + -- | Delete a conflict edge. k1 -> k2 --- returns Nothing if the node isn't in the graph -delConflict - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) - +-- returns Nothing if the node isn't in the graph +delConflict + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + delConflict k1 k2 - = modNode - (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) - k1 + = modNode + (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) + k1 -- | Add some conflicts to the graph, creating nodes if required. --- All the nodes in the set are taken to conflict with each other. +-- All the nodes in the set are taken to conflict with each other. addConflicts - :: Uniquable k - => UniqSet k -> (k -> cls) - -> Graph k cls color -> Graph k cls color - -addConflicts conflicts getClass - - -- just a single node, but no conflicts, create the node anyway. - | (u : []) <- uniqSetToList conflicts - = graphMapModify - $ adjustWithDefaultUFM - id - (newNode u (getClass u)) - u - - | otherwise - = graphMapModify - $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm - $ uniqSetToList conflicts) + :: Uniquable k + => UniqSet k -> (k -> cls) + -> Graph k cls color -> Graph k cls color +addConflicts conflicts getClass -addConflictSet1 u getClass set + -- just a single node, but no conflicts, create the node anyway. + | (u : []) <- uniqSetToList conflicts + = graphMapModify + $ adjustWithDefaultUFM + id + (newNode u (getClass u)) + u + + | otherwise + = graphMapModify + $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm + $ uniqSetToList conflicts) + + +addConflictSet1 :: Uniquable k + => k -> (k -> cls) -> UniqSet k + -> UniqFM (Node k cls color) + -> UniqFM (Node k cls color) +addConflictSet1 u getClass set = case delOneFromUniqSet set u of set' -> adjustWithDefaultUFM - (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) - (newNode u (getClass u)) { nodeConflicts = set' } - u + (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) + (newNode u (getClass u)) { nodeConflicts = set' } + u -- | Add an exclusion to the graph, creating nodes if required. --- These are extra colors that the node cannot use. +-- These are extra colors that the node cannot use. addExclusion - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> color - -> Graph k cls color -> Graph k cls color - -addExclusion u getClass color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) - (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } - u + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> color + -> Graph k cls color -> Graph k cls color + +addExclusion u getClass color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) + (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } + u addExclusions - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> [color] - -> Graph k cls color -> Graph k cls color + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> [color] + -> Graph k cls color -> Graph k cls color addExclusions u getClass colors graph - = foldr (addExclusion u getClass) graph colors + = foldr (addExclusion u getClass) graph colors -- | Add a coalescence edge to the graph, creating nodes if requried. --- It is considered adventageous to assign the same color to nodes in a coalesence. -addCoalesce - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color - -addCoalesce (u1, c1) (u2, c2) - = let addCoalesce u c u' - = adjustWithDefaultUFM - (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) - (newNode u c) { nodeCoalesce = unitUniqSet u' } - u - - in graphMapModify - ( addCoalesce u1 c1 u2 +-- It is considered adventageous to assign the same color to nodes in a coalesence. +addCoalesce + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addCoalesce (u1, c1) (u2, c2) + = let addCoalesce u c u' + = adjustWithDefaultUFM + (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) + (newNode u c) { nodeCoalesce = unitUniqSet u' } + u + + in graphMapModify + ( addCoalesce u1 c1 u2 . addCoalesce u2 c2 u1) -- | Delete a coalescence edge (k1 -> k2) from the graph. delCoalesce - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) delCoalesce k1 k2 - = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) - k1 + = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) + k1 -- | Add a color preference to the graph, creating nodes if required. --- The most recently added preference is the most prefered. --- The algorithm tries to assign a node it's prefered color if possible. +-- The most recently added preference is the most prefered. +-- The algorithm tries to assign a node it's prefered color if possible. -- -addPreference - :: Uniquable k - => (k, cls) -> color - -> Graph k cls color -> Graph k cls color - -addPreference (u, c) color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodePreference = color : (nodePreference node) }) - (newNode u c) { nodePreference = [color] } - u +addPreference + :: Uniquable k + => (k, cls) -> color + -> Graph k cls color -> Graph k cls color + +addPreference (u, c) color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodePreference = color : (nodePreference node) }) + (newNode u c) { nodePreference = [color] } + u -- | Do agressive coalescing on this graph. --- returns the new graph and the list of pairs of nodes that got coaleced together. --- for each pair, the resulting node will have the least key and be second in the pair. +-- returns the new graph and the list of pairs of nodes that got coaleced together. +-- for each pair, the resulting node will have the least key and be second in the pair. -- coalesceGraph - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> ( Graph k cls color - , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the - -- coalescing was applied. + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> ( Graph k cls color + , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the + -- coalescing was applied. coalesceGraph aggressive triv graph - = coalesceGraph' aggressive triv graph [] - + = coalesceGraph' aggressive triv graph [] + +coalesceGraph' + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> [(k, k)] + -> ( Graph k cls color + , [(k, k)]) coalesceGraph' aggressive triv graph kkPairsAcc = let - -- find all the nodes that have coalescence edges - cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) - $ eltsUFM $ graphMap graph - - -- build a list of pairs of keys for node's we'll try and coalesce - -- every pair of nodes will appear twice in this list - -- ie [(k1, k2), (k2, k1) ... ] - -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for - -- build a list of what nodes get coalesced together for later on. - -- - cList = [ (nodeId node1, k2) - | node1 <- cNodes - , k2 <- uniqSetToList $ nodeCoalesce node1 ] - - -- do the coalescing, returning the new graph and a list of pairs of keys - -- that got coalesced together. - (graph', mPairs) - = mapAccumL (coalesceNodes aggressive triv) graph cList - - -- keep running until there are no more coalesces can be found - in case catMaybes mPairs of - [] -> (graph', reverse kkPairsAcc) - pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) + -- find all the nodes that have coalescence edges + cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) + $ eltsUFM $ graphMap graph + + -- build a list of pairs of keys for node's we'll try and coalesce + -- every pair of nodes will appear twice in this list + -- ie [(k1, k2), (k2, k1) ... ] + -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for + -- build a list of what nodes get coalesced together for later on. + -- + cList = [ (nodeId node1, k2) + | node1 <- cNodes + , k2 <- uniqSetToList $ nodeCoalesce node1 ] + + -- do the coalescing, returning the new graph and a list of pairs of keys + -- that got coalesced together. + (graph', mPairs) + = mapAccumL (coalesceNodes aggressive triv) graph cList + + -- keep running until there are no more coalesces can be found + in case catMaybes mPairs of + [] -> (graph', reverse kkPairsAcc) + pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) -- | Coalesce this pair of nodes unconditionally \/ agressively. --- The resulting node is the one with the least key. +-- The resulting node is the one with the least key. -- --- returns: Just the pair of keys if the nodes were coalesced --- the second element of the pair being the least one +-- returns: Just the pair of keys if the nodes were coalesced +-- the second element of the pair being the least one -- --- Nothing if either of the nodes weren't in the graph +-- Nothing if either of the nodes weren't in the graph coalesceNodes - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> (k, k) -- ^ keys of the nodes to be coalesced - -> (Graph k cls color, Maybe (k, k)) + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> (k, k) -- ^ keys of the nodes to be coalesced + -> (Graph k cls color, Maybe (k, k)) coalesceNodes aggressive triv graph (k1, k2) - | (kMin, kMax) <- if k1 < k2 - then (k1, k2) - else (k2, k1) - - -- the nodes being coalesced must be in the graph - , Just nMin <- lookupNode graph kMin - , Just nMax <- lookupNode graph kMax - - -- can't coalesce conflicting modes - , not $ elementOfUniqSet kMin (nodeConflicts nMax) - , not $ elementOfUniqSet kMax (nodeConflicts nMin) - - -- can't coalesce the same node - , nodeId nMin /= nodeId nMax - - = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + | (kMin, kMax) <- if k1 < k2 + then (k1, k2) + else (k2, k1) - -- don't do the coalescing after all - | otherwise - = (graph, Nothing) + -- the nodes being coalesced must be in the graph + , Just nMin <- lookupNode graph kMin + , Just nMax <- lookupNode graph kMax -coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - - -- sanity checks - | nodeClass nMin /= nodeClass nMax - = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes." + -- can't coalesce conflicting modes + , not $ elementOfUniqSet kMin (nodeConflicts nMax) + , not $ elementOfUniqSet kMax (nodeConflicts nMin) - | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) - = error "GraphOps.coalesceNodes: can't coalesce colored nodes." + -- can't coalesce the same node + , nodeId nMin /= nodeId nMax - --- - | otherwise - = let - -- the new node gets all the edges from its two components - node = - Node { nodeId = kMin - , nodeClass = nodeClass nMin - , nodeColor = Nothing + = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - -- nodes don't conflict with themselves.. - , nodeConflicts - = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax + -- don't do the coalescing after all + | otherwise + = (graph, Nothing) - , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) - , nodePreference = nodePreference nMin ++ nodePreference nMax +coalesceNodes_merge + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) - -- nodes don't coalesce with themselves.. - , nodeCoalesce - = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax - } +coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - in coalesceNodes_check aggressive triv graph kMin kMax node + -- sanity checks + | nodeClass nMin /= nodeClass nMax + = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes." + + | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) + = error "GraphOps.coalesceNodes: can't coalesce colored nodes." + + --- + | otherwise + = let + -- the new node gets all the edges from its two components + node = + Node { nodeId = kMin + , nodeClass = nodeClass nMin + , nodeColor = Nothing + + -- nodes don't conflict with themselves.. + , nodeConflicts + = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + + , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) + , nodePreference = nodePreference nMin ++ nodePreference nMax + + -- nodes don't coalesce with themselves.. + , nodeCoalesce + = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + } + + in coalesceNodes_check aggressive triv graph kMin kMax node + +coalesceNodes_check + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) coalesceNodes_check aggressive triv graph kMin kMax node - -- Unless we're coalescing aggressively, if the result node is not trivially - -- colorable then don't do the coalescing. - | not aggressive - , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - = (graph, Nothing) + -- Unless we're coalescing aggressively, if the result node is not trivially + -- colorable then don't do the coalescing. + | not aggressive + , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = (graph, Nothing) - | otherwise - = let -- delete the old nodes from the graph and add the new one - Just graph1 = delNode kMax graph - Just graph2 = delNode kMin graph1 - graph3 = addNode kMin node graph2 + | otherwise + = let -- delete the old nodes from the graph and add the new one + Just graph1 = delNode kMax graph + Just graph2 = delNode kMin graph1 + graph3 = addNode kMin node graph2 - in (graph3, Just (kMax, kMin)) + in (graph3, Just (kMax, kMin)) -- | Freeze a node --- This is for the iterative coalescer. --- By freezing a node we give up on ever coalescing it. --- Move all its coalesce edges into the frozen set - and update --- back edges from other nodes. +-- This is for the iterative coalescer. +-- By freezing a node we give up on ever coalescing it. +-- Move all its coalesce edges into the frozen set - and update +-- back edges from other nodes. -- freezeNode - :: Uniquable k - => k -- ^ key of the node to freeze - -> Graph k cls color -- ^ the graph - -> Graph k cls color -- ^ graph with that node frozen + :: Uniquable k + => k -- ^ key of the node to freeze + -> Graph k cls color -- ^ the graph + -> Graph k cls color -- ^ graph with that node frozen freezeNode k = graphMapModify $ \fm -> - let -- freeze all the edges in the node to be frozen - Just node = lookupUFM fm k - node' = node - { nodeCoalesce = emptyUniqSet } + let -- freeze all the edges in the node to be frozen + Just node = lookupUFM fm k + node' = node + { nodeCoalesce = emptyUniqSet } - fm1 = addToUFM fm k node' + fm1 = addToUFM fm k node' - -- update back edges pointing to this node - freezeEdge k node - = if elementOfUniqSet k (nodeCoalesce node) - then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } - else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" - -- If the edge isn't actually in the coelesce set then just ignore it. + -- update back edges pointing to this node + freezeEdge k node + = if elementOfUniqSet k (nodeCoalesce node) + then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } + else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" + -- If the edge isn't actually in the coelesce set then just ignore it. - fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 - $ nodeCoalesce node + fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 + $ nodeCoalesce node - in fm2 + in fm2 -- | Freeze one node in the graph --- This if for the iterative coalescer. --- Look for a move related node of low degree and freeze it. +-- This if for the iterative coalescer. +-- Look for a move related node of low degree and freeze it. -- --- We probably don't need to scan the whole graph looking for the node of absolute --- lowest degree. Just sample the first few and choose the one with the lowest --- degree out of those. Also, we don't make any distinction between conflicts of different --- classes.. this is just a heuristic, after all. +-- We probably don't need to scan the whole graph looking for the node of absolute +-- lowest degree. Just sample the first few and choose the one with the lowest +-- degree out of those. Also, we don't make any distinction between conflicts of different +-- classes.. this is just a heuristic, after all. -- --- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv --- right here, and add it to a worklist if known triv\/non-move nodes. +-- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv +-- right here, and add it to a worklist if known triv\/non-move nodes. -- freezeOneInGraph - :: (Uniquable k, Outputable k) - => Graph k cls color - -> ( Graph k cls color -- the new graph - , Bool ) -- whether we found a node to freeze + :: (Uniquable k, Outputable k) + => Graph k cls color + -> ( Graph k cls color -- the new graph + , Bool ) -- whether we found a node to freeze freezeOneInGraph graph - = let compareNodeDegree n1 n2 - = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) + = let compareNodeDegree n1 n2 + = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) - candidates - = sortBy compareNodeDegree - $ take 5 -- 5 isn't special, it's just a small number. - $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph + candidates + = sortBy compareNodeDegree + $ take 5 -- 5 isn't special, it's just a small number. + $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph - in case candidates of + in case candidates of - -- there wasn't anything available to freeze - [] -> (graph, False) + -- there wasn't anything available to freeze + [] -> (graph, False) - -- we found something to freeze - (n : _) - -> ( freezeNode (nodeId n) graph - , True) + -- we found something to freeze + (n : _) + -> ( freezeNode (nodeId n) graph + , True) -- | Freeze all the nodes in the graph --- for debugging the iterative allocator. +-- for debugging the iterative allocator. -- freezeAllInGraph - :: (Uniquable k, Outputable k) - => Graph k cls color - -> Graph k cls color + :: (Uniquable k, Outputable k) + => Graph k cls color + -> Graph k cls color freezeAllInGraph graph - = foldr freezeNode graph - $ map nodeId - $ eltsUFM $ graphMap graph + = foldr freezeNode graph + $ map nodeId + $ eltsUFM $ graphMap graph -- | Find all the nodes in the graph that meet some criteria -- scanGraph - :: Uniquable k - => (Node k cls color -> Bool) - -> Graph k cls color - -> [Node k cls color] + :: Uniquable k + => (Node k cls color -> Bool) + -> Graph k cls color + -> [Node k cls color] scanGraph match graph - = filter match $ eltsUFM $ graphMap graph + = filter match $ eltsUFM $ graphMap graph -- | validate the internal structure of a graph --- all its edges should point to valid nodes --- If they don't then throw an error +-- all its edges should point to valid nodes +-- If they don't then throw an error -- validateGraph - :: (Uniquable k, Outputable k, Eq color) - => SDoc -- ^ extra debugging info to display on error - -> Bool -- ^ whether this graph is supposed to be colored. - -> Graph k cls color -- ^ graph to validate - -> Graph k cls color -- ^ validated graph + :: (Uniquable k, Outputable k, Eq color) + => SDoc -- ^ extra debugging info to display on error + -> Bool -- ^ whether this graph is supposed to be colored. + -> Graph k cls color -- ^ graph to validate + -> Graph k cls color -- ^ validated graph validateGraph doc isColored graph - -- Check that all edges point to valid nodes. - | edges <- unionManyUniqSets - ( (map nodeConflicts $ eltsUFM $ graphMap graph) - ++ (map nodeCoalesce $ eltsUFM $ graphMap graph)) - - , nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph - , badEdges <- minusUniqSet edges nodes - , not $ isEmptyUniqSet badEdges - = pprPanic "GraphOps.validateGraph" - ( text "Graph has edges that point to non-existant nodes" - $$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges) - $$ doc ) - - -- Check that no conflicting nodes have the same color - | badNodes <- filter (not . (checkNode graph)) - $ eltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Node has same color as one of it's conflicts" - $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc) - - -- If this is supposed to be a colored graph, - -- check that all nodes have a color. - | isColored - , badNodes <- filter (\n -> isNothing $ nodeColor n) - $ eltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Supposably colored graph has uncolored nodes." - $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc ) - - - -- graph looks ok - | otherwise - = graph + -- Check that all edges point to valid nodes. + | edges <- unionManyUniqSets + ( (map nodeConflicts $ eltsUFM $ graphMap graph) + ++ (map nodeCoalesce $ eltsUFM $ graphMap graph)) + + , nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph + , badEdges <- minusUniqSet edges nodes + , not $ isEmptyUniqSet badEdges + = pprPanic "GraphOps.validateGraph" + ( text "Graph has edges that point to non-existant nodes" + $$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges) + $$ doc ) + + -- Check that no conflicting nodes have the same color + | badNodes <- filter (not . (checkNode graph)) + $ eltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GraphOps.validateGraph" + ( text "Node has same color as one of it's conflicts" + $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc) + + -- If this is supposed to be a colored graph, + -- check that all nodes have a color. + | isColored + , badNodes <- filter (\n -> isNothing $ nodeColor n) + $ eltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GraphOps.validateGraph" + ( text "Supposably colored graph has uncolored nodes." + $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc ) + + + -- graph looks ok + | otherwise + = graph -- | If this node is colored, check that all the nodes which --- conflict with it have different colors. +-- conflict with it have different colors. checkNode - :: (Uniquable k, Eq color) - => Graph k cls color - -> Node k cls color - -> Bool -- ^ True if this node is ok - + :: (Uniquable k, Eq color) + => Graph k cls color + -> Node k cls color + -> Bool -- ^ True if this node is ok + checkNode graph node - | Just color <- nodeColor node - , Just neighbors <- sequence $ map (lookupNode graph) - $ uniqSetToList $ nodeConflicts node + | Just color <- nodeColor node + , Just neighbors <- sequence $ map (lookupNode graph) + $ uniqSetToList $ nodeConflicts node + + , neighbourColors <- catMaybes $ map nodeColor neighbors + , elem color neighbourColors + = False - , neighbourColors <- catMaybes $ map nodeColor neighbors - , elem color neighbourColors - = False - - | otherwise - = True + | otherwise + = True -- | Slurp out a map of how many nodes had a certain number of conflict neighbours slurpNodeConflictCount - :: Uniquable k - => Graph k cls color - -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) + :: Uniquable k + => Graph k cls color + -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) slurpNodeConflictCount graph - = addListToUFM_C - (\(c1, n1) (_, n2) -> (c1, n1 + n2)) - emptyUFM - $ map (\node - -> let count = sizeUniqSet $ nodeConflicts node - in (count, (count, 1))) - $ eltsUFM - $ graphMap graph + = addListToUFM_C + (\(c1, n1) (_, n2) -> (c1, n1 + n2)) + emptyUFM + $ map (\node + -> let count = sizeUniqSet $ nodeConflicts node + in (count, (count, 1))) + $ eltsUFM + $ graphMap graph -- | Set the color of a certain node -setColor - :: Uniquable k - => k -> color - -> Graph k cls color -> Graph k cls color - +setColor + :: Uniquable k + => k -> color + -> Graph k cls color -> Graph k cls color + setColor u color - = graphMapModify - $ adjustUFM_C - (\n -> n { nodeColor = Just color }) - u - - -{-# INLINE adjustWithDefaultUFM #-} -adjustWithDefaultUFM - :: Uniquable k - => (a -> a) -> a -> k - -> UniqFM a -> UniqFM a + = graphMapModify + $ adjustUFM_C + (\n -> n { nodeColor = Just color }) + u + + +{-# INLINE adjustWithDefaultUFM #-} +adjustWithDefaultUFM + :: Uniquable k + => (a -> a) -> a -> k + -> UniqFM a -> UniqFM a adjustWithDefaultUFM f def k map - = addToUFM_C - (\old _ -> f old) - map - k def - + = addToUFM_C + (\old _ -> f old) + map + k def + -- Argument order different from UniqFM's adjustUFM {-# INLINE adjustUFM_C #-} -adjustUFM_C - :: Uniquable k - => (a -> a) - -> k -> UniqFM a -> UniqFM a +adjustUFM_C + :: Uniquable k + => (a -> a) + -> k -> UniqFM a -> UniqFM a adjustUFM_C f k map = case lookupUFM map k of - Nothing -> map - Just a -> addToUFM map k (f a) + Nothing -> map + Just a -> addToUFM map k (f a) diff --git a/compiler/utils/ListSetOps.lhs b/compiler/utils/ListSetOps.lhs index 2c6c6b0b6c..077eae2574 100644 --- a/compiler/utils/ListSetOps.lhs +++ b/compiler/utils/ListSetOps.lhs @@ -5,28 +5,16 @@ \section[ListSetOps]{Set-like operations on lists} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module ListSetOps ( unionLists, minusList, insertList, -- Association lists Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, - emptyAssoc, unitAssoc, mapAssoc, plusAssoc_C, extendAssoc_C, - mkLookupFun, findInList, assocElts, -- Duplicate handling hasNoDups, runs, removeDups, findDupsEq, equivClasses, equivClassesByUniq, - - -- Remove redudant elts - removeRedundant -- Used in the ghc/InteractiveUI, - -- although not in the compiler itself ) where #include "HsVersions.h" @@ -77,22 +65,11 @@ Inefficient finite maps based on association lists and equality. -- A finite mapping based on equality and association lists type Assoc a b = [(a,b)] -emptyAssoc :: Assoc a b -unitAssoc :: a -> b -> Assoc a b -assocElts :: Assoc a b -> [(a,b)] assoc :: (Eq a) => String -> Assoc a b -> a -> b assocDefault :: (Eq a) => b -> Assoc a b -> a -> b assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b -mapAssoc :: (b -> c) -> Assoc a b -> Assoc a c -extendAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> (a,b) -> Assoc a b -plusAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> Assoc a b -> Assoc a b - -- combining fn takes (old->new->result) - -emptyAssoc = [] -unitAssoc a b = [(a,b)] -assocElts xs = xs assocDefaultUsing _ deflt [] _ = deflt assocDefaultUsing eq deflt ((k,v) : rest) key @@ -108,45 +85,8 @@ assocMaybe alist key where lookup [] = Nothing lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest - -mapAssoc f alist = [(key, f val) | (key,val) <- alist] - -plusAssoc_C _ [] new = new -- Shortcut for common case -plusAssoc_C combine old new = foldl (extendAssoc_C combine) old new - -extendAssoc_C combine old_list (new_key, new_val) - = go old_list - where - go [] = [(new_key, new_val)] - go ((old_key, old_val) : old_list) - | new_key == old_key = ((old_key, old_val `combine` new_val) : old_list) - | otherwise = (old_key, old_val) : go old_list -\end{code} - - -@mkLookupFun eq alist@ is a function which looks up -its argument in the association list @alist@, returning a Maybe type. -@mkLookupFunDef@ is similar except that it is given a value to return -on failure. - -\begin{code} -mkLookupFun :: (key -> key -> Bool) -- Equality predicate - -> [(key,val)] -- The assoc list - -> key -- The key - -> Maybe val -- The corresponding value - -mkLookupFun eq alist s - = case [a | (s',a) <- alist, s' `eq` s] of - [] -> Nothing - (a:_) -> Just a - -findInList :: (a -> Bool) -> [a] -> Maybe a -findInList _ [] = Nothing -findInList p (x:xs) | p x = Just x - | otherwise = findInList p xs \end{code} - %************************************************************************ %* * \subsection[Utils-dups]{Duplicate-handling} @@ -173,10 +113,9 @@ equivClasses :: (a -> a -> Ordering) -- Comparison equivClasses _ [] = [] equivClasses _ stuff@[_] = [stuff] -equivClasses cmp items = runs eq (sortLe le items) +equivClasses cmp items = runs eq (sortBy cmp items) where eq a b = case cmp a b of { EQ -> True; _ -> False } - le a b = case cmp a b of { LT -> True; EQ -> True; GT -> False } \end{code} The first cases in @equivClasses@ above are just to cut to the point @@ -218,22 +157,6 @@ findDupsEq _ [] = [] findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs | otherwise = (x:eq_xs) : findDupsEq eq neq_xs where (eq_xs, neq_xs) = partition (eq x) xs - -removeRedundant :: (a -> a -> Bool) -- True <=> discard the *second* argument - -> [a] -> [a] --- Remove any element y for which --- another element x is in the list --- and (x `subsumes` y) --- Preserves order -removeRedundant subsumes xs - = WARN( length xs > 10, text "removeRedundant" <+> int (length xs) ) - -- This is a quadratic algorithm :-) so warn if the list gets long - go [] xs - where - go acc [] = reverse acc - go acc (x:xs) - | any (`subsumes` x) acc = go acc xs - | otherwise = go (x : filterOut (x `subsumes`) acc) xs \end{code} diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs index 3108a03d64..6f15ecc03d 100644 --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -16,8 +16,6 @@ module MonadUtils , MonadFix(..) , MonadIO(..) - , ID, runID - , liftIO1, liftIO2, liftIO3, liftIO4 , zipWith3M @@ -32,8 +30,6 @@ module MonadUtils , maybeMapM ) where -import Outputable - ------------------------------------------------------------------------------- -- Detection of available libraries ------------------------------------------------------------------------------- @@ -55,20 +51,6 @@ import Control.Monad import Control.Monad.Fix ------------------------------------------------------------------------------- --- The ID monad -------------------------------------------------------------------------------- - -newtype ID a = ID a -instance Monad ID where - return x = ID x - (ID x) >>= f = f x - _ >> y = y - fail s = panic s - -runID :: ID a -> a -runID (ID x) = x - -------------------------------------------------------------------------------- -- MTL ------------------------------------------------------------------------------- diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index c506e23410..7ffce77a47 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -13,7 +13,6 @@ module Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), - PlatformOutputable(..), -- * Pretty printing combinators SDoc, runSDoc, initSDocContext, @@ -23,7 +22,8 @@ module Outputable ( char, text, ftext, ptext, int, intWithCommas, integer, float, double, rational, - parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, + parens, cparen, brackets, braces, quotes, quote, + doubleQuotes, angleBrackets, paBrackets, semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, blankLine, @@ -38,13 +38,13 @@ module Outputable ( colBinder, bold, keyword, -- * Converting 'SDoc' into strings and outputing it - printSDoc, printErrs, printOutput, hPrintDump, printDump, + hPrintDump, printForC, printForAsm, printForUser, printForUserPartWay, pprCode, mkCodeStyle, showSDoc, showSDocOneLine, showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, showPpr, - showSDocUnqual, showsPrecSDoc, + showSDocUnqual, renderWithStyle, pprInfixVar, pprPrefixVar, @@ -56,6 +56,7 @@ module Outputable ( PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify, QualifyName(..), + sdocWithDynFlags, sdocWithPlatform, getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, @@ -66,18 +67,21 @@ module Outputable ( -- * Error handling and debugging utilities pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, pprTrace, pprDefiniteTrace, warnPprTrace, - trace, pgmError, panic, sorry, panicFastInt, assertPanic + trace, pgmError, panic, sorry, panicFastInt, assertPanic, + pprDebugAndThen, ) where +import {-# SOURCE #-} DynFlags( DynFlags, tracingDynFlags, + targetPlatform, pprUserLength, pprCols ) import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) import {-# SOURCE #-} Name( Name, nameModule ) import StaticFlags import FastString import FastTypes -import Platform import qualified Pretty -import Util ( snocView ) +import Util +import Platform import Pretty ( Doc, Mode(..) ) import Panic @@ -87,7 +91,7 @@ import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set import Data.Word -import System.IO ( Handle, stderr, stdout, hFlush ) +import System.IO ( Handle, hFlush ) import System.FilePath @@ -192,16 +196,17 @@ defaultDumpStyle | opt_PprStyle_Debug = PprDebug | otherwise = PprDump -- | Style for printing error messages -mkErrStyle :: PrintUnqualified -> PprStyle -mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength) +mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle +mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags)) -defaultErrStyle :: PprStyle +defaultErrStyle :: DynFlags -> PprStyle -- Default style for error messages -- It's a bit of a hack because it doesn't take into account what's in scope -- Only used for desugarer warnings, and typechecker errors in interface sigs -defaultErrStyle - | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay - | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength) +defaultErrStyle dflags = mkUserStyle alwaysQualify depth + where depth = if opt_PprStyle_Debug + then AllTheWay + else PartWay (pprUserLength dflags) mkUserStyle :: PrintUnqualified -> Depth -> PprStyle mkUserStyle unqual depth @@ -233,19 +238,21 @@ data SDocContext = SDC { sdocStyle :: !PprStyle , sdocLastColour :: !PprColour -- ^ The most recently used colour. This allows nesting colours. + , sdocDynFlags :: !DynFlags } -initSDocContext :: PprStyle -> SDocContext -initSDocContext sty = SDC +initSDocContext :: DynFlags -> PprStyle -> SDocContext +initSDocContext dflags sty = SDC { sdocStyle = sty , sdocLastColour = colReset + , sdocDynFlags = dflags } withPprStyle :: PprStyle -> SDoc -> SDoc withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} -withPprStyleDoc :: PprStyle -> SDoc -> Doc -withPprStyleDoc sty d = runSDoc d (initSDocContext sty) +withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc +withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty) pprDeeper :: SDoc -> SDoc pprDeeper d = SDoc $ \ctx -> case ctx of @@ -278,6 +285,12 @@ pprSetDepth depth doc = SDoc $ \ctx -> getPprStyle :: (PprStyle -> SDoc) -> SDoc getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx + +sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc +sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx + +sdocWithPlatform :: (Platform -> SDoc) -> SDoc +sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) \end{code} \begin{code} @@ -317,53 +330,35 @@ ifPprDebug d = SDoc $ \ctx -> \end{code} \begin{code} --- Unused [7/02 sof] -printSDoc :: SDoc -> PprStyle -> IO () -printSDoc d sty = do - Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty)) - hFlush stdout - --- I'm not sure whether the direct-IO approach of Pretty.printDoc --- above is better or worse than the put-big-string approach here -printErrs :: SDoc -> PprStyle -> IO () -printErrs doc sty = do - Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext sty)) - hFlush stderr - -printOutput :: Doc -> IO () -printOutput doc = Pretty.printDoc PageMode stdout doc - -printDump :: SDoc -> IO () -printDump doc = hPrintDump stdout doc - -hPrintDump :: Handle -> SDoc -> IO () -hPrintDump h doc = do - Pretty.printDoc PageMode h - (runSDoc better_doc (initSDocContext defaultDumpStyle)) +hPrintDump :: DynFlags -> Handle -> SDoc -> IO () +hPrintDump dflags h doc = do + Pretty.printDoc PageMode (pprCols dflags) h + (runSDoc better_doc (initSDocContext dflags defaultDumpStyle)) hFlush h where better_doc = doc $$ blankLine -printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () -printForUser handle unqual doc - = Pretty.printDoc PageMode handle - (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) +printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () +printForUser dflags handle unqual doc + = Pretty.printDoc PageMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay))) -printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO () -printForUserPartWay handle d unqual doc - = Pretty.printDoc PageMode handle - (runSDoc doc (initSDocContext (mkUserStyle unqual (PartWay d)))) +printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc + -> IO () +printForUserPartWay dflags handle d unqual doc + = Pretty.printDoc PageMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d)))) -- printForC, printForAsm do what they sound like -printForC :: Handle -> SDoc -> IO () -printForC handle doc = - Pretty.printDoc LeftMode handle - (runSDoc doc (initSDocContext (PprCode CStyle))) +printForC :: DynFlags -> Handle -> SDoc -> IO () +printForC dflags handle doc = + Pretty.printDoc LeftMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (PprCode CStyle))) -printForAsm :: Handle -> SDoc -> IO () -printForAsm handle doc = - Pretty.printDoc LeftMode handle - (runSDoc doc (initSDocContext (PprCode AsmStyle))) +printForAsm :: DynFlags -> Handle -> SDoc -> IO () +printForAsm dflags handle doc = + Pretty.printDoc LeftMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (PprCode AsmStyle))) pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d @@ -374,48 +369,45 @@ mkCodeStyle = PprCode -- Can't make SDoc an instance of Show because SDoc is just a function type -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string -showSDoc :: SDoc -> String -showSDoc d = +showSDoc :: DynFlags -> SDoc -> String +showSDoc dflags d = Pretty.showDocWith PageMode - (runSDoc d (initSDocContext defaultUserStyle)) + (runSDoc d (initSDocContext dflags defaultUserStyle)) -renderWithStyle :: SDoc -> PprStyle -> String -renderWithStyle sdoc sty = - Pretty.render (runSDoc sdoc (initSDocContext sty)) +renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String +renderWithStyle dflags sdoc sty = + Pretty.render (runSDoc sdoc (initSDocContext dflags sty)) -- This shows an SDoc, but on one line only. It's cheaper than a full -- showSDoc, designed for when we're getting results like "Foo.bar" -- and "foo{uniq strictness}" so we don't want fancy layout anyway. -showSDocOneLine :: SDoc -> String -showSDocOneLine d = - Pretty.showDocWith PageMode - (runSDoc d (initSDocContext defaultUserStyle)) +showSDocOneLine :: DynFlags -> SDoc -> String +showSDocOneLine dflags d + = Pretty.showDocWith PageMode + (runSDoc d (initSDocContext dflags defaultUserStyle)) -showSDocForUser :: PrintUnqualified -> SDoc -> String -showSDocForUser unqual doc = - show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) +showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String +showSDocForUser dflags unqual doc + = show (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay))) -showSDocUnqual :: SDoc -> String +showSDocUnqual :: DynFlags -> SDoc -> String -- Only used in the gruesome isOperator -showSDocUnqual d = - show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay))) - -showsPrecSDoc :: Int -> SDoc -> ShowS -showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle)) +showSDocUnqual dflags d + = show (runSDoc d (initSDocContext dflags (mkUserStyle neverQualify AllTheWay))) -showSDocDump :: SDoc -> String -showSDocDump d = - Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump)) +showSDocDump :: DynFlags -> SDoc -> String +showSDocDump dflags d + = Pretty.showDocWith PageMode (runSDoc d (initSDocContext dflags defaultDumpStyle)) -showSDocDumpOneLine :: SDoc -> String -showSDocDumpOneLine d = - Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump)) +showSDocDumpOneLine :: DynFlags -> SDoc -> String +showSDocDumpOneLine dflags d + = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext dflags PprDump)) -showSDocDebug :: SDoc -> String -showSDocDebug d = show (runSDoc d (initSDocContext PprDebug)) +showSDocDebug :: DynFlags -> SDoc -> String +showSDocDebug dflags d = show (runSDoc d (initSDocContext dflags PprDebug)) -showPpr :: Outputable a => a -> String -showPpr = showSDoc . ppr +showPpr :: Outputable a => DynFlags -> a -> String +showPpr dflags = showSDoc dflags . ppr \end{code} \begin{code} @@ -444,27 +436,31 @@ float n = docToSDoc $ Pretty.float n double n = docToSDoc $ Pretty.double n rational n = docToSDoc $ Pretty.rational n -parens, braces, brackets, quotes, quote, doubleQuotes, angleBrackets :: SDoc -> SDoc +parens, braces, brackets, quotes, quote, + paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc -parens d = SDoc $ Pretty.parens . runSDoc d -braces d = SDoc $ Pretty.braces . runSDoc d -brackets d = SDoc $ Pretty.brackets . runSDoc d -quote d = SDoc $ Pretty.quote . runSDoc d -doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +parens d = SDoc $ Pretty.parens . runSDoc d +braces d = SDoc $ Pretty.braces . runSDoc d +brackets d = SDoc $ Pretty.brackets . runSDoc d +quote d = SDoc $ Pretty.quote . runSDoc d +doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d angleBrackets d = char '<' <> d <> char '>' +paBrackets d = ptext (sLit "[:") <> d <> ptext (sLit ":]") cparen :: Bool -> SDoc -> SDoc cparen b d = SDoc $ Pretty.cparen b . runSDoc d -- 'quotes' encloses something in single quotes... --- but it omits them if the thing ends in a single quote +-- but it omits them if the thing begins or ends in a single quote -- so that we don't get `foo''. Instead we just have foo'. quotes d = SDoc $ \sty -> - let pp_d = runSDoc d sty in - case snocView (show pp_d) of - Just (_, '\'') -> pp_d - _other -> Pretty.quotes pp_d + let pp_d = runSDoc d sty + str = show pp_d + in case (str, snocView str) of + (_, Just (_, '\'')) -> pp_d + ('\'' : _, _) -> pp_d + _other -> Pretty.quotes pp_d semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc @@ -611,13 +607,6 @@ class Outputable a where ppr = pprPrec 0 pprPrec _ = ppr - -class PlatformOutputable a where - pprPlatform :: Platform -> a -> SDoc - pprPlatformPrec :: Platform -> Rational -> a -> SDoc - - pprPlatform platform = pprPlatformPrec platform 0 - pprPlatformPrec platform _ = pprPlatform platform \end{code} \begin{code} @@ -627,8 +616,6 @@ instance Outputable Bool where instance Outputable Int where ppr n = int n -instance PlatformOutputable Int where - pprPlatform _ = ppr instance Outputable Word16 where ppr n = integer $ fromIntegral n @@ -641,29 +628,19 @@ instance Outputable Word where instance Outputable () where ppr _ = text "()" -instance PlatformOutputable () where - pprPlatform _ _ = text "()" instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) -instance (PlatformOutputable a) => PlatformOutputable [a] where - pprPlatform platform xs = brackets (fsep (punctuate comma (map (pprPlatform platform) xs))) instance (Outputable a) => Outputable (Set a) where ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) -instance (PlatformOutputable a, PlatformOutputable b) => PlatformOutputable (a, b) where - pprPlatform platform (x,y) - = parens (sep [pprPlatform platform x <> comma, pprPlatform platform y]) instance Outputable a => Outputable (Maybe a) where ppr Nothing = ptext (sLit "Nothing") ppr (Just x) = ptext (sLit "Just") <+> ppr x -instance PlatformOutputable a => PlatformOutputable (Maybe a) where - pprPlatform _ Nothing = ptext (sLit "Nothing") - pprPlatform platform (Just x) = ptext (sLit "Just") <+> pprPlatform platform x instance (Outputable a, Outputable b) => Outputable (Either a b) where ppr (Left x) = ptext (sLit "Left") <+> ppr x @@ -720,8 +697,6 @@ instance Outputable FastString where instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where ppr m = ppr (M.toList m) -instance (PlatformOutputable key, PlatformOutputable elt) => PlatformOutputable (M.Map key elt) where - pprPlatform platform m = pprPlatform platform (M.toList m) instance (Outputable elt) => Outputable (IM.IntMap elt) where ppr m = ppr (IM.toList m) instance (PlatformOutputable elt) => PlatformOutputable (Set.Set elt) where @@ -920,62 +895,57 @@ plural _ = char 's' pprPanic :: String -> SDoc -> a -- ^ Throw an exception saying "bug in GHC" -pprPanic = pprAndThen panic +pprPanic = panicDoc pprSorry :: String -> SDoc -> a -- ^ Throw an exception saying "this isn't finished yet" -pprSorry = pprAndThen sorry +pprSorry = sorryDoc pprPgmError :: String -> SDoc -> a -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) -pprPgmError = pprAndThen pgmError +pprPgmError = pgmErrorDoc pprTrace :: String -> SDoc -> a -> a -- ^ If debug output is on, show some 'SDoc' on the screen pprTrace str doc x | opt_NoDebugOutput = x - | otherwise = pprAndThen trace str doc x + | otherwise = pprDebugAndThen tracingDynFlags trace str doc x -pprDefiniteTrace :: String -> SDoc -> a -> a +pprDefiniteTrace :: DynFlags -> String -> SDoc -> a -> a -- ^ Same as pprTrace, but show even if -dno-debug-output is on -pprDefiniteTrace str doc x = pprAndThen trace str doc x +pprDefiniteTrace dflags str doc x = pprDebugAndThen dflags trace str doc x pprPanicFastInt :: String -> SDoc -> FastInt -- ^ Specialization of pprPanic that can be safely used with 'FastInt' -pprPanicFastInt heading pretty_msg = - panicFastInt (show (runSDoc doc (initSDocContext PprDebug))) - where - doc = text heading <+> pretty_msg - - -pprAndThen :: (String -> a) -> String -> SDoc -> a -pprAndThen cont heading pretty_msg = - cont (show (runSDoc doc (initSDocContext PprDebug))) - where - doc = sep [text heading, nest 4 pretty_msg] - -assertPprPanic :: String -> Int -> SDoc -> a --- ^ Panic with an assertation failure, recording the given file and line number. --- Should typically be accessed with the ASSERT family of macros -assertPprPanic file line msg - = panic (show (runSDoc doc (initSDocContext PprDebug))) - where - doc = sep [hsep[text "ASSERT failed! file", - text file, - text "line", int line], - msg] +pprPanicFastInt heading pretty_msg = panicDocFastInt heading pretty_msg warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a -- ^ Just warn about an assertion failure, recording the given file and line number. -- Should typically be accessed with the WARN macros +warnPprTrace _ _ _ _ x | not debugIsOn = x warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x + = pprDebugAndThen tracingDynFlags trace str msg x + where + str = showSDoc tracingDynFlags (hsep [text "WARNING: file", text file <> comma, text "line", int line]) + +assertPprPanic :: String -> Int -> SDoc -> a +-- ^ Panic with an assertation failure, recording the given file and line number. +-- Should typically be accessed with the ASSERT family of macros +assertPprPanic file line msg + = pprDebugAndThen tracingDynFlags panic "ASSERT failed!" doc where - doc = sep [hsep [text "WARNING: file", text file, text "line", int line], - msg] + doc = sep [ hsep [ text "file", text file + , text "line", int line ] + , msg ] + +pprDebugAndThen :: DynFlags -> (String -> a) -> String -> SDoc -> a +pprDebugAndThen dflags cont heading pretty_msg + = cont (show (runSDoc doc (initSDocContext dflags PprDebug))) + where + doc = sep [text heading, nest 4 pretty_msg] \end{code} diff --git a/compiler/utils/Outputable.lhs-boot b/compiler/utils/Outputable.lhs-boot new file mode 100644 index 0000000000..e013307ef9 --- /dev/null +++ b/compiler/utils/Outputable.lhs-boot @@ -0,0 +1,7 @@ + +\begin{code} +module Outputable where + +data SDoc +\end{code} + diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index cc3603baeb..a459199fdb 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -8,33 +8,33 @@ It's hard to put these functions anywhere else without causing some unnecessary loops in the module dependency graph. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Panic ( GhcException(..), showGhcException, throwGhcException, handleGhcException, ghcError, progName, pgmError, panic, sorry, panicFastInt, assertPanic, trace, - - Exception.Exception(..), showException, try, tryMost, throwTo, + panicDoc, sorryDoc, panicDocFastInt, pgmErrorDoc, + + Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo, - installSignalHandlers, interruptTargetThread + installSignalHandlers, + pushInterruptTargetThread, popInterruptTargetThread ) where #include "HsVersions.h" +import {-# SOURCE #-} Outputable (SDoc) + import Config import FastTypes import Exception -import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_, - myThreadId ) + +import Control.Concurrent import Data.Dynamic -import Debug.Trace ( trace ) +#if __GLASGOW_HASKELL__ < 705 +import Data.Maybe +#endif +import Debug.Trace ( trace ) import System.IO.Unsafe import System.Exit import System.Environment @@ -51,44 +51,51 @@ import GHC.ConsoleHandler import GHC.Stack #endif --- | GHC's own exception type +#if __GLASGOW_HASKELL__ >= 705 +import System.Mem.Weak ( Weak, deRefWeak ) +#endif + +-- | GHC's own exception type -- error messages all take the form: -- -- @ --- <location>: <error> +-- <location>: <error> -- @ --- --- If the location is on the command line, or in GHC itself, then --- <location>="ghc". All of the error types below correspond to +-- +-- If the location is on the command line, or in GHC itself, then +-- <location>="ghc". All of the error types below correspond to -- a <location> of "ghc", except for ProgramError (where the string is -- assumed to contain a location already, so we don't print one). data GhcException - = PhaseFailed String -- name of phase - ExitCode -- an external phase (eg. cpp) failed + = PhaseFailed String -- name of phase + ExitCode -- an external phase (eg. cpp) failed -- | Some other fatal signal (SIGHUP,SIGTERM) - | Signal Int + | Signal Int -- | Prints the short usage msg after the error - | UsageError String + | UsageError String -- | A problem with the command line arguments, but don't print usage. | CmdLineError String -- | The 'impossible' happened. - | Panic String + | Panic String + | PprPanic String SDoc - -- | The user tickled something that's known not to work yet, + -- | The user tickled something that's known not to work yet, -- but we're not counting it as a bug. | Sorry String + | PprSorry String SDoc -- | An installation problem. | InstallationError String -- | An error in the user's code, probably. - | ProgramError String - deriving (Typeable, Eq) + | ProgramError String + | PprProgramError String SDoc + deriving (Typeable) instance Exception GhcException @@ -113,41 +120,59 @@ short_usage = "Usage: For basic information, try the `--help' option." showException :: Exception e => e -> String showException = show +-- | Show an exception which can possibly throw other exceptions. +-- Used when displaying exception thrown within TH code. +safeShowException :: Exception e => e -> IO String +safeShowException e = do + -- ensure the whole error message is evaluated inside try + r <- try (return $! forceList (showException e)) + case r of + Right msg -> return msg + Left e' -> safeShowException (e' :: SomeException) + where + forceList [] = [] + forceList xs@(x : xt) = x `seq` forceList xt `seq` xs -- | Append a description of the given exception to this string. showGhcException :: GhcException -> String -> String showGhcException exception = case exception of - UsageError str - -> showString str . showChar '\n' . showString short_usage - - PhaseFailed phase code - -> showString "phase `" . showString phase . - showString "' failed (exitcode = " . shows (int_code code) . - showString ")" - - CmdLineError str -> showString str - ProgramError str -> showString str - InstallationError str -> showString str - Signal n -> showString "signal: " . shows n - - Panic s - -> showString $ - "panic! (the 'impossible' happened)\n" - ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" - ++ s ++ "\n\n" - ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n" - - Sorry s - -> showString $ - "sorry! (unimplemented feature or known bug)\n" - ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" - ++ s ++ "\n" - - where int_code code = - case code of - ExitSuccess -> (0::Int) - ExitFailure x -> x + UsageError str + -> showString str . showChar '\n' . showString short_usage + + PhaseFailed phase code + -> showString "phase `" . showString phase . + showString "' failed (exitcode = " . shows (int_code code) . + showString ")" + + CmdLineError str -> showString str + PprProgramError str _ -> + showGhcException (ProgramError (str ++ "\n<<details unavailable>>")) + ProgramError str -> showString str + InstallationError str -> showString str + Signal n -> showString "signal: " . shows n + + PprPanic s _ -> + showGhcException (Panic (s ++ "\n<<details unavailable>>")) + Panic s + -> showString $ + "panic! (the 'impossible' happened)\n" + ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" + ++ s ++ "\n\n" + ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n" + + PprSorry s _ -> + showGhcException (Sorry (s ++ "\n<<details unavailable>>")) + Sorry s + -> showString $ + "sorry! (unimplemented feature or known bug)\n" + ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" + ++ s ++ "\n" + + where int_code code = + case code of + ExitSuccess -> (0::Int) + ExitFailure x -> x -- | Alias for `throwGhcException` @@ -176,6 +201,11 @@ panic x = throwGhcException (Panic x) sorry x = throwGhcException (Sorry x) pgmError x = throwGhcException (ProgramError x) +panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a +panicDoc x doc = throwGhcException (PprPanic x doc) +sorryDoc x doc = throwGhcException (PprSorry x doc) +pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) + -- | Panic while pretending to return an unboxed int. -- You can't use the regular panic functions in expressions @@ -183,11 +213,14 @@ pgmError x = throwGhcException (ProgramError x) panicFastInt :: String -> FastInt panicFastInt s = case (panic s) of () -> _ILIT(0) +panicDocFastInt :: String -> SDoc -> FastInt +panicDocFastInt s d = case (panicDoc s d) of () -> _ILIT(0) + -- | Throw an failed assertion exception for a given filename and line number. assertPanic :: String -> Int -> a -assertPanic file line = - Exception.throw (Exception.AssertionFailed +assertPanic file line = + Exception.throw (Exception.AssertionFailed ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) @@ -221,20 +254,20 @@ tryMost action = do r <- try action installSignalHandlers :: IO () installSignalHandlers = do main_thread <- myThreadId - modifyMVar_ interruptTargetThread (return . (main_thread :)) + pushInterruptTargetThread main_thread let interrupt_exn = (toException UserInterrupt) interrupt = do - withMVar interruptTargetThread $ \targets -> - case targets of - [] -> return () - (thread:_) -> throwTo thread interrupt_exn + mt <- peekInterruptTargetThread + case mt of + Nothing -> return () + Just t -> throwTo t interrupt_exn -- #if !defined(mingw32_HOST_OS) - _ <- installHandler sigQUIT (Catch interrupt) Nothing + _ <- installHandler sigQUIT (Catch interrupt) Nothing _ <- installHandler sigINT (Catch interrupt) Nothing -- see #3656; in the future we should install these automatically for -- all Haskell programs in the same way that we install a ^C handler. @@ -256,8 +289,44 @@ installSignalHandlers = do return () #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# NOINLINE interruptTargetThread #-} +interruptTargetThread :: MVar [Weak ThreadId] +interruptTargetThread = unsafePerformIO (newMVar []) + +pushInterruptTargetThread :: ThreadId -> IO () +pushInterruptTargetThread tid = do + wtid <- mkWeakThreadId tid + modifyMVar_ interruptTargetThread $ return . (wtid :) + +peekInterruptTargetThread :: IO (Maybe ThreadId) +peekInterruptTargetThread = + withMVar interruptTargetThread $ loop + where + loop [] = return Nothing + loop (t:ts) = do + r <- deRefWeak t + case r of + Nothing -> loop ts + Just t -> return (Just t) +#else {-# NOINLINE interruptTargetThread #-} interruptTargetThread :: MVar [ThreadId] interruptTargetThread = unsafePerformIO (newMVar []) +pushInterruptTargetThread :: ThreadId -> IO () +pushInterruptTargetThread tid = do + modifyMVar_ interruptTargetThread $ return . (tid :) + +peekInterruptTargetThread :: IO (Maybe ThreadId) +peekInterruptTargetThread = + withMVar interruptTargetThread $ return . listToMaybe +#endif + +popInterruptTargetThread :: IO () +popInterruptTargetThread = + modifyMVar_ interruptTargetThread $ + \tids -> return $! case tids of [] -> [] + (_:ts) -> ts + \end{code} diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 66f51e64e6..8252621661 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -7,6 +7,7 @@ module Platform ( OS(..), ArmISA(..), ArmISAExt(..), + ArmABI(..), target32Bit, osElfTarget @@ -41,7 +42,9 @@ data Arch | ArchSPARC | ArchARM { armISA :: ArmISA - , armISAExt :: [ArmISAExt] } + , armISAExt :: [ArmISAExt] + , armABI :: ArmABI + } deriving (Read, Show, Eq) @@ -58,9 +61,10 @@ data OS | OSOpenBSD | OSNetBSD | OSKFreeBSD + | OSHaiku deriving (Read, Show, Eq) --- | ARM Instruction Set Architecture and Extensions +-- | ARM Instruction Set Architecture, Extensions and ABI -- data ArmISA = ARMv5 @@ -76,6 +80,11 @@ data ArmISAExt | IWMMX2 deriving (Read, Show, Eq) +data ArmABI + = SOFT + | SOFTFP + | HARD + deriving (Read, Show, Eq) target32Bit :: Platform -> Bool target32Bit p = platformWordSize p == 4 @@ -91,6 +100,7 @@ osElfTarget OSSolaris2 = True osElfTarget OSDarwin = False osElfTarget OSMinGW32 = False osElfTarget OSKFreeBSD = True +osElfTarget OSHaiku = True osElfTarget OSUnknown = False -- Defaulting to False is safe; it means don't rely on any -- ELF-specific functionality. It is important to have a default for diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index cc8f235f2c..abe8957966 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -1002,13 +1002,10 @@ spaces n | n <=# _ILIT(0) = "" \end{code} \begin{code} -pprCols :: Int -pprCols = opt_PprCols - -printDoc :: Mode -> Handle -> Doc -> IO () -printDoc LeftMode hdl doc +printDoc :: Mode -> Int -> Handle -> Doc -> IO () +printDoc LeftMode _ hdl doc = do { printLeftRender hdl doc; hFlush hdl } -printDoc mode hdl doc +printDoc mode pprCols hdl doc = do { fullRender mode pprCols 1.5 put done doc ; hFlush hdl } where diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 4ee6e190cc..259689c454 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -20,7 +20,9 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order of arguments of combining function. \begin{code} -{-# OPTIONS -fno-warn-tabs -XGeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index d09a1ad345..9d12946052 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -19,7 +19,7 @@ module Util ( unzipWith, mapFst, mapSnd, - mapAndUnzip, mapAndUnzip3, + mapAndUnzip, mapAndUnzip3, mapAccumL2, nOfThem, filterOut, partitionWith, splitEithers, foldl1', foldl2, count, all2, @@ -35,6 +35,7 @@ module Util ( -- * Tuples fstOf3, sndOf3, thirdOf3, firstM, first3M, + third3, uncurry3, -- * List operations controlled by another list @@ -45,7 +46,7 @@ module Util ( nTimes, -- * Sorting - sortLe, sortWith, minWith, on, + sortWith, minWith, -- * Comparisons isEqual, eqListBy, eqMaybeBy, @@ -74,7 +75,6 @@ module Util ( maybeRead, maybeReadFuzzy, -- * IO-ish utilities - createDirectoryHierarchy, doesDirNameExist, getModificationUTCTime, modificationTimeIfExists, @@ -92,7 +92,10 @@ module Util ( abstractConstr, abstractDataType, mkNoRepType, -- * Utils for printing C code - charToC + charToC, + + -- * Hashing + hashString, ) where #include "HsVersions.h" @@ -109,13 +112,13 @@ import Data.List hiding (group) import FastTypes #endif -import Control.Monad ( unless, liftM ) +import Control.Monad ( liftM ) import System.IO.Error as IO ( isDoesNotExistError ) -import System.Directory ( doesDirectoryExist, createDirectory, - getModificationTime ) +import System.Directory ( doesDirectoryExist, getModificationTime ) import System.FilePath import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit ) +import Data.Int import Data.Ratio ( (%) ) import Data.Ord ( comparing ) import Data.Bits @@ -226,6 +229,9 @@ fstOf3 (a,_,_) = a sndOf3 (_,b,_) = b thirdOf3 (_,_,c) = c +third3 :: (c -> d) -> (a, b, c) -> (a, b, d) +third3 f (a, b, c) = (a, b, f c) + uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c \end{code} @@ -308,12 +314,7 @@ zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) zipLazy :: [a] -> [b] -> [(a,b)] zipLazy [] _ = [] --- We want to write this, but with GHC 6.4 we get a warning, so it --- doesn't validate: --- zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys --- so we write this instead: -zipLazy (x:xs) zs = let y : ys = zs - in (x,y) : zipLazy xs ys +zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys \end{code} @@ -355,6 +356,12 @@ mapAndUnzip3 f (x:xs) (rs1, rs2, rs3) = mapAndUnzip3 f xs in (r1:rs1, r2:rs2, r3:rs3) + +mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) +mapAccumL2 f s1 s2 xs = (s1', s2', ys) + where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of + (s1', s2', y) -> ((s1', s2'), y)) + (s1, s2) xs \end{code} \begin{code} @@ -469,114 +476,17 @@ isn'tIn msg x ys %************************************************************************ %* * -\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten} +\subsubsection{Sort utils} %* * %************************************************************************ -\begin{display} -Date: Mon, 3 May 93 20:45:23 +0200 -From: Carsten Kehler Holst <kehler@cs.chalmers.se> -To: partain@dcs.gla.ac.uk -Subject: natural merge sort beats quick sort [ and it is prettier ] - -Here is a piece of Haskell code that I'm rather fond of. See it as an -attempt to get rid of the ridiculous quick-sort routine. groupUpdown is -quite useful by itself I think it was John's idea originally though I -believe the lazy version is due to me [surprisingly complicated]. -gamma [used to be called] is called gamma because I got inspired by -the Gamma calculus. It is not very close to the calculus but does -behave less sequentially than both foldr and foldl. One could imagine -a version of gamma that took a unit element as well thereby avoiding -the problem with empty lists. - -I've tried this code against - - 1) insertion sort - as provided by haskell - 2) the normal implementation of quick sort - 3) a deforested version of quick sort due to Jan Sparud - 4) a super-optimized-quick-sort of Lennart's - -If the list is partially sorted both merge sort and in particular -natural merge sort wins. If the list is random [ average length of -rising subsequences = approx 2 ] mergesort still wins and natural -merge sort is marginally beaten by Lennart's soqs. The space -consumption of merge sort is a bit worse than Lennart's quick sort -approx a factor of 2. And a lot worse if Sparud's bug-fix [see his -fpca article ] isn't used because of groupUpdown. - -have fun -Carsten -\end{display} - \begin{code} -groupUpdown :: (a -> a -> Bool) -> [a] -> [[a]] --- Given a <= function, groupUpdown finds maximal contiguous up-runs --- or down-runs in the input list. --- It's stable, in the sense that it never re-orders equal elements --- --- Date: Mon, 12 Feb 1996 15:09:41 +0000 --- From: Andy Gill <andy@dcs.gla.ac.uk> --- Here is a `better' definition of groupUpdown. - -groupUpdown _ [] = [] -groupUpdown p (x:xs) = group' xs x x (x :) - where - group' [] _ _ s = [s []] - group' (x:xs) x_min x_max s - | x_max `p` x = group' xs x_min x (s . (x :)) - | not (x_min `p` x) = group' xs x x_max ((x :) . s) - | otherwise = s [] : group' xs x x (x :) - -- NB: the 'not' is essential for stablity - -- x `p` x_min would reverse equal elements - -generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a] -generalMerge _ xs [] = xs -generalMerge _ [] ys = ys -generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys) - | otherwise = y : generalMerge p (x:xs) ys - --- gamma is now called balancedFold - -balancedFold :: (a -> a -> a) -> [a] -> a -balancedFold _ [] = error "can't reduce an empty list using balancedFold" -balancedFold _ [x] = x -balancedFold f l = balancedFold f (balancedFold' f l) - -balancedFold' :: (a -> a -> a) -> [a] -> [a] -balancedFold' f (x:y:xs) = f x y : balancedFold' f xs -balancedFold' _ xs = xs - -generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a] -generalNaturalMergeSort _ [] = [] -generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . groupUpdown p) xs - -#if NOT_USED -generalMergeSort p [] = [] -generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs - -mergeSort, naturalMergeSort :: Ord a => [a] -> [a] - -mergeSort = generalMergeSort (<=) -naturalMergeSort = generalNaturalMergeSort (<=) - -mergeSortLe le = generalMergeSort le -#endif - -sortLe :: (a->a->Bool) -> [a] -> [a] -sortLe le = generalNaturalMergeSort le - sortWith :: Ord b => (a->b) -> [a] -> [a] -sortWith get_key xs = sortLe le xs - where - x `le` y = get_key x < get_key y +sortWith get_key xs = sortBy (comparing get_key) xs minWith :: Ord b => (a -> b) -> [a] -> a minWith get_key xs = ASSERT( not (null xs) ) head (sortWith get_key xs) - -on :: (a -> a -> c) -> (b -> a) -> b -> b -> c -on cmp sel = \x y -> sel x `cmp` sel y - \end{code} %************************************************************************ @@ -1018,16 +928,6 @@ maybeReadFuzzy str = case reads str of Nothing ----------------------------------------------------------------------------- --- Create a hierarchy of directories - -createDirectoryHierarchy :: FilePath -> IO () -createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack -createDirectoryHierarchy dir = do - b <- doesDirectoryExist dir - unless b $ do createDirectoryHierarchy (takeDirectory dir) - createDirectory dir - ------------------------------------------------------------------------------ -- Verify that the 'dirname' portion of a FilePath exists. -- doesDirNameExist :: FilePath -> IO Bool @@ -1153,3 +1053,70 @@ charToC w = chr (ord '0' + ord c `mod` 8)] \end{code} +%************************************************************************ +%* * +\subsection[Utils-Hashing]{Utils for hashing} +%* * +%************************************************************************ + +\begin{code} +-- | A sample hash function for Strings. We keep multiplying by the +-- golden ratio and adding. The implementation is: +-- +-- > hashString = foldl' f golden +-- > where f m c = fromIntegral (ord c) * magic + hashInt32 m +-- > magic = 0xdeadbeef +-- +-- Where hashInt32 works just as hashInt shown above. +-- +-- Knuth argues that repeated multiplication by the golden ratio +-- will minimize gaps in the hash space, and thus it's a good choice +-- for combining together multiple keys to form one. +-- +-- Here we know that individual characters c are often small, and this +-- produces frequent collisions if we use ord c alone. A +-- particular problem are the shorter low ASCII and ISO-8859-1 +-- character strings. We pre-multiply by a magic twiddle factor to +-- obtain a good distribution. In fact, given the following test: +-- +-- > testp :: Int32 -> Int +-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls +-- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] +-- > hs = foldl' f golden +-- > f m c = fromIntegral (ord c) * k + hashInt32 m +-- > n = 100000 +-- +-- We discover that testp magic = 0. +hashString :: String -> Int32 +hashString = foldl' f golden + where f m c = fromIntegral (ord c) * magic + hashInt32 m + magic = 0xdeadbeef + +golden :: Int32 +golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 +-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 +-- but that has bad mulHi properties (even adding 2^32 to get its inverse) +-- Whereas the above works well and contains no hash duplications for +-- [-32767..65536] + +-- | A sample (and useful) hash function for Int32, +-- implemented by extracting the uppermost 32 bits of the 64-bit +-- result of multiplying by a 33-bit constant. The constant is from +-- Knuth, derived from the golden ratio: +-- +-- > golden = round ((sqrt 5 - 1) * 2^32) +-- +-- We get good key uniqueness on small inputs +-- (a problem with previous versions): +-- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 +-- +hashInt32 :: Int32 -> Int32 +hashInt32 x = mulHi x golden + x + +-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply +mulHi :: Int32 -> Int32 -> Int32 +mulHi a b = fromIntegral (r `shiftR` 32) + where r :: Int64 + r = fromIntegral a * fromIntegral b +\end{code} + diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 88fc947242..8b7e817826 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -210,7 +210,8 @@ vectTopBind b@(Rec bs) ; if and hasNoVectDecls then return b -- all bindings have 'NOVECTORISE' else if or hasNoVectDecls - then cantVectorise noVectoriseErr (ppr b) -- some (but not all) have 'NOVECTORISE' + then do dflags <- getDynFlags + cantVectorise dflags noVectoriseErr (ppr b) -- some (but not all) have 'NOVECTORISE' else vectorise -- no binding has a 'NOVECTORISE' decl } noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group" @@ -264,10 +265,11 @@ vectTopBinder var inline expr Just (vdty, _) | eqType vty vdty -> return () | otherwise -> - cantVectorise ("Type mismatch in vectorisation pragma for " ++ show var) $ - (text "Expected type" <+> ppr vty) - $$ - (text "Inferred type" <+> ppr vdty) + do dflags <- getDynFlags + cantVectorise dflags ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $ + (text "Expected type" <+> ppr vty) + $$ + (text "Inferred type" <+> ppr vdty) -- Make the vectorised version of binding's name, and set the unfolding used for inlining ; var' <- liftM (`setIdUnfoldingLazily` unfolding) @@ -350,9 +352,10 @@ vectTopRhs recFs var expr = closedV $ do { globalScalar <- isGlobalScalarVar var ; vectDecl <- lookupVectDecl var + ; dflags <- getDynFlags ; let isDFun = isDFunId var - ; traceVt ("vectTopRhs of " ++ show var ++ info globalScalar isDFun vectDecl ++ ":") $ + ; traceVt ("vectTopRhs of " ++ showPpr dflags var ++ info globalScalar isDFun vectDecl ++ ":") $ ppr expr ; rhs globalScalar isDFun vectDecl @@ -361,18 +364,18 @@ vectTopRhs recFs var expr rhs _globalScalar _isDFun (Just (_, expr')) -- Case (1) = return (inlineMe, False, expr') rhs True False Nothing -- Case (2) - = do { expr' <- vectScalarFun True recFs expr + = do { expr' <- vectScalarFun expr ; return (inlineMe, True, vectorised expr') } rhs True True Nothing -- Case (3) - = do { expr' <- vectScalarDFun var recFs + = do { expr' <- vectScalarDFun var ; return (DontInline, True, expr') } rhs False False Nothing -- Case (4) — not a dfun = do { let exprFvs = freeVars expr ; (inline, isScalar, vexpr) <- inBind var $ - vectPolyExpr (isStrongLoopBreaker $ idOccInfo var) recFs exprFvs + vectPolyExpr (isStrongLoopBreaker $ idOccInfo var) recFs exprFvs Nothing ; return (inline, isScalar, vectorised vexpr) } rhs False True Nothing -- Case (4) — is a dfun diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs index 90afedfb87..ca2e750845 100644 --- a/compiler/vectorise/Vectorise/Builtins/Base.hs +++ b/compiler/vectorise/Vectorise/Builtins/Base.hs @@ -57,7 +57,7 @@ mAX_DPH_COMBINE :: Int mAX_DPH_COMBINE = 2 mAX_DPH_SCALAR_ARGS :: Int -mAX_DPH_SCALAR_ARGS = 3 +mAX_DPH_SCALAR_ARGS = 8 -- Types from 'GHC.Prim' supported by DPH -- diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index 1ef8183869..20c9f090d9 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -95,7 +95,7 @@ initBuiltins ; applyVar <- externalVar (fsLit "$:") ; liftedApplyVar <- externalVar (fsLit "liftedApply") ; closures <- mapM externalVar (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) - ; let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures + ; let closureCtrFuns = listArray (1, mAX_DPH_SCALAR_ARGS) closures -- Types and functions for selectors ; sel_tys <- mapM externalType (numbered "Sel" 2 mAX_DPH_SUM) diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs index cebee633ee..048362d59c 100644 --- a/compiler/vectorise/Vectorise/Convert.hs +++ b/compiler/vectorise/Vectorise/Convert.hs @@ -78,10 +78,11 @@ identityConv (TyConApp tycon tys) = do { mapM_ identityConv tys ; identityConvTyCon tycon } -identityConv (TyVarTy _) = noV $ text "identityConv: type variable changes under vectorisation" -identityConv (AppTy _ _) = noV $ text "identityConv: type appl. changes under vectorisation" -identityConv (FunTy _ _) = noV $ text "identityConv: function type changes under vectorisation" -identityConv (ForAllTy _ _) = noV $ text "identityConv: quantified type changes under vectorisation" +identityConv (LitTy {}) = noV $ text "identityConv: not sure about literal types under vectorisation" +identityConv (TyVarTy {}) = noV $ text "identityConv: type variable changes under vectorisation" +identityConv (AppTy {}) = noV $ text "identityConv: type appl. changes under vectorisation" +identityConv (FunTy {}) = noV $ text "identityConv: function type changes under vectorisation" +identityConv (ForAllTy {}) = noV $ text "identityConv: quantified type changes under vectorisation" -- |Check that this type constructor is neutral under type vectorisation — i.e., it is not altered -- by vectorisation as they contain no parallel arrays. diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index cf5bf9664f..a887e7736f 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -30,6 +30,9 @@ import NameSet import Name import NameEnv import FastString +import TysPrim +import TysWiredIn + import Data.Maybe @@ -158,11 +161,13 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs -- single variable to be able to obtain the type without -- inference — see also 'TcBinds.tcVect' scalar_vars = [var | Vect var Nothing <- vectDecls] ++ - [var | VectInst var <- vectDecls] + [var | VectInst var <- vectDecls] ++ + [dataConWrapId doubleDataCon, dataConWrapId floatDataCon, dataConWrapId intDataCon] -- TODO: fix this hack novects = [var | NoVect var <- vectDecls] scalar_tycons = [tyConName tycon | VectType True tycon Nothing <- vectDecls] ++ [tyConName tycon | VectType _ tycon (Just tycon') <- vectDecls - , tycon == tycon'] + , tycon == tycon'] ++ + map tyConName [doublePrimTyCon, intPrimTyCon, floatPrimTyCon] -- TODO: fix this hack -- - for 'VectType True tycon Nothing', we checked that the type does not -- contain arrays (or type variables that could be instatiated to arrays) -- - for 'VectType _ tycon (Just tycon')', where the two tycons are the same, diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 778a3a5d19..8c5ef0045d 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -33,7 +33,6 @@ import TyCon import TcType import Type import PrelNames -import NameSet import Var import VarEnv import VarSet @@ -48,45 +47,248 @@ import Control.Monad import Control.Applicative import Data.Maybe import Data.List +import TcRnMonad (doptM) +import DynFlags +import Util +-- Main entry point to vectorise expressions ----------------------------------- + -- |Vectorise a polymorphic expression. -- -vectPolyExpr :: Bool -- ^ When vectorising the RHS of a binding: is that binding a loop breaker? - -> [Var] - -> CoreExprWithFVs +-- If not yet available, precompute vectorisation avoidance information before vectorising. If +-- the vectorisation avoidance optimisation is enabled, also use the vectorisation avoidance +-- information to encapsulated subexpression that do not need to be vectorised. +-- +vectPolyExpr :: Bool -> [Var] -> CoreExprWithFVs -> Maybe VITree -> VM (Inline, Bool, VExpr) -vectPolyExpr loop_breaker recFns (_, AnnTick tickish expr) - = do { (inline, isScalarFn, expr') <- vectPolyExpr loop_breaker recFns expr - ; return (inline, isScalarFn, vTick tickish expr') - } -vectPolyExpr loop_breaker recFns expr - = do { arity <- polyArity tvs - ; polyAbstract tvs $ \args -> do - { (inline, isScalarFn, mono') <- vectFnExpr False loop_breaker recFns mono - ; return (addInlineArity inline arity, isScalarFn, mapVect (mkLams $ tvs ++ args) mono') - } } + -- precompute vectorisation avoidance information (and possibly encapsulated subexpressions) +vectPolyExpr loop_breaker recFns expr Nothing + = do + { vectAvoidance <- liftDs $ doptM Opt_AvoidVect + ; vi <- vectAvoidInfo expr + ; (expr', vi') <- + if vectAvoidance + then do + { (expr', vi') <- encapsulateScalars vi expr + ; traceVt "vectPolyExpr encapsulated:" (ppr $ deAnnotate expr') + ; return (expr', vi') + } + else return (expr, vi) + ; vectPolyExpr loop_breaker recFns expr' (Just vi') + } + + -- traverse through ticks +vectPolyExpr loop_breaker recFns (_, AnnTick tickish expr) (Just (VITNode _ [vit])) + = do + { (inline, isScalarFn, expr') <- vectPolyExpr loop_breaker recFns expr (Just vit) + ; return (inline, isScalarFn, vTick tickish expr') + } + + -- collect and vectorise type abstractions; then, descent into the body +vectPolyExpr loop_breaker recFns expr (Just vit) + = do + { let (tvs, mono) = collectAnnTypeBinders expr + vit' = stripLevels (length tvs) vit + ; arity <- polyArity tvs + ; polyAbstract tvs $ \args -> + do + { (inline, isScalarFn, mono') <- vectFnExpr False loop_breaker recFns mono vit' + ; return (addInlineArity inline arity, isScalarFn, mapVect (mkLams $ tvs ++ args) mono') + } + } where - (tvs, mono) = collectAnnTypeBinders expr + stripLevels 0 vit = vit + stripLevels n (VITNode _ [vit]) = stripLevels (n - 1) vit + stripLevels _ vit = pprPanic "vectPolyExpr: stripLevels:" (text (show vit)) --- |Vectorise an expression. +-- Encapsulate every purely sequential subexpression of a (potentially) parallel expression into a +-- into a lambda abstraction over all its free variables followed by the corresponding application +-- to those variables. We can, then, avoid the vectorisation of the ensapsulated subexpressions. +-- +-- Preconditions: +-- +-- * All free variables and the result type must be /simple/ types. +-- * The expression is sufficientlt complex (top warrant special treatment). For now, that is +-- every expression that is not constant and contains at least one operation. +-- +encapsulateScalars :: VITree -> CoreExprWithFVs -> VM (CoreExprWithFVs, VITree) +encapsulateScalars vit ce@(_, AnnType _ty) + = return (ce, vit) + +encapsulateScalars vit ce@(_, AnnVar _v) + = return (ce, vit) + +encapsulateScalars vit ce@(_, AnnLit _) + = return (ce, vit) + +encapsulateScalars (VITNode vi [vit]) (fvs, AnnTick tck expr) + = do { (extExpr, vit') <- encapsulateScalars vit expr + ; return ((fvs, AnnTick tck extExpr), VITNode vi [vit']) + } + +encapsulateScalars _ (_fvs, AnnTick _tck _expr) + = panic "encapsulateScalar AnnTick doesn't match up" + +encapsulateScalars (VITNode vi [vit]) ce@(fvs, AnnLam bndr expr) + = do { varsS <- varsSimple fvs + ; case (vi, varsS) of + (VISimple, True) -> do { let (e', vit') = liftSimple vit ce + ; return (e', vit') + } + _ -> do { (extExpr, vit') <- encapsulateScalars vit expr + ; return ((fvs, AnnLam bndr extExpr), VITNode vi [vit']) + } + } + +encapsulateScalars _ (_fvs, AnnLam _bndr _expr) + = panic "encapsulateScalars AnnLam doesn't match up" + +encapsulateScalars vt@(VITNode vi [vit1, vit2]) ce@(fvs, AnnApp ce1 ce2) + = do { varsS <- varsSimple fvs + ; case (vi, varsS) of + (VISimple, True) -> do { let (e', vt') = liftSimple vt ce + -- ; checkTreeAnnM vt' e' + -- ; traceVt "Passed checkTree test!!" (ppr $ deAnnotate e') + ; return (e', vt') + } + _ -> do { (etaCe1, vit1') <- encapsulateScalars vit1 ce1 + ; (etaCe2, vit2') <- encapsulateScalars vit2 ce2 + ; return ((fvs, AnnApp etaCe1 etaCe2), VITNode vi [vit1', vit2']) + } + } + +encapsulateScalars _ (_fvs, AnnApp _ce1 _ce2) + = panic "encapsulateScalars AnnApp doesn't match up" + +encapsulateScalars vt@(VITNode vi (scrutVit : altVits)) ce@(fvs, AnnCase scrut bndr ty alts) + = do { varsS <- varsSimple fvs + ; case (vi, varsS) of + (VISimple, True) -> return $ liftSimple vt ce + _ -> do { (extScrut, scrutVit') <- encapsulateScalars scrutVit scrut + ; extAltsVits <- zipWithM expAlt altVits alts + ; let (extAlts, altVits') = unzip extAltsVits + ; return ((fvs, AnnCase extScrut bndr ty extAlts), VITNode vi (scrutVit': altVits')) + } + } + where + expAlt vt (con, bndrs, expr) + = do { (extExpr, vt') <- encapsulateScalars vt expr + ; return ((con, bndrs, extExpr), vt') + } + +encapsulateScalars _ (_fvs, AnnCase _scrut _bndr _ty _alts) + = panic "encapsulateScalars AnnCase doesn't match up" + +encapsulateScalars vt@(VITNode vi [vt1, vt2]) ce@(fvs, AnnLet (AnnNonRec bndr expr1) expr2) + = do { varsS <- varsSimple fvs + ; case (vi, varsS) of + (VISimple, True) -> return $ liftSimple vt ce + _ -> do { (extExpr1, vt1') <- encapsulateScalars vt1 expr1 + ; (extExpr2, vt2') <- encapsulateScalars vt2 expr2 + ; return ((fvs, AnnLet (AnnNonRec bndr extExpr1) extExpr2), VITNode vi [vt1', vt2']) + } + } + +encapsulateScalars _ (_fvs, AnnLet (AnnNonRec _bndr _expr1) _expr2) + = panic "encapsulateScalars AnnLet nonrec doesn't match up" + +encapsulateScalars vt@(VITNode vi (vtB : vtBnds)) ce@(fvs, AnnLet (AnnRec bndngs) expr) + = do { varsS <- varsSimple fvs + ; case (vi, varsS) of + (VISimple, True) -> return $ liftSimple vt ce + _ -> do { extBndsVts <- zipWithM expBndg vtBnds bndngs + ; let (extBnds, vtBnds') = unzip extBndsVts + ; (extExpr, vtB') <- encapsulateScalars vtB expr + ; let vt' = VITNode vi (vtB':vtBnds') + ; return ((fvs, AnnLet (AnnRec extBnds) extExpr), vt') + } + } + where + expBndg vit (bndr, expr) + = do { (extExpr, vit') <- encapsulateScalars vit expr + ; return ((bndr, extExpr), vit') + } + +encapsulateScalars _ (_fvs, AnnLet (AnnRec _) _expr2) + = panic "encapsulateScalars AnnLet rec doesn't match up" + +encapsulateScalars (VITNode vi [vit]) (fvs, AnnCast expr coercion) + = do { (extExpr, vit') <- encapsulateScalars vit expr + ; return ((fvs, AnnCast extExpr coercion), VITNode vi [vit']) + } + +encapsulateScalars _ (_fvs, AnnCast _expr _coercion) + = panic "encapsulateScalars AnnCast rec doesn't match up" + +encapsulateScalars _ _ + = panic "encapsulateScalars case not handled" + +-- Lambda-lift the given expression and apply it to the abstracted free variables. -- -vectExpr :: CoreExprWithFVs -> VM VExpr +-- If the expression is a case expression scrutinising anything but a primitive type, then lift +-- each alternative individually. +-- +liftSimple :: VITree -> CoreExprWithFVs -> (CoreExprWithFVs, VITree) +liftSimple (VITNode vi (scrutVit : altVits)) (fvs, AnnCase expr bndr t alts) + | Just (c,_) <- splitTyConApp_maybe (exprType $ deAnnotate $ expr), + (not $ elem c [boolTyCon, intTyCon, doubleTyCon, floatTyCon]) -- FIXME: shouldn't be hardcoded + = ((fvs, AnnCase expr bndr t alts'), VITNode vi (scrutVit : altVits')) + where + (alts', altVits') = unzip $ map (\(ac,bndrs, (alt, avi)) -> ((ac,bndrs,alt), avi)) $ + zipWith (\(ac, bndrs, aex) -> \altVi -> (ac, bndrs, liftSimple altVi aex)) alts altVits + +liftSimple viTree ae@(fvs, _annEx) + = (mkAnnApps (mkAnnLams ae vars) vars, viTree') + where + mkViTreeLams (VITNode _ vits) [] = VITNode VIEncaps vits + mkViTreeLams vi (_:vs) = VITNode VIEncaps [mkViTreeLams vi vs] + + mkViTreeApps vi [] = vi + mkViTreeApps vi (_:vs) = VITNode VISimple [mkViTreeApps vi vs, VITNode VISimple []] + + vars = varSetElems fvs + viTree' = mkViTreeApps (mkViTreeLams viTree vars) vars + + mkAnnLam :: bndr -> AnnExpr bndr VarSet -> AnnExpr' bndr VarSet + mkAnnLam bndr ce = AnnLam bndr ce + + mkAnnLams:: CoreExprWithFVs -> [Var] -> CoreExprWithFVs + mkAnnLams (fv, aex') [] = (fv, aex') -- fv should be empty. check! + mkAnnLams (fv, aex') (v:vs) = mkAnnLams (delVarSet fv v, (mkAnnLam v ((delVarSet fv v), aex'))) vs + + mkAnnApp :: (AnnExpr bndr VarSet) -> Var -> (AnnExpr' bndr VarSet) + mkAnnApp aex v = AnnApp aex (unitVarSet v, (AnnVar v)) + + mkAnnApps:: CoreExprWithFVs -> [Var] -> CoreExprWithFVs + mkAnnApps (fv, aex') [] = (fv, aex') + mkAnnApps ae (v:vs) = + let + (fv, aex') = mkAnnApps ae vs + in (extendVarSet fv v, mkAnnApp (fv, aex') v) -vectExpr (_, AnnVar v) +-- |Vectorise an expression. +-- +vectExpr :: CoreExprWithFVs -> VITree -> VM VExpr +-- vectExpr e vi | not (checkTree vi (deAnnotate e)) +-- = pprPanic "vectExpr" (ppr $ deAnnotate e) + +vectExpr (_, AnnVar v) _ = vectVar v -vectExpr (_, AnnLit lit) +vectExpr (_, AnnLit lit) _ = vectConst $ Lit lit -vectExpr e@(_, AnnLam bndr _) - | isId bndr = (\(_, _, ve) -> ve) <$> vectFnExpr True False [] e +vectExpr e@(_, AnnLam bndr _) vt + | isId bndr = (\(_, _, ve) -> ve) <$> vectFnExpr True False [] e vt + | otherwise = do dflags <- getDynFlags + cantVectorise dflags "Unexpected type lambda (vectExpr)" (ppr (deAnnotate e)) -- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty'; -- its only purpose is to abort the program, but we need to adjust the type to keep CoreLint -- happy. -- FIXME: can't be do this with a VECTORISE pragma on 'pAT_ERROR_ID' now? -vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err) +vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err) _ | v == pAT_ERROR_ID = do { (vty, lty) <- vectAndLiftType ty ; return (mkCoreApps (Var v) [Type vty, err'], mkCoreApps (Var v) [Type lty, err']) @@ -96,13 +298,13 @@ vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err) -- type application (handle multiple consecutive type applications simultaneously to ensure the -- PA dictionaries are put at the right places) -vectExpr e@(_, AnnApp _ arg) +vectExpr e@(_, AnnApp _ arg) (VITNode _ [_, _]) | isAnnTypeArg arg = vectPolyApp e -- 'Int', 'Float', or 'Double' literal -- FIXME: this needs to be generalised -vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit)) +vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit)) _ | Just con <- isDataConId_maybe v , is_special_con con = do @@ -113,17 +315,17 @@ vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit)) is_special_con con = con `elem` [intDataCon, floatDataCon, doubleDataCon] -- value application (dictionary or user value) -vectExpr e@(_, AnnApp fn arg) +vectExpr e@(_, AnnApp fn arg) (VITNode _ [vit1, vit2]) | isPredTy arg_ty -- dictionary application (whose result is not a dictionary) = vectPolyApp e | otherwise -- user value = do { -- vectorise the types - ; varg_ty <- vectType arg_ty + ; varg_ty <- vectType arg_ty ; vres_ty <- vectType res_ty -- vectorise the function and argument expression - ; vfn <- vectExpr fn - ; varg <- vectExpr arg + ; vfn <- vectExpr fn vit1 + ; varg <- vectExpr arg vit2 -- the vectorised function is a closure; apply it to the vectorised argument ; mkClosureApp varg_ty vres_ty vfn varg @@ -131,42 +333,45 @@ vectExpr e@(_, AnnApp fn arg) where (arg_ty, res_ty) = splitFunTy . exprType $ deAnnotate fn -vectExpr (_, AnnCase scrut bndr ty alts) +vectExpr (_, AnnCase scrut bndr ty alts) vt | Just (tycon, ty_args) <- splitTyConApp_maybe scrut_ty , isAlgTyCon tycon - = vectAlgCase tycon ty_args scrut bndr ty alts - | otherwise = cantVectorise "Can't vectorise expression" (ppr scrut_ty) + = vectAlgCase tycon ty_args scrut bndr ty alts vt + | otherwise = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise expression" (ppr scrut_ty) where scrut_ty = exprType (deAnnotate scrut) -vectExpr (_, AnnLet (AnnNonRec bndr rhs) body) +vectExpr (_, AnnLet (AnnNonRec bndr rhs) body) (VITNode _ [vt1, vt2]) = do - vrhs <- localV . inBind bndr . liftM (\(_,_,z)->z) $ vectPolyExpr False [] rhs - (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) + vrhs <- localV . inBind bndr . liftM (\(_,_,z)->z) $ vectPolyExpr False [] rhs (Just vt1) + (vbndr, vbody) <- vectBndrIn bndr (vectExpr body vt2) return $ vLet (vNonRec vbndr vrhs) vbody -vectExpr (_, AnnLet (AnnRec bs) body) +vectExpr (_, AnnLet (AnnRec bs) body) (VITNode _ (vtB : vtBnds)) = do (vbndrs, (vrhss, vbody)) <- vectBndrsIn bndrs $ liftM2 (,) - (zipWithM vect_rhs bndrs rhss) - (vectExpr body) + (zipWith3M vect_rhs bndrs rhss vtBnds) + (vectExpr body vtB) return $ vLet (vRec vbndrs vrhss) vbody where (bndrs, rhss) = unzip bs - vect_rhs bndr rhs = localV - . inBind bndr - . liftM (\(_,_,z)->z) - $ vectPolyExpr (isStrongLoopBreaker $ idOccInfo bndr) [] rhs + vect_rhs bndr rhs vt = localV + . inBind bndr + . liftM (\(_,_,z)->z) + $ vectPolyExpr (isStrongLoopBreaker $ idOccInfo bndr) [] rhs (Just vt) + zipWith3M f xs ys zs = zipWithM (\x -> \(y,z) -> (f x y z)) xs (zip ys zs) -vectExpr (_, AnnTick tickish expr) - = liftM (vTick tickish) (vectExpr expr) +vectExpr (_, AnnTick tickish expr) (VITNode _ [vit]) + = liftM (vTick tickish) (vectExpr expr vit) -vectExpr (_, AnnType ty) +vectExpr (_, AnnType ty) _ = liftM vType (vectType ty) -vectExpr e = cantVectorise "Can't vectorise expression (vectExpr)" (ppr $ deAnnotate e) +vectExpr e vit = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise expression (vectExpr)" (ppr (deAnnotate e) $$ text (" " ++ show vit)) -- |Vectorise an expression that *may* have an outer lambda abstraction. -- @@ -179,23 +384,26 @@ vectFnExpr :: Bool -- ^ If we process the RHS of a binding, whether -> Bool -- ^ Whether the binding is a loop breaker -> [Var] -- ^ Names of function in same recursive binding group -> CoreExprWithFVs -- ^ Expression to vectorise; must have an outer `AnnLam` + -> VITree -> VM (Inline, Bool, VExpr) -vectFnExpr inline loop_breaker recFns expr@(_fvs, AnnLam bndr body) +-- vectFnExpr _ _ _ e vi | not (checkTree vi (deAnnotate e)) +-- = pprPanic "vectFnExpr" (ppr $ deAnnotate e) +vectFnExpr inline loop_breaker recFns expr@(_fvs, AnnLam bndr body) vt@(VITNode _ [vt']) -- predicate abstraction: leave as a normal abstraction, but vectorise the predicate type | isId bndr && isPredTy (idType bndr) = do { vBndr <- vectBndr bndr - ; (inline, isScalarFn, vbody) <- vectFnExpr inline loop_breaker recFns body + ; (inline, isScalarFn, vbody) <- vectFnExpr inline loop_breaker recFns body vt' ; return (inline, isScalarFn, mapVect (mkLams [vectorised vBndr]) vbody) } -- non-predicate abstraction: vectorise (try to vectorise as a scalar computation) | isId bndr - = mark DontInline True (vectScalarFun False recFns (deAnnotate expr)) + = mark DontInline True (vectScalarFunMaybe (deAnnotate expr) vt) `orElseV` - mark inlineMe False (vectLam inline loop_breaker expr) -vectFnExpr _ _ _ e + mark inlineMe False (vectLam inline loop_breaker expr vt) +vectFnExpr _ _ _ e vt -- not an abstraction: vectorise as a vanilla expression - = mark DontInline False $ vectExpr e + = mark DontInline False $ vectExpr e vt mark :: Inline -> Bool -> VM a -> VM (Inline, Bool, a) mark b isScalarFn p = do { x <- p; return (b, isScalarFn, x) } @@ -315,127 +523,35 @@ vectDictExpr (Coercion coe) -- |Vectorise an expression of functional type, where all arguments and the result are of primitive -- types (i.e., 'Int', 'Float', 'Double' etc., which have instances of the 'Scalar' type class) and -- which does not contain any subcomputations that involve parallel arrays. Such functionals do not --- requires the full blown vectorisation transformation; instead, they can be lifted by application +-- require the full blown vectorisation transformation; instead, they can be lifted by application -- of a member of the zipWith family (i.e., 'map', 'zipWith', zipWith3', etc.) -- -- Dictionary functions are also scalar functions (as dictionaries themselves are not vectorised, -- instead they become dictionaries of vectorised methods). We treat them differently, though see -- "Note [Scalar dfuns]" in 'Vectorise'. -- -vectScalarFun :: Bool -- ^ Was the function marked as scalar by the user? - -> [Var] -- ^ Functions names in same recursive binding group - -> CoreExpr -- ^ Expression to be vectorised - -> VM VExpr -vectScalarFun forceScalar recFns expr - = do { gscalarVars <- globalScalarVars - ; scalarTyCons <- globalScalarTyCons - ; let scalarVars = gscalarVars `extendVarSetList` recFns - (arg_tys, res_ty) = splitFunTys (exprType expr) - ; MASSERT( not $ null arg_tys ) - ; onlyIfV (ptext (sLit "not a scalar function")) - (forceScalar -- user asserts the functions is scalar - || - all is_primitive_ty arg_tys -- check whether the function is scalar - && is_primitive_ty res_ty - && is_scalar scalarVars (is_scalar_ty scalarTyCons) expr - && uses scalarVars expr - && length arg_tys <= mAX_DPH_SCALAR_ARGS) - $ mkScalarFun arg_tys res_ty expr - } - where - -- !!!FIXME: We would like to allow scalar functions with arguments and results that can be - -- any 'scalarTyCons', but can't at the moment, as those argument and result types - -- need to be members of the 'Scalar' class (that in its current form would better - -- be called 'Primitive'). *ALSO* the hardcoded list of types is ugly! - is_primitive_ty ty - | isPredTy ty -- dictionaries never get into the environment - = True - | Just (tycon, _) <- splitTyConApp_maybe ty - = tyConName tycon `elem` [boolTyConName, intTyConName, word8TyConName, doubleTyConName] - | otherwise - = False - - is_scalar_ty scalarTyCons ty - | isPredTy ty -- dictionaries never get into the environment - = True - | Just (tycon, _) <- splitTyConApp_maybe ty - = tyConName tycon `elemNameSet` scalarTyCons - | otherwise - = False - - -- Checks whether an expression contain a non-scalar subexpression. - -- - -- Precodition: The variables in the first argument are scalar. - -- - -- In case of a recursive binding group, we /assume/ that all bindings are scalar (by adding - -- them to the list of scalar variables) and then check them. If one of them turns out not to - -- be scalar, the entire group is regarded as not being scalar. - -- - -- The second argument is a predicate that checks whether a type is scalar. - -- - is_scalar :: VarSet -> (Type -> Bool) -> CoreExpr -> Bool - is_scalar scalars _isScalarTC (Var v) = v `elemVarSet` scalars - is_scalar _scalars _isScalarTC (Lit _) = True - is_scalar scalars isScalarTC e@(App e1 e2) - | maybe_parr_ty (exprType e) = False - | otherwise = is_scalar scalars isScalarTC e1 && - is_scalar scalars isScalarTC e2 - is_scalar scalars isScalarTC (Lam var body) - | maybe_parr_ty (varType var) = False - | otherwise = is_scalar (scalars `extendVarSet` var) - isScalarTC body - is_scalar scalars isScalarTC (Let bind body) = bindsAreScalar && - is_scalar scalars' isScalarTC body - where - (bindsAreScalar, scalars') = is_scalar_bind scalars isScalarTC bind - is_scalar scalars isScalarTC (Case e var ty alts) - | isScalarTC ty = is_scalar scalars' isScalarTC e && - all (is_scalar_alt scalars' isScalarTC) alts - | otherwise = False - where - scalars' = scalars `extendVarSet` var - is_scalar scalars isScalarTC (Cast e _coe) = is_scalar scalars isScalarTC e - is_scalar scalars isScalarTC (Tick _ e ) = is_scalar scalars isScalarTC e - is_scalar _scalars _isScalarTC (Type {}) = True - is_scalar _scalars _isScalarTC (Coercion {}) = True - - -- Result: (<is this binding group scalar>, scalars ++ variables bound in this group) - is_scalar_bind scalars isScalarTCs (NonRec var e) = (is_scalar scalars isScalarTCs e, - scalars `extendVarSet` var) - is_scalar_bind scalars isScalarTCs (Rec bnds) = (all (is_scalar scalars' isScalarTCs) es, - scalars') - where - (vars, es) = unzip bnds - scalars' = scalars `extendVarSetList` vars - - is_scalar_alt scalars isScalarTCs (_, vars, e) = is_scalar (scalars `extendVarSetList ` vars) - isScalarTCs e - - -- Checks whether the type might be a parallel array type. In particular, if the outermost - -- constructor is a type family, we conservatively assume that it may be a parallel array type. - maybe_parr_ty :: Type -> Bool - maybe_parr_ty ty - | Just ty' <- coreView ty = maybe_parr_ty ty' - | Just (tyCon, _) <- splitTyConApp_maybe ty = isPArrTyCon tyCon || isSynFamilyTyCon tyCon - maybe_parr_ty _ = False - - -- FIXME: I'm not convinced that this reasoning is (always) sound. If the identify functions - -- is called by some other function that is otherwise scalar, it would be very bad - -- that just this call to the identity makes it not be scalar. - -- A scalar function has to actually compute something. Without the check, - -- we would treat (\(x :: Int) -> x) as a scalar function and lift it to - -- (map (\x -> x)) which is very bad. Normal lifting transforms it to - -- (\n# x -> x) which is what we want. - uses funs (Var v) = v `elemVarSet` funs - uses funs (App e1 e2) = uses funs e1 || uses funs e2 - uses funs (Lam b body) = uses (funs `extendVarSet` b) body - uses funs (Let (NonRec _b letExpr) body) - = uses funs letExpr || uses funs body - uses funs (Case e _eId _ty alts) - = uses funs e || any (uses_alt funs) alts - uses _ _ = False - - uses_alt funs (_, _bs, e) = uses funs e +vectScalarFunMaybe :: CoreExpr -- ^ Expression to be vectorised + -> VITree -- ^ Vectorisation information + -> VM VExpr +vectScalarFunMaybe expr (VITNode VIEncaps _) = vectScalarFun expr +vectScalarFunMaybe _expr _ = noV $ ptext (sLit "not a scalar function") + +-- |Vectorise an expression of functional type by lifting it by an application of a member of the +-- zipWith family (i.e., 'map', 'zipWith', zipWith3', etc.) This is only a valid strategy if the +-- function does not contain parallel subcomputations and has only 'Scalar' types in its result and +-- arguments — this is a predcondition for calling this function. +-- +-- Dictionary functions are also scalar functions (as dictionaries themselves are not vectorised, +-- instead they become dictionaries of vectorised methods). We treat them differently, though see +-- "Note [Scalar dfuns]" in 'Vectorise'. +-- +vectScalarFun :: CoreExpr -> VM VExpr +vectScalarFun expr + = do + { traceVt "vectScalarFun" (ppr expr) + ; let (arg_tys, res_ty) = splitFunTys (exprType expr) + ; mkScalarFun arg_tys res_ty expr + } -- Generate code for a scalar function by generating a scalar closure. If the function is a -- dictionary function, vectorise it as dictionary code. @@ -492,9 +608,8 @@ mkScalarFun arg_tys res_ty expr -- the application of the unvectorised dfun, to enable the dictionary selection rules to fire. -- vectScalarDFun :: Var -- ^ Original dfun - -> [Var] -- ^ Functions names in same recursive binding group -> VM CoreExpr -vectScalarDFun var recFns +vectScalarDFun var = do { -- bring the type variables into scope ; mapM_ defLocalTyVar tvs @@ -510,7 +625,7 @@ vectScalarDFun var recFns dict = Var var `mkTyApps` (mkTyVarTys tvs) `mkVarApps` thetaVars scsOps = map (\selId -> varToCoreExpr selId `mkTyApps` tys `mkApps` [dict]) selIds - ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun True recFns e) scsOps + ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun e) scsOps -- vectorised applications of the class-dictionary data constructor ; Just vDataCon <- lookupDataCon dataCon @@ -552,7 +667,7 @@ unVectDict ty e Nothing -> panic "Vectorise.Exp.unVectDict: no class" selIds = classAllSelIds cls --- |Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures. +-- Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures. -- -- All non-dictionary free variables go into the closure's environment, whereas the dictionary -- variables are passed explicit (as conventional arguments) into the body during closure @@ -561,8 +676,9 @@ unVectDict ty e vectLam :: Bool -- ^ When the RHS of a binding, whether that binding should be inlined. -> Bool -- ^ Whether the binding is a loop breaker. -> CoreExprWithFVs -- ^ Body of abstraction. + -> VITree -> VM VExpr -vectLam inline loop_breaker expr@(fvs, AnnLam _ _) +vectLam inline loop_breaker expr@(fvs, AnnLam _ _) vi = do { let (bndrs, body) = collectAnnValBinders expr -- grab the in-scope type variables @@ -590,13 +706,18 @@ vectLam inline loop_breaker expr@(fvs, AnnLam _ _) . hoistPolyVExpr tyvars vfvs_dict' (maybe_inline arity) $ do { -- generate the vectorised body of the lambda abstraction ; lc <- builtin liftingContext - ; (vbndrs, vbody) <- vectBndrsIn (fvs_nondict ++ bndrs) (vectExpr body) + ; let viBody = stripLams expr vi + -- ; checkTreeAnnM vi expr + ; (vbndrs, vbody) <- vectBndrsIn (fvs_nondict ++ bndrs) (vectExpr body viBody) ; vbody' <- break_loop lc res_ty vbody ; return $ vLams lc vbndrs vbody' } } where + stripLams (_, AnnLam _ e) (VITNode _ [vt]) = stripLams e vt + stripLams _ vi = vi + maybe_inline n | inline = Inline n | otherwise = DontInline @@ -614,10 +735,11 @@ vectLam inline loop_breaker expr@(fvs, AnnLam _ _) (LitAlt (mkMachInt 0), [], empty)]) } | otherwise = return (ve, le) -vectLam _ _ _ = panic "vectLam" +vectLam _ _ _ _ = panic "vectLam" --- | Vectorise an algebraic case expression. --- We convert +-- Vectorise an algebraic case expression. +-- +-- We convert -- -- case e :: t of v { ... } -- @@ -632,31 +754,31 @@ vectLam _ _ _ = panic "vectLam" -- -- FIXME: this is too lazy -vectAlgCase :: TyCon -> [Type] -> CoreExprWithFVs -> Var -> Type - -> [(AltCon, [Var], CoreExprWithFVs)] +vectAlgCase :: TyCon -> [Type] -> CoreExprWithFVs-> Var -> Type + -> [(AltCon, [Var], CoreExprWithFVs)] -> VITree -> VM VExpr -vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)] +vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)] (VITNode _ (scrutVit : [altVit])) = do - vscrut <- vectExpr scrut + vscrut <- vectExpr scrut scrutVit (vty, lty) <- vectAndLiftType ty - (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) + (vbndr, vbody) <- vectBndrIn bndr (vectExpr body altVit) return $ vCaseDEFAULT vscrut vbndr vty lty vbody -vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)] +vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)] (VITNode _ (scrutVit : [altVit])) = do - vscrut <- vectExpr scrut + vscrut <- vectExpr scrut scrutVit (vty, lty) <- vectAndLiftType ty - (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) + (vbndr, vbody) <- vectBndrIn bndr (vectExpr body altVit) return $ vCaseDEFAULT vscrut vbndr vty lty vbody -vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)] +vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)] (VITNode _ (scrutVit : [altVit])) = do (vty, lty) <- vectAndLiftType ty - vexpr <- vectExpr scrut + vexpr <- vectExpr scrut scrutVit (vbndr, (vbndrs, (vect_body, lift_body))) <- vect_scrut_bndr . vectBndrsIn bndrs - $ vectExpr body + $ vectExpr body altVit let (vect_bndrs, lift_bndrs) = unzip vbndrs (vscrut, lscrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr) vect_dc <- maybeV dataConErr (lookupDataCon dc) @@ -674,7 +796,7 @@ vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)] dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc) -vectAlgCase tycon _ty_args scrut bndr ty alts +vectAlgCase tycon _ty_args scrut bndr ty alts (VITNode _ (scrutVit : altVits)) = do vect_tc <- maybeV tyConErr (lookupTyCon tycon) (vty, lty) <- vectAndLiftType ty @@ -685,10 +807,10 @@ vectAlgCase tycon _ty_args scrut bndr ty alts let sel = Var sel_bndr (vbndr, valts) <- vect_scrut_bndr - $ mapM (proc_alt arity sel vty lty) alts' + $ mapM (proc_alt arity sel vty lty) (zip alts' altVits) let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts - vexpr <- vectExpr scrut + vexpr <- vectExpr scrut scrutVit (vect_scrut, lift_scrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr) let (vect_bodies, lift_bodies) = unzip vbodies @@ -720,7 +842,7 @@ vectAlgCase tycon _ty_args scrut bndr ty alts cmp _ DEFAULT = GT cmp _ _ = panic "vectAlgCase/cmp" - proc_alt arity sel _ lty (DataAlt dc, bndrs, body) + proc_alt arity sel _ lty ((DataAlt dc, bndrs, body), vi) = do vect_dc <- maybeV dataConErr (lookupDataCon dc) let ntag = dataConTagZ vect_dc @@ -738,7 +860,7 @@ vectAlgCase tycon _ty_args scrut bndr ty alts binds <- mapM (pack_var (Var lc) sel_tags tag) . filter isLocalId $ varSetElems fvs - (ve, le) <- vectExpr body + (ve, le) <- vectExpr body vi return (ve, Case (elems `App` sel) lc lty [(DEFAULT, [], (mkLets (concat binds) le))]) -- empty <- emptyPD vty @@ -769,4 +891,216 @@ vectAlgCase tycon _ty_args scrut bndr ty alts return [(NonRec lv' expr)] _ -> return [] + +vectAlgCase tycon _ty_args _scrut _bndr _ty _alts (VITNode _ _) + = pprPanic "vectAlgCase (mismatched node information)" (ppr tycon) + + +-- Support to compute information for vectorisation avoidance ------------------ + +-- Annotation for Core AST nodes that describes how they should be handled during vectorisation +-- and especially if vectorisation of the corresponding computation can be avoided. +-- +data VectAvoidInfo = VIParr -- tree contains parallel computations + | VISimple -- result type is scalar & no parallel subcomputation + | VIComplex -- any result type, no parallel subcomputation + | VIEncaps -- tree encapsulated by 'liftSimple' + deriving (Eq, Show) + +-- Instead of integrating the vectorisation avoidance information into Core expression, we keep +-- them in a separate tree (that structurally mirrors the Core expression that it annotates). +-- +data VITree = VITNode VectAvoidInfo [VITree] + deriving (Show) + +-- Is any of the tree nodes a 'VIPArr' node? +-- +anyVIPArr :: [VITree] -> Bool +anyVIPArr = or . (map (\(VITNode vi _) -> vi == VIParr)) + +-- Compute Core annotations to determine for which subexpressions we can avoid vectorisation +-- +-- FIXME: free scalar vars don't actually need to be passed through, since encapsulations makes sure, +-- that there are no free variables in encapsulated lambda expressions +vectAvoidInfo :: CoreExprWithFVs -> VM VITree +vectAvoidInfo ce@(_, AnnVar v) + = do { vi <- vectAvoidInfoType $ exprType $ deAnnotate ce + ; viTrace ce vi [] + ; traceVt "vectAvoidInfo AnnVar" ((ppr v) <+> (ppr $ exprType $ deAnnotate ce)) + ; return $ VITNode vi [] + } + +vectAvoidInfo ce@(_, AnnLit _) + = do { vi <- vectAvoidInfoType $ exprType $ deAnnotate ce + ; viTrace ce vi [] + ; traceVt "vectAvoidInfo AnnLit" (ppr $ exprType $ deAnnotate ce) + ; return $ VITNode vi [] + } + +vectAvoidInfo ce@(_, AnnApp e1 e2) + = do { vt1 <- vectAvoidInfo e1 + ; vt2 <- vectAvoidInfo e2 + ; vi <- if anyVIPArr [vt1, vt2] + then return VIParr + else vectAvoidInfoType $ exprType $ deAnnotate ce + ; viTrace ce vi [vt1, vt2] + ; return $ VITNode vi [vt1, vt2] + } + +vectAvoidInfo ce@(_, AnnLam _var body) + = do { vt@(VITNode vi _) <- vectAvoidInfo body + ; viTrace ce vi [vt] + ; let resultVI | vi == VIParr = VIParr + | otherwise = VIComplex + ; return $ VITNode resultVI [vt] + } + +vectAvoidInfo ce@(_, AnnLet (AnnNonRec _var expr) body) + = do { vtE <- vectAvoidInfo expr + ; vtB <- vectAvoidInfo body + ; vi <- if anyVIPArr [vtE, vtB] + then return VIParr + else vectAvoidInfoType $ exprType $ deAnnotate ce + ; viTrace ce vi [vtE, vtB] + ; return $ VITNode vi [vtE, vtB] + } + +vectAvoidInfo ce@(_, AnnLet (AnnRec bnds) body) + = do { let (_, exprs) = unzip bnds + ; vtBnds <- mapM (\e -> vectAvoidInfo e) exprs + ; if (anyVIPArr vtBnds) + then do { vtBnds' <- mapM (\e -> vectAvoidInfo e) exprs + ; vtB <- vectAvoidInfo body + ; return (VITNode VIParr (vtB: vtBnds')) + } + else do { vtB@(VITNode vib _) <- vectAvoidInfo body + ; ni <- if (vib == VIParr) + then return VIParr + else vectAvoidInfoType $ exprType $ deAnnotate ce + ; viTrace ce ni (vtB : vtBnds) + ; return $ VITNode ni (vtB : vtBnds) + } + } + +vectAvoidInfo ce@(_, AnnCase expr _var _ty alts) + = do { vtExpr <- vectAvoidInfo expr + ; vtAlts <- mapM (\(_, _, e) -> vectAvoidInfo e) alts + ; ni <- if anyVIPArr (vtExpr : vtAlts) + then return VIParr + else vectAvoidInfoType $ exprType $ deAnnotate ce + ; viTrace ce ni (vtExpr : vtAlts) + ; return $ VITNode ni (vtExpr: vtAlts) + } + +vectAvoidInfo (_, AnnCast expr _) + = do { vt@(VITNode vi _) <- vectAvoidInfo expr + ; return $ VITNode vi [vt] + } + +vectAvoidInfo (_, AnnTick _ expr) + = do { vt@(VITNode vi _) <- vectAvoidInfo expr + ; return $ VITNode vi [vt] + } + +vectAvoidInfo (_, AnnType {}) + = return $ VITNode VISimple [] + +vectAvoidInfo (_, AnnCoercion {}) + = return $ VITNode VISimple [] + +-- Compute vectorisation avoidance information for a type. +-- +vectAvoidInfoType :: Type -> VM VectAvoidInfo +vectAvoidInfoType ty + | maybeParrTy ty = return VIParr + | otherwise + = do { sType <- isSimpleType ty + ; if sType + then return VISimple + else return VIComplex + } + +-- Checks whether the type might be a parallel array type. In particular, if the outermost +-- constructor is a type family, we conservatively assume that it may be a parallel array type. +-- +maybeParrTy :: Type -> Bool +maybeParrTy ty + | Just ty' <- coreView ty = maybeParrTy ty' + | Just (tyCon, ts) <- splitTyConApp_maybe ty = isPArrTyCon tyCon || isSynFamilyTyCon tyCon + || or (map maybeParrTy ts) +maybeParrTy _ = False + +-- FIXME: This should not be hardcoded. +isSimpleType :: Type -> VM Bool +isSimpleType ty + | Just (c, _cs) <- splitTyConApp_maybe ty + = return $ (tyConName c) `elem` [boolTyConName, intTyConName, word8TyConName, doubleTyConName, floatTyConName] +{- + = do { globals <- globalScalarTyCons + ; traceVt ("isSimpleType " ++ (show (elemNameSet (tyConName c) globals ))) (ppr c) + ; return (elemNameSet (tyConName c) globals ) + } + -} + | Nothing <- splitTyConApp_maybe ty + = return False +isSimpleType ty + = pprPanic "Vectorise.Exp.isSimpleType not handled" (ppr ty) + +varsSimple :: VarSet -> VM Bool +varsSimple vs + = do { varTypes <- mapM isSimpleType $ map varType $ varSetElems vs + ; return $ and varTypes + } + +viTrace :: CoreExprWithFVs -> VectAvoidInfo -> [VITree] -> VM () +viTrace ce vi vTs + = traceVt ("vitrace " ++ (show vi) ++ "[" ++ (concat $ map (\(VITNode vi _) -> show vi ++ " ") vTs) ++"]") + (ppr $ deAnnotate ce) + + +{- +---- Sanity check of the tree, for debugging only +checkTree :: VITree -> CoreExpr -> Bool +checkTree (VITNode _ []) (Type _ty) + = True + +checkTree (VITNode _ []) (Var _v) + = True + +checkTree (VITNode _ []) (Lit _) + = True + +checkTree (VITNode _ [vit]) (Tick _ expr) + = checkTree vit expr + +checkTree (VITNode _ [vit]) (Lam _ expr) + = checkTree vit expr + +checkTree (VITNode _ [vit1, vit2]) (App ce1 ce2) + = (checkTree vit1 ce1) && (checkTree vit2 ce2) + +checkTree (VITNode _ (scrutVit : altVits)) (Case scrut _ _ alts) + = (checkTree scrutVit scrut) && (and $ zipWith checkAlt altVits alts) + where + checkAlt vt (_, _, expr) = checkTree vt expr + +checkTree (VITNode _ [vt1, vt2]) (Let (NonRec _ expr1) expr2) + = (checkTree vt1 expr1) && (checkTree vt2 expr2) + +checkTree (VITNode _ (vtB : vtBnds)) (Let (Rec bndngs) expr) + = (and $ zipWith checkBndr vtBnds bndngs) && + (checkTree vtB expr) + where + checkBndr vt (_, e) = checkTree vt e + +checkTree (VITNode _ [vit]) (Cast expr _) + = checkTree vit expr + +checkTree _ _ = False +checkTreeAnnM:: VITree -> CoreExprWithFVs -> VM () +checkTreeAnnM vi e = + if not (checkTree vi $ deAnnotate e) + then error ("checkTreeAnnM : \n " ++ show vi) + else return () +-} diff --git a/compiler/vectorise/Vectorise/Generic/Description.hs b/compiler/vectorise/Vectorise/Generic/Description.hs index eed01b0818..e6a2ee174e 100644 --- a/compiler/vectorise/Vectorise/Generic/Description.hs +++ b/compiler/vectorise/Vectorise/Generic/Description.hs @@ -288,4 +288,5 @@ defined by the data instance. For example with: The type constructor corresponding to the instance will be named 'PDataSum2', and this is what we will get in the repr_psum_tc field of SumRepr.Sum. --}
\ No newline at end of file +-} + diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs index d73bea17ee..20aab59182 100644 --- a/compiler/vectorise/Vectorise/Generic/PADict.hs +++ b/compiler/vectorise/Vectorise/Generic/PADict.hs @@ -19,6 +19,7 @@ import Type import Id import Var import Name +import FastString -- |Build the PA dictionary function for some type and hoist it to top level. @@ -26,15 +27,15 @@ import Name -- The PA dictionary holds fns that convert values to and from their vectorised representations. -- -- @Recall the definition: --- class class PR (PRepr a) => PA a where +-- class PR (PRepr a) => PA a where -- toPRepr :: a -> PRepr a -- fromPRepr :: PRepr a -> a -- toArrPRepr :: PData a -> PData (PRepr a) -- fromArrPRepr :: PData (PRepr a) -> PData a -- -- Example: --- df :: forall a. PA a -> PA (T a) --- df = /\a. \(d:PA a). MkPA ($PR_df a d) ($toPRepr a d) ... +-- df :: forall a. PR (PRepr a) -> PA a -> PA (T a) +-- df = /\a. \(c:PR (PRepr a)) (d:PA a). MkPA c ($PR_df a d) ($toPRepr a d) ... -- $dPR_df :: forall a. PA a -> PR (PRepr (T a)) -- $dPR_df = .... -- $toRepr :: forall a. PA a -> T a -> PRepr (T a) @@ -52,34 +53,48 @@ buildPADict -> VM Var -- ^ name of the top-level dictionary function. buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr - = polyAbstract tvs $ \args -> -- The args are the dictionaries we lambda - -- abstract over; and they are put in the - -- envt, so when we need a (PA a) we can - -- find it in the envt + = polyAbstract tvs $ \args -> -- The args are the dictionaries we lambda abstract over; and they + -- are put in the envt, so when we need a (PA a) we can find it in + -- the envt; they don't include the silent superclass args yet do { mod <- liftDs getModuleDs ; let dfun_name = mkLocalisedOccName mod mkPADFunOcc vect_tc_name - + + -- The superclass dictionary is a (silent) argument if the tycon is polymorphic... + ; let mk_super_ty = do { r <- mkPReprType inst_ty + ; pr_cls <- builtin prClass + ; return $ mkClassPred pr_cls [r] + } + ; super_tys <- sequence [mk_super_ty | not (null tvs)] + ; super_args <- mapM (newLocalVar (fsLit "pr")) super_tys + ; let all_args = super_args ++ args + + -- ...it is constant otherwise + ; super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_ax [] | null tvs] + -- Get ids for each of the methods in the dictionary, including superclass ; paMethodBuilders <- buildPAScAndMethods - ; method_ids <- mapM (method args dfun_name) paMethodBuilders + ; method_ids <- mapM (method all_args dfun_name) paMethodBuilders -- Expression to build the dictionary. ; pa_dc <- builtin paDataCon - ; let dict = mkLams (tvs ++ args) + ; let dict = mkLams (tvs ++ all_args) $ mkConApp pa_dc $ Type inst_ty - : map (method_call args) method_ids + : map Var super_args ++ super_consts -- the superclass dictionary is either lambda-bound or constant + ++ map (method_call all_args) method_ids -- Build the type of the dictionary function. ; pa_cls <- builtin paClass ; let dfun_ty = mkForAllTys tvs - $ mkFunTys (map varType args) + $ mkFunTys (map varType all_args) (mkClassPred pa_cls [inst_ty]) -- Set the unfolding for the inliner. ; raw_dfun <- newExportedVar dfun_name dfun_ty ; let dfun_unf = mkDFunUnfolding dfun_ty $ - map Var method_ids + map (const $ DFunLamArg 0) super_args + -- ++ map DFunConstArg super_consts + ++ map (DFunPolyArg . Var) method_ids dfun = raw_dfun `setIdUnfolding` dfun_unf `setInlinePragma` dfunInlinePragma diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs index ce2d947519..61c07cd299 100644 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -23,6 +23,7 @@ import OccName import Coercion import MkId +import DynFlags import FastString import MonadUtils import Control.Monad @@ -67,8 +68,7 @@ type PAInstanceBuilder buildPAScAndMethods :: VM [(String, PAInstanceBuilder)] buildPAScAndMethods - = return [ ("PR", buildPRDict) - , ("toPRepr", buildToPRepr) + = return [ ("toPRepr", buildToPRepr) , ("fromPRepr", buildFromPRepr) , ("toArrPRepr", buildToArrPRepr) , ("fromArrPRepr", buildFromArrPRepr) @@ -76,14 +76,6 @@ buildPAScAndMethods , ("fromArrPReprs", buildFromArrPReprs)] -buildPRDict :: PAInstanceBuilder -buildPRDict vect_tc prepr_ax _ _ _ - = prDictOfPReprInstTyCon inst_ty prepr_ax arg_tys - where - arg_tys = mkTyVarTys (tyConTyVars vect_tc) - inst_ty = mkTyConApp vect_tc arg_tys - - -- buildToPRepr --------------------------------------------------------------- -- | Build the 'toRepr' method of the PA class. buildToPRepr :: PAInstanceBuilder @@ -394,8 +386,10 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r = case ss of -- We can't convert data types with no data. -- See Note: [Empty PDatas]. - EmptySum -> return ([], errorEmptyPDatas el_ty) - UnarySum r -> to_con (errorEmptyPDatas el_ty) r + EmptySum -> do dflags <- getDynFlags + return ([], errorEmptyPDatas dflags el_ty) + UnarySum r -> do dflags <- getDynFlags + to_con (errorEmptyPDatas dflags el_ty) r Sum{} -> do let psums_tc = repr_psums_tc ss @@ -486,7 +480,8 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r = case ss of -- We can't convert data types with no data. -- See Note: [Empty PDatas]. - EmptySum -> return (res, errorEmptyPDatas el_ty) + EmptySum -> do dflags <- getDynFlags + return (res, errorEmptyPDatas dflags el_ty) UnarySum r -> from_con res_ty res expr r Sum {} @@ -572,9 +567,9 @@ To fix this we'd need to add an Int field to VPDs:Empty1 as well, but that's too much hassle and there's no point running a parallel computation on no data anyway. -} -errorEmptyPDatas :: Type -> a -errorEmptyPDatas tc - = cantVectorise "Vectorise.PAMethods" +errorEmptyPDatas :: DynFlags -> Type -> a +errorEmptyPDatas dflags tc + = cantVectorise dflags "Vectorise.PAMethods" $ vcat [ text "Cannot vectorise data type with no parallel data " <> quotes (ppr tc) , text "Data types to be vectorised must contain at least one constructor" , text "with at least one field." ] diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index 1026e95029..49997f8502 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -47,6 +47,7 @@ buildDataFamInst name' fam_tc vect_tc rhs pat_tys = [mkTyConApp vect_tc (mkTyVarTys tyvars)] rep_tc = buildAlgTyCon name' tyvars + Nothing [] -- no stupid theta rhs rec_flag -- FIXME: is this ok? @@ -149,4 +150,5 @@ mkSumTys repr_selX_ty mkTc repr mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type]) mk_fam_inst fam_tc arg_tc = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc]) --}
\ No newline at end of file +-} + diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 426682cea8..375b0af85e 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -43,8 +43,6 @@ import Name import ErrUtils import Outputable -import System.IO - -- |Run a vectorisation computation. -- @@ -69,7 +67,9 @@ initV hsc_env guts info thing_inside ; return res } where - dumpIfVtTrace = dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_vt_trace + dflags = hsc_dflags hsc_env + + dumpIfVtTrace = dumpIfSet_dyn dflags Opt_D_dump_vt_trace bindsToIds (NonRec v _) = [v] bindsToIds (Rec binds) = map fst binds @@ -100,7 +100,7 @@ initV hsc_env guts info thing_inside Yes genv _ x -> return $ Just (new_info genv, x) No reason -> do { unqual <- mkPrintUnqualifiedDs ; liftIO $ - printForUser stderr unqual $ + printInfoForUser dflags unqual $ mkDumpDoc "Warning: vectorisation failure:" reason ; return Nothing } @@ -151,7 +151,9 @@ lookupVar v = do { mb_res <- lookupVar_maybe v ; case mb_res of Just x -> return x - Nothing -> dumpVar v + Nothing -> + do dflags <- getDynFlags + dumpVar dflags v } lookupVar_maybe :: Var -> VM (Maybe (Scope Var (Var, Var))) @@ -162,12 +164,12 @@ lookupVar_maybe v Nothing -> fmap Global <$> (readGEnv $ \env -> lookupVarEnv (global_vars env) v) } -dumpVar :: Var -> a -dumpVar var +dumpVar :: DynFlags -> Var -> a +dumpVar dflags var | Just _ <- isClassOpId_maybe var - = cantVectorise "ClassOpId not vectorised:" (ppr var) + = cantVectorise dflags "ClassOpId not vectorised:" (ppr var) | otherwise - = cantVectorise "Variable not vectorised:" (ppr var) + = cantVectorise dflags "Variable not vectorised:" (ppr var) -- Global scalars -------------------------------------------------------------- diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs index 91a9552a7e..bb0d045b41 100644 --- a/compiler/vectorise/Vectorise/Monad/Base.hs +++ b/compiler/vectorise/Vectorise/Monad/Base.hs @@ -34,10 +34,8 @@ import TcRnMonad import ErrUtils import Outputable import DynFlags -import StaticFlags import Control.Monad -import System.IO (stderr) -- The Vectorisation Monad ---------------------------------------------------- @@ -70,6 +68,8 @@ instance Functor VM where instance MonadIO VM where liftIO = liftDs . liftIO +instance HasDynFlags VM where + getDynFlags = liftDs getDynFlags -- Lifting -------------------------------------------------------------------- @@ -83,27 +83,30 @@ liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) } -- |Throw a `pgmError` saying we can't vectorise something. -- -cantVectorise :: String -> SDoc -> a -cantVectorise s d = pgmError - . showSDoc +cantVectorise :: DynFlags -> String -> SDoc -> a +cantVectorise dflags s d = pgmError + . showSDoc dflags $ vcat [text "*** Vectorisation error ***", nest 4 $ sep [text s, nest 4 d]] -- |Like `fromJust`, but `pgmError` on Nothing. -- -maybeCantVectorise :: String -> SDoc -> Maybe a -> a -maybeCantVectorise s d Nothing = cantVectorise s d -maybeCantVectorise _ _ (Just x) = x +maybeCantVectorise :: DynFlags -> String -> SDoc -> Maybe a -> a +maybeCantVectorise dflags s d Nothing = cantVectorise dflags s d +maybeCantVectorise _ _ _ (Just x) = x -- |Like `maybeCantVectorise` but in a `Monad`. -- -maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a +maybeCantVectoriseM :: (Monad m, HasDynFlags m) + => String -> SDoc -> m (Maybe a) -> m a maybeCantVectoriseM s d p = do r <- p case r of Just x -> return x - Nothing -> cantVectorise s d + Nothing -> + do dflags <- getDynFlags + cantVectorise dflags s d -- Debugging ------------------------------------------------------------------ @@ -112,18 +115,18 @@ maybeCantVectoriseM s d p -- emitVt :: String -> SDoc -> VM () emitVt herald doc - = liftDs $ - liftIO . printForUser stderr alwaysQualify $ + = liftDs $ do + dflags <- getDynFlags + liftIO . printInfoForUser dflags alwaysQualify $ hang (text herald) 2 doc -- |Output a trace message if -ddump-vt-trace is active. -- traceVt :: String -> SDoc -> VM () traceVt herald doc - | 1 <= opt_TraceLevel = liftDs $ - traceOptIf Opt_D_dump_vt_trace $ - hang (text herald) 2 doc - | otherwise = return () + = do dflags <- getDynFlags + when (1 <= traceLevel dflags) $ + liftDs $ traceOptIf Opt_D_dump_vt_trace $ hang (text herald) 2 doc -- |Dump the given program conditionally. -- @@ -140,7 +143,8 @@ dumpOptVt flag header doc dumpVt :: String -> SDoc -> VM () dumpVt header doc = do { unqual <- liftDs mkPrintUnqualifiedDs - ; liftIO $ printForUser stderr unqual (mkDumpDoc header doc) + ; dflags <- liftDs getDynFlags + ; liftIO $ printInfoForUser dflags unqual (mkDumpDoc header doc) } @@ -185,8 +189,9 @@ tryErrV (VM p) = VM $ \bi genv lenv -> case r of Yes genv' lenv' x -> return (Yes genv' lenv' (Just x)) No reason -> do { unqual <- mkPrintUnqualifiedDs + ; dflags <- getDynFlags ; liftIO $ - printForUser stderr unqual $ + printInfoForUser dflags unqual $ text "Warning: vectorisation failure:" <+> reason ; return (Yes genv lenv Nothing) } diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs index e728d6aa22..a5c8449fc2 100644 --- a/compiler/vectorise/Vectorise/Monad/Global.hs +++ b/compiler/vectorise/Vectorise/Monad/Global.hs @@ -37,6 +37,7 @@ import CoreSyn import Type import TyCon import DataCon +import DynFlags import NameEnv import NameSet import Name @@ -76,7 +77,9 @@ defGlobalVar v v' -- check for duplicate vectorisation ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v ; case currentDef of - Just old_v' -> cantVectorise "Variable is already vectorised:" $ + Just old_v' -> + do dflags <- getDynFlags + cantVectorise dflags "Variable is already vectorised:" $ ppr v <+> moduleOf v old_v' Nothing -> return () @@ -147,7 +150,9 @@ defTyConName tc nameOfTc' tc' -- check for duplicate vectorisation ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) ; case currentDef of - Just old_tc' -> cantVectorise "Type constructor or class is already vectorised:" $ + Just old_tc' -> + do dflags <- getDynFlags + cantVectorise dflags "Type constructor or class is already vectorised:" $ ppr tc <+> moduleOf tc old_tc' Nothing -> return () diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs index 971fd8ff1f..fc12ee567c 100644 --- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -8,12 +8,14 @@ import Vectorise.Monad.Global import Vectorise.Monad.Base import Vectorise.Env +import DynFlags import FamInstEnv import InstEnv import Class import Type import TyCon import Outputable +import Util #include "HsVersions.h" @@ -33,16 +35,18 @@ lookupInst cls tys = do { instEnv <- readGEnv global_inst_env ; case lookupUniqueInstEnv instEnv cls tys of Right (inst, inst_tys) -> return (instanceDFunId inst, inst_tys) - Left err -> cantVectorise "Vectorise.Monad.InstEnv.lookupInst:" err + Left err -> + do dflags <- getDynFlags + cantVectorise dflags "Vectorise.Monad.InstEnv.lookupInst:" err } --- Look up the representation tycon of a family instance. +-- Look up a family instance. -- -- The match must be unique - ie, match exactly one instance - but the -- type arguments used for matching may be more specific than those of -- the family instance declaration. -- --- Return the instance tycon and its type instance. For example, if we have +-- Return the family instance and its type instance. For example, if we have -- -- lookupFamInst 'T' '[Int]' yields (':R42T', 'Int') -- @@ -52,14 +56,14 @@ lookupInst cls tys -- -- which implies that :R42T was declared as 'data instance T [a]'. -- -lookupFamInst :: TyCon -> [Type] -> VM (TyCon, [Type]) +lookupFamInst :: TyCon -> [Type] -> VM (FamInst, [Type]) lookupFamInst tycon tys = ASSERT( isFamilyTyCon tycon ) do { instEnv <- readGEnv global_fam_inst_env ; case lookupFamInstEnv instEnv tycon tys of - [(fam_inst, rep_tys)] -> return ( dataFamInstRepTyCon fam_inst - , rep_tys) + [(fam_inst, rep_tys)] -> return ( fam_inst, rep_tys) _other -> - cantVectorise "VectMonad.lookupFamInst: not found: " + do dflags <- getDynFlags + cantVectorise dflags "VectMonad.lookupFamInst: not found: " (ppr $ mkTyConApp tycon tys) } diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs index ead7f14ea7..0cab706cf4 100644 --- a/compiler/vectorise/Vectorise/Type/Classify.hs +++ b/compiler/vectorise/Vectorise/Type/Classify.hs @@ -114,4 +114,5 @@ tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys) tyConsOfType (AppTy a b) = tyConsOfType a `unionUniqSets` tyConsOfType b tyConsOfType (FunTy a b) = (tyConsOfType a `unionUniqSets` tyConsOfType b) `addOneToUniqSet` funTyCon +tyConsOfType (LitTy _) = emptyUniqSet tyConsOfType (ForAllTy _ ty) = tyConsOfType ty diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 9b830446c8..05b78246db 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -11,6 +11,7 @@ import Type import TyCon import DataCon import BasicTypes +import DynFlags import Var import Name import Outputable @@ -35,7 +36,8 @@ vectTyConDecl tycon name' -- Type constructor representing a type class | Just cls <- tyConClass_maybe tycon = do { unless (null $ classATs cls) $ - cantVectorise "Associated types are not yet supported" (ppr cls) + do dflags <- getDynFlags + cantVectorise dflags "Associated types are not yet supported" (ppr cls) -- vectorise superclass constraint (types) ; theta' <- mapM vectType (classSCTheta cls) @@ -83,7 +85,8 @@ vectTyConDecl tycon name' -- Regular algebraic type constructor — for now, Haskell 2011-style only | isAlgTyCon tycon = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $ - cantVectorise "Currently only Haskell 2011 datatypes are supported" (ppr tycon) + do dflags <- getDynFlags + cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon) -- vectorise the data constructor of the class tycon ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon) @@ -96,6 +99,7 @@ vectTyConDecl tycon name' ; return $ buildAlgTyCon name' -- new name (tyConTyVars tycon) -- keep original type vars + Nothing [] -- no stupid theta rhs' -- new constructor defs rec_flag -- whether recursive @@ -105,7 +109,8 @@ vectTyConDecl tycon name' -- some other crazy thing that we don't handle | otherwise - = cantVectorise "Can't vectorise exotic type constructor" (ppr tycon) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon) -- |Vectorise a class method. (Don't enter it into the vectorisation map yet.) -- @@ -124,7 +129,8 @@ vectMethod id defMeth ty -- vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs vectAlgTyConRhs tc (AbstractTyCon {}) - = cantVectorise "Can't vectorise imported abstract type" (ppr tc) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc) vectAlgTyConRhs _tc DataFamilyTyCon = return DataFamilyTyCon vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons @@ -137,7 +143,8 @@ vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons } } vectAlgTyConRhs tc (NewTyCon {}) - = cantVectorise noNewtypeErr (ppr tc) + = do dflags <- getDynFlags + cantVectorise dflags noNewtypeErr (ppr tc) where noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration" @@ -146,13 +153,17 @@ vectAlgTyConRhs tc (NewTyCon {}) vectDataCon :: DataCon -> VM DataCon vectDataCon dc | not . null $ ex_tvs - = cantVectorise "Can't vectorise constructor with existential type variables yet" (ppr dc) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc) | not . null $ eq_spec - = cantVectorise "Can't vectorise constructor with equality context yet" (ppr dc) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc) | not . null $ dataConFieldLabels dc - = cantVectorise "Can't vectorise constructor with labelled fields yet" (ppr dc) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc) | not . null $ theta - = cantVectorise "Can't vectorise constructor with constraint context yet" (ppr dc) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc) | otherwise = do { name' <- mkLocalisedName mkVectDataConOcc name ; tycon' <- vectTyCon tycon diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs index db724ad4bf..a7ec86a296 100644 --- a/compiler/vectorise/Vectorise/Type/Type.hs +++ b/compiler/vectorise/Vectorise/Type/Type.hs @@ -59,6 +59,7 @@ vectType ty | Just ty' <- coreView ty = vectType ty' vectType (TyVarTy tv) = return $ TyVarTy tv +vectType (LitTy l) = return $ LitTy l vectType (AppTy ty1 ty2) = AppTy <$> vectType ty1 <*> vectType ty2 vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys vectType (FunTy ty1 ty2) diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index 2b47ddfb9b..9ed4e2c60e 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -21,6 +21,8 @@ module Vectorise.Utils.Base , pdataReprTyConExact , pdatasReprTyConExact , pdataUnwrapScrut + + , preprSynTyCon ) where import Vectorise.Monad @@ -29,6 +31,7 @@ import Vectorise.Builtins import CoreSyn import CoreUtils +import FamInstEnv import Coercion import Type import TyCon @@ -200,7 +203,11 @@ unwrapNewTypeBodyOfPDatasWrap e ty -- a set of distinct type variables. -- pdataReprTyCon :: Type -> VM (TyCon, [Type]) -pdataReprTyCon ty = builtin pdataTyCon >>= (`lookupFamInst` [ty]) +pdataReprTyCon ty + = do + { (famInst, tys) <- builtin pdataTyCon >>= (`lookupFamInst` [ty]) + ; return (dataFamInstRepTyCon famInst, tys) + } -- |Get the representation tycon of the 'PData' data family for a given type constructor. -- @@ -225,7 +232,7 @@ pdatasReprTyConExact tycon = do { -- look up the representation tycon; if there is a match at all, it will be be exact ; -- (i.e.,' _tys' will be distinct type variables) ; (ptycon, _tys) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon)) - ; return ptycon + ; return $ dataFamInstRepTyCon ptycon } where pdatasReprTyCon ty = builtin pdatasTyCon >>= (`lookupFamInst` [ty]) @@ -240,3 +247,11 @@ pdataUnwrapScrut (ve, le) } where ty = exprType ve + + +-- 'PRepr' representation types ---------------------------------------------- + +-- |Get the representation tycon of the 'PRepr' type family for a given type. +-- +preprSynTyCon :: Type -> VM (FamInst, [Type]) +preprSynTyCon ty = builtin preprTyCon >>= (`lookupFamInst` [ty]) diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index dfc08bcf58..85060c477c 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -12,12 +12,14 @@ import Vectorise.Utils.Base import CoreSyn import CoreUtils +import FamInstEnv import Coercion import Type import TypeRep import TyCon import Var import Outputable +import DynFlags import FastString import Control.Monad @@ -65,26 +67,37 @@ paDictOfType ty -- for type variables, look up the dfun and apply to the PA dictionaries -- of the type arguments paDictOfTyApp (TyVarTy tv) ty_args - = do dfun <- maybeCantVectoriseM "No PA dictionary for type variable" + = do + { dfun <- maybeCantVectoriseM "No PA dictionary for type variable" (ppr tv <+> text "in" <+> ppr ty) $ lookupTyVarPA tv - dicts <- mapM paDictOfType ty_args - return $ dfun `mkTyApps` ty_args `mkApps` dicts + ; dicts <- mapM paDictOfType ty_args + ; return $ dfun `mkTyApps` ty_args `mkApps` dicts + } -- for tycons, we also need to apply the dfun to the PR dictionary of -- the representation type if the tycon is polymorphic paDictOfTyApp (TyConApp tc []) ty_args - = do - dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty) + = do + { dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty) $ lookupTyConPA tc - dicts <- mapM paDictOfType ty_args - return $ Var dfun `mkTyApps` ty_args `mkApps` dicts - where - noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)" - - paDictOfTyApp _ _ = failure - - failure = cantVectorise "Can't construct PA dictionary for type" (ppr ty) + ; super <- super_dict tc ty_args + ; dicts <- mapM paDictOfType ty_args + ; return $ Var dfun `mkTyApps` ty_args `mkApps` super `mkApps` dicts + } + where + noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)" + + super_dict _ [] = return [] + super_dict tycon ty_args + = do + { pr <- prDictOfPReprInst (TyConApp tycon ty_args) + ; return [pr] + } + + paDictOfTyApp _ _ = getDynFlags >>= failure + + failure dflags = cantVectorise dflags "Can't construct PA dictionary for type" (ppr ty) -- |Produce code that refers to a method of the 'PA' class. -- @@ -94,11 +107,21 @@ paMethod _ query ty = liftM Var $ builtin (query tycon) paMethod method _ ty = do - fn <- builtin method - dict <- paDictOfType ty - return $ mkApps (Var fn) [Type ty, dict] + { fn <- builtin method + ; dict <- paDictOfType ty + ; return $ mkApps (Var fn) [Type ty, dict] + } + +-- |Given a type @ty@, return the PR dictionary for @PRepr ty@. +-- +prDictOfPReprInst :: Type -> VM CoreExpr +prDictOfPReprInst ty + = do + { (prepr_fam, prepr_args) <- preprSynTyCon ty + ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args + } --- | Given a type @ty@, its PRepr synonym tycon and its type arguments, +-- |Given a type @ty@, its PRepr synonym tycon and its type arguments, -- return the PR @PRepr ty@. Suppose we have: -- -- > type instance PRepr (T a1 ... an) = t @@ -160,8 +183,9 @@ prDictOfReprType ty prDictOfReprType' :: Type -> VM CoreExpr prDictOfReprType' ty = prDictOfReprType ty `orElseV` - cantVectorise "No PR dictionary for representation type" - (ppr ty) + do dflags <- getDynFlags + cantVectorise dflags "No PR dictionary for representation type" + (ppr ty) -- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding -- to the argument types. @@ -175,10 +199,12 @@ prDFunApply dfun tys = do pa <- builtin paTyCon pr <- builtin prTyCon - args <- zipWithM (dictionary pa pr) tys tycons + dflags <- getDynFlags + args <- zipWithM (dictionary dflags pa pr) tys tycons return $ Var dfun `mkTyApps` tys `mkApps` args - | otherwise = invalid + | otherwise = do dflags <- getDynFlags + invalid dflags where -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then -- ctxs is Just [PA, PR] @@ -191,10 +217,10 @@ prDFunApply dfun tys $ splitForAllTys $ varType dfun - dictionary pa pr ty tycon + dictionary dflags pa pr ty tycon | tycon == pa = paDictOfType ty | tycon == pr = prDictOfReprType ty - | otherwise = invalid + | otherwise = invalid dflags - invalid = cantVectorise "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys) + invalid dflags = cantVectorise dflags "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys) |