Fix a bug to do with recursive modules in one-shot mode

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

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 9ded3f5..604f7a7 100644 (file)
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -84,6 +84,7 @@ import CmmParse               ( parseCmmFile )
 import CmmCPS
 import CmmCPSZ
 import CmmInfo
+import OptimizationFuel ( initOptFuelState )
 import CmmCvt
 import CmmTx
 import CmmContFlowOpt
@@ -123,16 +124,19 @@ newHscEnv dflags
        ; us      <- mkSplitUniqSupply 'r'
        ; nc_var  <- newIORef (initNameCache us knownKeyNames)
        ; fc_var  <- newIORef emptyUFM
-       ; mlc_var  <- newIORef emptyModuleEnv
+       ; mlc_var <- newIORef emptyModuleEnv
+        ; optFuel <- initOptFuelState
        ; return (HscEnv { hsc_dflags = dflags,
                           hsc_targets = [],
                           hsc_mod_graph = [],
-                          hsc_IC     = emptyInteractiveContext,
-                          hsc_HPT    = emptyHomePackageTable,
-                          hsc_EPS    = eps_var,
-                          hsc_NC     = nc_var,
-                          hsc_FC     = fc_var,
-                          hsc_MLC    = mlc_var,
+                          hsc_IC      = emptyInteractiveContext,
+                          hsc_HPT     = emptyHomePackageTable,
+                          hsc_EPS     = eps_var,
+                          hsc_NC      = nc_var,
+                          hsc_FC      = fc_var,
+                          hsc_MLC     = mlc_var,
+                          hsc_OptFuel = optFuel,
+                           hsc_type_env_var = Nothing,
                            hsc_global_rdr_env = emptyGlobalRdrEnv,
                            hsc_global_type_env = emptyNameEnv } ) }
                        
@@ -332,7 +336,19 @@ type Compiler result =  HscEnv
 
 -- Compile Haskell, boot and extCore in OneShot mode.
 hscCompileOneShot :: Compiler HscStatus
-hscCompileOneShot
+hscCompileOneShot 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 <- newIORef emptyNameEnv
+    let 
+       mod = ms_mod mod_summary
+       hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
+    ---
+    hscCompilerOneShot' hsc_env' mod_summary src_changed mb_old_iface mb_i_of_n
+
+hscCompilerOneShot' :: Compiler HscStatus
+hscCompilerOneShot'
    = hscCompiler norecompOneShot oneShotMsg (genComp backend boot_backend)
    where
      backend inp  = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscOneShot
@@ -657,7 +673,7 @@ hscCompile cgguts
                               dir_imps cost_centre_info
                               stg_binds hpc_info
          --- Optionally run experimental Cmm transformations ---
-         cmms <- optionallyConvertAndOrCPS dflags cmms
+         cmms <- optionallyConvertAndOrCPS hsc_env cmms
                  -- ^ unless certain dflags are on, the identity function
          ------------------  Code output -----------------------
          rawcmms <- cmmToRawCmm cmms
@@ -703,13 +719,14 @@ hscInteractive _ = panic "GHC not compiled with interpreter"
 
 ------------------------------
 
-hscCmmFile :: DynFlags -> FilePath -> IO Bool
-hscCmmFile dflags filename = do
+hscCmmFile :: HscEnv -> FilePath -> IO Bool
+hscCmmFile hsc_env filename = do
+  dflags <- return $ hsc_dflags hsc_env
   maybe_cmm <- parseCmmFile dflags filename
   case maybe_cmm of
     Nothing -> return False
     Just cmm -> do
-        cmms <- optionallyConvertAndOrCPS dflags [cmm]
+        cmms <- optionallyConvertAndOrCPS hsc_env [cmm]
         rawCmms <- cmmToRawCmm cmms
        codeOutput dflags no_mod no_loc NoStubs [] rawCmms
        return True
@@ -719,11 +736,12 @@ 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 ------
+optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
+optionallyConvertAndOrCPS hsc_env cmms =
+    do let dflags = hsc_dflags hsc_env
+        --------  Optionally convert to and from zipper ------
        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
-               then mapM (testCmmConversion dflags) cmms
+               then mapM (testCmmConversion hsc_env) cmms
                else return cmms
          ---------  Optionally convert to CPS (MDA) -----------
        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
@@ -733,9 +751,10 @@ optionallyConvertAndOrCPS dflags cmms =
        return cmms
 
 
-testCmmConversion :: DynFlags -> Cmm -> IO Cmm
-testCmmConversion dflags cmm =
-    do showPass dflags "CmmToCmm"
+testCmmConversion :: HscEnv -> Cmm -> IO Cmm
+testCmmConversion hsc_env cmm =
+    do let dflags = hsc_dflags hsc_env
+       showPass dflags "CmmToCmm"
        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
        us <- mkSplitUniqSupply 'C'
@@ -743,7 +762,7 @@ testCmmConversion dflags cmm =
        let cvtm = do g <- cmmToZgraph cmm
                      return $ cfopts g
        let zgraph = initUs_ us cvtm
-       cps_zgraph <- protoCmmCPSZ dflags zgraph
+       cps_zgraph <- protoCmmCPSZ hsc_env 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"