Merge remote-tracking branch 'origin/master' into newcg
authorSimon Marlow <marlowsd@gmail.com>
Wed, 4 Jul 2012 09:34:48 +0000 (10:34 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Wed, 4 Jul 2012 09:34:48 +0000 (10:34 +0100)
* origin/master: (756 commits)
  don't crash if argv[0] == NULL (#7037)
  -package P was loading all versions of P in GHCi (#7030)
  Add a Note, copying text from #2437
  improve the --help docs a bit (#7008)
  Copy Data.HashTable's hashString into our Util module
  Build fix
  Build fixes
  Parse error: suggest brackets and indentation.
  Don't build the ghc DLL on Windows; works around trac #5987
  On Windows, detect if DLLs have too many symbols; trac #5987
  Add some more Integer rules; fixes #6111
  Fix PA dfun construction with silent superclass args
  Add silent superclass parameters to the vectoriser
  Add silent superclass parameters (again)
  Mention Generic1 in the user's guide
  Make the GHC API a little more powerful.
  tweak llvm version warning message
  New version of the patch for #5461.
  Fix Word64ToInteger conversion rule.
  Implemented feature request on reconfigurable pretty-printing in GHCi (#5461)
  ...

Conflicts:
compiler/basicTypes/UniqSupply.lhs
compiler/cmm/CmmBuildInfoTables.hs
compiler/cmm/CmmLint.hs
compiler/cmm/CmmOpt.hs
compiler/cmm/CmmPipeline.hs
compiler/cmm/CmmStackLayout.hs
compiler/cmm/MkGraph.hs
compiler/cmm/OldPprCmm.hs
compiler/codeGen/CodeGen.lhs
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmUtils.hs
compiler/main/CodeOutput.lhs
compiler/main/HscMain.hs
compiler/nativeGen/AsmCodeGen.lhs
compiler/simplStg/SimplStg.lhs

43 files changed:
1  2 
compiler/basicTypes/UniqSupply.lhs
compiler/cmm/Cmm.hs
compiler/cmm/CmmBuildInfoTables.hs
compiler/cmm/CmmCvt.hs
compiler/cmm/CmmExpr.hs
compiler/cmm/CmmInfo.hs
compiler/cmm/CmmLint.hs
compiler/cmm/CmmOpt.hs
compiler/cmm/CmmParse.y
compiler/cmm/CmmPipeline.hs
compiler/cmm/CmmProcPoint.hs
compiler/cmm/CmmUtils.hs
compiler/cmm/OldCmm.hs
compiler/cmm/OldCmmLint.hs
compiler/cmm/OldPprCmm.hs
compiler/cmm/OptimizationFuel.hs
compiler/cmm/PprCmm.hs
compiler/cmm/PprCmmExpr.hs
compiler/codeGen/CgInfoTbls.hs
compiler/codeGen/CgMonad.lhs
compiler/codeGen/CodeGen.lhs
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmEnv.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmMonad.hs
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmProf.hs
compiler/codeGen/StgCmmTicky.hs
compiler/codeGen/StgCmmUtils.hs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/main/CodeOutput.lhs
compiler/main/DynFlags.hs
compiler/main/HscMain.hs
compiler/nativeGen/AsmCodeGen.lhs
compiler/simplStg/SimplStg.lhs
compiler/utils/Outputable.lhs

@@@ -190,14 -187,7 +190,7 @@@ getUniqueUs = USM (\us -> case splitUni
  
  getUniquesUs :: UniqSM [Unique]
  getUniquesUs = USM (\us -> case splitUniqSupply us of
 -                           (us1,us2) -> (uniqsFromSupply us1, us2))
 +                           (us1,us2) -> (# uniqsFromSupply us1, us2 #))
- mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
- mapUs _ []     = returnUs []
- mapUs f (x:xs)
-   = f x         `thenUs` \ r  ->
-     mapUs f xs  `thenUs` \ rs ->
-     returnUs (r:rs)
  \end{code}
  
  \begin{code}
Simple merge
@@@ -90,12 -196,12 +89,12 @@@ type CAFEnv = BlockEnv CAFSe
  
  -- First, an analysis to find live CAFs.
  cafLattice :: DataflowLattice CAFSet
 -cafLattice = DataflowLattice "live cafs" Map.empty add
 -  where add _ (OldFact old) (NewFact new) = case old `Map.union` new of
 -                                              new' -> (changeIf $ Map.size new' > Map.size old, new')
 +cafLattice = DataflowLattice "live cafs" Set.empty add
 +  where add _ (OldFact old) (NewFact new) = case old `Set.union` new of
 +                                              new' -> (changeIf $ Set.size new' > Set.size old, new')
  
- cafTransfers :: Platform -> BwdTransfer CmmNode CAFSet
- cafTransfers platform = mkBTransfer3 first middle last
+ cafTransfers :: BwdTransfer CmmNode CAFSet
+ cafTransfers = mkBTransfer3 first middle last
    where first  _ live = live
          middle m live = foldExpDeep addCaf m live
          last   l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
                 CmmLit (CmmLabelOff c _)         -> add c set
                 CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
                 _ -> set
-         add l s = if hasCAF l then Set.insert (toClosureLbl platform l) s
 -        add l s = if hasCAF l then Map.insert (toClosureLbl l) () s
++        add l s = if hasCAF l then Set.insert (toClosureLbl l) s
                                else s
  
 -cafAnal :: CmmGraph -> FuelUniqSM CAFEnv
 -cafAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice cafTransfers
 +cafAnal :: Platform -> CmmGraph -> CAFEnv
- cafAnal platform g
-     = dataflowAnalBwd g [] $ analBwd cafLattice (cafTransfers platform)
++cafAnal g = dataflowAnalBwd g [] $ analBwd cafLattice cafTransfers
  
  -----------------------------------------------------------------------
  -- Building the SRTs
@@@ -24,16 -24,20 +24,16 @@@ cmmOfZgraph tops = map mapTop top
  
  data ValueDirection = Arguments | Results
  
 -add_hints :: Convention -> ValueDirection -> [a] -> [Old.CmmHinted a]
 +add_hints :: ForeignTarget -> ValueDirection -> [a] -> [Old.CmmHinted a]
  add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd)
  
 -get_hints :: Convention -> ValueDirection -> [ForeignHint]
 -get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
 -get_hints (Foreign (ForeignConvention _ _ hints)) Results   = hints
 -get_hints _other_conv                             _vd       = repeat NoHint
 -
 -get_conv :: ForeignTarget -> Convention
 -get_conv (PrimTarget _)       = NativeNodeCall -- JD: SUSPICIOUS
 -get_conv (ForeignTarget _ fc) = Foreign fc
 +get_hints :: ForeignTarget -> ValueDirection -> [ForeignHint]
 +get_hints (ForeignTarget _ (ForeignConvention _ hints _)) Arguments = hints
 +get_hints (ForeignTarget _ (ForeignConvention _ _ hints)) Results   = hints
 +get_hints (PrimTarget _) _vd = repeat NoHint
  
  cmm_target :: ForeignTarget -> Old.CmmCallTarget
- cmm_target (PrimTarget op) = Old.CmmPrim op
+ cmm_target (PrimTarget op) = Old.CmmPrim op Nothing
  cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc
  
  ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
Simple merge
Simple merge
@@@ -5,21 -5,26 +5,20 @@@
  -- CmmLint: checking the correctness of Cmm statements and expressions
  --
  -----------------------------------------------------------------------------
 -
 -{-# OPTIONS -fno-warn-tabs #-}
 --- The above warning supression flag is a temporary kludge.
 --- While working on this module you are encouraged to remove it and
 --- detab the module (please do the detabbing in a separate patch). See
 ---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 --- for details
 -
 +{-# LANGUAGE GADTs #-}
  module CmmLint (
 -  cmmLint, cmmLintTop
 +    cmmLint, cmmLintDecl, cmmLintGraph
    ) where
  
 +import Hoopl
 +import Cmm
 +import CmmUtils
 +import PprCmm ()
  import BlockId
 -import OldCmm
 +import FastString
  import CLabel
- import Platform
  import Outputable
 -import OldPprCmm()
  import Constants
 -import FastString
 -import Platform
  
  import Data.Maybe
  
  -- -----------------------------------------------------------------------------
  -- Exported entry points:
  
- cmmLint :: (PlatformOutputable d, PlatformOutputable h)
-         => Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc
- cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops
+ cmmLint :: (Outputable d, Outputable h)
 -        => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
 -cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops
++        => GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
++cmmLint tops = runCmmLint (mapM_ lintCmmDecl) tops
  
- cmmLintDecl :: (PlatformOutputable d, PlatformOutputable h)
-            => Platform -> GenCmmDecl d h CmmGraph -> Maybe SDoc
- cmmLintDecl platform top = runCmmLint platform lintCmmDecl top
 -cmmLintTop :: (Outputable d, Outputable h)
 -           => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
 -cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top
++cmmLintGraph :: CmmGraph -> Maybe SDoc
++cmmLintGraph g = runCmmLint lintCmmGraph g
  
- cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc
- cmmLintGraph platform g = runCmmLint platform lintCmmGraph g
- runCmmLint :: PlatformOutputable a
 -runCmmLint :: Outputable a
--           => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
- runCmmLint platform l p =
-    case unCL (l p) platform of
-    Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
-                            nest 2 err,
-                            ptext $ sLit ("Program was:"),
-                            nest 2 (pprPlatform platform p)])
-    Right _  -> Nothing
 -runCmmLint _ l p =
++runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
++runCmmLint l p =
+    case unCL (l p) of
 -   Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
 -                           nest 2 err,
 -                           ptext $ sLit ("Program was:"),
 -                           nest 2 (ppr p)])
 -   Right _  -> Nothing
 -
 -lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
 -lintCmmDecl platform (CmmProc _ lbl (ListGraph blocks))
 -  = addLintInfo (text "in proc " <> pprCLabel platform lbl) $
 -        let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
 -      in  mapM_ (lintCmmBlock platform labels) blocks
 -
 -lintCmmDecl _ (CmmData {})
++     Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
++                             nest 2 err,
++                             ptext $ sLit ("Program was:"),
++                             nest 2 (ppr p)])
++     Right _  -> Nothing
 +
 +lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
 +lintCmmDecl (CmmProc _ lbl g)
-   = addLintInfo (\platform -> text "in proc " <> pprCLabel platform lbl) $
-         lintCmmGraph g
++  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g
 +lintCmmDecl (CmmData {})
    = return ()
  
 -lintCmmBlock :: Platform -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
 -lintCmmBlock platform labels (BasicBlock id stmts)
 -  = addLintInfo (text "in basic block " <> ppr id) $
 -      mapM_ (lintCmmStmt platform labels) stmts
 +
 +lintCmmGraph :: CmmGraph -> CmmLint ()
 +lintCmmGraph g = mapM_ (lintCmmBlock labels) blocks
 +  where
 +       blocks = toBlockList g
 +       labels = setFromList (map entryLabel blocks)
 +
 +
 +lintCmmBlock :: BlockSet -> CmmBlock -> CmmLint ()
 +lintCmmBlock labels block
 +  = addLintInfo (\_ -> text "in basic block " <> ppr (entryLabel block)) $ do
 +        let (_, middle, last) = blockSplit block
 +        mapM_ lintCmmMiddle (blockToList middle)
 +        lintCmmLast labels last
  
  -- -----------------------------------------------------------------------------
  -- lintCmmExpr
@@@ -130,110 -119,91 +123,108 @@@ notNodeReg :: CmmExpr -> Boo
  notNodeReg (CmmReg reg) | reg == nodeReg = False
  notNodeReg _                             = True
  
 -lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint ()
 -lintCmmStmt platform labels = lint
 -    where lint (CmmNop) = return ()
 -          lint (CmmComment {}) = return ()
 -          lint stmt@(CmmAssign reg expr) = do
 -            erep <- lintCmmExpr platform expr
 -          let reg_ty = cmmRegType reg
 +lintCmmMiddle :: CmmNode O O -> CmmLint ()
 +lintCmmMiddle node = case node of
 +  CmmComment _ -> return ()
 +
 +  CmmAssign reg expr -> do
 +            erep <- lintCmmExpr expr
 +            let reg_ty = cmmRegType reg
              if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
                  then return ()
 -                else cmmLintAssignErr stmt erep reg_ty
 -          lint (CmmStore l r) = do
 -            _ <- lintCmmExpr platform l
 -            _ <- lintCmmExpr platform r
 +                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
 +
 +  CmmStore l r -> do
 +            _ <- lintCmmExpr l
 +            _ <- lintCmmExpr r
              return ()
 -          lint (CmmCall target _res args _) =
 -              do lintTarget platform labels target
 -                 mapM_ (lintCmmExpr platform . hintlessCmm) args
 -          lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond e
 -          lint (CmmSwitch e branches) = do
 +
 +  CmmUnsafeForeignCall target _formals actuals -> do
 +            lintTarget target
 +            mapM_ lintCmmExpr actuals
 +
 +
 +lintCmmLast :: BlockSet -> CmmNode O C -> CmmLint ()
 +lintCmmLast labels node = case node of
 +  CmmBranch id -> checkTarget id
 +
 +  CmmCondBranch e t f -> do
 +            mapM_ checkTarget [t,f]
 +            _ <- lintCmmExpr e
 +            checkCond e
 +
 +  CmmSwitch e branches -> do
              mapM_ checkTarget $ catMaybes branches
 -            erep <- lintCmmExpr platform e
 +            erep <- lintCmmExpr e
              if (erep `cmmEqType_ignoring_ptrhood` bWord)
                then return ()
-               else cmmLintErr (\platform ->
-                                text "switch scrutinee is not a word: " <>
-                                pprPlatform platform e <>
 -              else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
--                               text " :: " <> ppr erep)
 -          lint (CmmJump e _) = lintCmmExpr platform e >> return ()
 -          lint (CmmReturn) = return ()
 -          lint (CmmBranch id) = checkTarget id
 -          checkTarget id = if setMember id labels then return ()
 -                           else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
 -
 -lintTarget :: Platform -> BlockSet -> CmmCallTarget -> CmmLint ()
 -lintTarget platform _      (CmmCallee e _) = do _ <- lintCmmExpr platform e
 -                                                return ()
 -lintTarget _        _      (CmmPrim _ Nothing) = return ()
 -lintTarget platform labels (CmmPrim _ (Just stmts))
 -    = mapM_ (lintCmmStmt platform labels) stmts
++              else cmmLintErr (text "switch scrutinee is not a word: " <>
++                               ppr e <> text " :: " <> ppr erep)
 +
 +  CmmCall { cml_target = target, cml_cont = cont } -> do
 +          _ <- lintCmmExpr target
 +          maybe (return ()) checkTarget cont
 +
 +  CmmForeignCall tgt _ args succ _ _ -> do
 +          lintTarget tgt
 +          mapM_ lintCmmExpr args
 +          checkTarget succ
 + where
 +  checkTarget id
 +     | setMember id labels = return ()
 +     | otherwise = cmmLintErr (\_ -> text "Branch to nonexistent id" <+> ppr id)
 +
 +
 +lintTarget :: ForeignTarget -> CmmLint ()
 +lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
 +lintTarget (PrimTarget {})     = return ()
  
  
  checkCond :: CmmExpr -> CmmLint ()
  checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
  checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
  checkCond expr
-     = cmmLintErr (\platform -> hang (text "expression is not a conditional:") 2
-                          (pprPlatform platform expr))
+     = cmmLintErr (hang (text "expression is not a conditional:") 2
 -                       (ppr expr))
++                         (ppr expr))
  
  -- -----------------------------------------------------------------------------
  -- CmmLint monad
  
  -- just a basic error monad:
  
- newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a }
+ newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
  
  instance Monad CmmLint where
 -  CmmLint m >>= k = CmmLint $ case m of 
 -                              Left e -> Left e
 -                              Right a -> unCL (k a)
 -  return a = CmmLint (Right a)
 +  CmmLint m >>= k = CmmLint $ \p -> case m p of
 +                                      Left e -> Left e
 +                                      Right a -> unCL (k a) p
 +  return a = CmmLint (\_ -> Right a)
  
- cmmLintErr :: (Platform -> SDoc) -> CmmLint a
+ cmmLintErr :: SDoc -> CmmLint a
 -cmmLintErr msg = CmmLint (Left msg)
 +cmmLintErr msg = CmmLint (\p -> Left (msg p))
  
- addLintInfo :: (Platform -> SDoc) -> CmmLint a -> CmmLint a
+ addLintInfo :: SDoc -> CmmLint a -> CmmLint a
 -addLintInfo info thing = CmmLint $ 
 -   case unCL thing of
 -      Left err -> Left (hang info 2 err)
 -      Right a  -> Right a
 +addLintInfo info thing = CmmLint $ \p ->
 +   case unCL thing of
 +        Left err -> Left (hang (info p) 2 err)
 +        Right a  -> Right a
  
  cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
  cmmLintMachOpErr expr argsRep opExpectsRep
-      = cmmLintErr (\platform -> text "in MachOp application: " $$
-                                         nest 2 (pprPlatform platform expr) $$
-                                         (text "op is expecting: " <+> ppr opExpectsRep) $$
-                                         (text "arguments provide: " <+> ppr argsRep))
 -     = cmmLintErr (text "in MachOp application: " $$ 
 -                                      nest 2 (ppr expr) $$
 -                                      (text "op is expecting: " <+> ppr opExpectsRep) $$
 -                                      (text "arguments provide: " <+> ppr argsRep))
++     = cmmLintErr (text "in MachOp application: " $$
++                   nest 2 (ppr  expr) $$
++                      (text "op is expecting: " <+> ppr opExpectsRep) $$
++                      (text "arguments provide: " <+> ppr argsRep))
  
 -cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
 +cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
  cmmLintAssignErr stmt e_ty r_ty
-   = cmmLintErr (\platform -> text "in assignment: " $$
-                nest 2 (vcat [pprPlatform platform stmt,
-                                 text "Reg ty:" <+> ppr r_ty,
-                                 text "Rhs ty:" <+> ppr e_ty]))
 -  = cmmLintErr (text "in assignment: " $$ 
 -              nest 2 (vcat [ppr stmt, 
 -                            text "Reg ty:" <+> ppr r_ty,
 -                            text "Rhs ty:" <+> ppr e_ty]))
 -                       
 -                                      
++  = cmmLintErr (text "in assignment: " $$
++                nest 2 (vcat [ppr stmt,
++                              text "Reg ty:" <+> ppr r_ty,
++                              text "Rhs ty:" <+> ppr e_ty]))
 +
  
  cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
  cmmLintDubiousWordOffset expr
-    = cmmLintErr (\platform -> text "offset is not a multiple of words: " $$
-                               nest 2 (pprPlatform platform expr))
+    = cmmLintErr (text "offset is not a multiple of words: " $$
 -                      nest 2 (ppr expr))
++                 nest 2 (ppr expr))
@@@ -143,45 -145,50 +145,46 @@@ To inline _smi
  -}
  
  countUses :: UserOfLocalRegs a => a -> UniqFM Int
 -countUses a = foldRegsUsed (\m r -> addToUFM m r (count m r + 1)) emptyUFM a
 +countUses a = foldRegsUsed (\m r -> addToUFM_C (+) m r 1) emptyUFM a
    where count m r = lookupWithDefaultUFM m (0::Int) r
  
- cmmMiniInline :: Platform -> [CmmBasicBlock] -> [CmmBasicBlock]
- cmmMiniInline platform blocks = map do_inline blocks
+ cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock]
+ cmmMiniInline dflags blocks = map do_inline blocks
    where do_inline (BasicBlock id stmts)
-           = BasicBlock id (cmmMiniInlineStmts platform (countUses blocks) stmts)
+           = BasicBlock id (cmmMiniInlineStmts dflags (countUses blocks) stmts)
  
- cmmMiniInlineStmts :: Platform -> UniqFM Int -> [CmmStmt] -> [CmmStmt]
- cmmMiniInlineStmts _        _    [] = []
- cmmMiniInlineStmts platform uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
+ cmmMiniInlineStmts :: DynFlags -> UniqFM Int -> [CmmStmt] -> [CmmStmt]
+ cmmMiniInlineStmts _      _    [] = []
+ cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
          -- not used: just discard this assignment
 -  | Nothing <- lookupUFM uses u
 -  = cmmMiniInlineStmts dflags uses stmts
 +  | 0 <- lookupWithDefaultUFM uses 0 u
