diff options
| -rw-r--r-- | compiler/cmm/PprC.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/CgClosure.lhs | 26 | ||||
| -rw-r--r-- | compiler/codeGen/CgUtils.hs | 12 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 31 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmUtils.hs | 17 | ||||
| -rw-r--r-- | compiler/main/CmdLineParser.hs | 124 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 1022 | ||||
| -rw-r--r-- | compiler/main/HscMain.lhs | 6 | ||||
| -rw-r--r-- | compiler/main/StaticFlagParser.hs | 84 | ||||
| -rw-r--r-- | compiler/main/StaticFlags.hs | 49 | ||||
| -rw-r--r-- | compiler/simplCore/SimplCore.lhs | 516 | ||||
| -rwxr-xr-x | compiler/typecheck/TcDeriv.lhs | 177 | ||||
| -rw-r--r-- | driver/ordering-passes | 257 | ||||
| -rw-r--r-- | driver/test_mangler | 29 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 8 | ||||
| -rw-r--r-- | ghc/Main.hs | 76 | ||||
| -rw-r--r-- | includes/rts/storage/GC.h | 4 | ||||
| -rw-r--r-- | mk/config.mk.in | 2 | ||||
| -rw-r--r-- | rts/sm/Storage.c | 143 |
19 files changed, 1171 insertions, 1414 deletions
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 78cd6990ba..812f3b2827 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -958,7 +958,7 @@ cLoad platform expr rep = struct = ptext (sLit "struct") <+> braces (decl) packed_attr = ptext (sLit "__attribute__((packed))") cast = parens (struct <+> packed_attr <> char '*') - in parens (cast <+> pprExpr1 expr) <> ptext (sLit "->x") + in parens (cast <+> pprExpr1 platform expr) <> ptext (sLit "->x") #else cLoad platform expr rep = char '*' <> parens (cCast platform (machRepPtrCType rep) expr) #endif diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 2f312016c7..bccadb5a5d 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -44,7 +44,6 @@ import Util import BasicTypes import StaticFlags import DynFlags -import Constants import Outputable import FastString @@ -572,27 +571,26 @@ link_caf cl_info _is_upd = do -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF") + ; ret <- newTemp bWord + ; emitRtsCallGen [CmmHinted ret NoHint] rtsPackageId (fsLit "newCAF") [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint, - CmmHinted (CmmReg nodeReg) AddrHint ] - [node] False + CmmHinted (CmmReg nodeReg) AddrHint, + CmmHinted hp_rel AddrHint ] + (Just [node]) False -- node is live, so save it. - -- Overwrite the closure with a (static) indirection - -- to the newly-allocated black hole - ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel - , CmmStore (CmmReg nodeReg) ind_static_info ] + -- see Note [atomic CAF entry] in rts/sm/Storage.c + ; emitIf (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit]) $ + -- re-enter R1. Doing this directly is slightly dodgy; we're + -- assuming lots of things, like the stack pointer hasn't + -- moved since we entered the CAF. + let target = entryCode (closureInfoPtr (CmmReg nodeReg)) in + stmtC (CmmJump target []) ; returnFC hp_rel } where bh_cl_info :: ClosureInfo bh_cl_info = cafBlackHoleClosureInfo cl_info - - ind_static_info :: CmmExpr - ind_static_info = mkLblExpr mkIndStaticInfoLabel - - off_indirectee :: WordOff - off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE \end{code} diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index a71702cb4c..5c52eeb2c6 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -13,6 +13,7 @@ module CgUtils ( emitRODataLits, mkRODataLits, emitIf, emitIfThenElse, emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, + emitRtsCallGen, assignTemp, assignTemp_, newTemp, emitSimultaneously, emitSwitch, emitLitSwitch, @@ -235,22 +236,23 @@ emitRtsCall -> Bool -- ^ whether this is a safe call -> Code -- ^ cmm code -emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe +emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args Nothing safe -- The 'Nothing' says "save all global registers" emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code emitRtsCallWithVols pkg fun args vols safe - = emitRtsCall' [] pkg fun args (Just vols) safe + = emitRtsCallGen [] pkg fun args (Just vols) safe emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString -> [CmmHinted CmmExpr] -> Bool -> Code + emitRtsCallWithResult res hint pkg fun args safe - = emitRtsCall' [CmmHinted res hint] pkg fun args Nothing safe + = emitRtsCallGen [CmmHinted res hint] pkg fun args Nothing safe -- Make a call to an RTS C procedure -emitRtsCall' +emitRtsCallGen :: [CmmHinted LocalReg] -> PackageId -> FastString @@ -258,7 +260,7 @@ emitRtsCall' -> Maybe [GlobalReg] -> Bool -- True <=> CmmSafe call -> Code -emitRtsCall' res pkg fun args vols safe = do +emitRtsCallGen res pkg fun args vols safe = do safety <- if safe then getSRTInfo >>= (return . CmmSafe) else return CmmUnsafe diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 1bf9366f50..9f66684603 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -644,25 +644,24 @@ link_caf _is_upd = do -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF") + ; ret <- newTemp bWord + ; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF") [ (CmmReg (CmmGlobal BaseReg), AddrHint), - (CmmReg nodeReg, AddrHint) ] - [node] False - -- node is live, so save it. - - -- Overwrite the closure with a (static) indirection - -- to the newly-allocated black hole - ; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*> - mkStore (CmmReg nodeReg) ind_static_info) + (CmmReg nodeReg, AddrHint), + (CmmReg (CmmLocal hp_rel), AddrHint) ] + (Just [node]) False + -- node is live, so save it. + + -- see Note [atomic CAF entry] in rts/sm/Storage.c + ; emit $ mkCmmIfThen + (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit]) $ + -- re-enter R1. Doing this directly is slightly dodgy; we're + -- assuming lots of things, like the stack pointer hasn't + -- moved since we entered the CAF. + let target = entryCode (closureInfoPtr (CmmReg nodeReg)) in + mkJump target [] 0 ; return hp_rel } - where - ind_static_info :: CmmExpr - ind_static_info = mkLblExpr mkIndStaticInfoLabel - - off_indirectee :: WordOff - off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE - ------------------------------------------------------------------------ -- Profiling diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 509a1ebbb4..ddb87e4ffe 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -10,8 +10,8 @@ module StgCmmUtils ( cgLit, mkSimpleLit, emitDataLits, mkDataLits, emitRODataLits, mkRODataLits, - emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, - assignTemp, newTemp, withTemp, + emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, emitRtsCallGen, + assignTemp, newTemp, withTemp, newUnboxedTupleRegs, @@ -171,20 +171,20 @@ tagToClosure tycon tag ------------------------------------------------------------------------- emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe +emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args Nothing safe -- The 'Nothing' says "save all global registers" emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode () emitRtsCallWithVols pkg fun args vols safe - = emitRtsCall' [] pkg fun args (Just vols) safe + = emitRtsCallGen [] pkg fun args (Just vols) safe emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCallWithResult res hint pkg fun args safe - = emitRtsCall' [(res,hint)] pkg fun args Nothing safe + = emitRtsCallGen [(res,hint)] pkg fun args Nothing safe -- Make a call to an RTS C procedure -emitRtsCall' +emitRtsCallGen :: [(LocalReg,ForeignHint)] -> PackageId -> FastString @@ -192,9 +192,8 @@ emitRtsCall' -> Maybe [GlobalReg] -> Bool -- True <=> CmmSafe call -> FCode () -emitRtsCall' res pkg fun args _vols safe - = --error "emitRtsCall'" - do { updfr_off <- getUpdFrameOff +emitRtsCallGen res pkg fun args _vols safe + = do { updfr_off <- getUpdFrameOff ; emit caller_save ; emit $ call updfr_off ; emit caller_load } diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 02b6042148..c4bfe3abe7 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -12,10 +12,10 @@ module CmdLineParser ( processArgs, OptKind(..), CmdLineP(..), getCmdLineState, putCmdLineState, - Flag(..), FlagSafety(..), flagA, flagR, flagC, flagN, - errorsToGhcException, determineSafeLevel, + Flag(..), + errorsToGhcException, - EwM, addErr, addWarn, getArg, liftEwM, deprecate + EwM, addErr, addWarn, getArg, getCurLoc, liftEwM, deprecate ) where #include "HsVersions.h" @@ -29,43 +29,16 @@ import SrcLoc import Data.List -------------------------------------------------------- --- The Flag and OptKind types +-- The Flag and OptKind types -------------------------------------------------------- data Flag m = Flag { flagName :: String, -- Flag, without the leading "-" - flagSafety :: FlagSafety, -- Flag safety level (Safe Haskell) flagOptKind :: OptKind m -- What to do if we see it } --- | This determines how a flag should behave when Safe Haskell --- mode is on. -data FlagSafety - = EnablesSafe -- ^ This flag is a little bit of a hack. We give - -- the safe haskell flags (-XSafe and -XSafeLanguage) - -- this safety type so we can easily detect when safe - -- haskell mode has been enable in a module pragma - -- as this changes how the rest of the parsing should - -- happen. - - | AlwaysAllowed -- ^ Flag is always allowed - | RestrictedFunction -- ^ Flag is allowed but functions in a reduced way - | CmdLineOnly -- ^ Flag is only allowed on command line, not in pragma - | NeverAllowed -- ^ Flag isn't allowed at all - deriving ( Eq, Ord ) - -determineSafeLevel :: Bool -> FlagSafety -determineSafeLevel False = RestrictedFunction -determineSafeLevel True = CmdLineOnly - -flagA, flagR, flagC, flagN :: String -> OptKind m -> Flag m -flagA n o = Flag n AlwaysAllowed o -flagR n o = Flag n RestrictedFunction o -flagC n o = Flag n CmdLineOnly o -flagN n o = Flag n NeverAllowed o - ------------------------------- -data OptKind m -- Suppose the flag is -f +data OptKind m -- Suppose the flag is -f = NoArg (EwM m ()) -- -f all by itself | HasArg (String -> EwM m ()) -- -farg or -f arg | SepArg (String -> EwM m ()) -- -f arg @@ -80,7 +53,7 @@ data OptKind m -- Suppose the flag is -f -------------------------------------------------------- --- The EwM monad +-- The EwM monad -------------------------------------------------------- type Err = Located String @@ -90,46 +63,39 @@ type Warns = Bag Warn -- EwM (short for "errors and warnings monad") is a -- monad transformer for m that adds an (err, warn) state -newtype EwM m a = EwM { unEwM :: Located String -- Current arg - -> FlagSafety -- arg safety level - -> FlagSafety -- global safety level +newtype EwM m a = EwM { unEwM :: Located String -- Current arg -> Errs -> Warns -> m (Errs, Warns, a) } instance Monad m => Monad (EwM m) where - (EwM f) >>= k = EwM (\l s c e w -> do { (e', w', r) <- f l s c e w - ; unEwM (k r) l s c e' w' }) - return v = EwM (\_ _ _ e w -> return (e, w, v)) - -setArg :: Monad m => Located String -> FlagSafety -> EwM m () -> EwM m () -setArg l s (EwM f) = EwM (\_ _ c es ws -> - let check | s <= c = f l s c es ws - | otherwise = err l es ws - err (L loc ('-' : arg)) es ws = - let msg = "Warning: " ++ arg ++ " is not allowed in " - ++ "Safe Haskell; ignoring " ++ arg - in return (es, ws `snocBag` L loc msg, ()) - err _ _ _ = error "Bad pattern match in setArg" - in check) + (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w + unEwM (k r) l e' w') + return v = EwM (\_ e w -> return (e, w, v)) + +setArg :: Monad m => Located String -> EwM m () -> EwM m () +setArg l (EwM f) = EwM (\_ es ws -> f l es ws) addErr :: Monad m => String -> EwM m () -addErr e = EwM (\(L loc _) _ _ es ws -> return (es `snocBag` L loc e, ws, ())) +addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ())) addWarn :: Monad m => String -> EwM m () -addWarn msg = EwM (\(L loc _) _ _ es ws -> return (es, ws `snocBag` L loc w, ())) +addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ())) where w = "Warning: " ++ msg deprecate :: Monad m => String -> EwM m () -deprecate s - = do { arg <- getArg - ; addWarn (arg ++ " is deprecated: " ++ s) } +deprecate s + = do arg <- getArg + addWarn (arg ++ " is deprecated: " ++ s) getArg :: Monad m => EwM m String -getArg = EwM (\(L _ arg) _ _ es ws -> return (es, ws, arg)) +getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) + +getCurLoc :: Monad m => EwM m SrcSpan +getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) liftEwM :: Monad m => m a -> EwM m a -liftEwM action = EwM (\_ _ _ es ws -> do { r <- action; return (es, ws, r) }) +liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) -- ----------------------------------------------------------------------------- -- A state monad for use in the command-line parser @@ -150,47 +116,42 @@ putCmdLineState s = CmdLineP $ \_ -> ((),s) -------------------------------------------------------- --- Processing arguments +-- Processing arguments -------------------------------------------------------- processArgs :: Monad m => [Flag m] -- cmdline parser spec -> [Located String] -- args - -> FlagSafety -- flag clearance lvl - -> Bool -> m ( [Located String], -- spare args [Located String], -- errors [Located String] -- warnings ) -processArgs spec args clvl0 cmdline - = let (clvl1, action) = process clvl0 args [] - in do { (errs, warns, spare) <- unEwM action (panic "processArgs: no arg yet") - AlwaysAllowed clvl1 emptyBag emptyBag - ; return (spare, bagToList errs, bagToList warns) } +processArgs spec args + = let action = process args [] + in do (errs, warns, spare) <- unEwM action (panic "processArgs: no arg yet") + emptyBag emptyBag + return (spare, bagToList errs, bagToList warns) where - -- process :: FlagSafety -> [Located String] -> [Located String] -> (FlagSafety, EwM m [Located String]) + -- process :: [Located String] -> [Located String] -> EwM m [Located String] -- - process clvl [] spare = (clvl, return (reverse spare)) + process [] spare = return (reverse spare) - process clvl (locArg@(L _ ('-' : arg)) : args) spare = + process (locArg@(L _ ('-' : arg)) : args) spare = case findArg spec arg of - Just (rest, opt_kind, fsafe) -> - let clvl1 = if fsafe == EnablesSafe then determineSafeLevel cmdline else clvl - in case processOneArg opt_kind rest arg args of + Just (rest, opt_kind) -> + case processOneArg opt_kind rest arg args of Left err -> - let (clvl2,b) = process clvl1 args spare - clvl3 = min clvl1 clvl2 - in (clvl3, (setArg locArg fsafe $ addErr err) >> b) + let b = process args spare + in (setArg locArg $ addErr err) >> b Right (action,rest) -> - let (clvl2,b) = process clvl1 rest spare - clvl3 = min clvl1 clvl2 - in (clvl3, (setArg locArg fsafe $ action) >> b) + let b = process rest spare + in (setArg locArg $ action) >> b - Nothing -> process clvl args (locArg : spare) + Nothing -> process args (locArg : spare) - process clvl (arg : args) spare = process clvl args (arg : spare) + process (arg : args) spare = process args (arg : spare) processOneArg :: OptKind m -> String -> String -> [Located String] @@ -231,12 +192,11 @@ processOneArg opt_kind rest arg args AnySuffixPred _ f -> Right (f dash_arg, args) -findArg :: [Flag m] -> String -> Maybe (String, OptKind m, FlagSafety) +findArg :: [Flag m] -> String -> Maybe (String, OptKind m) findArg spec arg - = case [ (removeSpaces rest, optKind, flagSafe) + = case [ (removeSpaces rest, optKind) | flag <- spec, let optKind = flagOptKind flag, - let flagSafe = flagSafety flag, Just rest <- [stripPrefix (flagName flag) arg], arg_ok optKind rest arg ] of diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 708060afb1..866301376d 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -41,6 +41,7 @@ module DynFlags ( SafeHaskellMode(..), safeHaskellOn, safeLanguageOn, safeDirectImpsReq, safeImplicitImpsReq, + packageTrustOn, -- ** System tool settings and locations Settings(..), @@ -81,7 +82,7 @@ module DynFlags ( -- * Compiler configuration suitable for display to the user compilerInfo #ifdef GHCI --- Only in stage 2 can we be sure that the RTS +-- Only in stage 2 can we be sure that the RTS -- exposes the appropriate runtime boolean , rtsIsProfiled #endif @@ -106,12 +107,12 @@ import SrcLoc import FastString import Outputable #ifdef GHCI -import Foreign.C ( CInt ) +import Foreign.C ( CInt ) #endif import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) #ifdef GHCI -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe ( unsafePerformIO ) #endif import Data.IORef import Control.Monad ( when ) @@ -192,7 +193,7 @@ data DynFlag | Opt_D_dump_rn_stats | Opt_D_dump_opt_cmm | Opt_D_dump_simpl_stats - | Opt_D_dump_cs_trace -- Constraint solver in type checker + | Opt_D_dump_cs_trace -- Constraint solver in type checker | Opt_D_dump_tc_trace | Opt_D_dump_if_trace | Opt_D_dump_vt_trace @@ -236,7 +237,7 @@ data DynFlag | Opt_CaseMerge | Opt_UnboxStrictFields | Opt_DictsCheap - | Opt_EnableRewriteRules -- Apply rewrite rules during simplification + | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_Vectorise | Opt_RegsGraph -- do graph coloring register allocation | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation @@ -281,7 +282,7 @@ data DynFlag | Opt_GhciHistory | Opt_HelpfulErrors - -- temporary flags + -- temporary flags | Opt_RunCPS | Opt_RunCPSZ | Opt_AutoLinkPackages @@ -296,6 +297,9 @@ data DynFlag | Opt_KeepRawTokenStream | Opt_KeepLlvmFiles + -- safe haskell flags + | Opt_PackageTrust + deriving (Eq, Show) data WarningFlag = @@ -357,14 +361,14 @@ data ExtensionFlag | Opt_MonomorphismRestriction | Opt_MonoPatBinds | Opt_MonoLocalBinds - | Opt_RelaxedPolyRec -- Deprecated - | Opt_ExtendedDefaultRules -- Use GHC's extended rules for defaulting + | Opt_RelaxedPolyRec -- Deprecated + | Opt_ExtendedDefaultRules -- Use GHC's extended rules for defaulting | Opt_ForeignFunctionInterface | Opt_UnliftedFFITypes | Opt_InterruptibleFFI | Opt_GHCForeignImportPrim - | Opt_ParallelArrays -- Syntactic support for parallel arrays - | Opt_Arrows -- Arrow-notation syntax + | Opt_ParallelArrays -- Syntactic support for parallel arrays + | Opt_Arrows -- Arrow-notation syntax | Opt_TemplateHaskell | Opt_QuasiQuotes | Opt_ImplicitParams @@ -384,7 +388,7 @@ data ExtensionFlag | Opt_DoAndIfThenElse | Opt_RebindableSyntax | Opt_ConstraintKinds - + | Opt_StandaloneDeriving | Opt_DeriveDataTypeable | Opt_DeriveFunctor @@ -445,12 +449,12 @@ data DynFlags = DynFlags { ruleCheck :: Maybe String, strictnessBefore :: [Int], -- ^ Additional demand analysis - simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks + simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating - -- See CoreMonad.FloatOutSwitches + -- See CoreMonad.FloatOutSwitches targetPlatform :: Platform.Platform, -- ^ The platform we're compiling for. Used by the NCG. cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ @@ -547,6 +551,11 @@ data DynFlags = DynFlags { language :: Maybe Language, -- | Safe Haskell mode safeHaskell :: SafeHaskellMode, + -- We store the location of where template haskell and newtype deriving were + -- turned on so we can produce accurate error messages when Safe Haskell turns + -- them off. + thOnLoc :: SrcSpan, + newDerivOnLoc :: SrcSpan, -- Don't change this without updating extensionFlags: extensions :: [OnOff ExtensionFlag], -- extensionFlags should always be equal to @@ -802,11 +811,11 @@ defaultDynFlags mySettings = maxSimplIterations = 4, shouldDumpSimplPhase = Nothing, ruleCheck = Nothing, - simplTickFactor = 100, + simplTickFactor = 100, specConstrThreshold = Just 2000, specConstrCount = Just 3, liberateCaseThreshold = Just 2000, - floatLamArgs = Just 0, -- Default: float only if no fvs + floatLamArgs = Just 0, -- Default: float only if no fvs strictnessBefore = [], targetPlatform = defaultTargetPlatform, @@ -869,6 +878,8 @@ defaultDynFlags mySettings = warningFlags = standardWarnings, language = Nothing, safeHaskell = Sf_None, + thOnLoc = noSrcSpan, + newDerivOnLoc = noSrcSpan, extensions = [], extensionFlags = flattenExtensionFlags Nothing [], log_action = defaultLogAction @@ -1005,6 +1016,10 @@ setLanguage l = upd f dynFlagDependencies :: DynFlags -> [ModuleName] dynFlagDependencies = pluginModNames +-- | Is the -fpackage-trust mode on +packageTrustOn :: DynFlags -> Bool +packageTrustOn = dopt Opt_PackageTrust + -- | Is the Safe Haskell safe language in use safeLanguageOn :: DynFlags -> Bool safeLanguageOn dflags = safeHaskell dflags == Sf_Safe @@ -1202,9 +1217,9 @@ getStgToDo dflags = todo1 {- ********************************************************************** -%* * - DynFlags parser -%* * +%* * + DynFlags parser +%* * %********************************************************************* -} -- ----------------------------------------------------------------------------- @@ -1251,18 +1266,11 @@ parseDynamicFlags dflags0 args cmdline = do flag_spec | cmdline = package_flags ++ dynamic_flags | otherwise = dynamic_flags - let safeLevel = if safeLanguageOn dflags0 - then determineSafeLevel cmdline else NeverAllowed let ((leftover, errs, warns), dflags1) - = runCmdLine (processArgs flag_spec args' safeLevel cmdline) dflags0 + = runCmdLine (processArgs flag_spec args') dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs -- check for disabled flags in safe haskell - -- Hack: unfortunately flags that are completely disabled can't be stopped from being - -- enabled on the command line before a -XSafe or -XSafeLanguage flag is encountered. - -- the easiest way to fix this is to just check that they aren't enabled now. The down - -- side is that flags marked as NeverAllowed must also be checked here placing a sync - -- burden on the ghc hacker. let (dflags2, sh_warns) = if (safeLanguageOn dflags1) then shFlagsDisallowed dflags1 else (dflags1, []) @@ -1274,23 +1282,25 @@ parseDynamicFlags dflags0 args cmdline = do shFlagsDisallowed :: DynFlags -> (DynFlags, [Located String]) shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags where - check_method (df, warns) (test,str,fix) - | test df = (fix df, warns ++ safeFailure str) + check_method (df, warns) (str,loc,test,fix) + | test df = (fix df, warns ++ safeFailure loc str) | otherwise = (df, warns) - bad_flags = [(xopt Opt_GeneralizedNewtypeDeriving, "-XGeneralizedNewtypeDeriving", - flip xopt_unset Opt_GeneralizedNewtypeDeriving), - (xopt Opt_TemplateHaskell, "-XTemplateHaskell", - flip xopt_unset Opt_TemplateHaskell)] + bad_flags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc dflags, + xopt Opt_GeneralizedNewtypeDeriving, + flip xopt_unset Opt_GeneralizedNewtypeDeriving), + ("-XTemplateHaskell", thOnLoc dflags, + xopt Opt_TemplateHaskell, + flip xopt_unset Opt_TemplateHaskell)] - safeFailure str = [L noSrcSpan $ "Warning: " ++ str ++ " is not allowed in" + safeFailure loc str = [L loc $ "Warning: " ++ str ++ " is not allowed in" ++ " Safe Haskell; ignoring " ++ str] {- ********************************************************************** -%* * - DynFlags specifications -%* * +%* * + DynFlags specifications +%* * %********************************************************************* -} allFlags :: [String] @@ -1302,303 +1312,306 @@ allFlags = map ('-':) $ where ok (PrefixPred _ _) = False ok _ = True fflags = fflags0 ++ fflags1 ++ fflags2 - fflags0 = [ name | (name, _, _, _) <- fFlags ] - fflags1 = [ name | (name, _, _, _) <- fWarningFlags ] - fflags2 = [ name | (name, _, _, _) <- fLangFlags ] + fflags0 = [ name | (name, _, _) <- fFlags ] + fflags1 = [ name | (name, _, _) <- fWarningFlags ] + fflags2 = [ name | (name, _, _) <- fLangFlags ] --------------- The main flags themselves ------------------ dynamic_flags :: [Flag (CmdLineP DynFlags)] dynamic_flags = [ - flagA "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect")) - , flagA "cpp" (NoArg (setExtensionFlag Opt_Cpp)) - , flagA "F" (NoArg (setDynFlag Opt_Pp)) - , flagA "#include" - (HasArg (\s -> do { addCmdlineHCInclude s - ; addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect" })) - , flagA "v" (OptIntSuffix setVerbosity) + Flag "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect")) + , Flag "cpp" (NoArg (setExtensionFlag Opt_Cpp)) + , Flag "F" (NoArg (setDynFlag Opt_Pp)) + , Flag "#include" + (HasArg (\s -> do addCmdlineHCInclude s + addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect")) + , Flag "v" (OptIntSuffix setVerbosity) ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. - , flagA "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) - , flagA "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) - , flagA "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) - , flagA "pgmP" (hasArg setPgmP) - , flagA "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) - , flagA "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) - , flagA "pgmm" (HasArg (\_ -> addWarn "The -pgmm flag does nothing; it will be removed in a future GHC release")) - , flagA "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) - , flagA "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) - , flagA "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) - , flagA "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) - , flagA "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) + , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) + , Flag "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , Flag "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) + , Flag "pgmP" (hasArg setPgmP) + , Flag "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) + , Flag "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) + , Flag "pgmm" (HasArg (\_ -> addWarn "The -pgmm flag does nothing; it will be removed in a future GHC release")) + , Flag "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) + , Flag "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) + , Flag "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) + , Flag "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) + , Flag "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) -- need to appear before -optl/-opta to be parsed as LLVM flags. - , flagA "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) - , flagA "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) - , flagA "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) - , flagA "optP" (hasArg addOptP) - , flagA "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) - , flagA "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) - , flagA "optm" (HasArg (\_ -> addWarn "The -optm flag does nothing; it will be removed in a future GHC release")) - , flagA "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) - , flagA "optl" (hasArg addOptl) - , flagA "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) - - , flagA "split-objs" - (NoArg (if can_split + , Flag "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) + , Flag "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) + , Flag "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) + , Flag "optP" (hasArg addOptP) + , Flag "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) + , Flag "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) + , Flag "optm" (HasArg (\_ -> addWarn "The -optm flag does nothing; it will be removed in a future GHC release")) + , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) + , Flag "optl" (hasArg addOptl) + , Flag "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) + + , Flag "split-objs" + (NoArg (if can_split then setDynFlag Opt_SplitObjs else addWarn "ignoring -fsplit-objs")) -------- ghc -M ----------------------------------------------------- - , flagA "dep-suffix" (hasArg addDepSuffix) - , flagA "optdep-s" (hasArgDF addDepSuffix "Use -dep-suffix instead") - , flagA "dep-makefile" (hasArg setDepMakefile) - , flagA "optdep-f" (hasArgDF setDepMakefile "Use -dep-makefile instead") - , flagA "optdep-w" (NoArg (deprecate "doesn't do anything")) - , flagA "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) - , flagA "optdep--include-prelude" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") - , flagA "optdep--include-pkg-deps" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") - , flagA "exclude-module" (hasArg addDepExcludeMod) - , flagA "optdep--exclude-module" (hasArgDF addDepExcludeMod "Use -exclude-module instead") - , flagA "optdep-x" (hasArgDF addDepExcludeMod "Use -exclude-module instead") + , Flag "dep-suffix" (hasArg addDepSuffix) + , Flag "optdep-s" (hasArgDF addDepSuffix "Use -dep-suffix instead") + , Flag "dep-makefile" (hasArg setDepMakefile) + , Flag "optdep-f" (hasArgDF setDepMakefile "Use -dep-makefile instead") + , Flag "optdep-w" (NoArg (deprecate "doesn't do anything")) + , Flag "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) + , Flag "optdep--include-prelude" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") + , Flag "optdep--include-pkg-deps" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") + , Flag "exclude-module" (hasArg addDepExcludeMod) + , Flag "optdep--exclude-module" (hasArgDF addDepExcludeMod "Use -exclude-module instead") + , Flag "optdep-x" (hasArgDF addDepExcludeMod "Use -exclude-module instead") -------- Linking ---------------------------------------------------- - , flagA "no-link" (noArg (\d -> d{ ghcLink=NoLink })) - , flagA "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) - , flagA "dynload" (hasArg parseDynLibLoaderMode) - , flagA "dylib-install-name" (hasArg setDylibInstallName) + , Flag "no-link" (noArg (\d -> d{ ghcLink=NoLink })) + , Flag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) + , Flag "dynload" (hasArg parseDynLibLoaderMode) + , Flag "dylib-install-name" (hasArg setDylibInstallName) ------- Libraries --------------------------------------------------- - , flagA "L" (Prefix addLibraryPath) - , flagA "l" (hasArg (addOptl . ("-l" ++))) + , Flag "L" (Prefix addLibraryPath) + , Flag "l" (hasArg (addOptl . ("-l" ++))) ------- Frameworks -------------------------------------------------- -- -framework-path should really be -F ... - , flagA "framework-path" (HasArg addFrameworkPath) - , flagA "framework" (hasArg addCmdlineFramework) + , Flag "framework-path" (HasArg addFrameworkPath) + , Flag "framework" (hasArg addCmdlineFramework) ------- Output Redirection ------------------------------------------ - , flagA "odir" (hasArg setObjectDir) - , flagA "o" (sepArg (setOutputFile . Just)) - , flagA "ohi" (hasArg (setOutputHi . Just )) - , flagA "osuf" (hasArg setObjectSuf) - , flagA "hcsuf" (hasArg setHcSuf) - , flagA "hisuf" (hasArg setHiSuf) - , flagA "hidir" (hasArg setHiDir) - , flagA "tmpdir" (hasArg setTmpDir) - , flagA "stubdir" (hasArg setStubDir) - , flagA "outputdir" (hasArg setOutputDir) - , flagA "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) + , Flag "odir" (hasArg setObjectDir) + , Flag "o" (sepArg (setOutputFile . Just)) + , Flag "ohi" (hasArg (setOutputHi . Just )) + , Flag "osuf" (hasArg setObjectSuf) + , Flag "hcsuf" (hasArg setHcSuf) + , Flag "hisuf" (hasArg setHiSuf) + , Flag "hidir" (hasArg setHiDir) + , Flag "tmpdir" (hasArg setTmpDir) + , Flag "stubdir" (hasArg setStubDir) + , Flag "outputdir" (hasArg setOutputDir) + , Flag "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) ------- Keeping temporary files ------------------------------------- -- These can be singular (think ghc -c) or plural (think ghc --make) - , flagA "keep-hc-file" (NoArg (setDynFlag Opt_KeepHcFiles)) - , flagA "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) - , flagA "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) - , flagA "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) - , flagA "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) - , flagA "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) - , flagA "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) - , flagA "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) + , Flag "keep-hc-file" (NoArg (setDynFlag Opt_KeepHcFiles)) + , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) + , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) + , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) + , Flag "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) + , Flag "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) + , Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) + , Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) -- This only makes sense as plural - , flagA "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) + , Flag "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) ------- Miscellaneous ---------------------------------------------- - , flagA "no-auto-link-packages" (NoArg (unSetDynFlag Opt_AutoLinkPackages)) - , flagA "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) - , flagA "with-rtsopts" (HasArg setRtsOpts) - , flagA "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) - , flagA "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) - , flagA "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) - , flagA "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) - , flagA "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) - , flagA "main-is" (SepArg setMainIs) - , flagA "haddock" (NoArg (setDynFlag Opt_Haddock)) - , flagA "haddock-opts" (hasArg addHaddockOpts) - , flagA "hpcdir" (SepArg setOptHpcDir) + , Flag "no-auto-link-packages" (NoArg (unSetDynFlag Opt_AutoLinkPackages)) + , Flag "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) + , Flag "with-rtsopts" (HasArg setRtsOpts) + , Flag "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) + , Flag "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) + , Flag "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) + , Flag "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) + , Flag "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) + , Flag "main-is" (SepArg setMainIs) + , Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) + , Flag "haddock-opts" (hasArg addHaddockOpts) + , Flag "hpcdir" (SepArg setOptHpcDir) ------- recompilation checker -------------------------------------- - , flagA "recomp" (NoArg (do { unSetDynFlag Opt_ForceRecomp - ; deprecate "Use -fno-force-recomp instead" })) - , flagA "no-recomp" (NoArg (do { setDynFlag Opt_ForceRecomp - ; deprecate "Use -fforce-recomp instead" })) + , Flag "recomp" (NoArg (do unSetDynFlag Opt_ForceRecomp + deprecate "Use -fno-force-recomp instead")) + , Flag "no-recomp" (NoArg (do setDynFlag Opt_ForceRecomp + deprecate "Use -fforce-recomp instead")) ------ HsCpp opts --------------------------------------------------- - , flagA "D" (AnySuffix (upd . addOptP)) - , flagA "U" (AnySuffix (upd . addOptP)) + , Flag "D" (AnySuffix (upd . addOptP)) + , Flag "U" (AnySuffix (upd . addOptP)) ------- Include/Import Paths ---------------------------------------- - , flagA "I" (Prefix addIncludePath) - , flagA "i" (OptPrefix addImportPath) + , Flag "I" (Prefix addIncludePath) + , Flag "i" (OptPrefix addImportPath) ------ Debugging ---------------------------------------------------- - , flagA "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) - - , flagA "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) - , flagA "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm) - , flagA "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) - , flagA "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) - , flagA "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe) - , flagA "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills) - , flagA "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc) - , flagA "ddump-cmmz-rewrite" (setDumpFlag Opt_D_dump_cmmz_rewrite) - , flagA "ddump-cmmz-dead" (setDumpFlag Opt_D_dump_cmmz_dead) - , flagA "ddump-cmmz-stub" (setDumpFlag Opt_D_dump_cmmz_stub) - , flagA "ddump-cmmz-sp" (setDumpFlag Opt_D_dump_cmmz_sp) - , flagA "ddump-cmmz-procmap" (setDumpFlag Opt_D_dump_cmmz_procmap) - , flagA "ddump-cmmz-split" (setDumpFlag Opt_D_dump_cmmz_split) - , flagA "ddump-cmmz-lower" (setDumpFlag Opt_D_dump_cmmz_lower) - , flagA "ddump-cmmz-info" (setDumpFlag Opt_D_dump_cmmz_info) - , flagA "ddump-cmmz-cafs" (setDumpFlag Opt_D_dump_cmmz_cafs) - , flagA "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) - , flagA "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) - , flagA "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) - , flagA "ddump-asm" (setDumpFlag Opt_D_dump_asm) - , flagA "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) - , flagA "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) - , flagA "ddump-asm-coalesce" (setDumpFlag Opt_D_dump_asm_coalesce) - , flagA "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) - , flagA "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) - , flagA "ddump-asm-regalloc-stages" (setDumpFlag Opt_D_dump_asm_regalloc_stages) - , flagA "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) - , flagA "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) - , flagA "ddump-llvm" (NoArg (do { setObjTarget HscLlvm - ; setDumpFlag' Opt_D_dump_llvm})) - , flagA "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) - , flagA "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) - , flagA "ddump-ds" (setDumpFlag Opt_D_dump_ds) - , flagA "ddump-flatC" (setDumpFlag Opt_D_dump_flatC) - , flagA "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) - , flagA "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) - , flagA "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) - , flagA "ddump-rule-rewrites" (setDumpFlag Opt_D_dump_rule_rewrites) - , flagA "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) - , flagA "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) - , flagA "ddump-rn" (setDumpFlag Opt_D_dump_rn) - , flagA "ddump-core-pipeline" (setDumpFlag Opt_D_dump_core_pipeline) - , flagA "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) - , flagA "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations) - , flagA "ddump-simpl-phases" (OptPrefix setDumpSimplPhases) - , flagA "ddump-spec" (setDumpFlag Opt_D_dump_spec) - , flagA "ddump-prep" (setDumpFlag Opt_D_dump_prep) - , flagA "ddump-stg" (setDumpFlag Opt_D_dump_stg) - , flagA "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) - , flagA "ddump-tc" (setDumpFlag Opt_D_dump_tc) - , flagA "ddump-types" (setDumpFlag Opt_D_dump_types) - , flagA "ddump-rules" (setDumpFlag Opt_D_dump_rules) - , flagA "ddump-cse" (setDumpFlag Opt_D_dump_cse) - , flagA "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) - , flagA "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) - , flagA "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) - , flagA "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) - , flagA "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) - , flagA "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) - , flagA "ddump-splices" (setDumpFlag Opt_D_dump_splices) - , flagA "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) - , flagA "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) - , flagA "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) - , flagA "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) - , flagA "dsource-stats" (setDumpFlag Opt_D_source_stats) - , flagA "dverbose-core2core" (NoArg (do { setVerbosity (Just 2) - ; setVerboseCore2Core })) - , flagA "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) - , flagA "ddump-hi" (setDumpFlag Opt_D_dump_hi) - , flagA "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) - , flagA "ddump-vect" (setDumpFlag Opt_D_dump_vect) - , flagA "ddump-hpc" (setDumpFlag Opt_D_dump_hpc) - , flagA "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) - , flagA "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) - , flagA "ddump-to-file" (setDumpFlag Opt_DumpToFile) - , flagA "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) - , flagA "ddump-rtti" (setDumpFlag Opt_D_dump_rtti) - , flagA "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting)) - , flagA "dstg-lint" (NoArg (setDynFlag Opt_DoStgLinting)) - , flagA "dcmm-lint" (NoArg (setDynFlag Opt_DoCmmLinting)) - , flagA "dasm-lint" (NoArg (setDynFlag Opt_DoAsmLinting)) - , flagA "dshow-passes" (NoArg (do forceRecompile - setVerbosity (Just 2))) - , flagA "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) + , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) + + , Flag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) + , Flag "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm) + , Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) + , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) + , Flag "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe) + , Flag "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills) + , Flag "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc) + , Flag "ddump-cmmz-rewrite" (setDumpFlag Opt_D_dump_cmmz_rewrite) + , Flag "ddump-cmmz-dead" (setDumpFlag Opt_D_dump_cmmz_dead) + , Flag "ddump-cmmz-stub" (setDumpFlag Opt_D_dump_cmmz_stub) + , Flag "ddump-cmmz-sp" (setDumpFlag Opt_D_dump_cmmz_sp) + , Flag "ddump-cmmz-procmap" (setDumpFlag Opt_D_dump_cmmz_procmap) + , Flag "ddump-cmmz-split" (setDumpFlag Opt_D_dump_cmmz_split) + , Flag "ddump-cmmz-lower" (setDumpFlag Opt_D_dump_cmmz_lower) + , Flag "ddump-cmmz-info" (setDumpFlag Opt_D_dump_cmmz_info) + , Flag "ddump-cmmz-cafs" (setDumpFlag Opt_D_dump_cmmz_cafs) + , Flag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) + , Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) + , Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) + , Flag "ddump-asm" (setDumpFlag Opt_D_dump_asm) + , Flag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) + , Flag "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) + , Flag "ddump-asm-coalesce" (setDumpFlag Opt_D_dump_asm_coalesce) + , Flag "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) + , Flag "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) + , Flag "ddump-asm-regalloc-stages" (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , Flag "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) + , Flag "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) + , Flag "ddump-llvm" (NoArg (do setObjTarget HscLlvm + setDumpFlag' Opt_D_dump_llvm)) + , Flag "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) + , Flag "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) + , Flag "ddump-ds" (setDumpFlag Opt_D_dump_ds) + , Flag "ddump-flatC" (setDumpFlag Opt_D_dump_flatC) + , Flag "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) + , Flag "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) + , Flag "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) + , Flag "ddump-rule-rewrites" (setDumpFlag Opt_D_dump_rule_rewrites) + , Flag "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) + , Flag "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) + , Flag "ddump-rn" (setDumpFlag Opt_D_dump_rn) + , Flag "ddump-core-pipeline" (setDumpFlag Opt_D_dump_core_pipeline) + , Flag "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) + , Flag "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations) + , Flag "ddump-simpl-phases" (OptPrefix setDumpSimplPhases) + , Flag "ddump-spec" (setDumpFlag Opt_D_dump_spec) + , Flag "ddump-prep" (setDumpFlag Opt_D_dump_prep) + , Flag "ddump-stg" (setDumpFlag Opt_D_dump_stg) + , Flag "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) + , Flag "ddump-tc" (setDumpFlag Opt_D_dump_tc) + , Flag "ddump-types" (setDumpFlag Opt_D_dump_types) + , Flag "ddump-rules" (setDumpFlag Opt_D_dump_rules) + , Flag "ddump-cse" (setDumpFlag Opt_D_dump_cse) + , Flag "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) + , Flag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) + , Flag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) + , Flag "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) + , Flag "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) + , Flag "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) + , Flag "ddump-splices" (setDumpFlag Opt_D_dump_splices) + , Flag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) + , Flag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) + , Flag "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) + , Flag "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) + , Flag "dsource-stats" (setDumpFlag Opt_D_source_stats) + , Flag "dverbose-core2core" (NoArg (do setVerbosity (Just 2) + setVerboseCore2Core)) + , Flag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) + , Flag "ddump-hi" (setDumpFlag Opt_D_dump_hi) + , Flag "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) + , Flag "ddump-vect" (setDumpFlag Opt_D_dump_vect) + , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_hpc) + , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) + , Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) + , Flag "ddump-to-file" (setDumpFlag Opt_DumpToFile) + , Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) + , Flag "ddump-rtti" (setDumpFlag Opt_D_dump_rtti) + , Flag "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting)) + , Flag "dstg-lint" (NoArg (setDynFlag Opt_DoStgLinting)) + , Flag "dcmm-lint" (NoArg (setDynFlag Opt_DoCmmLinting)) + , Flag "dasm-lint" (NoArg (setDynFlag Opt_DoAsmLinting)) + , Flag "dshow-passes" (NoArg (do forceRecompile + setVerbosity $ Just 2)) + , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) ------ Machine dependant (-m<blah>) stuff --------------------------- - , flagA "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) - , flagA "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) - , flagA "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) - , flagA "msse2" (NoArg (setDynFlag Opt_SSE2)) - , flagA "msse4.2" (NoArg (setDynFlag Opt_SSE4_2)) + , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "msse2" (NoArg (setDynFlag Opt_SSE2)) + , Flag "msse4.2" (NoArg (setDynFlag Opt_SSE4_2)) ------ Warning opts ------------------------------------------------- - , flagA "W" (NoArg (mapM_ setWarningFlag minusWOpts)) - , flagA "Werror" (NoArg (setDynFlag Opt_WarnIsError)) - , flagA "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) - , flagA "Wall" (NoArg (mapM_ setWarningFlag minusWallOpts)) - , flagA "Wnot" (NoArg (do upd (\dfs -> dfs {warningFlags = []}) - deprecate "Use -w instead")) - , flagA "w" (NoArg (upd (\dfs -> dfs {warningFlags = []}))) + , Flag "W" (NoArg (mapM_ setWarningFlag minusWOpts)) + , Flag "Werror" (NoArg (setDynFlag Opt_WarnIsError)) + , Flag "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) + , Flag "Wall" (NoArg (mapM_ setWarningFlag minusWallOpts)) + , Flag "Wnot" (NoArg (do upd (\dfs -> dfs {warningFlags = []}) + deprecate "Use -w instead")) + , Flag "w" (NoArg (upd (\dfs -> dfs {warningFlags = []}))) ------ Plugin flags ------------------------------------------------ - , flagA "fplugin-opt" (hasArg addPluginModuleNameOption) - , flagA "fplugin" (hasArg addPluginModuleName) - + , Flag "fplugin-opt" (hasArg addPluginModuleNameOption) + , Flag "fplugin" (hasArg addPluginModuleName) + ------ Optimisation flags ------------------------------------------ - , flagA "O" (noArgM (setOptLevel 1)) - , flagA "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead" - setOptLevel 0 dflags)) - , flagA "Odph" (noArgM setDPHOpt) - , flagA "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) + , Flag "O" (noArgM (setOptLevel 1)) + , Flag "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead" + setOptLevel 0 dflags)) + , Flag "Odph" (noArgM setDPHOpt) + , Flag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) -- If the number is missing, use 1 - , flagA "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) - , flagA "fmax-simplifier-iterations" (intSuffix (\n d -> d{ maxSimplIterations = n })) - , flagA "fsimpl-tick-factor" (intSuffix (\n d -> d{ simplTickFactor = n })) - , flagA "fspec-constr-threshold" (intSuffix (\n d -> d{ specConstrThreshold = Just n })) - , flagA "fno-spec-constr-threshold" (noArg (\d -> d{ specConstrThreshold = Nothing })) - , flagA "fspec-constr-count" (intSuffix (\n d -> d{ specConstrCount = Just n })) - , flagA "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount = Nothing })) - , flagA "fliberate-case-threshold" (intSuffix (\n d -> d{ liberateCaseThreshold = Just n })) - , flagA "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing })) - , flagA "frule-check" (sepArg (\s d -> d{ ruleCheck = Just s })) - , flagA "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) - , flagA "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) - , flagA "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) - , flagA "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) + , Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) + , Flag "fmax-simplifier-iterations" (intSuffix (\n d -> d{ maxSimplIterations = n })) + , Flag "fsimpl-tick-factor" (intSuffix (\n d -> d{ simplTickFactor = n })) + , Flag "fspec-constr-threshold" (intSuffix (\n d -> d{ specConstrThreshold = Just n })) + , Flag "fno-spec-constr-threshold" (noArg (\d -> d{ specConstrThreshold = Nothing })) + , Flag "fspec-constr-count" (intSuffix (\n d -> d{ specConstrCount = Just n })) + , Flag "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount = Nothing })) + , Flag "fliberate-case-threshold" (intSuffix (\n d -> d{ liberateCaseThreshold = Just n })) + , Flag "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing })) + , Flag "frule-check" (sepArg (\s d -> d{ ruleCheck = Just s })) + , Flag "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) + , Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) + , Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) + , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) ------ Profiling ---------------------------------------------------- -- XXX Should the -f* flags be deprecated? -- They don't seem to be documented - , flagA "fauto-sccs-on-all-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) - , flagA "auto-all" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) - , flagA "no-auto-all" (NoArg (unSetDynFlag Opt_AutoSccsOnAllToplevs)) - , flagA "fauto-sccs-on-exported-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) - , flagA "auto" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) - , flagA "no-auto" (NoArg (unSetDynFlag Opt_AutoSccsOnExportedToplevs)) - , flagA "fauto-sccs-on-individual-cafs" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) - , flagA "caf-all" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) - , flagA "no-caf-all" (NoArg (unSetDynFlag Opt_AutoSccsOnIndividualCafs)) + , Flag "fauto-sccs-on-all-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) + , Flag "auto-all" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) + , Flag "no-auto-all" (NoArg (unSetDynFlag Opt_AutoSccsOnAllToplevs)) + , Flag "fauto-sccs-on-exported-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) + , Flag "auto" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) + , Flag "no-auto" (NoArg (unSetDynFlag Opt_AutoSccsOnExportedToplevs)) + , Flag "fauto-sccs-on-individual-cafs" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) + , Flag "caf-all" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) + , Flag "no-caf-all" (NoArg (unSetDynFlag Opt_AutoSccsOnIndividualCafs)) ------ DPH flags ---------------------------------------------------- - , flagA "fdph-seq" (NoArg (setDPHBackend DPHSeq)) - , flagA "fdph-par" (NoArg (setDPHBackend DPHPar)) - , flagA "fdph-this" (NoArg (setDPHBackend DPHThis)) - , flagA "fdph-none" (NoArg (setDPHBackend DPHNone)) + , Flag "fdph-seq" (NoArg (setDPHBackend DPHSeq)) + , Flag "fdph-par" (NoArg (setDPHBackend DPHPar)) + , Flag "fdph-this" (NoArg (setDPHBackend DPHThis)) + , Flag "fdph-none" (NoArg (setDPHBackend DPHNone)) ------ Compiler flags ----------------------------------------------- - , flagA "fasm" (NoArg (setObjTarget HscAsm)) - , flagA "fvia-c" (NoArg + , Flag "fasm" (NoArg (setObjTarget HscAsm)) + , Flag "fvia-c" (NoArg (addWarn "The -fvia-c flag does nothing; it will be removed in a future GHC release")) - , flagA "fvia-C" (NoArg + , Flag "fvia-C" (NoArg (addWarn "The -fvia-C flag does nothing; it will be removed in a future GHC release")) - , flagA "fllvm" (NoArg (setObjTarget HscLlvm)) - - , flagA "fno-code" (NoArg (do { upd $ \d -> d{ ghcLink=NoLink } - ; setTarget HscNothing })) - , flagA "fbyte-code" (NoArg (setTarget HscInterpreted)) - , flagA "fobject-code" (NoArg (setTarget defaultHscTarget)) - , flagA "fglasgow-exts" (NoArg (enableGlasgowExts >> deprecate "Use individual extensions instead")) - , flagA "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead")) + , Flag "fllvm" (NoArg (setObjTarget HscLlvm)) + + , Flag "fno-code" (NoArg (do upd $ \d -> d{ ghcLink=NoLink } + setTarget HscNothing)) + , Flag "fbyte-code" (NoArg (setTarget HscInterpreted)) + , Flag "fobject-code" (NoArg (setTarget defaultHscTarget)) + , Flag "fglasgow-exts" (NoArg (enableGlasgowExts >> deprecate "Use individual extensions instead")) + , Flag "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead")) + + ------ Safe Haskell flags ------------------------------------------- + , Flag "fpackage-trust" (NoArg (setDynFlag Opt_PackageTrust)) ] ++ map (mkFlag turnOn "f" setDynFlag ) fFlags ++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags @@ -1610,53 +1623,50 @@ dynamic_flags = [ ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlags ++ map (mkFlag turnOn "X" setLanguage) languageFlags ++ map (mkFlag turnOn "X" setSafeHaskell) safeHaskellFlags - ++ [ flagA "XGenerics" (NoArg (deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support.")) - , flagA "XNoGenerics" (NoArg (deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support.")) ] + ++ [ Flag "XGenerics" (NoArg (deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support.")) + , Flag "XNoGenerics" (NoArg (deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support.")) ] package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ ------- Packages ---------------------------------------------------- - -- specifying these to be flagC is redundant since they are actually - -- static flags, but best to do this anyway. - flagC "package-conf" (HasArg extraPkgConf_) - , flagC "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) - , flagC "package-name" (hasArg setPackageName) - , flagC "package-id" (HasArg exposePackageId) - , flagC "package" (HasArg exposePackage) - , flagC "hide-package" (HasArg hidePackage) - , flagC "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) - , flagC "ignore-package" (HasArg ignorePackage) - , flagC "syslib" (HasArg (\s -> do { exposePackage s - ; deprecate "Use -package instead" })) - , flagC "trust" (HasArg trustPackage) - , flagC "distrust" (HasArg distrustPackage) - , flagC "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages)) + Flag "package-conf" (HasArg extraPkgConf_) + , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) + , Flag "package-name" (hasArg setPackageName) + , Flag "package-id" (HasArg exposePackageId) + , Flag "package" (HasArg exposePackage) + , Flag "hide-package" (HasArg hidePackage) + , Flag "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) + , Flag "ignore-package" (HasArg ignorePackage) + , Flag "syslib" (HasArg (\s -> do exposePackage s + deprecate "Use -package instead")) + , Flag "trust" (HasArg trustPackage) + , Flag "distrust" (HasArg distrustPackage) + , Flag "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages)) ] type TurnOnFlag = Bool -- True <=> we are turning the flag on - -- False <=> we are turning the flag off -turnOn :: TurnOnFlag; turnOn = True + -- False <=> we are turning the flag off +turnOn :: TurnOnFlag; turnOn = True turnOff :: TurnOnFlag; turnOff = False type FlagSpec flag - = ( String -- Flag in string form - , FlagSafety + = ( String -- Flag in string form , flag -- Flag in internal form , TurnOnFlag -> DynP ()) -- Extra action to run when the flag is found -- Typically, emit a warning or error mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on -> String -- ^ The flag prefix - -> (flag -> DynP ()) -- ^ What to do when the flag is found - -> FlagSpec flag -- ^ Specification of this particular flag + -> (flag -> DynP ()) -- ^ What to do when the flag is found + -> FlagSpec flag -- ^ Specification of this particular flag -> Flag (CmdLineP DynFlags) -mkFlag turn_on flagPrefix f (name, fsafe, flag, extra_action) - = Flag (flagPrefix ++ name) fsafe (NoArg (f flag >> extra_action turn_on)) +mkFlag turn_on flagPrefix f (name, flag, extra_action) + = Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) deprecatedForExtension :: String -> TurnOnFlag -> DynP () deprecatedForExtension lang turn_on = deprecate ("use -X" ++ flag ++ " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead") - where + where flag | turn_on = lang | otherwise = "No"++lang @@ -1672,134 +1682,134 @@ nop _ = return () -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fWarningFlags :: [FlagSpec WarningFlag] fWarningFlags = [ - ( "warn-dodgy-foreign-imports", AlwaysAllowed, Opt_WarnDodgyForeignImports, nop ), - ( "warn-dodgy-exports", AlwaysAllowed, Opt_WarnDodgyExports, nop ), - ( "warn-dodgy-imports", AlwaysAllowed, Opt_WarnDodgyImports, nop ), - ( "warn-duplicate-exports", AlwaysAllowed, Opt_WarnDuplicateExports, nop ), - ( "warn-hi-shadowing", AlwaysAllowed, Opt_WarnHiShadows, nop ), - ( "warn-implicit-prelude", AlwaysAllowed, Opt_WarnImplicitPrelude, nop ), - ( "warn-incomplete-patterns", AlwaysAllowed, Opt_WarnIncompletePatterns, nop ), - ( "warn-incomplete-uni-patterns", AlwaysAllowed, Opt_WarnIncompleteUniPatterns, nop ), - ( "warn-incomplete-record-updates", AlwaysAllowed, Opt_WarnIncompletePatternsRecUpd, nop ), - ( "warn-missing-fields", AlwaysAllowed, Opt_WarnMissingFields, nop ), - ( "warn-missing-import-lists", AlwaysAllowed, Opt_WarnMissingImportList, nop ), - ( "warn-missing-methods", AlwaysAllowed, Opt_WarnMissingMethods, nop ), - ( "warn-missing-signatures", AlwaysAllowed, Opt_WarnMissingSigs, nop ), - ( "warn-missing-local-sigs", AlwaysAllowed, Opt_WarnMissingLocalSigs, nop ), - ( "warn-name-shadowing", AlwaysAllowed, Opt_WarnNameShadowing, nop ), - ( "warn-overlapping-patterns", AlwaysAllowed, Opt_WarnOverlappingPatterns, nop ), - ( "warn-type-defaults", AlwaysAllowed, Opt_WarnTypeDefaults, nop ), - ( "warn-monomorphism-restriction", AlwaysAllowed, Opt_WarnMonomorphism, nop ), - ( "warn-unused-binds", AlwaysAllowed, Opt_WarnUnusedBinds, nop ), - ( "warn-unused-imports", AlwaysAllowed, Opt_WarnUnusedImports, nop ), - ( "warn-unused-matches", AlwaysAllowed, Opt_WarnUnusedMatches, nop ), - ( "warn-warnings-deprecations", AlwaysAllowed, Opt_WarnWarningsDeprecations, nop ), - ( "warn-deprecations", AlwaysAllowed, Opt_WarnWarningsDeprecations, nop ), - ( "warn-deprecated-flags", AlwaysAllowed, Opt_WarnDeprecatedFlags, nop ), - ( "warn-orphans", AlwaysAllowed, Opt_WarnOrphans, nop ), - ( "warn-identities", AlwaysAllowed, Opt_WarnIdentities, nop ), - ( "warn-auto-orphans", AlwaysAllowed, Opt_WarnAutoOrphans, nop ), - ( "warn-tabs", AlwaysAllowed, Opt_WarnTabs, nop ), - ( "warn-unrecognised-pragmas", AlwaysAllowed, Opt_WarnUnrecognisedPragmas, nop ), - ( "warn-lazy-unlifted-bindings", AlwaysAllowed, Opt_WarnLazyUnliftedBindings, nop), - ( "warn-unused-do-bind", AlwaysAllowed, Opt_WarnUnusedDoBind, nop ), - ( "warn-wrong-do-bind", AlwaysAllowed, Opt_WarnWrongDoBind, nop ), - ( "warn-alternative-layout-rule-transitional", AlwaysAllowed, Opt_WarnAlternativeLayoutRuleTransitional, nop )] + ( "warn-dodgy-foreign-imports", Opt_WarnDodgyForeignImports, nop ), + ( "warn-dodgy-exports", Opt_WarnDodgyExports, nop ), + ( "warn-dodgy-imports", Opt_WarnDodgyImports, nop ), + ( "warn-duplicate-exports", Opt_WarnDuplicateExports, nop ), + ( "warn-hi-shadowing", Opt_WarnHiShadows, nop ), + ( "warn-implicit-prelude", Opt_WarnImplicitPrelude, nop ), + ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns, nop ), + ( "warn-incomplete-uni-patterns", Opt_WarnIncompleteUniPatterns, nop ), + ( "warn-incomplete-record-updates", Opt_WarnIncompletePatternsRecUpd, nop ), + ( "warn-missing-fields", Opt_WarnMissingFields, nop ), + ( "warn-missing-import-lists", Opt_WarnMissingImportList, nop ), + ( "warn-missing-methods", Opt_WarnMissingMethods, nop ), + ( "warn-missing-signatures", Opt_WarnMissingSigs, nop ), + ( "warn-missing-local-sigs", Opt_WarnMissingLocalSigs, nop ), + ( "warn-name-shadowing", Opt_WarnNameShadowing, nop ), + ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns, nop ), + ( "warn-type-defaults", Opt_WarnTypeDefaults, nop ), + ( "warn-monomorphism-restriction", Opt_WarnMonomorphism, nop ), + ( "warn-unused-binds", Opt_WarnUnusedBinds, nop ), + ( "warn-unused-imports", Opt_WarnUnusedImports, nop ), + ( "warn-unused-matches", Opt_WarnUnusedMatches, nop ), + ( "warn-warnings-deprecations", Opt_WarnWarningsDeprecations, nop ), + ( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ), + ( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ), + ( "warn-orphans", Opt_WarnOrphans, nop ), + ( "warn-identities", Opt_WarnIdentities, nop ), + ( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ), + ( "warn-tabs", Opt_WarnTabs, nop ), + ( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ), + ( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings, nop), + ( "warn-unused-do-bind", Opt_WarnUnusedDoBind, nop ), + ( "warn-wrong-do-bind", Opt_WarnWrongDoBind, nop ), + ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop )] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fFlags :: [FlagSpec DynFlag] fFlags = [ - ( "print-explicit-foralls", AlwaysAllowed, Opt_PrintExplicitForalls, nop ), - ( "strictness", AlwaysAllowed, Opt_Strictness, nop ), - ( "specialise", AlwaysAllowed, Opt_Specialise, nop ), - ( "float-in", AlwaysAllowed, Opt_FloatIn, nop ), - ( "static-argument-transformation", AlwaysAllowed, Opt_StaticArgumentTransformation, nop ), - ( "full-laziness", AlwaysAllowed, Opt_FullLaziness, nop ), - ( "liberate-case", AlwaysAllowed, Opt_LiberateCase, nop ), - ( "spec-constr", AlwaysAllowed, Opt_SpecConstr, nop ), - ( "cse", AlwaysAllowed, Opt_CSE, nop ), - ( "ignore-interface-pragmas", AlwaysAllowed, Opt_IgnoreInterfacePragmas, nop ), - ( "omit-interface-pragmas", AlwaysAllowed, Opt_OmitInterfacePragmas, nop ), - ( "expose-all-unfoldings", AlwaysAllowed, Opt_ExposeAllUnfoldings, nop ), - ( "do-lambda-eta-expansion", AlwaysAllowed, Opt_DoLambdaEtaExpansion, nop ), - ( "ignore-asserts", AlwaysAllowed, Opt_IgnoreAsserts, nop ), - ( "do-eta-reduction", AlwaysAllowed, Opt_DoEtaReduction, nop ), - ( "case-merge", AlwaysAllowed, Opt_CaseMerge, nop ), - ( "unbox-strict-fields", AlwaysAllowed, Opt_UnboxStrictFields, nop ), - ( "dicts-cheap", AlwaysAllowed, Opt_DictsCheap, nop ), - ( "excess-precision", AlwaysAllowed, Opt_ExcessPrecision, nop ), - ( "eager-blackholing", AlwaysAllowed, Opt_EagerBlackHoling, nop ), - ( "print-bind-result", AlwaysAllowed, Opt_PrintBindResult, nop ), - ( "force-recomp", AlwaysAllowed, Opt_ForceRecomp, nop ), - ( "hpc-no-auto", AlwaysAllowed, Opt_Hpc_No_Auto, nop ), - ( "rewrite-rules", AlwaysAllowed, Opt_EnableRewriteRules, useInstead "enable-rewrite-rules" ), - ( "enable-rewrite-rules", AlwaysAllowed, Opt_EnableRewriteRules, nop ), - ( "break-on-exception", AlwaysAllowed, Opt_BreakOnException, nop ), - ( "break-on-error", AlwaysAllowed, Opt_BreakOnError, nop ), - ( "print-evld-with-show", AlwaysAllowed, Opt_PrintEvldWithShow, nop ), - ( "print-bind-contents", AlwaysAllowed, Opt_PrintBindContents, nop ), - ( "run-cps", AlwaysAllowed, Opt_RunCPS, nop ), - ( "run-cpsz", AlwaysAllowed, Opt_RunCPSZ, nop ), - ( "new-codegen", AlwaysAllowed, Opt_TryNewCodeGen, nop ), - ( "vectorise", AlwaysAllowed, Opt_Vectorise, nop ), - ( "regs-graph", AlwaysAllowed, Opt_RegsGraph, nop ), - ( "regs-iterative", AlwaysAllowed, Opt_RegsIterative, nop ), - ( "gen-manifest", AlwaysAllowed, Opt_GenManifest, nop ), - ( "embed-manifest", AlwaysAllowed, Opt_EmbedManifest, nop ), - ( "ext-core", AlwaysAllowed, Opt_EmitExternalCore, nop ), - ( "shared-implib", AlwaysAllowed, Opt_SharedImplib, nop ), - ( "ghci-sandbox", AlwaysAllowed, Opt_GhciSandbox, nop ), - ( "ghci-history", AlwaysAllowed, Opt_GhciHistory, nop ), - ( "helpful-errors", AlwaysAllowed, Opt_HelpfulErrors, nop ), - ( "building-cabal-package", AlwaysAllowed, Opt_BuildingCabalPackage, nop ), - ( "implicit-import-qualified", AlwaysAllowed, Opt_ImplicitImportQualified, nop ) + ( "print-explicit-foralls", Opt_PrintExplicitForalls, nop ), + ( "strictness", Opt_Strictness, nop ), + ( "specialise", Opt_Specialise, nop ), + ( "float-in", Opt_FloatIn, nop ), + ( "static-argument-transformation", Opt_StaticArgumentTransformation, nop ), + ( "full-laziness", Opt_FullLaziness, nop ), + ( "liberate-case", Opt_LiberateCase, nop ), + ( "spec-constr", Opt_SpecConstr, nop ), + ( "cse", Opt_CSE, nop ), + ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas, nop ), + ( "omit-interface-pragmas", Opt_OmitInterfacePragmas, nop ), + ( "expose-all-unfoldings", Opt_ExposeAllUnfoldings, nop ), + ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion, nop ), + ( "ignore-asserts", Opt_IgnoreAsserts, nop ), + ( "do-eta-reduction", Opt_DoEtaReduction, nop ), + ( "case-merge", Opt_CaseMerge, nop ), + ( "unbox-strict-fields", Opt_UnboxStrictFields, nop ), + ( "dicts-cheap", Opt_DictsCheap, nop ), + ( "excess-precision", Opt_ExcessPrecision, nop ), + ( "eager-blackholing", Opt_EagerBlackHoling, nop ), + ( "print-bind-result", Opt_PrintBindResult, nop ), + ( "force-recomp", Opt_ForceRecomp, nop ), + ( "hpc-no-auto", Opt_Hpc_No_Auto, nop ), + ( "rewrite-rules", Opt_EnableRewriteRules, useInstead "enable-rewrite-rules" ), + ( "enable-rewrite-rules", Opt_EnableRewriteRules, nop ), + ( "break-on-exception", Opt_BreakOnException, nop ), + ( "break-on-error", Opt_BreakOnError, nop ), + ( "print-evld-with-show", Opt_PrintEvldWithShow, nop ), + ( "print-bind-contents", Opt_PrintBindContents, nop ), + ( "run-cps", Opt_RunCPS, nop ), + ( "run-cpsz", Opt_RunCPSZ, nop ), + ( "new-codegen", Opt_TryNewCodeGen, nop ), + ( "vectorise", Opt_Vectorise, nop ), + ( "regs-graph", Opt_RegsGraph, nop ), + ( "regs-iterative", Opt_RegsIterative, nop ), + ( "gen-manifest", Opt_GenManifest, nop ), + ( "embed-manifest", Opt_EmbedManifest, nop ), + ( "ext-core", Opt_EmitExternalCore, nop ), + ( "shared-implib", Opt_SharedImplib, nop ), + ( "ghci-sandbox", Opt_GhciSandbox, nop ), + ( "ghci-history", Opt_GhciHistory, nop ), + ( "helpful-errors", Opt_HelpfulErrors, nop ), + ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), + ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fLangFlags :: [FlagSpec ExtensionFlag] fLangFlags = [ - ( "th", NeverAllowed, Opt_TemplateHaskell, + ( "th", Opt_TemplateHaskell, deprecatedForExtension "TemplateHaskell" >> checkTemplateHaskellOk ), - ( "fi", RestrictedFunction, Opt_ForeignFunctionInterface, + ( "fi", Opt_ForeignFunctionInterface, deprecatedForExtension "ForeignFunctionInterface" ), - ( "ffi", RestrictedFunction, Opt_ForeignFunctionInterface, + ( "ffi", Opt_ForeignFunctionInterface, deprecatedForExtension "ForeignFunctionInterface" ), - ( "arrows", AlwaysAllowed, Opt_Arrows, + ( "arrows", Opt_Arrows, deprecatedForExtension "Arrows" ), - ( "implicit-prelude", AlwaysAllowed, Opt_ImplicitPrelude, + ( "implicit-prelude", Opt_ImplicitPrelude, deprecatedForExtension "ImplicitPrelude" ), - ( "bang-patterns", AlwaysAllowed, Opt_BangPatterns, + ( "bang-patterns", Opt_BangPatterns, deprecatedForExtension "BangPatterns" ), - ( "monomorphism-restriction", AlwaysAllowed, Opt_MonomorphismRestriction, + ( "monomorphism-restriction", Opt_MonomorphismRestriction, deprecatedForExtension "MonomorphismRestriction" ), - ( "mono-pat-binds", AlwaysAllowed, Opt_MonoPatBinds, + ( "mono-pat-binds", Opt_MonoPatBinds, deprecatedForExtension "MonoPatBinds" ), - ( "extended-default-rules", AlwaysAllowed, Opt_ExtendedDefaultRules, + ( "extended-default-rules", Opt_ExtendedDefaultRules, deprecatedForExtension "ExtendedDefaultRules" ), - ( "implicit-params", AlwaysAllowed, Opt_ImplicitParams, + ( "implicit-params", Opt_ImplicitParams, deprecatedForExtension "ImplicitParams" ), - ( "scoped-type-variables", AlwaysAllowed, Opt_ScopedTypeVariables, + ( "scoped-type-variables", Opt_ScopedTypeVariables, deprecatedForExtension "ScopedTypeVariables" ), - ( "parr", AlwaysAllowed, Opt_ParallelArrays, + ( "parr", Opt_ParallelArrays, deprecatedForExtension "ParallelArrays" ), - ( "PArr", AlwaysAllowed, Opt_ParallelArrays, + ( "PArr", Opt_ParallelArrays, deprecatedForExtension "ParallelArrays" ), - ( "allow-overlapping-instances", RestrictedFunction, Opt_OverlappingInstances, + ( "allow-overlapping-instances", Opt_OverlappingInstances, deprecatedForExtension "OverlappingInstances" ), - ( "allow-undecidable-instances", AlwaysAllowed, Opt_UndecidableInstances, + ( "allow-undecidable-instances", Opt_UndecidableInstances, deprecatedForExtension "UndecidableInstances" ), - ( "allow-incoherent-instances", AlwaysAllowed, Opt_IncoherentInstances, + ( "allow-incoherent-instances", Opt_IncoherentInstances, deprecatedForExtension "IncoherentInstances" ) ] supportedLanguages :: [String] -supportedLanguages = [ name | (name, _, _, _) <- languageFlags ] +supportedLanguages = [ name | (name, _, _) <- languageFlags ] supportedLanguageOverlays :: [String] -supportedLanguageOverlays = [ name | (name, _, _, _) <- safeHaskellFlags ] +supportedLanguageOverlays = [ name | (name, _, _) <- safeHaskellFlags ] supportedExtensions :: [String] -supportedExtensions = [ name' | (name, _, _, _) <- xFlags, name' <- [name, "No" ++ name] ] +supportedExtensions = [ name' | (name, _, _) <- xFlags, name' <- [name, "No" ++ name] ] supportedLanguagesAndExtensions :: [String] supportedLanguagesAndExtensions = @@ -1808,8 +1818,8 @@ supportedLanguagesAndExtensions = -- | These -X<blah> flags cannot be reversed with -XNo<blah> languageFlags :: [FlagSpec Language] languageFlags = [ - ( "Haskell98", AlwaysAllowed, Haskell98, nop ), - ( "Haskell2010", AlwaysAllowed, Haskell2010, nop ) + ( "Haskell98", Haskell98, nop ), + ( "Haskell2010", Haskell2010, nop ) ] -- | These -X<blah> flags cannot be reversed with -XNo<blah> @@ -1817,103 +1827,103 @@ languageFlags = [ -- features can be used. safeHaskellFlags :: [FlagSpec SafeHaskellMode] safeHaskellFlags = [mkF Sf_SafeImports, mkF Sf_Trustworthy, mkF' Sf_Safe] - where mkF flag = (showPpr flag, AlwaysAllowed, flag, nop) - mkF' flag = (showPpr flag, EnablesSafe, flag, nop) + where mkF flag = (showPpr flag, flag, nop) + mkF' flag = (showPpr flag, flag, nop) -- | These -X<blah> flags can all be reversed with -XNo<blah> xFlags :: [FlagSpec ExtensionFlag] xFlags = [ - ( "CPP", AlwaysAllowed, Opt_Cpp, nop ), - ( "PostfixOperators", AlwaysAllowed, Opt_PostfixOperators, nop ), - ( "TupleSections", AlwaysAllowed, Opt_TupleSections, nop ), - ( "PatternGuards", AlwaysAllowed, Opt_PatternGuards, nop ), - ( "UnicodeSyntax", AlwaysAllowed, Opt_UnicodeSyntax, nop ), - ( "MagicHash", AlwaysAllowed, Opt_MagicHash, nop ), - ( "PolymorphicComponents", AlwaysAllowed, Opt_PolymorphicComponents, nop ), - ( "ExistentialQuantification", AlwaysAllowed, Opt_ExistentialQuantification, nop ), - ( "KindSignatures", AlwaysAllowed, Opt_KindSignatures, nop ), - ( "EmptyDataDecls", AlwaysAllowed, Opt_EmptyDataDecls, nop ), - ( "ParallelListComp", AlwaysAllowed, Opt_ParallelListComp, nop ), - ( "TransformListComp", AlwaysAllowed, Opt_TransformListComp, nop ), - ( "MonadComprehensions", AlwaysAllowed, Opt_MonadComprehensions, nop), - ( "ForeignFunctionInterface", RestrictedFunction, Opt_ForeignFunctionInterface, nop ), - ( "UnliftedFFITypes", AlwaysAllowed, Opt_UnliftedFFITypes, nop ), - ( "InterruptibleFFI", AlwaysAllowed, Opt_InterruptibleFFI, nop ), - ( "GHCForeignImportPrim", AlwaysAllowed, Opt_GHCForeignImportPrim, nop ), - ( "LiberalTypeSynonyms", AlwaysAllowed, Opt_LiberalTypeSynonyms, nop ), - ( "Rank2Types", AlwaysAllowed, Opt_Rank2Types, nop ), - ( "RankNTypes", AlwaysAllowed, Opt_RankNTypes, nop ), - ( "ImpredicativeTypes", AlwaysAllowed, Opt_ImpredicativeTypes, nop), - ( "TypeOperators", AlwaysAllowed, Opt_TypeOperators, nop ), - ( "RecursiveDo", AlwaysAllowed, Opt_RecursiveDo, -- Enables 'mdo' + ( "CPP", Opt_Cpp, nop ), + ( "PostfixOperators", Opt_PostfixOperators, nop ), + ( "TupleSections", Opt_TupleSections, nop ), + ( "PatternGuards", Opt_PatternGuards, nop ), + ( "UnicodeSyntax", Opt_UnicodeSyntax, nop ), + ( "MagicHash", Opt_MagicHash, nop ), + ( "PolymorphicComponents", Opt_PolymorphicComponents, nop ), + ( "ExistentialQuantification", Opt_ExistentialQuantification, nop ), + ( "KindSignatures", Opt_KindSignatures, nop ), + ( "EmptyDataDecls", Opt_EmptyDataDecls, nop ), + ( "ParallelListComp", Opt_ParallelListComp, nop ), + ( "TransformListComp", Opt_TransformListComp, nop ), + ( "MonadComprehensions", Opt_MonadComprehensions, nop), + ( "ForeignFunctionInterface", Opt_ForeignFunctionInterface, nop ), + ( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ), + ( "InterruptibleFFI", Opt_InterruptibleFFI, nop ), + ( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ), + ( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms, nop ), + ( "Rank2Types", Opt_Rank2Types, nop ), + ( "RankNTypes", Opt_RankNTypes, nop ), + ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), + ( "TypeOperators", Opt_TypeOperators, nop ), + ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo' deprecatedForExtension "DoRec"), - ( "DoRec", AlwaysAllowed, Opt_DoRec, nop ), -- Enables 'rec' keyword - ( "Arrows", AlwaysAllowed, Opt_Arrows, nop ), - ( "ParallelArrays", AlwaysAllowed, Opt_ParallelArrays, nop ), - ( "TemplateHaskell", NeverAllowed, Opt_TemplateHaskell, checkTemplateHaskellOk ), - ( "QuasiQuotes", AlwaysAllowed, Opt_QuasiQuotes, nop ), - ( "ImplicitPrelude", AlwaysAllowed, Opt_ImplicitPrelude, nop ), - ( "RecordWildCards", AlwaysAllowed, Opt_RecordWildCards, nop ), - ( "NamedFieldPuns", AlwaysAllowed, Opt_RecordPuns, nop ), - ( "RecordPuns", AlwaysAllowed, Opt_RecordPuns, + ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword + ( "Arrows", Opt_Arrows, nop ), + ( "ParallelArrays", Opt_ParallelArrays, nop ), + ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), + ( "QuasiQuotes", Opt_QuasiQuotes, nop ), + ( "ImplicitPrelude", Opt_ImplicitPrelude, nop ), + ( "RecordWildCards", Opt_RecordWildCards, nop ), + ( "NamedFieldPuns", Opt_RecordPuns, nop ), + ( "RecordPuns", Opt_RecordPuns, deprecatedForExtension "NamedFieldPuns" ), - ( "DisambiguateRecordFields", AlwaysAllowed, Opt_DisambiguateRecordFields, nop ), - ( "OverloadedStrings", AlwaysAllowed, Opt_OverloadedStrings, nop ), - ( "GADTs", AlwaysAllowed, Opt_GADTs, nop ), - ( "GADTSyntax", AlwaysAllowed, Opt_GADTSyntax, nop ), - ( "ViewPatterns", AlwaysAllowed, Opt_ViewPatterns, nop ), - ( "TypeFamilies", AlwaysAllowed, Opt_TypeFamilies, nop ), - ( "BangPatterns", AlwaysAllowed, Opt_BangPatterns, nop ), - ( "MonomorphismRestriction", AlwaysAllowed, Opt_MonomorphismRestriction, nop ), - ( "NPlusKPatterns", AlwaysAllowed, Opt_NPlusKPatterns, nop ), - ( "DoAndIfThenElse", AlwaysAllowed, Opt_DoAndIfThenElse, nop ), - ( "RebindableSyntax", AlwaysAllowed, Opt_RebindableSyntax, nop ), - ( "ConstraintKinds", AlwaysAllowed, Opt_ConstraintKinds, nop ), - ( "MonoPatBinds", AlwaysAllowed, Opt_MonoPatBinds, + ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), + ( "OverloadedStrings", Opt_OverloadedStrings, nop ), + ( "GADTs", Opt_GADTs, nop ), + ( "GADTSyntax", Opt_GADTSyntax, nop ), + ( "ViewPatterns", Opt_ViewPatterns, nop ), + ( "TypeFamilies", Opt_TypeFamilies, nop ), + ( "BangPatterns", Opt_BangPatterns, nop ), + ( "MonomorphismRestriction", Opt_MonomorphismRestriction, nop ), + ( "NPlusKPatterns", Opt_NPlusKPatterns, nop ), + ( "DoAndIfThenElse", Opt_DoAndIfThenElse, nop ), + ( "RebindableSyntax", Opt_RebindableSyntax, nop ), + ( "ConstraintKinds", Opt_ConstraintKinds, nop ), + ( "MonoPatBinds", Opt_MonoPatBinds, \ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ), - ( "ExplicitForAll", AlwaysAllowed, Opt_ExplicitForAll, nop ), - ( "AlternativeLayoutRule", AlwaysAllowed, Opt_AlternativeLayoutRule, nop ), - ( "AlternativeLayoutRuleTransitional",AlwaysAllowed, Opt_AlternativeLayoutRuleTransitional, nop ), - ( "DatatypeContexts", AlwaysAllowed, Opt_DatatypeContexts, + ( "ExplicitForAll", Opt_ExplicitForAll, nop ), + ( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, nop ), + ( "AlternativeLayoutRuleTransitional",Opt_AlternativeLayoutRuleTransitional, nop ), + ( "DatatypeContexts", Opt_DatatypeContexts, \ turn_on -> when turn_on $ deprecate "It was widely considered a misfeature, and has been removed from the Haskell language." ), - ( "NondecreasingIndentation", AlwaysAllowed, Opt_NondecreasingIndentation, nop ), - ( "RelaxedLayout", AlwaysAllowed, Opt_RelaxedLayout, nop ), - ( "TraditionalRecordSyntax", AlwaysAllowed, Opt_TraditionalRecordSyntax, nop ), - ( "MonoLocalBinds", AlwaysAllowed, Opt_MonoLocalBinds, nop ), - ( "RelaxedPolyRec", AlwaysAllowed, Opt_RelaxedPolyRec, - \ turn_on -> if not turn_on + ( "NondecreasingIndentation", Opt_NondecreasingIndentation, nop ), + ( "RelaxedLayout", Opt_RelaxedLayout, nop ), + ( "TraditionalRecordSyntax", Opt_TraditionalRecordSyntax, nop ), + ( "MonoLocalBinds", Opt_MonoLocalBinds, nop ), + ( "RelaxedPolyRec", Opt_RelaxedPolyRec, + \ turn_on -> if not turn_on then deprecate "You can't turn off RelaxedPolyRec any more" else return () ), - ( "ExtendedDefaultRules", AlwaysAllowed, Opt_ExtendedDefaultRules, nop ), - ( "ImplicitParams", AlwaysAllowed, Opt_ImplicitParams, nop ), - ( "ScopedTypeVariables", AlwaysAllowed, Opt_ScopedTypeVariables, nop ), + ( "ExtendedDefaultRules", Opt_ExtendedDefaultRules, nop ), + ( "ImplicitParams", Opt_ImplicitParams, nop ), + ( "ScopedTypeVariables", Opt_ScopedTypeVariables, nop ), - ( "PatternSignatures", AlwaysAllowed, Opt_ScopedTypeVariables, + ( "PatternSignatures", Opt_ScopedTypeVariables, deprecatedForExtension "ScopedTypeVariables" ), - ( "UnboxedTuples", AlwaysAllowed, Opt_UnboxedTuples, nop ), - ( "StandaloneDeriving", AlwaysAllowed, Opt_StandaloneDeriving, nop ), - ( "DeriveDataTypeable", AlwaysAllowed, Opt_DeriveDataTypeable, nop ), - ( "DeriveFunctor", AlwaysAllowed, Opt_DeriveFunctor, nop ), - ( "DeriveTraversable", AlwaysAllowed, Opt_DeriveTraversable, nop ), - ( "DeriveFoldable", AlwaysAllowed, Opt_DeriveFoldable, nop ), - ( "DeriveGeneric", AlwaysAllowed, Opt_DeriveGeneric, nop ), - ( "DefaultSignatures", AlwaysAllowed, Opt_DefaultSignatures, nop ), - ( "TypeSynonymInstances", AlwaysAllowed, Opt_TypeSynonymInstances, nop ), - ( "FlexibleContexts", AlwaysAllowed, Opt_FlexibleContexts, nop ), - ( "FlexibleInstances", AlwaysAllowed, Opt_FlexibleInstances, nop ), - ( "ConstrainedClassMethods", AlwaysAllowed, Opt_ConstrainedClassMethods, nop ), - ( "MultiParamTypeClasses", AlwaysAllowed, Opt_MultiParamTypeClasses, nop ), - ( "FunctionalDependencies", AlwaysAllowed, Opt_FunctionalDependencies, nop ), - ( "GeneralizedNewtypeDeriving", AlwaysAllowed, Opt_GeneralizedNewtypeDeriving, nop ), - ( "OverlappingInstances", RestrictedFunction, Opt_OverlappingInstances, nop ), - ( "UndecidableInstances", AlwaysAllowed, Opt_UndecidableInstances, nop ), - ( "IncoherentInstances", AlwaysAllowed, Opt_IncoherentInstances, nop ), - ( "PackageImports", AlwaysAllowed, Opt_PackageImports, nop ) + ( "UnboxedTuples", Opt_UnboxedTuples, nop ), + ( "StandaloneDeriving", Opt_StandaloneDeriving, nop ), + ( "DeriveDataTypeable", Opt_DeriveDataTypeable, nop ), + ( "DeriveFunctor", Opt_DeriveFunctor, nop ), + ( "DeriveTraversable", Opt_DeriveTraversable, nop ), + ( "DeriveFoldable", Opt_DeriveFoldable, nop ), + ( "DeriveGeneric", Opt_DeriveGeneric, nop ), + ( "DefaultSignatures", Opt_DefaultSignatures, nop ), + ( "TypeSynonymInstances", Opt_TypeSynonymInstances, nop ), + ( "FlexibleContexts", Opt_FlexibleContexts, nop ), + ( "FlexibleInstances", Opt_FlexibleInstances, nop ), + ( "ConstrainedClassMethods", Opt_ConstrainedClassMethods, nop ), + ( "MultiParamTypeClasses", Opt_MultiParamTypeClasses, nop ), + ( "FunctionalDependencies", Opt_FunctionalDependencies, nop ), + ( "GeneralizedNewtypeDeriving", Opt_GeneralizedNewtypeDeriving, setGenDeriving ), + ( "OverlappingInstances", Opt_OverlappingInstances, nop ), + ( "UndecidableInstances", Opt_UndecidableInstances, nop ), + ( "IncoherentInstances", Opt_IncoherentInstances, nop ), + ( "PackageImports", Opt_PackageImports, nop ) ] defaultFlags :: [DynFlag] -defaultFlags +defaultFlags = [ Opt_AutoLinkPackages, Opt_ReadUserPackageConf, @@ -1952,16 +1962,16 @@ impliedFlags , (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds) , (Opt_TypeFamilies, turnOn, Opt_KindSignatures) -- Type families use kind signatures - -- all over the place + -- all over the place , (Opt_ImpredicativeTypes, turnOn, Opt_RankNTypes) - -- Record wild-cards implies field disambiguation - -- Otherwise if you write (C {..}) you may well get - -- stuff like " 'a' not in scope ", which is a bit silly - -- if the compiler has just filled in field 'a' of constructor 'C' + -- Record wild-cards implies field disambiguation + -- Otherwise if you write (C {..}) you may well get + -- stuff like " 'a' not in scope ", which is a bit silly + -- if the compiler has just filled in field 'a' of constructor 'C' , (Opt_RecordWildCards, turnOn, Opt_DisambiguateRecordFields) - + , (Opt_ParallelArrays, turnOn, Opt_ParallelListComp) ] @@ -2095,13 +2105,17 @@ rtsIsProfiled :: Bool rtsIsProfiled = unsafePerformIO rtsIsProfiledIO /= 0 #endif +setGenDeriving :: Bool -> DynP () +setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) +setGenDeriving False = return () + checkTemplateHaskellOk :: Bool -> DynP () #ifdef GHCI checkTemplateHaskellOk turn_on | turn_on && rtsIsProfiled = addErr "You can't use Template Haskell with a profiled compiler" | otherwise - = return () + = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) #else -- In stage 1 we don't know that the RTS has rts_isProfiled, -- so we simply say "ok". It doesn't matter because TH isn't @@ -2110,9 +2124,9 @@ checkTemplateHaskellOk _ = return () #endif {- ********************************************************************** -%* * - DynFlags constructors -%* * +%* * + DynFlags constructors +%* * %********************************************************************* -} type DynP = EwM (CmdLineP DynFlags) @@ -2140,8 +2154,8 @@ hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) hasArg fn = HasArg (upd . fn) hasArgDF :: (String -> DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynFlags) -hasArgDF fn deprec = HasArg (\s -> do { upd (fn s) - ; deprecate deprec }) +hasArgDF fn deprec = HasArg (\s -> do upd (fn s) + deprecate deprec) sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) sepArg fn = SepArg (upd . fn) @@ -2168,8 +2182,8 @@ unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) -------------------------- setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP () -setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f) - ; sequence_ deps } +setExtensionFlag f = do upd (\dfs -> xopt_set dfs f) + sequence_ deps where deps = [ if turn_on then setExtensionFlag d else unSetExtensionFlag d @@ -2189,28 +2203,28 @@ alterSettings f dflags = dflags { settings = f (settings dflags) } -------------------------- setDumpFlag' :: DynFlag -> DynP () setDumpFlag' dump_flag - = do { setDynFlag dump_flag - ; when want_recomp forceRecompile } + = do setDynFlag dump_flag + when want_recomp forceRecompile where - -- Certain dumpy-things are really interested in what's going + -- Certain dumpy-things are really interested in what's going -- on during recompilation checking, so in those cases we -- don't want to turn it off. want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, - Opt_D_dump_hi_diffs] + Opt_D_dump_hi_diffs] forceRecompile :: DynP () --- Whenver we -ddump, force recompilation (by switching off the --- recompilation checker), else you don't see the dump! However, +-- Whenver we -ddump, force recompilation (by switching off the +-- recompilation checker), else you don't see the dump! However, -- don't switch it off in --make mode, else *everything* gets -- recompiled which probably isn't what you want -forceRecompile = do { dfs <- liftEwM getCmdLineState - ; when (force_recomp dfs) (setDynFlag Opt_ForceRecomp) } +forceRecompile = do dfs <- liftEwM getCmdLineState + when (force_recomp dfs) (setDynFlag Opt_ForceRecomp) where - force_recomp dfs = isOneShot (ghcMode dfs) + force_recomp dfs = isOneShot (ghcMode dfs) setVerboseCore2Core :: DynP () setVerboseCore2Core = do forceRecompile - setDynFlag Opt_D_verbose_core2core + setDynFlag Opt_D_verbose_core2core upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing }) setDumpSimplPhases :: String -> DynP () @@ -2323,7 +2337,7 @@ setDPHBackend backend = upd $ \dflags -> dflags { dphBackend = backend } -- Query the DPH backend package to be used by the vectoriser and desugaring of DPH syntax. -- dphPackageMaybe :: DynFlags -> Maybe PackageId -dphPackageMaybe dflags +dphPackageMaybe dflags = case dphBackend dflags of DPHPar -> Just dphParPackageId DPHSeq -> Just dphSeqPackageId diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 48cca7bc1f..b8874b1a9f 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -890,7 +890,7 @@ checkSafeImports dflags hsc_env tcg_env = do imps <- mapM condense imports' pkgs <- mapM checkSafe imps - checkPkgTrust pkg_reqs + when (packageTrustOn dflags) $ checkPkgTrust pkg_reqs -- add in trusted package requirements for this module let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs } @@ -936,7 +936,9 @@ checkSafeImports dflags hsc_env tcg_env -- modules in the home package are trusted but otherwise -- we check the package trust flag. packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool - packageTrusted Sf_Safe False _ = True + packageTrusted _ _ _ + | not (packageTrustOn dflags) = True + packageTrusted Sf_Safe False _ = True packageTrusted _ _ m | isHomePkg m = True | otherwise = trusted $ getPackageDetails (pkgState dflags) diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index c63f070608..1db5ef63e0 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -50,7 +50,7 @@ parseStaticFlags args = do ready <- readIORef v_opt_C_ready when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession") - (leftover, errs, warns1) <- processArgs static_flags args CmdLineOnly True + (leftover, errs, warns1) <- processArgs static_flags args when (not (null errs)) $ ghcError $ errorsToGhcException errs -- deal with the way flags: the way (eg. prof) gives rise to @@ -60,10 +60,10 @@ parseStaticFlags args = do -- if we're unregisterised, add some more flags let unreg_flags | cGhcUnregisterised == "YES" = unregFlags - | otherwise = [] + | otherwise = [] (more_leftover, errs, warns2) <- - processArgs static_flags (unreg_flags ++ way_flags') CmdLineOnly True + processArgs static_flags (unreg_flags ++ way_flags') -- see sanity code in staticOpts writeIORef v_opt_C_ready True @@ -77,7 +77,7 @@ parseStaticFlags args = do | otherwise = [] -- HACK: -fexcess-precision is both a static and a dynamic flag. If - -- the static flag parser has slurped it, we must return it as a + -- the static flag parser has slurped it, we must return it as a -- leftover too. ToDo: make -fexcess-precision dynamic only. let excess_prec | opt_SimplExcessPrecision = map (mkGeneralLocated "in excess_prec") @@ -96,7 +96,7 @@ static_flags :: [Flag IO] -- -- The common (PassFlag addOpt) action puts the static flag into the bunch of -- things that are searched up by the top-level definitions like --- opt_foo = lookUp (fsLit "-dfoo") +-- opt_foo = lookUp (fsLit "-dfoo") -- Note that ordering is important in the following list: any flag which -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override @@ -104,65 +104,65 @@ static_flags :: [Flag IO] static_flags = [ ------- GHCi ------------------------------------------------------- - flagC "ignore-dot-ghci" (PassFlag addOpt) - , flagC "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) + Flag "ignore-dot-ghci" (PassFlag addOpt) + , Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) ------- ways -------------------------------------------------------- - , flagC "prof" (NoArg (addWay WayProf)) - , flagC "eventlog" (NoArg (addWay WayEventLog)) - , flagC "parallel" (NoArg (addWay WayPar)) - , flagC "gransim" (NoArg (addWay WayGran)) - , flagC "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead")) - , flagC "debug" (NoArg (addWay WayDebug)) - , flagC "ndp" (NoArg (addWay WayNDP)) - , flagC "threaded" (NoArg (addWay WayThreaded)) - - , flagC "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug)) + , Flag "prof" (NoArg (addWay WayProf)) + , Flag "eventlog" (NoArg (addWay WayEventLog)) + , Flag "parallel" (NoArg (addWay WayPar)) + , Flag "gransim" (NoArg (addWay WayGran)) + , Flag "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead")) + , Flag "debug" (NoArg (addWay WayDebug)) + , Flag "ndp" (NoArg (addWay WayNDP)) + , Flag "threaded" (NoArg (addWay WayThreaded)) + + , Flag "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug)) -- -ticky enables ticky-ticky code generation, and also implies -debug which -- is required to get the RTS ticky support. ------ Debugging ---------------------------------------------------- - , flagC "dppr-debug" (PassFlag addOpt) - , flagC "dppr-cols" (AnySuffix addOpt) - , flagC "dppr-user-length" (AnySuffix addOpt) - , flagC "dppr-case-as-let" (PassFlag addOpt) - , flagC "dsuppress-all" (PassFlag addOpt) - , flagC "dsuppress-uniques" (PassFlag addOpt) - , flagC "dsuppress-coercions" (PassFlag addOpt) - , flagC "dsuppress-module-prefixes" (PassFlag addOpt) - , flagC "dsuppress-type-applications" (PassFlag addOpt) - , flagC "dsuppress-idinfo" (PassFlag addOpt) - , flagC "dsuppress-type-signatures" (PassFlag addOpt) - , flagC "dopt-fuel" (AnySuffix addOpt) - , flagC "dtrace-level" (AnySuffix addOpt) - , flagC "dno-debug-output" (PassFlag addOpt) - , flagC "dstub-dead-values" (PassFlag addOpt) + , Flag "dppr-debug" (PassFlag addOpt) + , Flag "dppr-cols" (AnySuffix addOpt) + , Flag "dppr-user-length" (AnySuffix addOpt) + , Flag "dppr-case-as-let" (PassFlag addOpt) + , Flag "dsuppress-all" (PassFlag addOpt) + , Flag "dsuppress-uniques" (PassFlag addOpt) + , Flag "dsuppress-coercions" (PassFlag addOpt) + , Flag "dsuppress-module-prefixes" (PassFlag addOpt) + , Flag "dsuppress-type-applications" (PassFlag addOpt) + , Flag "dsuppress-idinfo" (PassFlag addOpt) + , Flag "dsuppress-type-signatures" (PassFlag addOpt) + , Flag "dopt-fuel" (AnySuffix addOpt) + , Flag "dtrace-level" (AnySuffix addOpt) + , Flag "dno-debug-output" (PassFlag addOpt) + , Flag "dstub-dead-values" (PassFlag addOpt) -- rest of the debugging flags are dynamic ----- Linker -------------------------------------------------------- - , flagC "static" (PassFlag addOpt) - , flagC "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn)) + , Flag "static" (PassFlag addOpt) + , Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn)) -- ignored for compat w/ gcc: - , flagC "rdynamic" (NoArg (return ())) + , Flag "rdynamic" (NoArg (return ())) ----- RTS opts ------------------------------------------------------ - , flagC "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s))))) - - , flagC "Rghc-timing" (NoArg (liftEwM enableTimingStats)) + , Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s))))) + + , Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats)) ------ Compiler flags ----------------------------------------------- -- -fPIC requires extra checking: only the NCG supports it. -- See also DynFlags.parseDynamicFlags. - , flagC "fPIC" (PassFlag setPIC) + , Flag "fPIC" (PassFlag setPIC) -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline - , flagC "fno-" + , Flag "fno-" (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s))) - + -- Pass all remaining "-f<blah>" options to hsc - , flagC "f" (AnySuffixPred isStaticFlag addOpt) + , Flag "f" (AnySuffixPred isStaticFlag addOpt) ] setPIC :: String -> StaticP () diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index d225e39743..37b500896b 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -24,7 +24,7 @@ module StaticFlags ( opt_PprCols, opt_PprCaseAsLet, opt_PprStyle_Debug, opt_TraceLevel, - opt_NoDebugOutput, + opt_NoDebugOutput, -- Suppressing boring aspects of core dumps opt_SuppressAll, @@ -85,7 +85,7 @@ module StaticFlags ( -- For the parser addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready, - + -- Saving/restoring globals saveStaticFlagGlobals, restoreStaticFlagGlobals ) where @@ -119,7 +119,7 @@ addWay = consIORef v_Ways . lkupWay removeOpt :: String -> IO () removeOpt f = do fs <- readIORef v_opt_C - writeIORef v_opt_C $! filter (/= f) fs + writeIORef v_opt_C $! filter (/= f) fs lookUp :: FastString -> Bool lookup_def_int :: String -> Int -> Int @@ -147,14 +147,14 @@ packed_static_opts :: [FastString] packed_static_opts = map mkFastString staticFlags lookUp sw = sw `elem` packed_static_opts - --- (lookup_str "foo") looks for the flag -foo=X or -fooX, + +-- (lookup_str "foo") looks for the flag -foo=X or -fooX, -- and returns the string X -lookup_str sw +lookup_str sw = case firstJusts (map (stripPrefix sw) staticFlags) of Just ('=' : str) -> Just str Just str -> Just str - Nothing -> Nothing + Nothing -> Nothing lookup_all_str sw = map f $ catMaybes (map (stripPrefix sw) staticFlags) where f ('=' : str) = str @@ -198,7 +198,7 @@ unpacked_opts = opt_IgnoreDotGhci :: Bool opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci") - + opt_GhciScripts :: [String] opt_GhciScripts = lookup_all_str "-ghci-script" @@ -207,13 +207,13 @@ opt_GhciScripts = lookup_all_str "-ghci-script" -- Except for uniques, as some simplifier phases introduce new varibles that -- have otherwise identical names. opt_SuppressAll :: Bool -opt_SuppressAll +opt_SuppressAll = lookUp (fsLit "-dsuppress-all") -- | Suppress all coercions, them replacing with '...' opt_SuppressCoercions :: Bool opt_SuppressCoercions - = lookUp (fsLit "-dsuppress-all") + = lookUp (fsLit "-dsuppress-all") || lookUp (fsLit "-dsuppress-coercions") -- | Suppress module id prefixes on variables. @@ -230,7 +230,7 @@ opt_SuppressTypeApplications -- | Suppress info such as arity and unfoldings on identifiers. opt_SuppressIdInfo :: Bool -opt_SuppressIdInfo +opt_SuppressIdInfo = lookUp (fsLit "-dsuppress-all") || lookUp (fsLit "-dsuppress-idinfo") @@ -254,10 +254,10 @@ opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let") -- | Set the maximum width of the dumps -- If GHC's command line options are bad then the options parser uses the -- pretty printer display the error message. In this case the staticFlags --- won't be initialized yet, so we must check for this case explicitly +-- won't be initialized yet, so we must check for this case explicitly -- and return the default value. opt_PprCols :: Int -opt_PprCols +opt_PprCols = unsafePerformIO $ do ready <- readIORef v_opt_C_ready if (not ready) @@ -287,7 +287,7 @@ opt_SccProfilingOn = lookUp (fsLit "-fscc-profiling") -- Hpc opts opt_Hpc :: Bool -opt_Hpc = lookUp (fsLit "-fhpc") +opt_Hpc = lookUp (fsLit "-fhpc") -- language opts opt_DictsStrict :: Bool @@ -369,7 +369,7 @@ opt_Unregisterised = lookUp (fsLit "-funregisterised") -- Derived, not a real option. Determines whether we will be compiling -- info tables that reside just before the entry code, or with an --- indirection to the entry code. See TABLES_NEXT_TO_CODE in +-- indirection to the entry code. See TABLES_NEXT_TO_CODE in -- includes/rts/storage/InfoTables.h. tablesNextToCode :: Bool tablesNextToCode = not opt_Unregisterised @@ -417,7 +417,7 @@ data WayName GLOBAL_VAR(v_Ways, [] ,[Way]) allowed_combination :: [WayName] -> Bool -allowed_combination way = and [ x `allowedWith` y +allowed_combination way = and [ x `allowedWith` y | x <- way, y <- way, x < y ] where -- Note ordering in these tests: the left argument is @@ -448,7 +448,7 @@ getWayFlags = do if not (allowed_combination (map wayName ways)) then ghcError (CmdLineError $ "combination not supported: " ++ - foldr1 (\a b -> a ++ '/':b) + foldr1 (\a b -> a ++ '/':b) (map wayDesc ways)) else return (concatMap wayOpts ways) @@ -457,13 +457,13 @@ mkBuildTag :: [Way] -> String mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) lkupWay :: WayName -> Way -lkupWay w = +lkupWay w = case listToMaybe (filter ((==) w . wayName) way_details) of Nothing -> error "findBuildTag" Just details -> details isRTSWay :: WayName -> Bool -isRTSWay = wayRTSOnly . lkupWay +isRTSWay = wayRTSOnly . lkupWay data Way = Way { wayName :: WayName, @@ -496,10 +496,10 @@ way_details = Way WayDyn "dyn" False "Dynamic" [ "-DDYNAMIC" - , "-optc-DDYNAMIC" + , "-optc-DDYNAMIC" #if defined(mingw32_TARGET_OS) -- On Windows, code that is to be linked into a dynamic library must be compiled - -- with -fPIC. Labels not in the current package are assumed to be in a DLL + -- with -fPIC. Labels not in the current package are assumed to be in a DLL -- different from the current one. , "-fPIC" #elif defined(openbsd_TARGET_OS) @@ -518,7 +518,7 @@ way_details = [ "-DTRACING" , "-optc-DTRACING" ], - Way WayPar "mp" False "Parallel" + Way WayPar "mp" False "Parallel" [ "-fparallel" , "-D__PARALLEL_HASKELL__" , "-optc-DPAR" @@ -529,7 +529,7 @@ way_details = , "-optl-lgpvm3" ], -- at the moment we only change the RTS and could share compiler and libs! - Way WayPar "mt" False "Parallel ticky profiling" + Way WayPar "mt" False "Parallel ticky profiling" [ "-fparallel" , "-D__PARALLEL_HASKELL__" , "-optc-DPAR" @@ -540,7 +540,7 @@ way_details = , "-optl-lpvm3" , "-optl-lgpvm3" ], - Way WayPar "md" False "Distributed" + Way WayPar "md" False "Distributed" [ "-fparallel" , "-D__PARALLEL_HASKELL__" , "-D__DISTRIBUTED_HASKELL__" @@ -580,3 +580,4 @@ restoreStaticFlagGlobals (c_ready, c, ways) = do writeIORef v_opt_C_ready c_ready writeIORef v_opt_C c writeIORef v_Ways ways + diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 5075075777..d5915dd165 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -12,70 +12,70 @@ import DynFlags import CoreSyn import CoreSubst import HscTypes -import CSE ( cseProgram ) -import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, - extendRuleBaseList, ruleCheckProgram, addSpecInfo, ) -import PprCore ( pprCoreBindings, pprCoreExpr ) -import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) +import CSE ( cseProgram ) +import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, + extendRuleBaseList, ruleCheckProgram, addSpecInfo, ) +import PprCore ( pprCoreBindings, pprCoreExpr ) +import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo -import CoreUtils ( coreBindsSize, exprSize ) -import Simplify ( simplTopBinds, simplExpr ) -import SimplUtils ( simplEnvForGHCi, activeRule ) +import CoreUtils ( coreBindsSize, exprSize ) +import Simplify ( simplTopBinds, simplExpr ) +import SimplUtils ( simplEnvForGHCi, activeRule ) import SimplEnv import SimplMonad import CoreMonad -import qualified ErrUtils as Err -import FloatIn ( floatInwards ) -import FloatOut ( floatOutwards ) +import qualified ErrUtils as Err +import FloatIn ( floatInwards ) +import FloatOut ( floatOutwards ) import FamInstEnv import Id import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma ) import VarSet import VarEnv -import LiberateCase ( liberateCase ) -import SAT ( doStaticArgs ) -import Specialise ( specProgram) -import SpecConstr ( specConstrProgram) -import DmdAnal ( dmdAnalPgm ) -import WorkWrap ( wwTopBinds ) +import LiberateCase ( liberateCase ) +import SAT ( doStaticArgs ) +import Specialise ( specProgram) +import SpecConstr ( specConstrProgram) +import DmdAnal ( dmdAnalPgm ) +import WorkWrap ( wwTopBinds ) import Vectorise ( vectorise ) import FastString import Util -import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) +import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import Outputable import Control.Monad #ifdef GHCI -import Type ( mkTyConTy ) -import RdrName ( mkRdrQual ) -import OccName ( mkVarOcc ) -import PrelNames ( pluginTyConName ) +import Type ( mkTyConTy ) +import RdrName ( mkRdrQual ) +import OccName ( mkVarOcc ) +import PrelNames ( pluginTyConName ) import DynamicLoading ( forceLoadTyCon, lookupRdrNameInModule, getValueSafely ) -import Module ( ModuleName ) +import Module ( ModuleName ) import Panic #endif \end{code} %************************************************************************ -%* * +%* * \subsection{The driver for the simplifier} -%* * +%* * %************************************************************************ \begin{code} core2core :: HscEnv -> ModGuts -> IO ModGuts -core2core hsc_env guts +core2core hsc_env guts = do { us <- mkSplitUniqSupply 's' - -- make sure all plugins are loaded + -- make sure all plugins are loaded ; let builtin_passes = getCoreToDo dflags - ; + ; ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ do { all_passes <- addPluginPasses dflags builtin_passes ; runCorePasses all_passes guts } -{-- +{-- ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline "Plugin information" "" -- TODO FIXME: dump plugin info --} @@ -98,9 +98,9 @@ core2core hsc_env guts %************************************************************************ -%* * +%* * Generating the main optimisation pipeline -%* * +%* * %************************************************************************ \begin{code} @@ -112,10 +112,10 @@ getCoreToDo dflags phases = simplPhases dflags max_iter = maxSimplIterations dflags rule_check = ruleCheck dflags - strictness = dopt Opt_Strictness dflags - full_laziness = dopt Opt_FullLaziness dflags - do_specialise = dopt Opt_Specialise dflags - do_float_in = dopt Opt_FloatIn dflags + strictness = dopt Opt_Strictness dflags + full_laziness = dopt Opt_FullLaziness dflags + do_specialise = dopt Opt_Specialise dflags + do_float_in = dopt Opt_FloatIn dflags cse = dopt Opt_CSE dflags spec_constr = dopt Opt_SpecConstr dflags liberate_case = dopt Opt_LiberateCase dflags @@ -144,14 +144,14 @@ getCoreToDo dflags , maybe_rule_check (Phase phase) ] - -- Vectorisation can introduce a fair few common sub expressions involving + -- Vectorisation can introduce a fair few common sub expressions involving -- DPH primitives. For example, see the Reverse test from dph-examples. -- We need to eliminate these common sub expressions before their definitions - -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings, + -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings, -- so we also run simpl_gently to inline them. ++ (if dopt Opt_Vectorise dflags && phase == 3 - then [CoreCSE, simpl_gently] - else []) + then [CoreCSE, simpl_gently] + else []) vectorisation = runWhen (dopt Opt_Vectorise dflags) $ @@ -210,16 +210,16 @@ getCoreToDo dflags floatOutLambdas = Just 0, floatOutConstants = True, floatOutPartialApplications = False }, - -- Was: gentleFloatOutSwitches + -- Was: gentleFloatOutSwitches -- - -- I have no idea why, but not floating constants to - -- top level is very bad in some cases. + -- I have no idea why, but not floating constants to + -- top level is very bad in some cases. -- - -- Notably: p_ident in spectral/rewrite - -- Changing from "gentle" to "constantsOnly" - -- improved rewrite's allocation by 19%, and - -- made 0.0% difference to any other nofib - -- benchmark + -- Notably: p_ident in spectral/rewrite + -- Changing from "gentle" to "constantsOnly" + -- improved rewrite's allocation by 19%, and + -- made 0.0% difference to any other nofib + -- benchmark -- -- Not doing floatOutPartialApplications yet, we'll do -- that later on when we've had a chance to get more @@ -298,13 +298,13 @@ addPluginPasses :: DynFlags -> [CoreToDo] -> CoreM [CoreToDo] addPluginPasses _ builtin_passes = return builtin_passes #else addPluginPasses dflags builtin_passes - = do { hsc_env <- getHscEnv + = do { hsc_env <- getHscEnv ; named_plugins <- liftIO (loadPlugins hsc_env) ; foldM query_plug builtin_passes named_plugins } where - query_plug todos (mod_nm, plug) + query_plug todos (mod_nm, plug) = installCoreToDos plug options todos - where + where options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags , opt_mod_nm == mod_nm ] @@ -319,17 +319,17 @@ loadPlugin hsc_env mod_name = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin") ; mb_name <- lookupRdrNameInModule hsc_env mod_name plugin_rdr_name ; case mb_name of { - Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep + Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep [ ptext (sLit "The module"), ppr mod_name , ptext (sLit "did not export the plugin name") , ppr plugin_rdr_name ]) ; - Just name -> + Just name -> do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) ; case mb_plugin of Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep - [ ptext (sLit "The value"), ppr name + [ ptext (sLit "The value"), ppr name , ptext (sLit "did not have the type") , ppr pluginTyConName, ptext (sLit "as required")]) Just plugin -> return plugin } } } @@ -337,31 +337,31 @@ loadPlugin hsc_env mod_name \end{code} %************************************************************************ -%* * +%* * The CoreToDo interpreter -%* * +%* * %************************************************************************ \begin{code} runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts -runCorePasses passes guts +runCorePasses passes guts = foldM do_pass guts passes where do_pass guts CoreDoNothing = return guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts - do_pass guts pass + do_pass guts pass = do { dflags <- getDynFlags - ; liftIO $ showPass dflags pass - ; guts' <- doCorePass pass guts - ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts') - ; return guts' } + ; liftIO $ showPass dflags pass + ; guts' <- doCorePass pass guts + ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts') + ; return guts' } doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} simplifyPgm pass -doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} - doPass cseProgram +doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} + doPass cseProgram doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} doPassD liberateCase @@ -403,9 +403,9 @@ doCorePass pass = pprPanic "doCorePass" (ppr pass) \end{code} %************************************************************************ -%* * +%* * \subsection{Core pass combinators} -%* * +%* * %************************************************************************ \begin{code} @@ -459,43 +459,43 @@ observe do_pass = doPassM $ \binds -> do %************************************************************************ -%* * - Gentle simplification -%* * +%* * + Gentle simplification +%* * %************************************************************************ \begin{code} simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do - -> CoreExpr - -> IO CoreExpr + -> CoreExpr + -> IO CoreExpr -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt -- -- Also used by Template Haskell simplifyExpr dflags expr - = do { - ; Err.showPass dflags "Simplify" + = do { + ; Err.showPass dflags "Simplify" - ; us <- mkSplitUniqSupply 's' + ; us <- mkSplitUniqSupply 's' - ; let sz = exprSize expr + ; let sz = exprSize expr (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $ - simplExprGently (simplEnvForGHCi dflags) expr + simplExprGently (simplEnvForGHCi dflags) expr - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" - (pprCoreExpr expr') + ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" + (pprCoreExpr expr') - ; return expr' - } + ; return expr' + } simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr --- Simplifies an expression --- does occurrence analysis, then simplification --- and repeats (twice currently) because one pass --- alone leaves tons of crud. +-- Simplifies an expression +-- does occurrence analysis, then simplification +-- and repeats (twice currently) because one pass +-- alone leaves tons of crud. -- Used (a) for user expressions typed in at the interactive prompt --- (b) the LHS and RHS of a RULE --- (c) Template Haskell splices +-- (b) the LHS and RHS of a RULE +-- (c) Template Haskell splices -- -- The name 'Gently' suggests that the SimplifierMode is SimplGently, -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't @@ -513,9 +513,9 @@ simplExprGently env expr = do %************************************************************************ -%* * +%* * \subsection{The driver for the simplifier} -%* * +%* * %************************************************************************ \begin{code} @@ -524,31 +524,31 @@ simplifyPgm pass guts = do { hsc_env <- getHscEnv ; us <- getUniqueSupplyM ; rb <- getRuleBase - ; liftIOWithCount $ - simplifyPgmIO pass hsc_env us rb guts } + ; liftIOWithCount $ + simplifyPgmIO pass hsc_env us rb guts } simplifyPgmIO :: CoreToDo - -> HscEnv - -> UniqSupply - -> RuleBase - -> ModGuts - -> IO (SimplCount, ModGuts) -- New bindings + -> HscEnv + -> UniqSupply + -> RuleBase + -> ModGuts + -> IO (SimplCount, ModGuts) -- New bindings simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) - hsc_env us hpt_rule_base + hsc_env us hpt_rule_base guts@(ModGuts { mg_module = this_mod , mg_binds = binds, mg_rules = rules , mg_fam_inst_env = fam_inst_env }) - = do { (termination_msg, it_count, counts_out, guts') - <- do_iteration us 1 [] binds rules + = do { (termination_msg, it_count, counts_out, guts') + <- do_iteration us 1 [] binds rules - ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags) - "Simplifier statistics for following pass" - (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", - blankLine, - pprSimplCount counts_out]) + ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags) + "Simplifier statistics for following pass" + (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", + blankLine, + pprSimplCount counts_out]) - ; return (counts_out, guts') + ; return (counts_out, guts') } where dflags = hsc_dflags hsc_env @@ -557,146 +557,146 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) active_rule = activeRule simpl_env do_iteration :: UniqSupply - -> Int -- Counts iterations - -> [SimplCount] -- Counts from earlier iterations, reversed - -> CoreProgram -- Bindings in - -> [CoreRule] -- and orphan rules - -> IO (String, Int, SimplCount, ModGuts) + -> Int -- Counts iterations + -> [SimplCount] -- Counts from earlier iterations, reversed + -> CoreProgram -- Bindings in + -> [CoreRule] -- and orphan rules + -> IO (String, Int, SimplCount, ModGuts) do_iteration us iteration_no counts_so_far binds rules - -- iteration_no is the number of the iteration we are - -- about to begin, with '1' for the first - | iteration_no > max_iterations -- Stop if we've run out of iterations + -- iteration_no is the number of the iteration we are + -- about to begin, with '1' for the first + | iteration_no > max_iterations -- Stop if we've run out of iterations = WARN( debugIsOn && (max_iterations > 2) , ptext (sLit "Simplifier baling out after") <+> int max_iterations - <+> ptext (sLit "iterations") - <+> (brackets $ hsep $ punctuate comma $ + <+> ptext (sLit "iterations") + <+> (brackets $ hsep $ punctuate comma $ map (int . simplCountN) (reverse counts_so_far)) <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) ) - -- Subtract 1 from iteration_no to get the - -- number of iterations we actually completed - return ( "Simplifier baled out", iteration_no - 1 + -- Subtract 1 from iteration_no to get the + -- number of iterations we actually completed + return ( "Simplifier baled out", iteration_no - 1 , totalise counts_so_far , guts { mg_binds = binds, mg_rules = rules } ) -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. - | let sz = coreBindsSize binds + | let sz = coreBindsSize binds , sz == sz -- Force it = do { -- Occurrence analysis let { -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure - -- that the right-hand sides of vectorisation declarations are taken into + -- that the right-hand sides of vectorisation declarations are taken into -- account during occurence analysis. maybeVects = case sm_phase mode of InitialPhase -> mg_vect_decls guts _ -> [] - ; tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm this_mod active_rule rules maybeVects binds + ; tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm this_mod active_rule rules maybeVects binds } ; Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings tagged_binds); - -- Get any new rules, and extend the rule base - -- See Note [Overall plumbing for rules] in Rules.lhs - -- We need to do this regularly, because simplification can - -- poke on IdInfo thunks, which in turn brings in new rules - -- behind the scenes. Otherwise there's a danger we'll simply - -- miss the rules for Ids hidden inside imported inlinings - eps <- hscEPS hsc_env ; - let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) - ; rule_base2 = extendRuleBaseList rule_base1 rules - ; simpl_binds = {-# SCC "SimplTopBinds" #-} - simplTopBinds simpl_env tagged_binds - ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ; - - -- Simplify the program - -- We do this with a *case* not a *let* because lazy pattern - -- matching bit us with bad space leak! - -- With a let, we ended up with - -- let - -- t = initSmpl ... - -- counts1 = snd t - -- in - -- case t of {(_,counts1) -> if counts1=0 then ... } - -- So the conditional didn't force counts1, because the - -- selection got duplicated. Sigh! - case initSmpl dflags rule_base2 fam_envs us1 sz simpl_binds of { - (env1, counts1) -> do { - - let { binds1 = getFloats env1 + -- Get any new rules, and extend the rule base + -- See Note [Overall plumbing for rules] in Rules.lhs + -- We need to do this regularly, because simplification can + -- poke on IdInfo thunks, which in turn brings in new rules + -- behind the scenes. Otherwise there's a danger we'll simply + -- miss the rules for Ids hidden inside imported inlinings + eps <- hscEPS hsc_env ; + let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) + ; rule_base2 = extendRuleBaseList rule_base1 rules + ; simpl_binds = {-# SCC "SimplTopBinds" #-} + simplTopBinds simpl_env tagged_binds + ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ; + + -- Simplify the program + -- We do this with a *case* not a *let* because lazy pattern + -- matching bit us with bad space leak! + -- With a let, we ended up with + -- let + -- t = initSmpl ... + -- counts1 = snd t + -- in + -- case t of {(_,counts1) -> if counts1=0 then ... } + -- So the conditional didn't force counts1, because the + -- selection got duplicated. Sigh! + case initSmpl dflags rule_base2 fam_envs us1 sz simpl_binds of { + (env1, counts1) -> do { + + let { binds1 = getFloats env1 ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules - } ; - - -- Stop if nothing happened; don't dump output - if isZeroSimplCount counts1 then - return ( "Simplifier reached fixed point", iteration_no - , totalise (counts1 : counts_so_far) -- Include "free" ticks - , guts { mg_binds = binds1, mg_rules = rules1 } ) - else do { - -- Short out indirections - -- We do this *after* at least one run of the simplifier - -- because indirection-shorting uses the export flag on *occurrences* - -- and that isn't guaranteed to be ok until after the first run propagates - -- stuff from the binding site to its occurrences - -- - -- ToDo: alas, this means that indirection-shorting does not happen at all - -- if the simplifier does nothing (not common, I know, but unsavoury) - let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; - - -- Dump the result of this iteration - end_iteration dflags pass iteration_no counts1 binds2 rules1 ; - - -- Loop - do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 + } ; + + -- Stop if nothing happened; don't dump output + if isZeroSimplCount counts1 then + return ( "Simplifier reached fixed point", iteration_no + , totalise (counts1 : counts_so_far) -- Include "free" ticks + , guts { mg_binds = binds1, mg_rules = rules1 } ) + else do { + -- Short out indirections + -- We do this *after* at least one run of the simplifier + -- because indirection-shorting uses the export flag on *occurrences* + -- and that isn't guaranteed to be ok until after the first run propagates + -- stuff from the binding site to its occurrences + -- + -- ToDo: alas, this means that indirection-shorting does not happen at all + -- if the simplifier does nothing (not common, I know, but unsavoury) + let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; + + -- Dump the result of this iteration + end_iteration dflags pass iteration_no counts1 binds2 rules1 ; + + -- Loop + do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 } } } } | otherwise = panic "do_iteration" where - (us1, us2) = splitUniqSupply us + (us1, us2) = splitUniqSupply us - -- Remember the counts_so_far are reversed + -- Remember the counts_so_far are reversed totalise :: [SimplCount] -> SimplCount - totalise = foldr (\c acc -> acc `plusSimplCount` c) - (zeroSimplCount dflags) + totalise = foldr (\c acc -> acc `plusSimplCount` c) + (zeroSimplCount dflags) simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" ------------------- -end_iteration :: DynFlags -> CoreToDo -> Int +end_iteration :: DynFlags -> CoreToDo -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () end_iteration dflags pass iteration_no counts binds rules = do { dumpPassResult dflags mb_flag hdr pp_counts binds rules ; lintPassResult dflags pass binds } where - mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases - | otherwise = Nothing - -- Show details if Opt_D_dump_simpl_iterations is on + mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases + | otherwise = Nothing + -- Show details if Opt_D_dump_simpl_iterations is on hdr = ptext (sLit "Simplifier iteration=") <> int iteration_no pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr - , pprSimplCount counts + , pprSimplCount counts , ptext (sLit "---- End of simplifier counts for") <+> hdr ] \end{code} %************************************************************************ -%* * - Shorting out indirections -%* * +%* * + Shorting out indirections +%* * %************************************************************************ If we have this: - x_local = <expression> - ...bindings... - x_exported = x_local + x_local = <expression> + ...bindings... + x_exported = x_local where x_exported is exported, and x_local is not, then we replace it with this: - x_exported = <expression> - x_local = x_exported - ...bindings... + x_exported = <expression> + x_local = x_exported + ...bindings... Without this we never get rid of the x_exported = x_local thing. This save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and @@ -718,41 +718,41 @@ Note [Messing up the exported Id's RULES] We must be careful about discarding (obviously) or even merging the RULES on the exported Id. The example that went bad on me at one stage was this one: - + iterate :: (a -> a) -> a -> [a] - [Exported] - iterate = iterateList - + [Exported] + iterate = iterateList + iterateFB c f x = x `c` iterateFB c f (f x) iterateList f x = x : iterateList f (f x) - [Not exported] - + [Not exported] + {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterateList + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterateList #-} This got shorted out to: iterateList :: (a -> a) -> a -> [a] iterateList = iterate - + iterateFB c f x = x `c` iterateFB c f (f x) iterate f x = x : iterate f (f x) - + {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterate + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterate #-} -And now we get an infinite loop in the rule system - iterate f x -> build (\cn -> iterateFB c f x) - -> iterateFB (:) f x - -> iterate f x +And now we get an infinite loop in the rule system + iterate f x -> build (\cn -> iterateFB c f x) + -> iterateFB (:) f x + -> iterate f x -Old "solution": - use rule switching-off pragmas to get rid - of iterateList in the first place +Old "solution": + use rule switching-off pragmas to get rid + of iterateList in the first place But in principle the user *might* want rules that only apply to the Id he says. And inline pragmas are similar @@ -768,9 +768,9 @@ Note [Rules and indirection-zapping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Problem: what if x_exported has a RULE that mentions something in ...bindings...? Then the things mentioned can be out of scope! Solution - a) Make sure that in this pass the usage-info from x_exported is - available for ...bindings... - b) If there are any such RULES, rec-ify the entire top-level. + a) Make sure that in this pass the usage-info from x_exported is + available for ...bindings... + b) If there are any such RULES, rec-ify the entire top-level. It'll get sorted out next time round Other remarks @@ -778,88 +778,88 @@ Other remarks If more than one exported thing is equal to a local thing (i.e., the local thing really is shared), then we do one only: \begin{verbatim} - x_local = .... - x_exported1 = x_local - x_exported2 = x_local + x_local = .... + x_exported1 = x_local + x_exported2 = x_local ==> - x_exported1 = .... + x_exported1 = .... - x_exported2 = x_exported1 + x_exported2 = x_exported1 \end{verbatim} We rely on prior eta reduction to simplify things like \begin{verbatim} - x_exported = /\ tyvars -> x_local tyvars + x_exported = /\ tyvars -> x_local tyvars ==> - x_exported = x_local + x_exported = x_local \end{verbatim} Hence,there's a possibility of leaving unchanged something like this: \begin{verbatim} - x_local = .... - x_exported1 = x_local Int + x_local = .... + x_exported1 = x_local Int \end{verbatim} -By the time we've thrown away the types in STG land this +By the time we've thrown away the types in STG land this could be eliminated. But I don't think it's very common -and it's dangerous to do this fiddling in STG land +and it's dangerous to do this fiddling in STG land because we might elminate a binding that's mentioned in the unfolding for something. \begin{code} -type IndEnv = IdEnv Id -- Maps local_id -> exported_id +type IndEnv = IdEnv Id -- Maps local_id -> exported_id shortOutIndirections :: CoreProgram -> CoreProgram shortOutIndirections binds | isEmptyVarEnv ind_env = binds - | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping] - | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff + | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping] + | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff where - ind_env = makeIndEnv binds - exp_ids = varSetElems ind_env -- These exported Ids are the subjects - exp_id_set = mkVarSet exp_ids -- of the indirection-elimination + ind_env = makeIndEnv binds + exp_ids = varSetElems ind_env -- These exported Ids are the subjects + exp_id_set = mkVarSet exp_ids -- of the indirection-elimination no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids - binds' = concatMap zap binds + binds' = concatMap zap binds zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] - zap (Rec pairs) = [Rec (concatMap zapPair pairs)] + zap (Rec pairs) = [Rec (concatMap zapPair pairs)] zapPair (bndr, rhs) - | bndr `elemVarSet` exp_id_set = [] - | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs), - (bndr, Var exp_id)] - | otherwise = [(bndr,rhs)] - + | bndr `elemVarSet` exp_id_set = [] + | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs), + (bndr, Var exp_id)] + | otherwise = [(bndr,rhs)] + makeIndEnv :: [CoreBind] -> IndEnv makeIndEnv binds = foldr add_bind emptyVarEnv binds where add_bind :: CoreBind -> IndEnv -> IndEnv add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env - add_bind (Rec pairs) env = foldr add_pair env pairs + add_bind (Rec pairs) env = foldr add_pair env pairs add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv add_pair (exported_id, Var local_id) env - | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id + | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id add_pair _ env = env - + ----------------- shortMeOut :: IndEnv -> Id -> Id -> Bool shortMeOut ind_env exported_id local_id -- The if-then-else stuff is just so I can get a pprTrace to see -- how often I don't get shorting out becuase of IdInfo stuff - = if isExportedId exported_id && -- Only if this is exported + = if isExportedId exported_id && -- Only if this is exported + + isLocalId local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! - isLocalId local_id && -- Only if this one is defined in this - -- module, so that we *can* change its - -- binding to be the exported thing! + not (isExportedId local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it - not (isExportedId local_id) && -- Only if this one is not itself exported, - -- since the transformation will nuke it - - not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for then - if hasShortableIdInfo exported_id - then True -- See Note [Messing up the exported Id's IdInfo] - else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id ) + if hasShortableIdInfo exported_id + then True -- See Note [Messing up the exported Id's IdInfo] + else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id ) False else False @@ -879,9 +879,9 @@ hasShortableIdInfo id transferIdInfo :: Id -> Id -> Id -- See Note [Transferring IdInfo] -- If we have --- lcl_id = e; exp_id = lcl_id +-- lcl_id = e; exp_id = lcl_id -- and lcl_id has useful IdInfo, we don't want to discard it by going --- gbl_id = e; lcl_id = gbl_id +-- gbl_id = e; lcl_id = gbl_id -- Instead, transfer IdInfo from lcl_id to exp_id -- Overwriting, rather than merging, seems to work ok. transferIdInfo exported_id local_id @@ -889,11 +889,11 @@ transferIdInfo exported_id local_id where local_info = idInfo local_id transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info - `setUnfoldingInfo` unfoldingInfo local_info - `setInlinePragInfo` inlinePragInfo local_info - `setSpecInfo` addSpecInfo (specInfo exp_info) new_info - new_info = setSpecInfoHead (idName exported_id) - (specInfo local_info) - -- Remember to set the function-name field of the - -- rules as we transfer them from one function to another + `setUnfoldingInfo` unfoldingInfo local_info + `setInlinePragInfo` inlinePragInfo local_info + `setSpecInfo` addSpecInfo (specInfo exp_info) new_info + new_info = setSpecInfoHead (idName exported_id) + (specInfo local_info) + -- Remember to set the function-name field of the + -- rules as we transfer them from one function to another \end{code} diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index d311647db3..f28d728c1f 100755 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -64,7 +64,7 @@ import Control.Monad Overall plan ~~~~~~~~~~~~ -1. Convert the decls (i.e. data/newtype deriving clauses, +1. Convert the decls (i.e. data/newtype deriving clauses, plus standalone deriving) to [EarlyDerivSpec] 2. Infer the missing contexts for the Left DerivSpecs @@ -74,10 +74,10 @@ Overall plan \begin{code} -- DerivSpec is purely local to this module -data DerivSpec = DS { ds_loc :: SrcSpan - , ds_orig :: CtOrigin +data DerivSpec = DS { ds_loc :: SrcSpan + , ds_orig :: CtOrigin , ds_name :: Name - , ds_tvs :: [TyVar] + , ds_tvs :: [TyVar] , ds_theta :: ThetaType , ds_cls :: Class , ds_tys :: [Type] @@ -88,7 +88,7 @@ data DerivSpec = DS { ds_loc :: SrcSpan -- df :: forall tvs. theta => C tys -- The Name is the name for the DFun we'll build -- The tyvars bind all the variables in the theta - -- For type families, the tycon in + -- For type families, the tycon in -- in ds_tys is the *family* tycon -- in ds_tc, ds_tc_args is the *representation* tycon -- For non-family tycons, both are the same @@ -100,7 +100,7 @@ data DerivSpec = DS { ds_loc :: SrcSpan Example: newtype instance T [a] = MkT (Tree a) deriving( C s ) -==> +==> axiom T [a] = :RTList a axiom :RTList a = Tree a @@ -115,16 +115,16 @@ type DerivContext = Maybe ThetaType type EarlyDerivSpec = Either DerivSpec DerivSpec -- Left ds => the context for the instance should be inferred - -- In this case ds_theta is the list of all the + -- In this case ds_theta is the list of all the -- constraints needed, such as (Eq [a], Eq a) - -- The inference process is to reduce this to a + -- The inference process is to reduce this to a -- simpler form (e.g. Eq a) - -- - -- Right ds => the exact context for the instance is supplied + -- + -- Right ds => the exact context for the instance is supplied -- by the programmer; it is ds_theta pprDerivSpec :: DerivSpec -> SDoc -pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, +pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c, ds_tys = tys, ds_theta = rhs }) = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys] <+> equals <+> ppr rhs) @@ -134,7 +134,7 @@ instance Outputable DerivSpec where \end{code} -Inferring missing contexts +Inferring missing contexts ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -143,7 +143,7 @@ Consider | C3 (T a a) deriving (Eq) -[NOTE: See end of these comments for what to do with +[NOTE: See end of these comments for what to do with data (C a, D b) => T a b = ... ] @@ -228,7 +228,7 @@ We will need an instance decl like: The RealFloat in the context is because the read method for Complex is bound to construct a Complex, and doing that requires that the argument type is -in RealFloat. +in RealFloat. But this ain't true for Show, Eq, Ord, etc, since they don't construct a Complex; they only take them apart. @@ -250,13 +250,13 @@ Consider this: instance C [a] Char newtype T = T Char deriving( C [a] ) -Notice the free 'a' in the deriving. We have to fill this out to +Notice the free 'a' in the deriving. We have to fill this out to newtype T = T Char deriving( forall a. C [a] ) And then translate it to: instance C [a] Char => C [a] T where ... - - + + Note [Newtype deriving superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (See also Trac #1220 for an interesting exchange on newtype @@ -382,14 +382,13 @@ renameDeriv is_boot inst_infos bagBinds ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs) ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds - ; bindLocalNames (collectHsValBinders rn_aux_lhs) $ + ; bindLocalNames (collectHsValBinders rn_aux_lhs) $ do { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos ; return (listToBag rn_inst_infos, rn_aux, dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } where - rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars) rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc }) = return ( info { iBinds = NewTypeDerived coi tc } @@ -397,7 +396,7 @@ renameDeriv is_boot inst_infos bagBinds -- See Note [Newtype deriving and unused constructors] rn_inst_info inst_info@(InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv }) - = -- Bring the right type variables into + = -- Bring the right type variables into -- scope (yuk), and rename the method binds ASSERT( null sigs ) bindLocalNames (map Var.varName tyvars) $ @@ -495,8 +494,8 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) ------------------------------------------------------------------ deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec -deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, - tcdTyVars = tv_names, +deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, + tcdTyVars = tv_names, tcdTyPats = ty_pats })) = setSrcSpan loc $ -- Use the location of the 'deriving' item tcAddDeclCtxt decl $ @@ -513,7 +512,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, ; let cls_tyvars = classTyVars cls kind = tyVarKind (last cls_tyvars) (arg_kinds, _) = splitKindFunTys kind - n_args_to_drop = length arg_kinds + n_args_to_drop = length arg_kinds n_args_to_keep = tyConArity tc - n_args_to_drop args_to_drop = drop n_args_to_keep tc_args inst_ty = mkTyConApp tc (take n_args_to_keep tc_args) @@ -521,7 +520,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, dropped_tvs = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop) univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs) `minusVarSet` dropped_tvs - + -- Check that the result really is well-kinded ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind)) (derivingKindErr tc cls cls_tys kind) @@ -529,11 +528,11 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, ; checkTc (sizeVarSet dropped_tvs == n_args_to_drop && -- (a) tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b) (derivingEtaErr cls cls_tys inst_ty) - -- Check that + -- Check that -- (a) The data type can be eta-reduced; eg reject: -- data instance T a a = ... deriving( Monad ) -- (b) The type class args do not mention any of the dropped type - -- variables + -- variables -- newtype T a s = ... deriving( ST s ) -- Type families can't be partially applied @@ -571,7 +570,7 @@ When there are no type families, it's quite easy: -- :CoS :: S ~ [] -- Eta-reduced instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) - instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S + instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S When type familes are involved it's trickier: @@ -589,7 +588,7 @@ Henc the current typeFamilyPapErr, even though the instance makes sense. After all, we can write it out instance Monad [] => Monad (T Int) -- only if we can eta reduce??? return x = MkT [x] - ... etc ... + ... etc ... \begin{code} mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type @@ -625,10 +624,10 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta | otherwise = do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args - -- Be careful to test rep_tc here: in the case of families, + -- Be careful to test rep_tc here: in the case of families, -- we want to check the instance tycon, not the family tycon - -- For standalone deriving (mtheta /= Nothing), + -- For standalone deriving (mtheta /= Nothing), -- check that all the data constructors are in scope. ; rdr_env <- getGlobalRdrEnv ; let hidden_data_cons = not (isWiredInName (tyConName rep_tc)) && @@ -643,7 +642,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta mkDataTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta else - mkNewTypeEqn orig dflags tvs cls cls_tys + mkNewTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta } \end{code} @@ -660,7 +659,7 @@ mkDataTypeEqn :: CtOrigin -> [Var] -- Universally quantified type variables in the instance -> Class -- Class for which we need to derive an instance -> [Type] -- Other parameters to the class except the last - -> TyCon -- Type constructor for which the instance is requested + -> TyCon -- Type constructor for which the instance is requested -- (last parameter to the type class) -> [Type] -- Parameters to the type constructor -> TyCon -- rep of the above (for type families) @@ -679,7 +678,7 @@ mkDataTypeEqn orig dflags tvs cls cls_tys go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) -mk_data_eqn :: CtOrigin -> [TyVar] -> Class +mk_data_eqn :: CtOrigin -> [TyVar] -> Class -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext -> TcM EarlyDerivSpec mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta @@ -688,7 +687,7 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta ; let inst_tys = [mkTyConApp tycon tc_args] inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args spec = DS { ds_loc = loc, ds_orig = orig - , ds_name = dfun_name, ds_tvs = tvs + , ds_name = dfun_name, ds_tvs = tvs , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tc, ds_tc_args = rep_tc_args , ds_theta = mtheta `orElse` inferred_constraints @@ -698,7 +697,7 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta else Left spec) } -- Infer context ---------------------- -mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class +mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class -> TyCon -> [TcType] -> DerivContext -> TcM EarlyDerivSpec mk_typeable_eqn orig tvs cls tycon tc_args mtheta @@ -719,7 +718,7 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta | otherwise -- standaone deriving = do { checkTc (null tc_args) - (ptext (sLit "Derived typeable instance must be of form (Typeable") + (ptext (sLit "Derived typeable instance must be of form (Typeable") <> int (tyConArity tycon) <+> ppr tycon <> rparen) ; dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM @@ -746,7 +745,7 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args where -- Constraints arising from the arguments of each constructor con_arg_constraints - = [ mkClassPred cls [arg_ty] + = [ mkClassPred cls [arg_ty] | data_con <- tyConDataCons rep_tc, arg_ty <- ASSERT( isVanillaDataCon data_con ) get_constrained_tys $ @@ -762,7 +761,7 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args is_functor_like = getUnique cls `elem` functorLikeClassKeys get_constrained_tys :: [Type] -> [Type] - get_constrained_tys tys + get_constrained_tys tys | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys | otherwise = tys @@ -779,20 +778,20 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args -- Stupid constraints stupid_constraints = substTheta subst (tyConStupidTheta rep_tc) subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args - + -- Extra Data constraints - -- The Data class (only) requires that for - -- instance (...) => Data (T t1 t2) + -- The Data class (only) requires that for + -- instance (...) => Data (T t1 t2) -- IF t1:*, t2:* -- THEN (Data t1, Data t2) are among the (...) constraints -- Reason: when the IF holds, we generate a method -- dataCast2 f = gcast2 f -- and we need the Data constraints to typecheck the method - extra_constraints + extra_constraints | cls `hasKey` dataClassKey - , all (isLiftedTypeKind . typeKind) rep_tc_args + , all (isLiftedTypeKind . typeKind) rep_tc_args = [mkClassPred cls [ty] | ty <- rep_tc_args] - | otherwise + | otherwise = [] \end{code} @@ -830,7 +829,7 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc = case (cond (dflags, rep_tc)) of Just err -> DerivableClassError err -- Class-specific error Nothing | null cls_tys -> CanDerive -- All derivable classes are unary, so - -- cls_tys (the type args other than last) + -- cls_tys (the type args other than last) -- should be null | otherwise -> DerivableClassError ty_args_why -- e.g. deriving( Eq s ) | otherwise = NonDerivableClass -- Not a standard class @@ -852,7 +851,7 @@ sideConditions mtheta cls | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration) | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) - | cls_key == dataClassKey = Just (checkFlag Opt_DeriveDataTypeable `andCond` + | cls_key == dataClassKey = Just (checkFlag Opt_DeriveDataTypeable `andCond` cond_std `andCond` cond_args cls) | cls_key == functorClassKey = Just (checkFlag Opt_DeriveFunctor `andCond` cond_functorOK True) -- NB: no cond_std! @@ -870,12 +869,12 @@ sideConditions mtheta cls type Condition = (DynFlags, TyCon) -> Maybe SDoc -- first Bool is whether or not we are allowed to derive Data and Typeable -- second Bool is whether or not we are allowed to derive Functor - -- TyCon is the *representation* tycon if the + -- TyCon is the *representation* tycon if the -- data type is an indexed one -- Nothing => OK orCond :: Condition -> Condition -> Condition -orCond c1 c2 tc +orCond c1 c2 tc = case c1 tc of Nothing -> Nothing -- c1 succeeds Just x -> case c2 tc of -- c1 fails @@ -903,34 +902,34 @@ cond_stdOK Nothing (_, rep_tc) con_whys = mapCatMaybes check_con data_cons check_con :: DataCon -> Maybe SDoc - check_con con + check_con con | isVanillaDataCon con , all isTauTy (dataConOrigArgTys con) = Nothing | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type"))) - + no_cons_why :: TyCon -> SDoc -no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> +no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "must have at least one data constructor") cond_RepresentableOk :: Condition cond_RepresentableOk (_,t) = canDoGenerics t cond_enumOrProduct :: Class -> Condition -cond_enumOrProduct cls = cond_isEnumeration `orCond` +cond_enumOrProduct cls = cond_isEnumeration `orCond` (cond_isProduct `andCond` cond_args cls) cond_args :: Class -> Condition -- For some classes (eg Eq, Ord) we allow unlifted arg types -- by generating specilaised code. For others (eg Data) we don't. cond_args cls (_, tc) - = case bad_args of + = case bad_args of [] -> Nothing (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls)) 2 (ptext (sLit "for type") <+> quotes (ppr ty))) where bad_args = [ arg_ty | con <- tyConDataCons tc , arg_ty <- dataConOrigArgTys con - , isUnLiftedType arg_ty + , isUnLiftedType arg_ty , not (ok_ty arg_ty) ] cls_key = classKey cls @@ -949,7 +948,7 @@ cond_isEnumeration (_, rep_tc) | isEnumerationTyCon rep_tc = Nothing | otherwise = Just why where - why = sep [ quotes (pprSourceTyCon rep_tc) <+> + why = sep [ quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "must be an enumeration type") , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ] -- See Note [Enumeration types] in TyCon @@ -959,7 +958,7 @@ cond_isProduct (_, rep_tc) | isProductTyCon rep_tc = Nothing | otherwise = Just why where - why = quotes (pprSourceTyCon rep_tc) <+> + why = quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "must have precisely one constructor") cond_typeableOK :: Condition @@ -968,13 +967,13 @@ cond_typeableOK :: Condition -- (b) 7 or fewer args cond_typeableOK (_, tc) | tyConArity tc > 7 = Just too_many - | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tc)) + | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tc)) = Just bad_kind | otherwise = Nothing where - too_many = quotes (pprSourceTyCon tc) <+> + too_many = quotes (pprSourceTyCon tc) <+> ptext (sLit "must have 7 or fewer arguments") - bad_kind = quotes (pprSourceTyCon tc) <+> + bad_kind = quotes (pprSourceTyCon tc) <+> ptext (sLit "must only have arguments of kind `*'") functorLikeClassKeys :: [Unique] @@ -989,11 +988,11 @@ cond_functorOK :: Bool -> Condition -- (e) no "stupid context" on data type cond_functorOK allowFunctions (_, rep_tc) | null tc_tvs - = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) <+> ptext (sLit "must have some type parameters")) | not (null bad_stupid_theta) - = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta) | otherwise @@ -1014,13 +1013,13 @@ cond_functorOK allowFunctions (_, rep_tc) ft_check :: DataCon -> FFoldType (Maybe SDoc) ft_check con = FT { ft_triv = Nothing, ft_var = Nothing , ft_co_var = Just (badCon con covariant) - , ft_fun = \x y -> if allowFunctions then x `mplus` y + , ft_fun = \x y -> if allowFunctions then x `mplus` y else Just (badCon con functions) , ft_tup = \_ xs -> msum xs , ft_ty_app = \_ x -> x , ft_bad_app = Just (badCon con wrong_arg) , ft_forall = \_ x -> x } - + existential = ptext (sLit "must not have existential arguments") covariant = ptext (sLit "must not use the type variable in a function argument") functions = ptext (sLit "must not contain function types") @@ -1031,9 +1030,9 @@ checkFlag flag (dflags, _) | xopt flag dflags = Nothing | otherwise = Just why where - why = ptext (sLit "You need -X") <> text flag_str + why = ptext (sLit "You need -X") <> text flag_str <+> ptext (sLit "to derive an instance for this class") - flag_str = case [ s | (s, _, f, _) <- xFlags, f==flag ] of + flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of [s] -> s other -> pprPanic "checkFlag" (ppr other) @@ -1041,7 +1040,7 @@ std_class_via_iso :: Class -> Bool -- These standard classes can be derived for a newtype -- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving -- because giving so gives the same results as generating the boilerplate -std_class_via_iso clas +std_class_via_iso clas = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] -- Not Read/Show because they respect the type -- Not Enum, because newtypes are never in Enum @@ -1050,7 +1049,7 @@ std_class_via_iso clas non_iso_class :: Class -> Bool -- *Never* derive Read, Show, Typeable, Data, Generic by isomorphism, -- even with -XGeneralizedNewtypeDeriving -non_iso_class cls +non_iso_class cls = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey , genClassKey] ++ typeableClassKeys) @@ -1068,14 +1067,14 @@ badCon :: DataCon -> SDoc -> SDoc badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg \end{code} -Note [Superclasses of derived instance] +Note [Superclasses of derived instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general, a derived instance decl needs the superclasses of the derived class too. So if we have data T a = ...deriving( Ord ) -then the initial context for Ord (T a) should include Eq (T a). Often this is +then the initial context for Ord (T a) should include Eq (T a). Often this is redundant; we'll also generate an Ord constraint for each constructor argument, -and that will probably generate enough constraints to make the Eq (T a) constraint +and that will probably generate enough constraints to make the Eq (T a) constraint be satisfied too. But not always; consider: data S a = S @@ -1112,7 +1111,7 @@ mkNewTypeEqn orig dflags tvs ; dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM ; let spec = DS { ds_loc = loc, ds_orig = orig - , ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs + , ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = mtheta `orElse` all_preds @@ -1143,7 +1142,7 @@ mkNewTypeEqn orig dflags tvs -- where t is a type, -- ak+1...an is a suffix of a1..an, and are all tyars -- ak+1...an do not occur free in t, nor in the s1..sm - -- (C s1 ... sm) is a *partial applications* of class C + -- (C s1 ... sm) is a *partial applications* of class C -- with the last parameter missing -- (T a1 .. ak) matches the kind of C's last argument -- (and hence so does t) @@ -1153,7 +1152,7 @@ mkNewTypeEqn orig dflags tvs -- We generate the instance -- instance forall ({a1..ak} u fvs(s1..sm)). -- C s1 .. sm t => C s1 .. sm (T a1...ak) - -- where T a1...ap is the partial application of + -- where T a1...ap is the partial application of -- the LHS of the correct kind and p >= k -- -- NB: the variables below are: @@ -1166,7 +1165,7 @@ mkNewTypeEqn orig dflags tvs -- -- Running example: newtype T s a = MkT (ST s a) deriving( Monad ) -- We generate the instance - -- instance Monad (ST s) => Monad (T s) where + -- instance Monad (ST s) => Monad (T s) where nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon)) -- For newtype T a b = MkT (S a a b), the TyCon machinery already @@ -1177,7 +1176,7 @@ mkNewTypeEqn orig dflags tvs -- Note [Newtype representation] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Need newTyConRhs (*not* a recursive representation finder) + -- Need newTyConRhs (*not* a recursive representation finder) -- to get the representation type. For example -- newtype B = MkB Int -- newtype A = MkA B deriving( Num ) @@ -1188,7 +1187,7 @@ mkNewTypeEqn orig dflags tvs rep_pred = mkClassPred cls rep_tys -- rep_pred is the representation dictionary, from where -- we are gong to get all the methods for the newtype - -- dictionary + -- dictionary -- Next we figure out what superclass dictionaries to use @@ -1233,11 +1232,11 @@ mkNewTypeEqn orig dflags tvs -- And the [a] must not mention 'b'. That's all handled -- by nt_eta_rity. - ats_ok = null (classATs cls) - -- No associated types for the class, because we don't + ats_ok = null (classATs cls) + -- No associated types for the class, because we don't -- currently generate type 'instance' decls; and cannot do -- so for 'data' instance decls - + cant_derive_err = vcat [ ppUnless arity_ok arity_msg , ppUnless eta_ok eta_msg @@ -1309,7 +1308,7 @@ inferInstanceContexts oflag infer_specs | n > 20 -- Looks as if we are in an infinite loop -- This can happen if we have -XUndecidableInstances -- (See TcSimplify.tcSimplifyDeriv.) - = pprPanic "solveDerivEqns: probable loop" + = pprPanic "solveDerivEqns: probable loop" (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns) | otherwise = do { -- Extend the inst info from the explicit instance decls @@ -1324,22 +1323,22 @@ inferInstanceContexts oflag infer_specs eqList f xs ys = length xs == length ys && and (zipWith f xs ys) ; if (eqList (eqList eqType) current_solns new_solns) then - return [ spec { ds_theta = soln } + return [ spec { ds_theta = soln } | (spec, soln) <- zip infer_specs current_solns ] else iterate_deriv (n+1) new_solns } ------------------------------------------------------------------ gen_soln :: DerivSpec -> TcM [PredType] - gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars + gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) = setSrcSpan loc $ - addErrCtxt (derivInstCtxt the_pred) $ + addErrCtxt (derivInstCtxt the_pred) $ do { theta <- simplifyDeriv orig the_pred tyvars deriv_rhs -- checkValidInstance tyvars theta clas inst_tys -- Not necessary; see Note [Exotic derived instance contexts] -- in TcSimplify - + ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta) -- Claim: the result instance declaration is guaranteed valid -- Hence no need to call: @@ -1363,7 +1362,7 @@ extendLocalInstEnv :: [Instance] -> TcM a -> TcM a -- for functional dependency errors -- that'll happen in TcInstDcls extendLocalInstEnv dfuns thing_inside = do { env <- getGblEnv - ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns + ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns env' = env { tcg_inst_env = inst_env' } ; setGblEnv env' thing_inside } \end{code} @@ -1469,7 +1468,7 @@ genInst standalone_deriv oflag co = co1 `mkTransCo` co2 id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args) --- Example: newtype instance N [a] = N1 (Tree a) +-- Example: newtype instance N [a] = N1 (Tree a) -- deriving instance Eq b => Eq (N [(b,b)]) -- From the instance, we get an implicit newtype R1:N a = N1 (Tree a) -- When dealing with the deriving clause @@ -1529,12 +1528,12 @@ derivingEtaErr cls cls_tys inst_ty typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> Message typeFamilyPapErr tc cls cls_tys inst_ty = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty]))) - 2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc) + 2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc) derivingThingErr :: Bool -> Class -> [Type] -> Type -> Message -> Message derivingThingErr newtype_deriving clas tys ty why = sep [(hang (ptext (sLit "Can't make a derived instance of")) - 2 (quotes (ppr pred)) + 2 (quotes (ppr pred)) $$ nest 2 extra) <> colon, nest 2 why] where @@ -1548,7 +1547,7 @@ derivingHiddenErr tc 2 (ptext (sLit "so you cannot derive an instance for it")) standaloneCtxt :: LHsType Name -> SDoc -standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) +standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 2 (quotes (ppr ty)) derivInstCtxt :: PredType -> Message diff --git a/driver/ordering-passes b/driver/ordering-passes deleted file mode 100644 index 305f3f06b4..0000000000 --- a/driver/ordering-passes +++ /dev/null @@ -1,257 +0,0 @@ - Ordering the compiler's passes - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Change notes -~~~~~~~~~~~~ -1 Nov 94 * NB: if float-out is done after strictness, remember to - switch off demandedness flags on floated bindings! -13 Oct 94 * Run Float Inwards once more after strictness-simplify [andre] - 4 Oct 94 * Do simplification between float-in and strictness [andre] - * Ignore-inline-pragmas flag for final simplification [andre] - -Aug 94 Original: Simon, Andy, Andre - - - - -This ordering obeys all the constraints except (5) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - full laziness - simplify with foldr/build - float-in - simplify - strictness - float-in - -[check FFT2 still gets benefits with this ordering] - -================================= - Constraints -================================= - -1. float-in before strictness. -Reason: floating inwards moves definitions inwards to a site at which -the binding might well be strict. - -Example let x = ... in - y = x+1 - in - ... -===> - let y = let x = ... in x+1 - in ... - -The strictness analyser will do a better job of the latter -than the former. - -2. Don't simplify between float-in and strictness, -unless you disable float-let-out-of-let, otherwise -the simiplifier's local floating might undo some -useful floating-in. - -Example let f = let y = .. in \x-> x+y - in ... -===> - let y = ... - f = \x -> x+y - in ... - -This is a bad move, because now y isn't strict. -In the pre-float case, the binding for y is strict. -Mind you, this isn't a very common case, and -it's easy to disable float-let-from-let. - -3. Want full-laziness before foldr/build. -Reason: Give priority to sharing rather than deforestation. - -Example \z -> let xs = build g - in foldr k z xs -===> - let xs = build g - in \x -> foldr k z xs - -In the post-full-laziness case, xs is shared between all -applications of the function. If we did foldr/build -first, we'd have got - - \z -> g k z - -and now we can't share xs. - - -4. Want strictness after foldr/build. -Reason: foldr/build makes new function definitions which -can benefit from strictness analysis. - -Example: sum [1..10] -===> (f/b) - let g x a | x > 10 = a - | otherwise = g (x+1) (a+x) - -Here we clearly want to get strictness analysis on g. - - -5. Want full laziness after strictness -Reason: absence may allow something to be floated out -which would not otherwise be. - -Example \z -> let x = f (a,z) in ... -===> (absence anal + inline wrapper of f) - \z -> let x = f.wrk a in ... -===> (full laziness) - let x= f.wrk a in \z -> ... - -TOO BAD. This doesn't look a common case to me. - - -6. Want float-in after foldr/build. -Reason: Desugaring list comprehensions + foldr/build -gives rise to new float-in opportunities. - -Example ...some list comp... -==> (foldr/build) - let v = h xs in - case ... of - [] -> v - (y:ys) -> ...(t v)... -==> (simplifier) - let v = h xs in - case ... of - [] -> h xs - (y:ys) -> ...(t v)... - -Now v could usefully be floated into the second branch. - -7. Want simplify after float-inwards. -[Occurred in the prelude, compiling ITup2.hs, function dfun.Ord.(*,*)] -This is due to the following (that happens with dictionaries): - -let a1 = case v of (a,b) -> a -in let m1 = \ c -> case c of I# c# -> case c# of 1 -> a1 5 - 2 -> 6 -in let m2 = \ c -> case c of I# c# -> - case c# +# 1# of cc# -> let cc = I# cc# - in m1 cc - in (m1,m2) - -floating inwards will push the definition of a1 into m1 (supposing -it is only used there): - -in let m1 = let a1 = case v of (a,b) -> a - in \ c -> case c of I# c# -> case c# of 1 -> a1 5 - 2 -> 6 -in let m2 = \ c -> case c of I# c# -> - case c# +# 1# of cc# -> let cc = I# cc# - in m1 cc - in (m1,m2) - -if we do strictness analysis now we will not get a worker-wrapper -for m1, because of the "let a1 ..." (notice that a1 is not strict in -its body). - -Not having this worker wrapper might be very bad, because it might -mean that we will have to rebox arguments to m1 if they are -already unboxed, generating extra allocations, as occurs with m2 (cc) -above. - -To solve this problem we have decided to run the simplifier after -float-inwards, so that lets whose body is a HNF are floated out, -undoing the float-inwards transformation in these cases. -We are then back to the original code, which would have a worker-wrapper -for m1 after strictness analysis and would avoid the extra let in m2. - -What we lose in this case are the opportunities for case-floating -that could be presented if, for example, a1 would indeed be demanded (strict) -after the floating inwards. - -The only way of having the best of both is if we have the worker/wrapper -pass explicitly called, and then we could do with - -float-in -strictness analysis -simplify -strictness analysis -worker-wrapper generation - -as we would -a) be able to detect the strictness of m1 after the - first call to the strictness analyser, and exploit it with the simplifier - (in case it was strict). -b) after the call to the simplifier (if m1 was not demanded) - it would be floated out just like we currently do, before stricness - analysis II and worker/wrapperisation. - -The reason to not do worker/wrapperisation twice is to avoid -generating wrappers for wrappers which could happen. - - -8. If full laziness is ever done after strictness, remember to switch off -demandedness flags on floated bindings! This isn't done at the moment. - - -Ignore-inline-pragmas flag for final simplification -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -[Occurred in the prelude, compiling ITup2.hs, function dfun.Ord.(*,*)] -Sometimes (e.g. in dictionary methods) we generate -worker/wrappers for functions but the wrappers are never -inlined. In dictionaries we often have - -dict = let f1 = ... - f2 = ... - ... - in (f1,f2,...) - -and if we create worker/wrappers for f1,...,fn the wrappers will not -be inlined anywhere, and we will have ended up with extra -closures (one for the worker and one for the wrapper) and extra -function calls, as when we access the dictionary we will be acessing -the wrapper, which will call the worker. -The simplifier never inlines workers into wrappers, as the wrappers -themselves have INLINE pragmas attached to them (so that they are always -inlined, and we do not know in advance how many times they will be inlined). - -To solve this problem, in the last call to the simplifier we will -ignore these inline pragmas and handle the workers and the wrappers -as normal definitions. This will allow a worker to be inlined into -the wrapper if it satisfies all the criteria for inlining (e.g. it is -the only occurrence of the worker etc.). - -Run Float Inwards once more after strictness-simplify -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -[Occurred in the prelude, compiling IInt.hs, function const.Int.index.wrk] -When workers are generated after strictness analysis (worker/wrapper), -we generate them with "reboxing" lets, that simply reboxes the unboxed -arguments, as it may be the case that the worker will need the -original boxed value: - -f x y = case x of - (a,b) -> case y of - (c,d) -> case a == c of - True -> (x,x) - False -> ((1,1),(2,2)) - -==> (worker/wrapper) - -f_wrapper x y = case x of - (a,b) -> case y of - (c,d) -> f_worker a b c d - -f_worker a b c d = let x = (a,b) - y = (c,d) - in case a == c of - True -> (x,x) - False -> ((1,1),(2,2)) - -in this case the simplifier will remove the binding for y as it is not -used (we expected this to happen very often, but we do not know how -many "reboxers" are eventually removed and how many are kept), and -will keep the binding for x. But notice that x is only used in *one* -of the branches in the case, but is always being allocated! The -floating inwards pass would push its definition into the True branch. -A similar benefit occurs if it is only used inside a let definition. -These are basically the advantages of floating inwards, but they are -only exposed after the S.A./worker-wrapperisation of the code! As we -also have reasons to float inwards before S.A. we have to run it -twice. - diff --git a/driver/test_mangler b/driver/test_mangler deleted file mode 100644 index 96cf31ca68..0000000000 --- a/driver/test_mangler +++ /dev/null @@ -1,29 +0,0 @@ -#! /usr/bin/perl -# a simple wrapper to test a .s-file mangler -# reads stdin, writes stdout - -push(@INC,"/net/dazdak/BUILDS/gransim-4.04/i386-unknown-linux/ghc/driver"); - -$TargetPlatform = $ARGV[0]; shift; # nice error checking, Will - -require("ghc-asm.prl") || die "require mangler failed!\n"; - -$SpX86Mangling = 1; -$StolenX86Regs = 4; - -open(INP, "> /tmp/mangle1.$$") || die "Can't open tmp file 1\n"; -while (<>) { - print INP $_; -} -close(INP) || die "Can't close tmp file 1"; - -&mangle_asm("/tmp/mangle1.$$", "/tmp/mangle2.$$"); - -open(INP, "< /tmp/mangle2.$$") || die "Can't open tmp file 2\n"; -while (<INP>) { - print STDOUT $_; -} -close(INP) || die "Can't close tmp file 2"; - -unlink("/tmp/mangle1.$$", "/tmp/mangle2.$$"); -exit(0); diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index c635b94d1c..897f3f3d28 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1728,17 +1728,17 @@ setCmd "" nest 2 (vcat (map (warnSetting dflags) DynFlags.fWarningFlags)) )) - where flagSetting dflags (str, _, f, _) + where flagSetting dflags (str, f, _) | dopt f dflags = fstr str | otherwise = fnostr str - warnSetting dflags (str, _, f, _) + warnSetting dflags (str, f, _) | wopt f dflags = fstr str | otherwise = fnostr str fstr str = text "-f" <> text str fnostr str = text "-fno-" <> text str - (ghciFlags,others) = partition (\(_, _, f, _) -> f `elem` flags) + (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags) DynFlags.fFlags flags = [Opt_PrintExplicitForalls ,Opt_PrintBindResult @@ -2021,7 +2021,7 @@ showLanguages = do dflags <- getDynFlags liftIO $ putStrLn $ showSDoc $ vcat $ text "active language flags:" : - [text (" -X" ++ str) | (str, _, f, _) <- DynFlags.xFlags, xopt f dflags] + [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags] -- ----------------------------------------------------------------------------- diff --git a/ghc/Main.hs b/ghc/Main.hs index 0514fd2556..d44ecc58af 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -182,13 +182,13 @@ main' postLoadMode dflags0 args flagWarnings = do hsc_env <- GHC.getSession let - -- To simplify the handling of filepaths, we normalise all filepaths right + -- To simplify the handling of filepaths, we normalise all filepaths right -- away - e.g., for win32 platforms, backslashes are converted -- into forward slashes. normal_fileish_paths = map (normalise . unLoc) fileish_args (srcs, objs) = partition_args normal_fileish_paths [] [] - -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on + -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on -- the command-line. liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs) @@ -236,7 +236,7 @@ partition_args ("-x":suff:args) srcs objs | StopLn <- phase = partition_args args srcs (slurp ++ objs) | otherwise = partition_args rest (these_srcs ++ srcs) objs where phase = startPhase suff - (slurp,rest) = break (== "-x") args + (slurp,rest) = break (== "-x") args these_srcs = zip slurp (repeat (Just phase)) partition_args (arg:args) srcs objs | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs @@ -248,7 +248,7 @@ partition_args (arg:args) srcs objs The following things should be considered compilation manager inputs: - - haskell source files (strings ending in .hs, .lhs or other + - haskell source files (strings ending in .hs, .lhs or other haskellish extension), - module names (not forgetting hierarchical module names), @@ -260,7 +260,7 @@ partition_args (arg:args) srcs objs straight through to the linker. -} looks_like_an_input :: String -> Bool -looks_like_an_input m = isSourceFilename m +looks_like_an_input m = isSourceFilename m || looksLikeModuleName m || '.' `notElem` m @@ -284,10 +284,10 @@ checkOptions mode dflags srcs objs = do -- -prof and --interactive are not a good combination when (notNull (filter (not . isRTSWay) (wayNames dflags)) && isInterpretiveMode mode) $ - do ghcError (UsageError + do ghcError (UsageError "--interactive can't be used with -prof or -unreg.") -- -ohi sanity check - if (isJust (outputHi dflags) && + if (isJust (outputHi dflags) && (isCompManagerMode mode || srcs `lengthExceeds` 1)) then ghcError (UsageError "-ohi can only be used when compiling a single source file") else do @@ -316,12 +316,12 @@ checkOptions mode dflags srcs objs = do -- Compiler output options -- called to verify that the output files & directories --- point somewhere valid. +-- point somewhere valid. -- -- The assumption is that the directory portion of these output -- options will have to exist by the time 'verifyOutputFiles' -- is invoked. --- +-- verifyOutputFiles :: DynFlags -> IO () verifyOutputFiles dflags = do -- not -odir: we create the directory for -odir if it doesn't exist (#2278). @@ -336,9 +336,9 @@ verifyOutputFiles dflags = do flg <- doesDirNameExist hi when (not flg) (nonExistentDir "-ohi" hi) where - nonExistentDir flg dir = - ghcError (CmdLineError ("error: directory portion of " ++ - show dir ++ " does not exist (used with " ++ + nonExistentDir flg dir = + ghcError (CmdLineError ("error: directory portion of " ++ + show dir ++ " does not exist (used with " ++ show flg ++ " option.)")) ----------------------------------------------------------------------------- @@ -478,7 +478,7 @@ parseModeFlags :: [Located String] [Located String]) parseModeFlags args = do let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = - runCmdLine (processArgs mode_flags args CmdLineOnly True) + runCmdLine (processArgs mode_flags args) (Nothing, [], []) mode = case mModeFlag of Nothing -> doMakeMode @@ -494,16 +494,16 @@ type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) mode_flags :: [Flag ModeM] mode_flags = [ ------- help / version ---------------------------------------------- - flagC "?" (PassFlag (setMode showGhcUsageMode)) - , flagC "-help" (PassFlag (setMode showGhcUsageMode)) - , flagC "V" (PassFlag (setMode showVersionMode)) - , flagC "-version" (PassFlag (setMode showVersionMode)) - , flagC "-numeric-version" (PassFlag (setMode showNumVersionMode)) - , flagC "-info" (PassFlag (setMode showInfoMode)) - , flagC "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) - , flagC "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) + Flag "?" (PassFlag (setMode showGhcUsageMode)) + , Flag "-help" (PassFlag (setMode showGhcUsageMode)) + , Flag "V" (PassFlag (setMode showVersionMode)) + , Flag "-version" (PassFlag (setMode showVersionMode)) + , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode)) + , Flag "-info" (PassFlag (setMode showInfoMode)) + , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) + , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) ] ++ - [ flagC k' (PassFlag (setMode (printSetting k))) + [ Flag k' (PassFlag (setMode (printSetting k))) | k <- ["Project version", "Booter version", "Stage", @@ -529,21 +529,21 @@ mode_flags = replaceSpace c = c ] ++ ------- interfaces ---------------------------------------------------- - [ flagC "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) + [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) "--show-iface")) ------- primary modes ------------------------------------------------ - , flagC "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f - addFlag "-no-link" f)) - , flagC "M" (PassFlag (setMode doMkDependHSMode)) - , flagC "E" (PassFlag (setMode (stopBeforeMode anyHsc))) - , flagC "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f - addFlag "-fvia-C" f)) - , flagC "S" (PassFlag (setMode (stopBeforeMode As))) - , flagC "-make" (PassFlag (setMode doMakeMode)) - , flagC "-interactive" (PassFlag (setMode doInteractiveMode)) - , flagC "-abi-hash" (PassFlag (setMode doAbiHashMode)) - , flagC "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) + , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f + addFlag "-no-link" f)) + , Flag "M" (PassFlag (setMode doMkDependHSMode)) + , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) + , Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f + addFlag "-fvia-C" f)) + , Flag "S" (PassFlag (setMode (stopBeforeMode As))) + , Flag "-make" (PassFlag (setMode doMakeMode)) + , Flag "-interactive" (PassFlag (setMode doInteractiveMode)) + , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode)) + , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) ] setMode :: Mode -> String -> EwM ModeM () @@ -603,9 +603,9 @@ doMake :: [(String,Maybe Phase)] -> Ghc () doMake srcs = do let (hs_srcs, non_hs_srcs) = partition haskellish srcs - haskellish (f,Nothing) = + haskellish (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f - haskellish (_,Just phase) = + haskellish (_,Just phase) = phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] hsc_env <- GHC.getSession @@ -690,7 +690,7 @@ showUsage ghci dflags = do dump (c:s) = putChar c >> dump s dumpFinalStats :: DynFlags -> IO () -dumpFinalStats dflags = +dumpFinalStats dflags = when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags dumpFastStringStats :: DynFlags -> IO () @@ -715,7 +715,7 @@ dumpFastStringStats dflags = do countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int) countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z) -countFS entries longest is_z has_z (b:bs) = +countFS entries longest is_z has_z (b:bs) = let len = length b longest' = max len longest diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h index e745b0460b..fef8e00598 100644 --- a/includes/rts/storage/GC.h +++ b/includes/rts/storage/GC.h @@ -170,8 +170,8 @@ void performMajorGC(void); The CAF table - used to let us revert CAFs in GHCi -------------------------------------------------------------------------- */ -void newCAF (StgRegTable *reg, StgClosure *); -void newDynCAF (StgRegTable *reg, StgClosure *); +StgWord newCAF (StgRegTable *reg, StgClosure *caf, StgClosure *bh); +StgWord newDynCAF (StgRegTable *reg, StgClosure *caf, StgClosure *bh); void revertCAFs (void); // Request that all CAFs are retained indefinitely. diff --git a/mk/config.mk.in b/mk/config.mk.in index 89cce18261..aef093799b 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -137,7 +137,7 @@ PlatformSupportsSharedLibs = $(if $(filter $(TARGETPLATFORM),\ # the compiler you build with is generating registerised binaries), but # the stage2 compiler will be an unregisterised binary. # -ifneq "$(findstring $(HostArch_CPP), i386 x86_64 powerpc)" "" +ifneq "$(findstring $(HostArch_CPP), i386 x86_64 powerpc arm)" "" GhcUnregisterised=NO else GhcUnregisterised=YES diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index f8a9e559bf..82e89a5470 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -229,21 +229,47 @@ freeStorage (rtsBool free_heap) The entry code for every CAF does the following: - - builds a BLACKHOLE in the heap - - pushes an update frame pointing to the BLACKHOLE - - calls newCaf, below - - updates the CAF with a static indirection to the BLACKHOLE - + - builds a CAF_BLACKHOLE in the heap + + - calls newCaf, which atomically updates the CAF with + IND_STATIC pointing to the CAF_BLACKHOLE + + - if newCaf returns zero, it re-enters the CAF (see Note [atomic + CAF entry]) + + - pushes an update frame pointing to the CAF_BLACKHOLE + Why do we build an BLACKHOLE in the heap rather than just updating the thunk directly? It's so that we only need one kind of update - frame - otherwise we'd need a static version of the update frame too. + frame - otherwise we'd need a static version of the update frame + too, and various other parts of the RTS that deal with update + frames would also need special cases for static update frames. newCaf() does the following: + - it updates the CAF with an IND_STATIC pointing to the + CAF_BLACKHOLE, atomically. + - it puts the CAF on the oldest generation's mutable list. This is so that we treat the CAF as a root when collecting younger generations. + ------------------ + Note [atomic CAF entry] + + With THREADED_RTS, newCaf() is required to be atomic (see + #5558). This is because if two threads happened to enter the same + CAF simultaneously, they would create two distinct CAF_BLACKHOLEs, + and so the normal threadPaused() machinery for detecting duplicate + evaluation will not detect this. Hence in lockCAF() below, we + atomically lock the CAF with WHITEHOLE before updating it with + IND_STATIC, and return zero if another thread locked the CAF first. + In the event that we lost the race, CAF entry code will re-enter + the CAF and block on the other thread's CAF_BLACKHOLE. + + ------------------ + Note [GHCi CAFs] + For GHCI, we have additional requirements when dealing with CAFs: - we must *retain* all dynamically-loaded CAFs ever entered, @@ -264,36 +290,76 @@ freeStorage (rtsBool free_heap) -------------------------------------------------------------------------- */ -void -newCAF(StgRegTable *reg, StgClosure* caf) +STATIC_INLINE StgWord lockCAF (StgClosure *caf, StgClosure *bh) { - if(keepCAFs) - { - // HACK: - // If we are in GHCi _and_ we are using dynamic libraries, - // then we can't redirect newCAF calls to newDynCAF (see below), - // so we make newCAF behave almost like newDynCAF. - // The dynamic libraries might be used by both the interpreted - // program and GHCi itself, so they must not be reverted. - // This also means that in GHCi with dynamic libraries, CAFs are not - // garbage collected. If this turns out to be a problem, we could - // do another hack here and do an address range test on caf to figure - // out whether it is from a dynamic library. - ((StgIndStatic *)caf)->saved_info = (StgInfoTable *)caf->header.info; - - ACQUIRE_SM_LOCK; // caf_list is global, locked by sm_mutex - ((StgIndStatic *)caf)->static_link = caf_list; - caf_list = caf; - RELEASE_SM_LOCK; - } - else - { - // Put this CAF on the mutable list for the old generation. - ((StgIndStatic *)caf)->saved_info = NULL; - if (oldest_gen->no != 0) { - recordMutableCap(caf, regTableToCapability(reg), oldest_gen->no); + const StgInfoTable *orig_info; + + orig_info = caf->header.info; + +#ifdef THREADED_RTS + const StgInfoTable *cur_info; + + if (orig_info == &stg_IND_STATIC_info || + orig_info == &stg_WHITEHOLE_info) { + // already claimed by another thread; re-enter the CAF + return 0; } - } + + cur_info = (const StgInfoTable *) + cas((StgVolatilePtr)&caf->header.info, + (StgWord)orig_info, + (StgWord)&stg_WHITEHOLE_info); + + if (cur_info != orig_info) { + // already claimed by another thread; re-enter the CAF + return 0; + } + + // successfully claimed by us; overwrite with IND_STATIC +#endif + + // For the benefit of revertCAFs(), save the original info pointer + ((StgIndStatic *)caf)->saved_info = orig_info; + + ((StgIndStatic*)caf)->indirectee = bh; + write_barrier(); + SET_INFO(caf,&stg_IND_STATIC_info); + + return 1; +} + +StgWord +newCAF(StgRegTable *reg, StgClosure *caf, StgClosure *bh) +{ + if (lockCAF(caf,bh) == 0) return 0; + + if(keepCAFs) + { + // HACK: + // If we are in GHCi _and_ we are using dynamic libraries, + // then we can't redirect newCAF calls to newDynCAF (see below), + // so we make newCAF behave almost like newDynCAF. + // The dynamic libraries might be used by both the interpreted + // program and GHCi itself, so they must not be reverted. + // This also means that in GHCi with dynamic libraries, CAFs are not + // garbage collected. If this turns out to be a problem, we could + // do another hack here and do an address range test on caf to figure + // out whether it is from a dynamic library. + + ACQUIRE_SM_LOCK; // caf_list is global, locked by sm_mutex + ((StgIndStatic *)caf)->static_link = caf_list; + caf_list = caf; + RELEASE_SM_LOCK; + } + else + { + // Put this CAF on the mutable list for the old generation. + ((StgIndStatic *)caf)->saved_info = NULL; + if (oldest_gen->no != 0) { + recordMutableCap(caf, regTableToCapability(reg), oldest_gen->no); + } + } + return 1; } // External API for setting the keepCAFs flag. see #3900. @@ -312,16 +378,19 @@ setKeepCAFs (void) // // The linker hackily arranges that references to newCaf from dynamic // code end up pointing to newDynCAF. -void -newDynCAF (StgRegTable *reg STG_UNUSED, StgClosure *caf) +StgWord +newDynCAF (StgRegTable *reg STG_UNUSED, StgClosure *caf, StgClosure *bh) { + if (lockCAF(caf,bh) == 0) return 0; + ACQUIRE_SM_LOCK; - ((StgIndStatic *)caf)->saved_info = (StgInfoTable *)caf->header.info; ((StgIndStatic *)caf)->static_link = revertible_caf_list; revertible_caf_list = caf; RELEASE_SM_LOCK; + + return 1; } /* ----------------------------------------------------------------------------- |