On Mon, Dec 17, 2012 at 02:01:28PM +0000, Simon Peyton-Jones wrote:
> | On Mon, Dec 17, 2012 at 09:21:44AM +0000, Simon Peyton-Jones wrote:
> | >
> | > o There's a seg-fault
> |
> | I can reproduce this. I'll look into it.
>
> Great, thank you.
>
> It turns out that simply
>
> ghc-stage2 -debug
> or
> ghc-stage2 -prof
>
> is enough to trigger the seg-fault. Any "way" flag seems to do it.
Unfortunately, I've run out of time to debug this for now. Here's what
I've got:
It seems that the commits
0c4a9f38637dfc3bc8fd48e8ba6bf64da51b727b
ecd967612877e1965ddebefe9b83acd837bb413a
introduced the problem, but I'm not sure whether they are the direct
cause or just happened to tickle a pre-existing bug. Attached is a
self-contained module that goes wrong:
$ inplace/bin/ghc-stage1 -debug --make test -O -fforce-recomp
$ ./test +RTS -DS; echo $?
cap 0: initialised
A
Segmentation fault/access violation in generated code
1
Works with 7.4.1:
$ ghc -debug --make test -O -fforce-recomp
$ ./test; echo $?
A
[WayDyn]
B
0
It's quite fragile, e.g. if I remove
ghcMode :: (),
from the DynFlags type then it succeeds.
Thanks
Ian
module Main (main) where
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List
import System.IO
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
hSetBuffering stderr NoBuffering
let dflags0 = DynFlags {
ways = [],
settings = Settings {
sTargetPlatform = Platform {
platformOS = OSMinGW32
}
}
}
((), dflags1) = runCmdLine processArgs dflags0
putStrLn "A"
print $ ways dflags1
putStrLn "B"
data GeneralFlag
= Opt_PIC
| Opt_SccProfilingOn
| Opt_Static
deriving (Eq, Show, Enum)
data Language = Haskell98 | Haskell2010
deriving Enum
data ExtensionFlag
= Opt_ParallelArrays
deriving Enum
data DynFlags = DynFlags {
settings :: Settings,
extensions :: [OnOff ExtensionFlag],
extensionFlags :: IntSet,
ways :: [Way],
buildTag :: String,
rtsBuildTag :: String,
packageFlags :: [PackageFlag],
generalFlags :: IntSet,
language :: Maybe Language,
ghcMode :: (),
ghcLink :: (),
hscTarget :: (),
hscOutName :: (),
extCoreName :: (),
verbosity :: (),
optLevel :: (),
simplPhases :: (),
maxSimplIterations :: (),
shouldDumpSimplPhase :: (),
ruleCheck :: (),
strictnessBefore :: (),
simplTickFactor :: (),
specConstrThreshold :: (),
specConstrCount :: (),
liberateCaseThreshold :: (),
floatLamArgs :: (),
historySize :: (),
cmdlineHcIncludes :: (),
importPaths :: (),
mainFunIs :: (),
ctxtStkDepth :: (),
splitInfo :: (),
objectDir :: (),
dylibInstallName :: (),
hiDir :: (),
stubDir :: (),
dumpDir :: (),
objectSuf :: (),
hcSuf :: (),
hiSuf :: (),
canGenerateDynamicToo :: (),
dynObjectSuf :: (),
dynHiSuf :: (),
outputFile :: (),
outputHi :: (),
dynLibLoader :: (),
dumpPrefixForce :: (),
includePaths :: (),
libraryPaths :: (),
frameworkPaths :: (),
cmdlineFrameworks :: (),
rtsOpts :: (),
rtsOptsEnabled :: (),
hpcDir :: (),
depMakefile :: (),
depIncludePkgDeps :: (),
depSuffixes :: (),
extraPkgConfs :: (),
filesToClean :: (),
dirsToClean :: (),
filesToNotIntermelean :: (),
generatedDumps :: (),
dumpFlags :: (),
warningFlags :: (),
safeHaskell :: (),
thOnLoc :: (),
newDerivOnLoc :: (),
pkgTrustOnLoc :: (),
warnSafeOnLoc :: (),
warnUnsafeOnLoc :: (),
ufCreationThreshold :: (),
ufUseThreshold :: (),
ufFunAppDiscount :: (),
ufDictDiscount :: (),
ufKeenessFactor :: (),
ufDearOp :: (),
maxWorkerArgs :: (),
ghciHistSize :: (),
haddockOptions :: (),
ghciScripts :: (),
pprUserLength :: (),
pprCols :: (),
traceLevel :: (),
profAuto :: (),
interactivePrint :: (),
llvmVersion :: (),
nextWrapperNum :: ()
}
data Settings = Settings {
sTargetPlatform :: Platform
}
targetPlatform :: DynFlags -> Platform
targetPlatform dflags = sTargetPlatform (settings dflags)
data PackageFlag
= ExposePackage String
data Way
= WayThreaded
| WayDebug
| WayProf
| WayEventLog
| WayPar
| WayGran
| WayNDP
| WayDyn
deriving (Show, Eq, Ord)
wayGeneralFlags :: Platform -> Way -> [GeneralFlag]
wayGeneralFlags _ WayThreaded = []
wayGeneralFlags _ WayDebug = []
wayGeneralFlags platform WayDyn =
case platformOS platform of
OSMinGW32 -> [Opt_PIC]
OSDarwin -> [Opt_PIC]
OSLinux -> [Opt_PIC]
_ -> []
wayGeneralFlags _ WayProf = [Opt_SccProfilingOn]
wayGeneralFlags _ WayEventLog = []
wayGeneralFlags _ WayPar = []
wayGeneralFlags _ WayGran = []
wayGeneralFlags _ WayNDP = []
wayExtras :: Platform -> Way -> DynFlags -> DynFlags
wayExtras _ WayThreaded dflags = dflags
wayExtras _ WayDebug dflags = dflags
wayExtras _ WayDyn dflags = dflags
wayExtras _ WayProf dflags = dflags
wayExtras _ WayEventLog dflags = dflags
wayExtras _ WayPar dflags = exposePackage' "concurrent" dflags
wayExtras _ WayGran dflags = exposePackage' "concurrent" dflags
wayExtras _ WayNDP dflags = setExtensionFlag' Opt_ParallelArrays dflags
data OnOff a = On a
flattenExtensionFlags :: Maybe Language -> [OnOff ExtensionFlag] -> IntSet
flattenExtensionFlags ml = foldr f defaultExtensionFlags
where f (On flag) flags = IntSet.insert (fromEnum flag) flags
defaultExtensionFlags = IntSet.fromList (map fromEnum (languageExtensions ml))
languageExtensions :: Maybe Language -> [ExtensionFlag]
languageExtensions Nothing = []
languageExtensions (Just Haskell98) = []
languageExtensions (Just Haskell2010) = []
gopt_set :: DynFlags -> GeneralFlag -> DynFlags
gopt_set dfs f = dfs{ generalFlags = IntSet.insert (fromEnum f) (generalFlags dfs) }
gopt_unset :: DynFlags -> GeneralFlag -> DynFlags
gopt_unset dfs f = dfs{ generalFlags = IntSet.delete (fromEnum f) (generalFlags dfs) }
xopt_set :: DynFlags -> ExtensionFlag -> DynFlags
xopt_set dfs f
= let onoffs = On f : extensions dfs
in dfs { extensions = onoffs,
extensionFlags = flattenExtensionFlags (language dfs) onoffs }
flagsAll :: [Flag (CmdLineP DynFlags)]
flagsAll = [
Flag "-prof" (NoArg (addWay WayProf))
, Flag "-dynamic" (NoArg (do unSetGeneralFlag Opt_Static
addWay WayDyn))
]
type DynP = EwM (CmdLineP DynFlags)
upd :: (DynFlags -> DynFlags) -> DynP ()
upd f = liftEwM (do dflags <- getCmdLineState
putCmdLineState $ f dflags)
addWay :: Way -> DynP ()
addWay w = upd (addWay' w)
addWay' :: Way -> DynFlags -> DynFlags
addWay' w dflags0 = let platform = targetPlatform dflags0
dflags1 = dflags0 { ways = w : ways dflags0 }
dflags2 = wayExtras platform w dflags1
dflags3 = foldr setGeneralFlag' dflags2 (wayGeneralFlags platform w)
in dflags3
unSetGeneralFlag :: GeneralFlag -> DynP ()
unSetGeneralFlag f = upd (unSetGeneralFlag' f)
setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags
setGeneralFlag' f dflags = gopt_set dflags f
unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags
unSetGeneralFlag' f dflags = gopt_unset dflags f
setExtensionFlag' :: ExtensionFlag -> DynFlags -> DynFlags
setExtensionFlag' f dflags = xopt_set dflags f
exposePackage' :: String -> DynFlags -> DynFlags
exposePackage' p dflags
= dflags { packageFlags = ExposePackage p : packageFlags dflags }
data Platform
= Platform {
platformOS :: OS
}
deriving (Read, Show, Eq)
data OS
= OSUnknown
| OSLinux
| OSDarwin
| OSSolaris2
| OSMinGW32
| OSFreeBSD
| OSDragonFly
| OSOpenBSD
| OSNetBSD
| OSKFreeBSD
| OSHaiku
| OSOsf3
deriving (Read, Show, Eq)
data Flag m = Flag
{ flagName :: String, -- Flag, without the leading "-"
flagOptKind :: OptKind m -- What to do if we see it
}
data OptKind m -- Suppose the flag is -f
= NoArg (EwM m ()) -- -f all by itself
newtype EwM m a = EwM { unEwM :: String -> m a }
instance Monad m => Monad (EwM m) where
(EwM f) >>= k = EwM (\l -> do r <- f l
unEwM (k r) l)
return v = EwM (\_ -> return v)
setArg :: Monad m => String -> EwM m () -> EwM m ()
setArg l (EwM f) = EwM (\_ -> f l)
liftEwM :: Monad m => m a -> EwM m a
liftEwM action = EwM (\_ -> do { r <- action; return r })
newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
instance Monad (CmdLineP s) where
m >>= k = CmdLineP $ \s ->
let (a, s') = runCmdLine m s
in runCmdLine (k a) s'
return a = CmdLineP $ \s -> (a, s)
getCmdLineState :: CmdLineP s s
getCmdLineState = CmdLineP $ \s -> (s,s)
putCmdLineState :: s -> CmdLineP s ()
putCmdLineState s = CmdLineP $ \_ -> ((),s)
processArgs :: CmdLineP DynFlags ()
processArgs = unEwM process (error "processArgs: no arg yet")
where
process =
case findArg flagsAll "-dynamic" of
Just (NoArg _) -> setArg "-dynamic" $ do unSetGeneralFlag Opt_Static
addWay WayDyn
Nothing -> return ()
findArg :: [Flag m] -> String -> Maybe (OptKind m)
findArg spec arg =
case
[ optKind
| flag <- spec,
let optKind = flagOptKind flag,
Just _ <- [stripPrefix (flagName flag) arg] ]
of
[] -> Nothing
(one:_) -> Just one
_______________________________________________
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
