Don't allow Float#/Double# literal patterns

  This patch does the following two things:

    1. Fix the check in Core Lint to properly throw an error when it
       comes across Float#/Double# literal patterns. The check
       was incorrect before, because it expected the type to be
       Float/Double instead of Float#/Double#.

    2. Add an error in the parser when the user writes a floating-point
       literal pattern such as `case x of { 2.0## -> ... }`.

  Fixes #21115

13 files changed, 132 insertions, 20 deletions

diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 90eb08e7f6..a3dedcc0fb 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -507,7 +507,7 @@ checked by Core Lint.
 5. Floating-point values must not be scrutinised against literals.
    See #9238 and Note [Rules for floating-point comparisons]
    in GHC.Core.Opt.ConstantFold for rationale.  Checked in lintCaseExpr;
-   see the call to isFloatingTy.
+   see the call to isFloatingPrimTy.
 
 6. The 'ty' field of (Case scrut bndr ty alts) is the type of the
    /entire/ case expression.  Checked in lintAltExpr.
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 32d109b2f1..c0cc8b0cfd 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -30,7 +30,7 @@ import GHC.Driver.Ppr
 import GHC.Driver.Env
 import GHC.Driver.Config.Diagnostic
 
-import GHC.Tc.Utils.TcType   ( isFloatingTy, isTyFamFree )
+import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree )
 import GHC.Unit.Module.ModGuts
 import GHC.Runtime.Context
 
@@ -1413,7 +1413,7 @@ lintCaseExpr scrut var alt_ty alts =
      -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold
      ; let isLitPat (Alt (LitAlt _) _  _) = True
            isLitPat _                     = False
-     ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)
+     ; checkL (not $ isFloatingPrimTy scrut_ty && any isLitPat alts)
          (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)."
           $$ text "scrut" <+> ppr scrut)
 
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index a581a961b5..2913404b00 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -506,9 +506,9 @@ to convert it to the needed type `Word8`.
 
 tidyLitPat :: HsLit GhcTc -> Pat GhcTc
 -- Result has only the following HsLits:
---      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
---      HsDoublePrim, HsStringPrim, HsString
---  * HsInteger, HsRat, HsInt can't show up in LitPats
+--      HsIntPrim, HsWordPrim, HsCharPrim, HsString
+--  * HsInteger, HsRat, HsInt, as well as HsStringPrim,
+--    HsFloatPrim and HsDoublePrim can't show up in LitPats
 --  * We get rid of HsChar right here
 tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
 tidyLitPat (HsString src s)
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index fe9f74eb73..4f649d9190 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -306,6 +306,8 @@ instance Diagnostic PsMessage where
       -> mkSimpleDecorated $ text "Not a record constructor:" <+> ppr p
     PsErrIllegalUnboxedStringInPat lit
       -> mkSimpleDecorated $ text "Illegal unboxed string literal in pattern:" $$ ppr lit
+    PsErrIllegalUnboxedFloatingLitInPat lit
+      -> mkSimpleDecorated $ text "Illegal unboxed floating point literal in pattern:" $$ ppr lit
     PsErrDoNotationInPat
       -> mkSimpleDecorated $ text "do-notation in pattern"
     PsErrIfThenElseInPat
@@ -551,6 +553,7 @@ instance Diagnostic PsMessage where
     PsErrUnexpectedKindAppInDataCon{}             -> ErrorWithoutFlag
     PsErrInvalidRecordCon{}                       -> ErrorWithoutFlag
     PsErrIllegalUnboxedStringInPat{}              -> ErrorWithoutFlag
+    PsErrIllegalUnboxedFloatingLitInPat{}         -> ErrorWithoutFlag
     PsErrDoNotationInPat{}                        -> ErrorWithoutFlag
     PsErrIfThenElseInPat                          -> ErrorWithoutFlag
     PsErrLambdaCaseInPat                          -> ErrorWithoutFlag
@@ -679,6 +682,7 @@ instance Diagnostic PsMessage where
     PsErrUnexpectedKindAppInDataCon{}             -> noHints
     PsErrInvalidRecordCon{}                       -> noHints
     PsErrIllegalUnboxedStringInPat{}              -> noHints
+    PsErrIllegalUnboxedFloatingLitInPat{}         -> noHints
     PsErrDoNotationInPat{}                        -> noHints
     PsErrIfThenElseInPat                          -> noHints
     PsErrLambdaCaseInPat                          -> noHints
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index d50b21d7ad..d99f789154 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -235,6 +235,9 @@ data PsMessage
    -- | Illegal unboxed string literal in pattern
    | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs)
 
