Fix merge-related problems

compiler/cmm/CmmBuildInfoTables.hs

@@ -23,28 +23,20 @@ where
 #include "HsVersions.h"
 
 -- These should not be imported here!
-import StgCmmForeign
 import StgCmmUtils
 
-import Constants
 import Digraph
 import qualified Prelude as P
 import Prelude hiding (succ)
-import Util
 
 import BlockId
 import Bitmap
 import CLabel
 import Cmm
 import CmmUtils
-import Module
-import FastString
-import ForeignCall
 import IdInfo
 import Data.List
 import Maybes
-import MkGraph as M
-import Control.Monad
 import Name
 import OptimizationFuel
 import Outputable
@@ -57,8 +49,8 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
-import qualified FiniteMap as Map
 
+foldSet :: (a -> b -> b) -> b -> Set a -> b
 #if __GLASGOW_HASKELL__ < 704
 foldSet = Set.fold
 #else
@@ -106,7 +98,7 @@ cafTransfers = mkBTransfer3 first middle last
         add l s = if hasCAF l then Set.insert (toClosureLbl l) s
                               else s
 
-cafAnal :: Platform -> CmmGraph -> CAFEnv
+cafAnal :: CmmGraph -> CAFEnv
 cafAnal g = dataflowAnalBwd g [] $ analBwd cafLattice cafTransfers
 
 -----------------------------------------------------------------------

compiler/cmm/CmmLayoutStack.hs

@@ -1033,13 +1033,16 @@ walk (n:ns) acc as
     (dropped, as') = partition should_drop as
        where should_drop a = a `conflicts` n
 
+toNodes :: [(LocalReg,CmmExpr)] -> [CmmNode O O]
 toNodes as = [ CmmAssign (CmmLocal r) rhs | (r,rhs) <- as ]
 
 -- We only sink "r = G" assignments right now, so conflicts is very simple:
-(r, rhs) `conflicts` CmmAssign reg  _  | reg `regUsedIn` rhs = True
+conflicts :: (LocalReg,CmmExpr) -> CmmNode O O -> Bool
+(_, rhs) `conflicts` CmmAssign reg  _  | reg `regUsedIn` rhs = True
 --(r, CmmLoad _ _) `conflicts` CmmStore _ _ = True
 (r, _)   `conflicts` node
   = foldRegsUsed (\b r' -> r == r' || b) False node
 
+conflictsWithLast :: (LocalReg,CmmExpr) -> CmmNode O C -> Bool
 (r, _) `conflictsWithLast` node
   = foldRegsUsed (\b r' -> r == r' || b) False node

compiler/cmm/CmmLint.hs

@@ -7,7 +7,7 @@
 -----------------------------------------------------------------------------
 {-# LANGUAGE GADTs #-}
 module CmmLint (
-    cmmLint, cmmLintDecl, cmmLintGraph
+    cmmLint, cmmLintGraph
   ) where
 
 import Hoopl
@@ -31,7 +31,7 @@ import Data.Maybe
 -- Exported entry points:
 
 cmmLint :: (Outputable d, Outputable h)
-        => GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
+        => GenCmmGroup d h CmmGraph -> Maybe SDoc
 cmmLint tops = runCmmLint (mapM_ lintCmmDecl) tops
 
 cmmLintGraph :: CmmGraph -> Maybe SDoc
@@ -62,7 +62,7 @@ lintCmmGraph g = mapM_ (lintCmmBlock labels) blocks
 
 lintCmmBlock :: BlockSet -> CmmBlock -> CmmLint ()
 lintCmmBlock labels block
-  = addLintInfo (\_ -> text "in basic block " <> ppr (entryLabel block)) $ do
+  = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
         let (_, middle, last) = blockSplit block
         mapM_ lintCmmMiddle (blockToList middle)
         lintCmmLast labels last
@@ -172,7 +172,7 @@ lintCmmLast labels node = case node of
  where
   checkTarget id
      | setMember id labels = return ()
-     | otherwise = cmmLintErr (\_ -> text "Branch to nonexistent id" <+> ppr id)
+     | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
 
 
 lintTarget :: ForeignTarget -> CmmLint ()
@@ -195,18 +195,18 @@ checkCond expr
 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
 
 instance Monad CmmLint where
-  CmmLint m >>= k = CmmLint $ \p -> case m p of
-                                      Left e -> Left e
-                                      Right a -> unCL (k a) p
-  return a = CmmLint (\_ -> Right a)
+  CmmLint m >>= k = CmmLint $ case m of
+                                Left e -> Left e
+                                Right a -> unCL (k a)
+  return a = CmmLint (Right a)
 
 cmmLintErr :: SDoc -> CmmLint a
-cmmLintErr msg = CmmLint (\p -> Left (msg p))
+cmmLintErr msg = CmmLint (Left msg)
 
 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
-addLintInfo info thing = CmmLint $ \p ->
-   case unCL thing p of
-        Left err -> Left (hang (info p) 2 err)
+addLintInfo info thing = CmmLint $
+   case unCL thing of
+        Left err -> Left (hang info 2 err)
         Right a  -> Right a
 
 cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a

compiler/cmm/CmmOpt.hs

@@ -146,7 +146,6 @@ To inline _smi:
 
 countUses :: UserOfLocalRegs a => a -> UniqFM Int
 countUses a = foldRegsUsed (\m r -> addToUFM_C (+) m r 1) emptyUFM a
-  where count m r = lookupWithDefaultUFM m (0::Int) r
 
 cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock]
 cmmMiniInline dflags blocks = map do_inline blocks
@@ -158,14 +157,14 @@ cmmMiniInlineStmts _      _    [] = []
 cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
         -- not used: just discard this assignment
   | 0 <- lookupWithDefaultUFM uses 0 u
-  = cmmMiniInlineStmts uses stmts
+  = cmmMiniInlineStmts dflags uses stmts
 
         -- used (foldable to small thing): try to inline at all the use sites
   | Just n <- lookupUFM uses u,
     e <- wrapRecExp foldExp expr,
     isTiny e
   =
-     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
+     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $
      case lookForInlineMany u e stmts of
          (m, stmts')
              | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts'
@@ -256,6 +255,7 @@ okToInline _ _ = True
 -- changed is not one we were relying on.  I don't know how much of a
 -- performance hit this is (we have to create a regset for every
 -- instruction.) -- EZY
+okToSkip :: CmmStmt -> Unique -> CmmExpr -> RegSet -> Bool
 okToSkip stmt u expr regset
    = case stmt of
          CmmNop -> True

compiler/cmm/CmmPipeline.hs

@@ -12,28 +12,22 @@ module CmmPipeline (
 import CLabel
 import Cmm
 import CmmLint
-import CmmLive
 import CmmBuildInfoTables
 import CmmCommonBlockElim
 import CmmProcPoint
-import CmmRewriteAssignments
 import CmmContFlowOpt
 import OptimizationFuel
 import CmmLayoutStack
-import Hoopl
-import CmmUtils
 
 import DynFlags
 import ErrUtils
 import HscTypes
 import Data.Maybe
 import Control.Monad
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
 import Outputable
-import StaticFlags
+
+import qualified Data.Set as Set
+import Data.Map (Map)
 
 -----------------------------------------------------------------------------
 -- | Top level driver for C-- pipeline
@@ -133,8 +127,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
        dumps Opt_D_dump_cmmz_split "Post splitting" gs
 
        ------------- More CAFs ------------------------------
-       let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform g
-       let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo platform cafEnv) gs
+       let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
+       let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo cafEnv) gs
        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
 
        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
@@ -155,7 +149,6 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
               -- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
 
   where dflags = hsc_dflags hsc_env
-        platform = targetPlatform dflags
         mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
                          | otherwise = z
         dump = dumpGraph dflags
@@ -165,9 +158,6 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
 
         -- Runs a required transformation/analysis
         run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
-        -- Runs an optional transformation/analysis (and should
-        -- thus be subject to optimization fuel)
-        runOptimization = runFuelIO (hsc_OptFuel hsc_env)
 
 
 dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
@@ -175,8 +165,8 @@ dumpGraph dflags flag name g = do
   when (dopt Opt_DoCmmLinting dflags) $ do_lint g
   dumpWith dflags flag name g
  where
-  do_lint g = case cmmLintGraph (targetPlatform dflags) g of
-                 Just err -> do { printDump err
+  do_lint g = case cmmLintGraph g of
+                 Just err -> do { fatalErrorMsg dflags err
                                 ; ghcExit dflags 1
                                 }
                  Nothing  -> return ()

compiler/codeGen/CodeGen.lhs

@@ -30,7 +30,7 @@ import CgHpc
 
 import CLabel
 import OldCmm
-import OldPprCmm
+import OldPprCmm ()
 
 import StgSyn
 import PrelNames
@@ -46,6 +46,7 @@ import Module
 import ErrUtils
 import Panic
 import Outputable
+import Util
 
 import OrdList
 import Stream (Stream, liftIO)

compiler/codeGen/StgCmmHeap.hs

@@ -338,7 +338,7 @@ entryHeapCheck cl_info offset nodeSet arity args code
 
            args' = map (CmmReg . CmmLocal) args
            setN = case nodeSet of
-                          Just n  -> mkNop -- No need to assign R1, it already
+                          Just _  -> mkNop -- No need to assign R1, it already
                                            -- points to the closure
                           Nothing -> mkAssign nodeReg $
                               CmmLit (CmmLabel $ staticClosureLabel cl_info)

compiler/codeGen/StgCmmUtils.hs

@@ -575,8 +575,8 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do
     branches_lbls <- label_branches join_lbl branches
     tag_expr'     <- assignTemp' tag_expr
     
-    emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches) mb_deflt_lbl
-                lo_tag hi_tag via_C
+    emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches_lbls)
+                mb_deflt_lbl lo_tag hi_tag via_C
 
           -- Sort the branches before calling mk_switch
 

