import Var
import SrcLoc
import VarEnv
+import VarSet
import Name
import Module
#if mingw32_TARGET_OS
import Util
import Data.Word
import Data.Bits
-
-import GHC.Exts -- For `xori`
\end{code}
coreAltType :: CoreAlt -> Type
-- ^ Returns the type of the alternatives right hand side
-coreAltType (_,_,rhs) = exprType rhs
+coreAltType (_,bs,rhs)
+ | any bad_binder bs = expandTypeSynonyms ty
+ | otherwise = ty -- Note [Existential variables and silly type synonyms]
+ where
+ ty = exprType rhs
+ free_tvs = tyVarsOfType ty
+ bad_binder b = isTyVar b && b `elemVarSet` free_tvs
coreAltsType :: [CoreAlt] -> Type
-- ^ Returns the type of the first alternative, which should be the same as for all alternatives
coreAltsType [] = panic "corAltsType"
\end{code}
+Note [Existential variables and silly type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ data T = forall a. T (Funny a)
+ type Funny a = Bool
+ f :: T -> Bool
+ f (T x) = x
+
+Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.
+That means that 'exprType' and 'coreAltsType' may give a result that *appears*
+to mention an out-of-scope type variable. See Trac #3409 for a more real-world
+example.
+
+Various possibilities suggest themselves:
+
+ - Ignore the problem, and make Lint not complain about such variables
+
+ - Expand all type synonyms (or at least all those that discard arguments)
+ This is tricky, because at least for top-level things we want to
+ retain the type the user originally specified.
+
+ - Expand synonyms on the fly, when the problem arises. That is what
+ we are doing here. It's not too expensive, I think.
+
\begin{code}
mkPiType :: Var -> Type -> Type
-- ^ Makes a @(->)@ type or a forall type, depending
-- | Wraps the given expression in an inlining hint unless the expression
-- is trivial in some sense, so that doing so would usually hurt us
mkInlineMe :: CoreExpr -> CoreExpr
-mkInlineMe (Var v) = Var v
-mkInlineMe e = Note InlineMe e
+mkInlineMe e@(Var _) = e
+mkInlineMe e@(Note InlineMe _) = e
+mkInlineMe e = Note InlineMe e
\end{code}
\begin{code}
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
findDefault alts = (alts, Nothing)
+isDefaultAlt :: CoreAlt -> Bool
+isDefaultAlt (DEFAULT, _, _) = True
+isDefaultAlt _ = False
+
+
-- | Find the case alternative corresponding to a particular
-- constructor: panics if no such constructor exists
-findAlt :: AltCon -> [CoreAlt] -> CoreAlt
+findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt
+ -- A "Nothing" result *is* legitmiate
+ -- See Note [Unreachable code]
findAlt con alts
= case alts of
- (deflt@(DEFAULT,_,_):alts) -> go alts deflt
- _ -> go alts panic_deflt
+ (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)
+ _ -> go alts Nothing
where
- panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
-
- go [] deflt = deflt
+ go [] deflt = deflt
go (alt@(con1,_,_) : alts) deflt
= case con `cmpAltCon` con1 of
LT -> deflt -- Missed it already; the alts are in increasing order
- EQ -> alt
+ EQ -> Just alt
GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
-isDefaultAlt :: CoreAlt -> Bool
-isDefaultAlt (DEFAULT, _, _) = True
-isDefaultAlt _ = False
-
---------------------------------
mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
-- ^ Merge alternatives preserving order; alternatives in
trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
\end{code}
+Note [Unreachable code]
+~~~~~~~~~~~~~~~~~~~~~~~
+It is possible (although unusual) for GHC to find a case expression
+that cannot match. For example:
+
+ data Col = Red | Green | Blue
+ x = Red
+ f v = case x of
+ Red -> ...
+ _ -> ...(case x of { Green -> e1; Blue -> e2 })...
+
+Suppose that for some silly reason, x isn't substituted in the case
+expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff
+gets in the way; cf Trac #3118.) Then the full-lazines pass might produce
+this
+
+ x = Red
+ lvl = case x of { Green -> e1; Blue -> e2 })
+ f v = case x of
+ Red -> ...
+ _ -> ...lvl...
+
+Now if x gets inlined, we won't be able to find a matching alternative
+for 'Red'. That's because 'lvl' is unreachable. So rather than crashing
+we generate (error "Inaccessible alternative").
+
+Similar things can happen (augmented by GADTs) when the Simplifier
+filters down the matching alternatives in Simplify.rebuildCase.
+
+
%************************************************************************
%* *
applications. Note that primop Ids aren't considered
trivial unless
+Note [Variable are trivial]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
rare that I plan to allow them to be duplicated and put up with
saturating them.
-SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
- a) it really generates code, (and a heap object when it's
- a function arg) to capture the cost centre
- b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
+Note [SCCs are trivial]
+~~~~~~~~~~~~~~~~~~~~~~~
+We used not to treat (_scc_ "foo" x) as trivial, because it really
+generates code, (and a heap object when it's a function arg) to
+capture the cost centre. However, the profiling system discounts the
+allocation costs for such "boxing thunks" whereas the extra costs of
+*not* inlining otherwise-trivial bindings can be high, and are hard to
+discount.
\begin{code}
exprIsTrivial :: CoreExpr -> Bool
-exprIsTrivial (Var _) = True -- See notes above
+exprIsTrivial (Var _) = True -- See Note [Variables are trivial]
exprIsTrivial (Type _) = True
exprIsTrivial (Lit lit) = litIsTrivial lit
exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
-exprIsTrivial (Note (SCC _) _) = False -- See notes above
-exprIsTrivial (Note _ e) = exprIsTrivial e
+exprIsTrivial (Note _ e) = exprIsTrivial e -- See Note [SCCs are trivial]
exprIsTrivial (Cast e _) = exprIsTrivial e
exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
exprIsTrivial _ = False
isDivOp IntRemOp = True
isDivOp WordQuotOp = True
isDivOp WordRemOp = True
-isDivOp IntegerQuotRemOp = True
-isDivOp IntegerDivModOp = True
isDivOp FloatDivOp = True
isDivOp DoubleDivOp = True
isDivOp _ = False
projects / ghc-hetmet.git / blobdiff