[commit: ghc] master: Do not treat a constructor in a *pattern* as a *use* of that constructor (910a642)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/910a642294eb3547d0cbb3d5735ad81b964f137b

>---------------------------------------------------------------

commit 910a642294eb3547d0cbb3d5735ad81b964f137b
Author: Simon Peyton Jones <[email protected]>
Date:   Mon Oct 29 23:25:25 2012 +0000

    Do not treat a constructor in a *pattern* as a *use* of that constructor
    
    Occurrences in terms are uses, in patterns they are not.
    In this way we get unused-constructor warnings from modules like this
    
       module M( f, g, T ) where
         data T = T1 | T2 Bool
    
         f x = T2 x
    
         g T1 = True
         g (T2 x) = x
    
    Here a T1 value cannot be constructed, so we can warn. The use
    in a pattern doesn't count.  See Note [Patterns are not uses]
    in RnPat.
    
    Interestingly this change exposed three module in GHC itself
    that had unused constructors, which I duly removed:
      * ghc/Main.hs
      * compiler/ghci/ByteCodeAsm
      * compiler/nativeGen/PPC/RegInfo
    Their changes are in this patch.

>---------------------------------------------------------------

 compiler/ghci/ByteCodeAsm.lhs     |   14 +++++++-------
 compiler/nativeGen/PPC/RegInfo.hs |    7 +------
 compiler/rename/RnPat.lhs         |   20 ++++++++++++++++++--
 ghc/Main.hs                       |    2 --
 4 files changed, 26 insertions(+), 17 deletions(-)

diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index 4ff09ef..17b3042 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -207,8 +207,8 @@ sizeSS (SizedSeq n _) = n
 data Operand
   = Op Word
   | SmallOp Word16
-  | LargeOp Word
   | LabelOp Word16
+-- (unused)  | LargeOp Word
 
 data Assembler a
   = AllocPtr (IO BCOPtr) (Word -> Assembler a)
@@ -244,10 +244,10 @@ type LabelEnv = Word16 -> Word
 
 largeOp :: Bool -> Operand -> Bool
 largeOp long_jumps op = case op of
-  LargeOp _ -> True
-  SmallOp _ -> False
-  Op w      -> isLarge w
-  LabelOp _ -> long_jumps
+   SmallOp _ -> False
+   Op w      -> isLarge w
+   LabelOp _ -> long_jumps
+-- LargeOp _ -> True
 
 runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> State AsmState IO a
 runAsm dflags long_jumps e = go
@@ -272,9 +272,9 @@ runAsm dflags long_jumps e = go
             | otherwise = w
           words = concatMap expand ops
           expand (SmallOp w) = [w]
-          expand (LargeOp w) = largeArg dflags w
           expand (LabelOp w) = expand (Op (e w))
           expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]
+--        expand (LargeOp w) = largeArg dflags w
       State $ \(st_i0,st_l0,st_p0) -> do
         let st_i1 = addListToSS st_i0 (opcode : words)
         return ((st_i1,st_l0,st_p0), ())
@@ -306,9 +306,9 @@ inspectAsm dflags long_jumps initial_offset
         size = sum (map count ops) + 1
         largeOps = any (largeOp long_jumps) ops
         count (SmallOp _) = 1
-        count (LargeOp _) = largeArg16s dflags
         count (LabelOp _) = count (Op 0)
         count (Op _) = if largeOps then largeArg16s dflags else 1
+--      count (LargeOp _) = largeArg16s dflags
 
 -- Bring in all the bci_ bytecode constants.
 #include "rts/Bytecodes.h"
diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs
index 019cf82..2b74d1d 100644
--- a/compiler/nativeGen/PPC/RegInfo.hs
+++ b/compiler/nativeGen/PPC/RegInfo.hs
@@ -26,21 +26,18 @@ where
 #include "nativeGen/NCG.h"
 #include "HsVersions.h"
 
-import PPC.Regs
 import PPC.Instr
 
 import BlockId
 import OldCmm
 import CLabel
 
-import Outputable
 import Unique
 
-data JumpDest = DestBlockId BlockId | DestImm Imm
+data JumpDest = DestBlockId BlockId
 
 getJumpDestBlockId :: JumpDest -> Maybe BlockId
 getJumpDestBlockId (DestBlockId bid) = Just bid
-getJumpDestBlockId _                 = Nothing
 
 canShortcut :: Instr -> Maybe JumpDest
 canShortcut _ = Nothing
@@ -80,7 +77,5 @@ shortBlockId fn blockid =
    case fn blockid of
       Nothing -> mkAsmTempLabel uq
       Just (DestBlockId blockid')  -> shortBlockId fn blockid'
-      Just (DestImm (ImmCLbl lbl)) -> lbl
-      _other -> panic "shortBlockId"
    where uq = getUnique blockid
 
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index c3b40fe..9738585 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -121,10 +121,26 @@ wrapSrcSpanCps fn (L loc a)
 lookupConCps :: Located RdrName -> CpsRn (Located Name)
 lookupConCps con_rdr 
   = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr
-                    ; (r, fvs) <- k con_name
-                    ; return (r, fvs `plusFV` unitFV (unLoc con_name)) })
+                    ; k con_name })
+    -- We do not add the constructor name to the free vars
+    -- See Note [Patterns are not uses]
 \end{code}
 
+Note [Patterns are not uses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  module Foo( f, g ) where
+  data T = T1 | T2
+
+  f T1 = True
+  f T2 = False
+
+  g _ = T1
+
+Arguaby we should report T2 as unused, even though it appears in a
+pattern, because it never occurs in a constructed position.  See
+Trac #7336.
+
 %*********************************************************
 %*							*
 	Name makers
diff --git a/ghc/Main.hs b/ghc/Main.hs
index f05ddab..a84f2ac 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -110,7 +110,6 @@ main = do
                    ShowSupportedExtensions -> showSupportedExtensions
                    ShowVersion             -> showVersion
                    ShowNumVersion          -> putStrLn cProjectVersion
-                   Print str               -> putStrLn str
         Right postStartupMode ->
             -- start our GHC session
             GHC.runGhc mbMinusB $ do
@@ -361,7 +360,6 @@ data PreStartupMode
   = ShowVersion             -- ghc -V/--version
   | ShowNumVersion          -- ghc --numeric-version
   | ShowSupportedExtensions -- ghc --supported-extensions
-  | Print String            -- ghc --print-foo
 
 showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
 showVersionMode             = mkPreStartupMode ShowVersion