refactoring: inline hscMkCompiler

[ghc-hetmet.git] / compiler / main / HscMain.lhs

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 0152549..c223bad 100644 (file)
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -256,41 +256,6 @@ type Compiler result =  HscEnv
                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
                      -> IO (Maybe result)
 
-
--- This functions checks if recompilation is necessary and
--- then combines the FrontEnd and BackEnd to a working compiler.
-hscMkCompiler :: NoRecomp result         -- What to do when recompilation isn't required.
-              -> (Maybe (Int,Int) -> Bool -> Comp ())
-              -> Comp (Maybe ModGuts)       -- Front end
-              -> (ModGuts -> Comp result)   -- Backend.
-              -> Compiler result
-hscMkCompiler norecomp messenger frontend backend
-              hsc_env mod_summary source_unchanged
-              mbOldIface mbModIndex
-    = flip evalComp (CompState hsc_env mod_summary mbOldIface) $
-      do (recomp_reqd, mbCheckedIface)
-             <- {-# SCC "checkOldIface" #-}
-                liftIO $ checkOldIface hsc_env mod_summary
-                              source_unchanged mbOldIface
-        -- save the interface that comes back from checkOldIface.
-        -- In one-shot mode we don't have the old iface until this
-        -- point, when checkOldIface reads it from the disk.
-        modify (\s -> s{ compOldIface = mbCheckedIface })
-         case mbCheckedIface of 
-           Just iface | not recomp_reqd
-               -> do messenger mbModIndex False
-                     result <- norecomp iface
-                     return (Just result)
-           _otherwise
-               -> do messenger mbModIndex True
-                     mbCore <- frontend
-                     case mbCore of
-                       Nothing
-                           -> return Nothing
-                       Just core
-                           -> do result <- backend core
-                                 return (Just result)
-
 --------------------------------------------------------------
 -- Compilers
 --------------------------------------------------------------
@@ -333,9 +298,34 @@ hscCompiler
         -> (ModGuts -> Comp result)  -- Compile normal file
         -> (ModGuts -> Comp result) -- Compile boot file
         -> Compiler result
-hscCompiler norecomp msg nonBootComp bootComp hsc_env mod_summary =
-    hscMkCompiler norecomp msg frontend backend hsc_env mod_summary
+hscCompiler norecomp messenger nonBootComp bootComp hsc_env mod_summary 
+            source_unchanged mbOldIface mbModIndex
+    = flip evalComp (CompState hsc_env mod_summary mbOldIface) $
+      do (recomp_reqd, mbCheckedIface)
+             <- {-# SCC "checkOldIface" #-}
+                liftIO $ checkOldIface hsc_env mod_summary
+                              source_unchanged mbOldIface
+        -- save the interface that comes back from checkOldIface.
+        -- In one-shot mode we don't have the old iface until this
+        -- point, when checkOldIface reads it from the disk.
+        modify (\s -> s{ compOldIface = mbCheckedIface })
+         case mbCheckedIface of 
+           Just iface | not recomp_reqd
+               -> do messenger mbModIndex False
+                     result <- norecomp iface
+                     return (Just result)
+           _otherwise
+               -> do messenger mbModIndex True
+                     mb_modguts <- frontend
+                     case mb_modguts of
+                       Nothing
+                           -> return Nothing
+                       Just core
+                           -> do result <- backend core
+                                 return (Just result)
     where
+          frontend :: Comp (Maybe ModGuts)       -- Front end
+          -- backend  :: (ModGuts -> Comp result)   -- Backend.
           (frontend,backend)
               = case ms_hsc_src mod_summary of
                 ExtCoreFile -> (hscCoreFrontEnd, nonBootComp)
@@ -594,17 +584,9 @@ hscCompile cgguts
                       codeGen dflags this_mod data_tycons
                               dir_imps cost_centre_info
                               stg_binds hpc_info
-         --------  Optionally convert to and from zipper ------
-         cmms <-
-             if dopt Opt_ConvertToZipCfgAndBack dflags
-             then mapM (testCmmConversion dflags) cmms
-             else return cmms
-         ------------  Optionally convert to CPS --------------
-         cmms <-
-             if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
-                dopt Opt_RunCPSZ dflags
-             then cmmCPS dflags cmms
-             else return cmms
+         --- Optionally run experimental Cmm transformations ---
+         cmms <- optionallyConvertAndOrCPS dflags cmms
+                 -- ^ unless certain dflags are on, the identity function
          ------------------  Code output -----------------------
          rawcmms <- cmmToRawCmm cmms
          (_stub_h_exists, stub_c_exists)
@@ -717,10 +699,9 @@ hscCmmFile dflags filename = do
   case maybe_cmm of
     Nothing -> return False
     Just cmm -> do
-        cmm <- testCmmConversion dflags cmm
-        --continuationC <- cmmCPS dflags cmm >>= cmmToRawCmm
-        continuationC <- cmmToRawCmm [cmm]
-       codeOutput dflags no_mod no_loc NoStubs [] continuationC
+        cmms <- optionallyConvertAndOrCPS dflags [cmm]
+        rawCmms <- cmmToRawCmm cmms
+       codeOutput dflags no_mod no_loc NoStubs [] rawCmms
        return True
   where
        no_mod = panic "hscCmmFile: no_mod"
@@ -728,6 +709,20 @@ hscCmmFile dflags filename = do
                               ml_hi_file  = panic "hscCmmFile: no hi file",
                               ml_obj_file = panic "hscCmmFile: no obj file" }
 
+optionallyConvertAndOrCPS :: DynFlags -> [Cmm] -> IO [Cmm]
+optionallyConvertAndOrCPS dflags cmms =
+    do   --------  Optionally convert to and from zipper ------
+       cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
+               then mapM (testCmmConversion dflags) cmms
+               else return cmms
+         ---------  Optionally convert to CPS (MDA) -----------
+       cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
+                  dopt Opt_RunCPSZ dflags
+               then cmmCPS dflags cmms
+               else return cmms
+       return cmms
+
+
 testCmmConversion :: DynFlags -> Cmm -> IO Cmm
 testCmmConversion dflags cmm =
     do showPass dflags "CmmToCmm"