Pattern-synonym matcher and builder Ids must be *LocalIds*

This easy-to-make mistake meant that pattern-synonym matcher and
builder Ids weren't being treated as locally defined by the simpplier.
That meant that we never looked up them up in the environment, got an
out-of-date unfolding, which made the Simplifier fall into an infinite
loop.  This was the cause of Trac #98587, but it was quite tricky to
find!

In a separate patch I'll make Lint check for locally-bound GlobalIds,
since they are always an error.

4 files changed, 172 insertions, 3 deletions

diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index fa34a4fd78..ccd6c9b494 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -314,6 +314,7 @@ We use mkExportedLocalId for things like
  - Dictionary functions (DFunId)
  - Wrapper and matcher Ids for pattern synonyms
  - Default methods for classes
+ - Pattern-synonym matcher and builder Ids
  - etc
 
 They marked as "exported" in the sense that they should be kept alive
@@ -329,7 +330,9 @@ of reasons:
    dependency analysis (e.g. CoreFVs.exprFreeVars).
 
  * Look them up in the current substitution when we come across
-   occurrences of them (in Subst.lookupIdSubst)
+   occurrences of them (in Subst.lookupIdSubst). Lacking this we
+   can get an out-of-date unfolding, which can in turn make the
+   simplifier go into an infinite loop (Trac #9857)
 
  * Ensure that for dfuns that the specialiser does not float dict uses
    above their defns, which would prevent good simplifications happening.
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 9cc49111ac..65339818fe 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -26,6 +26,7 @@ import Outputable
 import FastString
 import Var
 import Id
+import IdInfo( IdDetails(..) )
 import TcBinds
 import BasicTypes
 import TcSimplify
@@ -254,7 +255,8 @@ tcPatSynMatcher (L loc name) lpat
 
        ; let matcher_tau   = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
              matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
-             matcher_id    = mkVanillaGlobal matcher_name matcher_sigma
+             matcher_id    = mkExportedLocalId VanillaId matcher_name matcher_sigma
+                             -- See Note [Exported LocalIds] in Id
 
              cont_dicts = map nlHsVar prov_dicts
              cont' = mkLHsWrap (mkWpLet prov_ev_binds) $
@@ -326,7 +328,8 @@ mkPatSynBuilderId dir  (L _ name) qtvs theta arg_tys pat_ty
   | otherwise
   = do { builder_name <- newImplicitBinder name mkDataConWorkerOcc
        ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty)
-             builder_id    = mkVanillaGlobal builder_name builder_sigma
+             builder_id    = mkExportedLocalId VanillaId builder_name builder_sigma
+                             -- See Note [Exported LocalIds] in Id
        ; return (Just (builder_id, need_dummy_arg)) }
   where
     builder_arg_tys | need_dummy_arg = [voidPrimTy]
