diff options
Diffstat (limited to 'compiler')
51 files changed, 276 insertions, 261 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] |