#include "HsVersions.h"
#ifdef GHCI
-import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType )
-import Module ( Module )
+import HsSyn ( Stmt(..), LStmt, LHsType )
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan )
+import VarSet
import VarEnv ( emptyTidyEnv )
#endif
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 FastString
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}
-- 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
-- 1 2 3 4 5 6 7 8 9
-- Compile Haskell, boot and extCore in OneShot mode.
hscCompileOneShot :: Compiler HscStatus
-hscCompileOneShot hsc_env mod_summary =
- compiler hsc_env mod_summary
- where mkComp = hscMkCompiler norecompOneShot oneShotMsg
- -- How to compile nonBoot files.
- nonBootComp inp = hscSimplify inp >>= hscNormalIface >>=
- hscWriteIface >>= hscOneShot
- -- How to compile boot files.
- bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscConst (HscRecomp False)
- compiler
- = case ms_hsc_src mod_summary of
- ExtCoreFile
- -> mkComp hscCoreFrontEnd nonBootComp
- HsSrcFile
- -> mkComp hscFileFrontEnd nonBootComp
- HsBootFile
- -> mkComp hscFileFrontEnd bootComp
+hscCompileOneShot = hscCompileHardCode norecompOneShot oneShotMsg hscOneShot (hscConst (HscRecomp False))
-- Compile Haskell, boot and extCore in batch mode.
hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
-hscCompileBatch hsc_env mod_summary
- = compiler hsc_env mod_summary
- where mkComp = hscMkCompiler norecompBatch batchMsg
+hscCompileBatch = hscCompileHardCode norecompBatch batchMsg hscBatch hscNothing
+
+-- Compile to hardcode (C,asm,...). This general structure is shared by OneShot and Batch.
+hscCompileHardCode :: NoRecomp result -- No recomp necessary
+ -> (Maybe (Int,Int) -> Bool -> Comp ()) -- Message callback
+ -> ((ModIface, ModDetails, CgGuts) -> Comp result) -- Compile normal file
+ -> ((ModIface, ModDetails, ModGuts) -> Comp result) -- Compile boot file
+ -> Compiler result
+hscCompileHardCode norecomp msg compNormal compBoot hsc_env mod_summary =
+ compiler hsc_env mod_summary
+ where mkComp = hscMkCompiler norecomp msg
+ -- How to compile nonBoot files.
nonBootComp inp = hscSimplify inp >>= hscNormalIface >>=
- hscWriteIface >>= hscBatch
- bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing
+ hscWriteIface >>= compNormal
+ -- How to compile boot files.
+ bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= compBoot
compiler
= case ms_hsc_src mod_summary of
ExtCoreFile
liftIO $ do
if recomp
then showMsg "Compiling "
- else if verbosity (hsc_dflags hsc_env) >= 1
+ else if verbosity (hsc_dflags hsc_env) >= 2
then showMsg "Skipping "
else return ()
-------------------
-- DESUGAR
-------------------
- -> {-# SCC "DeSugar" #-} deSugar hsc_env tc_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_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
abstractC <- {-# SCC "CodeGen" #-}
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
prepd_binds <- {-# SCC "CorePrep" #-}
corePrepPgm dflags core_binds data_tycons ;
----------------- Generate byte code ------------------
- comp_bc <- byteCodeGen dflags prepd_binds data_tycons
+ comp_bc <- byteCodeGen dflags prepd_binds data_tycons (md_modBreaks details)
------------------ Create f-x-dynamic C-side stuff ---
(istub_h_exists, istub_c_exists)
<- outputForeignStubs dflags this_mod location foreign_stubs
md_exports = tcg_exports tc_result,
md_insts = tcg_insts tc_result,
md_fam_insts = tcg_fam_insts tc_result,
- md_rules = [panic "no rules"] }
+ md_modBreaks = emptyModBreaks,
+ md_rules = [panic "no rules"],
-- Rules are CoreRules, not the
-- RuleDecls we get out of the typechecker
+ md_vect_info =
+ panic "HscMain.hscFileCheck: no VectInfo"
+ -- VectInfo is added by the Core
+ -- vectorisation pass
+ }
rnInfo = do decl <- tcg_rn_decls tc_result
imports <- tcg_rn_imports tc_result
let exports = tcg_rn_exports tc_result
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"
hscStmt -- Compile a stmt all the way to an HValue, but don't run it
:: HscEnv
-> String -- The statement
- -> IO (Maybe (HscEnv, [Name], HValue))
+ -> IO (Maybe ([Id], HValue))
hscStmt hsc_env stmt
= do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
; case maybe_tc_result of {
Nothing -> return Nothing ;
- Just (new_ic, bound_names, tc_expr) -> do {
-
+ Just (ids, tc_expr) -> do {
-- Desugar it
- ; let rdr_env = ic_rn_gbl_env new_ic
- type_env = ic_type_env new_ic
+ ; let rdr_env = ic_rn_gbl_env icontext
+ type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
; case mb_ds_expr of {
; let src_span = srcLocSpan interactiveSrcLoc
; hval <- compileExpr hsc_env src_span ds_expr
- ; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
+ ; return (Just (ids, hval))
}}}}}}}
hscTcExpr -- Typecheck an expression (but don't run it)
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.
-- Lint if necessary
-- ToDo: improve SrcLoc
; if lint_on then
- case lintUnfolding noSrcLoc [] prepd_expr of
+ 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
projects / ghc-hetmet.git / blobdiff