import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
+import CoreSyn ( CoreExpr )
import CoreTidy ( tidyExpr )
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType )
import Type ( Type )
import PrelNames ( iNTERACTIVE )
-import Kind ( Kind )
+import {- Kind parts of -} Type ( Kind )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
-import SrcLoc ( noSrcLoc, getLoc )
+import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan )
import VarEnv ( emptyTidyEnv )
#endif
import Var ( Id )
import Module ( emptyModuleEnv, ModLocation(..) )
import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv )
-import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl )
+import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc,
+ HaddockModInfo )
import SrcLoc ( Located(..) )
import StringBuffer ( hGetStringBuffer, stringToStringBuffer )
import Parser
-import Lexer ( P(..), ParseResult(..), mkPState )
+import Lexer
import SrcLoc ( mkSrcLoc )
import TcRnDriver ( tcRnModule, tcRnExtCore )
import TcIface ( typecheckIface )
import CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
import TyCon ( isDataTyCon )
-import Packages ( mkHomeModules )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import CmmParse ( parseCmmFile )
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
+import Breakpoints ( noDbgSites )
import DynFlags
import ErrUtils
import ParserCore
import ParserCoreUtils
import FastString
-import Maybes ( expectJust )
+import UniqFM ( emptyUFM )
import Bag ( unitBag )
-import Monad ( unless )
-import IO
-import DATA_IOREF ( newIORef, readIORef )
+
+import Control.Monad
+import System.Exit
+import System.IO
+import Data.IORef
\end{code}
= do { eps_var <- newIORef initExternalPackageState
; us <- mkSplitUniqSupply 'r'
; nc_var <- newIORef (initNameCache us knownKeyNames)
- ; fc_var <- newIORef emptyModuleEnv
+ ; fc_var <- newIORef emptyUFM
+ ; mlc_var <- newIORef emptyModuleEnv
; return (HscEnv { hsc_dflags = dflags,
hsc_targets = [],
hsc_mod_graph = [],
hsc_EPS = eps_var,
hsc_NC = nc_var,
hsc_FC = fc_var,
+ hsc_MLC = mlc_var,
hsc_global_rdr_env = emptyGlobalRdrEnv,
hsc_global_type_env = emptyNameEnv } ) }
-- parsed
(Located (HsModule RdrName))
-- renamed
- (Maybe (HsGroup Name,[LImportDecl Name],Maybe [LIE Name]))
+ (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
+ Maybe (HsDoc Name), HaddockModInfo Name))
-- typechecked
(Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
-- This is a hack. We can't compile C files here
-- since it's done in DriverPipeline. For now we
-- just return True if we want the caller to compile
- -- it for us.
+ -- them for us.
-- Status of a compilation to byte-code.
data InteractiveStatus
liftIO $ do
if recomp
then showMsg "Compiling "
- else if verbosity (hsc_dflags hsc_env) >= 2
+ else if verbosity (hsc_dflags hsc_env) >= 1
then showMsg "Skipping "
else return ()
-------------------
-- DESUGAR
-------------------
- -> do (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
- deSugar hsc_env tc_result
- printBagOfWarnings dflags warns
- return maybe_ds_result
+ -> {-# SCC "DeSugar" #-} deSugar hsc_env (ms_location mod_summary) tc_result
--------------------------------------------------------------
-- Simplifiers
<- {-# SCC "MkFinalIface" #-}
mkIface hsc_env maybe_old_iface simpl_result details
-- Emit external core
- emitExternalCore (hsc_dflags hsc_env) (mg_exports simpl_result) cg_guts -- Move this? --Lemmih 03/07/2006
+ emitExternalCore (hsc_dflags hsc_env) (availsToNameSet (mg_exports simpl_result)) cg_guts -- Move this? --Lemmih 03/07/2006
dumpIfaceStats hsc_env
-------------------
hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
hscWriteIface (iface, no_change, details, a)
= do mod_summary <- gets compModSummary
+ hsc_env <- gets compHscEnv
+ let dflags = hsc_dflags hsc_env
liftIO $ do
unless no_change
- $ writeIfaceFile (ms_location mod_summary) iface
+ $ writeIfaceFile dflags (ms_location mod_summary) iface
return (iface, details, a)
hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
cg_tycons = tycons,
cg_dir_imps = dir_imps,
cg_foreign = foreign_stubs,
- cg_home_mods = home_mods,
- cg_dep_pkgs = dependencies } = cgguts
+ 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
----------------- Convert to STG ------------------
(stg_binds, cost_centre_info)
<- {-# SCC "CoreToStg" #-}
- myCoreToStg dflags home_mods this_mod prepd_binds
+ myCoreToStg dflags this_mod prepd_binds
------------------ Code generation ------------------
abstractC <- {-# SCC "CodeGen" #-}
- codeGen dflags home_mods this_mod data_tycons
+ codeGen dflags this_mod data_tycons
foreign_stubs dir_imps cost_centre_info
- stg_binds
+ stg_binds hpc_info
------------------ Code output -----------------------
(stub_h_exists,stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
; case maybe_tc_result of {
Nothing -> return (Just (HscChecked rdr_module Nothing Nothing));
Just tc_result -> do
- let md = ModDetails {
- md_types = tcg_type_env tc_result,
- md_exports = tcg_exports tc_result,
- md_insts = tcg_insts tc_result,
- md_rules = [panic "no rules"] }
+ let type_env = tcg_type_env tc_result
+ md = ModDetails {
+ md_types = type_env,
+ md_exports = tcg_exports tc_result,
+ md_insts = tcg_insts tc_result,
+ md_fam_insts = tcg_fam_insts tc_result,
+ md_dbg_sites = noDbgSites,
+ md_rules = [panic "no rules"] }
-- Rules are CoreRules, not the
-- RuleDecls we get out of the typechecker
rnInfo = do decl <- tcg_rn_decls tc_result
imports <- tcg_rn_imports tc_result
let exports = tcg_rn_exports tc_result
- return (decl,imports,exports)
+ let doc = tcg_doc tc_result
+ hmi = tcg_hmi tc_result
+ return (decl,imports,exports,doc,hmi)
return (Just (HscChecked rdr_module
rnInfo
(Just (tcg_binds tc_result,
hscCmmFile :: DynFlags -> FilePath -> IO Bool
hscCmmFile dflags filename = do
- maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename
+ maybe_cmm <- parseCmmFile dflags filename
case maybe_cmm of
Nothing -> return False
Just cmm -> do
PFailed span err -> return (Left (mkPlainErrMsg span err));
- POk _ rdr_module -> do {
+ POk pst rdr_module -> do {
+ let {ms = getMessages pst};
+ printErrorsAndWarnings dflags ms;
+ when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
+
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
}}
-myCoreToStg dflags home_mods this_mod prepd_binds
+myCoreToStg dflags this_mod prepd_binds
= do
stg_binds <- {-# SCC "Core2Stg" #-}
- coreToStg home_mods prepd_binds
+ coreToStg (thisPackage dflags) prepd_binds
(stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
- stg2stg dflags home_mods this_mod stg_binds
+ stg2stg dflags this_mod stg_binds
return (stg_binds2, cost_centre_info)
\end{code}
Nothing -> return Nothing ;
Just (new_ic, bound_names, tc_expr) -> do {
+
+ -- Desugar it
+ ; let rdr_env = ic_rn_gbl_env new_ic
+ type_env = ic_type_env new_ic
+ ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
+
+ ; case mb_ds_expr of {
+ Nothing -> return Nothing ;
+ Just ds_expr -> do {
+
-- Then desugar, code gen, and link it
- ; hval <- compileExpr hsc_env iNTERACTIVE
- (ic_rn_gbl_env new_ic)
- (ic_type_env new_ic)
- tc_expr
+ ; let src_span = srcLocSpan interactiveSrcLoc
+ ; hval <- compileExpr hsc_env src_span ds_expr
; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
- }}}}}
+ }}}}}}}
hscTcExpr -- Typecheck an expression (but don't run it)
:: HscEnv
= do { maybe_type <- hscParseType (hsc_dflags hsc_env) str
; let icontext = hsc_IC hsc_env
; case maybe_type of {
- Just ty -> tcRnType hsc_env icontext ty ;
- Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ;
- return Nothing } ;
- Nothing -> return Nothing } }
+ Just ty -> tcRnType hsc_env icontext ty ;
+ Nothing -> return Nothing } }
#endif
\end{code}
PFailed span err -> do { printError span err;
return Nothing };
- POk _ thing -> do {
+ POk pst thing -> do {
+
+ let {ms = getMessages pst};
+ printErrorsAndWarnings dflags ms;
+ when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
--ToDo: can't free the string buffer until we've finished this
-- compilation sweep and all the identifiers have gone away.
\begin{code}
#ifdef GHCI
-compileExpr :: HscEnv
- -> Module -> GlobalRdrEnv -> TypeEnv
- -> LHsExpr Id
- -> IO HValue
+compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
-compileExpr hsc_env this_mod rdr_env type_env tc_expr
+compileExpr hsc_env srcspan ds_expr
= do { let { dflags = hsc_dflags hsc_env ;
- lint_on = dopt Opt_DoCoreLinting dflags ;
- !srcspan = getLoc tc_expr }
+ lint_on = dopt Opt_DoCoreLinting dflags }
- -- Desugar it
- ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
-
-- Flatten it
; flat_expr <- flattenExpr hsc_env ds_expr
projects / ghc-hetmet.git / blobdiff