Browse files

Forwarding GHC runtime system arguments.

Normally GHC runtime system arguments are
processed before the program, and invisible to
System.Environment.getArgs.

We use GHC.Environment.getFullArgs to forward them,
and add an option rtsOptsHandling to describe
whether they should be appended by any other, or replaced
during relaunch.
  • Loading branch information...
1 parent 6ee75c7 commit 109dcb9b576def538dcec43c6a5d0744f7cac178 Michal J. Gajda committed Jul 16, 2012
Showing with 44 additions and 6 deletions.
  1. +36 −5 Config/Dyre.hs
  2. +8 −1 Config/Dyre/Params.hs
View
41 Config/Dyre.hs
@@ -99,11 +99,13 @@ import System.IO ( hPutStrLn, stderr )
import System.Directory ( doesFileExist, removeFile, canonicalizePath
, getDirectoryContents, doesDirectoryExist )
import System.FilePath ( (</>) )
-import System.Environment ( getArgs )
+import System.Environment (getArgs)
+import GHC.Environment (getFullArgs)
+import Control.Exception (assert)
import Control.Monad ( when, filterM )
-import Config.Dyre.Params ( Params(..) )
+import Config.Dyre.Params ( Params(..), RTSOptionHandling(..) )
import Config.Dyre.Compile ( customCompile, getErrorPath, getErrorString )
import Config.Dyre.Compat ( customExec )
import Config.Dyre.Options ( getForceReconf, getDenyReconf, getDebug
@@ -124,6 +126,7 @@ defaultParams = Params
, ghcOpts = []
, forceRecomp = True
, statusOut = hPutStrLn stderr
+ , rtsOptsHandling = RTSAppend []
}
-- | 'wrapMain' is how Dyre recieves control of the program. It is expected
@@ -183,10 +186,11 @@ wrapMain params@Params{projectName = pName} cfg = withDyreOptions params $
else enterMain errorData
where launchSub errorData tempBinary = do
statusOut params $ "Launching custom binary " ++ tempBinary ++ "\n"
+ givenArgs <- handleRTSOptions $ rtsOptsHandling params
-- Deny reconfiguration if a compile already failed.
- arguments <- case errorData of
- Nothing -> getArgs
- Just _ -> ("--deny-reconf":) `fmap` getArgs
+ let arguments = case errorData of
+ Nothing -> givenArgs
+ Just _ -> "--deny-reconf":givenArgs
-- Execute
customExec tempBinary $ Just arguments
enterMain errorData = do
@@ -209,3 +213,30 @@ recFiles d = do
subfiles <- concat `fmap` mapM recFiles dirs
return $ files ++ subfiles
else return []
+
+assertM b = assert b $ return ()
+
+-- | Filters GHC runtime system arguments:
+filterRTSArgs = filt False
+ where
+ filt _ [] = []
+ filt _ ("--RTS":rest) = []
+ filt False ("+RTS" :rest) = filt True rest
+ filt True ("-RTS" :rest) = filt False rest
+ filt False (_ :rest) = filt False rest
+ filt True (arg :rest) = arg:filt True rest
+ --filt state args = error $ "Error filtering RTS arguments in state " ++ show state ++ " remaining arguments: " ++ show args
+
+editRTSOptions opts (RTSReplace ls) = ls
+editRTSOptions opts (RTSAppend ls) = opts ++ ls
+
+handleRTSOptions h = do fargs <- getFullArgs
+ args <- getArgs
+ let rtsArgs = editRTSOptions (filterRTSArgs fargs) h
+ assertM $ not $ "--RTS" `elem` rtsArgs
+ case rtsArgs of
+ [] -> if not $ "+RTS" `elem` args
+ then return args -- cleaner output
+ else return $ "--RTS":args
+ _ -> return $ ["+RTS"] ++ rtsArgs ++ ["--RTS"] ++ args
+
View
9 Config/Dyre/Params.hs
@@ -3,7 +3,7 @@ Defines the 'Params' datatype which Dyre uses to define all
program-specific configuration data. Shouldn't be imported
directly, as 'Config.Dyre' re-exports it.
-}
-module Config.Dyre.Params ( Params(..) ) where
+module Config.Dyre.Params ( Params(..), RTSOptionHandling(..) ) where
-- | This structure is how all kinds of useful data is fed into Dyre. Of
-- course, only the 'projectName', 'realMain', and 'showError' fields
@@ -43,4 +43,11 @@ data Params cfgType = Params
-- when Dyre recompiles or launches anything. A good value
-- is 'hPutStrLn stderr', assuming there is no pressing
-- reason to not put messages on stderr.
+ , rtsOptsHandling :: RTSOptionHandling
+ -- ^ Whether to append, or replace GHC runtime system options
+ -- with others.
}
+
+data RTSOptionHandling = RTSReplace [String] -- replaces RTS options with given list
+ | RTSAppend [String] -- merges given list with RTS options from command line (so that nothing is lost)
+

0 comments on commit 109dcb9

Please sign in to comment.