From 3a76c57adfbcd60491d47900bca6fa0c99febac6 Mon Sep 17 00:00:00 2001
From: "kodiakhq[bot]" <49736102+kodiakhq[bot]@users.noreply.github.com>
Date: Mon, 7 Nov 2022 20:31:57 +0000
Subject: [PATCH] Some inlining and bang patterns to improve memory residency

Just forcing some of the most numerous thunks (with -hi profiling), it
seems some of these were retaining significant amount of data

this can follow merge of, or supersede #6679

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6710
GitOrigin-RevId: d0566ee288841e264637231a7f238946aa2e3564
---
 .../src/Hasura/GraphQL/Parser/Directives.hs         |  2 ++
 .../src/Hasura/GraphQL/Parser/Internal/Input.hs     |  5 +++++
 .../src/Hasura/GraphQL/Parser/Internal/Parser.hs    | 10 ++++++++++
 server/src-lib/Hasura/GraphQL/Schema.hs             |  4 ++--
 server/src-lib/Hasura/GraphQL/Schema/BoolExp.hs     |  2 +-
 server/src-lib/Hasura/GraphQL/Schema/OrderBy.hs     |  2 +-
 server/src-lib/Hasura/GraphQL/Schema/Select.hs      | 13 +++++++------
 server/src-lib/Hasura/GraphQL/Schema/Table.hs       |  8 ++++----
 8 files changed, 32 insertions(+), 14 deletions(-)

diff --git a/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Directives.hs b/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Directives.hs
index 961852ed9c6..1750eab4067 100644
--- a/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Directives.hs
+++ b/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Directives.hs
@@ -110,6 +110,7 @@ parseDirectives ::
   G.DirectiveLocation ->
   [G.Directive Variable] ->
   m DirectiveMap
