Commit 139c0683 authored by Iustin Pop's avatar Iustin Pop

Remove read instances from our Haskell code

It turns out that optimising 'read' derived instances (via -O) for
complex data types (like OpCode, or the various objects) can be slow
to very slow. Disabling such instances results in (time make
$all_our_haskell_binaries) large compile-time savings and also smaller
(unstripped) binaries (by a significant amount):

ghc 6.12:        time  htools sz  hconfd sz
  with read:    4m50s 12,244,694 14,927,928
  no read:      3m30s 10,234,305 12,536,745
ghc 7.6:
  with read:   14m45s 13,694,761 15,741,755
  no read:      3m40s 11,631,373 13,245,134

So let's remove these instances, since we never use read in production
for our custom types, and even when debugging in GHCI, we can simply
use the 'show' representation to create the types, without needing to
actually parse from strings.

Note: for the very slow ghc 7.6 compilation time, I filled a ticket
(ghc #7450), since it is surprising(ly slow).
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarMichele Tartara <mtartara@google.com>
parent f9556d33
......@@ -124,8 +124,7 @@ prop_filter_serialisation = forAll genFilter testSerialisation
-- | Tests that filter regexes are serialised correctly.
prop_filterregex_instances :: FilterRegex -> Property
prop_filterregex_instances rex =
printTestCase "failed JSON encoding" (testSerialisation rex) .&&.
printTestCase "failed read/show instances" (read (show rex) ==? rex)
printTestCase "failed JSON encoding" (testSerialisation rex)
-- | Tests 'ResultStatus' serialisation.
prop_resultstatus_serialisation :: ResultStatus -> Property
......
......@@ -51,7 +51,7 @@ import Data.List
data GenericResult a b
= Bad a
| Ok b
deriving (Show, Read, Eq)
deriving (Show, Eq)
-- | Type alias for a string Result.
type Result = GenericResult String
......@@ -147,14 +147,14 @@ data MatchPriority = ExactMatch
| MultipleMatch
| PartialMatch
| FailMatch
deriving (Show, Read, Enum, Eq, Ord)
deriving (Show, Enum, Eq, Ord)
-- | The result of a name lookup in a list.
data LookupResult = LookupResult
{ lrMatchPriority :: MatchPriority -- ^ The result type
-- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
, lrContent :: String
} deriving (Show, Read)
} deriving (Show)
-- | Lookup results have an absolute preference ordering.
instance Eq LookupResult where
......
......@@ -78,13 +78,13 @@ data OptCompletion = OptComplNone -- ^ No parameter to this option
| OptComplString -- ^ Arbitrary string
| OptComplChoices [String] -- ^ List of string choices
| OptComplSuggest [String] -- ^ Suggested choices
deriving (Show, Read, Eq)
deriving (Show, Eq)
-- | Argument type. This differs from (and wraps) an Option by the
-- fact that it can (and usually does) support multiple repetitions of
-- the same argument, via a min and max limit.
data ArgCompletion = ArgCompletion OptCompletion Int (Maybe Int)
deriving (Show, Read, Eq)
deriving (Show, Eq)
-- | Yes\/no choices completion.
optComplYesNo :: OptCompletion
......
......@@ -104,7 +104,7 @@ $(buildObject "ConfdReqQ" "confdReqQ"
data ConfdQuery = EmptyQuery
| PlainQuery String
| DictQuery ConfdReqQ
deriving (Show, Read, Eq)
deriving (Show, Eq)
instance JSON ConfdQuery where
readJSON o = case o of
......
......@@ -142,7 +142,7 @@ emptyEvacSolution = EvacSolution { esMoved = []
-- | The complete state for the balancing solution.
data Table = Table Node.List Instance.List Score [Placement]
deriving (Show, Read)
deriving (Show)
-- | Cluster statistics data type.
data CStats = CStats
......@@ -167,7 +167,7 @@ data CStats = CStats
, csNmem :: Integer -- ^ Node own memory
, csScore :: Score -- ^ The cluster score
, csNinst :: Int -- ^ The total number of instances
} deriving (Show, Read)
} deriving (Show)
-- | A simple type for allocation functions.
type AllocMethod = Node.List -- ^ Node list
......
......@@ -4,7 +4,7 @@
{-
Copyright (C) 2010, 2011 Google Inc.
Copyright (C) 2010, 2011, 2012 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
......@@ -47,7 +47,7 @@ data Group = Group
, allocPolicy :: T.AllocPolicy -- ^ The allocation policy for this group
, iPolicy :: T.IPolicy -- ^ The instance policy for this group
, allTags :: [String] -- ^ The tags for this group
} deriving (Show, Read, Eq)
} deriving (Show, Eq)
-- Note: we use the name as the alias, and the UUID as the official
-- name
......
......@@ -83,7 +83,7 @@ data Instance = Instance
, spindleUse :: Int -- ^ The numbers of used spindles
, allTags :: [String] -- ^ List of all instance tags
, exclTags :: [String] -- ^ List of instance exclusion tags
} deriving (Show, Read, Eq)
} deriving (Show, Eq)
instance T.Element Instance where
nameOf = name
......
......@@ -74,11 +74,11 @@ data RqType
| NodeEvacuate [Idx] EvacMode -- ^ node-evacuate mode
| ChangeGroup [Gdx] [Idx] -- ^ Multi-relocate mode
| MultiAllocate [(Instance.Instance, Int)] -- ^ Multi-allocate mode
deriving (Show, Read)
deriving (Show)
-- | A complete request, as received from Ganeti.
data Request = Request RqType ClusterData
deriving (Show, Read)
deriving (Show)
-- | The cluster state.
data ClusterData = ClusterData
......@@ -87,7 +87,7 @@ data ClusterData = ClusterData
, cdInstances :: Instance.List -- ^ The instance list
, cdTags :: [String] -- ^ The cluster tags
, cdIPolicy :: IPolicy -- ^ The cluster instance policy
} deriving (Show, Read, Eq)
} deriving (Show, Eq)
-- | An empty cluster.
emptyCluster :: ClusterData
......
......@@ -130,7 +130,7 @@ data Node = Node
, pTags :: TagMap -- ^ Primary instance exclusion tags and their count
, group :: T.Gdx -- ^ The node's group (index)
, iPolicy :: T.IPolicy -- ^ The instance policy (of the node's group)
} deriving (Show, Read, Eq)
} deriving (Show, Eq)
instance T.Element Node where
nameOf = name
......
......@@ -110,7 +110,7 @@ defaultGroupID = "00000000-0000-0000-0000-000000000000"
data MirrorType = MirrorNone -- ^ No mirroring/movability
| MirrorInternal -- ^ DRBD-type mirroring
| MirrorExternal -- ^ Shared-storage type mirroring
deriving (Eq, Show, Read)
deriving (Eq, Show)
-- | Correspondence between disk template and mirror type.
templateMirrorType :: DiskTemplate -> MirrorType
......@@ -127,7 +127,7 @@ data RSpec = RSpec
{ rspecCpu :: Int -- ^ Requested VCPUs
, rspecMem :: Int -- ^ Requested memory
, rspecDsk :: Int -- ^ Requested disk
} deriving (Show, Read, Eq)
} deriving (Show, Eq)
-- | Allocation stats type. This is used instead of 'RSpec' (which was
-- used at first), because we need to track more stats. The actual
......@@ -139,7 +139,7 @@ data AllocInfo = AllocInfo
, allocInfoNCpus :: Double -- ^ Normalised CPUs
, allocInfoMem :: Int -- ^ Memory
, allocInfoDisk :: Int -- ^ Disk
} deriving (Show, Read, Eq)
} deriving (Show, Eq)
-- | Currently used, possibly to allocate, unallocable.
type AllocStats = (AllocInfo, AllocInfo, AllocInfo)
......@@ -224,7 +224,7 @@ data DynUtil = DynUtil
, memWeight :: Weight -- ^ Standardised memory load
, dskWeight :: Weight -- ^ Standardised disk I\/O usage
, netWeight :: Weight -- ^ Standardised network usage
} deriving (Show, Read, Eq)
} deriving (Show, Eq)
-- | Initial empty utilisation.
zeroUtil :: DynUtil
......@@ -260,7 +260,7 @@ data IMove = Failover -- ^ Failover the instance (f)
| ReplaceSecondary Ndx -- ^ Replace secondary (r:ns)
| ReplaceAndFailover Ndx -- ^ Replace secondary, failover (r:np, f)
| FailoverAndReplace Ndx -- ^ Failover, replace secondary (f, r:ns)
deriving (Show, Read)
deriving (Show)
-- | Formatted solution output for one move (involved nodes and
-- commands.
......@@ -295,7 +295,7 @@ data FailMode = FailMem -- ^ Failed due to not enough RAM
| FailCPU -- ^ Failed due to not enough CPU capacity
| FailN1 -- ^ Failed due to not passing N1 checks
| FailTags -- ^ Failed due to tag exclusion
deriving (Eq, Enum, Bounded, Show, Read)
deriving (Eq, Enum, Bounded, Show)
-- | List with failure statistics.
type FailStats = [(FailMode, Int)]
......
......@@ -186,7 +186,7 @@ instance HasStringRepr String where
-- | The container type, a wrapper over Data.Map
newtype GenericContainer a b =
GenericContainer { fromContainer :: Map.Map a b }
deriving (Show, Read, Eq)
deriving (Show, Eq)
-- | Type alias for string keys.
type Container = GenericContainer String
......
......@@ -93,7 +93,7 @@ withTimeout secs descr action = do
data RecvResult = RecvConnClosed -- ^ Connection closed
| RecvError String -- ^ Any other error
| RecvOk String -- ^ Successfull receive
deriving (Show, Read, Eq)
deriving (Show, Eq)
-- | The Ganeti job type.
type JobId = Int
......
......@@ -216,7 +216,7 @@ data DiskLogicalId
| LIDFile FileDriver String -- ^ Driver, path
| LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
| LIDRados String String -- ^ Unused, path
deriving (Read, Show, Eq)
deriving (Show, Eq)
-- | Mapping from a logical id to a disk type.
lidDiskType :: DiskLogicalId -> DiskType
......@@ -302,7 +302,7 @@ data Disk = Disk
, diskIvName :: String
, diskSize :: Int
, diskMode :: DiskMode
} deriving (Read, Show, Eq)
} deriving (Show, Eq)
$(buildObjectSerialisation "Disk"
[ customField 'decodeDLId 'encodeFullDLId $
......
......@@ -308,7 +308,7 @@ data TagObject = TagInstance String
| TagNode String
| TagGroup String
| TagCluster
deriving (Show, Read, Eq)
deriving (Show, Eq)
-- | Tag type for a given tag object.
tagTypeOf :: TagObject -> TagType
......@@ -365,7 +365,7 @@ $(makeJSONInstance ''ReplaceDisksMode)
-- | Disk index type (embedding constraints on the index value via a
-- smart constructor).
newtype DiskIndex = DiskIndex { unDiskIndex :: Int }
deriving (Show, Read, Eq, Ord)
deriving (Show, Eq, Ord)
-- | Smart constructor for 'DiskIndex'.
mkDiskIndex :: (Monad m) => Int -> m DiskIndex
......@@ -413,7 +413,7 @@ data RecreateDisksInfo
= RecreateDisksAll
| RecreateDisksIndices (NonEmpty DiskIndex)
| RecreateDisksParams (NonEmpty (DiskIndex, IDiskParams))
deriving (Eq, Read, Show)
deriving (Eq, Show)
readRecreateDisks :: JSValue -> Text.JSON.Result RecreateDisksInfo
readRecreateDisks (JSArray []) = return RecreateDisksAll
......@@ -435,7 +435,7 @@ instance JSON RecreateDisksInfo where
-- | Simple type for old-style ddm changes.
data DdmOldChanges = DdmOldIndex (NonNegative Int)
| DdmOldMod DdmSimple
deriving (Eq, Read, Show)
deriving (Eq, Show)
readDdmOldChanges :: JSValue -> Text.JSON.Result DdmOldChanges
readDdmOldChanges v =
......@@ -456,7 +456,7 @@ data SetParamsMods a
= SetParamsEmpty
| SetParamsDeprecated (NonEmpty (DdmOldChanges, a))
| SetParamsNew (NonEmpty (DdmFull, Int, a))
deriving (Eq, Read, Show)
deriving (Eq, Show)
-- | Custom deserialiser for 'SetParamsMods'.
readSetParams :: (JSON a) => JSValue -> Text.JSON.Result (SetParamsMods a)
......@@ -478,7 +478,7 @@ instance (JSON a) => JSON (SetParamsMods a) where
-- tests). But the proper type could be parsed if we wanted.
data ExportTarget = ExportTargetLocal NonEmptyString
| ExportTargetRemote UncheckedList
deriving (Eq, Read, Show)
deriving (Eq, Show)
-- | Custom reader for 'ExportTarget'.
readExportTarget :: JSValue -> Text.JSON.Result ExportTarget
......
......@@ -120,7 +120,7 @@ $(makeJSONInstance ''QueryTypeLuxi)
-- | Overall query type.
data ItemType = ItemTypeLuxi QueryTypeLuxi
| ItemTypeOpCode QueryTypeOp
deriving (Show, Read, Eq)
deriving (Show, Eq)
-- | Custom JSON decoder for 'ItemType'.
decodeItemType :: (Monad m) => JSValue -> m ItemType
......@@ -172,7 +172,7 @@ data Filter a
| GEFilter a FilterValue -- ^ @>=@ /field/ /value/
| RegexpFilter a FilterRegex -- ^ @=~@ /field/ /regexp/
| ContainsFilter a FilterValue -- ^ @=[]@ /list-field/ /value/
deriving (Show, Read, Eq)
deriving (Show, Eq)
-- | Serialiser for the 'Filter' data type.
showFilter :: (JSON a) => Filter a -> JSValue
......@@ -293,7 +293,7 @@ type FilterField = String
-- | Value to compare the field value to, for filtering purposes.
data FilterValue = QuotedString String
| NumericValue Integer
deriving (Read, Show, Eq)
deriving (Show, Eq)
-- | Serialiser for 'FilterValue'. The Python code just sends this to
-- JSON as-is, so we'll do the same.
......@@ -348,15 +348,6 @@ mkRegex _ =
instance Show FilterRegex where
show (FilterRegex re _) = "mkRegex " ++ show re
-- | 'Read' instance: we manually read \"mkRegex\" followed by a
-- string, and build the 'FilterRegex' using that.
instance Read FilterRegex where
readsPrec _ str = do
("mkRegex", s') <- lex str
(re, s'') <- reads s'
filterre <- mkRegex re
return (filterre, s'')
-- | 'Eq' instance: we only compare the string versions of the regexes.
instance Eq FilterRegex where
(FilterRegex re1 _) == (FilterRegex re2 _) = re1 == re2
......@@ -388,7 +379,7 @@ $(buildObject "FieldDefinition" "fdef"
data ResultEntry = ResultEntry
{ rentryStatus :: ResultStatus -- ^ The result status
, rentryValue :: Maybe ResultValue -- ^ The (optional) result value
} deriving (Show, Read, Eq)
} deriving (Show, Eq)
instance JSON ResultEntry where
showJSON (ResultEntry rs rv) =
......
......@@ -386,7 +386,7 @@ instance Rpc RpcCallNodeInfo RpcResultNodeInfo where
-- Query node version.
-- Note: We can't use THH as it does not know what to do with empty dict
data RpcCallVersion = RpcCallVersion {}
deriving (Show, Read, Eq)
deriving (Show, Eq)
instance J.JSON RpcCallVersion where
showJSON _ = J.JSNull
......
......@@ -283,7 +283,7 @@ buildSimpleCons tname cons = do
decl_d <- mapM (\(cname, fields) -> do
fields' <- mapM (buildConsField . snd) fields
return $ NormalC (mkName cname) fields') cons
return $ DataD [] tname [] decl_d [''Show, ''Read, ''Eq]
return $ DataD [] tname [] decl_d [''Show, ''Eq]
-- | Generate the save function for a given type.
genSaveSimpleObj :: Name -- ^ Object type
......@@ -306,7 +306,7 @@ strADTDecl :: Name -> [String] -> Dec
strADTDecl name constructors =
DataD [] name []
(map (flip NormalC [] . mkName) constructors)
[''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
[''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
-- | Generates a toRaw function.
--
......@@ -529,7 +529,7 @@ genOpCode name cons = do
fields' <- mapM (fieldTypeInfo "op") fields
return $ RecC (mkName cname) fields')
cons
let declD = DataD [] tname [] decl_d [''Show, ''Read, ''Eq]
let declD = DataD [] tname [] decl_d [''Show, ''Eq]
(savesig, savefn) <- genSaveOpCode tname "saveOpCode" cons
(uncurry saveConstructor)
......@@ -638,7 +638,7 @@ genLuxiOp name cons = do
let fields'' = zip (repeat NotStrict) fields'
return $ NormalC (mkName cname) fields'')
cons
let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
(savesig, savefn) <- genSaveOpCode tname "opToArgs"
cons saveLuxiConstructor
req_defs <- declareSADT "LuxiReq" .
......@@ -678,7 +678,7 @@ buildObject sname field_pfx fields = do
let name = mkName sname
fields_d <- mapM (fieldTypeInfo field_pfx) fields
let decl_d = RecC name fields_d
let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq]
let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
ser_decls <- buildObjectSerialisation sname fields
return $ declD:ser_decls
......@@ -836,8 +836,8 @@ buildParam sname field_pfx fields = do
fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
let decl_f = RecC name_f fields_f
decl_p = RecC name_p fields_p
let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
ser_decls_f <- buildObjectSerialisation sname_f fields
ser_decls_p <- buildPParamSerialisation sname_p fields
fill_decls <- fillParam sname field_pfx fields
......
......@@ -83,7 +83,7 @@ import Ganeti.JSON
-- | Type that holds a non-negative value.
newtype NonNegative a = NonNegative { fromNonNegative :: a }
deriving (Show, Read, Eq)
deriving (Show, Eq)
-- | Smart constructor for 'NonNegative'.
mkNonNegative :: (Monad m, Num a, Ord a, Show a) => a -> m (NonNegative a)
......@@ -97,7 +97,7 @@ instance (JSON.JSON a, Num a, Ord a, Show a) => JSON.JSON (NonNegative a) where
-- | Type that holds a positive value.
newtype Positive a = Positive { fromPositive :: a }
deriving (Show, Read, Eq)
deriving (Show, Eq)
-- | Smart constructor for 'Positive'.
mkPositive :: (Monad m, Num a, Ord a, Show a) => a -> m (Positive a)
......@@ -111,7 +111,7 @@ instance (JSON.JSON a, Num a, Ord a, Show a) => JSON.JSON (Positive a) where
-- | Type that holds a non-null list.
newtype NonEmpty a = NonEmpty { fromNonEmpty :: [a] }
deriving (Show, Read, Eq)
deriving (Show, Eq)
-- | Smart constructor for 'NonEmpty'.
mkNonEmpty :: (Monad m) => [a] -> m (NonEmpty a)
......
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