Collect better statistics, and expand the heap for better GC performa…

…nce.

Makefile

@@ -37,6 +37,9 @@ install:
 dev:
 	${MAKE} install -e "OPTS=${CONFIG_OPTS}"
 
+prof:
+	${MAKE} install -e "OPTS=${CONFIG_OPTS} --enable-library-profiling --enable-executable-profiling"
+
 sdist:
 	(cd rsagl-math && cabal check && cabal sdist ${OPTS})
 	(cd rsagl-frp && cabal check && cabal sdist ${OPTS})

roguestar-gl/Main.hs

@@ -10,7 +10,7 @@ import System.FilePath
 import System.IO
 import Control.Monad
 import Paths_roguestar_gl
-import GHC.Environment
+import System.Environment
 import System.Time
 import qualified Data.ByteString as B
 import Data.ByteString.Char8 ()
@@ -71,7 +71,7 @@ main =
                arg_verbose = False,
                arg_engine = [],
                arg_client = [] }
-       raw_args <- getFullArgs
+       raw_args <- getArgs
        let (opts_list,_,errs) = getOpt (ReturnInOrder $ \s args -> args {
                    arg_engine = arg_engine args ++ [s],
                    arg_client = arg_client args ++ [s] })
@@ -84,9 +84,9 @@ main =
        when (not $ null errs) $
            do mapM_ putStrLn errs
               exitWith ExitSuccess
-       let n_rts_string = if arg_single_threaded args then [] else ["-N"]
+       let n_rts_string = if arg_single_threaded args then [] else ["-N", "-A100m"]
        let gl_args =
-               ["+RTS", "-G4"] ++
+               ["+RTS"] ++
                n_rts_string ++
                ["-RTS"] ++
                arg_client args

roguestar-gl/src/Animation.hs

@@ -63,6 +63,7 @@ import Strings
 import Globals
 import PrintText
 import PrintTextData
+import Statistics
 import Control.Concurrent.STM
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Map as Map
@@ -132,7 +133,7 @@ runRoguestarAnimationObject lib globals driver_object print_text_object
                animstate_suspended_stm_action = return () }
        (result_scene_layer_info,result_animstate) <-
            updateFRPProgram Nothing ((),anim_state) rso
-       atomically $
+       runStatistics animation_post_exec $ atomically $
            do when (not $ animstate_block_continue result_animstate) $
                   executeContinueAction $
                       ActionInput globals driver_object print_text_object
@@ -152,7 +153,7 @@ driverGetAnswerA :: (StateOf m ~ AnimationState,
 driverGetAnswerA = proc query ->
     do driver_object <- arr animstate_driver_object <<< fetch -< ()
        ioAction (\(driver_object_,query_) ->
-           atomically $ getAnswer driver_object_ query_) -<
+           runStatistics animation_query $ atomically $ getAnswer driver_object_ query_) -<
                (driver_object,query)
 
 -- | Request a data table from the engine.  This will return 'Nothing' until the entire table arrives, which may never happen.
@@ -162,7 +163,7 @@ driverGetTableA :: (StateOf m ~ AnimationState,
 driverGetTableA = proc query ->
     do driver_object <- arr animstate_driver_object <<< fetch -< ()
        ioAction (\(driver_object_,(the_table_name,the_table_id)) ->
-                 atomically $
+                 runStatistics animation_query $ atomically $
                      getTable driver_object_ the_table_name the_table_id) -<
                          (driver_object,query)
 
@@ -206,7 +207,7 @@ donesA :: (StateOf m ~ AnimationState,
           FRP e m () Integer
 donesA = proc () ->
     do driver_object <- arr animstate_driver_object <<< fetch -< ()
-       ioAction (atomically . driverDones) -< driver_object
+       ioAction (runStatistics animation_query . atomically . driverDones) -< driver_object
 
 -- | Print a debugging message to 'stderr'.  This will print on every frame of animation.
 debugA :: (StateOf m ~ AnimationState,
@@ -231,9 +232,10 @@ actionNameToKeysA action_name = proc () ->
        let action_input = ActionInput (animstate_globals animstate)
                                       (thawDriver $ animstate_driver_object animstate)
                                       (animstate_print_text_object animstate)
-       ioAction id -< atomically (actionNameToKeys action_input
-                                                   common_keymap
-                                                   action_name)
+       ioAction id -< runStatistics animation_query $
+                          atomically (actionNameToKeys action_input
+                                                       common_keymap
+                                                       action_name)
 
 -- | Print a menu using 'printMenuItemA'
 printMenuA :: (FRPModel m, StateOf m ~ AnimationState,
@@ -320,5 +322,5 @@ readGlobal :: (StateOf m ~ AnimationState,
               (Globals -> TVar g) -> FRP e m () g
 readGlobal f = proc () ->
     do globals <- arr animstate_globals <<< fetch -< ()
-       ioAction (\globals_ -> atomically $ readTVar $ f globals_) -< globals
+       ioAction (\globals_ -> runStatistics animation_query $ atomically $ readTVar $ f globals_) -< globals
 

roguestar-gl/src/Driver.hs

@@ -19,6 +19,7 @@ import Data.Set as Set
 import Data.Maybe
 import System.IO
 import Tables
+import Statistics
 import RSAGL.FRP.Time
 import Control.Applicative
 import Control.Monad.Reader

roguestar-gl/src/Processes.hs

@@ -43,7 +43,7 @@ sceneLoop init_vars = liftM (const ()) $ forkIO $ forever $
                    exitWith $ ExitFailure 1
            else return ()
 
--- | Update aspect ration, when it changes.
+-- | Update aspect ratio, when it changes.
 reshape :: Size -> IO ()
 reshape (Size width height) =
     do mat_mode <- get matrixMode

roguestar-gl/src/Statistics.hs

@@ -1,5 +1,7 @@
 module Statistics
-    (Statistics,newStatistics,runStatistics)
+    (Statistics,newStatistics,runStatistics,
+     animation_query,
+     animation_post_exec)
     where
 
 import Data.List as L
@@ -14,6 +16,14 @@ import Text.Printf
 import Control.Exception
 import Data.Maybe
 
+{-# NOINLINE animation_query #-}
+animation_query :: Statistics
+animation_query = unsafePerformIO $ newStatistics "animation-query"
+
+{-# NOINLINE animation_post_exec #-}
+animation_post_exec :: Statistics
+animation_post_exec = unsafePerformIO $ newStatistics "animation-post-exec"
+
 {-# NOINLINE error_pump #-}
 error_pump :: Chan String
 error_pump = unsafePerformIO $