diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2021-01-12 19:30:55 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-01-22 15:02:45 -0500 |
| commit | 957b53760e50d072accc17c77948f18a10a4bb53 (patch) | |
| tree | 5099bcc355fc9a5047e5dac697511259f688e155 | |
| parent | 887eb6ec23eed243604f71c025d280c0b854f4c4 (diff) | |
| download | haskell-957b53760e50d072accc17c77948f18a10a4bb53.tar.gz | |
Core: introduce Alt/AnnAlt/IfaceAlt datatypes
Alt, AnnAlt and IfaceAlt were using triples. This patch makes them use
dedicated types so that we can try to make some fields strict (for
example) in the future.
54 files changed, 281 insertions, 266 deletions
diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs index bc9b114573..a8cc569548 100644 --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/GHC/ByteCode/Instr.hs @@ -222,7 +222,7 @@ pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T" pprCoreExprShort e = pprCoreExpr e pprCoreAltShort :: CoreAlt -> SDoc -pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr +pprCoreAltShort (Alt con args expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr instance Outputable BCInstr where ppr (STKCHECK n) = text "STKCHECK" <+> ppr n diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 523c8e3d79..230d3498ce 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -12,7 +12,7 @@ -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core ( -- * Main data types - Expr(..), Alt, Bind(..), AltCon(..), Arg, + Expr(..), Alt(..), Bind(..), AltCon(..), Arg, Tickish(..), TickishScoping(..), TickishPlacement(..), CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, @@ -75,7 +75,7 @@ module GHC.Core ( canUnfold, neverUnfoldGuidance, isStableSource, -- * Annotated expression data types - AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt(..), -- ** Operations on annotated expressions collectAnnArgs, collectAnnArgsTicks, @@ -282,7 +282,9 @@ type Arg b = Expr b -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in GHC.Core.Lint -type Alt b = (AltCon, [b], Expr b) +data Alt b + = Alt AltCon [b] (Expr b) + deriving (Data) -- | A case alternative constructor (i.e. pattern match) @@ -1834,10 +1836,10 @@ instance Outputable AltCon where ppr (LitAlt lit) = ppr lit ppr DEFAULT = text "__DEFAULT" -cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering -cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 +cmpAlt :: Alt a -> Alt a -> Ordering +cmpAlt (Alt con1 _ _) (Alt con2 _ _) = con1 `cmpAltCon` con2 -ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool +ltAlt :: Alt a -> Alt a -> Bool ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT cmpAltCon :: AltCon -> AltCon -> Ordering @@ -1936,7 +1938,7 @@ deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs) deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs] deTagAlt :: TaggedAlt t -> CoreAlt -deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs) +deTagAlt (Alt con bndrs rhs) = Alt con [b | TB b _ <- bndrs] (deTagExpr rhs) {- ************************************************************************ @@ -2136,7 +2138,7 @@ rhssOfBind (NonRec _ rhs) = [rhs] rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] rhssOfAlts :: [Alt b] -> [Expr b] -rhssOfAlts alts = [e | (_,_,e) <- alts] +rhssOfAlts alts = [e | Alt _ _ e <- alts] -- | Collapse all the bindings in the supplied groups into a single -- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group @@ -2299,7 +2301,7 @@ data AnnExpr' bndr annot | AnnCoercion Coercion -- | A clone of the 'Alt' type but allowing annotation at every tree node -type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) +data AnnAlt bndr annot = AnnAlt AltCon [bndr] (AnnExpr bndr annot) -- | A clone of the 'Bind' type but allowing annotation at every tree node data AnnBind bndr annot @@ -2344,7 +2346,7 @@ deAnnotate' (AnnCase scrut v t alts) = Case (deAnnotate scrut) v t (map deAnnAlt alts) deAnnAlt :: AnnAlt bndr annot -> Alt bndr -deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) +deAnnAlt (AnnAlt con args rhs) = Alt con args (deAnnotate rhs) deAnnBind :: AnnBind b annot -> Bind b deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index 92386a6d2f..bf5dab7bc3 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -268,7 +268,7 @@ expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr (mapUnionFV alt_fvs alts)) fv_cand in_scope acc where - alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) + alt_fvs (Alt _ bndrs rhs) = addBndrs bndrs (expr_fvs rhs) expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body)) @@ -326,7 +326,7 @@ exprOrphNames e go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty `unionNameSet` unionNameSets (map go_alt as) - go_alt (_,_,r) = go r + go_alt (Alt _ _ r) = go r -- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details exprsOrphNames :: [CoreExpr] -> NameSet @@ -756,8 +756,8 @@ freeVars = go (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts alts_fvs = unionFVss alts_fvs_s - fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), - (con, args, rhs2)) + fv_alt (Alt con args rhs) = (delBindersFV args (freeVarsOf rhs2), + (AnnAlt con args rhs2)) where rhs2 = go rhs diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 6dc84b91ab..104f53d8c9 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1304,8 +1304,8 @@ lintCaseExpr scrut var alt_ty alts = -- if there are any literal alternatives -- See GHC.Core Note [Case expression invariants] item (5) -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold - ; let isLitPat (LitAlt _, _ , _) = True - isLitPat _ = False + ; let isLitPat (Alt (LitAlt _) _ _) = True + isLitPat _ = False ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts) (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++ "expression with literal pattern in case " ++ @@ -1370,8 +1370,8 @@ checkCaseAlts e ty alts = increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest increasing_tag _ = True - non_deflt (DEFAULT, _, _) = False - non_deflt _ = True + non_deflt (Alt DEFAULT _ _) = False + non_deflt _ = True is_infinite_ty = case tyConAppTyCon_maybe ty of Nothing -> False @@ -1392,11 +1392,11 @@ lintCoreAlt :: Var -- Case binder -> LintM UsageEnv -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintCoreAlt _ _ _ alt_ty (DEFAULT, args, rhs) = +lintCoreAlt _ _ _ alt_ty (Alt DEFAULT args rhs) = do { lintL (null args) (mkDefaultArgsMsg args) ; lintAltExpr rhs alt_ty } -lintCoreAlt _case_bndr scrut_ty _ alt_ty (LitAlt lit, args, rhs) +lintCoreAlt _case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs) | litIsLifted lit = failWithL integerScrutinisedMsg | otherwise @@ -1406,7 +1406,7 @@ lintCoreAlt _case_bndr scrut_ty _ alt_ty (LitAlt lit, args, rhs) where lit_ty = literalType lit -lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(DataAlt con, args, rhs) +lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs) | isNewTyCon (dataConTyCon con) = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt) | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty @@ -2936,10 +2936,10 @@ dumpLoc (BodyOfLetRec bs@(_:_)) dumpLoc (AnExpr e) = (noSrcLoc, text "In the expression:" <+> ppr e) -dumpLoc (CaseAlt (con, args, _)) +dumpLoc (CaseAlt (Alt con args _)) = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) -dumpLoc (CasePat (con, args, _)) +dumpLoc (CasePat (Alt con args _)) = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) dumpLoc (CaseTy scrut) diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 6d6dd38b29..cc67143fba 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -211,7 +211,7 @@ mkWildCase scrut (Scaled w scrut_ty) res_ty alts mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr -- Build a strict application (case e2 of x -> e1 x) mkStrictApp fun arg (Scaled w arg_ty) res_ty - = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] + = Case arg arg_id res_ty [Alt DEFAULT [] (App fun (Var arg_id))] -- mkDefaultCase looks attractive here, and would be sound. -- But it uses (exprType alt_rhs) to compute the result type, -- whereas here we already know that the result type is res_ty @@ -231,8 +231,8 @@ mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr mkIfThenElse guard then_expr else_expr -- Not going to be refining, so okay to take the type of the "then" clause = mkWildCase guard (linear boolTy) (exprType then_expr) - [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! - (DataAlt trueDataCon, [], then_expr) ] + [ Alt (DataAlt falseDataCon) [] else_expr, -- Increasing order of tag! + Alt (DataAlt trueDataCon) [] then_expr ] castBottomExpr :: CoreExpr -> Type -> CoreExpr -- (castBottomExpr e ty), assuming that 'e' diverges, @@ -514,7 +514,7 @@ mkSmallTupleSelector vars the_var scrut_var scrut mkSmallTupleSelector1 vars the_var scrut_var scrut = ASSERT( notNull vars ) Case scrut scrut_var (idType the_var) - [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)] + [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)] -- | A generalization of 'mkTupleSelector', allowing the body -- of the case to be an arbitrary expression. @@ -568,7 +568,7 @@ mkSmallTupleCase [var] body _scrut_var scrut mkSmallTupleCase vars body scrut_var scrut -- One branch no refinement? = Case scrut scrut_var (exprType body) - [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)] + [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body] {- ************************************************************************ diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs index 2181abb304..03c0876138 100644 --- a/compiler/GHC/Core/Map/Expr.hs +++ b/compiler/GHC/Core/Map/Expr.hs @@ -350,11 +350,11 @@ instance TrieMap AltMap where instance Eq (DeBruijn CoreAlt) where D env1 a1 == D env2 a2 = go a1 a2 where - go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2) + go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2) = D env1 rhs1 == D env2 rhs2 - go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2) + go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2) = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 - go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2) + go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2) = dc1 == dc2 && D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 go _ _ = False @@ -372,17 +372,17 @@ ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) , am_lit = mapTM (filterTM f) alit } lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a -lkA env (DEFAULT, _, rhs) = am_deflt >.> lkG (D env rhs) -lkA env (LitAlt lit, _, rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) -lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc +lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs) +lkA env (Alt (LitAlt lit) _ rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) +lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc >=> lkG (D (extendCMEs env bs) rhs) xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a -xtA env (DEFAULT, _, rhs) f m = +xtA env (Alt DEFAULT _ rhs) f m = m { am_deflt = am_deflt m |> xtG (D env rhs) f } -xtA env (LitAlt l, _, rhs) f m = +xtA env (Alt (LitAlt l) _ rhs) f m = m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } -xtA env (DataAlt d, bs, rhs) f m = +xtA env (Alt (DataAlt d) bs rhs) f m = m { am_data = am_data m |> xtDNamed d |>> xtG (D (extendCMEs env bs) rhs) f } diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index fed664d6fb..99cfd1b15f 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -999,7 +999,7 @@ arityType env (Case scrut bndr _ alts) | otherwise -- In the remaining cases we may not push = takeWhileOneShot alts_type -- evaluation of the scrutinee in where - alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts] + alts_type = foldr1 andArityType [arityType env rhs | Alt _ _ rhs <- alts] arityType env (Let (NonRec j rhs) body) | Just join_arity <- isJoinId_maybe j @@ -1447,7 +1447,7 @@ etaInfoApp in_scope expr eis (subst1, b1) = Core.substBndr subst b alts' = map subst_alt alts ty' = etaInfoAppTy (Core.substTy subst ty) eis - subst_alt (con, bs, rhs) = (con, bs', go subst2 rhs eis) + subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis) where (subst2,bs') = Core.substBndrs subst1 bs go subst (Let b e) eis diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index 537bd931af..45e26acc4b 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -620,15 +620,15 @@ cseCase env scrut bndr ty alts arg_tys = tyConAppArgs (idType bndr3) -- See Note [CSE for case alternatives] - cse_alt (DataAlt con, args, rhs) - = (DataAlt con, args', tryForCSE new_env rhs) + cse_alt (Alt (DataAlt con) args rhs) + = Alt (DataAlt con) args' (tryForCSE new_env rhs) where (env', args') = addBinders alt_env args new_env = extendCSEnv env' con_expr con_target con_expr = mkAltExpr (DataAlt con) args' arg_tys - cse_alt (con, args, rhs) - = (con, args', tryForCSE env' rhs) + cse_alt (Alt con args rhs) + = Alt con args' (tryForCSE env' rhs) where (env', args') = addBinders alt_env args @@ -636,11 +636,11 @@ combineAlts :: CSEnv -> [OutAlt] -> [OutAlt] -- See Note [Combine case alternatives] combineAlts env alts | (Just alt1, rest_alts) <- find_bndr_free_alt alts - , (_,bndrs1,rhs1) <- alt1 + , Alt _ bndrs1 rhs1 <- alt1 , let filtered_alts = filterOut (identical_alt rhs1) rest_alts , not (equalLength rest_alts filtered_alts) = ASSERT2( null bndrs1, ppr alts ) - (DEFAULT, [], rhs1) : filtered_alts + Alt DEFAULT [] rhs1 : filtered_alts | otherwise = alts @@ -652,12 +652,12 @@ combineAlts env alts -- See Note [Combine case alts: awkward corner] find_bndr_free_alt [] = (Nothing, []) - find_bndr_free_alt (alt@(_,bndrs,_) : alts) + find_bndr_free_alt (alt@(Alt _ bndrs _) : alts) | null bndrs = (Just alt, alts) | otherwise = case find_bndr_free_alt alts of (mb_bf, alts) -> (mb_bf, alt:alts) - identical_alt rhs1 (_,_,rhs) = eqExpr in_scope rhs1 rhs + identical_alt rhs1 (Alt _ _ rhs) = eqExpr in_scope rhs1 rhs -- Even if this alt has binders, they will have been cloned -- If any of these binders are mentioned in 'rhs', then -- 'rhs' won't compare equal to 'rhs1' (which is from an diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs index 4df70ed176..aa1f2ee5a1 100644 --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -524,8 +524,8 @@ callArityAnal arity int (Case scrut bndr ty alts) (final_ae, Case scrut' bndr ty alts') where (alt_aes, alts') = unzip $ map go alts - go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e - in (ae, (dc, bndrs, e')) + go (Alt dc bndrs e) = let (ae, e') = callArityAnal arity int e + in (ae, Alt dc bndrs e') alt_ae = lubRess alt_aes (scrut_ae, scrut') = callArityAnal 0 int scrut final_ae = scrut_ae `both` alt_ae diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs index 1bbf96ca73..0807675d57 100644 --- a/compiler/GHC/Core/Opt/CallerCC.hs +++ b/compiler/GHC/Core/Opt/CallerCC.hs @@ -93,7 +93,7 @@ doExpr env (Let b rhs) = Let <$> doBind env b <*> doExpr env rhs doExpr env (Case scrut b ty alts) = Case <$> doExpr env scrut <*> pure b <*> pure ty <*> mapM doAlt alts where - doAlt (con, bs, rhs) = (con, bs,) <$> doExpr env rhs + doAlt (Alt con bs rhs) = Alt con bs <$> doExpr env rhs doExpr env (Cast expr co) = Cast <$> doExpr env expr <*> pure co doExpr env (Tick t e) = Tick t <$> doExpr env e doExpr _env e@(Type _) = pure e diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index ea5504c831..a4bc764d28 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -910,8 +910,8 @@ litEq is_eq = msum do_lit_eq platform lit expr = do guard (not (litIsLifted lit)) return (mkWildCase expr (unrestricted $ literalType lit) intPrimTy - [(DEFAULT, [], val_if_neq), - (LitAlt lit, [], val_if_eq)]) + [ Alt DEFAULT [] val_if_neq + , Alt (LitAlt lit) [] val_if_eq]) where val_if_eq | is_eq = trueValInt platform | otherwise = falseValInt platform diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index 41ccd26c7b..d1a5de100d 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -209,14 +209,14 @@ cprAnalAlt -> Id -- ^ case binder -> Alt Var -- ^ current alternative -> (CprType, Alt Var) -cprAnalAlt env scrut case_bndr (con@(DataAlt dc),bndrs,rhs) +cprAnalAlt env scrut case_bndr (Alt con@(DataAlt dc) bndrs rhs) -- See 'extendEnvForDataAlt' and Note [CPR in a DataAlt case alternative] - = (rhs_ty, (con, bndrs, rhs')) + = (rhs_ty, Alt con bndrs rhs') where env_alt = extendEnvForDataAlt env scrut case_bndr dc bndrs (rhs_ty, rhs') = cprAnal env_alt rhs -cprAnalAlt env _ _ (con,bndrs,rhs) - = (rhs_ty, (con, bndrs, rhs')) +cprAnalAlt env _ _ (Alt con bndrs rhs) + = (rhs_ty, Alt con bndrs rhs') where (rhs_ty, rhs') = cprAnal env rhs diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index fe2e66849f..af0c28e9a1 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -424,7 +424,7 @@ dmdAnal' env dmd (Lam var body) in (multDmdType n lam_ty, Lam var' body') -dmdAnal' env dmd (Case scrut case_bndr ty [(alt, bndrs, rhs)]) +dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type. | is_single_data_alt alt @@ -464,7 +464,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(alt, bndrs, rhs)]) -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ - (res_ty, Case scrut' case_bndr' ty [(alt, bndrs', rhs')]) + (res_ty, Case scrut' case_bndr' ty [Alt alt bndrs' rhs']) where is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc is_single_data_alt _ = True @@ -536,13 +536,13 @@ forcesRealWorld fam_envs ty = False dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> (DmdType, Alt Var) -dmdAnalSumAlt env dmd case_bndr (con,bndrs,rhs) +dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) | (rhs_ty, rhs') <- dmdAnal env dmd rhs , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr -- See Note [Demand on scrutinee of a product case] id_dmds = addCaseBndrDmd case_bndr_sd dmds - = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) + = (alt_ty, Alt con (setBndrsDemandInfo bndrs id_dmds) rhs') {- Note [Analysing with absent demand] diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs index d806e9c607..2b34992d72 100644 --- a/compiler/GHC/Core/Opt/Exitify.hs +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -81,7 +81,7 @@ exitifyProgram binds = map goTopLvl binds = Case (go in_scope scrut) bndr ty (map go_alt alts) where in_scope1 = in_scope `extendInScopeSet` bndr - go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs) + go_alt (Alt dc pats rhs) = Alt dc pats (go in_scope' rhs) where in_scope' = in_scope1 `extendInScopeSetList` pats go in_scope (Let (NonRec bndr rhs) body) @@ -152,9 +152,9 @@ exitifyRec in_scope pairs -- Case right hand sides are in tail-call position go captured (_, AnnCase scrut bndr ty alts) = do - alts' <- forM alts $ \(dc, pats, rhs) -> do + alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do rhs' <- go (captured ++ [bndr] ++ pats) rhs - return (dc, pats, rhs') + return (Alt dc pats rhs') return $ Case (deAnnotate scrut) bndr ty alts' go captured (_, AnnLet ann_bind body) diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index bc98f764c7..7feea9f516 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -454,7 +454,7 @@ bindings are: -} -fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) +fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs]) | isUnliftedType (idType case_bndr) , exprOkForSideEffects (deAnnotate scrut) -- See Note [Floating primops] @@ -493,12 +493,12 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) scrut_fvs = freeVarsOf scrut alts_fvs = map alt_fvs alts all_alts_fvs = unionDVarSets alts_fvs - alt_fvs (_con, args, rhs) + alt_fvs (AnnAlt _con args rhs) = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args) -- Delete case_bndr and args from free vars of rhs -- to get free vars of alt - fi_alt to_drop (con, args, rhs) = (con, args, fiExpr platform to_drop rhs) + fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs) ------------------ fiBind :: Platform diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index be3cd1f1c4..fc65ae77f5 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -468,7 +468,7 @@ floatExpr (Let bind body) floatExpr (Case scrut (TB case_bndr case_spec) ty alts) = case case_spec of FloatMe dest_lvl -- Case expression moves - | [(con@(DataAlt {}), bndrs, rhs)] <- alts + | [Alt con@(DataAlt {}) bndrs rhs] <- alts -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> case floatExpr rhs of { (fsb, fdb, rhs') -> let @@ -485,9 +485,9 @@ floatExpr (Case scrut (TB case_bndr case_spec) ty alts) (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') }} where - float_alt bind_lvl (con, bs, rhs) + float_alt bind_lvl (Alt con bs rhs) = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } + (fs, rhs_floats, Alt con [b | TB b _ <- bs] rhs') } floatRhs :: CoreBndr -> LevelledExpr diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs index 1405e6acd2..e9140612f0 100644 --- a/compiler/GHC/Core/Opt/LiberateCase.hs +++ b/compiler/GHC/Core/Opt/LiberateCase.hs @@ -255,9 +255,8 @@ libCase env (Case scrut bndr ty alts) mk_alt_env (Cast scrut _) = mk_alt_env scrut -- Note [Scrutinee with cast] mk_alt_env _ = env -libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr) - -> (AltCon, [CoreBndr], CoreExpr) -libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) +libCaseAlt :: LibCaseEnv -> Alt CoreBndr -> Alt CoreBndr +libCaseAlt env (Alt con args rhs) = Alt con args (libCase (addBinders env args) rhs) {- Ids diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index a746e4feb8..5e2f77ec28 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -2196,12 +2196,12 @@ occAnalLamOrRhs env binders body occAnalAlt :: OccEnv -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo) -occAnalAlt env (con, bndrs, rhs) +occAnalAlt env (Alt con bndrs rhs) = case occAnal (env `addInScope` bndrs) rhs of { (rhs_usage1, rhs1) -> let (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs in -- See Note [Binders in case alternatives] - (alt_usg, (con, tagged_bndrs, rhs1)) } + (alt_usg, Alt con tagged_bndrs rhs1) } {- ************************************************************************ diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 00d38f40cd..88b1d34a9e 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -491,7 +491,7 @@ lvlCase :: LevelEnv -- Level of in-scope names/tyvars -> LvlM LevelledExpr -- Result expression lvlCase env scrut_fvs scrut' case_bndr ty alts -- See Note [Floating single-alternative cases] - | [(con@(DataAlt {}), bs, body)] <- alts + | [AnnAlt con@(DataAlt {}) bs body] <- alts , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] , not (isTopLvl dest_lvl) -- Can't have top-level cases , not (floatTopLvlOnly env) -- Can float anywhere @@ -501,7 +501,7 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut' ; body' <- lvlMFE rhs_env True body - ; let alt' = (con, map (stayPut dest_lvl) bs', body') + ; let alt' = Alt con (map (stayPut dest_lvl) bs') body' ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) } | otherwise -- Stays put @@ -516,9 +516,9 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts dest_lvl = maxFvLevel (const True) env scrut_fvs -- Don't abstract over type variables, hence const True - lvl_alt alts_env (con, bs, rhs) + lvl_alt alts_env (AnnAlt con bs rhs) = do { rhs' <- lvlMFE new_env True rhs - ; return (con, bs', rhs') } + ; return (Alt con bs' rhs') } where (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs @@ -701,13 +701,13 @@ lvlMFE env strict_ctxt ann_expr ; let l1r = incMinorLvlFrom rhs_env float_rhs = mkLams abs_vars_w_lvls $ Case expr1 (stayPut l1r ubx_bndr) dc_res_ty - [(DEFAULT, [], mkConApp dc [Var ubx_bndr])] + [Alt DEFAULT [] (mkConApp dc [Var ubx_bndr])] ; var <- newLvlVar float_rhs Nothing is_mk_static ; let l1u = incMinorLvlFrom env use_expr = Case (mkVarApps (Var var) abs_vars) (stayPut l1u bx_bndr) expr_ty - [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)] + [Alt (DataAlt dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)] ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) use_expr) } diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index fc3373419e..97173eee5c 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -1222,7 +1222,7 @@ simplTick env tickish expr cont tickScrut e = foldr mkTick e ticks -- Alternatives get annotated with all ticks that scope in some way, -- but we don't want to count entries. - tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope) + tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope) ts_scope = map mkNoCount $ filter (not . (`tickishScopesLike` NoScope)) ticks @@ -2586,8 +2586,8 @@ rebuildCase env scrut case_bndr alts cont , not (litIsLifted lit) = do { tick (KnownBranch case_bndr) ; case findAlt (LitAlt lit) alts of - Nothing -> missingAlt env case_bndr alts cont - Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs } + Nothing -> missingAlt env case_bndr alts cont + Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs } | Just (in_scope', wfloats, con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut @@ -2598,12 +2598,12 @@ rebuildCase env scrut case_bndr alts cont ; let scaled_wfloats = map scale_float wfloats ; case findAlt (DataAlt con) alts of Nothing -> missingAlt env0 case_bndr alts cont - Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con) + Just (Alt DEFAULT bs rhs) -> let con_app = Var (dataConWorkId con) `mkTyApps` ty_args `mkApps` other_args - in simple_rhs env0 scaled_wfloats con_app bs rhs - Just (_, bs, rhs) -> knownCon env0 scrut scaled_wfloats con ty_args other_args - case_bndr bs rhs cont + in simple_rhs env0 scaled_wfloats con_app bs rhs + Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args other_args + case_bndr bs rhs cont } where simple_rhs env wfloats scrut' bs rhs = @@ -2650,7 +2650,7 @@ rebuildCase env scrut case_bndr alts cont -- 2. Eliminate the case if scrutinee is evaluated -------------------------------------------------- -rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont +rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont -- See if we can get rid of the case altogether -- See Note [Case elimination] -- mkCase made sure that if all the alternatives are equal, @@ -2882,7 +2882,7 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv -> OutExpr -> InId -> OutId -> [InAlt] -> SimplM (SimplEnv, OutExpr, OutId) -- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] +improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) = do { case_bndr2 <- newId (fsLit "nt") Many ty2 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing @@ -2903,21 +2903,21 @@ simplAlt :: SimplEnv -> InAlt -> SimplM OutAlt -simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) +simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs) = ASSERT( null bndrs ) do { let env' = addBinderUnfolding env case_bndr' (mkOtherCon imposs_deflt_cons) -- Record the constructors that the case-binder *can't* be. ; rhs' <- simplExprC env' rhs cont' - ; return (DEFAULT, [], rhs') } + ; return (Alt DEFAULT [] rhs') } -simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs) +simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs) = ASSERT( null bndrs ) do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) ; rhs' <- simplExprC env' rhs cont' - ; return (LitAlt lit, [], rhs') } + ; return (Alt (LitAlt lit) [] rhs') } -simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs) +simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs) = do { -- See Note [Adding evaluatedness info to pattern-bound variables] let vs_with_evals = addEvals scrut' con vs ; (env', vs') <- simplLamBndrs env vs_with_evals @@ -2929,7 +2929,7 @@ simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs) ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app ; rhs' <- simplExprC env'' rhs cont' - ; return (DataAlt con, vs', rhs') } + ; return (Alt (DataAlt con) vs' rhs') } {- Note [Adding evaluatedness info to pattern-bound variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3247,7 +3247,7 @@ altsWouldDup (alt:alts) | otherwise = not (all is_bot_alt alts) -- otherwise case: first alt is non-bot, so all the rest must be bot where - is_bot_alt (_,_,rhs) = exprIsDeadEnd rhs + is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs ------------------------- mkDupableCont :: SimplEnv @@ -3435,9 +3435,9 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty mkDupableAlt :: Platform -> OutId -> JoinFloats -> OutAlt -> SimplM (JoinFloats, OutAlt) -mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs') +mkDupableAlt platform case_bndr jfloats (Alt con bndrs' rhs') | exprIsDupable platform rhs' -- Note [Small alternative rhs] - = return (jfloats, (con, bndrs', rhs')) + = return (jfloats, Alt con bndrs' rhs') | otherwise = do { simpl_opts <- initSimpleOpts <$> getDynFlags @@ -3481,7 +3481,7 @@ mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs') ; join_bndr <- newJoinId final_bndrs' rhs_ty' ; let join_call = mkApps (Var join_bndr) final_args - alt' = (con, bndrs', join_call) + alt' = Alt con bndrs' join_call ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) , alt') } diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 8c25d7e171..2ab7fe2e28 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -2242,15 +2242,15 @@ mkCase, mkCase1, mkCase2, mkCase3 -- 1. Merge Nested Cases -------------------------------------------------- -mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) +mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) | gopt Opt_CaseMerge dflags , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) <- stripTicksTop tickishFloatable deflt_rhs , inner_scrut_var == outer_bndr = do { tick (CaseMerge outer_bndr) - ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args ) - (con, args, wrap_rhs rhs) + ; let wrap_alt (Alt con args rhs) = ASSERT( outer_bndr `notElem` args ) + (Alt con args (wrap_rhs rhs)) -- Simplifier's no-shadowing invariant should ensure -- that outer_bndr is not shadowed by the inner patterns wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs @@ -2284,13 +2284,13 @@ mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts -- 2. Eliminate Identity Case -------------------------------------------------- -mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case +mkCase1 _dflags scrut case_bndr _ alts@(Alt _ _ rhs1 : _) -- Identity case | all identity_alt alts = do { tick (CaseIdentity case_bndr) ; return (mkTicks ticks $ re_cast scrut rhs1) } where - ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts) - identity_alt (con, args, rhs) = check_eq rhs con args + ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) (tail alts) + identity_alt (Alt con args rhs) = check_eq rhs con args check_eq (Cast rhs co) con args -- See Note [RHS casts] = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args @@ -2332,8 +2332,8 @@ mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts mkCase2 dflags scrut bndr alts_ty alts | -- See Note [Scrutinee Constant Folding] case alts of -- Not if there is just a DEFAULT alternative - [(DEFAULT,_,_)] -> False - _ -> True + [Alt DEFAULT _ _] -> False + _ -> True , gopt Opt_CaseFolding dflags , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut = do { bndr' <- newId (fsLit "lwild") Many (exprType scrut') @@ -2368,11 +2368,11 @@ mkCase2 dflags scrut bndr alts_ty alts tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id -> CoreAlt -> SimplM (Maybe CoreAlt) - tx_alt tx_con mk_orig new_bndr (con, bs, rhs) + tx_alt tx_con mk_orig new_bndr (Alt con bs rhs) = case tx_con con of Nothing -> return Nothing Just con' -> do { bs' <- mk_new_bndrs new_bndr con' - ; return (Just (con', bs', rhs')) } + ; return (Just (Alt con' bs' rhs')) } where rhs' | isDeadBinder bndr = rhs | otherwise = bindNonRec bndr orig_val rhs @@ -2399,8 +2399,8 @@ mkCase2 dflags scrut bndr alts_ty alts add_default :: [CoreAlt] -> [CoreAlt] -- See Note [Literal cases] - add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts - add_default alts = alts + add_default (Alt (LitAlt {}) bs rhs : alts) = Alt DEFAULT bs rhs : alts + add_default alts = alts {- Note [Literal cases] ~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 02c1c3cf2e..ccff26df78 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1233,8 +1233,8 @@ scExpr' env (Case scrut b ty alts) } where sc_con_app con args scrut' -- Known constructor; simplify - = do { let (_, bs, rhs) = findAlt con alts - `orElse` (DEFAULT, [], mkImpossibleExpr ty) + = do { let Alt _ bs rhs = findAlt con alts + `orElse` Alt DEFAULT [] (mkImpossibleExpr ty) alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) ; scExpr alt_env' rhs } @@ -1254,7 +1254,7 @@ scExpr' env (Case scrut b ty alts) ; return (foldr combineUsage scrut_usg' alt_usgs, Case scrut' b' (scSubstTy env ty) alts') } - sc_alt env scrut' b' (con,bs,rhs) + sc_alt env scrut' b' (Alt con bs rhs) = do { let (env1, bs1) = extendBndrsWith RecArg env bs (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 ; (usg, rhs') <- scExpr env2 rhs @@ -1262,7 +1262,7 @@ scExpr' env (Case scrut b ty alts) scrut_occ = case con of DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) _ -> ScrutOcc emptyUFM - ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } + ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') } scExpr' env (Let (NonRec bndr rhs) body) | isTyVar bndr -- Type-lets may be created by doBeta diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 4cca5199c7..4ff730fa77 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -1140,14 +1140,14 @@ specCase :: SpecEnv , Id , [CoreAlt] , UsageDetails) -specCase env scrut' case_bndr [(con, args, rhs)] +specCase env scrut' case_bndr [Alt con args rhs] | isDictId case_bndr -- See Note [Floating dictionaries out of cases] , interestingDict env scrut' , not (isDeadBinder case_bndr && null sc_args') = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') - [(con, args', Var sc_arg')] + [Alt con args' (Var sc_arg')] | sc_arg' <- sc_args' ] -- Extend the substitution for RHS to map the *original* binders @@ -1171,7 +1171,7 @@ specCase env scrut' case_bndr [(con, args, rhs)] flt_binds = scrut_bind : sc_binds (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds all_uds = flt_binds `addDictBinds` free_uds - alt' = (con, args', wrapDictBindsE dumped_dbs rhs') + alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs') ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } where (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) @@ -1200,10 +1200,10 @@ specCase env scrut case_bndr alts ; return (scrut, case_bndr', alts', uds_alts) } where (env_alt, case_bndr') = substBndr env case_bndr - spec_alt (con, args, rhs) = do + spec_alt (Alt con args rhs) = do (rhs', uds) <- specExpr env_rhs rhs let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds - return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds) + return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) where (env_rhs, args') = substBndrs env_alt args diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs index 180d555c2f..ad82267523 100644 --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -225,9 +225,9 @@ satExpr (Case expr bndr ty alts) interesting_ids = do let (alts', sat_infos_alts) = unzip zipped_alts' return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing) where - satAlt (con, bndrs, expr) = do + satAlt (Alt con bndrs expr) = do (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids - return ((con, bndrs, expr'), sat_info_expr) + return (Alt con bndrs expr', sat_info_expr) satExpr (Let bind body) interesting_ids = do (body', sat_info_body, body_app) <- satExpr body interesting_ids diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 4ea61f3e85..8631888bbd 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -142,12 +142,12 @@ wwExpr dflags fam_envs (Case expr binder ty alts) = do -- See Note [Zapping Used Once info in WorkWrap] return (Case new_expr new_binder ty new_alts) where - ww_alt (con, binders, rhs) = do + ww_alt (Alt con binders rhs) = do new_rhs <- wwExpr dflags fam_envs rhs let new_binders = [ if isId b then zapIdUsedOnceInfo b else b | b <- binders ] -- See Note [Zapping Used Once info in WorkWrap] - return (con, new_binders, new_rhs) + return (Alt con new_binders new_rhs) {- ************************************************************************ diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index 37e5afc963..ddfa2ea2a6 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -68,6 +68,9 @@ instance OutputableBndr b => Outputable (Bind b) where instance OutputableBndr b => Outputable (Expr b) where ppr expr = pprCoreExpr expr +instance OutputableBndr b => Outputable (Alt b) where + ppr expr = pprCoreAlt expr + {- ************************************************************************ * * @@ -221,7 +224,7 @@ ppr_expr add_par expr@(App {}) _ -> parens (hang (pprParendExpr fun) 2 pp_args) } -ppr_expr add_par (Case expr var ty [(con,args,rhs)]) +ppr_expr add_par (Case expr var ty [Alt con args rhs]) = sdocOption sdocPrintCaseAsLet $ \case True -> add_par $ -- See Note [Print case as let] sep [ sep [ text "let! {" @@ -299,8 +302,8 @@ ppr_expr add_par (Tick tickish expr) True -> ppr_expr add_par expr False -> add_par (sep [ppr tickish, pprCoreExpr expr]) -pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc -pprCoreAlt (con, args, rhs) +pprCoreAlt :: OutputableBndr a => Alt a -> SDoc +pprCoreAlt (Alt con args rhs) = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index 752e094264..4516899b88 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -890,7 +890,7 @@ match_alts :: RuleMatchEnv -> Maybe RuleSubst match_alts _ subst [] [] = return subst -match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) +match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2) | c1 == c2 = do { subst1 <- match renv' subst r1 r2 ; match_alts renv subst1 alts1 alts2 } @@ -1211,7 +1211,7 @@ ruleCheck env (Cast e _) = ruleCheck env e ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e ruleCheck env (Lam _ e) = ruleCheck env e ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` - unionManyBags [ruleCheck env r | (_,_,r) <- as] + unionManyBags [ruleCheck env r | Alt _ _ r <- as] ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs index 25a6ab31dc..4dafc9c2e8 100644 --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -99,7 +99,7 @@ seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs seqAlts :: [CoreAlt] -> () seqAlts [] = () -seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts +seqAlts (Alt c bs e:alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts seqUnfolding :: Unfolding -> () seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 4467648fed..a26be7e0ae 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -257,7 +257,7 @@ simple_opt_expr env expr | isDeadBinder b , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' -- We don't need to be concerned about floats when looking for coerce. - , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as + , Just (Alt altcon bs rhs) <- findAlt (DataAlt con) as = case altcon of DEFAULT -> go rhs _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs @@ -267,7 +267,7 @@ simple_opt_expr env expr -- Note [Getting the map/coerce RULE to work] | isDeadBinder b - , [(DEFAULT, _, rhs)] <- as + , [Alt DEFAULT _ rhs] <- as , isCoVarType (varType b) , (Var fun, _args) <- collectArgs e , fun `hasKey` coercibleSCSelIdKey @@ -285,8 +285,8 @@ simple_opt_expr env expr go_co co = optCoercion (soe_co_opt_opts env) (getTCvSubst subst) co ---------------------- - go_alt env (con, bndrs, rhs) - = (con, bndrs', simple_opt_expr env' rhs) + go_alt env (Alt con bndrs rhs) + = Alt con bndrs' (simple_opt_expr env' rhs) where (env', bndrs') = subst_opt_bndrs env bndrs @@ -1129,7 +1129,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr float = FloatLet (NonRec bndr' rhs') in go subst' (float:floats) expr cont - go subst floats (Case scrut b _ [(con, vars, expr)]) cont + go subst floats (Case scrut b _ [Alt con vars expr]) cont = let scrut' = subst_expr subst scrut (subst', b') = subst_bndr subst b diff --git a/compiler/GHC/Core/Stats.hs b/compiler/GHC/Core/Stats.hs index cdff8283be..46d5af5106 100644 --- a/compiler/GHC/Core/Stats.hs +++ b/compiler/GHC/Core/Stats.hs @@ -84,7 +84,7 @@ exprStats (Cast e co) = coStats co `plusCS` exprStats e exprStats (Tick _ e) = exprStats e altStats :: CoreAlt -> CoreStats -altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r +altStats (Alt _ bs r) = altBndrStats bs `plusCS` exprStats r altBndrStats :: [Var] -> CoreStats -- Charge one for the alternative, not for each binder @@ -134,4 +134,4 @@ pairSize :: (Var, CoreExpr) -> Int pairSize (b,e) = bndrSize b + exprSize e altSize :: CoreAlt -> Int -altSize (_,bs,e) = bndrsSize bs + exprSize e +altSize (Alt _ bs e) = bndrsSize bs + exprSize e diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index d57a0e2bf0..a4e702e83a 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -386,7 +386,7 @@ substExpr subst expr where (subst', bndr') = substBndr subst bndr - go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs) + go_alt subst (Alt con bndrs rhs) = Alt con bndrs' (substExpr subst' rhs) where (subst', bndrs') = substBndrs subst bndrs diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index e5637d6fef..db24e861cd 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -83,9 +83,9 @@ tidyExpr env (Lam b e) ------------ Case alternatives -------------- tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt -tidyAlt env (con, vs, rhs) +tidyAlt env (Alt con vs rhs) = tidyBndrs env vs =: \ (env', vs) -> - (con, vs, tidyExpr env' rhs) + (Alt con vs (tidyExpr env' rhs)) ------------ Tickish -------------- tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index a410bac6e1..345be79df4 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -195,7 +195,7 @@ inlineBoringOk e , exprIsTrivial a = go (credit-1) f go credit (Tick _ e) = go credit e -- dubious go credit (Cast e _) = go credit e - go credit (Case scrut _ _ [(_,_,rhs)]) -- See Note [Inline unsafeCoerce] + go credit (Case scrut _ _ [Alt _ _ rhs]) -- See Note [Inline unsafeCoerce] | isUnsafeEqualityProof scrut = go credit rhs go _ (Var {}) = boringCxtOk go _ _ = boringCxtNotOk @@ -541,7 +541,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr _ -> funSize opts top_args fun (length val_args) voids ------------ - size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 + size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10 -- Don't charge for args, so that wrappers look cheap -- (See comments about wrappers with Case) -- diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index afebee0678..3115e163f1 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -141,7 +141,7 @@ exprType other = pprPanic "exprType" (pprCoreExpr other) coreAltType :: CoreAlt -> Type -- ^ Returns the type of the alternatives right hand side -coreAltType alt@(_,bs,rhs) +coreAltType alt@(Alt _ bs rhs) = case occCheckExpand bs rhs_ty of -- Note [Existential variables and silly type synonyms] Just ty -> ty @@ -484,7 +484,7 @@ stripTicksE p expr = go expr go_bs (NonRec b e) = NonRec b (go e) go_bs (Rec bs) = Rec (map go_b bs) go_b (b, e) = (b, go e) - go_a (c,bs,e) = (c,bs, go e) + go_a (Alt c bs e) = Alt c bs (go e) stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] stripTicksT p expr = fromOL $ go expr @@ -500,7 +500,7 @@ stripTicksT p expr = fromOL $ go expr go_bs (NonRec _ e) = go e go_bs (Rec bs) = concatOL (map go_b bs) go_b (_, e) = go e - go_a (_, _, e) = go e + go_a (Alt _ _ e) = go e {- ************************************************************************ @@ -560,7 +560,7 @@ mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr -- Make (case x of y { DEFAULT -> e } mkDefaultCase scrut case_bndr body - = Case scrut case_bndr (exprType body) [(DEFAULT, [], body)] + = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body] mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr -- Use this function if possible, when building a case, @@ -568,7 +568,7 @@ mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr -- doesn't mention variables bound by the case -- See Note [Care with the type of a case expression] mkSingleAltCase scrut case_bndr con bndrs body - = Case scrut case_bndr case_ty [(con,bndrs,body)] + = Case scrut case_bndr case_ty [Alt con bndrs body] where body_ty = exprType body @@ -611,30 +611,30 @@ This makes it easy to find, though it makes matching marginally harder. -} -- | Extract the default case alternative -findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b) -findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) -findDefault alts = (alts, Nothing) +findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b)) +findDefault (Alt DEFAULT args rhs : alts) = ASSERT( null args ) (alts, Just rhs) +findDefault alts = (alts, Nothing) -addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)] +addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b] addDefault alts Nothing = alts -addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts +addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts -isDefaultAlt :: (AltCon, a, b) -> Bool -isDefaultAlt (DEFAULT, _, _) = True -isDefaultAlt _ = False +isDefaultAlt :: Alt b -> Bool +isDefaultAlt (Alt DEFAULT _ _) = True +isDefaultAlt _ = False -- | Find the case alternative corresponding to a particular -- constructor: panics if no such constructor exists -findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) +findAlt :: AltCon -> [Alt b] -> Maybe (Alt b) -- A "Nothing" result *is* legitimate -- See Note [Unreachable code] findAlt con alts = case alts of - (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt) - _ -> go alts Nothing + (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt) + _ -> go alts Nothing where go [] deflt = deflt - go (alt@(con1,_,_) : alts) deflt + go (alt@(Alt con1 _ _) : alts) deflt = case con `cmpAltCon` con1 of LT -> deflt -- Missed it already; the alts are in increasing order EQ -> Just alt @@ -671,7 +671,7 @@ filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase. -} --------------------------------- -mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)] +mergeAlts :: [Alt a] -> [Alt a] -> [Alt a] -- ^ Merge alternatives preserving order; alternatives in -- the first argument shadow ones in the second mergeAlts [] as2 = as2 @@ -700,8 +700,8 @@ trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities) -> [Type] -- ^ And its type arguments -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee - -> [(AltCon, [Var], a)] -- ^ Alternatives - -> ([AltCon], [(AltCon, [Var], a)]) + -> [Alt b] -- ^ Alternatives + -> ([AltCon], [Alt b]) -- Returns: -- 1. Constructors that will never be encountered by the -- *default* case (if any). A superset of imposs_cons @@ -721,7 +721,7 @@ filterAlts _tycon inst_tys imposs_cons alts = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) where (alts_wo_default, maybe_deflt) = findDefault alts - alt_cons = [con | (con,_,_) <- alts_wo_default] + alt_cons = [con | Alt con _ _ <- alts_wo_default] trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default @@ -732,10 +732,10 @@ filterAlts _tycon inst_tys imposs_cons alts -- EITHER by the context, -- OR by a non-DEFAULT branch in this case expression. - impossible_alt :: [Type] -> (AltCon, a, b) -> Bool - impossible_alt _ (con, _, _) | con `Set.member` imposs_cons_set = True - impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con - impossible_alt _ _ = False + impossible_alt :: [Type] -> Alt b -> Bool + impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True + impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con + impossible_alt _ _ = False -- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. -- See Note [Refine DEFAULT case alternatives] @@ -747,7 +747,7 @@ refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders -> [CoreAlt] -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts - | (DEFAULT,_,rhs) : rest_alts <- all_alts + | Alt DEFAULT _ rhs : rest_alts <- all_alts , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: -- case x of { DEFAULT -> e } @@ -764,7 +764,7 @@ refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts [] -> (False, rest_alts) -- It matches exactly one constructor, so fill it in: - [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)]) + [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs]) -- We need the mergeAlts to keep the alternatives in the right order where (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys @@ -947,25 +947,25 @@ combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT [CoreAlt]) -- New alternatives -- See Note [Combine identical alternatives] -- True <=> we did some combining, result is a single DEFAULT alternative -combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts) +combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts) | all isDeadBinder bndrs1 -- Remember the default , not (null elim_rest) -- alternative comes first = (True, imposs_deflt_cons', deflt_alt : filtered_rest) where (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts - deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1) + deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1) -- See Note [Care with impossible-constructors when combining alternatives] imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons - elim_cons = elim_con1 ++ map fstOf3 elim_rest + elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest elim_con1 = case con1 of -- Don't forget con1! DEFAULT -> [] -- See Note [ _ -> [con1] cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 - identical_to_alt1 (_con,bndrs,rhs) + identical_to_alt1 (Alt _con bndrs rhs) = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 - tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest + tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest combineIdenticalAlts imposs_cons alts = (False, imposs_cons, alts) @@ -976,7 +976,7 @@ scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt] scaleAltsBy w alts = map scaleAlt alts where scaleAlt :: CoreAlt -> CoreAlt - scaleAlt (con, bndrs, rhs) = (con, map scaleBndr bndrs, rhs) + scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs scaleBndr :: CoreBndr -> CoreBndr scaleBndr b = scaleVarBy w b @@ -1317,7 +1317,7 @@ exprIsCheapX ok_app e go _ (Coercion {}) = True go n (Cast e _) = go n e go n (Case scrut _ _ alts) = ok scrut && - and [ go n rhs | (_,_,rhs) <- alts ] + and [ go n rhs | Alt _ _ rhs <- alts ] go n (Tick t e) | tickishCounts t = False | otherwise = go n e go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e @@ -1602,7 +1602,7 @@ expr_ok primop_ok (Case scrut bndr _ alts) = -- See Note [exprOkForSpeculation: case expressions] expr_ok primop_ok scrut && isUnliftedType (idType bndr) - && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts + && all (\(Alt _ _ rhs) -> expr_ok primop_ok rhs) alts && altsAreExhaustive alts expr_ok primop_ok other_expr @@ -1669,7 +1669,7 @@ altsAreExhaustive :: [Alt b] -> Bool -- False <=> they may or may not be altsAreExhaustive [] = False -- Should not happen -altsAreExhaustive ((con1,_,_) : alts) +altsAreExhaustive (Alt con1 _ _ : alts) = case con1 of DEFAULT -> True LitAlt {} -> False @@ -2162,7 +2162,7 @@ eqExpr in_scope e1 e2 go _ _ _ = False ----------- - go_alt env (c1, bs1, e1) (c2, bs2, e2) + go_alt env (Alt c1 bs1 e1) (Alt c2 bs2 e2) = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool @@ -2205,7 +2205,7 @@ diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) -- See Note [Empty case alternatives] in GHC.Data.TrieMap = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) where env' = rnBndr2 env b1 b2 - diffAlt (c1, bs1, e1) (c2, bs2, e2) + diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2) | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 diffExpr _ _ e1 e2 diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index 31c40a9282..0e2f93ebec 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -655,7 +655,7 @@ schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut -- handle pairs with one void argument (e.g. state token) -schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) +schemeE d s p (AnnCase scrut bndr _ [AnnAlt (DataAlt dc) [bind1, bind2] rhs]) | isUnboxedTupleDataCon dc -- Convert -- case .... of x { (# V'd-thing, a #) -> ... } @@ -667,20 +667,20 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) -- envt (it won't be bound now) because we never look such things up. , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of ([], [_]) - -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr) + -> Just $ doCase d s p scrut bind2 [AnnAlt DEFAULT [] rhs] (Just bndr) ([_], []) - -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) + -> Just $ doCase d s p scrut bind1 [AnnAlt DEFAULT [] rhs] (Just bndr) _ -> Nothing = res -- handle unit tuples -schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) +schemeE d s p (AnnCase scrut bndr _ [AnnAlt (DataAlt dc) [bind1] rhs]) | isUnboxedTupleDataCon dc , typePrimRep (idType bndr) `lengthAtMost` 1 - = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) + = doCase d s p scrut bind1 [AnnAlt DEFAULT [] rhs] (Just bndr) -- handle nullary tuples -schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)]) +schemeE d s p (AnnCase scrut bndr _ alt@[AnnAlt DEFAULT [] _]) | isUnboxedTupleType (idType bndr) , Just ty <- case typePrimRep (idType bndr) of [_] -> Just (unwrapType (idType bndr)) @@ -1061,11 +1061,11 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple -- given an alt, return a discr and code for it. - codeAlt (DEFAULT, _, (_,rhs)) + codeAlt (AnnAlt DEFAULT _ (_,rhs)) = do rhs_code <- schemeE d_alts s p_alts rhs return (NoDiscr, rhs_code) - codeAlt alt@(_, bndrs, (_,rhs)) + codeAlt alt@(AnnAlt _ bndrs (_,rhs)) -- primitive or nullary constructor alt: no need to UNPACK | null real_bndrs = do rhs_code <- schemeE d_alts s p_alts rhs @@ -1099,13 +1099,13 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple where real_bndrs = filterOut isTyVar bndrs - my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} - my_discr (DataAlt dc, _, _) + my_discr (AnnAlt DEFAULT _ _) = NoDiscr {-shouldn't really happen-} + my_discr (AnnAlt (DataAlt dc) _ _) | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc = multiValException | otherwise = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) - my_discr (LitAlt l, _, _) + my_discr (AnnAlt (LitAlt l) _ _) = case l of LitNumber LitNumInt i -> DiscrI (fromInteger i) LitNumber LitNumWord w -> DiscrW (fromInteger w) LitFloat r -> DiscrF (fromRational r) @@ -1116,7 +1116,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple maybe_ncons | not isAlgCase = Nothing | otherwise - = case [dc | (DataAlt dc, _, _) <- alts] of + = case [dc | AnnAlt (DataAlt dc) _ _ <- alts] of [] -> Nothing (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) @@ -1954,7 +1954,7 @@ bcView (AnnTick _other_tick (_,e)) = Just e bcView (AnnCase (_,e) _ _ alts) -- Handle unsafe equality proof | AnnVar id <- bcViewLoop e , idName id == unsafeEqualityProofName - , [(_, _, (_, rhs))] <- alts + , [AnnAlt _ _ (_, rhs)] <- alts = Just rhs bcView _ = Nothing diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 076c2812d9..3d32985131 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -574,9 +574,8 @@ toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] --------------------- -toIfaceAlt :: (AltCon, [Var], CoreExpr) - -> (IfaceConAlt, [FastString], IfaceExpr) -toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r) +toIfaceAlt :: CoreAlt -> IfaceAlt +toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r) --------------------- toIfaceCon :: AltCon -> IfaceConAlt diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 8082023ae7..bc890ea6cb 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -448,8 +448,8 @@ coreToStgExpr e0@(Case scrut bndr _ alts) = do text "STG:" $$ pprStgExpr panicStgPprOpts stg _ -> return stg where - vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr) - vars_alt (con, binders, rhs) + vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr) + vars_alt (Alt con binders rhs) | DataAlt c <- con, c == unboxedUnitDataCon = -- This case is a bit smelly. -- See Note [Nullary unboxed tuple] in GHC.Core.Type @@ -500,7 +500,7 @@ mkStgAltType bndr alts -- grabbing the one from a constructor alternative -- if one exists. look_for_better_tycon - | ((DataAlt con, _, _) : _) <- data_alts = + | ((Alt (DataAlt con) _ _) : _) <- data_alts = AlgAlt (dataConTyCon con) | otherwise = ASSERT(null data_alts) diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index f8955ae977..d0515b4d86 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -622,7 +622,7 @@ cpeRhsE env expr@(Lam {}) cpeRhsE env (Case scrut bndr ty alts) | isUnsafeEqualityProof scrut - , [(con, bs, rhs)] <- alts + , [Alt con bs rhs] <- alts = do { (floats1, scrut') <- cpeBody env scrut ; (env1, bndr') <- cpCloneBndr env bndr ; (env2, bs') <- cpCloneBndrs env1 bs @@ -652,10 +652,10 @@ cpeRhsE env (Case scrut bndr ty alts) ; return (floats, Case scrut' bndr2 ty alts'') } where - sat_alt env (con, bs, rhs) + sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs ; rhs' <- cpeBodyNF env2 rhs - ; return (con, bs', rhs') } + ; return (Alt con bs' rhs') } -- --------------------------------------------------------------------------- -- CpeBody: produces a result satisfying CpeBody @@ -1120,7 +1120,7 @@ cpExprIsTrivial e = cpExprIsTrivial e | Case scrut _ _ alts <- e , isUnsafeEqualityProof scrut - , [(_,_,rhs)] <- alts + , [Alt _ _ rhs] <- alts = cpExprIsTrivial rhs | otherwise = exprIsTrivial e @@ -1374,7 +1374,7 @@ wrapBinds :: Floats -> CpeBody -> CpeBody wrapBinds (Floats _ binds) body = foldrOL mk_bind body binds where - mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [(con,bs,body)] + mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [Alt con bs body] mk_bind (FloatLet bind) body = Let bind body mk_bind (FloatTick tickish) body = mkTick tickish body @@ -1828,7 +1828,7 @@ collectCostCentres mod_name Type{} -> cs Coercion{} -> cs - go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e) + go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e) go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre go_bind cs (NonRec b e) = diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 6ebbcc9fd1..b667466810 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -204,7 +204,7 @@ coreCaseTuple uniqs scrut_var vars body coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body = Case (Var scrut_var) scrut_var (exprType body) - [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)] + [Alt (DataAlt (tupleDataCon Boxed 2)) [var1, var2] body] mkCorePairTy :: Type -> Type -> Type mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index e828202a61..664ce3edb4 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -929,7 +929,7 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs where (bs, body') = split_lets body -- handle "unlifted lets" too, needed for "map/coerce" - split_lets (Case r d _ [(DEFAULT, _, body)]) + split_lets (Case r d _ [Alt DEFAULT _ body]) | isCoVar d = ((d,r):bs, body') where (bs, body') = split_lets body diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index 1644a6ddf6..5cf906e376 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -37,7 +37,6 @@ import GHC.HsToCore.Utils import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Multiplicity -import GHC.Types.Id ( Id ) import GHC.Core.Coercion import GHC.Builtin.Types.Prim import GHC.Core.TyCon @@ -159,7 +158,7 @@ unboxArg arg \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0)) prim_arg (exprType body) - [(DEFAULT,[],body)]) + [Alt DEFAULT [] body]) -- Data types with a single constructor, which has a single, primitive-typed arg -- This deals with Int, Float etc; also Ptr, ForeignPtr @@ -169,7 +168,7 @@ unboxArg arg do case_bndr <- newSysLocalDs Many arg_ty prim_arg <- newSysLocalDs Many data_con_arg_ty1 return (Var prim_arg, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body] ) -- Byte-arrays, both mutable and otherwise; hack warning @@ -184,7 +183,7 @@ unboxArg arg = do case_bndr <- newSysLocalDs Many arg_ty vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys) return (Var arr_cts_var, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body] ) | otherwise @@ -275,7 +274,7 @@ boxResult result_ty mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) -> (Maybe Type, Expr Var -> Expr Var) - -> DsM (Type, (AltCon, [Id], Expr Var)) + -> DsM (Type, CoreAlt) mk_alt return_result (Nothing, wrap_result) = do -- The ccall returns () state_id <- newSysLocalDs Many realWorldStatePrimTy @@ -284,7 +283,7 @@ mk_alt return_result (Nothing, wrap_result) [wrap_result (panic "boxResult")] ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] - the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs) + the_alt = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs return (ccall_res_ty, the_alt) @@ -297,7 +296,7 @@ mk_alt return_result (Just prim_res_ty, wrap_result) ; let the_rhs = return_result (Var state_id) [wrap_result (Var result_id)] ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] - the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs) + the_alt = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs ; return (ccall_res_ty, the_alt) } @@ -332,8 +331,8 @@ resultWrapper result_ty ; let platform = targetPlatform dflags ; let marshal_bool e = mkWildCase e (unrestricted intPrimTy) boolTy - [ (DEFAULT ,[],Var trueDataConId ) - , (LitAlt (mkLitInt platform 0),[],Var falseDataConId)] + [ Alt DEFAULT [] (Var trueDataConId ) + , Alt (LitAlt (mkLitInt platform 0)) [] (Var falseDataConId)] ; return (Just intPrimTy, marshal_bool) } -- Newtypes diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index 1c7cee081e..ea10cdaf39 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -295,8 +295,8 @@ deBindComp pat core_list1 quals core_list2 = do let rhs = Lam u1 $ Case (Var u1) u1 res_ty - [(DataAlt nilDataCon, [], core_list2), - (DataAlt consDataCon, [u2, u3], core_match)] + [Alt (DataAlt nilDataCon) [] core_list2 + ,Alt (DataAlt consDataCon) [u2, u3] core_match] -- Increasing order of tag return (Let (Rec [(h, rhs)]) letrec_body) @@ -423,8 +423,8 @@ mkZipBind elt_tys = do mk_case (as, a', as') rest = Case (Var as) as elt_tuple_list_ty - [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty), - (DataAlt consDataCon, [a', as'], rest)] + [ Alt (DataAlt nilDataCon) [] (mkNilExpr elt_tuple_ty) + , Alt (DataAlt consDataCon) [a', as'] rest] -- Increasing order of tag diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 8007f36f02..86095b8e3f 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -259,7 +259,7 @@ matchEmpty var res_ty = return [MR_Fallible mk_seq] where mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty - [(DEFAULT, [], fail)] + [Alt DEFAULT [] fail] matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Real true variables, just like in matchVar, SLPJ p 94 diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 493324cf97..8623a628f3 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -261,7 +261,7 @@ mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr mkEvalMatchResult var ty = fmap $ \e -> - Case (Var var) var ty [(DEFAULT, [], e)] + Case (Var var) var ty [Alt DEFAULT [] e] mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr mkGuardedMatchResult pred_expr mr = MR_Fallible $ \fail -> do @@ -277,13 +277,13 @@ mkCoPrimCaseMatchResult var ty match_alts where mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts - return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) + return (Case (Var var) var ty (Alt DEFAULT [] fail : alts)) sorted_alts = sortWith fst match_alts -- Right order for a Case mk_alt fail (lit, mr) = ASSERT( not (litIsLifted lit) ) do body <- runMatchResult fail mr - return (LitAlt lit, [], body) + return (Alt (LitAlt lit) [] body) data CaseAlt a = MkCaseAlt{ alt_pat :: a, alt_bndrs :: [Var], @@ -367,7 +367,7 @@ mkDataConCase var ty alts@(alt1 :| _) , alt_result = match_result } = flip adjustMatchResultDs match_result $ \body -> do case dataConBoxer con of - Nothing -> return (DataAlt con, args, body) + Nothing -> return (Alt (DataAlt con) args body) Just (DCB boxer) -> do us <- newUniqueSupply let (rep_ids, binds) = initUs_ us (boxer ty_args args) @@ -375,12 +375,12 @@ mkDataConCase var ty alts@(alt1 :| _) -- Upholds the invariant that the binders of a case expression -- must be scaled by the case multiplicity. See Note [Case -- expression invariants] in CoreSyn. - return (DataAlt con, rep_ids', mkLets binds body) + return (Alt (DataAlt con) rep_ids' (mkLets binds body)) mk_default :: MatchResult (Maybe CoreAlt) mk_default | exhaustive_case = MR_Infallible $ return Nothing - | otherwise = MR_Fallible $ \fail -> return $ Just (DEFAULT, [], fail) + | otherwise = MR_Fallible $ \fail -> return $ Just (Alt DEFAULT [] fail) mentioned_constructors = mkUniqSet $ map alt_pat sorted_alts un_mentioned_constructors @@ -487,7 +487,7 @@ There are a few subtleties in the desugaring of `seq`: mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2 | f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2) - = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] + = Case arg1 case_bndr ty2 [Alt DEFAULT [] arg2] where case_bndr = case arg1 of Var v1 | isInternalName (idName v1) @@ -952,8 +952,8 @@ mkBinaryTickBox ixT ixF e = do trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) -- return $ Case e bndr1 boolTy - [ (DataAlt falseDataCon, [], falseBox) - , (DataAlt trueDataCon, [], trueBox) + [ Alt (DataAlt falseDataCon) [] falseBox + , Alt (DataAlt trueDataCon) [] trueBox ] diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 930d58ddc5..a5bf8b6253 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -662,8 +662,8 @@ rnIfaceTyConBinder :: Rename IfaceTyConBinder rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis rnIfaceAlt :: Rename IfaceAlt -rnIfaceAlt (conalt, names, rhs) - = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs +rnIfaceAlt (IfaceAlt conalt names rhs) + = IfaceAlt <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs rnIfaceConAlt :: Rename IfaceConAlt rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index b90c049c02..73e8525589 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -11,7 +11,7 @@ module GHC.Iface.Syntax ( IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, - IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceJoinInfo(..), + IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, @@ -569,7 +569,7 @@ data IfaceTickish | IfaceSource RealSrcSpan String -- from SourceNote -- no breakpoints: we never export these into interface files -type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) +data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr -- Note: IfLclName, not IfaceBndr (and same with the case binder) -- We reconstruct the kind/type of the thing from the context -- thus saving bulk in interface files @@ -1385,7 +1385,7 @@ pprIfaceExpr add_par (IfaceECase scrut ty) , text "ret_ty" <+> pprParendIfaceType ty , text "of {}" ]) -pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) +pprIfaceExpr add_par (IfaceCase scrut bndr [IfaceAlt con bs rhs]) = add_par (sep [text "case" <+> pprIfaceExpr noParens scrut <+> text "of" <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, @@ -1395,7 +1395,7 @@ pprIfaceExpr add_par (IfaceCase scrut bndr alts) = add_par (sep [text "case" <+> pprIfaceExpr noParens scrut <+> text "of" <+> ppr bndr <+> char '{', - nest 2 (sep (map ppr_alt alts)) <+> char '}']) + nest 2 (sep (map pprIfaceAlt alts)) <+> char '}']) pprIfaceExpr _ (IfaceCast expr co) = sep [pprParendIfaceExpr expr, @@ -1417,9 +1417,9 @@ pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) pprIfaceExpr add_par (IfaceTick tickish e) = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e) -ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc -ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, - arrow <+> pprIfaceExpr noParens rhs] +pprIfaceAlt :: IfaceAlt -> SDoc +pprIfaceAlt (IfaceAlt con bs rhs) + = sep [ppr_con_bs con bs, arrow <+> pprIfaceExpr noParens rhs] ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) @@ -1748,14 +1748,14 @@ freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty freeNamesIfExpr (IfaceCase s _ alts) = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts where - fn_alt (_con,_bs,r) = freeNamesIfExpr r + fn_alt (IfaceAlt _con _bs r) = freeNamesIfExpr r -- Depend on the data constructors. Just one will do! -- Note [Tracking data constructors] - fn_cons [] = emptyNameSet - fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs - fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con - fn_cons (_ : _ ) = emptyNameSet + fn_cons [] = emptyNameSet + fn_cons (IfaceAlt IfaceDefault _ _ : xs) = fn_cons xs + fn_cons (IfaceAlt (IfaceDataAlt con) _ _ : _ ) = unitNameSet con + fn_cons (_ : _ ) = emptyNameSet freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body @@ -2283,6 +2283,16 @@ instance Binary IfaceUnfolding where _ -> do e <- get bh return (IfCompulsory e) +instance Binary IfaceAlt where + put_ bh (IfaceAlt a b c) = do + put_ bh a + put_ bh b + put_ bh c + get bh = do + a <- get bh + b <- get bh + c <- get bh + return (IfaceAlt a b c) instance Binary IfaceExpr where put_ bh (IfaceLcl aa) = do @@ -2607,6 +2617,9 @@ instance NFData IfaceExpr where IfaceFCall fc ty -> fc `seq` rnf ty IfaceTick tick e -> rnf tick `seq` rnf e +instance NFData IfaceAlt where + rnf (IfaceAlt con bndrs rhs) = rnf con `seq` rnf bndrs `seq` rnf rhs + instance NFData IfaceBinding where rnf = \case IfaceNonRec bndr e -> rnf bndr `seq` rnf e diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 7283f78666..bd9edbe01c 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -836,8 +836,8 @@ dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) dffvExpr _other = return () -dffvAlt :: (t, [Var], CoreExpr) -> DFFV () -dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r) +dffvAlt :: CoreAlt -> DFFV () +dffvAlt (Alt _ xs r) = extendScopeList xs (dffvExpr r) dffvBind :: (Id, CoreExpr) -> DFFV () dffvBind(x,r) diff --git a/compiler/GHC/Iface/UpdateIdInfos.hs b/compiler/GHC/Iface/UpdateIdInfos.hs index 9c013cc320..9b8b058745 100644 --- a/compiler/GHC/Iface/UpdateIdInfos.hs +++ b/compiler/GHC/Iface/UpdateIdInfos.hs @@ -140,7 +140,7 @@ updateGlobalIds env e = go env e go env (Case e b ty alts) = assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts)) where - go_alt (k,bs,e) = assertNotInNameEnv env bs (k, bs, go env e) + go_alt (Alt k bs e) = assertNotInNameEnv env bs (Alt k bs (go env e)) go env (Cast e c) = Cast (go env e) c go env (Tick t e) = Tick t (go env e) go _ e@Type{} = e diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index de0fa6f023..c6cb4c4533 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1532,30 +1532,30 @@ tcIfaceLit lit = return lit ------------------------- tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type]) - -> (IfaceConAlt, [FastString], IfaceExpr) - -> IfL (AltCon, [TyVar], CoreExpr) -tcIfaceAlt _ _ _ (IfaceDefault, names, rhs) + -> IfaceAlt + -> IfL CoreAlt +tcIfaceAlt _ _ _ (IfaceAlt IfaceDefault names rhs) = ASSERT( null names ) do rhs' <- tcIfaceExpr rhs - return (DEFAULT, [], rhs') + return (Alt DEFAULT [] rhs') -tcIfaceAlt _ _ _ (IfaceLitAlt lit, names, rhs) +tcIfaceAlt _ _ _ (IfaceAlt (IfaceLitAlt lit) names rhs) = ASSERT( null names ) do lit' <- tcIfaceLit lit rhs' <- tcIfaceExpr rhs - return (LitAlt lit', [], rhs') + return (Alt (LitAlt lit') [] rhs') -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! -tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) +tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceAlt (IfaceDataAlt data_occ) arg_strs rhs) = do { con <- tcIfaceDataCon data_occ ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) ; tcIfaceDataAlt mult con inst_tys arg_strs rhs } tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr - -> IfL (AltCon, [TyVar], CoreExpr) + -> IfL CoreAlt tcIfaceDataAlt mult con inst_tys arg_strs rhs = do { us <- newUniqueSupply ; let uniqs = uniqsFromSupply us @@ -1565,7 +1565,7 @@ tcIfaceDataAlt mult con inst_tys arg_strs rhs ; rhs' <- extendIfaceEnvs ex_tvs $ extendIfaceIdEnv arg_ids $ tcIfaceExpr rhs - ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } + ; return (Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs') } {- ************************************************************************ diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index b34e3269a1..5bd1fe490d 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -1615,10 +1615,10 @@ zonkCoreExpr env (Case scrut b ty alts) return $ Case scrut' b' ty' alts' zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt -zonkCoreAlt env (dc, bndrs, rhs) +zonkCoreAlt env (Alt dc bndrs rhs) = do (env1, bndrs') <- zonkCoreBndrsX env bndrs rhs' <- zonkCoreExpr env1 rhs - return $ (dc, bndrs', rhs') + return $ Alt dc bndrs' rhs' zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind) zonkCoreBind env (NonRec v e) diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index dd5657f419..665a32a538 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -1493,7 +1493,7 @@ seqId = pcMiscPrelId seqName ty info [x,y] = mkTemplateLocals [alphaTy, openBetaTy] rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ - Case (Var x) x openBetaTy [(DEFAULT, [], Var y)] + Case (Var x) x openBetaTy [Alt DEFAULT [] (Var y)] ------------------------------------------------ lazyId :: Id -- See Note [lazyId magic] @@ -1556,7 +1556,7 @@ coerceId = pcMiscPrelId coerceName ty info [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] rhs = mkLams (bndrs ++ [eqR, x]) $ mkWildCase (Var eqR) (unrestricted eqRTy) b $ - [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] + [Alt (DataAlt coercibleDataCon) [eq] (Cast (Var x) (mkCoVarCo eq))] {- Note [seqId magic] diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs index 7ac0303820..33b8b067ed 100644 --- a/testsuite/tests/callarity/unittest/CallArity1.hs +++ b/testsuite/tests/callarity/unittest/CallArity1.hs @@ -74,7 +74,7 @@ exprs = (mkLams [y] $ Var y) ) $ mkLams [z] $ Var d `mkVarApps` [x]) $ Case (go `mkLApps` [0, 0]) z intTy - [(DEFAULT, [], Var f `mkVarApps` [z,z])] + [Alt DEFAULT [] (Var f `mkVarApps` [z,z])] , ("go2 (in function call)",) $ mkRFun go [x] (mkLetNonRec d (mkACase (Var go `mkVarApps` [x]) @@ -216,7 +216,7 @@ allBoundIds (Let (Rec binds) body) = allBoundIds (App e1 e2) = allBoundIds e1 `unionVarSet` allBoundIds e2 allBoundIds (Case scrut _ _ alts) = allBoundIds scrut `unionVarSet` unionVarSets - [ allBoundIds e | (_, _ , e) <- alts ] + [ allBoundIds e | Alt _ _ e <- alts ] allBoundIds (Lam _ e) = allBoundIds e allBoundIds (Tick _ e) = allBoundIds e allBoundIds (Cast e _) = allBoundIds e diff --git a/testsuite/tests/plugins/HomePackagePlugin.hs b/testsuite/tests/plugins/HomePackagePlugin.hs index d2b11dd81a..9349e833b1 100644 --- a/testsuite/tests/plugins/HomePackagePlugin.hs +++ b/testsuite/tests/plugins/HomePackagePlugin.hs @@ -31,4 +31,4 @@ replaceInExpr (Case e b ty alts) = Case (replaceInExpr e) b ty (map replaceInAlt replaceInExpr (Type ty) = Type ty replaceInAlt :: CoreAlt -> CoreAlt -replaceInAlt (ac, bs, e) = (ac, bs, replaceInExpr e) +replaceInAlt (Alt ac bs e) = Alt ac bs (replaceInExpr e) diff --git a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs index 49a3a6cffa..caa41cef16 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs @@ -10,7 +10,7 @@ import qualified GHC.Utils.Error import Simple.DataStructures import Control.Monad -import Data.Monoid +import Data.Monoid hiding (Alt) import Data.Dynamic import qualified Language.Haskell.TH as TH @@ -83,4 +83,4 @@ changeExpr anns mb_replacement e = let go = changeExpr anns mb_replacement in ca _ -> return e changeAlt :: VarEnv [ReplaceWith] -> Maybe String -> CoreAlt -> CoreM CoreAlt -changeAlt anns mb_replacement (con, bs, e) = liftM (\e' -> (con, bs, e')) (changeExpr anns mb_replacement e) +changeAlt anns mb_replacement (Alt con bs e) = liftM (\e' -> Alt con bs e') (changeExpr anns mb_replacement e) |