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

8 files changed, 19 insertions, 16 deletions

diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index 0fb90b0d77..532965c084 100644
--- a/compiler/codeGen/CgCon.lhs
+++ b/compiler/codeGen/CgCon.lhs
@@ -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 }
 
diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs
index df3720cd2d..42d26662b9 100644
--- a/compiler/codeGen/CgHeapery.lhs
+++ b/compiler/codeGen/CgHeapery.lhs
@@ -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 }
diff --git a/compiler/codeGen/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs
index f501be5941..14f5fb8269 100644
--- a/compiler/codeGen/CgLetNoEscape.lhs
+++ b/compiler/codeGen/CgLetNoEscape.lhs
@@ -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) }
diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index 1e9a5ba97b..af6b1ed311 100644
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -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}
 
 %************************************************************************
diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs
index bcb59ce032..6683de4c8b 100644
--- a/compiler/codeGen/CgStackery.lhs
+++ b/compiler/codeGen/CgStackery.lhs
@@ -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) })
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index ae4fa1b623..ee1983c34b 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -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)
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 96b9e316c4..2a0716ed24 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -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 }
 
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 550c42de60..dbcb540751 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -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