\section[GHC_Main]{Main driver for Glasgow Haskell compiler}
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module HscMain
( newHscEnv, hscCmmFile
, hscFileCheck
#include "HsVersions.h"
#ifdef GHCI
-import HsSyn ( Stmt(..), LStmt, LHsType )
+import HsSyn ( StmtLR(..), LStmt, LHsType )
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
-import CoreSyn ( CoreExpr )
import CoreTidy ( tidyExpr )
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
#endif
import Var ( Id )
-import Module ( emptyModuleEnv, ModLocation(..) )
+import Module ( emptyModuleEnv, ModLocation(..), Module )
import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv )
import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc,
HaddockModInfo )
import PrelInfo ( wiredInThings, basicKnownKeyNames )
import MkIface ( checkOldIface, mkIface, writeIfaceFile )
import Desugar ( deSugar )
-import Flattening ( flatten )
import SimplCore ( core2core )
import TidyPgm ( tidyProgram, mkBootModDetails )
import CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
+import StgSyn
+import CostCentre
import TyCon ( isDataTyCon )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
+import Cmm ( Cmm )
import CmmParse ( parseCmmFile )
import CmmCPS
+import CmmCPSZ
import CmmInfo
+import CmmCvt
+import CmmTx
+import CmmContFlowOpt
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
import ParserCoreUtils
import FastString
import UniqFM ( emptyUFM )
+import UniqSupply ( initUs_ )
import Bag ( unitBag )
import Control.Monad
= InteractiveNoRecomp
| InteractiveRecomp Bool -- Same as HscStatus
CompiledByteCode
+ ModBreaks
-- I want Control.Monad.State! --Lemmih 03/07/2006
return (a,s)
type NoRecomp result = ModIface -> Comp result
-type FrontEnd core = Comp (Maybe core)
-- FIXME: The old interface and module index are only using in 'batch' and
-- 'interactive' mode. They should be removed from 'oneshot' mode.
-> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs)
-> IO (Maybe result)
-
--- This functions checks if recompilation is necessary and
--- then combines the FrontEnd and BackEnd to a working compiler.
-hscMkCompiler :: NoRecomp result -- What to do when recompilation isn't required.
- -> (Maybe (Int,Int) -> Bool -> Comp ())
- -> FrontEnd core
- -> (core -> Comp result) -- Backend.
- -> Compiler result
-hscMkCompiler norecomp messenger frontend backend
- hsc_env mod_summary source_unchanged
- mbOldIface mbModIndex
- = flip evalComp (CompState hsc_env mod_summary mbOldIface) $
- do (recomp_reqd, mbCheckedIface)
- <- {-# SCC "checkOldIface" #-}
- liftIO $ checkOldIface hsc_env mod_summary
- source_unchanged mbOldIface
- -- save the interface that comes back from checkOldIface.
- -- In one-shot mode we don't have the old iface until this
- -- point, when checkOldIface reads it from the disk.
- modify (\s -> s{ compOldIface = mbCheckedIface })
- case mbCheckedIface of
- Just iface | not recomp_reqd
- -> do messenger mbModIndex False
- result <- norecomp iface
- return (Just result)
- _otherwise
- -> do messenger mbModIndex True
- mbCore <- frontend
- case mbCore of
- Nothing
- -> return Nothing
- Just core
- -> do result <- backend core
- return (Just result)
-
--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------
-> (ModGuts -> Comp result) -- Compile normal file
-> (ModGuts -> Comp result) -- Compile boot file
-> Compiler result
-hscCompiler norecomp msg nonBootComp bootComp hsc_env mod_summary =
- hscMkCompiler norecomp msg frontend backend hsc_env mod_summary
+hscCompiler norecomp messenger nonBootComp bootComp hsc_env mod_summary
+ source_unchanged mbOldIface mbModIndex
+ = flip evalComp (CompState hsc_env mod_summary mbOldIface) $
+ do (recomp_reqd, mbCheckedIface)
+ <- {-# SCC "checkOldIface" #-}
+ liftIO $ checkOldIface hsc_env mod_summary
+ source_unchanged mbOldIface
+ -- save the interface that comes back from checkOldIface.
+ -- In one-shot mode we don't have the old iface until this
+ -- point, when checkOldIface reads it from the disk.
+ modify (\s -> s{ compOldIface = mbCheckedIface })
+ case mbCheckedIface of
+ Just iface | not recomp_reqd
+ -> do messenger mbModIndex False
+ result <- norecomp iface
+ return (Just result)
+ _otherwise
+ -> do messenger mbModIndex True
+ mb_modguts <- frontend
+ case mb_modguts of
+ Nothing
+ -> return Nothing
+ Just core
+ -> do result <- backend core
+ return (Just result)
where
+ frontend :: Comp (Maybe ModGuts) -- Front end
+ -- backend :: (ModGuts -> Comp result) -- Backend.
(frontend,backend)
= case ms_hsc_src mod_summary of
ExtCoreFile -> (hscCoreFrontEnd, nonBootComp)
--------------------------------------------------------------
norecompOneShot :: NoRecomp HscStatus
-norecompOneShot old_iface
+norecompOneShot _old_iface
= do hsc_env <- gets compHscEnv
liftIO $ do
dumpIfaceStats hsc_env
norecompInteractive = norecompWorker InteractiveNoRecomp True
norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails)
-norecompWorker a isInterp old_iface
+norecompWorker a _isInterp old_iface
= do hsc_env <- gets compHscEnv
- mod_summary <- gets compModSummary
+ _mod_summary <- gets compModSummary
liftIO $ do
new_details <- {-# SCC "tcRnIface" #-}
initIfaceCheck hsc_env $
-- FrontEnds
--------------------------------------------------------------
-hscCoreFrontEnd :: FrontEnd ModGuts
+hscCoreFrontEnd :: Comp (Maybe ModGuts)
hscCoreFrontEnd =
do hsc_env <- gets compHscEnv
mod_summary <- gets compModSummary
Just mod_guts -> return (Just mod_guts) -- No desugaring to do!
-hscFileFrontEnd :: FrontEnd ModGuts
+hscFileFrontEnd :: Comp (Maybe ModGuts)
hscFileFrontEnd =
do hsc_env <- gets compHscEnv
mod_summary <- gets compModSummary
hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts)
hscSimpleIface ds_result
= do hsc_env <- gets compHscEnv
- mod_summary <- gets compModSummary
+ _mod_summary <- gets compModSummary
maybe_old_iface <- gets compOldIface
liftIO $ do
details <- mkBootModDetails hsc_env ds_result
hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface simpl_result
= do hsc_env <- gets compHscEnv
- mod_summary <- gets compModSummary
+ _mod_summary <- gets compModSummary
maybe_old_iface <- gets compOldIface
liftIO $ do
-------------------
return (iface, details, a)
hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
-hscIgnoreIface (iface, no_change, details, a)
+hscIgnoreIface (iface, _no_change, details, a)
= return (iface, details, a)
-- Don't output any code.
hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails)
-hscNothing (iface, details, a)
+hscNothing (iface, details, _)
= return (HscRecomp False, iface, details)
-- Generate code and return both the new ModIface and the ModDetails.
<- {-# SCC "CoreToStg" #-}
myCoreToStg dflags this_mod prepd_binds
------------------ Code generation ------------------
- abstractC <- {-# SCC "CodeGen" #-}
+ cmms <- {-# SCC "CodeGen" #-}
codeGen dflags this_mod data_tycons
dir_imps cost_centre_info
stg_binds hpc_info
- ------------------ Convert to CPS --------------------
- --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
- continuationC <- cmmToRawCmm abstractC
+ --- Optionally run experimental Cmm transformations ---
+ cmms <- optionallyConvertAndOrCPS dflags cmms
+ -- ^ unless certain dflags are on, the identity function
------------------ Code output -----------------------
- (stub_h_exists,stub_c_exists)
+ rawcmms <- cmmToRawCmm cmms
+ (_stub_h_exists, stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
- dependencies continuationC
+ dependencies rawcmms
return stub_c_exists
-hscConst :: b -> a -> Comp b
-hscConst b a = return b
-
hscInteractive :: (ModIface, ModDetails, CgGuts)
-> Comp (InteractiveStatus, ModIface, ModDetails)
-hscInteractive (iface, details, cgguts)
#ifdef GHCI
+hscInteractive (iface, details, cgguts)
= do hsc_env <- gets compHscEnv
mod_summary <- gets compModSummary
liftIO $ do
cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
- cg_foreign = foreign_stubs } = cgguts
+ cg_foreign = foreign_stubs,
+ cg_modBreaks = mod_breaks } = cgguts
dflags = hsc_dflags hsc_env
location = ms_location mod_summary
data_tycons = filter isDataTyCon tycons
prepd_binds <- {-# SCC "CorePrep" #-}
corePrepPgm dflags core_binds data_tycons ;
----------------- Generate byte code ------------------
- comp_bc <- byteCodeGen dflags prepd_binds data_tycons (md_modBreaks details)
+ comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
------------------ Create f-x-dynamic C-side stuff ---
- (istub_h_exists, istub_c_exists)
+ (_istub_h_exists, istub_c_exists)
<- outputForeignStubs dflags this_mod location foreign_stubs
- return (InteractiveRecomp istub_c_exists comp_bc, iface, details)
+ return (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details)
#else
- = panic "GHC not compiled with interpreter"
+hscInteractive _ = panic "GHC not compiled with interpreter"
#endif
------------------------------
md_exports = tcg_exports tc_result,
md_insts = tcg_insts tc_result,
md_fam_insts = tcg_fam_insts tc_result,
- md_modBreaks = emptyModBreaks,
md_rules = [panic "no rules"],
-- Rules are CoreRules, not the
-- RuleDecls we get out of the typechecker
case maybe_cmm of
Nothing -> return False
Just cmm -> do
- --continuationC <- cmmCPS dflags [cmm] >>= cmmToRawCmm
- continuationC <- cmmToRawCmm [cmm]
- codeOutput dflags no_mod no_loc NoStubs [] continuationC
+ cmms <- optionallyConvertAndOrCPS dflags [cmm]
+ rawCmms <- cmmToRawCmm cmms
+ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
return True
where
no_mod = panic "hscCmmFile: no_mod"
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 ------
+ cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
+ then mapM (testCmmConversion dflags) cmms
+ else return cmms
+ --------- Optionally convert to CPS (MDA) -----------
+ cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
+ dopt Opt_RunCPSZ dflags
+ then cmmCPS dflags cmms
+ else return cmms
+ return cmms
+
+
+testCmmConversion :: DynFlags -> Cmm -> IO Cmm
+testCmmConversion dflags cmm =
+ do showPass dflags "CmmToCmm"
+ dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
+ --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
+ us <- mkSplitUniqSupply 'C'
+ let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
+ let cvtm = do g <- cmmToZgraph cmm
+ return $ cfopts g
+ let zgraph = initUs_ us cvtm
+ cps_zgraph <- protoCmmCPSZ dflags 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"
+ 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
myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer
-> IO (Either ErrMsg (Located (HsModule RdrName)))
}}
+myCoreToStg :: DynFlags -> Module -> [CoreBind]
+ -> IO ( [(StgBinding,[(Id,[Id])])] -- output program
+ , CollectedCCs) -- cost centre info (declared and used)
+
myCoreToStg dflags this_mod prepd_binds
= do
stg_binds <- {-# SCC "Core2Stg" #-}
Nothing -> return Nothing ; -- Parse error
Just (Just (L _ (ExprStmt expr _ _)))
-> tcRnExpr hsc_env icontext expr ;
- Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
+ Just _ -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
return Nothing } ;
} }
%************************************************************************
\begin{code}
+showModuleIndex :: Maybe (Int, Int) -> String
showModuleIndex Nothing = ""
showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
where
projects / ghc-hetmet.git / blobdiff