[Git][ghc/ghc][master] JS: factorize SaneDouble into its own module
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Jun 16 16:26:02 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
a5f0c00e by Sylvain Henry at 2023-06-16T12:25:40-04:00
JS: factorize SaneDouble into its own module
Follow-up of b159e0e9 whose ticket is #22736
- - - - -
6 changed files:
- compiler/GHC/JS/Syntax.hs
- compiler/GHC/JS/Unsat/Syntax.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/StgToJS/Types.hs
- + compiler/GHC/Types/SaneDouble.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/JS/Syntax.hs
=====================================
@@ -94,6 +94,7 @@ import GHC.Prelude
import GHC.JS.Unsat.Syntax (Ident(..))
import GHC.Data.FastString
import GHC.Types.Unique.Map
+import GHC.Types.SaneDouble
import GHC.Utils.Misc
import Control.DeepSeq
@@ -333,25 +334,6 @@ data AOp
instance NFData AOp
--- | A newtype wrapper around 'Double' to ensure we never generate a 'Double'
--- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on
--- Sane-ness
-newtype SaneDouble = SaneDouble
- { unSaneDouble :: Double
- }
- deriving (Data, Typeable, Fractional, Num, Generic, NFData)
-
-instance Eq SaneDouble where
- (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y)
-
-instance Ord SaneDouble where
- compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y)
- where fromNaN z | isNaN z = Nothing
- | otherwise = Just z
-
-instance Show SaneDouble where
- show (SaneDouble x) = show x
-
--------------------------------------------------------------------------------
-- Helper Functions
--------------------------------------------------------------------------------
=====================================
compiler/GHC/JS/Unsat/Syntax.hs
=====================================
@@ -103,6 +103,7 @@ import GHC.Data.FastString
import GHC.Utils.Monad.State.Strict
import GHC.Types.Unique
import GHC.Types.Unique.Map
+import GHC.Types.SaneDouble
-- | A supply of identifiers, possibly empty
newtype IdentSupply a
@@ -359,26 +360,6 @@ data JUOp
instance NFData JUOp
--- | A newtype wrapper around 'Double' to ensure we never generate a 'Double'
--- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on
--- Sane-ness
-newtype SaneDouble = SaneDouble
- { unSaneDouble :: Double
- }
- deriving (Data, Typeable, Fractional, Num, Generic, NFData)
-
-instance Eq SaneDouble where
- (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y)
-
-instance Ord SaneDouble where
- compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y)
- where fromNaN z | isNaN z = Nothing
- | otherwise = Just z
-
-instance Show SaneDouble where
- show (SaneDouble x) = show x
-
-
--------------------------------------------------------------------------------
-- Identifiers
--------------------------------------------------------------------------------
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -86,7 +86,6 @@ import GHC.Unit.Module
import GHC.Data.FastString
import GHC.Types.Unique.Map
-import GHC.Float (castDoubleToWord64, castWord64ToDouble)
import GHC.Utils.Binary hiding (SymbolTable)
import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text, hsep)
@@ -483,39 +482,6 @@ instance Binary Ident where
put_ bh (TxtI xs) = put_ bh xs
get bh = TxtI <$> get bh
--- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this
-instance Binary Sat.SaneDouble where
- put_ bh (Sat.SaneDouble d)
- | isNaN d = putByte bh 1
- | isInfinite d && d > 0 = putByte bh 2
- | isInfinite d && d < 0 = putByte bh 3
- | isNegativeZero d = putByte bh 4
- | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d)
- get bh = getByte bh >>= \case
- 1 -> pure $ Sat.SaneDouble (0 / 0)
- 2 -> pure $ Sat.SaneDouble (1 / 0)
- 3 -> pure $ Sat.SaneDouble ((-1) / 0)
- 4 -> pure $ Sat.SaneDouble (-0)
- 5 -> Sat.SaneDouble . castWord64ToDouble <$> get bh
- n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n)
-
--- FIXME: remove after Unsat replaces JStat
--- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this
-instance Binary SaneDouble where
- put_ bh (SaneDouble d)
- | isNaN d = putByte bh 1
- | isInfinite d && d > 0 = putByte bh 2
- | isInfinite d && d < 0 = putByte bh 3
- | isNegativeZero d = putByte bh 4
- | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d)
- get bh = getByte bh >>= \case
- 1 -> pure $ SaneDouble (0 / 0)
- 2 -> pure $ SaneDouble (1 / 0)
- 3 -> pure $ SaneDouble ((-1) / 0)
- 4 -> pure $ SaneDouble (-0)
- 5 -> SaneDouble . castWord64ToDouble <$> get bh
- n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n)
-
instance Binary ClosureInfo where
put_ bh (ClosureInfo v regs name layo typ static) = do
put_ bh v >> put_ bh regs >> put_ bh name >> put_ bh layo >> put_ bh typ >> put_ bh static
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
@@ -48,9 +47,6 @@ import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.ByteString as BS
import Data.Monoid
-import Data.Typeable (Typeable)
-import GHC.Generics (Generic)
-import Control.DeepSeq
-- | A State monad over IO holding the generator state.
type G = StateT GenState IO
@@ -107,7 +103,7 @@ data ClosureInfo = ClosureInfo
, ciType :: CIType -- ^ type of the object, with extra info where required
, ciStatic :: CIStatic -- ^ static references of this object
}
- deriving stock (Eq, Show, Generic)
+ deriving stock (Eq, Show)
-- | Closure information, 'ClosureInfo', registers
data CIRegs
@@ -115,9 +111,7 @@ data CIRegs
| CIRegs { ciRegsSkip :: Int -- ^ unused registers before actual args start
, ciRegsTypes :: [VarType] -- ^ args
}
- deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData CIRegs
+ deriving stock (Eq, Ord, Show)
-- | Closure Information, 'ClosureInfo', layout
data CILayout
@@ -129,9 +123,7 @@ data CILayout
{ layoutSize :: !Int -- ^ closure size in array positions, including entry
, layout :: [VarType] -- ^ The set of sized Types to layout
}
- deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData CILayout
+ deriving stock (Eq, Ord, Show)
-- | The type of 'ClosureInfo'
data CIType
@@ -143,13 +135,11 @@ data CIType
| CIPap -- ^ The closure is a Partial Application
| CIBlackhole -- ^ The closure is a black hole
| CIStackFrame -- ^ The closure is a stack frame
- deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData CIType
+ deriving stock (Eq, Ord, Show)
-- | Static references that must be kept alive
newtype CIStatic = CIStaticRefs { staticRefs :: [FastString] }
- deriving stock (Eq, Generic)
+ deriving stock (Eq)
deriving newtype (Semigroup, Monoid, Show)
-- | static refs: array = references, null = nothing to report
@@ -169,9 +159,7 @@ data VarType
| RtsObjV -- ^ some RTS object from GHCJS (for example TVar#, MVar#, MutVar#, Weak#)
| ObjV -- ^ some JS object, user supplied, be careful around these, can be anything
| ArrV -- ^ boxed array
- deriving stock (Eq, Ord, Enum, Bounded, Show, Generic)
-
-instance NFData VarType
+ deriving stock (Eq, Ord, Enum, Bounded, Show)
instance ToJExpr VarType where
toJExpr = toJExpr . fromEnum
@@ -231,7 +219,7 @@ data StaticInfo = StaticInfo
{ siVar :: !FastString -- ^ global object
, siVal :: !StaticVal -- ^ static initialization
, siCC :: !(Maybe Ident) -- ^ optional CCS name
- } deriving stock (Eq, Show, Typeable, Generic)
+ } deriving stock (Eq, Show)
data StaticVal
= StaticFun !FastString [StaticArg]
@@ -245,7 +233,7 @@ data StaticVal
-- ^ regular datacon app
| StaticList [StaticArg] (Maybe FastString)
-- ^ list initializer (with optional tail)
- deriving stock (Eq, Show, Generic)
+ deriving stock (Eq, Show)
data StaticUnboxed
= StaticUnboxedBool !Bool
@@ -253,9 +241,7 @@ data StaticUnboxed
| StaticUnboxedDouble !SaneDouble
| StaticUnboxedString !BS.ByteString
| StaticUnboxedStringOffset !BS.ByteString
- deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData StaticUnboxed
+ deriving stock (Eq, Ord, Show)
-- | Static Arguments. Static Arguments are things that are statically
-- allocated, i.e., they exist at program startup. These are static heap objects
@@ -264,7 +250,7 @@ data StaticArg
= StaticObjArg !FastString -- ^ reference to a heap object
| StaticLitArg !StaticLit -- ^ literal
| StaticConArg !FastString [StaticArg] -- ^ unfloated constructor
- deriving stock (Eq, Show, Generic)
+ deriving stock (Eq, Show)
instance Outputable StaticArg where
ppr x = text (show x)
@@ -278,7 +264,7 @@ data StaticLit
| StringLit !FastString
| BinLit !BS.ByteString
| LabelLit !Bool !FastString -- ^ is function pointer, label (also used for string / binary init)
- deriving (Eq, Show, Generic)
+ deriving (Eq, Show)
instance Outputable StaticLit where
ppr x = text (show x)
@@ -300,7 +286,7 @@ data ForeignJSRef = ForeignJSRef
, foreignRefCConv :: !CCallConv
, foreignRefArgs :: ![FastString]
, foreignRefResult :: !FastString
- } deriving stock (Generic)
+ }
-- | data used to generate one ObjUnit in our object file
data LinkableUnit = LinkableUnit
=====================================
compiler/GHC/Types/SaneDouble.hs
=====================================
@@ -0,0 +1,48 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | Double datatype with saner instances
+module GHC.Types.SaneDouble
+ ( SaneDouble (..)
+ )
+where
+
+import GHC.Prelude
+import GHC.Utils.Binary
+import GHC.Float (castDoubleToWord64, castWord64ToDouble)
+
+-- | A newtype wrapper around 'Double' to ensure we never generate a 'Double'
+-- that becomes a 'NaN', see instances for details on sanity.
+newtype SaneDouble = SaneDouble
+ { unSaneDouble :: Double
+ }
+ deriving (Fractional, Num)
+
+instance Eq SaneDouble where
+ (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y)
+
+instance Ord SaneDouble where
+ compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y)
+ where fromNaN z | isNaN z = Nothing
+ | otherwise = Just z
+
+instance Show SaneDouble where
+ show (SaneDouble x) = show x
+
+-- we need to preserve NaN and infinities, unfortunately the Binary instance for
+-- Double does not do this
+instance Binary SaneDouble where
+ put_ bh (SaneDouble d)
+ | isNaN d = putByte bh 1
+ | isInfinite d && d > 0 = putByte bh 2
+ | isInfinite d && d < 0 = putByte bh 3
+ | isNegativeZero d = putByte bh 4
+ | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d)
+ get bh = getByte bh >>= \case
+ 1 -> pure $ SaneDouble (0 / 0)
+ 2 -> pure $ SaneDouble (1 / 0)
+ 3 -> pure $ SaneDouble ((-1) / 0)
+ 4 -> pure $ SaneDouble (-0)
+ 5 -> SaneDouble . castWord64ToDouble <$> get bh
+ n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n)
+
=====================================
compiler/ghc.cabal.in
=====================================
@@ -811,6 +811,7 @@ Library
GHC.Types.ProfAuto
GHC.Types.RepType
GHC.Types.SafeHaskell
+ GHC.Types.SaneDouble
GHC.Types.SourceError
GHC.Types.SourceFile
GHC.Types.SourceText
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a5f0c00ee19186d245bd0a55f1432811701a1bd7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a5f0c00ee19186d245bd0a55f1432811701a1bd7
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230616/3d117a14/attachment-0001.html>
More information about the ghc-commits
mailing list