projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Add Outputable.blankLine and use it
[ghc-hetmet.git]
/
compiler
/
coreSyn
/
CoreLint.lhs
diff --git
a/compiler/coreSyn/CoreLint.lhs
b/compiler/coreSyn/CoreLint.lhs
index
8d0304a
..
a3ba3ae
100644
(file)
--- a/
compiler/coreSyn/CoreLint.lhs
+++ b/
compiler/coreSyn/CoreLint.lhs
@@
-28,6
+28,7
@@
import VarEnv
import VarSet
import Name
import Id
import VarSet
import Name
import Id
+import IdInfo
import PprCore
import ErrUtils
import SrcLoc
import PprCore
import ErrUtils
import SrcLoc
@@
-55,17
+56,17
@@
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}
-endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
endPass = dumpAndLint dumpIfSet_core
endPass = dumpAndLint dumpIfSet_core
-endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
endPassIf cond = dumpAndLint (dumpIf_core cond)
endPassIf cond = dumpAndLint (dumpIf_core cond)
-endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
endIteration = dumpAndLint dumpIfSet_dyn
dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
endIteration = dumpAndLint dumpIfSet_dyn
dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
- -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+ -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
dumpAndLint dump dflags pass_name dump_flag binds
= do
-- Report result size if required
dumpAndLint dump dflags pass_name dump_flag binds
= do
-- Report result size if required
@@
-78,8
+79,6
@@
dumpAndLint dump dflags pass_name dump_flag binds
-- Type check
lintCoreBindings dflags pass_name binds
-- Type check
lintCoreBindings dflags pass_name binds
-
- return binds
\end{code}
\end{code}
@@
-227,7
+226,10
@@
lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
where
binder_ty = idType binder
maybeDmdTy = idNewStrictness_maybe binder
where
binder_ty = idType binder
maybeDmdTy = idNewStrictness_maybe binder
- bndr_vars = varSetElems (idFreeVars binder)
+ bndr_vars = varSetElems (idFreeVars binder `unionVarSet` wkr_vars)
+ wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info)
+ | otherwise = emptyVarSet
+ wkr_info = idWorkerInfo binder
lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
| otherwise = return ()
\end{code}
lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
| otherwise = return ()
\end{code}
@@
-299,7
+301,7
@@
lintCoreExpr (Let (NonRec bndr rhs) body)
lintCoreExpr (Let (Rec pairs) body)
= lintAndScopeIds bndrs $ \_ ->
lintCoreExpr (Let (Rec pairs) body)
= lintAndScopeIds bndrs $ \_ ->
- do { mapM (lintSingleBinding NotTopLevel Recursive) pairs
+ do { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
where
bndrs = map fst pairs
; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
where
bndrs = map fst pairs
@@
-349,7
+351,7
@@
lintCoreExpr e@(Case scrut var alt_ty alts) =
else lintAndScopeId var
; scope $ \_ ->
do { -- Check the alternatives
else lintAndScopeId var
; scope $ \_ ->
do { -- Check the alternatives
- mapM (lintCoreAlt scrut_ty alt_ty) alts
+ mapM_ (lintCoreAlt scrut_ty alt_ty) alts
; checkCaseAlts e scrut_ty alts
; return alt_ty } }
where
; checkCaseAlts e scrut_ty alts
; return alt_ty } }
where
@@
-548,7
+550,7
@@
lintBinder var linterF
| isTyVar var = lint_ty_bndr
| otherwise = lintIdBndr var linterF
where
| isTyVar var = lint_ty_bndr
| otherwise = lintIdBndr var linterF
where
- lint_ty_bndr = do { lintTy (tyVarKind var)
+ lint_ty_bndr = do { _ <- lintTy (tyVarKind var)
; subst <- getTvSubst
; let (subst', tv') = substTyVarBndr subst var
; updateTvSubst subst' (linterF tv') }
; subst <- getTvSubst
; let (subst', tv') = substTyVarBndr subst var
; updateTvSubst subst' (linterF tv') }
@@
-648,7
+650,7
@@
initL :: LintM a -> Maybe Message {- errors -}
initL m
= case unLintM m [] emptyTvSubst emptyBag of
(_, errs) | isEmptyBag errs -> Nothing
initL m
= case unLintM m [] emptyTvSubst emptyBag of
(_, errs) | isEmptyBag errs -> Nothing
- | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
+ | otherwise -> Just (vcat (punctuate blankLine (bagToList errs)))
\end{code}
\begin{code}
\end{code}
\begin{code}
@@
-715,7
+717,7
@@
lookupIdInScope id
= do { subst <- getTvSubst
; case lookupInScope (getTvInScope subst) id of
Just v -> return v
= do { subst <- getTvSubst
; case lookupInScope (getTvInScope subst) id of
Just v -> return v
- Nothing -> do { addErrL out_of_scope
+ Nothing -> do { _ <- addErrL out_of_scope
; return id } }
where
out_of_scope = ppr id <+> ptext (sLit "is out of scope")
; return id } }
where
out_of_scope = ppr id <+> ptext (sLit "is out of scope")