+   -- | Illegal primitive floating point literal in pattern
+   | PsErrIllegalUnboxedFloatingLitInPat !(HsLit GhcPs)
+
    -- | Do-notation in pattern
    | PsErrDoNotationInPat
 
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index a04eba73a4..b9be24259a 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1812,7 +1812,7 @@ instance DisambECP (PatBuilder GhcPs) where
   mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
   mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)
   mkHsLitPV lit@(L l a) = do
-    checkUnboxedStringLitPat lit
+    checkUnboxedLitPat lit
     return $ L l (PatBuilderPat (LitPat noExtField a))
   mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)
   mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))
@@ -1862,13 +1862,31 @@ instance DisambECP (PatBuilder GhcPs) where
   mkSumOrTuplePV = mkSumOrTuplePat
   rejectPragmaPV _ = return ()
 
-checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
-checkUnboxedStringLitPat (L loc lit) =
+-- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#.
+checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV ()
+checkUnboxedLitPat (L loc lit) =
   case lit of
-    HsStringPrim _ _  -- Trac #13260
+    -- Don't allow primitive string literal patterns.
+    -- See #13260.
+    HsStringPrim {}
       -> addFatalError $ mkPlainErrorMsgEnvelope loc $
                            (PsErrIllegalUnboxedStringInPat lit)
