Commit fbb42b2e authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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.
parent 71105aea
...@@ -314,6 +314,7 @@ We use mkExportedLocalId for things like ...@@ -314,6 +314,7 @@ We use mkExportedLocalId for things like
- Dictionary functions (DFunId) - Dictionary functions (DFunId)
- Wrapper and matcher Ids for pattern synonyms - Wrapper and matcher Ids for pattern synonyms
- Default methods for classes - Default methods for classes
- Pattern-synonym matcher and builder Ids
- etc - etc
They marked as "exported" in the sense that they should be kept alive They marked as "exported" in the sense that they should be kept alive
...@@ -329,7 +330,9 @@ of reasons: ...@@ -329,7 +330,9 @@ of reasons:
dependency analysis (e.g. CoreFVs.exprFreeVars). dependency analysis (e.g. CoreFVs.exprFreeVars).
* Look them up in the current substitution when we come across * 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 * Ensure that for dfuns that the specialiser does not float dict uses
above their defns, which would prevent good simplifications happening. above their defns, which would prevent good simplifications happening.
......
...@@ -26,6 +26,7 @@ import Outputable ...@@ -26,6 +26,7 @@ import Outputable
import FastString import FastString
import Var import Var
import Id import Id
import IdInfo( IdDetails(..) )
import TcBinds import TcBinds
import BasicTypes import BasicTypes
import TcSimplify import TcSimplify
...@@ -254,7 +255,8 @@ tcPatSynMatcher (L loc name) lpat ...@@ -254,7 +255,8 @@ tcPatSynMatcher (L loc name) lpat
; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau 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_dicts = map nlHsVar prov_dicts
cont' = mkLHsWrap (mkWpLet prov_ev_binds) $ cont' = mkLHsWrap (mkWpLet prov_ev_binds) $
...@@ -326,7 +328,8 @@ mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty ...@@ -326,7 +328,8 @@ mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty
| otherwise | otherwise
= do { builder_name <- newImplicitBinder name mkDataConWorkerOcc = do { builder_name <- newImplicitBinder name mkDataConWorkerOcc
; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty) ; 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)) } ; return (Just (builder_id, need_dummy_arg)) }
where where
builder_arg_tys | need_dummy_arg = [voidPrimTy] builder_arg_tys | need_dummy_arg = [voidPrimTy]
......
{-# 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)
...@@ -19,3 +19,4 @@ test('T8968-1', normal, compile, ['']) ...@@ -19,3 +19,4 @@ test('T8968-1', normal, compile, [''])
test('T8968-2', normal, compile, ['']) test('T8968-2', normal, compile, [''])
test('T8968-3', normal, compile, ['']) test('T8968-3', normal, compile, [''])
test('ImpExp_Imp', [extra_clean(['ImpExp_Exp.hi', 'ImpExp_Exp.o'])], multimod_compile, ['ImpExp_Imp', '-v0']) test('ImpExp_Imp', [extra_clean(['ImpExp_Exp.hi', 'ImpExp_Exp.o'])], multimod_compile, ['ImpExp_Imp', '-v0'])
test('T9857', normal, compile, [''])
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