Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

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

…nce.
  • Loading branch information...
commit 5fde7701dd0022db5759daaa5e78a5a92dd082c3 1 parent 6a81efa
@clanehin authored
View
3  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})
View
8 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
View
18 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
View
1  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
View
2  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
View
12 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 $
Please sign in to comment.
Something went wrong with that request. Please try again.