Major patch to fix reporting of unused imports
[ghc-hetmet.git] / compiler / main / HscMain.lhs
index 2fefcd4..26247b1 100644 (file)
@@ -1,10 +1,13 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
 %
-
-\section[GHC_Main]{Main driver for Glasgow Haskell compiler}
-
 \begin{code}
+-- | Main driver for the compiling plain Haskell source code.
+--
+-- This module implements compilation of a Haskell-only source file.  It is
+-- /not/ concerned with preprocessing of source files; this is handled in
+-- "DriverPipeline".
+--
 module HscMain
     ( newHscEnv, hscCmmFile
     , hscParseIdentifier
@@ -14,12 +17,15 @@ module HscMain
     , hscStmt, hscTcExpr, hscKcType
     , compileExpr
 #endif
+    , HsCompiler(..)
+    , hscOneShotCompiler, hscNothingCompiler
+    , hscInteractiveCompiler, hscBatchCompiler
     , hscCompileOneShot     -- :: Compiler HscStatus
     , hscCompileBatch       -- :: Compiler (HscStatus, ModIface, ModDetails)
     , hscCompileNothing     -- :: Compiler (HscStatus, ModIface, ModDetails)
     , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
     , HscStatus' (..)
-    , InteractiveStatus, NothingStatus, OneShotStatus, BatchStatus
+    , InteractiveStatus, HscStatus
 
     -- The new interface
     , hscParse
@@ -71,14 +77,17 @@ import SimplCore        ( core2core )
 import TidyPgm
 import CorePrep                ( corePrepPgm )
 import CoreToStg       ( coreToStg )
+import qualified StgCmm        ( codeGen )
 import StgSyn
 import CostCentre
-import TyCon           ( isDataTyCon )
+import TyCon           ( TyCon, isDataTyCon )
 import Name            ( Name, NamedThing(..) )
 import SimplStg                ( stg2stg )
 import CodeGen         ( codeGen )
 import Cmm              ( Cmm )
+import PprCmm          ( pprCmms )
 import CmmParse                ( parseCmmFile )
+import CmmBuildInfoTables
 import CmmCPS
 import CmmCPSZ
 import CmmInfo
@@ -103,10 +112,10 @@ import LazyUniqFM         ( emptyUFM )
 import UniqSupply       ( initUs_ )
 import Bag             ( unitBag )
 import Exception
-import MonadUtils
+-- import MonadUtils
 
 import Control.Monad
-import System.IO
+-- import System.IO
 import Data.IORef
 \end{code}
 #include "HsVersions.h"
@@ -119,8 +128,8 @@ import Data.IORef
 %************************************************************************
 
 \begin{code}
-newHscEnv :: DynFlags -> IO HscEnv
-newHscEnv dflags
+newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv
+newHscEnv callbacks dflags
   = do         { eps_var <- newIORef initExternalPackageState
        ; us      <- mkSplitUniqSupply 'r'
        ; nc_var  <- newIORef (initNameCache us knownKeyNames)
@@ -128,6 +137,7 @@ newHscEnv dflags
        ; mlc_var <- newIORef emptyModuleEnv
         ; optFuel <- initOptFuelState
        ; return (HscEnv { hsc_dflags = dflags,
+                           hsc_callbacks = callbacks,
                           hsc_targets = [],
                           hsc_mod_graph = [],
                           hsc_IC      = emptyInteractiveContext,
@@ -219,12 +229,13 @@ hscTypecheckRename mod_summary rdr_module = do
           <- {-# SCC "Typecheck-Rename" #-}
              ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
 
-    let rn_info = do decl <- tcg_rn_decls tc_result
-                     imports <- tcg_rn_imports tc_result
-                     let exports = tcg_rn_exports tc_result
-                     let doc = tcg_doc tc_result
-                    let hmi = tcg_hmi tc_result
-                     return (decl,imports,exports,doc,hmi)
+    let -- This 'do' is in the Maybe monad!
+        rn_info = do { decl <- tcg_rn_decls tc_result
+                     ; let imports = tcg_rn_imports tc_result
+                           exports = tcg_rn_exports tc_result
+                           doc            = tcg_doc tc_result
+                          hmi     = tcg_hmi tc_result
+                     ; return (decl,imports,exports,doc,hmi) }
 
     return (tc_result, rn_info)
 
@@ -305,17 +316,13 @@ data HscStatus' a
 -- functional dependencies, we have to parameterise the typeclass over the
 -- result type.  Therefore we need to artificially distinguish some types.  We
 -- do this by adding type tags which will simply be ignored by the caller.
-data HscOneShotTag = HscOneShotTag
-data HscNothingTag = HscNothingTag
-
-type OneShotStatus     = HscStatus' HscOneShotTag
-type BatchStatus       = HscStatus' ()
-type InteractiveStatus = HscStatus' (CompiledByteCode, ModBreaks)
-type NothingStatus     = HscStatus' HscNothingTag
+type HscStatus         = HscStatus' ()
+type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
+    -- INVARIANT: result is @Nothing@ <=> input was a boot file
 
-type OneShotResult = OneShotStatus
-type BatchResult   = (BatchStatus, ModIface, ModDetails)
-type NothingResult = (NothingStatus, ModIface, ModDetails)
+type OneShotResult     = HscStatus
+type BatchResult       = (HscStatus, ModIface, ModDetails)
+type NothingResult     = (HscStatus, ModIface, ModDetails)
 type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
 
 -- FIXME: The old interface and module index are only using in 'batch' and
@@ -328,36 +335,41 @@ type Compiler result =  GhcMonad m =>
                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
                      -> m result
 
-class HsCompiler a where
-  -- | The main interface.
-  hscCompile :: GhcMonad m =>
-                HscEnv -> ModSummary -> Bool
-             -> Maybe ModIface -> Maybe (Int, Int)
-             -> m a
-
-  -- | Called when no recompilation is necessary.
-  hscNoRecomp :: GhcMonad m =>
-                 ModIface -> m a
-
-  -- | Called to recompile the module.
-  hscRecompile :: GhcMonad m =>
-                  ModSummary -> Maybe Fingerprint -> m a
-
-  -- | Code generation for Boot modules.
-  hscGenBootOutput :: GhcMonad m =>
-                      TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a
-
-  -- | Code generation for normal modules.
-  hscGenOutput :: GhcMonad m =>
-                  ModGuts  -> ModSummary -> Maybe Fingerprint -> m a
-
-
-genericHscCompile :: (HsCompiler a, GhcMonad m) =>
-                     (Maybe (Int,Int) -> Bool -> ModSummary -> m ())
+data HsCompiler a
+  = HsCompiler {
+    -- | The main interface.
+    hscCompile :: GhcMonad m =>
+                  HscEnv -> ModSummary -> Bool
+               -> Maybe ModIface -> Maybe (Int, Int)
+               -> m a,
+
+    -- | Called when no recompilation is necessary.
+    hscNoRecomp :: GhcMonad m =>
+                   ModIface -> m a,
+
+    -- | Called to recompile the module.
+    hscRecompile :: GhcMonad m =>
+                    ModSummary -> Maybe Fingerprint -> m a,
+
+    hscBackend :: GhcMonad m =>
+                  TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
+
+    -- | Code generation for Boot modules.
+    hscGenBootOutput :: GhcMonad m =>
+                        TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
+
+    -- | Code generation for normal modules.
+    hscGenOutput :: GhcMonad m =>
+                    ModGuts  -> ModSummary -> Maybe Fingerprint -> m a
+  }
+
+genericHscCompile :: GhcMonad m =>
+                     HsCompiler a
+                  -> (Maybe (Int,Int) -> Bool -> ModSummary -> m ())
                   -> HscEnv -> ModSummary -> Bool
                   -> Maybe ModIface -> Maybe (Int, Int)
                   -> m a
-genericHscCompile hscMessage
+genericHscCompile compiler hscMessage
                   hsc_env mod_summary source_unchanged
                   mb_old_iface0 mb_mod_index =
    withTempSession (\_ -> hsc_env) $ do
@@ -372,147 +384,176 @@ genericHscCompile hscMessage
      case mb_checked_iface of
        Just iface | not recomp_reqd
            -> do hscMessage mb_mod_index False mod_summary
-                 hscNoRecomp iface
+                 hscNoRecomp compiler iface
        _otherwise
            -> do hscMessage mb_mod_index True mod_summary
-                 hscRecompile mod_summary mb_old_hash
+                 hscRecompile compiler mod_summary mb_old_hash
 
-genericHscRecompile :: (HsCompiler a, GhcMonad m) =>
-                       ModSummary -> Maybe Fingerprint
+genericHscRecompile :: GhcMonad m =>
+                       HsCompiler a
+                    -> ModSummary -> Maybe Fingerprint
                     -> m a
-genericHscRecompile mod_summary mb_old_hash
+genericHscRecompile compiler mod_summary mb_old_hash
   | ExtCoreFile <- ms_hsc_src mod_summary =
       panic "GHC does not currently support reading External Core files"
   | otherwise = do
       tc_result <- hscFileFrontEnd mod_summary
-      case ms_hsc_src mod_summary of
-        HsBootFile ->
-            hscGenBootOutput tc_result mod_summary mb_old_hash
-        _other     -> do
-            guts <- hscDesugar mod_summary tc_result
-            hscGenOutput guts mod_summary mb_old_hash
+      hscBackend compiler tc_result mod_summary mb_old_hash
+
+genericHscBackend :: GhcMonad m =>
+                     HsCompiler a
+                  -> TcGblEnv -> ModSummary -> Maybe Fingerprint
+                  -> m a
+genericHscBackend compiler tc_result mod_summary mb_old_hash
+  | HsBootFile <- ms_hsc_src mod_summary =
+      hscGenBootOutput compiler tc_result mod_summary mb_old_hash
+  | otherwise = do
+      guts <- hscDesugar mod_summary tc_result
+      hscGenOutput compiler guts mod_summary mb_old_hash
 
 --------------------------------------------------------------
 -- Compilers
 --------------------------------------------------------------
 
-instance HsCompiler OneShotResult where
-
-  hscCompile hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do
-     -- One-shot mode needs a knot-tying mutable variable for interface files.
-     -- See TcRnTypes.TcGblEnv.tcg_type_env_var.
-    type_env_var <- liftIO $ newIORef emptyNameEnv
-    let 
-       mod = ms_mod mod_summary
-       hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
-    ---
-    genericHscCompile oneShotMsg hsc_env' mod_summary src_changed
-                      mb_old_iface mb_i_of_n
-
-  hscNoRecomp _old_iface = do
-    withSession (liftIO . dumpIfaceStats)
-    return HscNoRecomp
-
-  hscRecompile = genericHscRecompile
-
-  hscGenBootOutput tc_result mod_summary mb_old_iface = do
-     (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
-     hscWriteIface iface changed mod_summary
-     return (HscRecomp False HscOneShotTag)
-
-  hscGenOutput guts0 mod_summary mb_old_iface = do
-     guts <- hscSimplify guts0
-     (iface, changed, _details, cgguts)
-         <- hscNormalIface guts mb_old_iface
-     hscWriteIface iface changed mod_summary
-     hasStub <- hscGenHardCode cgguts mod_summary
-     return (HscRecomp hasStub HscOneShotTag)
+hscOneShotCompiler :: HsCompiler OneShotResult
+hscOneShotCompiler =
+  HsCompiler {
+
+    hscCompile = \hsc_env mod_summary src_changed mb_old_iface mb_i_of_n -> do
+       -- One-shot mode needs a knot-tying mutable variable for interface
+       -- files.  See TcRnTypes.TcGblEnv.tcg_type_env_var.
+      type_env_var <- liftIO $ newIORef emptyNameEnv
+      let
+         mod = ms_mod mod_summary
+         hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
+      ---
+      genericHscCompile hscOneShotCompiler
+                        oneShotMsg hsc_env' mod_summary src_changed
+                        mb_old_iface mb_i_of_n
+
+  , hscNoRecomp = \_old_iface -> do
+      withSession (liftIO . dumpIfaceStats)
+      return HscNoRecomp
+
+  , hscRecompile = genericHscRecompile hscOneShotCompiler
+
+  , hscBackend = genericHscBackend hscOneShotCompiler
+
+  , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
+       (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
+       hscWriteIface iface changed mod_summary
+       return (HscRecomp False ())
+
+  , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
+       guts <- hscSimplify guts0
+       (iface, changed, _details, cgguts)
+           <- hscNormalIface guts mb_old_iface
+       hscWriteIface iface changed mod_summary
+       hasStub <- hscGenHardCode cgguts mod_summary
+       return (HscRecomp hasStub ())
+  }
 
 -- Compile Haskell, boot and extCore in OneShot mode.
-hscCompileOneShot :: Compiler OneShotStatus
-hscCompileOneShot = hscCompile
+hscCompileOneShot :: Compiler OneShotResult
+hscCompileOneShot = hscCompile hscOneShotCompiler
 
 --------------------------------------------------------------
 
-instance HsCompiler BatchResult where
+hscBatchCompiler :: HsCompiler BatchResult
+hscBatchCompiler =
+  HsCompiler {
+
+    hscCompile = genericHscCompile hscBatchCompiler batchMsg
 
-  hscCompile = genericHscCompile batchMsg
+  , hscNoRecomp = \iface -> do
+       details <- genModDetails iface
+       return (HscNoRecomp, iface, details)
 
-  hscNoRecomp iface = do
-     details <- genModDetails iface
-     return (HscNoRecomp, iface, details)
+  , hscRecompile = genericHscRecompile hscBatchCompiler
 
-  hscRecompile = genericHscRecompile
+  , hscBackend = genericHscBackend hscBatchCompiler
 
-  hscGenBootOutput tc_result mod_summary mb_old_iface = do
-     (iface, changed, details)
-         <- hscSimpleIface tc_result mb_old_iface
-     hscWriteIface iface changed mod_summary
-     return (HscRecomp False (), iface, details)
+  , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
+       (iface, changed, details)
+           <- hscSimpleIface tc_result mb_old_iface
+       hscWriteIface iface changed mod_summary
+       return (HscRecomp False (), iface, details)
 
-  hscGenOutput guts0 mod_summary mb_old_iface = do
-     guts <- hscSimplify guts0
-     (iface, changed, details, cgguts)
-         <- hscNormalIface guts mb_old_iface
-     hscWriteIface iface changed mod_summary
-     hasStub <- hscGenHardCode cgguts mod_summary
-     return (HscRecomp hasStub (), iface, details)
+  , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
+       guts <- hscSimplify guts0
+       (iface, changed, details, cgguts)
+           <- hscNormalIface guts mb_old_iface
+       hscWriteIface iface changed mod_summary
+       hasStub <- hscGenHardCode cgguts mod_summary
+       return (HscRecomp hasStub (), iface, details)
+  }
 
 -- Compile Haskell, boot and extCore in batch mode.
-hscCompileBatch :: Compiler (BatchStatus, ModIface, ModDetails)
-hscCompileBatch = hscCompile
+hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
+hscCompileBatch = hscCompile hscBatchCompiler
 
 --------------------------------------------------------------
 
-instance HsCompiler InteractiveResult where
+hscInteractiveCompiler :: HsCompiler InteractiveResult
+hscInteractiveCompiler =
+  HsCompiler {
+    hscCompile = genericHscCompile hscInteractiveCompiler batchMsg
 
-  hscCompile = genericHscCompile batchMsg
+  , hscNoRecomp = \iface -> do
+       details <- genModDetails iface
+       return (HscNoRecomp, iface, details)
 
-  hscNoRecomp iface = do
-     details <- genModDetails iface
-     return (HscNoRecomp, iface, details)
+  , hscRecompile = genericHscRecompile hscInteractiveCompiler
 
-  hscRecompile = genericHscRecompile
+  , hscBackend = genericHscBackend hscInteractiveCompiler
 
-  hscGenBootOutput _ _ _ = panic "hscCompileInteractive: HsBootFile"
+  , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
+       (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
+       return (HscRecomp False Nothing, iface, details)
 
-  hscGenOutput guts0 mod_summary mb_old_iface = do
-     guts <- hscSimplify guts0
-     (iface, _changed, details, cgguts)
-         <- hscNormalIface guts mb_old_iface
-     hscInteractive (iface, details, cgguts) mod_summary
+  , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
+       guts <- hscSimplify guts0
+       (iface, _changed, details, cgguts)
+           <- hscNormalIface guts mb_old_iface
+       hscInteractive (iface, details, cgguts) mod_summary
+  }
 
 -- Compile Haskell, extCore to bytecode.
 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
-hscCompileInteractive = hscCompile
+hscCompileInteractive = hscCompile hscInteractiveCompiler
 
 --------------------------------------------------------------
 
-instance HsCompiler NothingResult where
-
-  hscCompile = genericHscCompile batchMsg
-
-  hscNoRecomp iface = do
-     details <- genModDetails iface
-     return (HscNoRecomp, iface, details)
-
-  hscRecompile mod_summary mb_old_hash
-    | ExtCoreFile <- ms_hsc_src mod_summary =
-        panic "hscCompileNothing: cannot do external core"
-    | otherwise = do
-        tc_result <- hscFileFrontEnd mod_summary
-        hscGenBootOutput tc_result mod_summary mb_old_hash
-
-  hscGenBootOutput tc_result _mod_summary mb_old_iface = do
-     (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
-     return (HscRecomp False HscNothingTag, iface, details)
+hscNothingCompiler :: HsCompiler NothingResult
+hscNothingCompiler =
+  HsCompiler {
+    hscCompile = genericHscCompile hscNothingCompiler batchMsg
 
-  hscGenOutput _ _ _ =
-      panic "hscCompileNothing: hscGenOutput should not be called"
+  , hscNoRecomp = \iface -> do
+       details <- genModDetails iface
+       return (HscNoRecomp, iface, details)
 
+  , hscRecompile = \mod_summary mb_old_hash ->
+      case ms_hsc_src mod_summary of
+        ExtCoreFile ->
+          panic "hscCompileNothing: cannot do external core"
+        _otherwise -> do
+          tc_result <- hscFileFrontEnd mod_summary
+          hscBackend hscNothingCompiler tc_result mod_summary mb_old_hash
+
+  , hscBackend = \tc_result _mod_summary mb_old_iface -> do
+       (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
+       return (HscRecomp False (), iface, details)
+
+  , hscGenBootOutput = \_ _ _ ->
+        panic "hscCompileNothing: hscGenBootOutput should not be called"
+
+  , hscGenOutput = \_ _ _ ->
+        panic "hscCompileNothing: hscGenOutput should not be called"
+  }
 -- Type-check Haskell and .hs-boot only (no external core)
-hscCompileNothing :: Compiler (NothingStatus, ModIface, ModDetails)
-hscCompileNothing = hscCompile
+hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
+hscCompileNothing = hscCompile hscNothingCompiler
 
 --------------------------------------------------------------
 -- NoRecomp handlers
@@ -648,7 +689,7 @@ hscGenHardCode cgguts mod_summary
                      cg_dir_imps = dir_imps,
                      cg_foreign  = foreign_stubs,
                      cg_dep_pkgs = dependencies,
-                    cg_hpc_info = hpc_info } = cgguts
+                     cg_hpc_info = hpc_info } = cgguts
              dflags = hsc_dflags hsc_env
              location = ms_location mod_summary
              data_tycons = filter isDataTyCon tycons
@@ -664,16 +705,24 @@ hscGenHardCode cgguts mod_summary
          (stg_binds, cost_centre_info)
              <- {-# SCC "CoreToStg" #-}
                 myCoreToStg dflags this_mod prepd_binds        
+
          ------------------  Code generation ------------------
-         cmms <- {-# SCC "CodeGen" #-}
-                      codeGen dflags this_mod data_tycons
-                              dir_imps cost_centre_info
-                              stg_binds hpc_info
+         cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)
+                 then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
+                                 dir_imps cost_centre_info
+                                 stg_binds hpc_info
+                         return cmms
+                 else {-# SCC "CodeGen" #-}
+                       codeGen dflags this_mod data_tycons
+                               dir_imps cost_centre_info
+                               stg_binds hpc_info
+
          --- Optionally run experimental Cmm transformations ---
-         cmms <- optionallyConvertAndOrCPS hsc_env cmms
+         -- cmms <- optionallyConvertAndOrCPS hsc_env cmms
                  -- unless certain dflags are on, the identity function
          ------------------  Code output -----------------------
          rawcmms <- cmmToRawCmm cmms
+         dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms)
          (_stub_h_exists, stub_c_exists)
              <- codeOutput dflags this_mod location foreign_stubs 
                 dependencies rawcmms
@@ -710,7 +759,8 @@ hscInteractive (iface, details, cgguts) mod_summary
          ------------------ Create f-x-dynamic C-side stuff ---
          (_istub_h_exists, istub_c_exists) 
              <- outputForeignStubs dflags this_mod location foreign_stubs
-         return (HscRecomp istub_c_exists (comp_bc, mod_breaks), iface, details)
+         return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
+                , iface, details)
 #else
 hscInteractive _ _ = panic "GHC not compiled with interpreter"
 #endif
@@ -724,7 +774,7 @@ hscCmmFile hsc_env filename = do
              parseCmmFile dflags filename
     cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm]
     rawCmms <- liftIO $ cmmToRawCmm cmms
-    liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
+    _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
     return ()
   where
        no_mod = panic "hscCmmFile: no_mod"
@@ -732,6 +782,42 @@ hscCmmFile hsc_env filename = do
                               ml_hi_file  = panic "hscCmmFile: no hi file",
                               ml_obj_file = panic "hscCmmFile: no obj file" }
 
+-------------------- Stuff for new code gen ---------------------
+
+tryNewCodeGen  :: HscEnv -> Module -> [TyCon] -> [Module]
+               -> CollectedCCs
+               -> [(StgBinding,[(Id,[Id])])]
+               -> HpcInfo
+               -> IO [Cmm]
+tryNewCodeGen hsc_env this_mod data_tycons imported_mods 
+             cost_centre_info stg_binds hpc_info
+  | not (dopt Opt_TryNewCodeGen (hsc_dflags hsc_env))
+  = return []
+  | otherwise
+  = do { let dflags = hsc_dflags hsc_env
+        ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods 
+                        cost_centre_info stg_binds hpc_info
+       ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" 
+               (pprCmms prog)
+
+       ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog
+               -- Control flow optimisation
+
+        -- Note: Have to thread the module's SRT through all the procedures
+        -- because we greedily build it as we go.
+        ; us <- mkSplitUniqSupply 'S'
+        ; let topSRT = initUs_ us emptySRT
+       ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog
+               -- The main CPS conversion
+
+       ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
+               -- Control flow optimisation, again
+
+       ; let prog' = map cmmOfZgraph prog
+       ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
+       ; return prog' }
+
+
 optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
 optionallyConvertAndOrCPS hsc_env cmms =
     do let dflags = hsc_dflags hsc_env
@@ -741,7 +827,7 @@ optionallyConvertAndOrCPS hsc_env cmms =
                else return cmms
          ---------  Optionally convert to CPS (MDA) -----------
        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
-                  dopt Opt_RunCPSZ dflags
+                  dopt Opt_RunCPS dflags
                then cmmCPS dflags cmms
                else return cmms
        return cmms
@@ -758,14 +844,15 @@ testCmmConversion hsc_env cmm =
        let cvtm = do g <- cmmToZgraph cmm
                      return $ cfopts g
        let zgraph = initUs_ us cvtm
-       cps_zgraph <- protoCmmCPSZ hsc_env zgraph
+       us <- mkSplitUniqSupply 'S'
+       let topSRT = initUs_ us emptySRT
+       (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph
        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
        showPass dflags "Convert from Z back to Cmm"
        let cvt = cmmOfZgraph $ cfopts $ chosen_graph
        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
        return cvt
-       -- return cmm -- don't use the conversion
 
 myCoreToStg :: DynFlags -> Module -> [CoreBind]
             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program