Ticket #3263: 3263.patch

File 3263.patch, 54.7 KB (added by batterseapower, 5 years ago)

Patch for the compiler incorporating SPJ comments

Line 
1Wed Jul  1 21:03:44 BST 2009  Max Bolingbroke <batterseapower@hotmail.com>
2  * Support for -fwarn-unused-do-bind and -fwarn-wrong-do-bind, as per #3263
3
4Thu Jul  2 16:09:43 BST 2009  Max Bolingbroke <batterseapower@hotmail.com>
5  * Make changes to -fwarn-unused-do-bind and -fwarn-wrong-do-bind suggested by SPJ
6
7New patches:
8
9[Support for -fwarn-unused-do-bind and -fwarn-wrong-do-bind, as per #3263
10Max Bolingbroke <batterseapower@hotmail.com>**20090701200344
11 Ignore-this: 511117ffc10d4b656e530b751559b8b8
12] {
13hunk ./compiler/cmm/CmmCPSZ.hs 127
14        dump Opt_D_dump_cmmz "procpoint map" procPointMap
15        gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
16                                        (CmmProc h l args (stackInfo, g))
17-       mapM (dump Opt_D_dump_cmmz "after splitting") gs
18+       mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
19        let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
20        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
21        gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
22hunk ./compiler/cmm/CmmCPSZ.hs 131
23-       mapM (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
24+       mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
25 
26        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
27        let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
28hunk ./compiler/cmm/CmmCPSZ.hs 135
29-       mapM (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
30+       mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
31        let gs'' = map (bundleCAFs cafEnv) gs'
32hunk ./compiler/cmm/CmmCPSZ.hs 137
33-       mapM (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
34+       mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
35        return (localCAFs, gs'')
36   where dflags = hsc_dflags hsc_env
37         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
38hunk ./compiler/cmm/CmmLint.hs 72
39 
40 lintCmmExpr :: CmmExpr -> CmmLint CmmType
41 lintCmmExpr (CmmLoad expr rep) = do
42-  lintCmmExpr expr
43+  _ <- lintCmmExpr expr
44   when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
45      cmmCheckWordAddress expr
46   return rep
47hunk ./compiler/cmm/CmmLint.hs 129
48                 then return ()
49                 else cmmLintAssignErr stmt erep reg_ty
50           lint (CmmStore l r) = do
51-            lintCmmExpr l
52-            lintCmmExpr r
53+            _ <- lintCmmExpr l
54+            _ <- lintCmmExpr r
55             return ()
56           lint (CmmCall target _res args _ _) =
57               lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
58hunk ./compiler/cmm/DFMonad.hs 170
59                                     text "changed from", nest 4 (ppr old_a), text "to",
60                                     nest 4 (ppr new),
61                                     text "after supposedly reaching fixed point;",
62-                                    text "env is", pprFacts facts])
63-                  ; setFact id a }
64+                                    text "env is", pprFacts facts]) }
65          }
66     where pprFacts env = vcat (map pprFact (blockEnvToList env))
67           pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
68hunk ./compiler/cmm/ZipDataflow.hs 508
69   forw rewrite name start_facts transfers rewrites =
70    let anal_f :: DFM a b -> a -> Graph m l -> DFM a b
71        anal_f finish in' g =
72-           do { fwd_pure_anal name emptyBlockEnv transfers in' g; finish }
73+           do { _ <- fwd_pure_anal name emptyBlockEnv transfers in' g; finish }
74 
75        solve :: DFM a b -> a -> Graph m l -> Fuel -> DFM a (b, Fuel)
76        solve finish in_fact (Graph entry blockenv) fuel =
77hunk ./compiler/cmm/ZipDataflow.hs 612
78            in_fact `seq` g `seq`
79             let Graph entry blockenv = g
80                 blocks = G.postorder_dfs_from blockenv entry
81-            in do { solve depth name start transfers rewrites in_fact g fuel
82+            in do { _ <- solve depth name start transfers rewrites in_fact g fuel
83                   ; eid <- freshBlockId "temporary entry id"
84                   ; (rewritten, fuel) <-
85                       rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
86hunk ./compiler/cmm/ZipDataflow.hs 621
87                   ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
88                   }
89           don't_rewrite facts finish in_fact g fuel =
90-              do  { solve depth name facts transfers rewrites in_fact g fuel
91+              do  { _ <- solve depth name facts transfers rewrites in_fact g fuel
92                   ; a <- finish
93                   ; return (a, g, fuel)
94                   }
95hunk ./compiler/cmm/ZipDataflow.hs 687
96           either_last rewrites in' (LastOther l) = fr_last rewrites l in'
97           check_facts in' (LastOther l) =
98             let LastOutFacts last_outs = ft_last_outs transfers l in'
99-            in mapM (uncurry checkFactMatch) last_outs
100-          check_facts _ LastExit = return []
101+            in mapM_ (uncurry checkFactMatch) last_outs
102+          check_facts _ LastExit = return ()
103       in  fixed_pt_and_fuel
104 
105 lastOutFacts :: DFM f (LastOutFacts f)
106hunk ./compiler/cmm/ZipDataflow.hs 784
107                                      my_trace "analysis rewrites last node"
108                                       (ppr l <+> pprGraph g') $
109                                       subsolve g exit_fact fuel
110-                    ; set_head_fact h a fuel
111+                    ; _ <- set_head_fact h a fuel
112                     ; return fuel }
113 
114          in do { fuel <- run "backward" name set_block_fact blocks fuel
115hunk ./compiler/codeGen/CgCon.lhs 442
116                = do { code_blks <- getCgStmts the_code
117                     ; emitClosureCodeAndInfoTable cl_info [] code_blks }
118                where
119-                 the_code = do { ticky_code
120+                 the_code = do { _ <- ticky_code
121                                ; ldvEnter (CmmReg nodeReg)
122                                ; body_code }
123 
124hunk ./compiler/codeGen/CgHeapery.lhs 81
125 initHeapUsage fcode
126   = do { orig_hp_usage <- getHpUsage
127        ; setHpUsage initHpUsage
128-       ; fixC (\heap_usage2 -> do
129+       ; fixC_(\heap_usage2 -> do
130                { fcode (heapHWM heap_usage2)
131                ; getHpUsage })
132        ; setHpUsage orig_hp_usage }
133hunk ./compiler/codeGen/CgLetNoEscape.lhs 171
134 
135                        -- Ignore the label that comes back from
136                        -- mkRetDirectTarget.  It must be conjured up elswhere
137-                   ; emitReturnTarget (idName bndr) abs_c
138+                   ; _ <- emitReturnTarget (idName bndr) abs_c
139                    ; return () })
140 
141        ; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) }
142hunk ./compiler/codeGen/CgMonad.lhs 16
143        FCode,  -- type
144 
145        initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
146-       returnFC, fixC, checkedAbsC,
147+       returnFC, fixC, fixC_, checkedAbsC,
148        stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
149        newUnique, newUniqSupply,
150 
151hunk ./compiler/codeGen/CgMonad.lhs 446
152                in
153                        result
154        )
155+
156+fixC_ :: (a -> FCode a) -> FCode ()
157+fixC_ fcode = fixC fcode >> return ()
158 \end{code}
159 
160 %************************************************************************
161hunk ./compiler/codeGen/CgStackery.lhs 201
162 Allocate a chunk ON TOP OF the stack. 
163 
164 \begin{code}
165-allocStackTop :: WordOff -> FCode VirtualSpOffset
166+allocStackTop :: WordOff -> FCode ()
167 allocStackTop size
168   = do { stk_usg <- getStkUsage
169        ; let push_virt_sp = virtSp stk_usg + size
170hunk ./compiler/codeGen/CgStackery.lhs 206
171        ; setStkUsage (stk_usg { virtSp = push_virt_sp,
172-                                hwSp   = hwSp stk_usg `max` push_virt_sp })
173-       ; return push_virt_sp }
174+                                hwSp   = hwSp stk_usg `max` push_virt_sp }) }
175 \end{code}
176 
177 Pop some words from the current top of stack.  This is used for
178hunk ./compiler/codeGen/CgStackery.lhs 213
179 de-allocating the return address in a case alternative.
180 
181 \begin{code}
182-deAllocStackTop :: WordOff -> FCode VirtualSpOffset
183+deAllocStackTop :: WordOff -> FCode ()
184 deAllocStackTop size
185   = do { stk_usg <- getStkUsage
186        ; let pop_virt_sp = virtSp stk_usg - size
187hunk ./compiler/codeGen/CgStackery.lhs 217
188-       ; setStkUsage (stk_usg { virtSp = pop_virt_sp })
189-       ; return pop_virt_sp }
190+       ; setStkUsage (stk_usg { virtSp = pop_virt_sp }) }
191 \end{code}
192 
193 \begin{code}
194hunk ./compiler/codeGen/CgStackery.lhs 232
195 \begin{code}
196 getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
197 getFinalStackHW fcode
198-  = do { fixC (\hw_sp -> do
199+  = do { fixC_ (\hw_sp -> do
200                { fcode hw_sp
201                ; stk_usg <- getStkUsage
202                ; return (hwSp stk_usg) })
203hunk ./compiler/codeGen/StgCmm.hs 116
204   = do { let (bndrs, rhss) = unzip pairs
205        ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
206        ; let pairs' = zip bndrs' rhss
207-       ; fixC (\ new_binds -> do
208+       ; fixC_(\ new_binds -> do
209                { addBindsC new_binds
210                ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
211        ; return () }
212hunk ./compiler/codeGen/StgCmm.hs 337
213 
214            mk_code ticky_code
215              =         -- NB: We don't set CC when entering data (WDP 94/06)
216-               do { ticky_code
217+               do { _ <- ticky_code
218                   ; ldvEnter (CmmReg nodeReg)
219                   ; tickyReturnOldCon (length arg_things)
220                   ; emitReturn [cmmOffsetB (CmmReg nodeReg)
221hunk ./compiler/codeGen/StgCmmExpr.hs 299
222        ; restoreCurrentCostCentre mb_cc
223 
224   -- JD: We need Note: [Better Alt Heap Checks]
225-       ; bindArgsToRegs ret_bndrs
226+       ; _ <- bindArgsToRegs ret_bndrs
227        ; cgAlts gc_plan (NonVoid bndr) alt_type alts }
228 
229 -----------------
230hunk ./compiler/codeGen/StgCmmExpr.hs 411
231     cg_alt (con, bndrs, _uses, rhs)
232       = getCodeR                 $
233        maybeAltHeapCheck gc_plan $
234-       do { bindConArgs con base_reg bndrs
235+       do { _ <- bindConArgs con base_reg bndrs
236           ; cgExpr rhs
237           ; return con }
238 
239hunk ./compiler/codeGen/StgCmmMonad.hs 13
240        FCode,  -- type
241 
242        initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
243-       returnFC, fixC, nopC, whenC,
244+       returnFC, fixC, fixC_, nopC, whenC,
245        newUnique, newUniqSupply,
246 
247        emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc,
248hunk ./compiler/codeGen/StgCmmMonad.hs 152
249                        result
250        )
251 
252+fixC_ :: (a -> FCode a) -> FCode ()
253+fixC_ fcode = fixC fcode >> return ()
254 
255 --------------------------------------------------------
256 --     The code generator environment
257hunk ./compiler/coreSyn/CoreLint.lhs 59
258 and do Core Lint when necessary.
259 
260 \begin{code}
261-endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
262+endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
263 endPass = dumpAndLint dumpIfSet_core
264 
265hunk ./compiler/coreSyn/CoreLint.lhs 62
266-endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
267+endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
268 endPassIf cond = dumpAndLint (dumpIf_core cond)
269 
270hunk ./compiler/coreSyn/CoreLint.lhs 65
271-endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
272+endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
273 endIteration = dumpAndLint dumpIfSet_dyn
274 
275 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
276hunk ./compiler/coreSyn/CoreLint.lhs 69
277-            -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
278+            -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
279 dumpAndLint dump dflags pass_name dump_flag binds
280   = do
281        -- Report result size if required
282hunk ./compiler/coreSyn/CoreLint.lhs 82
283 
284        -- Type check
285        lintCoreBindings dflags pass_name binds
286-
287-       return binds
288 \end{code}
289 
290 
291hunk ./compiler/coreSyn/CoreLint.lhs 304
292 
293 lintCoreExpr (Let (Rec pairs) body)
294   = lintAndScopeIds bndrs      $ \_ ->
295-    do { mapM (lintSingleBinding NotTopLevel Recursive) pairs 
296+    do { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
297        ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
298   where
299     bndrs = map fst pairs
300hunk ./compiler/coreSyn/CoreLint.lhs 354
301                    else lintAndScopeId var
302      ; scope $ \_ ->
303        do { -- Check the alternatives
304-            mapM (lintCoreAlt scrut_ty alt_ty) alts
305+            mapM_ (lintCoreAlt scrut_ty alt_ty) alts
306           ; checkCaseAlts e scrut_ty alts
307           ; return alt_ty } }
308   where
309hunk ./compiler/coreSyn/CoreLint.lhs 553
310   | isTyVar var = lint_ty_bndr
311   | otherwise   = lintIdBndr var linterF
312   where
313-    lint_ty_bndr = do { lintTy (tyVarKind var)
314+    lint_ty_bndr = do { _ <- lintTy (tyVarKind var)
315                      ; subst <- getTvSubst
316                      ; let (subst', tv') = substTyVarBndr subst var
317                      ; updateTvSubst subst' (linterF tv') }
318hunk ./compiler/coreSyn/CoreLint.lhs 720
319   = do { subst <- getTvSubst
320        ; case lookupInScope (getTvInScope subst) id of
321                Just v  -> return v
322-               Nothing -> do { addErrL out_of_scope
323+               Nothing -> do { _ <- addErrL out_of_scope
324                              ; return id } }
325   where
326     out_of_scope = ppr id <+> ptext (sLit "is out of scope")
327hunk ./compiler/cprAnalysis/CprAnalyse.lhs 146
328         let { binds_plus_cpr = do_prog binds } ;
329         endPass dflags "Constructed Product analysis"
330                 Opt_D_dump_cpranal binds_plus_cpr
331+        return binds_plus_cpr
332     }
333   where
334     do_prog :: [CoreBind] -> [CoreBind]
335hunk ./compiler/deSugar/DsExpr.lhs 64
336 import Bag
337 import Outputable
338 import FastString
339+
340+import Control.Monad
341 \end{code}
342 
343 
344hunk ./compiler/deSugar/DsExpr.lhs 667
345        -> DsM CoreExpr
346 
347 dsDo stmts body _result_ty
348-  = go (map unLoc stmts)
349+  = goL stmts
350   where
351hunk ./compiler/deSugar/DsExpr.lhs 669
352-    go [] = dsLExpr body
353-   
354-    go (ExprStmt rhs then_expr _ : stmts)
355+    goL [] = dsLExpr body
356+    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go stmt lstmts)
357
358+    go (ExprStmt rhs then_expr _) stmts
359       = do { rhs2 <- dsLExpr rhs
360hunk ./compiler/deSugar/DsExpr.lhs 674
361-          ; then_expr2 <- dsExpr then_expr
362-          ; rest <- go stmts
363+           ; case tcSplitAppTy_maybe (exprType rhs2) of
364+                Just (container_ty, returning_ty) -> warnDiscardedDoBindings container_ty returning_ty
365+                _                                 -> return ()
366+           ; then_expr2 <- dsExpr then_expr
367+          ; rest <- goL stmts
368           ; return (mkApps then_expr2 [rhs2, rest]) }
369     
370hunk ./compiler/deSugar/DsExpr.lhs 681
371-    go (LetStmt binds : stmts)
372-      = do { rest <- go stmts
373+    go (LetStmt binds) stmts
374+      = do { rest <- goL stmts
375           ; dsLocalBinds binds rest }
376 
377hunk ./compiler/deSugar/DsExpr.lhs 685
378-    go (BindStmt pat rhs bind_op fail_op : stmts)
379+    go (BindStmt pat rhs bind_op fail_op) stmts
380       =
381hunk ./compiler/deSugar/DsExpr.lhs 687
382-       do  { body     <- go stmts
383+       do  { body     <- goL stmts
384            ; rhs'     <- dsLExpr rhs
385           ; bind_op' <- dsExpr bind_op
386           ; var   <- selectSimpleMatchVarL pat
387hunk ./compiler/deSugar/DsExpr.lhs 728
388        -> DsM CoreExpr
389 
390 dsMDo tbl stmts body result_ty
391-  = go (map unLoc stmts)
392+  = goL stmts
393   where
394hunk ./compiler/deSugar/DsExpr.lhs 730
395+    goL [] = dsLExpr body
396+    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
397
398     (m_ty, b_ty) = tcSplitAppTy result_ty      -- result_ty must be of the form (m b)
399     mfix_id   = lookupEvidence tbl mfixName
400     return_id = lookupEvidence tbl returnMName
401hunk ./compiler/deSugar/DsExpr.lhs 741
402     fail_id   = lookupEvidence tbl failMName
403     ctxt      = MDoExpr tbl
404 
405-    go [] = dsLExpr body
406-   
407-    go (LetStmt binds : stmts)
408-      = do { rest <- go stmts
409+    go _ (LetStmt binds) stmts
410+      = do { rest <- goL stmts
411           ; dsLocalBinds binds rest }
412 
413hunk ./compiler/deSugar/DsExpr.lhs 745
414-    go (ExprStmt rhs _ rhs_ty : stmts)
415+    go _ (ExprStmt rhs _ rhs_ty) stmts
416       = do { rhs2 <- dsLExpr rhs
417hunk ./compiler/deSugar/DsExpr.lhs 747
418-          ; rest <- go stmts
419+          ; warnDiscardedDoBindings m_ty rhs_ty
420+           ; rest <- goL stmts
421           ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
422     
423hunk ./compiler/deSugar/DsExpr.lhs 751
424-    go (BindStmt pat rhs _ _ : stmts)
425-      = do { body  <- go stmts
426+    go _ (BindStmt pat rhs _ _) stmts
427+      = do { body  <- goL stmts
428           ; var   <- selectSimpleMatchVarL pat
429           ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
430                                  result_ty (cantFailMatchResult body)
431hunk ./compiler/deSugar/DsExpr.lhs 764
432           ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
433                                             rhs', Lam var match_code]) }
434     
435-    go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
436+    go loc (RecStmt rec_stmts later_ids rec_ids rec_rets binds) stmts
437       = ASSERT( length rec_ids > 0 )
438         ASSERT( length rec_ids == length rec_rets )
439hunk ./compiler/deSugar/DsExpr.lhs 767
440-       go (new_bind_stmt : let_stmt : stmts)
441+       goL (new_bind_stmt : let_stmt : stmts)
442       where
443hunk ./compiler/deSugar/DsExpr.lhs 769
444-        new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
445-       let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
446+        new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
447+       let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
448 
449       
450                -- Remove the later_ids that appear (without fancy coercions)
451hunk ./compiler/deSugar/DsExpr.lhs 814
452        mk_ret_tup [r] = r
453        mk_ret_tup rs  = noLoc $ ExplicitTuple rs Boxed
454 \end{code}
455+
456+
457+%************************************************************************
458+%*                                                                     *
459+\subsection{Errors and contexts}
460+%*                                                                     *
461+%************************************************************************
462+
463+\begin{code}
464+-- Warn about certain types of values discarded in monadic bindings (#3263)
465+warnDiscardedDoBindings :: Type -> Type -> DsM ()
466+warnDiscardedDoBindings container_ty returning_ty = do
467+        -- Warn about discarding non-() things in 'monadic' binding
468+        warn_unused <- doptDs Opt_WarnUnusedDoBind
469+        when (warn_unused && not (returning_ty `tcEqType` unitTy)) $
470+              warnDs (unusedMonadBind returning_ty)
471+       
472+        -- Warn about discarding m a things in 'monadic' binding of the same type
473+        warn_wrong <- doptDs Opt_WarnWrongDoBind
474+        case tcSplitAppTy_maybe returning_ty of
475+                Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
476+                                                          warnDs (wrongMonadBind returning_ty)
477+                _ -> return ()
478+
479+unusedMonadBind :: Type -> SDoc
480+unusedMonadBind returning_ty
481+  = ptext (sLit "A do-notation statement threw away a result of a type which appears to contain something other than (), namely") <+> ppr returning_ty <>
482+    ptext (sLit ". You can suppress this warning by explicitly binding the result to _")
483+
484+wrongMonadBind :: Type -> SDoc
485+wrongMonadBind returning_ty
486+  = 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 <>
487+    ptext (sLit ". You can suppress this warning by explicitly binding the result to _")
488+\end{code}
489hunk ./compiler/ghci/Debugger.hs 174
490                       -- with the changed error handling and logging?
491            let noop_log _ _ _ _ = return ()
492                expr = "show " ++ showSDoc (ppr bname)
493-           GHC.setSessionDynFlags dflags{log_action=noop_log}
494+           _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
495            txt_ <- withExtendedLinkEnv [(bname, val)]
496                                          (GHC.compileExpr expr)
497            let myprec = 10 -- application precedence. TODO Infix constructors
498hunk ./compiler/ghci/Linker.lhs 747
499            pls1                     = pls { objs_loaded = objs_loaded' }
500            unlinkeds                = concatMap linkableUnlinked new_objs
501 
502-       mapM loadObj (map nameOfObject unlinkeds)
503+       mapM_ loadObj (map nameOfObject unlinkeds)
504 
505        -- Link the all together
506        ok <- resolveObjs
507hunk ./compiler/ghci/RtClosureInspect.hs 859
508     (ty_tvs,  _, _)   <- tcInstType return ty
509     (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
510     (_, _, rtti_ty')  <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
511-    getLIE(boxyUnify rtti_ty' ty')
512+    _ <- getLIE(boxyUnify rtti_ty' ty')
513     tvs1_contents     <- zonkTcTyVars ty_tvs'
514     let subst = (uncurry zipTopTvSubst . unzip)
515                  [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
516hunk ./compiler/ghci/RtClosureInspect.hs 1099
517                         text " in presence of newtype evidence " <> ppr new_tycon)
518                vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
519                let ty' = mkTyConApp new_tycon vars
520-               liftTcM (boxyUnify ty (repType ty'))
521+               _ <- liftTcM (boxyUnify ty (repType ty'))
522         -- assumes that reptype doesn't ^^^^ touch tyconApp args
523                return ty'
524 
525hunk ./compiler/hsSyn/Convert.lhs 86
526 initCvt :: SrcSpan -> CvtM a -> Either Message a
527 initCvt loc (CvtM m) = m loc
528 
529-force :: a -> CvtM a
530-force a = a `seq` return a
531+force :: a -> CvtM ()
532+force a = a `seq` return ()
533 
534 failWith :: Message -> CvtM a
535 failWith m = CvtM (\_ -> Left full_msg)
536hunk ./compiler/hsSyn/Convert.lhs 811
537 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
538 cvtName ctxt_ns (TH.Name occ flavour)
539   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
540-  | otherwise                  = force (thRdrName ctxt_ns occ_str flavour)
541+  | otherwise                  = force rdr_name >> return rdr_name
542   where
543     occ_str = TH.occString occ
544hunk ./compiler/hsSyn/Convert.lhs 814
545+    rdr_name = thRdrName ctxt_ns occ_str flavour
546 
547 okOcc :: OccName.NameSpace -> String -> Bool
548 okOcc _  []      = False
549hunk ./compiler/iface/BinIface.hs 152
550         -- The version and way descriptor go next
551   put_ bh (show opt_HiVersion)
552   way_descr <- getWayDescr
553-  put  bh way_descr
554+  put_  bh way_descr
555 
556         -- Remember where the symbol table pointer will go
557   symtab_p_p <- tellBin bh
558hunk ./compiler/iface/BinIface.hs 684
559 
560 instance Binary DmdType where
561        -- Ignore DmdEnv when spitting out the DmdType
562-  put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
563+  put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
564   get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
565 
566 instance Binary Demand where
567hunk ./compiler/iface/LoadIface.lhs 134
568 loadWiredInHomeIface :: Name -> IfM lcl ()
569 loadWiredInHomeIface name
570   = ASSERT( isWiredInName name )
571-    do loadSysInterface doc (nameModule name); return ()
572+    do _ <- loadSysInterface doc (nameModule name); return ()
573   where
574     doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name
575 
576hunk ./compiler/main/DriverMkDepend.hs 76
577     -- and complaining about cycles
578     hsc_env <- getSession
579     root <- liftIO getCurrentDirectory
580-    mapM (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
581+    mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
582 
583     -- If -ddump-mod-cycles, show cycles in the module graph
584     liftIO $ dumpModCycles dflags mod_summaries
585hunk ./compiler/main/DriverPipeline.hs 190
586                             -> return ([], ms_hs_date summary)
587                           -- We're in --make mode: finish the compilation pipeline.
588                           _other
589-                            -> do runPipeline StopLn hsc_env' (output_fn,Nothing)
590+                            -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing)
591                                               (Just basename)
592                                               Persistent
593                                               (Just location)
594hunk ./compiler/main/DriverPipeline.hs 267
595        let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env)
596                                    (moduleName mod) location
597 
598-       runPipeline StopLn hsc_env (stub_c,Nothing)  Nothing
599+       _ <- runPipeline StopLn hsc_env (stub_c,Nothing)  Nothing
600                (SpecificFile stub_o) Nothing{-no ModLocation-}
601 
602        return stub_o
603hunk ./compiler/main/DriverPipeline.hs 1237
604            pvm_executable_base = "=" ++ input_fn
605            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
606         -- nuke old binary; maybe use configur'ed names for cp and rm?
607-        tryIO (removeFile pvm_executable)
608+        _ <- tryIO (removeFile pvm_executable)
609         -- move the newly created binary into PVM land
610         copy dflags "copying PVM executable" input_fn pvm_executable
611         -- generate a wrapper script for running a parallel prg under PVM
612hunk ./compiler/main/DynFlags.hs 1
613-
614 -- |
615 -- Dynamic flags
616 --
617hunk ./compiler/main/DynFlags.hs 194
618    | Opt_WarnUnrecognisedPragmas
619    | Opt_WarnDodgyForeignImports
620    | Opt_WarnLazyUnliftedBindings
621+   | Opt_WarnUnusedDoBind
622+   | Opt_WarnWrongDoBind
623+
624 
625    -- language opts
626    | Opt_OverlappingInstances
627hunk ./compiler/main/DynFlags.hs 914
628         Opt_WarnMissingMethods,
629         Opt_WarnDuplicateExports,
630         Opt_WarnLazyUnliftedBindings,
631-        Opt_WarnDodgyForeignImports
632+        Opt_WarnDodgyForeignImports,
633+        Opt_WarnWrongDoBind
634       ]
635 
636 minusWOpts :: [DynFlag]
637hunk ./compiler/main/DynFlags.hs 935
638         Opt_WarnNameShadowing,
639         Opt_WarnMissingSigs,
640         Opt_WarnHiShadows,
641-        Opt_WarnOrphans
642+        Opt_WarnOrphans,
643+        Opt_WarnUnusedDoBind
644       ]
645 
646 -- minuswRemovesOpts should be every warning option
647hunk ./compiler/main/DynFlags.hs 1671
648   ( "warn-unrecognised-pragmas",        Opt_WarnUnrecognisedPragmas, const Supported ),
649   ( "warn-lazy-unlifted-bindings",      Opt_WarnLazyUnliftedBindings,
650     const $ Deprecated "lazy unlifted bindings will be an error in GHC 6.14, and this flag will no longer exist"),
651+  ( "warn-unused-do-bind",              Opt_WarnUnusedDoBind, const Supported ),
652+  ( "warn-wrong-do-bind",               Opt_WarnWrongDoBind, const Supported ),
653   ( "print-explicit-foralls",           Opt_PrintExplicitForalls, const Supported ),
654   ( "strictness",                       Opt_Strictness, const Supported ),
655   ( "static-argument-transformation",   Opt_StaticArgumentTransformation, const Supported ),
656hunk ./compiler/main/GHC.hs 787
657                                (flattenSCCs mg2_with_srcimps)
658                                stable_mods
659 
660-       liftIO $ evaluate pruned_hpt
661+       _ <- liftIO $ evaluate pruned_hpt
662 
663         -- before we unload anything, make sure we don't leave an old
664         -- interactive context around pointing to dead bindings.  Also,
665hunk ./compiler/main/GHC.hs 1211
666   (iface, changed, _details, cgguts)
667       <- hscNormalIface guts Nothing
668   hscWriteIface iface changed modSummary
669-  hscGenHardCode cgguts modSummary
670+  _ <- hscGenHardCode cgguts modSummary
671   return ()
672 
673 -- Makes a "vanilla" ModGuts.
674hunk ./compiler/main/GHC.hs 1245
675    -- First, set the target to the desired filename
676    target <- guessTarget fn Nothing
677    addTarget target
678-   load LoadAllTargets
679+   _ <- load LoadAllTargets
680    -- Then find dependencies
681    modGraph <- depanal [] True
682    case find ((== fn) . msHsFilePath) modGraph of
683hunk ./compiler/main/HscMain.lhs 776
684              parseCmmFile dflags filename
685     cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm]
686     rawCmms <- liftIO $ cmmToRawCmm cmms
687-    liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
688+    _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
689     return ()
690   where
691        no_mod = panic "hscCmmFile: no_mod"
692hunk ./compiler/main/InteractiveEval.hs 311
693              let history' = mkHistory hsc_env apStack info `consBL` history
694                 -- probably better make history strict here, otherwise
695                 -- our BoundedList will be pointless.
696-             liftIO $ evaluate history'
697+             _ <- liftIO $ evaluate history'
698              status <-
699                  withBreakAction True (hsc_dflags hsc_env)
700                                       breakMVar statusMVar $ do
701hunk ./compiler/main/SysTools.lhs 611
702   -- and run a loop piping the output from the compiler to the log_action in DynFlags
703   hSetBuffering hStdOut LineBuffering
704   hSetBuffering hStdErr LineBuffering
705-  forkIO (readerProc chan hStdOut filter_fn)
706-  forkIO (readerProc chan hStdErr filter_fn)
707+  _ <- forkIO (readerProc chan hStdOut filter_fn)
708+  _ <- forkIO (readerProc chan hStdErr filter_fn)
709   -- we don't want to finish until 2 streams have been completed
710   -- (stdout and stderr)
711   -- nor until 1 exit code has been retrieved.
712hunk ./compiler/rename/RnExpr.lhs 572
713 rnBracket (VarBr n) = do { name <- lookupOccRn n
714                         ; this_mod <- getModule
715                         ; checkM (nameIsLocalOrFrom this_mod name) $   -- Reason: deprecation checking asumes the
716-                          do { loadInterfaceForName msg name           -- home interface is loaded, and this is the
717+                          do { _ <- loadInterfaceForName msg name      -- home interface is loaded, and this is the
718                              ; return () }                             -- only way that is going to happen
719                         ; return (VarBr name, unitFV name) }
720                    where
721hunk ./compiler/rename/RnExpr.lhs 797
722             let (bndrs', dups) = removeDups cmpByOcc bndrs
723                 inner_env = extendLocalRdrEnv orig_lcl_env bndrs'
724             
725-            mapM dupErr dups
726+            mapM_ dupErr dups
727             (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
728             return (([], thing), fvs)
729 
730hunk ./compiler/stgSyn/StgLint.lhs 194
731 lintStgExpr (StgSCC _ expr) = lintStgExpr expr
732 
733 lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
734-    MaybeT $ lintStgExpr scrut
735+    _ <- MaybeT $ lintStgExpr scrut
736 
737     MaybeT $ liftM Just $
738      case alts_type of
739hunk ./compiler/typecheck/TcBinds.lhs 810
740 -- Post-condition: the returned Insts are full zonked
741 unifyCtxts [] = panic "unifyCtxts []"
742 unifyCtxts (sig1 : sigs)        -- Argument is always non-empty
743-  = do  { mapM unify_ctxt sigs
744+  = do  { mapM_ unify_ctxt sigs
745         ; theta <- zonkTcThetaType (sig_theta sig1)
746         ; newDictBndrs (sig_loc sig1) theta }
747   where
748hunk ./compiler/typecheck/TcBinds.lhs 869
749 
750 checkDistinctTyVars sig_tvs
751   = do  { zonked_tvs <- mapM zonkSigTyVar sig_tvs
752-        ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
753+        ; foldlM_ check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
754         ; return zonked_tvs }
755   where
756     check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
757hunk ./compiler/typecheck/TcClassDcl.lhs 455
758                              group `lengthExceeds` 1]
759        get_uniq (tc,_) = getUnique tc
760 
761-    mapM (addErrTc . dupGenericInsts) bad_groups
762+    mapM_ (addErrTc . dupGenericInsts) bad_groups
763 
764        -- Check that there is an InstInfo for each generic type constructor
765     let
766hunk ./compiler/typecheck/TcHsSyn.lhs 1073
767   , isLiftedTypeKind res                       --    Horrible hack to make less use
768   = return (mkTyConApp tup_tc [])              --    of mkAnyPrimTyCon
769   | otherwise
770-  = do { warn (getSrcSpan tv) msg
771+  = do { _ <- warn (getSrcSpan tv) msg
772        ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) }
773                -- Same name as the tyvar, apart from making it start with a colon (sigh)
774                -- I dread to think what will happen if this gets out into an
775hunk ./compiler/typecheck/TcPat.lhs 184
776 tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty
777   | Just mono_ty <- lookup_sig bndr_name
778   = do { mono_name <- newLocalName bndr_name
779-       ; boxyUnify mono_ty pat_ty
780+       ; _ <- boxyUnify mono_ty pat_ty
781        ; return (Id.mkLocalId mono_name mono_ty) }
782 
783   | otherwise
784hunk ./compiler/typecheck/TcPat.lhs 241
785                return ty'
786          else do       -- OpenTypeKind, so constrain it
787        { ty2 <- newFlexiTyVarTy argTypeKind
788-       ; unifyType ty' ty2
789+       ; _ <- unifyType ty' ty2
790        ; return ty' }}
791   where
792     msg = pp_this <+> ptext (sLit "cannot be bound to an unboxed tuple")
793hunk ./compiler/typecheck/TcPat.lhs 376
794 
795        -- Check that the pattern has a lifted type
796        ; pat_tv <- newBoxyTyVar liftedTypeKind
797-       ; boxyUnify pat_ty (mkTyVarTy pat_tv)
798+       ; _ <- boxyUnify pat_ty (mkTyVarTy pat_tv)
799 
800        ; return (LazyPat pat', [], res) }
801 
802hunk ./compiler/typecheck/TcSimplify.lhs 1640
803 \begin{code}
804 tcSimplifyBracket :: [Inst] -> TcM ()
805 tcSimplifyBracket wanteds
806-  = do { tryHardCheckLoop doc wanteds
807+  = do { _ <- tryHardCheckLoop doc wanteds
808        ; return () }
809   where
810     doc = text "tcSimplifyBracket"
811hunk ./compiler/typecheck/TcSimplify.lhs 2909
812   = do { mb_chosen_ty <- try_default default_tys
813        ; case mb_chosen_ty of
814             Nothing        -> return ()
815-            Just chosen_ty -> do { unifyType chosen_ty (mkTyVarTy tyvar)
816+            Just chosen_ty -> do { _ <- unifyType chosen_ty (mkTyVarTy tyvar)
817                                 ; warnDefault dicts chosen_ty } }
818   where
819     (_,_,tyvar) = ASSERT(not (null dicts)) head dicts  -- Should be non-empty
820hunk ./compiler/typecheck/TcSplice.lhs 236
821        ; tcSimplifyBracket lie
822 
823        -- Make the expected type have the right shape
824-       ; boxyUnify meta_ty res_ty
825+       ; _ <- boxyUnify meta_ty res_ty
826 
827        -- Return the original expression, not the type-decorated one
828        ; pendings <- readMutVar pending_splices
829hunk ./compiler/typecheck/TcSplice.lhs 260
830 
831 tc_bracket _ (ExpBr expr)
832   = do { any_ty <- newFlexiTyVarTy liftedTypeKind
833-       ; tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
834+       ; _ <- tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
835        ; tcMetaTy expQTyConName }
836        -- Result type is Expr (= Q Exp)
837 
838hunk ./compiler/typecheck/TcSplice.lhs 265
839 tc_bracket _ (TypBr typ)
840-  = do { tcHsSigTypeNC ThBrackCtxt typ
841+  = do { _ <- tcHsSigTypeNC ThBrackCtxt typ
842        ; tcMetaTy typeQTyConName }
843        -- Result type is Type (= Q Typ)
844 
845hunk ./compiler/typecheck/TcSplice.lhs 270
846 tc_bracket _ (DecBr decls)
847-  = do {  tcTopSrcDecls emptyModDetails decls
848+  = do { _ <- tcTopSrcDecls emptyModDetails decls
849        -- Typecheck the declarations, dicarding the result
850        -- We'll get all that stuff later, when we splice it in
851 
852hunk ./compiler/typecheck/TcSplice.lhs 315
853        -- Here (h 4) :: Q Exp
854        -- but $(h 4) :: forall a.a     i.e. anything!
855 
856-      unBox res_ty
857+      _ <- unBox res_ty
858       meta_exp_ty <- tcMetaTy expQTyConName
859       expr' <- setStage (Splice next_level) (
860                  setLIEVar lie_var    $
861hunk ./compiler/typecheck/TcUnify.lhs 1042
862 unifyTypeList :: [TcTauType] -> TcM ()
863 unifyTypeList []                 = return ()
864 unifyTypeList [_]                = return ()
865-unifyTypeList (ty1:tys@(ty2:_)) = do { unifyType ty1 ty2
866-                                      ; unifyTypeList tys }
867+unifyTypeList (ty1:tys@(ty2:_)) = do { _ <- unifyType ty1 ty2
868+                                     ; unifyTypeList tys }
869 \end{code}
870 
871 %************************************************************************
872hunk ./compiler/typecheck/TcUnify.lhs 1684
873 -- with that type.
874 zapToMonotype res_ty
875   = do  { res_tau <- newFlexiTyVarTy liftedTypeKind
876-        ; boxyUnify res_tau res_ty
877+        ; _ <- boxyUnify res_tau res_ty
878         ; return res_tau }
879 
880 unBox :: BoxyType -> TcM TcType
881hunk ./compiler/utils/Binary.hs 149
882     -- define one of put_, put.  Use of put_ is recommended because it
883     -- is more likely that tail-calls can kick in, and we rarely need the
884     -- position return value.
885-    put_ bh a = do put bh a; return ()
886+    put_ bh a = do _ <- put bh a; return ()
887     put bh a  = do p <- tellBin bh; put_ bh a; return p
888 
889 putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()
890hunk ./compiler/utils/Binary.hs 153
891-putAt bh p x = do seekBin bh p; put bh x; return ()
892+putAt bh p x = do seekBin bh p; put_ bh x; return ()
893 
894 getAt  :: Binary a => BinHandle -> Bin a -> IO a
895 getAt bh p = do seekBin bh p; get bh
896hunk ./compiler/utils/Exception.hs 65
897     gblock (do
898       a <- before
899       r <- gunblock (thing a) `gonException` after a
900-      after a
901+      _ <- after a
902       return r)
903 
904   a `gfinally` sequel =
905hunk ./compiler/utils/Exception.hs 71
906     gblock (do
907       r <- gunblock a `gonException` sequel
908-      sequel
909+      _ <- sequel
910       return r)
911 
912 instance ExceptionMonad IO where
913hunk ./compiler/utils/Exception.hs 92
914 -- second argument is executed and the exception is raised again.
915 gonException :: (ExceptionMonad m) => m a -> m b -> m a
916 gonException ioA cleanup = ioA `gcatch` \e ->
917-                             do cleanup
918+                             do _ <- cleanup
919                                 throw (e :: SomeException)
920 
921hunk ./compiler/utils/IOEnv.hs 69
922                                          unIOEnv (f r) env })
923 
924 thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b
925-thenM_ (IOEnv m) f = IOEnv (\ env -> do { m env ; unIOEnv f env })
926+thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env })
927 
928 failM :: IOEnv env a
929 failM = IOEnv (\ _ -> throwIO IOEnvFailure)
930hunk ./compiler/utils/MonadUtils.hs 21
931         , concatMapM
932         , mapMaybeM
933         , anyM, allM
934-        , foldlM, foldrM
935+        , foldlM, foldlM_, foldrM
936         , maybeMapM
937         ) where
938 
939hunk ./compiler/utils/MonadUtils.hs 149
940 foldlM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
941 foldlM = foldM
942 
943+-- | Monadic version of foldl that discards its result
944+foldlM_ :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()
945+foldlM_ = foldM_
946+
947 -- | Monadic version of foldr
948 foldrM        :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a
949 foldrM _ z []     = return z
950hunk ./compiler/utils/Panic.lhs 193
951           (thread:_) -> throwTo thread interrupt_exn
952   --
953 #if !defined(mingw32_HOST_OS)
954-  installHandler sigQUIT (Catch interrupt) Nothing
955-  installHandler sigINT  (Catch interrupt) Nothing
956+  _ <- installHandler sigQUIT (Catch interrupt) Nothing
957+  _ <- installHandler sigINT  (Catch interrupt) Nothing
958   return ()
959 #else
960   -- GHC 6.3+ has support for console events on Windows
961hunk ./docs/users_guide/flags.xml 1178
962            <entry><option>-fno-warn-unused-matches</option></entry>
963          </row>
964 
965+         <row>
966+           <entry><option>-fwarn-unused-do-bind</option></entry>
967+           <entry>warn about do bindings that appear to throw away values of types other than <literal>()</literal></entry>
968+           <entry>dynamic</entry>
969+           <entry><option>-fno-warn-unused-do-bind</option></entry>
970+         </row>
971+
972+         <row>
973+           <entry><option>-fwarn-wrong-do-bind</option></entry>
974+           <entry>warn about do bindings that appear to throw away monadic values that you should have bound instead</entry>
975+           <entry>dynamic</entry>
976+           <entry><option>-fno-warn-wrong-do-bind</option></entry>
977+         </row>
978+
979          </tbody>
980        </tgroup>
981       </informaltable>
982hunk ./docs/users_guide/using.xml 848
983     <option>-fwarn-duplicate-exports</option>,
984     <option>-fwarn-missing-fields</option>,
985     <option>-fwarn-missing-methods</option>,
986-    <option>-fwarn-lazy-unlifted-bindings</option>, and
987+    <option>-fwarn-lazy-unlifted-bindings</option>,
988+    <option>-fwarn-wrong-do-bind</option>, and
989     <option>-fwarn-dodgy-foreign-imports</option>.  The following
990     flags are
991     simple ways to select standard &ldquo;packages&rdquo; of warnings:
992hunk ./docs/users_guide/using.xml 881
993             <option>-fwarn-simple-patterns</option>,
994             <option>-fwarn-tabs</option>,
995             <option>-fwarn-incomplete-record-updates</option>,
996-            <option>-fwarn-monomorphism-restriction</option>, and
997+            <option>-fwarn-monomorphism-restriction</option>,
998+            <option>-fwarn-unused-do-bind</option>, and
999             <option>-fwarn-implicit-prelude</option>.</para>
1000        </listitem>
1001       </varlistentry>
1002hunk ./docs/users_guide/using.xml 1370
1003        </listitem>
1004       </varlistentry>
1005 
1006+      <varlistentry>
1007+       <term><option>-fwarn-unused-do-bind</option>:</term>
1008+       <listitem>
1009+         <indexterm><primary><option>-fwarn-unused-do-bind</option></primary></indexterm>
1010+         <indexterm><primary>unused do binding, warning</primary></indexterm>
1011+         <indexterm><primary>do binding, unused</primary></indexterm>
1012+
1013+         <para>Report expressions occuring in <literal>do</literal> and <literal>mdo</literal> blocks
1014+         that appear to silently throw information away.
1015+          For instance <literal>do { mapM popInt xs ; return 10 }</literal> would report
1016+          the first statement in the <literal>do</literal> block as suspicious,
1017+          as it has the type <literal>StackM [Int]</literal> and not <literal>StackM ()</literal>, but that
1018+          <literal>[Int]</literal> value is not bound to anything.  The warning is suppressed by
1019+          explicitly mentioning in the source code that your program is throwing something away:
1020+           <programlisting>
1021+              do { _ &lt;- mapM popInt xs ; return 10 }
1022+           </programlisting>
1023+         Of course, in this particular situation you can do even better:
1024+           <programlisting>
1025+              do { mapM_ popInt xs ; return 10 }
1026+           </programlisting>
1027+          </para>
1028+       </listitem>
1029+      </varlistentry>
1030+
1031+      <varlistentry>
1032+       <term><option>-fwarn-wrong-do-bind</option>:</term>
1033+       <listitem>
1034+         <indexterm><primary><option>-fwarn-wrong-do-bind</option></primary></indexterm>
1035+         <indexterm><primary>apparently erroneous do binding, warning</primary></indexterm>
1036+         <indexterm><primary>do binding, apparently erroneous</primary></indexterm>
1037+
1038+         <para>Report expressions occuring in <literal>do</literal> and <literal>mdo</literal> blocks
1039+         that appear to lack a binding.
1040+          For instance <literal>do { return (popInt 10) ; return 10 }</literal> would report
1041+          the first statement in the <literal>do</literal> block as suspicious,
1042+          as it has the type <literal>StackM (StackM Int)</literal> (which consists of two nested applications
1043+          of the same monad constructor), but which is not then &quot;unpacked&quot; by binding the result.
1044+          The warning is suppressed by explicitly mentioning in the source code that your program is throwing something away:
1045+           <programlisting>
1046+              do { _ &lt;- return (popInt 10) ; return 10 }
1047+           </programlisting>
1048+         For almost all sensible programs this will indicate a bug, and you probably intended to write:
1049+           <programlisting>
1050+              do { popInt 10 ; return 10 }
1051+           </programlisting>
1052+          </para>
1053+       </listitem>
1054+      </varlistentry>
1055+
1056     </variablelist>
1057 
1058     <para>If you're feeling really paranoid, the
1059hunk ./ghc/GhciMonad.hs 265
1060 setLogAction = do
1061     encoder <- getEncoder
1062     dflags <- GHC.getSessionDynFlags
1063-    GHC.setSessionDynFlags dflags {log_action = logAction encoder}
1064+    _ <- GHC.setSessionDynFlags dflags {log_action = logAction encoder}
1065     return ()
1066   where
1067     logAction encoder severity srcSpan style msg = case severity of
1068hunk ./ghc/GhciMonad.hs 372
1069 
1070       let f ref (Just ptr) = writeIORef ref ptr
1071           f _   Nothing    = panic "interactiveUI:setBuffering2"
1072-      zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
1073-                 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
1074-      return ()
1075+      zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
1076+                  [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
1077 
1078 flushInterpBuffers :: GHCi ()
1079 flushInterpBuffers
1080hunk ./ghc/InteractiveUI.hs 314
1081    -- it refers to might be finalized, including the standard Handles.
1082    -- This sounds like a bug, but we don't have a good solution right
1083    -- now.
1084-   liftIO $ newStablePtr stdin
1085-   liftIO $ newStablePtr stdout
1086-   liftIO $ newStablePtr stderr
1087+   _ <- liftIO $ newStablePtr stdin
1088+   _ <- liftIO $ newStablePtr stdout
1089+   _ <- liftIO $ newStablePtr stderr
1090 
1091     -- Initialise buffering for the *interpreted* I/O system
1092    initInterpBuffering
1093hunk ./ghc/InteractiveUI.hs 623
1094     -- QUESTION: is userError the one to use here?
1095     collectError = userError "unterminated multiline command :{ .. :}"
1096     doCommand (':' : cmd) = specialCommand cmd
1097-    doCommand stmt        = do timeIt $ lift $ runStmt stmt GHC.RunToCompletion
1098+    doCommand stmt        = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
1099                                return False
1100 
1101 enqueueCommands :: [String] -> GHCi ()
1102hunk ./ghc/InteractiveUI.hs 644
1103       -- are really two stdin Handles.  So we flush any bufferred data in
1104       -- GHCi's stdin Handle here (only relevant if stdin is attached to
1105       -- a file, otherwise the read buffer can't be flushed).
1106-      liftIO $ IO.try $ hFlushAll stdin
1107+      _ <- liftIO $ IO.try $ hFlushAll stdin
1108 #endif
1109       result <- GhciMonad.runStmt stmt step
1110       afterRunStmt (const True) result
1111hunk ./ghc/InteractiveUI.hs 878
1112         outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
1113   prev_context <- GHC.getContext
1114   GHC.setTargets []
1115-  GHC.load LoadAllTargets
1116+  _ <- GHC.load LoadAllTargets
1117   lift $ setContextAfterLoad prev_context False []
1118   GHC.workingDirectoryChanged
1119   dir <- expandPath dir
1120hunk ./ghc/InteractiveUI.hs 897
1121      let cmd = editor st
1122      when (null cmd)
1123        $ ghcError (CmdLineError "editor not set, use :set editor")
1124-     io $ system (cmd ++ ' ':file)
1125+     _ <- io $ system (cmd ++ ' ':file)
1126      return ()
1127 
1128 -- The user didn't specify a file so we pick one for them.
1129hunk ./ghc/InteractiveUI.hs 992
1130 loadModule fs = timeIt (loadModule' fs)
1131 
1132 loadModule_ :: [FilePath] -> InputT GHCi ()
1133-loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
1134+loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1135 
1136 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1137 loadModule' files = do
1138hunk ./ghc/InteractiveUI.hs 999
1139   prev_context <- GHC.getContext
1140 
1141   -- unload first
1142-  GHC.abandonAll
1143+  _ <- GHC.abandonAll
1144   lift discardActiveBreakPoints
1145   GHC.setTargets []
1146hunk ./ghc/InteractiveUI.hs 1002
1147-  GHC.load LoadAllTargets
1148+  _ <- GHC.load LoadAllTargets
1149 
1150   let (filenames, phases) = unzip files
1151   exp_filenames <- mapM expandPath filenames
1152hunk ./ghc/InteractiveUI.hs 1039
1153 reloadModule :: String -> InputT GHCi ()
1154 reloadModule m = do
1155   prev_context <- GHC.getContext
1156-  doLoad True prev_context $
1157+  _ <- doLoad True prev_context $
1158         if null m then LoadAllTargets
1159                   else LoadUpTo (GHC.mkModuleName m)
1160   return ()
1161hunk ./ghc/InteractiveUI.hs 1457
1162       when (packageFlags dflags /= pkg_flags) $ do
1163         io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1164         GHC.setTargets []
1165-        GHC.load LoadAllTargets
1166+        _ <- GHC.load LoadAllTargets
1167         io (linkPackages dflags new_pkgs)
1168         -- package flags changed, we can't re-use any of the old context
1169         setContextAfterLoad ([],[]) False []
1170hunk ./ghc/InteractiveUI.hs 1801
1171 
1172 stepCmd :: String -> GHCi ()
1173 stepCmd []         = doContinue (const True) GHC.SingleStep
1174-stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1175+stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1176 
1177 stepLocalCmd :: String -> GHCi ()
1178 stepLocalCmd  [] = do
1179hunk ./ghc/InteractiveUI.hs 1839
1180 
1181 traceCmd :: String -> GHCi ()
1182 traceCmd []         = doContinue (const True) GHC.RunAndLogSteps
1183-traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1184+traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1185 
1186 continueCmd :: String -> GHCi ()
1187 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1188hunk ./ghc/InteractiveUI.hs 1848
1189 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1190 doContinue pred step = do
1191   runResult <- resume pred step
1192-  afterRunStmt pred runResult
1193+  _ <- afterRunStmt pred runResult
1194   return ()
1195 
1196 abandonCmd :: String -> GHCi ()
1197hunk ./ghc/InteractiveUI.hs 2234
1198 discardActiveBreakPoints :: GHCi ()
1199 discardActiveBreakPoints = do
1200    st <- getGHCiState
1201-   mapM (turnOffBreak.snd) (breaks st)
1202+   mapM_ (turnOffBreak.snd) (breaks st)
1203    setGHCiState $ st { breaks = [] }
1204 
1205 deleteBreak :: Int -> GHCi ()
1206hunk ./ghc/InteractiveUI.hs 2246
1207       then printForUser (text "Breakpoint" <+> ppr identity <+>
1208                          text "does not exist")
1209       else do
1210-           mapM (turnOffBreak.snd) this
1211+           mapM_ (turnOffBreak.snd) this
1212            setGHCiState $ st { breaks = rest }
1213 
1214 turnOffBreak :: BreakLocation -> GHCi Bool
1215hunk ./ghc/Main.hs 167
1216   liftIO $ showBanner cli_mode dflags2
1217 
1218   -- we've finished manipulating the DynFlags, update the session
1219-  GHC.setSessionDynFlags dflags2
1220+  _ <- GHC.setSessionDynFlags dflags2
1221   dflags3 <- GHC.getSessionDynFlags
1222   hsc_env <- GHC.getSession
1223 
1224hunk ./utils/ghc-pkg/Main.hs 363
1225   parse
1226      +++
1227   (do n <- parse
1228-      string "-*"
1229+      _ <- string "-*"
1230       return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
1231 
1232 -- globVersion means "all versions"
1233hunk ./utils/ghc-pkg/Main.hs 509
1234   | otherwise
1235   = do str <- readFile filename
1236        let packages = map convertPackageInfoIn $ read str
1237-       Exception.evaluate packages
1238+       _ <- Exception.evaluate packages
1239          `catchError` \e->
1240             die ("error while parsing " ++ filename ++ ": " ++ show e)
1241        return (filename,packages)
1242hunk ./utils/ghc-pkg/Main.hs 816
1243             else do
1244               when (not simple_output) $ do
1245                   reportError ("There are problems in package " ++ display (package p) ++ ":")
1246-                  reportValidateErrors es "  " Nothing
1247+                  _ <- reportValidateErrors es "  " Nothing
1248                   return ()
1249               return [p]
1250 
1251hunk ./utils/ghc-pkg/Main.hs 1250
1252                                     (Exception.ErrorCall "interrupted")
1253   --
1254 #if !defined(mingw32_HOST_OS)
1255-  installHandler sigQUIT (Catch interrupt) Nothing
1256-  installHandler sigINT  (Catch interrupt) Nothing
1257+  _ <- installHandler sigQUIT (Catch interrupt) Nothing
1258+  _ <- installHandler sigINT  (Catch interrupt) Nothing
1259   return ()
1260 #elif __GLASGOW_HASKELL__ >= 603
1261   -- GHC 6.3+ has support for console events on Windows
1262hunk ./utils/hpc/Main.hs 59
1263               case getOpt Permute (options plugin []) args of
1264                 (_,_,errs) | not (null errs)
1265                      -> do putStrLn "hpc failed:"
1266-                          sequence [ putStr ("  " ++ err)
1267+                          sequence_ [ putStr ("  " ++ err)
1268                                    | err <- errs
1269                                    ]
1270                           putStrLn $ "\n"
1271}
1272[Make changes to -fwarn-unused-do-bind and -fwarn-wrong-do-bind suggested by SPJ
1273Max Bolingbroke <batterseapower@hotmail.com>**20090702150943
1274 Ignore-this: 595368298d2e11623c0bd280ff89d8de
1275] {
1276hunk ./compiler/deSugar/DsExpr.lhs 675
1277     go (ExprStmt rhs then_expr _) stmts
1278       = do { rhs2 <- dsLExpr rhs
1279            ; case tcSplitAppTy_maybe (exprType rhs2) of
1280-                Just (container_ty, returning_ty) -> warnDiscardedDoBindings container_ty returning_ty
1281+                Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
1282                 _                                 -> return ()
1283            ; then_expr2 <- dsExpr then_expr
1284           ; rest <- goL stmts
1285hunk ./compiler/deSugar/DsExpr.lhs 747
1286 
1287     go _ (ExprStmt rhs _ rhs_ty) stmts
1288       = do { rhs2 <- dsLExpr rhs
1289-          ; warnDiscardedDoBindings m_ty rhs_ty
1290+          ; warnDiscardedDoBindings rhs m_ty rhs_ty
1291            ; rest <- goL stmts
1292           ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
1293     
1294hunk ./compiler/deSugar/DsExpr.lhs 824
1295 
1296 \begin{code}
1297 -- Warn about certain types of values discarded in monadic bindings (#3263)
1298-warnDiscardedDoBindings :: Type -> Type -> DsM ()
1299-warnDiscardedDoBindings container_ty returning_ty = do
1300-        -- Warn about discarding non-() things in 'monadic' binding
1301-        warn_unused <- doptDs Opt_WarnUnusedDoBind
1302-        when (warn_unused && not (returning_ty `tcEqType` unitTy)) $
1303-              warnDs (unusedMonadBind returning_ty)
1304-       
1305-        -- Warn about discarding m a things in 'monadic' binding of the same type
1306-        warn_wrong <- doptDs Opt_WarnWrongDoBind
1307-        case tcSplitAppTy_maybe returning_ty of
1308-                Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
1309-                                                          warnDs (wrongMonadBind returning_ty)
1310-                _ -> return ()
1311+warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
1312+warnDiscardedDoBindings rhs container_ty returning_ty = do {
1313+          -- Warn about discarding non-() things in 'monadic' binding
1314+        ; warn_unused <- doptDs Opt_WarnUnusedDoBind
1315+        ; if warn_unused && not (returning_ty `tcEqType` unitTy)
1316+           then warnDs (unusedMonadBind rhs returning_ty)
1317+           else do {
1318+          -- Warn about discarding m a things in 'monadic' binding of the same type,
1319+          -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
1320+        ; warn_wrong <- doptDs Opt_WarnWrongDoBind
1321+        ; case tcSplitAppTy_maybe returning_ty of
1322+                  Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
1323+                                                            warnDs (wrongMonadBind rhs returning_ty)
1324+                  _ -> return () } }
1325 
1326hunk ./compiler/deSugar/DsExpr.lhs 839
1327-unusedMonadBind :: Type -> SDoc
1328-unusedMonadBind returning_ty
1329-  = ptext (sLit "A do-notation statement threw away a result of a type which appears to contain something other than (), namely") <+> ppr returning_ty <>
1330-    ptext (sLit ". You can suppress this warning by explicitly binding the result to _")
1331+unusedMonadBind :: LHsExpr Id -> Type -> SDoc
1332+unusedMonadBind rhs returning_ty
1333+  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
1334+    ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
1335+    ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
1336 
1337hunk ./compiler/deSugar/DsExpr.lhs 845
1338-wrongMonadBind :: Type -> SDoc
1339-wrongMonadBind returning_ty
1340-  = 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 <>
1341-    ptext (sLit ". You can suppress this warning by explicitly binding the result to _")
1342+wrongMonadBind :: LHsExpr Id -> Type -> SDoc
1343+wrongMonadBind rhs returning_ty
1344+  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
1345+    ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
1346+    ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
1347 \end{code}
1348}
1349
1350Context:
1351
1352[Fix #2197 (properly this time)
1353Simon Marlow <marlowsd@gmail.com>**20090701122354
1354 Ignore-this: 39b6e4b0bcdd8c2f4660f976b7db768d
1355 
1356 $ ./inplace/bin/ghc-stage2 --interactive
1357 GHCi, version 6.11.20090701: http://www.haskell.org/ghc/  :? for help
1358 ghc-stage2: GHCi cannot be used when compiled with -prof
1359 [1]    32473 exit 1     ./inplace/bin/ghc-stage2 --interactive
1360]
1361[make GhcProfiled work, and add a "prof" flavour to build.mk
1362Simon Marlow <marlowsd@gmail.com>**20090701114211
1363 Ignore-this: 386d347e4ad8b6c2bd40a2ba7da31ba6
1364 
1365 Building a profiled GHC is as simple as adding
1366 
1367 GhcLibWays += p
1368 GhcProfiled = YES
1369 
1370 to your build.mk and saying 'make'.  Then you have a profiled
1371 inplace/bin/ghc-stage2.
1372]
1373[remove unnecessary $(RM)s
1374Simon Marlow <marlowsd@gmail.com>**20090701110609
1375 Ignore-this: f326ec8931d0d484a66b67ce1270cc6e
1376]
1377['make html' in a library builds the Haddock docs
1378Simon Marlow <marlowsd@gmail.com>**20090630111137
1379 Ignore-this: 781bf10e2d4bca23b7f70c6f0465d120
1380]
1381[fix GC bug introduced with the C finalizer support
1382Simon Marlow <marlowsd@gmail.com>**20090630080834
1383 Ignore-this: 3567e3adb5ae4a5dcbce81733487f348
1384]
1385[Add a configure test for whether or not __mingw_vfprintf exists
1386Ian Lynagh <igloo@earth.li>**20090627150501]
1387[Fix #3319, and do various tidyups at the same time
1388Simon Marlow <marlowsd@gmail.com>**20090626095421
1389 Ignore-this: ea54175f6bd49e101d7b33392764f643
1390  - converting a THSyn FFI declaration to HsDecl was broken; fixed
1391  - pretty-printing of FFI declarations was variously bogus; fixed
1392  - there was an unused "library" field in CImport; removed
1393]
1394[rename cache variable to keep recent autoconfs happy
1395Ross Paterson <ross@soi.city.ac.uk>**20090626131410
1396 Ignore-this: 187091bbe78f2b14402162acfb98180f
1397]
1398[TAG 2009-06-25
1399Ian Lynagh <igloo@earth.li>**20090625155528]
1400Patch bundle hash:
1401ec109ff09476729608a6a9cf4f5aee36c8e7fa52