2 -- | Converts C-- with full proceedures and parameters
3 -- to a CPS transformed C-- with the stack made manifest.
9 import CmmCommonBlockElimZ
16 import ZipCfg hiding (zip, unzip)
27 -----------------------------------------------------------------------------
28 -- |Top level driver for the CPS pass
29 -----------------------------------------------------------------------------
30 protoCmmCPSZ :: HscEnv -- Compilation env including
31 -- dynamic flags: -dcmm-lint -ddump-cps-cmm
32 -> CmmZ -- Input C-- with Proceedures
33 -> IO CmmZ -- Output CPS transformed C--
34 protoCmmCPSZ hsc_env (Cmm tops)
35 | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env))
36 = return (Cmm tops) -- Only if -frun-cps
38 = do let dflags = hsc_dflags hsc_env
39 showPass dflags "CPSZ"
40 tops <- mapM (cpsTop hsc_env) tops
41 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr (Cmm tops))
46 The identity and the last pass are stored in
47 mutable reference cells in an 'HscEnv' and are
48 global to one compiler session.
51 cpsTop :: HscEnv -> CmmTopZ -> IO CmmTopZ
52 cpsTop _ p@(CmmData {}) = return p
53 cpsTop hsc_env (CmmProc h l args g) =
54 do dump Opt_D_dump_cmmz "Pre Proc Points Added" g
55 let callPPs = callProcPoints g
56 procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ g)
57 let varSlots = emptyFM
58 g <- return $ map_nodes id NotSpillOrReload id g
59 -- Change types of middle nodes to allow spill/reload
60 g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
61 (dualLivenessWithInsertion emptyBlockSet) g
62 (varSlots, g) <- trim g >>= run . elimSpillAndReload varSlots
63 g <- run $ addProcPointProtocols callPPs procPoints args g
64 dump Opt_D_dump_cmmz "Post Proc Points Added" g
65 g <- return $ map_nodes id NotSpillOrReload id g
66 -- Change types of middle nodes to allow spill/reload
67 g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
68 (dualLivenessWithInsertion procPoints) g
69 -- Insert spills at defns; reloads at return points
70 g <- run $ insertLateReloads' g -- Duplicate reloads just before uses
71 dump Opt_D_dump_cmmz "Post late reloads" g
72 g <- trim g >>= dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
73 (removeDeadAssignmentsAndReloads procPoints)
74 -- Remove redundant reloads (and any other redundant asst)
75 (_, g) <- trim g >>= run . elimSpillAndReload varSlots
76 gs <- run $ splitAtProcPoints args l procPoints g
77 gs `seq` dump Opt_D_dump_cmmz "Pre common block elimination" g
78 g <- return $ elimCommonBlocks g
79 dump Opt_D_dump_cmmz "Post common block elimination" g
80 return $ CmmProc h l args (runTx cmmCfgOptsZ g)
81 where dflags = hsc_dflags hsc_env
82 dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
83 run = runFuelIO (hsc_OptFuel hsc_env)
84 dual_rewrite flag txt pass g =
85 do dump flag ("Pre " ++ txt) g
86 g <- run $ pass (graphOfLGraph g) >>= lGraphOfGraph
87 dump flag ("Post " ++ txt) $ g
88 return $ graphOfLGraph g
89 trim (Graph (ZLast (LastOther (LastBranch id))) blocks) = return $ LGraph id blocks
90 trim (Graph tail blocks) =
91 do entry <- liftM BlockId $ run $ getUniqueM
92 return $ LGraph entry (insertBlock (Block entry tail) blocks)