Commit aab8656b authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺 Committed by Ben Gamari
Browse files

Turn on MonadFail desugaring by default

Summary:
This contains two commits:

----

Make GHC's code-base compatible w/ `MonadFail`

There were a couple of use-sites which implicitly used pattern-matches
in `do`-notation even though the underlying `Monad` didn't explicitly
support `fail`

This refactoring turns those use-sites into explicit case
discrimations and adds an `MonadFail` instance for `UniqSM`
(`UniqSM` was the worst offender so this has been postponed for a
follow-up refactoring)

---

Turn on MonadFail desugaring by default

This finally implements the phase scheduled for GHC 8.6 according to

https://prime.haskell.org/wiki/Libraries/Proposals/MonadFail#Transitionalstrategy

This also preserves some tests that assumed MonadFail desugaring to be
active; all ghc boot libs were already made compatible with this
`MonadFail` long ago, so no changes were needed there.

Test Plan: Locally performed ./validate --fast

Reviewers: bgamari, simonmar, jrtc27, RyanGlScott

Reviewed By: bgamari

Subscribers: bgamari, RyanGlScott, rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D5028
parent f22baa42
......@@ -32,6 +32,7 @@ module UniqSupply (
import GhcPrelude
import Unique
import Panic (panic)
import GHC.IO
......@@ -39,6 +40,7 @@ import MonadUtils
import Control.Monad
import Data.Bits
import Data.Char
import Control.Monad.Fail
#include "Unique.h"
......@@ -147,6 +149,10 @@ instance Applicative UniqSM where
(# xx, us'' #) -> (# ff xx, us'' #)
(*>) = thenUs_
-- TODO: try to get rid of this instance
instance MonadFail UniqSM where
fail = panic
-- | Run the 'UniqSM' action, returning the final 'UniqSupply'
initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) }
......
......@@ -86,8 +86,10 @@ cgTopRhsCon dflags id con args =
mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
mk_payload (FieldOff arg _) = do
CmmLit lit <- getArgAmode arg
return lit
amode <- getArgAmode arg
case amode of
CmmLit lit -> return lit
_ -> panic "StgCmmCon.cgTopRhsCon"
nonptr_wds = tot_wds - ptr_wds
......
......@@ -29,7 +29,7 @@ module StgCmmMonad (
mkCall, mkCmmCall,
forkClosureBody, forkLneBody, forkAlts, codeOnly,
forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,
ConTagZ,
......@@ -636,6 +636,15 @@ forkAlts branch_fcodes
-- NB foldl. state is the *left* argument to stateIncUsage
; return branch_results }
forkAltPair :: FCode a -> FCode a -> FCode (a,a)
-- Most common use of 'forkAlts'; having this helper function avoids
-- accidental use of failible pattern-matches in @do@-notation
forkAltPair x y = do
xy' <- forkAlts [x,y]
case xy' of
[x',y'] -> return (x',y')
_ -> panic "forkAltPair"
-- collect the code emitted by an FCode computation
getCodeR :: FCode a -> FCode (a, CmmAGraph)
getCodeR fcode
......
......@@ -1929,10 +1929,9 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes = do
dflags <- getDynFlags
[moveCall, cpyCall] <- forkAlts [
getCode $ emitMemmoveCall dst_p src_p bytes 1,
getCode $ emitMemcpyCall dst_p src_p bytes 1
]
(moveCall, cpyCall) <- forkAltPair
(getCode $ emitMemmoveCall dst_p src_p bytes 1)
(getCode $ emitMemcpyCall dst_p src_p bytes 1)
emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
......@@ -2073,12 +2072,11 @@ doCopyMutableArrayOp = emitCopyArray copy
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes = do
dflags <- getDynFlags
[moveCall, cpyCall] <- forkAlts [
getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags),
getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags)
]
(moveCall, cpyCall) <- forkAltPair
(getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags))
(getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags))
emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
......@@ -2136,12 +2134,11 @@ doCopySmallMutableArrayOp = emitCopySmallArray copy
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes = do
dflags <- getDynFlags
[moveCall, cpyCall] <- forkAlts
[ getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags)
, getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags)
]
(moveCall, cpyCall) <- forkAltPair
(getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags))
(getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags))
emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
......
......@@ -81,6 +81,7 @@ import DynFlags
import Data.List
import Data.Char ( ord )
import Control.Monad.Fail ( MonadFail )
infixl 4 `mkCoreApp`, `mkCoreApps`
......@@ -601,7 +602,7 @@ mkFoldrExpr elt_ty result_ty c n list = do
`App` list)
-- | Make a 'build' expression applied to a locally-bound worker function
mkBuildExpr :: (MonadThings m, MonadUnique m)
mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m)
=> Type -- ^ Type of list elements to be built
-> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's
-- of the binders for the build worker function, returns
......
......@@ -292,11 +292,15 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
tickish <- tickishType `liftM` getEnv
if inline && tickish == ProfNotes then return (L pos funBind) else do
(fvs, mg@(MG { mg_alts = matches' })) <-
(fvs, mg) <-
getFreeVars $
addPathEntry name $
addTickMatchGroup False (fun_matches funBind)
case mg of
MG {} -> return ()
_ -> panic "addTickLHsBind"
blackListed <- isBlackListed pos
exported_names <- liftM exports getEnv
......@@ -315,7 +319,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
return Nothing
let mbCons = maybe Prelude.id (:)
return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }
return $ L pos $ funBind { fun_matches = mg
, fun_tick = tick `mbCons` fun_tick funBind }
where
......
......@@ -125,9 +125,12 @@ mallocStrings hsc_env ulbcos = do
return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }
spliceLit (BCONPtrStr _) = do
(RemotePtr p : rest) <- get
put rest
return (BCONPtrWord (fromIntegral p))
rptrs <- get
case rptrs of
(RemotePtr p : rest) -> do
put rest
return (BCONPtrWord (fromIntegral p))
_ -> panic "mallocStrings:spliceLit"
spliceLit other = return other
splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco
......
......@@ -308,8 +308,10 @@ cPprTerm printers_ = go 0 where
go prec t = do
let default_ = Just `liftM` pprTermM go prec t
mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
Just doc <- firstJustM mb_customDocs
return$ cparen (prec>app_prec+1) doc
mdoc <- firstJustM mb_customDocs
case mdoc of
Nothing -> panic "cPprTerm"
Just doc -> return $ cparen (prec>app_prec+1) doc
firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
firstJustM [] = return Nothing
......
......@@ -571,7 +571,8 @@ genCallSimpleCast w t@(PrimTarget op) [dst] args = do
(argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, [])
(argsV', stmts4) <- castVars Signed $ zip argsV [width]
(retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
([retV'], stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
(retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
let retV' = singletonPanic "genCallSimpleCast" retVs'
let s2 = Store retV' dstV
let stmts = stmts2 `appOL` stmts4 `snocOL`
......@@ -602,7 +603,8 @@ genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do
(argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, [])
(argsV', stmts4) <- castVars Signed $ zip argsV (const width <$> argsV)
(retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
([retV'], stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
(retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
let retV' = singletonPanic "genCallSimpleCast2" retVs'
let s2 = Store retV' dstV
let stmts = stmts2 `appOL` stmts4 `snocOL`
......@@ -1275,7 +1277,8 @@ genMachOp _ op [x] = case op of
negateVec ty v2 negOp = do
(vx, stmts1, top) <- exprToVar x
([vx'], stmts2) <- castVars Signed [(vx, ty)]
(vxs', stmts2) <- castVars Signed [(vx, ty)]
let vx' = singletonPanic "genMachOp: negateVec" vxs'
(v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
......@@ -1338,7 +1341,8 @@ genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
vval <- exprToVarW val
vidx <- exprToVarW idx
[vval'] <- castVarsW Signed [(vval, LMVector l ty)]
vval' <- singletonPanic "genMachOp_slow" <$>
castVarsW Signed [(vval, LMVector l ty)]
doExprW ty $ Extract vval' vidx
where
ty = widthToLlvmInt w
......@@ -1346,7 +1350,8 @@ genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do
vval <- exprToVarW val
vidx <- exprToVarW idx
[vval'] <- castVarsW Signed [(vval, LMVector l ty)]
vval' <- singletonPanic "genMachOp_slow" <$>
castVarsW Signed [(vval, LMVector l ty)]
doExprW ty $ Extract vval' vidx
where
ty = widthToLlvmFloat w
......@@ -1356,7 +1361,8 @@ genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do
vval <- exprToVarW val
velt <- exprToVarW elt
vidx <- exprToVarW idx
[vval'] <- castVarsW Signed [(vval, ty)]
vval' <- singletonPanic "genMachOp_slow" <$>
castVarsW Signed [(vval, ty)]
doExprW ty $ Insert vval' velt vidx
where
ty = LMVector l (widthToLlvmInt w)
......@@ -1365,7 +1371,8 @@ genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do
vval <- exprToVarW val
velt <- exprToVarW elt
vidx <- exprToVarW idx
[vval'] <- castVarsW Signed [(vval, ty)]
vval' <- singletonPanic "genMachOp_slow" <$>
castVarsW Signed [(vval, ty)]
doExprW ty $ Insert vval' velt vidx
where
ty = LMVector l (widthToLlvmFloat w)
......@@ -1477,8 +1484,10 @@ genMachOp_slow opt op [x, y] = case op of
binCastLlvmOp ty binOp = runExprData $ do
vx <- exprToVarW x
vy <- exprToVarW y
[vx', vy'] <- castVarsW Signed [(vx, ty), (vy, ty)]
doExprW ty $ binOp vx' vy'
vxy' <- castVarsW Signed [(vx, ty), (vy, ty)]
case vxy' of
[vx',vy'] -> doExprW ty $ binOp vx' vy'
_ -> panic "genMachOp_slow: binCastLlvmOp"
-- | Need to use EOption here as Cmm expects word size results from
-- comparisons while LLVM return i1. Need to extend to llvmWord type
......@@ -1981,3 +1990,8 @@ doTrashStmts :: WriterT LlvmAccum LlvmM ()
doTrashStmts = do
stmts <- lift getTrashStmts
tell $ LlvmAccum stmts mempty
-- | Return element of single-element list; 'panic' if list is not a single-element list
singletonPanic :: String -> [a] -> a
singletonPanic _ [x] = x
singletonPanic s _ = panic s
......@@ -2116,6 +2116,7 @@ languageExtensions (Just Haskell98)
= [LangExt.ImplicitPrelude,
-- See Note [When is StarIsType enabled]
LangExt.StarIsType,
LangExt.MonadFailDesugaring,
LangExt.MonomorphismRestriction,
LangExt.NPlusKPatterns,
LangExt.DatatypeContexts,
......@@ -2132,6 +2133,7 @@ languageExtensions (Just Haskell2010)
= [LangExt.ImplicitPrelude,
-- See Note [When is StarIsType enabled]
LangExt.StarIsType,
LangExt.MonadFailDesugaring,
LangExt.MonomorphismRestriction,
LangExt.DatatypeContexts,
LangExt.TraditionalRecordSyntax,
......
......@@ -942,7 +942,11 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
ValBinds noExt
(unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt
let (hvals_io, fix_env) = case pstmt of
Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env')
_ -> panic "compileParsedExprRemote"
updateFixityEnv fix_env
status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)
case status of
......
......@@ -423,7 +423,10 @@ genCCall target dest_regs args
return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
ForeignTarget expr _
-> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr
-> do (dyn_c, dyn_rs) <- arg_to_int_vregs expr
let dyn_r = case dyn_rs of
[dyn_r'] -> dyn_r'
_ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
PrimTarget mop
......@@ -433,7 +436,10 @@ genCCall target dest_regs args
return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
Right mopExpr -> do
(dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr
(dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr
let dyn_r = case dyn_rs of
[dyn_r'] -> dyn_r'
_ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
return lblOrMopExpr
......
......@@ -997,9 +997,13 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->
ASSERT2(null rdr_fs, ppr rdr_fs) do
(name, AvailTC _ ns subflds, mb_parent)
(name, avail, mb_parent)
<- lookup_name (IEThingAbs noExt ltc) (ieWrappedName rdr_tc)
let (ns,subflds) = case avail of
AvailTC _ ns' subflds' -> (ns',subflds')
Avail _ -> panic "filterImports"
-- Look up the children in the sub-names of the parent
let subnames = case ns of -- The tc is first in ns,
[] -> [] -- if it is there at all
......
......@@ -9,6 +9,7 @@ The deriving code for the Functor, Foldable, and Traversable classes
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module TcGenFunctor (
FFoldType(..), functorLikeTraverse,
......@@ -435,20 +436,24 @@ foldDataConArgs ft con
mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
-- (mkSimpleLam fn) returns (\x. fn(x))
mkSimpleLam lam = do
(n:names) <- get
put names
body <- lam (nlHsVar n)
return (mkHsLam [nlVarPat n] body)
mkSimpleLam lam =
get >>= \case
n:names -> do
put names
body <- lam (nlHsVar n)
return (mkHsLam [nlVarPat n] body)
_ -> panic "mkSimpleLam"
mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
-> State [RdrName] (LHsExpr GhcPs))
-> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam2 lam = do
(n1:n2:names) <- get
put names
body <- lam (nlHsVar n1) (nlHsVar n2)
return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
mkSimpleLam2 lam =
get >>= \case
n1:n2:names -> do
put names
body <- lam (nlHsVar n1) (nlHsVar n2)
return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
_ -> panic "mkSimpleLam2"
-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
--
......
......@@ -134,6 +134,11 @@ Language
See :ghc-ticket:`13833`.
- :extension:`MonadFailDesugaring` is now enabled by default. See
`MonadFail Proposal (MFP)
<https://prime.haskell.org/wiki/Libraries/Proposals/MonadFail>`__
for more details.
Compiler
~~~~~~~~
......
......@@ -1592,14 +1592,13 @@ New monadic failure desugaring mechanism
when desugaring refutable patterns in ``do`` blocks.
 
The ``-XMonadFailDesugaring`` extension switches the desugaring of
``do``-blocks to use ``MonadFail.fail`` instead of ``Monad.fail``. This will
eventually be the default behaviour in a future GHC release, under the
``do``-blocks to use ``MonadFail.fail`` instead of ``Monad.fail``.
This extension is enabled by default since GHC 8.6.1, under the
`MonadFail Proposal (MFP)
<https://prime.haskell.org/wiki/Libraries/Proposals/MonadFail>`__.
 
This extension is temporary, and will be deprecated in a future release. It is
included so that library authors have a hard check for whether their code
will work with future GHC versions.
This extension is temporary, and will be deprecated in a future release.
 
.. _rebindable-syntax:
 
......
......@@ -889,7 +889,10 @@ installInteractivePrint :: Maybe String -> Bool -> GHCi ()
installInteractivePrint Nothing _ = return ()
installInteractivePrint (Just ipFun) exprmode = do
ok <- trySuccess $ do
(name:_) <- GHC.parseName ipFun
names <- GHC.parseName ipFun
let name = case names of
name':_ -> name'
[] -> panic "installInteractivePrint"
modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
in he{hsc_IC = new_ic})
return Succeeded
......@@ -3249,7 +3252,7 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
case mb_span of
Nothing -> stepCmd []
Just loc -> do
Just md <- getCurrentBreakModule
md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule
current_toplevel_decl <- enclosingTickSpan md loc
doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep
......@@ -3740,7 +3743,7 @@ turnOffBreak loc = do
getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)
getModBreak m = do
Just mod_info <- GHC.getModuleInfo m
mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m
let modBreaks = GHC.modInfoModBreaks mod_info
let arr = GHC.modBreaks_flags modBreaks
let ticks = GHC.modBreaks_locs modBreaks
......
......@@ -4,6 +4,7 @@ module Main where
import GHC
import MonadUtils ( liftIO )
import Data.Maybe
import DynFlags ( defaultFatalMessager, defaultFlushOut )
import Annotations ( AnnTarget(..), CoreAnnTarget )
import GHC.Serialized ( deserializeWithData )
......@@ -34,7 +35,7 @@ main = defaultErrorHandler defaultFatalMessager defaultFlushOut
liftIO $ putStrLn "Finding Module"
mod <- findModule mod_nm Nothing
liftIO $ putStrLn "Getting Module Info"
Just mod_info <- getModuleInfo mod
mod_info <- fromJust <$> getModuleInfo mod
liftIO $ putStrLn "Showing Details For Module"
showTargetAnns (ModuleTarget mod)
......
......@@ -2,6 +2,8 @@
-- is reflected by calling the monadic 'fail', not by a
-- runtime exception
{-# LANGUAGE NoMonadFailDesugaring #-}
import Control.Monad
import Data.Maybe
......
......@@ -20,7 +20,7 @@
-- | Module "Trampoline" defines the pipe computations and their basic building blocks.
{-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses,
TypeFamilies, KindSignatures, FlexibleContexts,
TypeFamilies, KindSignatures, FlexibleContexts, NoMonadFailDesugaring,
FlexibleInstances, OverlappingInstances, UndecidableInstances
#-}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment