Commit 3f0afaba authored by Simon Marlow's avatar Simon Marlow

Fix merge-related problems

parent 99fd2469
......@@ -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
-----------------------------------------------------------------------
......
......@@ -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
......@@ -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
......
......@@ -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
......
......@@ -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 ()
......
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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}
%************************************************************************
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment