summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/CodeOutput.lhs57
-rw-r--r--compiler/main/DynFlags.hs4
-rw-r--r--compiler/main/HscMain.hs75
-rw-r--r--compiler/main/HscTypes.lhs6
4 files changed, 93 insertions, 49 deletions
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index 24906671cd..e92eb4f34c 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -15,22 +15,22 @@ import UniqSupply ( mkSplitUniqSupply )
import Finder ( mkStubPaths )
import PprC ( writeCs )
-import CmmLint ( cmmLint )
+import OldCmmLint ( cmmLint )
import Packages
import OldCmm ( RawCmmGroup )
import HscTypes
import DynFlags
import Config
import SysTools
+import Stream (Stream)
+import qualified Stream
import ErrUtils
import Outputable
import Module
-import Maybes ( firstJusts )
import SrcLoc
import Control.Exception
-import Control.Monad
import System.Directory
import System.FilePath
import System.IO
@@ -48,19 +48,26 @@ codeOutput :: DynFlags
-> ModLocation
-> ForeignStubs
-> [PackageId]
- -> [RawCmmGroup] -- Compiled C--
+ -> Stream IO RawCmmGroup () -- Compiled C--
-> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})
-codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
+codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream
=
- do { when (dopt Opt_DoCmmLinting dflags) $ do
+ do {
+ -- Lint each CmmGroup as it goes past
+ ; let linted_cmm_stream =
+ if dopt Opt_DoCmmLinting dflags
+ then Stream.mapM do_lint cmm_stream
+ else cmm_stream
+
+ do_lint cmm = do
{ showPass dflags "CmmLint"
- ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
- ; case firstJusts lints of
+ ; case cmmLint (targetPlatform dflags) cmm of
Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err
; ghcExit dflags 1
}
Nothing -> return ()
+ ; return cmm
}
; showPass dflags "CodeOutput"
@@ -68,9 +75,9 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
; case hscTarget dflags of {
HscInterpreted -> return ();
- HscAsm -> outputAsm dflags filenm flat_abstractC;
- HscC -> outputC dflags filenm flat_abstractC pkg_deps;
- HscLlvm -> outputLlvm dflags filenm flat_abstractC;
+ HscAsm -> outputAsm dflags filenm linted_cmm_stream;
+ HscC -> outputC dflags filenm linted_cmm_stream pkg_deps;
+ HscLlvm -> outputLlvm dflags filenm linted_cmm_stream;
HscNothing -> panic "codeOutput: HscNothing"
}
; return stubs_exist
@@ -90,12 +97,16 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
\begin{code}
outputC :: DynFlags
-> FilePath
- -> [RawCmmGroup]
+ -> Stream IO RawCmmGroup ()
-> [PackageId]
-> IO ()
-outputC dflags filenm flat_absC packages
+outputC dflags filenm cmm_stream packages
= do
+ -- ToDo: make the C backend consume the C-- incrementally, by
+ -- pushing the cmm_stream inside (c.f. nativeCodeGen)
+ rawcmms <- Stream.collect cmm_stream
+
-- figure out which header files to #include in the generated .hc file:
--
-- * extra_includes from packages
@@ -117,7 +128,7 @@ outputC dflags filenm flat_absC packages
doOutput filenm $ \ h -> do
hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
hPutStr h cc_injects
- writeCs dflags h flat_absC
+ writeCs dflags h rawcmms
\end{code}
@@ -128,14 +139,14 @@ outputC dflags filenm flat_absC packages
%************************************************************************
\begin{code}
-outputAsm :: DynFlags -> FilePath -> [RawCmmGroup] -> IO ()
-outputAsm dflags filenm flat_absC
+outputAsm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
+outputAsm dflags filenm cmm_stream
| cGhcWithNativeCodeGen == "YES"
= do ncg_uniqs <- mkSplitUniqSupply 'n'
{-# SCC "OutputAsm" #-} doOutput filenm $
\f -> {-# SCC "NativeCodeGen" #-}
- nativeCodeGen dflags f ncg_uniqs flat_absC
+ nativeCodeGen dflags f ncg_uniqs cmm_stream
| otherwise
= panic "This compiler was built without a native code generator"
@@ -149,12 +160,17 @@ outputAsm dflags filenm flat_absC
%************************************************************************
\begin{code}
-outputLlvm :: DynFlags -> FilePath -> [RawCmmGroup] -> IO ()
-outputLlvm dflags filenm flat_absC
+outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
+outputLlvm dflags filenm cmm_stream
= do ncg_uniqs <- mkSplitUniqSupply 'n'
+
+ -- ToDo: make the LLVM backend consume the C-- incrementally,
+ -- by pushing the cmm_stream inside (c.f. nativeCodeGen)
+ rawcmms <- Stream.collect cmm_stream
+
{-# SCC "llvm_output" #-} doOutput filenm $
\f -> {-# SCC "llvm_CodeGen" #-}
- llvmCodeGen dflags f ncg_uniqs flat_absC
+ llvmCodeGen dflags f ncg_uniqs rawcmms
\end{code}
@@ -240,4 +256,3 @@ outputForeignStubs_help fname doc_str header footer
= do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
return True
\end{code}
-
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 53aa39f04e..60b6e82bb7 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -164,9 +164,9 @@ data DynFlag
= Opt_D_dump_cmm
| Opt_D_dump_raw_cmm
| Opt_D_dump_cmmz
- | Opt_D_dump_cmmz_pretty
-- All of the cmmz subflags (there are a lot!) Automatically
-- enabled if you run -ddump-cmmz
+ | Opt_D_dump_cmmz_cfg
| Opt_D_dump_cmmz_cbe
| Opt_D_dump_cmmz_proc
| Opt_D_dump_cmmz_spills
@@ -1675,7 +1675,7 @@ dynamic_flags = [
, Flag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm)
, Flag "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm)
, Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz)
- , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty)
+ , Flag "ddump-cmmz-cfg" (setDumpFlag Opt_D_dump_cmmz_cbe)
, Flag "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe)
, Flag "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills)
, Flag "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc)
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 562332d52a..0b03e83029 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -119,13 +119,12 @@ import TyCon
import Name
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
-import OldCmm as Old ( CmmGroup )
-import PprCmm ( pprCmms )
+import qualified OldCmm as Old
+import qualified Cmm as New
import CmmParse ( parseCmmFile )
import CmmBuildInfoTables
import CmmPipeline
import CmmInfo
-import OptimizationFuel ( initOptFuelState )
import CmmCvt
import CodeOutput
import NameEnv ( emptyNameEnv )
@@ -147,6 +146,9 @@ import UniqFM ( emptyUFM )
import UniqSupply ( initUs_ )
import Bag
import Exception
+import qualified Stream
+import Stream (Stream)
+
import Util
import Data.List
@@ -172,7 +174,6 @@ newHscEnv dflags = do
nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyUFM
mlc_var <- newIORef emptyModuleEnv
- optFuel <- initOptFuelState
return HscEnv { hsc_dflags = dflags,
hsc_targets = [],
hsc_mod_graph = [],
@@ -182,7 +183,6 @@ newHscEnv dflags = do
hsc_NC = nc_var,
hsc_FC = fc_var,
hsc_MLC = mlc_var,
- hsc_OptFuel = optFuel,
hsc_type_env_var = Nothing }
@@ -1276,20 +1276,27 @@ hscGenHardCode cgguts mod_summary = do
cost_centre_info
stg_binds hpc_info
else {-# SCC "CodeGen" #-}
- codeGen dflags this_mod data_tycons
- cost_centre_info
- stg_binds hpc_info
+ return (codeGen dflags this_mod data_tycons
+ cost_centre_info
+ stg_binds hpc_info)
+
------------------ Code output -----------------------
- rawcmms <- {-# SCC "cmmToRawCmm" #-}
+ rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
cmmToRawCmm platform cmms
- dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms)
+
+ let dump a = do dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm"
+ (ppr a)
+ return a
+ rawcmms1 = Stream.mapM dump rawcmms0
+
(_stub_h_exists, stub_c_exists)
<- {-# SCC "codeOutput" #-}
codeOutput dflags this_mod location foreign_stubs
- dependencies rawcmms
+ dependencies rawcmms1
return stub_c_exists
+
hscInteractive :: (ModIface, ModDetails, CgGuts)
-> ModSummary
-> Hsc (InteractiveStatus, ModIface, ModDetails)
@@ -1335,7 +1342,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
cmm <- ioMsgMaybe $ parseCmmFile dflags filename
liftIO $ do
- rawCmms <- cmmToRawCmm (targetPlatform dflags) [cmm]
+ rawCmms <- cmmToRawCmm (targetPlatform dflags) (Stream.yield cmm)
_ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
return ()
where
@@ -1350,24 +1357,52 @@ tryNewCodeGen :: HscEnv -> Module -> [TyCon]
-> CollectedCCs
-> [(StgBinding,[(Id,[Id])])]
-> HpcInfo
- -> IO [Old.CmmGroup]
+ -> IO (Stream IO Old.CmmGroup ())
+ -- Note we produce a 'Stream' of CmmGroups, so that the
+ -- backend can be run incrementally. Otherwise it generates all
+ -- the C-- up front, which has a significant space cost.
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
+
+ let cmm_stream :: Stream IO New.CmmGroup ()
+ cmm_stream = {-# SCC "StgCmm" #-}
+ 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)
+
+ -- codegen consumes a stream of CmmGroup, and produces a new
+ -- stream of CmmGroup (not necessarily synchronised: one
+ -- CmmGroup on input may produce many CmmGroups on output due
+ -- to proc-point splitting).
+
+ let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz
+ "Cmm produced by new codegen" (ppr a)
+ return a
+
+ ppr_stream1 = Stream.mapM dump1 cmm_stream
-- 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 initTopSRT = initUs_ us emptySRT
- (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog
- let prog' = map cmmOfZgraph (srtToData topSRT : prog)
- dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
- return prog'
+ let run_pipeline topSRT cmmgroup = do
+ (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup
+ return (topSRT,cmmOfZgraph cmmgroup)
+
+ let pipeline_stream = {-# SCC "cmmPipeline" #-} do
+ topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
+ Stream.yield (cmmOfZgraph (srtToData topSRT))
+
+ let
+ dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a
+ return a
+
+ ppr_stream2 = Stream.mapM dump2 pipeline_stream
+
+ return ppr_stream2
+
+
myCoreToStg :: DynFlags -> Module -> CoreProgram
-> IO ( [(StgBinding,[(Id,[Id])])] -- output program
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 156f081d3e..adaa9a3171 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -142,7 +142,6 @@ import Packages hiding ( Version(..) )
import DynFlags
import DriverPhases
import BasicTypes
-import OptimizationFuel ( OptFuelState )
import IfaceSyn
import CoreSyn ( CoreRule, CoreVect )
import Maybes
@@ -318,11 +317,6 @@ data HscEnv
-- ^ This caches the location of modules, so we don't have to
-- search the filesystem multiple times. See also 'hsc_FC'.
- hsc_OptFuel :: OptFuelState,
- -- ^ Settings to control the use of \"optimization fuel\":
- -- by limiting the number of transformations,
- -- we can use binary search to help find compiler bugs.
-
hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
-- ^ Used for one-shot compilation only, to initialise
-- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for
View Lorry Controller Status