X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=12b12e350c6b95bd623fac0a5e4d84f7573e07e8;hb=527f52a72acf214994921ad36de92f934e9632da;hp=e95be761b94c67f3bd311053691d7cb0d98ce9b2;hpb=1dfe7f1ee44b6ae59e072eec720984b136fc1dc5;p=ghc-hetmet.git

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index e95be76..12b12e3 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -17,6 +17,9 @@ 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)
@@ -313,7 +316,8 @@ data HscStatus' a
 -- 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.
 type HscStatus         = HscStatus' ()
-type InteractiveStatus = HscStatus' (CompiledByteCode, ModBreaks)
+type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
+    -- INVARIANT: result is @Nothing@ <=> input was a boot file
 
 type OneShotResult     = HscStatus
 type BatchResult       = (HscStatus, ModIface, ModDetails)
@@ -346,6 +350,9 @@ data HsCompiler a
     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,
@@ -390,12 +397,18 @@ genericHscRecompile compiler mod_summary mb_old_hash
       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 compiler tc_result mod_summary mb_old_hash
-        _other     -> do
-            guts <- hscDesugar mod_summary tc_result
-            hscGenOutput compiler 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
@@ -423,6 +436,8 @@ hscOneShotCompiler =
 
   , 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
@@ -455,6 +470,8 @@ hscBatchCompiler =
 
   , hscRecompile = genericHscRecompile hscBatchCompiler
 
+  , hscBackend = genericHscBackend hscBatchCompiler
+
   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
        (iface, changed, details)
            <- hscSimpleIface tc_result mb_old_iface
@@ -487,7 +504,11 @@ hscInteractiveCompiler =
 
   , hscRecompile = genericHscRecompile hscInteractiveCompiler
 
-  , hscGenBootOutput = \_ _ _ -> panic "hscCompileInteractive: HsBootFile"
+  , hscBackend = genericHscBackend hscInteractiveCompiler
+
+  , 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
@@ -517,12 +538,15 @@ hscNothingCompiler =
           panic "hscCompileNothing: cannot do external core"
         _otherwise -> do
           tc_result <- hscFileFrontEnd mod_summary
-          hscGenBootOutput hscNothingCompiler tc_result mod_summary mb_old_hash
+          hscBackend hscNothingCompiler tc_result mod_summary mb_old_hash
 
-  , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
+  , 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"
   }
@@ -693,10 +717,11 @@ hscGenHardCode cgguts mod_summary
                                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
@@ -733,7 +758,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
@@ -786,10 +812,8 @@ tryNewCodeGen hsc_env this_mod data_tycons imported_mods
 	; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
 		-- Control flow optimisation, again
 
-	; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprCmms prog)
-
 	; let prog' = map cmmOfZgraph prog
-	; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr prog')
+	; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
 	; return prog' }
 
 
@@ -828,7 +852,6 @@ testCmmConversion hsc_env 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