#14680: GHC 8.4.1-alpha panics when optimizing function using getTag and tagToEnum# -------------------------------------+------------------------------------- Reporter: RyanGlScott | Owner: (none) Type: bug | Status: new Priority: highest | Milestone: 8.4.1 Component: Compiler | Version: 8.4.1-alpha1 Resolution: | Keywords: Operating System: Unknown/Multiple | Architecture: Type of failure: Compile-time | Unknown/Multiple crash or panic | Test Case: Blocked By: | Blocking: Related Tickets: | Differential Rev(s): Wiki Page: | -------------------------------------+------------------------------------- Comment (by RyanGlScott): I had a go at this, but am stuck. I thought fixing this would be a matter of propagating the `FamInstEnvs` down to `get_con` and using that to look up the tycon, as in the following patch: {{{#!diff diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 3fcc935..a912979 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -625,7 +625,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts ; return AssignedDirectly } -cgAlts _ _ _ _ = panic "cgAlts" +cgAlts _ _ alt _ = pprPanic "cgAlts" (ppr alt) -- UbxTupAlt and PolyAlt have only one alternative diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 1e3447b..05ea7ca 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -434,6 +434,7 @@ Library WorkWrap WwLib FamInst + FamInstLookup Inst TcAnnotations TcArrows diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index db79589..9449747 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -33,6 +33,8 @@ import CoreSyn import MkCore import Id import Literal +import FamInstEnv ( FamInstEnvs ) +import FamInstLookup import CoreOpt ( exprIsLiteral_maybe ) import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn @@ -1404,6 +1406,7 @@ match_smallIntegerTo _ _ _ _ _ = Nothing -- | Match the scrutinee of a case and potentially return a new scrutinee and a -- function to apply to each literal alternative. caseRules :: DynFlags + -> FamInstEnvs -> CoreExpr -- Scrutinee -> Maybe ( CoreExpr -- New scrutinee , AltCon -> AltCon -- How to fix up the alt pattern @@ -1419,14 +1422,14 @@ caseRules :: DynFlags -- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs; -- ... } -caseRules dflags (App (App (Var f) v) (Lit l)) -- v `op` x# +caseRules dflags _ (App (App (Var f) v) (Lit l)) -- v `op` x# | Just op <- isPrimOpId_maybe f , Just x <- isLitValue_maybe l , Just adjust_lit <- adjustDyadicRight op x = Just (v, tx_lit_con dflags adjust_lit , \v -> (App (App (Var f) (Var v)) (Lit l))) -caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v +caseRules dflags _ (App (App (Var f) (Lit l)) v) -- x# `op` v | Just op <- isPrimOpId_maybe f , Just x <- isLitValue_maybe l , Just adjust_lit <- adjustDyadicLeft x op @@ -1434,25 +1437,25 @@ caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v , \v -> (App (App (Var f) (Lit l)) (Var v))) -caseRules dflags (App (Var f) v ) -- op v +caseRules dflags _ (App (Var f) v ) -- op v | Just op <- isPrimOpId_maybe f , Just adjust_lit <- adjustUnary op = Just (v, tx_lit_con dflags adjust_lit , \v -> App (Var f) (Var v)) -- See Note [caseRules for tagToEnum] -caseRules dflags (App (App (Var f) type_arg) v) +caseRules dflags _ (App (App (Var f) type_arg) v) | Just TagToEnumOp <- isPrimOpId_maybe f = Just (v, tx_con_tte dflags , \v -> (App (App (Var f) type_arg) (Var v))) -- See Note [caseRules for dataToTag] -caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x +caseRules _ fam_envs (App (App (Var f) (Type ty)) v) -- dataToTag x | Just DataToTagOp <- isPrimOpId_maybe f - = Just (v, tx_con_dtt ty + = Just (v, tx_con_dtt fam_envs ty , \v -> App (App (Var f) (Type ty)) (Var v)) -caseRules _ _ = Nothing +caseRules _ _ _ = Nothing tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> AltCon @@ -1506,13 +1509,19 @@ tx_con_tte dflags (DataAlt dc) tag = dataConTagZ dc tx_con_tte _ alt = pprPanic "caseRules" (ppr alt) -tx_con_dtt :: Type -> AltCon -> AltCon -tx_con_dtt _ DEFAULT = DEFAULT -tx_con_dtt ty (LitAlt (MachInt i)) = DataAlt (get_con ty (fromInteger i)) -tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) - -get_con :: Type -> ConTagZ -> DataCon -get_con ty tag = tyConDataCons (tyConAppTyCon ty) !! tag +tx_con_dtt :: FamInstEnvs -> Type -> AltCon -> AltCon +tx_con_dtt _ _ DEFAULT = DEFAULT +tx_con_dtt fam_envs ty (LitAlt (MachInt i)) = + DataAlt (get_con fam_envs ty (fromInteger i)) +tx_con_dtt _ _ alt = pprPanic "caseRules" (ppr alt) + +get_con :: FamInstEnvs -> Type -> ConTagZ -> DataCon +get_con fam_envs ty tag + | Just (tc, tys) <- tcSplitTyConApp_maybe ty + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + = tyConDataCons rep_tc !! tag + | otherwise + = pprPanic "get_con" (ppr ty) {- Note [caseRules for tagToEnum] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index d86adbb..252ebdb 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -65,6 +65,7 @@ import Outputable import Pair import PrelRules import FastString ( fsLit ) +import FamInstEnv ( FamInstEnvs ) import Control.Monad ( when ) import Data.List ( sortBy ) @@ -2012,6 +2013,7 @@ There are some wrinkles mkCase, mkCase1, mkCase2, mkCase3 :: DynFlags + -> FamInstEnvs -> OutExpr -> OutId -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order -> SimplM OutExpr @@ -2020,7 +2022,8 @@ mkCase, mkCase1, mkCase2, mkCase3 -- 1. Merge Nested Cases -------------------------------------------------- -mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) +mkCase dflags fam_envs scrut outer_bndr alts_ty + ((DEFAULT, _, deflt_rhs) : outer_alts) | gopt Opt_CaseMerge dflags , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) <- stripTicksTop tickishFloatable deflt_rhs @@ -2048,7 +2051,7 @@ mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) -- precedence over e2 as the value for A! ; fmap (mkTicks ticks) $ - mkCase1 dflags scrut outer_bndr alts_ty merged_alts + mkCase1 dflags fam_envs scrut outer_bndr alts_ty merged_alts } -- Warning: don't call mkCase recursively! -- Firstly, there's no point, because inner alts have already had @@ -2056,13 +2059,15 @@ mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr -- in munge_rhs may put a case into the DEFAULT branch! -mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts +mkCase dflags fam_envs scrut bndr alts_ty alts = + mkCase1 dflags fam_envs scrut bndr alts_ty alts -------------------------------------------------- -- 2. Eliminate Identity Case -------------------------------------------------- -mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case +mkCase1 _dflags _fam_envs scrut case_bndr _ + alts@((_,_,rhs1) : _) -- Identity case | all identity_alt alts = do { tick (CaseIdentity case_bndr) ; return (mkTicks ticks $ re_cast scrut rhs1) } @@ -2101,27 +2106,28 @@ mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co re_cast scrut _ = scrut -mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts +mkCase1 dflags fam_envs scrut bndr alts_ty alts = + mkCase2 dflags fam_envs scrut bndr alts_ty alts -------------------------------------------------- -- 2. Scrutinee Constant Folding -------------------------------------------------- -mkCase2 dflags scrut bndr alts_ty alts +mkCase2 dflags fam_envs scrut bndr alts_ty alts | -- See Note [Scrutinee Constant Folding] case alts of -- Not if there is just a DEFAULT alternative [(DEFAULT,_,_)] -> False _ -> True , gopt Opt_CaseFolding dflags - , Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut + , Just (scrut', tx_con, mk_orig) <- caseRules dflags fam_envs scrut = do { bndr' <- newId (fsLit "lwild") (exprType scrut') ; alts' <- mapM (tx_alt tx_con mk_orig bndr') alts - ; mkCase3 dflags scrut' bndr' alts_ty $ + ; mkCase3 dflags fam_envs scrut' bndr' alts_ty $ add_default (re_sort alts') } | otherwise - = mkCase3 dflags scrut bndr alts_ty alts + = mkCase3 dflags fam_envs scrut bndr alts_ty alts where -- We need to keep the correct association between the scrutinee and its -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with @@ -2174,7 +2180,7 @@ mkCase2 dflags scrut bndr alts_ty alts -------------------------------------------------- -- Catch-all -------------------------------------------------- -mkCase3 _dflags scrut bndr alts_ty alts +mkCase3 _dflags _fam_envs scrut bndr alts_ty alts = return (Case scrut bndr alts_ty alts) {- diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index b123055..1e4d9d5 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -2482,9 +2482,10 @@ simplAlts env0 scrut case_bndr alts cont' ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $ ; let alts_ty' = contResultType cont' + ; fam_envs <- getFamEnvs -- See Note [Avoiding space leaks in OutType] ; seqType alts_ty' `seq` - mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' } + mkCase (seDynFlags env0) fam_envs scrut' case_bndr' alts_ty' alts' } ------------------------------------ diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index 956a412..812a67d 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -17,6 +17,7 @@ import GhcPrelude import HscTypes import FamInstEnv +import FamInstLookup import InstEnv( roughMatchTcs ) import Coercion import TcEvidence @@ -469,38 +470,6 @@ getFamInsts hpt_fam_insts mod tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion) tcInstNewTyCon_maybe = instNewTyCon_maybe --- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if --- there is no data family to unwrap. --- Returns a Representational coercion -tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType] - -> (TyCon, [TcType], Coercion) -tcLookupDataFamInst fam_inst_envs tc tc_args - | Just (rep_tc, rep_args, co) - <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args - = (rep_tc, rep_args, co) - | otherwise - = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args)) - -tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType] - -> Maybe (TyCon, [TcType], Coercion) --- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a) --- and returns a coercion between the two: co :: F [a] ~R FList a. -tcLookupDataFamInst_maybe fam_inst_envs tc tc_args - | isDataFamilyTyCon tc - , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args - , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax - , fi_cvs = cvs }) - , fim_tys = rep_args - , fim_cos = rep_cos } <- match - , let rep_tc = dataFamInstRepTyCon rep_fam - co = mkUnbranchedAxInstCo Representational ax rep_args - (mkCoVarCos cvs) - = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in FamInstEnv - Just (rep_tc, rep_args, co) - - | otherwise - = Nothing - -- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes, -- potentially looking through newtype /instances/. -- }}} Unfortunately, that just causes the panic to change: {{{ $ inplace/bin/ghc-stage2 -fforce-recomp -O1 ../Bug.hs [1 of 1] Compiling Bug ( ../Bug.hs, ../Bug.o ) ghc-stage2: panic! (the 'impossible' happened) (GHC version 8.5.20180117 for x86_64-unknown-linux): cgAlts Polymorphic Call stack: CallStack (from HasCallStack): callStackDoc, called at compiler/utils/Outputable.hs:1150:37 in ghc:Outputable pprPanic, called at compiler/codeGen/StgCmmExpr.hs:628:20 in ghc:StgCmmExpr }}} I have no idea what's going on in `StgCmmExpr`, so I'm out of ideas. -- Ticket URL: http://ghc.haskell.org/trac/ghc/ticket/14680#comment:3 GHC http://www.haskell.org/ghc/ The Glasgow Haskell Compiler