Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/f96db3ca8a7c83cc3da242fad761fb05543068f6 >--------------------------------------------------------------- commit f96db3ca8a7c83cc3da242fad761fb05543068f6 Author: Simon Peyton Jones <[email protected]> Date: Wed Nov 9 23:32:20 2011 +0000 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. >--------------------------------------------------------------- compiler/basicTypes/Literal.lhs | 6 +++++- compiler/coreSyn/CoreLint.lhs | 13 ++++++------- compiler/coreSyn/CoreSyn.lhs | 30 +++++++++++++++++++++++++----- compiler/deSugar/DsUtils.lhs | 8 +++++--- compiler/prelude/PrelRules.lhs | 3 +++ compiler/simplCore/Simplify.lhs | 2 ++ compiler/specialise/SpecConstr.lhs | 4 +++- 7 files changed, 49 insertions(+), 17 deletions(-) diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index 4174445..966dca1 100644 --- a/compiler/basicTypes/Literal.lhs +++ b/compiler/basicTypes/Literal.lhs @@ -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 diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 9351da1..457af33 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -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 diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index ea0ef22..a8dbbce 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -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] diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index dc3f99b..1399475 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -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 diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 4e39966..40ee5b0 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -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)]) diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 0a9d388..61431be 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -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 diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 1249283..d2c07bc 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
