Commit f96db3ca authored by Simon Peyton Jones's avatar Simon Peyton Jones

Establish the invariant that (LitAlt l) is always unlifted

...and make sure it is, esp in the call to findAlt in
the mighty Simplifier.  Failing to check this led to
searching a bunch of DataAlts for a LitAlt Integer.
Naughty.  See Trac #5603 for a case in point.
parent 2d5a1a5b
......@@ -33,7 +33,7 @@ module Literal
, pprLiteral
-- ** Predicates on Literals and their contents
, litIsDupable, litIsTrivial
, litIsDupable, litIsTrivial, litIsLifted
, inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
, isZeroLit
, litFitsInChar
......@@ -368,6 +368,10 @@ litFitsInChar (MachInt i)
= fromInteger i <= ord minBound
&& fromInteger i >= ord maxBound
litFitsInChar _ = False
litIsLifted :: Literal -> Bool
litIsLifted (LitInteger {}) = True
litIsLifted _ = False
\end{code}
Types
......
......@@ -41,7 +41,6 @@ import Kind
import Type
import TypeRep
import TyCon
import TcType
import BasicTypes
import StaticFlags
import ListSetOps
......@@ -526,12 +525,12 @@ lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
; checkAltExpr rhs alt_ty }
lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs)
| isIntegerTy scrut_ty
= failWithL integerScrutinisedMsg
| litIsLifted lit
= failWithL integerScrutinisedMsg
| otherwise
= do { checkL (null args) (mkDefaultArgsMsg args)
; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
; checkAltExpr rhs alt_ty }
= do { checkL (null args) (mkDefaultArgsMsg args)
; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
; checkAltExpr rhs alt_ty }
where
lit_ty = literalType lit
......@@ -1089,7 +1088,7 @@ mkBadPatMsg con_result_ty scrut_ty
integerScrutinisedMsg :: Message
integerScrutinisedMsg
= text "In a case alternative, scrutinee type is Integer"
= text "In a LitAlt, the literal is lifted (probably Integer)"
mkBadAltMsg :: Type -> CoreAlt -> Message
mkBadAltMsg scrut_ty alt
......
......@@ -278,11 +278,16 @@ type Arg b = Expr b
type Alt b = (AltCon, [b], Expr b)
-- | A case alternative constructor (i.e. pattern match)
data AltCon = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
-- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
| LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@
| DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@
deriving (Eq, Ord, Data, Typeable)
data AltCon
= DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
-- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
| LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@
-- Invariant: always an *unlifted* literal
-- See Note [Literal alternatives]
| DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@
deriving (Eq, Ord, Data, Typeable)
-- | Binding, used for top level bindings in a module and local bindings in a @let@.
data Bind b = NonRec b (Expr b)
......@@ -290,6 +295,21 @@ data Bind b = NonRec b (Expr b)
deriving (Data, Typeable)
\end{code}
Note [Literal alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Literal alternatives (LitAlt lit) are always for *un-lifted* literals.
We have one literal, a literal Integer, that is lifted, and we don't
allow in a LitAlt, because LitAlt cases don't do any evaluation. Also
(see Trac #5603) if you say
case 3 of
S# x -> ...
J# _ _ -> ...
(where S#, J# are the constructors for Integer) we don't want the
simplifier calling findAlt with argument (LitAlt 3). No no. Integer
literals are an opaque encoding of an algebraic data type, not of
an unlifted literal, like all the others.
-------------------------- CoreSyn INVARIANTS ---------------------------
Note [CoreSyn top-level invariant]
......
......@@ -291,7 +291,7 @@ mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
mkCoPrimCaseMatchResult :: Id -- Scrutinee
-> Type -- Type of the case
-> [(Literal, MatchResult)] -- Alternatives
-> MatchResult
-> MatchResult -- Literals are all unlifted
mkCoPrimCaseMatchResult var ty match_alts
= MatchResult CanFail mk_case
where
......@@ -300,8 +300,10 @@ mkCoPrimCaseMatchResult var ty match_alts
return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
sorted_alts = sortWith fst match_alts -- Right order for a Case
mk_alt fail (lit, MatchResult _ body_fn) = do body <- body_fn fail
return (LitAlt lit, [], body)
mk_alt fail (lit, MatchResult _ body_fn)
= ASSERT( not (litIsLifted lit) )
do body <- body_fn fail
return (LitAlt lit, [], body)
mkCoAlgCaseMatchResult
......
......@@ -348,6 +348,9 @@ litEq op_name is_eq
rule_fn _ _ = Nothing
do_lit_eq lit expr
| litIsLifted lit
= Nothing
| otherwise
= Just (mkWildCase expr (literalType lit) boolTy
[(DEFAULT, [], val_if_neq),
(LitAlt lit, [], val_if_eq)])
......
......@@ -21,6 +21,7 @@ import Type hiding ( substTy, extendTvSubst, substTyVar )
import SimplEnv
import SimplUtils
import FamInstEnv ( FamInstEnv )
import Literal ( litIsLifted )
import Id
import MkId ( seqId, realWorldPrimId )
import MkCore ( mkImpossibleExpr )
......@@ -1713,6 +1714,7 @@ rebuildCase, reallyRebuildCase
rebuildCase env scrut case_bndr alts cont
| Lit lit <- scrut -- No need for same treatment as constructors
-- because literals are inlined more vigorously
, not (litIsLifted lit)
= do { tick (KnownBranch case_bndr)
; case findAlt (LitAlt lit) alts of
Nothing -> missingAlt env case_bndr alts cont
......
......@@ -31,6 +31,7 @@ import CoreUtils
import CoreUnfold ( couldBeSmallEnoughToInline )
import CoreFVs ( exprsFreeVars )
import CoreMonad
import Literal ( litIsLifted )
import HscTypes ( ModGuts(..) )
import WwLib ( mkWorkerArgs )
import DataCon
......@@ -1714,7 +1715,8 @@ argsToPats env in_scope val_env args occs
\begin{code}
isValue :: ValueEnv -> CoreExpr -> Maybe Value
isValue _env (Lit lit)
= Just (ConVal (LitAlt lit) [])
| litIsLifted lit = Nothing
| otherwise = Just (ConVal (LitAlt lit) [])
isValue env (Var v)
| Just stuff <- lookupVarEnv env v
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment