diff options
Diffstat (limited to 'compiler')
47 files changed, 1111 insertions, 547 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 9fc728b3f6..b32a2b7bfc 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -1146,17 +1146,14 @@ coerceId = pcMiscPrelId coerceName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs - kv = kKiVar - k = mkTyVarTy kv - a:b:_ = tyVarList k - [aTy,bTy] = map mkTyVarTy [a,b] - eqRTy = mkTyConApp coercibleTyCon [k, aTy, bTy] - eqRPrimTy = mkTyConApp eqReprPrimTyCon [k, aTy, bTy] - ty = mkForAllTys [kv, a, b] (mkFunTys [eqRTy, aTy] bTy) - - [eqR,x,eq] = mkTemplateLocals [eqRTy, aTy,eqRPrimTy] - rhs = mkLams [kv,a,b,eqR,x] $ - mkWildCase (Var eqR) eqRTy bTy $ + eqRTy = mkTyConApp coercibleTyCon [liftedTypeKind, alphaTy, betaTy] + eqRPrimTy = mkTyConApp eqReprPrimTyCon [liftedTypeKind, alphaTy, betaTy] + ty = mkForAllTys [alphaTyVar, betaTyVar] $ + mkFunTys [eqRTy, alphaTy] betaTy + + [eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy] + rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $ + mkWildCase (Var eqR) eqRTy betaTy $ [(DataAlt coercibleDataCon, [eq], Cast (Var x) (CoVarCo eq))] \end{code} diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index edd2986ed3..57f02d9b2a 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -380,7 +380,12 @@ integerPackageKey, primPackageKey, thPackageKey, dphSeqPackageKey, dphParPackageKey, mainPackageKey, thisGhcPackageKey, interactivePackageKey :: PackageKey primPackageKey = fsToPackageKey (fsLit "ghc-prim") -integerPackageKey = fsToPackageKey (fsLit cIntegerLibrary) +integerPackageKey = fsToPackageKey (fsLit n) + where + n = case cIntegerLibraryType of + IntegerGMP -> "integer-gmp" + IntegerGMP2 -> "integer-gmp" + IntegerSimple -> "integer-simple" basePackageKey = fsToPackageKey (fsLit "base") rtsPackageKey = fsToPackageKey (fsLit "rts") thPackageKey = fsToPackageKey (fsLit "template-haskell") diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs index 89c4374388..c651080244 100644 --- a/compiler/basicTypes/PatSyn.lhs +++ b/compiler/basicTypes/PatSyn.lhs @@ -14,7 +14,8 @@ module PatSyn ( -- ** Type deconstruction patSynName, patSynArity, patSynIsInfix, patSynArgs, patSynTyDetails, patSynType, - patSynWrapper, patSynMatcher, + patSynMatcher, + patSynWrapper, patSynWorker, patSynExTyVars, patSynSig, patSynInstArgTys, patSynInstResTy, tidyPatSynIds @@ -36,6 +37,7 @@ import HsBinds( HsPatSynDetails(..) ) import qualified Data.Data as Data import qualified Data.Typeable import Data.Function +import Control.Arrow (second) \end{code} @@ -109,6 +111,37 @@ Injectivity of bidirectional pattern synonyms is checked in tcPatToExpr which walks the pattern and returns its corresponding expression when available. +Note [Wrapper/worker for pattern synonyms with unboxed type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For bidirectional pattern synonyms that have no arguments and have +an unboxed type, we add an extra level of indirection, since $WP would +otherwise be a top-level declaration with an unboxed type. In this case, +a separate worker function is generated that has an extra Void# argument, +and the wrapper redirects to it via a compulsory unfolding (that just +applies it on Void#). Example: + + pattern P = 0# + + $WP :: Int# + $WP unfolded to ($wP Void#) + + $wP :: Void# -> Int# + $wP _ = 0# + +To make things more uniform, we always store two `Id`s in `PatSyn` for +the wrapper and the worker, with the following behaviour: + + if `psWrapper` == Just (`wrapper`, `worker`), then + + * `wrapper` should always be used when compiling the pattern synonym + in an expression context (and its type is as prescribed) + * `worker` is always an `Id` with a binding that needs to be exported + as part of the definition of the pattern synonym + +If a separate worker is not needed (because the pattern synonym has arguments +or has a non-unboxed type), the two `Id`s are the same. + %************************************************************************ %* * \subsection{Pattern synonyms} @@ -149,12 +182,14 @@ data PatSyn -- -> (Void# -> r) -- -> r - psWrapper :: Maybe Id + psWrapper :: Maybe (Id, Id) -- Nothing => uni-directional pattern synonym - -- Just wid => bi-direcitonal + -- Just (wrapper, worker) => bi-direcitonal -- Wrapper function, of type -- forall univ_tvs, ex_tvs. (prov_theta, req_theta) -- => arg_tys -> res_ty + -- + -- See Note [Wrapper/worker for pattern synonyms with unboxed type] } deriving Data.Typeable.Typeable \end{code} @@ -215,7 +250,7 @@ mkPatSyn :: Name -> [Type] -- ^ Original arguments -> Type -- ^ Original result type -> Id -- ^ Name of matcher - -> Maybe Id -- ^ Name of wrapper + -> Maybe (Id, Id) -- ^ Name of wrapper/worker -> PatSyn mkPatSyn name declared_infix (univ_tvs, req_theta) @@ -276,14 +311,17 @@ patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty) patSynWrapper :: PatSyn -> Maybe Id -patSynWrapper = psWrapper +patSynWrapper = fmap fst . psWrapper + +patSynWorker :: PatSyn -> Maybe Id +patSynWorker = fmap snd . psWrapper patSynMatcher :: PatSyn -> Id patSynMatcher = psMatcher tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id }) - = ps { psMatcher = tidy_fn match_id, psWrapper = fmap tidy_fn mb_wrap_id } + = ps { psMatcher = tidy_fn match_id, psWrapper = fmap (second tidy_fn) mb_wrap_id } patSynInstArgTys :: PatSyn -> [Type] -> [Type] -- Return the types of the argument patterns diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index d4afaf10fc..b9e3fcbd6a 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -157,9 +157,14 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns = ASSERT( isExternalName n ) - Orig (nameModule n) - (setOccNameSpace ns (nameOccName n)) +setRdrNameSpace (Exact n) ns + | isExternalName n + = Orig (nameModule n) occ + | otherwise -- This can happen when quoting and then splicing a fixity + -- declaration for a type + = Exact $ mkSystemNameAt (nameUnique n) occ (nameSrcSpan n) + where + occ = setOccNameSpace ns (nameOccName n) -- demoteRdrName lowers the NameSpace of RdrName. -- see Note [Demotion] in OccName diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 6b464542a5..c7e1fbea9f 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -99,11 +99,11 @@ data RealSrcLoc = SrcLoc FastString -- A precise location (file name) {-# UNPACK #-} !Int -- line number, begins at 1 {-# UNPACK #-} !Int -- column number, begins at 1 - deriving Show data SrcLoc = RealSrcLoc {-# UNPACK #-}!RealSrcLoc | UnhelpfulLoc FastString -- Just a general indication + deriving Show \end{code} %************************************************************************ @@ -259,8 +259,7 @@ data RealSrcSpan srcSpanLine :: {-# UNPACK #-} !Int, srcSpanCol :: {-# UNPACK #-} !Int } - deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, because we - -- derive Show for Token + deriving (Eq, Typeable) data SrcSpan = RealSrcSpan !RealSrcSpan @@ -433,6 +432,21 @@ instance Ord SrcSpan where (srcSpanStart a `compare` srcSpanStart b) `thenCmp` (srcSpanEnd a `compare` srcSpanEnd b) +instance Show RealSrcLoc where + show (SrcLoc filename row col) + = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col + +-- Show is used by Lexer.x, because we derive Show for Token +instance Show RealSrcSpan where + show (SrcSpanOneLine file l sc ec) + = "SrcSpanOneLine " ++ show file ++ " " + ++ intercalate " " (map show [l,sc,ec]) + show (SrcSpanMultiLine file sl sc el ec) + = "SrcSpanMultiLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,el,ec]) + show (SrcSpanPoint file l c) + = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [l,c]) + instance Outputable RealSrcSpan where ppr span = pprUserRealSpan True span diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 188233d1ea..c9399b3ba1 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -992,9 +992,12 @@ lowerSafeForeignCall dflags block id <- newTemp (bWord dflags) new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg)) let (caller_save, caller_load) = callerSaveVolatileRegs dflags - load_tso <- newTemp (gcWord dflags) load_stack <- newTemp (gcWord dflags) - let suspend = saveThreadState dflags <*> + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + bdfree <- newTemp (bWord dflags) + bdstart <- newTemp (bWord dflags) + let suspend = saveThreadState dflags tso cn <*> caller_save <*> mkMiddle (callSuspendThread dflags id intrbl) midCall = mkUnsafeCall tgt res args @@ -1003,7 +1006,7 @@ lowerSafeForeignCall dflags block -- might now have a different Capability! mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*> caller_load <*> - loadThreadState dflags load_tso load_stack + loadThreadState dflags tso load_stack cn bdfree bdstart (_, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ) diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index b84cb40c69..e9215d5021 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -3,7 +3,7 @@ module CmmMachOp ( MachOp(..) , pprMachOp, isCommutableMachOp, isAssociativeMachOp - , isComparisonMachOp, machOpResultType + , isComparisonMachOp, maybeIntComparison, machOpResultType , machOpArgReps, maybeInvertComparison -- MachOp builders @@ -11,9 +11,11 @@ module CmmMachOp , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe , mo_wordULe, mo_wordUGt, mo_wordULt - , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr + , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot + , mo_wordShl, mo_wordSShr, mo_wordUShr , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 - , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord + , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord + , mo_u_32ToWord, mo_s_32ToWord , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 -- CallishMachOp @@ -260,6 +262,7 @@ isAssociativeMachOp mop = MO_Xor {} -> True _other -> False + -- ---------------------------------------------------------------------------- -- isComparisonMachOp @@ -290,6 +293,25 @@ isComparisonMachOp mop = MO_F_Lt {} -> True _other -> False +{- | +Returns @Just w@ if the operation is an integer comparison with width +@w@, or @Nothing@ otherwise. +-} +maybeIntComparison :: MachOp -> Maybe Width +maybeIntComparison mop = + case mop of + MO_Eq w -> Just w + MO_Ne w -> Just w + MO_S_Ge w -> Just w + MO_S_Le w -> Just w + MO_S_Gt w -> Just w + MO_S_Lt w -> Just w + MO_U_Ge w -> Just w + MO_U_Le w -> Just w + MO_U_Gt w -> Just w + MO_U_Lt w -> Just w + _ -> Nothing + -- ----------------------------------------------------------------------------- -- Inverting conditions diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs index f5511515a9..4fbf42e607 100644 --- a/compiler/cmm/Hoopl/Dataflow.hs +++ b/compiler/cmm/Hoopl/Dataflow.hs @@ -3,7 +3,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fprof-auto-top #-} diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index eb1c7da76d..c2e276ed0b 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -9,12 +9,15 @@ ----------------------------------------------------------------------------- module StgCmmForeign ( - cgForeignCall, loadThreadState, saveThreadState, + cgForeignCall, emitPrimCall, emitCCall, emitForeignCall, -- For CmmParse - emitSaveThreadState, -- will be needed by the Cmm parser - emitLoadThreadState, -- ditto - emitCloseNursery, emitOpenNursery + emitSaveThreadState, + saveThreadState, + emitLoadThreadState, + loadThreadState, + emitOpenNursery, + emitCloseNursery, ) where #include "HsVersions.h" @@ -271,94 +274,221 @@ maybe_assign_temp e = do -- This stuff can't be done in suspendThread/resumeThread, because it -- refers to global registers which aren't available in the C world. -saveThreadState :: DynFlags -> CmmAGraph -saveThreadState dflags = - -- CurrentTSO->stackobj->sp = Sp; - mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp - <*> closeNursery dflags - -- and save the current cost centre stack in the TSO when profiling: - <*> if gopt Opt_SccProfilingOn dflags then - mkStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS - else mkNop - emitSaveThreadState :: FCode () emitSaveThreadState = do dflags <- getDynFlags - emit (saveThreadState dflags) + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + emit $ saveThreadState dflags tso cn + + +-- saveThreadState must be usable from the stack layout pass, where we +-- don't have FCode. Therefore it takes LocalRegs as arguments, so +-- the caller can create these. +saveThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph +saveThreadState dflags tso cn = + catAGraphs [ + -- tso = CurrentTSO; + mkAssign (CmmLocal tso) stgCurrentTSO, + -- tso->stackobj->sp = Sp; + mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp, + closeNursery dflags tso cn, + -- and save the current cost centre stack in the TSO when profiling: + if gopt Opt_SccProfilingOn dflags then + mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) curCCS + else mkNop + ] emitCloseNursery :: FCode () emitCloseNursery = do - df <- getDynFlags - emit (closeNursery df) + dflags <- getDynFlags + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> + closeNursery dflags tso cn + +{- +Closing the nursery corresponds to the following code: + + tso = CurrentTSO; + cn = CurrentNuresry; - -- CurrentNursery->free = Hp+1; -closeNursery :: DynFlags -> CmmAGraph -closeNursery dflags = mkStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1) + // Update the allocation limit for the current thread. We don't + // check to see whether it has overflowed at this point, that check is + // made when we run out of space in the current heap block (stg_gc_noregs) + // and in the scheduler when context switching (schedulePostRunThread). + tso->alloc_limit -= Hp + WDS(1) - cn->start; -loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph -loadThreadState dflags tso stack = do + // Set cn->free to the next unoccupied word in the block + cn->free = Hp + WDS(1); +-} + +closeNursery :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph +closeNursery df tso cn = + let + tsoreg = CmmLocal tso + cnreg = CmmLocal cn + in catAGraphs [ - -- tso = CurrentTSO; - mkAssign (CmmLocal tso) stgCurrentTSO, - -- stack = tso->stackobj; - mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), - -- Sp = stack->sp; - mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)), - -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) - (rESERVED_STACK_WORDS dflags)), - -- HpAlloc = 0; - -- HpAlloc is assumed to be set to non-zero only by a failed - -- a heap check, see HeapStackCheck.cmm:GC_GENERIC - mkAssign hpAlloc (zeroExpr dflags), - - openNursery dflags, - -- and load the current cost centre stack from the TSO when profiling: - if gopt Opt_SccProfilingOn dflags then - storeCurCCS - (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType dflags)) - else mkNop] + mkAssign cnreg stgCurrentNursery, + + -- CurrentNursery->free = Hp+1; + mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df stgHp 1), + + let alloc = + CmmMachOp (mo_wordSub df) + [ cmmOffsetW df stgHp 1 + , CmmLoad (nursery_bdescr_start df cnreg) (bWord df) + ] + + alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df) + in + + -- tso->alloc_limit += alloc + mkStore alloc_limit (CmmMachOp (MO_Sub W64) + [ CmmLoad alloc_limit b64 + , CmmMachOp (mo_WordTo64 df) [alloc] ]) + ] emitLoadThreadState :: FCode () emitLoadThreadState = do dflags <- getDynFlags - load_tso <- newTemp (gcWord dflags) - load_stack <- newTemp (gcWord dflags) - emit $ loadThreadState dflags load_tso load_stack + tso <- newTemp (gcWord dflags) + stack <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + bdfree <- newTemp (bWord dflags) + bdstart <- newTemp (bWord dflags) + emit $ loadThreadState dflags tso stack cn bdfree bdstart + +-- loadThreadState must be usable from the stack layout pass, where we +-- don't have FCode. Therefore it takes LocalRegs as arguments, so +-- the caller can create these. +loadThreadState :: DynFlags + -> LocalReg -> LocalReg -> LocalReg -> LocalReg -> LocalReg + -> CmmAGraph +loadThreadState dflags tso stack cn bdfree bdstart = + catAGraphs [ + -- tso = CurrentTSO; + mkAssign (CmmLocal tso) stgCurrentTSO, + -- stack = tso->stackobj; + mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), + -- Sp = stack->sp; + mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)), + -- SpLim = stack->stack + RESERVED_STACK_WORDS; + mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) + (rESERVED_STACK_WORDS dflags)), + -- HpAlloc = 0; + -- HpAlloc is assumed to be set to non-zero only by a failed + -- a heap check, see HeapStackCheck.cmm:GC_GENERIC + mkAssign hpAlloc (zeroExpr dflags), + openNursery dflags tso cn bdfree bdstart, + -- and load the current cost centre stack from the TSO when profiling: + if gopt Opt_SccProfilingOn dflags + then storeCurCCS + (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) + (tso_CCCS dflags)) (ccsType dflags)) + else mkNop + ] + emitOpenNursery :: FCode () emitOpenNursery = do - df <- getDynFlags - emit (openNursery df) - -openNursery :: DynFlags -> CmmAGraph -openNursery dflags = catAGraphs [ - -- Hp = CurrentNursery->free - 1; - mkAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (bWord dflags)) (-1)), - - -- HpLim = CurrentNursery->start + - -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; - mkAssign hpLim - (cmmOffsetExpr dflags - (CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) - (cmmOffset dflags - (CmmMachOp (mo_wordMul dflags) [ - CmmMachOp (MO_SS_Conv W32 (wordWidth dflags)) - [CmmLoad (nursery_bdescr_blocks dflags) b32], - mkIntExpr dflags (bLOCK_SIZE dflags) - ]) - (-1) - ) - ) + dflags <- getDynFlags + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + bdfree <- newTemp (bWord dflags) + bdstart <- newTemp (bWord dflags) + emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> + openNursery dflags tso cn bdfree bdstart + +{- +Opening the nursery corresponds to the following code: + + tso = CurrentTSO; + cn = CurrentNursery; + bdfree = CurrentNuresry->free; + bdstart = CurrentNuresry->start; + + // We *add* the currently occupied portion of the nursery block to + // the allocation limit, because we will subtract it again in + // closeNursery. + tso->alloc_limit += bdfree - bdstart; + + // Set Hp to the last occupied word of the heap block. Why not the + // next unocupied word? Doing it this way means that we get to use + // an offset of zero more often, which might lead to slightly smaller + // code on some architectures. + Hp = bdfree - WDS(1); + + // Set HpLim to the end of the current nursery block (note that this block + // might be a block group, consisting of several adjacent blocks. + HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1; +-} + +openNursery :: DynFlags + -> LocalReg -> LocalReg -> LocalReg -> LocalReg + -> CmmAGraph +openNursery df tso cn bdfree bdstart = + let + tsoreg = CmmLocal tso + cnreg = CmmLocal cn + bdfreereg = CmmLocal bdfree + bdstartreg = CmmLocal bdstart + in + -- These assignments are carefully ordered to reduce register + -- pressure and generate not completely awful code on x86. To see + -- what code we generate, look at the assembly for + -- stg_returnToStackTop in rts/StgStartup.cmm. + catAGraphs [ + mkAssign cnreg stgCurrentNursery, + mkAssign bdfreereg (CmmLoad (nursery_bdescr_free df cnreg) (bWord df)), + + -- Hp = CurrentNursery->free - 1; + mkAssign hp (cmmOffsetW df (CmmReg bdfreereg) (-1)), + + mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)), + + -- HpLim = CurrentNursery->start + + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; + mkAssign hpLim + (cmmOffsetExpr df + (CmmReg bdstartreg) + (cmmOffset df + (CmmMachOp (mo_wordMul df) [ + CmmMachOp (MO_SS_Conv W32 (wordWidth df)) + [CmmLoad (nursery_bdescr_blocks df cnreg) b32], + mkIntExpr df (bLOCK_SIZE df) + ]) + (-1) + ) + ), + + -- alloc = bd->free - bd->start + let alloc = + CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg] + + alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df) + in + + -- tso->alloc_limit += alloc + mkStore alloc_limit (CmmMachOp (MO_Add W64) + [ CmmLoad alloc_limit b64 + , CmmMachOp (mo_WordTo64 df) [alloc] ]) + ] -nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr -nursery_bdescr_free dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags) -nursery_bdescr_start dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags) -nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags) +nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks + :: DynFlags -> CmmReg -> CmmExpr +nursery_bdescr_free dflags cn = + cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags) +nursery_bdescr_start dflags cn = + cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags) +nursery_bdescr_blocks dflags cn = + cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags) -tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff +tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) +tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags) tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 374b98ece9..537cc01b43 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -1123,7 +1123,8 @@ lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon) lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of IntegerGMP -> guardIntegerUse dflags $ liftM Just $ initTcForLookup hsc_env (tcLookupDataCon integerSDataConName) - + IntegerGMP2-> guardIntegerUse dflags $ liftM Just $ + initTcForLookup hsc_env (tcLookupDataCon integerSDataConName) IntegerSimple -> return Nothing -- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName' diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 6844f48970..ce2d5a5d4a 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -46,12 +46,14 @@ import MkCore import DynFlags import CostCentre import Id +import Unique import Module import VarSet import VarEnv import ConLike import DataCon import TysWiredIn +import PrelNames ( seqIdKey ) import BasicTypes import Maybes import SrcLoc @@ -191,7 +193,12 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e dsExpr (ExprWithTySigOut e _) = dsLExpr e -dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars] +dsExpr (HsVar var) -- See Note [Unfolding while desugaring] + | unfold_var = return $ unfoldingTemplate unfolding + | otherwise = return (varToCoreExpr var) -- See Note [Desugaring vars] + where + unfold_var = isCompulsoryUnfolding unfolding && not (var `hasKey` seqIdKey) + unfolding = idUnfolding var dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar" dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit @@ -220,6 +227,19 @@ dsExpr (HsApp fun arg) dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar" \end{code} +Note [Unfolding while desugaring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Variables with compulsory unfolding must be substituted at desugaring +time. This is needed to preserve the let/app invariant in cases where +the unfolding changes whether wrapping in a case is needed. +Suppose we have a call like this: + I# x +where 'x' has an unfolding like this: + f void# +In this case, 'mkCoreAppDs' needs to see 'f void#', not 'x', to be +able to do the right thing. + + Note [Desugaring vars] ~~~~~~~~~~~~~~~~~~~~~~ In one situation we can get a *coercion* variable in a HsVar, namely diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 24785c257f..083c466baa 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -137,26 +137,26 @@ repTopDs group@(HsGroup { hs_valds = valds -- only "T", not "Foo:T" where Foo is the current module decls <- addBinds ss ( - do { val_ds <- rep_val_binds valds - ; _ <- mapM no_splice splcds - ; tycl_ds <- mapM repTyClD (tyClGroupConcat tyclds) - ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) - ; inst_ds <- mapM repInstD instds - ; _ <- mapM no_standalone_deriv derivds - ; fix_ds <- mapM repFixD fixds - ; _ <- mapM no_default_decl defds - ; for_ds <- mapM repForD fords - ; _ <- mapM no_warn warnds - ; ann_ds <- mapM repAnnD annds - ; rule_ds <- mapM repRuleD ruleds - ; _ <- mapM no_vect vects - ; _ <- mapM no_doc docs + do { val_ds <- rep_val_binds valds + ; _ <- mapM no_splice splcds + ; tycl_ds <- mapM repTyClD (tyClGroupConcat tyclds) + ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) + ; inst_ds <- mapM repInstD instds + ; deriv_ds <- mapM repStandaloneDerivD derivds + ; fix_ds <- mapM repFixD fixds + ; _ <- mapM no_default_decl defds + ; for_ds <- mapM repForD fords + ; _ <- mapM no_warn warnds + ; ann_ds <- mapM repAnnD annds + ; rule_ds <- mapM repRuleD ruleds + ; _ <- mapM no_vect vects + ; _ <- mapM no_doc docs -- more needed ; return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds ++ inst_ds ++ rule_ds ++ for_ds - ++ ann_ds) }) ; + ++ ann_ds ++ deriv_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -169,8 +169,6 @@ repTopDs group@(HsGroup { hs_valds = valds where no_splice (L loc _) = notHandledL loc "Splices within declaration brackets" empty - no_standalone_deriv (L loc (DerivDecl { deriv_type = deriv_ty })) - = notHandledL loc "Standalone-deriving" (ppr deriv_ty) no_default_decl (L loc decl) = notHandledL loc "Default declarations" (ppr decl) no_warn (L loc (Warning thing _)) @@ -422,6 +420,18 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds where Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty +repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty })) + = do { dec <- addTyVarBinds tvs $ \_ -> + do { cxt' <- repContext cxt + ; cls_tcon <- repTy (HsTyVar (unLoc cls)) + ; cls_tys <- repLTys tys + ; inst_ty <- repTapps cls_tcon cls_tys + ; repDeriv cxt' inst_ty } + ; return (loc, dec) } + where + Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty + repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) = do { let tc_name = tyFamInstDeclLName decl @@ -662,10 +672,9 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; return (concat sigs1) } rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -rep_sig (L loc (TypeSig nms ty)) = mapM (rep_ty_sig loc ty) nms +rep_sig (L loc (TypeSig nms ty)) = mapM (rep_ty_sig sigDName loc ty) nms rep_sig (L _ (PatSynSig {})) = notHandled "Pattern type signatures" empty -rep_sig (L _ (GenericSig nm _)) = notHandled "Default type signatures" msg - where msg = text "Illegal default signature for" <+> quotes (ppr nm) +rep_sig (L loc (GenericSig nms ty)) = mapM (rep_ty_sig defaultSigDName loc ty) nms rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc @@ -673,12 +682,12 @@ rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc rep_sig (L loc (SpecInstSig ty)) = rep_specialiseInst ty loc rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty -rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name +rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name -> DsM (SrcSpan, Core TH.DecQ) -rep_ty_sig loc (L _ ty) nm +rep_ty_sig mk_sig loc (L _ ty) nm = do { nm1 <- lookupLOcc nm ; ty1 <- rep_ty ty - ; sig <- repProto nm1 ty1 + ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } where -- We must special-case the top-level explicit for-all of a TypeSig @@ -693,7 +702,6 @@ rep_ty_sig loc (L _ ty) nm rep_ty ty = repTy ty - rep_inline :: Located Name -> InlinePragma -- Never defaultInlinePragma -> SrcSpan @@ -1741,6 +1749,9 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds] +repDeriv :: Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repDeriv (MkC cxt) (MkC ty) = rep2 standaloneDerivDName [cxt, ty] + repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch -> Core TH.Phases -> DsM (Core TH.DecQ) repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases) @@ -1807,8 +1818,8 @@ repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles] repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep) repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] -repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) -repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty] +repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] @@ -2105,9 +2116,9 @@ templateHaskellNames = [ bindSName, letSName, noBindSName, parSName, -- Dec funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceDName, sigDName, forImpDName, + classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, - pragRuleDName, pragAnnDName, + pragRuleDName, pragAnnDName, defaultSigDName, familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, infixLDName, infixRDName, infixNDName, @@ -2333,7 +2344,7 @@ parSName = libFun (fsLit "parS") parSIdKey funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName, - familyNoKindDName, + familyNoKindDName, standaloneDerivDName, defaultSigDName, familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name @@ -2344,7 +2355,10 @@ newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey tySynDName = libFun (fsLit "tySynD") tySynDIdKey classDName = libFun (fsLit "classD") classDIdKey instanceDName = libFun (fsLit "instanceD") instanceDIdKey +standaloneDerivDName + = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey sigDName = libFun (fsLit "sigD") sigDIdKey +defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey forImpDName = libFun (fsLit "forImpD") forImpDIdKey pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey @@ -2696,8 +2710,8 @@ parSIdKey = mkPreludeMiscIdUnique 323 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey, - pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey, - dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, + pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey, defaultSigDIdKey, + dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey, closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey, infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 330 @@ -2726,6 +2740,8 @@ infixLDIdKey = mkPreludeMiscIdUnique 352 infixRDIdKey = mkPreludeMiscIdUnique 353 infixNDIdKey = mkPreludeMiscIdUnique 354 roleAnnotDIdKey = mkPreludeMiscIdUnique 355 +standaloneDerivDIdKey = mkPreludeMiscIdUnique 356 +defaultSigDIdKey = mkPreludeMiscIdUnique 357 -- type Cxt = ... cxtIdKey :: Unique diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index c017a7cc01..1c707c4afc 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -221,7 +221,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside } where -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of - -- * 'Data.Array.Parallel' iff '-XParallalArrays' specified (see also 'checkLoadDAP'). + -- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP'). -- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified. loadDAP thing_inside = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr diff --git a/compiler/ghc.mk b/compiler/ghc.mk index b5f5dbce8f..fb8aa730e8 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -53,8 +53,10 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo >> $@ @echo '#include "ghc_boot_platform.h"' >> $@ @echo >> $@ - @echo 'data IntegerLibrary = IntegerGMP | IntegerSimple' >> $@ - @echo ' deriving Eq' >> $@ + @echo 'data IntegerLibrary = IntegerGMP' >> $@ + @echo ' | IntegerGMP2' >> $@ + @echo ' | IntegerSimple' >> $@ + @echo ' deriving Eq' >> $@ @echo >> $@ @echo 'cBuildPlatformString :: String' >> $@ @echo 'cBuildPlatformString = BuildPlatform_NAME' >> $@ @@ -84,6 +86,8 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cIntegerLibraryType :: IntegerLibrary' >> $@ ifeq "$(INTEGER_LIBRARY)" "integer-gmp" @echo 'cIntegerLibraryType = IntegerGMP' >> $@ +else ifeq "$(INTEGER_LIBRARY)" "integer-gmp2" + @echo 'cIntegerLibraryType = IntegerGMP2' >> $@ else ifeq "$(INTEGER_LIBRARY)" "integer-simple" @echo 'cIntegerLibraryType = IntegerSimple' >> $@ else ifneq "$(CLEANING)" "YES" @@ -570,6 +574,7 @@ compiler_stage2_dll0_MODULES = \ StringBuffer \ TcEvidence \ TcIface \ + TcMType \ TcRnMonad \ TcRnTypes \ TcType \ diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 43d9bfb4e9..9ad594c698 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -6,7 +6,6 @@ This module converts Template Haskell syntax into HsSyn \begin{code} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE CPP #-} module Convert( convertToHsExpr, convertToPat, convertToHsDecls, @@ -44,7 +43,6 @@ import Control.Applicative (Applicative(..)) import Data.Maybe( catMaybes ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH -import GHC.Exts ------------------------------------------------------------------- -- The external interface @@ -172,7 +170,11 @@ cvtDec (TH.SigD nm typ) ; returnJustL $ Hs.SigD (TypeSig [nm'] ty') } cvtDec (TH.InfixD fx nm) - = do { nm' <- vNameL nm + -- fixity signatures are allowed for variables, constructors, and types + -- the renamer automatically looks for types during renaming, even when + -- the RdrName says it's a variable or a constructor. So, just assume + -- it's a variable or constructor and proceed. + = do { nm' <- vcNameL nm ; returnJustL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) } cvtDec (PragmaD prag) @@ -303,6 +305,18 @@ cvtDec (TH.RoleAnnotD tc roles) = do { tc' <- tconNameL tc ; let roles' = map (noLoc . cvtRole) roles ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') } + +cvtDec (TH.StandaloneDerivD cxt ty) + = do { cxt' <- cvtContext cxt + ; L loc ty' <- cvtType ty + ; let inst_ty' = L loc $ mkImplicitHsForAllTy cxt' $ L loc ty' + ; returnJustL $ DerivD $ + DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } } + +cvtDec (TH.DefaultSigD nm typ) + = do { nm' <- vNameL nm + ; ty' <- cvtType typ + ; returnJustL $ Hs.SigD $ GenericSig [nm'] ty' } ---------------- cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) cvtTySynEqn tc (TySynEqn lhs rhs) @@ -521,7 +535,7 @@ cvtPragmaD (AnnP target exp) n' <- tconName n return (TypeAnnProvenance n') ValueAnnotation n -> do - n' <- if isVarName n then vName n else cName n + n' <- vcName n return (ValueAnnProvenance n') ; returnJustL $ Hs.AnnD $ HsAnnotation target' exp' } @@ -1071,9 +1085,10 @@ cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = -------------------------------------------------------------------- -- variable names -vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) -vName, cName, tName, tconName :: TH.Name -> CvtM RdrName +vNameL, cNameL, vcNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) +vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName +-- Variable names vNameL n = wrapL (vName n) vName n = cvtName OccName.varName n @@ -1081,6 +1096,10 @@ vName n = cvtName OccName.varName n cNameL n = wrapL (cName n) cName n = cvtName OccName.dataName n +-- Variable *or* constructor names; check by looking at the first char +vcNameL n = wrapL (vcName n) +vcName n = if isVarName n then vName n else cName n + -- Type variable names tName n = cvtName OccName.tvName n @@ -1181,8 +1200,8 @@ mk_mod mod = mkModuleName (TH.modString mod) mk_pkg :: TH.PkgName -> PackageKey mk_pkg pkg = stringToPackageKey (TH.pkgString pkg) -mk_uniq :: Int# -> Unique -mk_uniq u = mkUniqueGrimily (I# u) +mk_uniq :: Int -> Unique +mk_uniq u = mkUniqueGrimily u \end{code} Note [Binders in Template Haskell] diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 12e2388684..df2406fcd3 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -28,7 +28,7 @@ module HsUtils( mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdCast, - nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, + nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, toHsType, toHsKind, @@ -177,6 +177,9 @@ mkSimpleHsAlt pat expr nlHsTyApp :: name -> [Type] -> LHsExpr name nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id)) +nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name +nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs + --------- Adding parens --------- mkLHsPar :: LHsExpr name -> LHsExpr name -- Wrap in parens if hsExprNeedsParens says it needs them diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index d90e63c972..106a15fc9a 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -179,7 +179,7 @@ mkDataConStupidTheta tycon arg_tys univ_tvs ------------------------------------------------------ buildPatSyn :: Name -> Bool - -> Id -> Maybe Id + -> Id -> Maybe (Id, Id) -> ([TyVar], ThetaType) -- ^ Univ and req -> ([TyVar], ThetaType) -- ^ Ex and prov -> [Type] -- ^ Argument types diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 5cfe773dc8..c2b7c5276b 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -128,7 +128,7 @@ data IfaceDecl | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym ifPatIsInfix :: Bool, ifPatMatcher :: IfExtName, - ifPatWrapper :: Maybe IfExtName, + ifPatWorker :: Maybe IfExtName, -- Everything below is redundant, -- but needed to implement pprIfaceDecl ifPatUnivTvs :: [IfaceTvBndr], @@ -759,15 +759,15 @@ pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax) pp_branches _ = Outputable.empty -pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper, +pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWorker = worker, ifPatIsInfix = is_infix, ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs, ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, ifPatArgs = args, ifPatTy = ty }) - = pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt) + = pprPatSynSig name is_bidirectional args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt) where - has_wrap = isJust wrapper + is_bidirectional = isJust worker args' = case (is_infix, args) of (True, [left_ty, right_ty]) -> InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty) @@ -1131,7 +1131,7 @@ freeNamesIfDecl d@IfaceAxiom{} = fnList freeNamesIfAxBranch (ifAxBranches d) freeNamesIfDecl d@IfacePatSyn{} = unitNameSet (ifPatMatcher d) &&& - maybe emptyNameSet unitNameSet (ifPatWrapper d) &&& + maybe emptyNameSet unitNameSet (ifPatWorker d) &&& freeNamesIfTvBndrs (ifPatUnivTvs d) &&& freeNamesIfTvBndrs (ifPatExTvs d) &&& freeNamesIfContext (ifPatProvCtxt d) &&& diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index faaea6c456..3b2f7f25c9 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -92,7 +92,7 @@ loadSrcInterface doc mod want_boot maybe_pkg Failed err -> failWithTc err Succeeded iface -> return iface } --- | Like loadSrcInterface, but returns a MaybeErr +-- | Like 'loadSrcInterface', but returns a 'MaybeErr'. loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? @@ -111,7 +111,10 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) err -> return (Failed (cannotFindInterface (hsc_dflags hsc_env) mod err)) } --- | Load interface for a module. +-- | Load interface directly for a fully qualified 'Module'. (This is a fairly +-- rare operation, but in particular it is used to load orphan modules +-- in order to pull their instances into the global package table and to +-- handle some operations in GHCi). loadModuleInterface :: SDoc -> Module -> TcM ModIface loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 78111b299e..95fe479447 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1534,7 +1534,7 @@ patSynToIfaceDecl :: PatSyn -> IfaceDecl patSynToIfaceDecl ps = IfacePatSyn { ifName = getOccName . getName $ ps , ifPatMatcher = matcher - , ifPatWrapper = wrapper + , ifPatWorker = worker , ifPatIsInfix = patSynIsInfix ps , ifPatUnivTvs = toIfaceTvBndrs univ_tvs' , ifPatExTvs = toIfaceTvBndrs ex_tvs' @@ -1549,7 +1549,7 @@ patSynToIfaceDecl ps (env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs matcher = idName (patSynMatcher ps) - wrapper = fmap idName (patSynWrapper ps) + worker = fmap idName (patSynWorker ps) -------------------------- diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 65345ec3c8..85ea0f94cc 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -14,7 +14,8 @@ module TcIface ( tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceExpr, -- Desired by HERMIT (Trac #7683) - tcIfaceGlobal + tcIfaceGlobal, + mkPatSynWrapperId, mkPatSynWorkerId -- Have to be here to avoid circular import ) where #include "HsVersions.h" @@ -27,7 +28,8 @@ import BuildTyCl import TcRnMonad import TcType import Type -import Coercion +import TcMType +import Coercion hiding (substTy) import TypeRep import HscTypes import Annotations @@ -37,7 +39,7 @@ import CoreSyn import CoreUtils import CoreUnfold import CoreLint -import MkCore ( castBottomExpr ) +import MkCore import Id import MkId import IdInfo @@ -75,6 +77,7 @@ import qualified Data.Map as Map #if __GLASGOW_HASKELL__ < 709 import Data.Traversable ( traverse ) #endif +import Data.Traversable ( for ) \end{code} This module takes @@ -181,9 +184,9 @@ We need to make sure that we have at least *read* the interface files for any module with an instance decl or RULE that we might want. * If the instance decl is an orphan, we have a whole separate mechanism - (loadOprhanModules) + (loadOrphanModules) -* If the instance decl not an orphan, then the act of looking at the +* If the instance decl is not an orphan, then the act of looking at the TyCon or Class will force in the defining module for the TyCon/Class, and hence the instance decl @@ -582,7 +585,7 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name , ifPatMatcher = matcher_name - , ifPatWrapper = wrapper_name + , ifPatWorker = worker_name , ifPatIsInfix = is_infix , ifPatUnivTvs = univ_tvs , ifPatExTvs = ex_tvs @@ -593,10 +596,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name = do { name <- lookupIfaceTop occ_name ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name) ; matcher <- tcExt "Matcher" matcher_name - ; wrapper <- case wrapper_name of - Nothing -> return Nothing - Just wn -> do { wid <- tcExt "Wrapper" wn - ; return (Just wid) } + ; worker <- traverse (tcExt "Worker") worker_name ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do { bindIfaceTyVars ex_tvs $ \ex_tvs -> do { patsyn <- forkM (mk_doc name) $ @@ -604,6 +604,14 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name ; req_theta <- tcIfaceCtxt req_ctxt ; pat_ty <- tcIfaceType pat_ty ; arg_tys <- mapM tcIfaceType args + ; wrapper <- for worker $ \worker_id -> do + { wrapper_id <- mkPatSynWrapperId (noLoc name) + (univ_tvs ++ ex_tvs) + (req_theta ++ prov_theta) + arg_tys pat_ty + worker_id + ; return (wrapper_id, worker_id) + } ; return $ buildPatSyn name is_infix matcher wrapper (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty } @@ -1520,3 +1528,41 @@ bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside bindIfaceTyVars_AT bs $ \bs' -> thing_inside (b':bs') } \end{code} + +%************************************************************************ +%* * + PatSyn wrapper/worker helpers +%* * +%************************************************************************ + +\begin{code} +-- These are here (and not in TcPatSyn) just to avoid circular imports. + +mkPatSynWrapperId :: Located Name + -> [TyVar] -> ThetaType -> [Type] -> Type + -> Id + -> TcRnIf gbl lcl Id +mkPatSynWrapperId name qtvs theta arg_tys pat_ty worker_id + | need_dummy_arg = do + { wrapper_id <- mkPatSynWorkerId name mkDataConWrapperOcc qtvs theta arg_tys pat_ty + ; let unfolding = mkCoreApp (Var worker_id) (Var voidPrimId) + wrapper_id' = setIdUnfolding wrapper_id $ mkCompulsoryUnfolding unfolding + ; return wrapper_id' } + | otherwise = return worker_id -- No indirection needed + where + need_dummy_arg = null arg_tys && isUnLiftedType pat_ty + +mkPatSynWorkerId :: Located Name -> (OccName -> OccName) + -> [TyVar] -> ThetaType -> [Type] -> Type + -> TcRnIf gbl loc Id +mkPatSynWorkerId (L loc name) mk_occ_name qtvs theta arg_tys pat_ty + = do { worker_name <- newImplicitBinder name mk_occ_name + ; (subst, worker_tvs) <- tcInstSigTyVarsLoc loc qtvs + ; let worker_theta = substTheta subst theta + pat_ty' = substTy subst pat_ty + arg_tys' = map (substTy subst) arg_tys + worker_tau = mkFunTys arg_tys' pat_ty' + -- TODO: just substitute worker_sigma... + worker_sigma = mkSigmaTy worker_tvs worker_theta worker_tau + ; return $ mkVanillaGlobal worker_name worker_sigma } +\end{code} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 0c6639a048..043174f3b0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -482,6 +482,7 @@ data WarningFlag = | Opt_WarnAlternativeLayoutRuleTransitional | Opt_WarnUnsafe | Opt_WarnSafe + | Opt_WarnTrustworthySafe | Opt_WarnPointlessPragmas | Opt_WarnUnsupportedCallingConventions | Opt_WarnUnsupportedLlvmVersion @@ -778,6 +779,7 @@ data DynFlags = DynFlags { pkgTrustOnLoc :: SrcSpan, warnSafeOnLoc :: SrcSpan, warnUnsafeOnLoc :: SrcSpan, + trustworthyOnLoc :: SrcSpan, -- Don't change this without updating extensionFlags: extensions :: [OnOff ExtensionFlag], -- extensionFlags should always be equal to @@ -1466,6 +1468,7 @@ defaultDynFlags mySettings = pkgTrustOnLoc = noSrcSpan, warnSafeOnLoc = noSrcSpan, warnUnsafeOnLoc = noSrcSpan, + trustworthyOnLoc = noSrcSpan, extensions = [], extensionFlags = flattenExtensionFlags Nothing [], @@ -1758,11 +1761,15 @@ setSafeHaskell s = updM f where f dfs = do let sf = safeHaskell dfs safeM <- combineSafeFlags sf s - return $ case (s == Sf_Safe || s == Sf_Unsafe) of - True -> dfs { safeHaskell = safeM, safeInfer = False } + case s of + Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } -- leave safe inferrence on in Trustworthy mode so we can warn -- if it could have been inferred safe. - False -> dfs { safeHaskell = safeM } + Sf_Trustworthy -> do + l <- getCurLoc + return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } + -- leave safe inference on in Unsafe mode as well. + _ -> return $ dfs { safeHaskell = safeM } -- | Are all direct imports required to be safe for this Safe Haskell mode? -- Direct imports are when the code explicitly imports a module @@ -2663,6 +2670,7 @@ fWarningFlags = [ ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns, nop ), ( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ), ( "warn-safe", Opt_WarnSafe, setWarnSafe ), + ( "warn-trustworthy-safe", Opt_WarnTrustworthySafe, nop ), ( "warn-tabs", Opt_WarnTabs, nop ), ( "warn-type-defaults", Opt_WarnTypeDefaults, nop ), ( "warn-typed-holes", Opt_WarnTypedHoles, nop ), diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index bec66f858a..c9baa5ac3e 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -412,19 +412,27 @@ tcRnModule' hsc_env sum save_rn_syntax mod = do -- end of the safe haskell line, how to respond to user? if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK) -- if safe Haskell off or safe infer failed, mark unsafe - then markUnsafe tcg_res emptyBag + then markUnsafeInfer tcg_res emptyBag -- module (could be) safe, throw warning if needed else do tcg_res' <- hscCheckSafeImports tcg_res safe <- liftIO $ readIORef (tcg_safeInfer tcg_res') - when (safe && wopt Opt_WarnSafe dflags) - (logWarnings $ unitBag $ mkPlainWarnMsg dflags - (warnSafeOnLoc dflags) $ errSafe tcg_res') + when safe $ do + case wopt Opt_WarnSafe dflags of + True -> (logWarnings $ unitBag $ mkPlainWarnMsg dflags + (warnSafeOnLoc dflags) $ errSafe tcg_res') + False | safeHaskell dflags == Sf_Trustworthy && + wopt Opt_WarnTrustworthySafe dflags -> + (logWarnings $ unitBag $ mkPlainWarnMsg dflags + (trustworthyOnLoc dflags) $ errTwthySafe tcg_res') + False -> return () return tcg_res' where pprMod t = ppr $ moduleName $ tcg_mod t errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" + errTwthySafe t = quotes (pprMod t) + <+> text "is marked as Trustworthy but has been inferred as safe!" -- | Convert a typechecked module to Core hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts @@ -762,6 +770,18 @@ hscFileFrontEnd mod_summary = do -- * For modules explicitly marked -XSafe, we throw the errors. -- * For unmarked modules (inference mode), we drop the errors -- and mark the module as being Unsafe. +-- +-- It used to be that we only did safe inference on modules that had no Safe +-- Haskell flags, but now we perform safe inference on all modules as we want +-- to allow users to set the `--fwarn-safe`, `--fwarn-unsafe` and +-- `--fwarn-trustworthy-safe` flags on Trustworthy and Unsafe modules so that a +-- user can ensure their assumptions are correct and see reasons for why a +-- module is safe or unsafe. +-- +-- This is tricky as we must be careful when we should throw an error compared +-- to just warnings. For checking safe imports we manage it as two steps. First +-- we check any imports that are required to be safe, then we check all other +-- imports to see if we can infer them to be safe. -- | Check that the safe imports of the module being compiled are valid. @@ -772,21 +792,24 @@ hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv hscCheckSafeImports tcg_env = do dflags <- getDynFlags tcg_env' <- checkSafeImports dflags tcg_env - case safeLanguageOn dflags of - True -> do - -- XSafe: we nuke user written RULES - logWarnings $ warns dflags (tcg_rules tcg_env') - return tcg_env' { tcg_rules = [] } - False - -- SafeInferred: user defined RULES, so not safe - | safeInferOn dflags && not (null $ tcg_rules tcg_env') - -> markUnsafe tcg_env' $ warns dflags (tcg_rules tcg_env') - - -- Trustworthy OR SafeInferred: with no RULES - | otherwise - -> return tcg_env' + checkRULES dflags tcg_env' where + checkRULES dflags tcg_env' = do + case safeLanguageOn dflags of + True -> do + -- XSafe: we nuke user written RULES + logWarnings $ warns dflags (tcg_rules tcg_env') + return tcg_env' { tcg_rules = [] } + False + -- SafeInferred: user defined RULES, so not safe + | safeInferOn dflags && not (null $ tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') + + -- Trustworthy OR SafeInferred: with no RULES + | otherwise + -> return tcg_env' + warns dflags rules = listToBag $ map (warnRules dflags) rules warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) = mkPlainWarnMsg dflags loc $ @@ -808,51 +831,55 @@ hscCheckSafeImports tcg_env = do checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv checkSafeImports dflags tcg_env = do + imps <- mapM condense imports' + let (safeImps, regImps) = partition (\(_,_,s) -> s) imps + -- We want to use the warning state specifically for detecting if safe -- inference has failed, so store and clear any existing warnings. oldErrs <- getWarnings clearWarnings - imps <- mapM condense imports' - pkgs <- mapM checkSafe imps - - -- grab any safe haskell specific errors and restore old warnings - errs <- getWarnings + -- Check safe imports are correct + safePkgs <- mapM checkSafe safeImps + safeErrs <- getWarnings clearWarnings - logWarnings oldErrs + -- Check non-safe imports are correct if inferring safety -- See the Note [Safe Haskell Inference] - case (not $ isEmptyBag errs) of - - -- We have errors! - True -> - -- did we fail safe inference or fail -XSafe? - case safeInferOn dflags of - True -> markUnsafe tcg_env errs - False -> liftIO . throwIO . mkSrcErr $ errs - - -- All good matey! - False -> do - when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs - -- add in trusted package requirements for this module - let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs } - return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust } + (infErrs, infPkgs) <- case (safeInferOn dflags) of + False -> return (emptyBag, []) + True -> do infPkgs <- mapM checkSafe regImps + infErrs <- getWarnings + clearWarnings + return (infErrs, infPkgs) + + -- restore old errors + logWarnings oldErrs + + case (isEmptyBag safeErrs) of + -- Failed safe check + False -> liftIO . throwIO . mkSrcErr $ safeErrs + + -- Passed safe check + True -> do + let infPassed = isEmptyBag infErrs + tcg_env' <- case (not infPassed) of + True -> markUnsafeInfer tcg_env infErrs + False -> return tcg_env + when (packageTrustOn dflags) $ checkPkgTrust dflags pkgReqs + let newTrust = pkgTrustReqs safePkgs infPkgs infPassed + return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } where - imp_info = tcg_imports tcg_env -- ImportAvails - imports = imp_mods imp_info -- ImportedMods + impInfo = tcg_imports tcg_env -- ImportAvails + imports = imp_mods impInfo -- ImportedMods imports' = moduleEnvToList imports -- (Module, [ImportedModsVal]) - pkg_reqs = imp_trust_pkgs imp_info -- [PackageKey] + pkgReqs = imp_trust_pkgs impInfo -- [PackageKey] condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) condense (_, []) = panic "HscMain.condense: Pattern match failure!" condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs - -- we turn all imports into safe ones when - -- inference mode is on. - let s' = if safeInferOn dflags && - safeHaskell dflags == Sf_None - then True else s - return (m, l, s') + return (m, l, s) -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal @@ -865,8 +892,17 @@ checkSafeImports dflags tcg_env = return v1 -- easier interface to work with - checkSafe (_, _, False) = return Nothing - checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l + checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l + + -- what pkg's to add to our trust requirements + pkgTrustReqs req inf infPassed | safeInferOn dflags + && safeHaskell dflags == Sf_None && infPassed + = emptyImportAvails { + imp_trust_pkgs = catMaybes req ++ catMaybes inf + } + pkgTrustReqs _ _ _ | safeHaskell dflags == Sf_Unsafe + = emptyImportAvails + pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = catMaybes req } -- | Check that a module is safe to import. -- @@ -1000,11 +1036,16 @@ checkPkgTrust dflags pkgs = -- | Set module to unsafe and (potentially) wipe trust information. -- --- Make sure to call this method to set a module to inferred unsafe, --- it should be a central and single failure method. We only wipe the trust --- information when we aren't in a specific Safe Haskell mode. -markUnsafe :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv -markUnsafe tcg_env whyUnsafe = do +-- Make sure to call this method to set a module to inferred unsafe, it should +-- be a central and single failure method. We only wipe the trust information +-- when we aren't in a specific Safe Haskell mode. +-- +-- While we only use this for recording that a module was inferred unsafe, we +-- may call it on modules using Trustworthy or Unsafe flags so as to allow +-- warning flags for safety to function correctly. See Note [Safe Haskell +-- Inference]. +markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv +markUnsafeInfer tcg_env whyUnsafe = do dflags <- getDynFlags when (wopt Opt_WarnUnsafe dflags) diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index 3f2bf1680b..b94ea65a65 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -75,6 +75,25 @@ instance Outputable SourcePackageId where instance Outputable PackageName where ppr (PackageName str) = ftext str +-- | Pretty-print an 'ExposedModule' in the same format used by the textual +-- installed package database. +pprExposedModule :: (Outputable a, Outputable b) => ExposedModule a b -> SDoc +pprExposedModule (ExposedModule exposedName exposedReexport exposedSignature) = + sep [ ppr exposedName + , case exposedReexport of + Just m -> sep [text "from", pprOriginalModule m] + Nothing -> empty + , case exposedSignature of + Just m -> sep [text "is", pprOriginalModule m] + Nothing -> empty + ] + +-- | Pretty-print an 'OriginalModule' in the same format used by the textual +-- installed package database. +pprOriginalModule :: (Outputable a, Outputable b) => OriginalModule a b -> SDoc +pprOriginalModule (OriginalModule originalPackageId originalModuleName) = + ppr originalPackageId <> char ':' <> ppr originalModuleName + defaultPackageConfig :: PackageConfig defaultPackageConfig = emptyInstalledPackageInfo @@ -101,9 +120,11 @@ pprPackageConfig InstalledPackageInfo {..} = field "id" (ppr installedPackageId), field "key" (ppr packageKey), field "exposed" (ppr exposed), - field "exposed-modules" (fsep (map ppr exposedModules)), + field "exposed-modules" + (if all isExposedModule exposedModules + then fsep (map pprExposedModule exposedModules) + else pprWithCommas pprExposedModule exposedModules), field "hidden-modules" (fsep (map ppr hiddenModules)), - field "reexported-modules" (fsep (map ppr haddockHTMLs)), field "trusted" (ppr trusted), field "import-dirs" (fsep (map text importDirs)), field "library-dirs" (fsep (map text libraryDirs)), @@ -122,6 +143,8 @@ pprPackageConfig InstalledPackageInfo {..} = ] where field name body = text name <> colon <+> nest 4 body + isExposedModule (ExposedModule _ Nothing Nothing) = True + isExposedModule _ = False -- ----------------------------------------------------------------------------- diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index a308a990d1..519353e0bb 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -35,7 +35,6 @@ module Packages ( collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, - ModuleExport(..), -- * Utils packageKeyPackageIdString, @@ -211,17 +210,6 @@ originEmpty :: ModuleOrigin -> Bool originEmpty (ModOrigin Nothing [] [] False) = True originEmpty _ = False --- | When we do a plain lookup (e.g. for an import), initially, all we want --- to know is if we can find it or not (and if we do and it's a reexport, --- what the real name is). If the find fails, we'll want to investigate more --- to give a good error message. -data SimpleModuleConf = - SModConf Module PackageConfig ModuleOrigin - | SModConfAmbiguous - --- | 'UniqFM' map from 'ModuleName' -type ModuleNameMap = UniqFM - -- | 'UniqFM' map from 'PackageKey' type PackageKeyMap = UniqFM @@ -253,10 +241,6 @@ data PackageState = PackageState { -- is always mentioned before the packages it depends on. preloadPackages :: [PackageKey], - -- | This is a simplified map from 'ModuleName' to original 'Module' and - -- package configuration providing it. - moduleToPkgConf :: ModuleNameMap SimpleModuleConf, - -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want -- to report them in error messages), or it may be an ambiguous import. @@ -997,7 +981,6 @@ mkPackageState dflags pkgs0 preload0 this_package = do let pstate = PackageState{ preloadPackages = dep_preload, pkgIdMap = pkg_db, - moduleToPkgConf = mkModuleToPkgConf dflags pkg_db ipid_map vis_map, moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map, installedPackageIdMap = ipid_map } @@ -1047,16 +1030,17 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo ppr orig <+> text "in package" <+> ppr pk))) es :: Bool -> [(ModuleName, e)] - es e = - [(m, sing pk m pkg (fromExposedModules e)) | m <- exposed_mods] ++ - [(m, sing pk' m' pkg' (fromReexportedModules e pkg)) - | ModuleExport { - exportModuleName = m, - exportOriginalPackageId = ipid', - exportOriginalModuleName = m' - } <- reexported_mods - , let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) - pkg' = pkg_lookup pk' ] + es e = do + -- TODO: signature support + ExposedModule m exposedReexport _exposedSignature <- exposed_mods + let (pk', m', pkg', origin') = + case exposedReexport of + Nothing -> (pk, m, pkg, fromExposedModules e) + Just (OriginalModule ipid' m') -> + let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) + pkg' = pkg_lookup pk' + in (pk', m', pkg', fromReexportedModules e pkg') + return (m, sing pk' m' pkg' origin') esmap :: UniqFM e esmap = listToUFM (es False) -- parameter here doesn't matter, orig will @@ -1068,32 +1052,8 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db exposed_mods = exposedModules pkg - reexported_mods = reexportedModules pkg hidden_mods = hiddenModules pkg --- | This is a quick and efficient module map, which only contains an entry --- if it is specified unambiguously. -mkModuleToPkgConf - :: DynFlags - -> PackageConfigMap - -> InstalledPackageIdMap - -> VisibilityMap - -> ModuleNameMap SimpleModuleConf -mkModuleToPkgConf = - mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo - where emptyMap = emptyUFM - sing pk m pkg = SModConf (mkModule pk m) pkg - -- NB: don't put hidden entries in the map, they're not valid! - addListTo m xs = addListToUFM_C merge m (filter isVisible xs) - isVisible (_, SModConf _ _ o) = originVisible o - isVisible (_, SModConfAmbiguous) = False - merge (SModConf m pkg o) (SModConf m' _ o') - | m == m' = SModConf m pkg (o `mappend` o') - | otherwise = SModConfAmbiguous - merge _ _ = SModConfAmbiguous - setOrigins (SModConf m pkg _) os = SModConf m pkg os - setOrigins SModConfAmbiguous _ = SModConfAmbiguous - -- | This is a slow and complete map, which includes information about -- everything, including hidden modules mkModuleToPkgConfAll @@ -1241,17 +1201,11 @@ lookupModuleWithSuggestions :: DynFlags -> Maybe FastString -> LookupResult lookupModuleWithSuggestions dflags m mb_pn - = case lookupUFM (moduleToPkgConf pkg_state) m of - Just (SModConf m pkg o) | matches mb_pn pkg o -> - ASSERT( originVisible o ) LookupFound m pkg - _ -> case Map.lookup m (moduleToPkgConfAll pkg_state) of + = case Map.lookup m (moduleToPkgConfAll pkg_state) of Nothing -> LookupNotFound suggestions Just xs -> case foldl' classify ([],[],[]) (Map.toList xs) of ([], [], []) -> LookupNotFound suggestions - -- NB: Yes, we have to check this case too, since package qualified - -- imports could cause the main lookup to fail due to ambiguity, - -- but the second lookup to succeed. (_, _, [(m, _)]) -> LookupFound m (mod_pkg m) (_, _, exposed@(_:_)) -> LookupMultiple exposed (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod @@ -1269,9 +1223,6 @@ lookupModuleWithSuggestions dflags m mb_pn pkg_state = pkgState dflags mod_pkg = pkg_lookup . modulePackageKey - matches Nothing _ _ = True -- shortcut for efficiency - matches mb_pn pkg o = originVisible (filterOrigin mb_pn pkg o) - -- Filters out origins which are not associated with the given package -- qualifier. No-op if there is no package qualifier. Test if this -- excluded all origins with 'originEmpty'. diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index a975fdd5ac..b7a867d718 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -421,7 +421,7 @@ lookup_aux_id :: TypeEnv -> Var -> Id lookup_aux_id type_env id = case lookupTypeEnv type_env (idName id) of Just (AnId id') -> id' - _other -> pprPanic "lookup_axu_id" (ppr id) + _other -> pprPanic "lookup_aux_id" (ppr id) \end{code} diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index abd87ed087..a4115a0b6d 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -391,6 +391,21 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do ADC II32 (OpReg r2hi) (OpReg rhi) ] return (ChildCode64 code rlo) +iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + ChildCode64 code2 r2lo <- iselExpr64 e2 + (rlo,rhi) <- getNewRegPairNat II32 + let + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + SUB II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + SBB II32 (OpReg r2hi) (OpReg rhi) ] + return (ChildCode64 code rlo) + iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do fn <- getAnyReg expr r_dst_lo <- getNewRegNat II32 @@ -1272,24 +1287,23 @@ getCondCode (CmmMachOp mop [x, y]) MO_F_Lt W64 -> condFltCode LTT x y MO_F_Le W64 -> condFltCode LE x y - MO_Eq _ -> condIntCode EQQ x y - MO_Ne _ -> condIntCode NE x y - - MO_S_Gt _ -> condIntCode GTT x y - MO_S_Ge _ -> condIntCode GE x y - MO_S_Lt _ -> condIntCode LTT x y - MO_S_Le _ -> condIntCode LE x y - - MO_U_Gt _ -> condIntCode GU x y - MO_U_Ge _ -> condIntCode GEU x y - MO_U_Lt _ -> condIntCode LU x y - MO_U_Le _ -> condIntCode LEU x y - - _other -> pprPanic "getCondCode(x86,x86_64)" (ppr (CmmMachOp mop [x,y])) + _ -> condIntCode (machOpToCond mop) x y getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other) - +machOpToCond :: MachOp -> Cond +machOpToCond mo = case mo of + MO_Eq _ -> EQQ + MO_Ne _ -> NE + MO_S_Gt _ -> GTT + MO_S_Ge _ -> GE + MO_S_Lt _ -> LTT + MO_S_Le _ -> LE + MO_U_Gt _ -> GU + MO_U_Ge _ -> GEU + MO_U_Lt _ -> LU + MO_U_Le _ -> LEU + _other -> pprPanic "machOpToCond" (pprMachOp mo) -- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be @@ -1538,7 +1552,31 @@ genCondJump -> CmmExpr -- the condition on which to branch -> NatM InstrBlock -genCondJump id bool = do +genCondJump id expr = do + is32Bit <- is32BitPlatform + genCondJump' is32Bit id expr + +genCondJump' :: Bool -> BlockId -> CmmExpr -> NatM InstrBlock + +-- 64-bit integer comparisons on 32-bit +genCondJump' is32Bit true (CmmMachOp mop [e1,e2]) + | is32Bit, Just W64 <- maybeIntComparison mop = do + ChildCode64 code1 r1_lo <- iselExpr64 e1 + ChildCode64 code2 r2_lo <- iselExpr64 e2 + let r1_hi = getHiVRegFromLo r1_lo + r2_hi = getHiVRegFromLo r2_lo + cond = machOpToCond mop + Just cond' = maybeFlipCond cond + false <- getBlockIdNat + return $ code1 `appOL` code2 `appOL` toOL [ + CMP II32 (OpReg r2_hi) (OpReg r1_hi), + JXX cond true, + JXX cond' false, + CMP II32 (OpReg r2_lo) (OpReg r1_lo), + JXX cond true, + NEWBLOCK false ] + +genCondJump' _ id bool = do CondCode is_float cond cond_code <- getCondCode bool use_sse2 <- sse2Enabled if not is_float || not use_sse2 @@ -1569,7 +1607,6 @@ genCondJump id bool = do ] return (cond_code `appOL` code) - -- ----------------------------------------------------------------------------- -- Generating C calls diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 2f6196227b..0d85376868 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -196,6 +196,7 @@ data Instr | ADD Size Operand Operand | ADC Size Operand Operand | SUB Size Operand Operand + | SBB Size Operand Operand | MUL Size Operand Operand | MUL2 Size Operand -- %edx:%eax = operand * %rax @@ -365,6 +366,7 @@ x86_regUsageOfInstr platform instr ADD _ src dst -> usageRM src dst ADC _ src dst -> usageRM src dst SUB _ src dst -> usageRM src dst + SBB _ src dst -> usageRM src dst IMUL _ src dst -> usageRM src dst IMUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] MUL _ src dst -> usageRM src dst @@ -543,6 +545,7 @@ x86_patchRegsOfInstr instr env ADD sz src dst -> patch2 (ADD sz) src dst ADC sz src dst -> patch2 (ADC sz) src dst SUB sz src dst -> patch2 (SUB sz) src dst + SBB sz src dst -> patch2 (SBB sz) src dst IMUL sz src dst -> patch2 (IMUL sz) src dst IMUL2 sz src -> patch1 (IMUL2 sz) src MUL sz src dst -> patch2 (MUL sz) src dst diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index cc39557f1d..2b3711751c 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -570,11 +570,10 @@ pprInstr (ADD size (OpImm (ImmInt (-1))) dst) = pprSizeOp (sLit "dec") size dst pprInstr (ADD size (OpImm (ImmInt 1)) dst) = pprSizeOp (sLit "inc") size dst -pprInstr (ADD size src dst) - = pprSizeOpOp (sLit "add") size src dst -pprInstr (ADC size src dst) - = pprSizeOpOp (sLit "adc") size src dst +pprInstr (ADD size src dst) = pprSizeOpOp (sLit "add") size src dst +pprInstr (ADC size src dst) = pprSizeOpOp (sLit "adc") size src dst pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst +pprInstr (SBB size src dst) = pprSizeOpOp (sLit "sbb") size src dst pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 pprInstr (ADD_CC size src dst) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 2fed8dd869..7098504d85 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -357,6 +357,7 @@ basicKnownKeyNames , ghciIoClassName, ghciStepIoMName ] ++ case cIntegerLibraryType of IntegerGMP -> [integerSDataConName] + IntegerGMP2 -> [integerSDataConName] IntegerSimple -> [] genericTyConNames :: [Name] @@ -937,6 +938,7 @@ integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") int integerSDataConName = conName gHC_INTEGER_TYPE (fsLit n) integerSDataConKey where n = case cIntegerLibraryType of IntegerGMP -> "S#" + IntegerGMP2 -> "S#" IntegerSimple -> panic "integerSDataConName evaluated for integer-simple" mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index e33ed15808..0a73585976 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -309,9 +309,21 @@ lookupTopBndrRn_maybe rdr_name ----------------------------------------------- +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This adds an error if the name cannot be found. lookupExactOcc :: Name -> RnM Name --- See Note [Looking up Exact RdrNames] lookupExactOcc name + = do { result <- lookupExactOcc_either name + ; case result of + Left err -> do { addErr err + ; return name } + Right name' -> return name' } + +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This never adds an error, but it may return one. +lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name) +-- See Note [Looking up Exact RdrNames] +lookupExactOcc_either name | Just thing <- wiredInNameTyThing_maybe name , Just tycon <- case thing of ATyCon tc -> Just tc @@ -319,10 +331,10 @@ lookupExactOcc name _ -> Nothing , isTupleTyCon tycon = do { checkTupSize (tyConArity tycon) - ; return name } + ; return (Right name) } | isExternalName name - = return name + = return (Right name) | otherwise = do { env <- getGlobalRdrEnv @@ -337,23 +349,23 @@ lookupExactOcc name ; case gres of [] -> -- See Note [Splicing Exact names] do { lcl_env <- getLocalRdrEnv - ; unless (name `inLocalRdrEnvScope` lcl_env) $ + ; if name `inLocalRdrEnvScope` lcl_env + then return (Right name) + else #ifdef GHCI do { th_topnames_var <- fmap tcg_th_topnames getGblEnv ; th_topnames <- readTcRef th_topnames_var - ; unless (name `elemNameSet` th_topnames) - (addErr exact_nm_err) + ; if name `elemNameSet` th_topnames + then return (Right name) + else return (Left exact_nm_err) } #else /* !GHCI */ - addErr exact_nm_err + return (Left exact_nm_err) #endif /* !GHCI */ - ; return name } - [gre] -> return (gre_name gre) - (gre:_) -> do {addErr dup_nm_err - ; return (gre_name gre) - } + [gre] -> return (Right (gre_name gre)) + _ -> return (Left dup_nm_err) -- We can get more than one GRE here, if there are multiple -- bindings for the same name. Sometimes they are caught later -- by findLocalDupsRdrEnv, like in this example (Trac #8932): @@ -1034,10 +1046,11 @@ lookupBindGroupOcc :: HsSigCtxt -- See Note [Looking up signature names] lookupBindGroupOcc ctxt what rdr_name | Just n <- isExact_maybe rdr_name - = do { n' <- lookupExactOcc n - ; return (Right n') } -- Maybe we should check the side conditions - -- but it's a pain, and Exact things only show - -- up when you know what you are doing + = lookupExactOcc_either n -- allow for the possibility of missing Exacts; + -- see Note [dataTcOccs and Exact Names] + -- Maybe we should check the side conditions + -- but it's a pain, and Exact things only show + -- up when you know what you are doing | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name = do { n' <- lookupOrig rdr_mod rdr_occ @@ -1114,10 +1127,8 @@ lookupLocalTcNames ctxt what rdr_name dataTcOccs :: RdrName -> [RdrName] -- Return both the given name and the same name promoted to the TcClsName -- namespace. This is useful when we aren't sure which we are looking at. +-- See also Note [dataTcOccs and Exact Names] dataTcOccs rdr_name - | Just n <- isExact_maybe rdr_name - , not (isBuiltInSyntax n) -- See Note [dataTcOccs and Exact Names] - = [rdr_name] | isDataOcc occ || isVarOcc occ = [rdr_name, rdr_name_tc] | otherwise @@ -1130,8 +1141,12 @@ dataTcOccs rdr_name Note [dataTcOccs and Exact Names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Exact RdrNames can occur in code generated by Template Haskell, and generally -those references are, well, exact, so it's wrong to return the TyClsName too. -But there is an awkward exception for built-in syntax. Example in GHCi +those references are, well, exact. However, the TH `Name` type isn't expressive +enough to always track the correct namespace information, so we sometimes get +the right Unique but wrong namespace. Thus, we still have to do the double-lookup +for Exact RdrNames. + +There is also an awkward situation for built-in syntax. Example in GHCi :info [] This parses as the Exact RdrName for nilDataCon, but we also want the list type constructor. diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 8aed1657be..c2af40703d 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -16,7 +16,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynWrapper ) +import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynWorker ) import DynFlags import HsSyn @@ -320,8 +320,8 @@ tcValBinds top_lvl binds sigs thing_inside { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do { thing <- thing_inside -- See Note [Pattern synonym wrappers don't yield dependencies] - ; patsyn_wrappers <- mapM tcPatSynWrapper patsyns - ; let extra_binds = [ (NonRecursive, wrapper) | wrapper <- patsyn_wrappers ] + ; patsyn_workers <- mapM tcPatSynWorker patsyns + ; let extra_binds = [ (NonRecursive, worker) | worker <- patsyn_workers ] ; return (extra_binds, thing) } ; return (binds' ++ extra_binds', thing) }} where @@ -424,7 +424,7 @@ tc_single _top_lvl _sig_fn _prag_fn (L _ (PatSynBind psb)) thing_inside ; let tything = AConLike (PatSynCon pat_syn) implicit_ids = (patSynMatcher pat_syn) : - (maybeToList (patSynWrapper pat_syn)) + (maybeToList (patSynWorker pat_syn)) ; thing <- tcExtendGlobalEnv [tything] $ tcExtendGlobalEnvImplicit (map AnId implicit_ids) $ diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index bcd6bfdf82..0ef74a1f5a 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -224,7 +224,8 @@ tcLookupInstance cls tys where extractTyVar (TyVarTy tv) = tv extractTyVar _ = panic "TcEnv.tcLookupInstance: extractTyVar" - + + -- NB: duplicated to prevent circular dependence on Inst tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv; ; return (eps_inst_env eps, tcg_inst_env env) } diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index deda6137d0..a242ed77d2 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -124,16 +124,9 @@ tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr) tcInferRhoNC (L loc expr) = setSrcSpan loc $ - do { (expr', rho) <- tcInfExpr expr + do { (expr', rho) <- tcInfer (tcExpr expr) ; return (L loc expr', rho) } -tcInfExpr :: HsExpr Name -> TcM (HsExpr TcId, TcRhoType) -tcInfExpr (HsVar f) = tcInferId f -tcInfExpr (HsPar e) = do { (e', ty) <- tcInferRhoNC e - ; return (HsPar e', ty) } -tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2] -tcInfExpr e = tcInfer (tcExpr e) - tcHole :: OccName -> TcRhoType -> TcM (HsExpr TcId) tcHole occ res_ty = do { ty <- newFlexiTyVarTy liftedTypeKind @@ -326,13 +319,15 @@ tcExpr (OpApp arg1 op fix arg2) res_ty -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 -- (which gives a seg fault) -- We do this by unifying with a MetaTv; but of course - -- it must allow foralls in the type it unifies with (hence PolyTv)! + -- it must allow foralls in the type it unifies with (hence ReturnTv)! -- -- The result type can have any kind (Trac #8739), -- so we can just use res_ty -- ($) :: forall (a:*) (b:Open). (a->b) -> a -> b - ; a_ty <- newPolyFlexiTyVarTy + ; a_tv <- newReturnTyVar liftedTypeKind + ; let a_ty = mkTyVarTy a_tv + ; arg2' <- tcArg op (arg2, arg2_ty, 2) ; co_a <- unifyType arg2_ty a_ty -- arg2 ~ a @@ -937,23 +932,6 @@ mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun) , ptext (sLit "is applied to")] ---------------- -tcInferApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args - -> TcM (HsExpr TcId, TcRhoType) -- Translated fun and args - -tcInferApp (L _ (HsPar e)) args = tcInferApp e args -tcInferApp (L _ (HsApp e1 e2)) args = tcInferApp e1 (e2:args) -tcInferApp fun args - = -- Very like the tcApp version, except that there is - -- no expected result type passed in - do { (fun1, fun_tau) <- tcInferFun fun - ; (co_fun, expected_arg_tys, actual_res_ty) - <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau - ; args1 <- tcArgs fun args expected_arg_tys - ; let fun2 = mkLHsWrapCo co_fun fun1 - app = foldl mkHsApp fun2 args1 - ; return (unLoc app, actual_res_ty) } - ----------------- tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) -- Infer and instantiate the type of a function tcInferFun (L loc (HsVar name)) diff --git a/compiler/typecheck/TcFlatten.lhs b/compiler/typecheck/TcFlatten.lhs index 3ee4d593f6..2e9c6eb0a9 100644 --- a/compiler/typecheck/TcFlatten.lhs +++ b/compiler/typecheck/TcFlatten.lhs @@ -601,6 +601,9 @@ goals. But to be honest I'm not absolutely certain, so I am leaving FM_Avoid in the code base. What I'm removing is the unique place where it is *used*, namely in TcCanonical.canEqTyVar. +See also Note [Conservative unification check] in TcUnify, which gives +other examples where lazy flattening caused problems. + Bottom line: FM_Avoid is unused for now (Nov 14). Note: T5321Fun got faster when I disabled FM_Avoid T5837 did too, but it's pathalogical anyway diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index ddb2e6531a..b6c0da1e8b 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -1009,23 +1009,28 @@ superclass is bottom when it should not be. Consider the following (extreme) situation: class C a => D a where ... - instance D [a] => D [a] where ... + instance D [a] => D [a] where ... (dfunD) + instance C [a] => C [a] where ... (dfunC) Although this looks wrong (assume D [a] to prove D [a]), it is only a more extreme case of what happens with recursive dictionaries, and it can, just about, make sense because the methods do some work before recursing. -To implement the dfun we must generate code for the superclass C [a], +To implement the dfunD we must generate code for the superclass C [a], which we had better not get by superclass selection from the supplied argument: - dfun :: forall a. D [a] -> D [a] - dfun = \d::D [a] -> MkD (scsel d) .. + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (scsel d) .. Otherwise if we later encounter a situation where we have a [Wanted] dw::D [a] we might solve it thus: - dw := dfun dw + dw := dfunD dw Which is all fine except that now ** the superclass C is bottom **! +The instance we want is: + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ... + THE SOLUTION Our solution to this problem "silent superclass arguments". We pass diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 811b16a616..2e5618ea78 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -1197,56 +1197,69 @@ Consider generating the superclasses of the instance declaration instance Foo a => Foo [a] So our problem is this - d0 :_g Foo t - d1 :_w Data Maybe [t] + [G] d0 : Foo t + [W] d1 : Data Maybe [t] -- Desired superclass We may add the given in the inert set, along with its superclasses [assuming we don't fail because there is a matching instance, see topReactionsStage, given case ] Inert: - d0 :_g Foo t + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 WorkList - d01 :_g Data Maybe t -- d2 := EvDictSuperClass d0 0 - d1 :_w Data Maybe [t] -Then d2 can readily enter the inert, and we also do solving of the wanted + [W] d1 : Data Maybe [t] + +Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 Inert: - d0 :_g Foo t - d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3 + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] WorkList - d2 :_w Sat (Maybe [t]) - d3 :_w Data Maybe t - d01 :_g Data Maybe t -Now, we may simplify d2 more: + [W] d2 : Sat (Maybe [t]) + [W] d3 : Data Maybe t + +Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 Inert: - d0 :_g Foo t - d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3 - d1 :_g Data Maybe [t] - d2 :_g Sat (Maybe [t]) d2 := dfunSat d4 + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) WorkList: - d3 :_w Data Maybe t - d4 :_w Foo [t] - d01 :_g Data Maybe t + [W] d3 : Data Maybe t + [W] d4 : Foo [t] -Now, we can just solve d3. +Now, we can just solve d3 from d01; d3 := d01 Inert - d0 :_g Foo t - d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3 - d2 :_g Sat (Maybe [t]) d2 := dfunSat d4 + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) WorkList - d4 :_w Foo [t] - d01 :_g Data Maybe t -And now we can simplify d4 again, but since it has superclasses we *add* them to the worklist: + [W] d4 : Foo [t] + +Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 Inert - d0 :_g Foo t - d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3 - d2 :_g Sat (Maybe [t]) d2 := dfunSat d4 - d4 :_g Foo [t] d4 := dfunFoo2 d5 + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + d4 : Foo [t] WorkList: - d5 :_w Foo t - d6 :_g Data Maybe [t] d6 := EvDictSuperClass d4 0 - d01 :_g Data Maybe t -Now, d5 can be solved! (and its superclass enter scope) - Inert + [W] d5 : Foo t + +Now, d5 can be solved! d5 := d0 + +Result + d1 := dfunData2 d2 d3 + d2 := dfunSat d4 + d3 := d01 + d4 := dfunFoo2 d5 + d5 := d0 + d0 :_g Foo t d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3 d2 :_g Sat (Maybe [t]) d2 := dfunSat d4 diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index d6f37c8f96..c78c125bf1 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -19,12 +19,12 @@ module TcMType ( newFlexiTyVar, newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] - newPolyFlexiTyVarTy, + newReturnTyVar, newMetaKindVar, newMetaKindVars, mkTcTyVarName, cloneMetaTyVar, newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, - newMetaDetails, isFilledMetaTyVar, isFlexiMetaTyVar, + newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar, -------------------------------- -- Creating new evidence variables @@ -311,7 +311,7 @@ newMetaTyVar meta_info kind = do { uniq <- newUnique ; let name = mkTcTyVarName uniq s s = case meta_info of - PolyTv -> fsLit "s" + ReturnTv -> fsLit "r" TauTv -> fsLit "t" FlatMetaTv -> fsLit "fmv" SigTv -> fsLit "a" @@ -363,9 +363,9 @@ isFilledMetaTyVar tv ; return (isIndirect details) } | otherwise = return False -isFlexiMetaTyVar :: TyVar -> TcM Bool +isUnfilledMetaTyVar :: TyVar -> TcM Bool -- True of a un-filled-in (Flexi) meta type variable -isFlexiMetaTyVar tv +isUnfilledMetaTyVar tv | not (isTcTyVar tv) = return False | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv = do { details <- readMutVar ref @@ -448,9 +448,8 @@ newFlexiTyVarTy kind = do newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) -newPolyFlexiTyVarTy :: TcM TcType -newPolyFlexiTyVarTy = do { tv <- newMetaTyVar PolyTv liftedTypeKind - ; return (TyVarTy tv) } +newReturnTyVar :: Kind -> TcM TcTyVar +newReturnTyVar kind = newMetaTyVar ReturnTv kind tcInstTyVars :: [TKVar] -> TcM (TvSubst, [TcTyVar]) -- Instantiate with META type variables diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs index ea2dbce9d7..d6f6817cce 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -7,13 +7,14 @@ \begin{code} {-# LANGUAGE CPP #-} -module TcPatSyn (tcPatSynDecl, tcPatSynWrapper) where +module TcPatSyn (tcPatSynDecl, mkPatSynWrapperId, tcPatSynWorker) where import HsSyn import TcPat import TcRnMonad import TcEnv import TcMType +import TcIface import TysPrim import Name import SrcLoc @@ -36,7 +37,7 @@ import Data.Monoid import Bag import TcEvidence import BuildTyCl -import TypeRep +import Data.Maybe #include "HsVersions.h" \end{code} @@ -48,7 +49,6 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, psb_def = lpat, psb_dir = dir } = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat ; tcCheckPatSynPat lpat - ; ; let (arg_names, is_infix) = case details of PrefixPatSyn names -> (map unLoc names, False) @@ -78,6 +78,7 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, ; req_theta <- zonkTcThetaType req_theta ; pat_ty <- zonkTcType pat_ty ; args <- mapM zonkId args + ; let arg_tys = map varType args ; traceTc "tcPatSynDecl: ex" (ppr ex_tvs $$ ppr prov_theta $$ @@ -87,7 +88,8 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, ppr req_dicts $$ ppr ev_binds) - ; let theta = prov_theta ++ req_theta + ; let qtvs = univ_tvs ++ ex_tvs + ; let theta = req_theta ++ prov_theta ; traceTc "tcPatSynDecl: type" (ppr name $$ ppr univ_tvs $$ @@ -101,17 +103,19 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, prov_theta req_theta pat_ty - ; wrapper_id <- if isBidirectional dir - then fmap Just $ mkPatSynWrapperId lname args univ_tvs ex_tvs theta pat_ty - else return Nothing + ; wrapper_ids <- if isBidirectional dir + then fmap Just $ mkPatSynWrapperIds lname + qtvs theta + arg_tys pat_ty + else return Nothing ; traceTc "tcPatSynDecl }" $ ppr name ; let patSyn = mkPatSyn name is_infix (univ_tvs, req_theta) (ex_tvs, prov_theta) - (map varType args) + arg_tys pat_ty - matcher_id wrapper_id + matcher_id wrapper_ids ; return (patSyn, matcher_bind) } \end{code} @@ -134,7 +138,7 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc ; return $ mkTcTyVar tv_name openTypeKind (SkolemTv False) } ; matcher_name <- newImplicitBinder name mkMatcherOcc - ; let res_ty = TyVarTy res_tv + ; let res_ty = mkTyVarTy res_tv cont_args = if null args then [voidPrimId] else args cont_ty = mkSigmaTy ex_tvs prov_theta $ mkFunTys (map varType cont_args) res_ty @@ -149,7 +153,8 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d ; scrutinee <- mkId "scrut" pat_ty ; cont <- mkId "cont" cont_ty - ; let cont' = nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts ++ cont_args) + ; let cont' = nlHsTyApps cont (map mkTyVarTy ex_tvs) $ + map nlHsVar (prov_dicts ++ cont_args) ; fail <- mkId "fail" fail_ty ; let fail' = nlHsApps fail [nlHsVar voidPrimId] @@ -201,73 +206,69 @@ isBidirectional Unidirectional = False isBidirectional ImplicitBidirectional = True isBidirectional ExplicitBidirectional{} = True -tcPatSynWrapper :: PatSynBind Name Name +tcPatSynWorker :: PatSynBind Name Name -> TcM (LHsBinds Id) -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn -tcPatSynWrapper PSB{ psb_id = L loc name, psb_def = lpat, psb_dir = dir, psb_args = details } +tcPatSynWorker PSB{ psb_id = lname, psb_def = lpat, psb_dir = dir, psb_args = details } = case dir of Unidirectional -> return emptyBag ImplicitBidirectional -> - do { wrapper_id <- tcLookupPatSynWrapper name - ; lexpr <- case tcPatToExpr (mkNameSet args) lpat of + do { lexpr <- case tcPatToExpr (mkNameSet args) lpat of Nothing -> cannotInvertPatSynErr lpat Just lexpr -> return lexpr ; let wrapper_args = map (noLoc . VarPat) args - wrapper_lname = L (getLoc lpat) (idName wrapper_id) wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds - wrapper_bind = mkTopFunBind Generated wrapper_lname [wrapper_match] - ; mkPatSynWrapper wrapper_id wrapper_bind } - ExplicitBidirectional mg -> - do { wrapper_id <- tcLookupPatSynWrapper name - ; mkPatSynWrapper wrapper_id $ - FunBind{ fun_id = L loc (idName wrapper_id) - , fun_infix = False - , fun_matches = mg - , fun_co_fn = idHsWrapper - , bind_fvs = placeHolderNamesTc - , fun_tick = Nothing }} + ; mkPatSynWorker lname $ mkMatchGroupName Generated [wrapper_match] } + ExplicitBidirectional mg -> mkPatSynWorker lname mg where args = map unLoc $ case details of PrefixPatSyn args -> args InfixPatSyn arg1 arg2 -> [arg1, arg2] - tcLookupPatSynWrapper name - = do { patsyn <- tcLookupPatSyn name - ; case patSynWrapper patsyn of - Nothing -> panic "tcLookupPatSynWrapper" - Just wrapper_id -> return wrapper_id } - -mkPatSynWrapperId :: Located Name - -> [Var] -> [TyVar] -> [TyVar] -> ThetaType -> Type - -> TcM Id -mkPatSynWrapperId (L _ name) args univ_tvs ex_tvs theta pat_ty - = do { let qtvs = univ_tvs ++ ex_tvs - ; (subst, wrapper_tvs) <- tcInstSkolTyVars qtvs - ; let wrapper_theta = substTheta subst theta - pat_ty' = substTy subst pat_ty - args' = map (\arg -> setVarType arg $ substTy subst (varType arg)) args - wrapper_tau = mkFunTys (map varType args') pat_ty' - wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau - - ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc - ; return $ mkVanillaGlobal wrapper_name wrapper_sigma } - -mkPatSynWrapper :: Id - -> HsBind Name +mkPatSynWrapperIds :: Located Name + -> [TyVar] -> ThetaType -> [Type] -> Type + -> TcM (Id, Id) +mkPatSynWrapperIds lname qtvs theta arg_tys pat_ty + = do { worker_id <- mkPatSynWorkerId lname mkDataConWorkerOcc qtvs theta worker_arg_tys pat_ty + ; wrapper_id <- mkPatSynWrapperId lname qtvs theta arg_tys pat_ty worker_id + ; return (wrapper_id, worker_id) } + where + worker_arg_tys | need_dummy_arg = [voidPrimTy] + | otherwise = arg_tys + need_dummy_arg = null arg_tys && isUnLiftedType pat_ty + +mkPatSynWorker :: Located Name + -> MatchGroup Name (LHsExpr Name) -> TcM (LHsBinds Id) -mkPatSynWrapper wrapper_id bind - = do { (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind) - ; traceTc "tcPatSynDecl wrapper" $ ppr wrapper_binds - ; traceTc "tcPatSynDecl wrapper type" $ ppr (varType wrapper_id) - ; return wrapper_binds } +mkPatSynWorker (L loc name) mg + = do { patsyn <- tcLookupPatSyn name + ; let worker_id = fromMaybe (panic "mkPatSynWrapper") $ + patSynWorker patsyn + need_dummy_arg = null (patSynArgs patsyn) && isUnLiftedType (patSynType patsyn) + + ; let match_dummy = mkMatch [nlWildPatName] (noLoc $ HsLam mg) emptyLocalBinds + mg' | need_dummy_arg = mkMatchGroupName Generated [match_dummy] + | otherwise = mg + + ; let (worker_tvs, worker_theta, worker_tau) = tcSplitSigmaTy (idType worker_id) + bind = FunBind { fun_id = L loc (idName worker_id) + , fun_infix = False + , fun_matches = mg' + , fun_co_fn = idHsWrapper + , bind_fvs = placeHolderNamesTc + , fun_tick = Nothing } + + sig = TcSigInfo{ sig_id = worker_id + , sig_tvs = map (\tv -> (Nothing, tv)) worker_tvs + , sig_theta = worker_theta + , sig_tau = worker_tau + , sig_loc = noSrcSpan + } + + ; (worker_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind) + ; traceTc "tcPatSynDecl worker" $ ppr worker_binds + ; return worker_binds } where - sig = TcSigInfo{ sig_id = wrapper_id - , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs - , sig_theta = wrapper_theta - , sig_tau = wrapper_tau - , sig_loc = noSrcSpan - } - (wrapper_tvs, wrapper_theta, wrapper_tau) = tcSplitSigmaTy (idType wrapper_id) \end{code} diff --git a/compiler/typecheck/TcPatSyn.lhs-boot b/compiler/typecheck/TcPatSyn.lhs-boot index 700137c16c..0e28caa6ca 100644 --- a/compiler/typecheck/TcPatSyn.lhs-boot +++ b/compiler/typecheck/TcPatSyn.lhs-boot @@ -10,6 +10,6 @@ import PatSyn ( PatSyn ) tcPatSynDecl :: PatSynBind Name Name -> TcM (PatSyn, LHsBinds Id) -tcPatSynWrapper :: PatSynBind Name Name - -> TcM (LHsBinds Id) +tcPatSynWorker :: PatSynBind Name Name + -> TcM (LHsBinds Id) \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 02d0026bdd..a646ea445a 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -238,10 +238,7 @@ checkHsigIface' gr ; r <- tcLookupImported_maybe name ; case r of Failed err -> addErr err - Succeeded real_thing -> - when (not (checkBootDecl sig_thing real_thing)) - $ addErrAt (nameSrcSpan (getName sig_thing)) - (bootMisMatch False real_thing sig_thing) + Succeeded real_thing -> checkBootDeclM False sig_thing real_thing }} where name = availName sig_avail @@ -767,9 +764,7 @@ checkHiBootIface' -- then compare the definitions | Just real_thing <- lookupTypeEnv local_type_env name, Just boot_thing <- mb_boot_thing - = when (not (checkBootDecl boot_thing real_thing)) - $ addErrAt (nameSrcSpan (getName boot_thing)) - (bootMisMatch True real_thing boot_thing) + = checkBootDeclM True boot_thing real_thing | otherwise = addErrTc (missingBootThing True name "defined in") @@ -810,11 +805,25 @@ checkHiBootIface' -- -- See rnfail055 for a good test of this stuff. -checkBootDecl :: TyThing -> TyThing -> Bool +-- | Compares two things for equivalence between boot-file and normal code, +-- reporting an error if they don't match up. +checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) + -> TyThing -> TyThing -> TcM () +checkBootDeclM is_boot boot_thing real_thing + = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err -> + addErrAt (nameSrcSpan (getName boot_thing)) + (bootMisMatch is_boot err real_thing boot_thing) + +-- | Compares the two things for equivalence between boot-file and normal +-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ +-- failure. If the difference will be apparent to the user, @Just empty@ is +-- perfectly suitable. +checkBootDecl :: TyThing -> TyThing -> Maybe SDoc checkBootDecl (AnId id1) (AnId id2) = ASSERT(id1 == id2) - (idType id1 `eqType` idType id2) + check (idType id1 `eqType` idType id2) + (text "The two types are different") checkBootDecl (ATyCon tc1) (ATyCon tc2) = checkBootTyCon tc1 tc2 @@ -822,13 +831,52 @@ checkBootDecl (ATyCon tc1) (ATyCon tc2) checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) = pprPanic "checkBootDecl" (ppr dc1) -checkBootDecl _ _ = False -- probably shouldn't happen +checkBootDecl _ _ = Just empty -- probably shouldn't happen + +-- | Combines two potential error messages +andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc +Nothing `andThenCheck` msg = msg +msg `andThenCheck` Nothing = msg +Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2) +infixr 0 `andThenCheck` + +-- | If the test in the first parameter is True, succeed with @Nothing@; +-- otherwise, return the provided check +checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc +checkUnless True _ = Nothing +checkUnless False k = k + +-- | Run the check provided for every pair of elements in the lists. +-- The provided SDoc should name the element type, in the plural. +checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc + -> Maybe SDoc +checkListBy check_fun as bs whats = go [] as bs + where + herald = text "The" <+> whats <+> text "do not match" + + go [] [] [] = Nothing + go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs)) + go docs (x:xs) (y:ys) = case check_fun x y of + Just doc -> go (doc:docs) xs ys + Nothing -> go docs xs ys + go _ _ _ = Just (hang (herald <> colon) + 2 (text "There are different numbers of" <+> whats)) + +-- | If the test in the first parameter is True, succeed with @Nothing@; +-- otherwise, fail with the given SDoc. +check :: Bool -> SDoc -> Maybe SDoc +check True _ = Nothing +check False doc = Just doc + +-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends. +checkSuccess :: Maybe SDoc +checkSuccess = Nothing ---------------- -checkBootTyCon :: TyCon -> TyCon -> Bool +checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc checkBootTyCon tc1 tc2 | not (eqKind (tyConKind tc1) (tyConKind tc2)) - = False -- First off, check the kind + = Just $ text "The types have different kinds" -- First off, check the kind | Just c1 <- tyConClass_maybe tc1 , Just c2 <- tyConClass_maybe tc2 @@ -839,18 +887,29 @@ checkBootTyCon tc1 tc2 , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 = let eqSig (id1, def_meth1) (id2, def_meth2) - = idName id1 == idName id2 && - eqTypeX env op_ty1 op_ty2 && - def_meth1 == def_meth2 + = check (name1 == name2) + (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> + text "are different") `andThenCheck` + check (eqTypeX env op_ty1 op_ty2) + (text "The types of" <+> pname1 <+> + text "are different") `andThenCheck` + check (def_meth1 == def_meth2) + (text "The default methods associated with" <+> pname1 <+> + text "are different") where + name1 = idName id1 + name2 = idName id2 + pname1 = quotes (ppr name1) + pname2 = quotes (ppr name2) (_, rho_ty1) = splitForAllTys (idType id1) op_ty1 = funResultTy rho_ty1 (_, rho_ty2) = splitForAllTys (idType id2) op_ty2 = funResultTy rho_ty2 eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) - = checkBootTyCon tc1 tc2 && - eqATDef def_ats1 def_ats2 + = checkBootTyCon tc1 tc2 `andThenCheck` + check (eqATDef def_ats1 def_ats2) + (text "The associated type defaults differ") -- Ignore the location of the defaults eqATDef Nothing Nothing = True @@ -861,14 +920,16 @@ checkBootTyCon tc1 tc2 eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) in - roles1 == roles2 && - -- Checks kind of class - eqListBy eqFD clas_fds1 clas_fds2 && - (null sc_theta1 && null op_stuff1 && null ats1 - || -- Above tests for an "abstract" class - eqListBy (eqPredX env) sc_theta1 sc_theta2 && - eqListBy eqSig op_stuff1 op_stuff2 && - eqListBy eqAT ats1 ats2) + check (roles1 == roles2) roles_msg `andThenCheck` + -- Checks kind of class + check (eqListBy eqFD clas_fds1 clas_fds2) + (text "The functional dependencies do not match") `andThenCheck` + checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $ + -- Above tests for an "abstract" class + check (eqListBy (eqPredX env) sc_theta1 sc_theta2) + (text "The class constraints do not match") `andThenCheck` + checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` + checkListBy eqAT ats1 ats2 (text "associated types") | Just syn_rhs1 <- synTyConRhs_maybe tc1 , Just syn_rhs2 <- synTyConRhs_maybe tc2 @@ -884,37 +945,61 @@ checkBootTyCon tc1 tc2 eqSynRhs (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2 eqSynRhs _ _ = False in - roles1 == roles2 && - eqSynRhs syn_rhs1 syn_rhs2 + check (roles1 == roles2) roles_msg `andThenCheck` + check (eqSynRhs syn_rhs1 syn_rhs2) empty -- nothing interesting to say | isAlgTyCon tc1 && isAlgTyCon tc2 , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = ASSERT(tc1 == tc2) - roles1 == roles2 && - eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) && - eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) + check (roles1 == roles2) roles_msg `andThenCheck` + check (eqListBy (eqPredX env) + (tyConStupidTheta tc1) (tyConStupidTheta tc2)) + (text "The datatype contexts do not match") `andThenCheck` + eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) - | otherwise = False + | otherwise = Just empty -- two very different types -- should be obvious where roles1 = tyConRoles tc1 roles2 = tyConRoles tc2 - - eqAlgRhs (AbstractTyCon dis1) rhs2 - | dis1 = isDistinctAlgRhs rhs2 --Check compatibility - | otherwise = True - eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True - eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = - eqListBy eqCon (data_cons tc1) (data_cons tc2) - eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} = + roles_msg = text "The roles do not match." <+> + (text "Roles default to" <+> + quotes (text "representational") <+> text "in boot files") + + eqAlgRhs tc (AbstractTyCon dis1) rhs2 + | dis1 = check (isDistinctAlgRhs rhs2) --Check compatibility + (text "The natures of the declarations for" <+> + quotes (ppr tc) <+> text "are different") + | otherwise = checkSuccess + eqAlgRhs _ DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess + eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = + checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") + eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} = eqCon (data_con tc1) (data_con tc2) - eqAlgRhs _ _ = False + eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+> + text "definition with a" <+> quotes (text "newtype") <+> + text "definition") eqCon c1 c2 - = dataConName c1 == dataConName c2 - && dataConIsInfix c1 == dataConIsInfix c2 - && eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2) - && dataConFieldLabels c1 == dataConFieldLabels c2 - && eqType (dataConUserType c1) (dataConUserType c2) + = check (name1 == name2) + (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> + text "differ") `andThenCheck` + check (dataConIsInfix c1 == dataConIsInfix c2) + (text "The fixities of" <+> pname1 <+> + text "differ") `andThenCheck` + check (eqListBy eqHsBang + (dataConStrictMarks c1) (dataConStrictMarks c2)) + (text "The strictness annotations for" <+> pname1 <+> + text "differ") `andThenCheck` + check (dataConFieldLabels c1 == dataConFieldLabels c2) + (text "The record label lists for" <+> pname1 <+> + text "differ") `andThenCheck` + check (eqType (dataConUserType c1) (dataConUserType c2)) + (text "The types for" <+> pname1 <+> text "differ") + where + name1 = dataConName c1 + name2 = dataConName c2 + pname1 = quotes (ppr name1) + pname2 = quotes (ppr name2) eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 }) (CoAxiom { co_ax_branches = branches2 }) @@ -940,8 +1025,8 @@ missingBootThing is_boot name what <+> ptext (sLit "file, but not") <+> text what <+> ptext (sLit "the module") -bootMisMatch :: Bool -> TyThing -> TyThing -> SDoc -bootMisMatch is_boot real_thing boot_thing +bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc +bootMisMatch is_boot extra_info real_thing boot_thing = vcat [ppr real_thing <+> ptext (sLit "has conflicting definitions in the module"), ptext (sLit "and its") <+> @@ -951,7 +1036,8 @@ bootMisMatch is_boot real_thing boot_thing (if is_boot then ptext (sLit "Boot file: ") else ptext (sLit "Hsig file: ")) - <+> PprTyThing.pprTyThing boot_thing] + <+> PprTyThing.pprTyThing boot_thing, + extra_info] instMisMatch :: Bool -> ClsInst -> SDoc instMisMatch is_boot inst diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 19bd602e52..743dcbcd55 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1251,6 +1251,9 @@ mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, if_tv_env = emptyUFM, if_id_env = emptyUFM } +-- | Run an 'IfG' (top-level interface monad) computation inside an existing +-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv' +-- based on 'TcGblEnv'. initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index cc76c03523..15be2a6212 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -148,7 +148,11 @@ import qualified Language.Haskell.TH as TH The monad itself has to be defined here, because it is mentioned by ErrCtxt \begin{code} +-- | Type alias for 'IORef'; the convention is we'll use this for mutable +-- bits of data in 'TcGblEnv' which are updated during typechecking and +-- returned at the end. type TcRef a = IORef a +-- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'? type TcId = Id type TcIdSet = IdSet @@ -158,9 +162,19 @@ type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff type IfG = IfM () -- Top level type IfL = IfM IfLclEnv -- Nested + +-- | Type-checking and renaming monad: the main monad that most type-checking +-- takes place in. The global environment is 'TcGblEnv', which tracks +-- all of the top-level type-checking information we've accumulated while +-- checking a module, while the local environment is 'TcLclEnv', which +-- tracks local information as we move inside expressions. type TcRn = TcRnIf TcGblEnv TcLclEnv -type RnM = TcRn -- Historical -type TcM = TcRn -- Historical + +-- | Historical "renaming monad" (now it's just 'TcRn'). +type RnM = TcRn + +-- | Historical "type-checking monad" (now it's just 'TcRn'). +type TcM = TcRn \end{code} Representation of type bindings to uninstantiated meta variables used during @@ -208,12 +222,11 @@ instance ContainsDynFlags (Env gbl lcl) where instance ContainsModule gbl => ContainsModule (Env gbl lcl) where extractModule env = extractModule (env_gbl env) --- TcGblEnv describes the top-level of the module at the +-- | '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 -- For state that needs to be updated during the typechecking --- phase and returned at end, use a TcRef (= IORef). - +-- phase and returned at end, use a 'TcRef' (= 'IORef'). data TcGblEnv = TcGblEnv { tcg_mod :: Module, -- ^ Module being compiled @@ -502,8 +515,8 @@ data IfLclEnv %* * %************************************************************************ -The Global-Env/Local-Env story -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [The Global-Env/Local-Env story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During type checking, we keep in the tcg_type_env * All types and classes * All Ids derived from types and classes (constructors, selectors) diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index ea467f0ad0..f2efb2ae58 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1308,15 +1308,22 @@ reifyClass cls = do { cxt <- reifyCxt theta ; inst_envs <- tcGetInstEnvs ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) - ; ops <- mapM reify_op op_stuff + ; ops <- concatMapM reify_op op_stuff ; tvs' <- reifyTyVars tvs ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops ; return (TH.ClassI dec insts ) } where (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls fds' = map reifyFunDep fds - reify_op (op, _) = do { ty <- reifyType (idType op) - ; return (TH.SigD (reifyName op) ty) } + reify_op (op, def_meth) + = do { ty <- reifyType (idType op) + ; let nm' = reifyName op + ; case def_meth of + GenDefMeth gdm_nm -> + do { gdm_id <- tcLookupId gdm_nm + ; gdm_ty <- reifyType (idType gdm_id) + ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty] } + _ -> return [TH.SigD nm' ty] } ------------------------------ -- | Annotate (with TH.SigT) a type if the first parameter is True diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index a4a646c8e9..dba1be8964 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -269,6 +269,35 @@ Similarly consider When doing kind inference on {S,T} we don't want *skolems* for k1,k2, because they end up unifying; we want those SigTvs again. +Note [ReturnTv] +~~~~~~~~~~~~~~~ +We sometimes want to convert a checking algorithm into an inference +algorithm. An easy way to do this is to "check" that a term has a +metavariable as a type. But, we must be careful to allow that metavariable +to unify with *anything*. (Well, anything that doesn't fail an occurs-check.) +This is what ReturnTv means. + +For example, if we have + + (undefined :: (forall a. TF1 a ~ TF2 a => a)) x + +we'll call (tcInfer . tcExpr) on the function expression. tcInfer will +create a ReturnTv to represent the expression's type. We really need this +ReturnTv to become set to (forall a. TF1 a ~ TF2 a => a) despite the fact +that this type mentions type families and is a polytype. + +However, we must also be careful to make sure that the ReturnTvs really +always do get unified with something -- we don't want these floating +around in the solver. So, we check after running the checker to make +sure the ReturnTv is filled. If it's not, we set it to a TauTv. + +We can't ASSERT that no ReturnTvs hit the solver, because they +can if there's, say, a kind error that stops checkTauTvUpdate from +working. This happens in test case typecheck/should_fail/T5570, for +example. + +See also the commentary on #9404. + \begin{code} -- A TyVarDetails is inside a TyVar data TcTyVarDetails @@ -307,7 +336,9 @@ data MetaInfo -- A TauTv is always filled in with a tau-type, which -- never contains any ForAlls - | PolyTv -- Like TauTv, but can unify with a sigma-type + | ReturnTv -- Can unify with *anything*. Used to convert a + -- type "checking" algorithm into a type inference algorithm. + -- See Note [ReturnTv] | SigTv -- A variant of TauTv, except that it should not be -- unified with a type, only with a type variable @@ -481,7 +512,7 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_untch = untch }) = pp_info <> colon <> ppr untch where pp_info = case info of - PolyTv -> ptext (sLit "poly") + ReturnTv -> ptext (sLit "return") TauTv -> ptext (sLit "tau") SigTv -> ptext (sLit "sig") FlatMetaTv -> ptext (sLit "fuv") @@ -1133,7 +1164,7 @@ occurCheckExpand :: DynFlags -> TcTyVar -> Type -> OccCheckResult Type -- Check whether -- a) the given variable occurs in the given type. -- b) there is a forall in the type (unless we have -XImpredicativeTypes --- or it's a PolyTv +-- or it's a ReturnTv -- c) if it's a SigTv, ty should be a tyvar -- -- We may have needed to do some type synonym unfolding in order to @@ -1152,13 +1183,13 @@ occurCheckExpand dflags tv ty impredicative = case details of - MetaTv { mtv_info = PolyTv } -> True - MetaTv { mtv_info = SigTv } -> False - MetaTv { mtv_info = TauTv } -> xopt Opt_ImpredicativeTypes dflags - || isOpenTypeKind (tyVarKind tv) + MetaTv { mtv_info = ReturnTv } -> True + MetaTv { mtv_info = SigTv } -> False + MetaTv { mtv_info = TauTv } -> xopt Opt_ImpredicativeTypes dflags + || isOpenTypeKind (tyVarKind tv) -- Note [OpenTypeKind accepts foralls] -- in TcUnify - _other -> True + _other -> True -- We can have non-meta tyvars in given constraints -- Check 'ty' is a tyvar, or can be expanded into one diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index f5033ee08a..421d076dbf 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -46,6 +46,7 @@ import TyCon import TysWiredIn import Var import VarEnv +import VarSet import ErrUtils import DynFlags import BasicTypes @@ -338,10 +339,19 @@ tcSubType origin ctxt ty_actual ty_expected PatSigOrigin -> TypeEqOrigin { uo_actual = ty2, uo_expected = ty1 } _other -> TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 } +-- | Infer a type using a type "checking" function by passing in a ReturnTv, +-- which can unify with *anything*. See also Note [ReturnTv] in TcType tcInfer :: (TcType -> TcM a) -> TcM (a, TcType) -tcInfer tc_infer = do { ty <- newFlexiTyVarTy openTypeKind - ; res <- tc_infer ty - ; return (res, ty) } +tcInfer tc_check + = do { tv <- newReturnTyVar openTypeKind + ; let ty = mkTyVarTy tv + ; res <- tc_check ty + ; whenM (isUnfilledMetaTyVar tv) $ -- checking was uninformative + do { traceTc "Defaulting an un-filled ReturnTv to a TauTv" empty + ; tau_ty <- newFlexiTyVarTy openTypeKind + ; writeMetaTyVar tv tau_ty } + ; return (res, ty) } + where ----------------- tcWrapResult :: HsExpr TcId -> TcRhoType -> TcRhoType -> TcM (HsExpr TcId) @@ -844,7 +854,7 @@ nicer_to_update_tv1 tv1 _ _ = isSystemName (Var.varName tv1) ---------------- checkTauTvUpdate :: DynFlags -> TcTyVar -> TcType -> TcM (Maybe TcType) -- (checkTauTvUpdate tv ty) --- We are about to update the TauTv/PolyTv tv with ty. +-- We are about to update the TauTv/ReturnTv tv with ty. -- Check (a) that tv doesn't occur in ty (occurs check) -- (b) that kind(ty) is a sub-kind of kind(tv) -- @@ -873,6 +883,9 @@ checkTauTvUpdate dflags tv ty ; case sub_k of Nothing -> return Nothing Just LT -> return Nothing + _ | is_return_tv -> if tv `elemVarSet` tyVarsOfType ty + then return Nothing + else return (Just ty1) _ | defer_me ty1 -- Quick test -> -- Failed quick test so try harder case occurCheckExpand dflags tv ty1 of @@ -882,11 +895,12 @@ checkTauTvUpdate dflags tv ty | otherwise -> return (Just ty1) } where info = ASSERT2( isMetaTyVar tv, ppr tv ) metaTyVarInfo tv + -- See Note [ReturnTv] in TcType + is_return_tv = case info of { ReturnTv -> True; _ -> False } impredicative = xopt Opt_ImpredicativeTypes dflags || isOpenTypeKind (tyVarKind tv) -- Note [OpenTypeKind accepts foralls] - || case info of { PolyTv -> True; _ -> False } defer_me :: TcType -> Bool -- Checks for (a) occurrence of tv @@ -917,7 +931,6 @@ we can instantiate it with Int#. So we also allow such type variables to be instantiate with foralls. It's a bit of a hack, but seems straightforward. - Note [Conservative unification check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When unifying (tv ~ rhs), w try to avoid creating deferred constraints diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs index 60748ead29..b066b404a1 100644 --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -21,6 +21,7 @@ module MonadUtils , anyM, allM , foldlM, foldlM_, foldrM , maybeMapM + , whenM ) where ------------------------------------------------------------------------------- @@ -149,3 +150,8 @@ foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r } maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) maybeMapM _ Nothing = return Nothing maybeMapM m (Just x) = liftM Just $ m x + +-- | Monadic version of @when@, taking the condition in the monad +whenM :: Monad m => m Bool -> m () -> m () +whenM mb thing = do { b <- mb + ; when b thing } |