summaryrefslogtreecommitdiff
path: root/compiler/coreSyn
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/coreSyn')
-rw-r--r--compiler/coreSyn/CoreFVs.hs19
-rw-r--r--compiler/coreSyn/CoreLint.hs10
-rw-r--r--compiler/coreSyn/CorePrep.hs6
-rw-r--r--compiler/coreSyn/CoreSeq.hs8
-rw-r--r--compiler/coreSyn/CoreSubst.hs14
-rw-r--r--compiler/coreSyn/CoreSyn.hs7
-rw-r--r--compiler/coreSyn/CoreUnfold.hs2
-rw-r--r--compiler/coreSyn/PprCore.hs2
8 files changed, 35 insertions, 33 deletions
diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs
index f5f58dc442..0e5027768a 100644
--- a/compiler/coreSyn/CoreFVs.hs
+++ b/compiler/coreSyn/CoreFVs.hs
@@ -24,7 +24,7 @@ module CoreFVs (
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
- ruleLhsOrphNames, ruleLhsFreeIds, exprsOrphNames,
+ ruleLhsFreeIds, exprsOrphNames,
vectsFreeVars,
-- * Core syntax tree annotation with free variables
@@ -215,21 +215,6 @@ tickish_fvs _ = noVars
************************************************************************
-}
--- | ruleLhsOrphNames is used when deciding whether
--- a rule is an orphan. In particular, suppose that T is defined in this
--- module; we want to avoid declaring that a rule like:
---
--- > fromIntegral T = fromIntegral_T
---
--- is an orphan. Of course it isn't, and declaring it an orphan would
--- make the whole module an orphan module, which is bad.
-ruleLhsOrphNames :: CoreRule -> NameSet
-ruleLhsOrphNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
-ruleLhsOrphNames (Rule { ru_fn = fn, ru_args = tpl_args })
- = extendNameSet (exprsOrphNames tpl_args) fn
- -- No need to delete bndrs, because
- -- exprsOrphNames finds only External names
-
-- | Finds the free /external/ names of an expression, notably
-- including the names of type constructors (which of course do not show
-- up in 'exprFreeVars').
@@ -423,7 +408,7 @@ idRuleAndUnfoldingVars id = ASSERT( isId id)
idUnfoldingVars id
idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars
-idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
+idRuleVars id = ASSERT( isId id) ruleInfoFreeVars (idSpecialisation id)
idUnfoldingVars :: Id -> VarSet
-- Produce free vars for an unfolding, but NOT for an ordinary
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 0b72ff4db2..ea1d9689b7 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -32,6 +32,7 @@ import Literal
import DataCon
import TysWiredIn
import TysPrim
+import TcType ( isFloatingTy )
import Var
import VarEnv
import VarSet
@@ -662,6 +663,15 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
(ptext (sLit "No alternatives for a case scrutinee not known to diverge for sure:") <+> ppr scrut)
}
+ -- See Note [Rules for floating-point comparisons] in PrelRules
+ ; let isLitPat (LitAlt _, _ , _) = True
+ isLitPat _ = False
+ ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)
+ (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++
+ "expression with literal pattern in case " ++
+ "analysis (see Trac #9238).")
+ $$ text "scrut" <+> ppr scrut)
+
; case tyConAppTyCon_maybe (idType var) of
Just tycon
| debugIsOn &&
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 7b256a4012..23afcdfb04 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -1168,9 +1168,9 @@ lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
-- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
guardIntegerUse :: DynFlags -> IO a -> IO a
guardIntegerUse dflags act
- | thisPackage dflags == primPackageKey
+ | thisPackage dflags == primUnitId
= return $ panic "Can't use Integer in ghc-prim"
- | thisPackage dflags == integerPackageKey
+ | thisPackage dflags == integerUnitId
= return $ panic "Can't use Integer in integer-*"
| otherwise = act
@@ -1218,7 +1218,7 @@ cpCloneBndr env bndr
-- so that we can drop more stuff as dead code.
-- See also Note [Dead code in CorePrep]
let bndr'' = bndr' `setIdUnfolding` noUnfolding
- `setIdSpecialisation` emptySpecInfo
+ `setIdSpecialisation` emptyRuleInfo
return (extendCorePrepEnv env bndr bndr'', bndr'')
| otherwise -- Top level things, which we don't want
diff --git a/compiler/coreSyn/CoreSeq.hs b/compiler/coreSyn/CoreSeq.hs
index 9bd3f458b6..e3c7844f2e 100644
--- a/compiler/coreSyn/CoreSeq.hs
+++ b/compiler/coreSyn/CoreSeq.hs
@@ -7,7 +7,7 @@
module CoreSeq (
-- * Utilities for forcing Core structures
seqExpr, seqExprs, seqUnfolding, seqRules,
- megaSeqIdInfo, seqSpecInfo, seqBinds,
+ megaSeqIdInfo, seqRuleInfo, seqBinds,
) where
import CoreSyn
@@ -24,7 +24,7 @@ import Id( Id, idInfo )
-- compiler
megaSeqIdInfo :: IdInfo -> ()
megaSeqIdInfo info
- = seqSpecInfo (specInfo info) `seq`
+ = seqRuleInfo (ruleInfo info) `seq`
-- Omitting this improves runtimes a little, presumably because
-- some unfoldings are not calculated at all
@@ -39,8 +39,8 @@ megaSeqIdInfo info
seqOneShot :: OneShotInfo -> ()
seqOneShot l = l `seq` ()
-seqSpecInfo :: SpecInfo -> ()
-seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
+seqRuleInfo :: RuleInfo -> ()
+seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
seqCaf :: CafInfo -> ()
seqCaf c = c `seq` ()
diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index e78ff70888..c1de2051ee 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -623,12 +623,12 @@ substIdType subst@(Subst _ _ tv_env cv_env) id
substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
substIdInfo subst new_id info
| nothing_to_do = Nothing
- | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules
+ | otherwise = Just (info `setRuleInfo` substSpec subst new_id old_rules
`setUnfoldingInfo` substUnfolding subst old_unf)
where
- old_rules = specInfo info
+ old_rules = ruleInfo info
old_unf = unfoldingInfo info
- nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf
+ nothing_to_do = isEmptyRuleInfo old_rules && isClosedUnfolding old_unf
------------------
@@ -668,12 +668,12 @@ substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of
------------------
-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
-substSpec :: Subst -> Id -> SpecInfo -> SpecInfo
-substSpec subst new_id (SpecInfo rules rhs_fvs)
- = seqSpecInfo new_spec `seq` new_spec
+substSpec :: Subst -> Id -> RuleInfo -> RuleInfo
+substSpec subst new_id (RuleInfo rules rhs_fvs)
+ = seqRuleInfo new_spec `seq` new_spec
where
subst_ru_fn = const (idName new_id)
- new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules)
+ new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules)
(substVarSet subst rhs_fvs)
------------------
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index fedf1d73ec..24ce641039 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -233,6 +233,10 @@ These data types are the heart of the compiler
-- The inner case does not need a @Red@ alternative, because @x@
-- can't be @Red@ at that program point.
--
+-- 5. Floating-point values must not be scrutinised against literals.
+-- See Trac #9238 and Note [Rules for floating-point comparisons]
+-- in PrelRules for rationale.
+--
-- * Cast an expression to a particular type.
-- This is used to implement @newtype@s (a @newtype@ constructor or
-- destructor just becomes a 'Cast' in Core) and GADTs.
@@ -329,6 +333,9 @@ 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.
+Also, we do not permit case analysis with literal patterns on floating-point
+types. See Trac #9238 and Note [Rules for floating-point comparisons] in
+PrelRules for the rationale for this restriction.
-------------------------- CoreSyn INVARIANTS ---------------------------
diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs
index b04c13d886..edbe503fc4 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -1239,7 +1239,7 @@ CONLIKE thing (modulo lets).
Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables]
~~~~~~~~~~~~~~~~~~~~~ which appears below
The "lone-variable" case is important. I spent ages messing about
-with unsatisfactory varaints, but this is nice. The idea is that if a
+with unsatisfactory variants, but this is nice. The idea is that if a
variable appears all alone
as an arg of lazy fn, or rhs BoringCtxt
diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
index 2ae1577bd0..eb5e595925 100644
--- a/compiler/coreSyn/PprCore.hs
+++ b/compiler/coreSyn/PprCore.hs
@@ -418,7 +418,7 @@ ppIdInfo id info
unf_info = unfoldingInfo info
has_unf = hasSomeUnfolding unf_info
- rules = specInfoRules (specInfo info)
+ rules = ruleInfoRules (ruleInfo info)
showAttributes :: [(Bool,SDoc)] -> SDoc
showAttributes stuff
View Lorry Controller Status