Rename CmmCPS to CmmPipeline.

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

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 841125a..a120926 100644 (file)
--- 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 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 )
 import Name            ( Name, NamedThing(..) )
 import SimplStg                ( stg2stg )
 import CodeGen         ( codeGen )

@@ -117,7 +118,7 @@ import OldCmm           ( Cmm )
 import PprCmm          ( pprCmms )
 import CmmParse                ( parseCmmFile )
 import CmmBuildInfoTables
 import PprCmm          ( pprCmms )
 import CmmParse                ( parseCmmFile )
 import CmmBuildInfoTables

-import CmmCPS
+import CmmPipeline

 import CmmInfo
 import OptimizationFuel ( initOptFuelState )
 import CmmCvt
 import CmmInfo
 import OptimizationFuel ( initOptFuelState )
 import CmmCvt

@@ -339,7 +340,7 @@ hscParse' mod_summary
             Just b  -> return b
             Nothing -> liftIO $ hGetStringBuffer src_filename
 
             Just b  -> return b
             Nothing -> liftIO $ hGetStringBuffer src_filename
 

-   let loc  = mkSrcLoc (mkFastString src_filename) 1 1
+   let loc  = mkRealSrcLoc (mkFastString src_filename) 1 1

 
    case unP parseModule (mkPState dflags buf loc) of
      PFailed span err ->
 
    case unP parseModule (mkPState dflags buf loc) of
      PFailed span err ->

@@ -429,7 +430,7 @@ makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
 
 
 It's the task of the compilation proper to compile Haskell, hs-boot and
 
 
 It's the task of the compilation proper to compile Haskell, hs-boot and

-core files to either byte-code, hard-code (C, asm, Java, ect) or to
+core files to either byte-code, hard-code (C, asm, LLVM, ect) or to

 nothing at all (the module is still parsed and type-checked. This
 feature is mostly used by IDE's and the likes).
 Compilation can happen in either 'one-shot', 'batch', 'nothing',
 nothing at all (the module is still parsed and type-checked. This
 feature is mostly used by IDE's and the likes).
 Compilation can happen in either 'one-shot', 'batch', 'nothing',

@@ -863,8 +864,7 @@ hscGenHardCode cgguts mod_summary
                      cg_module   = this_mod,
                      cg_binds    = core_binds,
                      cg_tycons   = tycons,
                      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
                      cg_dep_pkgs = dependencies,
                      cg_hpc_info = hpc_info } = cgguts
              dflags = hsc_dflags hsc_env

@@ -883,16 +883,19 @@ hscGenHardCode cgguts mod_summary
              <- {-# SCC "CoreToStg" #-}
                 myCoreToStg dflags this_mod prepd_binds        
 
              <- {-# 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
          ------------------  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
                                  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 ---
                                stg_binds hpc_info
 
          --- Optionally run experimental Cmm transformations ---

@@ -963,35 +966,28 @@ hscCompileCmmFile hsc_env filename
 
 -------------------- Stuff for new code gen ---------------------
 
 
 -------------------- 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 =
-  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 runCmmContFlowOpts prog
-               -- Control flow optimisation
+tryNewCodeGen   :: HscEnv -> Module -> [TyCon]
+                -> CollectedCCs
+                -> [(StgBinding,[(Id,[Id])])]
+                -> HpcInfo
+                -> IO [Cmm]
+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
+                         cost_centre_info stg_binds hpc_info
+        ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" 
+                (pprCmms prog)

 
         -- We are building a single SRT for the entire module, so
         -- we must thread it through all the procedures as we cps-convert them.
         ; us <- mkSplitUniqSupply 'S'
 
         -- We are building a single SRT for the entire module, so
         -- we must thread it through all the procedures as we cps-convert them.
         ; us <- mkSplitUniqSupply 'S'

-        ; let topSRT = initUs_ us emptySRT
-       ; (topSRT, prog) <- foldM (protoCmmCPS hsc_env) (topSRT, []) prog
-               -- The main CPS conversion
-
-       ; prog <- return $ map runCmmContFlowOpts (srtToData topSRT : prog)
-               -- Control flow optimisation, again
+        ; let initTopSRT = initUs_ us emptySRT
+        ; (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog

 
 

-       ; let prog' = map cmmOfZgraph prog
-       ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
-       ; return prog' }
+        ; let prog' = map cmmOfZgraph (srtToData topSRT : prog)
+        ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
+        ; return prog' }

 
 
 optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
 
 
 optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]

@@ -1011,15 +1007,17 @@ testCmmConversion hsc_env cmm =
        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
        us <- mkSplitUniqSupply 'C'
        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
        us <- mkSplitUniqSupply 'C'

-       let cvtm = runCmmContFlowOpts `liftM` cmmToZgraph cmm
-       let zgraph = initUs_ us cvtm
-       us <- mkSplitUniqSupply 'S'
-       let topSRT = initUs_ us emptySRT
-       (_, [cps_zgraph]) <- protoCmmCPS hsc_env (topSRT, []) zgraph
-       let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
+       let zgraph = initUs_ us (cmmToZgraph cmm)
+       chosen_graph <-
+        if dopt Opt_RunCPSZ dflags
+            then do us <- mkSplitUniqSupply 'S'
+                    let topSRT = initUs_ us emptySRT
+                    (_, [zgraph]) <- cmmPipeline hsc_env (topSRT, []) zgraph
+                    return zgraph
+            else return (runCmmContFlowOpts zgraph)

        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
        showPass dflags "Convert from Z back to Cmm"
        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
        showPass dflags "Convert from Z back to Cmm"

-       let cvt = cmmOfZgraph $ runCmmContFlowOpts $ chosen_graph
+       let cvt = cmmOfZgraph chosen_graph

        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
        return cvt
 
        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
        return cvt
 

@@ -1129,12 +1127,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
 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
 
 -- | Find the kind of a type
 hscKcType

@@ -1184,7 +1181,7 @@ hscParseThingWithLocation source linenumber parser str
       liftIO $ showPass dflags "Parser"
 
       let buf = stringToStringBuffer str
       liftIO $ showPass dflags "Parser"
 
       let buf = stringToStringBuffer str

-          loc  = mkSrcLoc (fsLit source) linenumber 1
+          loc  = mkRealSrcLoc (fsLit source) linenumber 1

 
       case unP parser (mkPState dflags buf loc) of
 
 
       case unP parser (mkPState dflags buf loc) of