compiler/cmm/CmmCPSZ.hs

   1 module CmmCPSZ (
   2   -- | Converts C-- with full proceedures and parameters
   3   -- to a CPS transformed C-- with the stack made manifest.
   4   -- Well, sort of.
   5   protoCmmCPSZ
   6 ) where
   7
   8 import Cmm
   9 import CmmContFlowOpt
  10 import CmmProcPointZ
  11 import CmmSpillReload
  12 import CmmTx
  13 import DFMonad
  14 import PprCmmZ()
  15 import ZipCfg hiding (zip, unzip)
  16 import ZipCfgCmmRep
  17 import ZipDataflow0
  18
  19 import DynFlags
  20 import ErrUtils
  21 import Outputable
  22 import UniqSupply
  23
  24 import Data.IORef
  25
  26 -----------------------------------------------------------------------------
  27 -- |Top level driver for the CPS pass
  28 -----------------------------------------------------------------------------
  29 protoCmmCPSZ :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
  30        -> CmmZ     -- ^ Input C-- with Proceedures
  31        -> IO CmmZ  -- ^ Output CPS transformed C--
  32 protoCmmCPSZ dflags (Cmm tops)
  33   | not (dopt Opt_RunCPSZ dflags)
  34   = return (Cmm tops)                -- Only if -frun-cps
  35   | otherwise
  36   = do  { showPass dflags "CPSZ"
  37         ; u <- mkSplitUniqSupply 'p'
  38         ; pass_ref <- newIORef "unoptimized program" -- XXX see [Note global fuel]
  39         ; fuel_ref <- newIORef (tankFilledTo maxBound) -- XXX see [Note global fuel]
  40         ; let txtops = initUs_ u $ mapM cpsTop tops
  41         ; tops <- runFuelIO pass_ref fuel_ref (sequence txtops)
  42         ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr (Cmm tops))
  43         ; return $ Cmm tops
  44         }
  45
  46 {- [Note global fuel]
  47 ~~~~~~~~~~~~~~~~~~~~~
  48 In a correct world, the identity and the last pass would be stored in
  49 mutable reference cells associated with an 'HscEnv' and would be
  50 global to one compiler session.  Unfortunately the 'HscEnv' is not
  51 plumbed sufficiently close to this function; only the DynFlags are
  52 plumbed here.  One day the plumbing will be extended, in which case
  53 this pass will use the global 'pass_ref' and 'fuel_ref' instead of the
  54 bogus facsimiles in place here.
  55 -}
  56
  57 cpsTop :: CmmTopZ -> UniqSM (FuelMonad CmmTopZ)
  58 cpsTop p@(CmmData {}) = return (return p)
  59 cpsTop (CmmProc h l args g) =
  60     let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g)
  61         g' = addProcPointProtocols procPoints args g
  62         g'' = map_nodes id NotSpillOrReload id g'
  63                -- Change types of middle nodes to allow spill/reload
  64     in do { u1 <- getUs; u2 <- getUs; u3 <- getUs
  65           ; entry <- getUniqueUs >>= return . BlockId
  66           ; return $
  67               do { g <- return g''
  68                  ; g <- dual_rewrite u1 dualLivenessWithInsertion g
  69                            -- Insert spills at defns; reloads at return points
  70                  ; g <- insertLateReloads' u2 (extend g)
  71                            -- Duplicate reloads just before uses
  72                  ; g <- dual_rewrite u3 removeDeadAssignmentsAndReloads (trim entry g)
  73                            -- Remove redundant reloads (and any other redundant asst)
  74                  ; return $ CmmProc h l args $ map_nodes id spillAndReloadComments id g
  75                  }
  76           }
  77   where dual_rewrite u pass g = runDFM u dualLiveLattice $ b_rewrite pass g
  78         extend (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
  79         trim _ (Graph (ZLast (LastOther (LastBranch id))) blocks) = LGraph id blocks
  80         trim e (Graph tail blocks) = LGraph e (insertBlock (Block e tail) blocks)