projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2000-11-10 15:12:50 by simonpj]
[ghc-hetmet.git]
/
ghc
/
compiler
/
coreSyn
/
CoreLint.lhs
diff --git
a/ghc/compiler/coreSyn/CoreLint.lhs
b/ghc/compiler/coreSyn/CoreLint.lhs
index
df54d8f
..
ccd3afa
100644
(file)
--- a/
ghc/compiler/coreSyn/CoreLint.lhs
+++ b/
ghc/compiler/coreSyn/CoreLint.lhs
@@
-7,15
+7,13
@@
module CoreLint (
lintCoreBindings,
lintUnfolding,
module CoreLint (
lintCoreBindings,
lintUnfolding,
- beginPass, endPass, endPassWithRules
+ showPass, endPass, endPassWithRules
) where
#include "HsVersions.h"
import IO ( hPutStr, hPutStrLn, stdout )
) where
#include "HsVersions.h"
import IO ( hPutStr, hPutStrLn, stdout )
-import CmdLineOpts ( DynFlags, dopt_D_show_passes, dopt_DoCoreLinting,
- opt_PprStyle_Debug )
import CoreSyn
import Rules ( RuleBase, pprRuleBase )
import CoreFVs ( idFreeVars, mustHaveLocalBinding )
import CoreSyn
import Rules ( RuleBase, pprRuleBase )
import CoreFVs ( idFreeVars, mustHaveLocalBinding )
@@
-29,7
+27,7
@@
import VarSet
import Subst ( mkTyVarSubst, substTy )
import Name ( getSrcLoc )
import PprCore
import Subst ( mkTyVarSubst, substTy )
import Name ( getSrcLoc )
import PprCore
-import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message,
+import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message, showPass,
ErrMsg, addErrLocHdrLine, pprBagOfErrors,
WarnMsg, pprBagOfWarnings)
import SrcLoc ( SrcLoc, noSrcLoc )
ErrMsg, addErrLocHdrLine, pprBagOfErrors,
WarnMsg, pprBagOfWarnings)
import SrcLoc ( SrcLoc, noSrcLoc )
@@
-40,8
+38,9
@@
import Type ( Type, tyVarsOfType,
isUnboxedTupleType,
hasMoreBoxityInfo
)
isUnboxedTupleType,
hasMoreBoxityInfo
)
-import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
+import TyCon ( isPrimTyCon )
import BasicTypes ( RecFlag(..), isNonRec )
import BasicTypes ( RecFlag(..), isNonRec )
+import CmdLineOpts
import Maybe
import Outputable
import Maybe
import Outputable
@@
-59,14
+58,6
@@
place for them. They print out stuff before and after core passes,
and do Core Lint when necessary.
\begin{code}
and do Core Lint when necessary.
\begin{code}
-beginPass :: DynFlags -> String -> IO ()
-beginPass dflags pass_name
- | dopt_D_show_passes dflags
- = hPutStrLn stdout ("*** " ++ pass_name)
- | otherwise
- = return ()
-
-
endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind]
endPass dflags pass_name dump_flag binds
= do
endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind]
endPass dflags pass_name dump_flag binds
= do
@@
-81,7
+72,7
@@
endPassWithRules dflags pass_name dump_flag binds rules
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
- if dopt_D_show_passes dflags then
+ if dopt Opt_D_show_passes dflags then
hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
else
return ()
hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
else
return ()
@@
-134,7
+125,7
@@
Outstanding issues:
lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
lintCoreBindings dflags whoDunnit binds
lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
lintCoreBindings dflags whoDunnit binds
- | not (dopt_DoCoreLinting dflags)
+ | not (dopt Opt_DoCoreLinting dflags)
= return ()
lintCoreBindings dflags whoDunnit binds
= return ()
lintCoreBindings dflags whoDunnit binds
@@
-157,7
+148,7
@@
lintCoreBindings dflags whoDunnit binds
returnL ()
lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
returnL ()
lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
- done_lint = doIfSet_dyn dflags dopt_D_show_passes
+ done_lint = doIfSet_dyn dflags Opt_D_show_passes
(hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
warn warnings
= vcat [
(hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
warn warnings
= vcat [
@@
-198,7
+189,7
@@
lintUnfolding :: DynFlags
-> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
lintUnfolding dflags locn vars expr
-> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
lintUnfolding dflags locn vars expr
- | not (dopt_DoCoreLinting dflags)
+ | not (dopt Opt_DoCoreLinting dflags)
= (Nothing, Nothing)
| otherwise
= (Nothing, Nothing)
| otherwise