From: Ian Lynagh Date: Sun, 8 May 2011 15:13:33 +0000 (+0100) Subject: Merge branch 'coloured-core' of https://github.com/nominolo/ghc into coloured-core X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=d45197aabb22178066a8ec50d29331786a0c518c;hp=-c Merge branch 'coloured-core' of https://github.com/nominolo/ghc into coloured-core --- d45197aabb22178066a8ec50d29331786a0c518c diff --combined compiler/basicTypes/Module.lhs index 03f541e,108bd8d..89b3edd --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@@ -73,7 -73,6 +73,6 @@@ module Modul import Config import Outputable - import qualified Pretty import Unique import UniqFM import FastString @@@ -155,7 -154,6 +154,7 @@@ addBootSuffixLocn loc \begin{code} -- | A ModuleName is essentially a simple string, e.g. @Data.List@. newtype ModuleName = ModuleName FastString + deriving Typeable instance Uniquable ModuleName where getUnique (ModuleName nm) = getUnique nm @@@ -176,6 -174,8 +175,6 @@@ instance Binary ModuleName wher put_ bh (ModuleName fs) = put_ bh fs get bh = do fs <- get bh; return (ModuleName fs) -INSTANCE_TYPEABLE0(ModuleName,moduleNameTc,"ModuleName") - instance Data ModuleName where -- don't traverse? toConstr _ = abstractConstr "ModuleName" @@@ -223,7 -223,7 +222,7 @@@ data Module = Module modulePackageId :: !PackageId, -- pkg-1.0 moduleName :: !ModuleName -- A.B.C } - deriving (Eq, Ord) + deriving (Eq, Ord, Typeable) instance Uniquable Module where getUnique (Module p n) = getUnique (packageIdFS p `appendFS` moduleNameFS n) @@@ -235,6 -235,8 +234,6 @@@ instance Binary Module wher put_ bh (Module p n) = put_ bh p >> put_ bh n get bh = do p <- get bh; n <- get bh; return (Module p n) -INSTANCE_TYPEABLE0(Module,moduleTc,"Module") - instance Data Module where -- don't traverse? toConstr _ = abstractConstr "Module" @@@ -253,9 -255,10 +252,10 @@@ mkModule :: PackageId -> ModuleName -> mkModule = Module pprModule :: Module -> SDoc - pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n + pprModule mod@(Module p n) = + pprPackagePrefix p mod <> pprModuleName n - pprPackagePrefix :: PackageId -> Module -> PprStyle -> Pretty.Doc + pprPackagePrefix :: PackageId -> Module -> SDoc pprPackagePrefix p mod = getPprStyle doc where doc sty @@@ -277,7 -280,7 +277,7 @@@ \begin{code} -- | Essentially just a string identifying a package, including the version: e.g. parsec-1.0 -newtype PackageId = PId FastString deriving( Eq ) +newtype PackageId = PId FastString deriving( Eq, Typeable ) -- here to avoid module loops with PackageConfig instance Uniquable PackageId where @@@ -288,6 -291,8 +288,6 @@@ instance Ord PackageId where nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 -INSTANCE_TYPEABLE0(PackageId,packageIdTc,"PackageId") - instance Data PackageId where -- don't traverse? toConstr _ = abstractConstr "PackageId" diff --combined compiler/main/DynFlags.hs index 2f3e9f4,9eac33c..e405aea --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@@ -1,3 -1,6 +1,3 @@@ -{-# OPTIONS_GHC -w #-} --- Temporary, until rtsIsProfiled is fixed - -- | -- Dynamic flags -- @@@ -32,21 -35,12 +32,21 @@@ module DynFlags DPHBackend(..), dphPackageMaybe, wayNames, + Settings(..), + ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, + extraGccViaCFlags, systemPackageConfig, + pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, + pgm_sysman, pgm_windres, pgm_lo, pgm_lc, + opt_L, opt_P, opt_F, opt_c, opt_m, opt_a, opt_l, + opt_windres, opt_lo, opt_lc, + + -- ** Manipulating DynFlags - defaultDynFlags, -- DynFlags + defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] - getVerbFlag, + getVerbFlags, updOptLevel, setTmpDir, setPackageName, @@@ -60,13 -54,14 +60,13 @@@ supportedLanguagesAndExtensions, -- ** DynFlag C compiler options - machdepCCOpts, picCCOpts, + picCCOpts, -- * Configuration of the stg-to-stg passes StgToDo(..), getStgToDo, -- * Compiler configuration suitable for display to the user - Printable(..), compilerInfo #ifdef GHCI -- Only in stage 2 can we be sure that the RTS @@@ -77,7 -72,9 +77,7 @@@ #include "HsVersions.h" -#ifndef OMIT_NATIVE_CODEGEN import Platform -#endif import Module import PackageConfig import PrelNames ( mAIN ) @@@ -93,14 -90,10 +93,14 @@@ import Maybes ( orElse import SrcLoc import FastString import Outputable +#ifdef GHCI import Foreign.C ( CInt ) +#endif import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) +#ifdef GHCI import System.IO.Unsafe ( unsafePerformIO ) +#endif import Data.IORef import Control.Monad ( when ) @@@ -108,6 -101,7 +108,6 @@@ import Data.Cha import Data.List import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe import System.FilePath import System.IO ( stderr, hPutChar ) @@@ -258,6 -252,7 +258,6 @@@ data DynFla | Opt_Pp | Opt_ForceRecomp | Opt_DryRun - | Opt_DoAsmMangling | Opt_ExcessPrecision | Opt_EagerBlackHoling | Opt_ReadUserPackageConf @@@ -294,6 -289,7 +294,6 @@@ | Opt_KeepHiDiffs | Opt_KeepHcFiles | Opt_KeepSFiles - | Opt_KeepRawSFiles | Opt_KeepTmpFiles | Opt_KeepRawTokenStream | Opt_KeepLlvmFiles @@@ -357,7 -353,6 +357,7 @@@ data ExtensionFla | Opt_KindSignatures | Opt_ParallelListComp | Opt_TransformListComp + | Opt_MonadComprehensions | Opt_GeneralizedNewtypeDeriving | Opt_RecursiveDo | Opt_DoRec @@@ -400,7 -395,10 +400,7 @@@ data DynFlags = DynFlags floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating -- See CoreMonad.FloatOutSwitches -#ifndef OMIT_NATIVE_CODEGEN - targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG. -#endif - stolen_x86_regs :: Int, + targetPlatform :: Platform.Platform, -- ^ The platform we're compiling for. Used by the NCG. cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ importPaths :: [FilePath], mainModIs :: Module, @@@ -445,13 -443,42 +445,13 @@@ libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only cmdlineFrameworks :: [String], -- ditto - tmpDir :: String, -- no trailing '/' - ghcUsagePath :: FilePath, -- Filled in by SysTools - ghciUsagePath :: FilePath, -- ditto rtsOpts :: Maybe String, rtsOptsEnabled :: RtsOptsEnabled, hpcDir :: String, -- ^ Path to store the .mix files - -- options for particular phases - opt_L :: [String], - opt_P :: [String], - opt_F :: [String], - opt_c :: [String], - opt_m :: [String], - opt_a :: [String], - opt_l :: [String], - opt_windres :: [String], - opt_lo :: [String], -- LLVM: llvm optimiser - opt_lc :: [String], -- LLVM: llc static compiler - - -- commands for particular phases - pgm_L :: String, - pgm_P :: (String,[Option]), - pgm_F :: String, - pgm_c :: (String,[Option]), - pgm_m :: (String,[Option]), - pgm_s :: (String,[Option]), - pgm_a :: (String,[Option]), - pgm_l :: (String,[Option]), - pgm_dll :: (String,[Option]), - pgm_T :: String, - pgm_sysman :: String, - pgm_windres :: String, - pgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser - pgm_lc :: (String,[Option]), -- LLVM: llc static compiler + settings :: Settings, -- For ghc -M depMakefile :: FilePath, @@@ -461,6 -488,8 +461,6 @@@ -- Package flags extraPkgConfs :: [FilePath], - topDir :: FilePath, -- filled in by SysTools - systemPackageConfig :: FilePath, -- ditto -- ^ The @-package-conf@ flags given on the command line, in the order -- they appeared. @@@ -495,105 -524,6 +495,105 @@@ haddockOptions :: Maybe String } +data Settings = Settings { + sGhcUsagePath :: FilePath, -- Filled in by SysTools + sGhciUsagePath :: FilePath, -- ditto + sTopDir :: FilePath, + sTmpDir :: String, -- no trailing '/' + -- You shouldn't need to look things up in rawSettings directly. + -- They should have their own fields instead. + sRawSettings :: [(String, String)], + sExtraGccViaCFlags :: [String], + sSystemPackageConfig :: FilePath, + -- commands for particular phases + sPgm_L :: String, + sPgm_P :: (String,[Option]), + sPgm_F :: String, + sPgm_c :: (String,[Option]), + sPgm_s :: (String,[Option]), + sPgm_a :: (String,[Option]), + sPgm_l :: (String,[Option]), + sPgm_dll :: (String,[Option]), + sPgm_T :: String, + sPgm_sysman :: String, + sPgm_windres :: String, + sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser + sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler + -- options for particular phases + sOpt_L :: [String], + sOpt_P :: [String], + sOpt_F :: [String], + sOpt_c :: [String], + sOpt_m :: [String], + sOpt_a :: [String], + sOpt_l :: [String], + sOpt_windres :: [String], + sOpt_lo :: [String], -- LLVM: llvm optimiser + sOpt_lc :: [String] -- LLVM: llc static compiler + + } + +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = sGhcUsagePath (settings dflags) +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = sGhciUsagePath (settings dflags) +topDir :: DynFlags -> FilePath +topDir dflags = sTopDir (settings dflags) +tmpDir :: DynFlags -> String +tmpDir dflags = sTmpDir (settings dflags) +rawSettings :: DynFlags -> [(String, String)] +rawSettings dflags = sRawSettings (settings dflags) +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags) +systemPackageConfig :: DynFlags -> FilePath +systemPackageConfig dflags = sSystemPackageConfig (settings dflags) +pgm_L :: DynFlags -> String +pgm_L dflags = sPgm_L (settings dflags) +pgm_P :: DynFlags -> (String,[Option]) +pgm_P dflags = sPgm_P (settings dflags) +pgm_F :: DynFlags -> String +pgm_F dflags = sPgm_F (settings dflags) +pgm_c :: DynFlags -> (String,[Option]) +pgm_c dflags = sPgm_c (settings dflags) +pgm_s :: DynFlags -> (String,[Option]) +pgm_s dflags = sPgm_s (settings dflags) +pgm_a :: DynFlags -> (String,[Option]) +pgm_a dflags = sPgm_a (settings dflags) +pgm_l :: DynFlags -> (String,[Option]) +pgm_l dflags = sPgm_l (settings dflags) +pgm_dll :: DynFlags -> (String,[Option]) +pgm_dll dflags = sPgm_dll (settings dflags) +pgm_T :: DynFlags -> String +pgm_T dflags = sPgm_T (settings dflags) +pgm_sysman :: DynFlags -> String +pgm_sysman dflags = sPgm_sysman (settings dflags) +pgm_windres :: DynFlags -> String +pgm_windres dflags = sPgm_windres (settings dflags) +pgm_lo :: DynFlags -> (String,[Option]) +pgm_lo dflags = sPgm_lo (settings dflags) +pgm_lc :: DynFlags -> (String,[Option]) +pgm_lc dflags = sPgm_lc (settings dflags) +opt_L :: DynFlags -> [String] +opt_L dflags = sOpt_L (settings dflags) +opt_P :: DynFlags -> [String] +opt_P dflags = sOpt_P (settings dflags) +opt_F :: DynFlags -> [String] +opt_F dflags = sOpt_F (settings dflags) +opt_c :: DynFlags -> [String] +opt_c dflags = sOpt_c (settings dflags) +opt_m :: DynFlags -> [String] +opt_m dflags = sOpt_m (settings dflags) +opt_a :: DynFlags -> [String] +opt_a dflags = sOpt_a (settings dflags) +opt_l :: DynFlags -> [String] +opt_l dflags = sOpt_l (settings dflags) +opt_windres :: DynFlags -> [String] +opt_windres dflags = sOpt_windres (settings dflags) +opt_lo :: DynFlags -> [String] +opt_lo dflags = sOpt_lo (settings dflags) +opt_lc :: DynFlags -> [String] +opt_lc dflags = sOpt_lc (settings dflags) + wayNames :: DynFlags -> [WayName] wayNames = map wayName . ways @@@ -626,14 -556,6 +626,14 @@@ data HscTarge | HscNothing -- ^ Don't generate any code. See notes above. deriving (Eq, Show) +showHscTargetFlag :: HscTarget -> String +showHscTargetFlag HscC = "-fvia-c" +showHscTargetFlag HscAsm = "-fasm" +showHscTargetFlag HscLlvm = "-fllvm" +showHscTargetFlag HscJava = panic "No flag for HscJava" +showHscTargetFlag HscInterpreted = "-fbyte-code" +showHscTargetFlag HscNothing = "-fno-code" + -- | Will this target result in an object file on the disk? isObjectTarget :: HscTarget -> Bool isObjectTarget HscC = True @@@ -696,9 -618,8 +696,9 @@@ defaultHscTarget = defaultObjectTarge -- object files on the current platform. defaultObjectTarget :: HscTarget defaultObjectTarget + | cGhcUnregisterised == "YES" = HscC | cGhcWithNativeCodeGen == "YES" = HscAsm - | otherwise = HscC + | otherwise = HscLlvm data DynLibLoader = Deployable @@@ -706,7 -627,6 +706,7 @@@ deriving Eq data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll + deriving (Show) -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags @@@ -725,8 -645,8 +725,8 @@@ initDynFlags dflags = d -- | The normal 'DynFlags'. Note that they is not suitable for use in this form -- and must be fully initialized by 'GHC.newSession' first. -defaultDynFlags :: DynFlags -defaultDynFlags = +defaultDynFlags :: Settings -> DynFlags +defaultDynFlags mySettings = DynFlags { ghcMode = CompManager, ghcLink = LinkBinary, @@@ -745,7 -665,10 +745,7 @@@ floatLamArgs = Just 0, -- Default: float only if no fvs strictnessBefore = [], -#ifndef OMIT_NATIVE_CODEGEN targetPlatform = defaultTargetPlatform, -#endif - stolen_x86_regs = 4, cmdlineHcIncludes = [], importPaths = ["."], mainModIs = mAIN, @@@ -774,11 -697,25 +774,11 @@@ libraryPaths = [], frameworkPaths = [], cmdlineFrameworks = [], - tmpDir = cDEFAULT_TMPDIR, rtsOpts = Nothing, rtsOptsEnabled = RtsOptsSafeOnly, hpcDir = ".hpc", - opt_L = [], - opt_P = (if opt_PIC - then ["-D__PIC__", "-U __PIC__"] -- this list is reversed - else []), - opt_F = [], - opt_c = [], - opt_a = [], - opt_m = [], - opt_l = [], - opt_windres = [], - opt_lo = [], - opt_lc = [], - extraPkgConfs = [], packageFlags = [], pkgDatabase = Nothing, @@@ -787,7 -724,26 +787,7 @@@ buildTag = panic "defaultDynFlags: No buildTag", rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag", splitInfo = Nothing, - -- initSysTools fills all these in - ghcUsagePath = panic "defaultDynFlags: No ghciUsagePath", - ghciUsagePath = panic "defaultDynFlags: No ghciUsagePath", - topDir = panic "defaultDynFlags: No topDir", - systemPackageConfig = panic "no systemPackageConfig: call GHC.setSessionDynFlags", - pgm_L = panic "defaultDynFlags: No pgm_L", - pgm_P = panic "defaultDynFlags: No pgm_P", - pgm_F = panic "defaultDynFlags: No pgm_F", - pgm_c = panic "defaultDynFlags: No pgm_c", - pgm_m = panic "defaultDynFlags: No pgm_m", - pgm_s = panic "defaultDynFlags: No pgm_s", - pgm_a = panic "defaultDynFlags: No pgm_a", - pgm_l = panic "defaultDynFlags: No pgm_l", - pgm_dll = panic "defaultDynFlags: No pgm_dll", - pgm_T = panic "defaultDynFlags: No pgm_T", - pgm_sysman = panic "defaultDynFlags: No pgm_sysman", - pgm_windres = panic "defaultDynFlags: No pgm_windres", - pgm_lo = panic "defaultDynFlags: No pgm_lo", - pgm_lc = panic "defaultDynFlags: No pgm_lc", - -- end of initSysTools values + settings = mySettings, -- ghc -M values depMakefile = "Makefile", depIncludePkgDeps = False, @@@ -804,12 -760,12 +804,12 @@@ log_action = \severity srcSpan style msg -> case severity of - SevOutput -> printOutput (msg style) - SevInfo -> printErrs (msg style) - SevFatal -> printErrs (msg style) + SevOutput -> printSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style _ -> do hPutChar stderr '\n' - printErrs ((mkLocMessage srcSpan msg) style) + printErrs (mkLocMessage srcSpan msg) style -- careful (#2302): printErrs prints in UTF-8, whereas -- converting to string first and using hPutStr would -- just emit the low 8 bits of each unicode char. @@@ -922,10 -878,10 +922,10 @@@ getOpts dflags opts = reverse (opts dfl -- | Gets the verbosity flag for the current verbosity level. This is fed to -- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included -getVerbFlag :: DynFlags -> String -getVerbFlag dflags - | verbosity dflags >= 3 = "-v" - | otherwise = "" +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] setObjectDir, setHiDir, setStubDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, @@@ -961,9 -917,9 +961,9 @@@ setDumpPrefixForce f d = d { dumpPrefix -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. -setPgmP f d = let (pgm:args) = words f in d{ pgm_P = (pgm, map Option args)} -addOptl f d = d{ opt_l = f : opt_l d} -addOptP f d = d{ opt_P = f : opt_P d} +setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) +addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s}) +addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s}) setDepMakefile :: FilePath -> DynFlags -> DynFlags @@@ -1101,7 -1057,16 +1101,7 @@@ parseDynamicFlags_ dflags0 args pkg_fla = runCmdLine (processArgs flag_spec args') dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs - let (pic_warns, dflags2) -#if !(x86_64_TARGET_ARCH && linux_TARGET_OS) - | (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm - = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -" - ++ "dynamic on this platform;\n ignoring -fllvm"], - dflags1{ hscTarget = HscAsm }) -#endif - | otherwise = ([], dflags1) - - return (dflags2, leftover, pic_warns ++ warns) + return (dflags1, leftover, warns) {- ********************************************************************** @@@ -1135,30 -1100,30 +1135,30 @@@ dynamic_flags = ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. - , Flag "pgmlo" (hasArg (\f d -> d{ pgm_lo = (f,[])})) - , Flag "pgmlc" (hasArg (\f d -> d{ pgm_lc = (f,[])})) - , Flag "pgmL" (hasArg (\f d -> d{ pgm_L = 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 d -> d{ pgm_F = f})) - , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])})) - , Flag "pgmm" (hasArg (\f d -> d{ pgm_m = (f,[])})) - , Flag "pgms" (hasArg (\f d -> d{ pgm_s = (f,[])})) - , Flag "pgma" (hasArg (\f d -> d{ pgm_a = (f,[])})) - , Flag "pgml" (hasArg (\f d -> d{ pgm_l = (f,[])})) - , Flag "pgmdll" (hasArg (\f d -> d{ pgm_dll = (f,[])})) - , Flag "pgmwindres" (hasArg (\f d -> d{ pgm_windres = f})) + , 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 -keep-raw-s-files 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. - , Flag "optlo" (hasArg (\f d -> d{ opt_lo = f : opt_lo d})) - , Flag "optlc" (hasArg (\f d -> d{ opt_lc = f : opt_lc d})) - , Flag "optL" (hasArg (\f d -> d{ opt_L = f : opt_L d})) + , 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 d -> d{ opt_F = f : opt_F d})) - , Flag "optc" (hasArg (\f d -> d{ opt_c = f : opt_c d})) - , Flag "optm" (hasArg (\f d -> d{ opt_m = f : opt_m d})) - , Flag "opta" (hasArg (\f d -> d{ opt_a = f : opt_a d})) + , 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 (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s}))) + , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) , Flag "optl" (hasArg addOptl) - , Flag "optwindres" (hasArg (\f d -> d{ opt_windres = f : opt_windres d})) + , Flag "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) , Flag "split-objs" (NoArg (if can_split @@@ -1212,8 -1177,8 +1212,8 @@@ , 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 (setDynFlag Opt_KeepRawSFiles)) - , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles)) + , 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 @@@ -1324,9 -1289,9 +1324,9 @@@ ------ Machine dependant (-m) stuff --------------------------- - , Flag "monly-2-regs" (noArg (\s -> s{stolen_x86_regs = 2})) - , Flag "monly-3-regs" (noArg (\s -> s{stolen_x86_regs = 3})) - , Flag "monly-4-regs" (noArg (\s -> s{stolen_x86_regs = 4})) + , 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)) ------ Warning opts ------------------------------------------------- @@@ -1339,11 -1304,10 +1339,11 @@@ , Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) ------ Optimisation flags ------------------------------------------ - , Flag "O" (noArg (setOptLevel 1)) - , Flag "Onot" (noArgDF (setOptLevel 0) "Use -O0 instead") - , Flag "Odph" (noArg setDPHOpt) - , Flag "O" (OptIntSuffix (\mb_n -> upd (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 , Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) @@@ -1358,7 -1322,7 +1358,7 @@@ , 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" (intSuffix (\n d -> d{ floatLamArgs = Nothing })) + , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) ------ Profiling ---------------------------------------------------- @@@ -1514,6 -1478,7 +1514,6 @@@ fFlags = ( "dicts-cheap", Opt_DictsCheap, nop ), ( "excess-precision", Opt_ExcessPrecision, nop ), ( "eager-blackholing", Opt_EagerBlackHoling, nop ), - ( "asm-mangling", Opt_DoAsmMangling, nop ), ( "print-bind-result", Opt_PrintBindResult, nop ), ( "force-recomp", Opt_ForceRecomp, nop ), ( "hpc-no-auto", Opt_Hpc_No_Auto, nop ), @@@ -1610,7 -1575,6 +1610,7 @@@ xFlags = ( "EmptyDataDecls", Opt_EmptyDataDecls, nop ), ( "ParallelListComp", Opt_ParallelListComp, nop ), ( "TransformListComp", Opt_TransformListComp, nop ), + ( "MonadComprehensions", Opt_MonadComprehensions, nop), ( "ForeignFunctionInterface", Opt_ForeignFunctionInterface, nop ), ( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ), ( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ), @@@ -1619,9 -1583,9 +1619,9 @@@ ( "RankNTypes", Opt_RankNTypes, nop ), ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), ( "TypeOperators", Opt_TypeOperators, nop ), - ( "RecursiveDo", Opt_RecursiveDo, + ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo' deprecatedForExtension "DoRec"), - ( "DoRec", Opt_DoRec, nop ), + ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword ( "Arrows", Opt_Arrows, nop ), ( "ParallelArrays", Opt_ParallelArrays, nop ), ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), @@@ -1686,12 -1650,10 +1686,12 @@@ defaultFlag = [ Opt_AutoLinkPackages, Opt_ReadUserPackageConf, - Opt_DoAsmMangling, - Opt_SharedImplib, +#if GHC_DEFAULT_NEW_CODEGEN + Opt_TryNewCodeGen, +#endif + Opt_GenManifest, Opt_EmbedManifest, Opt_PrintBindContents, @@@ -1875,20 -1837,18 +1875,20 @@@ foreign import ccall unsafe "rts_isProf rtsIsProfiled :: Bool rtsIsProfiled = unsafePerformIO rtsIsProfiledIO /= 0 +#endif checkTemplateHaskellOk :: Bool -> DynP () -checkTemplateHaskellOk turn_on +#ifdef GHCI +checkTemplateHaskellOk turn_on | turn_on && rtsIsProfiled = addErr "You can't use Template Haskell with a profiled compiler" | otherwise = return () #else --- In stage 1 we don't know that the RTS has rts_isProfiled, +-- 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 -- available in stage 1 anyway. -checkTemplateHaskellOk turn_on = return () +checkTemplateHaskellOk _ = return () #endif {- ********************************************************************** @@@ -1900,21 -1860,13 +1900,21 @@@ type DynP = EwM (CmdLineP DynFlags) upd :: (DynFlags -> DynFlags) -> DynP () -upd f = liftEwM (do { dfs <- getCmdLineState - ; putCmdLineState $! (f dfs) }) +upd f = liftEwM (do dflags <- getCmdLineState + putCmdLineState $! f dflags) + +updM :: (DynFlags -> DynP DynFlags) -> DynP () +updM f = do dflags <- liftEwM getCmdLineState + dflags' <- f dflags + liftEwM $ putCmdLineState $! dflags' --------------- Constructor functions for OptKind ----------------- noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) noArg fn = NoArg (upd fn) +noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +noArgM fn = NoArg (updM fn) + noArgDF :: (DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynFlags) noArgDF fn deprec = NoArg (upd fn >> deprecate deprec) @@@ -1928,10 -1880,6 +1928,10 @@@ hasArgDF fn deprec = HasArg (\s -> do intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) intSuffix fn = IntSuffix (\n -> upd (fn n)) +optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) + -> OptKind (CmdLineP DynFlags) +optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) + setDumpFlag :: DynFlag -> OptKind (CmdLineP DynFlags) setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) @@@ -1957,10 -1905,6 +1957,10 @@@ unSetExtensionFlag f = upd (\dfs -> xop -- (except for -fno-glasgow-exts, which is treated specially) -------------------------- +alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags +alterSettings f dflags = dflags { settings = f (settings dflags) } + +-------------------------- setDumpFlag' :: DynFlag -> DynP () setDumpFlag' dump_flag = do { setDynFlag dump_flag @@@ -2030,43 -1974,20 +2030,43 @@@ setTarget l = upd se -- not from bytecode to object-code. The idea is that -fasm/-fllvm -- can be safely used in an OPTIONS_GHC pragma. setObjTarget :: HscTarget -> DynP () -setObjTarget l = upd set +setObjTarget l = updM set where - set dfs - | isObjectTarget (hscTarget dfs) = dfs { hscTarget = l } - | otherwise = dfs - -setOptLevel :: Int -> DynFlags -> DynFlags + set dflags + | isObjectTarget (hscTarget dflags) + = case l of + HscC + | cGhcUnregisterised /= "YES" -> + do addWarn ("Compiler not unregisterised, so ignoring " ++ flag) + return dflags + HscAsm + | cGhcWithNativeCodeGen /= "YES" -> + do addWarn ("Compiler has no native codegen, so ignoring " ++ + flag) + return dflags + HscLlvm + | cGhcUnregisterised == "YES" -> + do addWarn ("Compiler unregisterised, so ignoring " ++ flag) + return dflags + | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) && + (not opt_Static || opt_PIC) + -> + do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform") + return dflags + _ -> return $ dflags { hscTarget = l } + | otherwise = return dflags + where platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + flag = showHscTargetFlag l + +setOptLevel :: Int -> DynFlags -> DynP DynFlags setOptLevel n dflags | hscTarget dflags == HscInterpreted && n > 0 - = dflags - -- not in IO any more, oh well: - -- putStr "warning: -O conflicts with --interactive; -O ignored.\n" + = do addWarn "-O conflicts with --interactive; -O ignored." + return dflags | otherwise - = updOptLevel n dflags + = return (updOptLevel n dflags) -- -Odph is equivalent to @@@ -2075,7 -1996,7 +2075,7 @@@ -- -fmax-simplifier-iterations20 this is necessary sometimes -- -fsimplifier-phases=3 we use an additional simplifier phase for fusion -- -setDPHOpt :: DynFlags -> DynFlags +setDPHOpt :: DynFlags -> DynP DynFlags setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 , simplPhases = 3 }) @@@ -2198,7 -2119,7 +2198,7 @@@ splitPathList s = filter notNull (split -- tmpDir, where we store temporary files. setTmpDir :: FilePath -> DynFlags -> DynFlags -setTmpDir dir dflags = dflags{ tmpDir = normalise dir } +setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir }) -- we used to fix /cygdrive/c/.. on Windows, but this doesn't -- seem necessary now --SDM 7/2/2008 @@@ -2223,14 -2144,103 +2223,14 @@@ setOptHpcDir arg = upd $ \ d -> d{hpcD -- There are some options that we need to pass to gcc when compiling -- Haskell code via C, but are only supported by recent versions of -- gcc. The configure script decides which of these options we need, --- and puts them in the file "extra-gcc-opts" in $topdir, which is --- read before each via-C compilation. The advantage of having these --- in a separate file is that the file can be created at install-time --- depending on the available gcc version, and even re-generated later --- if gcc is upgraded. +-- and puts them in the "settings" file in $topdir. The advantage of +-- having these in a separate file is that the file can be created at +-- install-time depending on the available gcc version, and even +-- re-generated later if gcc is upgraded. -- -- The options below are not dependent on the version of gcc, only the -- platform. -machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts dflags = let (flagsAll, flagsRegHc) = machdepCCOpts' dflags - in (cCcOpts ++ flagsAll, flagsRegHc) - -machdepCCOpts' :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts' _dflags -#if alpha_TARGET_ARCH - = ( ["-w", "-mieee" -#ifdef HAVE_THREADED_RTS_SUPPORT - , "-D_REENTRANT" -#endif - ], [] ) - -- For now, to suppress the gcc warning "call-clobbered - -- register used for global register variable", we simply - -- disable all warnings altogether using the -w flag. Oh well. - -#elif hppa_TARGET_ARCH - -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! - -- (very nice, but too bad the HP /usr/include files don't agree.) - = ( ["-D_HPUX_SOURCE"], [] ) - -#elif m68k_TARGET_ARCH - -- -fno-defer-pop : for the .hc files, we want all the pushing/ - -- popping of args to routines to be explicit; if we let things - -- be deferred 'til after an STGJUMP, imminent death is certain! - -- - -- -fomit-frame-pointer : *don't* - -- It's better to have a6 completely tied up being a frame pointer - -- rather than let GCC pick random things to do with it. - -- (If we want to steal a6, then we would try to do things - -- as on iX86, where we *do* steal the frame pointer [%ebp].) - = ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] ) - -#elif i386_TARGET_ARCH - -- -fno-defer-pop : basically the same game as for m68k - -- - -- -fomit-frame-pointer : *must* in .hc files; because we're stealing - -- the fp (%ebp) for our register maps. - = let n_regs = stolen_x86_regs _dflags - in - ( - [ if opt_Static then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" - ], - [ "-fno-defer-pop", - "-fomit-frame-pointer", - -- we want -fno-builtin, because when gcc inlines - -- built-in functions like memcpy() it tends to - -- run out of registers, requiring -monly-n-regs - "-fno-builtin", - "-DSTOLEN_X86_REGS="++show n_regs ] - ) - -#elif ia64_TARGET_ARCH - = ( [], ["-fomit-frame-pointer", "-G0"] ) - -#elif x86_64_TARGET_ARCH - = ( - [], - ["-fomit-frame-pointer", - "-fno-asynchronous-unwind-tables", - -- the unwind tables are unnecessary for HC code, - -- and get in the way of -split-objs. Another option - -- would be to throw them away in the mangler, but this - -- is easier. - "-fno-builtin" - -- calling builtins like strlen() using the FFI can - -- cause gcc to run out of regs, so use the external - -- version. - ] ) - -#elif sparc_TARGET_ARCH - = ( [], ["-w"] ) - -- For now, to suppress the gcc warning "call-clobbered - -- register used for global register variable", we simply - -- disable all warnings altogether using the -w flag. Oh well. - -#elif powerpc_apple_darwin_TARGET - -- -no-cpp-precomp: - -- Disable Apple's precompiling preprocessor. It's a great thing - -- for "normal" programs, but it doesn't support register variable - -- declarations. - = ( [], ["-no-cpp-precomp"] ) -#else - = ( [], [] ) -#endif - picCCOpts :: DynFlags -> [String] picCCOpts _dflags #if darwin_TARGET_OS @@@ -2273,34 -2283,30 +2273,34 @@@ can_split = cSupportsSplitObjs == "YES -- ----------------------------------------------------------------------------- -- Compiler Info -data Printable = String String - | FromDynFlags (DynFlags -> String) - -compilerInfo :: [(String, Printable)] -compilerInfo = [("Project name", String cProjectName), - ("Project version", String cProjectVersion), - ("Booter version", String cBooterVersion), - ("Stage", String cStage), - ("Build platform", String cBuildPlatformString), - ("Host platform", String cHostPlatformString), - ("Target platform", String cTargetPlatformString), - ("Have interpreter", String cGhcWithInterpreter), - ("Object splitting supported", String cSupportsSplitObjs), - ("Have native code generator", String cGhcWithNativeCodeGen), - ("Support SMP", String cGhcWithSMP), - ("Unregisterised", String cGhcUnregisterised), - ("Tables next to code", String cGhcEnableTablesNextToCode), - ("RTS ways", String cGhcRTSWays), - ("Leading underscore", String cLeadingUnderscore), - ("Debug on", String (show debugIsOn)), - ("LibDir", FromDynFlags topDir), - ("Global Package DB", FromDynFlags systemPackageConfig), - ("C compiler flags", String (show cCcOpts)), - ("Gcc Linker flags", String (show cGccLinkerOpts)), - ("Ld Linker flags", String (show cLdLinkerOpts)) - ] +compilerInfo :: DynFlags -> [(String, String)] +compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : rawSettings dflags + ++ [("Project version", cProjectVersion), + ("Booter version", cBooterVersion), + ("Stage", cStage), + ("Build platform", cBuildPlatformString), + ("Host platform", cHostPlatformString), + ("Target platform", cTargetPlatformString), + ("Have interpreter", cGhcWithInterpreter), + ("Object splitting supported", cSupportsSplitObjs), + ("Have native code generator", cGhcWithNativeCodeGen), + ("Support SMP", cGhcWithSMP), + ("Unregisterised", cGhcUnregisterised), + ("Tables next to code", cGhcEnableTablesNextToCode), + ("RTS ways", cGhcRTSWays), + ("Leading underscore", cLeadingUnderscore), + ("Debug on", show debugIsOn), + ("LibDir", topDir dflags), + ("Global Package DB", systemPackageConfig dflags), + ("Gcc Linker flags", show cGccLinkerOpts), + ("Ld Linker flags", show cLdLinkerOpts) + ] diff --combined compiler/nativeGen/AsmCodeGen.lhs index c99629c,0ce95ef..07acbbb --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@@ -13,7 -13,13 +13,7 @@@ module AsmCodeGen ( nativeCodeGen ) whe #include "nativeGen/NCG.h" -#if alpha_TARGET_ARCH -import Alpha.CodeGen -import Alpha.Regs -import Alpha.RegInfo -import Alpha.Instr - -#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH +#if i386_TARGET_ARCH || x86_64_TARGET_ARCH import X86.CodeGen import X86.Regs import X86.Instr @@@ -58,7 -64,7 +58,7 @@@ import NCGMona import BlockId import CgUtils ( fixStgRegisters ) import OldCmm -import CmmOpt ( cmmMiniInline, cmmMachOpFold ) +import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold ) import OldPprCmm import CLabel @@@ -86,6 -92,7 +86,6 @@@ import Data.Lis import Data.Maybe import Control.Monad import System.IO -import Distribution.System {- The native-code generator has machine-independent and @@@ -371,48 -378,37 +371,48 @@@ cmmNativeGen dflags us cmm coun , Nothing , mPprStats) + ---- x86fp_kludge. This pass inserts ffree instructions to clear + ---- the FPU stack on x86. The x86 ABI requires that the FPU stack + ---- is clear, and library functions can return odd results if it + ---- isn't. + ---- + ---- NB. must happen before shortcutBranches, because that + ---- generates JXX_GBLs which we can't fix up in x86fp_kludge. + let kludged = +#if i386_TARGET_ARCH + {-# SCC "x86fp_kludge" #-} + map x86fp_kludge alloced +#else + alloced +#endif + + ---- generate jump tables + let tabled = + {-# SCC "generateJumpTables" #-} + generateJumpTables kludged + ---- shortcut branches let shorted = {-# SCC "shortcutBranches" #-} - shortcutBranches dflags alloced + shortcutBranches dflags tabled ---- sequence blocks let sequenced = {-# SCC "sequenceBlocks" #-} map sequenceTop shorted - ---- x86fp_kludge - let kludged = -#if i386_TARGET_ARCH - {-# SCC "x86fp_kludge" #-} - map x86fp_kludge sequenced -#else - sequenced -#endif - - ---- expansion of SPARC synthetic instrs + ---- expansion of SPARC synthetic instrs #if sparc_TARGET_ARCH let expanded = {-# SCC "sparc_expand" #-} - map expandTop kludged + map expandTop sequenced dumpIfSet_dyn dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" (vcat $ map (docToSDoc . pprNatCmmTop) expanded) #else let expanded = - kludged + sequenced #endif return ( usAlloc @@@ -484,7 -480,7 +484,7 @@@ makeImportsDoc dflags import | otherwise = Pretty.empty - doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle) + doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle) astyle = mkCodeStyle AsmStyle @@@ -613,18 -609,6 +613,18 @@@ makeFarBranches = i #endif -- ----------------------------------------------------------------------------- +-- Generate jump tables + +-- Analyzes all native code and generates data sections for all jump +-- table instructions. +generateJumpTables + :: [NatCmmTop Instr] -> [NatCmmTop Instr] +generateJumpTables xs = concatMap f xs + where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs + f p = [p] + g (BasicBlock _ xs) = catMaybes (map generateJumpTableForInstr xs) + +-- ----------------------------------------------------------------------------- -- Shortcut branches shortcutBranches @@@ -734,9 -718,10 +734,9 @@@ Here we do and position independent refs (ii) compile a list of imported symbols -Ideas for other things we could do (ToDo): +Ideas for other things we could do: - shortcut jumps-to-jumps - - eliminate dead code blocks - simple CSE: if an expr is assigned to a temp, then replace later occs of that expr with the temp, until the expr is no longer valid (can push through temp assignments, and certain assigns to mem...) @@@ -745,7 -730,7 +745,7 @@@ cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do - blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) + blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks)) return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) @@@ -822,10 -807,8 +822,10 @@@ cmmStmtConFold stm cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr -cmmExprConFold referenceKind expr - = case expr of +cmmExprConFold referenceKind expr = do + dflags <- getDynFlagsCmmOpt + let arch = platformArch (targetPlatform dflags) + case expr of CmmLoad addr rep -> do addr' <- cmmExprConFold DataReference addr return $ CmmLoad addr' rep @@@ -838,9 -821,11 +838,9 @@@ CmmLit (CmmLabel lbl) -> do cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl CmmLit (CmmLabelOff lbl off) -> do - dflags <- getDynFlagsCmmOpt dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl return $ cmmMachOpFold (MO_Add wordWidth) [ dynRef, @@@ -851,15 -836,15 +851,15 @@@ -- to use the register table, so we replace these registers -- with the corresponding labels: CmmReg (CmmGlobal EagerBlackholeInfo) - | cTargetArch == PPC && not opt_PIC + | arch == ArchPPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) - | cTargetArch == PPC && not opt_PIC + | arch == ArchPPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) - | cTargetArch == PPC && not opt_PIC + | arch == ArchPPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) diff --combined compiler/typecheck/TcRnMonad.lhs index 826c09b,f105e62..bd48872 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@@ -781,6 -781,11 +781,6 @@@ updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> env { tcl_ctxt = upd ctxt }) --- Conditionally add an error context -maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a -maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside -maybeAddErrCtxt Nothing thing_inside = thing_inside - popErrCtxt :: TcM a -> TcM a popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) @@@ -1147,7 -1152,7 +1147,7 @@@ failIfM :: Message -> IfL failIfM msg = do { env <- getLclEnv ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; liftIO (printErrs (full_msg defaultErrStyle)) + ; liftIO (printErrs full_msg defaultErrStyle) ; failM } -------------------- @@@ -1182,7 -1187,7 +1182,7 @@@ forkM_maybe doc thing_insid ; return Nothing } }} where - print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle)) + print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle) forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside diff --combined compiler/utils/Outputable.lhs index c4a685b,a2779a2..fc4d919 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@@ -15,7 -15,7 +15,7 @@@ module Outputable Outputable(..), OutputableBndr(..), -- * Pretty printing combinators - SDoc, + SDoc, runSDoc, initSDocContext, docToSDoc, interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, empty, nest, @@@ -33,6 -33,9 +33,9 @@@ hang, punctuate, ppWhen, ppUnless, speakNth, speakNTimes, speakN, speakNOf, plural, + coloured, PprColour, colType, colCoerc, colDataCon, + colBinder, bold, keyword, + -- * Converting 'SDoc' into strings and outputing it printSDoc, printErrs, printOutput, hPrintDump, printDump, printForC, printForAsm, printForUser, printForUserPartWay, @@@ -41,6 -44,7 +44,7 @@@ showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, showPpr, showSDocUnqual, showsPrecSDoc, + renderWithStyle, pprInfixVar, pprPrefixVar, pprHsChar, pprHsString, pprHsInfix, pprHsVar, @@@ -60,7 -64,7 +64,7 @@@ -- * Error handling and debugging utilities pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, - pprTrace, warnPprTrace, + pprTrace, pprDefiniteTrace, warnPprTrace, trace, pgmError, panic, sorry, panicFastInt, assertPanic ) where @@@ -218,38 -222,56 +222,56 @@@ code (either C or assembly), or generat %************************************************************************ \begin{code} - type SDoc = PprStyle -> Doc + newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } + + data SDocContext = SDC + { sdocStyle :: !PprStyle + , sdocLastColour :: !PprColour + -- ^ The most recently used colour. This allows nesting colours. + } + + initSDocContext :: PprStyle -> SDocContext + initSDocContext sty = SDC + { sdocStyle = sty + , sdocLastColour = colReset + } withPprStyle :: PprStyle -> SDoc -> SDoc - withPprStyle sty d _sty' = d sty + withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} withPprStyleDoc :: PprStyle -> SDoc -> Doc - withPprStyleDoc sty d = d sty + withPprStyleDoc sty d = runSDoc d (initSDocContext sty) pprDeeper :: SDoc -> SDoc - pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..." - pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1))) - pprDeeper d other_sty = d other_sty + pprDeeper d = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..." + SDC{sdocStyle=PprUser q (PartWay n)} -> + runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))} + _ -> runSDoc d ctx pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc -- Truncate a list that list that is longer than the current depth - pprDeeperList f ds (PprUser q (PartWay n)) - | n==0 = Pretty.text "..." - | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1))) - where - go _ [] = [] - go i (d:ds) | i >= n = [text "...."] - | otherwise = d : go (i+1) ds - - pprDeeperList f ds other_sty - = f ds other_sty + pprDeeperList f ds = SDoc work + where + work ctx@SDC{sdocStyle=PprUser q (PartWay n)} + | n==0 = Pretty.text "..." + | otherwise = + runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))} + where + go _ [] = [] + go i (d:ds) | i >= n = [text "...."] + | otherwise = d : go (i+1) ds + work other_ctx = runSDoc (f ds) other_ctx pprSetDepth :: Depth -> SDoc -> SDoc - pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth) - pprSetDepth _depth doc other_sty = doc other_sty + pprSetDepth depth doc = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprUser q _} -> + runSDoc doc ctx{sdocStyle = PprUser q depth} + _ -> + runSDoc doc ctx getPprStyle :: (PprStyle -> SDoc) -> SDoc - getPprStyle df sty = df sty sty + getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx \end{code} \begin{code} @@@ -282,22 -304,24 +304,24 @@@ userStyle (PprUser _ _) = Tru userStyle _other = False ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style - ifPprDebug d sty@PprDebug = d sty - ifPprDebug _ _ = Pretty.empty + ifPprDebug d = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprDebug} -> runSDoc d ctx + _ -> Pretty.empty \end{code} \begin{code} -- Unused [7/02 sof] printSDoc :: SDoc -> PprStyle -> IO () printSDoc d sty = do - Pretty.printDoc PageMode stdout (d sty) + Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty)) hFlush stdout -- I'm not sure whether the direct-IO approach of Pretty.printDoc -- above is better or worse than the put-big-string approach here - printErrs :: Doc -> IO () - printErrs doc = do Pretty.printDoc PageMode stderr doc - hFlush stderr + printErrs :: SDoc -> PprStyle -> IO () + printErrs doc sty = do + Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext sty)) + hFlush stderr printOutput :: Doc -> IO () printOutput doc = Pretty.printDoc PageMode stdout doc @@@ -307,25 -331,32 +331,32 @@@ printDump doc = hPrintDump stdout do hPrintDump :: Handle -> SDoc -> IO () hPrintDump h doc = do - Pretty.printDoc PageMode h (better_doc defaultDumpStyle) + Pretty.printDoc PageMode h + (runSDoc better_doc (initSDocContext defaultDumpStyle)) hFlush h where better_doc = doc $$ blankLine printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () printForUser handle unqual doc - = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay)) + = Pretty.printDoc PageMode handle + (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO () printForUserPartWay handle d unqual doc - = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d))) + = Pretty.printDoc PageMode handle + (runSDoc doc (initSDocContext (mkUserStyle unqual (PartWay d)))) -- printForC, printForAsm do what they sound like printForC :: Handle -> SDoc -> IO () - printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle)) + printForC handle doc = + Pretty.printDoc LeftMode handle + (runSDoc doc (initSDocContext (PprCode CStyle))) printForAsm :: Handle -> SDoc -> IO () - printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle)) + printForAsm handle doc = + Pretty.printDoc LeftMode handle + (runSDoc doc (initSDocContext (PprCode AsmStyle))) pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d @@@ -337,32 -368,44 +368,44 @@@ mkCodeStyle = PprCod -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string showSDoc :: SDoc -> String - showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle) + showSDoc d = + Pretty.showDocWith PageMode + (runSDoc d (initSDocContext defaultUserStyle)) + + renderWithStyle :: SDoc -> PprStyle -> String + renderWithStyle sdoc sty = + Pretty.render (runSDoc sdoc (initSDocContext sty)) -- This shows an SDoc, but on one line only. It's cheaper than a full -- showSDoc, designed for when we're getting results like "Foo.bar" -- and "foo{uniq strictness}" so we don't want fancy layout anyway. showSDocOneLine :: SDoc -> String - showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle) + showSDocOneLine d = + Pretty.showDocWith PageMode + (runSDoc d (initSDocContext defaultUserStyle)) showSDocForUser :: PrintUnqualified -> SDoc -> String - showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay)) + showSDocForUser unqual doc = + show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) showSDocUnqual :: SDoc -> String -- Only used in the gruesome isOperator - showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) + showSDocUnqual d = + show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay))) showsPrecSDoc :: Int -> SDoc -> ShowS - showsPrecSDoc p d = showsPrec p (d defaultUserStyle) + showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle)) showSDocDump :: SDoc -> String - showSDocDump d = Pretty.showDocWith PageMode (d PprDump) + showSDocDump d = + Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump)) showSDocDumpOneLine :: SDoc -> String - showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump) + showSDocDumpOneLine d = + Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump)) showSDocDebug :: SDoc -> String - showSDocDebug d = show (d PprDebug) + showSDocDebug d = show (runSDoc d (initSDocContext PprDebug)) showPpr :: Outputable a => a -> String showPpr = showSDoc . ppr @@@ -370,7 -413,7 +413,7 @@@ \begin{code} docToSDoc :: Doc -> SDoc - docToSDoc d = \_ -> d + docToSDoc d = SDoc (\_ -> d) empty :: SDoc char :: Char -> SDoc @@@ -383,58 -426,58 +426,58 @@@ float :: Float -> SDo double :: Double -> SDoc rational :: Rational -> SDoc - empty _sty = Pretty.empty - char c _sty = Pretty.char c - text s _sty = Pretty.text s - ftext s _sty = Pretty.ftext s - ptext s _sty = Pretty.ptext s - int n _sty = Pretty.int n - integer n _sty = Pretty.integer n - float n _sty = Pretty.float n - double n _sty = Pretty.double n - rational n _sty = Pretty.rational n + empty = docToSDoc $ Pretty.empty + char c = docToSDoc $ Pretty.char c + text s = docToSDoc $ Pretty.text s + ftext s = docToSDoc $ Pretty.ftext s + ptext s = docToSDoc $ Pretty.ptext s + int n = docToSDoc $ Pretty.int n + integer n = docToSDoc $ Pretty.integer n + float n = docToSDoc $ Pretty.float n + double n = docToSDoc $ Pretty.double n + rational n = docToSDoc $ Pretty.rational n parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc - parens d sty = Pretty.parens (d sty) - braces d sty = Pretty.braces (d sty) - brackets d sty = Pretty.brackets (d sty) - doubleQuotes d sty = Pretty.doubleQuotes (d sty) - angleBrackets d = char '<' <> d <> char '>' + parens d = SDoc $ Pretty.parens . runSDoc d + braces d = SDoc $ Pretty.braces . runSDoc d + brackets d = SDoc $ Pretty.brackets . runSDoc d + doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d + angleBrackets d = char '<' <> d <> char '>' cparen :: Bool -> SDoc -> SDoc - cparen b d sty = Pretty.cparen b (d sty) + cparen b d = SDoc $ Pretty.cparen b . runSDoc d -- quotes encloses something in single quotes... -- but it omits them if the thing ends in a single quote -- so that we don't get `foo''. Instead we just have foo'. - quotes d sty = case show pp_d of - ('\'' : _) -> pp_d - _other -> Pretty.quotes pp_d - where - pp_d = d sty + quotes d = SDoc $ \sty -> + let pp_d = runSDoc d sty in + case show pp_d of + ('\'' : _) -> pp_d + _other -> Pretty.quotes pp_d semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc - blankLine _sty = Pretty.ptext (sLit "") - dcolon _sty = Pretty.ptext (sLit "::") - arrow _sty = Pretty.ptext (sLit "->") - darrow _sty = Pretty.ptext (sLit "=>") - semi _sty = Pretty.semi - comma _sty = Pretty.comma - colon _sty = Pretty.colon - equals _sty = Pretty.equals - space _sty = Pretty.space - underscore = char '_' - dot = char '.' - lparen _sty = Pretty.lparen - rparen _sty = Pretty.rparen - lbrack _sty = Pretty.lbrack - rbrack _sty = Pretty.rbrack - lbrace _sty = Pretty.lbrace - rbrace _sty = Pretty.rbrace + blankLine = docToSDoc $ Pretty.ptext (sLit "") + dcolon = docToSDoc $ Pretty.ptext (sLit "::") + arrow = docToSDoc $ Pretty.ptext (sLit "->") + darrow = docToSDoc $ Pretty.ptext (sLit "=>") + semi = docToSDoc $ Pretty.semi + comma = docToSDoc $ Pretty.comma + colon = docToSDoc $ Pretty.colon + equals = docToSDoc $ Pretty.equals + space = docToSDoc $ Pretty.space + underscore = char '_' + dot = char '.' + lparen = docToSDoc $ Pretty.lparen + rparen = docToSDoc $ Pretty.rparen + lbrack = docToSDoc $ Pretty.lbrack + rbrack = docToSDoc $ Pretty.rbrack + lbrace = docToSDoc $ Pretty.lbrace + rbrace = docToSDoc $ Pretty.rbrace nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount @@@ -448,11 -491,11 +491,11 @@@ ($+$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically - nest n d sty = Pretty.nest n (d sty) - (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty) - (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty) - ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty) - ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty) + nest n d = SDoc $ Pretty.nest n . runSDoc d + (<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) + (<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) + ($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) + ($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) hcat :: [SDoc] -> SDoc -- ^ Concatenate 'SDoc' horizontally @@@ -471,19 -514,19 +514,19 @@@ fcat :: [SDoc] -> SDo -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' - hcat ds sty = Pretty.hcat [d sty | d <- ds] - hsep ds sty = Pretty.hsep [d sty | d <- ds] - vcat ds sty = Pretty.vcat [d sty | d <- ds] - sep ds sty = Pretty.sep [d sty | d <- ds] - cat ds sty = Pretty.cat [d sty | d <- ds] - fsep ds sty = Pretty.fsep [d sty | d <- ds] - fcat ds sty = Pretty.fcat [d sty | d <- ds] + hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] + hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] + vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] + sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] + cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] + fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] + fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] hang :: SDoc -- ^ The header -> Int -- ^ Amount to indent the hung body -> SDoc -- ^ The hung body, indented and placed below the header -> SDoc - hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty) + hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) punctuate :: SDoc -- ^ The punctuation -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements @@@ -500,6 -543,46 +543,46 @@@ ppWhen False _ = empt ppUnless True _ = empty ppUnless False doc = doc + + -- | A colour\/style for use with 'coloured'. + newtype PprColour = PprColour String + + -- Colours + + colType :: PprColour + colType = PprColour "\27[34m" + + colBold :: PprColour + colBold = PprColour "\27[;1m" + + colCoerc :: PprColour + colCoerc = PprColour "\27[34m" + + colDataCon :: PprColour + colDataCon = PprColour "\27[31m" + + colBinder :: PprColour + colBinder = PprColour "\27[32m" + + colReset :: PprColour + colReset = PprColour "\27[0m" + + -- | Apply the given colour\/style for the argument. + -- + -- Only takes effect if colours are enabled. + coloured :: PprColour -> SDoc -> SDoc + -- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt + coloured col@(PprColour c) sdoc = + SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } -> + let ctx' = ctx{ sdocLastColour = col } in + Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc + + bold :: SDoc -> SDoc + bold = coloured colBold + + keyword :: SDoc -> SDoc + keyword = bold + \end{code} @@@ -800,27 -883,26 +883,29 @@@ pprTrace str doc | opt_NoDebugOutput = x | otherwise = pprAndThen trace str doc x +pprDefiniteTrace :: String -> SDoc -> a -> a +-- ^ Same as pprTrace, but show even if -dno-debug-output is on +pprDefiniteTrace str doc x = pprAndThen trace str doc x pprPanicFastInt :: String -> SDoc -> FastInt -- ^ Specialization of pprPanic that can be safely used with 'FastInt' - pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug)) - where - doc = text heading <+> pretty_msg + pprPanicFastInt heading pretty_msg = + panicFastInt (show (runSDoc doc (initSDocContext PprDebug))) + where + doc = text heading <+> pretty_msg pprAndThen :: (String -> a) -> String -> SDoc -> a - pprAndThen cont heading pretty_msg = cont (show (doc PprDebug)) - where + pprAndThen cont heading pretty_msg = + cont (show (runSDoc doc (initSDocContext PprDebug))) + where doc = sep [text heading, nest 4 pretty_msg] assertPprPanic :: String -> Int -> SDoc -> a -- ^ Panic with an assertation failure, recording the given file and line number. -- Should typically be accessed with the ASSERT family of macros assertPprPanic file line msg - = panic (show (doc PprDebug)) + = panic (show (runSDoc doc (initSDocContext PprDebug))) where doc = sep [hsep[text "ASSERT failed! file", text file, @@@ -833,7 -915,7 +918,7 @@@ warnPprTrace :: Bool -> String -> Int - warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = trace (show (doc defaultDumpStyle)) x + = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x where doc = sep [hsep [text "WARNING: file", text file, text "line", int line], msg]