Commit 3f0afaba by 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!