increase lazy bytestring evaluation in serialization when writing to …

…disk

add ghc eventlog tracing
use "+RTS -p -h -l -RTS" and ghc-events-analyze to visualize results

src/lib/ProjectM36/Persist.hs

@@ -1,13 +1,15 @@
 {-# LANGUAGE ForeignFunctionInterface, CPP #-}
 --this module is related to persisting Project:M36 structures to disk and not related to the persistent library
 module ProjectM36.Persist (writeFileSync, 
-                           writeBSFileSync,
+                           writeSerialiseSync,
                            renameSync,
                            printFdCount,
                            DiskSync(..)) where
 -- on Windows, use FlushFileBuffers and MoveFileEx
 import qualified Data.Text as T
-
+import Codec.Winery
+import qualified Data.ByteString.FastBuilder as BB
+import System.IO (withBinaryFile)
 #if defined(linux_HOST_OS)
 # define FDCOUNTSUPPORTED 1
 # define FDDIR "/proc/self/fd"
@@ -36,7 +38,7 @@ import Foreign.C
 #endif
 
 import System.IO (withFile, IOMode(WriteMode), Handle)
-import qualified Data.ByteString as BS'
+import qualified Data.ByteString as BS
 import qualified Data.Text.Encoding as TE
 
 #if defined(mingw32_HOST_OS)
@@ -52,7 +54,7 @@ writeFileSync :: DiskSync -> FilePath -> T.Text -> IO()
 writeFileSync sync path strOut = withFile path WriteMode handler
   where
     handler handle = do
-      BS'.hPut handle (TE.encodeUtf8 strOut)
+      BS.hPut handle (TE.encodeUtf8 strOut)
       syncHandle sync handle
 
 renameSync :: DiskSync -> FilePath -> FilePath -> IO ()
@@ -99,10 +101,11 @@ syncDirectory :: DiskSync -> FilePath -> IO ()
 syncDirectory FsyncDiskSync path = directoryFsync path 
 syncDirectory NoDiskSync _ = pure ()
 
-writeBSFileSync :: DiskSync -> FilePath -> BS'.ByteString -> IO ()
-writeBSFileSync sync path bstring =
-  withFile path WriteMode $ \handle -> do
-    BS'.hPut handle bstring
+--uses lazy bytestring to write to file
+writeSerialiseSync :: Serialise a => DiskSync -> FilePath -> a -> IO ()
+writeSerialiseSync sync path val = 
+  withBinaryFile path WriteMode $ \handle -> do
+    BB.hPutBuilder handle $ toBuilderWithSchema val
     syncHandle sync handle
 
 directoryFsync :: FilePath -> IO ()

src/lib/ProjectM36/Trace.hs

@@ -0,0 +1,10 @@
+module ProjectM36.Trace where
+import Debug.Trace (traceEventIO)
+-- utility module to enable easy enabling/disabling of eventlog data
+
+-- | Utility function for tracing with ghc-events-analyze using START and STOP markers
+traceBlock :: String -> IO () -> IO ()
+traceBlock label m = do
+  traceEventIO ("START " <> label)
+  m
+  traceEventIO ("STOP " <> label)

src/lib/ProjectM36/Transaction/Persist.hs

@@ -1,16 +1,18 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
 #ifdef PM36_HASKELL_SCRIPTING
 {-# LANGUAGE TypeApplications #-}
 #endif
 module ProjectM36.Transaction.Persist where
+import ProjectM36.Trace
 import ProjectM36.Base
 import ProjectM36.Error
 import ProjectM36.Transaction
 import ProjectM36.DatabaseContextFunction
 import ProjectM36.AtomFunction
-import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync)
+import ProjectM36.Persist (DiskSync, renameSync, writeSerialiseSync)
 import ProjectM36.Function
 import qualified Data.Map as M
 import qualified Data.HashSet as HS
@@ -109,14 +111,14 @@ writeTransaction sync dbdir trans = do
 writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO ()
 writeRelVars sync transDir relvars = do
   let path = relvarsPath transDir
-  writeBSFileSync sync path (serialise relvars)
+  traceBlock "write relvars" $ writeSerialiseSync sync path relvars
 
 readRelVars :: FilePath -> IO RelationVariables
 readRelVars transDir = 
   readFileDeserialise (relvarsPath transDir)
 
 writeFuncs :: Traversable t => DiskSync -> FilePath -> t (Function a) -> IO ()
-writeFuncs sync funcWritePath funcs = do
+writeFuncs sync funcWritePath funcs = traceBlock "write functions" $ do
   funcs' <- forM funcs $ \fun -> do
     case funcBody fun of
       FunctionScriptBody{} -> pure fun
@@ -134,7 +136,7 @@ writeFuncs sync funcWritePath funcs = do
             Just (ObjectFileInfo (objPath, modName, entryFunc))
           FunctionScriptBody{} -> Nothing
           FunctionBuiltInBody{} -> Nothing
-  writeBSFileSync sync funcWritePath (serialise $ fmap functionData (toList funcs'))
+  writeSerialiseSync sync funcWritePath (fmap functionData (toList funcs'))
 
 readFuncs :: FilePath -> FilePath -> HS.HashSet (Function a) -> Maybe ScriptSession -> IO (HS.HashSet (Function a))
 readFuncs transDir funcPath precompiledFunctions mScriptSession = do
@@ -223,11 +225,12 @@ readAtomFunc transDir funcName' mScriptSession precompiledFuncs = do
 #endif
 
 writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()  
-writeIncDep sync transDir (incDepName, incDep) = 
-  writeBSFileSync sync (incDepsDir transDir </> T.unpack incDepName) $ serialise incDep
+writeIncDep sync transDir (incDepName, incDep) = do
+  writeSerialiseSync sync (incDepsDir transDir </> T.unpack incDepName) incDep
 
 writeIncDeps :: DiskSync -> FilePath -> M.Map IncDepName InclusionDependency -> IO ()  
-writeIncDeps sync transDir incdeps = mapM_ (writeIncDep sync transDir) $ M.toList incdeps 
+writeIncDeps sync transDir incdeps = 
+  traceBlock "write incdeps" $ mapM_ (writeIncDep sync transDir) $ M.toList incdeps 
 
 readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency)
 readIncDep transDir incdepName = do
@@ -249,11 +252,12 @@ readSubschemas transDir = do
 writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO ()  
 writeSubschemas sync transDir sschemas = do
   let sschemasPath = subschemasPath transDir
-  writeBSFileSync sync sschemasPath (serialise sschemas)
+  traceBlock "write subschemas" $ writeSerialiseSync sync sschemasPath sschemas
 
 writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO ()  
-writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in
-  writeBSFileSync sync atPath $ serialise types
+writeTypeConstructorMapping sync path types = do
+  let atPath = typeConsPath path
+  traceBlock "write tconsmap" $ writeSerialiseSync sync atPath types
 
 readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping
 readTypeConstructorMapping path = do