-   = cmmMiniInlineStmts platform uses stmts
++  = cmmMiniInlineStmts uses stmts
  
 -        -- used (literal): try to inline at all the use sites
 -  | Just n <- lookupUFM uses u, isLit expr
 -  =
 -     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $
 -     case lookForInlineLit u expr stmts of
 -         (m, stmts')
 -             | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts'
 -             | otherwise ->
 -                 stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts'
 -
 -        -- used (foldable to literal): try to inline at all the use sites
 +        -- used (foldable to small thing): try to inline at all the use sites
    | Just n <- lookupUFM uses u,
 -    e@(CmmLit _) <- wrapRecExp foldExp expr
 +    e <- wrapRecExp foldExp expr,
 +    isTiny e
    =
-      ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $
 -     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $
 -     case lookForInlineLit u e stmts of
++     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
 +     case lookForInlineMany u e stmts of
           (m, stmts')
-              | n == m -> cmmMiniInlineStmts platform (delFromUFM uses u) stmts'
+              | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts'
               | otherwise ->
-                  stmt : cmmMiniInlineStmts platform (adjustUFM (\x -> x - m) uses u) stmts'
+                  stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts'
  
          -- used once (non-literal): try to inline at the use site
    | Just 1 <- lookupUFM uses u,
      Just stmts' <- lookForInline u expr stmts
    = 
-      ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $
-      cmmMiniInlineStmts platform uses stmts'
+      ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $
+      cmmMiniInlineStmts dflags uses stmts'
   where
 +  isTiny (CmmLit _) = True
 +  isTiny (CmmReg (CmmGlobal _)) = True
 +         -- not CmmLocal: that might invalidate the usage analysis results
 +  isTiny _ = False
 +
+   platform = targetPlatform dflags
    foldExp (CmmMachOp op args) = cmmMachOpFold platform op args
    foldExp e = e
  
@@@ -1055,11 -1070,10 +1055,11 @@@ parseCmmFile dflags filename = d
                -- in there we don't want.
    case unP cmmParse init_state of
      PFailed span err -> do
-         let msg = mkPlainErrMsg span err
+         let msg = mkPlainErrMsg dflags span err
          return ((emptyBag, unitBag msg), Nothing)
      POk pst code -> do
 -        cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
 +        st <- initC
 +        let (cmm,_) = runC dflags no_module st (getCmm (unEC code initEnv [] >> return ()))
          let ms = getMessages pst
          if (errorsFound dflags ms)
           then return (ms, Nothing)
@@@ -76,9 -73,12 +76,9 @@@ cmmPipeline hsc_env topSRT prog 
       let cmms :: CmmGroup
           cmms = reverse (concat tops)
  
-      dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms)
+      dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
  
 -     -- SRT is not affected by control flow optimization pass
 -     let prog' = runCmmContFlowOpts cmms
 -
 -     return (topSRT, prog' : rst)
 +     return (topSRT, cmms)
  
  {- [Note global fuel]
  ~~~~~~~~~~~~~~~~~~~~~
@@@ -92,63 -92,75 +92,63 @@@ global to one compiler session
  -- -ddump-cmmz
  
  cpsTop :: HscEnv -> CmmDecl -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmDecl)])
 -cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
 +cpsTop _ p@(CmmData {}) = return ([], [(Set.empty, p)])
  cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
      do
 -       -- Why bother doing these early: dualLivenessWithInsertion,
 -       -- insertLateReloads, rewriteAssignments?
 +       ----------- Control-flow optimisations ---------------
 +       g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOpts g
 +       dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
  
         ----------- Eliminate common blocks -------------------
 -       g <- return $ elimCommonBlocks g
 +       g <- {-# SCC "elimCommonBlocks" #-} return $ elimCommonBlocks g
         dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
 -       -- Any work storing block Labels must be performed _after_ elimCommonBlocks
 +       -- Any work storing block Labels must be performed _after_
 +       -- elimCommonBlocks
  
         ----------- Proc points -------------------
 -       let callPPs = callProcPoints g
 -       procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g
 -       g <- run $ addProcPointProtocols callPPs procPoints g
 -       dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
 -
 -       ----------- Spills and reloads -------------------
 -       g <- run $ dualLivenessWithInsertion procPoints g
 -       dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
 -
 -       ----------- Sink and inline assignments -------------------
 -       g <- runOptimization $ rewriteAssignments platform g
 -       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
 -
 -       ----------- Eliminate dead assignments -------------------
 -       g <- runOptimization $ removeDeadAssignments g
 -       dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g
 -
 -       ----------- Zero dead stack slots (Debug only) ---------------
 -       -- Debugging: stubbing slots on death can cause crashes early
 -       g <- if opt_StubDeadValues
 -                then run $ stubSlotsOnDeath g
 -                else return g
 -       dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
 -
 -       --------------- Stack layout ----------------
 -       slotEnv <- run $ liveSlotAnal g
 -       let spEntryMap = getSpEntryMap entry_off g
 -       mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
 -       let areaMap = layout procPoints spEntryMap slotEnv entry_off g
 -       mbpprTrace "areaMap" (ppr areaMap) $ return ()
 -
 -       ------------  Manifest the stack pointer --------
 -       g  <- run $ manifestSP spEntryMap areaMap entry_off g
 -       dump Opt_D_dump_cmmz_sp "Post manifestSP" g
 -       -- UGH... manifestSP can require updates to the procPointMap.
 -       -- We can probably do something quicker here for the update...
 +       let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
 +       procPoints <- {-# SCC "minimalProcPointSet" #-} run $
 +                     minimalProcPointSet (targetPlatform dflags) callPPs g
 +
 +       ----------- Layout the stack and manifest Sp ---------------
 +       -- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
 +       (g, stackmaps) <- {-# SCC "layoutStack" #-}
 +                         run $ cmmLayoutStack procPoints entry_off g
 +       dump Opt_D_dump_cmmz_sp "Layout Stack" g
 +
 +       g <- {-# SCC "sink" #-} run $ cmmSink g
 +       dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
 +
 +--       ----------- Sink and inline assignments -------------------
 +--       g <- {-# SCC "rewriteAssignments" #-} runOptimization $
 +--            rewriteAssignments platform g
 +--       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
  
         ------------- Split into separate procedures ------------
 -       procPointMap  <- run $ procPointAnalysis procPoints g
 -       dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
 -       gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
 -                                       (CmmProc h l g)
 -       mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
 -
 -       ------------- More CAFs and foreign calls ------------
 -       cafEnv <- run $ cafAnal g
 -       let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
 +       procPointMap  <- {-# SCC "procPointAnalysis" #-} run $
 +                        procPointAnalysis procPoints g
-        dumpWith dflags ppr Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
++       dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
 +       gs <- {-# SCC "splitAtProcPoints" #-} run $
 +             splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
 +       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
-        mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
+        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
  
 -       gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
 -       mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
 -
         -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
 -       gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
 -       mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
 -       gs <- return $ map (bundleCAFs cafEnv) gs
 -       mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
 +       gs <- {-# SCC "setInfoTableStackMap" #-}
 +             return $ map (setInfoTableStackMap stackmaps) gs
 +       dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
 +
 +       ----------- Control-flow optimisations ---------------
 +       gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
 +       dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
 +
 +       gs <- {-# SCC "bundleCAFs" #-} return $ map (bundleCAFs cafEnv) gs
 +       dumps Opt_D_dump_cmmz_cafs "after bundleCAFs" gs
 +
         return (localCAFs, gs)
  
                -- gs        :: [ (CAFSet, CmmDecl) ]
  
    where dflags = hsc_dflags hsc_env
          platform = targetPlatform dflags
 -        mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
 -        dump f = dumpWith ppr f
 -        dumpWith pprFun f txt g = do
 -            -- ToDo: No easy way of say "dump all the cmmz, *and* split
 -            -- them into files."  Also, -ddump-cmmz doesn't play nicely
 -            -- with -ddump-to-file, since the headers get omitted.
 -            dumpIfSet_dyn dflags f txt (pprFun g)
 -            when (not (dopt f dflags)) $
 -                dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
 +        mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
 +                         | otherwise = z
 +        dump = dumpGraph dflags
 +
 +        dumps flag name
-            = mapM_ (dumpWith dflags (pprPlatform platform) flag name)
++           = mapM_ (dumpWith dflags flag name)
 +
          -- 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)
  
-   dumpWith dflags (pprPlatform (targetPlatform dflags)) flag name g
 +
 +dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
 +dumpGraph dflags flag name g = do
 +  when (dopt Opt_DoCmmLinting dflags) $ do_lint g
- dumpWith :: DynFlags -> (a -> SDoc) -> DynFlag -> String -> a -> IO ()
- dumpWith dflags pprFun flag txt g = do
++  dumpWith dflags flag name g
 + where
 +  do_lint g = case cmmLintGraph (targetPlatform dflags) g of
 +                 Just err -> do { printDump err
 +                                ; ghcExit dflags 1
 +                                }
 +                 Nothing  -> return ()
 +
-    dumpIfSet_dyn dflags flag txt (pprFun g)
++dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO ()
++dumpWith dflags flag txt g = do
 +         -- ToDo: No easy way of say "dump all the cmmz, *and* split
 +         -- them into files."  Also, -ddump-cmmz doesn't play nicely
 +         -- with -ddump-to-file, since the headers get omitted.
-       dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
++   dumpIfSet_dyn dflags flag txt (ppr g)
 +   when (not (dopt flag dflags)) $
++      dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
 +
  -- This probably belongs in CmmBuildInfoTables?
  -- We're just finishing the job here: once we know what CAFs are defined
  -- in non-static closures, we can build the SRTs.
Simple merge
Simple merge
@@@ -213,9 -222,13 +213,9 @@@ instance UserOfLocalRegs CmmStmt wher
        gen a set = foldRegsUsed f set a
  
  instance UserOfLocalRegs CmmCallTarget where
-     foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
-     foldRegsUsed _ set (CmmPrim {})    = set
+     foldRegsUsed f set (CmmCallee e _)    = foldRegsUsed f set e
+     foldRegsUsed f set (CmmPrim _ mStmts) = foldRegsUsed f set mStmts
  
 -instance UserOfSlots CmmCallTarget where
 -    foldSlotsUsed f set (CmmCallee e _) = foldSlotsUsed f set e
 -    foldSlotsUsed _ set (CmmPrim {})    = set
 -
  instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where
      foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a)
  
index cc7e2cd,0000000..72e40ce
mode 100644,000000..100644
--- /dev/null
@@@ -1,205 -1,0 +1,209 @@@
- cmmLint :: (PlatformOutputable d, PlatformOutputable h)
 +-----------------------------------------------------------------------------
 +--
 +-- (c) The University of Glasgow 2004-2006
 +--
 +-- CmmLint: checking the correctness of Cmm statements and expressions
 +--
 +-----------------------------------------------------------------------------
 +
 +{-# OPTIONS -fno-warn-tabs #-}
 +-- The above warning supression flag is a temporary kludge.
 +-- While working on this module you are encouraged to remove it and
 +-- detab the module (please do the detabbing in a separate patch). See
 +--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 +-- for details
 +
 +module OldCmmLint (
 +  cmmLint, cmmLintTop
 +  ) where
 +
 +import BlockId
 +import OldCmm
 +import CLabel
 +import Outputable
 +import OldPprCmm()
 +import Constants
 +import FastString
 +import Platform
 +
 +import Data.Maybe
 +
 +-- -----------------------------------------------------------------------------
 +-- Exported entry points:
 +
- cmmLintTop :: (PlatformOutputable d, PlatformOutputable h)
++cmmLint :: (Outputable d, Outputable h)
 +        => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
 +cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops
 +
- runCmmLint :: PlatformOutputable a
++cmmLintTop :: (Outputable d, Outputable h)
 +           => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
 +cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top
 +
- runCmmLint platform l p =
++runCmmLint :: Outputable a
 +           => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
-                            nest 2 (pprPlatform platform p)])
++runCmmLint _ l p =
 +   case unCL (l p) of
 +   Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
 +                           nest 2 err,
 +                           ptext $ sLit ("Program was:"),
-       else cmmLintMachOpErr platform expr (map cmmExprType args) (machOpArgReps op)
++                           nest 2 (ppr p)])
 +   Right _  -> Nothing
 +
 +lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
 +lintCmmDecl platform (CmmProc _ lbl (ListGraph blocks))
 +  = addLintInfo (text "in proc " <> pprCLabel platform lbl) $
 +        let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
 +      in  mapM_ (lintCmmBlock platform labels) blocks
 +
 +lintCmmDecl _ (CmmData {})
 +  = return ()
 +
 +lintCmmBlock :: Platform -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
 +lintCmmBlock platform labels (BasicBlock id stmts)
 +  = addLintInfo (text "in basic block " <> ppr id) $
 +      mapM_ (lintCmmStmt platform labels) stmts
 +
 +-- -----------------------------------------------------------------------------
 +-- lintCmmExpr
 +
 +-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
 +-- byte/word mismatches.
 +
 +lintCmmExpr :: Platform -> CmmExpr -> CmmLint CmmType
 +lintCmmExpr platform (CmmLoad expr rep) = do
 +  _ <- lintCmmExpr platform expr
 +  -- Disabled, if we have the inlining phase before the lint phase,
 +  -- we can have funny offsets due to pointer tagging. -- EZY
 +  -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
 +  --   cmmCheckWordAddress expr
 +  return rep
 +lintCmmExpr platform expr@(CmmMachOp op args) = do
 +  tys <- mapM (lintCmmExpr platform) args
 +  if map (typeWidth . cmmExprType) args == machOpArgReps op
 +      then cmmCheckMachOp op args tys
- _cmmCheckWordAddress :: Platform -> CmmExpr -> CmmLint ()
- _cmmCheckWordAddress platform e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
++      else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
 +lintCmmExpr platform (CmmRegOff reg offset)
 +  = lintCmmExpr platform (CmmMachOp (MO_Add rep)
 +              [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
 +  where rep = typeWidth (cmmRegType reg)
 +lintCmmExpr _ expr =
 +  return (cmmExprType expr)
 +
 +-- Check for some common byte/word mismatches (eg. Sp + 1)
 +cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
 +cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
 +  = cmmCheckMachOp op [reg, lit] tys
 +cmmCheckMachOp op _ tys
 +  = return (machOpResultType op tys)
 +
 +isOffsetOp :: MachOp -> Bool
 +isOffsetOp (MO_Add _) = True
 +isOffsetOp (MO_Sub _) = True
 +isOffsetOp _ = False
 +
 +-- This expression should be an address from which a word can be loaded:
 +-- check for funny-looking sub-word offsets.
-   = cmmLintDubiousWordOffset platform e
- _cmmCheckWordAddress platform e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
++_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
++_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
 +  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
-   = cmmLintDubiousWordOffset platform e
- _cmmCheckWordAddress _ _
++  = cmmLintDubiousWordOffset e
++_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
 +  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
-                 else cmmLintAssignErr platform stmt erep reg_ty
++  = cmmLintDubiousWordOffset e
++_cmmCheckWordAddress _
 +  = return ()
 +
 +-- No warnings for unaligned arithmetic with the node register,
 +-- which is used to extract fields from tagged constructor closures.
 +notNodeReg :: CmmExpr -> Bool
 +notNodeReg (CmmReg reg) | reg == nodeReg = False
 +notNodeReg _                             = True
 +
 +lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint ()
 +lintCmmStmt platform labels = lint
 +    where lint (CmmNop) = return ()
 +          lint (CmmComment {}) = return ()
 +          lint stmt@(CmmAssign reg expr) = do
 +            erep <- lintCmmExpr platform expr
 +          let reg_ty = cmmRegType reg
 +            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
 +                then return ()
-               lintTarget platform target >> mapM_ (lintCmmExpr platform . hintlessCmm) args
-           lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e
++                else cmmLintAssignErr stmt erep reg_ty
 +          lint (CmmStore l r) = do
 +            _ <- lintCmmExpr platform l
 +            _ <- lintCmmExpr platform r
 +            return ()
 +          lint (CmmCall target _res args _) =
-               else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <>
++              do lintTarget platform labels target
++                 mapM_ (lintCmmExpr platform . hintlessCmm) args
++          lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond e
 +          lint (CmmSwitch e branches) = do
 +            mapM_ checkTarget $ catMaybes branches
 +            erep <- lintCmmExpr platform e
 +            if (erep `cmmEqType_ignoring_ptrhood` bWord)
 +              then return ()
- lintTarget :: Platform -> CmmCallTarget -> CmmLint ()
- lintTarget platform (CmmCallee e _) = lintCmmExpr platform e >> return ()
- lintTarget _        (CmmPrim {})    = return ()
++              else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
 +                               text " :: " <> ppr erep)
 +          lint (CmmJump e _) = lintCmmExpr platform e >> return ()
 +          lint (CmmReturn) = return ()
 +          lint (CmmBranch id)    = checkTarget id
 +          checkTarget id = if setMember id labels then return ()
 +                           else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
 +
- checkCond :: Platform -> CmmExpr -> CmmLint ()
- checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
- checkCond _ (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
- checkCond platform expr
++lintTarget :: Platform -> BlockSet -> CmmCallTarget -> CmmLint ()
++lintTarget platform _      (CmmCallee e _) = do _ <- lintCmmExpr platform e
++                                                return ()
++lintTarget _        _      (CmmPrim _ Nothing) = return ()
++lintTarget platform labels (CmmPrim _ (Just stmts))
++    = mapM_ (lintCmmStmt platform labels) stmts
 +
 +
-                        (pprPlatform platform expr))
++checkCond :: CmmExpr -> CmmLint ()
++checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
++checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
++checkCond expr
 +    = cmmLintErr (hang (text "expression is not a conditional:") 2
- cmmLintMachOpErr :: Platform -> CmmExpr -> [CmmType] -> [Width] -> CmmLint a
- cmmLintMachOpErr platform expr argsRep opExpectsRep
++                       (ppr expr))
 +
 +-- -----------------------------------------------------------------------------
 +-- CmmLint monad
 +
 +-- just a basic error monad:
 +
 +newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
 +
 +instance Monad CmmLint where
 +  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 (Left msg)
 +
 +addLintInfo :: SDoc -> CmmLint a -> CmmLint a
 +addLintInfo info thing = CmmLint $ 
 +   case unCL thing of
 +      Left err -> Left (hang info 2 err)
 +      Right a  -> Right a
 +
-                                       nest 2 (pprPlatform platform expr) $$
++cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
++cmmLintMachOpErr expr argsRep opExpectsRep
 +     = cmmLintErr (text "in MachOp application: " $$ 
- cmmLintAssignErr :: Platform -> CmmStmt -> CmmType -> CmmType -> CmmLint a
- cmmLintAssignErr platform stmt e_ty r_ty
++                                      nest 2 (ppr expr) $$
 +                                      (text "op is expecting: " <+> ppr opExpectsRep) $$
 +                                      (text "arguments provide: " <+> ppr argsRep))
 +
-               nest 2 (vcat [pprPlatform platform stmt, 
++cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
++cmmLintAssignErr stmt e_ty r_ty
 +  = cmmLintErr (text "in assignment: " $$ 
- cmmLintDubiousWordOffset :: Platform -> CmmExpr -> CmmLint a
- cmmLintDubiousWordOffset platform expr
++              nest 2 (vcat [ppr stmt, 
 +                            text "Reg ty:" <+> ppr r_ty,
 +                            text "Rhs ty:" <+> ppr e_ty]))
 +                       
 +                                      
 +
-                       nest 2 (pprPlatform platform expr))
++cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
++cmmLintDubiousWordOffset expr
 +   = cmmLintErr (text "offset is not a multiple of words: " $$
++                      nest 2 (ppr expr))
@@@ -55,29 -54,46 +54,27 @@@ import Data.Lis
  
  -----------------------------------------------------------------------------
  
- instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where
-     pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks)
+ instance Outputable instr => Outputable (ListGraph instr) where
+     ppr (ListGraph blocks) = vcat (map ppr blocks)
  
- instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where
-     pprPlatform platform b = pprBBlock platform b
- instance PlatformOutputable CmmStmt where
-     pprPlatform = pprStmt
+ instance Outputable instr => Outputable (GenBasicBlock instr) where
+     ppr = pprBBlock
  
+ instance Outputable CmmStmt where
+     ppr s = pprStmt s
  
 -instance Outputable CmmInfo where
 -    ppr i = pprInfo i
 -
 -
  -- --------------------------------------------------------------------------
- instance PlatformOutputable CmmSafety where
-   pprPlatform _ CmmUnsafe = ptext (sLit "_unsafe_call_")
-   pprPlatform _ CmmInterruptible = ptext (sLit "_interruptible_call_")
-   pprPlatform platform (CmmSafe srt) = pprPlatform platform srt
+ instance Outputable CmmSafety where
+   ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
+   ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
+   ppr (CmmSafe srt) = ppr srt
  
  -- --------------------------------------------------------------------------
 --- Info tables. The current pretty printer needs refinement
 --- but will work for now.
 ---
 --- For ideas on how to refine it, they used to be printed in the
 --- style of C--'s 'stackdata' declaration, just inside the proc body,
 --- and were labelled with the procedure name ++ "_info".
 -pprInfo :: CmmInfo -> SDoc
 -pprInfo (CmmInfo _gc_target update_frame info_table) =
 -    vcat [{-ptext (sLit "gc_target: ") <>
 -                maybe (ptext (sLit "<none>")) ppr gc_target,-}
 -          ptext (sLit "update_frame: ") <>
 -                maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
 -          ppr info_table]
 -
 --- --------------------------------------------------------------------------
  -- Basic blocks look like assembly blocks.
  --      lbl: stmt ; stmt ; ..
- pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc
- pprBBlock platform (BasicBlock ident stmts) =
-     hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts))
+ pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
+ pprBBlock (BasicBlock ident stmts) =
+     hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
  
  -- --------------------------------------------------------------------------
  -- Statements. C-- usually, exceptions to this should be obvious.
Simple merge
Simple merge
Simple merge
Simple merge
Simple merge
@@@ -64,33 -58,27 +64,32 @@@ codeGen :: DynFlag
                -- possible for object splitting to split up the
                -- pieces later.
  
 -codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do
 -    showPass dflags "CodeGen"
 -    code_stuff <-
 -        initC dflags this_mod $ do
 -            cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
 -            cmm_tycons <- mapM cgTyCon data_tycons
 -            cmm_init   <- getCmm (mkModuleInit dflags cost_centre_info this_mod hpc_info)
 -            return (cmm_init : cmm_binds ++ cmm_tycons)
 -                -- Put datatype_stuff after code_stuff, because the
 -                -- datatype closure table (for enumeration types) to
 -                -- (say) PrelBase_True_closure, which is defined in
 -                -- code_stuff
 -
 -                -- Note [codegen-split-init] the cmm_init block must
 -                -- come FIRST.  This is because when -split-objs is on
 -                -- we need to combine this block with its
 -                -- initialisation routines; see Note
 -                -- [pipeline-split-init].
 -
 -    dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
 -    return code_stuff
 +codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info
 +
 +   = do { liftIO $ showPass dflags "CodeGen"
 +
 +        ; cgref <- liftIO $ newIORef =<< initC
 +        ; let cg :: FCode CmmGroup -> Stream IO CmmGroup ()
 +              cg fcode = do
 +                cmm <- liftIO $ do
 +                         st <- readIORef cgref
 +                         let (a,st') = runC dflags this_mod st fcode
 +
-                          dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" $
-                              pprPlatform (targetPlatform dflags) a
++                         dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" $ ppr a
 +
 +                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
 +                         -- a big space leak.  DO NOT REMOVE!
 +                         writeIORef cgref $! st'{ cgs_tops = nilOL,
 +                                                  cgs_stmts = nilOL }
 +                         return a
 +                Stream.yield cmm
 +
 +        ; cg (getCmm $ mkModuleInit dflags cost_centre_info this_mod hpc_info)
 +
 +        ; mapM_ (cg . getCmm . cgTopBinding dflags) stg_binds
 +
 +        ; mapM_ (cg . cgTyCon) data_tycons
 +        }
  
  mkModuleInit
          :: DynFlags
@@@ -46,13 -46,7 +46,14 @@@ import TyCo
  import Module
  import ErrUtils
  import Outputable
 +import Stream
 +
 +import OrdList
 +import MkGraph
 +
 +import Data.IORef
 +import Control.Monad (when)
+ import Util
  
  codeGen :: DynFlags
         -> Module
@@@ -76,12 -76,13 +76,13 @@@ cgTopRhsClosure :: I
  cgTopRhsClosure id ccs _ upd_flag srt args body = do
    {   -- LAY OUT THE OBJECT
      let name = idName id
 -  ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
 -  ; srt_info <- getSRTInfo srt
 +  ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
 +  ; has_srt <- getSRTInfo srt
    ; mod_name <- getModuleName
-   ; let descr         = closureDescription mod_name name
+   ; dflags   <- getDynFlags
+   ; let descr         = closureDescription dflags mod_name name
 -      closure_info  = mkClosureInfo True id lf_info 0 0 srt_info descr
 -      closure_label = mkLocalClosureLabel name (idCafInfo id)
 +        closure_info  = mkClosureInfo True id lf_info 0 0 descr
-       closure_label = mkLocalClosureLabel name (idCafInfo id)
++        closure_label = mkLocalClosureLabel name (idCafInfo id)
        cg_id_info    = litIdInfo id lf_info (CmmLabel closure_label)
          caffy         = idCafInfo id
          info_tbl      = mkCmmInfo closure_info -- XXX short-cut
@@@ -285,9 -288,11 +286,10 @@@ mkRhsClosure bndr cc _ fvs upd_flag arg
        -- MAKE CLOSURE INFO FOR THIS CLOSURE
        ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
        ; mod_name <- getModuleName
 -      ; c_srt <- getSRTInfo srt
 -      ; dflags <- getDynFlags
 -      ; let   name  = idName bndr
 -              descr = closureDescription dflags mod_name name
 -              fv_details :: [(NonVoid Id, VirtualHpOffset)]
++        ; dflags <- getDynFlags
 +        ; let   name  = idName bndr
-               descr = closureDescription mod_name name
-               fv_details :: [(NonVoid Id, VirtualHpOffset)]
++                descr = closureDescription dflags mod_name name
++                fv_details :: [(NonVoid Id, VirtualHpOffset)]
                (tot_wds, ptr_wds, fv_details)
                   = mkVirtHeapOffsets (isLFThunk lf_info)
                                       (addIdReps (map stripNV reduced_fvs))
@@@ -336,10 -342,11 +339,10 @@@ cgStdThunk bndr _cc _bndr_info _body lf
    ; let (tot_wds, ptr_wds, payload_w_offsets)
            = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
  
-       descr = closureDescription mod_name (idName bndr)
+       descr = closureDescription dflags mod_name (idName bndr)
        closure_info = mkClosureInfo False      -- Not static
                                     bndr lf_info tot_wds ptr_wds
 -                                   NoC_SRT    -- No SRT for a std-form closure
 -                                   descr
 +                                     descr
  
  --  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
    ; let use_cc = curCCS; blame_cc = curCCS
Simple merge
Simple merge
Simple merge
Simple merge
@@@ -46,19 -45,20 +46,21 @@@ import Control.Mona
  -- Code generation for Foreign Calls
  -----------------------------------------------------------------------------
  
 -cgForeignCall :: [LocalReg]             -- r1,r2  where to put the results
 -              -> [ForeignHint]
 -              -> ForeignCall            -- the op
 +-- | emit code for a foreign call, and return the results to the sequel.
 +--
 +cgForeignCall :: ForeignCall            -- the op
                -> [StgArg]               -- x,y    arguments
 +              -> Type                   -- result type
                -> FCode ()
 --- Emits code for an unsafe foreign call:      r1, r2 = foo( x, y, z )
  
 -cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
 +cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
    = do  { cmm_args <- getFCallArgs stg_args
 +        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
          ; let ((call_args, arg_hints), cmm_target)
                  = case target of
-                    StaticTarget lbl mPkgId
+                    StaticTarget _   _      False ->
+                        panic "cgForeignCall: unexpected FFI value import"
+                    StaticTarget lbl mPkgId True
                       -> let labelSource
                                  = case mPkgId of
                                          Nothing         -> ForeignLabelInThisPackage
@@@ -342,12 -335,11 +338,12 @@@ entryHeapCheck cl_info offset nodeSet a
  
             args' = map (CmmReg . CmmLocal) args
             setN = case nodeSet of
 -                          Just n  -> mkAssign nodeReg (CmmReg $ CmmLocal n)
 +                          Just n  -> mkNop -- No need to assign R1, it already
 +                                           -- points to the closure
                            Nothing -> mkAssign nodeReg $
-                               CmmLit (CmmLabel $ staticClosureLabel platform cl_info)
+                               CmmLit (CmmLabel $ staticClosureLabel cl_info)
  
 -           {- Thunks:          Set R1 = node, jump GCEnter1
 +           {- Thunks:          jump GCEnter1
                Function (fast): Set R1 = node, jump GCFun
                Function (slow): Set R1 = node, call generic_gc -}
             gc_call upd = setN <*> gc_lbl upd
@@@ -52,10 -50,8 +52,9 @@@ import StgSy
  import Id
  import Name
  import TyCon          ( PrimRep(..) )
- import BasicTypes     ( Arity )
- import DynFlags
+ import BasicTypes     ( RepArity )
  import StaticFlags
 +import Module
  
  import Constants
  import Util
@@@ -153,20 -127,7 +152,20 @@@ adjustHpBackward
  --    Making calls: directCall and slowCall
  -------------------------------------------------------------------------
  
- directCall :: CLabel -> Arity -> [StgArg] -> FCode ()
 +-- General plan is:
 +--   - we'll make *one* fast call, either to the function itself
 +--     (directCall) or to stg_ap_<pat>_fast (slowCall)
 +--     Any left-over arguments will be pushed on the stack,
 +--
 +--     e.g. Sp[old+8]  = arg1
 +--          Sp[old+16] = arg2
 +--          Sp[old+32] = stg_ap_pp_info
 +--          R2 = arg3
 +--          R3 = arg4
 +--          call f() return to Nothing updfr_off: 32
 +
 +
+ directCall :: CLabel -> RepArity -> [StgArg] -> FCode ()
  -- (directCall f n args)
  -- calls f(arg1, ..., argn), and applies the result to the remaining args
  -- The function f has arity n, and there are guaranteed at least n args
@@@ -179,117 -139,50 +178,114 @@@ directCall lbl arity stg_arg
  slowCall :: CmmExpr -> [StgArg] -> FCode ()
  -- (slowCall fun args) applies fun to args, returning the results to Sequel
  slowCall fun stg_args 
 -  = do        { cmm_args <- getNonVoidArgAmodes stg_args
 -      ; slow_call fun cmm_args (argsReps stg_args) }
 +  = do  { dflags <- getDynFlags
 +        ; argsreps <- getArgRepsAmodes stg_args
 +        ; let (rts_fun, arity) = slowCallPattern (map fst argsreps)
-         ; let platform = targetPlatform dflags
 +        ; call <- getCode $ direct_call "slow_call"
 +                       (mkRtsApFastLabel rts_fun) arity argsreps
 +        ; emitComment $ mkFastString ("slow_call for " ++
-                                       showSDoc (pprPlatform platform fun) ++
-                                       " with pat " ++ showSDoc (ftext rts_fun))
++                                      showSDoc dflags (ppr fun) ++
++                                      " with pat " ++ unpackFS rts_fun)
 +        ; emit (mkAssign nodeReg fun <*> call)
 +        }
 +
  
  --------------
- direct_call :: String -> CLabel -> Arity -> [(ArgRep,Maybe CmmExpr)] -> FCode ()
 -direct_call :: String -> CLabel -> RepArity -> [CmmExpr] -> [ArgRep] -> FCode ()
 --- NB1: (length args) may be less than (length reps), because
 ---     the args exclude the void ones
 --- NB2: 'arity' refers to the *reps* 
 -direct_call caller lbl arity args reps
 -  | debugIsOn && arity > length reps  -- Too few args
++direct_call :: String -> CLabel -> RepArity -> [(ArgRep,Maybe CmmExpr)] -> FCode ()
 +direct_call caller lbl arity args
 +  | debugIsOn && arity > length args  -- Too few args
    = do -- Caller should ensure that there enough args!
-        dflags <- getDynFlags
-        let platform = targetPlatform dflags
 -       pprPanic "direct_call" (text caller <+> ppr arity
 -                           <+> ppr lbl <+> ppr (length reps)
 -                           <+> ppr args <+> ppr reps )
 -
 -  | null rest_reps     -- Precisely the right number of arguments
 -  = emitCall (NativeDirectCall, NativeReturn) target args
 -
 -  | otherwise         -- Over-saturated call
 -  = ASSERT( arity == length initial_reps )
 -    do        { pap_id <- newTemp gcWord
 -      ; withSequel (AssignTo [pap_id] True)
 -                   (emitCall (NativeDirectCall, NativeReturn) target fast_args)
 -      ; slow_call (CmmReg (CmmLocal pap_id)) 
 -                  rest_args rest_reps }
 +       pprPanic "direct_call" $
 +            text caller <+> ppr arity <+>
-             pprPlatform platform lbl <+> ppr (length args) <+>
-             pprPlatform platform (map snd args) <+> ppr (map fst args)
++            ppr lbl <+> ppr (length args) <+>
++            ppr (map snd args) <+> ppr (map fst args)
 +
 +  | null rest_args  -- Precisely the right number of arguments
 +  = emitCall (NativeDirectCall, NativeReturn) target (nonVArgs args)
 +
 +  | otherwise       -- Note [over-saturated calls]
 +  = emitCallWithExtraStack (NativeDirectCall, NativeReturn)
 +                           target (nonVArgs fast_args) (mkStkOffsets stack_args)
    where
      target = CmmLit (CmmLabel lbl)
 -    (initial_reps, rest_reps) = splitAt arity reps
 -    arg_arity = count isNonV initial_reps
 -    (fast_args, rest_args) = splitAt arg_arity args
 +    (fast_args, rest_args) = splitAt arity args
 +    stack_args = slowArgs rest_args
  
 ---------------
 -slow_call :: CmmExpr -> [CmmExpr] -> [ArgRep] -> FCode ()
 -slow_call fun args reps
 -  = do dflags <- getDynFlags
 -       call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
 -       emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc dflags (ppr fun) ++
 -                                        " with pat " ++ unpackFS rts_fun)
 -       emit (mkAssign nodeReg fun <*> call)
 +
 +-- When constructing calls, it is easier to keep the ArgReps and the
 +-- CmmExprs zipped together.  However, a void argument has no
 +-- representation, so we need to use Maybe CmmExpr (the alternative of
 +-- using zeroCLit or even undefined would work, but would be ugly).
 +--
 +getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
 +getArgRepsAmodes = mapM getArgRepAmode
 +  where getArgRepAmode arg
 +           | V <- rep  = return (V, Nothing)
 +           | otherwise = do expr <- getArgAmode (NonVoid arg)
 +                            return (rep, Just expr)
 +           where rep = toArgRep (argPrimRep arg)
 +
 +nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
 +nonVArgs [] = []
 +nonVArgs ((_,Nothing)  : args) = nonVArgs args
 +nonVArgs ((_,Just arg) : args) = arg : nonVArgs args
 +
 +{-
 +Note [over-saturated calls]
 +
 +The natural thing to do for an over-saturated call would be to call
 +the function with the correct number of arguments, and then apply the
 +remaining arguments to the value returned, e.g.
 +
 +  f a b c d   (where f has arity 2)
 +  -->
 +  r = call f(a,b)
 +  call r(c,d)
 +
 +but this entails
 +  - saving c and d on the stack
 +  - making a continuation info table
 +  - at the continuation, loading c and d off the stack into regs
 +  - finally, call r
 +
 +Note that since there are a fixed number of different r's
 +(e.g.  stg_ap_pp_fast), we can also pre-compile continuations
 +that correspond to each of them, rather than generating a fresh
 +one for each over-saturated call.
 +
 +Not only does this generate much less code, it is faster too.  We will
 +generate something like:
 +
 +Sp[old+16] = c
 +Sp[old+24] = d
 +Sp[old+32] = stg_ap_pp_info
 +call f(a,b) -- usual calling convention
 +
 +For the purposes of the CmmCall node, we count this extra stack as
 +just more arguments that we are passing on the stack (cml_args).
 +-}
 +
 +-- | 'slowArgs' takes a list of function arguments and prepares them for
 +-- pushing on the stack for "extra" arguments to a function which requires
 +-- fewer arguments than we currently have.
 +slowArgs :: [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
 +slowArgs [] = []
 +slowArgs args -- careful: reps contains voids (V), but args does not
 +  | opt_SccProfilingOn = save_cccs ++ this_pat ++ slowArgs rest_args
 +  | otherwise          =              this_pat ++ slowArgs rest_args
    where
 -    (rts_fun, arity) = slowCallPattern reps
 +    (arg_pat, n)            = slowCallPattern (map fst args)
 +    (call_args, rest_args)  = splitAt n args
 +
 +    stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
 +    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args
 +    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)]
 +    save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs")
 +
 +
  
  -- These cases were found to cover about 99% of all slow calls:
- slowCallPattern :: [ArgRep] -> (FastString, Arity)
+ slowCallPattern :: [ArgRep] -> (FastString, RepArity)
  -- Returns the generic apply function and arity
  slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
  slowCallPattern (P: P: P: P: P: _)    = (fsLit "stg_ap_ppppp", 5)
Simple merge
Simple merge
Simple merge
Simple merge
@@@ -560,29 -563,24 +562,26 @@@ mkCmmSwitch :: Bool                     -- True <=> neve
            -> Maybe CmmAGraph          -- Default branch (if any)
            -> ConTagZ -> ConTagZ       -- Min and Max possible values; behaviour
                                        --      outside this range is undefined
 -          -> CmmAGraph
 +            -> FCode ()
  
  -- First, two rather common cases in which there is no work to do
 -mkCmmSwitch _ _ []         (Just code) _ _ = code
 -mkCmmSwitch _ _ [(_,code)] Nothing     _ _ = code
 +mkCmmSwitch _ _ []         (Just code) _ _ = emit code
 +mkCmmSwitch _ _ [(_,code)] Nothing     _ _ = emit code
  
  -- Right, off we go
 -mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag
 -  = withFreshLabel "switch join"      $ \ join_lbl ->
 -    label_default join_lbl mb_deflt   $ \ mb_deflt ->
 -    label_branches join_lbl branches  $ \ branches ->
 -    assignTemp' tag_expr              $ \tag_expr' -> 
 +mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do
 +    join_lbl      <- newLabelC
 +    mb_deflt_lbl  <- label_default join_lbl mb_deflt
 +    branches_lbls <- label_branches join_lbl branches
 +    tag_expr'     <- assignTemp' tag_expr
      
-     emit =<< mk_switch tag_expr' (sortLe le branches_lbls) mb_deflt_lbl
 -    mk_switch tag_expr' (sortBy (comparing fst) branches) mb_deflt 
 -            lo_tag hi_tag via_C
 -        -- Sort the branches before calling mk_switch
 -    <*> mkLabel join_lbl
++    emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches) mb_deflt_lbl
 +                lo_tag hi_tag via_C
 +
 +          -- Sort the branches before calling mk_switch
 +
 +    emitLabel join_lbl
  
-   where
-     (t1,_) `le` (t2,_) = t1 <= t2
  mk_switch :: CmmExpr -> [(ConTagZ, BlockId)]
          -> Maybe BlockId 
          -> ConTagZ -> ConTagZ -> Bool
@@@ -730,16 -724,14 +729,15 @@@ emitCmmLitSwitch :: CmmExp
  --
  -- ToDo: for integers we could do better here, perhaps by generalising
  -- mk_switch and using that.  --SDM 15/09/2004
 -mkCmmLitSwitch _scrut []       deflt = deflt
 -mkCmmLitSwitch scrut  branches deflt
 -  = assignTemp' scrut         $ \ scrut' ->
 -    withFreshLabel "switch join"      $ \ join_lbl ->
 -    label_code join_lbl deflt         $ \ deflt ->
 -    label_branches join_lbl branches  $ \ branches ->
 -    mk_lit_switch scrut' deflt (sortBy (comparing fst) branches)
 -    <*> mkLabel join_lbl
 +emitCmmLitSwitch _scrut []       deflt = emit deflt
 +emitCmmLitSwitch scrut  branches deflt = do
 +    scrut' <- assignTemp' scrut
 +    join_lbl <- newLabelC
 +    deflt_lbl <- label_code join_lbl deflt
 +    branches_lbls <- label_branches join_lbl branches
-     emit =<< mk_lit_switch scrut' deflt_lbl (sortLe le branches_lbls)
++    emit =<< mk_lit_switch scrut' deflt_lbl
++               (sortBy (comparing fst) branches_lbls)
 +    emitLabel join_lbl
-   where
-     le (t1,_) (t2,_) = t1 <= t2
  
  mk_lit_switch :: CmmExpr -> BlockId 
              -> [(Literal,BlockId)]
Simple merge
diff --cc compiler/ghc.mk
Simple merge
@@@ -14,19 -14,16 +14,18 @@@ import LlvmCodeGen ( llvmCodeGen 
  import UniqSupply       ( mkSplitUniqSupply )
  
  import Finder           ( mkStubPaths )
 -import PprC             ( writeCs )
 -import CmmLint          ( cmmLint )
 +import PprC           ( writeCs )
 +import OldCmmLint       ( cmmLint )
  import Packages
- import Util
  import OldCmm           ( RawCmmGroup )
  import HscTypes
  import DynFlags
  import Config
  import SysTools
 +import Stream           (Stream)
 +import qualified Stream
  
- import ErrUtils         ( dumpIfSet_dyn, showPass, ghcExit )
+ import ErrUtils
  import Outputable
  import Module
  import Maybes           ( firstJusts )
@@@ -47,39 -45,32 +47,39 @@@ import System.I
  \begin{code}
  codeOutput :: DynFlags
             -> Module
 -           -> ModLocation
 -           -> ForeignStubs
 -           -> [PackageId]
 -           -> [RawCmmGroup]                       -- Compiled C--
 +         -> ModLocation
 +         -> ForeignStubs
 +         -> [PackageId]
 +           -> Stream IO RawCmmGroup ()                       -- Compiled C--
             -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})
  
 -codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
 +codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream
    = 
 -    do  { when (dopt Opt_DoCmmLinting dflags) $ do
 +    do  {
 +        -- Lint each CmmGroup as it goes past
 +        ; let linted_cmm_stream =
 +                 if dopt Opt_DoCmmLinting dflags
 +                    then Stream.mapM do_lint cmm_stream
 +                    else cmm_stream
 +
 +              do_lint cmm = do
                  { showPass dflags "CmmLint"
 -                ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
 -                ; case firstJusts lints of
 +                ; case cmmLint (targetPlatform dflags) cmm of
-                       Just err -> do { printDump err
+                         Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err
 -                                       ; ghcExit dflags 1
 -                                       }
 -                        Nothing  -> return ()
 +                                     ; ghcExit dflags 1
 +                                     }
 +                      Nothing  -> return ()
 +                ; return cmm
                  }
  
 -        ; showPass dflags "CodeOutput"
 -        ; let filenm = hscOutName dflags 
 -        ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
 -        ; case hscTarget dflags of {
 +      ; showPass dflags "CodeOutput"
 +      ; let filenm = hscOutName dflags 
 +      ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
 +      ; case hscTarget dflags of {
               HscInterpreted -> return ();
 -             HscAsm         -> outputAsm dflags filenm flat_abstractC;
 -             HscC           -> outputC dflags filenm flat_abstractC pkg_deps;
 -             HscLlvm        -> outputLlvm dflags filenm flat_abstractC;
 +             HscAsm         -> outputAsm dflags filenm linted_cmm_stream;
 +             HscC           -> outputC dflags filenm linted_cmm_stream pkg_deps;
 +             HscLlvm        -> outputLlvm dflags filenm linted_cmm_stream;
               HscNothing     -> panic "codeOutput: HscNothing"
            }
          ; return stubs_exist
Simple merge
@@@ -147,10 -147,7 +148,11 @@@ import UniqFM           ( emptyUFM 
  import UniqSupply       ( initUs_ )
  import Bag
  import Exception
 +import qualified Stream
 +import Stream (Stream)
 +
 +import CLabel
+ import Util
  
  import Data.List
  import Control.Monad
@@@ -1243,20 -1276,14 +1281,20 @@@ hscGenHardCode cgguts mod_summary = d
                               cost_centre_info
                               stg_binds hpc_info
                      else {-# SCC "CodeGen" #-}
 -                         codeGen dflags this_mod data_tycons
 -                             cost_centre_info
 -                             stg_binds hpc_info
 +                         return (codeGen dflags this_mod data_tycons
 +                               cost_centre_info
 +                               stg_binds hpc_info)
 +
  
          ------------------  Code output -----------------------
 -        rawcmms <- {-# SCC "cmmToRawCmm" #-}
 +        rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
                     cmmToRawCmm platform cmms
 -        dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms)
 +
 +        let dump a = do dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm"
-                            (pprPlatform platform a)
++                           (ppr a)
 +                        return a
 +            rawcmms1 = Stream.mapM dump rawcmms0
 +
          (_stub_h_exists, stub_c_exists)
              <- {-# SCC "codeOutput" #-}
                 codeOutput dflags this_mod location foreign_stubs
@@@ -1330,48 -1354,20 +1369,45 @@@ tryNewCodeGen   :: HscEnv -> Module -> 
  tryNewCodeGen hsc_env this_mod data_tycons
                cost_centre_info stg_binds hpc_info = do
      let dflags = hsc_dflags hsc_env
-         platform = targetPlatform dflags
 -    prog <- StgCmm.codeGen dflags this_mod data_tycons
 +
 +    let cmm_stream :: Stream IO New.CmmGroup ()
 +        cmm_stream = {-# SCC "StgCmm" #-}
 +            StgCmm.codeGen dflags this_mod data_tycons
                             cost_centre_info stg_binds hpc_info
 -    dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
 -                  (pprCmms prog)
 +
 +        -- codegen consumes a stream of CmmGroup, and produces a new
 +        -- stream of CmmGroup (not necessarily synchronised: one
 +        -- CmmGroup on input may produce many CmmGroups on output due
 +        -- to proc-point splitting).
 +
 +    let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz
-                        "Cmm produced by new codegen"
-                        (pprPlatform platform a)
++                       "Cmm produced by new codegen" (ppr a)
 +                     return a
 +
 +        ppr_stream1 = Stream.mapM dump1 cmm_stream
  
      -- We are building a single SRT for the entire module, so
      -- we must thread it through all the procedures as we cps-convert them.
      us <- mkSplitUniqSupply 'S'
      let initTopSRT = initUs_ us emptySRT
 -    (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog
  
 -    let prog' = map cmmOfZgraph (srtToData topSRT : prog)
 -    dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
 -    return prog'
 +    let run_pipeline topSRT cmmgroup = do
 +           (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup
 +           return (topSRT,cmmOfZgraph cmmgroup)
 +
 +    let pipeline_stream = {-# SCC "cmmPipeline" #-} do
 +          topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
 +          Stream.yield (cmmOfZgraph (srtToData topSRT))
 +
 +    let
-         dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $
-                        pprPlatform platform a
++        dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a
 +                     return a
 +
 +        ppr_stream2 = Stream.mapM dump2 pipeline_stream
 +
 +    return ppr_stream2
 +
 +
  
  myCoreToStg :: DynFlags -> Module -> CoreProgram
              -> IO ( [(StgBinding,[(Id,[Id])])] -- output program
@@@ -157,10 -147,10 +149,10 @@@ data NcgImpl statics instr jumpDest = N
      }
  
  --------------------
 -nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
 +nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
  nativeCodeGen dflags h us cmms
   = let platform = targetPlatform dflags
-        nCG' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
+        nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
         nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
         x86NcgImpl = NcgImpl {
                           cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
                   ArchUnknown ->
                       panic "nativeCodeGen: No NCG for unknown arch"
  
- nativeCodeGen' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+ nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
                 => DynFlags
                 -> NcgImpl statics instr jumpDest
 -               -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
 +               -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
  nativeCodeGen' dflags ncgImpl h us cmms
   = do
-       let platform = targetPlatform dflags
+         let platform = targetPlatform dflags
 -            split_cmms  = concat $ map add_split cmms
 +            split_cmms  = Stream.map add_split cmms
          -- BufHandle is a performance hack.  We could hide it inside
          -- Pretty if it weren't for the fact that we do lots of little
          -- printDocs here (in order to do codegen in constant space).
          bufh <- newBufHandle h
 -        (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
 +        (imports, prof) <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms [] [] 0
          bFlush bufh
  
-       let (native, colorStats, linearStats)
-               = unzip3 prof
-       -- dump native code
-       dumpIfSet_dyn dflags
-               Opt_D_dump_asm "Asm code"
-               (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) $ concat native)
-       -- dump global NCG stats for graph coloring allocator
-       (case concat $ catMaybes colorStats of
-         []    -> return ()
-         stats -> do   
-               -- build the global register conflict graph
-               let graphGlobal 
-                       = foldl Color.union Color.initGraph
-                       $ [ Color.raGraph stat
-                               | stat@Color.RegAllocStatsStart{} <- stats]
-          
-               dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
-                       $ Color.pprStats stats graphGlobal
-               dumpIfSet_dyn dflags
-                       Opt_D_dump_asm_conflicts "Register conflict graph"
-                       $ Color.dotGraph 
-                               (targetRegDotColor platform)
-                               (Color.trivColorable platform
-                                       (targetVirtualRegSqueeze platform)
-                                       (targetRealRegSqueeze platform))
-                       $ graphGlobal)
-       -- dump global NCG stats for linear allocator
-       (case concat $ catMaybes linearStats of
-               []      -> return ()
-               stats   -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
-                               $ Linear.pprStats (concat native) stats)
-       -- write out the imports
-       Pretty.printDoc Pretty.LeftMode h
-               $ makeImportsDoc dflags (concat imports)
-       return  ()
+         let (native, colorStats, linearStats)
+                 = unzip3 prof
+         -- dump native code
+         dumpIfSet_dyn dflags
+                 Opt_D_dump_asm "Asm code"
+                 (vcat $ map (pprNatCmmDecl ncgImpl platform) $ concat native)
+         -- dump global NCG stats for graph coloring allocator
+         (case concat $ catMaybes colorStats of
+           []    -> return ()
+           stats -> do
+                 -- build the global register conflict graph
+                 let graphGlobal
+                         = foldl Color.union Color.initGraph
+                         $ [ Color.raGraph stat
+                                 | stat@Color.RegAllocStatsStart{} <- stats]
+                 dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
+                         $ Color.pprStats stats graphGlobal
+                 dumpIfSet_dyn dflags
+                         Opt_D_dump_asm_conflicts "Register conflict graph"
+                         $ Color.dotGraph
+                                 (targetRegDotColor platform)
+                                 (Color.trivColorable platform
+                                         (targetVirtualRegSqueeze platform)
+                                         (targetRealRegSqueeze platform))
+                         $ graphGlobal)
+         -- dump global NCG stats for linear allocator
+         (case concat $ catMaybes linearStats of
+                 []      -> return ()
+                 stats   -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
+                                 $ Linear.pprStats (concat native) stats)
+         -- write out the imports
+         Pretty.printDoc Pretty.LeftMode (pprCols dflags) h
+                 $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
+                 $ makeImportsDoc dflags (concat imports)
+         return  ()
  
   where  add_split tops
-               | dopt Opt_SplitObjs dflags = split_marker : tops
-               | otherwise                 = tops
+                 | dopt Opt_SplitObjs dflags = split_marker : tops
+                 | otherwise                 = tops
  
-       split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
+         split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
  
  
 +cmmNativeGenStream :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
 +              => DynFlags
 +              -> NcgImpl statics instr jumpDest
 +              -> BufHandle
 +              -> UniqSupply
 +              -> Stream IO RawCmmGroup ()
 +              -> [[CLabel]]
 +              -> [ ([NatCmmDecl statics instr],
 +                   Maybe [Color.RegAllocStats statics instr],
 +                   Maybe [Linear.RegAllocStats]) ]
 +              -> Int
 +              -> IO ( [[CLabel]],
 +                      [([NatCmmDecl statics instr],
 +                      Maybe [Color.RegAllocStats statics instr],
 +                      Maybe [Linear.RegAllocStats])] )
 +
 +cmmNativeGenStream dflags ncgImpl h us cmm_stream impAcc profAcc count
 + = do
 +        r <- Stream.runStream cmm_stream
 +        case r of
 +          Left () -> return (reverse impAcc, reverse profAcc)
 +          Right (cmms, cmm_stream') -> do
 +            (impAcc,profAcc,us') <- cmmNativeGens dflags ncgImpl h us cmms
 +                                              impAcc profAcc count
 +            cmmNativeGenStream dflags ncgImpl h us' cmm_stream'
 +                                              impAcc profAcc count
 +
 +
  -- | Do native code generation on all these cmms.
  --
- cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+ cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
                => DynFlags
                -> NcgImpl statics instr jumpDest
                -> BufHandle
@@@ -856,13 -817,7 +848,11 @@@ Ideas for other things we could do (pu
  cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
  cmmToCmm _ top@(CmmData _ _) = (top, [])
  cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
-   let platform = targetPlatform dflags
 -  blocks' <- mapM cmmBlockConFold (cmmMiniInline dflags (cmmEliminateDeadBlocks blocks))
 +  let reachable_blocks | dopt Opt_TryNewCodeGen dflags = blocks
 +                       | otherwise = cmmEliminateDeadBlocks blocks
 +      -- The new codegen path has already eliminated unreachable blocks by now
 +
-   blocks' <- mapM cmmBlockConFold (cmmMiniInline platform reachable_blocks)
++  blocks' <- mapM cmmBlockConFold (cmmMiniInline dflags reachable_blocks)
    return $ CmmProc info lbl (ListGraph blocks')
  
  newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
@@@ -49,12 -51,11 +51,14 @@@ stg2stg dflags module_name bind
        ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
  
                -- Do the main business!
+         ; let (us0, us1) = splitUniqSupply us'
        ; (processed_binds, _, cost_centres) 
-               <- foldl_mn do_stg_pass (binds', us', ccs) (getStgToDo dflags)
+               <- foldl_mn do_stg_pass (binds', us0, ccs) (getStgToDo dflags)
  
 -      ; let srt_binds = computeSRTs (unarise us1 processed_binds)
++        ; let un_binds = unarise us1 processed_binds
 +        ; let srt_binds
-                | dopt Opt_TryNewCodeGen dflags = zip processed_binds (repeat [])
-                | otherwise = computeSRTs processed_binds
++               | dopt Opt_TryNewCodeGen dflags = zip un_binds (repeat [])
++               | otherwise = computeSRTs un_binds
  
        ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" 
                        (pprStgBindingsWithSRTs srt_binds)
@@@ -720,12 -697,8 +697,10 @@@ instance Outputable FastString wher
  
  instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
      ppr m = ppr (M.toList m)
- instance (PlatformOutputable key, PlatformOutputable elt) => PlatformOutputable (M.Map key elt) where
-     pprPlatform platform m = pprPlatform platform (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}
  
  %************************************************************************