summaryrefslogtreecommitdiff
path: root/compiler/stgSyn
diff options
context:
space:
mode:
authorÖmer Sinan Ağacan <omeragacan@gmail.com>2018-02-18 11:12:53 -0500
committerBen Gamari <ben@smart-cactus.org>2018-02-18 11:57:46 -0500
commit7f389a580f42a105623853adad15ab3323b41ed5 (patch)
treece072fb7732bd1626ed9ed214e60d2bdd5dee848 /compiler/stgSyn
parentfc33f8b31b9c23cc12f02a028bbaeab06ba8fe96 (diff)
downloadhaskell-7f389a580f42a105623853adad15ab3323b41ed5.tar.gz
StgLint overhaul
- Remove all type checks - Check two STG invariants (no unboxed let bindings, variables defined before used) and post-unarisation invariants. See the module header and #14787. This version validates with `-dstg-lint` added to `GhcStage2HcOpts` and `GhcLibHcOpts` and `EXTRA_HC_OPTS`. Unarise changes: - `unariseConArgBinder` and `unariseFunArgBinder` functions were almost the same; only difference was when unarising fun args we keep void args while in con args we drop them. A new function `unariseArgBinder` added with a `Bool` argument for whether we're unarising a con arg. `unariseConArgBinder` and `unariseFunArgBinder` are now defined as unariseConArgBinder = unarsieArgBinder True -- data con unariseFunArgBinder = unariseArgBinder False -- not data con - A bug in `unariseConArgBinder` and `unariseFunArgBinder` (which are just calls to `unariseArgBinder` now) that invalidated the post-unarise invariants when the argument has single type rep (i.e. `length (typePrimRep x) == 1`) fixed. This isn't a correctness issue (it's fine not to unarise if a variable is already represented as single value), but it triggers StgLint. Test Plan: - Pass testsuite with `-dstg-lint` [done] - Boot stage2 (including libraries) with `-dstg-lint` [done] Reviewers: simonpj, bgamari Reviewed By: bgamari Subscribers: duog, rwbarton, thomie, carter GHC Trac Issues: #14787 Differential Revision: https://phabricator.haskell.org/D4404
Diffstat (limited to 'compiler/stgSyn')
-rw-r--r--compiler/stgSyn/StgLint.hs459
-rw-r--r--compiler/stgSyn/StgSyn.hs1
2 files changed, 147 insertions, 313 deletions
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index 70231f2863..bb2064ab48 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -1,10 +1,36 @@
-{-
+{- |
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-\section[StgLint]{A ``lint'' pass to check for Stg correctness}
--}
+A lint pass to check basic STG invariants:
+
+- Variables should be defined before used.
+
+- Let bindings should not have unboxed types (unboxed bindings should only
+ appear in case), except when they're join points (see Note [CoreSyn let/app
+ invariant] and #14117).
+
+- If linting after unarisation, invariants listed in Note [Post-unarisation
+ invariants].
+
+Because we don't have types and coercions in STG we can't really check types
+here.
+
+Some history:
-{-# LANGUAGE CPP #-}
+StgLint used to check types, but it never worked and so it was disabled in 2000
+with this note:
+
+ WARNING:
+ ~~~~~~~~
+
+ This module has suffered bit-rot; it is likely to yield lint errors
+ for Stg code that is currently perfectly acceptable for code
+ generation. Solution: don't use it! (KSW 2000-05).
+
+Since then there were some attempts at enabling it again, as summarised in
+#14787. It's finally decided that we remove all type checking and only look for
+basic properties listed above.
+-}
module StgLint ( lintStgTopBindings ) where
@@ -12,66 +38,43 @@ import GhcPrelude
import StgSyn
+import DynFlags
import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import Id ( Id, idType, isLocalId, isJoinId )
import VarSet
import DataCon
import CoreSyn ( AltCon(..) )
-import PrimOp ( primOpType )
-import Literal ( literalType )
-import Maybes
import Name ( getSrcLoc )
import ErrUtils ( MsgDoc, Severity(..), mkLocMessage )
import Type
import RepType
-import TyCon
-import Util
import SrcLoc
import Outputable
+import qualified ErrUtils as Err
+import Control.Applicative ((<|>))
import Control.Monad
-#include "HsVersions.h"
-
-{-
-Checks for
- (a) *some* type errors
- (b) locally-defined variables used but not defined
-
-
-Note: unless -dverbose-stg is on, display of lint errors will result
-in "panic: bOGUS_LVs".
-
-WARNING:
-~~~~~~~~
-
-This module has suffered bit-rot; it is likely to yield lint errors
-for Stg code that is currently perfectly acceptable for code
-generation. Solution: don't use it! (KSW 2000-05).
-
-
-************************************************************************
-* *
-\subsection{``lint'' for various constructs}
-* *
-************************************************************************
-
-@lintStgTopBindings@ is the top-level interface function.
--}
-
-lintStgTopBindings :: Bool -- ^ have we run Unarise yet?
- -> String -> [StgTopBinding] -> [StgTopBinding]
+lintStgTopBindings :: DynFlags
+ -> Bool -- ^ have we run Unarise yet?
+ -> String -- ^ who produced the STG?
+ -> [StgTopBinding]
+ -> IO ()
-lintStgTopBindings unarised whodunnit binds
+lintStgTopBindings dflags unarised whodunnit binds
= {-# SCC "StgLint" #-}
- case (initL unarised (lint_binds binds)) of
- Nothing -> binds
- Just msg -> pprPanic "" (vcat [
- text "*** Stg Lint ErrMsgs: in" <+>
- text whodunnit <+> text "***",
- msg,
- text "*** Offending Program ***",
- pprStgTopBindings binds,
- text "*** End of Offense ***"])
+ case initL unarised (lint_binds binds) of
+ Nothing ->
+ return ()
+ Just msg -> do
+ putLogMsg dflags NoReason Err.SevDump noSrcSpan
+ (defaultDumpStyle dflags)
+ (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
+ text whodunnit <+> text "***",
+ msg,
+ text "*** Offending Program ***",
+ pprStgTopBindings binds,
+ text "*** End of Offense ***"])
+ Err.ghcExit dflags 1
where
lint_binds :: [StgTopBinding] -> LintM ()
@@ -84,13 +87,12 @@ lintStgTopBindings unarised whodunnit binds
lint_bind (StgTopLifted bind) = lintStgBinds bind
lint_bind (StgTopStringLit v _) = return [v]
-lintStgArg :: StgArg -> LintM (Maybe Type)
-lintStgArg (StgLitArg lit) = return (Just (literalType lit))
-lintStgArg (StgVarArg v) = lintStgVar v
+lintStgArg :: StgArg -> LintM ()
+lintStgArg (StgLitArg _) = return ()
+lintStgArg (StgVarArg v) = lintStgVar v
-lintStgVar :: Id -> LintM (Maybe Kind)
-lintStgVar v = do checkInScope v
- return (Just (idType v))
+lintStgVar :: Id -> LintM ()
+lintStgVar id = checkInScope id
lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
lintStgBinds (StgNonRec binder rhs) = do
@@ -107,80 +109,50 @@ lintStgBinds (StgRec pairs)
lint_binds_help :: (Id, StgRhs) -> LintM ()
lint_binds_help (binder, rhs)
= addLoc (RhsOf binder) $ do
- -- Check the rhs
- _maybe_rhs_ty <- lintStgRhs rhs
-
- -- Check binder doesn't have unlifted type
- checkL (isJoinId binder || not (isUnliftedType binder_ty))
+ lintStgRhs rhs
+ -- Check binder doesn't have unlifted type or it's a join point
+ checkL (isJoinId binder || not (isUnliftedType (idType binder)))
(mkUnliftedTyMsg binder rhs)
- -- Check match to RHS type
- -- Actually we *can't* check the RHS type, because
- -- unsafeCoerce means it really might not match at all
- -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce...
- -- case maybe_rhs_ty of
- -- Nothing -> return ()
- -- Just rhs_ty -> checkTys binder_ty
- -- rhs_ty
- --- (mkRhsMsg binder rhs_ty)
-
- return ()
- where
- binder_ty = idType binder
-
-lintStgRhs :: StgRhs -> LintM (Maybe Type) -- Just ty => type is exact
+lintStgRhs :: StgRhs -> LintM ()
lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
= lintStgExpr expr
lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
= addLoc (LambdaBodyOf binders) $
- addInScopeVars binders $ runMaybeT $ do
- body_ty <- MaybeT $ lintStgExpr expr
- return (mkFunTys (map idType binders) body_ty)
+ addInScopeVars binders $
+ lintStgExpr expr
lintStgRhs rhs@(StgRhsCon _ con args) = do
- -- TODO: Check arg_tys
when (isUnboxedTupleCon con || isUnboxedSumCon con) $
addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
ppr rhs)
- runMaybeT $ do
- arg_tys <- mapM (MaybeT . lintStgArg) args
- MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
- where
- con_ty = dataConRepType con
-
-lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Just ty => type is exact
+ mapM_ lintStgArg args
+ mapM_ checkPostUnariseConArg args
-lintStgExpr (StgLit l) = return (Just (literalType l))
+lintStgExpr :: StgExpr -> LintM ()
-lintStgExpr e@(StgApp fun args) = runMaybeT $ do
- fun_ty <- MaybeT $ lintStgVar fun
- arg_tys <- mapM (MaybeT . lintStgArg) args
- MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
+lintStgExpr (StgLit _) = return ()
-lintStgExpr e@(StgConApp con args _arg_tys) = runMaybeT $ do
- -- TODO: Check arg_tys
- arg_tys <- mapM (MaybeT . lintStgArg) args
- MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
- where
- con_ty = dataConRepType con
+lintStgExpr (StgApp fun args) = do
+ lintStgVar fun
+ mapM_ lintStgArg args
-lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do
- arg_tys <- mapM (MaybeT . lintStgArg) args
- MaybeT $ checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
- where
- op_ty = primOpType op
+lintStgExpr app@(StgConApp con args _arg_tys) = do
+ -- unboxed sums should vanish during unarise
+ lf <- getLintFlags
+ when (lf_unarised lf && isUnboxedSumCon con) $
+ addErrL (text "Unboxed sum after unarise:" $$
+ ppr app)
+ mapM_ lintStgArg args
+ mapM_ checkPostUnariseConArg args
-lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do
- -- We don't have enough type information to check
- -- the application for StgFCallOp and StgPrimCallOp; ToDo
- _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args
- return res_ty
+lintStgExpr (StgOpApp _ args _) =
+ mapM_ lintStgArg args
-lintStgExpr (StgLam bndrs _) = do
- addErrL (text "Unexpected StgLam" <+> ppr bndrs)
- return Nothing
+lintStgExpr lam@(StgLam _ _) =
+ addErrL (text "Unexpected StgLam" <+> ppr lam)
lintStgExpr (StgLet binds body) = do
binders <- lintStgBinds binds
@@ -196,83 +168,33 @@ lintStgExpr (StgLetNoEscape binds body) = do
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
- -- 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] $
- lintStgAlts alts scrut_ty
- where
- scrut_ty = idType bndr
- scrut_reps = typePrimRep scrut_ty
- check_bndr reps = checkL (scrut_reps == reps) bad_bndr
- where
- bad_bndr = mkDefltMsg bndr reps
-
-lintStgAlts :: [StgAlt]
- -> Type -- Type of scrutinee
- -> LintM (Maybe Type) -- Just ty => type is accurage
-
-lintStgAlts alts scrut_ty = do
- maybe_result_tys <- mapM (lintAlt scrut_ty) alts
-
- -- Check the result types
- case catMaybes (maybe_result_tys) of
- [] -> return Nothing
-
- (first_ty:_tys) -> do -- mapM_ check tys
- return (Just first_ty)
- where
- -- check ty = checkTys first_ty ty (mkCaseAltMsg alts)
- -- We can't check that the alternatives have the
- -- same type, because they don't, with unsafeCoerce#
-
-lintAlt :: Type -> (AltCon, [Id], StgExpr) -> LintM (Maybe Type)
-lintAlt _ (DEFAULT, _, rhs)
- = lintStgExpr rhs
-
-lintAlt scrut_ty (LitAlt lit, _, rhs) = do
- checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty)
- lintStgExpr rhs
-
-lintAlt scrut_ty (DataAlt con, args, rhs) = do
- case splitTyConApp_maybe scrut_ty of
- Just (tycon, tys_applied) | isAlgTyCon tycon &&
- not (isNewTyCon tycon) -> do
- let
- cons = tyConDataCons tycon
- arg_tys = dataConInstArgTys con tys_applied
- -- This does not work for existential constructors
-
- checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)
- checkL (args `lengthIs` dataConRepArity con) (mkAlgAltMsg3 con args)
- when (isVanillaDataCon con) $
- mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
- return ()
- _ ->
- addErrL (mkAltMsg1 scrut_ty)
-
- addInScopeVars args $
- lintStgExpr rhs
- where
- check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
+lintStgExpr (StgCase scrut bndr alts_type alts) = do
+ lintStgExpr scrut
- -- elem: yes, the elem-list here can sometimes be long-ish,
- -- but as it's use-once, probably not worth doing anything different
- -- We give it its own copy, so it isn't overloaded.
- elem _ [] = False
- elem x (y:ys) = x==y || elem x ys
+ lf <- getLintFlags
+ let in_scope =
+ case alts_type of
+ AlgAlt _ -> True
+ PrimAlt _ -> True
+ -- Case binders of unboxed tuple or unboxed sum type always dead
+ -- after the unariser has run.
+ -- See Note [Post-unarisation invariants].
+ MultiValAlt _ -> not (lf_unarised lf)
+ PolyAlt -> True
+
+ addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
+
+lintAlt :: (AltCon, [Id], StgExpr) -> LintM ()
+
+lintAlt (DEFAULT, _, rhs) =
+ lintStgExpr rhs
+
+lintAlt (LitAlt _, _, rhs) =
+ lintStgExpr rhs
+
+lintAlt (DataAlt _, bndrs, rhs) = do
+ mapM_ checkPostUnariseBndr bndrs
+ addInScopeVars bndrs (lintStgExpr rhs)
{-
************************************************************************
@@ -353,6 +275,44 @@ checkL :: Bool -> MsgDoc -> LintM ()
checkL True _ = return ()
checkL False msg = addErrL msg
+-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
+checkPostUnariseBndr :: Id -> LintM ()
+checkPostUnariseBndr bndr = do
+ lf <- getLintFlags
+ when (lf_unarised lf) $
+ forM_ (checkPostUnariseId bndr) $ \unexpected ->
+ addErrL $
+ text "After unarisation, binder " <>
+ ppr bndr <> text " has " <> text unexpected <> text " type " <>
+ ppr (idType bndr)
+
+-- Arguments shouldn't have sum, tuple, or void types.
+checkPostUnariseConArg :: StgArg -> LintM ()
+checkPostUnariseConArg arg = case arg of
+ StgLitArg _ ->
+ return ()
+ StgVarArg id -> do
+ lf <- getLintFlags
+ when (lf_unarised lf) $
+ forM_ (checkPostUnariseId id) $ \unexpected ->
+ addErrL $
+ text "After unarisation, arg " <>
+ ppr id <> text " has " <> text unexpected <> text " type " <>
+ ppr (idType id)
+
+-- Post-unarisation args and case alt binders should not have unboxed tuple,
+-- unboxed sum, or void types. Return what the binder is if it is one of these.
+checkPostUnariseId :: Id -> Maybe String
+checkPostUnariseId id =
+ let
+ id_ty = idType id
+ is_sum, is_tuple, is_void :: Maybe String
+ is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"
+ is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"
+ is_void = guard (isVoidTy id_ty) >> return "void"
+ in
+ is_sum <|> is_tuple <|> is_void
+
addErrL :: MsgDoc -> LintM ()
addErrL msg = LintM $ \_lf loc _scope errs -> ((), addErr errs msg loc)
@@ -377,67 +337,6 @@ addInScopeVars ids m = LintM $ \lf loc scope errs
getLintFlags :: LintM LintFlags
getLintFlags = LintM $ \lf _loc _scope errs -> (lf, errs)
-{-
-Checking function applications: we only check that the type has the
-right *number* of arrows, we don't actually compare the types. This
-is because we can't expect the types to be equal - the type
-applications and type lambdas that we use to calculate accurate types
-have long since disappeared.
--}
-
-checkFunApp :: Type -- The function type
- -> [Type] -- The arg type(s)
- -> MsgDoc -- Error message
- -> LintM (Maybe Type) -- Just ty => result type is accurate
-
-checkFunApp fun_ty arg_tys msg
- = do { case mb_msg of
- Just msg -> addErrL msg
- Nothing -> return ()
- ; return mb_ty }
- where
- (mb_ty, mb_msg) = cfa True fun_ty arg_tys
-
- cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result?
- , Maybe MsgDoc) -- Errors?
-
- cfa accurate fun_ty [] -- Args have run out; that's fine
- = (if accurate then Just fun_ty else Nothing, Nothing)
-
- cfa accurate fun_ty arg_tys@(arg_ty':arg_tys')
- | Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
- = if accurate && not (arg_ty `stgEqType` arg_ty')
- then (Nothing, Just msg) -- Arg type mismatch
- else cfa accurate res_ty arg_tys'
-
- | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty
- = cfa False fun_ty' arg_tys
-
- | Just (tc,tc_args) <- splitTyConApp_maybe fun_ty
- , isNewTyCon tc
- = if tc_args `lengthLessThan` tyConArity tc
- then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg )
- (Nothing, Nothing) -- This is odd, but I've seen it
- else cfa False (newTyConInstRhs tc tc_args) arg_tys
-
- | Just tc <- tyConAppTyCon_maybe fun_ty
- , not (isTypeFamilyTyCon tc) -- Definite error
- = (Nothing, Just msg) -- Too many args
-
- | otherwise
- = (Nothing, Nothing)
-
--- | "Compare" types. We used to try a crude comparison of the type themselves,
--- but this is essentially impossible in STG as we have discarded both casts
--- and type applications, so types might look different but be the same. Now we
--- simply compare their runtime representations. See #14120.
-stgEqType :: Type -> Type -> Bool
-stgEqType ty1 ty2
- = reps1 == reps2
- where
- reps1 = typePrimRep ty1
- reps2 = typePrimRep ty2
-
checkInScope :: Id -> LintM ()
checkInScope id = LintM $ \_lf loc scope errs
-> if isLocalId id && not (id `elemVarSet` scope) then
@@ -446,72 +345,6 @@ checkInScope id = LintM $ \_lf loc scope errs
else
((), errs)
-checkTys :: Type -> Type -> MsgDoc -> LintM ()
-checkTys ty1 ty2 msg = LintM $ \_lf loc _scope errs
- -> if (ty1 `stgEqType` ty2)
- then ((), errs)
- else ((), addErr errs msg loc)
-
-_mkCaseAltMsg :: [StgAlt] -> MsgDoc
-_mkCaseAltMsg _alts
- = ($$) (text "In some case alternatives, type of alternatives not all same:")
- (Outputable.empty) -- LATER: ppr alts
-
-mkDefltMsg :: Id -> [PrimRep] -> MsgDoc
-mkDefltMsg bndr reps
- = ($$) (text "Binder of a case expression doesn't match representation of scrutinee:")
- (ppr bndr $$ ppr (idType bndr) $$ ppr reps)
-
-mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc
-mkFunAppMsg fun_ty arg_tys expr
- = vcat [text "In a function application, function type doesn't match arg types:",
- hang (text "Function type:") 4 (ppr fun_ty),
- hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys)),
- hang (text "Expression:") 4 (ppr expr)]
-
-mkRhsConMsg :: Type -> [Type] -> MsgDoc
-mkRhsConMsg fun_ty arg_tys
- = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
- hang (text "Constructor type:") 4 (ppr fun_ty),
- hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys))]
-
-mkAltMsg1 :: Type -> MsgDoc
-mkAltMsg1 ty
- = ($$) (text "In a case expression, type of scrutinee does not match patterns")
- (ppr ty)
-
-mkAlgAltMsg2 :: Type -> DataCon -> MsgDoc
-mkAlgAltMsg2 ty con
- = vcat [
- text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
- ppr ty,
- ppr con
- ]
-
-mkAlgAltMsg3 :: DataCon -> [Id] -> MsgDoc
-mkAlgAltMsg3 con alts
- = vcat [
- text "In some algebraic case alternative, number of arguments doesn't match constructor:",
- ppr con <+> parens (text "arity" <+> ppr (dataConRepArity con)),
- ppr alts
- ]
-
-mkAlgAltMsg4 :: Type -> Id -> MsgDoc
-mkAlgAltMsg4 ty arg
- = vcat [
- text "In some algebraic case alternative, type of argument doesn't match data constructor:",
- ppr ty,
- ppr arg
- ]
-
-_mkRhsMsg :: Id -> Type -> MsgDoc
-_mkRhsMsg binder ty
- = vcat [hsep [text "The type of this binder doesn't match the type of its RHS:",
- ppr binder],
- hsep [text "Binder's type:", ppr (idType binder)],
- hsep [text "Rhs type:", ppr ty]
- ]
-
mkUnliftedTyMsg :: Id -> StgRhs -> SDoc
mkUnliftedTyMsg binder rhs
= (text "Let(rec) binder" <+> quotes (ppr binder) <+>
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 330e2b409f..29d544103f 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -549,6 +549,7 @@ data AltType
= PolyAlt -- Polymorphic (a lifted type variable)
| MultiValAlt Int -- Multi value of this arity (unboxed tuple or sum)
-- the arity could indeed be 1 for unary unboxed tuple
+ -- or enum-like unboxed sums
| AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts
| PrimAlt PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts