-cpsTop :: CmmTopZ -> UniqSM (FuelMonad CmmTopZ)
-cpsTop p@(CmmData {}) = return (return p)
-cpsTop (CmmProc h l args g) =
- let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g)
- g' = addProcPointProtocols procPoints args g
- g'' = map_nodes id NotSpillOrReload id g'
- -- Change types of middle nodes to allow spill/reload
- in do { u1 <- getUs; u2 <- getUs; u3 <- getUs
- ; entry <- getUniqueUs >>= return . BlockId
- ; return $
- do { g <- return g''
- ; g <- dual_rewrite u1 dualLivenessWithInsertion g
- -- Insert spills at defns; reloads at return points
- ; g <- insertLateReloads' u2 (extend g)
- -- Duplicate reloads just before uses
- ; g <- dual_rewrite u3 removeDeadAssignmentsAndReloads (trim entry g)
- -- Remove redundant reloads (and any other redundant asst)
- ; return $ CmmProc h l args $ map_nodes id spillAndReloadComments id g
- }
- }
- where dual_rewrite u pass g = runDFM u dualLiveLattice $ b_rewrite pass g
- extend (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
- trim _ (Graph (ZLast (LastOther (LastBranch id))) blocks) = LGraph id blocks
- trim e (Graph tail blocks) = LGraph e (insertBlock (Block e tail) blocks)
+cpsTop :: HscEnv -> CmmTopZ ->
+ IO ([(CLabel, CAFSet)],
+ [(CAFSet, CmmTopForInfoTables)])
+cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)])
+cpsTop hsc_env (CmmProc h l args 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
+ 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"
+ (dualLivenessWithInsertion procPoints) g
+ -- Insert spills at defns; reloads at return points
+ 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"
+ (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
+ slotEnv <- run $ liveSlotAnal g
+ mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
+ cafEnv <- run $ cafAnal g
+ (cafEnv, slotEnv) <- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
+ mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
+ let areaMap = layout procPoints slotEnv g
+ mbpprTrace "areaMap" (ppr areaMap) $ return ()
+ g <- run $ manifestSP procPoints procPointMap areaMap 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
+ 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
+
+ -- 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'
+ let gs'' = map (bundleCAFs cafEnv) 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)
+ run = runFuelIO (hsc_OptFuel hsc_env)
+ dual_rewrite flag txt pass g =
+ do dump flag ("Pre " ++ txt) g
+ g <- run $ pass g
+ dump flag ("Post " ++ txt) $ g
+ return g
+
+-- This probably belongs in CmmBuildInfoTables?
+-- We're just finishing the job here: once we know what CAFs are defined
+-- in non-static closures, we can build the SRTs.
+toTops :: HscEnv -> FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]])
+ -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
+
+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
+ gs' <- mapM finishInfoTables (concat gs')
+ return (topSRT, concat gs' : tops)
+ where run = runFuelIO (hsc_OptFuel hsc_env)