perf: strictify Meta's ID field

[brprice]

This one-character change massively reduces our memory usage (measured by maximum residency) on some workloads. When running the testsuite with --hedgehog-tests 0 (to get reproducible results) we see a (roughly) 15% drop in maximum residency (as measured by +RTS -s), and with the following patch to run a much bigger version of EvalFull.unit_8, we see a 97% drop, and the total memory in use drops from 1177MB to 58MB! It also has a small beneficial effect on the amount of memory copied during GC, and a negligible effect on both total memory allocated and elapsed runtimes.

diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs index c98878049..9292b2870 100644
--- a/primer/test/Tests/EvalFull.hs
+++ b/primer/test/Tests/EvalFull.hs
@@ -209,13 +209,13 @@ unit_7 =

 unit_8 :: Assertion
 unit_8 =
-  let n = 10
+  let n = 100 e = mapEven n in do evalFullTest (maxID e) builtinTypes (defMap e) 500 Syn (expr e) >>= \case Left (TimedOut _) -> pure () x -> assertFailure $ show x
-        s <- evalFullTest (maxID e) builtinTypes (defMap e) 1000 Syn (expr e)
+        s <- evalFullTest (maxID e) builtinTypes (defMap e) 100000 Syn (expr e)
         s <~==> Right (expectedResult e)

 -- A worker/wrapper'd map

[brprice]

I also attempted to add similar bangs on the metadata-containing fields of Expr and Type and Kind; and also to strictify regenerate{Type,Expr}IDs. However these had much less effect (the two with a noticeable effect (non-rigourous testing, potentially just noise) are putting bangs on Expr and strictifying regenerateExprIDs). Since their effect was so small, I did not think it worth doing.

The diff of the above attempt

