X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPSZ.hs;h=e44e3040f1ab1589e381fc79c00a5da00e9e3811;hp=7db4eed07352cbaa4e123ecef975ce9ba0699743;hb=1e50fd4185479a62e02d987bdfcb1c62712859ca;hpb=e367ebeb97b97bc2732202bcfabbbde63f1ec5cd diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index 7db4eed..e44e304 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -20,8 +20,8 @@ import DynFlags import ErrUtils import FiniteMap import HscTypes -import Maybe -import Monad +import Data.Maybe +import Control.Monad import Outputable import StaticFlags @@ -43,12 +43,12 @@ import StaticFlags -- The SRT needs to be threaded because it is grown lazily. protoCmmCPSZ :: HscEnv -- Compilation env including -- dynamic flags: -dcmm-lint -ddump-cps-cmm - -> (TopSRT, [CmmZ]) -- SRT table and + -> (TopSRT, [CmmZ]) -- SRT table and accumulating list of compiled procs -> CmmZ -- Input C-- with Procedures -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C-- protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) - | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env)) - = return (topSRT, Cmm tops : rst) -- Only if -frun-cps + | not (dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)) + = return (topSRT, Cmm tops : rst) -- Only if -fnew-codegen | otherwise = do let dflags = hsc_dflags hsc_env showPass dflags "CPSZ" @@ -71,72 +71,71 @@ cpsTop :: HscEnv -> CmmTopZ -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTopForInfoTables)]) cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)]) -cpsTop hsc_env (CmmProc h l args g) = +cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = do dump Opt_D_dump_cmmz "Pre Proc Points Added" g let callPPs = callProcPoints g - g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" - (dualLivenessWithInsertion callPPs) g - g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" - (removeDeadAssignmentsAndReloads callPPs) g + -- Why bother doing it this early? + -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" + -- (dualLivenessWithInsertion callPPs) g + -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses + -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" + -- (removeDeadAssignmentsAndReloads callPPs) g dump Opt_D_dump_cmmz "Pre common block elimination" g g <- return $ elimCommonBlocks g dump Opt_D_dump_cmmz "Post common block elimination" g procPoints <- run $ minimalProcPointSet callPPs g - -- print $ "call procPoints: " ++ (showSDoc $ ppr procPoints) g <- run $ addProcPointProtocols callPPs procPoints g dump Opt_D_dump_cmmz "Post Proc Points Added" g - g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" + g <- + -- pprTrace "pre Spills" (ppr g) $ + dual_rewrite Opt_D_dump_cmmz "spills and reloads" (dualLivenessWithInsertion procPoints) g -- Insert spills at defns; reloads at return points - g <- run $ insertLateReloads g -- Duplicate reloads just before uses + g <- + -- pprTrace "pre insertLateReloads" (ppr g) $ + run $ insertLateReloads g -- Duplicate reloads just before uses dump Opt_D_dump_cmmz "Post late reloads" g - g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" + g <- + -- pprTrace "post insertLateReloads" (ppr g) $ + dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" (removeDeadAssignmentsAndReloads procPoints) g -- Remove redundant reloads (and any other redundant asst) -- Debugging: stubbing slots on death can cause crashes early - g <- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g - mbpprTrace "graph before procPointMap: " (ppr g) $ return () - procPointMap <- run $ procPointAnalysis procPoints g + g <- + -- trace "post dead-assign elim" $ + if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g slotEnv <- run $ liveSlotAnal g mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return () - cafEnv <- run $ cafAnal g - (cafEnv, slotEnv) <- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g + cafEnv <- + -- trace "post liveSlotAnal" $ + run $ cafAnal g + (cafEnv, slotEnv) <- + -- trace "post print cafAnal" $ + return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return () - let areaMap = layout procPoints slotEnv g + let areaMap = layout procPoints slotEnv entry_off g mbpprTrace "areaMap" (ppr areaMap) $ return () - g <- run $ manifestSP procPoints procPointMap areaMap g + g <- run $ manifestSP areaMap entry_off g dump Opt_D_dump_cmmz "after manifestSP" g -- UGH... manifestSP can require updates to the procPointMap. -- We can probably do something quicker here for the update... procPointMap <- run $ procPointAnalysis procPoints g - gs <- pprTrace "procPointMap" (ppr procPointMap) $ - run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap - (CmmProc h l args g) - mapM (dump Opt_D_dump_cmmz "after splitting") gs + dump Opt_D_dump_cmmz "procpoint map" procPointMap + gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap + (CmmProc h l args (stackInfo, g)) + mapM_ (dump Opt_D_dump_cmmz "after splitting") gs let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs mbpprTrace "localCAFs" (ppr localCAFs) $ return () - gs <- liftM concat $ run $ foldM (lowerSafeForeignCalls procPoints) [] gs - mapM (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs + gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs + mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES let gs' = map (setInfoTableStackMap slotEnv areaMap) gs - mapM (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs' + mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs' let gs'' = map (bundleCAFs cafEnv) gs' - mapM (dump Opt_D_dump_cmmz "after bundleCAFs") gs'' + mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs'' return (localCAFs, gs'') -{- - -- Return: (a) CAFs used by this proc (b) a closure that will compute - -- a new SRT for the procedure. - let toTops topCAFEnv (topSRT, tops) = - do let setSRT (topSRT, rst) g = - do (topSRT, gs) <- setInfoTableSRT cafEnv topCAFEnv topSRT g - return (topSRT, gs : rst) - (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs' - gs' <- mapM finishInfoTables (concat gs') - return (topSRT, concat gs' : tops) - return (localCAFs, toTops) --} where dflags = hsc_dflags hsc_env mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z dump f txt g = dumpIfSet_dyn dflags f txt (ppr g) @@ -157,7 +156,6 @@ toTops hsc_env topCAFEnv (topSRT, tops) gs = do let setSRT (topSRT, rst) g = do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g return (topSRT, gs : rst) - (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs + (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs gs' <- mapM finishInfoTables (concat gs') return (topSRT, concat gs' : tops) - where run = runFuelIO (hsc_OptFuel hsc_env)