+{-# INLINE parseDirectives #-}
 parseDirectives directiveParsers location givenDirectives = do
   result <-
     catMaybes <$> for givenDirectives \directive -> do
@@ -278,6 +279,7 @@ mkDirective ::
   [G.DirectiveLocation] ->
   InputFieldsParser origin m a ->
   Directive origin m
+{-# INLINE mkDirective #-}
 mkDirective name description advertised location argsParser =
   Directive
     { dDefinition = DirectiveInfo name description (ifDefinitions argsParser) location,
diff --git a/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Internal/Input.hs b/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Internal/Input.hs
index 1636df9be36..ed292d6c39e 100644
--- a/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Internal/Input.hs
+++ b/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Internal/Input.hs
@@ -242,6 +242,7 @@ field ::
   Maybe Description ->
   Parser origin k m a ->
   InputFieldsParser origin m a
+{-# INLINE field #-}
 field name description parser =
   InputFieldsParser
     { ifDefinitions = [Definition name description Nothing [] $ InputFieldInfo (pType parser) Nothing],
@@ -270,6 +271,7 @@ fieldOptional ::
   Maybe Description ->
   Parser origin k m a ->
   InputFieldsParser origin m (Maybe a)
+{-# INLINE fieldOptional #-}
 fieldOptional name description parser =
   InputFieldsParser
     { ifDefinitions =
@@ -295,6 +297,7 @@ fieldWithDefault ::
   Value Void ->
   Parser origin k m a ->
   InputFieldsParser origin m a
+{-# INLINE fieldWithDefault #-}
 fieldWithDefault name description defaultValue parser =
   InputFieldsParser
     { ifDefinitions = [Definition name description Nothing [] $ InputFieldInfo (pType parser) (Just defaultValue)],
@@ -354,6 +357,7 @@ object ::
   Maybe Description ->
   InputFieldsParser origin m a ->
   Parser origin 'Input m a
+{-# INLINE object #-}
 object name description parser =
   Parser
     { pType = schemaType,
@@ -386,6 +390,7 @@ object name description parser =
     invalidName key = parseError $ "variable value contains object with key " <> ErrorValue.dquote key <> ", which is not a legal GraphQL name"
 
 list :: forall origin k m a. (MonadParse m, 'Input <: k) => Parser origin k m a -> Parser origin k m [a]
+{-# INLINE list #-}
 list parser =
   gcastWith
     (inputParserInput @k)
diff --git a/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Internal/Parser.hs b/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Internal/Parser.hs
index 02446481497..2bb8bd4d1bc 100644
--- a/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Internal/Parser.hs
+++ b/server/lib/schema-parsers/src/Hasura/GraphQL/Parser/Internal/Parser.hs
@@ -185,6 +185,7 @@ safeSelectionSet ::
   Maybe Description ->
   [FieldParser origin m a] ->
   n (Parser origin 'Output m (OMap.InsOrdHashMap Name (ParsedSelection a)))
+{-# INLINE safeSelectionSet #-}
 safeSelectionSet name description fields =
   case duplicatesList of
     [] -> pure $ selectionSetObject name description fields []
@@ -224,6 +225,7 @@ selectionSetObject ::
   -- see Note [The interfaces story] in Hasura.GraphQL.Parser.Schema.
   [Parser origin 'Output m b] ->
   Parser origin 'Output m (OMap.InsOrdHashMap Name (ParsedSelection a))
+{-# INLINE selectionSetObject #-}
 selectionSetObject name description parsers implementsInterfaces =
   Parser
     { pType =
@@ -283,6 +285,7 @@ selectionSetInterface ::
   -- Note [The interfaces story] in Hasura.GraphQL.Parser.Schema for details.
   t (Parser origin 'Output n b) ->
   Parser origin 'Output n (t b)
+{-# INLINE selectionSetInterface #-}
 selectionSetInterface name description fields objectImplementations =
   Parser
     { pType =
@@ -311,6 +314,7 @@ selectionSetUnion ::
   -- | The member object types.
   t (Parser origin 'Output n b) ->
   Parser origin 'Output n (t b)
+{-# INLINE selectionSetUnion #-}
 selectionSetUnion name description objectImplementations =
   Parser
     { pType =
@@ -338,6 +342,7 @@ selection ::
   -- | type of the result
   Parser origin 'Both m b ->
   FieldParser origin m a
+{-# INLINE selection #-}
 selection name description argumentsParser resultParser =
   rawSelection name description argumentsParser resultParser
     <&> \(_alias, _args, a) -> a
@@ -353,6 +358,7 @@ rawSelection ::
   Parser origin 'Both m b ->
   -- | alias provided (if any), and the arguments
   FieldParser origin m (Maybe Name, HashMap Name (Value Variable), a)
+{-# INLINE rawSelection #-}
 rawSelection name description argumentsParser resultParser =
   FieldParser
     { fDefinition =
@@ -396,6 +402,7 @@ subselection ::
   -- | parser for the subselection set
   Parser origin 'Output m b ->
   FieldParser origin m (a, b)
+{-# INLINE subselection #-}
 subselection name description argumentsParser bodyParser =
   rawSubselection name description argumentsParser bodyParser
     <&> \(_alias, _args, a, b) -> (a, b)
@@ -410,6 +417,7 @@ rawSubselection ::
   -- | parser for the subselection set
   Parser origin 'Output m b ->
   FieldParser origin m (Maybe Name, HashMap Name (Value Variable), a, b)
+{-# INLINE rawSubselection #-}
 rawSubselection name description argumentsParser bodyParser =
   FieldParser
     { fDefinition =
@@ -437,6 +445,7 @@ selection_ ::
   -- | type of the result
   Parser origin 'Both m a ->
   FieldParser origin m ()
+{-# INLINE selection_ #-}
 selection_ name description = selection name description (pure ())
 
 -- | A shorthand for a 'subselection' that takes no arguments.
@@ -447,5 +456,6 @@ subselection_ ::
   -- | parser for the subselection set
   Parser origin 'Output m a ->
   FieldParser origin m a
+{-# INLINE subselection_ #-}
 subselection_ name description bodyParser =
   snd <$> subselection name description (pure ()) bodyParser
diff --git a/server/src-lib/Hasura/GraphQL/Schema.hs b/server/src-lib/Hasura/GraphQL/Schema.hs
index 1b3be0eb4df..df641786ed4 100644
--- a/server/src-lib/Hasura/GraphQL/Schema.hs
+++ b/server/src-lib/Hasura/GraphQL/Schema.hs
@@ -242,7 +242,7 @@ buildRoleContext options sources remotes actions customTypes role remoteSchemaPe
 
     -- build all remote schemas
     -- we only keep the ones that don't result in a name conflict
-    (remoteSchemaFields, remoteSchemaErrors) <-
+    (remoteSchemaFields, !remoteSchemaErrors) <-
       runRemoteSchema schemaContext $
         buildAndValidateRemoteSchemas remotes sourcesQueryFields sourcesMutationBackendFields role remoteSchemaPermsCtx
     let remotesQueryFields = concatMap piQuery remoteSchemaFields
@@ -275,7 +275,7 @@ buildRoleContext options sources remotes actions customTypes role remoteSchemaPe
     -- required for introspection, which ends up doing a few correctness
     -- checks in the GraphQL schema. Furthermore, we want to persist this
     -- information in the case of the admin role.
-    introspectionSchema <- do
+    !introspectionSchema <- do
       result <-
         throwOnConflictingDefinitions $
           convertToSchemaIntrospection
diff --git a/server/src-lib/Hasura/GraphQL/Schema/BoolExp.hs b/server/src-lib/Hasura/GraphQL/Schema/BoolExp.hs
index 245ac85ae8b..e94c4758b75 100644
--- a/server/src-lib/Hasura/GraphQL/Schema/BoolExp.hs
+++ b/server/src-lib/Hasura/GraphQL/Schema/BoolExp.hs
@@ -119,7 +119,7 @@ boolExp sourceInfo tableInfo = P.memoizeOn 'boolExp (_siName sourceInfo, tableNa
       FieldInfo b ->
       SchemaT r m (Maybe (InputFieldsParser n (Maybe (AnnBoolExpFld b (UnpreparedValue b)))))
     mkField fieldInfo = runMaybeT do
-      roleName <- retrieve scRole
+      !roleName <- retrieve scRole
       fieldName <- hoistMaybe $ fieldInfoGraphQLName fieldInfo
       P.fieldOptional fieldName Nothing <$> case fieldInfo of
         -- field_name: field_type_comparison_exp
diff --git a/server/src-lib/Hasura/GraphQL/Schema/OrderBy.hs b/server/src-lib/Hasura/GraphQL/Schema/OrderBy.hs
index 82e8a1a9610..f0f426fd35d 100644
--- a/server/src-lib/Hasura/GraphQL/Schema/OrderBy.hs
+++ b/server/src-lib/Hasura/GraphQL/Schema/OrderBy.hs
@@ -85,7 +85,7 @@ orderByExp sourceInfo tableInfo = P.memoizeOn 'orderByExp (_siName sourceInfo, t
       roleName <- retrieve scRole
       case fieldInfo of
         FIColumn columnInfo -> do
-          let fieldName = ciName columnInfo
+          let !fieldName = ciName columnInfo
           pure $
             P.fieldOptional
               fieldName
diff --git a/server/src-lib/Hasura/GraphQL/Schema/Select.hs b/server/src-lib/Hasura/GraphQL/Schema/Select.hs
index 3d24a99efab..b2494f471bf 100644
--- a/server/src-lib/Hasura/GraphQL/Schema/Select.hs
+++ b/server/src-lib/Hasura/GraphQL/Schema/Select.hs
@@ -953,12 +953,13 @@ tableAggregationFields sourceInfo tableInfo =
     mkNumericAggFields name
       | name == Name._sum = traverse mkColumnAggField
       | otherwise = traverse \columnInfo ->
-          pure $
+          pure $! do
+            let !cfcol = IR.CFCol (ciColumn columnInfo) (ciType columnInfo)
             P.selection_
               (ciName columnInfo)
               (ciDescription columnInfo)
               (P.nullable P.float)
-              $> IR.CFCol (ciColumn columnInfo) (ciType columnInfo)
+              $> cfcol
 
     mkColumnAggField :: ColumnInfo b -> SchemaT r m (FieldParser n (IR.ColFld b))
     mkColumnAggField columnInfo =
@@ -1040,9 +1041,9 @@ fieldSelection sourceInfo table tableInfo = \case
       let columnName = ciColumn columnInfo
       selectPermissions <- hoistMaybe $ tableSelectPermissions roleName tableInfo
       guard $ columnName `Map.member` spiCols selectPermissions
-      let caseBoolExp = join $ Map.lookup columnName (spiCols selectPermissions)
-          caseBoolExpUnpreparedValue =
-            (fmap . fmap) partialSQLExpToUnpreparedValue <$> caseBoolExp
+      let !caseBoolExp = join $ Map.lookup columnName (spiCols selectPermissions)
+          !caseBoolExpUnpreparedValue =
+            (fmap . fmap) partialSQLExpToUnpreparedValue <$!> caseBoolExp
           pathArg = scalarSelectionArgumentsParser $ ciType columnInfo
           -- In an inherited role, when a column is part of all the select
           -- permissions which make up the inherited role then the nullability
@@ -1065,7 +1066,7 @@ fieldSelection sourceInfo table tableInfo = \case
           -- allow the case analysis only on nullable columns.
           nullability = ciIsNullable columnInfo || isJust caseBoolExp
       field <- lift $ columnParser (ciType columnInfo) (G.Nullability nullability)
-      pure $
+      pure $!
         P.selection fieldName (ciDescription columnInfo) pathArg field
           <&> IR.mkAnnColumnField (ciColumn columnInfo) (ciType columnInfo) caseBoolExpUnpreparedValue
   FIRelationship relationshipInfo ->
diff --git a/server/src-lib/Hasura/GraphQL/Schema/Table.hs b/server/src-lib/Hasura/GraphQL/Schema/Table.hs
index 5e48cedd465..4782795c391 100644
--- a/server/src-lib/Hasura/GraphQL/Schema/Table.hs
+++ b/server/src-lib/Hasura/GraphQL/Schema/Table.hs
@@ -212,17 +212,17 @@ tableSelectFields sourceInfo tableInfo = do
   where
     canBeSelected _ Nothing _ = pure False
     canBeSelected _ (Just permissions) (FIColumn columnInfo) =
-      pure $ Map.member (ciColumn columnInfo) (spiCols permissions)
+      pure $! Map.member (ciColumn columnInfo) (spiCols permissions)
     canBeSelected role _ (FIRelationship relationshipInfo) = do
       tableInfo' <- askTableInfo sourceInfo $ riRTable relationshipInfo
-      pure $ isJust $ tableSelectPermissions @b role tableInfo'
+      pure $! isJust $ tableSelectPermissions @b role tableInfo'
     canBeSelected role (Just permissions) (FIComputedField computedFieldInfo) =
       case computedFieldReturnType @b (_cfiReturnType computedFieldInfo) of
         ReturnsScalar _ ->
-          pure $ Map.member (_cfiName computedFieldInfo) $ spiComputedFields permissions
+          pure $! Map.member (_cfiName computedFieldInfo) $ spiComputedFields permissions
         ReturnsTable tableName -> do
           tableInfo' <- askTableInfo sourceInfo tableName
-          pure $ isJust $ tableSelectPermissions @b role tableInfo'
+          pure $! isJust $ tableSelectPermissions @b role tableInfo'
         ReturnsOthers -> pure False
     canBeSelected _ _ (FIRemoteRelationship _) = pure True