diff --git a/testsuite/tests/patsyn/should_compile/T9857.hs b/testsuite/tests/patsyn/should_compile/T9857.hs
new file mode 100644
index 0000000000..1204e888df
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T9857.hs
@@ -0,0 +1,162 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- |
+-- Copyright   :  (C) 2014 Edward Kmett
+-- License     :  BSD-style (see the file LICENSE)
+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
+-- Stability   :  experimental
+-- Portability :  PatternSynonyms
+--
+-- Half-precision floating-point values. These arise commonly in GPU work
+-- and it is useful to be able to compute them and compute with them on the
+-- CPU as well.
+----------------------------------------------------------------------------
+
+module T9857 
+  ( Half(..)
+  , isZero
+  , fromHalf
+  , toHalf
+  , pattern POS_INF
+  , pattern NEG_INF
+  , pattern QNaN
+  , pattern SNaN
+  , pattern HALF_MIN
+  , pattern HALF_NRM_MIN
+  , pattern HALF_MAX
+  , pattern HALF_EPSILON
+  , pattern HALF_DIG
+  , pattern HALF_MIN_10_EXP
+  , pattern HALF_MAX_10_EXP
+  ) where
+
+import Data.Bits
+import Data.Function (on)
+import Data.Typeable
+import Foreign.C.Types
+import Foreign.Storable
+import Text.Read
+
+-- | Convert a 'Float' to a 'Half' with proper rounding, while preserving NaN and dealing appropriately with infinity
+foreign import ccall unsafe "hs_floatToHalf" toHalf :: Float -> Half
+{-# RULES "toHalf"  realToFrac = toHalf #-}
+
+-- | Convert a 'Half' to a 'Float' while preserving NaN
+foreign import ccall unsafe "hs_halfToFloat" fromHalf :: Half -> Float
+{-# RULES "fromHalf" realToFrac = fromHalf #-}
+
+newtype {-# CTYPE "unsigned short" #-} Half = Half { getHalf :: CUShort } deriving (Storable, Typeable)
+
+instance Show Half where
+  showsPrec d h = showsPrec d (fromHalf h)
+
+instance Read Half where
+  readPrec = fmap toHalf readPrec
+
+instance Eq Half where
+  (==) = (==) `on` fromHalf
+
+instance Ord Half where
+  compare = compare `on` fromHalf
+
+instance Real Half where
+  toRational = toRational . fromHalf
+
+instance Fractional Half where
+  fromRational = toHalf . fromRational
+  recip = toHalf . recip . fromHalf
+  a / b = toHalf $ fromHalf a / fromHalf b
+
+instance RealFrac Half where
+  properFraction a = case properFraction (fromHalf a) of
+    (b, c) -> (b, toHalf c)
+  truncate = truncate . fromHalf
+  round = round . fromHalf
+  ceiling = ceiling . fromHalf
+  floor = floor . fromHalf
+
+instance Floating Half where
+  pi = toHalf pi
+  exp = toHalf . exp . fromHalf
+  sqrt = toHalf . sqrt . fromHalf
+  log = toHalf . log . fromHalf
+  a ** b = toHalf $ fromHalf a ** fromHalf b
+  logBase a b = toHalf $ logBase (fromHalf a) (fromHalf b)
+  sin = toHalf . sin . fromHalf
+  tan = toHalf . tan . fromHalf
+  cos = toHalf . cos . fromHalf
+  asin = toHalf . asin . fromHalf
+  atan = toHalf . atan . fromHalf
+  acos = toHalf . acos . fromHalf
+  sinh = toHalf . sinh . fromHalf
+  tanh = toHalf . tanh . fromHalf
+  cosh = toHalf . cosh . fromHalf
+  asinh = toHalf . asinh . fromHalf
+  atanh = toHalf . atanh . fromHalf
+  acosh = toHalf . acosh . fromHalf
+
+instance RealFloat Half where
+  floatRadix  _ = 2
+  floatDigits _ = 11
+  decodeFloat = decodeFloat . fromHalf
+  isInfinite (Half h) = unsafeShiftR h 10 .&. 0x1f >= 32
+  isIEEE _ = isIEEE (undefined :: Float)
+  atan2 a b = toHalf $ atan2 (fromHalf a) (fromHalf b)
+  isDenormalized (Half h) = unsafeShiftR h 10 .&. 0x1f == 0 && h .&. 0x3ff /= 0
+  isNaN (Half h) = unsafeShiftR h 10 .&. 0x1f == 0x1f && h .&. 0x3ff /= 0
+  isNegativeZero (Half h) = h == 0x8000
+  floatRange _ = (16,-13)
+  encodeFloat i j = toHalf $ encodeFloat i j
+  exponent = exponent . fromHalf
+  significand = toHalf . significand . fromHalf
+  scaleFloat n = toHalf . scaleFloat n . fromHalf
+
+-- | Is this 'Half' equal to 0?
+isZero :: Half -> Bool
+isZero (Half h) = h .&. 0x7fff == 0
+
+-- | Positive infinity
+pattern POS_INF = Half 0x7c00
+
+-- | Negative infinity
+pattern NEG_INF = Half 0xfc00
+
+-- | Quiet NaN
+pattern QNaN    = Half 0x7fff
+
+-- | Signalling NaN
+pattern SNaN    = Half 0x7dff
+
+-- | Smallest positive half
+pattern HALF_MIN = 5.96046448e-08 :: Half 
+
+-- | Smallest positive normalized half
+pattern HALF_NRM_MIN = 6.10351562e-05 :: Half
+
+-- | Largest positive half
+pattern HALF_MAX = 65504.0 :: Half
+
+-- | Smallest positive e for which half (1.0 + e) != half (1.0)
+pattern HALF_EPSILON = 0.00097656 :: Half
+
+-- | Number of base 10 digits that can be represented without change
+pattern HALF_DIG = 2 
+
+-- Minimum positive integer such that 10 raised to that power is a normalized half
+pattern HALF_MIN_10_EXP = -4
+
+-- Maximum positive integer such that 10 raised to that power is a normalized half
+pattern HALF_MAX_10_EXP = 4
+
+instance Num Half where
+  a * b = toHalf (fromHalf a * fromHalf b)
+  a - b = toHalf (fromHalf a - fromHalf b)
+  a + b = toHalf (fromHalf a + fromHalf b)
+  negate (Half a) = Half (xor 0x8000 a)
+  abs = toHalf . abs . fromHalf
+  signum = toHalf . signum . fromHalf
+  fromInteger a = toHalf (fromInteger a)
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index c8a88c347e..91c0012d48 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -19,3 +19,4 @@ test('T8968-1', normal, compile, [''])
 test('T8968-2', normal, compile, [''])
 test('T8968-3', normal, compile, [''])
 test('ImpExp_Imp', [extra_clean(['ImpExp_Exp.hi', 'ImpExp_Exp.o'])], multimod_compile, ['ImpExp_Imp', '-v0'])
+test('T9857', normal, compile, [''])