#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 RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv )
import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc,
HaddockModInfo )
+import CoreSyn
import SrcLoc ( Located(..) )
-import StringBuffer ( hGetStringBuffer, stringToStringBuffer )
+import StringBuffer
import Parser
import Lexer
import SrcLoc ( mkSrcLoc )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import CmmParse ( parseCmmFile )
+import CmmCPS
+import CmmInfo
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
-import Breakpoints ( noDbgSites )
import DynFlags
import ErrUtils
Maybe (HsDoc Name), HaddockModInfo Name))
-- typechecked
(Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
-
+ -- desugared
+ (Maybe [CoreBind])
-- Status of a compilation to hard-code or nothing.
data HscStatus
-- 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 ()
hscSimplify ds_result
= do hsc_env <- gets compHscEnv
liftIO $ do
- flat_result <- {-# SCC "Flattening" #-}
- flatten hsc_env ds_result
-------------------
-- SIMPLIFY
-------------------
simpl_result <- {-# SCC "Core2Core" #-}
- core2core hsc_env flat_result
+ core2core hsc_env ds_result
return simpl_result
--------------------------------------------------------------
------------------ Code generation ------------------
abstractC <- {-# SCC "CodeGen" #-}
codeGen dflags this_mod data_tycons
- foreign_stubs dir_imps cost_centre_info
+ dir_imps cost_centre_info
stg_binds hpc_info
+ ------------------ Convert to CPS --------------------
+ --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
+ continuationC <- cmmToRawCmm abstractC
------------------ Code output -----------------------
(stub_h_exists,stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
- dependencies abstractC
+ dependencies continuationC
return stub_c_exists
hscConst :: b -> a -> Comp b
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
------------------------------
-hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked)
-hscFileCheck hsc_env mod_summary = do {
+hscFileCheck :: HscEnv -> ModSummary -> Bool -> IO (Maybe HscChecked)
+hscFileCheck hsc_env mod_summary compileToCore = do {
-------------------
-- PARSE
-------------------
-- RENAME and TYPECHECK
-------------------
(tc_msgs, maybe_tc_result)
- <- _scc_ "Typecheck-Rename"
+ <- {-# SCC "Typecheck-Rename" #-}
tcRnModule hsc_env (ms_hsc_src mod_summary)
True{-save renamed syntax-}
rdr_module
; printErrorsAndWarnings dflags tc_msgs
; case maybe_tc_result of {
- Nothing -> return (Just (HscChecked rdr_module Nothing Nothing));
+ Nothing -> return (Just (HscChecked rdr_module Nothing Nothing Nothing));
Just tc_result -> do
let type_env = tcg_type_env tc_result
md = ModDetails {
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"] }
+ md_modBreaks = emptyModBreaks,
+ md_rules = [panic "no rules"],
-- Rules are CoreRules, not the
-- RuleDecls we get out of the typechecker
+ md_vect_info = noVectInfo
+ -- 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
let doc = tcg_doc tc_result
hmi = tcg_hmi tc_result
return (decl,imports,exports,doc,hmi)
- return (Just (HscChecked rdr_module
+ maybeModGuts <-
+ if compileToCore then
+ deSugar hsc_env (ms_location mod_summary) tc_result
+ else
+ return Nothing
+ return (Just (HscChecked rdr_module
rnInfo
(Just (tcg_binds tc_result,
tcg_rdr_env tc_result,
- md))))
+ md))
+ (fmap mg_binds maybeModGuts)))
}}}}
case maybe_cmm of
Nothing -> return False
Just cmm -> do
- codeOutput dflags no_mod no_loc NoStubs [] [cmm]
+ --continuationC <- cmmCPS dflags [cmm] >>= cmmToRawCmm
+ continuationC <- cmmToRawCmm [cmm]
+ codeOutput dflags no_mod no_loc NoStubs [] continuationC
return True
where
no_mod = panic "hscCmmFile: no_mod"
ml_obj_file = panic "hscCmmFile: no obj file" }
+myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer
+ -> IO (Either ErrMsg (Located (HsModule RdrName)))
myParseModule dflags src_filename maybe_src_buf
= -------------------------- Parser ----------------
showPass dflags "Parser" >>
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)
-- 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