-cpsTop :: CmmTopZ -> UniqSM (DFTx 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'
- in do us <- getUs
- let g = runDFM us dualLiveLattice $ b_rewrite dualLivenessWithInsertion g''
- -- let igraph = buildIGraph
- return $ do g' <- g >>= return . map_nodes id spillAndReloadComments id
- return $ CmmProc h l args g'
+cpsTop :: HscEnv -> CmmTopZ -> IO CmmTopZ
+cpsTop _ p@(CmmData {}) = return 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 <- return $ map_nodes id NotSpillOrReload id g
+ -- Change types of middle nodes to allow spill/reload
+ g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+ (dualLivenessWithInsertion callPPs) g
+ (varSlots, g) <- trim g >>= return . elimSpillAndReload emptyFM
+ procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ g)
+ g <- run $ addProcPointProtocols callPPs procPoints g
+ dump Opt_D_dump_cmmz "Post Proc Points Added" g
+ g <- return $ map_nodes id NotSpillOrReload id g
+ -- Change types of middle nodes to allow spill/reload
+ 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 <- trim g >>= dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+ (removeDeadAssignmentsAndReloads procPoints)
+ -- Remove redundant reloads (and any other redundant asst)
+ (_, g) <- trim g >>= return . elimSpillAndReload varSlots
+ gs <- run $ splitAtProcPoints args l procPoints g
+ gs `seq` dump Opt_D_dump_cmmz "Pre common block elimination" g
+ g <- return $ elimCommonBlocks g
+ dump Opt_D_dump_cmmz "Post common block elimination" g
+ return $ CmmProc h l args (runTx cmmCfgOptsZ g)
+ where dflags = hsc_dflags hsc_env
+ 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 (graphOfLGraph g) >>= lGraphOfGraph
+ dump flag ("Post " ++ txt) $ g
+ return $ graphOfLGraph g
+ trim (Graph (ZLast (LastOther (LastBranch id))) blocks) = return $ LGraph id blocks
+ trim (Graph tail blocks) =
+ do entry <- liftM BlockId $ run $ getUniqueM
+ return $ LGraph entry (insertBlock (Block entry tail) blocks)