Commit 9d0c8f84 authored by batterseapower's avatar batterseapower

Support for -fwarn-unused-do-bind and -fwarn-wrong-do-bind, as per #3263

parent ab1d5052
......@@ -124,17 +124,17 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
dump Opt_D_dump_cmmz "procpoint map" procPointMap
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
(CmmProc h l args (stackInfo, g))
mapM (dump Opt_D_dump_cmmz "after splitting") gs
mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
mapM (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
mapM (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
let gs'' = map (bundleCAFs cafEnv) gs'
mapM (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
return (localCAFs, gs'')
where dflags = hsc_dflags hsc_env
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
......
......@@ -69,7 +69,7 @@ lintCmmBlock labels (BasicBlock id stmts)
lintCmmExpr :: CmmExpr -> CmmLint CmmType
lintCmmExpr (CmmLoad expr rep) = do
lintCmmExpr expr
_ <- lintCmmExpr expr
when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
cmmCheckWordAddress expr
return rep
......@@ -126,8 +126,8 @@ lintCmmStmt labels = lint
then return ()
else cmmLintAssignErr stmt erep reg_ty
lint (CmmStore l r) = do
lintCmmExpr l
lintCmmExpr r
_ <- lintCmmExpr l
_ <- lintCmmExpr r
return ()
lint (CmmCall target _res args _ _) =
lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
......
......@@ -167,8 +167,7 @@ instance Monad m => DataflowAnalysis (DFM' m) where
text "changed from", nest 4 (ppr old_a), text "to",
nest 4 (ppr new),
text "after supposedly reaching fixed point;",
text "env is", pprFacts facts])
; setFact id a }
text "env is", pprFacts facts]) }
}
where pprFacts env = vcat (map pprFact (blockEnvToList env))
pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
......
......@@ -505,7 +505,7 @@ forward_sol check_maybe = forw
forw rewrite name start_facts transfers rewrites =
let anal_f :: DFM a b -> a -> Graph m l -> DFM a b
anal_f finish in' g =
do { fwd_pure_anal name emptyBlockEnv transfers in' g; finish }
do { _ <- fwd_pure_anal name emptyBlockEnv transfers in' g; finish }
solve :: DFM a b -> a -> Graph m l -> Fuel -> DFM a (b, Fuel)
solve finish in_fact (Graph entry blockenv) fuel =
......@@ -609,7 +609,7 @@ forward_rew check_maybe = forw
in_fact `seq` g `seq`
let Graph entry blockenv = g
blocks = G.postorder_dfs_from blockenv entry
in do { solve depth name start transfers rewrites in_fact g fuel
in do { _ <- solve depth name start transfers rewrites in_fact g fuel
; eid <- freshBlockId "temporary entry id"
; (rewritten, fuel) <-
rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
......@@ -618,7 +618,7 @@ forward_rew check_maybe = forw
; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
}
don't_rewrite facts finish in_fact g fuel =
do { solve depth name facts transfers rewrites in_fact g fuel
do { _ <- solve depth name facts transfers rewrites in_fact g fuel
; a <- finish
; return (a, g, fuel)
}
......@@ -684,8 +684,8 @@ forward_rew check_maybe = forw
either_last rewrites in' (LastOther l) = fr_last rewrites l in'
check_facts in' (LastOther l) =
let LastOutFacts last_outs = ft_last_outs transfers l in'
in mapM (uncurry checkFactMatch) last_outs
check_facts _ LastExit = return []
in mapM_ (uncurry checkFactMatch) last_outs
check_facts _ LastExit = return ()
in fixed_pt_and_fuel
lastOutFacts :: DFM f (LastOutFacts f)
......@@ -781,7 +781,7 @@ backward_sol check_maybe = back
my_trace "analysis rewrites last node"
(ppr l <+> pprGraph g') $
subsolve g exit_fact fuel
; set_head_fact h a fuel
; _ <- set_head_fact h a fuel
; return fuel }
in do { fuel <- run "backward" name set_block_fact blocks fuel
......
......@@ -439,7 +439,7 @@ cgDataCon data_con
= do { code_blks <- getCgStmts the_code
; emitClosureCodeAndInfoTable cl_info [] code_blks }
where
the_code = do { ticky_code
the_code = do { _ <- ticky_code
; ldvEnter (CmmReg nodeReg)
; body_code }
......
......@@ -78,7 +78,7 @@ initHeapUsage :: (VirtualHpOffset -> Code) -> Code
initHeapUsage fcode
= do { orig_hp_usage <- getHpUsage
; setHpUsage initHpUsage
; fixC (\heap_usage2 -> do
; fixC_(\heap_usage2 -> do
{ fcode (heapHWM heap_usage2)
; getHpUsage })
; setHpUsage orig_hp_usage }
......
......@@ -168,7 +168,7 @@ cgLetNoEscapeClosure
-- Ignore the label that comes back from
-- mkRetDirectTarget. It must be conjured up elswhere
; emitReturnTarget (idName bndr) abs_c
; _ <- emitReturnTarget (idName bndr) abs_c
; return () })
; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) }
......
......@@ -13,7 +13,7 @@ module CgMonad (
FCode, -- type
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
returnFC, fixC, checkedAbsC,
returnFC, fixC, fixC_, checkedAbsC,
stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
newUnique, newUniqSupply,
......@@ -443,6 +443,9 @@ fixC fcode = FCode (
in
result
)
fixC_ :: (a -> FCode a) -> FCode ()
fixC_ fcode = fixC fcode >> return ()
\end{code}
%************************************************************************
......
......@@ -198,25 +198,23 @@ allocPrimStack rep
Allocate a chunk ON TOP OF the stack.
\begin{code}
allocStackTop :: WordOff -> FCode VirtualSpOffset
allocStackTop :: WordOff -> FCode ()
allocStackTop size
= do { stk_usg <- getStkUsage
; let push_virt_sp = virtSp stk_usg + size
; setStkUsage (stk_usg { virtSp = push_virt_sp,
hwSp = hwSp stk_usg `max` push_virt_sp })
; return push_virt_sp }
hwSp = hwSp stk_usg `max` push_virt_sp }) }
\end{code}
Pop some words from the current top of stack. This is used for
de-allocating the return address in a case alternative.
\begin{code}
deAllocStackTop :: WordOff -> FCode VirtualSpOffset
deAllocStackTop :: WordOff -> FCode ()
deAllocStackTop size
= do { stk_usg <- getStkUsage
; let pop_virt_sp = virtSp stk_usg - size
; setStkUsage (stk_usg { virtSp = pop_virt_sp })
; return pop_virt_sp }
; setStkUsage (stk_usg { virtSp = pop_virt_sp }) }
\end{code}
\begin{code}
......@@ -231,7 +229,7 @@ A knot-tying beast.
\begin{code}
getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
getFinalStackHW fcode
= do { fixC (\hw_sp -> do
= do { fixC_ (\hw_sp -> do
{ fcode hw_sp
; stk_usg <- getStkUsage
; return (hwSp stk_usg) })
......
......@@ -113,7 +113,7 @@ cgTopBinding dflags (StgRec pairs, _srts)
= do { let (bndrs, rhss) = unzip pairs
; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
; let pairs' = zip bndrs' rhss
; fixC (\ new_binds -> do
; fixC_(\ new_binds -> do
{ addBindsC new_binds
; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
; return () }
......@@ -334,7 +334,7 @@ cgDataCon data_con
mk_code ticky_code
= -- NB: We don't set CC when entering data (WDP 94/06)
do { ticky_code
do { _ <- ticky_code
; ldvEnter (CmmReg nodeReg)
; tickyReturnOldCon (length arg_things)
; emitReturn [cmmOffsetB (CmmReg nodeReg)
......
......@@ -296,7 +296,7 @@ cgCase scrut bndr srt alt_type alts
; restoreCurrentCostCentre mb_cc
-- JD: We need Note: [Better Alt Heap Checks]
; bindArgsToRegs ret_bndrs
; _ <- bindArgsToRegs ret_bndrs
; cgAlts gc_plan (NonVoid bndr) alt_type alts }
-----------------
......@@ -408,7 +408,7 @@ cgAltRhss gc_plan bndr alts
cg_alt (con, bndrs, _uses, rhs)
= getCodeR $
maybeAltHeapCheck gc_plan $
do { bindConArgs con base_reg bndrs
do { _ <- bindConArgs con base_reg bndrs
; cgExpr rhs
; return con }
......
......@@ -10,7 +10,7 @@ module StgCmmMonad (
FCode, -- type
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
returnFC, fixC, nopC, whenC,
returnFC, fixC, fixC_, nopC, whenC,
newUnique, newUniqSupply,
emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc,
......@@ -149,6 +149,8 @@ fixC fcode = FCode (
result
)
fixC_ :: (a -> FCode a) -> FCode ()
fixC_ fcode = fixC fcode >> return ()
--------------------------------------------------------
-- The code generator environment
......
......@@ -56,17 +56,17 @@ place for them. They print out stuff before and after core passes,
and do Core Lint when necessary.
\begin{code}
endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
endPass = dumpAndLint dumpIfSet_core
endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
endPassIf cond = dumpAndLint (dumpIf_core cond)
endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
endIteration = dumpAndLint dumpIfSet_dyn
dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
-> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
-> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
dumpAndLint dump dflags pass_name dump_flag binds
= do
-- Report result size if required
......@@ -79,8 +79,6 @@ dumpAndLint dump dflags pass_name dump_flag binds
-- Type check
lintCoreBindings dflags pass_name binds
return binds
\end{code}
......@@ -303,7 +301,7 @@ lintCoreExpr (Let (NonRec bndr rhs) body)
lintCoreExpr (Let (Rec pairs) body)
= lintAndScopeIds bndrs $ \_ ->
do { mapM (lintSingleBinding NotTopLevel Recursive) pairs
do { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
where
bndrs = map fst pairs
......@@ -353,7 +351,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
else lintAndScopeId var
; scope $ \_ ->
do { -- Check the alternatives
mapM (lintCoreAlt scrut_ty alt_ty) alts
mapM_ (lintCoreAlt scrut_ty alt_ty) alts
; checkCaseAlts e scrut_ty alts
; return alt_ty } }
where
......@@ -552,7 +550,7 @@ lintBinder var linterF
| isTyVar var = lint_ty_bndr
| otherwise = lintIdBndr var linterF
where
lint_ty_bndr = do { lintTy (tyVarKind var)
lint_ty_bndr = do { _ <- lintTy (tyVarKind var)
; subst <- getTvSubst
; let (subst', tv') = substTyVarBndr subst var
; updateTvSubst subst' (linterF tv') }
......@@ -719,7 +717,7 @@ lookupIdInScope id
= do { subst <- getTvSubst
; case lookupInScope (getTvInScope subst) id of
Just v -> return v
Nothing -> do { addErrL out_of_scope
Nothing -> do { _ <- addErrL out_of_scope
; return id } }
where
out_of_scope = ppr id <+> ptext (sLit "is out of scope")
......
......@@ -143,6 +143,7 @@ cprAnalyse dflags binds
let { binds_plus_cpr = do_prog binds } ;
endPass dflags "Constructed Product analysis"
Opt_D_dump_cpranal binds_plus_cpr
return binds_plus_cpr
}
where
do_prog :: [CoreBind] -> [CoreBind]
......
......@@ -61,6 +61,8 @@ import Util
import Bag
import Outputable
import FastString
import Control.Monad
\end{code}
......@@ -662,23 +664,27 @@ dsDo :: [LStmt Id]
-> DsM CoreExpr
dsDo stmts body _result_ty
= go (map unLoc stmts)
= goL stmts
where
go [] = dsLExpr body
go (ExprStmt rhs then_expr _ : stmts)
goL [] = dsLExpr body
goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go stmt lstmts)
go (ExprStmt rhs then_expr _) stmts
= do { rhs2 <- dsLExpr rhs
; then_expr2 <- dsExpr then_expr
; rest <- go stmts
; case tcSplitAppTy_maybe (exprType rhs2) of
Just (container_ty, returning_ty) -> warnDiscardedDoBindings container_ty returning_ty
_ -> return ()
; then_expr2 <- dsExpr then_expr
; rest <- goL stmts
; return (mkApps then_expr2 [rhs2, rest]) }
go (LetStmt binds : stmts)
= do { rest <- go stmts
go (LetStmt binds) stmts
= do { rest <- goL stmts
; dsLocalBinds binds rest }
go (BindStmt pat rhs bind_op fail_op : stmts)
go (BindStmt pat rhs bind_op fail_op) stmts
=
do { body <- go stmts
do { body <- goL stmts
; rhs' <- dsLExpr rhs
; bind_op' <- dsExpr bind_op
; var <- selectSimpleMatchVarL pat
......@@ -719,8 +725,11 @@ dsMDo :: PostTcTable
-> DsM CoreExpr
dsMDo tbl stmts body result_ty
= go (map unLoc stmts)
= goL stmts
where
goL [] = dsLExpr body
goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
(m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
mfix_id = lookupEvidence tbl mfixName
return_id = lookupEvidence tbl returnMName
......@@ -729,19 +738,18 @@ dsMDo tbl stmts body result_ty
fail_id = lookupEvidence tbl failMName
ctxt = MDoExpr tbl
go [] = dsLExpr body
go (LetStmt binds : stmts)
= do { rest <- go stmts
go _ (LetStmt binds) stmts
= do { rest <- goL stmts
; dsLocalBinds binds rest }
go (ExprStmt rhs _ rhs_ty : stmts)
go _ (ExprStmt rhs _ rhs_ty) stmts
= do { rhs2 <- dsLExpr rhs
; rest <- go stmts
; warnDiscardedDoBindings m_ty rhs_ty
; rest <- goL stmts
; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
go (BindStmt pat rhs _ _ : stmts)
= do { body <- go stmts
go _ (BindStmt pat rhs _ _) stmts
= do { body <- goL stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
result_ty (cantFailMatchResult body)
......@@ -753,13 +761,13 @@ dsMDo tbl stmts body result_ty
; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
go loc (RecStmt rec_stmts later_ids rec_ids rec_rets binds) stmts
= ASSERT( length rec_ids > 0 )
ASSERT( length rec_ids == length rec_rets )
go (new_bind_stmt : let_stmt : stmts)
goL (new_bind_stmt : let_stmt : stmts)
where
new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
-- Remove the later_ids that appear (without fancy coercions)
......@@ -803,3 +811,37 @@ dsMDo tbl stmts body result_ty
mk_ret_tup [r] = r
mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed
\end{code}
%************************************************************************
%* *
\subsection{Errors and contexts}
%* *
%************************************************************************
\begin{code}
-- Warn about certain types of values discarded in monadic bindings (#3263)
warnDiscardedDoBindings :: Type -> Type -> DsM ()
warnDiscardedDoBindings container_ty returning_ty = do
-- Warn about discarding non-() things in 'monadic' binding
warn_unused <- doptDs Opt_WarnUnusedDoBind
when (warn_unused && not (returning_ty `tcEqType` unitTy)) $
warnDs (unusedMonadBind returning_ty)
-- Warn about discarding m a things in 'monadic' binding of the same type
warn_wrong <- doptDs Opt_WarnWrongDoBind
case tcSplitAppTy_maybe returning_ty of
Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
warnDs (wrongMonadBind returning_ty)
_ -> return ()
unusedMonadBind :: Type -> SDoc
unusedMonadBind returning_ty
= ptext (sLit "A do-notation statement threw away a result of a type which appears to contain something other than (), namely") <+> ppr returning_ty <>
ptext (sLit ". You can suppress this warning by explicitly binding the result to _")
wrongMonadBind :: Type -> SDoc
wrongMonadBind returning_ty
= ptext (sLit "A do-notation statement threw away a result of a type that like a monadic action waiting to execute, namely") <+> ppr returning_ty <>
ptext (sLit ". You can suppress this warning by explicitly binding the result to _")
\end{code}
......@@ -171,7 +171,7 @@ showTerm term = do
-- with the changed error handling and logging?
let noop_log _ _ _ _ = return ()
expr = "show " ++ showSDoc (ppr bname)
GHC.setSessionDynFlags dflags{log_action=noop_log}
_ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
txt_ <- withExtendedLinkEnv [(bname, val)]
(GHC.compileExpr expr)
let myprec = 10 -- application precedence. TODO Infix constructors
......
......@@ -744,7 +744,7 @@ dynLinkObjs dflags objs
pls1 = pls { objs_loaded = objs_loaded' }
unlinkeds = concatMap linkableUnlinked new_objs
mapM loadObj (map nameOfObject unlinkeds)
mapM_ loadObj (map nameOfObject unlinkeds)
-- Link the all together
ok <- resolveObjs
......
......@@ -856,7 +856,7 @@ improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
(ty_tvs, _, _) <- tcInstType return ty
(ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
(_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
getLIE(boxyUnify rtti_ty' ty')
_ <- getLIE(boxyUnify rtti_ty' ty')
tvs1_contents <- zonkTcTyVars ty_tvs'
let subst = (uncurry zipTopTvSubst . unzip)
[(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
......@@ -1096,7 +1096,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
text " in presence of newtype evidence " <> ppr new_tycon)
vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
let ty' = mkTyConApp new_tycon vars
liftTcM (boxyUnify ty (repType ty'))
_ <- liftTcM (boxyUnify ty (repType ty'))
-- assumes that reptype doesn't ^^^^ touch tyconApp args
return ty'
......
......@@ -83,8 +83,8 @@ instance Monad CvtM where
initCvt :: SrcSpan -> CvtM a -> Either Message a
initCvt loc (CvtM m) = m loc
force :: a -> CvtM a
force a = a `seq` return a
force :: a -> CvtM ()
force a = a `seq` return ()
failWith :: Message -> CvtM a
failWith m = CvtM (\_ -> Left full_msg)
......@@ -817,9 +817,10 @@ tconName n = cvtName OccName.tcClsName n
cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
cvtName ctxt_ns (TH.Name occ flavour)
| not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
| otherwise = force (thRdrName ctxt_ns occ_str flavour)
| otherwise = force rdr_name >> return rdr_name
where
occ_str = TH.occString occ
rdr_name = thRdrName ctxt_ns occ_str flavour
okOcc :: OccName.NameSpace -> String -> Bool
okOcc _ [] = False
......
......@@ -149,7 +149,7 @@ writeBinIface dflags hi_path mod_iface = do
-- The version and way descriptor go next
put_ bh (show opt_HiVersion)
way_descr <- getWayDescr
put bh way_descr
put_ bh way_descr
-- Remember where the symbol table pointer will go
symtab_p_p <- tellBin bh
......@@ -681,7 +681,7 @@ instance (Binary name) => Binary (IPName name) where
instance Binary DmdType where
-- Ignore DmdEnv when spitting out the DmdType
put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
instance Binary Demand where
......
......@@ -131,7 +131,7 @@ loadInterfaceForName doc name
loadWiredInHomeIface :: Name -> IfM lcl ()
loadWiredInHomeIface name
= ASSERT( isWiredInName name )
do loadSysInterface doc (nameModule name); return ()
do _ <- loadSysInterface doc (nameModule name); return ()
where
doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name
......
......@@ -73,7 +73,7 @@ doMkDependHS srcs = do
-- and complaining about cycles
hsc_env <- getSession
root <- liftIO getCurrentDirectory
mapM (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
-- If -ddump-mod-cycles, show cycles in the module graph
liftIO $ dumpModCycles dflags mod_summaries
......
......@@ -187,7 +187,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler)
-> return ([], ms_hs_date summary)
-- We're in --make mode: finish the compilation pipeline.
_other
-> do runPipeline StopLn hsc_env' (output_fn,Nothing)
-> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing)
(Just basename)
Persistent
(Just location)
......@@ -264,7 +264,7 @@ compileStub hsc_env mod location = do
let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env)
(moduleName mod) location
runPipeline StopLn hsc_env (stub_c,Nothing) Nothing
_ <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing
(SpecificFile stub_o) Nothing{-no ModLocation-}
return stub_o
......@@ -1234,7 +1234,7 @@ runPhase_MoveBinary dflags input_fn dep_packages
pvm_executable_base = "=" ++ input_fn
pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
-- nuke old binary; maybe use configur'ed names for cp and rm?
tryIO (removeFile pvm_executable)
_ <- tryIO (removeFile pvm_executable)
-- move the newly created binary into PVM land
copy dflags "copying PVM executable" input_fn pvm_executable
-- generate a wrapper script for running a parallel prg under PVM
......
-- |
-- Dynamic flags
--
......@@ -192,6 +191,9 @@ data DynFlag
| Opt_WarnUnrecognisedPragmas
| Opt_WarnDodgyForeignImports
| Opt_WarnLazyUnliftedBindings
| Opt_WarnUnusedDoBind
| Opt_WarnWrongDoBind
-- language opts
| Opt_OverlappingInstances
......@@ -909,7 +911,8 @@ standardWarnings
Opt_WarnMissingMethods,
Opt_WarnDuplicateExports,
Opt_WarnLazyUnliftedBindings,
Opt_WarnDodgyForeignImports
Opt_WarnDodgyForeignImports,
Opt_WarnWrongDoBind
]
minusWOpts :: [DynFlag]
......@@ -929,7 +932,8 @@ minusWallOpts
Opt_WarnNameShadowing,
Opt_WarnMissingSigs,
Opt_WarnHiShadows,
Opt_WarnOrphans
Opt_WarnOrphans,
Opt_WarnUnusedDoBind
]
-- minuswRemovesOpts should be every warning option
......@@ -1664,6 +1668,8 @@ fFlags = [
( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, const Supported ),
( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings,
const $ Deprecated "lazy unlifted bindings will be an error in GHC 6.14, and this flag will no longer exist"),
( "warn-unused-do-bind", Opt_WarnUnusedDoBind, const Supported ),
( "warn-wrong-do-bind", Opt_WarnWrongDoBind, const Supported ),
( "print-explicit-foralls", Opt_PrintExplicitForalls, const Supported ),
( "strictness", Opt_Strictness, const Supported ),
( "static-argument-transformation", Opt_StaticArgumentTransformation, const Supported ),
......
......@@ -784,7 +784,7 @@ load2 how_much mod_graph = do
(flattenSCCs mg2_with_srcimps)
stable_mods
liftIO $ evaluate pruned_hpt
_ <- liftIO $ evaluate pruned_hpt
-- before we unload anything, make sure we don't leave an old
-- interactive context around pointing to dead bindings. Also,
......@@ -1208,7 +1208,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
(iface, changed, _details, cgguts)
<- hscNormalIface guts Nothing
hscWriteIface iface changed modSummary
hscGenHardCode cgguts modSummary
_ <- hscGenHardCode cgguts modSummary
return ()