```diff diff --git a/primer/src/Primer/Core.hs b/primer/src/Primer/Core.hs index 4e168de1e..0c0b80f42 100644 --- a/primer/src/Primer/Core.hs +++ b/primer/src/Primer/Core.hs @@ -149,17 +149,17 @@ type Expr = Expr' ExprMeta TypeMeta -- Most of the backend fixes a ~ b ~ ID. -- The typechecker produces a ~ (ID, Type' ()), b ~ ID. data Expr' a b - = Hole a (Expr' a b) -- See Note [Holes and bidirectionality] - | EmptyHole a - | Ann a (Expr' a b) (Type' b) - | App a (Expr' a b) (Expr' a b) - | APP a (Expr' a b) (Type' b) - | Con a ValConName [Expr' a b] -- See Note [Checkable constructors] - | Lam a LVarName (Expr' a b) - | LAM a TyVarName (Expr' a b) - | Var a TmVarRef + = Hole !a (Expr' a b) -- See Note [Holes and bidirectionality] + | EmptyHole !a + | Ann !a (Expr' a b) (Type' b) + | App !a (Expr' a b) (Expr' a b) + | APP !a (Expr' a b) (Type' b) + | Con !a ValConName [Expr' a b] -- See Note [Checkable constructors] + | Lam !a LVarName (Expr' a b) + | LAM !a TyVarName (Expr' a b) + | Var !a TmVarRef | Let - a + !a -- | bound variable LVarName -- | value the variable is bound to @@ -170,7 +170,7 @@ data Expr' a b -- It is currently only constructed automatically during evaluation - -- the student can't directly make it. LetType - a + !a -- | bound variable TyVarName -- | value the variable is bound to @@ -178,7 +178,7 @@ data Expr' a b -- | expression the binding scopes over (Expr' a b) | Letrec - a + !a -- | bound variable LVarName -- | value the variable is bound to; the variable itself is in scope, as this is a recursive let @@ -187,8 +187,8 @@ data Expr' a b (Type' b) -- | body of the let; binding scopes over this (Expr' a b) - | Case a (Expr' a b) [CaseBranch' a b] (CaseFallback' a b) -- See Note [Case] - | PrimCon a PrimCon + | Case !a (Expr' a b) [CaseBranch' a b] (CaseFallback' a b) -- See Note [Case] + | PrimCon !a PrimCon deriving stock (Eq, Show, Read, Data, Generic) deriving (FromJSON, ToJSON) via PrimerJSON (Expr' a b) deriving anyclass (NFData) diff --git a/primer/src/Primer/Core/Type.hs b/primer/src/Primer/Core/Type.hs index a3ddd97ba..429cc4573 100644 --- a/primer/src/Primer/Core/Type.hs +++ b/primer/src/Primer/Core/Type.hs @@ -41,18 +41,18 @@ type TypeMeta = Meta (Maybe (Kind' ()))

-- | NB: Be careful with equality -- it is on-the-nose, rather than up-to-alpha: see Subst:alphaEqTy
data Type' a

• = TEmptyHole a
• | THole a (Type' a)
• | TCon a TyConName
• | TFun a (Type' a) (Type' a)
• | TVar a TyVarName
• | TApp a (Type' a) (Type' a)
• | TForall a TyVarName (Kind' ()) (Type' a)

• = TEmptyHole !a
• | THole !a (Type' a)
• | TCon !a TyConName
• | TFun !a (Type' a) (Type' a)
• | TVar !a TyVarName
• | TApp !a (Type' a) (Type' a)
• | TForall !a TyVarName (Kind' ()) (Type' a)
  | -- | TLet is a let binding at the type level.
  -- It is currently only constructed automatically during evaluation -
  -- the student can't directly make it.
  TLet

•  a
  

•  !a
   -- | bound variable
   TyVarName
   -- | type the variable is bound to; the variable itself is not in scope, this is a non-recursive let
  

@@ -80,9 +80,9 @@ type Kind = Kind' KindMeta
type KindMeta = Meta ()

data Kind' a

• = KHole a
• | KType a
• | KFun a (Kind' a) (Kind' a)

• = KHole !a
• | KType !a
• | KFun !a (Kind' a) (Kind' a)
  deriving stock (Eq, Ord, Show, Read, Data, Generic)
  deriving (FromJSON, ToJSON) via PrimerJSON (Kind' a)
  deriving anyclass (NFData)
  diff --git a/primer/src/Primer/Core/Type/Utils.hs b/primer/src/Primer/Core/Type/Utils.hs
  index aad34efb5..526d0ac2b 100644
  --- a/primer/src/Primer/Core/Type/Utils.hs
  +++ b/primer/src/Primer/Core/Type/Utils.hs
  @@ -28,6 +28,7 @@ import Optics (
  getting,
  hasn't,
  set,
• set',
  traversalVL,
  traverseOf,
  (%),
  @@ -53,10 +54,10 @@ import Primer.Zipper.Type (getBoundHereDnTy)

-- | Regenerate all IDs, not changing any other metadata
regenerateTypeIDs :: (HasID a, MonadFresh ID m) => Type' a -> m (Type' a)
-regenerateTypeIDs = regenerateTypeIDs' (set _id)
+regenerateTypeIDs = regenerateTypeIDs' (set' _id)

regenerateTypeIDs' :: MonadFresh ID m => (ID -> a -> b) -> Type' a -> m (Type' b)
-regenerateTypeIDs' s = traverseOf _typeMeta (\a -> flip s a <$> fresh)
+regenerateTypeIDs' s = traverseOf _typeMeta (\a -> flip s a <$!> fresh)

-- | Adds 'ID's and trivial metadata
generateTypeIDs :: MonadFresh ID m => Type' () -> m Type
diff --git a/primer/src/Primer/Core/Utils.hs b/primer/src/Primer/Core/Utils.hs
index 213393ef0..3027c4bc6 100644
--- a/primer/src/Primer/Core/Utils.hs
+++ b/primer/src/Primer/Core/Utils.hs
@@ -38,6 +38,7 @@ import Optics (
adjoin,
getting,
set,

• set',
  summing,
  to,
  traversalVL,
  @@ -86,12 +87,12 @@ import Primer.Name (Name)

-- | Regenerate all IDs, not changing any other metadata
regenerateExprIDs :: (HasID a, HasID b, MonadFresh ID m) => Expr' a b -> m (Expr' a b)
-regenerateExprIDs = regenerateExprIDs' (set _id) (set _id)
+regenerateExprIDs = regenerateExprIDs' (set' _id) (set' _id)

regenerateExprIDs' :: MonadFresh ID m => (ID -> a -> a') -> (ID -> b -> b') -> Expr' a b -> m (Expr' a' b')
regenerateExprIDs' se st =

• traverseOf _exprMeta (\a -> flip se a <$> fresh)

• => traverseOf _exprTypeMeta (\a -> flip st a <$> fresh)

• traverseOf _exprMeta (\a -> flip se a <$!> fresh)

• => traverseOf _exprTypeMeta (\a -> flip st a <$!> fresh)

-- | Like 'generateTypeIDs', but for expressions
generateIDs :: MonadFresh ID m => Expr' () () -> m Expr
diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs
index c98878049..9292b2870 100644
--- a/primer/test/Tests/EvalFull.hs
+++ b/primer/test/Tests/EvalFull.hs
@@ -209,13 +209,13 @@ unit_7 =

unit_8 :: Assertion
unit_8 =

• let n = 10

• let n = 100
  e = mapEven n
  in do
  evalFullTest (maxID e) builtinTypes (defMap e) 500 Syn (expr e) >>= \case
  Left (TimedOut _) -> pure ()
  x -> assertFailure $ show x

•    s <- evalFullTest (maxID e) builtinTypes (defMap e) 1000 Syn (expr e)
  

•    s <- evalFullTest (maxID e) builtinTypes (defMap e) 100000 Syn (expr e)
     s <~==> Right (expectedResult e)
  

-- A worker/wrapper'd map

</details>

[brprice]

Could someone independently confirm some time&space measurements for this change?

[brprice]

Let's just merge this -- easy enough to revert, and hopefully our benchmark suite will reproduce.

[dhess]

(I've always wondered why we haven't done this more aggressively across the entire code base.)