import ErrUtils
import FiniteMap
import HscTypes
-import Maybe
-import Monad
+import Data.Maybe
+import Control.Monad
import Outputable
import StaticFlags
-> 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"
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
dump Opt_D_dump_cmmz "procpoint map" procPointMap
- gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap
- (CmmProc h l args g)
- mapM (dump Opt_D_dump_cmmz "after splitting") gs
+ 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 [] gs
- mapM (dump Opt_D_dump_cmmz "after 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)
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)
projects / ghc-hetmet.git / blobdiff