[GHC] #14680: GHC 8.4.1-alpha panics when optimizing function using getTag and tagToEnum#
GHC
ghc-devs at haskell.org
Thu Jan 18 01:04:30 UTC 2018
#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
More information about the ghc-tickets
mailing list