[commit: ghc] master: StgLint: Enforce MultiValAlt liveness invariant only after unariser (a36b34c)
git at git.haskell.org
git at git.haskell.org
Tue Aug 29 23:11:02 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/a36b34c4821653e3db3ff24b903265a7750a3397/ghc
>---------------------------------------------------------------
commit a36b34c4821653e3db3ff24b903265a7750a3397
Author: Ben Gamari <bgamari.foss at gmail.com>
Date: Tue Aug 29 14:53:12 2017 -0400
StgLint: Enforce MultiValAlt liveness invariant only after unariser
The unariser ensures that we never use case binders that are void,
unboxed sums, or unboxed tuples. However, previously StgLint was
enforcing this invariant even before the unariser was running, giving
rise to spurious lint failures. Fix this. Following CoreLint, we
introduce a LintFlags environment to the linter monad, allowing for
additional flags to be easily accomodated in the future.
See #14118.
Test Plan: Build GHC with -dstg-lint
Reviewers: simonpj, austin
Subscribers: rwbarton, thomie
GHC Trac Issues: #14118
Differential Revision: https://phabricator.haskell.org/D3889
>---------------------------------------------------------------
a36b34c4821653e3db3ff24b903265a7750a3397
compiler/simplStg/SimplStg.hs | 11 ++++----
compiler/stgSyn/StgLint.hs | 60 +++++++++++++++++++++++++++----------------
2 files changed, 44 insertions(+), 27 deletions(-)
diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
index 4943f52..6c8b005 100644
--- a/compiler/simplStg/SimplStg.hs
+++ b/compiler/simplStg/SimplStg.hs
@@ -51,7 +51,8 @@ stg2stg dflags module_name binds
; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
(pprStgTopBindings processed_binds)
- ; let un_binds = unarise us1 processed_binds
+ ; let un_binds = stg_linter True "Unarise"
+ $ unarise us1 processed_binds
; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
(pprStgTopBindings un_binds)
@@ -60,9 +61,9 @@ stg2stg dflags module_name binds
}
where
- stg_linter = if gopt Opt_DoStgLinting dflags
- then lintStgTopBindings
- else ( \ _whodunnit binds -> binds )
+ stg_linter unarised
+ | gopt Opt_DoStgLinting dflags = lintStgTopBindings unarised
+ | otherwise = \ _whodunnit binds -> binds
-------------------------------------------
do_stg_pass (binds, us, ccs) to_do
@@ -91,7 +92,7 @@ stg2stg dflags module_name binds
= do -- report verbosely, if required
dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
(vcat (map ppr binds2))
- let linted_binds = stg_linter what binds2
+ let linted_binds = stg_linter False what binds2
return (linted_binds, us2, ccs)
-- return: processed binds
-- UniqueSupply for the next guy to use
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index baceca2..ac25ab5 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -56,11 +56,12 @@ generation. Solution: don't use it! (KSW 2000-05).
@lintStgTopBindings@ is the top-level interface function.
-}
-lintStgTopBindings :: String -> [StgTopBinding] -> [StgTopBinding]
+lintStgTopBindings :: Bool -- ^ have we run Unarise yet?
+ -> String -> [StgTopBinding] -> [StgTopBinding]
-lintStgTopBindings whodunnit binds
+lintStgTopBindings unarised whodunnit binds
= {-# SCC "StgLint" #-}
- case (initL (lint_binds binds)) of
+ case (initL unarised (lint_binds binds)) of
Nothing -> binds
Just msg -> pprPanic "" (vcat [
text "*** Stg Lint ErrMsgs: in" <+>
@@ -196,11 +197,16 @@ lintStgExpr (StgTick _ expr) = lintStgExpr expr
lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do
_ <- MaybeT $ lintStgExpr scrut
+ lf <- liftMaybeT getLintFlags
in_scope <- MaybeT $ liftM Just $
case alts_type of
AlgAlt tc -> check_bndr (tyConPrimRep tc) >> return True
PrimAlt rep -> check_bndr [rep] >> return True
- MultiValAlt _ -> return False -- Binder is always dead in this case
+ -- Case binders of unboxed tuple or unboxed sum type always dead
+ -- after the unariser has run. See Note [Post-unarisation invariants].
+ MultiValAlt _
+ | lf_unarised lf -> return False
+ | otherwise -> return True
PolyAlt -> return True
MaybeT $ addInScopeVars [bndr | in_scope] $
@@ -275,12 +281,17 @@ lintAlt scrut_ty (DataAlt con, args, rhs) = do
-}
newtype LintM a = LintM
- { unLintM :: [LintLocInfo] -- Locations
+ { unLintM :: LintFlags
+ -> [LintLocInfo] -- Locations
-> IdSet -- Local vars in scope
-> Bag MsgDoc -- Error messages so far
-> (a, Bag MsgDoc) -- Result and error messages (if any)
}
+data LintFlags = LintFlags { lf_unarised :: !Bool
+ -- ^ have we run the unariser yet?
+ }
+
data LintLocInfo
= RhsOf Id -- The variable bound
| LambdaBodyOf [Id] -- The lambda-binder
@@ -303,20 +314,22 @@ pp_binders bs
pp_binder b
= hsep [ppr b, dcolon, ppr (idType b)]
-initL :: LintM a -> Maybe MsgDoc
-initL (LintM m)
- = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
+initL :: Bool -> LintM a -> Maybe MsgDoc
+initL unarised (LintM m)
+ = case (m lf [] emptyVarSet emptyBag) of { (_, errs) ->
if isEmptyBag errs then
Nothing
else
Just (vcat (punctuate blankLine (bagToList errs)))
}
+ where
+ lf = LintFlags unarised
instance Functor LintM where
fmap = liftM
instance Applicative LintM where
- pure a = LintM $ \_loc _scope errs -> (a, errs)
+ pure a = LintM $ \_lf _loc _scope errs -> (a, errs)
(<*>) = ap
(*>) = thenL_
@@ -325,21 +338,21 @@ instance Monad LintM where
(>>) = (*>)
thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k = LintM $ \loc scope errs
- -> case unLintM m loc scope errs of
- (r, errs') -> unLintM (k r) loc scope errs'
+thenL m k = LintM $ \lf loc scope errs
+ -> case unLintM m lf loc scope errs of
+ (r, errs') -> unLintM (k r) lf loc scope errs'
thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k = LintM $ \loc scope errs
- -> case unLintM m loc scope errs of
- (_, errs') -> unLintM k loc scope errs'
+thenL_ m k = LintM $ \lf loc scope errs
+ -> case unLintM m lf loc scope errs of
+ (_, errs') -> unLintM k lf loc scope errs'
checkL :: Bool -> MsgDoc -> LintM ()
checkL True _ = return ()
checkL False msg = addErrL msg
addErrL :: MsgDoc -> LintM ()
-addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc)
+addErrL msg = LintM $ \_lf loc _scope errs -> ((), addErr errs msg loc)
addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
addErr errs_so_far msg locs
@@ -350,14 +363,17 @@ addErr errs_so_far msg locs
mk_msg [] = msg
addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m = LintM $ \loc scope errs
- -> unLintM m (extra_loc:loc) scope errs
+addLoc extra_loc m = LintM $ \lf loc scope errs
+ -> unLintM m lf (extra_loc:loc) scope errs
addInScopeVars :: [Id] -> LintM a -> LintM a
-addInScopeVars ids m = LintM $ \loc scope errs
+addInScopeVars ids m = LintM $ \lf loc scope errs
-> let
new_set = mkVarSet ids
- in unLintM m loc (scope `unionVarSet` new_set) errs
+ in unLintM m lf loc (scope `unionVarSet` new_set) errs
+
+getLintFlags :: LintM LintFlags
+getLintFlags = LintM $ \lf _loc _scope errs -> (lf, errs)
{-
Checking function applications: we only check that the type has the
@@ -457,7 +473,7 @@ stgEqType orig_ty1 orig_ty2
-- Type variables in particular
checkInScope :: Id -> LintM ()
-checkInScope id = LintM $ \loc scope errs
+checkInScope id = LintM $ \_lf loc scope errs
-> if isLocalId id && not (id `elemVarSet` scope) then
((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
text "is out of scope"]) loc)
@@ -465,7 +481,7 @@ checkInScope id = LintM $ \loc scope errs
((), errs)
checkTys :: Type -> Type -> MsgDoc -> LintM ()
-checkTys ty1 ty2 msg = LintM $ \loc _scope errs
+checkTys ty1 ty2 msg = LintM $ \_lf loc _scope errs
-> if (ty1 `stgEqType` ty2)
then ((), errs)
else ((), addErr errs msg loc)
More information about the ghc-commits
mailing list