X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=6a5552f5dfb726c2367142faa5f47973f9b6b818;hb=4063e1d8501b38b5ed8d620dcd8e27adee0e7091;hp=37c65bbf0f083e5baae0f96cb339234ea575930a;hpb=731afdc81fb55e4cc0989443bbc6aa2770d4a26b;p=ghc-hetmet.git

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 37c65bb..6a5552f 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -109,7 +109,8 @@ import CoreToStg	( coreToStg )
 import qualified StgCmm	( codeGen )
 import StgSyn
 import CostCentre
-import TyCon		( TyCon, isDataTyCon )
+import ProfInit
+import TyCon            ( TyCon, isDataTyCon )
 import Name		( Name, NamedThing(..) )
 import SimplStg		( stg2stg )
 import CodeGen		( codeGen )
@@ -460,7 +461,8 @@ error. This is the only thing that isn't caught by the type-system.
 data HscStatus' a
     = HscNoRecomp
     | HscRecomp
-       Bool -- Has stub files.  This is a hack. We can't compile C files here
+       (Maybe FilePath)
+            -- Has stub files.  This is a hack. We can't compile C files here
             -- since it's done in DriverPipeline. For now we just return True
             -- if we want the caller to compile them for us.
        a
@@ -596,14 +598,14 @@ hscOneShotCompiler =
   , hscBackend = \ tc_result mod_summary mb_old_hash -> do
        dflags <- getDynFlags
        case hscTarget dflags of
-         HscNothing -> return (HscRecomp False ())
+         HscNothing -> return (HscRecomp Nothing ())
          _otherw    -> genericHscBackend hscOneShotCompiler
                                          tc_result mod_summary mb_old_hash
 
   , 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 ())
+       return (HscRecomp Nothing ())
 
   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
        guts <- hscSimplify' guts0
@@ -649,7 +651,7 @@ 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)
+       return (HscRecomp Nothing (), iface, details)
 
   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
        guts <- hscSimplify' guts0
@@ -681,7 +683,7 @@ 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)
+       return (HscRecomp Nothing Nothing, iface, details)
 
   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
        guts <- hscSimplify' guts0
@@ -710,7 +712,7 @@ hscNothingCompiler =
   , hscBackend = \tc_result _mod_summary mb_old_iface -> do
        handleWarnings
        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
-       return (HscRecomp False (), iface, details)
+       return (HscRecomp Nothing (), iface, details)
 
   , hscGenBootOutput = \_ _ _ ->
         panic "hscCompileNothing: hscGenBootOutput should not be called"
@@ -852,7 +854,7 @@ hscWriteIface iface no_change mod_summary
 
 -- | Compile to hard-code.
 hscGenHardCode :: CgGuts -> ModSummary
-               -> Hsc Bool -- ^ @True@ <=> stub.c exists
+               -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
 hscGenHardCode cgguts mod_summary
   = do
     hsc_env <- getHscEnv
@@ -862,8 +864,7 @@ hscGenHardCode cgguts mod_summary
                      cg_module   = this_mod,
                      cg_binds    = core_binds,
                      cg_tycons   = tycons,
-                     cg_dir_imps = dir_imps,
-                     cg_foreign  = foreign_stubs,
+                     cg_foreign  = foreign_stubs0,
                      cg_dep_pkgs = dependencies,
                      cg_hpc_info = hpc_info } = cgguts
              dflags = hsc_dflags hsc_env
@@ -882,16 +883,19 @@ hscGenHardCode cgguts mod_summary
              <- {-# SCC "CoreToStg" #-}
                 myCoreToStg dflags this_mod prepd_binds	
 
+         let prof_init = profilingInitCode this_mod cost_centre_info
+             foreign_stubs = foreign_stubs0 `appendStubC` prof_init
+
          ------------------  Code generation ------------------
          
          cmms <- if dopt Opt_TryNewCodeGen dflags
                  then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
-                                 dir_imps cost_centre_info
+                                 cost_centre_info
                                  stg_binds hpc_info
                          return cmms
                  else {-# SCC "CodeGen" #-}
                        codeGen dflags this_mod data_tycons
-                               dir_imps cost_centre_info
+                               cost_centre_info
                                stg_binds hpc_info
 
          --- Optionally run experimental Cmm transformations ---
@@ -962,15 +966,15 @@ hscCompileCmmFile hsc_env filename
 
 -------------------- Stuff for new code gen ---------------------
 
-tryNewCodeGen	:: HscEnv -> Module -> [TyCon] -> [Module]
+tryNewCodeGen   :: HscEnv -> Module -> [TyCon]
 		-> CollectedCCs
 		-> [(StgBinding,[(Id,[Id])])]
 		-> HpcInfo
 		-> IO [Cmm]
-tryNewCodeGen hsc_env this_mod data_tycons imported_mods 
+tryNewCodeGen hsc_env this_mod data_tycons
 	      cost_centre_info stg_binds hpc_info =
   do	{ let dflags = hsc_dflags hsc_env
-        ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods 
+        ; prog <- StgCmm.codeGen dflags this_mod data_tycons
 		 	 cost_centre_info stg_binds hpc_info
 	; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" 
 		(pprCmms prog)
@@ -1128,12 +1132,11 @@ hscTcExpr	-- Typecheck an expression (but don't run it)
 hscTcExpr hsc_env expr = runHsc hsc_env $ do
     maybe_stmt <- hscParseStmt expr
     case maybe_stmt of
-      Just (L _ (ExprStmt expr _ _)) ->
-          ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
-      _ -> 
-          liftIO $ throwIO $ mkSrcErr $ unitBag $ 
-              mkPlainErrMsg noSrcSpan
-                            (text "not an expression:" <+> quotes (text expr))
+        Just (L _ (ExprStmt expr _ _ _)) ->
+            ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
+        _ ->
+            liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan
+                (text "not an expression:" <+> quotes (text expr))
 
 -- | Find the kind of a type
 hscKcType