From 30f38da494be662a329c57b4ac70491f279ecfc8 Mon Sep 17 00:00:00 2001 From: Bas van Dijk Date: Mon, 27 Feb 2023 15:52:49 +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. I'll close this draft PR if it doesn't help. --- bin/ic-ref-run.hs | 2 +- default.nix | 13 +++++++++---- ic-hs.cabal | 8 ++++---- 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 | 1 + src/IC/Crypto.hs | 1 + src/IC/Crypto/BLS.hsc | 1 + src/IC/Crypto/Secp256k1.hs | 1 + src/IC/Crypto/WebAuthn.hs | 1 + src/IC/DRun/Parse.hs | 1 + src/IC/HTTP.hs | 2 +- src/IC/HTTP/GenR.hs | 1 + src/IC/HTTP/GenR/Parse.hs | 2 +- src/IC/Ref/Types.hs | 1 + src/IC/StateFile.hs | 5 +++-- src/IC/Test/Agent.hs | 1 + src/IC/Test/Spec.hs | 1 + src/IC/Test/Spec/HTTP.hs | 1 + src/IC/Test/Universal.hs | 1 + src/IC/Types.hs | 1 + src/IC/Utils.hs | 1 + src/IC/Wasm/Winter/Persist.hs | 1 + 25 files changed, 38 insertions(+), 13 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/default.nix b/default.nix index 7b9f0462..b9d0a097 100644 --- a/default.nix +++ b/default.nix @@ -39,16 +39,21 @@ let staticHaskellPackages = nixpkgs.pkgsStatic.haskellPackages.override { }; in let - ic-hs = nixpkgs.haskell.lib.dontCheck ( - haskellPackages.ic-hs.overrideAttrs (old: { + ic-hs = + let + ic-hs-pkg = + nixpkgs.haskell.lib.disableLibraryProfiling + (nixpkgs.haskell.lib.disableExecutableProfiling + (nixpkgs.haskell.lib.dontCheck haskellPackages.ic-hs)); + in + ic-hs-pkg.overrideAttrs (old: { installPhase = (old.installPhase or "") + '' mkdir $out/test-data cp ${universal-canister}/universal-canister.wasm $out/test-data ''; # variant of justStaticExecutables that retains propagatedBuildInputs postFixup = "rm -rf $out/lib $out/share/doc"; - }) - ); + }); # Alias, to be replaced with a derivation that just copies bin/ic-ref ic-ref = ic-hs; diff --git a/ic-hs.cabal b/ic-hs.cabal index d19aa988..e488aa78 100644 --- a/ic-hs.cabal +++ b/ic-hs.cabal @@ -9,7 +9,7 @@ extra-source-files: cbits/*.h ic.did common ghc-flags default-language: Haskell2010 - ghc-options: -Wall -Wno-name-shadowing + ghc-options: -Wall -Wno-name-shadowing -O2 library import: ghc-flags @@ -187,7 +187,7 @@ library executable ic-ref import: ghc-flags - ghc-options: -rtsopts + ghc-options: -rtsopts -threaded hs-source-dirs: bin main-is: ic-ref.hs @@ -204,7 +204,7 @@ executable ic-ref executable ic-ref-run import: ghc-flags - ghc-options: -rtsopts + ghc-options: -rtsopts -threaded hs-source-dirs: bin main-is: ic-ref-run.hs @@ -226,7 +226,7 @@ executable ic-ref-run executable ic-ref-test import: ghc-flags - ghc-options: -rtsopts + ghc-options: -rtsopts -threaded hs-source-dirs: bin main-is: ic-ref-test.hs 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..2d782351 100644 --- a/src/IC/Certificate.hs +++ b/src/IC/Certificate.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE StrictData #-} module IC.Certificate where import IC.HashTree 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..9b63e3ef 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 diff --git a/src/IC/DRun/Parse.hs b/src/IC/DRun/Parse.hs index bf45207d..a663c896 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 diff --git a/src/IC/HTTP.hs b/src/IC/HTTP.hs index c5892451..0cec6451 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) diff --git a/src/IC/HTTP/GenR.hs b/src/IC/HTTP/GenR.hs index 15afb5ca..69a26f70 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. 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/Types.hs b/src/IC/Ref/Types.hs index 10259fb0..31526a76 100644 --- a/src/IC/Ref/Types.hs +++ b/src/IC/Ref/Types.hs @@ -14,6 +14,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE StrictData #-} {-| This module implements the main abstract types of the Internet Computer. 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 941b6f79..24259c9a 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/Spec/HTTP.hs b/src/IC/Test/Spec/HTTP.hs index 2c1f04ba..11bb8373 100644 --- a/src/IC/Test/Spec/HTTP.hs +++ b/src/IC/Test/Spec/HTTP.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.HTTP (canister_http_calls) 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..a4b6f88c 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 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.