diff options
Diffstat (limited to 'compiler')
79 files changed, 1488 insertions, 4527 deletions
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 1d5a5b3cda..6518c5b5b0 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -333,16 +333,36 @@ emitPrimOp [res] FreezeArrayOp [src,src_off,n] = emitPrimOp [res] ThawArrayOp [src,src_off,n] = emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n +emitPrimOp [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] = + doCopyArrayOp src src_off dst dst_off n +emitPrimOp [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] = + doCopyMutableArrayOp src src_off dst dst_off n + -- Reading/writing pointer arrays -emitPrimOp [r] ReadArrayOp [obj,ix] = doReadPtrArrayOp r obj ix -emitPrimOp [r] IndexArrayOp [obj,ix] = doReadPtrArrayOp r obj ix +emitPrimOp [res] ReadArrayOp [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] IndexArrayOp [obj,ix] = doReadPtrArrayOp res obj ix emitPrimOp [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp [res] IndexArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] IndexArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] ReadArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] ReadArrayArrayOp_MutableByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] ReadArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] ReadArrayArrayOp_MutableArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [] WriteArrayArrayOp_ByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp [] WriteArrayArrayOp_ArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v + emitPrimOp [res] SizeofArrayOp [arg] = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord) emitPrimOp [res] SizeofMutableArrayOp [arg] = emitPrimOp [res] SizeofArrayOp [arg] +emitPrimOp [res] SizeofArrayArrayOp [arg] + = emitPrimOp [res] SizeofArrayOp [arg] +emitPrimOp [res] SizeofMutableArrayArrayOp [arg] + = emitPrimOp [res] SizeofArrayOp [arg] -- IndexXXXoffAddr diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index a8985d0019..ed288096f7 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -26,7 +26,7 @@ import CoreFVs import CoreMonad ( endPass, CoreToDo(..) ) import CoreSyn import CoreSubst -import MkCore +import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here import Type import Literal import Coercion diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index c18af8e189..d7296e3e25 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -343,6 +343,12 @@ Note [Type let] ~~~~~~~~~~~~~~~ See #type_let# +%************************************************************************ +%* * + Ticks +%* * +%************************************************************************ + \begin{code} -- | Allows attaching extra information to points in expressions data Tickish id = @@ -893,7 +899,7 @@ the occurrence info is wrong %************************************************************************ %* * -\subsection{The main data type} + AltCon %* * %************************************************************************ diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 47e31fa5cb..198ac7e610 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -21,7 +21,8 @@ module CoreUtils ( exprType, coreAltType, coreAltsType, exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun, - exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike, + exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, + exprIsBig, exprIsConLike, rhsIsStatic, isCheapApp, isExpandableApp, -- * Expression and bindings size @@ -181,6 +182,10 @@ mkCast :: CoreExpr -> Coercion -> CoreExpr mkCast e co | isReflCo co = e mkCast (Coercion e_co) co + | isCoVarType (pSnd (coercionKind 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) @@ -752,35 +757,39 @@ it's applied only to dictionaries. -- -- We can only do this if the @y + 1@ is ok for speculation: it has no -- side effects, and can't diverge or raise an exception. -exprOkForSpeculation :: Expr b -> Bool +exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool +exprOkForSpeculation = expr_ok primOpOkForSpeculation +exprOkForSideEffects = expr_ok primOpOkForSideEffects -- Polymorphic in binder type -- There is one call at a non-Id binder type, in SetLevels -exprOkForSpeculation (Lit _) = True -exprOkForSpeculation (Type _) = True -exprOkForSpeculation (Coercion _) = True -exprOkForSpeculation (Var v) = appOkForSpeculation v [] -exprOkForSpeculation (Cast e _) = exprOkForSpeculation e + +expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool +expr_ok _ (Lit _) = True +expr_ok _ (Type _) = True +expr_ok _ (Coercion _) = True +expr_ok primop_ok (Var v) = app_ok primop_ok v [] +expr_ok primop_ok (Cast e _) = expr_ok primop_ok e -- Tick annotations that *tick* cannot be speculated, because these -- are meant to identify whether or not (and how often) the particular -- source expression was evaluated at runtime. -exprOkForSpeculation (Tick tickish e) +expr_ok primop_ok (Tick tickish e) | tickishCounts tickish = False - | otherwise = exprOkForSpeculation e + | otherwise = expr_ok primop_ok e -exprOkForSpeculation (Case e _ _ alts) - = exprOkForSpeculation e -- Note [exprOkForSpeculation: case expressions] - && all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts - && altsAreExhaustive alts -- Note [exprOkForSpeculation: exhaustive alts] +expr_ok primop_ok (Case e _ _ alts) + = expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions] + && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts + && altsAreExhaustive alts -- Note [Exhaustive alts] -exprOkForSpeculation other_expr +expr_ok primop_ok other_expr = case collectArgs other_expr of - (Var f, args) -> appOkForSpeculation f args + (Var f, args) -> app_ok primop_ok f args _ -> False ----------------------------- -appOkForSpeculation :: Id -> [Expr b] -> Bool -appOkForSpeculation fun args +app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool +app_ok primop_ok fun args = case idDetails fun of DFunId new_type -> not new_type -- DFuns terminate, unless the dict is implemented @@ -794,7 +803,7 @@ appOkForSpeculation fun args PrimOpId op | isDivOp op -- Special case for dividing operations that fail , [arg1, Lit lit] <- args -- only if the divisor is zero - -> not (isZeroLit lit) && exprOkForSpeculation arg1 + -> not (isZeroLit lit) && expr_ok primop_ok arg1 -- Often there is a literal divisor, and this -- can get rid of a thunk in an inner looop @@ -802,14 +811,14 @@ appOkForSpeculation fun args -> True | otherwise - -> primOpOkForSpeculation op && - all exprOkForSpeculation args - -- A bit conservative: we don't really need + -> primop_ok op -- A bit conservative: we don't really need + && all (expr_ok primop_ok) args + -- to care about lazy arguments, but this is easy _other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF || idArity fun > n_val_args -- Partial apps - || (n_val_args ==0 && + || (n_val_args == 0 && isEvaldUnfolding (idUnfolding fun)) -- Let-bound values where n_val_args = valArgCount args @@ -872,13 +881,13 @@ If exprOkForSpeculation doesn't look through case expressions, you get this: The inner case is redundant, and should be nuked. -Note [exprOkForSpeculation: exhaustive alts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Exhaustive alts] +~~~~~~~~~~~~~~~~~~~~~~ We might have something like case x of { A -> ... _ -> ...(case x of { B -> ...; C -> ... })... -Here, the inner case is fine, becuase the A alternative +Here, the inner case is fine, because the A alternative can't happen, but it's not ok to float the inner case outside the outer one (even if we know x is evaluated outside), because then it would be non-exhaustive. See Trac #5453. diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index ae6b095f99..5d1c19bc5f 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -21,6 +21,9 @@ module MkCore ( mkFloatExpr, mkDoubleExpr, mkCharExpr, mkStringExpr, mkStringExprFS, + -- * Floats + FloatBind(..), wrapFloat, + -- * Constructing/deconstructing implicit parameter boxes mkIPUnbox, mkIPBox, @@ -389,6 +392,25 @@ mkBigCoreTupTy :: [Type] -> Type mkBigCoreTupTy = mkChunkified mkBoxedTupleTy \end{code} + +%************************************************************************ +%* * + Floats +%* * +%************************************************************************ + +\begin{code} +data FloatBind + = FloatLet CoreBind + | FloatCase CoreExpr Id AltCon [Var] + -- case e of y { C ys -> ... } + -- See Note [Floating cases] in SetLevels + +wrapFloat :: FloatBind -> CoreExpr -> CoreExpr +wrapFloat (FloatLet defns) body = Let defns body +wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)] +\end{code} + %************************************************************************ %* * \subsection{Tuple destructors} diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 84cb6d628f..2d0ad237fc 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -41,7 +41,8 @@ import CLabel import Util import Data.Array -import System.Directory ( createDirectoryIfMissing ) +import Data.Time +import System.Directory import Trace.Hpc.Mix import Trace.Hpc.Util @@ -158,7 +159,7 @@ writeMixEntries dflags mod count entries filename tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges. createDirectoryIfMissing True hpc_mod_dir - modTime <- getModificationTime filename + modTime <- getModificationUTCTime filename let entries' = [ (hpcPos, box) | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] when (length entries' /= count) $ do @@ -1097,7 +1098,7 @@ type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) -- This hash only has to be hashed at Mix creation time, -- and is for sanity checking only. -mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int +mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int mixHash file tm tabstop entries = fromIntegral $ hashString (show $ Mix file tm 0 tabstop entries) \end{code} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 4320934f8e..172545daaf 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -52,7 +52,7 @@ import TysWiredIn ( eqBoxDataCon, tupleCon ) import Id import Class import DataCon ( dataConWorkId ) -import Name ( localiseName ) +import Name ( Name, localiseName ) import MkId ( seqId ) import Var import VarSet @@ -64,9 +64,11 @@ import Maybes import OrdList import Bag import BasicTypes hiding ( TopLevel ) +import DynFlags import FastString +import ErrUtils( MsgDoc ) import Util - +import Control.Monad( when ) import MonadUtils import Control.Monad(liftM) \end{code} @@ -401,6 +403,13 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) -- Moreover, classops don't (currently) have an inl_sat arity set -- (it would be Just 0) and that in turn makes makeCorePair bleat + | no_act_spec && isNeverActive rule_act + = putSrcSpanDs loc $ + do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:") + <+> quotes (ppr poly_id)) + ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that + -- See Note [Activation pragmas for SPECIALISE] + | otherwise = putSrcSpanDs loc $ do { let poly_name = idName poly_id @@ -417,28 +426,6 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; let spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf - id_inl = idInlinePragma poly_id - - -- See Note [Activation pragmas for SPECIALISE] - inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl - | not is_local_id -- See Note [Specialising imported functions] - -- in OccurAnal - , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma - | otherwise = id_inl - -- Get the INLINE pragma from SPECIALISE declaration, or, - -- failing that, from the original Id - - spec_prag_act = inlinePragmaActivation spec_inl - - -- See Note [Activation pragmas for SPECIALISE] - -- no_act_spec is True if the user didn't write an explicit - -- phase specification in the SPECIALISE pragma - no_act_spec = case inlinePragmaSpec spec_inl of - NoInline -> isNeverActive spec_prag_act - _ -> isAlwaysActive spec_prag_act - rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit - | otherwise = spec_prag_act -- Specified by user - rule = mkRule False {- Not auto -} is_local_id (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) rule_act poly_name @@ -448,6 +435,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; 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)) } } } where @@ -462,6 +452,29 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) -- The type checker has checked that it *has* an unfolding + id_inl = idInlinePragma poly_id + + -- See Note [Activation pragmas for SPECIALISE] + inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl + | not is_local_id -- See Note [Specialising imported functions] + -- in OccurAnal + , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma + | otherwise = id_inl + -- Get the INLINE pragma from SPECIALISE declaration, or, + -- failing that, from the original Id + + spec_prag_act = inlinePragmaActivation spec_inl + + -- See Note [Activation pragmas for SPECIALISE] + -- no_act_spec is True if the user didn't write an explicit + -- phase specification in the SPECIALISE pragma + no_act_spec = case inlinePragmaSpec spec_inl of + NoInline -> isNeverActive spec_prag_act + _ -> isAlwaysActive spec_prag_act + rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit + | otherwise = spec_prag_act -- Specified by user + + specUnfolding :: HsWrapper -> Type -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr)) {- [Dec 10: TEMPORARILY commented out, until we can straighten out how to @@ -474,6 +487,10 @@ specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops) -} specUnfolding _ _ _ = return (noUnfolding, nilOL) + +specOnInline :: Name -> MsgDoc +specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") + <+> quotes (ppr f) \end{code} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 65134ed85f..d31c77479d 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -685,7 +685,7 @@ makes all list literals be generated via the simple route. dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr -- See Note [Desugaring explicit lists] dsExplicitList elt_ty xs - = do { dflags <- getDOptsDs + = do { dflags <- getDynFlags ; xs' <- mapM dsLExpr xs ; let (dynamic_prefix, static_suffix) = spanTail is_static xs' ; if opt_SimpleListLiterals -- -fsimple-list-literals @@ -760,21 +760,21 @@ dsDo stmts = ASSERT( length rec_ids > 0 ) goL (new_bind_stmt : stmts) where - new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) + new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats) mfix_app bind_op noSyntaxExpr -- Tuple cannot fail tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids - tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case + tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case rec_tup_pats = map nlVarPat tup_ids later_pats = rec_tup_pats rets = map noLoc rec_rets mfix_app = nlHsApp (noLoc mfix_op) mfix_arg mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] (mkFunTy tup_ty body_ty)) - mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats + mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty - ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) + ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets) ret_stmt = noLoc $ mkLastStmt ret_app -- This LastStmt will be desugared with dsDo, -- which ignores the return_op in the LastStmt, diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index cce8ba78c7..b613fbdcec 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -345,7 +345,7 @@ dsFExport fn_id co ext_name cconv isDyn = do -- The function returns t Nothing -> (orig_res_ty, False) - dflags <- getDOpts + dflags <- getDynFlags return $ mkFExportCBits dflags ext_name (if isDyn then Nothing else Just fn_id) diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 4ad8006b39..917e8b19ed 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -47,7 +47,7 @@ dsListComp :: [LStmt Id] -> Type -- Type of entire list -> DsM CoreExpr dsListComp lquals res_ty = do - dflags <- getDOptsDs + dflags <- getDynFlags let quals = map unLoc lquals elt_ty = case tcTyConAppArgs res_ty of [elt_ty] -> elt_ty diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 551165a3ad..e68e6db7c2 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -20,7 +20,7 @@ module DsMonad ( mkPrintUnqualifiedDs, newUnique, UniqSupply, newUniqueSupply, - getDOptsDs, getGhcModeDs, doptDs, woptDs, + getGhcModeDs, doptDs, woptDs, dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon, PArrBuiltin(..), @@ -267,7 +267,7 @@ initDsTc thing_inside = do { this_mod <- getModule ; tcg_env <- getGblEnv ; msg_var <- getErrsVar - ; dflags <- getDOpts + ; dflags <- getDynFlags ; let type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env ds_envs = mkDsEnvs dflags this_mod rdr_env type_env msg_var @@ -346,9 +346,6 @@ We can also reach out and either set/grab location information from the @SrcSpan@ being carried around. \begin{code} -getDOptsDs :: DsM DynFlags -getDOptsDs = getDOpts - doptDs :: DynFlag -> TcRnIf gbl lcl Bool doptDs = doptM @@ -356,7 +353,7 @@ woptDs :: WarningFlag -> TcRnIf gbl lcl Bool woptDs = woptM getGhcModeDs :: DsM GhcMode -getGhcModeDs = getDOptsDs >>= return . ghcMode +getGhcModeDs = getDynFlags >>= return . ghcMode getModuleDs :: DsM Module getModuleDs = do { env <- getGblEnv; return (ds_mod env) } diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index f2e3be8bb8..c80446a751 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -66,7 +66,7 @@ matchCheck :: DsMatchContext -> DsM MatchResult -- Desugared result! matchCheck ctx vars ty qs - = do { dflags <- getDOptsDs + = do { dflags <- getDynFlags ; matchCheck_really dflags ctx vars ty qs } matchCheck_really :: DynFlags diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index a9d86f88be..51ae1542e3 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -61,11 +61,14 @@ Library if !flag(base3) && !flag(base4) Build-Depends: base < 3 + if flag(stage1) && impl(ghc < 7.5) + Build-Depends: old-time >= 1 && < 1.1 + if flag(base3) || flag(base4) Build-Depends: directory >= 1 && < 1.2, process >= 1 && < 1.2, bytestring >= 0.9 && < 0.10, - old-time >= 1 && < 1.1, + time < 1.5, containers >= 0.1 && < 0.5, array >= 0.1 && < 0.4 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 4d6f17129a..94462c5191 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -59,7 +59,6 @@ import Data.Word import Data.Array import Data.IORef import Control.Monad -import System.Time ( ClockTime(..) ) -- --------------------------------------------------------------------------- @@ -77,7 +76,7 @@ readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> TcRnIf a b ModIface readBinIface checkHiWay traceBinIFaceReading hi_path = do ncu <- mkNameCacheUpdater - dflags <- getDOpts + dflags <- getDynFlags liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath @@ -618,16 +617,6 @@ instance Binary AvailInfo where ac <- get bh return (AvailTC ab ac) - --- where should this be located? -instance Binary ClockTime where - put_ bh (TOD x y) = put_ bh x >> put_ bh y - - get bh = do - x <- get bh - y <- get bh - return $ TOD x y - instance Binary Usage where put_ bh usg@UsagePackageModule{} = do putByte bh 0 diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 37379b5be4..107c24c94f 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -188,7 +188,7 @@ loadInterface doc_str mod from ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) -- Check whether we have the interface already - ; dflags <- getDOpts + ; dflags <- getDynFlags ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded @@ -489,7 +489,7 @@ findAndReadIface doc_str mod hi_boot_file nest 4 (ptext (sLit "reason:") <+> doc_str)]) -- Check for GHC.Prim, and return its static interface - ; dflags <- getDOpts + ; dflags <- getDynFlags ; if mod == gHC_PRIM then return (Succeeded (ghcPrimIface, "<built in interface for GHC.Prim>")) @@ -526,7 +526,7 @@ findAndReadIface doc_str mod hi_boot_file }} ; err -> do { traceIf (ptext (sLit "...not found")) - ; dflags <- getDOpts + ; dflags <- getDynFlags ; return (Failed (cannotFindInterface dflags (moduleName mod) err)) } } diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 35b4c91f2a..9904042fe0 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -111,7 +111,6 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.IORef import System.FilePath -import System.Directory (getModificationTime) \end{code} @@ -595,8 +594,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- - flag abi hash mod_hash <- computeFingerprint putNameLiterally (map fst sorted_decls, - export_hash, - orphan_hash, + export_hash, -- includes orphan_hash mi_warns iface0, mi_vect_info iface0) @@ -623,7 +621,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls mi_orphan = not ( null orph_rules && null orph_insts && null orph_fis - && null (ifaceVectInfoVar (mi_vect_info iface0))), + && isNoIfaceVectInfo (mi_vect_info iface0)), mi_finsts = not . null $ mi_fam_insts iface0, mi_decls = sorted_decls, mi_hash_fn = lookupOccEnv local_env } @@ -886,7 +884,7 @@ mkOrphMap get_key decls mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage] mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files = do { eps <- hscEPS hsc_env - ; mtimes <- mapM getModificationTime dependent_files + ; mtimes <- mapM getModificationUTCTime dependent_files ; let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod dir_imp_mods used_names ; let usages = mod_usages ++ map to_file_usage (zip dependent_files mtimes) @@ -1334,7 +1332,7 @@ checkModUsage _this_pkg UsageFile{ usg_file_path = file, usg_mtime = old_mtime } = liftIO $ handleIO handle $ do - new_mtime <- getModificationTime file + new_mtime <- getModificationUTCTime file return $ old_mtime /= new_mtime where handle = diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 1854b77f87..5e7d25895a 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -745,9 +745,9 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo ; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons ; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse ; vScalarVars <- mapM vectVar scalarVars - ; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2) + ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2) ; return $ VectInfo - { vectInfoVar = mkVarEnv vVars + { vectInfoVar = mkVarEnv vVars `extendVarEnvList` concat vScSels , vectInfoTyCon = mkNameEnv vTyCons , vectInfoDataCon = mkNameEnv (concat vDataCons) , vectInfoScalarVars = mkVarSet vScalarVars @@ -765,6 +765,19 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo tcIfaceExtId vName ; return (var, (var, vVar)) } + -- where + -- lookupLocalOrExternalId name + -- = do { let mb_id = lookupTypeEnv typeEnv name + -- ; case mb_id of + -- -- id is local + -- Just (AnId id) -> return id + -- -- name is not an Id => internal inconsistency + -- Just _ -> notAnIdErr + -- -- Id is external + -- Nothing -> tcIfaceExtId name + -- } + -- + -- notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name) vectVar name = forkM (ptext (sLit "vect scalar var") <+> ppr name) $ @@ -779,13 +792,17 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo = vectTyConMapping vars name name vectTyConMapping vars name vName - = do { tycon <- lookupLocalOrExternal name - ; vTycon <- lookupLocalOrExternal vName + = do { tycon <- lookupLocalOrExternalTyCon name + ; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $ + lookupLocalOrExternalTyCon vName - -- map the data constructors of the original type constructor to those of the + -- Map the data constructors of the original type constructor to those of the -- vectorised type constructor /unless/ the type constructor was vectorised -- abstractly; if it was vectorised abstractly, the workers of its data constructors - -- do not appear in the set of vectorised variables + -- do not appear in the set of vectorised variables. + -- + -- NB: This is lazy! We don't pull at the type constructors before we actually use + -- the data constructor mapping. ; let isAbstract | isClassTyCon tycon = False | datacon:_ <- tyConDataCons tycon = not $ dataConWrapId datacon `elemVarSet` vars @@ -796,14 +813,25 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo (tyConDataCons vTycon) ] + -- Map the (implicit) superclass and methods selectors as they don't occur in + -- the var map. + vScSels | Just cls <- tyConClass_maybe tycon + , Just vCls <- tyConClass_maybe vTycon + = [ (sel, (sel, vSel)) + | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls) + ] + | otherwise + = [] + ; return ( (name, (tycon, vTycon)) -- (T, T_v) , vDataCons -- list of (Ci, Ci_v) + , vScSels -- list of (seli, seli_v) ) } where -- we need a fully defined version of the type constructor to be able to extract -- its data constructors etc. - lookupLocalOrExternal name + lookupLocalOrExternalTyCon name = do { let mb_tycon = lookupTypeEnv typeEnv name ; case mb_tycon of -- tycon is local diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 07e53fb731..35de40bdc4 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -7,6 +7,7 @@ module Llvm.Types where #include "HsVersions.h" import Data.Char +import Data.Int import Data.List (intercalate) import Numeric @@ -223,7 +224,9 @@ getPlainName (LMLitVar x ) = getLit x -- | Print a literal value. No type. getLit :: LlvmLit -> String -getLit (LMIntLit i _ ) = show ((fromInteger i)::Int) +getLit (LMIntLit i (LMInt 32)) = show (fromInteger i :: Int32) +getLit (LMIntLit i (LMInt 64)) = show (fromInteger i :: Int64) +getLit (LMIntLit i _ ) = show (fromInteger i :: Int) getLit (LMFloatLit r LMFloat ) = fToStr $ realToFrac r getLit (LMFloatLit r LMDouble) = dToStr r getLit f@(LMFloatLit _ _) = error $ "Can't print this float literal!" ++ show f diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index f239ee50cf..531d90a8ee 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -27,6 +27,7 @@ import UniqSupply import Util import SysTools ( figureLlvmVersion ) +import Data.IORef ( writeIORef ) import Data.Maybe ( fromMaybe ) import System.IO @@ -37,7 +38,7 @@ llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO () llvmCodeGen dflags h us cmms = let cmm = concat cmms (cdata,env) = {-# SCC "llvm_split" #-} - foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm + foldr split ([], initLlvmEnv dflags) cmm split (CmmData s d' ) (d,e) = ((s,d'):d,e) split (CmmProc i l _) (d,e) = let lbl = strCLabel_llvm env $ case i of @@ -47,10 +48,12 @@ llvmCodeGen dflags h us cmms in (d,env') in do showPass dflags "LlVM CodeGen" - bufh <- newBufHandle h dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc pprLlvmHeader + bufh <- newBufHandle h Prt.bufLeftRender bufh $ pprLlvmHeader ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags + -- cache llvm version for later use + writeIORef (llvmVersion dflags) ver env' <- {-# SCC "llvm_datas_gen" #-} cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] {-# SCC "llvm_procs_gen" #-} diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index a896cdd482..9bdb115505 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -13,7 +13,7 @@ module LlvmCodeGen.Base ( LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert, funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform, - ghcInternalFunctions, + getDflags, ghcInternalFunctions, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, @@ -32,6 +32,7 @@ import CLabel import CgUtils ( activeStgRegs ) import Config import Constants +import DynFlags import FastString import OldCmm import qualified Outputable as Outp @@ -150,12 +151,13 @@ defaultLlvmVersion = 28 -- -- two maps, one for functions and one for local vars. -newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, Platform) +newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags) + type LlvmEnvMap = UniqFM LlvmType -- | Get initial Llvm environment. -initLlvmEnv :: Platform -> LlvmEnv -initLlvmEnv platform = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, platform) +initLlvmEnv :: DynFlags -> LlvmEnv +initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags) where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions ] -- | Here we pre-initialise some functions that are used internally by GHC @@ -211,7 +213,11 @@ setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p) -- | Get the platform we are generating code for getLlvmPlatform :: LlvmEnv -> Platform -getLlvmPlatform (LlvmEnv (_, _, _, p)) = p +getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d + +-- | Get the DynFlags for this compilation pass +getDflags :: LlvmEnv -> DynFlags +getDflags (LlvmEnv (_, _, _, d)) = d -- ---------------------------------------------------------------------------- -- * Label handling diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 4309dcdae1..d5037828c7 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -16,13 +16,14 @@ import CgUtils ( activeStgRegs, callerSaves ) import CLabel import OldCmm import qualified OldPprCmm as PprCmm -import OrdList +import DynFlags import FastString import ForeignCall import Outputable hiding ( panic, pprPanic ) import qualified Outputable import Platform +import OrdList import UniqSupply import Unique import Util @@ -475,7 +476,7 @@ genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData -- Call to known function genJump env (CmmLit (CmmLabel lbl)) live = do (env', vf, stmts, top) <- getHsFunc env lbl - (stgRegs, stgStmts) <- funEpilogue live + (stgRegs, stgStmts) <- funEpilogue env live let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs let s2 = Return Nothing return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) @@ -494,7 +495,7 @@ genJump env expr live = do ++ show (ty) ++ ")" (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) - (stgRegs, stgStmts) <- funEpilogue live + (stgRegs, stgStmts) <- funEpilogue env live let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs let s3 = Return Nothing return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, @@ -550,7 +551,7 @@ genStore env addr@(CmmMachOp (MO_Sub _) [ = genStore_fast env addr r (negate $ fromInteger n) val -- generic case -genStore env addr val = genStore_slow env addr val [top] +genStore env addr val = genStore_slow env addr val [other] -- | CmmStore operation -- This is a special case for storing to a global register pointer @@ -1032,7 +1033,7 @@ genLoad env e@(CmmMachOp (MO_Sub _) [ = genLoad_fast env e r (negate $ fromInteger n) ty -- generic case -genLoad env e ty = genLoad_slow env e ty [top] +genLoad env e ty = genLoad_slow env e ty [other] -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer @@ -1200,29 +1201,33 @@ funPrologue = concat $ map getReg activeStgRegs -- | Function epilogue. Load STG variables to use as argument for call. -funEpilogue :: Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements) -funEpilogue Nothing = do +-- STG Liveness optimisation done here. +funEpilogue :: LlvmEnv -> Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements) + +-- Have information and liveness optimisation is enabled +funEpilogue env (Just live) | dopt Opt_RegLiveness (getDflags env) = do loads <- mapM loadExpr activeStgRegs let (vars, stmts) = unzip loads return (vars, concatOL stmts) where - loadExpr r = do + loadExpr r | r `elem` alwaysLive || r `elem` live = do let reg = lmGlobalRegVar r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) + loadExpr r = do + let ty = (pLower . getVarType $ lmGlobalRegVar r) + return (LMLitVar $ LMUndefLit ty, unitOL Nop) -funEpilogue (Just live) = do +-- don't do liveness optimisation +funEpilogue _ _ = do loads <- mapM loadExpr activeStgRegs let (vars, stmts) = unzip loads return (vars, concatOL stmts) where - loadExpr r | r `elem` alwaysLive || r `elem` live = do + loadExpr r = do let reg = lmGlobalRegVar r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) - loadExpr r = do - let ty = (pLower . getVarType $ lmGlobalRegVar r) - return (LMLitVar $ LMUndefLit ty, unitOL Nop) -- | A serries of statements to trash all the STG registers. diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index 55b2e0db80..b7ff9f008e 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -4,7 +4,7 @@ module LlvmCodeGen.Regs ( lmGlobalRegArg, lmGlobalRegVar, alwaysLive, - stgTBAA, top, base, stack, heap, rx, tbaa, getTBAA + stgTBAA, top, base, stack, heap, rx, other, tbaa, getTBAA ) where #include "HsVersions.h" @@ -70,23 +70,30 @@ stgTBAA , MetaUnamed heapN [MetaStr (fsLit "heap"), MetaNode topN] , MetaUnamed rxN [MetaStr (fsLit "rx"), MetaNode heapN] , MetaUnamed baseN [MetaStr (fsLit "base"), MetaNode topN] + -- FIX: Not 100% sure about 'others' place. Might need to be under 'heap'. + -- OR I think the big thing is Sp is never aliased, so might want + -- to change the hieracy to have Sp on its own branch that is never + -- aliased (e.g never use top as a TBAA node). + , MetaUnamed otherN [MetaStr (fsLit "other"), MetaNode topN] ] -- | Id values -topN, stackN, heapN, rxN, baseN :: LlvmMetaUnamed +topN, stackN, heapN, rxN, baseN, otherN:: LlvmMetaUnamed topN = LMMetaUnamed 0 stackN = LMMetaUnamed 1 heapN = LMMetaUnamed 2 rxN = LMMetaUnamed 3 baseN = LMMetaUnamed 4 +otherN = LMMetaUnamed 5 -- | The various TBAA types -top, heap, stack, rx, base :: MetaData +top, heap, stack, rx, base, other :: MetaData top = (tbaa, topN) heap = (tbaa, heapN) stack = (tbaa, stackN) rx = (tbaa, rxN) base = (tbaa, baseN) +other = (tbaa, otherN) -- | The TBAA metadata identifier tbaa :: LMString diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index e845460413..a9ab3f66b7 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -4,13 +4,6 @@ \section{Code output phase} \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 CodeOutput( codeOutput, outputForeignStubs ) where #include "HsVersions.h" @@ -18,11 +11,11 @@ module CodeOutput( codeOutput, outputForeignStubs ) where import AsmCodeGen ( nativeCodeGen ) import LlvmCodeGen ( llvmCodeGen ) -import UniqSupply ( mkSplitUniqSupply ) +import UniqSupply ( mkSplitUniqSupply ) -import Finder ( mkStubPaths ) -import PprC ( writeCs ) -import CmmLint ( cmmLint ) +import Finder ( mkStubPaths ) +import PprC ( writeCs ) +import CmmLint ( cmmLint ) import Packages import Util import OldCmm ( RawCmmGroup ) @@ -31,10 +24,10 @@ import DynFlags import Config import SysTools -import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) +import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Module -import Maybes ( firstJusts ) +import Maybes ( firstJusts ) import Control.Exception import Control.Monad @@ -44,50 +37,44 @@ import System.IO \end{code} %************************************************************************ -%* * +%* * \subsection{Steering} -%* * +%* * %************************************************************************ \begin{code} codeOutput :: DynFlags - -> Module - -> ModLocation - -> ForeignStubs - -> [PackageId] + -> Module + -> ModLocation + -> ForeignStubs + -> [PackageId] -> [RawCmmGroup] -- Compiled C-- -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}) codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC = - -- You can have C (c_output) or assembly-language (ncg_output), - -- but not both. [Allowing for both gives a space leak on - -- flat_abstractC. WDP 94/10] - - -- Dunno if the above comment is still meaningful now. JRS 001024. - - do { when (dopt Opt_DoCmmLinting dflags) $ do - { showPass dflags "CmmLint" - ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC - ; case firstJusts lints of - Just err -> do { printDump err - ; ghcExit dflags 1 - } - Nothing -> return () - } - - ; showPass dflags "CodeOutput" - ; let filenm = hscOutName dflags - ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs - ; case hscTarget dflags of { + do { when (dopt Opt_DoCmmLinting dflags) $ do + { showPass dflags "CmmLint" + ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC + ; case firstJusts lints of + Just err -> do { printDump err + ; ghcExit dflags 1 + } + Nothing -> return () + } + + ; showPass dflags "CodeOutput" + ; let filenm = hscOutName dflags + ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs + ; case hscTarget dflags of { HscInterpreted -> return (); HscAsm -> outputAsm dflags filenm flat_abstractC; HscC -> outputC dflags filenm flat_abstractC pkg_deps; HscLlvm -> outputLlvm dflags filenm flat_abstractC; HscNothing -> panic "codeOutput: HscNothing" - } - ; return stubs_exist - } + } + ; return stubs_exist + } doOutput :: String -> (Handle -> IO ()) -> IO () doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action @@ -95,9 +82,9 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action %************************************************************************ -%* * +%* * \subsection{C} -%* * +%* * %************************************************************************ \begin{code} @@ -118,26 +105,26 @@ outputC dflags filenm flat_absC packages let rts = getPackageDetails (pkgState dflags) rtsPackageId let cc_injects = unlines (map mk_include (includes rts)) - mk_include h_file = - case h_file of - '"':_{-"-} -> "#include "++h_file - '<':_ -> "#include "++h_file - _ -> "#include \""++h_file++"\"" + mk_include h_file = + case h_file of + '"':_{-"-} -> "#include "++h_file + '<':_ -> "#include "++h_file + _ -> "#include \""++h_file++"\"" pkg_configs <- getPreloadPackagesAnd dflags packages let pkg_names = map (display.sourcePackageId) pkg_configs doOutput filenm $ \ h -> do - hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") - hPutStr h cc_injects - writeCs dflags h flat_absC + hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") + hPutStr h cc_injects + writeCs dflags h flat_absC \end{code} %************************************************************************ -%* * +%* * \subsection{Assembler} -%* * +%* * %************************************************************************ \begin{code} @@ -156,9 +143,9 @@ outputAsm dflags filenm flat_absC %************************************************************************ -%* * +%* * \subsection{LLVM} -%* * +%* * %************************************************************************ \begin{code} @@ -172,14 +159,14 @@ outputLlvm dflags filenm flat_absC %************************************************************************ -%* * +%* * \subsection{Foreign import/export} -%* * +%* * %************************************************************************ \begin{code} outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs - -> IO (Bool, -- Header file created + -> IO (Bool, -- Header file created Maybe FilePath) -- C file created outputForeignStubs dflags mod location stubs = do @@ -188,54 +175,54 @@ outputForeignStubs dflags mod location stubs case stubs of NoStubs -> do - -- When compiling External Core files, may need to use stub - -- files from a previous compilation + -- When compiling External Core files, may need to use stub + -- files from a previous compilation stub_h_exists <- doesFileExist stub_h return (stub_h_exists, Nothing) ForeignStubs h_code c_code -> do let - stub_c_output_d = pprCode CStyle c_code - stub_c_output_w = showSDoc 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_c_output_d = pprCode CStyle c_code + stub_c_output_w = showSDoc 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 createDirectoryHierarchy (takeDirectory stub_h) - dumpIfSet_dyn dflags Opt_D_dump_foreign + dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d - -- we need the #includes from the rts package for the stub files - let rts_includes = - let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in - concatMap mk_include (includes rts_pkg) - mk_include i = "#include \"" ++ i ++ "\"\n" + -- we need the #includes from the rts package for the stub files + let rts_includes = + let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in + concatMap mk_include (includes rts_pkg) + mk_include i = "#include \"" ++ i ++ "\"\n" -- wrapper code mentions the ffi_arg type, which comes from ffi.h ffi_includes | cLibFFI = "#include \"ffi.h\"\n" | otherwise = "" - stub_h_file_exists + stub_h_file_exists <- outputForeignStubs_help stub_h stub_h_output_w - ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr + ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr - dumpIfSet_dyn dflags Opt_D_dump_foreign + dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export stubs" stub_c_output_d - stub_c_file_exists + stub_c_file_exists <- outputForeignStubs_help stub_c stub_c_output_w - ("#define IN_STG_CODE 0\n" ++ - "#include \"Rts.h\"\n" ++ - rts_includes ++ - ffi_includes ++ - cplusplus_hdr) - cplusplus_ftr - -- We're adding the default hc_header to the stub file, but this - -- isn't really HC code, so we need to define IN_STG_CODE==0 to - -- avoid the register variables etc. being enabled. + ("#define IN_STG_CODE 0\n" ++ + "#include \"Rts.h\"\n" ++ + rts_includes ++ + ffi_includes ++ + cplusplus_hdr) + cplusplus_ftr + -- We're adding the default hc_header to the stub file, but this + -- isn't really HC code, so we need to define IN_STG_CODE==0 to + -- avoid the register variables etc. being enabled. return (stub_h_file_exists, if stub_c_file_exists then Just stub_c diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 0e8990777b..df6e7fd163 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -190,7 +190,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) (Just location) maybe_stub_o -- The object filename comes from the ModLocation - o_time <- getModificationTime object_filename + o_time <- getModificationUTCTime object_filename return ([DotO object_filename], o_time) let linkable = LM unlinked_time this_mod hs_unlinked @@ -353,13 +353,13 @@ linkingNeeded dflags linkables pkg_deps = do -- modification times on all of the objects and libraries, then omit -- linking (unless the -fforce-recomp flag was given). let exe_file = exeFileName dflags - e_exe_time <- tryIO $ getModificationTime exe_file + e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of Left _ -> return True Right t -> do -- first check object files and extra_ld_inputs extra_ld_inputs <- readIORef v_Ld_inputs - e_extra_times <- mapM (tryIO . getModificationTime) extra_ld_inputs + e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs let (errs,extra_times) = splitEithers e_extra_times let obj_times = map linkableTime linkables ++ extra_times if not (null errs) || any (t <) obj_times @@ -375,7 +375,7 @@ linkingNeeded dflags linkables pkg_deps = do pkg_libfiles <- mapM (uncurry findHSLib) pkg_hslibs if any isNothing pkg_libfiles then return True else do - e_lib_times <- mapM (tryIO . getModificationTime) + e_lib_times <- mapM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles) let (lib_errs,lib_times) = splitEithers e_lib_times if not (null lib_errs) || any (t <) lib_times @@ -906,7 +906,7 @@ runPhase (Hsc src_flavour) input_fn dflags0 -- changed (which the compiler itself figures out). -- Setting source_unchanged to False tells the compiler that M.o is out of -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. - src_timestamp <- io $ getModificationTime (basename <.> suff) + src_timestamp <- io $ getModificationUTCTime (basename <.> suff) let hsc_lang = hscTarget dflags source_unchanged <- io $ @@ -919,7 +919,7 @@ runPhase (Hsc src_flavour) input_fn dflags0 else do o_file_exists <- doesFileExist o_file if not o_file_exists then return SourceModified -- Need to recompile - else do t2 <- getModificationTime o_file + else do t2 <- getModificationUTCTime o_file if t2 > src_timestamp then return SourceUnmodified else return SourceModified @@ -1306,15 +1306,21 @@ runPhase SplitAs _input_fn dflags runPhase LlvmOpt input_fn dflags = do - let lo_opts = getOpts dflags opt_lo - let opt_lvl = max 0 (min 2 $ optLevel dflags) - -- don't specify anything if user has specified commands. We do this for - -- opt but not llc since opt is very specifically for optimisation passes - -- only, so if the user is passing us extra options we assume they know - -- what they are doing and don't get in the way. - let optFlag = if null lo_opts - then [SysTools.Option (llvmOpts !! opt_lvl)] - else [] + ver <- io $ readIORef (llvmVersion dflags) + + let lo_opts = getOpts dflags opt_lo + opt_lvl = max 0 (min 2 $ optLevel dflags) + -- don't specify anything if user has specified commands. We do this + -- for opt but not llc since opt is very specifically for optimisation + -- passes only, so if the user is passing us extra options we assume + -- they know what they are doing and don't get in the way. + optFlag = if null lo_opts + then [SysTools.Option (llvmOpts !! opt_lvl)] + else [] + tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier + | dopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" + | otherwise = "--enable-tbaa=false" + output_fn <- phaseOutputFilename LlvmLlc @@ -1323,6 +1329,7 @@ runPhase LlvmOpt input_fn dflags SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ optFlag + ++ [SysTools.Option tbaa] ++ map SysTools.Option lo_opts) return (LlvmLlc, output_fn) @@ -1336,11 +1343,16 @@ runPhase LlvmOpt input_fn dflags runPhase LlvmLlc input_fn dflags = do + ver <- io $ readIORef (llvmVersion dflags) + let lc_opts = getOpts dflags opt_lc opt_lvl = max 0 (min 2 $ optLevel dflags) rmodel | opt_PIC = "pic" | not opt_Static = "dynamic-no-pic" | otherwise = "static" + tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier + | dopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" + | otherwise = "--enable-tbaa=false" -- hidden debugging flag '-dno-llvm-mangler' to skip mangling let next_phase = case dopt Opt_NoLlvmMangler dflags of @@ -1356,6 +1368,7 @@ runPhase LlvmLlc input_fn dflags SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts + ++ [SysTools.Option tbaa] ++ map SysTools.Option fpOpts) return (next_phase, output_fn) @@ -1373,7 +1386,7 @@ runPhase LlvmLlc input_fn dflags else if (elem VFPv3D16 ext) then ["-mattr=+v7,+vfp3,+d16"] else [] - _ -> [] + _ -> [] ----------------------------------------------------------------------------- -- LlvmMangle phase diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 48830e1b99..ac4df37ac8 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -29,7 +29,7 @@ module DynFlags ( xopt_set, xopt_unset, DynFlags(..), - HasDynFlags(..), + HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, GhcMode(..), isOneShot, @@ -250,6 +250,8 @@ data DynFlag | 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 -- Interface files | Opt_IgnoreInterfacePragmas @@ -346,6 +348,7 @@ data WarningFlag = | Opt_WarnAlternativeLayoutRuleTransitional | Opt_WarnUnsafe | Opt_WarnSafe + | Opt_WarnPointlessPragmas deriving (Eq, Show, Enum) data Language = Haskell98 | Haskell2010 @@ -404,6 +407,7 @@ data ExtensionFlag | Opt_RebindableSyntax | Opt_ConstraintKinds | Opt_PolyKinds -- Kind polymorphism + | Opt_DataKinds -- Datatype promotion | Opt_InstanceSigs | Opt_StandaloneDeriving @@ -585,12 +589,17 @@ data DynFlags = DynFlags { haddockOptions :: Maybe String, -- | what kind of {-# SCC #-} to add automatically - profAuto :: ProfAuto + profAuto :: ProfAuto, + + llvmVersion :: IORef (Int) } class HasDynFlags m where getDynFlags :: m DynFlags +class ContainsDynFlags t where + extractDynFlags :: t -> DynFlags + data ProfAuto = NoProfAuto -- ^ no SCC annotations added | ProfAutoAll -- ^ top-level and nested functions are annotated @@ -821,13 +830,15 @@ initDynFlags dflags = do refFilesToClean <- newIORef [] refDirsToClean <- newIORef Map.empty refGeneratedDumps <- newIORef Set.empty + refLlvmVersion <- newIORef 28 return dflags{ - ways = ways, - buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), - rtsBuildTag = mkBuildTag ways, - filesToClean = refFilesToClean, - dirsToClean = refDirsToClean, - generatedDumps = refGeneratedDumps + ways = ways, + buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), + rtsBuildTag = mkBuildTag ways, + filesToClean = refFilesToClean, + dirsToClean = refDirsToClean, + generatedDumps = refGeneratedDumps, + llvmVersion = refLlvmVersion } -- | The normal 'DynFlags'. Note that they is not suitable for use in this form @@ -919,7 +930,8 @@ defaultDynFlags mySettings = extensions = [], extensionFlags = flattenExtensionFlags Nothing [], log_action = defaultLogAction, - profAuto = NoProfAuto + profAuto = NoProfAuto, + llvmVersion = panic "defaultDynFlags: No llvmVersion" } type LogAction = Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () @@ -1782,7 +1794,8 @@ fWarningFlags = [ ( "warn-wrong-do-bind", Opt_WarnWrongDoBind, nop ), ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ), ( "warn-unsafe", Opt_WarnUnsafe, setWarnUnsafe ), - ( "warn-safe", Opt_WarnSafe, setWarnSafe ) ] + ( "warn-safe", Opt_WarnSafe, setWarnSafe ), + ( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fFlags :: [FlagSpec DynFlag] @@ -1823,6 +1836,8 @@ fFlags = [ ( "vectorise", Opt_Vectorise, nop ), ( "regs-graph", Opt_RegsGraph, nop ), ( "regs-iterative", Opt_RegsIterative, nop ), + ( "llvm-tbaa", Opt_LlvmTBAA, nop), + ( "reg-liveness", Opt_RegLiveness, nop), ( "gen-manifest", Opt_GenManifest, nop ), ( "embed-manifest", Opt_EmbedManifest, nop ), ( "ext-core", Opt_EmitExternalCore, nop ), @@ -1952,6 +1967,7 @@ xFlags = [ ( "RebindableSyntax", Opt_RebindableSyntax, nop ), ( "ConstraintKinds", Opt_ConstraintKinds, nop ), ( "PolyKinds", Opt_PolyKinds, nop ), + ( "DataKinds", Opt_DataKinds, nop ), ( "InstanceSigs", Opt_InstanceSigs, nop ), ( "MonoPatBinds", Opt_MonoPatBinds, \ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ), @@ -2039,8 +2055,6 @@ impliedFlags , (Opt_TypeFamilies, turnOn, Opt_KindSignatures) -- Type families use kind signatures -- all over the place - , (Opt_PolyKinds, turnOn, Opt_KindSignatures) - , (Opt_ImpredicativeTypes, turnOn, Opt_RankNTypes) -- Record wild-cards implies field disambiguation @@ -2071,6 +2085,8 @@ optLevelFlags , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) , ([2], Opt_RegsGraph) + , ([0,1,2], Opt_LlvmTBAA) + , ([0,1,2], Opt_RegLiveness) -- , ([2], Opt_StaticArgumentTransformation) -- Max writes: I think it's probably best not to enable SAT with -O2 for the @@ -2104,7 +2120,8 @@ standardWarnings Opt_WarnLazyUnliftedBindings, Opt_WarnDodgyForeignImports, Opt_WarnWrongDoBind, - Opt_WarnAlternativeLayoutRuleTransitional + Opt_WarnAlternativeLayoutRuleTransitional, + Opt_WarnPointlessPragmas ] minusWOpts :: [WarningFlag] diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index 3ac3a473a3..1417dad061 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -46,8 +46,8 @@ import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) import System.Directory import System.FilePath import Control.Monad -import System.Time ( ClockTime ) import Data.List ( partition ) +import Data.Time type FileExt = String -- Filename extension @@ -528,7 +528,7 @@ findObjectLinkableMaybe mod locn -- Make an object linkable when we know the object file exists, and we know -- its modification time. -findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable +findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) -- We used to look for _stub.o files here, but that was a bug (#706) -- Now GHC merges the stub.o into the main .o (#3687) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 6c31e2e1bf..d3a8bb11de 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -300,11 +300,11 @@ import Lexer import System.Directory ( doesFileExist, getCurrentDirectory ) import Data.Maybe import Data.List ( find ) +import Data.Time import Data.Typeable ( Typeable ) import Data.Word ( Word8 ) import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) -import System.Time ( getClockTime ) import Exception import Data.IORef import System.FilePath @@ -812,7 +812,7 @@ compileToCore fn = do compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m () compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do dflags <- getSessionDynFlags - currentTime <- liftIO $ getClockTime + currentTime <- liftIO $ getCurrentTime cwd <- liftIO $ getCurrentDirectory modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd ((moduleNameSlashes . moduleName) mName) diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 3db920553e..a2fb9edf16 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -62,15 +62,15 @@ import UniqFM import qualified Data.Map as Map import qualified FiniteMap as Map( insertListWith) -import System.Directory ( doesFileExist, getModificationTime ) +import System.Directory import System.IO ( fixIO ) import System.IO.Error ( isDoesNotExistError ) -import System.Time ( ClockTime ) import System.FilePath import Control.Monad import Data.Maybe import Data.List import qualified Data.List as List +import Data.Time -- ----------------------------------------------------------------------------- -- Loading the program @@ -1200,7 +1200,7 @@ summariseFile -> FilePath -- source file name -> Maybe Phase -- start phase -> Bool -- object code allowed? - -> Maybe (StringBuffer,ClockTime) + -> Maybe (StringBuffer,UTCTime) -> IO ModSummary summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf @@ -1214,10 +1214,10 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf -- return the cached summary if the source didn't change src_timestamp <- case maybe_buf of Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file + Nothing -> liftIO $ getModificationUTCTime file -- The file exists; we checked in getRootSummary above. -- If it gets removed subsequently, then this - -- getModificationTime may fail, but that's the right + -- getModificationUTCTime may fail, but that's the right -- behaviour. if ms_hs_date old_summary == src_timestamp @@ -1251,7 +1251,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf src_timestamp <- case maybe_buf of Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file + Nothing -> liftIO $ getModificationUTCTime file -- getMofificationTime may fail -- when the user asks to load a source file by name, we only @@ -1285,7 +1285,7 @@ summariseModule -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised -> Bool -- object code allowed? - -> Maybe (StringBuffer, ClockTime) + -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -- Modules to exclude -> IO (Maybe ModSummary) -- Its new summary @@ -1306,7 +1306,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) case maybe_buf of Just (_,t) -> check_timestamp old_summary location src_fn t Nothing -> do - m <- tryIO (getModificationTime src_fn) + m <- tryIO (getModificationUTCTime src_fn) case m of Right t -> check_timestamp old_summary location src_fn t Left e | isDoesNotExistError e -> find_it @@ -1398,7 +1398,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) ms_obj_date = obj_timestamp })) -getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) +getObjTimestamp :: ModLocation -> Bool -> IO (Maybe UTCTime) getObjTimestamp location is_boot = if is_boot then return Nothing else modificationTimeIfExists (ml_obj_file location) @@ -1407,7 +1407,7 @@ getObjTimestamp location is_boot preprocessFile :: HscEnv -> FilePath -> Maybe Phase -- ^ Starting phase - -> Maybe (StringBuffer,ClockTime) + -> Maybe (StringBuffer,UTCTime) -> IO (DynFlags, FilePath, StringBuffer) preprocessFile hsc_env src_fn mb_phase Nothing = do diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index b6bf938332..3224acf0fe 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -92,7 +92,7 @@ module HscTypes ( -- * Vectorisation information VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, - noIfaceVectInfo, + noIfaceVectInfo, isNoIfaceVectInfo, -- * Safe Haskell information hscGetSafeInf, hscSetSafeInf, @@ -164,11 +164,11 @@ 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 ) import Exception import System.FilePath -import System.Time ( ClockTime ) -- ----------------------------------------------------------------------------- -- Source Errors @@ -356,7 +356,7 @@ data Target = Target { targetId :: TargetId, -- ^ module or filename targetAllowObjCode :: Bool, -- ^ object code allowed? - targetContents :: Maybe (StringBuffer,ClockTime) + targetContents :: Maybe (StringBuffer,UTCTime) -- ^ in-memory text buffer? } @@ -696,8 +696,8 @@ data ModIface mi_insts :: [IfaceClsInst], -- ^ Sorted class instance mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances mi_rules :: [IfaceRule], -- ^ Sorted rules - mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules and class - -- and family instances combined + mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules, class and family + -- instances, and vectorise pragmas combined mi_vect_info :: !IfaceVectInfo, -- ^ Vectorisation information @@ -1566,6 +1566,8 @@ lookupFixity env n = case lookupNameEnv env n of -- -- * A transformation rule in a module other than the one defining -- the function in the head of the rule +-- +-- * A vectorisation pragma type WhetherHasOrphans = Bool -- | Does this module define family instances? @@ -1632,7 +1634,7 @@ data Usage } -- ^ Module from the current package | UsageFile { usg_file_path :: FilePath, - usg_mtime :: ClockTime + usg_mtime :: UTCTime -- ^ External file dependency. From a CPP #include or TH addDependentFile. Should be absolute. } deriving( Eq ) @@ -1803,8 +1805,8 @@ data ModSummary ms_mod :: Module, -- ^ Identity of the module ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell, hs-boot or external core ms_location :: ModLocation, -- ^ Location of the various files belonging to the module - ms_hs_date :: ClockTime, -- ^ Timestamp of source file - ms_obj_date :: Maybe ClockTime, -- ^ Timestamp of object, if we have one + ms_hs_date :: UTCTime, -- ^ Timestamp of source file + ms_obj_date :: Maybe UTCTime, -- ^ Timestamp of object, if we have one ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module ms_textual_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module from the module *text* ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file @@ -2009,6 +2011,10 @@ concatVectInfo = foldr plusVectInfo noVectInfo noIfaceVectInfo :: IfaceVectInfo noIfaceVectInfo = IfaceVectInfo [] [] [] [] [] +isNoIfaceVectInfo :: IfaceVectInfo -> Bool +isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5) + = null l1 && null l2 && null l3 && null l4 && null l5 + instance Outputable VectInfo where ppr info = vcat [ ptext (sLit "variables :") <+> ppr (vectInfoVar info) @@ -2100,7 +2106,7 @@ stuff is the *dynamic* linker, and isn't present in a stage-1 compiler \begin{code} -- | Information we can use to dynamically link modules into the compiler data Linkable = LM { - linkableTime :: ClockTime, -- ^ Time at which this linkable was built + linkableTime :: UTCTime, -- ^ Time at which this linkable was built -- (i.e. when the bytecodes were produced, -- or the mod date on the files) linkableModule :: Module, -- ^ The linkable module itself diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 5e2a9375a0..34afd5ca0e 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -513,6 +513,7 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars tidy_var_v = lookup_var var_v , isExportedId tidy_var , isExportedId tidy_var_v + , isDataConWorkId var || not (isImplicitId var) ] tidy_scalarVars = mkVarSet [ lookup_var var diff --git a/compiler/parser/LexCore.hs b/compiler/parser/LexCore.hs index b3d8d63fbd..861fffb7f6 100644 --- a/compiler/parser/LexCore.hs +++ b/compiler/parser/LexCore.hs @@ -1,11 +1,3 @@ - -{-# 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 LexCore where import ParserCoreUtils @@ -15,39 +7,39 @@ import Numeric isNameChar :: Char -> Bool isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'') - || (c == '$') || (c == '-') || (c == '.') + || (c == '$') || (c == '-') || (c == '.') isKeywordChar :: Char -> Bool -isKeywordChar c = isAlpha c || (c == '_') +isKeywordChar c = isAlpha c || (c == '_') -lexer :: (Token -> P a) -> P a -lexer cont [] = cont TKEOF [] -lexer cont ('\n':cs) = \line -> lexer cont cs (line+1) +lexer :: (Token -> P a) -> P a +lexer cont [] = cont TKEOF [] +lexer cont ('\n':cs) = \line -> lexer cont cs (line+1) lexer cont ('-':'>':cs) = cont TKrarrow cs -lexer cont (c:cs) - | isSpace c = lexer cont cs +lexer cont (c:cs) + | isSpace c = lexer cont cs | isLower c || (c == '_') = lexName cont TKname (c:cs) - | isUpper c = lexName cont TKcname (c:cs) + | isUpper c = lexName cont TKcname (c:cs) | isDigit c || (c == '-') = lexNum cont (c:cs) -lexer cont ('%':cs) = lexKeyword cont cs -lexer cont ('\'':cs) = lexChar cont cs -lexer cont ('\"':cs) = lexString [] cont cs -lexer cont ('#':cs) = cont TKhash cs -lexer cont ('(':cs) = cont TKoparen cs -lexer cont (')':cs) = cont TKcparen cs -lexer cont ('{':cs) = cont TKobrace cs -lexer cont ('}':cs) = cont TKcbrace cs +lexer cont ('%':cs) = lexKeyword cont cs +lexer cont ('\'':cs) = lexChar cont cs +lexer cont ('\"':cs) = lexString [] cont cs +lexer cont ('#':cs) = cont TKhash cs +lexer cont ('(':cs) = cont TKoparen cs +lexer cont (')':cs) = cont TKcparen cs +lexer cont ('{':cs) = cont TKobrace cs +lexer cont ('}':cs) = cont TKcbrace cs lexer cont ('=':cs) = cont TKeq cs lexer cont (':':'=':':':cs) = cont TKcoloneqcolon cs lexer cont (':':':':cs) = cont TKcoloncolon cs -lexer cont ('*':cs) = cont TKstar cs -lexer cont ('.':cs) = cont TKdot cs +lexer cont ('*':cs) = cont TKstar cs +lexer cont ('.':cs) = cont TKdot cs lexer cont ('\\':cs) = cont TKlambda cs -lexer cont ('@':cs) = cont TKat cs -lexer cont ('?':cs) = cont TKquestion cs -lexer cont (';':cs) = cont TKsemicolon cs +lexer cont ('@':cs) = cont TKat cs +lexer cont ('?':cs) = cont TKquestion cs +lexer cont (';':cs) = cont TKsemicolon cs -- 20060420 GHC spits out constructors with colon in them nowadays. jds -- 20061103 but it's easier to parse if we split on the colon, and treat them -- as several tokens @@ -68,7 +60,7 @@ lexChar _ cs = panic ("lexChar: " ++ show cs) lexString :: String -> (Token -> [Char] -> Int -> ParseResult a) -> String -> Int -> ParseResult a -lexString s cont ('\\':'x':h1:h0:cs) +lexString s cont ('\\':'x':h1:h0:cs) | isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs lexString _ _ ('\\':_) = failP "invalid string character" ['\\'] lexString _ _ ('\'':_) = failP "invalid string character" ['\''] @@ -86,14 +78,14 @@ lexNum :: (Token -> String -> a) -> String -> a lexNum cont cs = case cs of ('-':cs) -> f (-1) cs - _ -> f 1 cs - where f sgn cs = + _ -> f 1 cs + where f sgn cs = case span isDigit cs of - (digits,'.':c:rest) - | isDigit c -> cont (TKrational (fromInteger sgn * r)) rest' - where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest)) - -- When reading a floating-point number, which is - -- a bit complicated, use the standard library function + (digits,'.':c:rest) + | isDigit c -> cont (TKrational (fromInteger sgn * r)) rest' + where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest)) + -- When reading a floating-point number, which is + -- a bit complicated, use the standard library function -- "readFloat" (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest @@ -103,21 +95,21 @@ lexName cont cstr cs = cont (cstr name) rest lexKeyword :: (Token -> [Char] -> Int -> ParseResult a) -> String -> Int -> ParseResult a -lexKeyword cont cs = +lexKeyword cont cs = case span isKeywordChar cs of ("module",rest) -> cont TKmodule rest ("data",rest) -> cont TKdata rest ("newtype",rest) -> cont TKnewtype rest - ("forall",rest) -> cont TKforall rest - ("rec",rest) -> cont TKrec rest - ("let",rest) -> cont TKlet rest - ("in",rest) -> cont TKin rest - ("case",rest) -> cont TKcase rest - ("of",rest) -> cont TKof rest - ("cast",rest) -> cont TKcast rest - ("note",rest) -> cont TKnote rest + ("forall",rest) -> cont TKforall rest + ("rec",rest) -> cont TKrec rest + ("let",rest) -> cont TKlet rest + ("in",rest) -> cont TKin rest + ("case",rest) -> cont TKcase rest + ("of",rest) -> cont TKof rest + ("cast",rest) -> cont TKcast rest + ("note",rest) -> cont TKnote rest ("external",rest) -> cont TKexternal rest ("local",rest) -> cont TKlocal rest ("_",rest) -> cont TKwild rest - _ -> failP "invalid keyword" ('%':cs) + _ -> failP "invalid keyword" ('%':cs) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index e0e97fed4a..6e74cfbc4a 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -509,8 +509,6 @@ data Token | ITocurly -- special symbols | ITccurly - | ITocurlybar -- {|, for type applications - | ITccurlybar -- |}, for type applications | ITvocurly | ITvccurly | ITobrack diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 9803650842..b664861c44 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -294,8 +294,6 @@ incorrect. '{' { L _ ITocurly } -- special symbols '}' { L _ ITccurly } - '{|' { L _ ITocurlybar } - '|}' { L _ ITccurlybar } vocurly { L _ ITvocurly } -- virtual open curly (from layout) vccurly { L _ ITvccurly } -- virtual close curly (from layout) '[' { L _ ITobrack } @@ -1432,14 +1430,6 @@ aexp1 :: { LHsExpr RdrName } ; checkRecordSyntax (LL r) }} | aexp2 { $1 } --- Here was the syntax for type applications that I was planning --- but there are difficulties (e.g. what order for type args) --- so it's not enabled yet. --- But this case *is* used for the left hand side of a generic definition, --- which is parsed as an expression before being munged into a pattern - | qcname '{|' type '|}' { LL $ HsApp (sL (getLoc $1) (HsVar (unLoc $1))) - (sL (getLoc $3) (HsType $3)) } - aexp2 :: { LHsExpr RdrName } : ipvar { L1 (HsIPVar $! unLoc $1) } | qcname { L1 (HsVar $! unLoc $1) } @@ -1591,16 +1581,17 @@ squals :: { Located [LStmt RdrName] } -- In reverse order, because the last -- | '{|' pquals '|}' { L1 [$2] } --- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |} --- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user --- demand. +-- It is possible to enable bracketing (associating) qualifier lists +-- by uncommenting the lines with {| |} above. Due to a lack of +-- consensus on the syntax, this feature is not being used until we +-- get user demand. transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) } -- Function is applied to a list of stmts *in order* - : 'then' exp { LL $ \leftStmts -> (mkTransformStmt leftStmts $2) } - | 'then' exp 'by' exp { LL $ \leftStmts -> (mkTransformByStmt leftStmts $2 $4) } - | 'then' 'group' 'using' exp { LL $ \leftStmts -> (mkGroupUsingStmt leftStmts $4) } - | 'then' 'group' 'by' exp 'using' exp { LL $ \leftStmts -> (mkGroupByUsingStmt leftStmts $4 $6) } + : 'then' exp { LL $ \ss -> (mkTransformStmt ss $2) } + | 'then' exp 'by' exp { LL $ \ss -> (mkTransformByStmt ss $2 $4) } + | 'then' 'group' 'using' exp { LL $ \ss -> (mkGroupUsingStmt ss $4) } + | 'then' 'group' 'by' exp 'using' exp { LL $ \ss -> (mkGroupByUsingStmt ss $4 $6) } -- Note that 'group' is a special_id, which means that you can enable -- TransformListComp while still using Data.List.group. However, this diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 8daa6fa3c7..131c86bda2 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -870,10 +870,10 @@ quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quo divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey -floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromIntegerName") floatFromIntegerIdKey -doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromIntegerName") doubleFromIntegerIdKey -encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatIntegerName") encodeFloatIntegerIdKey -encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleIntegerName") encodeDoubleIntegerIdKey +floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey +doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey +encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey +encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index d57d1f926e..39bee1fb9d 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -12,7 +12,8 @@ module PrimOp ( tagToEnumKey, primOpOutOfLine, primOpCodeSize, - primOpOkForSpeculation, primOpIsCheap, + primOpOkForSpeculation, primOpOkForSideEffects, + primOpIsCheap, getPrimOpResultInfo, PrimOpResultInfo(..), @@ -307,77 +308,93 @@ primOpOutOfLine :: PrimOp -> Bool Note [PrimOp can_fail and has_side_effects] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * A primop that is neither can_fail nor has_side_effects can be - executed speculatively, any number of times +Both can_fail and has_side_effects mean that the primop has +some effect that is not captured entirely by its result value. + + ---------- has_side_effects --------------------- + Has some imperative side effect, perhaps on the world (I/O), + or perhaps on some mutable data structure (writeIORef). + Generally speaking all such primops have a type like + State -> input -> (State, output) + so the state token guarantees ordering, and also ensures + that the primop is executed even if 'output' is discarded. + + ---------- can_fail ---------------------------- + Can fail with a seg-fault or divide-by-zero error on some elements + of its input domain. Main examples: + division (fails on zero demoninator + array indexing (fails if the index is out of bounds) + However (ASSUMPTION), these can_fail primops are ALWAYS surrounded + with a test that checks for the bad cases. + +Consequences: + +* You can discard a can_fail primop, or float it _inwards_. + But you cannot float it _outwards_, lest you escape the + dynamic scope of the test. Example: + case d ># 0# of + True -> case x /# d of r -> r +# 1 + False -> 0 + Here we must not float the case outwards to give + case x/# d of r -> + case d ># 0# of + True -> r +# 1 + False -> 0 + +* I believe that exactly the same rules apply to a has_side_effects + primop; you can discard it (remember, the state token will keep + it alive if necessary), or float it in, but not float it out. + + Example of the latter + if blah then let! s1 = writeMutVar s0 v True in s1 + else s0 + Notice that s0 is mentioned in both branches of the 'if', but + only one of these two will actually be consumed. But if we + float out to + let! s1 = writeMutVar s0 v True + in if blah then s1 else s0 + the writeMutVar will be performed in both branches, which is + utterly wrong. + +* You cannot duplicate a has_side_effect primop. You might wonder + how this can occur given the state token threading, but just look + at Control.Monad.ST.Lazy.Imp.strictToLazy! We get something like + this + p = case readMutVar# s v of + (# s', r #) -> (S# s', r) + s' = case p of (s', r) -> s' + r = case p of (s', r) -> r + + (All these bindings are boxed.) If we inline p at its two call + sites, we get a catastrophe: because the read is performed once when + s' is demanded, and once when 'r' is demanded, which may be much + later. Utterly wrong. Trac #3207 is real example of this happening. + + However, it's fine to duplicate a can_fail primop. That is + the difference between can_fail and has_side_effects. + + can_fail has_side_effects +Discard YES YES +Float in YES YES +Float out NO NO +Duplicate YES NO + +How do we achieve these effects? - * A primop that is marked can_fail cannot be executed speculatively, - (becuase the might provoke the failure), but it can be repeated. - Why would you want to do that? Perhaps it might enable some - eta-expansion, if you can prove that the lambda is definitely - applied at least once. I guess we don't currently do that. +Note [primOpOkForSpeculation] + * The "no-float-out" thing is achieved by ensuring that we never + let-bind a can_fail or has_side_effects primop. The RHS of a + let-binding (which can float in and out freely) satisfies + exprOkForSpeculation. And exprOkForSpeculation is false of + can_fail and no_side_effect. - * A primop that is marked has_side_effects can be neither speculated - nor repeated; it must be executed exactly the right number of - times. + * So can_fail and no_side_effect primops will appear only as the + scrutinees of cases, and that's why the FloatIn pass is capable + of floating case bindings inwards. -So has_side_effects implies can_fail. We don't currently exploit -the case of primops that can_fail but do not have_side_effects. + * The no-duplicate thing is done via primOpIsCheap, by making + has_side_effects things (very very very) not-cheap! -Note [primOpOkForSpeculation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Sometimes we may choose to execute a PrimOp even though it isn't -certain that its result will be required; ie execute them -``speculatively''. The same thing as ``cheap eagerness.'' Usually -this is OK, because PrimOps are usually cheap, but it isn't OK for - * PrimOps that are expensive - * PrimOps which can fail - * PrimOps that have side effects - -Ok-for-speculation also means that it's ok *not* to execute the -primop. For example - case op a b of - r -> 3 -Here the result is not used, so we can discard the primop. Anything -that has side effects mustn't be dicarded in this way, of course! - -See also @primOpIsCheap@ (below). - -Note [primOpHasSideEffects] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some primops have side-effects and so, for example, must not be -duplicated. - -This predicate means a little more than just "modifies the state of -the world". What it really means is "it cosumes the state on its -input". To see what this means, consider - - let - t = case readMutVar# v s0 of (# s1, x #) -> (S# s1, x) - y = case t of (s,x) -> x - in - ... y ... y ... - -Now, this is part of an ST or IO thread, so we are guaranteed by -construction that the program uses the state in a single-threaded way. -Whenever the state resulting from the readMutVar# is demanded, the -readMutVar# will be performed, and it will be ordered correctly with -respect to other operations in the monad. - -But there's another way this could go wrong: GHC can inline t into y, -and inline y. Then although the original readMutVar# will still be -correctly ordered with respect to the other operations, there will be -one or more extra readMutVar#s performed later, possibly out-of-order. -This really happened; see #3207. - -The property we need to capture about readMutVar# is that it consumes -the State# value on its input. We must retain the linearity of the -State#. - -Our fix for this is to declare any primop that must be used linearly -as having side-effects. When primOpHasSideEffects is True, -primOpOkForSpeculation will be False, and hence primOpIsCheap will -also be False, and applications of the primop will never be -duplicated. \begin{code} primOpHasSideEffects :: PrimOp -> Bool @@ -387,15 +404,19 @@ primOpCanFail :: PrimOp -> Bool #include "primop-can-fail.hs-incl" primOpOkForSpeculation :: PrimOp -> Bool - -- See Note [primOpOkForSpeculation] + -- See Note [primOpOkForSpeculation and primOpOkForFloatOut] -- See comments with CoreUtils.exprOkForSpeculation primOpOkForSpeculation op = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op) + +primOpOkForSideEffects :: PrimOp -> Bool +primOpOkForSideEffects op + = not (primOpHasSideEffects op) \end{code} -primOpIsCheap -~~~~~~~~~~~~~ +Note [primOpIsCheap] +~~~~~~~~~~~~~~~~~~~~ @primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK WARNING), we just borrow some other predicates for a what-should-be-good-enough test. "Cheap" means willing to call it more diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 5047b3cb63..48dd76873a 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1481,7 +1481,10 @@ primop RaiseOp "raise#" GenPrimOp -- one kind of bottom into another, as it is allowed to do in pure code. -- -- But we *do* want to know that it returns bottom after --- being applied to two arguments +-- being applied to two arguments, so that this function is strict in y +-- f x y | x>0 = raiseIO blah +-- | y>0 = return 1 +-- | otherwise = return 2 primop RaiseIOOp "raiseIO#" GenPrimOp a -> State# RealWorld -> (# State# RealWorld, b #) diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index a4bf1f2d69..bd424e87b8 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -462,17 +462,17 @@ lookupPromotedOccRn rdr_name Nothing -> do { -- Maybe it's the name of a *data* constructor - poly_kinds <- xoptM Opt_PolyKinds + data_kinds <- xoptM Opt_DataKinds ; mb_demoted_name <- case demoteRdrName rdr_name of Just demoted_rdr -> lookupOccRn_maybe demoted_rdr Nothing -> return Nothing ; case mb_demoted_name of Nothing -> unboundName WL_Any rdr_name Just demoted_name - | poly_kinds -> return demoted_name + | data_kinds -> return demoted_name | otherwise -> unboundNameX WL_Any rdr_name suggest_pk }}} where - suggest_pk = ptext (sLit "A data constructor of that name is in scope; did you mean -XPolyKinds?") + suggest_pk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") \end{code} Note [Demotion] @@ -1112,7 +1112,7 @@ checkShadowedOccs (global_env,local_env) loc_occs -- Returns False for record selectors that are shadowed, when -- punning or wild-cards are on (cf Trac #2723) is_shadowed_gre gre@(GRE { gre_par = ParentIs _ }) - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; if (xopt Opt_RecordPuns dflags || xopt Opt_RecordWildCards dflags) then do { is_fld <- is_rec_fld gre; return (not is_fld) } else return True } @@ -1437,7 +1437,7 @@ kindSigErr thing polyKindsErr :: Outputable a => a -> SDoc polyKindsErr thing = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr thing)) - 2 (ptext (sLit "Perhaps you intended to use -XPolyKinds")) + 2 (ptext (sLit "Perhaps you intended to use -XDataKinds")) badQualBndrErr :: RdrName -> SDoc diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 04877331d0..7caae61027 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -1239,7 +1239,7 @@ checkStmt :: HsStmtContext Name -> LStmt RdrName -> RnM () checkStmt ctxt (L _ stmt) - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; case okStmt dflags ctxt stmt of Nothing -> return () Just extra -> addErr (msg $$ extra) } diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 1f9041e473..68e6d027e6 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -200,7 +200,7 @@ rnImportDecl this_mod -- and indeed we shouldn't do it here because the existence of -- the non-boot module depends on the compilation order, which -- is not deterministic. The hs-boot test can show this up. - dflags <- getDOpts + dflags <- getDynFlags warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ @@ -964,7 +964,7 @@ rnExports explicit_mod exports -- written "module Main where ..." -- Reason: don't want to complain about 'main' not in scope -- in interactive mode - ; dflags <- getDOpts + ; dflags <- getDynFlags ; let real_exports | explicit_mod = exports | ghcLink dflags == LinkInMemory = Nothing diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 197f2b2554..175b9a7ba4 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -682,7 +682,7 @@ rnHsVectDecl (HsVectClassOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" rnHsVectDecl (HsVectInstIn instTy) = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy - ; return (HsVectInstIn instTy', emptyFVs) + ; return (HsVectInstIn instTy', extractHsTyNames instTy') } rnHsVectDecl (HsVectInstOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'" @@ -749,7 +749,7 @@ rnTyClDecls :: [Name] -> [[LTyClDecl RdrName]] -- Rename the declarations and do depedency analysis on them rnTyClDecls extra_deps tycl_ds = do { ds_w_fvs <- mapM (wrapLocFstM (rnTyClDecl Nothing)) (concat tycl_ds) - ; thisPkg <- fmap thisPackage getDOpts + ; thisPkg <- fmap thisPackage getDynFlags ; let add_boot_deps :: FreeVars -> FreeVars -- See Note [Extra dependencies from .hs-boot files] add_boot_deps fvs | any (isInPackage thisPkg) (nameSetToList fvs) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 936f38f55b..c6c64e8b33 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -196,8 +196,8 @@ rnHsTyKi isType doc (HsFunTy ty1 ty2) = do else return (HsFunTy ty1' ty2') rnHsTyKi isType doc listTy@(HsListTy ty) = do - poly_kinds <- xoptM Opt_PolyKinds - unless (poly_kinds || isType) (addErr (polyKindsErr listTy)) + data_kinds <- xoptM Opt_DataKinds + unless (data_kinds || isType) (addErr (polyKindsErr listTy)) ty' <- rnLHsTyKi isType doc ty return (HsListTy ty') @@ -216,8 +216,8 @@ rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do -- 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 - poly_kinds <- xoptM Opt_PolyKinds - unless (poly_kinds || isType) (addErr (polyKindsErr tupleTy)) + data_kinds <- xoptM Opt_DataKinds + unless (data_kinds || isType) (addErr (polyKindsErr tupleTy)) tys' <- mapM (rnLHsTyKi isType doc) tys return (HsTupleTy tup_con tys') diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 6745fda8cb..0601d7b7bf 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -24,7 +24,8 @@ module FloatIn ( floatInwards ) where #include "HsVersions.h" import CoreSyn -import CoreUtils ( exprIsHNF, exprIsDupable ) +import MkCore +import CoreUtils ( exprIsDupable, exprIsExpandable, exprOkForSideEffects ) import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars ) import Id ( isOneShotBndr, idType ) import Var @@ -119,26 +120,28 @@ the closure for a is not built. %************************************************************************ \begin{code} -type FreeVarsSet = IdSet +type FreeVarSet = IdSet +type BoundVarSet = IdSet -type FloatingBinds = [(CoreBind, FreeVarsSet)] - -- In reverse dependency order (innermost binder first) - - -- The FreeVarsSet is the free variables of the binding. In the case +data FloatInBind = FB BoundVarSet FreeVarSet FloatBind + -- The FreeVarSet is the free variables of the binding. In the case -- of recursive bindings, the set doesn't include the bound -- variables. -fiExpr :: FloatingBinds -- Binds we're trying to drop +type FloatInBinds = [FloatInBind] + -- In reverse dependency order (innermost binder first) + +fiExpr :: FloatInBinds -- Binds we're trying to drop -- as far "inwards" as possible -> CoreExprWithFVs -- Input expr -> CoreExpr -- Result fiExpr to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty -fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) -fiExpr to_drop (_, AnnCoercion co) = mkCoLets' to_drop (Coercion co) +fiExpr to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) +fiExpr to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) fiExpr to_drop (_, AnnCast expr (fvs_co, co)) - = mkCoLets' (drop_here ++ co_drop) $ + = wrapFloats (drop_here ++ co_drop) $ Cast (fiExpr e_drop expr) co where [drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop @@ -149,10 +152,16 @@ need to get at all the arguments. The next simplifier run will pull out any silly ones. \begin{code} -fiExpr to_drop (_,AnnApp fun arg) - = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg)) +fiExpr to_drop (_,AnnApp fun arg@(arg_fvs, ann_arg)) + | noFloatIntoRhs ann_arg = wrapFloats drop_here $ wrapFloats arg_drop $ + App (fiExpr fun_drop fun) (fiExpr [] arg) + -- It's inconvenient to test for an unlifted arg here, + -- and it really doesn't matter if we float into one + | otherwise = wrapFloats drop_here $ + App (fiExpr fun_drop fun) (fiExpr arg_drop arg) where - [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop + [drop_here, fun_drop, arg_drop] + = sepBindsByDropPoint False [freeVarsOf fun, arg_fvs] to_drop \end{code} Note [Floating in past a lambda group] @@ -199,7 +208,7 @@ fiExpr to_drop lam@(_, AnnLam _ _) = mkLams bndrs (fiExpr to_drop body) | otherwise -- Dump it all here - = mkCoLets' to_drop (mkLams bndrs (fiExpr [] body)) + = wrapFloats to_drop (mkLams bndrs (fiExpr [] body)) where (bndrs, body) = collectAnnBndrs lam @@ -220,7 +229,7 @@ We don't float lets inwards past an SCC. fiExpr to_drop (_, AnnTick tickish expr) | tickishScoped tickish = -- Wimp out for now - we could push values in - mkCoLets' to_drop (Tick tickish (fiExpr [] expr)) + wrapFloats to_drop (Tick tickish (fiExpr [] expr)) | otherwise = Tick tickish (fiExpr to_drop expr) @@ -266,7 +275,7 @@ can't have unboxed bindings. So we make "extra_fvs" which is the rhs_fvs of such bindings, and arrange to dump bindings that bind extra_fvs before the entire let. -Note [extra_fvs (s): free variables of rules] +Note [extra_fvs (2): free variables of rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider let x{rule mentioning y} = rhs in body @@ -280,13 +289,13 @@ idFreeVars. fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) = fiExpr new_to_drop body where - body_fvs = freeVarsOf body + body_fvs = freeVarsOf body `delVarSet` id rule_fvs = idRuleAndUnfoldingVars id -- See Note [extra_fvs (2): free variables of rules] extra_fvs | noFloatIntoRhs ann_rhs || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs | otherwise = rule_fvs - -- See Note [extra_fvs (2): avoid floating into RHS] + -- See Note [extra_fvs (1): avoid floating into RHS] -- No point in floating in only to float straight out again -- Ditto ok-for-speculation unlifted RHSs @@ -294,7 +303,8 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) = sepBindsByDropPoint False [extra_fvs, rhs_fvs, body_fvs] to_drop new_to_drop = body_binds ++ -- the bindings used only in the body - [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself + [FB (unitVarSet id) rhs_fvs' + (FloatLet (NonRec id rhs'))] ++ -- the new binding itself extra_binds ++ -- bindings from extra_fvs shared_binds -- the bindings used both in rhs and body @@ -308,7 +318,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) where (ids, rhss) = unzip bindings rhss_fvs = map freeVarsOf rhss - body_fvs = freeVarsOf body + body_fvs = freeVarsOf body -- See Note [extra_fvs (1,2)] rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids @@ -320,7 +330,8 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) = sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop new_to_drop = body_binds ++ -- the bindings used only in the body - [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++ + [FB (mkVarSet ids) rhs_fvs' + (FloatLet (Rec (fi_bind rhss_binds bindings)))] ++ -- The new binding itself extra_binds ++ -- Note [extra_fvs (1,2)] shared_binds -- Used in more than one place @@ -330,7 +341,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) rule_fvs -- Don't forget the rule variables! -- Push rhs_binds into the right hand side of the binding - fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss + fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss -> [(Id, CoreExprWithFVs)] -> [(Id, CoreExpr)] @@ -344,17 +355,32 @@ bindings are: (a)~inside the scrutinee, (b)~inside one of the alternatives/default [default FVs always {\em first}!]. \begin{code} +fiExpr to_drop (_, AnnCase scrut case_bndr _ [(DEFAULT,[],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 []) + 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 + scrut_fvs = freeVarsOf scrut + fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) - = mkCoLets' drop_here1 $ - mkCoLets' drop_here2 $ + = wrapFloats drop_here1 $ + wrapFloats drop_here2 $ Case (fiExpr scrut_drops scrut) case_bndr ty (zipWith fi_alt alts_drops_s alts) where -- Float into the scrut and alts-considered-together just like App - [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop + [drop_here1, scrut_drops, alts_drops] + = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop -- Float into the alts with the is_case flag set - (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops + (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops scrut_fvs = freeVarsOf scrut alts_fvs = map alt_fvs alts @@ -376,7 +402,9 @@ noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) -- boxing constructor into it, else we box it every time which is very bad -- news indeed. -noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again... +noFloatIntoRhs rhs = exprIsExpandable (deAnnotate' rhs) + -- We'd just float right back out again... + -- Should match the test in SimplEnv.doFloatFromRhs is_one_shot :: Var -> Bool is_one_shot b = isId b && isOneShotBndr b @@ -407,9 +435,9 @@ We have to maintain the order on these drop-point-related lists. \begin{code} sepBindsByDropPoint :: Bool -- True <=> is case expression - -> [FreeVarsSet] -- One set of FVs per drop point - -> FloatingBinds -- Candidate floaters - -> [FloatingBinds] -- FIRST one is bindings which must not be floated + -> [FreeVarSet] -- One set of FVs per drop point + -> FloatInBinds -- Candidate floaters + -> [FloatInBinds] -- FIRST one is bindings which must not be floated -- inside any drop point; the rest correspond -- one-to-one with the input list of FV sets @@ -419,7 +447,7 @@ sepBindsByDropPoint -- a binding (let x = E in B) might have a specialised version of -- x (say x') stored inside x, but x' isn't free in E or B. -type DropBox = (FreeVarsSet, FloatingBinds) +type DropBox = (FreeVarSet, FloatInBinds) sepBindsByDropPoint _is_case drop_pts [] = [] : [[] | _ <- drop_pts] -- cut to the chase scene; it happens @@ -427,19 +455,19 @@ sepBindsByDropPoint _is_case drop_pts [] sepBindsByDropPoint is_case drop_pts floaters = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts)) where - go :: FloatingBinds -> [DropBox] -> [FloatingBinds] + go :: FloatInBinds -> [DropBox] -> [FloatInBinds] -- The *first* one in the argument list is the drop_here set - -- The FloatingBinds in the lists are in the reverse of - -- the normal FloatingBinds order; that is, they are the right way round! + -- The FloatInBinds in the lists are in the reverse of + -- the normal FloatInBinds order; that is, they are the right way round! go [] drop_boxes = map (reverse . snd) drop_boxes - go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes) + go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes) = go binds new_boxes where -- "here" means the group of bindings dropped at the top of the fork - (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind) + (used_here : used_in_flags) = [ fvs `intersectsVarSet` bndrs | (fvs, _) <- drop_boxes] drop_here = used_here || not can_push @@ -460,7 +488,7 @@ sepBindsByDropPoint is_case drop_pts floaters || (is_case && -- We are looking at case alternatives n_used_alts > 1 && -- It's used in more than one n_used_alts < n_alts && -- ...but not all - bindIsDupable bind) -- and we can duplicate the binding + floatIsDupable bind) -- and we can duplicate the binding new_boxes | drop_here = (insert here_box : fork_boxes) | otherwise = (here_box : new_fork_boxes) @@ -476,14 +504,19 @@ sepBindsByDropPoint is_case drop_pts floaters go _ _ = panic "sepBindsByDropPoint/go" -floatedBindsFVs :: FloatingBinds -> FreeVarsSet -floatedBindsFVs binds = unionVarSets (map snd binds) +floatedBindsFVs :: FloatInBinds -> FreeVarSet +floatedBindsFVs binds = foldr (unionVarSet . fbFVs) emptyVarSet binds + +fbFVs :: FloatInBind -> VarSet +fbFVs (FB _ fvs _) = fvs -mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr -mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop - -- Remember to_drop is in *reverse* dependency order +wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr +-- Remember FloatInBinds is in *reverse* dependency order +wrapFloats [] e = e +wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) -bindIsDupable :: Bind CoreBndr -> Bool -bindIsDupable (Rec prs) = all (exprIsDupable . snd) prs -bindIsDupable (NonRec _ r) = exprIsDupable r +floatIsDupable :: FloatBind -> Bool +floatIsDupable (FloatCase scrut _ _ _) = exprIsDupable scrut +floatIsDupable (FloatLet (Rec prs)) = all (exprIsDupable . snd) prs +floatIsDupable (FloatLet (NonRec _ r)) = exprIsDupable r \end{code} diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index 00d6554790..18fc9b4af4 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -17,12 +17,12 @@ module FloatOut ( floatOutwards ) where import CoreSyn import CoreUtils +import MkCore import CoreArity ( etaExpand ) import CoreMonad ( FloatOutSwitches(..) ) import DynFlags ( DynFlags, DynFlag(..) ) import ErrUtils ( dumpIfSet_dyn ) -import DataCon ( DataCon ) import Id ( Id, idArity, isBottomingId ) import Var ( Var ) import SetLevels @@ -326,7 +326,7 @@ floatExpr (Let bind body) floatExpr (Case scrut (TB case_bndr case_spec) ty alts) = case case_spec of FloatMe dest_lvl -- Case expression moves - | [(DataAlt con, bndrs, rhs)] <- alts + | [(con@(DataAlt {}), bndrs, rhs)] <- alts -> case floatExpr scrut of { (fse, fde, scrut') -> case floatExpr rhs of { (fsb, fdb, rhs') -> let @@ -444,13 +444,6 @@ partitionByMajorLevel. \begin{code} -data FloatBind - = FloatLet FloatLet - - | FloatCase CoreExpr Id DataCon [Var] - -- case e of y { C ys -> ... } - -- See Note [Floating cases] in SetLevels - type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted type MajorEnv = M.IntMap MinorEnv -- Keyed by major level type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level @@ -491,7 +484,7 @@ flattenMinor = M.fold unionBags emptyBag emptyFloats :: FloatBinds emptyFloats = FB emptyBag M.empty -unitCaseFloat :: Level -> CoreExpr -> Id -> DataCon -> [Var] -> FloatBinds +unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds unitCaseFloat (Level major minor) e b con bs = FB emptyBag (M.singleton major (M.singleton minor (unitBag (FloatCase e b con bs)))) @@ -514,12 +507,7 @@ plusMinor = M.unionWith unionBags install :: Bag FloatBind -> CoreExpr -> CoreExpr install defn_groups expr - = foldrBag install_group expr defn_groups - where - install_group (FloatLet defns) body - = Let defns body - install_group (FloatCase e b con bs) body - = Case e b (exprType body) [(DataAlt con, bs, body)] + = foldrBag wrapFloat expr defn_groups partitionByLevel :: Level -- Partitioning level diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index a80dea4603..beb64cb061 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -423,7 +423,7 @@ Things to note * We only do this with a single-alternative case Note [Check the output scrutinee for okForSpec] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this: case x of y { A -> ....(case y of alts).... @@ -432,7 +432,7 @@ Because of the binder-swap, the inner case will get substituted to (case x of ..). So when testing whether the scrutinee is okForSpecuation we must be careful to test the *result* scrutinee ('x' in this case), not the *input* one 'y'. The latter *is* ok for -speculation here, but the former is not -- and ideed we can't float +speculation here, but the former is not -- and indeed we can't float the inner case out, at least not unless x is also evaluated at its binding site. diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 62f96e7c6e..8661d71e04 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -397,6 +397,7 @@ classifyFF (NonRec bndr rhs) | otherwise = FltCareful doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool +-- If you change this function look also at FloatIn.noFloatFromRhs doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) = not (isNilOL fs) && want_to_float && can_float where diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 647da72d16..e025e6cb34 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -15,7 +15,7 @@ module SimplMonad ( -- The monad SimplM, initSmpl, - getDOptsSmpl, getSimplRules, getFamEnvs, + getSimplRules, getFamEnvs, -- Unique supply MonadUnique(..), newId, @@ -31,7 +31,7 @@ import Type ( Type ) import FamInstEnv ( FamInstEnv ) import Rules ( RuleBase ) import UniqSupply -import DynFlags ( DynFlags( simplTickFactor ) ) +import DynFlags import CoreMonad import Outputable import FastString @@ -148,8 +148,8 @@ instance MonadUnique SimplM where = SM (\_st_env us sc -> case splitUniqSupply us of (us1, us2) -> (uniqsFromSupply us1, us2, sc)) -getDOptsSmpl :: SimplM DynFlags -getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc)) +instance HasDynFlags SimplM where + getDynFlags = SM (\st_env us sc -> (st_flags st_env, us, sc)) getSimplRules :: SimplM RuleBase getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc)) diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 86dc88ddd1..ad6fe5488b 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -1054,7 +1054,7 @@ mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr mkLam _b [] body = return body mkLam _env bndrs body - = do { dflags <- getDOptsSmpl + = do { dflags <- getDynFlags ; mkLam' dflags bndrs body } where mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr @@ -1125,7 +1125,7 @@ because the latter is not well-kinded. tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr) -- See Note [Eta-expanding at let bindings] tryEtaExpand env bndr rhs - = do { dflags <- getDOptsSmpl + = do { dflags <- getDynFlags ; (new_arity, new_rhs) <- try_expand dflags ; WARN( new_arity < old_arity || new_arity < _dmd_arity, diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 2d84249e97..900d70c7de 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -221,7 +221,7 @@ simplTopBinds env0 binds0 -- It's rather as if the top-level binders were imported. -- See note [Glomming] in OccurAnal. ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0) - ; dflags <- getDOptsSmpl + ; dflags <- getDynFlags ; let dump_flag = dopt Opt_D_verbose_core2core dflags ; env2 <- simpl_binds dump_flag env1 binds0 ; freeTick SimplifierDone @@ -976,11 +976,6 @@ simplType env ty --------------------------------- simplCoercionF :: SimplEnv -> InCoercion -> SimplCont -> SimplM (SimplEnv, OutExpr) --- We are simplifying a term of form (Coercion co) --- Simplify the InCoercion, and then try to combine with the --- context, to implememt the rule --- (Coercion co) |> g --- = Coercion (syn (nth 0 g) ; co ; nth 1 g) simplCoercionF env co cont = do { co' <- simplCoercion env co ; rebuild env (Coercion co') cont } @@ -1164,7 +1159,7 @@ 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 + -- 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 @@ -1388,7 +1383,7 @@ simplIdF env var cont completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) completeCall env var cont = do { ------------- Try inlining ---------------- - dflags <- getDOptsSmpl + dflags <- getDynFlags ; let (lone_variable, arg_infos, call_cont) = contArgs cont -- The args are OutExprs, obtained by *lazily* substituting -- in the args found in cont. These args are only examined @@ -1564,7 +1559,7 @@ tryRules env rules fn args call_cont Just (rule, rule_rhs) -> do { checkedTick (RuleFired (ru_name rule)) - ; dflags <- getDOptsSmpl + ; dflags <- getDynFlags ; trace_dump dflags rule rule_rhs $ return (Just (ruleArity rule, rule_rhs)) }}} where @@ -1766,7 +1761,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont | all isDeadBinder bndrs -- bndrs are [InId] , if isUnLiftedType (idType case_bndr) - then ok_for_spec -- Satisfy the let-binding invariant + then elim_unlifted -- Satisfy the let-binding invariant else elim_lifted = do { -- pprTrace "case elim" (vcat [ppr case_bndr, ppr (exprIsHNF scrut), -- ppr strict_case_bndr, ppr (scrut_is_var scrut), @@ -1786,6 +1781,14 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont || (is_plain_seq && ok_for_spec) -- Note: not the same as exprIsHNF + elim_unlifted + | is_plain_seq = exprOkForSideEffects scrut + -- The entire case is dead, so we can drop it, + -- _unless_ the scrutinee has side effects + | 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 + ok_for_spec = exprOkForSpeculation scrut is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect strict_case_bndr = isStrictDmd (idDemandInfo case_bndr) @@ -1832,7 +1835,7 @@ reallyRebuildCase env scrut case_bndr alts cont -- Check for empty alternatives ; if null alts' then missingAlt env case_bndr alts cont else do - { dflags <- getDOptsSmpl + { dflags <- getDynFlags ; case_expr <- mkCase dflags scrut' case_bndr' alts' -- Notice that rebuild gets the in-scope set from env', not alt_env diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 614798873e..0bfd025410 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -265,17 +265,26 @@ dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) idDemandInfo case_bndr' (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut + res_ty = alt_ty1 `bothType` scrut_ty in - (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt']) +-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty" <+> ppr alt_ty1 +-- , text "res_ty" <+> ppr res_ty ]) $ + (res_ty, Case scrut' case_bndr' ty [alt']) 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 + res_ty = alt_ty `bothType` scrut_ty in --- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys) - (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts') +-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty" <+> ppr alt_ty +-- , text "res_ty" <+> ppr res_ty ]) $ + (res_ty, Case scrut' case_bndr' ty alts') dmdAnal env dmd (Let (NonRec id rhs) body) = let @@ -337,7 +346,7 @@ dmdAnalAlt env dmd (con,bndrs,rhs) -- other -> return () -- So the 'y' isn't necessarily going to be evaluated -- - -- A more complete example where this shows up is: + -- A more complete example (Trac #148, #1592) where this shows up is: -- do { let len = <expensive> ; -- ; when (...) (exitWith ExitSuccess) -- ; print len } diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 6269051e5f..98305e48a2 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -21,6 +21,7 @@ import TypeRep import TcMType import TcRnMonad import TyCon +import DynFlags import Name import Module import SrcLoc @@ -92,7 +93,7 @@ listToSet l = Map.fromList (zip l (repeat ())) checkFamInstConsistency :: [Module] -> [Module] -> TcM () checkFamInstConsistency famInstMods directlyImpMods - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; (eps, hpt) <- getEpsAndHpt ; let { -- Fetch the iface of a given module. Must succeed as diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index b589c265db..a194d748ed 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -377,7 +377,7 @@ syntaxNameCtxt name orig ty tidy_env = do \begin{code} getOverlapFlag :: TcM OverlapFlag getOverlapFlag - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; let overlap_ok = xopt Opt_OverlappingInstances dflags incoherent_ok = xopt Opt_IncoherentInstances dflags safeOverlap = safeLanguageOn dflags diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 7d20aaa946..e14bd49458 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -332,7 +332,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list -- (as determined by sig_fn), returning a TcSigInfo for each ; tc_sig_fn <- tcInstSigs sig_fn binder_names - ; dflags <- getDOpts + ; dflags <- getDynFlags ; type_env <- getLclTypeEnv ; let plan = decideGeneralisationPlan dflags type_env binder_names bind_list tc_sig_fn @@ -585,7 +585,8 @@ tcSpec poly_id prag@(SpecSig _ hs_ty inl) = addErrCtxt (spec_ctxt prag) $ do { spec_ty <- tcHsSigType sig_ctxt hs_ty ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) - (ptext (sLit "SPECIALISE pragma for non-overloaded function") <+> quotes (ppr poly_id)) + (ptext (sLit "SPECIALISE pragma for non-overloaded function") + <+> quotes (ppr poly_id)) -- Note [SPECIALISE pragmas] ; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty ; return (SpecPrag poly_id wrap inl) } @@ -603,7 +604,7 @@ tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] -- SPECIALISE pragamas for imported things tcImpPrags prags = do { this_mod <- getModule - ; dflags <- getDOpts + ; dflags <- getDynFlags ; if (not_specialising dflags) then return [] else diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 77f1c42982..ac1895fe35 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -363,7 +363,7 @@ 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 <- getDOpts + 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)])) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index dda82fff99..4db96c6e3c 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -331,7 +331,7 @@ tcDeriving tycl_decls inst_decls deriv_decls ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds - ; dflags <- getDOpts + ; dflags <- getDynFlags ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" (ddump_deriving inst_info rn_binds newTyCons famInsts)) @@ -617,7 +617,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta mk_alg_eqn tycon tc_args | className cls `elem` typeableClassNames - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; case checkTypeableConditions (dflags, tycon) of Just err -> bale_out err Nothing -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta } @@ -641,7 +641,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta ; unless (isNothing mtheta || not hidden_data_cons) (bale_out (derivingHiddenErr tycon)) - ; dflags <- getDOpts + ; dflags <- getDynFlags ; if isDataTyCon rep_tc then mkDataTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 915978ba3a..ae320ce692 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -558,7 +558,7 @@ tcGetDefaultTys :: Bool -- True <=> interactive context (Bool, -- True <=> Use overloaded strings Bool)) -- True <=> Use extended defaulting rules tcGetDefaultTys interactive - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; let ovl_strings = xopt Opt_OverloadedStrings dflags extended_defaults = interactive || xopt Opt_ExtendedDefaultRules dflags diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index a6aef315ab..5d5413d145 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -900,7 +900,7 @@ mkAmbigMsg ctxt cts | isEmptyVarSet ambig_tv_set = return (ctxt, False, empty) | otherwise - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; (ctxt', gbl_docs) <- findGlobals ctxt ambig_tv_set ; return (ctxt', True, mk_msg dflags gbl_docs) } where diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 93c5bf56ea..8b724a4cac 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -1,515 +1,515 @@ -%
-% (c) The University of Glasgow 2006
-%
-
-\begin{code}
-module TcEvidence (
-
- -- HsWrapper
- HsWrapper(..),
- (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpLams, mkWpLet,
- idHsWrapper, isIdHsWrapper, pprHsWrapper,
-
- -- Evidence bindin
- TcEvBinds(..), EvBindsVar(..),
- EvBindMap(..), emptyEvBindMap, extendEvBinds, lookupEvBind, evBindMapBinds,
-
- EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds,
-
- EvTerm(..), mkEvCast, evVarsOfTerm, mkEvKindCast,
-
- -- TcCoercion
- TcCoercion(..),
- mkTcReflCo, mkTcTyConAppCo, mkTcAppCo, mkTcAppCos, mkTcFunCo,
- mkTcAxInstCo, mkTcForAllCo, mkTcForAllCos,
- mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcInstCos,
- tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo,
- isTcReflCo, isTcReflCo_maybe, getTcCoVar_maybe,
- liftTcCoSubstWith
-
- ) where
-#include "HsVersions.h"
-
-import Var
-
-import PprCore () -- Instance OutputableBndr TyVar
-import TypeRep -- Knows type representation
-import TcType
-import Type( tyConAppArgN, getEqPredTys_maybe, tyConAppTyCon_maybe )
-import TysPrim( funTyCon )
-import TyCon
-import PrelNames
-import VarEnv
-import VarSet
-import Name
-
-import Util
-import Bag
-import Pair
-import Control.Applicative
-import Data.Traversable (traverse, sequenceA)
-import qualified Data.Data as Data
-import Outputable
-import FastString
-import Data.IORef( IORef )
-\end{code}
-
-
-Note [TcCoercions]
-~~~~~~~~~~~~~~~~~~
-| LCoercions are a hack used by the typechecker. Normally,
-Coercions have free variables of type (a ~# b): we call these
-CoVars. However, the type checker passes around equality evidence
-(boxed up) at type (a ~ b).
-
-An LCoercion is simply a Coercion whose free variables have the
-boxed type (a ~ b). After we are done with typechecking the
-desugarer finds the free variables, unboxes them, and creates a
-resulting real Coercion with kosher free variables.
-
-We can use most of the Coercion "smart constructors" to build LCoercions. However,
-mkCoVarCo will not work! The equivalent is mkTcCoVarCo.
-
-The data type is similar to Coercion.Coercion, with the following
-differences
- * Most important, TcLetCo adds let-bindings for coercions.
- This is what lets us unify two for-all types and generate
- equality constraints underneath
-
- * The kind of a TcCoercion is t1 ~ t2
- of a Coercion is t1 ~# t2
-
- * TcAxiomInstCo takes Types, not Coecions as arguments;
- the generality is required only in the Simplifier
-
- * UnsafeCo aren't required
-
- * Reprsentation invariants are weaker:
- - we are allowed to have type synonyms in TcTyConAppCo
- - the first arg of a TcAppCo can be a TcTyConAppCo
- Reason: they'll get established when we desugar to Coercion
-
-\begin{code}
-data TcCoercion
- = TcRefl TcType
- | TcTyConAppCo TyCon [TcCoercion]
- | TcAppCo TcCoercion TcCoercion
- | TcForAllCo TyVar TcCoercion
- | TcInstCo TcCoercion TcType
- | TcCoVarCo EqVar
- | TcAxiomInstCo CoAxiom [TcType]
- | TcSymCo TcCoercion
- | TcTransCo TcCoercion TcCoercion
- | TcNthCo Int TcCoercion
- | TcLetCo TcEvBinds TcCoercion
- deriving (Data.Data, Data.Typeable)
-
-isEqVar :: Var -> Bool
--- Is lifted coercion variable (only!)
-isEqVar v = case tyConAppTyCon_maybe (varType v) of
- Just tc -> tc `hasKey` eqTyConKey
- Nothing -> False
-
-isTcReflCo_maybe :: TcCoercion -> Maybe TcType
-isTcReflCo_maybe (TcRefl ty) = Just ty
-isTcReflCo_maybe _ = Nothing
-
-isTcReflCo :: TcCoercion -> Bool
-isTcReflCo (TcRefl {}) = True
-isTcReflCo _ = False
-
-getTcCoVar_maybe :: TcCoercion -> Maybe CoVar
-getTcCoVar_maybe (TcCoVarCo v) = Just v
-getTcCoVar_maybe _ = Nothing
-
-mkTcReflCo :: TcType -> TcCoercion
-mkTcReflCo = TcRefl
-
-mkTcFunCo :: TcCoercion -> TcCoercion -> TcCoercion
-mkTcFunCo co1 co2 = mkTcTyConAppCo funTyCon [co1, co2]
-
-mkTcTyConAppCo :: TyCon -> [TcCoercion] -> TcCoercion
-mkTcTyConAppCo tc cos -- No need to expand type synonyms
- -- See Note [TcCoercions]
- | Just tys <- traverse isTcReflCo_maybe cos
- = TcRefl (mkTyConApp tc tys) -- See Note [Refl invariant]
-
- | otherwise = TcTyConAppCo tc cos
-
-mkTcAxInstCo :: CoAxiom -> [TcType] -> TcCoercion
-mkTcAxInstCo ax tys
- | arity == n_tys = TcAxiomInstCo ax tys
- | otherwise = ASSERT( arity < n_tys )
- foldl TcAppCo (TcAxiomInstCo ax (take arity tys))
- (map TcRefl (drop arity tys))
- where
- n_tys = length tys
- arity = coAxiomArity ax
-
-mkTcAppCo :: TcCoercion -> TcCoercion -> TcCoercion
--- No need to deal with TyConApp on the left; see Note [TcCoercions]
-mkTcAppCo (TcRefl ty1) (TcRefl ty2) = TcRefl (mkAppTy ty1 ty2)
-mkTcAppCo co1 co2 = TcAppCo co1 co2
-
-mkTcSymCo :: TcCoercion -> TcCoercion
-mkTcSymCo co@(TcRefl {}) = co
-mkTcSymCo (TcSymCo co) = co
-mkTcSymCo co = TcSymCo co
-
-mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion
-mkTcTransCo (TcRefl _) co = co
-mkTcTransCo co (TcRefl _) = co
-mkTcTransCo co1 co2 = TcTransCo co1 co2
-
-mkTcNthCo :: Int -> TcCoercion -> TcCoercion
-mkTcNthCo n (TcRefl ty) = TcRefl (tyConAppArgN n ty)
-mkTcNthCo n co = TcNthCo n co
-
-mkTcAppCos :: TcCoercion -> [TcCoercion] -> TcCoercion
-mkTcAppCos co1 tys = foldl mkTcAppCo co1 tys
-
-mkTcForAllCo :: Var -> TcCoercion -> TcCoercion
--- note that a TyVar should be used here, not a CoVar (nor a TcTyVar)
-mkTcForAllCo tv (TcRefl ty) = ASSERT( isTyVar tv ) TcRefl (mkForAllTy tv ty)
-mkTcForAllCo tv co = ASSERT( isTyVar tv ) TcForAllCo tv co
-
-mkTcForAllCos :: [Var] -> TcCoercion -> TcCoercion
-mkTcForAllCos tvs (TcRefl ty) = ASSERT( all isTyVar tvs ) TcRefl (mkForAllTys tvs ty)
-mkTcForAllCos tvs co = ASSERT( all isTyVar tvs ) foldr TcForAllCo co tvs
-
-mkTcInstCos :: TcCoercion -> [TcType] -> TcCoercion
-mkTcInstCos (TcRefl ty) tys = TcRefl (applyTys ty tys)
-mkTcInstCos co tys = foldl TcInstCo co tys
-
-mkTcCoVarCo :: EqVar -> TcCoercion
--- ipv :: s ~ t (the boxed equality type)
-mkTcCoVarCo ipv
- | ty1 `eqType` ty2 = TcRefl ty1
- | otherwise = TcCoVarCo ipv
- where
- (ty1, ty2) = case getEqPredTys_maybe (varType ipv) of
- Nothing -> pprPanic "mkCoVarLCo" (ppr ipv)
- Just tys -> tys
-\end{code}
-
-\begin{code}
-tcCoercionKind :: TcCoercion -> Pair Type
-tcCoercionKind co = go co
- where
- go (TcRefl ty) = Pair ty ty
- go (TcLetCo _ co) = go co
- 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
- go (TcInstCo co ty) = go_inst co [ty]
- 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 (TcNthCo d co) = tyConAppArgN d <$> go co
-
- -- c.f. Coercion.coercionKind
- go_inst (TcInstCo co ty) tys = go_inst co (ty:tys)
- go_inst co tys = (`applyTys` tys) <$> go co
-
-eqVarKind :: EqVar -> Pair Type
-eqVarKind cv
- | Just (tc, [_kind,ty1,ty2]) <- tcSplitTyConApp_maybe (varType cv)
- = ASSERT (tc `hasKey` eqTyConKey)
- Pair ty1 ty2
- | otherwise = panic "eqVarKind, non coercion variable"
-
-coVarsOfTcCo :: TcCoercion -> VarSet
--- Only works on *zonked* coercions, because of TcLetCo
-coVarsOfTcCo tc_co
- = go tc_co
- where
- go (TcRefl _) = emptyVarSet
- go (TcTyConAppCo _ cos) = foldr (unionVarSet . go) emptyVarSet cos
- go (TcAppCo co1 co2) = go co1 `unionVarSet` go co2
- go (TcForAllCo _ co) = go co
- go (TcInstCo co _) = go co
- go (TcCoVarCo v) = unitVarSet v
- go (TcAxiomInstCo {}) = emptyVarSet
- go (TcSymCo co) = go co
- go (TcTransCo co1 co2) = go co1 `unionVarSet` go co2
- 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)
-
- -- We expect only coercion bindings
- go_bind :: EvBind -> VarSet
- go_bind (EvBind _ (EvCoercion co)) = go co
- go_bind (EvBind _ (EvId v)) = unitVarSet v
- go_bind other = pprPanic "coVarsOfTcCo:Bind" (ppr other)
-
- get_bndrs :: Bag EvBind -> VarSet
- get_bndrs = foldrBag (\ (EvBind b _) bs -> extendVarSet bs b) emptyVarSet
-
-liftTcCoSubstWith :: [TyVar] -> [TcCoercion] -> TcType -> TcCoercion
--- This version can ignore capture; the free varialbes of the
--- TcCoerion are all fresh. Result is mush simpler code
-liftTcCoSubstWith tvs cos ty
- = ASSERT( equalLength tvs cos )
- go ty
- where
- env = zipVarEnv tvs cos
-
- go ty@(TyVarTy tv) = case lookupVarEnv env tv of
- Just co -> co
- Nothing -> mkTcReflCo ty
- go (AppTy t1 t2) = mkTcAppCo (go t1) (go t2)
- go (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys)
+% +% (c) The University of Glasgow 2006 +% + +\begin{code} +module TcEvidence ( + + -- HsWrapper + HsWrapper(..), + (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpLams, mkWpLet, + idHsWrapper, isIdHsWrapper, pprHsWrapper, + + -- Evidence bindin + TcEvBinds(..), EvBindsVar(..), + EvBindMap(..), emptyEvBindMap, extendEvBinds, lookupEvBind, evBindMapBinds, + + EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, + + EvTerm(..), mkEvCast, evVarsOfTerm, mkEvKindCast, + + -- TcCoercion + TcCoercion(..), + mkTcReflCo, mkTcTyConAppCo, mkTcAppCo, mkTcAppCos, mkTcFunCo, + mkTcAxInstCo, mkTcForAllCo, mkTcForAllCos, + mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcInstCos, + tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo, + isTcReflCo, isTcReflCo_maybe, getTcCoVar_maybe, + liftTcCoSubstWith + + ) where +#include "HsVersions.h" + +import Var + +import PprCore () -- Instance OutputableBndr TyVar +import TypeRep -- Knows type representation +import TcType +import Type( tyConAppArgN, getEqPredTys_maybe, tyConAppTyCon_maybe ) +import TysPrim( funTyCon ) +import TyCon +import PrelNames +import VarEnv +import VarSet +import Name + +import Util +import Bag +import Pair +import Control.Applicative +import Data.Traversable (traverse, sequenceA) +import qualified Data.Data as Data +import Outputable +import FastString +import Data.IORef( IORef ) +\end{code} + + +Note [TcCoercions] +~~~~~~~~~~~~~~~~~~ +| LCoercions are a hack used by the typechecker. Normally, +Coercions have free variables of type (a ~# b): we call these +CoVars. However, the type checker passes around equality evidence +(boxed up) at type (a ~ b). + +An LCoercion is simply a Coercion whose free variables have the +boxed type (a ~ b). After we are done with typechecking the +desugarer finds the free variables, unboxes them, and creates a +resulting real Coercion with kosher free variables. + +We can use most of the Coercion "smart constructors" to build LCoercions. However, +mkCoVarCo will not work! The equivalent is mkTcCoVarCo. + +The data type is similar to Coercion.Coercion, with the following +differences + * Most important, TcLetCo adds let-bindings for coercions. + This is what lets us unify two for-all types and generate + equality constraints underneath + + * The kind of a TcCoercion is t1 ~ t2 + of a Coercion is t1 ~# t2 + + * TcAxiomInstCo takes Types, not Coecions as arguments; + the generality is required only in the Simplifier + + * UnsafeCo aren't required + + * Reprsentation invariants are weaker: + - we are allowed to have type synonyms in TcTyConAppCo + - the first arg of a TcAppCo can be a TcTyConAppCo + Reason: they'll get established when we desugar to Coercion + +\begin{code} +data TcCoercion + = TcRefl TcType + | TcTyConAppCo TyCon [TcCoercion] + | TcAppCo TcCoercion TcCoercion + | TcForAllCo TyVar TcCoercion + | TcInstCo TcCoercion TcType + | TcCoVarCo EqVar + | TcAxiomInstCo CoAxiom [TcType] + | TcSymCo TcCoercion + | TcTransCo TcCoercion TcCoercion + | TcNthCo Int TcCoercion + | TcLetCo TcEvBinds TcCoercion + deriving (Data.Data, Data.Typeable) + +isEqVar :: Var -> Bool +-- Is lifted coercion variable (only!) +isEqVar v = case tyConAppTyCon_maybe (varType v) of + Just tc -> tc `hasKey` eqTyConKey + Nothing -> False + +isTcReflCo_maybe :: TcCoercion -> Maybe TcType +isTcReflCo_maybe (TcRefl ty) = Just ty +isTcReflCo_maybe _ = Nothing + +isTcReflCo :: TcCoercion -> Bool +isTcReflCo (TcRefl {}) = True +isTcReflCo _ = False + +getTcCoVar_maybe :: TcCoercion -> Maybe CoVar +getTcCoVar_maybe (TcCoVarCo v) = Just v +getTcCoVar_maybe _ = Nothing + +mkTcReflCo :: TcType -> TcCoercion +mkTcReflCo = TcRefl + +mkTcFunCo :: TcCoercion -> TcCoercion -> TcCoercion +mkTcFunCo co1 co2 = mkTcTyConAppCo funTyCon [co1, co2] + +mkTcTyConAppCo :: TyCon -> [TcCoercion] -> TcCoercion +mkTcTyConAppCo tc cos -- No need to expand type synonyms + -- See Note [TcCoercions] + | Just tys <- traverse isTcReflCo_maybe cos + = TcRefl (mkTyConApp tc tys) -- See Note [Refl invariant] + + | otherwise = TcTyConAppCo tc cos + +mkTcAxInstCo :: CoAxiom -> [TcType] -> TcCoercion +mkTcAxInstCo ax tys + | arity == n_tys = TcAxiomInstCo ax tys + | otherwise = ASSERT( arity < n_tys ) + foldl TcAppCo (TcAxiomInstCo ax (take arity tys)) + (map TcRefl (drop arity tys)) + where + n_tys = length tys + arity = coAxiomArity ax + +mkTcAppCo :: TcCoercion -> TcCoercion -> TcCoercion +-- No need to deal with TyConApp on the left; see Note [TcCoercions] +mkTcAppCo (TcRefl ty1) (TcRefl ty2) = TcRefl (mkAppTy ty1 ty2) +mkTcAppCo co1 co2 = TcAppCo co1 co2 + +mkTcSymCo :: TcCoercion -> TcCoercion +mkTcSymCo co@(TcRefl {}) = co +mkTcSymCo (TcSymCo co) = co +mkTcSymCo co = TcSymCo co + +mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion +mkTcTransCo (TcRefl _) co = co +mkTcTransCo co (TcRefl _) = co +mkTcTransCo co1 co2 = TcTransCo co1 co2 + +mkTcNthCo :: Int -> TcCoercion -> TcCoercion +mkTcNthCo n (TcRefl ty) = TcRefl (tyConAppArgN n ty) +mkTcNthCo n co = TcNthCo n co + +mkTcAppCos :: TcCoercion -> [TcCoercion] -> TcCoercion +mkTcAppCos co1 tys = foldl mkTcAppCo co1 tys + +mkTcForAllCo :: Var -> TcCoercion -> TcCoercion +-- note that a TyVar should be used here, not a CoVar (nor a TcTyVar) +mkTcForAllCo tv (TcRefl ty) = ASSERT( isTyVar tv ) TcRefl (mkForAllTy tv ty) +mkTcForAllCo tv co = ASSERT( isTyVar tv ) TcForAllCo tv co + +mkTcForAllCos :: [Var] -> TcCoercion -> TcCoercion +mkTcForAllCos tvs (TcRefl ty) = ASSERT( all isTyVar tvs ) TcRefl (mkForAllTys tvs ty) +mkTcForAllCos tvs co = ASSERT( all isTyVar tvs ) foldr TcForAllCo co tvs + +mkTcInstCos :: TcCoercion -> [TcType] -> TcCoercion +mkTcInstCos (TcRefl ty) tys = TcRefl (applyTys ty tys) +mkTcInstCos co tys = foldl TcInstCo co tys + +mkTcCoVarCo :: EqVar -> TcCoercion +-- ipv :: s ~ t (the boxed equality type) +mkTcCoVarCo ipv + | ty1 `eqType` ty2 = TcRefl ty1 + | otherwise = TcCoVarCo ipv + where + (ty1, ty2) = case getEqPredTys_maybe (varType ipv) of + Nothing -> pprPanic "mkCoVarLCo" (ppr ipv) + Just tys -> tys +\end{code} + +\begin{code} +tcCoercionKind :: TcCoercion -> Pair Type +tcCoercionKind co = go co + where + go (TcRefl ty) = Pair ty ty + go (TcLetCo _ co) = go co + 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 + go (TcInstCo co ty) = go_inst co [ty] + 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 (TcNthCo d co) = tyConAppArgN d <$> go co + + -- c.f. Coercion.coercionKind + go_inst (TcInstCo co ty) tys = go_inst co (ty:tys) + go_inst co tys = (`applyTys` tys) <$> go co + +eqVarKind :: EqVar -> Pair Type +eqVarKind cv + | Just (tc, [_kind,ty1,ty2]) <- tcSplitTyConApp_maybe (varType cv) + = ASSERT (tc `hasKey` eqTyConKey) + Pair ty1 ty2 + | otherwise = panic "eqVarKind, non coercion variable" + +coVarsOfTcCo :: TcCoercion -> VarSet +-- Only works on *zonked* coercions, because of TcLetCo +coVarsOfTcCo tc_co + = go tc_co + where + go (TcRefl _) = emptyVarSet + go (TcTyConAppCo _ cos) = foldr (unionVarSet . go) emptyVarSet cos + go (TcAppCo co1 co2) = go co1 `unionVarSet` go co2 + go (TcForAllCo _ co) = go co + go (TcInstCo co _) = go co + go (TcCoVarCo v) = unitVarSet v + go (TcAxiomInstCo {}) = emptyVarSet + go (TcSymCo co) = go co + go (TcTransCo co1 co2) = go co1 `unionVarSet` go co2 + 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) + + -- We expect only coercion bindings + go_bind :: EvBind -> VarSet + go_bind (EvBind _ (EvCoercion co)) = go co + go_bind (EvBind _ (EvId v)) = unitVarSet v + go_bind other = pprPanic "coVarsOfTcCo:Bind" (ppr other) + + get_bndrs :: Bag EvBind -> VarSet + get_bndrs = foldrBag (\ (EvBind b _) bs -> extendVarSet bs b) emptyVarSet + +liftTcCoSubstWith :: [TyVar] -> [TcCoercion] -> TcType -> TcCoercion +-- This version can ignore capture; the free varialbes of the +-- TcCoerion are all fresh. Result is mush simpler code +liftTcCoSubstWith tvs cos ty + = ASSERT( equalLength tvs cos ) + go ty + where + env = zipVarEnv tvs cos + + go ty@(TyVarTy tv) = case lookupVarEnv env tv of + Just co -> co + 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}
-
-Pretty printing
-
-\begin{code}
-instance Outputable TcCoercion where
- ppr = pprTcCo
-
-pprTcCo, pprParendTcCo :: TcCoercion -> SDoc
-pprTcCo co = ppr_co TopPrec co
-pprParendTcCo co = ppr_co TyConPrec co
-
-ppr_co :: Prec -> TcCoercion -> SDoc
-ppr_co _ (TcRefl ty) = angleBrackets (ppr ty)
-
-ppr_co p co@(TcTyConAppCo tc [_,_])
- | tc `hasKey` funTyConKey = ppr_fun_co p co
-
-ppr_co p (TcTyConAppCo tc cos) = pprTcApp p ppr_co tc cos
-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 co@(TcForAllCo {}) = ppr_forall_co p co
-ppr_co p (TcInstCo co ty) = maybeParen p TyConPrec $
- pprParendTcCo co <> ptext (sLit "@") <> pprType ty
-
-ppr_co _ (TcCoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv)
-ppr_co p (TcAxiomInstCo con cos) = pprTypeNameApp p ppr_type (getName con) cos
-
-ppr_co p (TcTransCo co1 co2) = maybeParen p FunPrec $
- ppr_co FunPrec co1
- <+> ptext (sLit ";")
- <+> ppr_co FunPrec co2
-ppr_co p (TcSymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendTcCo co]
-ppr_co p (TcNthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendTcCo co]
-
-ppr_fun_co :: Prec -> TcCoercion -> SDoc
-ppr_fun_co p co = pprArrowChain p (split co)
- where
- split :: TcCoercion -> [SDoc]
- split (TcTyConAppCo f [arg,res])
- | f `hasKey` funTyConKey
- = ppr_co FunPrec arg : split res
- split co = [ppr_co TopPrec co]
-
-ppr_forall_co :: Prec -> TcCoercion -> SDoc
-ppr_forall_co p ty
- = maybeParen p FunPrec $
- sep [pprForAll tvs, ppr_co TopPrec rho]
- where
- (tvs, rho) = split1 [] ty
- split1 tvs (TcForAllCo tv ty) = split1 (tv:tvs) ty
- split1 tvs ty = (reverse tvs, ty)
-\end{code}
-
-%************************************************************************
-%* *
- HsWrapper
-%* *
-%************************************************************************
-
-\begin{code}
-data HsWrapper
- = WpHole -- The identity coercion
-
- | WpCompose HsWrapper HsWrapper
- -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]]
- --
- -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. [])
- -- But ([] a) `WpCompose` ([] b) = ([] b a)
-
- | WpCast TcCoercion -- A cast: [] `cast` co
- -- Guaranteed not the identity coercion
-
- -- Evidence abstraction and application
- -- (both dictionaries and coercions)
- | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable
- | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint
-
- -- Kind and Type abstraction and application
- | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var)
- | WpTyApp KindOrType -- [] t the 't' is a type (not coercion)
-
-
- | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings,
- -- so that the identity coercion is always exactly WpHole
- deriving (Data.Data, Data.Typeable)
-
-
-(<.>) :: HsWrapper -> HsWrapper -> HsWrapper
-WpHole <.> c = c
-c <.> WpHole = c
-c1 <.> c2 = c1 `WpCompose` c2
-
-mkWpTyApps :: [Type] -> HsWrapper
-mkWpTyApps tys = mk_co_app_fn WpTyApp tys
-
-mkWpEvApps :: [EvTerm] -> HsWrapper
-mkWpEvApps args = mk_co_app_fn WpEvApp args
-
-mkWpEvVarApps :: [EvVar] -> HsWrapper
-mkWpEvVarApps vs = mkWpEvApps (map EvId vs)
-
-mkWpTyLams :: [TyVar] -> HsWrapper
-mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
-
-mkWpLams :: [Var] -> HsWrapper
-mkWpLams ids = mk_co_lam_fn WpEvLam ids
-
-mkWpLet :: TcEvBinds -> HsWrapper
--- This no-op is a quite a common case
-mkWpLet (EvBinds b) | isEmptyBag b = WpHole
-mkWpLet ev_binds = WpLet ev_binds
-
-mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
-mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as
-
-mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
--- For applications, the *first* argument must
--- come *last* in the composition sequence
-mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as
-
-idHsWrapper :: HsWrapper
-idHsWrapper = WpHole
-
-isIdHsWrapper :: HsWrapper -> Bool
-isIdHsWrapper WpHole = True
-isIdHsWrapper _ = False
-\end{code}
-
-
-%************************************************************************
-%* *
- Evidence bindings
-%* *
-%************************************************************************
-
-\begin{code}
-data TcEvBinds
- = TcEvBinds -- Mutable evidence bindings
- EvBindsVar -- Mutable because they are updated "later"
- -- when an implication constraint is solved
-
- | EvBinds -- Immutable after zonking
- (Bag EvBind)
-
- deriving( Data.Typeable )
-
-data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
- -- The Unique is only for debug printing
-
-instance Data.Data TcEvBinds where
- -- Placeholder; we can't travers into TcEvBinds
- toConstr _ = abstractConstr "TcEvBinds"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = Data.mkNoRepType "TcEvBinds"
-
------------------
-newtype EvBindMap
- = EvBindMap {
- ev_bind_varenv :: VarEnv EvBind
- } -- Map from evidence variables to evidence terms
-
-emptyEvBindMap :: EvBindMap
-emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv }
-
-extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
-extendEvBinds bs v t
- = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) v (EvBind v t) }
-
-lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
-lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs)
-
-evBindMapBinds :: EvBindMap -> Bag EvBind
-evBindMapBinds bs
- = foldVarEnv consBag emptyBag (ev_bind_varenv bs)
-
------------------
--- All evidence is bound by EvBinds; no side effects
-data EvBind = EvBind EvVar EvTerm
-
-data EvTerm
- = EvId EvId -- Term-level variable-to-variable bindings
- -- (no coercion variables! they come via EvCoercion)
-
- | EvCoercion TcCoercion -- (Boxed) coercion bindings
-
- | EvCast EvVar TcCoercion -- d |> co
-
- | EvDFunApp DFunId -- Dictionary instance application
- [Type] [EvVar]
-
- | EvTupleSel EvId Int -- n'th component of the tuple
-
- | EvTupleMk [EvId] -- 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
- -- dictionaries, even though the former have no
- -- selector Id. We count up from _0_
- | EvKindCast EvVar TcCoercion -- See Note [EvKindCast]
+ go (ForAllTy tv ty) = mkTcForAllCo tv (go ty) + go (FunTy t1 t2) = mkTcFunCo (go t1) (go t2) +\end{code} + +Pretty printing + +\begin{code} +instance Outputable TcCoercion where + ppr = pprTcCo + +pprTcCo, pprParendTcCo :: TcCoercion -> SDoc +pprTcCo co = ppr_co TopPrec co +pprParendTcCo co = ppr_co TyConPrec co + +ppr_co :: Prec -> TcCoercion -> SDoc +ppr_co _ (TcRefl ty) = angleBrackets (ppr ty) + +ppr_co p co@(TcTyConAppCo tc [_,_]) + | tc `hasKey` funTyConKey = ppr_fun_co p co + +ppr_co p (TcTyConAppCo tc cos) = pprTcApp p ppr_co tc cos +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 co@(TcForAllCo {}) = ppr_forall_co p co +ppr_co p (TcInstCo co ty) = maybeParen p TyConPrec $ + pprParendTcCo co <> ptext (sLit "@") <> pprType ty + +ppr_co _ (TcCoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) +ppr_co p (TcAxiomInstCo con cos) = pprTypeNameApp p ppr_type (getName con) cos + +ppr_co p (TcTransCo co1 co2) = maybeParen p FunPrec $ + ppr_co FunPrec co1 + <+> ptext (sLit ";") + <+> ppr_co FunPrec co2 +ppr_co p (TcSymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendTcCo co] +ppr_co p (TcNthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendTcCo co] + +ppr_fun_co :: Prec -> TcCoercion -> SDoc +ppr_fun_co p co = pprArrowChain p (split co) + where + split :: TcCoercion -> [SDoc] + split (TcTyConAppCo f [arg,res]) + | f `hasKey` funTyConKey + = ppr_co FunPrec arg : split res + split co = [ppr_co TopPrec co] + +ppr_forall_co :: Prec -> TcCoercion -> SDoc +ppr_forall_co p ty + = maybeParen p FunPrec $ + sep [pprForAll tvs, ppr_co TopPrec rho] + where + (tvs, rho) = split1 [] ty + split1 tvs (TcForAllCo tv ty) = split1 (tv:tvs) ty + split1 tvs ty = (reverse tvs, ty) +\end{code} + +%************************************************************************ +%* * + HsWrapper +%* * +%************************************************************************ + +\begin{code} +data HsWrapper + = WpHole -- The identity coercion + + | WpCompose HsWrapper HsWrapper + -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] + -- + -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) + -- But ([] a) `WpCompose` ([] b) = ([] b a) + + | WpCast TcCoercion -- A cast: [] `cast` co + -- Guaranteed not the identity coercion + + -- Evidence abstraction and application + -- (both dictionaries and coercions) + | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable + | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint + + -- Kind and Type abstraction and application + | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) + | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) + + + | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, + -- so that the identity coercion is always exactly WpHole + deriving (Data.Data, Data.Typeable) + + +(<.>) :: HsWrapper -> HsWrapper -> HsWrapper +WpHole <.> c = c +c <.> WpHole = c +c1 <.> c2 = c1 `WpCompose` c2 + +mkWpTyApps :: [Type] -> HsWrapper +mkWpTyApps tys = mk_co_app_fn WpTyApp tys + +mkWpEvApps :: [EvTerm] -> HsWrapper +mkWpEvApps args = mk_co_app_fn WpEvApp args + +mkWpEvVarApps :: [EvVar] -> HsWrapper +mkWpEvVarApps vs = mkWpEvApps (map EvId vs) + +mkWpTyLams :: [TyVar] -> HsWrapper +mkWpTyLams ids = mk_co_lam_fn WpTyLam ids + +mkWpLams :: [Var] -> HsWrapper +mkWpLams ids = mk_co_lam_fn WpEvLam ids + +mkWpLet :: TcEvBinds -> HsWrapper +-- This no-op is a quite a common case +mkWpLet (EvBinds b) | isEmptyBag b = WpHole +mkWpLet ev_binds = WpLet ev_binds + +mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as + +mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +-- For applications, the *first* argument must +-- come *last* in the composition sequence +mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as + +idHsWrapper :: HsWrapper +idHsWrapper = WpHole + +isIdHsWrapper :: HsWrapper -> Bool +isIdHsWrapper WpHole = True +isIdHsWrapper _ = False +\end{code} + + +%************************************************************************ +%* * + Evidence bindings +%* * +%************************************************************************ + +\begin{code} +data TcEvBinds + = TcEvBinds -- Mutable evidence bindings + EvBindsVar -- Mutable because they are updated "later" + -- when an implication constraint is solved + + | EvBinds -- Immutable after zonking + (Bag EvBind) + + deriving( Data.Typeable ) + +data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique + -- The Unique is only for debug printing + +instance Data.Data TcEvBinds where + -- Placeholder; we can't travers into TcEvBinds + toConstr _ = abstractConstr "TcEvBinds" + gunfold _ _ = error "gunfold" + dataTypeOf _ = Data.mkNoRepType "TcEvBinds" + +----------------- +newtype EvBindMap + = EvBindMap { + ev_bind_varenv :: VarEnv EvBind + } -- Map from evidence variables to evidence terms + +emptyEvBindMap :: EvBindMap +emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv } + +extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap +extendEvBinds bs v t + = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) v (EvBind v t) } + +lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind +lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs) + +evBindMapBinds :: EvBindMap -> Bag EvBind +evBindMapBinds bs + = foldVarEnv consBag emptyBag (ev_bind_varenv bs) + +----------------- +-- All evidence is bound by EvBinds; no side effects +data EvBind = EvBind EvVar EvTerm + +data EvTerm + = EvId EvId -- Term-level variable-to-variable bindings + -- (no coercion variables! they come via EvCoercion) + + | EvCoercion TcCoercion -- (Boxed) coercion bindings + + | EvCast EvVar TcCoercion -- d |> co + + | EvDFunApp DFunId -- Dictionary instance application + [Type] [EvVar] + + | EvTupleSel EvId Int -- n'th component of the tuple + + | EvTupleMk [EvId] -- 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 + -- dictionaries, even though the former have no + -- selector Id. We count up from _0_ + | EvKindCast EvVar TcCoercion -- See Note [EvKindCast] | EvInteger Integer -- The dictionary for class "NatI"
-- Note [EvInteger]
-
- deriving( Data.Data, Data.Typeable)
-\end{code}
-
-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
-always turn out to be ReflCo, so why is this needed? Because sometimes
-we will want to defer kind errors until the runtime and in these cases
-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.
-
-
-Note [EvBinds/EvTerm]
-~~~~~~~~~~~~~~~~~~~~~
-How evidence is created and updated. Bindings for dictionaries,
-and coercions and implicit parameters are carried around in TcEvBinds
-which during constraint generation and simplification is always of the
-form (TcEvBinds ref). After constraint simplification is finished it
-will be transformed to t an (EvBinds ev_bag).
-
-Evidence for coercions *SHOULD* be filled in using the TcEvBinds
-However, all EvVars that correspond to *wanted* coercion terms in
-an EvBind must be mutable variables so that they can be readily
-inlined (by zonking) after constraint simplification is finished.
-
-Conclusion: a new wanted coercion variable should be made mutable.
-[Notice though that evidence variables that bind coercion terms
- from super classes will be "given" and hence rigid]
-
-
+ + deriving( Data.Data, Data.Typeable) +\end{code} + +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 +always turn out to be ReflCo, so why is this needed? Because sometimes +we will want to defer kind errors until the runtime and in these cases +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. + + +Note [EvBinds/EvTerm] +~~~~~~~~~~~~~~~~~~~~~ +How evidence is created and updated. Bindings for dictionaries, +and coercions and implicit parameters are carried around in TcEvBinds +which during constraint generation and simplification is always of the +form (TcEvBinds ref). After constraint simplification is finished it +will be transformed to t an (EvBinds ev_bag). + +Evidence for coercions *SHOULD* be filled in using the TcEvBinds +However, all EvVars that correspond to *wanted* coercion terms in +an EvBind must be mutable variables so that they can be readily +inlined (by zonking) after constraint simplification is finished. + +Conclusion: a new wanted coercion variable should be made mutable. +[Notice though that evidence variables that bind coercion terms + from super classes will be "given" and hence rigid] + + Note [EvInteger]
~~~~~~~~~~~~~~~~
A part of the type-level naturals implementation is the class "NatI",
@@ -542,97 +542,97 @@ one to make it into a "NatS" value, and another to make it into "NatI" evidence. -\begin{code}
-mkEvCast :: EvVar -> TcCoercion -> EvTerm
-mkEvCast ev lco
- | isTcReflCo lco = EvId ev
- | otherwise = EvCast ev lco
-
-mkEvKindCast :: EvVar -> TcCoercion -> EvTerm
-mkEvKindCast ev lco
- | isTcReflCo lco = EvId ev
- | otherwise = EvKindCast ev lco
-
-emptyTcEvBinds :: TcEvBinds
-emptyTcEvBinds = EvBinds emptyBag
-
-isEmptyTcEvBinds :: TcEvBinds -> Bool
-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)
+\begin{code} +mkEvCast :: EvVar -> TcCoercion -> EvTerm +mkEvCast ev lco + | isTcReflCo lco = EvId ev + | otherwise = EvCast ev lco + +mkEvKindCast :: EvVar -> TcCoercion -> EvTerm +mkEvKindCast ev lco + | isTcReflCo lco = EvId ev + | otherwise = EvKindCast ev lco + +emptyTcEvBinds :: TcEvBinds +emptyTcEvBinds = EvBinds emptyBag + +isEmptyTcEvBinds :: TcEvBinds -> Bool +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) evVarsOfTerm (EvInteger _) = []
-\end{code}
-
-
-%************************************************************************
-%* *
- Pretty printing
-%* *
-%************************************************************************
-
-\begin{code}
-instance Outputable HsWrapper where
- ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
-
-pprHsWrapper :: SDoc -> HsWrapper -> SDoc
--- In debug mode, print the wrapper
--- otherwise just print what's inside
-pprHsWrapper doc wrap
- = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc)
- where
- help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc
- -- True <=> appears in function application position
- -- False <=> appears as body of let or lambda
- help it WpHole = it
- help it (WpCompose f1 f2) = help (help it f2) f1
- help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
- <+> pprParendTcCo co)]
- help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)]
- help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
- help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
- help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False]
- help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False]
-
- pp_bndr v = pprBndr LambdaBind v <> dot
-
- add_parens, no_parens :: SDoc -> Bool -> SDoc
- add_parens d True = parens d
- add_parens d False = d
- no_parens d _ = d
-
-instance Outputable TcEvBinds where
- ppr (TcEvBinds v) = ppr v
- ppr (EvBinds bs) = ptext (sLit "EvBinds") <> braces (vcat (map ppr (bagToList bs)))
-
-instance Outputable EvBindsVar where
- ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)
-
-instance Outputable EvBind where
- ppr (EvBind v e) = sep [ ppr v, nest 2 $ equals <+> ppr e ]
- -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing
-
-instance Outputable EvTerm where
- ppr (EvId v) = ppr v
- ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co
- ppr (EvKindCast v co) = ppr v <+> (ptext (sLit "`kind-cast`")) <+> pprParendTcCo co
- ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
- ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n))
- 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 (EvInteger n) = integer n
- ppr (EvDelayedError ty msg) = ptext (sLit "error")
- <+> sep [ char '@' <> ppr ty, ppr msg ]
-\end{code}
-
+\end{code} + + +%************************************************************************ +%* * + Pretty printing +%* * +%************************************************************************ + +\begin{code} +instance Outputable HsWrapper where + ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn + +pprHsWrapper :: SDoc -> HsWrapper -> SDoc +-- In debug mode, print the wrapper +-- otherwise just print what's inside +pprHsWrapper doc wrap + = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc) + where + help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc + -- True <=> appears in function application position + -- False <=> appears as body of let or lambda + help it WpHole = it + help it (WpCompose f1 f2) = help (help it f2) f1 + help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") + <+> pprParendTcCo co)] + help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] + help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty] + help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False] + help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False] + help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False] + + pp_bndr v = pprBndr LambdaBind v <> dot + + add_parens, no_parens :: SDoc -> Bool -> SDoc + add_parens d True = parens d + add_parens d False = d + no_parens d _ = d + +instance Outputable TcEvBinds where + ppr (TcEvBinds v) = ppr v + ppr (EvBinds bs) = ptext (sLit "EvBinds") <> braces (vcat (map ppr (bagToList bs))) + +instance Outputable EvBindsVar where + ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u) + +instance Outputable EvBind where + ppr (EvBind v e) = sep [ ppr v, nest 2 $ equals <+> ppr e ] + -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing + +instance Outputable EvTerm where + ppr (EvId v) = ppr v + ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co + ppr (EvKindCast v co) = ppr v <+> (ptext (sLit "`kind-cast`")) <+> pprParendTcCo co + ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co + ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n)) + 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 (EvInteger n) = integer n + ppr (EvDelayedError ty msg) = ptext (sLit "error") + <+> sep [ char '@' <> ppr ty, ppr msg ] +\end{code} + diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index a3b33bca60..abcff85d7d 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -325,7 +325,7 @@ tcExpr (SectionR op arg2) res_ty tcExpr (SectionL arg1 op) res_ty = do { (op', op_ty) <- tcInferFun op - ; dflags <- getDOpts -- Note [Left sections] + ; dflags <- getDynFlags -- Note [Left sections] ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1 | otherwise = 2 diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index bf3bcbebe8..10de6acea5 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -246,14 +246,14 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar check False (illegalForeignTyErr empty sig_ty) return idecl (arg1_ty:arg_tys) -> do - dflags <- getDOpts + dflags <- getDynFlags check (isFFIDynArgumentTy arg1_ty) (illegalForeignTyErr argument arg1_ty) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty return idecl | cconv == PrimCallConv = do - dflags <- getDOpts + dflags <- getDynFlags check (xopt Opt_GHCForeignImportPrim dflags) (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.") checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) @@ -268,7 +268,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar checkCg checkCOrAsmOrLlvmOrDotNetOrInterp checkCConv cconv checkCTarget target - dflags <- getDOpts + dflags <- getDynFlags checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty checkMissingAmpersand dflags arg_tys res_ty @@ -383,7 +383,7 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty -- Case for non-IO result type with FFI Import _ -> do - dflags <- getDOpts + dflags <- getDynFlags case (pred_res_ty ty && non_io_result_ok) of -- handle normal typecheck fail, we want to handle this first and -- only report safe haskell errors if the normal type check is OK. @@ -440,7 +440,7 @@ checkCOrAsmOrLlvmOrDotNetOrInterp _ checkCg :: (HscTarget -> Maybe SDoc) -> TcM () checkCg check = do - dflags <- getDOpts + dflags <- getDynFlags let target = hscTarget dflags case target of HscNothing -> return () @@ -456,7 +456,7 @@ Calling conventions checkCConv :: CCallConv -> TcM () checkCConv CCallConv = return () checkCConv CApiConv = return () -checkCConv StdCallConv = do dflags <- getDOpts +checkCConv StdCallConv = do dflags <- getDynFlags let platform = targetPlatform dflags unless (platformArch platform == ArchX86) $ -- This is a warning, not an error. see #3336 diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 8bef05968f..1fbb7df856 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -117,7 +117,7 @@ genGenericRepExtras tc mod = genDtMeta :: (TyCon, MetaTyCons) -> TcM BagDerivStuff genDtMeta (tc,metaDts) = do loc <- getSrcSpanM - dflags <- getDOpts + dflags <- getDynFlags dClas <- tcLookupClass datatypeClassName let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc d_dfun_name <- new_dfun_name dClas tc diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 6efc1028e2..6221bcd270 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -68,7 +68,7 @@ import NameSet import TysWiredIn import BasicTypes import SrcLoc -import DynFlags ( ExtensionFlag( Opt_PolyKinds ) ) +import DynFlags ( ExtensionFlag( Opt_DataKinds ) ) import Util import UniqSupply import Outputable @@ -1349,8 +1349,8 @@ sc_ds_var_app name arg_kis = do case mb_thing of Just (AGlobal (ATyCon tc)) | isAlgTyCon tc || isTupleTyCon tc -> do - poly_kinds <- xoptM Opt_PolyKinds - unless poly_kinds $ addErr (polyKindsErr name) + data_kinds <- xoptM Opt_DataKinds + unless data_kinds $ addErr (polyKindsErr name) let tc_kind = tyConKind tc case isPromotableKind tc_kind of Just n | n == length arg_kis -> diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index ac9769ca25..8351b7b52d 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -399,7 +399,7 @@ tcInstDecls1 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 -- performed. Derived instances are OK. - ; dflags <- getDOpts + ; dflags <- getDynFlags ; when (safeLanguageOn dflags) $ mapM_ (\x -> when (typInstCheck x) (addErrAt (getSrcSpan $ iSpec x) typInstErr)) @@ -716,7 +716,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] - ; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds + ; spec_inst_info <- tcSpecInstPrags dfun_id ibinds -- Typecheck the methods ; (meth_ids, meth_binds) @@ -725,7 +725,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Those tyvars are inside the dfun_id's type, which is a bit -- bizarre, but OK so long as you realise it! tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars - inst_tys spec_info + inst_tys spec_inst_info op_items ibinds -- Create the result bindings @@ -776,7 +776,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) map Var meth_ids export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun - , abe_mono = self_dict, abe_prags = SpecPrags spec_inst_prags } + , abe_mono = self_dict, abe_prags = noSpecPrags } + -- NB: noSpecPrags, see Note [SPECIALISE instance pragmas] main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] @@ -895,16 +896,12 @@ Consider range (x,y) = ... We do *not* want to make a specialised version of the dictionary -function. Rather, we want specialised versions of each method. +function. Rather, we want specialised versions of each *method*. Thus we should generate something like this: - $dfIx :: (Ix a, Ix x) => Ix (a,b) - {- DFUN [$crange, ...] -} - $dfIx da db = Ix ($crange da db) (...other methods...) - - $dfIxPair :: (Ix a, Ix x) => Ix (a,b) + $dfIxPair :: (Ix a, Ix b) => Ix (a,b) {- DFUN [$crangePair, ...] -} - $dfIxPair = Ix ($crangePair da db) (...other methods...) + $dfIxPair da db = Ix ($crangePair da db) (...other methods...) $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} @@ -1067,14 +1064,22 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags -- Adapt the SPECIALISE pragmas to work for this method Id -- There are two sources: - -- * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-} - -- These ones have the dfun inside, but [perhaps surprisingly] - -- the correct wrapper -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-} + -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-} + -- These ones have the dfun inside, but [perhaps surprisingly] + -- the correct wrapper. mk_meth_spec_prags meth_id spec_prags_for_me - = SpecPrags (spec_prags_for_me ++ - [ L loc (SpecPrag meth_id wrap inl) - | L loc (SpecPrag _ wrap inl) <- spec_inst_prags]) + = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) + where + spec_prags_from_inst + | isInlinePragma (idInlinePragma meth_id) + = [] -- Do not inherit SPECIALISE from the instance if the + -- method is marked INLINE, because then it'll be inlined + -- and the specialisation would do nothing. (Indeed it'll provoke + -- a warning from the desugarer + | otherwise + = [ L loc (SpecPrag meth_id wrap inl) + | L loc (SpecPrag _ wrap inl) <- spec_inst_prags] loc = getSrcSpan dfun_id sig_fn = mkSigFun sigs diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 3cc95a09f2..8e63ecf53b 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -99,35 +99,44 @@ solveInteractCts cts ; setTcSEvVarCacheMap new_evvar_cache ; updWorkListTcS (appendWorkListCt cts_thinner) >> solveInteract } - where add_cts_in_cache evvar_cache = foldM solve_or_cache ([],evvar_cache) - solve_or_cache :: ([Ct],TypeMap (EvVar,CtFlavor)) - -> Ct - -> TcS ([Ct],TypeMap (EvVar,CtFlavor)) - solve_or_cache (acc_cts,acc_cache) ct - | dont_cache (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 :: 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 - dont_cache _ = False + 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 () solveInteractGiven gloc evs diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index e131c3d1a2..48ad6e379d 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -1184,7 +1184,7 @@ check_valid_theta :: UserTypeCtxt -> [PredType] -> TcM () check_valid_theta _ [] = return () check_valid_theta ctxt theta = do - dflags <- getDOpts + dflags <- getDynFlags warnTc (notNull dups) (dupPredWarn dups) mapM_ (check_pred_ty dflags ctxt) theta where @@ -1491,7 +1491,7 @@ We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () checkValidInstHead ctxt clas tys - = do { dflags <- getDOpts + = do { dflags <- getDynFlags -- Check language restrictions; -- but not for SPECIALISE isntance pragmas diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 333c2d0984..acdc8389be 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -804,7 +804,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys - tup_ty = mkBoxedTupleTy tup_elt_tys + tup_ty = mkBigCoreTupTy tup_elt_tys ; tcExtendIdEnv tup_ids $ do { stmts_ty <- newFlexiTyVarTy liftedTypeKind diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 4e46de90d9..908588b8f6 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -983,7 +983,7 @@ checkMain :: TcM TcGblEnv -- If we are in module Main, check that 'main' is defined. checkMain = do { tcg_env <- getGblEnv ; - dflags <- getDOpts ; + dflags <- getDynFlags ; check_main dflags tcg_env } @@ -1065,7 +1065,7 @@ getMainFun dflags = case (mainFunIs dflags) of checkMainExported :: TcGblEnv -> TcM () checkMainExported tcg_env = do - dflags <- getDOpts + dflags <- getDynFlags case tcg_main tcg_env of Nothing -> return () -- not the main module Just main_name -> do @@ -1677,7 +1677,7 @@ rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) } tcDump :: TcGblEnv -> TcRn () tcDump env - = do { dflags <- getDOpts ; + = do { dflags <- getDynFlags ; -- Dump short output if -ddump-types or -ddump-tc when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) @@ -1694,7 +1694,7 @@ tcDump env tcCoreDump :: ModGuts -> TcM () tcCoreDump mod_guts - = do { dflags <- getDOpts ; + = do { dflags <- getDynFlags ; when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) (dumpTcRn (pprModGuts mod_guts)) ; diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 2c6461fef9..351a3e25d0 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -254,17 +254,14 @@ setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = Command-line flags \begin{code} -getDOpts :: TcRnIf gbl lcl DynFlags -getDOpts = do { env <- getTopEnv; return (hsc_dflags env) } - xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool -xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) } +xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } doptM :: DynFlag -> TcRnIf gbl lcl Bool -doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } +doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } woptM :: WarningFlag -> TcRnIf gbl lcl Bool -woptM flag = do { dflags <- getDOpts; return (wopt flag dflags) } +woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } setXOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setXOptM flag = updEnv (\ env@(Env { env_top = top }) -> @@ -457,7 +454,7 @@ traceOptTcRn flag doc = ifDOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv - ; dflags <- getDOpts + ; dflags <- getDynFlags ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } debugDumpTcRn :: SDoc -> TcRn () @@ -626,7 +623,7 @@ mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg mkLongErrAt loc msg extra = do { traceTc "Adding error:" (mkLocMessage SevError loc (msg $$ extra)) ; rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; + dflags <- getDynFlags ; return $ mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () @@ -649,7 +646,7 @@ reportWarning warn dumpDerivingInfo :: SDoc -> TcM () dumpDerivingInfo doc - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; when (dopt Opt_D_dump_deriv dflags) $ do { rdr_env <- getGlobalRdrEnv ; let unqual = mkPrintUnqualified dflags rdr_env @@ -719,7 +716,7 @@ tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a) -- there might be warnings tryTcErrs thing = do { (msgs, res) <- tryTc thing - ; dflags <- getDOpts + ; dflags <- getDynFlags ; let errs_found = errorsFound dflags msgs ; return (msgs, case res of Nothing -> Nothing @@ -775,7 +772,7 @@ ifErrsM :: TcRn r -> TcRn r -> TcRn r ifErrsM bale_out normal = do { errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; - dflags <- getDOpts ; + dflags <- getDynFlags ; if errorsFound dflags msgs then bale_out else @@ -908,7 +905,7 @@ add_warn msg extra_info add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () add_warn_at loc msg extra_info = do { rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; + dflags <- getDynFlags ; let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg extra_info } ; reportWarning warn } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 015510fb3f..8ff3ce3f76 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -116,6 +116,7 @@ import UniqSupply import Unique import BasicTypes import Bag +import DynFlags import Outputable import ListSetOps import FastString @@ -187,6 +188,9 @@ data Env gbl lcl env_lcl :: lcl -- Nested stuff; changes as we go into } +instance ContainsDynFlags (Env gbl lcl) where + extractDynFlags env = hsc_dflags (env_top env) + -- TcGblEnv describes the top-level of the module at the -- point at which the typechecker is finished work. -- It is this structure that is handed on to the desugarer diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 240ba9c017..660007d7c5 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -923,7 +923,7 @@ emitFrozenError fl ev depth ; wrapTcS (TcM.writeTcRef inert_ref inerts_new) } instance HasDynFlags TcS where - getDynFlags = wrapTcS TcM.getDOpts + getDynFlags = wrapTcS getDynFlags getTcSContext :: TcS SimplContext getTcSContext = TcS (return . tcs_context) diff --git a/compiler/typecheck/TcSimplify.lhs-old b/compiler/typecheck/TcSimplify.lhs-old deleted file mode 100644 index 274c14d70b..0000000000 --- a/compiler/typecheck/TcSimplify.lhs-old +++ /dev/null @@ -1,3297 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -TcSimplify - -\begin{code} -module TcSimplify ( - tcSimplifyInfer, tcSimplifyInferCheck, - tcSimplifyCheck, tcSimplifyRestricted, - tcSimplifyRuleLhs, tcSimplifyIPs, - tcSimplifySuperClasses, - tcSimplifyTop, tcSimplifyInteractive, - tcSimplifyBracket, tcSimplifyCheckPat, - - tcSimplifyDeriv, tcSimplifyDefault, - bindInstsOfLocalFuns, - - misMatchMsg - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TcUnify( unifyType ) -import HsSyn - -import TcRnMonad -import TcHsSyn ( hsLPatType ) -import Inst -import TcEnv -import InstEnv -import TcType -import TcMType -import TcIface -import TcTyFuns -import DsUtils -- Big-tuple functions -import Var -import Id -import Name -import NameSet -import Class -import FunDeps -import PrelInfo -import PrelNames -import TysWiredIn -import ErrUtils -import BasicTypes -import VarSet -import VarEnv -import FiniteMap -import Bag -import Outputable -import ListSetOps -import Util -import SrcLoc -import DynFlags -import FastString - -import Control.Monad -import Data.List -\end{code} - - -%************************************************************************ -%* * -\subsection{NOTES} -%* * -%************************************************************************ - - -------------------------------------- - Notes on functional dependencies (a bug) - -------------------------------------- - -Consider this: - - class C a b | a -> b - class D a b | a -> b - - instance D a b => C a b -- Undecidable - -- (Not sure if it's crucial to this eg) - f :: C a b => a -> Bool - f _ = True - - g :: C a b => a -> Bool - g = f - -Here f typechecks, but g does not!! Reason: before doing improvement, -we reduce the (C a b1) constraint from the call of f to (D a b1). - -Here is a more complicated example: - -@ - > class Foo a b | a->b - > - > class Bar a b | a->b - > - > data Obj = Obj - > - > instance Bar Obj Obj - > - > instance (Bar a b) => Foo a b - > - > foo:: (Foo a b) => a -> String - > foo _ = "works" - > - > runFoo:: (forall a b. (Foo a b) => a -> w) -> w - > runFoo f = f Obj - - *Test> runFoo foo - - <interactive>:1: - Could not deduce (Bar a b) from the context (Foo a b) - arising from use of `foo' at <interactive>:1 - Probable fix: - Add (Bar a b) to the expected type of an expression - In the first argument of `runFoo', namely `foo' - In the definition of `it': it = runFoo foo - - Why all of the sudden does GHC need the constraint Bar a b? The - function foo didn't ask for that... -@ - -The trouble is that to type (runFoo foo), GHC has to solve the problem: - - Given constraint Foo a b - Solve constraint Foo a b' - -Notice that b and b' aren't the same. To solve this, just do -improvement and then they are the same. But GHC currently does - simplify constraints - apply improvement - and loop - -That is usually fine, but it isn't here, because it sees that Foo a b is -not the same as Foo a b', and so instead applies the instance decl for -instance Bar a b => Foo a b. And that's where the Bar constraint comes -from. - -The Right Thing is to improve whenever the constraint set changes at -all. Not hard in principle, but it'll take a bit of fiddling to do. - -Note [Choosing which variables to quantify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are about to do a generalisation step. We have in our hand - - G the environment - T the type of the RHS - C the constraints from that RHS - -The game is to figure out - - Q the set of type variables over which to quantify - Ct the constraints we will *not* quantify over - Cq the constraints we will quantify over - -So we're going to infer the type - - forall Q. Cq => T - -and float the constraints Ct further outwards. - -Here are the things that *must* be true: - - (A) Q intersect fv(G) = EMPTY limits how big Q can be - (B) Q superset fv(Cq union T) \ oclose(fv(G),C) limits how small Q can be - - (A) says we can't quantify over a variable that's free in the environment. - (B) says we must quantify over all the truly free variables in T, else - we won't get a sufficiently general type. - -We do not *need* to quantify over any variable that is fixed by the -free vars of the environment G. - - BETWEEN THESE TWO BOUNDS, ANY Q WILL DO! - -Example: class H x y | x->y where ... - - fv(G) = {a} C = {H a b, H c d} - T = c -> b - - (A) Q intersect {a} is empty - (B) Q superset {a,b,c,d} \ oclose({a}, C) = {a,b,c,d} \ {a,b} = {c,d} - - So Q can be {c,d}, {b,c,d} - -In particular, it's perfectly OK to quantify over more type variables -than strictly necessary; there is no need to quantify over 'b', since -it is determined by 'a' which is free in the envt, but it's perfectly -OK to do so. However we must not quantify over 'a' itself. - -Other things being equal, however, we'd like to quantify over as few -variables as possible: smaller types, fewer type applications, more -constraints can get into Ct instead of Cq. Here's a good way to -choose Q: - - Q = grow( fv(T), C ) \ oclose( fv(G), C ) - -That is, quantify over all variable that that MIGHT be fixed by the -call site (which influences T), but which aren't DEFINITELY fixed by -G. This choice definitely quantifies over enough type variables, -albeit perhaps too many. - -Why grow( fv(T), C ) rather than fv(T)? Consider - - class H x y | x->y where ... - - T = c->c - C = (H c d) - - If we used fv(T) = {c} we'd get the type - - forall c. H c d => c -> b - - And then if the fn was called at several different c's, each of - which fixed d differently, we'd get a unification error, because - d isn't quantified. Solution: quantify d. So we must quantify - everything that might be influenced by c. - -Why not oclose( fv(T), C )? Because we might not be able to see -all the functional dependencies yet: - - class H x y | x->y where ... - instance H x y => Eq (T x y) where ... - - T = c->c - C = (Eq (T c d)) - -Now oclose(fv(T),C) = {c}, because the functional dependency isn't -apparent yet, and that's wrong. We must really quantify over d too. - -There really isn't any point in quantifying over any more than -grow( fv(T), C ), because the call sites can't possibly influence -any other type variables. - - - -------------------------------------- - Note [Ambiguity] -------------------------------------- - -It's very hard to be certain when a type is ambiguous. Consider - - class K x - class H x y | x -> y - instance H x y => K (x,y) - -Is this type ambiguous? - forall a b. (K (a,b), Eq b) => a -> a - -Looks like it! But if we simplify (K (a,b)) we get (H a b) and -now we see that a fixes b. So we can't tell about ambiguity for sure -without doing a full simplification. And even that isn't possible if -the context has some free vars that may get unified. Urgle! - -Here's another example: is this ambiguous? - forall a b. Eq (T b) => a -> a -Not if there's an insance decl (with no context) - instance Eq (T b) where ... - -You may say of this example that we should use the instance decl right -away, but you can't always do that: - - class J a b where ... - instance J Int b where ... - - f :: forall a b. J a b => a -> a - -(Notice: no functional dependency in J's class decl.) -Here f's type is perfectly fine, provided f is only called at Int. -It's premature to complain when meeting f's signature, or even -when inferring a type for f. - - - -However, we don't *need* to report ambiguity right away. It'll always -show up at the call site.... and eventually at main, which needs special -treatment. Nevertheless, reporting ambiguity promptly is an excellent thing. - -So here's the plan. We WARN about probable ambiguity if - - fv(Cq) is not a subset of oclose(fv(T) union fv(G), C) - -(all tested before quantification). -That is, all the type variables in Cq must be fixed by the the variables -in the environment, or by the variables in the type. - -Notice that we union before calling oclose. Here's an example: - - class J a b c | a b -> c - fv(G) = {a} - -Is this ambiguous? - forall b c. (J a b c) => b -> b - -Only if we union {a} from G with {b} from T before using oclose, -do we see that c is fixed. - -It's a bit vague exactly which C we should use for this oclose call. If we -don't fix enough variables we might complain when we shouldn't (see -the above nasty example). Nothing will be perfect. That's why we can -only issue a warning. - - -Can we ever be *certain* about ambiguity? Yes: if there's a constraint - - c in C such that fv(c) intersect (fv(G) union fv(T)) = EMPTY - -then c is a "bubble"; there's no way it can ever improve, and it's -certainly ambiguous. UNLESS it is a constant (sigh). And what about -the nasty example? - - class K x - class H x y | x -> y - instance H x y => K (x,y) - -Is this type ambiguous? - forall a b. (K (a,b), Eq b) => a -> a - -Urk. The (Eq b) looks "definitely ambiguous" but it isn't. What we are after -is a "bubble" that's a set of constraints - - Cq = Ca union Cq' st fv(Ca) intersect (fv(Cq') union fv(T) union fv(G)) = EMPTY - -Hence another idea. To decide Q start with fv(T) and grow it -by transitive closure in Cq (no functional dependencies involved). -Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok. -The definitely-ambiguous can then float out, and get smashed at top level -(which squashes out the constants, like Eq (T a) above) - - - -------------------------------------- - Notes on principal types - -------------------------------------- - - class C a where - op :: a -> a - - f x = let g y = op (y::Int) in True - -Here the principal type of f is (forall a. a->a) -but we'll produce the non-principal type - f :: forall a. C Int => a -> a - - - -------------------------------------- - The need for forall's in constraints - -------------------------------------- - -[Exchange on Haskell Cafe 5/6 Dec 2000] - - class C t where op :: t -> Bool - instance C [t] where op x = True - - p y = (let f :: c -> Bool; f x = op (y >> return x) in f, y ++ []) - q y = (y ++ [], let f :: c -> Bool; f x = op (y >> return x) in f) - -The definitions of p and q differ only in the order of the components in -the pair on their right-hand sides. And yet: - - ghc and "Typing Haskell in Haskell" reject p, but accept q; - Hugs rejects q, but accepts p; - hbc rejects both p and q; - nhc98 ... (Malcolm, can you fill in the blank for us!). - -The type signature for f forces context reduction to take place, and -the results of this depend on whether or not the type of y is known, -which in turn depends on which component of the pair the type checker -analyzes first. - -Solution: if y::m a, float out the constraints - Monad m, forall c. C (m c) -When m is later unified with [], we can solve both constraints. - - - -------------------------------------- - Notes on implicit parameters - -------------------------------------- - -Note [Inheriting implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f x = (x::Int) + ?y - -where f is *not* a top-level binding. -From the RHS of f we'll get the constraint (?y::Int). -There are two types we might infer for f: - - f :: Int -> Int - -(so we get ?y from the context of f's definition), or - - f :: (?y::Int) => Int -> Int - -At first you might think the first was better, becuase then -?y behaves like a free variable of the definition, rather than -having to be passed at each call site. But of course, the WHOLE -IDEA is that ?y should be passed at each call site (that's what -dynamic binding means) so we'd better infer the second. - -BOTTOM LINE: when *inferring types* you *must* quantify -over implicit parameters. See the predicate isFreeWhenInferring. - - -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'. - - -Question 2: type signatures -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -BUT WATCH OUT: When you supply a type signature, we can't force you -to quantify over implicit parameters. For example: - - (?x + 1) :: Int - -This is perfectly reasonable. We do not want to insist on - - (?x + 1) :: (?x::Int => Int) - -That would be silly. Here, the definition site *is* the occurrence site, -so the above strictures don't apply. Hence the difference between -tcSimplifyCheck (which *does* allow implicit paramters to be inherited) -and tcSimplifyCheckBind (which does not). - -What about when you supply a type signature for a binding? -Is it legal to give the following explicit, user type -signature to f, thus: - - f :: Int -> Int - f x = (x::Int) + ?y - -At first sight this seems reasonable, but it has the nasty property -that adding a type signature changes the dynamic semantics. -Consider this: - - (let f x = (x::Int) + ?y - in (f 3, f 3 with ?y=5)) with ?y = 6 - - returns (3+6, 3+5) -vs - (let f :: Int -> Int - f x = x + ?y - in (f 3, f 3 with ?y=5)) with ?y = 6 - - returns (3+6, 3+6) - -Indeed, simply inlining f (at the Haskell source level) would change the -dynamic semantics. - -Nevertheless, as Launchbury says (email Oct 01) we can't really give the -semantics for a Haskell program without knowing its typing, so if you -change the typing you may change the semantics. - -To make things consistent in all cases where we are *checking* against -a supplied signature (as opposed to inferring a type), we adopt the -rule: - - a signature does not need to quantify over implicit params. - -[This represents a (rather marginal) change of policy since GHC 5.02, -which *required* an explicit signature to quantify over all implicit -params for the reasons mentioned above.] - -But that raises a new question. Consider - - Given (signature) ?x::Int - Wanted (inferred) ?x::Int, ?y::Bool - -Clearly we want to discharge the ?x and float the ?y out. But -what is the criterion that distinguishes them? Clearly it isn't -what free type variables they have. The Right Thing seems to be -to float a constraint that - neither mentions any of the quantified type variables - nor any of the quantified implicit parameters - -See the predicate isFreeWhenChecking. - - -Question 3: monomorphism -~~~~~~~~~~~~~~~~~~~~~~~~ -There's a nasty corner case when the monomorphism restriction bites: - - z = (x::Int) + ?y - -The argument above suggests that we *must* generalise -over the ?y parameter, to get - z :: (?y::Int) => Int, -but the monomorphism restriction says that we *must not*, giving - z :: Int. -Why does the momomorphism restriction say this? Because if you have - - let z = x + ?y in z+z - -you might not expect the addition to be done twice --- but it will if -we follow the argument of Question 2 and generalise over ?y. - - -Question 4: top level -~~~~~~~~~~~~~~~~~~~~~ -At the top level, monomorhism makes no sense at all. - - module Main where - main = let ?x = 5 in print foo - - foo = woggle 3 - - woggle :: (?x :: Int) => Int -> Int - woggle y = ?x + y - -We definitely don't want (foo :: Int) with a top-level implicit parameter -(?x::Int) becuase there is no way to bind it. - - -Possible choices -~~~~~~~~~~~~~~~~ -(A) Always generalise over implicit parameters - Bindings that fall under the monomorphism restriction can't - be generalised - - Consequences: - * Inlining remains valid - * No unexpected loss of sharing - * But simple bindings like - z = ?y + 1 - will be rejected, unless you add an explicit type signature - (to avoid the monomorphism restriction) - z :: (?y::Int) => Int - z = ?y + 1 - This seems unacceptable - -(B) Monomorphism restriction "wins" - Bindings that fall under the monomorphism restriction can't - be generalised - Always generalise over implicit parameters *except* for bindings - that fall under the monomorphism restriction - - Consequences - * Inlining isn't valid in general - * No unexpected loss of sharing - * Simple bindings like - z = ?y + 1 - accepted (get value of ?y from binding site) - -(C) Always generalise over implicit parameters - Bindings that fall under the monomorphism restriction can't - be generalised, EXCEPT for implicit parameters - Consequences - * Inlining remains valid - * Unexpected loss of sharing (from the extra generalisation) - * Simple bindings like - z = ?y + 1 - accepted (get value of ?y from occurrence sites) - - -Discussion -~~~~~~~~~~ -None of these choices seems very satisfactory. But at least we should -decide which we want to do. - -It's really not clear what is the Right Thing To Do. If you see - - z = (x::Int) + ?y - -would you expect the value of ?y to be got from the *occurrence sites* -of 'z', or from the valuue of ?y at the *definition* of 'z'? In the -case of function definitions, the answer is clearly the former, but -less so in the case of non-fucntion definitions. On the other hand, -if we say that we get the value of ?y from the definition site of 'z', -then inlining 'z' might change the semantics of the program. - -Choice (C) really says "the monomorphism restriction doesn't apply -to implicit parameters". Which is fine, but remember that every -innocent binding 'x = ...' that mentions an implicit parameter in -the RHS becomes a *function* of that parameter, called at each -use of 'x'. Now, the chances are that there are no intervening 'with' -clauses that bind ?y, so a decent compiler should common up all -those function calls. So I think I strongly favour (C). Indeed, -one could make a similar argument for abolishing the monomorphism -restriction altogether. - -BOTTOM LINE: we choose (B) at present. See tcSimplifyRestricted - - - -%************************************************************************ -%* * -\subsection{tcSimplifyInfer} -%* * -%************************************************************************ - -tcSimplify is called when we *inferring* a type. Here's the overall game plan: - - 1. Compute Q = grow( fvs(T), C ) - - 2. Partition C based on Q into Ct and Cq. Notice that ambiguous - predicates will end up in Ct; we deal with them at the top level - - 3. Try improvement, using functional dependencies - - 4. If Step 3 did any unification, repeat from step 1 - (Unification can change the result of 'grow'.) - -Note: we don't reduce dictionaries in step 2. For example, if we have -Eq (a,b), we don't simplify to (Eq a, Eq b). So Q won't be different -after step 2. However note that we may therefore quantify over more -type variables than we absolutely have to. - -For the guts, we need a loop, that alternates context reduction and -improvement with unification. E.g. Suppose we have - - class C x y | x->y where ... - -and tcSimplify is called with: - (C Int a, C Int b) -Then improvement unifies a with b, giving - (C Int a, C Int a) - -If we need to unify anything, we rattle round the whole thing all over -again. - - -\begin{code} -tcSimplifyInfer - :: SDoc - -> TcTyVarSet -- fv(T); type vars - -> [Inst] -- Wanted - -> TcM ([TcTyVar], -- Tyvars to quantify (zonked and quantified) - [Inst], -- Dict Ids that must be bound here (zonked) - TcDictBinds) -- Bindings - -- Any free (escaping) Insts are tossed into the environment -\end{code} - - -\begin{code} -tcSimplifyInfer doc tau_tvs wanted - = do { tau_tvs1 <- zonkTcTyVarsAndFV (varSetElems tau_tvs) - ; wanted' <- mapM zonkInst wanted -- Zonk before deciding quantified tyvars - ; gbl_tvs <- tcGetGlobalTyVars - ; let preds1 = fdPredsOfInsts wanted' - gbl_tvs1 = oclose preds1 gbl_tvs - qtvs = growInstsTyVars wanted' tau_tvs1 `minusVarSet` gbl_tvs1 - -- See Note [Choosing which variables to quantify] - - -- To maximise sharing, remove from consideration any - -- constraints that don't mention qtvs at all - ; let (free, bound) = partition (isFreeWhenInferring qtvs) wanted' - ; extendLIEs free - - -- To make types simple, reduce as much as possible - ; traceTc (text "infer" <+> (ppr preds1 $$ ppr (growInstsTyVars wanted' tau_tvs1) $$ ppr gbl_tvs $$ - ppr gbl_tvs1 $$ ppr free $$ ppr bound)) - ; (irreds1, binds1) <- tryHardCheckLoop doc bound - - -- Note [Inference and implication constraints] - ; let want_dict d = tyVarsOfInst d `intersectsVarSet` qtvs - ; (irreds2, binds2) <- approximateImplications doc want_dict irreds1 - - -- Now work out all over again which type variables to quantify, - -- exactly in the same way as before, but starting from irreds2. Why? - -- a) By now improvment may have taken place, and we must *not* - -- quantify over any variable free in the environment - -- tc137 (function h inside g) is an example - -- - -- b) Do not quantify over constraints that *now* do not - -- mention quantified type variables, because they are - -- simply ambiguous (or might be bound further out). Example: - -- f :: Eq b => a -> (a, b) - -- g x = fst (f x) - -- From the RHS of g we get the MethodInst f77 :: alpha -> (alpha, beta) - -- We decide to quantify over 'alpha' alone, but free1 does not include f77 - -- because f77 mentions 'alpha'. Then reducing leaves only the (ambiguous) - -- constraint (Eq beta), which we dump back into the free set - -- See test tcfail181 - -- - -- c) irreds may contain type variables not previously mentioned, - -- e.g. instance D a x => Foo [a] - -- wanteds = Foo [a] - -- Then after simplifying we'll get (D a x), and x is fresh - -- We must quantify over x else it'll be totally unbound - ; tau_tvs2 <- zonkTcTyVarsAndFV (varSetElems tau_tvs1) - ; gbl_tvs2 <- zonkTcTyVarsAndFV (varSetElems gbl_tvs1) - -- Note that we start from gbl_tvs1 - -- We use tcGetGlobalTyVars, then oclose wrt preds2, because - -- we've already put some of the original preds1 into frees - -- E.g. wanteds = C a b (where a->b) - -- gbl_tvs = {a} - -- tau_tvs = {b} - -- Then b is fixed by gbl_tvs, so (C a b) will be in free, and - -- irreds2 will be empty. But we don't want to generalise over b! - ; let preds2 = fdPredsOfInsts irreds2 -- irreds2 is zonked - qtvs = growInstsTyVars irreds2 tau_tvs2 `minusVarSet` oclose preds2 gbl_tvs2 - --------------------------------------------------- - -- BUG WARNING: there's a nasty bug lurking here - -- fdPredsOfInsts may return preds that mention variables quantified in - -- one of the implication constraints in irreds2; and that is clearly wrong: - -- we might quantify over too many variables through accidental capture - --------------------------------------------------- - ; let (free, irreds3) = partition (isFreeWhenInferring qtvs) irreds2 - ; extendLIEs free - - -- Turn the quantified meta-type variables into real type variables - ; qtvs2 <- zonkQuantifiedTyVars (varSetElems qtvs) - - -- We can't abstract over any remaining unsolved - -- implications so instead just float them outwards. Ugh. - ; let (q_dicts0, implics) = partition isAbstractableInst irreds3 - ; loc <- getInstLoc (ImplicOrigin doc) - ; implic_bind <- bindIrreds loc qtvs2 q_dicts0 implics - - -- Prepare equality instances for quantification - ; let (q_eqs0,q_dicts) = partition isEqInst q_dicts0 - ; q_eqs <- mapM finalizeEqInst q_eqs0 - - ; return (qtvs2, q_eqs ++ q_dicts, binds1 `unionBags` binds2 `unionBags` implic_bind) } - -- NB: when we are done, we might have some bindings, but - -- the final qtvs might be empty. See Note [NO TYVARS] below. - -approximateImplications :: SDoc -> (Inst -> Bool) -> [Inst] -> TcM ([Inst], TcDictBinds) --- Note [Inference and implication constraints] --- Given a bunch of Dict and ImplicInsts, try to approximate the implications by --- - fetching any dicts inside them that are free --- - using those dicts as cruder constraints, to solve the implications --- - returning the extra ones too - -approximateImplications doc want_dict irreds - | null extra_dicts - = return (irreds, emptyBag) - | otherwise - = do { extra_dicts' <- mapM cloneDict extra_dicts - ; tryHardCheckLoop doc (extra_dicts' ++ irreds) } - -- By adding extra_dicts', we make them - -- available to solve the implication constraints - where - extra_dicts = get_dicts (filter isImplicInst irreds) - - get_dicts :: [Inst] -> [Inst] -- Returns only Dicts - -- Find the wanted constraints in implication constraints that satisfy - -- want_dict, and are not bound by forall's in the constraint itself - get_dicts ds = concatMap get_dict ds - - get_dict d@(Dict {}) | want_dict d = [d] - | otherwise = [] - get_dict (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds}) - = [ d | let tv_set = mkVarSet tvs - , d <- get_dicts wanteds - , not (tyVarsOfInst d `intersectsVarSet` tv_set)] - get_dict i@(EqInst {}) | want_dict i = [i] - | otherwise = [] - get_dict other = pprPanic "approximateImplications" (ppr other) -\end{code} - -Note [Inference and implication constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a wanted implication constraint (perhaps arising from -a nested pattern match) like - C a => D [a] -and we are now trying to quantify over 'a' when inferring the type for -a function. In principle it's possible that there might be an instance - instance (C a, E a) => D [a] -so the context (E a) would suffice. The Right Thing is to abstract over -the implication constraint, but we don't do that (a) because it'll be -surprising to programmers and (b) because we don't have the machinery to deal -with 'given' implications. - -So our best approximation is to make (D [a]) part of the inferred -context, so we can use that to discharge the implication. Hence -the strange function get_dicts in approximateImplications. - -The common cases are more clear-cut, when we have things like - forall a. C a => C b -Here, abstracting over (C b) is not an approximation at all -- but see -Note [Freeness and implications]. - -See Trac #1430 and test tc228. - - -\begin{code} ------------------------------------------------------------ --- tcSimplifyInferCheck is used when we know the constraints we are to simplify --- against, but we don't know the type variables over which we are going to quantify. --- This happens when we have a type signature for a mutually recursive group -tcSimplifyInferCheck - :: InstLoc - -> TcTyVarSet -- fv(T) - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM ([TyVar], -- Fully zonked, and quantified - TcDictBinds) -- Bindings - -tcSimplifyInferCheck loc tau_tvs givens wanteds - = do { traceTc (text "tcSimplifyInferCheck <-" <+> ppr wanteds) - ; (irreds, binds) <- gentleCheckLoop loc givens wanteds - - -- Figure out which type variables to quantify over - -- You might think it should just be the signature tyvars, - -- but in bizarre cases you can get extra ones - -- f :: forall a. Num a => a -> a - -- f x = fst (g (x, head [])) + 1 - -- g a b = (b,a) - -- Here we infer g :: forall a b. a -> b -> (b,a) - -- We don't want g to be monomorphic in b just because - -- f isn't quantified over b. - ; let all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens) - ; all_tvs <- zonkTcTyVarsAndFV all_tvs - ; gbl_tvs <- tcGetGlobalTyVars - ; let qtvs = varSetElems (all_tvs `minusVarSet` gbl_tvs) - -- We could close gbl_tvs, but its not necessary for - -- soundness, and it'll only affect which tyvars, not which - -- dictionaries, we quantify over - - ; qtvs' <- zonkQuantifiedTyVars qtvs - - -- Now we are back to normal (c.f. tcSimplCheck) - ; implic_bind <- bindIrreds loc qtvs' givens irreds - - ; traceTc (text "tcSimplifyInferCheck ->" <+> ppr (implic_bind)) - ; return (qtvs', binds `unionBags` implic_bind) } -\end{code} - -Note [Squashing methods] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Be careful if you want to float methods more: - truncate :: forall a. RealFrac a => forall b. Integral b => a -> b -From an application (truncate f i) we get - t1 = truncate at f - t2 = t1 at i -If we have also have a second occurrence of truncate, we get - t3 = truncate at f - t4 = t3 at i -When simplifying with i,f free, we might still notice that -t1=t3; but alas, the binding for t2 (which mentions t1) -may continue to float out! - - -Note [NO TYVARS] -~~~~~~~~~~~~~~~~~ - class Y a b | a -> b where - y :: a -> X b - - instance Y [[a]] a where - y ((x:_):_) = X x - - k :: X a -> X a -> X a - - g :: Num a => [X a] -> [X a] - g xs = h xs - where - h ys = ys ++ map (k (y [[0]])) xs - -The excitement comes when simplifying the bindings for h. Initially -try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}. -From this we get t1~t2, but also various bindings. We can't forget -the bindings (because of [LOOP]), but in fact t1 is what g is -polymorphic in. - -The net effect of [NO TYVARS] - -\begin{code} -\end{code} - - -%************************************************************************ -%* * -\subsection{tcSimplifyCheck} -%* * -%************************************************************************ - -@tcSimplifyCheck@ is used when we know exactly the set of variables -we are going to quantify over. For example, a class or instance declaration. - -\begin{code} ------------------------------------------------------------ --- tcSimplifyCheck is used when checking expression type signatures, --- class decls, instance decls etc. -tcSimplifyCheck :: InstLoc - -> [TcTyVar] -- Quantify over these - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM TcDictBinds -- Bindings -tcSimplifyCheck loc qtvs givens wanteds - = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs ) - do { traceTc (text "tcSimplifyCheck") - ; (irreds, binds) <- gentleCheckLoop loc givens wanteds - ; implic_bind <- bindIrreds loc qtvs givens irreds - ; return (binds `unionBags` implic_bind) } - ------------------------------------------------------------ --- tcSimplifyCheckPat is used for existential pattern match -tcSimplifyCheckPat :: InstLoc - -> [TcTyVar] -- Quantify over these - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM TcDictBinds -- Bindings -tcSimplifyCheckPat loc qtvs givens wanteds - = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs ) - do { traceTc (text "tcSimplifyCheckPat") - ; (irreds, binds) <- gentleCheckLoop loc givens wanteds - ; implic_bind <- bindIrredsR loc qtvs givens irreds - ; return (binds `unionBags` implic_bind) } - ------------------------------------------------------------ -bindIrreds :: InstLoc -> [TcTyVar] - -> [Inst] -> [Inst] - -> TcM TcDictBinds -bindIrreds loc qtvs givens irreds - = bindIrredsR loc qtvs givens irreds - -bindIrredsR :: InstLoc -> [TcTyVar] -> [Inst] -> [Inst] -> TcM TcDictBinds --- Make a binding that binds 'irreds', by generating an implication --- constraint for them, *and* throwing the constraint into the LIE -bindIrredsR loc qtvs givens irreds - | null irreds - = return emptyBag - | otherwise - = do { let givens' = filter isAbstractableInst givens - -- The givens can (redundantly) include methods - -- We want to retain both EqInsts and Dicts - -- There should be no implicadtion constraints - -- See Note [Pruning the givens in an implication constraint] - - -- If there are no 'givens', then it's safe to - -- partition the 'wanteds' by their qtvs, thereby trimming irreds - -- See Note [Freeness and implications] - ; irreds' <- if null givens' - then do - { let qtv_set = mkVarSet qtvs - (frees, real_irreds) = partition (isFreeWrtTyVars qtv_set) irreds - ; extendLIEs frees - ; return real_irreds } - else return irreds - - ; (implics, bind) <- makeImplicationBind loc qtvs givens' irreds' - -- This call does the real work - -- If irreds' is empty, it does something sensible - ; extendLIEs implics - ; return bind } - - -makeImplicationBind :: InstLoc -> [TcTyVar] - -> [Inst] -> [Inst] - -> TcM ([Inst], TcDictBinds) --- Make a binding that binds 'irreds', by generating an implication --- constraint for them. --- --- The binding looks like --- (ir1, .., irn) = f qtvs givens --- where f is (evidence for) the new implication constraint --- f :: forall qtvs. givens => (ir1, .., irn) --- qtvs includes coercion variables --- --- This binding must line up the 'rhs' in reduceImplication -makeImplicationBind loc all_tvs - givens -- Guaranteed all Dicts or EqInsts - irreds - | null irreds -- If there are no irreds, we are done - = return ([], emptyBag) - | otherwise -- Otherwise we must generate a binding - = do { uniq <- newUnique - ; span <- getSrcSpanM - ; let (eq_givens, dict_givens) = partition isEqInst givens - - -- extract equality binders - eq_cotvs = map eqInstType eq_givens - - -- make the implication constraint instance - name = mkInternalName uniq (mkVarOcc "ic") span - implic_inst = ImplicInst { tci_name = name, - tci_tyvars = all_tvs, - tci_given = eq_givens ++ dict_givens, - -- same order as binders - tci_wanted = irreds, - tci_loc = loc } - - -- create binders for the irreducible dictionaries - dict_irreds = filter (not . isEqInst) irreds - dict_irred_ids = map instToId dict_irreds - lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids) - - -- create the binding - rhs = L span (mkHsWrap co (HsVar (instToId implic_inst))) - co = mkWpApps (map instToId dict_givens) - <.> mkWpTyApps eq_cotvs - <.> mkWpTyApps (mkTyVarTys all_tvs) - bind | [dict_irred_id] <- dict_irred_ids - = mkVarBind dict_irred_id rhs - | otherwise - = L span $ - PatBind { pat_lhs = lpat - , pat_rhs = unguardedGRHSs rhs - , pat_rhs_ty = hsLPatType lpat - , bind_fvs = placeHolderNames - } - - ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst - ; return ([implic_inst], unitBag bind) - } - ------------------------------------------------------------ -tryHardCheckLoop :: SDoc - -> [Inst] -- Wanted - -> TcM ([Inst], TcDictBinds) - -tryHardCheckLoop doc wanteds - = do { (irreds,binds) <- checkLoop (mkInferRedEnv doc try_me) wanteds - ; return (irreds,binds) - } - where - try_me _ = ReduceMe - -- Here's the try-hard bit - ------------------------------------------------------------ -gentleCheckLoop :: InstLoc - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM ([Inst], TcDictBinds) - -gentleCheckLoop inst_loc givens wanteds - = do { (irreds,binds) <- checkLoop env wanteds - ; return (irreds,binds) - } - where - env = mkRedEnv (pprInstLoc inst_loc) try_me givens - - try_me inst | isMethodOrLit inst = ReduceMe - | otherwise = Stop - -- When checking against a given signature - -- we MUST be very gentle: Note [Check gently] - -gentleInferLoop :: SDoc -> [Inst] - -> TcM ([Inst], TcDictBinds) -gentleInferLoop doc wanteds - = do { (irreds, binds) <- checkLoop env wanteds - ; return (irreds, binds) } - where - env = mkInferRedEnv doc try_me - try_me inst | isMethodOrLit inst = ReduceMe - | otherwise = Stop -\end{code} - -Note [Check gently] -~~~~~~~~~~~~~~~~~~~~ -We have to very careful about not simplifying too vigorously -Example: - data T a where - MkT :: a -> T [a] - - f :: Show b => T b -> b - f (MkT x) = show [x] - -Inside the pattern match, which binds (a:*, x:a), we know that - b ~ [a] -Hence we have a dictionary for Show [a] available; and indeed we -need it. We are going to build an implication contraint - forall a. (b~[a]) => Show [a] -Later, we will solve this constraint using the knowledge (Show b) - -But we MUST NOT reduce (Show [a]) to (Show a), else the whole -thing becomes insoluble. So we simplify gently (get rid of literals -and methods only, plus common up equal things), deferring the real -work until top level, when we solve the implication constraint -with tryHardCheckLooop. - - -\begin{code} ------------------------------------------------------------ -checkLoop :: RedEnv - -> [Inst] -- Wanted - -> TcM ([Inst], TcDictBinds) --- Precondition: givens are completely rigid --- Postcondition: returned Insts are zonked - -checkLoop env wanteds - = go env wanteds - where go env wanteds - = do { -- We do need to zonk the givens; cf Note [Zonking RedEnv] - ; env' <- zonkRedEnv env - ; wanteds' <- zonkInsts wanteds - - ; (improved, tybinds, binds, irreds) - <- reduceContext env' wanteds' - ; execTcTyVarBinds tybinds - - ; if null irreds || not improved then - return (irreds, binds) - else do - - -- If improvement did some unification, we go round again. - -- We start again with irreds, not wanteds - -- Using an instance decl might have introduced a fresh type - -- variable which might have been unified, so we'd get an - -- infinite loop if we started again with wanteds! - -- See Note [LOOP] - { (irreds1, binds1) <- go env' irreds - ; return (irreds1, binds `unionBags` binds1) } } -\end{code} - -Note [Zonking RedEnv] -~~~~~~~~~~~~~~~~~~~~~ -It might appear as if the givens in RedEnv are always rigid, but that is not -necessarily the case for programs involving higher-rank types that have class -contexts constraining the higher-rank variables. An example from tc237 in the -testsuite is - - class Modular s a | s -> a - - wim :: forall a w. Integral a - => a -> (forall s. Modular s a => M s w) -> w - wim i k = error "urk" - - test5 :: (Modular s a, Integral a) => M s a - test5 = error "urk" - - test4 = wim 4 test4' - -Notice how the variable 'a' of (Modular s a) in the rank-2 type of wim is -quantified further outside. When type checking test4, we have to check -whether the signature of test5 is an instance of - - (forall s. Modular s a => M s w) - -Consequently, we will get (Modular s t_a), where t_a is a TauTv into the -givens. - -Given the FD of Modular in this example, class improvement will instantiate -t_a to 'a', where 'a' is the skolem from test5's signatures (due to the -Modular s a predicate in that signature). If we don't zonk (Modular s t_a) in -the givens, we will get into a loop as improveOne uses the unification engine -Unify.tcUnifyTys, which doesn't know about mutable type variables. - - -Note [LOOP] -~~~~~~~~~~~ - class If b t e r | b t e -> r - instance If T t e t - instance If F t e e - class Lte a b c | a b -> c where lte :: a -> b -> c - instance Lte Z b T - instance (Lte a b l,If l b a c) => Max a b c - -Wanted: Max Z (S x) y - -Then we'll reduce using the Max instance to: - (Lte Z (S x) l, If l (S x) Z y) -and improve by binding l->T, after which we can do some reduction -on both the Lte and If constraints. What we *can't* do is start again -with (Max Z (S x) y)! - - - -%************************************************************************ -%* * - tcSimplifySuperClasses -%* * -%************************************************************************ - -Note [SUPERCLASS-LOOP 1] -~~~~~~~~~~~~~~~~~~~~~~~~ -We have to be very, very careful when generating superclasses, lest we -accidentally build a loop. Here's an example: - - class S a - - class S a => C a where { opc :: a -> a } - class S b => D b where { opd :: b -> b } - - instance C Int where - opc = opd - - instance D Int where - opd = opc - -From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int} -Simplifying, we may well get: - $dfCInt = :C ds1 (opd dd) - dd = $dfDInt - ds1 = $p1 dd -Notice that we spot that we can extract ds1 from dd. - -Alas! Alack! We can do the same for (instance D Int): - - $dfDInt = :D ds2 (opc dc) - dc = $dfCInt - ds2 = $p1 dc - -And now we've defined the superclass in terms of itself. -Two more nasty cases are in - tcrun021 - tcrun033 - -Solution: - - Satisfy the superclass context *all by itself* - (tcSimplifySuperClasses) - - And do so completely; i.e. no left-over constraints - to mix with the constraints arising from method declarations - - -Note [Recursive instances and superclases] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this code, which arises in the context of "Scrap Your -Boilerplate with Class". - - class Sat a - class Data ctx a - instance Sat (ctx Char) => Data ctx Char - instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] - - class Data Maybe a => Foo a - - instance Foo t => Sat (Maybe t) - - instance Data Maybe a => Foo a - instance Foo a => Foo [a] - instance Foo [Char] - -In the instance for Foo [a], when generating evidence for the superclasses -(ie in tcSimplifySuperClasses) we need a superclass (Data Maybe [a]). -Using the instance for Data, we therefore need - (Sat (Maybe [a], Data Maybe a) -But we are given (Foo a), and hence its superclass (Data Maybe a). -So that leaves (Sat (Maybe [a])). Using the instance for Sat means -we need (Foo [a]). And that is the very dictionary we are bulding -an instance for! So we must put that in the "givens". So in this -case we have - Given: Foo a, Foo [a] - Watend: Data Maybe [a] - -BUT we must *not not not* put the *superclasses* of (Foo [a]) in -the givens, which is what 'addGiven' would normally do. Why? Because -(Data Maybe [a]) is the superclass, so we'd "satisfy" the wanted -by selecting a superclass from Foo [a], which simply makes a loop. - -On the other hand we *must* put the superclasses of (Foo a) in -the givens, as you can see from the derivation described above. - -Conclusion: in the very special case of tcSimplifySuperClasses -we have one 'given' (namely the "this" dictionary) whose superclasses -must not be added to 'givens' by addGiven. - -There is a complication though. Suppose there are equalities - instance (Eq a, a~b) => Num (a,b) -Then we normalise the 'givens' wrt the equalities, so the original -given "this" dictionary is cast to one of a different type. So it's a -bit trickier than before to identify the "special" dictionary whose -superclasses must not be added. See test - indexed-types/should_run/EqInInstance - -We need a persistent property of the dictionary to record this -special-ness. Current I'm using the InstLocOrigin (a bit of a hack, -but cool), which is maintained by dictionary normalisation. -Specifically, the InstLocOrigin is - NoScOrigin -then the no-superclass thing kicks in. WATCH OUT if you fiddle -with InstLocOrigin! - -\begin{code} -tcSimplifySuperClasses - :: InstLoc - -> Inst -- The dict whose superclasses - -- are being figured out - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM TcDictBinds -tcSimplifySuperClasses loc this givens sc_wanteds - = do { traceTc (text "tcSimplifySuperClasses") - - -- Note [Recursive instances and superclases] - ; no_sc_loc <- getInstLoc NoScOrigin - ; let no_sc_this = setInstLoc this no_sc_loc - - ; let env = RedEnv { red_doc = pprInstLoc loc, - red_try_me = try_me, - red_givens = no_sc_this : givens, - red_stack = (0,[]), - red_improve = False } -- No unification vars - - - ; (irreds,binds1) <- checkLoop env sc_wanteds - ; let (tidy_env, tidy_irreds) = tidyInsts irreds - ; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds - ; return binds1 } - where - try_me _ = ReduceMe -- Try hard, so we completely solve the superclass - -- constraints right here. See Note [SUPERCLASS-LOOP 1] -\end{code} - - -%************************************************************************ -%* * -\subsection{tcSimplifyRestricted} -%* * -%************************************************************************ - -tcSimplifyRestricted infers which type variables to quantify for a -group of restricted bindings. This isn't trivial. - -Eg1: id = \x -> x - We want to quantify over a to get id :: forall a. a->a - -Eg2: eq = (==) - We do not want to quantify over a, because there's an Eq a - constraint, so we get eq :: a->a->Bool (notice no forall) - -So, assume: - RHS has type 'tau', whose free tyvars are tau_tvs - RHS has constraints 'wanteds' - -Plan A (simple) - Quantify over (tau_tvs \ ftvs(wanteds)) - This is bad. The constraints may contain (Monad (ST s)) - where we have instance Monad (ST s) where... - so there's no need to be monomorphic in s! - - Also the constraint might be a method constraint, - whose type mentions a perfectly innocent tyvar: - op :: Num a => a -> b -> a - Here, b is unconstrained. A good example would be - foo = op (3::Int) - We want to infer the polymorphic type - foo :: forall b. b -> b - - -Plan B (cunning, used for a long time up to and including GHC 6.2) - Step 1: Simplify the constraints as much as possible (to deal - with Plan A's problem). Then set - qtvs = tau_tvs \ ftvs( simplify( wanteds ) ) - - Step 2: Now simplify again, treating the constraint as 'free' if - it does not mention qtvs, and trying to reduce it otherwise. - The reasons for this is to maximise sharing. - - This fails for a very subtle reason. Suppose that in the Step 2 - a constraint (Foo (Succ Zero) (Succ Zero) b) gets thrown upstairs as 'free'. - In the Step 1 this constraint might have been simplified, perhaps to - (Foo Zero Zero b), AND THEN THAT MIGHT BE IMPROVED, to bind 'b' to 'T'. - This won't happen in Step 2... but that in turn might prevent some other - constraint (Baz [a] b) being simplified (e.g. via instance Baz [a] T where {..}) - and that in turn breaks the invariant that no constraints are quantified over. - - Test typecheck/should_compile/tc177 (which failed in GHC 6.2) demonstrates - the problem. - - -Plan C (brutal) - Step 1: Simplify the constraints as much as possible (to deal - with Plan A's problem). Then set - qtvs = tau_tvs \ ftvs( simplify( wanteds ) ) - Return the bindings from Step 1. - - -A note about Plan C (arising from "bug" reported by George Russel March 2004) -Consider this: - - instance (HasBinary ty IO) => HasCodedValue ty - - foo :: HasCodedValue a => String -> IO a - - doDecodeIO :: HasCodedValue a => () -> () -> IO a - doDecodeIO codedValue view - = let { act = foo "foo" } in act - -You might think this should work becuase the call to foo gives rise to a constraint -(HasCodedValue t), which can be satisfied by the type sig for doDecodeIO. But the -restricted binding act = ... calls tcSimplifyRestricted, and PlanC simplifies the -constraint using the (rather bogus) instance declaration, and now we are stuffed. - -I claim this is not really a bug -- but it bit Sergey as well as George. So here's -plan D - - -Plan D (a variant of plan B) - Step 1: Simplify the constraints as much as possible (to deal - with Plan A's problem), BUT DO NO IMPROVEMENT. Then set - qtvs = tau_tvs \ ftvs( simplify( wanteds ) ) - - Step 2: Now simplify again, treating the constraint as 'free' if - it does not mention qtvs, and trying to reduce it otherwise. - - The point here is that it's generally OK to have too few qtvs; that is, - to make the thing more monomorphic than it could be. We don't want to - do that in the common cases, but in wierd cases it's ok: the programmer - can always add a signature. - - Too few qtvs => too many wanteds, which is what happens if you do less - improvement. - - -\begin{code} -tcSimplifyRestricted -- Used for restricted binding groups - -- i.e. ones subject to the monomorphism restriction - :: SDoc - -> TopLevelFlag - -> [Name] -- Things bound in this group - -> TcTyVarSet -- Free in the type of the RHSs - -> [Inst] -- Free in the RHSs - -> TcM ([TyVar], -- Tyvars to quantify (zonked and quantified) - TcDictBinds) -- Bindings - -- tcSimpifyRestricted returns no constraints to - -- quantify over; by definition there are none. - -- They are all thrown back in the LIE - -tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds - -- Zonk everything in sight - = do { traceTc (text "tcSimplifyRestricted") - ; wanteds_z <- zonkInsts wanteds - - -- 'ReduceMe': Reduce as far as we can. Don't stop at - -- dicts; the idea is to get rid of as many type - -- variables as possible, and we don't want to stop - -- at (say) Monad (ST s), because that reduces - -- immediately, with no constraint on s. - -- - -- BUT do no improvement! See Plan D above - -- HOWEVER, some unification may take place, if we instantiate - -- a method Inst with an equality constraint - ; let env = mkNoImproveRedEnv doc (\_ -> ReduceMe) - ; (_imp, _tybinds, _binds, constrained_dicts) - <- reduceContext env wanteds_z - - -- Next, figure out the tyvars we will quantify over - ; tau_tvs' <- zonkTcTyVarsAndFV (varSetElems tau_tvs) - ; gbl_tvs' <- tcGetGlobalTyVars - ; constrained_dicts' <- zonkInsts constrained_dicts - - ; let qtvs1 = tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs' - -- As in tcSimplifyInfer - - -- Do not quantify over constrained type variables: - -- this is the monomorphism restriction - constrained_tvs' = tyVarsOfInsts constrained_dicts' - qtvs = qtvs1 `minusVarSet` constrained_tvs' - pp_bndrs = pprWithCommas (quotes . ppr) bndrs - - -- Warn in the mono - ; warn_mono <- doptM Opt_WarnMonomorphism - ; warnTc (warn_mono && (constrained_tvs' `intersectsVarSet` qtvs1)) - (vcat[ ptext (sLit "the Monomorphism Restriction applies to the binding") - <> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs, - ptext (sLit "Consider giving a type signature for") <+> pp_bndrs]) - - ; traceTc (text "tcSimplifyRestricted" <+> vcat [ - pprInsts wanteds, pprInsts constrained_dicts', - ppr _binds, - ppr constrained_tvs', ppr tau_tvs', ppr qtvs ]) - - -- The first step may have squashed more methods than - -- necessary, so try again, this time more gently, knowing the exact - -- set of type variables to quantify over. - -- - -- We quantify only over constraints that are captured by qtvs; - -- these will just be a subset of non-dicts. This in contrast - -- to normal inference (using isFreeWhenInferring) in which we quantify over - -- all *non-inheritable* constraints too. This implements choice - -- (B) under "implicit parameter and monomorphism" above. - -- - -- Remember that we may need to do *some* simplification, to - -- (for example) squash {Monad (ST s)} into {}. It's not enough - -- just to float all constraints - -- - -- At top level, we *do* squash methods because we want to - -- expose implicit parameters to the test that follows - ; let is_nested_group = isNotTopLevel top_lvl - try_me inst | isFreeWrtTyVars qtvs inst, - (is_nested_group || isDict inst) = Stop - | otherwise = ReduceMe - env = mkNoImproveRedEnv doc try_me - ; (_imp, tybinds, binds, irreds) <- reduceContext env wanteds_z - ; execTcTyVarBinds tybinds - - -- See "Notes on implicit parameters, Question 4: top level" - ; ASSERT( all (isFreeWrtTyVars qtvs) irreds ) -- None should be captured - if is_nested_group then - extendLIEs irreds - else do { let (bad_ips, non_ips) = partition isIPDict irreds - ; addTopIPErrs bndrs bad_ips - ; extendLIEs non_ips } - - ; qtvs' <- zonkQuantifiedTyVars (varSetElems qtvs) - ; return (qtvs', binds) } -\end{code} - - -%************************************************************************ -%* * - tcSimplifyRuleLhs -%* * -%************************************************************************ - -On the LHS of transformation rules we only simplify methods and constants, -getting dictionaries. We want to keep all of them unsimplified, to serve -as the available stuff for the RHS of the rule. - -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, tcSimplifyRuleLhs must *only* squash LitInst and MethInts, leaving -all dicts unchanged, with absolutely no sharing. It's simpler to do this -from scratch, rather than further parameterise simpleReduceLoop etc. -Simpler, maybe, but alas not simple (see Trac #2494) - -* Type errors may give rise to an (unsatisfiable) equality constraint - -* Applications of a higher-rank function on the LHS may give - rise to an implication constraint, esp if there are unsatisfiable - equality constraints inside. - -\begin{code} -tcSimplifyRuleLhs :: [Inst] -> TcM ([Inst], TcDictBinds) -tcSimplifyRuleLhs wanteds - = do { wanteds' <- zonkInsts wanteds - - -- Simplify equalities - -- It's important to do this: Trac #3346 for example - ; (_, wanteds'', tybinds, binds1) <- tcReduceEqs [] wanteds' - ; execTcTyVarBinds tybinds - - -- Simplify other constraints - ; (irreds, binds2) <- go [] emptyBag wanteds'' - - -- Report anything that is left - ; let (dicts, bad_irreds) = partition isDict irreds - ; traceTc (text "tcSimplifyrulelhs" <+> pprInsts bad_irreds) - ; addNoInstanceErrs (nub bad_irreds) - -- The nub removes duplicates, which has - -- not happened otherwise (see notes above) - - ; return (dicts, binds1 `unionBags` binds2) } - where - go :: [Inst] -> TcDictBinds -> [Inst] -> TcM ([Inst], TcDictBinds) - go irreds binds [] - = return (irreds, binds) - go irreds binds (w:ws) - | isDict w - = go (w:irreds) binds ws - | isImplicInst w -- Have a go at reducing the implication - = do { (binds1, irreds1) <- reduceImplication red_env w - ; let (bad_irreds, ok_irreds) = partition isImplicInst irreds1 - ; go (bad_irreds ++ irreds) - (binds `unionBags` binds1) - (ok_irreds ++ ws)} - | otherwise - = do { w' <- zonkInst w -- So that (3::Int) does not generate a call - -- to fromInteger; this looks fragile to me - ; lookup_result <- lookupSimpleInst w' - ; case lookup_result of - NoInstance -> go (w:irreds) binds ws - GenInst ws' rhs -> go irreds binds' (ws' ++ ws) - where - binds' = addInstToDictBind binds w rhs - } - - -- Sigh: we need to reduce inside implications - red_env = mkInferRedEnv doc try_me - doc = ptext (sLit "Implication constraint in RULE lhs") - try_me inst | isMethodOrLit inst = ReduceMe - | otherwise = Stop -- Be gentle -\end{code} - -tcSimplifyBracket is used when simplifying the constraints arising from -a Template Haskell bracket [| ... |]. We want to check that there aren't -any constraints that can't be satisfied (e.g. Show Foo, where Foo has no -Show instance), but we aren't otherwise interested in the results. -Nor do we care about ambiguous dictionaries etc. We will type check -this bracket again at its usage site. - -\begin{code} -tcSimplifyBracket :: [Inst] -> TcM () -tcSimplifyBracket wanteds - = do { _ <- tryHardCheckLoop doc wanteds - ; return () } - where - doc = text "tcSimplifyBracket" -\end{code} - - -%************************************************************************ -%* * -\subsection{Filtering at a dynamic binding} -%* * -%************************************************************************ - -When we have - let ?x = R in B - -we must discharge all the ?x constraints from B. We also do an improvement -step; if we have ?x::t1 and ?x::t2 we must unify t1, t2. - -Actually, the constraints from B might improve the types in ?x. For example - - f :: (?x::Int) => Char -> Char - let ?x = 3 in f 'c' - -then the constraint (?x::Int) arising from the call to f will -force the binding for ?x to be of type Int. - -\begin{code} -tcSimplifyIPs :: [Inst] -- The implicit parameters bound here - -> [Inst] -- Wanted - -> TcM TcDictBinds - -- We need a loop so that we do improvement, and then - -- (next time round) generate a binding to connect the two - -- let ?x = e in ?x - -- Here the two ?x's have different types, and improvement - -- makes them the same. - -tcSimplifyIPs given_ips wanteds - = do { wanteds' <- zonkInsts wanteds - ; given_ips' <- zonkInsts given_ips - -- Unusually for checking, we *must* zonk the given_ips - - ; let env = mkRedEnv doc try_me given_ips' - ; (improved, tybinds, binds, irreds) <- reduceContext env wanteds' - ; execTcTyVarBinds tybinds - - ; if null irreds || not improved then - ASSERT( all is_free irreds ) - do { extendLIEs irreds - ; return binds } - else do - -- If improvement did some unification, we go round again. - -- We start again with irreds, not wanteds - -- Using an instance decl might have introduced a fresh type - -- variable which might have been unified, so we'd get an - -- infinite loop if we started again with wanteds! - -- See Note [LOOP] - { binds1 <- tcSimplifyIPs given_ips' irreds - ; return $ binds `unionBags` binds1 - } } - where - doc = text "tcSimplifyIPs" <+> ppr given_ips - ip_set = mkNameSet (ipNamesOfInsts given_ips) - is_free inst = isFreeWrtIPs ip_set inst - - -- Simplify any methods that mention the implicit parameter - try_me inst | is_free inst = Stop - | otherwise = ReduceMe -\end{code} - - -%************************************************************************ -%* * -\subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@} -%* * -%************************************************************************ - -When doing a binding group, we may have @Insts@ of local functions. -For example, we might have... -\begin{verbatim} -let f x = x + 1 -- orig local function (overloaded) - f.1 = f Int -- two instances of f - f.2 = f Float - in - (f.1 5, f.2 6.7) -\end{verbatim} -The point is: we must drop the bindings for @f.1@ and @f.2@ here, -where @f@ is in scope; those @Insts@ must certainly not be passed -upwards towards the top-level. If the @Insts@ were binding-ified up -there, they would have unresolvable references to @f@. - -We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@. -For each method @Inst@ in the @init_lie@ that mentions one of the -@Ids@, we create a binding. We return the remaining @Insts@ (in an -@LIE@), as well as the @HsBinds@ generated. - -\begin{code} -bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM TcDictBinds --- Simlifies only MethodInsts, and generate only bindings of form --- fm = f tys dicts --- We're careful not to even generate bindings of the form --- d1 = d2 --- You'd think that'd be fine, but it interacts with what is --- arguably a bug in Match.tidyEqnInfo (see notes there) - -bindInstsOfLocalFuns wanteds local_ids - | null overloaded_ids = do - -- Common case - extendLIEs wanteds - return emptyLHsBinds - - | otherwise - = do { (irreds, binds) <- gentleInferLoop doc for_me - ; extendLIEs not_for_me - ; extendLIEs irreds - ; return binds } - where - doc = text "bindInsts" <+> ppr local_ids - overloaded_ids = filter is_overloaded local_ids - is_overloaded id = isOverloadedTy (idType id) - (for_me, not_for_me) = partition (isMethodFor overloaded_set) wanteds - - overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them - -- so it's worth building a set, so that - -- lookup (in isMethodFor) is faster -\end{code} - - -%************************************************************************ -%* * -\subsection{Data types for the reduction mechanism} -%* * -%************************************************************************ - -The main control over context reduction is here - -\begin{code} -data RedEnv - = RedEnv { red_doc :: SDoc -- The context - , red_try_me :: Inst -> WhatToDo - , red_improve :: Bool -- True <=> do improvement - , red_givens :: [Inst] -- All guaranteed rigid - -- Always dicts & equalities - -- but see Note [Rigidity] - - , red_stack :: (Int, [Inst]) -- Recursion stack (for err msg) - -- See Note [RedStack] - } - --- Note [Rigidity] --- The red_givens are rigid so far as cmpInst is concerned. --- There is one case where they are not totally rigid, namely in tcSimplifyIPs --- let ?x = e in ... --- Here, the given is (?x::a), where 'a' is not necy a rigid type --- But that doesn't affect the comparison, which is based only on mame. - --- Note [RedStack] --- The red_stack pair (n,insts) pair is just used for error reporting. --- 'n' is always the depth of the stack. --- The 'insts' is the stack of Insts being reduced: to produce X --- I had to produce Y, to produce Y I had to produce Z, and so on. - - -mkRedEnv :: SDoc -> (Inst -> WhatToDo) -> [Inst] -> RedEnv -mkRedEnv doc try_me givens - = RedEnv { red_doc = doc, red_try_me = try_me, - red_givens = givens, - red_stack = (0,[]), - red_improve = True } - -mkInferRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv --- No givens at all -mkInferRedEnv doc try_me - = RedEnv { red_doc = doc, red_try_me = try_me, - red_givens = [], - red_stack = (0,[]), - red_improve = True } - -mkNoImproveRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv --- Do not do improvement; no givens -mkNoImproveRedEnv doc try_me - = RedEnv { red_doc = doc, red_try_me = try_me, - red_givens = [], - red_stack = (0,[]), - red_improve = True } - -data WhatToDo - = ReduceMe -- Try to reduce this - -- If there's no instance, add the inst to the - -- irreductible ones, but don't produce an error - -- message of any kind. - -- It might be quite legitimate such as (Eq a)! - - | Stop -- Return as irreducible unless it can - -- be reduced to a constant in one step - -- Do not add superclasses; see - -data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses - -- of a predicate when adding it to the avails - -- The reason for this flag is entirely the super-class loop problem - -- Note [SUPER-CLASS LOOP 1] - -zonkRedEnv :: RedEnv -> TcM RedEnv -zonkRedEnv env - = do { givens' <- mapM zonkInst (red_givens env) - ; return $ env {red_givens = givens'} - } -\end{code} - - -%************************************************************************ -%* * -\subsection[reduce]{@reduce@} -%* * -%************************************************************************ - -Note [Ancestor Equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -During context reduction, we add to the wanted equalities also those -equalities that (transitively) occur in superclass contexts of wanted -class constraints. Consider the following code - - class a ~ Int => C a - instance C Int - -If (C a) is wanted, we want to add (a ~ Int), which will be discharged by -substituting Int for a. Hence, we ultimately want (C Int), which we -discharge with the explicit instance. - -\begin{code} -reduceContext :: RedEnv - -> [Inst] -- Wanted - -> TcM (ImprovementDone, - TcTyVarBinds, -- Type variable bindings - TcDictBinds, -- Dictionary bindings - [Inst]) -- Irreducible - -reduceContext env wanteds0 - = do { traceTc (text "reduceContext" <+> (vcat [ - text "----------------------", - red_doc env, - text "given" <+> ppr (red_givens env), - text "wanted" <+> ppr wanteds0, - text "----------------------" - ])) - - -- We want to add as wanted equalities those that (transitively) - -- occur in superclass contexts of wanted class constraints. - -- See Note [Ancestor Equalities] - ; ancestor_eqs <- ancestorEqualities wanteds0 - ; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs - - -- Normalise and solve all equality constraints as far as possible - -- and normalise all dictionary constraints wrt to the reduced - -- equalities. The returned wanted constraints include the - -- irreducible wanted equalities. - ; let wanteds = wanteds0 ++ ancestor_eqs - givens = red_givens env - ; (givens', - wanteds', - tybinds, - normalise_binds) <- tcReduceEqs givens wanteds - ; traceTc $ text "reduceContext: tcReduceEqs result" <+> vcat - [ppr givens', ppr wanteds', ppr tybinds, - ppr normalise_binds] - - -- Build the Avail mapping from "given_dicts" - ; (init_state, _) <- getConstraints $ do - { init_state <- foldlM addGiven emptyAvails givens' - ; return init_state - } - - -- Solve the *wanted* *dictionary* constraints (not implications) - -- This may expose some further equational constraints in the course - -- of improvement due to functional dependencies if any of the - -- involved unifications gets deferred. - ; let (wanted_implics, wanted_dicts) = partition isImplicInst wanteds' - ; (avails, extra_eqs) <- getConstraints (reduceList env wanted_dicts init_state) - -- The getConstraints is reqd because reduceList does improvement - -- (via extendAvails) which may in turn do unification - ; (dict_binds, - bound_dicts, - dict_irreds) <- extractResults avails wanted_dicts - ; traceTc $ text "reduceContext: extractResults" <+> vcat - [ppr avails, ppr wanted_dicts, ppr dict_binds] - - -- Solve the wanted *implications*. In doing so, we can provide - -- as "given" all the dicts that were originally given, - -- *or* for which we now have bindings, - -- *or* which are now irreds - -- NB: Equality irreds need to be converted, as the recursive - -- invocation of the solver will still treat them as wanteds - -- otherwise. - ; let implic_env = env { red_givens - = givens ++ bound_dicts ++ - map wantedToLocalEqInst dict_irreds } - ; (implic_binds_s, implic_irreds_s) - <- mapAndUnzipM (reduceImplication implic_env) wanted_implics - ; let implic_binds = unionManyBags implic_binds_s - implic_irreds = concat implic_irreds_s - - -- Collect all irreducible instances, and determine whether we should - -- go round again. We do so in either of two cases: - -- (1) If dictionary reduction or equality solving led to - -- improvement (i.e., bindings for type variables). - -- (2) If we reduced dictionaries (i.e., got dictionary bindings), - -- they may have exposed further opportunities to normalise - -- family applications. See Note [Dictionary Improvement] - -- - -- NB: We do *not* go around for new extra_eqs. Morally, we should, - -- but we can't without risking non-termination (see #2688). By - -- not going around, we miss some legal programs mixing FDs and - -- TFs, but we never claimed to support such programs in the - -- current implementation anyway. - - ; let all_irreds = dict_irreds ++ implic_irreds ++ extra_eqs - avails_improved = availsImproved avails - eq_improved = anyBag (not . isCoVarBind) tybinds - improvedFlexible = avails_improved || eq_improved - reduced_dicts = not (isEmptyBag dict_binds) - improved = improvedFlexible || reduced_dicts - -- - improvedHint = (if avails_improved then " [AVAILS]" else "") ++ - (if eq_improved then " [EQ]" else "") - - ; traceTc (text "reduceContext end" <+> (vcat [ - text "----------------------", - red_doc env, - text "given" <+> ppr givens, - text "wanted" <+> ppr wanteds0, - text "----", - text "tybinds" <+> ppr tybinds, - text "avails" <+> pprAvails avails, - text "improved =" <+> ppr improved <+> text improvedHint, - text "(all) irreds = " <+> ppr all_irreds, - text "dict-binds = " <+> ppr dict_binds, - text "implic-binds = " <+> ppr implic_binds, - text "----------------------" - ])) - - ; return (improved, - tybinds, - normalise_binds `unionBags` dict_binds - `unionBags` implic_binds, - all_irreds) - } - where - isCoVarBind (TcTyVarBind tv _) = isCoVar tv - -tcImproveOne :: Avails -> Inst -> TcM ImprovementDone -tcImproveOne avails inst - | not (isDict inst) = return False - | otherwise - = do { inst_envs <- tcGetInstEnvs - ; let eqns = improveOne (classInstances inst_envs) - (dictPred inst, pprInstArising inst) - [ (dictPred p, pprInstArising p) - | p <- availsInsts avails, isDict p ] - -- Avails has all the superclasses etc (good) - -- It also has all the intermediates of the deduction (good) - -- It does not have duplicates (good) - -- NB that (?x::t1) and (?x::t2) will be held separately in - -- avails so that improve will see them separate - ; traceTc (text "improveOne" <+> ppr inst) - ; unifyEqns eqns } - -unifyEqns :: [(Equation, (PredType, SDoc), (PredType, SDoc))] - -> TcM ImprovementDone -unifyEqns [] = return False -unifyEqns eqns - = do { traceTc (ptext (sLit "Improve:") <+> vcat (map pprEquationDoc eqns)) - ; improved <- mapM unify eqns - ; return $ or improved - } - where - unify ((qtvs, pairs), what1, what2) - = addErrCtxtM (mkEqnMsg what1 what2) $ - do { let freeTyVars = unionVarSets (map tvs_pr pairs) - `minusVarSet` qtvs - ; (_, _, tenv) <- tcInstTyVars (varSetElems qtvs) - ; mapM_ (unif_pr tenv) pairs - ; anyM isFilledMetaTyVar $ varSetElems freeTyVars - } - - unif_pr tenv (ty1, ty2) = unifyType (substTy tenv ty1) (substTy tenv ty2) - - tvs_pr (ty1, ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 - -pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc -pprEquationDoc (eqn, (p1, _), (p2, _)) - = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)] - -mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv - -> TcM (TidyEnv, SDoc) -mkEqnMsg (pred1,from1) (pred2,from2) tidy_env - = do { pred1' <- zonkTcPredType pred1 - ; pred2' <- zonkTcPredType pred2 - ; let { pred1'' = tidyPred tidy_env pred1' - ; pred2'' = tidyPred tidy_env pred2' } - ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"), - nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]), - nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])] - ; return (tidy_env, msg) } -\end{code} - -Note [Dictionary Improvement] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In reduceContext, we first reduce equalities and then class constraints. -However, the letter may expose further opportunities for the former. Hence, -we need to go around again if dictionary reduction produced any dictionary -bindings. The following example demonstrated the point: - - data EX _x _y (p :: * -> *) - data ANY - - class Base p - - class Base (Def p) => Prop p where - type Def p - - instance Base () - instance Prop () where - type Def () = () - - instance (Base (Def (p ANY))) => Base (EX _x _y p) - instance (Prop (p ANY)) => Prop (EX _x _y p) where - type Def (EX _x _y p) = EX _x _y p - - data FOO x - instance Prop (FOO x) where - type Def (FOO x) = () - - data BAR - instance Prop BAR where - type Def BAR = EX () () FOO - -During checking the last instance declaration, we need to check the superclass -cosntraint Base (Def BAR), which family normalisation reduced to -Base (EX () () FOO). Chasing the instance for Base (EX _x _y p), gives us -Base (Def (FOO ANY)), which again requires family normalisation of Def to -Base () before we can finish. - - -The main context-reduction function is @reduce@. Here's its game plan. - -\begin{code} -reduceList :: RedEnv -> [Inst] -> Avails -> TcM Avails -reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state - = do { traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state)) - ; dopts <- getDOpts - ; when (debugIsOn && (n > 8)) $ do - debugDumpTcRn (hang (ptext (sLit "Interesting! Context reduction stack depth") <+> int n) - 2 (ifPprDebug (nest 2 (pprStack stk)))) - ; if n >= ctxtStkDepth dopts then - failWithTc (reduceDepthErr n stk) - else - go wanteds state } - where - go [] state = return state - go (w:ws) state = do { state' <- reduce (env {red_stack = (n+1, w:stk)}) w state - ; go ws state' } - - -- Base case: we're done! -reduce :: RedEnv -> Inst -> Avails -> TcM Avails -reduce env wanted avails - - -- We don't reduce equalities here (and they must not end up as irreds - -- in the Avails!) - | isEqInst wanted - = return avails - - -- It's the same as an existing inst, or a superclass thereof - | Just _ <- findAvail avails wanted - = do { traceTc (text "reduce: found " <+> ppr wanted) - ; return avails - } - - | otherwise - = do { traceTc (text "reduce" <+> ppr wanted $$ ppr avails) - ; case red_try_me env wanted of { - Stop -> try_simple (addIrred NoSCs); - -- See Note [No superclasses for Stop] - - ReduceMe -> do -- It should be reduced - { (avails, lookup_result) <- reduceInst env avails wanted - ; case lookup_result of - NoInstance -> addIrred AddSCs avails wanted - -- Add it and its superclasses - - GenInst [] rhs -> addWanted AddSCs avails wanted rhs [] - - GenInst wanteds' rhs - -> do { avails1 <- addIrred NoSCs avails wanted - ; avails2 <- reduceList env wanteds' avails1 - ; addWanted AddSCs avails2 wanted rhs wanteds' } } - -- Temporarily do addIrred *before* the reduceList, - -- which has the effect of adding the thing we are trying - -- to prove to the database before trying to prove the things it - -- needs. See note [RECURSIVE DICTIONARIES] - -- NB: we must not do an addWanted before, because that adds the - -- superclasses too, and that can lead to a spurious loop; see - -- the examples in [SUPERCLASS-LOOP] - -- So we do an addIrred before, and then overwrite it afterwards with addWanted - } } - where - -- First, see if the inst can be reduced to a constant in one step - -- Works well for literals (1::Int) and constant dictionaries (d::Num Int) - -- Don't bother for implication constraints, which take real work - try_simple do_this_otherwise - = do { res <- lookupSimpleInst wanted - ; case res of - GenInst [] rhs -> addWanted AddSCs avails wanted rhs [] - _ -> do_this_otherwise avails wanted } -\end{code} - - -Note [RECURSIVE DICTIONARIES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data D r = ZeroD | SuccD (r (D r)); - - instance (Eq (r (D r))) => Eq (D r) where - ZeroD == ZeroD = True - (SuccD a) == (SuccD b) = a == b - _ == _ = False; - - equalDC :: D [] -> D [] -> Bool; - equalDC = (==); - -We need to prove (Eq (D [])). Here's how we go: - - d1 : Eq (D []) - -by instance decl, holds if - d2 : Eq [D []] - where d1 = dfEqD d2 - -by instance decl of Eq, holds if - d3 : D [] - where d2 = dfEqList d3 - d1 = dfEqD d2 - -But now we can "tie the knot" to give - - d3 = d1 - d2 = dfEqList d3 - d1 = dfEqD d2 - -and it'll even run! The trick is to put the thing we are trying to prove -(in this case Eq (D []) into the database before trying to prove its -contributing clauses. - -Note [SUPERCLASS-LOOP 2] -~~~~~~~~~~~~~~~~~~~~~~~~ -We need to be careful when adding "the constaint we are trying to prove". -Suppose we are *given* d1:Ord a, and want to deduce (d2:C [a]) where - - class Ord a => C a where - instance Ord [a] => C [a] where ... - -Then we'll use the instance decl to deduce C [a] from Ord [a], and then add the -superclasses of C [a] to avails. But we must not overwrite the binding -for Ord [a] (which is obtained from Ord a) with a superclass selection or we'll just -build a loop! - -Here's another variant, immortalised in tcrun020 - class Monad m => C1 m - class C1 m => C2 m x - instance C2 Maybe Bool -For the instance decl we need to build (C1 Maybe), and it's no good if -we run around and add (C2 Maybe Bool) and its superclasses to the avails -before we search for C1 Maybe. - -Here's another example - class Eq b => Foo a b - instance Eq a => Foo [a] a -If we are reducing - (Foo [t] t) - -we'll first deduce that it holds (via the instance decl). We must not -then overwrite the Eq t constraint with a superclass selection! - -At first I had a gross hack, whereby I simply did not add superclass constraints -in addWanted, though I did for addGiven and addIrred. This was sub-optimal, -becuase it lost legitimate superclass sharing, and it still didn't do the job: -I found a very obscure program (now tcrun021) in which improvement meant the -simplifier got two bites a the cherry... so something seemed to be an Stop -first time, but reducible next time. - -Now we implement the Right Solution, which is to check for loops directly -when adding superclasses. It's a bit like the occurs check in unification. - - - -%************************************************************************ -%* * - Reducing a single constraint -%* * -%************************************************************************ - -\begin{code} ---------------------------------------------- -reduceInst :: RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult) -reduceInst _ avails other_inst - = do { result <- lookupSimpleInst other_inst - ; return (avails, result) } -\end{code} - -Note [Equational Constraints in Implication Constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -An implication constraint is of the form - Given => Wanted -where Given and Wanted may contain both equational and dictionary -constraints. The delay and reduction of these two kinds of constraints -is distinct: - --) In the generated code, wanted Dictionary constraints are wrapped up in an - implication constraint that is created at the code site where the wanted - dictionaries can be reduced via a let-binding. This let-bound implication - constraint is deconstructed at the use-site of the wanted dictionaries. - --) While the reduction of equational constraints is also delayed, the delay - is not manifest in the generated code. The required evidence is generated - in the code directly at the use-site. There is no let-binding and deconstruction - necessary. The main disadvantage is that we cannot exploit sharing as the - same evidence may be generated at multiple use-sites. However, this disadvantage - is limited because it only concerns coercions which are erased. - -The different treatment is motivated by the different in representation. Dictionary -constraints require manifest runtime dictionaries, while equations require coercions -which are types. - -\begin{code} ---------------------------------------------- -reduceImplication :: RedEnv - -> Inst - -> TcM (TcDictBinds, [Inst]) -\end{code} - -Suppose we are simplifying the constraint - forall bs. extras => wanted -in the context of an overall simplification problem with givens 'givens'. - -Note that - * The 'givens' need not mention any of the quantified type variables - e.g. forall {}. Eq a => Eq [a] - forall {}. C Int => D (Tree Int) - - This happens when you have something like - data T a where - T1 :: Eq a => a -> T a - - f :: T a -> Int - f x = ...(case x of { T1 v -> v==v })... - -\begin{code} - -- ToDo: should we instantiate tvs? I think it's not necessary - -- - -- Note on coercion variables: - -- - -- The extra given coercion variables are bound at two different - -- sites: - -- - -- -) in the creation context of the implication constraint - -- the solved equational constraints use these binders - -- - -- -) at the solving site of the implication constraint - -- the solved dictionaries use these binders; - -- these binders are generated by reduceImplication - -- - -- Note [Binders for equalities] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- To reuse the binders of local/given equalities in the binders of - -- implication constraints, it is crucial that these given equalities - -- always have the form - -- cotv :: t1 ~ t2 - -- where cotv is a simple coercion type variable (and not a more - -- complex coercion term). We require that the extra_givens always - -- have this form and exploit the special form when generating binders. -reduceImplication env - orig_implic@(ImplicInst { tci_name = name, tci_loc = inst_loc, - tci_tyvars = tvs, - tci_given = extra_givens, tci_wanted = wanteds - }) - = do { -- Solve the sub-problem - ; let try_me _ = ReduceMe -- Note [Freeness and implications] - env' = env { red_givens = extra_givens ++ red_givens env - , red_doc = sep [ptext (sLit "reduceImplication for") - <+> ppr name, - nest 2 (parens $ ptext (sLit "within") - <+> red_doc env)] - , red_try_me = try_me } - - ; traceTc (text "reduceImplication" <+> vcat - [ ppr (red_givens env), ppr extra_givens, - ppr wanteds]) - ; (irreds, binds) <- checkLoop env' wanteds - - ; traceTc (text "reduceImplication result" <+> vcat - [ppr irreds, ppr binds]) - - ; -- extract superclass binds - -- (sc_binds,_) <- extractResults avails [] --- ; traceTc (text "reduceImplication sc_binds" <+> vcat --- [ppr sc_binds, ppr avails]) --- - - -- SLPJ Sept 07: what if improvement happened inside the checkLoop? - -- Then we must iterate the outer loop too! - - ; didntSolveWantedEqs <- allM wantedEqInstIsUnsolved wanteds - -- we solve wanted eqs by side effect! - - -- Progress is no longer measered by the number of bindings - -- If there are any irreds, but no bindings and no solved - -- equalities, we back off and do nothing - ; let backOff = isEmptyLHsBinds binds && -- no new bindings - (not $ null irreds) && -- but still some irreds - didntSolveWantedEqs -- no instantiated cotv - - ; if backOff then -- No progress - return (emptyBag, [orig_implic]) - else do - { (simpler_implic_insts, bind) - <- makeImplicationBind inst_loc tvs extra_givens irreds - -- This binding is useless if the recursive simplification - -- made no progress; but currently we don't try to optimise that - -- case. After all, we only try hard to reduce at top level, or - -- when inferring types. - - ; let -- extract Id binders for dicts and CoTyVar binders for eqs; - -- see Note [Binders for equalities] - (extra_eq_givens, extra_dict_givens) = partition isEqInst - extra_givens - eq_cotvs = map instToVar extra_eq_givens - dict_ids = map instToId extra_dict_givens - - co = mkWpTyLams tvs - <.> mkWpTyLams eq_cotvs - <.> mkWpLams dict_ids - <.> WpLet (binds `unionBags` bind) - rhs = mkLHsWrap co payload - loc = instLocSpan inst_loc - -- wanted equalities are solved by updating their - -- cotv; we don't generate bindings for them - dict_bndrs = map (L loc . HsVar . instToId) - . filter (not . isEqInst) - $ wanteds - payload = mkBigLHsTup dict_bndrs - - ; traceTc (vcat [text "reduceImplication" <+> ppr name, - ppr simpler_implic_insts, - text "->" <+> ppr rhs]) - ; return (unitBag (L loc (VarBind { var_id= instToId orig_implic - , var_rhs = rhs - , var_inline = notNull dict_ids } - -- See Note [Always inline implication constraints] - )), - simpler_implic_insts) - } - } -reduceImplication _ i = pprPanic "reduceImplication" (ppr i) -\end{code} - -Note [Always inline implication constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose an implication constraint floats out of an INLINE function. -Then although the implication has a single call site, it won't be -inlined. And that is bad because it means that even if there is really -*no* overloading (type signatures specify the exact types) there will -still be dictionary passing in the resulting code. To avert this, -we mark the implication constraints themselves as INLINE, at least when -there is no loss of sharing as a result. - -Note [Freeness and implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's hard to say when an implication constraint can be floated out. Consider - forall {} Eq a => Foo [a] -The (Foo [a]) doesn't mention any of the quantified variables, but it -still might be partially satisfied by the (Eq a). - -There is a useful special case when it *is* easy to partition the -constraints, namely when there are no 'givens'. Consider - forall {a}. () => Bar b -There are no 'givens', and so there is no reason to capture (Bar b). -We can let it float out. But if there is even one constraint we -must be much more careful: - forall {a}. C a b => Bar (m b) -because (C a b) might have a superclass (D b), from which we might -deduce (Bar [b]) when m later gets instantiated to []. Ha! - -Here is an even more exotic example - class C a => D a b -Now consider the constraint - forall b. D Int b => C Int -We can satisfy the (C Int) from the superclass of D, so we don't want -to float the (C Int) out, even though it mentions no type variable in -the constraints! - -One more example: the constraint - class C a => D a b - instance (C a, E c) => E (a,c) - - constraint: forall b. D Int b => E (Int,c) - -You might think that the (D Int b) can't possibly contribute -to solving (E (Int,c)), since the latter mentions 'c'. But -in fact it can, because solving the (E (Int,c)) constraint needs -dictionaries - C Int, E c -and the (C Int) can be satisfied from the superclass of (D Int b). -So we must still not float (E (Int,c)) out. - -To think about: special cases for unary type classes? - -Note [Pruning the givens in an implication constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are about to form the implication constraint - forall tvs. Eq a => Ord b -The (Eq a) cannot contribute to the (Ord b), because it has no access to -the type variable 'b'. So we could filter out the (Eq a) from the givens. -But BE CAREFUL of the examples above in [Freeness and implications]. - -Doing so would be a bit tidier, but all the implication constraints get -simplified away by the optimiser, so it's no great win. So I don't take -advantage of that at the moment. - -If you do, BE CAREFUL of wobbly type variables. - - -%************************************************************************ -%* * - Avails and AvailHow: the pool of evidence -%* * -%************************************************************************ - - -\begin{code} -data Avails = Avails !ImprovementDone !AvailEnv - -type ImprovementDone = Bool -- True <=> some unification has happened - -- so some Irreds might now be reducible - -- keys that are now - -type AvailEnv = FiniteMap Inst AvailHow -data AvailHow - = IsIrred -- Used for irreducible dictionaries, - -- which are going to be lambda bound - - | Given Inst -- Used for dictionaries for which we have a binding - -- e.g. those "given" in a signature - - | Rhs -- Used when there is a RHS - (LHsExpr TcId) -- The RHS - [Inst] -- Insts free in the RHS; we need these too - -instance Outputable Avails where - ppr = pprAvails - -pprAvails :: Avails -> SDoc -pprAvails (Avails imp avails) - = vcat [ ptext (sLit "Avails") <> (if imp then ptext (sLit "[improved]") else empty) - , nest 2 $ braces $ - vcat [ sep [ppr inst, nest 2 (equals <+> ppr avail)] - | (inst,avail) <- Map.toList avails ]] - -instance Outputable AvailHow where - ppr = pprAvail - -------------------------- -pprAvail :: AvailHow -> SDoc -pprAvail IsIrred = text "Irred" -pprAvail (Given x) = text "Given" <+> ppr x -pprAvail (Rhs rhs bs) = sep [text "Rhs" <+> ppr bs, - nest 2 (ppr rhs)] - -------------------------- -extendAvailEnv :: AvailEnv -> Inst -> AvailHow -> AvailEnv -extendAvailEnv env inst avail = Map.insert inst avail env - -findAvailEnv :: AvailEnv -> Inst -> Maybe AvailHow -findAvailEnv env wanted = Map.lookup wanted env - -- NB 1: the Ord instance of Inst compares by the class/type info - -- *not* by unique. So - -- d1::C Int == d2::C Int - -emptyAvails :: Avails -emptyAvails = Avails False emptyFM - -findAvail :: Avails -> Inst -> Maybe AvailHow -findAvail (Avails _ avails) wanted = findAvailEnv avails wanted - -elemAvails :: Inst -> Avails -> Bool -elemAvails wanted (Avails _ avails) = wanted `elemFM` avails - -extendAvails :: Avails -> Inst -> AvailHow -> TcM Avails --- Does improvement -extendAvails avails@(Avails imp env) inst avail - = do { imp1 <- tcImproveOne avails inst -- Do any improvement - ; return (Avails (imp || imp1) (extendAvailEnv env inst avail)) } - -availsInsts :: Avails -> [Inst] -availsInsts (Avails _ avails) = Map.keys avails - -availsImproved :: Avails -> ImprovementDone -availsImproved (Avails imp _) = imp -\end{code} - -Extracting the bindings from a bunch of Avails. -The bindings do *not* come back sorted in dependency order. -We assume that they'll be wrapped in a big Rec, so that the -dependency analyser can sort them out later - -\begin{code} -type DoneEnv = FiniteMap Inst [Id] --- Tracks which things we have evidence for - -extractResults :: Avails - -> [Inst] -- Wanted - -> TcM (TcDictBinds, -- Bindings - [Inst], -- The insts bound by the bindings - [Inst]) -- Irreducible ones - -- Note [Reducing implication constraints] - -extractResults (Avails _ avails) wanteds - = go emptyBag [] [] emptyFM wanteds - where - go :: TcDictBinds -- Bindings for dicts - -> [Inst] -- Bound by the bindings - -> [Inst] -- Irreds - -> DoneEnv -- Has an entry for each inst in the above three sets - -> [Inst] -- Wanted - -> TcM (TcDictBinds, [Inst], [Inst]) - go binds bound_dicts irreds _ [] - = return (binds, bound_dicts, irreds) - - go binds bound_dicts irreds done (w:ws) - | isEqInst w - = go binds bound_dicts (w:irreds) done' ws - - | Just done_ids@(done_id : rest_done_ids) <- Map.lookup w done - = if w_id `elem` done_ids then - go binds bound_dicts irreds done ws - else - go (add_bind (nlHsVar done_id)) bound_dicts irreds - (Map.insert w (done_id : w_id : rest_done_ids) done) ws - - | otherwise -- Not yet done - = case findAvailEnv avails w of - Nothing -> pprTrace "Urk: extractResults" (ppr w) $ - go binds bound_dicts irreds done ws - - Just IsIrred -> go binds bound_dicts (w:irreds) done' ws - - Just (Rhs rhs ws') -> go (add_bind rhs) (w:bound_dicts) irreds done' (ws' ++ ws) - - Just (Given g) -> go binds' bound_dicts irreds (Map.insert w [g_id] done) ws - where - g_id = instToId g - binds' | w_id == g_id = binds - | otherwise = add_bind (nlHsVar g_id) - where - w_id = instToId w - done' = Map.insert w [w_id] done - add_bind rhs = addInstToDictBind binds w rhs -\end{code} - - -Note [No superclasses for Stop] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we decide not to reduce an Inst -- the 'WhatToDo' --- we still -add it to avails, so that any other equal Insts will be commoned up -right here. However, we do *not* add superclasses. If we have - df::Floating a - dn::Num a -but a is not bound here, then we *don't* want to derive dn from df -here lest we lose sharing. - -\begin{code} -addWanted :: WantSCs -> Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails -addWanted want_scs avails wanted rhs_expr wanteds - = addAvailAndSCs want_scs avails wanted avail - where - avail = Rhs rhs_expr wanteds - -addGiven :: Avails -> Inst -> TcM Avails -addGiven avails given - = addAvailAndSCs want_scs avails given (Given given) - where - want_scs = case instLocOrigin (instLoc given) of - NoScOrigin -> NoSCs - _other -> AddSCs - -- Conditionally add superclasses for 'given' - -- See Note [Recursive instances and superclases] - - -- No ASSERT( not (given `elemAvails` avails) ) because in an - -- instance decl for Ord t we can add both Ord t and Eq t as - -- 'givens', so the assert isn't true -\end{code} - -\begin{code} -addIrred :: WantSCs -> Avails -> Inst -> TcM Avails -addIrred want_scs avails irred = ASSERT2( not (irred `elemAvails` avails), ppr irred $$ ppr avails ) - addAvailAndSCs want_scs avails irred IsIrred - -addAvailAndSCs :: WantSCs -> Avails -> Inst -> AvailHow -> TcM Avails -addAvailAndSCs want_scs avails inst avail - | not (isClassDict inst) = extendAvails avails inst avail - | NoSCs <- want_scs = extendAvails avails inst avail - | otherwise = do { traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps]) - ; avails' <- extendAvails avails inst avail - ; addSCs is_loop avails' inst } - where - is_loop pred = any (`tcEqType` mkPredTy pred) dep_tys - -- Note: this compares by *type*, not by Unique - deps = findAllDeps (unitVarSet (instToVar inst)) avail - dep_tys = map idType (varSetElems deps) - - findAllDeps :: IdSet -> AvailHow -> IdSet - -- Find all the Insts that this one depends on - -- See Note [SUPERCLASS-LOOP 2] - -- Watch out, though. Since the avails may contain loops - -- (see Note [RECURSIVE DICTIONARIES]), so we need to track the ones we've seen so far - findAllDeps so_far (Rhs _ kids) = foldl find_all so_far kids - findAllDeps so_far _ = so_far - - find_all :: IdSet -> Inst -> IdSet - find_all so_far kid - | isEqInst kid = so_far - | kid_id `elemVarSet` so_far = so_far - | Just avail <- findAvail avails kid = findAllDeps so_far' avail - | otherwise = so_far' - where - so_far' = extendVarSet so_far kid_id -- Add the new kid to so_far - kid_id = instToId kid - -addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails - -- Add all the superclasses of the Inst to Avails - -- The first param says "don't do this because the original thing - -- depends on this one, so you'd build a loop" - -- Invariant: the Inst is already in Avails. - -addSCs is_loop avails dict - = ASSERT( isDict dict ) - do { sc_dicts <- newCtGivens (instLoc dict) sc_theta' - ; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) } - where - (clas, tys) = getDictClassTys dict - (tyvars, sc_theta, sc_sels, _) = classBigSig clas - sc_theta' = filter (not . isEqPred) $ - substTheta (zipTopTvSubst tyvars tys) sc_theta - - add_sc avails (sc_dict, sc_sel) - | is_loop (dictPred sc_dict) = return avails -- See Note [SUPERCLASS-LOOP 2] - | is_given sc_dict = return avails - | otherwise = do { avails' <- extendAvails avails sc_dict (Rhs sc_sel_rhs [dict]) - ; addSCs is_loop avails' sc_dict } - where - sc_sel_rhs = L (instSpan dict) (HsWrap co_fn (HsVar sc_sel)) - co_fn = WpApp (instToVar dict) <.> mkWpTyApps tys - - is_given :: Inst -> Bool - is_given sc_dict = case findAvail avails sc_dict of - Just (Given _) -> True -- Given is cheaper than superclass selection - _ -> False - --- From the a set of insts obtain all equalities that (transitively) occur in --- superclass contexts of class constraints (aka the ancestor equalities). --- -ancestorEqualities :: [Inst] -> TcM [Inst] -ancestorEqualities - = mapM mkWantedEqInst -- turn only equality predicates.. - . filter isEqPred -- ..into wanted equality insts - . bagToList - . addAEsToBag emptyBag -- collect the superclass constraints.. - . map dictPred -- ..of all predicates in a bag - . filter isClassDict - where - addAEsToBag :: Bag PredType -> [PredType] -> Bag PredType - addAEsToBag bag [] = bag - addAEsToBag bag (pred:preds) - | pred `elemBag` bag = addAEsToBag bag preds - | isEqPred pred = addAEsToBag bagWithPred preds - | isClassPred pred = addAEsToBag bagWithPred predsWithSCs - | otherwise = addAEsToBag bag preds - where - bagWithPred = bag `snocBag` pred - predsWithSCs = preds ++ substTheta (zipTopTvSubst tyvars tys) sc_theta - -- - (tyvars, sc_theta, _, _) = classBigSig clas - (clas, tys) = getClassPredTys pred -\end{code} - - -%************************************************************************ -%* * -\section{tcSimplifyTop: defaulting} -%* * -%************************************************************************ - - -@tcSimplifyTop@ is called once per module to simplify all the constant -and ambiguous Insts. - -We need to be careful of one case. Suppose we have - - instance Num a => Num (Foo a b) where ... - -and @tcSimplifyTop@ is given a constraint (Num (Foo x y)). Then it'll simplify -to (Num x), and default x to Int. But what about y?? - -It's OK: the final zonking stage should zap y to (), which is fine. - - -\begin{code} -tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds -tcSimplifyTop wanteds - = tc_simplify_top doc False wanteds - where - doc = text "tcSimplifyTop" - -tcSimplifyInteractive wanteds - = tc_simplify_top doc True wanteds - where - doc = text "tcSimplifyInteractive" - --- The TcLclEnv should be valid here, solely to improve --- error message generation for the monomorphism restriction -tc_simplify_top :: SDoc -> Bool -> [Inst] -> TcM (Bag (LHsBind TcId)) -tc_simplify_top doc interactive wanteds - = do { dflags <- getDOpts - ; wanteds <- zonkInsts wanteds - ; mapM_ zonkTopTyVar (varSetElems (tyVarsOfInsts wanteds)) - - ; traceTc (text "tc_simplify_top 0: " <+> ppr wanteds) - ; (irreds1, binds1) <- tryHardCheckLoop doc1 wanteds --- ; (irreds1, binds1) <- gentleInferLoop doc1 wanteds - ; traceTc (text "tc_simplify_top 1: " <+> ppr irreds1) - ; (irreds2, binds2) <- approximateImplications doc2 (\_ -> True) irreds1 - ; traceTc (text "tc_simplify_top 2: " <+> ppr irreds2) - - -- Use the defaulting rules to do extra unification - -- NB: irreds2 are already zonked - ; (irreds3, binds3) <- disambiguate doc3 interactive dflags irreds2 - - -- Deal with implicit parameters - ; let (bad_ips, non_ips) = partition isIPDict irreds3 - (ambigs, others) = partition isTyVarDict non_ips - - ; topIPErrs bad_ips -- Can arise from f :: Int -> Int - -- f x = x + ?y - ; addNoInstanceErrs others - ; addTopAmbigErrs ambigs - - ; return (binds1 `unionBags` binds2 `unionBags` binds3) } - where - doc1 = doc <+> ptext (sLit "(first round)") - doc2 = doc <+> ptext (sLit "(approximate)") - doc3 = doc <+> ptext (sLit "(disambiguate)") -\end{code} - -If a dictionary constrains a type variable which is - * not mentioned in the environment - * and not mentioned in the type of the expression -then it is ambiguous. No further information will arise to instantiate -the type variable; nor will it be generalised and turned into an extra -parameter to a function. - -It is an error for this to occur, except that Haskell provided for -certain rules to be applied in the special case of numeric types. -Specifically, if - * at least one of its classes is a numeric class, and - * all of its classes are numeric or standard -then the type variable can be defaulted to the first type in the -default-type list which is an instance of all the offending classes. - -So here is the function which does the work. It takes the ambiguous -dictionaries and either resolves them (producing bindings) or -complains. It works by splitting the dictionary list by type -variable, and using @disambigOne@ to do the real business. - -@disambigOne@ assumes that its arguments dictionaries constrain all -the same type variable. - -ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to -@()@ instead of @Int@. I reckon this is the Right Thing to do since -the most common use of defaulting is code like: -\begin{verbatim} - _ccall_ foo `seqPrimIO` bar -\end{verbatim} -Since we're not using the result of @foo@, the result if (presumably) -@void@. - -\begin{code} -disambiguate :: SDoc -> Bool -> DynFlags -> [Inst] -> TcM ([Inst], TcDictBinds) - -- Just does unification to fix the default types - -- The Insts are assumed to be pre-zonked -disambiguate doc interactive dflags insts - | null insts - = return (insts, emptyBag) - - | null defaultable_groups - = do { traceTc (text "disambigutate, no defaultable groups" <+> vcat [ppr unaries, ppr insts, ppr bad_tvs, ppr defaultable_groups]) - ; return (insts, emptyBag) } - - | otherwise - = do { -- Figure out what default types to use - default_tys <- getDefaultTys extended_defaulting ovl_strings - - ; traceTc (text "disambiguate1" <+> vcat [ppr insts, ppr unaries, ppr bad_tvs, ppr defaultable_groups]) - ; mapM_ (disambigGroup default_tys) defaultable_groups - - -- disambigGroup does unification, hence try again - ; tryHardCheckLoop doc insts } - - where - extended_defaulting = interactive || dopt Opt_ExtendedDefaultRules dflags - -- See also Trac #1974 - ovl_strings = dopt Opt_OverloadedStrings dflags - - unaries :: [(Inst, Class, TcTyVar)] -- (C tv) constraints - bad_tvs :: TcTyVarSet -- Tyvars mentioned by *other* constraints - (unaries, bad_tvs_s) = partitionWith find_unary insts - bad_tvs = unionVarSets bad_tvs_s - - -- Finds unary type-class constraints - find_unary d@(Dict {tci_pred = ClassP cls [ty]}) - | Just tv <- tcGetTyVar_maybe ty = Left (d,cls,tv) - find_unary inst = Right (tyVarsOfInst inst) - - -- Group by type variable - defaultable_groups :: [[(Inst,Class,TcTyVar)]] - defaultable_groups = filter defaultable_group (equivClasses cmp_tv unaries) - cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 - - defaultable_group :: [(Inst,Class,TcTyVar)] -> Bool - defaultable_group ds@((_,_,tv):_) - = isTyConableTyVar tv -- Note [Avoiding spurious errors] - && not (tv `elemVarSet` bad_tvs) - && defaultable_classes [c | (_,c,_) <- ds] - defaultable_group [] = panic "defaultable_group" - - defaultable_classes clss - | extended_defaulting = any isInteractiveClass clss - | otherwise = all is_std_class clss && (any is_num_class clss) - - -- In interactive mode, or with -XExtendedDefaultRules, - -- we default Show a to Show () to avoid graututious errors on "show []" - isInteractiveClass cls - = is_num_class cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey]) - - is_num_class cls = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) - -- is_num_class adds IsString to the standard numeric classes, - -- when -foverloaded-strings is enabled - - is_std_class cls = isStandardClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) - -- Similarly is_std_class - ------------------------ -disambigGroup :: [Type] -- The default types - -> [(Inst,Class,TcTyVar)] -- All standard classes of form (C a) - -> TcM () -- Just does unification, to fix the default types - -disambigGroup default_tys dicts - = do { mb_chosen_ty <- try_default default_tys - ; case mb_chosen_ty of - Nothing -> return () - Just chosen_ty -> do { _ <- unifyType chosen_ty (mkTyVarTy tyvar) - ; warnDefault dicts chosen_ty } } - where - (_,_,tyvar) = ASSERT(not (null dicts)) head dicts -- Should be non-empty - classes = [c | (_,c,_) <- dicts] - - try_default [] = return Nothing - try_default (default_ty : default_tys) - = tryTcLIE_ (try_default default_tys) $ - do { tcSimplifyDefault [mkClassPred clas [default_ty] | clas <- classes] - -- This may fail; then the tryTcLIE_ kicks in - -- Failure here is caused by there being no type in the - -- default list which can satisfy all the ambiguous classes. - -- For example, if Real a is reqd, but the only type in the - -- default list is Int. - - ; return (Just default_ty) -- TOMDO: do something with the coercion - } - - ------------------------ -getDefaultTys :: Bool -> Bool -> TcM [Type] -getDefaultTys extended_deflts ovl_strings - = do { mb_defaults <- getDeclaredDefaultTys - ; case mb_defaults of { - Just tys -> return tys ; -- User-supplied defaults - Nothing -> do - - -- No use-supplied default - -- Use [Integer, Double], plus modifications - { integer_ty <- tcMetaTy integerTyConName - ; checkWiredInTyCon doubleTyCon - ; string_ty <- tcMetaTy stringTyConName - ; return (opt_deflt extended_deflts unitTy - -- Note [Default unitTy] - ++ - [integer_ty,doubleTy] - ++ - opt_deflt ovl_strings string_ty) } } } - where - opt_deflt True ty = [ty] - opt_deflt False _ = [] -\end{code} - -Note [Default unitTy] -~~~~~~~~~~~~~~~~~~~~~ -In interative mode (or with -XExtendedDefaultRules) we add () as the first type we -try when defaulting. This has very little real impact, except in the following case. -Consider: - Text.Printf.printf "hello" -This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't -want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to -default the 'a' to (), rather than to Integer (which is what would otherwise happen; -and then GHCi doesn't attempt to print the (). So in interactive mode, we add -() to the list of defaulting types. See Trac #1200. - -Note [Avoiding spurious errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When doing the unification for defaulting, we check for skolem -type variables, and simply don't default them. For example: - f = (*) -- Monomorphic - g :: Num a => a -> a - g x = f x x -Here, we get a complaint when checking the type signature for g, -that g isn't polymorphic enough; but then we get another one when -dealing with the (Num a) context arising from f's definition; -we try to unify a with Int (to default it), but find that it's -already been unified with the rigid variable from g's type sig - - -%************************************************************************ -%* * -\subsection[simple]{@Simple@ versions} -%* * -%************************************************************************ - -Much simpler versions when there are no bindings to make! - -@tcSimplifyThetas@ simplifies class-type constraints formed by -@deriving@ declarations and when specialising instances. We are -only interested in the simplified bunch of class/type constraints. - -It simplifies to constraints of the form (C a b c) where -a,b,c are type variables. This is required for the context of -instance declarations. - -\begin{code} -tcSimplifyDeriv :: InstOrigin - -> [TyVar] - -> ThetaType -- Wanted - -> TcM ThetaType -- Needed --- Given instance (wanted) => C inst_ty --- Simplify 'wanted' as much as possible - -tcSimplifyDeriv orig tyvars theta - = do { (tvs, _, tenv) <- tcInstTyVars tyvars - -- The main loop may do unification, and that may crash if - -- it doesn't see a TcTyVar, so we have to instantiate. Sigh - -- ToDo: what if two of them do get unified? - ; wanteds <- newCtGivensO orig (substTheta tenv theta) - ; (irreds, _) <- tryHardCheckLoop doc wanteds - - ; let (tv_dicts, others) = partition ok irreds - (tidy_env, tidy_insts) = tidyInsts others - ; reportNoInstances tidy_env Nothing [alt_fix] tidy_insts - -- See Note [Exotic derived instance contexts] in TcMType - - ; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars) - simpl_theta = substTheta rev_env (map dictPred tv_dicts) - -- This reverse-mapping is a pain, but the result - -- should mention the original TyVars not TcTyVars - - ; return simpl_theta } - where - doc = ptext (sLit "deriving classes for a data type") - - ok dict | isDict dict = validDerivPred (dictPred dict) - | otherwise = False - alt_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration instead,"), - ptext (sLit "so you can specify the instance context yourself")] -\end{code} - - -@tcSimplifyDefault@ just checks class-type constraints, essentially; -used with \tr{default} declarations. We are only interested in -whether it worked or not. - -\begin{code} -tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it - -> TcM () - -tcSimplifyDefault theta = do - wanteds <- newCtGivensO DefaultOrigin theta - (irreds, _) <- tryHardCheckLoop doc wanteds - addNoInstanceErrs irreds - if null irreds then - return () - else - traceTc (ptext (sLit "tcSimplifyDefault failing")) >> failM - where - doc = ptext (sLit "default declaration") -\end{code} - - - -%************************************************************************ -%* * -\section{Errors and contexts} -%* * -%************************************************************************ - -ToDo: for these error messages, should we note the location as coming -from the insts, or just whatever seems to be around in the monad just -now? - -\begin{code} -groupErrs :: ([Inst] -> TcM ()) -- Deal with one group - -> [Inst] -- The offending Insts - -> TcM () --- Group together insts with the same origin --- We want to report them together in error messages - -groupErrs _ [] - = return () -groupErrs report_err (inst:insts) - = do { do_one (inst:friends) - ; groupErrs report_err others } - where - -- (It may seem a bit crude to compare the error messages, - -- but it makes sure that we combine just what the user sees, - -- and it avoids need equality on InstLocs.) - (friends, others) = partition is_friend insts - loc_msg = showSDoc (pprInstLoc (instLoc inst)) - is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg - do_one insts = setInstCtxt (instLoc (head insts)) (report_err insts) - -- Add location and context information derived from the Insts - --- Add the "arising from..." part to a message about bunch of dicts -addInstLoc :: [Inst] -> Message -> Message -addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts)) - -addTopIPErrs :: [Name] -> [Inst] -> TcM () -addTopIPErrs _ [] - = return () -addTopIPErrs bndrs ips - = do { dflags <- getDOpts - ; addErrTcM (tidy_env, mk_msg dflags tidy_ips) } - where - (tidy_env, tidy_ips) = tidyInsts ips - mk_msg dflags ips - = vcat [sep [ptext (sLit "Implicit parameters escape from"), - nest 2 (ptext (sLit "the monomorphic top-level binding") - <> plural bndrs <+> ptext (sLit "of") - <+> pprBinders bndrs <> colon)], - nest 2 (vcat (map ppr_ip ips)), - monomorphism_fix dflags] - ppr_ip ip = pprPred (dictPred ip) <+> pprInstArising ip - -topIPErrs :: [Inst] -> TcM () -topIPErrs dicts - = groupErrs report tidy_dicts - where - (tidy_env, tidy_dicts) = tidyInsts dicts - report dicts = addErrTcM (tidy_env, mk_msg dicts) - mk_msg dicts = addInstLoc dicts (ptext (sLit "Unbound implicit parameter") <> - plural tidy_dicts <+> pprDictsTheta tidy_dicts) - -addNoInstanceErrs :: [Inst] -- Wanted (can include implications) - -> TcM () -addNoInstanceErrs insts - = do { let (tidy_env, tidy_insts) = tidyInsts insts - ; reportNoInstances tidy_env Nothing [] tidy_insts } - -reportNoInstances - :: TidyEnv - -> Maybe (InstLoc, [Inst]) -- Context - -- Nothing => top level - -- Just (d,g) => d describes the construct - -- with givens g - -> [SDoc] -- Alternative fix for no-such-instance - -> [Inst] -- What is wanted (can include implications) - -> TcM () - -reportNoInstances tidy_env mb_what alt_fix insts - = groupErrs (report_no_instances tidy_env mb_what alt_fix) insts - -report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [SDoc] -> [Inst] -> TcM () -report_no_instances tidy_env mb_what alt_fixes insts - = do { inst_envs <- tcGetInstEnvs - ; let (implics, insts1) = partition isImplicInst insts - (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1 - (eqInsts, insts3) = partition isEqInst insts2 - ; traceTc (text "reportNoInstances" <+> vcat - [ppr insts, ppr implics, ppr insts1, ppr insts2]) - ; mapM_ complain_implic implics - ; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps - ; groupErrs complain_no_inst insts3 - ; mapM_ (addErrTcM . mk_eq_err) eqInsts - } - where - complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts) - - complain_implic inst -- Recurse! - = reportNoInstances tidy_env - (Just (tci_loc inst, tci_given inst)) - alt_fixes (tci_wanted inst) - - check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc - -- Right msg => overlap message - -- Left inst => no instance - check_overlap inst_envs wanted - | not (isClassDict wanted) = Left wanted - | otherwise - = case lookupInstEnv inst_envs clas tys of - ([], _) -> Left wanted -- No match - -- The case of exactly one match and no unifiers means a - -- successful lookup. That can't happen here, because dicts - -- only end up here if they didn't match in Inst.lookupInst - ([_],[]) - | debugIsOn -> pprPanic "reportNoInstance" (ppr wanted) - res -> Right (mk_overlap_msg wanted res) - where - (clas,tys) = getDictClassTys wanted - - mk_overlap_msg dict (matches, unifiers) - = ASSERT( not (null matches) ) - vcat [ addInstLoc [dict] ((ptext (sLit "Overlapping instances for") - <+> pprPred (dictPred dict))), - sep [ptext (sLit "Matching instances") <> colon, - nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])], - if not (isSingleton matches) - then -- Two or more matches - empty - else -- One match, plus some unifiers - ASSERT( not (null unifiers) ) - parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+> - quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))), - ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), - ptext (sLit "when compiling the other instance declarations")])] - where - ispecs = [ispec | (ispec, _) <- matches] - - mk_eq_err :: Inst -> (TidyEnv, SDoc) - mk_eq_err inst = misMatchMsg tidy_env (eqInstTys inst) - - mk_no_inst_err insts - | null insts = empty - - | Just (loc, givens) <- mb_what, -- Nested (type signatures, instance decls) - not (isEmptyVarSet (tyVarsOfInsts insts)) - = vcat [ addInstLoc insts $ - sep [ ptext (sLit "Could not deduce") <+> pprDictsTheta insts - , nest 2 $ ptext (sLit "from the context") <+> pprDictsTheta givens] - , show_fixes (fix1 loc : fixes2 ++ alt_fixes) ] - - | otherwise -- Top level - = vcat [ addInstLoc insts $ - ptext (sLit "No instance") <> plural insts - <+> ptext (sLit "for") <+> pprDictsTheta insts - , show_fixes (fixes2 ++ alt_fixes) ] - - where - fix1 loc = sep [ ptext (sLit "add") <+> pprDictsTheta insts - <+> ptext (sLit "to the context of"), - nest 2 (ppr (instLocOrigin loc)) ] - -- I'm not sure it helps to add the location - -- nest 2 (ptext (sLit "at") <+> ppr (instLocSpan loc)) ] - - fixes2 | null instance_dicts = [] - | otherwise = [sep [ptext (sLit "add an instance declaration for"), - pprDictsTheta instance_dicts]] - instance_dicts = [d | d <- insts, isClassDict d, not (isTyVarDict d)] - -- Insts for which it is worth suggesting an adding an instance declaration - -- Exclude implicit parameters, and tyvar dicts - - 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))] - -addTopAmbigErrs :: [Inst] -> TcRn () -addTopAmbigErrs dicts --- Divide into groups that share a common set of ambiguous tyvars - = ifErrsM (return ()) $ -- Only report ambiguity if no other errors happened - -- See Note [Avoiding spurious errors] - mapM_ report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts]) - where - (tidy_env, tidy_dicts) = tidyInsts dicts - - tvs_of :: Inst -> [TcTyVar] - tvs_of d = varSetElems (tyVarsOfInst d) - cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 - - report :: [(Inst,[TcTyVar])] -> TcM () - report pairs@((inst,tvs) : _) = do -- The pairs share a common set of ambiguous tyvars - (tidy_env, mono_msg) <- mkMonomorphismMsg tidy_env tvs - setSrcSpan (instSpan inst) $ - -- the location of the first one will do for the err message - addErrTcM (tidy_env, msg $$ mono_msg) - where - dicts = map fst pairs - msg = sep [text "Ambiguous type variable" <> plural tvs <+> - pprQuotedList tvs <+> in_msg, - nest 2 (pprDictsInFull dicts)] - in_msg = text "in the constraint" <> plural dicts <> colon - report [] = panic "addTopAmbigErrs" - - -mkMonomorphismMsg :: TidyEnv -> [TcTyVar] -> TcM (TidyEnv, Message) --- There's an error with these Insts; if they have free type variables --- it's probably caused by the monomorphism restriction. --- Try to identify the offending variable --- ASSUMPTION: the Insts are fully zonked -mkMonomorphismMsg tidy_env inst_tvs - = do { dflags <- getDOpts - ; (tidy_env, docs) <- findGlobals (mkVarSet inst_tvs) tidy_env - ; return (tidy_env, mk_msg dflags docs) } - where - mk_msg _ _ | any isRuntimeUnk inst_tvs - = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+> - (pprWithCommas ppr inst_tvs), - ptext (sLit "Use :print or :force to determine these types")] - mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)") - -- This happens in things like - -- f x = show (read "foo") - -- where monomorphism doesn't play any role - mk_msg dflags docs - = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"), - nest 2 (vcat docs), - monomorphism_fix dflags] - -monomorphism_fix :: DynFlags -> SDoc -monomorphism_fix dflags - = ptext (sLit "Probable fix:") <+> vcat - [ptext (sLit "give these definition(s) an explicit type signature"), - if dopt Opt_MonomorphismRestriction dflags - then ptext (sLit "or use -XNoMonomorphismRestriction") - else empty] -- Only suggest adding "-XNoMonomorphismRestriction" - -- if it is not already set! - -warnDefault :: [(Inst, Class, Var)] -> Type -> TcM () -warnDefault ups default_ty = do - warn_flag <- doptM Opt_WarnTypeDefaults - setInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg) - where - dicts = [d | (d,_,_) <- ups] - - -- Tidy them first - (_, tidy_dicts) = tidyInsts dicts - warn_msg = vcat [ptext (sLit "Defaulting the following constraint(s) to type") <+> - quotes (ppr default_ty), - pprDictsInFull tidy_dicts] - -reduceDepthErr :: Int -> [Inst] -> SDoc -reduceDepthErr n stack - = vcat [ptext (sLit "Context reduction stack overflow; size =") <+> int n, - ptext (sLit "Use -fcontext-stack=N to increase stack size to N"), - nest 4 (pprStack stack)] - -pprStack :: [Inst] -> SDoc -pprStack stack = vcat (map pprInstInFull stack) -\end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 880d957718..a6b2a10aa6 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -72,6 +72,7 @@ import Pair import Unique import Data.Maybe import BasicTypes +import DynFlags import Panic import FastString import Control.Monad ( when ) @@ -1106,7 +1107,7 @@ tcLookupTh name else do -- It's imported { (eps,hpt) <- getEpsAndHpt - ; dflags <- getDOpts + ; dflags <- getDynFlags ; case lookupType dflags hpt (eps_PTE eps) name of Just thing -> return (AGlobal thing) Nothing -> do { thing <- tcImportDecl name diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 2e0e45bdc9..2c28655ccf 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1364,17 +1364,10 @@ checkValidClass cls -- Check the associated type defaults are well-formed and instantiated -- See Note [Checking consistent instantiation] - ; mapM_ check_at_defs at_stuff - - -- Check that if the class has generic methods, then the - -- class has only one parameter. We can't do generic - -- multi-parameter type classes! - ; checkTc (unary || no_generics) (genericMultiParamErr 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 - no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff] + unary = isSingleton (snd (splitKiTyVars tyvars)) -- IA0_NOTE: only count type arguments check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do @@ -1699,11 +1692,6 @@ noClassTyVarErr clas op ptext (sLit "mentions none of the type variables of the class") <+> ppr clas <+> hsep (map ppr (classTyVars clas))] -genericMultiParamErr :: Class -> SDoc -genericMultiParamErr clas - = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+> - ptext (sLit "cannot have generic methods") - recSynErr :: [LTyClDecl Name] -> TcRn () recSynErr syn_decls = setSrcSpan (getLoc (head sorted_decls)) $ diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 4c1ab4aa5f..e2308baa0d 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -318,8 +318,9 @@ isCoVar v = isCoVarType (varType v) isCoVarType :: Type -> Bool isCoVarType ty -- Tests for t1 ~# t2, the unboxed equality - | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` eqPrimTyConKey - | otherwise = False + = case splitTyConApp_maybe ty of + Just (tc,tys) -> tc `hasKey` eqPrimTyConKey && tys `lengthAtLeast` 2 + Nothing -> False \end{code} @@ -456,8 +457,9 @@ pprCoAxiom ax -- -- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c] decomposeCo :: Arity -> Coercion -> [Coercion] -decomposeCo arity co = [mkNthCo n co | n <- [0..(arity-1)] ] - -- Remember, Nth is zero-indexed +decomposeCo arity co + = [mkNthCo n co | n <- [0..(arity-1)] ] + -- Remember, Nth is zero-indexed -- | Attempts to obtain the type variable underlying a 'Coercion' getCoVar_maybe :: Coercion -> Maybe CoVar @@ -615,8 +617,17 @@ mkTransCo co (Refl _) = co mkTransCo co1 co2 = TransCo co1 co2 mkNthCo :: Int -> Coercion -> Coercion -mkNthCo n (Refl ty) = Refl (tyConAppArgN n ty) -mkNthCo n co = NthCo n co +mkNthCo n (Refl ty) = ASSERT( ok_tc_app ty n ) + Refl (tyConAppArgN n ty) +mkNthCo n co = ASSERT( ok_tc_app _ty1 n && ok_tc_app _ty2 n ) + NthCo n co + where + Pair _ty1 _ty2 = coercionKind co + +ok_tc_app :: Type -> Int -> Bool +ok_tc_app ty n = case splitTyConApp_maybe ty of + Just (_, tys) -> tys `lengthExceeds` n + Nothing -> False -- | Instantiates a 'Coercion' with a 'Type' argument. mkInstCo :: Coercion -> Type -> Coercion diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index bfddf5b322..feb4be50c1 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -76,6 +76,7 @@ import Foreign import Data.Array import Data.IORef import Data.Char ( ord, chr ) +import Data.Time import Data.Typeable #if __GLASGOW_HASKELL__ >= 701 import Data.Typeable.Internal @@ -488,6 +489,23 @@ instance (Binary a, Binary b) => Binary (Either a b) where 0 -> do a <- get bh ; return (Left a) _ -> do b <- get bh ; return (Right b) +instance Binary UTCTime where + put_ bh u = do put_ bh (utctDay u) + put_ bh (utctDayTime u) + get bh = do day <- get bh + dayTime <- get bh + return $ UTCTime { utctDay = day, utctDayTime = dayTime } + +instance Binary Day where + put_ bh d = put_ bh (toModifiedJulianDay d) + get bh = do i <- get bh + return $ ModifiedJulianDay { toModifiedJulianDay = i } + +instance Binary DiffTime where + put_ bh dt = put_ bh (toRational dt) + get bh = do r <- get bh + return $ fromRational r + #if defined(__GLASGOW_HASKELL__) || 1 --to quote binary-0.3 on this code idea, -- diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index c029e4a8e0..ee7e616305 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -30,6 +30,7 @@ module IOEnv ( atomicUpdMutVar, atomicUpdMutVar' ) where +import DynFlags import Exception import Panic @@ -88,6 +89,10 @@ instance Show IOEnvFailure where instance Exception IOEnvFailure +instance ContainsDynFlags env => HasDynFlags (IOEnv env) where + getDynFlags = do env <- getEnv + return $ extractDynFlags env + ---------------------------------------------------------------------- -- Fundmantal combinators specific to the monad ---------------------------------------------------------------------- diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 93800b0399..d09a1ad345 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -76,6 +76,7 @@ module Util ( -- * IO-ish utilities createDirectoryHierarchy, doesDirNameExist, + getModificationUTCTime, modificationTimeIfExists, global, consIORef, globalM, @@ -113,7 +114,6 @@ import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, createDirectory, getModificationTime ) import System.FilePath -import System.Time ( ClockTime ) import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit ) import Data.Ratio ( (%) ) @@ -122,6 +122,12 @@ import Data.Bits import Data.Word import qualified Data.IntMap as IM +import Data.Time +#if __GLASGOW_HASKELL__ < 705 +import Data.Time.Clock.POSIX +import System.Time +#endif + infixr 9 `thenCmp` \end{code} @@ -753,7 +759,7 @@ restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 restrictedDamerauLevenshteinDistance' - :: (Bits bv) => bv -> Int -> Int -> String -> String -> Int + :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 | [] <- str1 = n | otherwise = extractAnswer $ @@ -766,7 +772,7 @@ restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 extractAnswer (_, _, _, _, distance) = distance restrictedDamerauLevenshteinDistanceWorker - :: (Bits bv) => IM.IntMap bv -> bv -> bv + :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask (pm, d0, vp, vn, distance) char2 @@ -795,7 +801,7 @@ restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask sizedComplement :: Bits bv => bv -> bv -> bv sizedComplement vector_mask vect = vector_mask `xor` vect -matchVectors :: Bits bv => String -> IM.IntMap bv +matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv matchVectors = snd . foldl' go (0 :: Int, IM.empty) where go (ix, im) char = let ix' = ix + 1 @@ -1029,12 +1035,24 @@ doesDirNameExist fpath = case takeDirectory fpath of "" -> return True -- XXX Hack _ -> doesDirectoryExist (takeDirectory fpath) +----------------------------------------------------------------------------- +-- Backwards compatibility definition of getModificationTime + +getModificationUTCTime :: FilePath -> IO UTCTime +#if __GLASGOW_HASKELL__ < 705 +getModificationUTCTime f = do + TOD secs _ <- getModificationTime f + return $ posixSecondsToUTCTime (realToFrac secs) +#else +getModificationUTCTime = getModificationTime +#endif + -- -------------------------------------------------------------- -- check existence & modification time at the same time -modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime) +modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) modificationTimeIfExists f = do - (do t <- getModificationTime f; return (Just t)) + (do t <- getModificationUTCTime f; return (Just t)) `catchIO` \e -> if isDoesNotExistError e then return Nothing else ioError e diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index a6bf6d973f..426682cea8 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -54,12 +54,12 @@ initV :: HscEnv -> VM a -> IO (Maybe (VectInfo, a)) initV hsc_env guts info thing_inside - = do { - let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) + = do { dumpIfVtTrace "Incoming VectInfo" (ppr info) + + ; let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) ; (_, Just res) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) type_env go - ; dumpIfVtTrace "Incoming VectInfo" (ppr info) ; case res of Nothing -> dumpIfVtTrace "Vectorisation FAILED!" empty diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs index 559bbac1b6..0cab706cf4 100644 --- a/compiler/vectorise/Vectorise/Type/Classify.hs +++ b/compiler/vectorise/Vectorise/Type/Classify.hs @@ -23,6 +23,7 @@ import DataCon import TyCon import TypeRep import Type +import PrelNames import Digraph @@ -54,14 +55,21 @@ classifyTyCons convStatus tcs = classify [] [] [] convStatus (tyConGroups tcs) where refs = ds `delListFromUniqSet` tcs - can_convert = isNullUFM (refs `minusUFM` cs) && all convertable tcs + can_convert = (isNullUFM (refs `minusUFM` cs) && all convertable tcs) + || isShowClass tcs must_convert = foldUFM (||) False (intersectUFM_C const cs refs) + && (not . isShowClass $ tcs) -- We currently admit Haskell 2011-style data and newtype declarations as well as type -- constructors representing classes. convertable tc = (isDataTyCon tc || isNewTyCon tc) && all isVanillaDataCon (tyConDataCons tc) || isClassTyCon tc + + -- !!!FIXME: currently we allow 'Show' in vectorised code without actually providing a + -- vectorised definition (to be able to vectorise 'Num') + isShowClass [tc] = tyConName tc == showClassName + isShowClass _ = False -- Used to group type constructors into mutually dependent groups. -- diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index a6f77bb9db..0051d072a4 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -147,14 +147,6 @@ vectTypeEnv :: [TyCon] -- Type constructors defined in this mod vectTypeEnv tycons vectTypeDecls vectClassDecls = do { traceVt "** vectTypeEnv" $ ppr tycons - -- Build a map containing all vectorised type constructor. If they are scalar, they are - -- mapped to 'False' (vectorised type constructor == original type constructor). - ; allScalarTyConNames <- globalScalarTyCons -- covers both current and imported modules - ; vectTyCons <- globalVectTyCons - ; let vectTyConBase = mapNameEnv (const True) vectTyCons -- by default fully vectorised - vectTyConFlavour = foldNameSet (\n env -> extendNameEnv env n False) vectTyConBase - allScalarTyConNames - ; let -- {-# VECTORISE SCALAR type T -#} (imported and local tycons) localAbstractTyCons = [tycon | VectType True tycon Nothing <- vectTypeDecls] @@ -172,6 +164,23 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls localAbstractTyCons ++ map fst3 vectTyConsWithRHS notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames + -- Build a map containing all vectorised type constructor. If they are scalar, they are + -- mapped to 'False' (vectorised type constructor == original type constructor). + ; allScalarTyConNames <- globalScalarTyCons -- covers both current and imported modules + ; vectTyCons <- globalVectTyCons + ; let vectTyConBase = mapNameEnv (const True) vectTyCons -- by default fully vectorised + vectTyConFlavour = vectTyConBase + `plusNameEnv` + mkNameEnv [ (tyConName tycon, True) + | (tycon, _, _) <- vectTyConsWithRHS] + `plusNameEnv` + mkNameEnv [ (tcName, False) -- original representation + | tcName <- nameSetToList allScalarTyConNames] + `plusNameEnv` + mkNameEnv [ (tyConName tycon, False) -- original representation + | tycon <- localAbstractTyCons] + + -- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2) -- that we could, but don't need to vectorise. Type constructors that are not data -- type constructors or use non-Haskell98 features are being dropped. They may not @@ -219,6 +228,12 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls -- Vectorise all the data type declarations that we can and must vectorise (enter the -- type and data constructors into the vectorisation map on-the-fly.) ; new_tcs <- vectTyConDecls conv_tcs + + ; let dumpTc tc vTc = traceVt "---" (ppr tc <+> text "::" <+> ppr (dataConSig tc) $$ + ppr vTc <+> text "::" <+> ppr (dataConSig vTc)) + dataConSig tc | Just dc <- tyConSingleDataCon_maybe tc = dataConRepType dc + | otherwise = panic "dataConSig" + ; zipWithM_ dumpTc (filter isClassTyCon conv_tcs) (filter isClassTyCon new_tcs) -- We don't need new representation types for dictionary constructors. The constructors -- are always fully applied, and we don't need to lift them to arrays as a dictionary |