projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix for warning message (bug #812)
[ghc-hetmet.git]
/
compiler
/
main
/
HscMain.lhs
diff --git
a/compiler/main/HscMain.lhs
b/compiler/main/HscMain.lhs
index
986d2ce
..
d25202f
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
@@
-217,6
+217,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
+256,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
+397,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
@@
-894,7
+901,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
+932,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
}