JS: factorize SaneDouble into its own module

Follow-up of b159e0e9 whose ticket is #22736

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

-{-# 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

+{-# 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