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 )
+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 CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
import TyCon ( isDataTyCon )
-import Packages ( mkHomeModules )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import ParserCore
import ParserCoreUtils
import FastString
-import Maybes ( expectJust )
+import UniqFM ( emptyUFM )
import Bag ( unitBag )
import Monad ( unless )
import IO
= 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))
liftIO $ do
if recomp
then showMsg "Compiling "
- else showMsg "Skipping "
-
-
+ else if verbosity (hsc_dflags hsc_env) >= 1
+ then showMsg "Skipping "
+ else return ()
--------------------------------------------------------------
-- FrontEnds
-------------------
-- 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 tc_result
--------------------------------------------------------------
-- Simplifiers
<- {-# SCC "MkFinalIface" #-}
mkIface hsc_env maybe_old_iface simpl_result details
-- Emit external core
- emitExternalCore (hsc_dflags hsc_env) 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
dflags = hsc_dflags hsc_env
location = ms_location mod_summary
----------------- 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
------------------ Code output -----------------------
; 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_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
}}
-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}
\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 }
- -- Desugar it
- ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
-
-- Flatten it
; flat_expr <- flattenExpr hsc_env ds_expr
; bcos <- coreExprToBCOs dflags prepd_expr
-- link it
- ; hval <- linkExpr hsc_env bcos
+ ; hval <- linkExpr hsc_env srcspan bcos
; return hval
}
projects / ghc-hetmet.git / blobdiff