compiler/main/CodeOutput.lhs

@@ -28,11 +28,9 @@ import qualified Stream
 import ErrUtils
 import Outputable
 import Module
-import Maybes           ( firstJusts )
 import SrcLoc
 
 import Control.Exception
-import Control.Monad
 import System.Directory
 import System.FilePath
 import System.IO

compiler/main/HscMain.hs

@@ -121,7 +121,6 @@ import SimplStg         ( stg2stg )
 import CodeGen          ( codeGen )
 import qualified OldCmm as Old
 import qualified Cmm as New
-import PprCmm           ( pprCmms )
 import CmmParse         ( parseCmmFile )
 import CmmBuildInfoTables
 import CmmPipeline
@@ -151,7 +150,6 @@ import Exception
 import qualified Stream
 import Stream (Stream)
 
-import CLabel
 import Util
 
 import Data.List

compiler/nativeGen/AsmCodeGen.lhs

@@ -274,7 +274,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
         split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
 
 
-cmmNativeGenStream :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
               => DynFlags
               -> NcgImpl statics instr jumpDest
               -> BufHandle

compiler/utils/Outputable.lhs

@@ -699,8 +699,6 @@ instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
     ppr m = ppr (M.toList m)
 instance (Outputable elt) => Outputable (IM.IntMap elt) where
     ppr m = ppr (IM.toList m)
-instance (PlatformOutputable elt) => PlatformOutputable (Set.Set elt) where
-    pprPlatform platform m = pprPlatform platform (Set.toList m)
 \end{code}
 
 %************************************************************************