projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Re-factor mkAtomicArgs and completeNonRecX
[ghc-hetmet.git]
/
compiler
/
main
/
HscMain.lhs
diff --git
a/compiler/main/HscMain.lhs
b/compiler/main/HscMain.lhs
index
986d2ce
..
6536068
100644
(file)
--- a/
compiler/main/HscMain.lhs
+++ b/
compiler/main/HscMain.lhs
@@
-41,7
+41,7
@@
import PrelNames ( iNTERACTIVE )
import Kind ( Kind )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
import Kind ( Kind )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
-import SrcLoc ( noSrcLoc )
+import SrcLoc ( noSrcLoc, getLoc )
import VarEnv ( emptyTidyEnv )
#endif
import VarEnv ( emptyTidyEnv )
#endif
@@
-68,7
+68,6
@@
import TidyPgm ( tidyProgram, mkBootModDetails )
import CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
import TyCon ( isDataTyCon )
import CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
import TyCon ( isDataTyCon )
-import Packages ( mkHomeModules )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
@@
-87,7
+86,7
@@
import MkExternalCore ( emitExternalCore )
import ParserCore
import ParserCoreUtils
import FastString
import ParserCore
import ParserCoreUtils
import FastString
-import Maybes ( expectJust )
+import UniqFM ( emptyUFM )
import Bag ( unitBag )
import Monad ( unless )
import IO
import Bag ( unitBag )
import Monad ( unless )
import IO
@@
-107,7
+106,8
@@
newHscEnv dflags
= do { eps_var <- newIORef initExternalPackageState
; us <- mkSplitUniqSupply 'r'
; nc_var <- newIORef (initNameCache us knownKeyNames)
= 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 = [],
; return (HscEnv { hsc_dflags = dflags,
hsc_targets = [],
hsc_mod_graph = [],
@@
-116,6
+116,7
@@
newHscEnv dflags
hsc_EPS = eps_var,
hsc_NC = nc_var,
hsc_FC = fc_var,
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 } ) }
hsc_global_rdr_env = emptyGlobalRdrEnv,
hsc_global_type_env = emptyNameEnv } ) }
@@
-217,6
+218,9
@@
data CompState
get :: Comp CompState
get = Comp $ \s -> return (s,s)
get :: Comp CompState
get = Comp $ \s -> return (s,s)
+modify :: (CompState -> CompState) -> Comp ()
+modify f = Comp $ \s -> return ((), f s)
+
gets :: (CompState -> a) -> Comp a
gets getter = do st <- get
return (getter st)
gets :: (CompState -> a) -> Comp a
gets getter = do st <- get
return (getter st)
@@
-253,6
+257,10
@@
hscMkCompiler norecomp messenger frontend backend
<- {-# SCC "checkOldIface" #-}
liftIO $ checkOldIface hsc_env mod_summary
source_unchanged mbOldIface
<- {-# SCC "checkOldIface" #-}
liftIO $ checkOldIface hsc_env mod_summary
source_unchanged mbOldIface
+ -- save the interface that comes back from checkOldIface.
+ -- In one-shot mode we don't have the old iface until this
+ -- point, when checkOldIface reads it from the disk.
+ modify (\s -> s{ compOldIface = mbCheckedIface })
case mbCheckedIface of
Just iface | not recomp_reqd
-> do messenger mbModIndex False
case mbCheckedIface of
Just iface | not recomp_reqd
-> do messenger mbModIndex False
@@
-390,9
+398,9
@@
batchMsg mb_mod_index recomp
liftIO $ do
if recomp
then showMsg "Compiling "
liftIO $ do
if recomp
then showMsg "Compiling "
- else showMsg "Skipping "
-
-
+ else if verbosity (hsc_dflags hsc_env) >= 2
+ then showMsg "Skipping "
+ else return ()
--------------------------------------------------------------
-- FrontEnds
--------------------------------------------------------------
-- FrontEnds
@@
-519,7
+527,7
@@
hscNormalIface simpl_result
<- {-# SCC "MkFinalIface" #-}
mkIface hsc_env maybe_old_iface simpl_result details
-- Emit external core
<- {-# 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) (mg_exports simpl_result) cg_guts -- Move this? --Lemmih 03/07/2006
dumpIfaceStats hsc_env
-------------------
dumpIfaceStats hsc_env
-------------------
@@
-572,7
+580,6
@@
hscCompile cgguts
cg_tycons = tycons,
cg_dir_imps = dir_imps,
cg_foreign = foreign_stubs,
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
cg_dep_pkgs = dependencies } = cgguts
dflags = hsc_dflags hsc_env
location = ms_location mod_summary
@@
-588,10
+595,10
@@
hscCompile cgguts
----------------- Convert to STG ------------------
(stg_binds, cost_centre_info)
<- {-# SCC "CoreToStg" #-}
----------------- 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" #-}
------------------ 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 -----------------------
foreign_stubs dir_imps cost_centre_info
stg_binds
------------------ Code output -----------------------
@@
-689,7
+696,7
@@
hscFileCheck hsc_env mod_summary = do {
hscCmmFile :: DynFlags -> FilePath -> IO Bool
hscCmmFile dflags filename = do
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
case maybe_cmm of
Nothing -> return False
Just cmm -> do
@@
-732,13
+739,13
@@
myParseModule dflags src_filename maybe_src_buf
}}
}}
-myCoreToStg dflags home_mods this_mod prepd_binds
+myCoreToStg dflags this_mod prepd_binds
= do
stg_binds <- {-# SCC "Core2Stg" #-}
= do
stg_binds <- {-# SCC "Core2Stg" #-}
- coreToStg home_mods prepd_binds
+ coreToStg (thisPackage dflags) prepd_binds
(stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
(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}
return (stg_binds2, cost_centre_info)
\end{code}
@@
-832,10
+839,8
@@
hscKcType hsc_env str
= do { maybe_type <- hscParseType (hsc_dflags hsc_env) str
; let icontext = hsc_IC hsc_env
; case maybe_type of {
= 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}
#endif
\end{code}
@@
-894,7
+899,8
@@
compileExpr :: HscEnv
compileExpr hsc_env this_mod rdr_env type_env tc_expr
= do { let { dflags = hsc_dflags hsc_env ;
compileExpr hsc_env this_mod rdr_env type_env tc_expr
= do { let { dflags = hsc_dflags hsc_env ;
- lint_on = dopt Opt_DoCoreLinting dflags }
+ lint_on = dopt Opt_DoCoreLinting dflags ;
+ !srcspan = getLoc tc_expr }
-- Desugar it
; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
-- Desugar it
; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
@@
-924,7
+930,7
@@
compileExpr hsc_env this_mod rdr_env type_env tc_expr
; bcos <- coreExprToBCOs dflags prepd_expr
-- link it
; bcos <- coreExprToBCOs dflags prepd_expr
-- link it
- ; hval <- linkExpr hsc_env bcos
+ ; hval <- linkExpr hsc_env srcspan bcos
; return hval
}
; return hval
}