%
% (c) The GRASP/AQUA Project, Glasgow University, 19932000
%
\begin{code}
module HscMain
( newHscEnv, hscCmmFile
, hscParseIdentifier
, hscSimplify
, hscNormalIface, hscWriteIface, hscGenHardCode
#ifdef GHCI
, hscStmt, hscTcExpr, hscKcType
, compileExpr
#endif
, HsCompiler(..)
, hscOneShotCompiler, hscNothingCompiler
, hscInteractiveCompiler, hscBatchCompiler
, hscCompileOneShot
, hscCompileBatch
, hscCompileNothing
, hscCompileInteractive
, HscStatus' (..)
, InteractiveStatus, HscStatus
, hscParse
, hscTypecheck
, hscTypecheckRename
, hscDesugar
, makeSimpleIface
, makeSimpleDetails
) where
#ifdef GHCI
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
import CoreTidy ( tidyExpr )
import CorePrep ( corePrepExpr )
import Desugar ( deSugarExpr )
import SimplCore ( simplifyExpr )
import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType )
import Type ( Type )
import PrelNames ( iNTERACTIVE )
import Type ( Kind )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan )
import VarSet
import VarEnv ( emptyTidyEnv )
#endif
import Id ( Id )
import Module ( emptyModuleEnv, ModLocation(..), Module )
import RdrName
import HsSyn
import CoreSyn
import SrcLoc ( Located(..) )
import StringBuffer
import Parser
import Lexer
import SrcLoc ( mkSrcLoc )
import TcRnDriver ( tcRnModule )
import TcIface ( typecheckIface )
import TcRnMonad ( initIfaceCheck, TcGblEnv(..) )
import IfaceEnv ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState )
import PrelInfo ( wiredInThings, basicKnownKeyNames )
import MkIface
import Desugar ( deSugar )
import SimplCore ( core2core )
import TidyPgm
import CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
import qualified StgCmm ( codeGen )
import StgSyn
import CostCentre
import TyCon ( TyCon, isDataTyCon )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import Cmm ( Cmm )
import PprCmm ( pprCmms )
import CmmParse ( parseCmmFile )
import CmmBuildInfoTables
import CmmCPS
import CmmCPSZ
import CmmInfo
import OptimizationFuel ( initOptFuelState )
import CmmCvt
import CmmTx
import CmmContFlowOpt
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
import Fingerprint ( Fingerprint )
import DynFlags
import ErrUtils
import UniqSupply ( mkSplitUniqSupply )
import Outputable
import HscStats ( ppSourceStats )
import HscTypes
import MkExternalCore ( emitExternalCore )
import FastString
import LazyUniqFM ( emptyUFM )
import UniqSupply ( initUs_ )
import Bag ( unitBag )
import Exception
import Control.Monad
import Data.IORef
\end{code}
#include "HsVersions.h"
%************************************************************************
%* *
Initialisation
%* *
%************************************************************************
\begin{code}
newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv
newHscEnv callbacks dflags
= do { eps_var <- newIORef initExternalPackageState
; us <- mkSplitUniqSupply 'r'
; nc_var <- newIORef (initNameCache us knownKeyNames)
; fc_var <- newIORef emptyUFM
; mlc_var <- newIORef emptyModuleEnv
; optFuel <- initOptFuelState
; return (HscEnv { hsc_dflags = dflags,
hsc_callbacks = callbacks,
hsc_targets = [],
hsc_mod_graph = [],
hsc_IC = emptyInteractiveContext,
hsc_HPT = emptyHomePackageTable,
hsc_EPS = eps_var,
hsc_NC = nc_var,
hsc_FC = fc_var,
hsc_MLC = mlc_var,
hsc_OptFuel = optFuel,
hsc_type_env_var = Nothing,
hsc_global_rdr_env = emptyGlobalRdrEnv,
hsc_global_type_env = emptyNameEnv } ) }
knownKeyNames :: [Name]
knownKeyNames = map getName wiredInThings
++ basicKnownKeyNames
#ifdef GHCI
++ templateHaskellNames
#endif
\end{code}
\begin{code}
hscParse :: GhcMonad m =>
ModSummary
-> m (Located (HsModule RdrName))
hscParse mod_summary = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
src_filename = ms_hspp_file mod_summary
maybe_src_buf = ms_hspp_buf mod_summary
liftIO $ showPass dflags "Parser"
do
buf <- case maybe_src_buf of
Just b -> return b
Nothing -> liftIO $ hGetStringBuffer src_filename
let loc = mkSrcLoc (mkFastString src_filename) 1 0
case unP parseModule (mkPState buf loc dflags) of
PFailed span err ->
throwOneError (mkPlainErrMsg span err)
POk pst rdr_module -> do
let ms@(warns,errs) = getMessages pst
logWarnings warns
if errorsFound dflags ms then
liftIO $ throwIO $ mkSrcErr errs
else liftIO $ do
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
(ppSourceStats False rdr_module) ;
return rdr_module
hscTypecheck :: GhcMonad m =>
ModSummary -> Located (HsModule RdrName)
-> m TcGblEnv
hscTypecheck mod_summary rdr_module = do
hsc_env <- getSession
r <-
ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
return r
type RenamedStuff =
(Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
Maybe LHsDocString))
hscTypecheckRename ::
GhcMonad m =>
ModSummary -> Located (HsModule RdrName)
-> m (TcGblEnv, RenamedStuff)
hscTypecheckRename mod_summary rdr_module = do
hsc_env <- getSession
tc_result
<-
ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
let
rn_info = do { decl <- tcg_rn_decls tc_result
; let imports = tcg_rn_imports tc_result
exports = tcg_rn_exports tc_result
doc_hdr = tcg_doc_hdr tc_result
; return (decl,imports,exports,doc_hdr) }
return (tc_result, rn_info)
hscDesugar :: GhcMonad m => ModSummary -> TcGblEnv -> m ModGuts
hscDesugar mod_summary tc_result =
withSession $ \hsc_env ->
ioMsgMaybe $ deSugar hsc_env (ms_location mod_summary) tc_result
makeSimpleIface :: GhcMonad m =>
Maybe ModIface -> TcGblEnv -> ModDetails
-> m (ModIface,Bool)
makeSimpleIface maybe_old_iface tc_result details =
withSession $ \hsc_env ->
ioMsgMaybe $ mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
makeSimpleDetails :: GhcMonad m => TcGblEnv -> m ModDetails
makeSimpleDetails tc_result =
withSession $ \hsc_env -> liftIO $ mkBootModDetailsTc hsc_env tc_result
\end{code}
%************************************************************************
%* *
The main compiler pipeline
%* *
%************************************************************************
The compilation proper
It's the task of the compilation proper to compile Haskell, hsboot and
core files to either bytecode, hardcode (C, asm, Java, ect) or to
nothing at all (the module is still parsed and typechecked. This
feature is mostly used by IDE's and the likes).
Compilation can happen in either 'oneshot', 'batch', 'nothing',
or 'interactive' mode. 'Oneshot' mode targets hardcode, 'batch' mode
targets hardcode, 'nothing' mode targets nothing and 'interactive' mode
targets bytecode.
The modes are kept separate because of their different types and meanings.
In 'oneshot' mode, we're only compiling a single file and can therefore
discard the new ModIface and ModDetails. This is also the reason it only
targets hardcode; compiling to bytecode or nothing doesn't make sense
when we discard the result.
'Batch' mode is like 'oneshot' except that we keep the resulting ModIface
and ModDetails. 'Batch' mode doesn't target bytecode since that require
us to return the newly compiled bytecode.
'Nothing' mode has exactly the same type as 'batch' mode but they're still
kept separate. This is because compiling to nothing is fairly special: We
don't output any interface files, we don't run the simplifier and we don't
generate any code.
'Interactive' mode is similar to 'batch' mode except that we return the
compiled bytecode together with the ModIface and ModDetails.
Trying to compile a hsboot file to bytecode will result in a runtime
error. This is the only thing that isn't caught by the typesystem.
\begin{code}
data HscStatus' a
= HscNoRecomp
| HscRecomp
Bool
a
type HscStatus = HscStatus' ()
type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
type OneShotResult = HscStatus
type BatchResult = (HscStatus, ModIface, ModDetails)
type NothingResult = (HscStatus, ModIface, ModDetails)
type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
type Compiler result = GhcMonad m =>
HscEnv
-> ModSummary
-> Bool
-> Maybe ModIface
-> Maybe (Int,Int)
-> m result
data HsCompiler a
= HsCompiler {
hscCompile :: GhcMonad m =>
HscEnv -> ModSummary -> Bool
-> Maybe ModIface -> Maybe (Int, Int)
-> m a,
hscNoRecomp :: GhcMonad m =>
ModIface -> m a,
hscRecompile :: GhcMonad m =>
ModSummary -> Maybe Fingerprint -> m a,
hscBackend :: GhcMonad m =>
TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
hscGenBootOutput :: GhcMonad m =>
TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
hscGenOutput :: GhcMonad m =>
ModGuts -> ModSummary -> Maybe Fingerprint -> m a
}
genericHscCompile :: GhcMonad m =>
HsCompiler a
-> (Maybe (Int,Int) -> Bool -> ModSummary -> m ())
-> HscEnv -> ModSummary -> Bool
-> Maybe ModIface -> Maybe (Int, Int)
-> m a
genericHscCompile compiler hscMessage
hsc_env mod_summary source_unchanged
mb_old_iface0 mb_mod_index =
withTempSession (\_ -> hsc_env) $ do
(recomp_reqd, mb_checked_iface)
<-
liftIO $ checkOldIface hsc_env mod_summary
source_unchanged mb_old_iface0
let mb_old_hash = fmap mi_iface_hash mb_checked_iface
case mb_checked_iface of
Just iface | not recomp_reqd
-> do hscMessage mb_mod_index False mod_summary
hscNoRecomp compiler iface
_otherwise
-> do hscMessage mb_mod_index True mod_summary
hscRecompile compiler mod_summary mb_old_hash
genericHscRecompile :: GhcMonad m =>
HsCompiler a
-> ModSummary -> Maybe Fingerprint
-> m a
genericHscRecompile compiler mod_summary mb_old_hash
| ExtCoreFile <- ms_hsc_src mod_summary =
panic "GHC does not currently support reading External Core files"
| otherwise = do
tc_result <- hscFileFrontEnd mod_summary
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
hscOneShotCompiler :: HsCompiler OneShotResult
hscOneShotCompiler =
HsCompiler {
hscCompile = \hsc_env mod_summary src_changed mb_old_iface mb_i_of_n -> do
type_env_var <- liftIO $ newIORef emptyNameEnv
let
mod = ms_mod mod_summary
hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
genericHscCompile hscOneShotCompiler
oneShotMsg hsc_env' mod_summary src_changed
mb_old_iface mb_i_of_n
, hscNoRecomp = \_old_iface -> do
withSession (liftIO . dumpIfaceStats)
return HscNoRecomp
, 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
return (HscRecomp False ())
, hscGenOutput = \guts0 mod_summary mb_old_iface -> do
guts <- hscSimplify guts0
(iface, changed, _details, cgguts)
<- hscNormalIface guts mb_old_iface
hscWriteIface iface changed mod_summary
hasStub <- hscGenHardCode cgguts mod_summary
return (HscRecomp hasStub ())
}
hscCompileOneShot :: Compiler OneShotResult
hscCompileOneShot = hscCompile hscOneShotCompiler
hscBatchCompiler :: HsCompiler BatchResult
hscBatchCompiler =
HsCompiler {
hscCompile = genericHscCompile hscBatchCompiler batchMsg
, hscNoRecomp = \iface -> do
details <- genModDetails iface
return (HscNoRecomp, iface, details)
, hscRecompile = genericHscRecompile hscBatchCompiler
, hscBackend = genericHscBackend 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)
, hscGenOutput = \guts0 mod_summary mb_old_iface -> do
guts <- hscSimplify guts0
(iface, changed, details, cgguts)
<- hscNormalIface guts mb_old_iface
hscWriteIface iface changed mod_summary
hasStub <- hscGenHardCode cgguts mod_summary
return (HscRecomp hasStub (), iface, details)
}
hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
hscCompileBatch = hscCompile hscBatchCompiler
hscInteractiveCompiler :: HsCompiler InteractiveResult
hscInteractiveCompiler =
HsCompiler {
hscCompile = genericHscCompile hscInteractiveCompiler batchMsg
, hscNoRecomp = \iface -> do
details <- genModDetails iface
return (HscNoRecomp, iface, details)
, hscRecompile = genericHscRecompile hscInteractiveCompiler
, 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
(iface, _changed, details, cgguts)
<- hscNormalIface guts mb_old_iface
hscInteractive (iface, details, cgguts) mod_summary
}
hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
hscCompileInteractive = hscCompile hscInteractiveCompiler
hscNothingCompiler :: HsCompiler NothingResult
hscNothingCompiler =
HsCompiler {
hscCompile = genericHscCompile hscNothingCompiler batchMsg
, hscNoRecomp = \iface -> do
details <- genModDetails iface
return (HscNoRecomp, iface, details)
, hscRecompile = \mod_summary mb_old_hash ->
case ms_hsc_src mod_summary of
ExtCoreFile ->
panic "hscCompileNothing: cannot do external core"
_otherwise -> do
tc_result <- hscFileFrontEnd mod_summary
hscBackend hscNothingCompiler tc_result mod_summary mb_old_hash
, 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"
}
hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
hscCompileNothing = hscCompile hscNothingCompiler
genModDetails :: GhcMonad m => ModIface -> m ModDetails
genModDetails old_iface =
withSession $ \hsc_env -> liftIO $ do
new_details <-
initIfaceCheck hsc_env $
typecheckIface old_iface
dumpIfaceStats hsc_env
return new_details
oneShotMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
oneShotMsg _mb_mod_index recomp _mod_summary
= do hsc_env <- getSession
liftIO $ do
if recomp
then return ()
else compilationProgressMsg (hsc_dflags hsc_env) $
"compilation IS NOT required"
batchMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
batchMsg mb_mod_index recomp mod_summary
= do hsc_env <- getSession
let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
(showModuleIndex mb_mod_index ++
msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
liftIO $ do
if recomp
then showMsg "Compiling "
else if verbosity (hsc_dflags hsc_env) >= 2
then showMsg "Skipping "
else return ()
hscFileFrontEnd :: GhcMonad m => ModSummary -> m TcGblEnv
hscFileFrontEnd mod_summary =
do rdr_module <- hscParse mod_summary
hscTypecheck mod_summary rdr_module
hscSimplify :: GhcMonad m => ModGuts -> m ModGuts
hscSimplify ds_result
= do hsc_env <- getSession
simpl_result <-
liftIO $ core2core hsc_env ds_result
return simpl_result
hscSimpleIface :: GhcMonad m =>
TcGblEnv
-> Maybe Fingerprint
-> m (ModIface, Bool, ModDetails)
hscSimpleIface tc_result mb_old_iface
= do hsc_env <- getSession
details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
(new_iface, no_change)
<-
ioMsgMaybe $ mkIfaceTc hsc_env mb_old_iface details tc_result
liftIO $ dumpIfaceStats hsc_env
return (new_iface, no_change, details)
hscNormalIface :: GhcMonad m =>
ModGuts
-> Maybe Fingerprint
-> m (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface simpl_result mb_old_iface
= do hsc_env <- getSession
(cg_guts, details) <-
liftIO $ tidyProgram hsc_env simpl_result
(new_iface, no_change)
<-
ioMsgMaybe $ mkIface hsc_env mb_old_iface
details simpl_result
liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
liftIO $ dumpIfaceStats hsc_env
return (new_iface, no_change, details, cg_guts)
hscWriteIface :: GhcMonad m =>
ModIface -> Bool
-> ModSummary
-> m ()
hscWriteIface iface no_change mod_summary
= do hsc_env <- getSession
let dflags = hsc_dflags hsc_env
liftIO $ do
unless no_change
$ writeIfaceFile dflags (ms_location mod_summary) iface
hscGenHardCode :: GhcMonad m =>
CgGuts -> ModSummary
-> m Bool
hscGenHardCode cgguts mod_summary
= withSession $ \hsc_env -> liftIO $ do
let CgGuts{
cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_dir_imps = dir_imps,
cg_foreign = foreign_stubs,
cg_dep_pkgs = dependencies,
cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env
location = ms_location mod_summary
data_tycons = filter isDataTyCon tycons
prepd_binds <-
corePrepPgm dflags core_binds data_tycons ;
(stg_binds, cost_centre_info)
<-
myCoreToStg dflags this_mod prepd_binds
cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)
then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
dir_imps cost_centre_info
stg_binds hpc_info
return cmms
else
codeGen dflags this_mod data_tycons
dir_imps cost_centre_info
stg_binds hpc_info
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
return stub_c_exists
hscInteractive :: GhcMonad m =>
(ModIface, ModDetails, CgGuts)
-> ModSummary
-> m (InteractiveStatus, ModIface, ModDetails)
#ifdef GHCI
hscInteractive (iface, details, cgguts) mod_summary
= do hsc_env <- getSession
liftIO $ do
let CgGuts{
cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
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 <-
corePrepPgm dflags core_binds data_tycons ;
comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
(_istub_h_exists, istub_c_exists)
<- outputForeignStubs dflags this_mod location foreign_stubs
return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
, iface, details)
#else
hscInteractive _ _ = panic "GHC not compiled with interpreter"
#endif
hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m ()
hscCmmFile hsc_env filename = do
dflags <- return $ hsc_dflags hsc_env
cmm <- ioMsgMaybe $
parseCmmFile dflags filename
cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm]
rawCmms <- liftIO $ cmmToRawCmm cmms
_ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
return ()
where
no_mod = panic "hscCmmFile: no_mod"
no_loc = ModLocation{ ml_hs_file = Just filename,
ml_hi_file = panic "hscCmmFile: no hi file",
ml_obj_file = panic "hscCmmFile: no obj file" }
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
| not (dopt Opt_TryNewCodeGen (hsc_dflags hsc_env))
= return []
| otherwise
= 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 (runTx $ runCmmOpts cmmCfgOptsZ) prog
; us <- mkSplitUniqSupply 'S'
; let topSRT = initUs_ us emptySRT
; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog
; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
; let prog' = map cmmOfZgraph prog
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
; return prog' }
optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
optionallyConvertAndOrCPS hsc_env cmms =
do let dflags = hsc_dflags hsc_env
cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
then mapM (testCmmConversion hsc_env) cmms
else return cmms
cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
dopt Opt_RunCPS dflags
then cmmCPS dflags cmms
else return cmms
return cmms
testCmmConversion :: HscEnv -> Cmm -> IO Cmm
testCmmConversion hsc_env cmm =
do let dflags = hsc_dflags hsc_env
showPass dflags "CmmToCmm"
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
us <- mkSplitUniqSupply 'C'
let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
let cvtm = do g <- cmmToZgraph cmm
return $ cfopts g
let zgraph = initUs_ us cvtm
us <- mkSplitUniqSupply 'S'
let topSRT = initUs_ us emptySRT
(_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) 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
myCoreToStg :: DynFlags -> Module -> [CoreBind]
-> IO ( [(StgBinding,[(Id,[Id])])]
, CollectedCCs)
myCoreToStg dflags this_mod prepd_binds
= do
stg_binds <-
coreToStg (thisPackage dflags) prepd_binds
(stg_binds2, cost_centre_info) <-
stg2stg dflags this_mod stg_binds
return (stg_binds2, cost_centre_info)
\end{code}
%************************************************************************
%* *
\subsection{Compiling a dostatement}
%* *
%************************************************************************
When the UnlinkedBCOExpr is linked you get an HValue of type
IO [HValue]
When you run it you get a list of HValues that should be
the same length as the list of names; add them to the ClosureEnv.
A naked expression returns a singleton Name [it].
What you type The IO [HValue] that hscStmt returns
let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
bindings: [x,y,...]
pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
bindings: [x,y,...]
expr (of IO type) ==> expr >>= \ v -> return [v]
[NB: result not printed] bindings: [it]
expr (of nonIO type,
result showable) ==> let v = expr in print v >> return [v]
bindings: [it]
expr (of nonIO type,
result not showable) ==> error
\begin{code}
#ifdef GHCI
hscStmt
:: GhcMonad m =>
HscEnv
-> String
-> m (Maybe ([Id], HValue))
hscStmt hsc_env stmt = do
maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
case maybe_stmt of
Nothing -> return Nothing
Just parsed_stmt -> do
let icontext = hsc_IC hsc_env
(ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt
let rdr_env = ic_rn_gbl_env icontext
type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
ds_expr <- ioMsgMaybe $
deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
let src_span = srcLocSpan interactiveSrcLoc
hval <- liftIO $ compileExpr hsc_env src_span ds_expr
return $ Just (ids, hval)
hscTcExpr
:: GhcMonad m =>
HscEnv
-> String
-> m Type
hscTcExpr hsc_env expr = do
maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
let icontext = hsc_IC hsc_env
case maybe_stmt of
Just (L _ (ExprStmt expr _ _)) -> do
ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr
return ty
_ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg
noSrcSpan
(text "not an expression:" <+> quotes (text expr))
hscKcType
:: GhcMonad m =>
HscEnv
-> String
-> m Kind
hscKcType hsc_env str = do
ty <- hscParseType (hsc_dflags hsc_env) str
let icontext = hsc_IC hsc_env
ioMsgMaybe $ tcRnType hsc_env icontext ty
#endif
\end{code}
\begin{code}
#ifdef GHCI
hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName))
hscParseStmt = hscParseThing parseStmt
hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName)
hscParseType = hscParseThing parseType
#endif
hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName)
hscParseIdentifier = hscParseThing parseIdentifier
hscParseThing :: (Outputable thing, GhcMonad m)
=> Lexer.P thing
-> DynFlags -> String
-> m thing
hscParseThing parser dflags str
= (liftIO $ showPass dflags "Parser") >>
do
buf <- liftIO $ stringToStringBuffer str
let loc = mkSrcLoc (fsLit "<interactive>") 1 0
case unP parser (mkPState buf loc dflags) of
PFailed span err -> do
let msg = mkPlainErrMsg span err
throw (mkSrcErr (unitBag msg))
POk pst thing -> do
let ms@(warns, errs) = getMessages pst
logWarnings warns
when (errorsFound dflags ms) $
throw (mkSrcErr errs)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
return thing
\end{code}
%************************************************************************
%* *
Desugar, simplify, convert to bytecode, and link an expression
%* *
%************************************************************************
\begin{code}
#ifdef GHCI
compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
compileExpr hsc_env srcspan ds_expr
= do { let { dflags = hsc_dflags hsc_env ;
lint_on = dopt Opt_DoCoreLinting dflags }
; simpl_expr <- simplifyExpr dflags ds_expr
; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
; prepd_expr <- corePrepExpr dflags tidy_expr
; if lint_on then
let ictxt = hsc_IC hsc_env
tyvars = varSetElems (ic_tyvars ictxt)
in
case lintUnfolding noSrcLoc tyvars prepd_expr of
Just err -> pprPanic "compileExpr" err
Nothing -> return ()
else
return ()
; bcos <- coreExprToBCOs dflags prepd_expr
; hval <- linkExpr hsc_env srcspan bcos
; return hval
}
#endif
\end{code}
%************************************************************************
%* *
Statistics on reading interfaces
%* *
%************************************************************************
\begin{code}
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env
= do { eps <- readIORef (hsc_EPS hsc_env)
; dumpIfSet (dump_if_trace || dump_rn_stats)
"Interface statistics"
(ifaceStats eps) }
where
dflags = hsc_dflags hsc_env
dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
dump_if_trace = dopt Opt_D_dump_if_trace dflags
\end{code}
%************************************************************************
%* *
Progress Messages: Module i of n
%* *
%************************************************************************
\begin{code}
showModuleIndex :: Maybe (Int, Int) -> String
showModuleIndex Nothing = ""
showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
where
n_str = show n
i_str = show i
padded = replicate (length n_str length i_str) ' ' ++ i_str
\end{code}