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
- 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.
......
......@@ -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]
......
{-# 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, [''])
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, [''])
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