-    _ -> return ()
+
+   -- Don't allow Float#/Double# literal patterns.
+   -- See #9238 and Note [Rules for floating-point comparisons]
+   -- in GHC.Core.Opt.ConstantFold.
+    _ | is_floating_lit lit
+      -> addFatalError $ mkPlainErrorMsgEnvelope loc $
+                           (PsErrIllegalUnboxedFloatingLitInPat lit)
+
+      | otherwise
+      -> return ()
+
+  where
+    is_floating_lit :: HsLit GhcPs -> Bool
+    is_floating_lit (HsFloatPrim  {}) = True
+    is_floating_lit (HsDoublePrim {}) = True
+    is_floating_lit _                 = False
 
 mkPatRec ::
   LocatedA (PatBuilder GhcPs) ->
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index b01f72b185..d538638279 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -78,7 +78,7 @@ module GHC.Tc.Utils.TcType (
   pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,
   tcEqTyConApps,
   isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
-  isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
+  isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
   isIntegerTy, isNaturalTy,
   isBoolTy, isUnitTy, isCharTy,
   isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
@@ -1999,11 +1999,15 @@ isOverloadedTy (ForAllTy _  ty)             = isOverloadedTy ty
 isOverloadedTy (FunTy { ft_af = InvisArg }) = True
 isOverloadedTy _                            = False
 
-isFloatTy, isDoubleTy, isIntegerTy, isNaturalTy,
+isFloatTy, isDoubleTy,
+    isFloatPrimTy, isDoublePrimTy,
+    isIntegerTy, isNaturalTy,
     isIntTy, isWordTy, isBoolTy,
     isUnitTy, isCharTy, isAnyTy :: Type -> Bool
 isFloatTy      = is_tc floatTyConKey
 isDoubleTy     = is_tc doubleTyConKey
+isFloatPrimTy  = is_tc floatPrimTyConKey
+isDoublePrimTy = is_tc doublePrimTyConKey
 isIntegerTy    = is_tc integerTyConKey
 isNaturalTy    = is_tc naturalTyConKey
 isIntTy        = is_tc intTyConKey
@@ -2013,9 +2017,15 @@ isUnitTy       = is_tc unitTyConKey
 isCharTy       = is_tc charTyConKey
 isAnyTy        = is_tc anyTyConKey
 
--- | Does a type represent a floating-point number?
-isFloatingTy :: Type -> Bool
-isFloatingTy ty = isFloatTy ty || isDoubleTy ty
+-- | Is the type inhabited by machine floating-point numbers?
+--
+-- Used to check that we don't use floating-point literal patterns
+-- in Core.
+--
+-- See #9238 and Note [Rules for floating-point comparisons]
+-- in GHC.Core.Opt.ConstantFold.
+isFloatingPrimTy :: Type -> Bool
+isFloatingPrimTy ty = isFloatPrimTy ty || isDoublePrimTy ty
 
 -- | Is a type 'String'?
 isStringTy :: Type -> Bool
diff --git a/testsuite/tests/codeGen/should_run/T8103.hs b/testsuite/tests/codeGen/should_run/T8103.hs
index 99e213b06c..d309c829e7 100644
--- a/testsuite/tests/codeGen/should_run/T8103.hs
+++ b/testsuite/tests/codeGen/should_run/T8103.hs
@@ -1,8 +1,9 @@
 {-# LANGUAGE MagicHash #-}
 module Main where
 import T8103_A
+import GHC.Exts (isTrue#, (==##))
 
-float_text = case (0.0## `foo` 1.2##) of
-               0.0## -> "1"
-               _     -> "0"
+float_text = if isTrue# ((0.0## `foo` 1.2##) ==## 0.0##)
+             then "1"
+             else "0"
 main = putStrLn (float_text)
diff --git a/testsuite/tests/corelint/T21115.hs b/testsuite/tests/corelint/T21115.hs
new file mode 100644
index 0000000000..75f654c09d
--- /dev/null
+++ b/testsuite/tests/corelint/T21115.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE MagicHash #-}
+
+module T21115 where
+
+import GHC.Exts (Double#, Int#)
+
+foo :: Double# -> Int#
+foo x =
+  case x of
+    0.0##  -> 2#
+    2.0##  -> 3#
+    -0.0## -> 4#
+    _      -> 5#
diff --git a/testsuite/tests/corelint/T21115.stderr b/testsuite/tests/corelint/T21115.stderr
new file mode 100644
index 0000000000..cb4f3a3e4f
--- /dev/null
+++ b/testsuite/tests/corelint/T21115.stderr
@@ -0,0 +1,4 @@
+
+T21115.hs:10:5: error:
+    Illegal unboxed floating point literal in pattern:
+    0.0##
diff --git a/testsuite/tests/corelint/T21115b.hs b/testsuite/tests/corelint/T21115b.hs
new file mode 100644
index 0000000000..6053a3c71a
--- /dev/null
+++ b/testsuite/tests/corelint/T21115b.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE LambdaCase, MagicHash, TemplateHaskell #-}
+
+module T21115b where
+
+import GHC.Exts (Double#, Int#)
+import Language.Haskell.TH.Syntax
+
+foo :: Double# -> Int#
+foo =
+  $( return $ LamCaseE
+      [ Match (LitP $ DoublePrimL 0.0) (NormalB $ LitE $ IntPrimL 2) []
+      , Match (LitP $ DoublePrimL 2.0) (NormalB $ LitE $ IntPrimL 3) []
+      , Match WildP                    (NormalB $ LitE $ IntPrimL 5) []
+      ]
+   )
diff --git a/testsuite/tests/corelint/T21115b.stderr b/testsuite/tests/corelint/T21115b.stderr
new file mode 100644
index 0000000000..8833208b19
--- /dev/null
+++ b/testsuite/tests/corelint/T21115b.stderr
@@ -0,0 +1,37 @@
+*** Core Lint errors : in result of Desugar (before optimization) ***
+T21115b.hs:9:1: warning:
+    Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238).
+    scrut ds
+    In the RHS of foo :: Double# -> Int#
+    In the body of lambda with binder ds :: Double#
+    In the body of letrec with binders fail :: (# #) -> Int#
+    In the body of letrec with binders fail :: (# #) -> Int#
+    Substitution: [TCvSubst
+                     In scope: InScope {}
+                     Type env: []
+                     Co env: []]
+*** Offending Program ***
+Rec {
+$trModule = Module (TrNameS "main"#) (TrNameS "T21115b"#)
+
+foo
+  = \ ds ->
+      let {
+        fail
+          = \ ds ->
+              case patError "T21115b.hs:(10,4)-(15,4)|case"# of wild { } } in
+      let { fail = \ ds -> 5# } in
+      case ds of ds {
+        __DEFAULT -> fail void#;
+        0.0## -> 2#;
+        2.0## -> 3#
+      }
+end Rec }
+
+*** End of Offense ***
+
+
+<no location info>: error: 
+Compilation had errors
+
+
diff --git a/testsuite/tests/corelint/all.T b/testsuite/tests/corelint/all.T
index 1b53c188be..4deab99146 100644
--- a/testsuite/tests/corelint/all.T
+++ b/testsuite/tests/corelint/all.T
@@ -1,5 +1,12 @@
+
+test('T21115', normal, compile_fail, [''])
+test('T21115b', normal, compile_fail, ['-dsuppress-uniques -dsuppress-all'])
+test('T21152', normal, compile, ['-g3'])
+
+## Tests which use the GHC API.
 setTestOpts(extra_hc_opts('-package ghc'))
 setTestOpts(extra_run_opts('"' + config.libdir + '"'))
 
 test('LintEtaExpand', normal, compile_and_run, [''])
-test('T21152', normal, compile, ['-g3'])
+## These tests use the GHC API.
+## Test cases which don't use the GHC API should be added nearer the top.