%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
%
\begin{code}
module HscMain
( newHscEnv, hscCmmFile
, hscParseIdentifier
, hscSimplify
, hscNormalIface, hscWriteIface, hscGenHardCode
#ifdef GHCI
, hscStmt, hscTcExpr, hscImport, hscKcType
, compileExpr
#endif
, HsCompiler(..)
, hscOneShotCompiler, hscNothingCompiler
, hscInteractiveCompiler, hscBatchCompiler
, hscCompileOneShot
, hscCompileBatch
, hscCompileNothing
, hscCompileInteractive
, hscCheckRecompBackend
, 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, tyVarsOfTypes )
import PrelNames ( iNTERACTIVE )
import Type ( Kind )
import Id ( idType )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc )
import VarSet
import VarEnv ( emptyTidyEnv )
import Panic
#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 UniqFM ( 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 } ) }
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 1
case unP parseModule (mkPState dflags buf loc) 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, hs-boot and
core files to either byte-code, hard-code (C, asm, Java, 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',
or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode
targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
targets byte-code.
The modes are kept separate because of their different types and meanings.
In 'one-shot' 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 hard-code; compiling to byte-code or nothing doesn't make sense
when we discard the result.
'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
and ModDetails. 'Batch' mode doesn't target byte-code since that require
us to return the newly compiled byte-code.
'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 byte-code together with the ModIface and ModDetails.
Trying to compile a hs-boot file to byte-code will result in a run-time
error. This is the only thing that isn't caught by the type-system.
\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 {
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
hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
hscCheckRecompBackend compiler tc_result
hsc_env mod_summary source_unchanged mb_old_iface _m_of_n =
withTempSession (\_ -> hsc_env) $ do
(recomp_reqd, mb_checked_iface)
<-
liftIO $ checkOldIface hsc_env mod_summary
source_unchanged mb_old_iface
let mb_old_hash = fmap mi_iface_hash mb_checked_iface
case mb_checked_iface of
Just iface | not recomp_reqd
-> hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) }
_otherwise
-> hscBackend compiler tc_result 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 {
hscNoRecomp = \_old_iface -> do
withSession (liftIO . dumpIfaceStats)
return HscNoRecomp
, hscRecompile = genericHscRecompile hscOneShotCompiler
, hscBackend = \ tc_result mod_summary mb_old_hash -> do
hsc_env <- getSession
case hscTarget (hsc_dflags hsc_env) of
HscNothing -> return (HscRecomp False ())
_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 ())
, 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 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
hscBatchCompiler :: HsCompiler BatchResult
hscBatchCompiler =
HsCompiler {
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 = genericHscCompile hscBatchCompiler batchMsg
hscInteractiveCompiler :: HsCompiler InteractiveResult
hscInteractiveCompiler =
HsCompiler {
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 = genericHscCompile hscInteractiveCompiler batchMsg
hscNothingCompiler :: HsCompiler NothingResult
hscNothingCompiler =
HsCompiler {
hscNoRecomp = \iface -> do
details <- genModDetails iface
return (HscNoRecomp, iface, details)
, hscRecompile = genericHscRecompile hscNothingCompiler
, 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 = genericHscCompile hscNothingCompiler batchMsg
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 =
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 do-statement}
%* *
%************************************************************************
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 non-IO type,
result showable) ==> let v = expr in print v >> return [v]
bindings: [it]
expr (of non-IO 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)
hscImport :: GhcMonad m => HscEnv -> String -> m (ImportDecl RdrName)
hscImport hsc_env str = do
(L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule (hsc_dflags hsc_env) str
case is of
[i] -> return (unLoc i)
_ -> throwOneError (mkPlainErrMsg noSrcSpan (ptext (sLit "parse error in import declaration")))
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 1
case unP parser (mkPState dflags buf loc) 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
| rtsIsProfiled
= throwIO (InstallationError "You can't call compileExpr in a profiled compiler")
| otherwise
= 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 (tyVarsOfTypes (map idType (ic_tmp_ids 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}