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

Fix merge-related problems

parent 99fd2469
...@@ -23,28 +23,20 @@ where ...@@ -23,28 +23,20 @@ where
#include "HsVersions.h" #include "HsVersions.h"
-- These should not be imported here! -- These should not be imported here!
import StgCmmForeign
import StgCmmUtils import StgCmmUtils
import Constants
import Digraph import Digraph
import qualified Prelude as P import qualified Prelude as P
import Prelude hiding (succ) import Prelude hiding (succ)
import Util
import BlockId import BlockId
import Bitmap import Bitmap
import CLabel import CLabel
import Cmm import Cmm
import CmmUtils import CmmUtils
import Module
import FastString
import ForeignCall
import IdInfo import IdInfo
import Data.List import Data.List
import Maybes import Maybes
import MkGraph as M
import Control.Monad
import Name import Name
import OptimizationFuel import OptimizationFuel
import Outputable import Outputable
...@@ -57,8 +49,8 @@ import Data.Map (Map) ...@@ -57,8 +49,8 @@ import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified FiniteMap as Map
foldSet :: (a -> b -> b) -> b -> Set a -> b
#if __GLASGOW_HASKELL__ < 704 #if __GLASGOW_HASKELL__ < 704
foldSet = Set.fold foldSet = Set.fold
#else #else
...@@ -106,7 +98,7 @@ cafTransfers = mkBTransfer3 first middle last ...@@ -106,7 +98,7 @@ cafTransfers = mkBTransfer3 first middle last
add l s = if hasCAF l then Set.insert (toClosureLbl l) s add l s = if hasCAF l then Set.insert (toClosureLbl l) s
else s else s
cafAnal :: Platform -> CmmGraph -> CAFEnv cafAnal :: CmmGraph -> CAFEnv
cafAnal g = dataflowAnalBwd g [] $ analBwd cafLattice cafTransfers cafAnal g = dataflowAnalBwd g [] $ analBwd cafLattice cafTransfers
----------------------------------------------------------------------- -----------------------------------------------------------------------
......
...@@ -1033,13 +1033,16 @@ walk (n:ns) acc as ...@@ -1033,13 +1033,16 @@ walk (n:ns) acc as
(dropped, as') = partition should_drop as (dropped, as') = partition should_drop as
where should_drop a = a `conflicts` n where should_drop a = a `conflicts` n
toNodes :: [(LocalReg,CmmExpr)] -> [CmmNode O O]
toNodes as = [ CmmAssign (CmmLocal r) rhs | (r,rhs) <- as ] toNodes as = [ CmmAssign (CmmLocal r) rhs | (r,rhs) <- as ]
-- We only sink "r = G" assignments right now, so conflicts is very simple: -- 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, CmmLoad _ _) `conflicts` CmmStore _ _ = True
(r, _) `conflicts` node (r, _) `conflicts` node
= foldRegsUsed (\b r' -> r == r' || b) False node = foldRegsUsed (\b r' -> r == r' || b) False node
conflictsWithLast :: (LocalReg,CmmExpr) -> CmmNode O C -> Bool
(r, _) `conflictsWithLast` node (r, _) `conflictsWithLast` node
= foldRegsUsed (\b r' -> r == r' || b) False node = foldRegsUsed (\b r' -> r == r' || b) False node
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
module CmmLint ( module CmmLint (
cmmLint, cmmLintDecl, cmmLintGraph cmmLint, cmmLintGraph
) where ) where
import Hoopl import Hoopl
...@@ -31,7 +31,7 @@ import Data.Maybe ...@@ -31,7 +31,7 @@ import Data.Maybe
-- Exported entry points: -- Exported entry points:
cmmLint :: (Outputable d, Outputable h) cmmLint :: (Outputable d, Outputable h)
=> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc => GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint tops = runCmmLint (mapM_ lintCmmDecl) tops cmmLint tops = runCmmLint (mapM_ lintCmmDecl) tops
cmmLintGraph :: CmmGraph -> Maybe SDoc cmmLintGraph :: CmmGraph -> Maybe SDoc
...@@ -62,7 +62,7 @@ lintCmmGraph g = mapM_ (lintCmmBlock labels) blocks ...@@ -62,7 +62,7 @@ lintCmmGraph g = mapM_ (lintCmmBlock labels) blocks
lintCmmBlock :: BlockSet -> CmmBlock -> CmmLint () lintCmmBlock :: BlockSet -> CmmBlock -> CmmLint ()
lintCmmBlock labels block 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 let (_, middle, last) = blockSplit block
mapM_ lintCmmMiddle (blockToList middle) mapM_ lintCmmMiddle (blockToList middle)
lintCmmLast labels last lintCmmLast labels last
...@@ -172,7 +172,7 @@ lintCmmLast labels node = case node of ...@@ -172,7 +172,7 @@ lintCmmLast labels node = case node of
where where
checkTarget id checkTarget id
| setMember id labels = return () | 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 () lintTarget :: ForeignTarget -> CmmLint ()
...@@ -195,18 +195,18 @@ checkCond expr ...@@ -195,18 +195,18 @@ checkCond expr
newtype CmmLint a = CmmLint { unCL :: Either SDoc a } newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
instance Monad CmmLint where instance Monad CmmLint where
CmmLint m >>= k = CmmLint $ \p -> case m p of CmmLint m >>= k = CmmLint $ case m of
Left e -> Left e Left e -> Left e
Right a -> unCL (k a) p Right a -> unCL (k a)
return a = CmmLint (\_ -> Right a) return a = CmmLint (Right a)
cmmLintErr :: SDoc -> CmmLint a cmmLintErr :: SDoc -> CmmLint a
cmmLintErr msg = CmmLint (\p -> Left (msg p)) cmmLintErr msg = CmmLint (Left msg)
addLintInfo :: SDoc -> CmmLint a -> CmmLint a addLintInfo :: SDoc -> CmmLint a -> CmmLint a
addLintInfo info thing = CmmLint $ \p -> addLintInfo info thing = CmmLint $
case unCL thing p of case unCL thing of
Left err -> Left (hang (info p) 2 err) Left err -> Left (hang info 2 err)
Right a -> Right a Right a -> Right a
cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
......
...@@ -146,7 +146,6 @@ To inline _smi: ...@@ -146,7 +146,6 @@ To inline _smi:
countUses :: UserOfLocalRegs a => a -> UniqFM Int countUses :: UserOfLocalRegs a => a -> UniqFM Int
countUses a = foldRegsUsed (\m r -> addToUFM_C (+) 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 :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock] cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock]
cmmMiniInline dflags blocks = map do_inline blocks cmmMiniInline dflags blocks = map do_inline blocks
...@@ -158,14 +157,14 @@ cmmMiniInlineStmts _ _ [] = [] ...@@ -158,14 +157,14 @@ cmmMiniInlineStmts _ _ [] = []
cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts) cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
-- not used: just discard this assignment -- not used: just discard this assignment
| 0 <- lookupWithDefaultUFM uses 0 u | 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 -- used (foldable to small thing): try to inline at all the use sites
| Just n <- lookupUFM uses u, | Just n <- lookupUFM uses u,
e <- wrapRecExp foldExp expr, e <- wrapRecExp foldExp expr,
isTiny e isTiny e
= =
ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $ ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $
case lookForInlineMany u e stmts of case lookForInlineMany u e stmts of
(m, stmts') (m, stmts')
| n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts' | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts'
...@@ -256,6 +255,7 @@ okToInline _ _ = True ...@@ -256,6 +255,7 @@ okToInline _ _ = True
-- changed is not one we were relying on. I don't know how much of a -- 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 -- performance hit this is (we have to create a regset for every
-- instruction.) -- EZY -- instruction.) -- EZY
okToSkip :: CmmStmt -> Unique -> CmmExpr -> RegSet -> Bool
okToSkip stmt u expr regset okToSkip stmt u expr regset
= case stmt of = case stmt of
CmmNop -> True CmmNop -> True
......
...@@ -12,28 +12,22 @@ module CmmPipeline ( ...@@ -12,28 +12,22 @@ module CmmPipeline (
import CLabel import CLabel
import Cmm import Cmm
import CmmLint import CmmLint
import CmmLive
import CmmBuildInfoTables import CmmBuildInfoTables
import CmmCommonBlockElim import CmmCommonBlockElim
import CmmProcPoint import CmmProcPoint
import CmmRewriteAssignments
import CmmContFlowOpt import CmmContFlowOpt
import OptimizationFuel import OptimizationFuel
import CmmLayoutStack import CmmLayoutStack
import Hoopl
import CmmUtils
import DynFlags import DynFlags
import ErrUtils import ErrUtils
import HscTypes import HscTypes
import Data.Maybe import Data.Maybe
import Control.Monad 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 Outputable
import StaticFlags
import qualified Data.Set as Set
import Data.Map (Map)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline -- | Top level driver for C-- pipeline
...@@ -133,8 +127,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ...@@ -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 dumps Opt_D_dump_cmmz_split "Post splitting" gs
------------- More CAFs ------------------------------ ------------- More CAFs ------------------------------
let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform g let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo platform cafEnv) gs let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo cafEnv) gs
mbpprTrace "localCAFs" (ppr localCAFs) $ return () mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES -- 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}}) ...@@ -155,7 +149,6 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
-- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?) -- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
where dflags = hsc_dflags hsc_env where dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
| otherwise = z | otherwise = z
dump = dumpGraph dflags dump = dumpGraph dflags
...@@ -165,9 +158,6 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ...@@ -165,9 +158,6 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
-- Runs a required transformation/analysis -- Runs a required transformation/analysis
run = runInfiniteFuelIO (hsc_OptFuel hsc_env) 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 () dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
...@@ -175,8 +165,8 @@ dumpGraph dflags flag name g = do ...@@ -175,8 +165,8 @@ dumpGraph dflags flag name g = do
when (dopt Opt_DoCmmLinting dflags) $ do_lint g when (dopt Opt_DoCmmLinting dflags) $ do_lint g
dumpWith dflags flag name g dumpWith dflags flag name g
where where
do_lint g = case cmmLintGraph (targetPlatform dflags) g of do_lint g = case cmmLintGraph g of
Just err -> do { printDump err Just err -> do { fatalErrorMsg dflags err
; ghcExit dflags 1 ; ghcExit dflags 1
} }
Nothing -> return () Nothing -> return ()
......
...@@ -30,7 +30,7 @@ import CgHpc ...@@ -30,7 +30,7 @@ import CgHpc
import CLabel import CLabel
import OldCmm import OldCmm
import OldPprCmm import OldPprCmm ()
import StgSyn import StgSyn
import PrelNames import PrelNames
...@@ -46,6 +46,7 @@ import Module ...@@ -46,6 +46,7 @@ import Module
import ErrUtils import ErrUtils
import Panic import Panic
import Outputable import Outputable
import Util
import OrdList import OrdList
import Stream (Stream, liftIO) import Stream (Stream, liftIO)
......
...@@ -338,7 +338,7 @@ entryHeapCheck cl_info offset nodeSet arity args code ...@@ -338,7 +338,7 @@ entryHeapCheck cl_info offset nodeSet arity args code
args' = map (CmmReg . CmmLocal) args args' = map (CmmReg . CmmLocal) args
setN = case nodeSet of 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 -- points to the closure
Nothing -> mkAssign nodeReg $ Nothing -> mkAssign nodeReg $
CmmLit (CmmLabel $ staticClosureLabel cl_info) CmmLit (CmmLabel $ staticClosureLabel cl_info)
......
...@@ -575,8 +575,8 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do ...@@ -575,8 +575,8 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do
branches_lbls <- label_branches join_lbl branches branches_lbls <- label_branches join_lbl branches
tag_expr' <- assignTemp' tag_expr tag_expr' <- assignTemp' tag_expr
emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches) mb_deflt_lbl emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches_lbls)
lo_tag hi_tag via_C mb_deflt_lbl lo_tag hi_tag via_C
-- Sort the branches before calling mk_switch -- Sort the branches before calling mk_switch
......
...@@ -28,11 +28,9 @@ import qualified Stream ...@@ -28,11 +28,9 @@ import qualified Stream
import ErrUtils import ErrUtils
import Outputable import Outputable
import Module import Module
import Maybes ( firstJusts )
import SrcLoc import SrcLoc
import Control.Exception import Control.Exception
import Control.Monad
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import System.IO import System.IO
......
...@@ -121,7 +121,6 @@ import SimplStg ( stg2stg ) ...@@ -121,7 +121,6 @@ import SimplStg ( stg2stg )
import CodeGen ( codeGen ) import CodeGen ( codeGen )
import qualified OldCmm as Old import qualified OldCmm as Old
import qualified Cmm as New import qualified Cmm as New
import PprCmm ( pprCmms )
import CmmParse ( parseCmmFile ) import CmmParse ( parseCmmFile )
import CmmBuildInfoTables import CmmBuildInfoTables
import CmmPipeline import CmmPipeline
...@@ -151,7 +150,6 @@ import Exception ...@@ -151,7 +150,6 @@ import Exception
import qualified Stream import qualified Stream
import Stream (Stream) import Stream (Stream)
import CLabel
import Util import Util
import Data.List import Data.List
......
...@@ -274,7 +274,7 @@ nativeCodeGen' dflags ncgImpl h us cmms ...@@ -274,7 +274,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph []) split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
cmmNativeGenStream :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags => DynFlags
-> NcgImpl statics instr jumpDest -> NcgImpl statics instr jumpDest
-> BufHandle -> BufHandle
......
...@@ -699,8 +699,6 @@ instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where ...@@ -699,8 +699,6 @@ instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
ppr m = ppr (M.toList m) ppr m = ppr (M.toList m)
instance (Outputable elt) => Outputable (IM.IntMap elt) where instance (Outputable elt) => Outputable (IM.IntMap elt) where
ppr m = ppr (IM.toList m) ppr m = ppr (IM.toList m)
instance (PlatformOutputable elt) => PlatformOutputable (Set.Set elt) where
pprPlatform platform m = pprPlatform platform (Set.toList m)
\end{code} \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