Strictify datatypes and state monads to reduce run-time memory

This sledgehammer approach is a quick experiment to see if we can
reduce the 17GB memory usage of `ic-ref` when run inside the
`ic-ref-test` and `coverage` jobs.

The right approach is to do a space profile and see what is being
allocated and why. But I'm lazy so doing this first to see if it helps.

bin/ic-ref-run.hs

@@ -21,7 +21,7 @@ import qualified Data.ByteString.Lazy.Char8 as BC
 import qualified Data.ByteString.Builder as B
 import qualified Data.Text as T
 import Control.Monad.Trans
-import Control.Monad.Trans.State
+import Control.Monad.Trans.State.Strict
 import Text.Printf
 import Data.List
 import Prettyprinter (pretty)

src/IC/Canister.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StrictData #-}
 
 module IC.Canister
     ( WasmState

src/IC/Canister/Imp.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE StrictData #-}
 
 {-|
 The canister interface, presented imperatively (or impurely), i.e. without rollback

src/IC/Canister/Snapshot.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StrictData #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 module IC.Canister.Snapshot ( CanisterSnapshot(..) ) where

src/IC/Canister/StableMemory.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
 {-|
 This module provides a wrapper around primitive byte array, exposing just
 the bits needed for accessing the stable memory.

src/IC/Certificate.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE StrictData #-}
 module IC.Certificate where
 
 import IC.HashTree
@@ -14,4 +15,3 @@ data Delegation = Delegation
     , del_certificate :: Blob
     }
   deriving (Show)
-

src/IC/Crypto.hs

@@ -3,6 +3,7 @@ Everything related to signature creation and checking
 -}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE StrictData #-}
 module IC.Crypto
  ( SecretKey(..)
  , createSecretKeyEd25519

src/IC/Crypto/BLS.hsc

@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-unused-imports -Wno-unused-top-binds #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StrictData #-}
 #include <bls_BLS12381.h>
 module IC.Crypto.BLS
  ( init

src/IC/Crypto/Secp256k1.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE StrictData #-}
 module IC.Crypto.Secp256k1
  ( init
  , SecretKey

src/IC/Crypto/WebAuthn.hs

@@ -7,6 +7,7 @@ nesting of CBOR, DER and JSON…
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE StrictData #-}
 module IC.Crypto.WebAuthn
  ( init
  , SecretKey
@@ -79,7 +80,7 @@ genClientDataJson challenge = JSON.encode $ JSON.Object $
     <> "type" JSON..= ("webauthn.get" :: T.Text)
     <> "origin" JSON..= ("ic-ref-test" :: T.Text)
 
-verifyCOSESig :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Either T.Text () 
+verifyCOSESig :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Either T.Text ()
 verifyCOSESig s msg sig = do
     kv <- decodeWithoutTag s >>= parseMap "COSE key"
     m <- M.fromList <$> mapM keyVal kv
@@ -194,7 +195,7 @@ sign (RSASecretKey pk) msg = do
 verify :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Either T.Text ()
 verify pk msg sig = do
     (ad, cdj, sig) <- parseSig sig
-    verifyCOSESig pk (ad <> sha256 cdj) sig 
+    verifyCOSESig pk (ad <> sha256 cdj) sig
     challenge <- parseClientDataJson cdj
     unless (challenge == msg) $
       throwError $ "Wrong challenge. Expected " <> T.pack (show msg) <>

src/IC/DRun/Parse.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
 module IC.DRun.Parse where
 
 import qualified Data.ByteString.Lazy.Char8 as B
@@ -61,5 +62,3 @@ parseArg ('"':xs)
         = B.unpack (B.fromStrict h) ++ go ys
     go (c:ys) = c : go ys
 parseArg x = error $ "Invalid argument " ++ x
-
-

src/IC/HTTP.hs

@@ -9,7 +9,7 @@ import Network.HTTP.Types
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Data.ByteString.Builder (stringUtf8)
-import Control.Monad.State
+import Control.Monad.State.Strict
 import Control.Monad.Except
 import Data.Aeson as JSON
 import Codec.Candid (Principal(..), parsePrincipal)
@@ -29,8 +29,8 @@ import IC.Utils
 
 withApp :: HasRefConfig => [SubnetConfig] -> Int -> Maybe FilePath -> (Application -> IO a) -> IO a
 withApp subnets systemTaskPeriod backingFile action =
-    withStore (initialIC subnets) backingFile $ \store -> 
-      withAsync (loopIC store) $ \_async -> 
+    withStore (initialIC subnets) backingFile $ \store ->
+      withAsync (loopIC store) $ \_async ->
         action $ handle store
   where
     loopIC :: Store IC -> IO ()

src/IC/HTTP/GenR.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE StrictData #-}
 {-|
 This module describe a type for our “generic request (or response)” format. It
 can be seen as a simplified (and more abstract) AST for CBOR data.
@@ -31,4 +32,3 @@ emptyR = GRec Data.HashMap.Lazy.empty
 (=:) = Data.HashMap.Lazy.singleton
 rec :: [HashMap Text GenR] -> GenR
 rec = GRec . mconcat
-

src/IC/HTTP/GenR/Parse.hs

@@ -12,7 +12,7 @@ module IC.HTTP.GenR.Parse where
 import Numeric.Natural
 import qualified Data.Text as T
 import qualified Data.ByteString.Lazy as BS
-import Control.Monad.State
+import Control.Monad.State.Strict
 import Control.Monad.Writer
 import Control.Monad.Except
 import qualified Data.HashMap.Lazy as HM

src/IC/Ref.hs

@@ -14,6 +14,7 @@
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE StrictData #-}
 
 {-|
 This module implements the main abstract logic of the Internet Computer. It
@@ -300,7 +301,7 @@ isCanisterEmpty :: ICM m => CanisterId -> m Bool
 isCanisterEmpty cid = isNothing . content <$> getCanister cid
 
 getCanisterRootKey :: CanisterId -> Bitcoin.ExtendedSecretKey
-getCanisterRootKey cid = Bitcoin.createExtendedKey $ rawEntityId cid 
+getCanisterRootKey cid = Bitcoin.createExtendedKey $ rawEntityId cid
 
 -- The following functions assume the canister does exist.
 -- It would be an internal error if they don't.
@@ -446,7 +447,7 @@ authReadStateRequest t ecid ev (ReadStateRequest user_id paths) = do
                 throwError "User is not authorized to read this metadata field"
             _ -> return () -- public or absent
       ("request_status":rid: _) | BS.length rid /= 32 -> throwError "Request IDs must be 32 bytes in length."
-      ("request_status":rid: _) ->                            
+      ("request_status":rid: _) ->
         gets (findRequest rid) >>= \case
           Just (ar, (_, ecid')) -> do
             assertEffectiveCanisterId ecid ecid'
@@ -1348,7 +1349,7 @@ icSignWithEcdsa caller r = do
           Right h ->
             return $ R.empty
               .+ #signature .== (Bitcoin.sign k h)
- 
+
 invokeEntry :: ICM m =>
     CallId -> WasmState -> CanisterModule -> Env -> EntryPoint ->
     m (TrapOr (WasmState, UpdateResult))
@@ -1576,4 +1577,3 @@ orElse a b = a >>= maybe b return
 
 onTrap :: Monad m => m (TrapOr a) -> (String -> m a) -> m a
 onTrap a b = a >>= \case { Trap msg -> b msg; Return x -> return x }
-

src/IC/StateFile.hs

@@ -19,13 +19,14 @@ be safe to kill the process; _a_ recent state will be persisted.
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE StrictData #-}
 module IC.StateFile (Store, withStore, modifyStore, peekStore) where
 
 import Codec.Serialise
 import qualified Data.ByteString.Lazy as BS
 import Control.Concurrent
 import Control.Exception
-import Control.Monad.State
+import Control.Monad.State.Strict
 import Data.IORef
 import System.AtomicWrite.Writer.LazyByteString.Binary
 import System.Directory
@@ -81,7 +82,7 @@ modifyStore :: Serialise a => Store a -> StateT a IO b -> IO b
 modifyStore store action =
     modifyMVar (stateVar store) $ \(!s) -> do
         n1 <- makeStableName s
-        (x, s') <- runStateT action s
+        (x, !s') <- runStateT action s
         n2 <- makeStableName s'
         -- If the stable names are the same, this means
         -- that the state is unchanged. No need to write new state

src/IC/Test/Agent.hs

@@ -28,6 +28,7 @@ This module can also be used in a REPL; see 'connect'.
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE StrictData #-}
 module IC.Test.Agent
     (
       HTTPErrOr,

src/IC/Test/Spec.hs

@@ -11,6 +11,7 @@ This module contains a test suite for the Internet Computer
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE StrictData #-}
 
 module IC.Test.Spec (icTests) where
 

src/IC/Test/Universal.hs

@@ -16,6 +16,7 @@ specification than this file and `universal-canister/src/`
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StrictData #-}
 
 module IC.Test.Universal where
 

src/IC/Types.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StrictData #-}
 module IC.Types where
 
 import qualified Data.ByteString.Lazy.Char8 as BS
@@ -255,4 +256,3 @@ validFor valid_for = mempty { valid_for }
 
 validWhere :: ValidityPred EntityId -> EnvValidity
 validWhere valid_where = mempty { valid_where }
-

src/IC/Utils.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE StrictData #-}
 {- |
 Generic utilities related to standard or imported data structures that we do
 don’t want to see in non-plumbing code.

src/IC/Wasm/Winter/Persist.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StrictData #-}
 {- |
 This module provides a way to persist the state of a Winter Wasm instance, and
 to recover it.