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