From fc84d7ca36a0c3a27fb6c9992731106e48430f27 Mon Sep 17 00:00:00 2001 From: Bas van Dijk Date: Mon, 27 Feb 2023 15:08:26 +0000 Subject: [PATCH] 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 | 2 +- src/IC/Canister.hs | 1 + src/IC/Canister/Imp.hs | 1 + src/IC/Canister/Snapshot.hs | 1 + src/IC/Canister/StableMemory.hs | 1 + src/IC/Certificate.hs | 2 +- src/IC/Crypto.hs | 1 + src/IC/Crypto/BLS.hsc | 1 + src/IC/Crypto/Secp256k1.hs | 1 + src/IC/Crypto/WebAuthn.hs | 5 +++-- src/IC/DRun/Parse.hs | 3 +-- src/IC/HTTP.hs | 6 +++--- src/IC/HTTP/GenR.hs | 2 +- src/IC/HTTP/GenR/Parse.hs | 2 +- src/IC/Ref.hs | 8 ++++---- src/IC/StateFile.hs | 5 +++-- src/IC/Test/Agent.hs | 1 + src/IC/Test/Spec.hs | 1 + src/IC/Test/Universal.hs | 1 + src/IC/Types.hs | 2 +- src/IC/Utils.hs | 1 + src/IC/Wasm/Winter/Persist.hs | 1 + 22 files changed, 31 insertions(+), 18 deletions(-) diff --git a/bin/ic-ref-run.hs b/bin/ic-ref-run.hs index d6cd7b8d..31991b81 100644 --- a/bin/ic-ref-run.hs +++ b/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) diff --git a/src/IC/Canister.hs b/src/IC/Canister.hs index 8a821255..4bb5a0a3 100644 --- a/src/IC/Canister.hs +++ b/src/IC/Canister.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} module IC.Canister ( WasmState diff --git a/src/IC/Canister/Imp.hs b/src/IC/Canister/Imp.hs index 43aa0344..e0089387 100644 --- a/src/IC/Canister/Imp.hs +++ b/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 diff --git a/src/IC/Canister/Snapshot.hs b/src/IC/Canister/Snapshot.hs index 7dc02c29..828c7d6e 100644 --- a/src/IC/Canister/Snapshot.hs +++ b/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 diff --git a/src/IC/Canister/StableMemory.hs b/src/IC/Canister/StableMemory.hs index 77d4fba8..33eee161 100644 --- a/src/IC/Canister/StableMemory.hs +++ b/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. diff --git a/src/IC/Certificate.hs b/src/IC/Certificate.hs index 760cfb8a..c436b54f 100644 --- a/src/IC/Certificate.hs +++ b/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) - diff --git a/src/IC/Crypto.hs b/src/IC/Crypto.hs index bb2d011e..5199303c 100644 --- a/src/IC/Crypto.hs +++ b/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 diff --git a/src/IC/Crypto/BLS.hsc b/src/IC/Crypto/BLS.hsc index b7fe10ce..623e1b5f 100644 --- a/src/IC/Crypto/BLS.hsc +++ b/src/IC/Crypto/BLS.hsc @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-unused-imports -Wno-unused-top-binds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StrictData #-} #include module IC.Crypto.BLS ( init diff --git a/src/IC/Crypto/Secp256k1.hs b/src/IC/Crypto/Secp256k1.hs index 5e480f60..bbdfc79f 100644 --- a/src/IC/Crypto/Secp256k1.hs +++ b/src/IC/Crypto/Secp256k1.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE StrictData #-} module IC.Crypto.Secp256k1 ( init , SecretKey diff --git a/src/IC/Crypto/WebAuthn.hs b/src/IC/Crypto/WebAuthn.hs index 0ca781e0..790f50ad 100644 --- a/src/IC/Crypto/WebAuthn.hs +++ b/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) <> diff --git a/src/IC/DRun/Parse.hs b/src/IC/DRun/Parse.hs index bf45207d..151ef4e8 100644 --- a/src/IC/DRun/Parse.hs +++ b/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 - - diff --git a/src/IC/HTTP.hs b/src/IC/HTTP.hs index c5892451..870588f8 100644 --- a/src/IC/HTTP.hs +++ b/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 () diff --git a/src/IC/HTTP/GenR.hs b/src/IC/HTTP/GenR.hs index 15afb5ca..64be971f 100644 --- a/src/IC/HTTP/GenR.hs +++ b/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 - diff --git a/src/IC/HTTP/GenR/Parse.hs b/src/IC/HTTP/GenR/Parse.hs index f4a344a1..d1fffef4 100644 --- a/src/IC/HTTP/GenR/Parse.hs +++ b/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 diff --git a/src/IC/Ref.hs b/src/IC/Ref.hs index 17d513da..121962ea 100644 --- a/src/IC/Ref.hs +++ b/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 } - diff --git a/src/IC/StateFile.hs b/src/IC/StateFile.hs index 94c26496..b9f6f09c 100644 --- a/src/IC/StateFile.hs +++ b/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 diff --git a/src/IC/Test/Agent.hs b/src/IC/Test/Agent.hs index 2b1af6b3..e045f7ed 100644 --- a/src/IC/Test/Agent.hs +++ b/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, diff --git a/src/IC/Test/Spec.hs b/src/IC/Test/Spec.hs index 659466e7..4ebc2643 100644 --- a/src/IC/Test/Spec.hs +++ b/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 diff --git a/src/IC/Test/Universal.hs b/src/IC/Test/Universal.hs index 50c633b5..d9652c28 100644 --- a/src/IC/Test/Universal.hs +++ b/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 diff --git a/src/IC/Types.hs b/src/IC/Types.hs index 97bbc34e..d3b5926b 100644 --- a/src/IC/Types.hs +++ b/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 } - diff --git a/src/IC/Utils.hs b/src/IC/Utils.hs index 27dacf88..0417fc43 100644 --- a/src/IC/Utils.hs +++ b/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. diff --git a/src/IC/Wasm/Winter/Persist.hs b/src/IC/Wasm/Winter/Persist.hs index 3021f9a2..116f4af3 100644 --- a/src/IC/Wasm/Winter/Persist.hs +++ b/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.